Home

Context Navigation

radiation_model_mod.f90 @ 4245

Last change on this file since 4245 was 4245, checked in by pavelkrc, 6 years ago

Merge branch resler into trunk

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-4244
/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: 545.4 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-2019 Institute of Computer Science of the
18	! Czech Academy of Sciences, Prague
19	! Copyright 2015-2019 Czech Technical University in Prague
20	! Copyright 1997-2019 Leibniz Universitaet Hannover
21	!------------------------------------------------------------------------------!
22	!
23	! Current revisions:
24	! ------------------
25	!
26	!
27	! Former revisions:
28	! -----------------
29	! $Id: radiation_model_mod.f90 4245 2019-09-30 08:40:37Z pavelkrc $
30	! Initialize explicit per-surface albedos from building_surface_pars
31	!
32	! 4238 2019-09-25 16:06:01Z suehring
33	! Modify check in order to avoid equality comparisons of floating points
34	!
35	! 4227 2019-09-10 18:04:34Z gronemeier
36	! implement new palm_date_time_mod
37	!
38	! 4226 2019-09-10 17:03:24Z suehring
39	! - Netcdf input routine for dimension length renamed
40	! - Define time variable for external radiation input relative to time_utc_init
41	!
42	! 4210 2019-09-02 13:07:09Z suehring
43	! - Revise steering of splitting diffuse and direct radiation
44	! - Bugfixes in checks
45	! - Optimize mapping of radiation components onto 2D arrays, avoid unnecessary
46	! operations
47	!
48	! 4208 2019-09-02 09:01:07Z suehring
49	! Bugfix in accessing albedo_pars in the clear-sky branch
50	! (merge from branch resler)
51	!
52	! 4198 2019-08-29 15:17:48Z gronemeier
53	! Prohibit execution of radiation model if rotation_angle is not zero
54	!
55	! 4197 2019-08-29 14:33:32Z suehring
56	! Revise steering of surface albedo initialization when albedo_pars is provided
57	!
58	! 4190 2019-08-27 15:42:37Z suehring
59	! Implement external radiation forcing also for level-of-detail = 2
60	! (horizontally 2D radiation)
61	!
62	! 4188 2019-08-26 14:15:47Z suehring
63	! Minor adjustment in error message
64	!
65	! 4187 2019-08-26 12:43:15Z suehring
66	! - Take external radiation from root domain dynamic input if not provided for
67	! each nested domain
68	! - Combine MPI_ALLREDUCE calls to reduce mpi overhead
69	!
70	! 4182 2019-08-22 15:20:23Z scharf
71	! Corrected "Former revisions" section
72	!
73	! 4179 2019-08-21 11:16:12Z suehring
74	! Remove debug prints
75	!
76	! 4178 2019-08-21 11:13:06Z suehring
77	! External radiation forcing implemented.
78	!
79	! 4168 2019-08-16 13:50:17Z suehring
80	! Replace function get_topography_top_index by topo_top_ind
81	!
82	! 4157 2019-08-14 09:19:12Z suehring
83	! Give informative message on raytracing distance only by core zero
84	!
85	! 4148 2019-08-08 11:26:00Z suehring
86	! Comments added
87	!
88	! 4134 2019-08-02 18:39:57Z suehring
89	! Bugfix in formatted write statement
90	!
91	! 4127 2019-07-30 14:47:10Z suehring
92	! Remove unused pch_index (merge from branch resler)
93	!
94	! 4089 2019-07-11 14:30:27Z suehring
95	! - Correct level 2 initialization of spectral albedos in rrtmg branch, long- and
96	! shortwave albedos were mixed-up.
97	! - Change order of albedo_pars so that it is now consistent with the defined
98	! order of albedo_pars in PIDS
99	!
100	! 4069 2019-07-01 14:05:51Z Giersch
101	! Masked output running index mid has been introduced as a local variable to
102	! avoid runtime error (Loop variable has been modified) in time_integration
103	!
104	! 4067 2019-07-01 13:29:25Z suehring
105	! Bugfix, pass dummy string to MPI_INFO_SET (J. Resler)
106	!
107	! 4039 2019-06-18 10:32:41Z suehring
108	! Bugfix for masked data output
109	!
110	! 4008 2019-05-30 09:50:11Z moh.hefny
111	! Bugfix in check variable when a variable's string is less than 3
112	! characters is processed. All variables now are checked if they
113	! belong to radiation
114	!
115	! 3992 2019-05-22 16:49:38Z suehring
116	! Bugfix in rrtmg radiation branch in a nested run when the lowest prognistic
117	! grid points in a child domain are all inside topography
118	!
119	! 3987 2019-05-22 09:52:13Z kanani
120	! Introduce alternative switch for debug output during timestepping
121	!
122	! 3943 2019-05-02 09:50:41Z maronga
123	! Missing blank characteer added.
124	!
125	! 3900 2019-04-16 15:17:43Z suehring
126	! Fixed initialization problem
127	!
128	! 3885 2019-04-11 11:29:34Z kanani
129	! Changes related to global restructuring of location messages and introduction
130	! of additional debug messages
131	!
132	! 3881 2019-04-10 09:31:22Z suehring
133	! Output of albedo and emissivity moved from USM, bugfixes in initialization
134	! of albedo
135	!
136	! 3861 2019-04-04 06:27:41Z maronga
137	! Bugfix: factor of 4.0 required instead of 3.0 in calculation of rad_lw_out_change_0
138	!
139	! 3859 2019-04-03 20:30:31Z maronga
140	! Added some descriptions
141	!
142	! 3847 2019-04-01 14:51:44Z suehring
143	! Implement check for dt_radiation (must be > 0)
144	!
145	! 3846 2019-04-01 13:55:30Z suehring
146	! unused variable removed
147	!
148	! 3814 2019-03-26 08:40:31Z pavelkrc
149	! Change zenith(0:0) and others to scalar.
150	! Code review.
151	! Rename exported nzu, nzp and related variables due to name conflict
152	!
153	! 3771 2019-02-28 12:19:33Z raasch
154	! rrtmg preprocessor for directives moved/added, save attribute added to temporary
155	! pointers to avoid compiler warnings about outlived pointer targets,
156	! statement added to avoid compiler warning about unused variable
157	!
158	! 3769 2019-02-28 10:16:49Z moh.hefny
159	! removed unused variables and subroutine radiation_radflux_gridbox
160	!
161	! 3767 2019-02-27 08:18:02Z raasch
162	! unused variable for file index removed from rrd-subroutines parameter list
163	!
164	! 3760 2019-02-21 18:47:35Z moh.hefny
165	! Bugfix: initialized simulated_time before calculating solar position
166	! to enable restart option with reading in SVF from file(s).
167	!
168	! 3754 2019-02-19 17:02:26Z kanani
169	! (resler, pavelkrc)
170	! Bugfixes: add further required MRT factors to read/write_svf,
171	! fix for aggregating view factors to eliminate local noise in reflected
172	! irradiance at mutually close surfaces (corners, presence of trees) in the
173	! angular discretization scheme.
174	!
175	! 3752 2019-02-19 09:37:22Z resler
176	! added read/write number of MRT factors to the respective routines
177	!
178	! 3705 2019-01-29 19:56:39Z suehring
179	! Make variables that are sampled in virtual measurement module public
180	!
181	! 3704 2019-01-29 19:51:41Z suehring
182	! Some interface calls moved to module_interface + cleanup
183	!
184	! 3667 2019-01-10 14:26:24Z schwenkel
185	! Modified check for rrtmg input files
186	!
187	! 3655 2019-01-07 16:51:22Z knoop
188	! nopointer option removed
189	!
190	! 1496 2014-12-02 17:25:50Z maronga
191	! Initial revision
192	!
193	!
194	! Description:
195	! ------------
196	!> Radiation models and interfaces
197	!> @todo Replace dz(1) appropriatly to account for grid stretching
198	!> @todo move variable definitions used in radiation_init only to the subroutine
199	!> as they are no longer required after initialization.
200	!> @todo Output of full column vertical profiles used in RRTMG
201	!> @todo Output of other rrtm arrays (such as volume mixing ratios)
202	!> @todo Check for mis-used NINT() calls in raytrace_2d
203	!> RESULT: Original was correct (carefully verified formula), the change
204	!> to INT broke raytracing -- P. Krc
205	!> @todo Optimize radiation_tendency routines
206	!> @todo Consider rotated model domains (rotation_angle/=0.0)
207	!>
208	!> @note Many variables have a leading dummy dimension (0:0) in order to
209	!> match the assume-size shape expected by the RRTMG model.
210	!------------------------------------------------------------------------------!
211	MODULE radiation_model_mod
212
213	USE arrays_3d, &
214	ONLY: dzw, hyp, nc, pt, p, q, ql, u, v, w, zu, zw, exner, d_exner
215
216	USE basic_constants_and_equations_mod, &
217	ONLY: c_p, g, lv_d_cp, l_v, pi, r_d, rho_l, solar_constant, sigma_sb, &
218	barometric_formula
219
220	USE calc_mean_profile_mod, &
221	ONLY: calc_mean_profile
222
223	USE control_parameters, &
224	ONLY: cloud_droplets, coupling_char, &
225	debug_output, debug_output_timestep, debug_string, &
226	dt_3d, &
227	dz, dt_spinup, end_time, &
228	humidity, &
229	initializing_actions, io_blocks, io_group, &
230	land_surface, large_scale_forcing, &
231	latitude, longitude, lsf_surf, &
232	message_string, plant_canopy, pt_surface, &
233	rho_surface, simulated_time, spinup_time, surface_pressure, &
234	read_svf, write_svf, &
235	time_since_reference_point, urban_surface, varnamelength
236
237	USE cpulog, &
238	ONLY: cpu_log, log_point, log_point_s
239
240	USE grid_variables, &
241	ONLY: ddx, ddy, dx, dy
242
243	USE indices, &
244	ONLY: nnx, nny, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, &
245	nzb, nzt, topo_top_ind
246
247	USE, INTRINSIC :: iso_c_binding
248
249	USE kinds
250
251	USE bulk_cloud_model_mod, &
252	ONLY: bulk_cloud_model, microphysics_morrison, na_init, nc_const, sigma_gc
253
254	#if defined ( __netcdf )
255	USE NETCDF
256	#endif
257
258	USE netcdf_data_input_mod, &
259	ONLY: albedo_type_f, &
260	albedo_pars_f, &
261	building_type_f, &
262	building_surface_pars_f, &
263	pavement_type_f, &
264	vegetation_type_f, &
265	water_type_f, &
266	char_fill, &
267	char_lod, &
268	check_existence, &
269	close_input_file, &
270	get_attribute, &
271	get_dimension_length, &
272	get_variable, &
273	inquire_num_variables, &
274	inquire_variable_names, &
275	input_file_dynamic, &
276	input_pids_dynamic, &
277	num_var_pids, &
278	pids_id, &
279	open_read_file, &
280	real_1d_3d, &
281	vars_pids
282
283	USE palm_date_time_mod, &
284	ONLY: date_time_str_len, get_date_time, &
285	hours_per_day, seconds_per_hour
286
287	USE plant_canopy_model_mod, &
288	ONLY: lad_s, pc_heating_rate, pc_transpiration_rate, pc_latent_rate, &
289	plant_canopy_transpiration, pcm_calc_transpiration_rate
290
291	USE pegrid
292
293	#if defined ( __rrtmg )
294	USE parrrsw, &
295	ONLY: naerec, nbndsw
296
297	USE parrrtm, &
298	ONLY: nbndlw
299
300	USE rrtmg_lw_init, &
301	ONLY: rrtmg_lw_ini
302
303	USE rrtmg_sw_init, &
304	ONLY: rrtmg_sw_ini
305
306	USE rrtmg_lw_rad, &
307	ONLY: rrtmg_lw
308
309	USE rrtmg_sw_rad, &
310	ONLY: rrtmg_sw
311	#endif
312	USE statistics, &
313	ONLY: hom
314
315	USE surface_mod, &
316	ONLY: ind_pav_green, ind_veg_wall, ind_wat_win, &
317	surf_lsm_h, surf_lsm_v, surf_type, surf_usm_h, surf_usm_v, &
318	vertical_surfaces_exist
319
320	IMPLICIT NONE
321
322	CHARACTER(10) :: radiation_scheme = 'clear-sky' ! 'constant', 'clear-sky', or 'rrtmg'
323
324	!
325	!-- Predefined Land surface classes (albedo_type) after Briegleb (1992)
326	CHARACTER(37), DIMENSION(0:33), PARAMETER :: albedo_type_name = (/ &
327	'user defined ', & ! 0
328	'ocean ', & ! 1
329	'mixed farming, tall grassland ', & ! 2
330	'tall/medium grassland ', & ! 3
331	'evergreen shrubland ', & ! 4
332	'short grassland/meadow/shrubland ', & ! 5
333	'evergreen needleleaf forest ', & ! 6
334	'mixed deciduous evergreen forest ', & ! 7
335	'deciduous forest ', & ! 8
336	'tropical evergreen broadleaved forest', & ! 9
337	'medium/tall grassland/woodland ', & ! 10
338	'desert, sandy ', & ! 11
339	'desert, rocky ', & ! 12
340	'tundra ', & ! 13
341	'land ice ', & ! 14
342	'sea ice ', & ! 15
343	'snow ', & ! 16
344	'bare soil ', & ! 17
345	'asphalt/concrete mix ', & ! 18
346	'asphalt (asphalt concrete) ', & ! 19
347	'concrete (Portland concrete) ', & ! 20
348	'sett ', & ! 21
349	'paving stones ', & ! 22
350	'cobblestone ', & ! 23
351	'metal ', & ! 24
352	'wood ', & ! 25
353	'gravel ', & ! 26
354	'fine gravel ', & ! 27
355	'pebblestone ', & ! 28
356	'woodchips ', & ! 29
357	'tartan (sports) ', & ! 30
358	'artifical turf (sports) ', & ! 31
359	'clay (sports) ', & ! 32
360	'building (dummy) ' & ! 33
361	/)
362	!
363	!-- Indices of radiation-related input attributes in building_surface_pars
364	!-- (other are in urban_surface_mod)
365	INTEGER(iwp) :: ind_s_alb_b_wall = 19 !< index for Broadband albedo of wall fraction
366	INTEGER(iwp) :: ind_s_alb_l_wall = 20 !< index for Longwave albedo of wall fraction
367	INTEGER(iwp) :: ind_s_alb_s_wall = 21 !< index for Shortwave albedo of wall fraction
368	INTEGER(iwp) :: ind_s_alb_b_win = 22 !< index for Broadband albedo of window fraction
369	INTEGER(iwp) :: ind_s_alb_l_win = 23 !< index for Longwave albedo of window fraction
370	INTEGER(iwp) :: ind_s_alb_s_win = 24 !< index for Shortwave albedo of window fraction
371	INTEGER(iwp) :: ind_s_alb_b_green = 24 !< index for Broadband albedo of green fraction
372	INTEGER(iwp) :: ind_s_alb_l_green = 25 !< index for Longwave albedo of green fraction
373	INTEGER(iwp) :: ind_s_alb_s_green = 26 !< index for Shortwave albedo of green fraction
374
375	INTEGER(iwp) :: albedo_type = 9999999_iwp, & !< Albedo surface type
376	dots_rad = 0_iwp !< starting index for timeseries output
377
378	LOGICAL :: unscheduled_radiation_calls = .TRUE., & !< flag parameter indicating whether additional calls of the radiation code are allowed
379	constant_albedo = .FALSE., & !< flag parameter indicating whether the albedo may change depending on zenith
380	force_radiation_call = .FALSE., & !< flag parameter for unscheduled radiation calls
381	lw_radiation = .TRUE., & !< flag parameter indicating whether longwave radiation shall be calculated
382	radiation = .FALSE., & !< flag parameter indicating whether the radiation model is used
383	sun_up = .TRUE., & !< flag parameter indicating whether the sun is up or down
384	sw_radiation = .TRUE., & !< flag parameter indicating whether shortwave radiation shall be calculated
385	sun_direction = .FALSE., & !< flag parameter indicating whether solar direction shall be calculated
386	average_radiation = .FALSE., & !< flag to set the calculation of radiation averaging for the domain
387	radiation_interactions = .FALSE., & !< flag to activiate RTM (TRUE only if vertical urban/land surface and trees exist)
388	surface_reflections = .TRUE., & !< flag to switch the calculation of radiation interaction between surfaces.
389	!< When it switched off, only the effect of buildings and trees shadow
390	!< will be considered. However fewer SVFs are expected.
391	radiation_interactions_on = .TRUE. !< namelist flag to force RTM activiation regardless to vertical urban/land surface and trees
392
393	REAL(wp) :: albedo = 9999999.9_wp, & !< NAMELIST alpha
394	albedo_lw_dif = 9999999.9_wp, & !< NAMELIST aldif
395	albedo_lw_dir = 9999999.9_wp, & !< NAMELIST aldir
396	albedo_sw_dif = 9999999.9_wp, & !< NAMELIST asdif
397	albedo_sw_dir = 9999999.9_wp, & !< NAMELIST asdir
398	decl_1, & !< declination coef. 1
399	decl_2, & !< declination coef. 2
400	decl_3, & !< declination coef. 3
401	dt_radiation = 0.0_wp, & !< radiation model timestep
402	emissivity = 9999999.9_wp, & !< NAMELIST surface emissivity
403	lon = 0.0_wp, & !< longitude in radians
404	lat = 0.0_wp, & !< latitude in radians
405	net_radiation = 0.0_wp, & !< net radiation at surface
406	skip_time_do_radiation = 0.0_wp, & !< Radiation model is not called before this time
407	sky_trans, & !< sky transmissivity
408	time_radiation = 0.0_wp !< time since last call of radiation code
409
410	INTEGER(iwp) :: day_of_year !< day of the current year
411
412	REAL(wp) :: cos_zenith !< cosine of solar zenith angle, also z-coordinate of solar unit vector
413	REAL(wp) :: d_hours_day !< 1 / hours-per-day
414	REAL(wp) :: d_seconds_hour !< 1 / seconds-per-hour
415	REAL(wp) :: second_of_day !< second of the current day
416	REAL(wp) :: sun_dir_lat !< y-coordinate of solar unit vector
417	REAL(wp) :: sun_dir_lon !< x-coordinate of solar unit vector
418
419	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_net_av !< average of net radiation (rad_net) at surface
420	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_xy_av !< average of incoming longwave radiation at surface
421	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_out_xy_av !< average of outgoing longwave radiation at surface
422	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_xy_av !< average of incoming shortwave radiation at surface
423	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_out_xy_av !< average of outgoing shortwave radiation at surface
424
425	REAL(wp), PARAMETER :: emissivity_atm_clsky = 0.8_wp !< emissivity of the clear-sky atmosphere
426	!
427	!-- Land surface albedos for solar zenith angle of 60degree after Briegleb (1992)
428	!-- (broadband, longwave, shortwave ): bb, lw, sw,
429	REAL(wp), DIMENSION(0:2,1:33), PARAMETER :: albedo_pars = RESHAPE( (/&
430	0.06_wp, 0.06_wp, 0.06_wp, & ! 1
431	0.19_wp, 0.28_wp, 0.09_wp, & ! 2
432	0.23_wp, 0.33_wp, 0.11_wp, & ! 3
433	0.23_wp, 0.33_wp, 0.11_wp, & ! 4
434	0.25_wp, 0.34_wp, 0.14_wp, & ! 5
435	0.14_wp, 0.22_wp, 0.06_wp, & ! 6
436	0.17_wp, 0.27_wp, 0.06_wp, & ! 7
437	0.19_wp, 0.31_wp, 0.06_wp, & ! 8
438	0.14_wp, 0.22_wp, 0.06_wp, & ! 9
439	0.18_wp, 0.28_wp, 0.06_wp, & ! 10
440	0.43_wp, 0.51_wp, 0.35_wp, & ! 11
441	0.32_wp, 0.40_wp, 0.24_wp, & ! 12
442	0.19_wp, 0.27_wp, 0.10_wp, & ! 13
443	0.77_wp, 0.65_wp, 0.90_wp, & ! 14
444	0.77_wp, 0.65_wp, 0.90_wp, & ! 15
445	0.82_wp, 0.70_wp, 0.95_wp, & ! 16
446	0.08_wp, 0.08_wp, 0.08_wp, & ! 17
447	0.17_wp, 0.17_wp, 0.17_wp, & ! 18
448	0.17_wp, 0.17_wp, 0.17_wp, & ! 19
449	0.30_wp, 0.30_wp, 0.30_wp, & ! 20
450	0.17_wp, 0.17_wp, 0.17_wp, & ! 21
451	0.17_wp, 0.17_wp, 0.17_wp, & ! 22
452	0.17_wp, 0.17_wp, 0.17_wp, & ! 23
453	0.17_wp, 0.17_wp, 0.17_wp, & ! 24
454	0.17_wp, 0.17_wp, 0.17_wp, & ! 25
455	0.17_wp, 0.17_wp, 0.17_wp, & ! 26
456	0.17_wp, 0.17_wp, 0.17_wp, & ! 27
457	0.17_wp, 0.17_wp, 0.17_wp, & ! 28
458	0.17_wp, 0.17_wp, 0.17_wp, & ! 29
459	0.17_wp, 0.17_wp, 0.17_wp, & ! 30
460	0.17_wp, 0.17_wp, 0.17_wp, & ! 31
461	0.17_wp, 0.17_wp, 0.17_wp, & ! 32
462	0.17_wp, 0.17_wp, 0.17_wp & ! 33
463	/), (/ 3, 33 /) )
464
465	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: &
466	rad_lw_cs_hr, & !< longwave clear sky radiation heating rate (K/s)
467	rad_lw_cs_hr_av, & !< average of rad_lw_cs_hr
468	rad_lw_hr, & !< longwave radiation heating rate (K/s)
469	rad_lw_hr_av, & !< average of rad_sw_hr
470	rad_lw_in, & !< incoming longwave radiation (W/m2)
471	rad_lw_in_av, & !< average of rad_lw_in
472	rad_lw_out, & !< outgoing longwave radiation (W/m2)
473	rad_lw_out_av, & !< average of rad_lw_out
474	rad_sw_cs_hr, & !< shortwave clear sky radiation heating rate (K/s)
475	rad_sw_cs_hr_av, & !< average of rad_sw_cs_hr
476	rad_sw_hr, & !< shortwave radiation heating rate (K/s)
477	rad_sw_hr_av, & !< average of rad_sw_hr
478	rad_sw_in, & !< incoming shortwave radiation (W/m2)
479	rad_sw_in_av, & !< average of rad_sw_in
480	rad_sw_out, & !< outgoing shortwave radiation (W/m2)
481	rad_sw_out_av !< average of rad_sw_out
482
483
484	!
485	!-- Variables and parameters used in RRTMG only
486	#if defined ( __rrtmg )
487	CHARACTER(LEN=12) :: rrtm_input_file = "RAD_SND_DATA" !< name of the NetCDF input file (sounding data)
488
489
490	!
491	!-- Flag parameters to be passed to RRTMG (should not be changed until ice phase in clouds is allowed)
492	INTEGER(iwp), PARAMETER :: rrtm_idrv = 1, & !< flag for longwave upward flux calculation option (0,1)
493	rrtm_inflglw = 2, & !< flag for lw cloud optical properties (0,1,2)
494	rrtm_iceflglw = 0, & !< flag for lw ice particle specifications (0,1,2,3)
495	rrtm_liqflglw = 1, & !< flag for lw liquid droplet specifications
496	rrtm_inflgsw = 2, & !< flag for sw cloud optical properties (0,1,2)
497	rrtm_iceflgsw = 0, & !< flag for sw ice particle specifications (0,1,2,3)
498	rrtm_liqflgsw = 1 !< flag for sw liquid droplet specifications
499
500	!
501	!-- The following variables should be only changed with care, as this will
502	!-- require further setting of some variables, which is currently not
503	!-- implemented (aerosols, ice phase).
504	INTEGER(iwp) :: nzt_rad, & !< upper vertical limit for radiation calculations
505	rrtm_icld = 0, & !< cloud flag (0: clear sky column, 1: cloudy column)
506	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)
507
508	INTEGER(iwp) :: nc_stat !< local variable for storin the result of netCDF calls for error message handling
509
510	LOGICAL :: snd_exists = .FALSE. !< flag parameter to check whether a user-defined input files exists
511	LOGICAL :: sw_exists = .FALSE. !< flag parameter to check whether that required rrtmg sw file exists
512	LOGICAL :: lw_exists = .FALSE. !< flag parameter to check whether that required rrtmg lw file exists
513
514
515	REAL(wp), PARAMETER :: mol_mass_air_d_wv = 1.607793_wp !< molecular weight dry air / water vapor
516
517	REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd, & !< hypostatic pressure from sounding data (hPa)
518	rrtm_tsfc, & !< dummy array for storing surface temperature
519	t_snd !< actual temperature from sounding data (hPa)
520
521	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rrtm_ccl4vmr, & !< CCL4 volume mixing ratio (g/mol)
522	rrtm_cfc11vmr, & !< CFC11 volume mixing ratio (g/mol)
523	rrtm_cfc12vmr, & !< CFC12 volume mixing ratio (g/mol)
524	rrtm_cfc22vmr, & !< CFC22 volume mixing ratio (g/mol)
525	rrtm_ch4vmr, & !< CH4 volume mixing ratio
526	rrtm_cicewp, & !< in-cloud ice water path (g/m2)
527	rrtm_cldfr, & !< cloud fraction (0,1)
528	rrtm_cliqwp, & !< in-cloud liquid water path (g/m2)
529	rrtm_co2vmr, & !< CO2 volume mixing ratio (g/mol)
530	rrtm_emis, & !< surface emissivity (0-1)
531	rrtm_h2ovmr, & !< H2O volume mixing ratio
532	rrtm_n2ovmr, & !< N2O volume mixing ratio
533	rrtm_o2vmr, & !< O2 volume mixing ratio
534	rrtm_o3vmr, & !< O3 volume mixing ratio
535	rrtm_play, & !< pressure layers (hPa, zu-grid)
536	rrtm_plev, & !< pressure layers (hPa, zw-grid)
537	rrtm_reice, & !< cloud ice effective radius (microns)
538	rrtm_reliq, & !< cloud water drop effective radius (microns)
539	rrtm_tlay, & !< actual temperature (K, zu-grid)
540	rrtm_tlev, & !< actual temperature (K, zw-grid)
541	rrtm_lwdflx, & !< RRTM output of incoming longwave radiation flux (W/m2)
542	rrtm_lwdflxc, & !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)
543	rrtm_lwuflx, & !< RRTM output of outgoing longwave radiation flux (W/m2)
544	rrtm_lwuflxc, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)
545	rrtm_lwuflx_dt, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)
546	rrtm_lwuflxc_dt,& !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)
547	rrtm_lwhr, & !< RRTM output of longwave radiation heating rate (K/d)
548	rrtm_lwhrc, & !< RRTM output of incoming longwave clear sky radiation heating rate (K/d)
549	rrtm_swdflx, & !< RRTM output of incoming shortwave radiation flux (W/m2)
550	rrtm_swdflxc, & !< RRTM output of outgoing clear sky shortwave radiation flux (W/m2)
551	rrtm_swuflx, & !< RRTM output of outgoing shortwave radiation flux (W/m2)
552	rrtm_swuflxc, & !< RRTM output of incoming clear sky shortwave radiation flux (W/m2)
553	rrtm_swhr, & !< RRTM output of shortwave radiation heating rate (K/d)
554	rrtm_swhrc, & !< RRTM output of incoming shortwave clear sky radiation heating rate (K/d)
555	rrtm_dirdflux, & !< RRTM output of incoming direct shortwave (W/m2)
556	rrtm_difdflux !< RRTM output of incoming diffuse shortwave (W/m2)
557
558	REAL(wp), DIMENSION(1) :: rrtm_aldif, & !< surface albedo for longwave diffuse radiation
559	rrtm_aldir, & !< surface albedo for longwave direct radiation
560	rrtm_asdif, & !< surface albedo for shortwave diffuse radiation
561	rrtm_asdir !< surface albedo for shortwave direct radiation
562
563	!
564	!-- Definition of arrays that are currently not used for calling RRTMG (due to setting of flag parameters)
565	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rad_lw_cs_in, & !< incoming clear sky longwave radiation (W/m2) (not used)
566	rad_lw_cs_out, & !< outgoing clear sky longwave radiation (W/m2) (not used)
567	rad_sw_cs_in, & !< incoming clear sky shortwave radiation (W/m2) (not used)
568	rad_sw_cs_out, & !< outgoing clear sky shortwave radiation (W/m2) (not used)
569	rrtm_lw_tauaer, & !< lw aerosol optical depth
570	rrtm_lw_taucld, & !< lw in-cloud optical depth
571	rrtm_sw_taucld, & !< sw in-cloud optical depth
572	rrtm_sw_ssacld, & !< sw in-cloud single scattering albedo
573	rrtm_sw_asmcld, & !< sw in-cloud asymmetry parameter
574	rrtm_sw_fsfcld, & !< sw in-cloud forward scattering fraction
575	rrtm_sw_tauaer, & !< sw aerosol optical depth
576	rrtm_sw_ssaaer, & !< sw aerosol single scattering albedo
577	rrtm_sw_asmaer, & !< sw aerosol asymmetry parameter
578	rrtm_sw_ecaer !< sw aerosol optical detph at 0.55 microns (rrtm_iaer = 6 only)
579
580	#endif
581	!
582	!-- Parameters of urban and land surface models
583	INTEGER(iwp) :: nz_urban !< number of layers of urban surface (will be calculated)
584	INTEGER(iwp) :: nz_plant !< number of layers of plant canopy (will be calculated)
585	INTEGER(iwp) :: nz_urban_b !< bottom layer of urban surface (will be calculated)
586	INTEGER(iwp) :: nz_urban_t !< top layer of urban surface (will be calculated)
587	INTEGER(iwp) :: nz_plant_t !< top layer of plant canopy (will be calculated)
588	!-- parameters of urban and land surface models
589	INTEGER(iwp), PARAMETER :: nzut_free = 3 !< number of free layers above top of of topography
590	INTEGER(iwp), PARAMETER :: ndsvf = 2 !< number of dimensions of real values in SVF
591	INTEGER(iwp), PARAMETER :: idsvf = 2 !< number of dimensions of integer values in SVF
592	INTEGER(iwp), PARAMETER :: ndcsf = 1 !< number of dimensions of real values in CSF
593	INTEGER(iwp), PARAMETER :: idcsf = 2 !< number of dimensions of integer values in CSF
594	INTEGER(iwp), PARAMETER :: kdcsf = 4 !< number of dimensions of integer values in CSF calculation array
595	INTEGER(iwp), PARAMETER :: id = 1 !< position of d-index in surfl and surf
596	INTEGER(iwp), PARAMETER :: iz = 2 !< position of k-index in surfl and surf
597	INTEGER(iwp), PARAMETER :: iy = 3 !< position of j-index in surfl and surf
598	INTEGER(iwp), PARAMETER :: ix = 4 !< position of i-index in surfl and surf
599	INTEGER(iwp), PARAMETER :: im = 5 !< position of surface m-index in surfl and surf
600	INTEGER(iwp), PARAMETER :: nidx_surf = 5 !< number of indices in surfl and surf
601
602	INTEGER(iwp), PARAMETER :: nsurf_type = 10 !< number of surf types incl. phys.(land+urban) & (atm.,sky,boundary) surfaces - 1
603
604	INTEGER(iwp), PARAMETER :: iup_u = 0 !< 0 - index of urban upward surface (ground or roof)
605	INTEGER(iwp), PARAMETER :: idown_u = 1 !< 1 - index of urban downward surface (overhanging)
606	INTEGER(iwp), PARAMETER :: inorth_u = 2 !< 2 - index of urban northward facing wall
607	INTEGER(iwp), PARAMETER :: isouth_u = 3 !< 3 - index of urban southward facing wall
608	INTEGER(iwp), PARAMETER :: ieast_u = 4 !< 4 - index of urban eastward facing wall
609	INTEGER(iwp), PARAMETER :: iwest_u = 5 !< 5 - index of urban westward facing wall
610
611	INTEGER(iwp), PARAMETER :: iup_l = 6 !< 6 - index of land upward surface (ground or roof)
612	INTEGER(iwp), PARAMETER :: inorth_l = 7 !< 7 - index of land northward facing wall
613	INTEGER(iwp), PARAMETER :: isouth_l = 8 !< 8 - index of land southward facing wall
614	INTEGER(iwp), PARAMETER :: ieast_l = 9 !< 9 - index of land eastward facing wall
615	INTEGER(iwp), PARAMETER :: iwest_l = 10 !< 10- index of land westward facing wall
616
617	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: idir = (/0, 0,0, 0,1,-1,0,0, 0,1,-1/) !< surface normal direction x indices
618	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: jdir = (/0, 0,1,-1,0, 0,0,1,-1,0, 0/) !< surface normal direction y indices
619	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: kdir = (/1,-1,0, 0,0, 0,1,0, 0,0, 0/) !< surface normal direction z indices
620	REAL(wp), DIMENSION(0:nsurf_type) :: facearea !< area of single face in respective
621	!< direction (will be calc'd)
622
623
624	!-- indices and sizes of urban and land surface models
625	INTEGER(iwp) :: startland !< start index of block of land and roof surfaces
626	INTEGER(iwp) :: endland !< end index of block of land and roof surfaces
627	INTEGER(iwp) :: nlands !< number of land and roof surfaces in local processor
628	INTEGER(iwp) :: startwall !< start index of block of wall surfaces
629	INTEGER(iwp) :: endwall !< end index of block of wall surfaces
630	INTEGER(iwp) :: nwalls !< number of wall surfaces in local processor
631
632	!-- indices needed for RTM netcdf output subroutines
633	INTEGER(iwp), PARAMETER :: nd = 5
634	CHARACTER(LEN=6), DIMENSION(0:nd-1), PARAMETER :: dirname = (/ '_roof ', '_south', '_north', '_west ', '_east ' /)
635	INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint_u = (/ iup_u, isouth_u, inorth_u, iwest_u, ieast_u /)
636	INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint_l = (/ iup_l, isouth_l, inorth_l, iwest_l, ieast_l /)
637	INTEGER(iwp), DIMENSION(0:nd-1) :: dirstart
638	INTEGER(iwp), DIMENSION(0:nd-1) :: dirend
639
640	!-- indices and sizes of urban and land surface models
641	INTEGER(iwp), DIMENSION(:,:), POINTER :: surfl !< coordinates of i-th local surface in local grid - surfl[:,k] = [d, z, y, x, m]
642	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surfl_linear !< dtto (linearly allocated array)
643	INTEGER(iwp), DIMENSION(:,:), POINTER :: surf !< coordinates of i-th surface in grid - surf[:,k] = [d, z, y, x, m]
644	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surf_linear !< dtto (linearly allocated array)
645	INTEGER(iwp) :: nsurfl !< number of all surfaces in local processor
646	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: nsurfs !< array of number of all surfaces in individual processors
647	INTEGER(iwp) :: nsurf !< global number of surfaces in index array of surfaces (nsurf = proc nsurfs)
648	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surfstart !< starts of blocks of surfaces for individual processors in array surf (indexed from 1)
649	!< respective block for particular processor is surfstart[iproc+1]+1 : surfstart[iproc+1]+nsurfs[iproc+1]
650
651	!-- block variables needed for calculation of the plant canopy model inside the urban surface model
652	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pct !< top layer of the plant canopy
653	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pch !< heights of the plant canopy
654	INTEGER(iwp) :: npcbl = 0 !< number of the plant canopy gridboxes in local processor
655	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pcbl !< k,j,i coordinates of l-th local plant canopy box pcbl[:,l] = [k, j, i]
656	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw !< array of absorbed sw radiation for local plant canopy box
657	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdir !< array of absorbed direct sw radiation for local plant canopy box
658	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdif !< array of absorbed diffusion sw radiation for local plant canopy box
659	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw !< array of absorbed lw radiation for local plant canopy box
660
661	!-- configuration parameters (they can be setup in PALM config)
662	LOGICAL :: raytrace_mpi_rma = .TRUE. !< use MPI RMA to access LAD and gridsurf from remote processes during raytracing
663	LOGICAL :: rad_angular_discretization = .TRUE.!< whether to use fixed resolution discretization of view factors for
664	!< reflected radiation (as opposed to all mutually visible pairs)
665	LOGICAL :: plant_lw_interact = .TRUE. !< whether plant canopy interacts with LW radiation (in addition to SW)
666	INTEGER(iwp) :: mrt_nlevels = 0 !< number of vertical boxes above surface for which to calculate MRT
667	LOGICAL :: mrt_skip_roof = .TRUE. !< do not calculate MRT above roof surfaces
668	LOGICAL :: mrt_include_sw = .TRUE. !< should MRT calculation include SW radiation as well?
669	LOGICAL :: mrt_geom_human = .TRUE. !< MRT direction weights simulate human body instead of a sphere
670	INTEGER(iwp) :: nrefsteps = 3 !< number of reflection steps to perform
671	REAL(wp), PARAMETER :: ext_coef = 0.6_wp !< extinction coefficient (a.k.a. alpha)
672	INTEGER(iwp), PARAMETER :: rad_version_len = 10 !< length of identification string of rad version
673	CHARACTER(rad_version_len), PARAMETER :: rad_version = 'RAD v. 3.0' !< identification of version of binary svf and restart files
674	INTEGER(iwp) :: raytrace_discrete_elevs = 40 !< number of discretization steps for elevation (nadir to zenith)
675	INTEGER(iwp) :: raytrace_discrete_azims = 80 !< number of discretization steps for azimuth (out of 360 degrees)
676	REAL(wp) :: max_raytracing_dist = -999.0_wp !< maximum distance for raytracing (in metres)
677	REAL(wp) :: min_irrf_value = 1e-6_wp !< minimum potential irradiance factor value for raytracing
678	REAL(wp), DIMENSION(1:30) :: svfnorm_report_thresh = 1e21_wp !< thresholds of SVF normalization values to report
679	INTEGER(iwp) :: svfnorm_report_num !< number of SVF normalization thresholds to report
680
681	!-- radiation related arrays to be used in radiation_interaction routine
682	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_dir !< direct sw radiation
683	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_diff !< diffusion sw radiation
684	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_diff !< diffusion lw radiation
685
686	!-- parameters required for RRTMG lower boundary condition
687	REAL(wp) :: albedo_urb !< albedo value retuned to RRTMG boundary cond.
688	REAL(wp) :: emissivity_urb !< emissivity value retuned to RRTMG boundary cond.
689	REAL(wp) :: t_rad_urb !< temperature value retuned to RRTMG boundary cond.
690
691	!-- type for calculation of svf
692	TYPE t_svf
693	INTEGER(iwp) :: isurflt !<
694	INTEGER(iwp) :: isurfs !<
695	REAL(wp) :: rsvf !<
696	REAL(wp) :: rtransp !<
697	END TYPE
698
699	!-- type for calculation of csf
700	TYPE t_csf
701	INTEGER(iwp) :: ip !<
702	INTEGER(iwp) :: itx !<
703	INTEGER(iwp) :: ity !<
704	INTEGER(iwp) :: itz !<
705	INTEGER(iwp) :: isurfs !< Idx of source face / -1 for sky
706	REAL(wp) :: rcvf !< Canopy view factor for faces /
707	!< canopy sink factor for sky (-1)
708	END TYPE
709
710	!-- arrays storing the values of USM
711	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: svfsurf !< svfsurf[:,isvf] = index of target and source surface for svf[isvf]
712	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: svf !< array of shape view factors+direct irradiation factors for local surfaces
713	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins !< array of sw radiation falling to local surface after i-th reflection
714	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl !< array of lw radiation for local surface after i-th reflection
715
716	REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvf !< array of sky view factor for each local surface
717	REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvft !< array of sky view factor including transparency for each local surface
718	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitrans !< dsidir[isvfl,i] = path transmittance of i-th
719	!< direction of direct solar irradiance per target surface
720	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitransc !< dtto per plant canopy box
721	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir !< dsidir[:,i] = unit vector of i-th
722	!< direction of direct solar irradiance
723	INTEGER(iwp) :: ndsidir !< number of apparent solar directions used
724	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: dsidir_rev !< dsidir_rev[ielev,iazim] = i for dsidir or -1 if not present
725
726	INTEGER(iwp) :: nmrtbl !< No. of local grid boxes for which MRT is calculated
727	INTEGER(iwp) :: nmrtf !< number of MRT factors for local processor
728	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mrtbl !< coordinates of i-th local MRT box - surfl[:,i] = [z, y, x]
729	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mrtfsurf !< mrtfsurf[:,imrtf] = index of target MRT box and source surface for mrtf[imrtf]
730	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtf !< array of MRT factors for each local MRT box
731	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtft !< array of MRT factors including transparency for each local MRT box
732	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtsky !< array of sky view factor for each local MRT box
733	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtskyt !< array of sky view factor including transparency for each local MRT box
734	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: mrtdsit !< array of direct solar transparencies for each local MRT box
735	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinsw !< mean SW radiant flux for each MRT box
736	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinlw !< mean LW radiant flux for each MRT box
737	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt !< mean radiant temperature for each MRT box
738	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinsw_av !< time average mean SW radiant flux for each MRT box
739	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinlw_av !< time average mean LW radiant flux for each MRT box
740	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt_av !< time average mean radiant temperature for each MRT box
741
742	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw !< array of sw radiation falling to local surface including radiation from reflections
743	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw !< array of lw radiation falling to local surface including radiation from reflections
744	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir !< array of direct sw radiation falling to local surface
745	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif !< array of diffuse sw radiation from sky and model boundary falling to local surface
746	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif !< array of diffuse lw radiation from sky and model boundary falling to local surface
747
748	!< Outward radiation is only valid for nonvirtual surfaces
749	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsl !< array of reflected sw radiation for local surface in i-th reflection
750	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutll !< array of reflected + emitted lw radiation for local surface in i-th reflection
751	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfouts !< array of reflected sw radiation for all surfaces in i-th reflection
752	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutl !< array of reflected + emitted lw radiation for all surfaces in i-th reflection
753	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlg !< global array of incoming lw radiation from plant canopy
754	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw !< array of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection
755	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw !< array of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection
756	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfemitlwl !< array of emitted lw radiation for local surface used to calculate effective surface temperature for radiation model
757
758	!-- block variables needed for calculation of the plant canopy model inside the urban surface model
759	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: csfsurf !< csfsurf[:,icsf] = index of target surface and csf grid index for csf[icsf]
760	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csf !< array of plant canopy sink fators + direct irradiation factors (transparency)
761	REAL(wp), DIMENSION(:,:,:), POINTER :: sub_lad !< subset of lad_s within urban surface, transformed to plain Z coordinate
762	REAL(wp), DIMENSION(:), POINTER :: sub_lad_g !< sub_lad globalized (used to avoid MPI RMA calls in raytracing)
763	REAL(wp) :: prototype_lad !< prototype leaf area density for computing effective optical depth
764	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nzterr, plantt !< temporary global arrays for raytracing
765	INTEGER(iwp) :: plantt_max
766
767	!-- arrays and variables for calculation of svf and csf
768	TYPE(t_svf), DIMENSION(:), POINTER :: asvf !< pointer to growing svc array
769	TYPE(t_csf), DIMENSION(:), POINTER :: acsf !< pointer to growing csf array
770	TYPE(t_svf), DIMENSION(:), POINTER :: amrtf !< pointer to growing mrtf array
771	TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: asvf1, asvf2 !< realizations of svf array
772	TYPE(t_csf), DIMENSION(:), ALLOCATABLE, TARGET :: acsf1, acsf2 !< realizations of csf array
773	TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: amrtf1, amrtf2 !< realizations of mftf array
774	INTEGER(iwp) :: nsvfla !< dimmension of array allocated for storage of svf in local processor
775	INTEGER(iwp) :: ncsfla !< dimmension of array allocated for storage of csf in local processor
776	INTEGER(iwp) :: nmrtfa !< dimmension of array allocated for storage of mrt
777	INTEGER(iwp) :: msvf, mcsf, mmrtf!< mod for swapping the growing array
778	INTEGER(iwp), PARAMETER :: gasize = 100000_iwp !< initial size of growing arrays
779	REAL(wp), PARAMETER :: grow_factor = 1.4_wp !< growth factor of growing arrays
780	INTEGER(iwp) :: nsvfl !< number of svf for local processor
781	INTEGER(iwp) :: ncsfl !< no. of csf in local processor
782	!< needed only during calc_svf but must be here because it is
783	!< shared between subroutines calc_svf and raytrace
784	INTEGER(iwp), DIMENSION(:,:,:,:), POINTER :: gridsurf !< reverse index of local surfl[d,k,j,i] (for case rad_angular_discretization)
785	INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: gridpcbl !< reverse index of local pcbl[k,j,i]
786	INTEGER(iwp), PARAMETER :: nsurf_type_u = 6 !< number of urban surf types (used in gridsurf)
787
788	!-- temporary arrays for calculation of csf in raytracing
789	INTEGER(iwp) :: maxboxesg !< max number of boxes ray can cross in the domain
790	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: boxes !< coordinates of gridboxes being crossed by ray
791	REAL(wp), DIMENSION(:), ALLOCATABLE :: crlens !< array of crossing lengths of ray for particular grid boxes
792	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: lad_ip !< array of numbers of process where lad is stored
793	#if defined( __parallel )
794	INTEGER(kind=MPI_ADDRESS_KIND), &
795	DIMENSION(:), ALLOCATABLE :: lad_disp !< array of displaycements of lad in local array of proc lad_ip
796	INTEGER(iwp) :: win_lad !< MPI RMA window for leaf area density
797	INTEGER(iwp) :: win_gridsurf !< MPI RMA window for reverse grid surface index
798	#endif
799	REAL(wp), DIMENSION(:), ALLOCATABLE :: lad_s_ray !< array of received lad_s for appropriate gridboxes crossed by ray
800	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: target_surfl
801	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: rt2_track
802	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rt2_track_lad
803	REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_track_dist
804	REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_dist
805
806	!-- arrays for time averages
807	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfradnet_av !< average of net radiation to local surface including radiation from reflections
808	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw_av !< average of sw radiation falling to local surface including radiation from reflections
809	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw_av !< average of lw radiation falling to local surface including radiation from reflections
810	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir_av !< average of direct sw radiation falling to local surface
811	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif_av !< average of diffuse sw radiation from sky and model boundary falling to local surface
812	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif_av !< average of diffuse lw radiation from sky and model boundary falling to local surface
813	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswref_av !< average of sw radiation falling to surface from reflections
814	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwref_av !< average of lw radiation falling to surface from reflections
815	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw_av !< average of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection
816	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw_av !< average of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection
817	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins_av !< average of array of residua of sw radiation absorbed in surface after last reflection
818	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl_av !< average of array of residua of lw radiation absorbed in surface after last reflection
819	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw_av !< Average of pcbinlw
820	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw_av !< Average of pcbinsw
821	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdir_av !< Average of pcbinswdir
822	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdif_av !< Average of pcbinswdif
823	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswref_av !< Average of pcbinswref
824
825
826	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
827	!-- Energy balance variables
828	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
829	!-- parameters of the land, roof and wall surfaces
830	REAL(wp), DIMENSION(:), ALLOCATABLE :: albedo_surf !< albedo of the surface
831	REAL(wp), DIMENSION(:), ALLOCATABLE :: emiss_surf !< emissivity of the wall surface
832	!
833	!-- External radiation. Depending on the given level of detail either a 1D or
834	!-- a 3D array will be allocated.
835	TYPE( real_1d_3d ) :: rad_lw_in_f !< external incoming longwave radiation, from observation or model
836	TYPE( real_1d_3d ) :: rad_sw_in_f !< external incoming shortwave radiation, from observation or model
837	TYPE( real_1d_3d ) :: rad_sw_in_dif_f !< external incoming shortwave radiation, diffuse part, from observation or model
838	TYPE( real_1d_3d ) :: time_rad_f !< time dimension for external radiation, from observation or model
839
840	INTERFACE radiation_check_data_output
841	MODULE PROCEDURE radiation_check_data_output
842	END INTERFACE radiation_check_data_output
843
844	INTERFACE radiation_check_data_output_ts
845	MODULE PROCEDURE radiation_check_data_output_ts
846	END INTERFACE radiation_check_data_output_ts
847
848	INTERFACE radiation_check_data_output_pr
849	MODULE PROCEDURE radiation_check_data_output_pr
850	END INTERFACE radiation_check_data_output_pr
851
852	INTERFACE radiation_check_parameters
853	MODULE PROCEDURE radiation_check_parameters
854	END INTERFACE radiation_check_parameters
855
856	INTERFACE radiation_clearsky
857	MODULE PROCEDURE radiation_clearsky
858	END INTERFACE radiation_clearsky
859
860	INTERFACE radiation_constant
861	MODULE PROCEDURE radiation_constant
862	END INTERFACE radiation_constant
863
864	INTERFACE radiation_control
865	MODULE PROCEDURE radiation_control
866	END INTERFACE radiation_control
867
868	INTERFACE radiation_3d_data_averaging
869	MODULE PROCEDURE radiation_3d_data_averaging
870	END INTERFACE radiation_3d_data_averaging
871
872	INTERFACE radiation_data_output_2d
873	MODULE PROCEDURE radiation_data_output_2d
874	END INTERFACE radiation_data_output_2d
875
876	INTERFACE radiation_data_output_3d
877	MODULE PROCEDURE radiation_data_output_3d
878	END INTERFACE radiation_data_output_3d
879
880	INTERFACE radiation_data_output_mask
881	MODULE PROCEDURE radiation_data_output_mask
882	END INTERFACE radiation_data_output_mask
883
884	INTERFACE radiation_define_netcdf_grid
885	MODULE PROCEDURE radiation_define_netcdf_grid
886	END INTERFACE radiation_define_netcdf_grid
887
888	INTERFACE radiation_header
889	MODULE PROCEDURE radiation_header
890	END INTERFACE radiation_header
891
892	INTERFACE radiation_init
893	MODULE PROCEDURE radiation_init
894	END INTERFACE radiation_init
895
896	INTERFACE radiation_parin
897	MODULE PROCEDURE radiation_parin
898	END INTERFACE radiation_parin
899
900	INTERFACE radiation_rrtmg
901	MODULE PROCEDURE radiation_rrtmg
902	END INTERFACE radiation_rrtmg
903
904	#if defined( __rrtmg )
905	INTERFACE radiation_tendency
906	MODULE PROCEDURE radiation_tendency
907	MODULE PROCEDURE radiation_tendency_ij
908	END INTERFACE radiation_tendency
909	#endif
910
911	INTERFACE radiation_rrd_local
912	MODULE PROCEDURE radiation_rrd_local
913	END INTERFACE radiation_rrd_local
914
915	INTERFACE radiation_wrd_local
916	MODULE PROCEDURE radiation_wrd_local
917	END INTERFACE radiation_wrd_local
918
919	INTERFACE radiation_interaction
920	MODULE PROCEDURE radiation_interaction
921	END INTERFACE radiation_interaction
922
923	INTERFACE radiation_interaction_init
924	MODULE PROCEDURE radiation_interaction_init
925	END INTERFACE radiation_interaction_init
926
927	INTERFACE radiation_presimulate_solar_pos
928	MODULE PROCEDURE radiation_presimulate_solar_pos
929	END INTERFACE radiation_presimulate_solar_pos
930
931	INTERFACE radiation_calc_svf
932	MODULE PROCEDURE radiation_calc_svf
933	END INTERFACE radiation_calc_svf
934
935	INTERFACE radiation_write_svf
936	MODULE PROCEDURE radiation_write_svf
937	END INTERFACE radiation_write_svf
938
939	INTERFACE radiation_read_svf
940	MODULE PROCEDURE radiation_read_svf
941	END INTERFACE radiation_read_svf
942
943
944	SAVE
945
946	PRIVATE
947
948	!
949	!-- Public functions / NEEDS SORTING
950	PUBLIC radiation_check_data_output, radiation_check_data_output_pr, &
951	radiation_check_data_output_ts, &
952	radiation_check_parameters, radiation_control, &
953	radiation_header, radiation_init, radiation_parin, &
954	radiation_3d_data_averaging, &
955	radiation_data_output_2d, radiation_data_output_3d, &
956	radiation_define_netcdf_grid, radiation_wrd_local, &
957	radiation_rrd_local, radiation_data_output_mask, &
958	radiation_calc_svf, radiation_write_svf, &
959	radiation_interaction, radiation_interaction_init, &
960	radiation_read_svf, radiation_presimulate_solar_pos
961
962
963	!
964	!-- Public variables and constants / NEEDS SORTING
965	PUBLIC albedo, albedo_type, decl_1, decl_2, decl_3, dots_rad, dt_radiation,&
966	emissivity, force_radiation_call, lat, lon, mrt_geom_human, &
967	mrt_include_sw, mrt_nlevels, mrtbl, mrtinsw, mrtinlw, nmrtbl, &
968	rad_net_av, radiation, radiation_scheme, rad_lw_in, &
969	rad_lw_in_av, rad_lw_out, rad_lw_out_av, &
970	rad_lw_cs_hr, rad_lw_cs_hr_av, rad_lw_hr, rad_lw_hr_av, rad_sw_in, &
971	rad_sw_in_av, rad_sw_out, rad_sw_out_av, rad_sw_cs_hr, &
972	rad_sw_cs_hr_av, rad_sw_hr, rad_sw_hr_av, solar_constant, &
973	skip_time_do_radiation, time_radiation, unscheduled_radiation_calls,&
974	cos_zenith, calc_zenith, sun_direction, sun_dir_lat, sun_dir_lon, &
975	idir, jdir, kdir, id, iz, iy, ix, &
976	iup_u, inorth_u, isouth_u, ieast_u, iwest_u, &
977	iup_l, inorth_l, isouth_l, ieast_l, iwest_l, &
978	nsurf_type, nz_urban_b, nz_urban_t, nz_urban, pch, nsurf, &
979	idsvf, ndsvf, idcsf, ndcsf, kdcsf, pct, &
980	radiation_interactions, startwall, startland, endland, endwall, &
981	skyvf, skyvft, radiation_interactions_on, average_radiation, &
982	rad_sw_in_diff, rad_sw_in_dir
983
984
985	#if defined ( __rrtmg )
986	PUBLIC radiation_tendency, rrtm_aldif, rrtm_aldir, rrtm_asdif, rrtm_asdir
987	#endif
988
989	CONTAINS
990
991
992	!------------------------------------------------------------------------------!
993	! Description:
994	! ------------
995	!> This subroutine controls the calls of the radiation schemes
996	!------------------------------------------------------------------------------!
997	SUBROUTINE radiation_control
998
999
1000	IMPLICIT NONE
1001
1002
1003	IF ( debug_output_timestep ) CALL debug_message( 'radiation_control', 'start' )
1004
1005
1006	SELECT CASE ( TRIM( radiation_scheme ) )
1007
1008	CASE ( 'constant' )
1009	CALL radiation_constant
1010
1011	CASE ( 'clear-sky' )
1012	CALL radiation_clearsky
1013
1014	CASE ( 'rrtmg' )
1015	CALL radiation_rrtmg
1016
1017	CASE ( 'external' )
1018	!
1019	!-- During spinup apply clear-sky model
1020	IF ( time_since_reference_point < 0.0_wp ) THEN
1021	CALL radiation_clearsky
1022	ELSE
1023	CALL radiation_external
1024	ENDIF
1025
1026	CASE DEFAULT
1027
1028	END SELECT
1029
1030	IF ( debug_output_timestep ) CALL debug_message( 'radiation_control', 'end' )
1031
1032	END SUBROUTINE radiation_control
1033
1034	!------------------------------------------------------------------------------!
1035	! Description:
1036	! ------------
1037	!> Check data output for radiation model
1038	!------------------------------------------------------------------------------!
1039	SUBROUTINE radiation_check_data_output( variable, unit, i, ilen, k )
1040
1041
1042	USE control_parameters, &
1043	ONLY: data_output, message_string
1044
1045	IMPLICIT NONE
1046
1047	CHARACTER (LEN=*) :: unit !<
1048	CHARACTER (LEN=*) :: variable !<
1049
1050	INTEGER(iwp) :: i, k
1051	INTEGER(iwp) :: ilen
1052	CHARACTER(LEN=varnamelength) :: var !< TRIM(variable)
1053
1054	var = TRIM(variable)
1055
1056	IF ( len(var) < 3_iwp ) THEN
1057	unit = 'illegal'
1058	RETURN
1059	ENDIF
1060
1061	IF ( var(1:3) /= 'rad' .AND. var(1:3) /= 'rtm' ) THEN
1062	unit = 'illegal'
1063	RETURN
1064	ENDIF
1065
1066	!-- first process diractional variables
1067	IF ( var(1:12) == 'rtm_rad_net_' .OR. var(1:13) == 'rtm_rad_insw_' .OR. &
1068	var(1:13) == 'rtm_rad_inlw_' .OR. var(1:16) == 'rtm_rad_inswdir_' .OR. &
1069	var(1:16) == 'rtm_rad_inswdif_' .OR. var(1:16) == 'rtm_rad_inswref_' .OR. &
1070	var(1:16) == 'rtm_rad_inlwdif_' .OR. var(1:16) == 'rtm_rad_inlwref_' .OR. &
1071	var(1:14) == 'rtm_rad_outsw_' .OR. var(1:14) == 'rtm_rad_outlw_' .OR. &
1072	var(1:14) == 'rtm_rad_ressw_' .OR. var(1:14) == 'rtm_rad_reslw_' ) THEN
1073	IF ( .NOT. radiation ) THEN
1074	message_string = 'output of "' // TRIM( var ) // '" require'&
1075	// 's radiation = .TRUE.'
1076	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1077	ENDIF
1078	unit = 'W/m2'
1079	ELSE IF ( var(1:7) == 'rtm_svf' .OR. var(1:7) == 'rtm_dif' .OR. &
1080	var(1:9) == 'rtm_skyvf' .OR. var(1:9) == 'rtm_skyvft' .OR. &
1081	var(1:12) == 'rtm_surfalb_' .OR. var(1:13) == 'rtm_surfemis_' ) THEN
1082	IF ( .NOT. radiation ) THEN
1083	message_string = 'output of "' // TRIM( var ) // '" require'&
1084	// 's radiation = .TRUE.'
1085	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1086	ENDIF
1087	unit = '1'
1088	ELSE
1089	!-- non-directional variables
1090	SELECT CASE ( TRIM( var ) )
1091	CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_lw_in', 'rad_lw_out', &
1092	'rad_sw_cs_hr', 'rad_sw_hr', 'rad_sw_in', 'rad_sw_out' )
1093	IF ( .NOT. radiation .OR. radiation_scheme /= 'rrtmg' ) THEN
1094	message_string = '"output of "' // TRIM( var ) // '" requi' // &
1095	'res radiation = .TRUE. and ' // &
1096	'radiation_scheme = "rrtmg"'
1097	CALL message( 'check_parameters', 'PA0406', 1, 2, 0, 6, 0 )
1098	ENDIF
1099	unit = 'K/h'
1100
1101	CASE ( 'rad_net', 'rrtm_aldif', 'rrtm_aldir', 'rrtm_asdif', &
1102	'rrtm_asdir', 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', &
1103	'rad_sw_out*')
1104	IF ( i == 0 .AND. ilen == 0 .AND. k == 0) THEN
1105	! Workaround for masked output (calls with i=ilen=k=0)
1106	unit = 'illegal'
1107	RETURN
1108	ENDIF
1109	IF ( k == 0 .OR. data_output(i)(ilen-2:ilen) /= '_xy' ) THEN
1110	message_string = 'illegal value for data_output: "' // &
1111	TRIM( var ) // '" & only 2d-horizontal ' // &
1112	'cross sections are allowed for this value'
1113	CALL message( 'check_parameters', 'PA0111', 1, 2, 0, 6, 0 )
1114	ENDIF
1115	IF ( .NOT. radiation .OR. radiation_scheme /= "rrtmg" ) THEN
1116	IF ( TRIM( var ) == 'rrtm_aldif*' .OR. &
1117	TRIM( var ) == 'rrtm_aldir*' .OR. &
1118	TRIM( var ) == 'rrtm_asdif*' .OR. &
1119	TRIM( var ) == 'rrtm_asdir*' ) &
1120	THEN
1121	message_string = 'output of "' // TRIM( var ) // '" require'&
1122	// 's radiation = .TRUE. and radiation_sch'&
1123	// 'eme = "rrtmg"'
1124	CALL message( 'check_parameters', 'PA0409', 1, 2, 0, 6, 0 )
1125	ENDIF
1126	ENDIF
1127
1128	IF ( TRIM( var ) == 'rad_net*' ) unit = 'W/m2'
1129	IF ( TRIM( var ) == 'rad_lw_in*' ) unit = 'W/m2'
1130	IF ( TRIM( var ) == 'rad_lw_out*' ) unit = 'W/m2'
1131	IF ( TRIM( var ) == 'rad_sw_in*' ) unit = 'W/m2'
1132	IF ( TRIM( var ) == 'rad_sw_out*' ) unit = 'W/m2'
1133	IF ( TRIM( var ) == 'rad_sw_in' ) unit = 'W/m2'
1134	IF ( TRIM( var ) == 'rrtm_aldif*' ) unit = ''
1135	IF ( TRIM( var ) == 'rrtm_aldir*' ) unit = ''
1136	IF ( TRIM( var ) == 'rrtm_asdif*' ) unit = ''
1137	IF ( TRIM( var ) == 'rrtm_asdir*' ) unit = ''
1138
1139	CASE ( 'rtm_rad_pc_inlw', 'rtm_rad_pc_insw', 'rtm_rad_pc_inswdir', &
1140	'rtm_rad_pc_inswdif', 'rtm_rad_pc_inswref')
1141	IF ( .NOT. radiation ) THEN
1142	message_string = 'output of "' // TRIM( var ) // '" require'&
1143	// 's radiation = .TRUE.'
1144	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1145	ENDIF
1146	unit = 'W'
1147
1148	CASE ( 'rtm_mrt', 'rtm_mrt_sw', 'rtm_mrt_lw' )
1149	IF ( i == 0 .AND. ilen == 0 .AND. k == 0) THEN
1150	! Workaround for masked output (calls with i=ilen=k=0)
1151	unit = 'illegal'
1152	RETURN
1153	ENDIF
1154
1155	IF ( .NOT. radiation ) THEN
1156	message_string = 'output of "' // TRIM( var ) // '" require'&
1157	// 's radiation = .TRUE.'
1158	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1159	ENDIF
1160	IF ( mrt_nlevels == 0 ) THEN
1161	message_string = 'output of "' // TRIM( var ) // '" require'&
1162	// 's mrt_nlevels > 0'
1163	CALL message( 'check_parameters', 'PA0510', 1, 2, 0, 6, 0 )
1164	ENDIF
1165	IF ( TRIM( var ) == 'rtm_mrt_sw' .AND. .NOT. mrt_include_sw ) THEN
1166	message_string = 'output of "' // TRIM( var ) // '" require'&
1167	// 's rtm_mrt_sw = .TRUE.'
1168	CALL message( 'check_parameters', 'PA0511', 1, 2, 0, 6, 0 )
1169	ENDIF
1170	IF ( TRIM( var ) == 'rtm_mrt' ) THEN
1171	unit = 'K'
1172	ELSE
1173	unit = 'W m-2'
1174	ENDIF
1175
1176	CASE DEFAULT
1177	unit = 'illegal'
1178
1179	END SELECT
1180	ENDIF
1181
1182	END SUBROUTINE radiation_check_data_output
1183
1184
1185	!------------------------------------------------------------------------------!
1186	! Description:
1187	! ------------
1188	!> Set module-specific timeseries units and labels
1189	!------------------------------------------------------------------------------!
1190	SUBROUTINE radiation_check_data_output_ts( dots_max, dots_num )
1191
1192
1193	INTEGER(iwp), INTENT(IN) :: dots_max
1194	INTEGER(iwp), INTENT(INOUT) :: dots_num
1195
1196	!
1197	!-- Next line is just to avoid compiler warning about unused variable.
1198	IF ( dots_max == 0 ) CONTINUE
1199
1200	!
1201	!-- Temporary solution to add LSM and radiation time series to the default
1202	!-- output
1203	IF ( land_surface .OR. radiation ) THEN
1204	IF ( TRIM( radiation_scheme ) == 'rrtmg' ) THEN
1205	dots_num = dots_num + 15
1206	ELSE
1207	dots_num = dots_num + 11
1208	ENDIF
1209	ENDIF
1210
1211
1212	END SUBROUTINE radiation_check_data_output_ts
1213
1214	!------------------------------------------------------------------------------!
1215	! Description:
1216	! ------------
1217	!> Check data output of profiles for radiation model
1218	!------------------------------------------------------------------------------!
1219	SUBROUTINE radiation_check_data_output_pr( variable, var_count, unit, &
1220	dopr_unit )
1221
1222	USE arrays_3d, &
1223	ONLY: zu
1224
1225	USE control_parameters, &
1226	ONLY: data_output_pr, message_string
1227
1228	USE indices
1229
1230	USE profil_parameter
1231
1232	USE statistics
1233
1234	IMPLICIT NONE
1235
1236	CHARACTER (LEN=*) :: unit !<
1237	CHARACTER (LEN=*) :: variable !<
1238	CHARACTER (LEN=*) :: dopr_unit !< local value of dopr_unit
1239
1240	INTEGER(iwp) :: var_count !<
1241
1242	SELECT CASE ( TRIM( variable ) )
1243
1244	CASE ( 'rad_net' )
1245	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )&
1246	THEN
1247	message_string = 'data_output_pr = ' // &
1248	TRIM( data_output_pr(var_count) ) // ' is' // &
1249	'not available for radiation = .FALSE. or ' //&
1250	'radiation_scheme = "constant"'
1251	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1252	ELSE
1253	dopr_index(var_count) = 99
1254	dopr_unit = 'W/m2'
1255	hom(:,2,99,:) = SPREAD( zw, 2, statistic_regions+1 )
1256	unit = dopr_unit
1257	ENDIF
1258
1259	CASE ( 'rad_lw_in' )
1260	IF ( ( .NOT. radiation) .OR. radiation_scheme == 'constant' ) &
1261	THEN
1262	message_string = 'data_output_pr = ' // &
1263	TRIM( data_output_pr(var_count) ) // ' is' // &
1264	'not available for radiation = .FALSE. or ' //&
1265	'radiation_scheme = "constant"'
1266	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1267	ELSE
1268	dopr_index(var_count) = 100
1269	dopr_unit = 'W/m2'
1270	hom(:,2,100,:) = SPREAD( zw, 2, statistic_regions+1 )
1271	unit = dopr_unit
1272	ENDIF
1273
1274	CASE ( 'rad_lw_out' )
1275	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) &
1276	THEN
1277	message_string = 'data_output_pr = ' // &
1278	TRIM( data_output_pr(var_count) ) // ' is' // &
1279	'not available for radiation = .FALSE. or ' //&
1280	'radiation_scheme = "constant"'
1281	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1282	ELSE
1283	dopr_index(var_count) = 101
1284	dopr_unit = 'W/m2'
1285	hom(:,2,101,:) = SPREAD( zw, 2, statistic_regions+1 )
1286	unit = dopr_unit
1287	ENDIF
1288
1289	CASE ( 'rad_sw_in' )
1290	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) &
1291	THEN
1292	message_string = 'data_output_pr = ' // &
1293	TRIM( data_output_pr(var_count) ) // ' is' // &
1294	'not available for radiation = .FALSE. or ' //&
1295	'radiation_scheme = "constant"'
1296	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1297	ELSE
1298	dopr_index(var_count) = 102
1299	dopr_unit = 'W/m2'
1300	hom(:,2,102,:) = SPREAD( zw, 2, statistic_regions+1 )
1301	unit = dopr_unit
1302	ENDIF
1303
1304	CASE ( 'rad_sw_out')
1305	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )&
1306	THEN
1307	message_string = 'data_output_pr = ' // &
1308	TRIM( data_output_pr(var_count) ) // ' is' // &
1309	'not available for radiation = .FALSE. or ' //&
1310	'radiation_scheme = "constant"'
1311	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1312	ELSE
1313	dopr_index(var_count) = 103
1314	dopr_unit = 'W/m2'
1315	hom(:,2,103,:) = SPREAD( zw, 2, statistic_regions+1 )
1316	unit = dopr_unit
1317	ENDIF
1318
1319	CASE ( 'rad_lw_cs_hr' )
1320	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1321	THEN
1322	message_string = 'data_output_pr = ' // &
1323	TRIM( data_output_pr(var_count) ) // ' is' // &
1324	'not available for radiation = .FALSE. or ' //&
1325	'radiation_scheme /= "rrtmg"'
1326	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1327	ELSE
1328	dopr_index(var_count) = 104
1329	dopr_unit = 'K/h'
1330	hom(:,2,104,:) = SPREAD( zu, 2, statistic_regions+1 )
1331	unit = dopr_unit
1332	ENDIF
1333
1334	CASE ( 'rad_lw_hr' )
1335	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1336	THEN
1337	message_string = 'data_output_pr = ' // &
1338	TRIM( data_output_pr(var_count) ) // ' is' // &
1339	'not available for radiation = .FALSE. or ' //&
1340	'radiation_scheme /= "rrtmg"'
1341	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1342	ELSE
1343	dopr_index(var_count) = 105
1344	dopr_unit = 'K/h'
1345	hom(:,2,105,:) = SPREAD( zu, 2, statistic_regions+1 )
1346	unit = dopr_unit
1347	ENDIF
1348
1349	CASE ( 'rad_sw_cs_hr' )
1350	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1351	THEN
1352	message_string = 'data_output_pr = ' // &
1353	TRIM( data_output_pr(var_count) ) // ' is' // &
1354	'not available for radiation = .FALSE. or ' //&
1355	'radiation_scheme /= "rrtmg"'
1356	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1357	ELSE
1358	dopr_index(var_count) = 106
1359	dopr_unit = 'K/h'
1360	hom(:,2,106,:) = SPREAD( zu, 2, statistic_regions+1 )
1361	unit = dopr_unit
1362	ENDIF
1363
1364	CASE ( 'rad_sw_hr' )
1365	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1366	THEN
1367	message_string = 'data_output_pr = ' // &
1368	TRIM( data_output_pr(var_count) ) // ' is' // &
1369	'not available for radiation = .FALSE. or ' //&
1370	'radiation_scheme /= "rrtmg"'
1371	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1372	ELSE
1373	dopr_index(var_count) = 107
1374	dopr_unit = 'K/h'
1375	hom(:,2,107,:) = SPREAD( zu, 2, statistic_regions+1 )
1376	unit = dopr_unit
1377	ENDIF
1378
1379
1380	CASE DEFAULT
1381	unit = 'illegal'
1382
1383	END SELECT
1384
1385
1386	END SUBROUTINE radiation_check_data_output_pr
1387
1388
1389	!------------------------------------------------------------------------------!
1390	! Description:
1391	! ------------
1392	!> Check parameters routine for radiation model
1393	!------------------------------------------------------------------------------!
1394	SUBROUTINE radiation_check_parameters
1395
1396	USE control_parameters, &
1397	ONLY: land_surface, message_string, rotation_angle, urban_surface
1398
1399	USE netcdf_data_input_mod, &
1400	ONLY: input_pids_static
1401
1402	IMPLICIT NONE
1403
1404	!
1405	!-- In case no urban-surface or land-surface model is applied, usage of
1406	!-- a radiation model make no sense.
1407	IF ( .NOT. land_surface .AND. .NOT. urban_surface ) THEN
1408	message_string = 'Usage of radiation module is only allowed if ' // &
1409	'land-surface and/or urban-surface model is applied.'
1410	CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 )
1411	ENDIF
1412
1413	IF ( radiation_scheme /= 'constant' .AND. &
1414	radiation_scheme /= 'clear-sky' .AND. &
1415	radiation_scheme /= 'rrtmg' .AND. &
1416	radiation_scheme /= 'external' ) THEN
1417	message_string = 'unknown radiation_scheme = '// &
1418	TRIM( radiation_scheme )
1419	CALL message( 'check_parameters', 'PA0405', 1, 2, 0, 6, 0 )
1420	ELSEIF ( radiation_scheme == 'rrtmg' ) THEN
1421	#if ! defined ( __rrtmg )
1422	message_string = 'radiation_scheme = "rrtmg" requires ' // &
1423	'compilation of PALM with pre-processor ' // &
1424	'directive -D__rrtmg'
1425	CALL message( 'check_parameters', 'PA0407', 1, 2, 0, 6, 0 )
1426	#endif
1427	#if defined ( __rrtmg ) && ! defined( __netcdf )
1428	message_string = 'radiation_scheme = "rrtmg" requires ' // &
1429	'the use of NetCDF (preprocessor directive ' // &
1430	'-D__netcdf'
1431	CALL message( 'check_parameters', 'PA0412', 1, 2, 0, 6, 0 )
1432	#endif
1433
1434	ENDIF
1435	!
1436	!-- Checks performed only if data is given via namelist only.
1437	IF ( .NOT. input_pids_static ) THEN
1438	IF ( albedo_type == 0 .AND. albedo == 9999999.9_wp .AND. &
1439	radiation_scheme == 'clear-sky') THEN
1440	message_string = 'radiation_scheme = "clear-sky" in combination'//&
1441	'with albedo_type = 0 requires setting of'// &
1442	'albedo /= 9999999.9'
1443	CALL message( 'check_parameters', 'PA0410', 1, 2, 0, 6, 0 )
1444	ENDIF
1445
1446	IF ( albedo_type == 0 .AND. radiation_scheme == 'rrtmg' .AND. &
1447	( albedo_lw_dif == 9999999.9_wp .OR. albedo_lw_dir == 9999999.9_wp&
1448	.OR. albedo_sw_dif == 9999999.9_wp .OR. albedo_sw_dir == 9999999.9_wp&
1449	) ) THEN
1450	message_string = 'radiation_scheme = "rrtmg" in combination' // &
1451	'with albedo_type = 0 requires setting of ' // &
1452	'albedo_lw_dif /= 9999999.9' // &
1453	'albedo_lw_dir /= 9999999.9' // &
1454	'albedo_sw_dif /= 9999999.9 and' // &
1455	'albedo_sw_dir /= 9999999.9'
1456	CALL message( 'check_parameters', 'PA0411', 1, 2, 0, 6, 0 )
1457	ENDIF
1458	ENDIF
1459	!
1460	!-- Parallel rad_angular_discretization without raytrace_mpi_rma is not implemented
1461	#if defined( __parallel )
1462	IF ( rad_angular_discretization .AND. .NOT. raytrace_mpi_rma ) THEN
1463	message_string = 'rad_angular_discretization can only be used ' // &
1464	'together with raytrace_mpi_rma or when ' // &
1465	'no parallelization is applied.'
1466	CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 )
1467	ENDIF
1468	#endif
1469
1470	IF ( cloud_droplets .AND. radiation_scheme == 'rrtmg' .AND. &
1471	average_radiation ) THEN
1472	message_string = 'average_radiation = .T. with radiation_scheme'// &
1473	'= "rrtmg" in combination cloud_droplets = .T.'// &
1474	'is not implementd'
1475	CALL message( 'check_parameters', 'PA0560', 1, 2, 0, 6, 0 )
1476	ENDIF
1477
1478	!
1479	!-- Incialize svf normalization reporting histogram
1480	svfnorm_report_num = 1
1481	DO WHILE ( svfnorm_report_thresh(svfnorm_report_num) < 1e20_wp &
1482	.AND. svfnorm_report_num <= 30 )
1483	svfnorm_report_num = svfnorm_report_num + 1
1484	ENDDO
1485	svfnorm_report_num = svfnorm_report_num - 1
1486	!
1487	!-- Check for dt_radiation
1488	IF ( dt_radiation <= 0.0 ) THEN
1489	message_string = 'dt_radiation must be > 0.0'
1490	CALL message( 'check_parameters', 'PA0591', 1, 2, 0, 6, 0 )
1491	ENDIF
1492	!
1493	!-- Check rotation angle
1494	!> @todo Remove this limitation
1495	IF ( rotation_angle /= 0.0 ) THEN
1496	message_string = 'rotation of the model domain is not considered in the radiation ' // &
1497	'model.&Using rotation_angle /= 0.0 is not allowed in combination ' // &
1498	'with the radiation model at the moment!'
1499	CALL message( 'check_parameters', 'PA0675', 1, 2, 0, 6, 0 )
1500	ENDIF
1501
1502	END SUBROUTINE radiation_check_parameters
1503
1504
1505	!------------------------------------------------------------------------------!
1506	! Description:
1507	! ------------
1508	!> Initialization of the radiation model
1509	!------------------------------------------------------------------------------!
1510	SUBROUTINE radiation_init
1511
1512	IMPLICIT NONE
1513
1514	INTEGER(iwp) :: i !< running index x-direction
1515	INTEGER(iwp) :: is !< running index for input surface elements
1516	INTEGER(iwp) :: ioff !< offset in x between surface element reference grid point in atmosphere and actual surface
1517	INTEGER(iwp) :: j !< running index y-direction
1518	INTEGER(iwp) :: joff !< offset in y between surface element reference grid point in atmosphere and actual surface
1519	INTEGER(iwp) :: k !< running index z-direction
1520	INTEGER(iwp) :: l !< running index for orientation of vertical surfaces
1521	INTEGER(iwp) :: m !< running index for surface elements
1522	INTEGER(iwp) :: ntime = 0 !< number of available external radiation timesteps
1523	#if defined( __rrtmg )
1524	INTEGER(iwp) :: ind_type !< running index for subgrid-surface tiles
1525	#endif
1526	LOGICAL :: radiation_input_root_domain !< flag indicating the existence of a dynamic input file for the root domain
1527
1528
1529	IF ( debug_output ) CALL debug_message( 'radiation_init', 'start' )
1530	!
1531	!-- Activate radiation_interactions according to the existence of vertical surfaces and/or trees.
1532	!-- The namelist parameter radiation_interactions_on can override this behavior.
1533	!-- (This check cannot be performed in check_parameters, because vertical_surfaces_exist is first set in
1534	!-- init_surface_arrays.)
1535	IF ( radiation_interactions_on ) THEN
1536	IF ( vertical_surfaces_exist .OR. plant_canopy ) THEN
1537	radiation_interactions = .TRUE.
1538	average_radiation = .TRUE.
1539	ELSE
1540	radiation_interactions_on = .FALSE. !< reset namelist parameter: no interactions
1541	!< calculations necessary in case of flat surface
1542	ENDIF
1543	ELSEIF ( vertical_surfaces_exist .OR. plant_canopy ) THEN
1544	message_string = 'radiation_interactions_on is set to .FALSE. although ' // &
1545	'vertical surfaces and/or trees exist. The model will run ' // &
1546	'without RTM (no shadows, no radiation reflections)'
1547	CALL message( 'init_3d_model', 'PA0348', 0, 1, 0, 6, 0 )
1548	ENDIF
1549	!
1550	!-- Precalculate some time constants
1551	d_hours_day = 1.0_wp / REAL( hours_per_day, KIND = wp )
1552	d_seconds_hour = 1.0_wp / seconds_per_hour
1553
1554	!
1555	!-- If required, initialize radiation interactions between surfaces
1556	!-- via sky-view factors. This must be done before radiation is initialized.
1557	IF ( radiation_interactions ) CALL radiation_interaction_init
1558	!
1559	!-- Allocate array for storing the surface net radiation
1560	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_net ) .AND. &
1561	surf_lsm_h%ns > 0 ) THEN
1562	ALLOCATE( surf_lsm_h%rad_net(1:surf_lsm_h%ns) )
1563	surf_lsm_h%rad_net = 0.0_wp
1564	ENDIF
1565	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_net ) .AND. &
1566	surf_usm_h%ns > 0 ) THEN
1567	ALLOCATE( surf_usm_h%rad_net(1:surf_usm_h%ns) )
1568	surf_usm_h%rad_net = 0.0_wp
1569	ENDIF
1570	DO l = 0, 3
1571	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_net ) .AND. &
1572	surf_lsm_v(l)%ns > 0 ) THEN
1573	ALLOCATE( surf_lsm_v(l)%rad_net(1:surf_lsm_v(l)%ns) )
1574	surf_lsm_v(l)%rad_net = 0.0_wp
1575	ENDIF
1576	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_net ) .AND. &
1577	surf_usm_v(l)%ns > 0 ) THEN
1578	ALLOCATE( surf_usm_v(l)%rad_net(1:surf_usm_v(l)%ns) )
1579	surf_usm_v(l)%rad_net = 0.0_wp
1580	ENDIF
1581	ENDDO
1582
1583
1584	!
1585	!-- Allocate array for storing the surface longwave (out) radiation change
1586	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_lw_out_change_0 ) .AND. &
1587	surf_lsm_h%ns > 0 ) THEN
1588	ALLOCATE( surf_lsm_h%rad_lw_out_change_0(1:surf_lsm_h%ns) )
1589	surf_lsm_h%rad_lw_out_change_0 = 0.0_wp
1590	ENDIF
1591	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_lw_out_change_0 ) .AND. &
1592	surf_usm_h%ns > 0 ) THEN
1593	ALLOCATE( surf_usm_h%rad_lw_out_change_0(1:surf_usm_h%ns) )
1594	surf_usm_h%rad_lw_out_change_0 = 0.0_wp
1595	ENDIF
1596	DO l = 0, 3
1597	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_lw_out_change_0 ) .AND. &
1598	surf_lsm_v(l)%ns > 0 ) THEN
1599	ALLOCATE( surf_lsm_v(l)%rad_lw_out_change_0(1:surf_lsm_v(l)%ns) )
1600	surf_lsm_v(l)%rad_lw_out_change_0 = 0.0_wp
1601	ENDIF
1602	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_lw_out_change_0 ) .AND. &
1603	surf_usm_v(l)%ns > 0 ) THEN
1604	ALLOCATE( surf_usm_v(l)%rad_lw_out_change_0(1:surf_usm_v(l)%ns) )
1605	surf_usm_v(l)%rad_lw_out_change_0 = 0.0_wp
1606	ENDIF
1607	ENDDO
1608
1609	!
1610	!-- Allocate surface arrays for incoming/outgoing short/longwave radiation
1611	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_sw_in ) .AND. &
1612	surf_lsm_h%ns > 0 ) THEN
1613	ALLOCATE( surf_lsm_h%rad_sw_in(1:surf_lsm_h%ns) )
1614	ALLOCATE( surf_lsm_h%rad_sw_out(1:surf_lsm_h%ns) )
1615	ALLOCATE( surf_lsm_h%rad_sw_dir(1:surf_lsm_h%ns) )
1616	ALLOCATE( surf_lsm_h%rad_sw_dif(1:surf_lsm_h%ns) )
1617	ALLOCATE( surf_lsm_h%rad_sw_ref(1:surf_lsm_h%ns) )
1618	ALLOCATE( surf_lsm_h%rad_sw_res(1:surf_lsm_h%ns) )
1619	ALLOCATE( surf_lsm_h%rad_lw_in(1:surf_lsm_h%ns) )
1620	ALLOCATE( surf_lsm_h%rad_lw_out(1:surf_lsm_h%ns) )
1621	ALLOCATE( surf_lsm_h%rad_lw_dif(1:surf_lsm_h%ns) )
1622	ALLOCATE( surf_lsm_h%rad_lw_ref(1:surf_lsm_h%ns) )
1623	ALLOCATE( surf_lsm_h%rad_lw_res(1:surf_lsm_h%ns) )
1624	surf_lsm_h%rad_sw_in = 0.0_wp
1625	surf_lsm_h%rad_sw_out = 0.0_wp
1626	surf_lsm_h%rad_sw_dir = 0.0_wp
1627	surf_lsm_h%rad_sw_dif = 0.0_wp
1628	surf_lsm_h%rad_sw_ref = 0.0_wp
1629	surf_lsm_h%rad_sw_res = 0.0_wp
1630	surf_lsm_h%rad_lw_in = 0.0_wp
1631	surf_lsm_h%rad_lw_out = 0.0_wp
1632	surf_lsm_h%rad_lw_dif = 0.0_wp
1633	surf_lsm_h%rad_lw_ref = 0.0_wp
1634	surf_lsm_h%rad_lw_res = 0.0_wp
1635	ENDIF
1636	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_sw_in ) .AND. &
1637	surf_usm_h%ns > 0 ) THEN
1638	ALLOCATE( surf_usm_h%rad_sw_in(1:surf_usm_h%ns) )
1639	ALLOCATE( surf_usm_h%rad_sw_out(1:surf_usm_h%ns) )
1640	ALLOCATE( surf_usm_h%rad_sw_dir(1:surf_usm_h%ns) )
1641	ALLOCATE( surf_usm_h%rad_sw_dif(1:surf_usm_h%ns) )
1642	ALLOCATE( surf_usm_h%rad_sw_ref(1:surf_usm_h%ns) )
1643	ALLOCATE( surf_usm_h%rad_sw_res(1:surf_usm_h%ns) )
1644	ALLOCATE( surf_usm_h%rad_lw_in(1:surf_usm_h%ns) )
1645	ALLOCATE( surf_usm_h%rad_lw_out(1:surf_usm_h%ns) )
1646	ALLOCATE( surf_usm_h%rad_lw_dif(1:surf_usm_h%ns) )
1647	ALLOCATE( surf_usm_h%rad_lw_ref(1:surf_usm_h%ns) )
1648	ALLOCATE( surf_usm_h%rad_lw_res(1:surf_usm_h%ns) )
1649	surf_usm_h%rad_sw_in = 0.0_wp
1650	surf_usm_h%rad_sw_out = 0.0_wp
1651	surf_usm_h%rad_sw_dir = 0.0_wp
1652	surf_usm_h%rad_sw_dif = 0.0_wp
1653	surf_usm_h%rad_sw_ref = 0.0_wp
1654	surf_usm_h%rad_sw_res = 0.0_wp
1655	surf_usm_h%rad_lw_in = 0.0_wp
1656	surf_usm_h%rad_lw_out = 0.0_wp
1657	surf_usm_h%rad_lw_dif = 0.0_wp
1658	surf_usm_h%rad_lw_ref = 0.0_wp
1659	surf_usm_h%rad_lw_res = 0.0_wp
1660	ENDIF
1661	DO l = 0, 3
1662	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_sw_in ) .AND. &
1663	surf_lsm_v(l)%ns > 0 ) THEN
1664	ALLOCATE( surf_lsm_v(l)%rad_sw_in(1:surf_lsm_v(l)%ns) )
1665	ALLOCATE( surf_lsm_v(l)%rad_sw_out(1:surf_lsm_v(l)%ns) )
1666	ALLOCATE( surf_lsm_v(l)%rad_sw_dir(1:surf_lsm_v(l)%ns) )
1667	ALLOCATE( surf_lsm_v(l)%rad_sw_dif(1:surf_lsm_v(l)%ns) )
1668	ALLOCATE( surf_lsm_v(l)%rad_sw_ref(1:surf_lsm_v(l)%ns) )
1669	ALLOCATE( surf_lsm_v(l)%rad_sw_res(1:surf_lsm_v(l)%ns) )
1670
1671	ALLOCATE( surf_lsm_v(l)%rad_lw_in(1:surf_lsm_v(l)%ns) )
1672	ALLOCATE( surf_lsm_v(l)%rad_lw_out(1:surf_lsm_v(l)%ns) )
1673	ALLOCATE( surf_lsm_v(l)%rad_lw_dif(1:surf_lsm_v(l)%ns) )
1674	ALLOCATE( surf_lsm_v(l)%rad_lw_ref(1:surf_lsm_v(l)%ns) )
1675	ALLOCATE( surf_lsm_v(l)%rad_lw_res(1:surf_lsm_v(l)%ns) )
1676
1677	surf_lsm_v(l)%rad_sw_in = 0.0_wp
1678	surf_lsm_v(l)%rad_sw_out = 0.0_wp
1679	surf_lsm_v(l)%rad_sw_dir = 0.0_wp
1680	surf_lsm_v(l)%rad_sw_dif = 0.0_wp
1681	surf_lsm_v(l)%rad_sw_ref = 0.0_wp
1682	surf_lsm_v(l)%rad_sw_res = 0.0_wp
1683
1684	surf_lsm_v(l)%rad_lw_in = 0.0_wp
1685	surf_lsm_v(l)%rad_lw_out = 0.0_wp
1686	surf_lsm_v(l)%rad_lw_dif = 0.0_wp
1687	surf_lsm_v(l)%rad_lw_ref = 0.0_wp
1688	surf_lsm_v(l)%rad_lw_res = 0.0_wp
1689	ENDIF
1690	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_sw_in ) .AND. &
1691	surf_usm_v(l)%ns > 0 ) THEN
1692	ALLOCATE( surf_usm_v(l)%rad_sw_in(1:surf_usm_v(l)%ns) )
1693	ALLOCATE( surf_usm_v(l)%rad_sw_out(1:surf_usm_v(l)%ns) )
1694	ALLOCATE( surf_usm_v(l)%rad_sw_dir(1:surf_usm_v(l)%ns) )
1695	ALLOCATE( surf_usm_v(l)%rad_sw_dif(1:surf_usm_v(l)%ns) )
1696	ALLOCATE( surf_usm_v(l)%rad_sw_ref(1:surf_usm_v(l)%ns) )
1697	ALLOCATE( surf_usm_v(l)%rad_sw_res(1:surf_usm_v(l)%ns) )
1698	ALLOCATE( surf_usm_v(l)%rad_lw_in(1:surf_usm_v(l)%ns) )
1699	ALLOCATE( surf_usm_v(l)%rad_lw_out(1:surf_usm_v(l)%ns) )
1700	ALLOCATE( surf_usm_v(l)%rad_lw_dif(1:surf_usm_v(l)%ns) )
1701	ALLOCATE( surf_usm_v(l)%rad_lw_ref(1:surf_usm_v(l)%ns) )
1702	ALLOCATE( surf_usm_v(l)%rad_lw_res(1:surf_usm_v(l)%ns) )
1703	surf_usm_v(l)%rad_sw_in = 0.0_wp
1704	surf_usm_v(l)%rad_sw_out = 0.0_wp
1705	surf_usm_v(l)%rad_sw_dir = 0.0_wp
1706	surf_usm_v(l)%rad_sw_dif = 0.0_wp
1707	surf_usm_v(l)%rad_sw_ref = 0.0_wp
1708	surf_usm_v(l)%rad_sw_res = 0.0_wp
1709	surf_usm_v(l)%rad_lw_in = 0.0_wp
1710	surf_usm_v(l)%rad_lw_out = 0.0_wp
1711	surf_usm_v(l)%rad_lw_dif = 0.0_wp
1712	surf_usm_v(l)%rad_lw_ref = 0.0_wp
1713	surf_usm_v(l)%rad_lw_res = 0.0_wp
1714	ENDIF
1715	ENDDO
1716	!
1717	!-- Fix net radiation in case of radiation_scheme = 'constant'
1718	IF ( radiation_scheme == 'constant' ) THEN
1719	IF ( ALLOCATED( surf_lsm_h%rad_net ) ) &
1720	surf_lsm_h%rad_net = net_radiation
1721	IF ( ALLOCATED( surf_usm_h%rad_net ) ) &
1722	surf_usm_h%rad_net = net_radiation
1723	!
1724	!-- Todo: weight with inclination angle
1725	DO l = 0, 3
1726	IF ( ALLOCATED( surf_lsm_v(l)%rad_net ) ) &
1727	surf_lsm_v(l)%rad_net = net_radiation
1728	IF ( ALLOCATED( surf_usm_v(l)%rad_net ) ) &
1729	surf_usm_v(l)%rad_net = net_radiation
1730	ENDDO
1731	! radiation = .FALSE.
1732	!
1733	!-- Calculate orbital constants
1734	ELSE
1735	decl_1 = SIN(23.45_wp * pi / 180.0_wp)
1736	decl_2 = 2.0_wp * pi / 365.0_wp
1737	decl_3 = decl_2 * 81.0_wp
1738	lat = latitude * pi / 180.0_wp
1739	lon = longitude * pi / 180.0_wp
1740	ENDIF
1741
1742	IF ( radiation_scheme == 'clear-sky' .OR. &
1743	radiation_scheme == 'constant' .OR. &
1744	radiation_scheme == 'external' ) THEN
1745	!
1746	!-- Allocate arrays for incoming/outgoing short/longwave radiation
1747	IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN
1748	ALLOCATE ( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) )
1749	ENDIF
1750	IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN
1751	ALLOCATE ( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) )
1752	ENDIF
1753
1754	IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN
1755	ALLOCATE ( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) )
1756	ENDIF
1757	IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN
1758	ALLOCATE ( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) )
1759	ENDIF
1760
1761	!
1762	!-- Allocate average arrays for incoming/outgoing short/longwave radiation
1763	IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN
1764	ALLOCATE ( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
1765	ENDIF
1766	IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN
1767	ALLOCATE ( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
1768	ENDIF
1769
1770	IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN
1771	ALLOCATE ( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
1772	ENDIF
1773	IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN
1774	ALLOCATE ( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
1775	ENDIF
1776	!
1777	!-- Allocate arrays for broadband albedo, and level 1 initialization
1778	!-- via namelist paramter, unless not already allocated.
1779	IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) THEN
1780	ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) )
1781	surf_lsm_h%albedo = albedo
1782	ENDIF
1783	IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) THEN
1784	ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) )
1785	surf_usm_h%albedo = albedo
1786	ENDIF
1787
1788	DO l = 0, 3
1789	IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) THEN
1790	ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) )
1791	surf_lsm_v(l)%albedo = albedo
1792	ENDIF
1793	IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) THEN
1794	ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) )
1795	surf_usm_v(l)%albedo = albedo
1796	ENDIF
1797	ENDDO
1798	!
1799	!-- Level 2 initialization of broadband albedo via given albedo_type.
1800	!-- Only if albedo_type is non-zero. In case of urban surface and
1801	!-- input data is read from ASCII file, albedo_type will be zero, so that
1802	!-- albedo won't be overwritten.
1803	DO m = 1, surf_lsm_h%ns
1804	IF ( surf_lsm_h%albedo_type(ind_veg_wall,m) /= 0 ) &
1805	surf_lsm_h%albedo(ind_veg_wall,m) = &
1806	albedo_pars(0,surf_lsm_h%albedo_type(ind_veg_wall,m))
1807	IF ( surf_lsm_h%albedo_type(ind_pav_green,m) /= 0 ) &
1808	surf_lsm_h%albedo(ind_pav_green,m) = &
1809	albedo_pars(0,surf_lsm_h%albedo_type(ind_pav_green,m))
1810	IF ( surf_lsm_h%albedo_type(ind_wat_win,m) /= 0 ) &
1811	surf_lsm_h%albedo(ind_wat_win,m) = &
1812	albedo_pars(0,surf_lsm_h%albedo_type(ind_wat_win,m))
1813	ENDDO
1814	DO m = 1, surf_usm_h%ns
1815	IF ( surf_usm_h%albedo_type(ind_veg_wall,m) /= 0 ) &
1816	surf_usm_h%albedo(ind_veg_wall,m) = &
1817	albedo_pars(0,surf_usm_h%albedo_type(ind_veg_wall,m))
1818	IF ( surf_usm_h%albedo_type(ind_pav_green,m) /= 0 ) &
1819	surf_usm_h%albedo(ind_pav_green,m) = &
1820	albedo_pars(0,surf_usm_h%albedo_type(ind_pav_green,m))
1821	IF ( surf_usm_h%albedo_type(ind_wat_win,m) /= 0 ) &
1822	surf_usm_h%albedo(ind_wat_win,m) = &
1823	albedo_pars(0,surf_usm_h%albedo_type(ind_wat_win,m))
1824	ENDDO
1825
1826	DO l = 0, 3
1827	DO m = 1, surf_lsm_v(l)%ns
1828	IF ( surf_lsm_v(l)%albedo_type(ind_veg_wall,m) /= 0 ) &
1829	surf_lsm_v(l)%albedo(ind_veg_wall,m) = &
1830	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_veg_wall,m))
1831	IF ( surf_lsm_v(l)%albedo_type(ind_pav_green,m) /= 0 ) &
1832	surf_lsm_v(l)%albedo(ind_pav_green,m) = &
1833	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_pav_green,m))
1834	IF ( surf_lsm_v(l)%albedo_type(ind_wat_win,m) /= 0 ) &
1835	surf_lsm_v(l)%albedo(ind_wat_win,m) = &
1836	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_wat_win,m))
1837	ENDDO
1838	DO m = 1, surf_usm_v(l)%ns
1839	IF ( surf_usm_v(l)%albedo_type(ind_veg_wall,m) /= 0 ) &
1840	surf_usm_v(l)%albedo(ind_veg_wall,m) = &
1841	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_veg_wall,m))
1842	IF ( surf_usm_v(l)%albedo_type(ind_pav_green,m) /= 0 ) &
1843	surf_usm_v(l)%albedo(ind_pav_green,m) = &
1844	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_pav_green,m))
1845	IF ( surf_usm_v(l)%albedo_type(ind_wat_win,m) /= 0 ) &
1846	surf_usm_v(l)%albedo(ind_wat_win,m) = &
1847	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_wat_win,m))
1848	ENDDO
1849	ENDDO
1850
1851	!
1852	!-- Level 3 initialization at grid points where albedo type is zero.
1853	!-- This case, albedo is taken from file. In case of constant radiation
1854	!-- or clear sky, only broadband albedo is given.
1855	IF ( albedo_pars_f%from_file ) THEN
1856	!
1857	!-- Horizontal surfaces
1858	DO m = 1, surf_lsm_h%ns
1859	i = surf_lsm_h%i(m)
1860	j = surf_lsm_h%j(m)
1861	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1862	surf_lsm_h%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1863	surf_lsm_h%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1864	surf_lsm_h%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1865	ENDIF
1866	ENDDO
1867	DO m = 1, surf_usm_h%ns
1868	i = surf_usm_h%i(m)
1869	j = surf_usm_h%j(m)
1870	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1871	surf_usm_h%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1872	surf_usm_h%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1873	surf_usm_h%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1874	ENDIF
1875	ENDDO
1876	!
1877	!-- Vertical surfaces
1878	DO l = 0, 3
1879
1880	ioff = surf_lsm_v(l)%ioff
1881	joff = surf_lsm_v(l)%joff
1882	DO m = 1, surf_lsm_v(l)%ns
1883	i = surf_lsm_v(l)%i(m) + ioff
1884	j = surf_lsm_v(l)%j(m) + joff
1885	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1886	surf_lsm_v(l)%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1887	surf_lsm_v(l)%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1888	surf_lsm_v(l)%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1889	ENDIF
1890	ENDDO
1891
1892	ioff = surf_usm_v(l)%ioff
1893	joff = surf_usm_v(l)%joff
1894	DO m = 1, surf_usm_v(l)%ns
1895	i = surf_usm_v(l)%i(m) + ioff
1896	j = surf_usm_v(l)%j(m) + joff
1897	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1898	surf_usm_v(l)%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1899	surf_usm_v(l)%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1900	surf_usm_v(l)%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1901	ENDIF
1902	ENDDO
1903	ENDDO
1904
1905	ENDIF
1906	!
1907	!-- Read explicit albedo values from building surface pars. If present,
1908	!-- they override all less specific albedo values and force a albedo_type
1909	!-- to zero in order to take effect.
1910	IF ( building_surface_pars_f%from_file ) THEN
1911	DO m = 1, surf_usm_h%ns
1912	i = surf_usm_h%i(m)
1913	j = surf_usm_h%j(m)
1914	k = surf_usm_h%k(m)
1915	!
1916	!-- Iterate over surfaces in column, check height and orientation
1917	DO is = building_surface_pars_f%index_ji(1,j,i), &
1918	building_surface_pars_f%index_ji(2,j,i)
1919	IF ( building_surface_pars_f%coords(4,is) == -surf_usm_h%koff .AND. &
1920	building_surface_pars_f%coords(1,is) == k ) THEN
1921
1922	IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /= &
1923	building_surface_pars_f%fill ) THEN
1924	surf_usm_h%albedo(ind_veg_wall,m) = &
1925	building_surface_pars_f%pars(ind_s_alb_b_wall,is)
1926	surf_usm_h%albedo_type(ind_veg_wall,m) = 0
1927	ENDIF
1928
1929	IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /= &
1930	building_surface_pars_f%fill ) THEN
1931	surf_usm_h%albedo(ind_wat_win,m) = &
1932	building_surface_pars_f%pars(ind_s_alb_b_win,is)
1933	surf_usm_h%albedo_type(ind_wat_win,m) = 0
1934	ENDIF
1935
1936	IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /= &
1937	building_surface_pars_f%fill ) THEN
1938	surf_usm_h%albedo(ind_pav_green,m) = &
1939	building_surface_pars_f%pars(ind_s_alb_b_green,is)
1940	surf_usm_h%albedo_type(ind_pav_green,m) = 0
1941	ENDIF
1942
1943	EXIT ! surface was found and processed
1944	ENDIF
1945	ENDDO
1946	ENDDO
1947
1948	DO l = 0, 3
1949	DO m = 1, surf_usm_v(l)%ns
1950	i = surf_usm_v(l)%i(m)
1951	j = surf_usm_v(l)%j(m)
1952	k = surf_usm_v(l)%k(m)
1953	!
1954	!-- Iterate over surfaces in column, check height and orientation
1955	DO is = building_surface_pars_f%index_ji(1,j,i), &
1956	building_surface_pars_f%index_ji(2,j,i)
1957	IF ( building_surface_pars_f%coords(5,is) == -surf_usm_v(l)%joff .AND. &
1958	building_surface_pars_f%coords(6,is) == -surf_usm_v(l)%ioff .AND. &
1959	building_surface_pars_f%coords(1,is) == k ) THEN
1960
1961	IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /= &
1962	building_surface_pars_f%fill ) THEN
1963	surf_usm_v(l)%albedo(ind_veg_wall,m) = &
1964	building_surface_pars_f%pars(ind_s_alb_b_wall,is)
1965	surf_usm_v(l)%albedo_type(ind_veg_wall,m) = 0
1966	ENDIF
1967
1968	IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /= &
1969	building_surface_pars_f%fill ) THEN
1970	surf_usm_v(l)%albedo(ind_wat_win,m) = &
1971	building_surface_pars_f%pars(ind_s_alb_b_win,is)
1972	surf_usm_v(l)%albedo_type(ind_wat_win,m) = 0
1973	ENDIF
1974
1975	IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /= &
1976	building_surface_pars_f%fill ) THEN
1977	surf_usm_v(l)%albedo(ind_pav_green,m) = &
1978	building_surface_pars_f%pars(ind_s_alb_b_green,is)
1979	surf_usm_v(l)%albedo_type(ind_pav_green,m) = 0
1980	ENDIF
1981
1982	EXIT ! surface was found and processed
1983	ENDIF
1984	ENDDO
1985	ENDDO
1986	ENDDO
1987	ENDIF
1988	!
1989	!-- Initialization actions for RRTMG
1990	ELSEIF ( radiation_scheme == 'rrtmg' ) THEN
1991	#if defined ( __rrtmg )
1992	!
1993	!-- Allocate albedos for short/longwave radiation, horizontal surfaces
1994	!-- for wall/green/window (USM) or vegetation/pavement/water surfaces
1995	!-- (LSM).
1996	ALLOCATE ( surf_lsm_h%aldif(0:2,1:surf_lsm_h%ns) )
1997	ALLOCATE ( surf_lsm_h%aldir(0:2,1:surf_lsm_h%ns) )
1998	ALLOCATE ( surf_lsm_h%asdif(0:2,1:surf_lsm_h%ns) )
1999	ALLOCATE ( surf_lsm_h%asdir(0:2,1:surf_lsm_h%ns) )
2000	ALLOCATE ( surf_lsm_h%rrtm_aldif(0:2,1:surf_lsm_h%ns) )
2001	ALLOCATE ( surf_lsm_h%rrtm_aldir(0:2,1:surf_lsm_h%ns) )
2002	ALLOCATE ( surf_lsm_h%rrtm_asdif(0:2,1:surf_lsm_h%ns) )
2003	ALLOCATE ( surf_lsm_h%rrtm_asdir(0:2,1:surf_lsm_h%ns) )
2004
2005	ALLOCATE ( surf_usm_h%aldif(0:2,1:surf_usm_h%ns) )
2006	ALLOCATE ( surf_usm_h%aldir(0:2,1:surf_usm_h%ns) )
2007	ALLOCATE ( surf_usm_h%asdif(0:2,1:surf_usm_h%ns) )
2008	ALLOCATE ( surf_usm_h%asdir(0:2,1:surf_usm_h%ns) )
2009	ALLOCATE ( surf_usm_h%rrtm_aldif(0:2,1:surf_usm_h%ns) )
2010	ALLOCATE ( surf_usm_h%rrtm_aldir(0:2,1:surf_usm_h%ns) )
2011	ALLOCATE ( surf_usm_h%rrtm_asdif(0:2,1:surf_usm_h%ns) )
2012	ALLOCATE ( surf_usm_h%rrtm_asdir(0:2,1:surf_usm_h%ns) )
2013
2014	!
2015	!-- Allocate broadband albedo (temporary for the current radiation
2016	!-- implementations)
2017	IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) &
2018	ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) )
2019	IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) &
2020	ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) )
2021
2022	!
2023	!-- Allocate albedos for short/longwave radiation, vertical surfaces
2024	DO l = 0, 3
2025
2026	ALLOCATE ( surf_lsm_v(l)%aldif(0:2,1:surf_lsm_v(l)%ns) )
2027	ALLOCATE ( surf_lsm_v(l)%aldir(0:2,1:surf_lsm_v(l)%ns) )
2028	ALLOCATE ( surf_lsm_v(l)%asdif(0:2,1:surf_lsm_v(l)%ns) )
2029	ALLOCATE ( surf_lsm_v(l)%asdir(0:2,1:surf_lsm_v(l)%ns) )
2030
2031	ALLOCATE ( surf_lsm_v(l)%rrtm_aldif(0:2,1:surf_lsm_v(l)%ns) )
2032	ALLOCATE ( surf_lsm_v(l)%rrtm_aldir(0:2,1:surf_lsm_v(l)%ns) )
2033	ALLOCATE ( surf_lsm_v(l)%rrtm_asdif(0:2,1:surf_lsm_v(l)%ns) )
2034	ALLOCATE ( surf_lsm_v(l)%rrtm_asdir(0:2,1:surf_lsm_v(l)%ns) )
2035
2036	ALLOCATE ( surf_usm_v(l)%aldif(0:2,1:surf_usm_v(l)%ns) )
2037	ALLOCATE ( surf_usm_v(l)%aldir(0:2,1:surf_usm_v(l)%ns) )
2038	ALLOCATE ( surf_usm_v(l)%asdif(0:2,1:surf_usm_v(l)%ns) )
2039	ALLOCATE ( surf_usm_v(l)%asdir(0:2,1:surf_usm_v(l)%ns) )
2040
2041	ALLOCATE ( surf_usm_v(l)%rrtm_aldif(0:2,1:surf_usm_v(l)%ns) )
2042	ALLOCATE ( surf_usm_v(l)%rrtm_aldir(0:2,1:surf_usm_v(l)%ns) )
2043	ALLOCATE ( surf_usm_v(l)%rrtm_asdif(0:2,1:surf_usm_v(l)%ns) )
2044	ALLOCATE ( surf_usm_v(l)%rrtm_asdir(0:2,1:surf_usm_v(l)%ns) )
2045	!
2046	!-- Allocate broadband albedo (temporary for the current radiation
2047	!-- implementations)
2048	IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) &
2049	ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) )
2050	IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) &
2051	ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) )
2052
2053	ENDDO
2054	!
2055	!-- Level 1 initialization of spectral albedos via namelist
2056	!-- paramters. Please note, this case all surface tiles are initialized
2057	!-- the same.
2058	IF ( surf_lsm_h%ns > 0 ) THEN
2059	surf_lsm_h%aldif = albedo_lw_dif
2060	surf_lsm_h%aldir = albedo_lw_dir
2061	surf_lsm_h%asdif = albedo_sw_dif
2062	surf_lsm_h%asdir = albedo_sw_dir
2063	surf_lsm_h%albedo = albedo_sw_dif
2064	ENDIF
2065	IF ( surf_usm_h%ns > 0 ) THEN
2066	IF ( surf_usm_h%albedo_from_ascii ) THEN
2067	surf_usm_h%aldif = surf_usm_h%albedo
2068	surf_usm_h%aldir = surf_usm_h%albedo
2069	surf_usm_h%asdif = surf_usm_h%albedo
2070	surf_usm_h%asdir = surf_usm_h%albedo
2071	ELSE
2072	surf_usm_h%aldif = albedo_lw_dif
2073	surf_usm_h%aldir = albedo_lw_dir
2074	surf_usm_h%asdif = albedo_sw_dif
2075	surf_usm_h%asdir = albedo_sw_dir
2076	surf_usm_h%albedo = albedo_sw_dif
2077	ENDIF
2078	ENDIF
2079
2080	DO l = 0, 3
2081
2082	IF ( surf_lsm_v(l)%ns > 0 ) THEN
2083	surf_lsm_v(l)%aldif = albedo_lw_dif
2084	surf_lsm_v(l)%aldir = albedo_lw_dir
2085	surf_lsm_v(l)%asdif = albedo_sw_dif
2086	surf_lsm_v(l)%asdir = albedo_sw_dir
2087	surf_lsm_v(l)%albedo = albedo_sw_dif
2088	ENDIF
2089
2090	IF ( surf_usm_v(l)%ns > 0 ) THEN
2091	IF ( surf_usm_v(l)%albedo_from_ascii ) THEN
2092	surf_usm_v(l)%aldif = surf_usm_v(l)%albedo
2093	surf_usm_v(l)%aldir = surf_usm_v(l)%albedo
2094	surf_usm_v(l)%asdif = surf_usm_v(l)%albedo
2095	surf_usm_v(l)%asdir = surf_usm_v(l)%albedo
2096	ELSE
2097	surf_usm_v(l)%aldif = albedo_lw_dif
2098	surf_usm_v(l)%aldir = albedo_lw_dir
2099	surf_usm_v(l)%asdif = albedo_sw_dif
2100	surf_usm_v(l)%asdir = albedo_sw_dir
2101	ENDIF
2102	ENDIF
2103	ENDDO
2104
2105	!
2106	!-- Level 2 initialization of spectral albedos via albedo_type.
2107	!-- Please note, for natural- and urban-type surfaces, a tile approach
2108	!-- is applied so that the resulting albedo is calculated via the weighted
2109	!-- average of respective surface fractions.
2110	DO m = 1, surf_lsm_h%ns
2111	!
2112	!-- Spectral albedos for vegetation/pavement/water surfaces
2113	DO ind_type = 0, 2
2114	IF ( surf_lsm_h%albedo_type(ind_type,m) /= 0 ) THEN
2115	surf_lsm_h%aldif(ind_type,m) = &
2116	albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m))
2117	surf_lsm_h%asdif(ind_type,m) = &
2118	albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m))
2119	surf_lsm_h%aldir(ind_type,m) = &
2120	albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m))
2121	surf_lsm_h%asdir(ind_type,m) = &
2122	albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m))
2123	surf_lsm_h%albedo(ind_type,m) = &
2124	albedo_pars(0,surf_lsm_h%albedo_type(ind_type,m))
2125	ENDIF
2126	ENDDO
2127
2128	ENDDO
2129	!
2130	!-- For urban surface only if albedo has not been already initialized
2131	!-- in the urban-surface model via the ASCII file.
2132	IF ( .NOT. surf_usm_h%albedo_from_ascii ) THEN
2133	DO m = 1, surf_usm_h%ns
2134	!
2135	!-- Spectral albedos for wall/green/window surfaces
2136	DO ind_type = 0, 2
2137	IF ( surf_usm_h%albedo_type(ind_type,m) /= 0 ) THEN
2138	surf_usm_h%aldif(ind_type,m) = &
2139	albedo_pars(1,surf_usm_h%albedo_type(ind_type,m))
2140	surf_usm_h%asdif(ind_type,m) = &
2141	albedo_pars(2,surf_usm_h%albedo_type(ind_type,m))
2142	surf_usm_h%aldir(ind_type,m) = &
2143	albedo_pars(1,surf_usm_h%albedo_type(ind_type,m))
2144	surf_usm_h%asdir(ind_type,m) = &
2145	albedo_pars(2,surf_usm_h%albedo_type(ind_type,m))
2146	surf_usm_h%albedo(ind_type,m) = &
2147	albedo_pars(0,surf_usm_h%albedo_type(ind_type,m))
2148	ENDIF
2149	ENDDO
2150
2151	ENDDO
2152	ENDIF
2153
2154	DO l = 0, 3
2155
2156	DO m = 1, surf_lsm_v(l)%ns
2157	!
2158	!-- Spectral albedos for vegetation/pavement/water surfaces
2159	DO ind_type = 0, 2
2160	IF ( surf_lsm_v(l)%albedo_type(ind_type,m) /= 0 ) THEN
2161	surf_lsm_v(l)%aldif(ind_type,m) = &
2162	albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m))
2163	surf_lsm_v(l)%asdif(ind_type,m) = &
2164	albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m))
2165	surf_lsm_v(l)%aldir(ind_type,m) = &
2166	albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m))
2167	surf_lsm_v(l)%asdir(ind_type,m) = &
2168	albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m))
2169	surf_lsm_v(l)%albedo(ind_type,m) = &
2170	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_type,m))
2171	ENDIF
2172	ENDDO
2173	ENDDO
2174	!
2175	!-- For urban surface only if albedo has not been already initialized
2176	!-- in the urban-surface model via the ASCII file.
2177	IF ( .NOT. surf_usm_v(l)%albedo_from_ascii ) THEN
2178	DO m = 1, surf_usm_v(l)%ns
2179	!
2180	!-- Spectral albedos for wall/green/window surfaces
2181	DO ind_type = 0, 2
2182	IF ( surf_usm_v(l)%albedo_type(ind_type,m) /= 0 ) THEN
2183	surf_usm_v(l)%aldif(ind_type,m) = &
2184	albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m))
2185	surf_usm_v(l)%asdif(ind_type,m) = &
2186	albedo_pars(2,surf_usm_v(l)%albedo_type(ind_type,m))
2187	surf_usm_v(l)%aldir(ind_type,m) = &
2188	albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m))
2189	surf_usm_v(l)%asdir(ind_type,m) = &
2190	albedo_pars(2,surf_usm_v(l)%albedo_type(ind_type,m))
2191	surf_usm_v(l)%albedo(ind_type,m) = &
2192	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_type,m))
2193	ENDIF
2194	ENDDO
2195
2196	ENDDO
2197	ENDIF
2198	ENDDO
2199	!
2200	!-- Level 3 initialization at grid points where albedo type is zero.
2201	!-- This case, spectral albedos are taken from file if available
2202	IF ( albedo_pars_f%from_file ) THEN
2203	!
2204	!-- Horizontal
2205	DO m = 1, surf_lsm_h%ns
2206	i = surf_lsm_h%i(m)
2207	j = surf_lsm_h%j(m)
2208	!
2209	!-- Spectral albedos for vegetation/pavement/water surfaces
2210	DO ind_type = 0, 2
2211	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) &
2212	surf_lsm_h%albedo(ind_type,m) = &
2213	albedo_pars_f%pars_xy(0,j,i)
2214	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) &
2215	surf_lsm_h%aldir(ind_type,m) = &
2216	albedo_pars_f%pars_xy(1,j,i)
2217	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) &
2218	surf_lsm_h%aldif(ind_type,m) = &
2219	albedo_pars_f%pars_xy(1,j,i)
2220	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) &
2221	surf_lsm_h%asdir(ind_type,m) = &
2222	albedo_pars_f%pars_xy(2,j,i)
2223	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) &
2224	surf_lsm_h%asdif(ind_type,m) = &
2225	albedo_pars_f%pars_xy(2,j,i)
2226	ENDDO
2227	ENDDO
2228	!
2229	!-- For urban surface only if albedo has not been already initialized
2230	!-- in the urban-surface model via the ASCII file.
2231	IF ( .NOT. surf_usm_h%albedo_from_ascii ) THEN
2232	DO m = 1, surf_usm_h%ns
2233	i = surf_usm_h%i(m)
2234	j = surf_usm_h%j(m)
2235	!
2236	!-- Broadband albedos for wall/green/window surfaces
2237	DO ind_type = 0, 2
2238	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )&
2239	surf_usm_h%albedo(ind_type,m) = &
2240	albedo_pars_f%pars_xy(0,j,i)
2241	ENDDO
2242	!
2243	!-- Spectral albedos especially for building wall surfaces
2244	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) THEN
2245	surf_usm_h%aldir(ind_veg_wall,m) = &
2246	albedo_pars_f%pars_xy(1,j,i)
2247	surf_usm_h%aldif(ind_veg_wall,m) = &
2248	albedo_pars_f%pars_xy(1,j,i)
2249	ENDIF
2250	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) THEN
2251	surf_usm_h%asdir(ind_veg_wall,m) = &
2252	albedo_pars_f%pars_xy(2,j,i)
2253	surf_usm_h%asdif(ind_veg_wall,m) = &
2254	albedo_pars_f%pars_xy(2,j,i)
2255	ENDIF
2256	!
2257	!-- Spectral albedos especially for building green surfaces
2258	IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill ) THEN
2259	surf_usm_h%aldir(ind_pav_green,m) = &
2260	albedo_pars_f%pars_xy(3,j,i)
2261	surf_usm_h%aldif(ind_pav_green,m) = &
2262	albedo_pars_f%pars_xy(3,j,i)
2263	ENDIF
2264	IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill ) THEN
2265	surf_usm_h%asdir(ind_pav_green,m) = &
2266	albedo_pars_f%pars_xy(4,j,i)
2267	surf_usm_h%asdif(ind_pav_green,m) = &
2268	albedo_pars_f%pars_xy(4,j,i)
2269	ENDIF
2270	!
2271	!-- Spectral albedos especially for building window surfaces
2272	IF ( albedo_pars_f%pars_xy(5,j,i) /= albedo_pars_f%fill ) THEN
2273	surf_usm_h%aldir(ind_wat_win,m) = &
2274	albedo_pars_f%pars_xy(5,j,i)
2275	surf_usm_h%aldif(ind_wat_win,m) = &
2276	albedo_pars_f%pars_xy(5,j,i)
2277	ENDIF
2278	IF ( albedo_pars_f%pars_xy(6,j,i) /= albedo_pars_f%fill ) THEN
2279	surf_usm_h%asdir(ind_wat_win,m) = &
2280	albedo_pars_f%pars_xy(6,j,i)
2281	surf_usm_h%asdif(ind_wat_win,m) = &
2282	albedo_pars_f%pars_xy(6,j,i)
2283	ENDIF
2284
2285	ENDDO
2286	ENDIF
2287	!
2288	!-- Vertical
2289	DO l = 0, 3
2290	ioff = surf_lsm_v(l)%ioff
2291	joff = surf_lsm_v(l)%joff
2292
2293	DO m = 1, surf_lsm_v(l)%ns
2294	i = surf_lsm_v(l)%i(m)
2295	j = surf_lsm_v(l)%j(m)
2296	!
2297	!-- Spectral albedos for vegetation/pavement/water surfaces
2298	DO ind_type = 0, 2
2299	IF ( albedo_pars_f%pars_xy(0,j+joff,i+ioff) /= &
2300	albedo_pars_f%fill ) &
2301	surf_lsm_v(l)%albedo(ind_type,m) = &
2302	albedo_pars_f%pars_xy(0,j+joff,i+ioff)
2303	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2304	albedo_pars_f%fill ) &
2305	surf_lsm_v(l)%aldir(ind_type,m) = &
2306	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2307	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2308	albedo_pars_f%fill ) &
2309	surf_lsm_v(l)%aldif(ind_type,m) = &
2310	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2311	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2312	albedo_pars_f%fill ) &
2313	surf_lsm_v(l)%asdir(ind_type,m) = &
2314	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2315	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2316	albedo_pars_f%fill ) &
2317	surf_lsm_v(l)%asdif(ind_type,m) = &
2318	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2319	ENDDO
2320	ENDDO
2321	!
2322	!-- For urban surface only if albedo has not been already initialized
2323	!-- in the urban-surface model via the ASCII file.
2324	IF ( .NOT. surf_usm_v(l)%albedo_from_ascii ) THEN
2325	ioff = surf_usm_v(l)%ioff
2326	joff = surf_usm_v(l)%joff
2327
2328	DO m = 1, surf_usm_v(l)%ns
2329	i = surf_usm_v(l)%i(m)
2330	j = surf_usm_v(l)%j(m)
2331	!
2332	!-- Broadband albedos for wall/green/window surfaces
2333	DO ind_type = 0, 2
2334	IF ( albedo_pars_f%pars_xy(0,j+joff,i+ioff) /= &
2335	albedo_pars_f%fill ) &
2336	surf_usm_v(l)%albedo(ind_type,m) = &
2337	albedo_pars_f%pars_xy(0,j+joff,i+ioff)
2338	ENDDO
2339	!
2340	!-- Spectral albedos especially for building wall surfaces
2341	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2342	albedo_pars_f%fill ) THEN
2343	surf_usm_v(l)%aldir(ind_veg_wall,m) = &
2344	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2345	surf_usm_v(l)%aldif(ind_veg_wall,m) = &
2346	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2347	ENDIF
2348	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2349	albedo_pars_f%fill ) THEN
2350	surf_usm_v(l)%asdir(ind_veg_wall,m) = &
2351	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2352	surf_usm_v(l)%asdif(ind_veg_wall,m) = &
2353	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2354	ENDIF
2355	!
2356	!-- Spectral albedos especially for building green surfaces
2357	IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= &
2358	albedo_pars_f%fill ) THEN
2359	surf_usm_v(l)%aldir(ind_pav_green,m) = &
2360	albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2361	surf_usm_v(l)%aldif(ind_pav_green,m) = &
2362	albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2363	ENDIF
2364	IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= &
2365	albedo_pars_f%fill ) THEN
2366	surf_usm_v(l)%asdir(ind_pav_green,m) = &
2367	albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2368	surf_usm_v(l)%asdif(ind_pav_green,m) = &
2369	albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2370	ENDIF
2371	!
2372	!-- Spectral albedos especially for building window surfaces
2373	IF ( albedo_pars_f%pars_xy(5,j+joff,i+ioff) /= &
2374	albedo_pars_f%fill ) THEN
2375	surf_usm_v(l)%aldir(ind_wat_win,m) = &
2376	albedo_pars_f%pars_xy(5,j+joff,i+ioff)
2377	surf_usm_v(l)%aldif(ind_wat_win,m) = &
2378	albedo_pars_f%pars_xy(5,j+joff,i+ioff)
2379	ENDIF
2380	IF ( albedo_pars_f%pars_xy(6,j+joff,i+ioff) /= &
2381	albedo_pars_f%fill ) THEN
2382	surf_usm_v(l)%asdir(ind_wat_win,m) = &
2383	albedo_pars_f%pars_xy(6,j+joff,i+ioff)
2384	surf_usm_v(l)%asdif(ind_wat_win,m) = &
2385	albedo_pars_f%pars_xy(6,j+joff,i+ioff)
2386	ENDIF
2387	ENDDO
2388	ENDIF
2389	ENDDO
2390
2391	ENDIF
2392	!
2393	!-- Read explicit albedo values from building surface pars. If present,
2394	!-- they override all less specific albedo values and force a albedo_type
2395	!-- to zero in order to take effect.
2396	IF ( building_surface_pars_f%from_file ) THEN
2397	DO m = 1, surf_usm_h%ns
2398	i = surf_usm_h%i(m)
2399	j = surf_usm_h%j(m)
2400	k = surf_usm_h%k(m)
2401	!
2402	!-- Iterate over surfaces in column, check height and orientation
2403	DO is = building_surface_pars_f%index_ji(1,j,i), &
2404	building_surface_pars_f%index_ji(2,j,i)
2405	IF ( building_surface_pars_f%coords(4,is) == -surf_usm_h%koff .AND. &
2406	building_surface_pars_f%coords(1,is) == k ) THEN
2407
2408	IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /= &
2409	building_surface_pars_f%fill ) THEN
2410	surf_usm_h%albedo(ind_veg_wall,m) = &
2411	building_surface_pars_f%pars(ind_s_alb_b_wall,is)
2412	surf_usm_h%albedo_type(ind_veg_wall,m) = 0
2413	ENDIF
2414
2415	IF ( building_surface_pars_f%pars(ind_s_alb_l_wall,is) /= &
2416	building_surface_pars_f%fill ) THEN
2417	surf_usm_h%aldir(ind_veg_wall,m) = &
2418	building_surface_pars_f%pars(ind_s_alb_l_wall,is)
2419	surf_usm_h%aldif(ind_veg_wall,m) = &
2420	building_surface_pars_f%pars(ind_s_alb_l_wall,is)
2421	surf_usm_h%albedo_type(ind_veg_wall,m) = 0
2422	ENDIF
2423
2424	IF ( building_surface_pars_f%pars(ind_s_alb_s_wall,is) /= &
2425	building_surface_pars_f%fill ) THEN
2426	surf_usm_h%asdir(ind_veg_wall,m) = &
2427	building_surface_pars_f%pars(ind_s_alb_s_wall,is)
2428	surf_usm_h%asdif(ind_veg_wall,m) = &
2429	building_surface_pars_f%pars(ind_s_alb_s_wall,is)
2430	surf_usm_h%albedo_type(ind_veg_wall,m) = 0
2431	ENDIF
2432
2433	IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /= &
2434	building_surface_pars_f%fill ) THEN
2435	surf_usm_h%albedo(ind_wat_win,m) = &
2436	building_surface_pars_f%pars(ind_s_alb_b_win,is)
2437	surf_usm_h%albedo_type(ind_wat_win,m) = 0
2438	ENDIF
2439
2440	IF ( building_surface_pars_f%pars(ind_s_alb_l_win,is) /= &
2441	building_surface_pars_f%fill ) THEN
2442	surf_usm_h%aldir(ind_wat_win,m) = &
2443	building_surface_pars_f%pars(ind_s_alb_l_win,is)
2444	surf_usm_h%aldif(ind_wat_win,m) = &
2445	building_surface_pars_f%pars(ind_s_alb_l_win,is)
2446	surf_usm_h%albedo_type(ind_wat_win,m) = 0
2447	ENDIF
2448
2449	IF ( building_surface_pars_f%pars(ind_s_alb_s_win,is) /= &
2450	building_surface_pars_f%fill ) THEN
2451	surf_usm_h%asdir(ind_wat_win,m) = &
2452	building_surface_pars_f%pars(ind_s_alb_s_win,is)
2453	surf_usm_h%asdif(ind_wat_win,m) = &
2454	building_surface_pars_f%pars(ind_s_alb_s_win,is)
2455	surf_usm_h%albedo_type(ind_wat_win,m) = 0
2456	ENDIF
2457
2458	IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /= &
2459	building_surface_pars_f%fill ) THEN
2460	surf_usm_h%albedo(ind_pav_green,m) = &
2461	building_surface_pars_f%pars(ind_s_alb_b_green,is)
2462	surf_usm_h%albedo_type(ind_pav_green,m) = 0
2463	ENDIF
2464
2465	IF ( building_surface_pars_f%pars(ind_s_alb_l_green,is) /= &
2466	building_surface_pars_f%fill ) THEN
2467	surf_usm_h%aldir(ind_pav_green,m) = &
2468	building_surface_pars_f%pars(ind_s_alb_l_green,is)
2469	surf_usm_h%aldif(ind_pav_green,m) = &
2470	building_surface_pars_f%pars(ind_s_alb_l_green,is)
2471	surf_usm_h%albedo_type(ind_pav_green,m) = 0
2472	ENDIF
2473
2474	IF ( building_surface_pars_f%pars(ind_s_alb_s_green,is) /= &
2475	building_surface_pars_f%fill ) THEN
2476	surf_usm_h%asdir(ind_pav_green,m) = &
2477	building_surface_pars_f%pars(ind_s_alb_s_green,is)
2478	surf_usm_h%asdif(ind_pav_green,m) = &
2479	building_surface_pars_f%pars(ind_s_alb_s_green,is)
2480	surf_usm_h%albedo_type(ind_pav_green,m) = 0
2481	ENDIF
2482
2483	EXIT ! surface was found and processed
2484	ENDIF
2485	ENDDO
2486	ENDDO
2487
2488	DO l = 0, 3
2489	DO m = 1, surf_usm_v(l)%ns
2490	i = surf_usm_v(l)%i(m)
2491	j = surf_usm_v(l)%j(m)
2492	k = surf_usm_v(l)%k(m)
2493	!
2494	!-- Iterate over surfaces in column, check height and orientation
2495	DO is = building_surface_pars_f%index_ji(1,j,i), &
2496	building_surface_pars_f%index_ji(2,j,i)
2497	IF ( building_surface_pars_f%coords(5,is) == -surf_usm_v(l)%joff .AND. &
2498	building_surface_pars_f%coords(6,is) == -surf_usm_v(l)%ioff .AND. &
2499	building_surface_pars_f%coords(1,is) == k ) THEN
2500
2501	IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /= &
2502	building_surface_pars_f%fill ) THEN
2503	surf_usm_v(l)%albedo(ind_veg_wall,m) = &
2504	building_surface_pars_f%pars(ind_s_alb_b_wall,is)
2505	surf_usm_v(l)%albedo_type(ind_veg_wall,m) = 0
2506	ENDIF
2507
2508	IF ( building_surface_pars_f%pars(ind_s_alb_l_wall,is) /= &
2509	building_surface_pars_f%fill ) THEN
2510	surf_usm_v(l)%aldir(ind_veg_wall,m) = &
2511	building_surface_pars_f%pars(ind_s_alb_l_wall,is)
2512	surf_usm_v(l)%aldif(ind_veg_wall,m) = &
2513	building_surface_pars_f%pars(ind_s_alb_l_wall,is)
2514	surf_usm_v(l)%albedo_type(ind_veg_wall,m) = 0
2515	ENDIF
2516
2517	IF ( building_surface_pars_f%pars(ind_s_alb_s_wall,is) /= &
2518	building_surface_pars_f%fill ) THEN
2519	surf_usm_v(l)%asdir(ind_veg_wall,m) = &
2520	building_surface_pars_f%pars(ind_s_alb_s_wall,is)
2521	surf_usm_v(l)%asdif(ind_veg_wall,m) = &
2522	building_surface_pars_f%pars(ind_s_alb_s_wall,is)
2523	surf_usm_v(l)%albedo_type(ind_veg_wall,m) = 0
2524	ENDIF
2525
2526	IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /= &
2527	building_surface_pars_f%fill ) THEN
2528	surf_usm_v(l)%albedo(ind_wat_win,m) = &
2529	building_surface_pars_f%pars(ind_s_alb_b_win,is)
2530	surf_usm_v(l)%albedo_type(ind_wat_win,m) = 0
2531	ENDIF
2532
2533	IF ( building_surface_pars_f%pars(ind_s_alb_l_win,is) /= &
2534	building_surface_pars_f%fill ) THEN
2535	surf_usm_v(l)%aldir(ind_wat_win,m) = &
2536	building_surface_pars_f%pars(ind_s_alb_l_win,is)
2537	surf_usm_v(l)%aldif(ind_wat_win,m) = &
2538	building_surface_pars_f%pars(ind_s_alb_l_win,is)
2539	surf_usm_v(l)%albedo_type(ind_wat_win,m) = 0
2540	ENDIF
2541
2542	IF ( building_surface_pars_f%pars(ind_s_alb_s_win,is) /= &
2543	building_surface_pars_f%fill ) THEN
2544	surf_usm_v(l)%asdir(ind_wat_win,m) = &
2545	building_surface_pars_f%pars(ind_s_alb_s_win,is)
2546	surf_usm_v(l)%asdif(ind_wat_win,m) = &
2547	building_surface_pars_f%pars(ind_s_alb_s_win,is)
2548	surf_usm_v(l)%albedo_type(ind_wat_win,m) = 0
2549	ENDIF
2550
2551	IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /= &
2552	building_surface_pars_f%fill ) THEN
2553	surf_usm_v(l)%albedo(ind_pav_green,m) = &
2554	building_surface_pars_f%pars(ind_s_alb_b_green,is)
2555	surf_usm_v(l)%albedo_type(ind_pav_green,m) = 0
2556	ENDIF
2557
2558	IF ( building_surface_pars_f%pars(ind_s_alb_l_green,is) /= &
2559	building_surface_pars_f%fill ) THEN
2560	surf_usm_v(l)%aldir(ind_pav_green,m) = &
2561	building_surface_pars_f%pars(ind_s_alb_l_green,is)
2562	surf_usm_v(l)%aldif(ind_pav_green,m) = &
2563	building_surface_pars_f%pars(ind_s_alb_l_green,is)
2564	surf_usm_v(l)%albedo_type(ind_pav_green,m) = 0
2565	ENDIF
2566
2567	IF ( building_surface_pars_f%pars(ind_s_alb_s_green,is) /= &
2568	building_surface_pars_f%fill ) THEN
2569	surf_usm_v(l)%asdir(ind_pav_green,m) = &
2570	building_surface_pars_f%pars(ind_s_alb_s_green,is)
2571	surf_usm_v(l)%asdif(ind_pav_green,m) = &
2572	building_surface_pars_f%pars(ind_s_alb_s_green,is)
2573	surf_usm_v(l)%albedo_type(ind_pav_green,m) = 0
2574	ENDIF
2575
2576	EXIT ! surface was found and processed
2577	ENDIF
2578	ENDDO
2579	ENDDO
2580	ENDDO
2581	ENDIF
2582
2583	!
2584	!-- Calculate initial values of current (cosine of) the zenith angle and
2585	!-- whether the sun is up
2586	CALL get_date_time( time_since_reference_point, &
2587	day_of_year=day_of_year, &
2588	second_of_day=second_of_day )
2589	CALL calc_zenith( day_of_year, second_of_day )
2590	!
2591	!-- Calculate initial surface albedo for different surfaces
2592	IF ( .NOT. constant_albedo ) THEN
2593	#if defined( __netcdf )
2594	!
2595	!-- Horizontally aligned natural and urban surfaces
2596	CALL calc_albedo( surf_lsm_h )
2597	CALL calc_albedo( surf_usm_h )
2598	!
2599	!-- Vertically aligned natural and urban surfaces
2600	DO l = 0, 3
2601	CALL calc_albedo( surf_lsm_v(l) )
2602	CALL calc_albedo( surf_usm_v(l) )
2603	ENDDO
2604	#endif
2605	ELSE
2606	!
2607	!-- Initialize sun-inclination independent spectral albedos
2608	!-- Horizontal surfaces
2609	IF ( surf_lsm_h%ns > 0 ) THEN
2610	surf_lsm_h%rrtm_aldir = surf_lsm_h%aldir
2611	surf_lsm_h%rrtm_asdir = surf_lsm_h%asdir
2612	surf_lsm_h%rrtm_aldif = surf_lsm_h%aldif
2613	surf_lsm_h%rrtm_asdif = surf_lsm_h%asdif
2614	ENDIF
2615	IF ( surf_usm_h%ns > 0 ) THEN
2616	surf_usm_h%rrtm_aldir = surf_usm_h%aldir
2617	surf_usm_h%rrtm_asdir = surf_usm_h%asdir
2618	surf_usm_h%rrtm_aldif = surf_usm_h%aldif
2619	surf_usm_h%rrtm_asdif = surf_usm_h%asdif
2620	ENDIF
2621	!
2622	!-- Vertical surfaces
2623	DO l = 0, 3
2624	IF ( surf_lsm_v(l)%ns > 0 ) THEN
2625	surf_lsm_v(l)%rrtm_aldir = surf_lsm_v(l)%aldir
2626	surf_lsm_v(l)%rrtm_asdir = surf_lsm_v(l)%asdir
2627	surf_lsm_v(l)%rrtm_aldif = surf_lsm_v(l)%aldif
2628	surf_lsm_v(l)%rrtm_asdif = surf_lsm_v(l)%asdif
2629	ENDIF
2630	IF ( surf_usm_v(l)%ns > 0 ) THEN
2631	surf_usm_v(l)%rrtm_aldir = surf_usm_v(l)%aldir
2632	surf_usm_v(l)%rrtm_asdir = surf_usm_v(l)%asdir
2633	surf_usm_v(l)%rrtm_aldif = surf_usm_v(l)%aldif
2634	surf_usm_v(l)%rrtm_asdif = surf_usm_v(l)%asdif
2635	ENDIF
2636	ENDDO
2637
2638	ENDIF
2639
2640	!
2641	!-- Allocate 3d arrays of radiative fluxes and heating rates
2642	IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN
2643	ALLOCATE ( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2644	rad_sw_in = 0.0_wp
2645	ENDIF
2646
2647	IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN
2648	ALLOCATE ( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2649	ENDIF
2650
2651	IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN
2652	ALLOCATE ( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2653	rad_sw_out = 0.0_wp
2654	ENDIF
2655
2656	IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN
2657	ALLOCATE ( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2658	ENDIF
2659
2660	IF ( .NOT. ALLOCATED ( rad_sw_hr ) ) THEN
2661	ALLOCATE ( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2662	rad_sw_hr = 0.0_wp
2663	ENDIF
2664
2665	IF ( .NOT. ALLOCATED ( rad_sw_hr_av ) ) THEN
2666	ALLOCATE ( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2667	rad_sw_hr_av = 0.0_wp
2668	ENDIF
2669
2670	IF ( .NOT. ALLOCATED ( rad_sw_cs_hr ) ) THEN
2671	ALLOCATE ( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2672	rad_sw_cs_hr = 0.0_wp
2673	ENDIF
2674
2675	IF ( .NOT. ALLOCATED ( rad_sw_cs_hr_av ) ) THEN
2676	ALLOCATE ( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2677	rad_sw_cs_hr_av = 0.0_wp
2678	ENDIF
2679
2680	IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN
2681	ALLOCATE ( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2682	rad_lw_in = 0.0_wp
2683	ENDIF
2684
2685	IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN
2686	ALLOCATE ( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2687	ENDIF
2688
2689	IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN
2690	ALLOCATE ( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2691	rad_lw_out = 0.0_wp
2692	ENDIF
2693
2694	IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN
2695	ALLOCATE ( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2696	ENDIF
2697
2698	IF ( .NOT. ALLOCATED ( rad_lw_hr ) ) THEN
2699	ALLOCATE ( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2700	rad_lw_hr = 0.0_wp
2701	ENDIF
2702
2703	IF ( .NOT. ALLOCATED ( rad_lw_hr_av ) ) THEN
2704	ALLOCATE ( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2705	rad_lw_hr_av = 0.0_wp
2706	ENDIF
2707
2708	IF ( .NOT. ALLOCATED ( rad_lw_cs_hr ) ) THEN
2709	ALLOCATE ( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2710	rad_lw_cs_hr = 0.0_wp
2711	ENDIF
2712
2713	IF ( .NOT. ALLOCATED ( rad_lw_cs_hr_av ) ) THEN
2714	ALLOCATE ( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2715	rad_lw_cs_hr_av = 0.0_wp
2716	ENDIF
2717
2718	ALLOCATE ( rad_sw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2719	ALLOCATE ( rad_sw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2720	rad_sw_cs_in = 0.0_wp
2721	rad_sw_cs_out = 0.0_wp
2722
2723	ALLOCATE ( rad_lw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2724	ALLOCATE ( rad_lw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2725	rad_lw_cs_in = 0.0_wp
2726	rad_lw_cs_out = 0.0_wp
2727
2728	!
2729	!-- Allocate 1-element array for surface temperature
2730	!-- (RRTMG anticipates an array as passed argument).
2731	ALLOCATE ( rrtm_tsfc(1) )
2732	!
2733	!-- Allocate surface emissivity.
2734	!-- Values will be given directly before calling rrtm_lw.
2735	ALLOCATE ( rrtm_emis(0:0,1:nbndlw+1) )
2736
2737	!
2738	!-- Initialize RRTMG, before check if files are existent
2739	INQUIRE( FILE='rrtmg_lw.nc', EXIST=lw_exists )
2740	IF ( .NOT. lw_exists ) THEN
2741	message_string = 'Input file rrtmg_lw.nc' // &
2742	'&for rrtmg missing. ' // &
2743	'&Please provide <jobname>_lsw file in the INPUT directory.'
2744	CALL message( 'radiation_init', 'PA0583', 1, 2, 0, 6, 0 )
2745	ENDIF
2746	INQUIRE( FILE='rrtmg_sw.nc', EXIST=sw_exists )
2747	IF ( .NOT. sw_exists ) THEN
2748	message_string = 'Input file rrtmg_sw.nc' // &
2749	'&for rrtmg missing. ' // &
2750	'&Please provide <jobname>_rsw file in the INPUT directory.'
2751	CALL message( 'radiation_init', 'PA0584', 1, 2, 0, 6, 0 )
2752	ENDIF
2753
2754	IF ( lw_radiation ) CALL rrtmg_lw_ini ( c_p )
2755	IF ( sw_radiation ) CALL rrtmg_sw_ini ( c_p )
2756
2757	!
2758	!-- Set input files for RRTMG
2759	INQUIRE(FILE="RAD_SND_DATA", EXIST=snd_exists)
2760	IF ( .NOT. snd_exists ) THEN
2761	rrtm_input_file = "rrtmg_lw.nc"
2762	ENDIF
2763
2764	!
2765	!-- Read vertical layers for RRTMG from sounding data
2766	!-- The routine provides nzt_rad, hyp_snd(1:nzt_rad),
2767	!-- t_snd(nzt+2:nzt_rad), rrtm_play(1:nzt_rad), rrtm_plev(1_nzt_rad+1),
2768	!-- rrtm_tlay(nzt+2:nzt_rad), rrtm_tlev(nzt+2:nzt_rad+1)
2769	CALL read_sounding_data
2770
2771	!
2772	!-- Read trace gas profiles from file. This routine provides
2773	!-- the rrtm_ arrays (1:nzt_rad+1)
2774	CALL read_trace_gas_data
2775	#endif
2776	ENDIF
2777	!
2778	!-- Initializaion actions exclusively required for external
2779	!-- radiation forcing
2780	IF ( radiation_scheme == 'external' ) THEN
2781	!
2782	!-- Open the radiation input file. Note, for child domain, a dynamic
2783	!-- input file is often not provided. In order to do not need to
2784	!-- duplicate the dynamic input file just for the radiation input, take
2785	!-- it from the dynamic file for the parent if not available for the
2786	!-- child domain(s). In this case this is possible because radiation
2787	!-- input should be the same for each model.
2788	INQUIRE( FILE = TRIM( input_file_dynamic ), &
2789	EXIST = radiation_input_root_domain )
2790
2791	IF ( .NOT. input_pids_dynamic .AND. &
2792	.NOT. radiation_input_root_domain ) THEN
2793	message_string = 'In case of external radiation forcing ' // &
2794	'a dynamic input file is required. If no ' // &
2795	'dynamic input for the child domain(s) is ' // &
2796	'provided, at least one for the root domain ' // &
2797	'is needed.'
2798	CALL message( 'radiation_init', 'PA0315', 1, 2, 0, 6, 0 )
2799	ENDIF
2800	#if defined( __netcdf )
2801	!
2802	!-- Open dynamic input file for child domain if available, else, open
2803	!-- dynamic input file for the root domain.
2804	IF ( input_pids_dynamic ) THEN
2805	CALL open_read_file( TRIM( input_file_dynamic ) // &
2806	TRIM( coupling_char ), &
2807	pids_id )
2808	ELSEIF ( radiation_input_root_domain ) THEN
2809	CALL open_read_file( TRIM( input_file_dynamic ), &
2810	pids_id )
2811	ENDIF
2812
2813	CALL inquire_num_variables( pids_id, num_var_pids )
2814	!
2815	!-- Allocate memory to store variable names and read them
2816	ALLOCATE( vars_pids(1:num_var_pids) )
2817	CALL inquire_variable_names( pids_id, vars_pids )
2818	!
2819	!-- Input time dimension.
2820	IF ( check_existence( vars_pids, 'time_rad' ) ) THEN
2821	CALL get_dimension_length( pids_id, ntime, 'time_rad' )
2822
2823	ALLOCATE( time_rad_f%var1d(0:ntime-1) )
2824	!
2825	!-- Read variable
2826	CALL get_variable( pids_id, 'time_rad', time_rad_f%var1d )
2827
2828	time_rad_f%from_file = .TRUE.
2829	ENDIF
2830	!
2831	!-- Input shortwave downwelling.
2832	IF ( check_existence( vars_pids, 'rad_sw_in' ) ) THEN
2833	!
2834	!-- Get _FillValue attribute
2835	CALL get_attribute( pids_id, char_fill, rad_sw_in_f%fill, &
2836	.FALSE., 'rad_sw_in' )
2837	!
2838	!-- Get level-of-detail
2839	CALL get_attribute( pids_id, char_lod, rad_sw_in_f%lod, &
2840	.FALSE., 'rad_sw_in' )
2841	!
2842	!-- Level-of-detail 1 - radiation depends only on time_rad
2843	IF ( rad_sw_in_f%lod == 1 ) THEN
2844	ALLOCATE( rad_sw_in_f%var1d(0:ntime-1) )
2845	CALL get_variable( pids_id, 'rad_sw_in', rad_sw_in_f%var1d )
2846	rad_sw_in_f%from_file = .TRUE.
2847	!
2848	!-- Level-of-detail 2 - radiation depends on time_rad, y, x
2849	ELSEIF ( rad_sw_in_f%lod == 2 ) THEN
2850	ALLOCATE( rad_sw_in_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2851
2852	CALL get_variable( pids_id, 'rad_sw_in', rad_sw_in_f%var3d, &
2853	nxl, nxr, nys, nyn, 0, ntime-1 )
2854
2855	rad_sw_in_f%from_file = .TRUE.
2856	ELSE
2857	message_string = '"rad_sw_in" has no valid lod attribute'
2858	CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2859	ENDIF
2860	ENDIF
2861	!
2862	!-- Input longwave downwelling.
2863	IF ( check_existence( vars_pids, 'rad_lw_in' ) ) THEN
2864	!
2865	!-- Get _FillValue attribute
2866	CALL get_attribute( pids_id, char_fill, rad_lw_in_f%fill, &
2867	.FALSE., 'rad_lw_in' )
2868	!
2869	!-- Get level-of-detail
2870	CALL get_attribute( pids_id, char_lod, rad_lw_in_f%lod, &
2871	.FALSE., 'rad_lw_in' )
2872	!
2873	!-- Level-of-detail 1 - radiation depends only on time_rad
2874	IF ( rad_lw_in_f%lod == 1 ) THEN
2875	ALLOCATE( rad_lw_in_f%var1d(0:ntime-1) )
2876	CALL get_variable( pids_id, 'rad_lw_in', rad_lw_in_f%var1d )
2877	rad_lw_in_f%from_file = .TRUE.
2878	!
2879	!-- Level-of-detail 2 - radiation depends on time_rad, y, x
2880	ELSEIF ( rad_lw_in_f%lod == 2 ) THEN
2881	ALLOCATE( rad_lw_in_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2882
2883	CALL get_variable( pids_id, 'rad_lw_in', rad_lw_in_f%var3d, &
2884	nxl, nxr, nys, nyn, 0, ntime-1 )
2885
2886	rad_lw_in_f%from_file = .TRUE.
2887	ELSE
2888	message_string = '"rad_lw_in" has no valid lod attribute'
2889	CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2890	ENDIF
2891	ENDIF
2892	!
2893	!-- Input shortwave downwelling, diffuse part.
2894	IF ( check_existence( vars_pids, 'rad_sw_in_dif' ) ) THEN
2895	!
2896	!-- Read _FillValue attribute
2897	CALL get_attribute( pids_id, char_fill, rad_sw_in_dif_f%fill, &
2898	.FALSE., 'rad_sw_in_dif' )
2899	!
2900	!-- Get level-of-detail
2901	CALL get_attribute( pids_id, char_lod, rad_sw_in_dif_f%lod, &
2902	.FALSE., 'rad_sw_in_dif' )
2903	!
2904	!-- Level-of-detail 1 - radiation depends only on time_rad
2905	IF ( rad_sw_in_dif_f%lod == 1 ) THEN
2906	ALLOCATE( rad_sw_in_dif_f%var1d(0:ntime-1) )
2907	CALL get_variable( pids_id, 'rad_sw_in_dif', &
2908	rad_sw_in_dif_f%var1d )
2909	rad_sw_in_dif_f%from_file = .TRUE.
2910	!
2911	!-- Level-of-detail 2 - radiation depends on time_rad, y, x
2912	ELSEIF ( rad_sw_in_dif_f%lod == 2 ) THEN
2913	ALLOCATE( rad_sw_in_dif_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2914
2915	CALL get_variable( pids_id, 'rad_sw_in_dif', &
2916	rad_sw_in_dif_f%var3d, &
2917	nxl, nxr, nys, nyn, 0, ntime-1 )
2918
2919	rad_sw_in_dif_f%from_file = .TRUE.
2920	ELSE
2921	message_string = '"rad_sw_in_dif" has no valid lod attribute'
2922	CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2923	ENDIF
2924	ENDIF
2925	!
2926	!-- Finally, close the input file and deallocate temporary arrays
2927	DEALLOCATE( vars_pids )
2928
2929	CALL close_input_file( pids_id )
2930	#endif
2931	!
2932	!-- Make some consistency checks.
2933	IF ( .NOT. rad_sw_in_f%from_file .OR. &
2934	.NOT. rad_lw_in_f%from_file ) THEN
2935	message_string = 'In case of external radiation forcing ' // &
2936	'both, rad_sw_in and rad_lw_in are required.'
2937	CALL message( 'radiation_init', 'PA0195', 1, 2, 0, 6, 0 )
2938	ENDIF
2939
2940	IF ( .NOT. time_rad_f%from_file ) THEN
2941	message_string = 'In case of external radiation forcing ' // &
2942	'dimension time_rad is required.'
2943	CALL message( 'radiation_init', 'PA0196', 1, 2, 0, 6, 0 )
2944	ENDIF
2945
2946	CALL get_date_time( 0.0_wp, second_of_day=second_of_day )
2947
2948	IF ( ABS( time_rad_f%var1d(0) - second_of_day ) > 1E-6_wp ) THEN
2949	message_string = 'External radiation forcing: first point in ' // &
2950	'time is /= origin_date_time.'
2951	CALL message( 'radiation_init', 'PA0313', 1, 2, 0, 6, 0 )
2952	ENDIF
2953
2954	IF ( end_time - spinup_time > time_rad_f%var1d(ntime-1) &
2955	- second_of_day ) THEN
2956	message_string = 'External radiation forcing does not cover ' // &
2957	'the entire simulation time.'
2958	CALL message( 'radiation_init', 'PA0314', 1, 2, 0, 6, 0 )
2959	ENDIF
2960	!
2961	!-- Check for fill values in radiation
2962	IF ( ALLOCATED( rad_sw_in_f%var1d ) ) THEN
2963	IF ( ANY( rad_sw_in_f%var1d == rad_sw_in_f%fill ) ) THEN
2964	message_string = 'External radiation array "rad_sw_in" ' // &
2965	'must not contain any fill values.'
2966	CALL message( 'radiation_init', 'PA0197', 1, 2, 0, 6, 0 )
2967	ENDIF
2968	ENDIF
2969
2970	IF ( ALLOCATED( rad_lw_in_f%var1d ) ) THEN
2971	IF ( ANY( rad_lw_in_f%var1d == rad_lw_in_f%fill ) ) THEN
2972	message_string = 'External radiation array "rad_lw_in" ' // &
2973	'must not contain any fill values.'
2974	CALL message( 'radiation_init', 'PA0198', 1, 2, 0, 6, 0 )
2975	ENDIF
2976	ENDIF
2977
2978	IF ( ALLOCATED( rad_sw_in_dif_f%var1d ) ) THEN
2979	IF ( ANY( rad_sw_in_dif_f%var1d == rad_sw_in_dif_f%fill ) ) THEN
2980	message_string = 'External radiation array "rad_sw_in_dif" ' //&
2981	'must not contain any fill values.'
2982	CALL message( 'radiation_init', 'PA0199', 1, 2, 0, 6, 0 )
2983	ENDIF
2984	ENDIF
2985
2986	IF ( ALLOCATED( rad_sw_in_f%var3d ) ) THEN
2987	IF ( ANY( rad_sw_in_f%var3d == rad_sw_in_f%fill ) ) THEN
2988	message_string = 'External radiation array "rad_sw_in" ' // &
2989	'must not contain any fill values.'
2990	CALL message( 'radiation_init', 'PA0197', 1, 2, 0, 6, 0 )
2991	ENDIF
2992	ENDIF
2993
2994	IF ( ALLOCATED( rad_lw_in_f%var3d ) ) THEN
2995	IF ( ANY( rad_lw_in_f%var3d == rad_lw_in_f%fill ) ) THEN
2996	message_string = 'External radiation array "rad_lw_in" ' // &
2997	'must not contain any fill values.'
2998	CALL message( 'radiation_init', 'PA0198', 1, 2, 0, 6, 0 )
2999	ENDIF
3000	ENDIF
3001
3002	IF ( ALLOCATED( rad_sw_in_dif_f%var3d ) ) THEN
3003	IF ( ANY( rad_sw_in_dif_f%var3d == rad_sw_in_dif_f%fill ) ) THEN
3004	message_string = 'External radiation array "rad_sw_in_dif" ' //&
3005	'must not contain any fill values.'
3006	CALL message( 'radiation_init', 'PA0199', 1, 2, 0, 6, 0 )
3007	ENDIF
3008	ENDIF
3009	!
3010	!-- Currently, 2D external radiation input is not possible in
3011	!-- combination with topography where average radiation is used.
3012	IF ( ( rad_lw_in_f%lod == 2 .OR. rad_sw_in_f%lod == 2 .OR. &
3013	rad_sw_in_dif_f%lod == 2 ) .AND. average_radiation ) THEN
3014	message_string = 'External radiation with lod = 2 is currently '//&
3015	'not possible with average_radiation = .T..'
3016	CALL message( 'radiation_init', 'PA0670', 1, 2, 0, 6, 0 )
3017	ENDIF
3018	!
3019	!-- All radiation input should have the same level of detail. The sum
3020	!-- of lods divided by the number of available radiation arrays must be
3021	!-- 1 (if all are lod = 1) or 2 (if all are lod = 2).
3022	IF ( REAL( MERGE( rad_lw_in_f%lod, 0, rad_lw_in_f%from_file ) + &
3023	MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + &
3024	MERGE( rad_sw_in_dif_f%lod, 0, rad_sw_in_dif_f%from_file ),&
3025	KIND = wp ) / &
3026	( MERGE( 1.0_wp, 0.0_wp, rad_lw_in_f%from_file ) + &
3027	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + &
3028	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_dif_f%from_file ) ) &
3029	/= 1.0_wp .AND. &
3030	REAL( MERGE( rad_lw_in_f%lod, 0, rad_lw_in_f%from_file ) + &
3031	MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + &
3032	MERGE( rad_sw_in_dif_f%lod, 0, rad_sw_in_dif_f%from_file ),&
3033	KIND = wp ) / &
3034	( MERGE( 1.0_wp, 0.0_wp, rad_lw_in_f%from_file ) + &
3035	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + &
3036	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_dif_f%from_file ) ) &
3037	/= 2.0_wp ) THEN
3038	message_string = 'External radiation input should have the same '//&
3039	'lod.'
3040	CALL message( 'radiation_init', 'PA0673', 1, 2, 0, 6, 0 )
3041	ENDIF
3042
3043	ENDIF
3044	!
3045	!-- Perform user actions if required
3046	CALL user_init_radiation
3047
3048	!
3049	!-- Calculate radiative fluxes at model start
3050	SELECT CASE ( TRIM( radiation_scheme ) )
3051
3052	CASE ( 'rrtmg' )
3053	CALL radiation_rrtmg
3054
3055	CASE ( 'clear-sky' )
3056	CALL radiation_clearsky
3057
3058	CASE ( 'constant' )
3059	CALL radiation_constant
3060
3061	CASE ( 'external' )
3062	!
3063	!-- During spinup apply clear-sky model
3064	IF ( time_since_reference_point < 0.0_wp ) THEN
3065	CALL radiation_clearsky
3066	ELSE
3067	CALL radiation_external
3068	ENDIF
3069
3070	CASE DEFAULT
3071
3072	END SELECT
3073
3074	!
3075	!-- Find all discretized apparent solar positions for radiation interaction.
3076	IF ( radiation_interactions ) CALL radiation_presimulate_solar_pos
3077
3078	!
3079	!-- If required, read or calculate and write out the SVF
3080	IF ( radiation_interactions .AND. read_svf) THEN
3081	!
3082	!-- Read sky-view factors and further required data from file
3083	CALL radiation_read_svf()
3084
3085	ELSEIF ( radiation_interactions .AND. .NOT. read_svf) THEN
3086	!
3087	!-- calculate SFV and CSF
3088	CALL radiation_calc_svf()
3089	ENDIF
3090
3091	IF ( radiation_interactions .AND. write_svf) THEN
3092	!
3093	!-- Write svf, csf svfsurf and csfsurf data to file
3094	CALL radiation_write_svf()
3095	ENDIF
3096
3097	!
3098	!-- Adjust radiative fluxes. In case of urban and land surfaces, also
3099	!-- call an initial interaction.
3100	IF ( radiation_interactions ) THEN
3101	CALL radiation_interaction
3102	ENDIF
3103
3104	IF ( debug_output ) CALL debug_message( 'radiation_init', 'end' )
3105
3106	RETURN !todo: remove, I don't see what we need this for here
3107
3108	END SUBROUTINE radiation_init
3109
3110
3111	!------------------------------------------------------------------------------!
3112	! Description:
3113	! ------------
3114	!> A simple clear sky radiation model
3115	!------------------------------------------------------------------------------!
3116	SUBROUTINE radiation_external
3117
3118	IMPLICIT NONE
3119
3120	INTEGER(iwp) :: l !< running index for surface orientation
3121	INTEGER(iwp) :: t !< index of current timestep
3122	INTEGER(iwp) :: tm !< index of previous timestep
3123
3124	LOGICAL :: horizontal !< flag indicating treatment of horinzontal surfaces
3125
3126	REAL(wp) :: fac_dt !< interpolation factor
3127	REAL(wp) :: second_of_day_init !< second of the day at model start
3128
3129	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
3130
3131	!
3132	!-- Calculate current zenith angle
3133	CALL get_date_time( time_since_reference_point, &
3134	day_of_year=day_of_year, &
3135	second_of_day=second_of_day )
3136	CALL calc_zenith( day_of_year, second_of_day )
3137	!
3138	!-- Interpolate external radiation on current timestep
3139	IF ( time_since_reference_point <= 0.0_wp ) THEN
3140	t = 0
3141	tm = 0
3142	fac_dt = 0
3143	ELSE
3144	CALL get_date_time( 0.0_wp, second_of_day=second_of_day_init )
3145	t = 0
3146	DO WHILE ( time_rad_f%var1d(t) <= &
3147	time_since_reference_point + second_of_day_init )
3148	t = t + 1
3149	ENDDO
3150
3151	tm = MAX( t-1, 0 )
3152
3153	fac_dt = ( time_since_reference_point + second_of_day_init &
3154	- time_rad_f%var1d(tm) + dt_3d ) &
3155	/ ( time_rad_f%var1d(t) - time_rad_f%var1d(tm) )
3156	fac_dt = MIN( 1.0_wp, fac_dt )
3157	ENDIF
3158	!
3159	!-- Call clear-sky calculation for each surface orientation.
3160	!-- First, horizontal surfaces
3161	horizontal = .TRUE.
3162	surf => surf_lsm_h
3163	CALL radiation_external_surf
3164	surf => surf_usm_h
3165	CALL radiation_external_surf
3166	horizontal = .FALSE.
3167	!
3168	!-- Vertical surfaces
3169	DO l = 0, 3
3170	surf => surf_lsm_v(l)
3171	CALL radiation_external_surf
3172	surf => surf_usm_v(l)
3173	CALL radiation_external_surf
3174	ENDDO
3175
3176	CONTAINS
3177
3178	SUBROUTINE radiation_external_surf
3179
3180	USE control_parameters
3181
3182	IMPLICIT NONE
3183
3184	INTEGER(iwp) :: i !< grid index along x-dimension
3185	INTEGER(iwp) :: j !< grid index along y-dimension
3186	INTEGER(iwp) :: k !< grid index along z-dimension
3187	INTEGER(iwp) :: m !< running index for surface elements
3188
3189	REAL(wp) :: lw_in !< downwelling longwave radiation, interpolated value
3190	REAL(wp) :: sw_in !< downwelling shortwave radiation, interpolated value
3191	REAL(wp) :: sw_in_dif !< downwelling diffuse shortwave radiation, interpolated value
3192
3193	IF ( surf%ns < 1 ) RETURN
3194	!
3195	!-- level-of-detail = 1. Note, here it must be distinguished between
3196	!-- averaged radiation and non-averaged radiation for the upwelling
3197	!-- fluxes.
3198	IF ( rad_sw_in_f%lod == 1 ) THEN
3199
3200	sw_in = ( 1.0_wp - fac_dt ) * rad_sw_in_f%var1d(tm) &
3201	+ fac_dt * rad_sw_in_f%var1d(t)
3202
3203	lw_in = ( 1.0_wp - fac_dt ) * rad_lw_in_f%var1d(tm) &
3204	+ fac_dt * rad_lw_in_f%var1d(t)
3205	!
3206	!-- Limit shortwave incoming radiation to positive values, in order
3207	!-- to overcome possible observation errors.
3208	sw_in = MAX( 0.0_wp, sw_in )
3209	sw_in = MERGE( sw_in, 0.0_wp, sun_up )
3210
3211	surf%rad_sw_in = sw_in
3212	surf%rad_lw_in = lw_in
3213
3214	IF ( average_radiation ) THEN
3215	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
3216
3217	surf%rad_lw_out = emissivity_urb * sigma_sb * t_rad_urb**4 &
3218	+ ( 1.0_wp - emissivity_urb ) * surf%rad_lw_in
3219
3220	surf%rad_net = surf%rad_sw_in - surf%rad_sw_out &
3221	+ surf%rad_lw_in - surf%rad_lw_out
3222
3223	surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb &
3224	* sigma_sb &
3225	* t_rad_urb**3
3226	ELSE
3227	DO m = 1, surf%ns
3228	k = surf%k(m)
3229	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3230	surf%albedo(ind_veg_wall,m) &
3231	+ surf%frac(ind_pav_green,m) * &
3232	surf%albedo(ind_pav_green,m) &
3233	+ surf%frac(ind_wat_win,m) * &
3234	surf%albedo(ind_wat_win,m) ) &
3235	* surf%rad_sw_in(m)
3236
3237	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3238	surf%emissivity(ind_veg_wall,m) &
3239	+ surf%frac(ind_pav_green,m) * &
3240	surf%emissivity(ind_pav_green,m) &
3241	+ surf%frac(ind_wat_win,m) * &
3242	surf%emissivity(ind_wat_win,m) &
3243	) &
3244	* sigma_sb &
3245	* ( surf%pt_surface(m) * exner(k) )**4
3246
3247	surf%rad_lw_out_change_0(m) = &
3248	( surf%frac(ind_veg_wall,m) * &
3249	surf%emissivity(ind_veg_wall,m) &
3250	+ surf%frac(ind_pav_green,m) * &
3251	surf%emissivity(ind_pav_green,m) &
3252	+ surf%frac(ind_wat_win,m) * &
3253	surf%emissivity(ind_wat_win,m) &
3254	) * 4.0_wp * sigma_sb &
3255	* ( surf%pt_surface(m) * exner(k) )**3
3256	ENDDO
3257
3258	ENDIF
3259	!
3260	!-- If diffuse shortwave radiation is available, store it on
3261	!-- the respective files.
3262	IF ( rad_sw_in_dif_f%from_file ) THEN
3263	sw_in_dif= ( 1.0_wp - fac_dt ) * rad_sw_in_dif_f%var1d(tm) &
3264	+ fac_dt * rad_sw_in_dif_f%var1d(t)
3265
3266	IF ( ALLOCATED( rad_sw_in_diff ) ) rad_sw_in_diff = sw_in_dif
3267	IF ( ALLOCATED( rad_sw_in_dir ) ) rad_sw_in_dir = sw_in &
3268	- sw_in_dif
3269	!
3270	!-- Diffuse longwave radiation equals the total downwelling
3271	!-- longwave radiation
3272	IF ( ALLOCATED( rad_lw_in_diff ) ) rad_lw_in_diff = lw_in
3273	ENDIF
3274	!
3275	!-- level-of-detail = 2
3276	ELSE
3277
3278	DO m = 1, surf%ns
3279	i = surf%i(m)
3280	j = surf%j(m)
3281	k = surf%k(m)
3282
3283	surf%rad_sw_in(m) = ( 1.0_wp - fac_dt ) &
3284	* rad_sw_in_f%var3d(tm,j,i) &
3285	+ fac_dt * rad_sw_in_f%var3d(t,j,i)
3286	!
3287	!-- Limit shortwave incoming radiation to positive values, in
3288	!-- order to overcome possible observation errors.
3289	surf%rad_sw_in(m) = MAX( 0.0_wp, surf%rad_sw_in(m) )
3290	surf%rad_sw_in(m) = MERGE( surf%rad_sw_in(m), 0.0_wp, sun_up )
3291
3292	surf%rad_lw_in(m) = ( 1.0_wp - fac_dt ) &
3293	* rad_lw_in_f%var3d(tm,j,i) &
3294	+ fac_dt * rad_lw_in_f%var3d(t,j,i)
3295	!
3296	!-- Weighted average according to surface fraction.
3297	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3298	surf%albedo(ind_veg_wall,m) &
3299	+ surf%frac(ind_pav_green,m) * &
3300	surf%albedo(ind_pav_green,m) &
3301	+ surf%frac(ind_wat_win,m) * &
3302	surf%albedo(ind_wat_win,m) ) &
3303	* surf%rad_sw_in(m)
3304
3305	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3306	surf%emissivity(ind_veg_wall,m) &
3307	+ surf%frac(ind_pav_green,m) * &
3308	surf%emissivity(ind_pav_green,m) &
3309	+ surf%frac(ind_wat_win,m) * &
3310	surf%emissivity(ind_wat_win,m) &
3311	) &
3312	* sigma_sb &
3313	* ( surf%pt_surface(m) * exner(k) )**4
3314
3315	surf%rad_lw_out_change_0(m) = &
3316	( surf%frac(ind_veg_wall,m) * &
3317	surf%emissivity(ind_veg_wall,m) &
3318	+ surf%frac(ind_pav_green,m) * &
3319	surf%emissivity(ind_pav_green,m) &
3320	+ surf%frac(ind_wat_win,m) * &
3321	surf%emissivity(ind_wat_win,m) &
3322	) * 4.0_wp * sigma_sb &
3323	* ( surf%pt_surface(m) * exner(k) )**3
3324
3325	surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) &
3326	+ surf%rad_lw_in(m) - surf%rad_lw_out(m)
3327	!
3328	!-- If diffuse shortwave radiation is available, store it on
3329	!-- the respective files.
3330	IF ( rad_sw_in_dif_f%from_file ) THEN
3331	IF ( ALLOCATED( rad_sw_in_diff ) ) &
3332	rad_sw_in_diff(j,i) = ( 1.0_wp - fac_dt ) &
3333	* rad_sw_in_dif_f%var3d(tm,j,i) &
3334	+ fac_dt * rad_sw_in_dif_f%var3d(t,j,i)
3335	!
3336	!-- dir = sw_in - sw_in_dif.
3337	IF ( ALLOCATED( rad_sw_in_dir ) ) &
3338	rad_sw_in_dir(j,i) = surf%rad_sw_in(m) - &
3339	rad_sw_in_diff(j,i)
3340	!
3341	!-- Diffuse longwave radiation equals the total downwelling
3342	!-- longwave radiation
3343	IF ( ALLOCATED( rad_lw_in_diff ) ) &
3344	rad_lw_in_diff(j,i) = surf%rad_lw_in(m)
3345	ENDIF
3346
3347	ENDDO
3348
3349	ENDIF
3350	!
3351	!-- Store radiation also on 2D arrays, which are still used for
3352	!-- direct-diffuse splitting. Note, this is only required
3353	!-- for horizontal surfaces, which covers all x,y position.
3354	IF ( horizontal ) THEN
3355	DO m = 1, surf%ns
3356	i = surf%i(m)
3357	j = surf%j(m)
3358
3359	rad_sw_in(0,j,i) = surf%rad_sw_in(m)
3360	rad_lw_in(0,j,i) = surf%rad_lw_in(m)
3361	rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3362	rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3363	ENDDO
3364	ENDIF
3365
3366	END SUBROUTINE radiation_external_surf
3367
3368	END SUBROUTINE radiation_external
3369
3370	!------------------------------------------------------------------------------!
3371	! Description:
3372	! ------------
3373	!> A simple clear sky radiation model
3374	!------------------------------------------------------------------------------!
3375	SUBROUTINE radiation_clearsky
3376
3377	IMPLICIT NONE
3378
3379	INTEGER(iwp) :: l !< running index for surface orientation
3380
3381	LOGICAL :: horizontal !< flag indicating treatment of horinzontal surfaces
3382
3383	REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top
3384	REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain
3385	REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top
3386	REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain
3387
3388	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
3389
3390	!
3391	!-- Calculate current zenith angle
3392	CALL get_date_time( time_since_reference_point, &
3393	day_of_year=day_of_year, &
3394	second_of_day=second_of_day )
3395	CALL calc_zenith( day_of_year, second_of_day )
3396
3397	!
3398	!-- Calculate sky transmissivity
3399	sky_trans = 0.6_wp + 0.2_wp * cos_zenith
3400
3401	!
3402	!-- Calculate value of the Exner function at model surface
3403	!
3404	!-- In case averaged radiation is used, calculate mean temperature and
3405	!-- liquid water mixing ratio at the urban-layer top.
3406	IF ( average_radiation ) THEN
3407	pt1 = 0.0_wp
3408	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = 0.0_wp
3409
3410	pt1_l = SUM( pt(nz_urban_t,nys:nyn,nxl:nxr) )
3411	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1_l = SUM( ql(nz_urban_t,nys:nyn,nxl:nxr) )
3412
3413	#if defined( __parallel )
3414	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
3415	CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3416	IF ( ierr /= 0 ) THEN
3417	WRITE(9,*) 'Error MPI_AllReduce1:', ierr, pt1_l, pt1
3418	FLUSH(9)
3419	ENDIF
3420
3421	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3422	CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3423	IF ( ierr /= 0 ) THEN
3424	WRITE(9,*) 'Error MPI_AllReduce2:', ierr, ql1_l, ql1
3425	FLUSH(9)
3426	ENDIF
3427	ENDIF
3428	#else
3429	pt1 = pt1_l
3430	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = ql1_l
3431	#endif
3432
3433	IF ( bulk_cloud_model .OR. cloud_droplets ) pt1 = pt1 + lv_d_cp / exner(nz_urban_t) * ql1
3434	!
3435	!-- Finally, divide by number of grid points
3436	pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp )
3437	ENDIF
3438	!
3439	!-- Call clear-sky calculation for each surface orientation.
3440	!-- First, horizontal surfaces
3441	horizontal = .TRUE.
3442	surf => surf_lsm_h
3443	CALL radiation_clearsky_surf
3444	surf => surf_usm_h
3445	CALL radiation_clearsky_surf
3446	horizontal = .FALSE.
3447	!
3448	!-- Vertical surfaces
3449	DO l = 0, 3
3450	surf => surf_lsm_v(l)
3451	CALL radiation_clearsky_surf
3452	surf => surf_usm_v(l)
3453	CALL radiation_clearsky_surf
3454	ENDDO
3455
3456	CONTAINS
3457
3458	SUBROUTINE radiation_clearsky_surf
3459
3460	IMPLICIT NONE
3461
3462	INTEGER(iwp) :: i !< index x-direction
3463	INTEGER(iwp) :: j !< index y-direction
3464	INTEGER(iwp) :: k !< index z-direction
3465	INTEGER(iwp) :: m !< running index for surface elements
3466
3467	IF ( surf%ns < 1 ) RETURN
3468
3469	!
3470	!-- Calculate radiation fluxes and net radiation (rad_net) assuming
3471	!-- homogeneous urban radiation conditions.
3472	IF ( average_radiation ) THEN
3473
3474	k = nz_urban_t
3475
3476	surf%rad_sw_in = solar_constant * sky_trans * cos_zenith
3477	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
3478
3479	surf%rad_lw_in = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k+1))**4
3480
3481	surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 &
3482	+ (1.0_wp - emissivity_urb) * surf%rad_lw_in
3483
3484	surf%rad_net = surf%rad_sw_in - surf%rad_sw_out &
3485	+ surf%rad_lw_in - surf%rad_lw_out
3486
3487	surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb &
3488	* (t_rad_urb)**3
3489
3490	!
3491	!-- Calculate radiation fluxes and net radiation (rad_net) for each surface
3492	!-- element.
3493	ELSE
3494
3495	DO m = 1, surf%ns
3496	i = surf%i(m)
3497	j = surf%j(m)
3498	k = surf%k(m)
3499
3500	surf%rad_sw_in(m) = solar_constant * sky_trans * cos_zenith
3501
3502	!
3503	!-- Weighted average according to surface fraction.
3504	!-- ATTENTION: when radiation interactions are switched on the
3505	!-- calculated fluxes below are not actually used as they are
3506	!-- overwritten in radiation_interaction.
3507	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3508	surf%albedo(ind_veg_wall,m) &
3509	+ surf%frac(ind_pav_green,m) * &
3510	surf%albedo(ind_pav_green,m) &
3511	+ surf%frac(ind_wat_win,m) * &
3512	surf%albedo(ind_wat_win,m) ) &
3513	* surf%rad_sw_in(m)
3514
3515	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3516	surf%emissivity(ind_veg_wall,m) &
3517	+ surf%frac(ind_pav_green,m) * &
3518	surf%emissivity(ind_pav_green,m) &
3519	+ surf%frac(ind_wat_win,m) * &
3520	surf%emissivity(ind_wat_win,m) &
3521	) &
3522	* sigma_sb &
3523	* ( surf%pt_surface(m) * exner(nzb) )**4
3524
3525	surf%rad_lw_out_change_0(m) = &
3526	( surf%frac(ind_veg_wall,m) * &
3527	surf%emissivity(ind_veg_wall,m) &
3528	+ surf%frac(ind_pav_green,m) * &
3529	surf%emissivity(ind_pav_green,m) &
3530	+ surf%frac(ind_wat_win,m) * &
3531	surf%emissivity(ind_wat_win,m) &
3532	) * 4.0_wp * sigma_sb &
3533	* ( surf%pt_surface(m) * exner(nzb) )** 3
3534
3535
3536	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3537	pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i)
3538	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k))**4
3539	ELSE
3540	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt(k,j,i) * exner(k))**4
3541	ENDIF
3542
3543	surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) &
3544	+ surf%rad_lw_in(m) - surf%rad_lw_out(m)
3545
3546	ENDDO
3547
3548	ENDIF
3549
3550	!
3551	!-- Fill out values in radiation arrays. Note, this is only required
3552	!-- for horizontal surfaces, which covers all x,y position.
3553	IF ( horizontal ) THEN
3554	DO m = 1, surf%ns
3555	i = surf%i(m)
3556	j = surf%j(m)
3557	rad_sw_in(0,j,i) = surf%rad_sw_in(m)
3558	rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3559	rad_lw_in(0,j,i) = surf%rad_lw_in(m)
3560	rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3561	ENDDO
3562	ENDIF
3563
3564	END SUBROUTINE radiation_clearsky_surf
3565
3566	END SUBROUTINE radiation_clearsky
3567
3568
3569	!------------------------------------------------------------------------------!
3570	! Description:
3571	! ------------
3572	!> This scheme keeps the prescribed net radiation constant during the run
3573	!------------------------------------------------------------------------------!
3574	SUBROUTINE radiation_constant
3575
3576
3577	IMPLICIT NONE
3578
3579	INTEGER(iwp) :: l !< running index for surface orientation
3580
3581	LOGICAL :: horizontal !< flag indicating treatment of horinzontal surfaces
3582
3583	REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top
3584	REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain
3585	REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top
3586	REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain
3587
3588	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
3589
3590	!
3591	!-- In case averaged radiation is used, calculate mean temperature and
3592	!-- liquid water mixing ratio at the urban-layer top.
3593	IF ( average_radiation ) THEN
3594	pt1 = 0.0_wp
3595	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = 0.0_wp
3596
3597	pt1_l = SUM( pt(nz_urban_t,nys:nyn,nxl:nxr) )
3598	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1_l = SUM( ql(nz_urban_t,nys:nyn,nxl:nxr) )
3599
3600	#if defined( __parallel )
3601	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
3602	CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3603	IF ( ierr /= 0 ) THEN
3604	WRITE(9,*) 'Error MPI_AllReduce3:', ierr, pt1_l, pt1
3605	FLUSH(9)
3606	ENDIF
3607	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3608	CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3609	IF ( ierr /= 0 ) THEN
3610	WRITE(9,*) 'Error MPI_AllReduce4:', ierr, ql1_l, ql1
3611	FLUSH(9)
3612	ENDIF
3613	ENDIF
3614	#else
3615	pt1 = pt1_l
3616	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = ql1_l
3617	#endif
3618	IF ( bulk_cloud_model .OR. cloud_droplets ) pt1 = pt1 + lv_d_cp / exner(nz_urban_t+1) * ql1
3619	!
3620	!-- Finally, divide by number of grid points
3621	pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp )
3622	ENDIF
3623
3624	!
3625	!-- First, horizontal surfaces
3626	horizontal = .TRUE.
3627	surf => surf_lsm_h
3628	CALL radiation_constant_surf
3629	surf => surf_usm_h
3630	CALL radiation_constant_surf
3631	horizontal = .FALSE.
3632	!
3633	!-- Vertical surfaces
3634	DO l = 0, 3
3635	surf => surf_lsm_v(l)
3636	CALL radiation_constant_surf
3637	surf => surf_usm_v(l)
3638	CALL radiation_constant_surf
3639	ENDDO
3640
3641	CONTAINS
3642
3643	SUBROUTINE radiation_constant_surf
3644
3645	IMPLICIT NONE
3646
3647	INTEGER(iwp) :: i !< index x-direction
3648	INTEGER(iwp) :: ioff !< offset between surface element and adjacent grid point along x
3649	INTEGER(iwp) :: j !< index y-direction
3650	INTEGER(iwp) :: joff !< offset between surface element and adjacent grid point along y
3651	INTEGER(iwp) :: k !< index z-direction
3652	INTEGER(iwp) :: koff !< offset between surface element and adjacent grid point along z
3653	INTEGER(iwp) :: m !< running index for surface elements
3654
3655	IF ( surf%ns < 1 ) RETURN
3656
3657	!-- Calculate homogenoeus urban radiation fluxes
3658	IF ( average_radiation ) THEN
3659
3660	surf%rad_net = net_radiation
3661
3662	surf%rad_lw_in = emissivity_atm_clsky * sigma_sb * (pt1 * exner(nz_urban_t+1))**4
3663
3664	surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 &
3665	+ ( 1.0_wp - emissivity_urb ) & ! shouldn't be this a bulk value -- emissivity_urb?
3666	* surf%rad_lw_in
3667
3668	surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb &
3669	* t_rad_urb**3
3670
3671	surf%rad_sw_in = ( surf%rad_net - surf%rad_lw_in &
3672	+ surf%rad_lw_out ) &
3673	/ ( 1.0_wp - albedo_urb )
3674
3675	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
3676
3677	!
3678	!-- Calculate radiation fluxes for each surface element
3679	ELSE
3680	!
3681	!-- Determine index offset between surface element and adjacent
3682	!-- atmospheric grid point
3683	ioff = surf%ioff
3684	joff = surf%joff
3685	koff = surf%koff
3686
3687	!
3688	!-- Prescribe net radiation and estimate the remaining radiative fluxes
3689	DO m = 1, surf%ns
3690	i = surf%i(m)
3691	j = surf%j(m)
3692	k = surf%k(m)
3693
3694	surf%rad_net(m) = net_radiation
3695
3696	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3697	pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i)
3698	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k))**4
3699	ELSE
3700	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * &
3701	( pt(k,j,i) * exner(k) )**4
3702	ENDIF
3703
3704	!
3705	!-- Weighted average according to surface fraction.
3706	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3707	surf%emissivity(ind_veg_wall,m) &
3708	+ surf%frac(ind_pav_green,m) * &
3709	surf%emissivity(ind_pav_green,m) &
3710	+ surf%frac(ind_wat_win,m) * &
3711	surf%emissivity(ind_wat_win,m) &
3712	) &
3713	* sigma_sb &
3714	* ( surf%pt_surface(m) * exner(nzb) )**4
3715
3716	surf%rad_sw_in(m) = ( surf%rad_net(m) - surf%rad_lw_in(m) &
3717	+ surf%rad_lw_out(m) ) &
3718	/ ( 1.0_wp - &
3719	( surf%frac(ind_veg_wall,m) * &
3720	surf%albedo(ind_veg_wall,m) &
3721	+ surf%frac(ind_pav_green,m) * &
3722	surf%albedo(ind_pav_green,m) &
3723	+ surf%frac(ind_wat_win,m) * &
3724	surf%albedo(ind_wat_win,m) ) &
3725	)
3726
3727	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3728	surf%albedo(ind_veg_wall,m) &
3729	+ surf%frac(ind_pav_green,m) * &
3730	surf%albedo(ind_pav_green,m) &
3731	+ surf%frac(ind_wat_win,m) * &
3732	surf%albedo(ind_wat_win,m) ) &
3733	* surf%rad_sw_in(m)
3734
3735	ENDDO
3736
3737	ENDIF
3738
3739	!
3740	!-- Fill out values in radiation arrays. Note, this is only required
3741	!-- for horizontal surfaces, which covers all x,y position.
3742	IF ( horizontal ) THEN
3743	DO m = 1, surf%ns
3744	i = surf%i(m)
3745	j = surf%j(m)
3746	rad_sw_in(0,j,i) = surf%rad_sw_in(m)
3747	rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3748	rad_lw_in(0,j,i) = surf%rad_lw_in(m)
3749	rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3750	ENDDO
3751	ENDIF
3752
3753	END SUBROUTINE radiation_constant_surf
3754
3755
3756	END SUBROUTINE radiation_constant
3757
3758	!------------------------------------------------------------------------------!
3759	! Description:
3760	! ------------
3761	!> Header output for radiation model
3762	!------------------------------------------------------------------------------!
3763	SUBROUTINE radiation_header ( io )
3764
3765
3766	IMPLICIT NONE
3767
3768	INTEGER(iwp), INTENT(IN) :: io !< Unit of the output file
3769
3770
3771
3772	!
3773	!-- Write radiation model header
3774	WRITE( io, 3 )
3775
3776	IF ( radiation_scheme == "constant" ) THEN
3777	WRITE( io, 4 ) net_radiation
3778	ELSEIF ( radiation_scheme == "clear-sky" ) THEN
3779	WRITE( io, 5 )
3780	ELSEIF ( radiation_scheme == "rrtmg" ) THEN
3781	WRITE( io, 6 )
3782	IF ( .NOT. lw_radiation ) WRITE( io, 10 )
3783	IF ( .NOT. sw_radiation ) WRITE( io, 11 )
3784	ELSEIF ( radiation_scheme == "external" ) THEN
3785	WRITE( io, 14 )
3786	ENDIF
3787
3788	IF ( albedo_type_f%from_file .OR. vegetation_type_f%from_file .OR. &
3789	pavement_type_f%from_file .OR. water_type_f%from_file .OR. &
3790	building_type_f%from_file ) THEN
3791	WRITE( io, 13 )
3792	ELSE
3793	IF ( albedo_type == 0 ) THEN
3794	WRITE( io, 7 ) albedo
3795	ELSE
3796	WRITE( io, 8 ) TRIM( albedo_type_name(albedo_type) )
3797	ENDIF
3798	ENDIF
3799	IF ( constant_albedo ) THEN
3800	WRITE( io, 9 )
3801	ENDIF
3802
3803	WRITE( io, 12 ) dt_radiation
3804
3805
3806	3 FORMAT (//' Radiation model information:'/ &
3807	' ----------------------------'/)
3808	4 FORMAT (' --> Using constant net radiation: net_radiation = ', F6.2, &
3809	// 'W/m**2')
3810	5 FORMAT (' --> Simple radiation scheme for clear sky is used (no clouds,',&
3811	' default)')
3812	6 FORMAT (' --> RRTMG scheme is used')
3813	7 FORMAT (/' User-specific surface albedo: albedo =', F6.3)
3814	8 FORMAT (/' Albedo is set for land surface type: ', A)
3815	9 FORMAT (/' --> Albedo is fixed during the run')
3816	10 FORMAT (/' --> Longwave radiation is disabled')
3817	11 FORMAT (/' --> Shortwave radiation is disabled.')
3818	12 FORMAT (' Timestep: dt_radiation = ', F6.2, ' s')
3819	13 FORMAT (/' Albedo is set individually for each xy-location, according ', &
3820	'to given surface type.')
3821	14 FORMAT (' --> External radiation forcing is used')
3822
3823
3824	END SUBROUTINE radiation_header
3825
3826
3827	!------------------------------------------------------------------------------!
3828	! Description:
3829	! ------------
3830	!> Parin for &radiation_parameters for radiation model
3831	!------------------------------------------------------------------------------!
3832	SUBROUTINE radiation_parin
3833
3834
3835	IMPLICIT NONE
3836
3837	CHARACTER (LEN=80) :: line !< dummy string that contains the current line of the parameter file
3838
3839	NAMELIST /radiation_par/ albedo, albedo_lw_dif, albedo_lw_dir, &
3840	albedo_sw_dif, albedo_sw_dir, albedo_type, &
3841	constant_albedo, dt_radiation, emissivity, &
3842	lw_radiation, max_raytracing_dist, &
3843	min_irrf_value, mrt_geom_human, &
3844	mrt_include_sw, mrt_nlevels, &
3845	mrt_skip_roof, net_radiation, nrefsteps, &
3846	plant_lw_interact, rad_angular_discretization,&
3847	radiation_interactions_on, radiation_scheme, &
3848	raytrace_discrete_azims, &
3849	raytrace_discrete_elevs, raytrace_mpi_rma, &
3850	skip_time_do_radiation, surface_reflections, &
3851	svfnorm_report_thresh, sw_radiation, &
3852	unscheduled_radiation_calls
3853
3854
3855	NAMELIST /radiation_parameters/ albedo, albedo_lw_dif, albedo_lw_dir, &
3856	albedo_sw_dif, albedo_sw_dir, albedo_type, &
3857	constant_albedo, dt_radiation, emissivity, &
3858	lw_radiation, max_raytracing_dist, &
3859	min_irrf_value, mrt_geom_human, &
3860	mrt_include_sw, mrt_nlevels, &
3861	mrt_skip_roof, net_radiation, nrefsteps, &
3862	plant_lw_interact, rad_angular_discretization,&
3863	radiation_interactions_on, radiation_scheme, &
3864	raytrace_discrete_azims, &
3865	raytrace_discrete_elevs, raytrace_mpi_rma, &
3866	skip_time_do_radiation, surface_reflections, &
3867	svfnorm_report_thresh, sw_radiation, &
3868	unscheduled_radiation_calls
3869
3870	line = ' '
3871
3872	!
3873	!-- Try to find radiation model namelist
3874	REWIND ( 11 )
3875	line = ' '
3876	DO WHILE ( INDEX( line, '&radiation_parameters' ) == 0 )
3877	READ ( 11, '(A)', END=12 ) line
3878	ENDDO
3879	BACKSPACE ( 11 )
3880
3881	!
3882	!-- Read user-defined namelist
3883	READ ( 11, radiation_parameters, ERR = 10 )
3884
3885	!
3886	!-- Set flag that indicates that the radiation model is switched on
3887	radiation = .TRUE.
3888
3889	GOTO 14
3890
3891	10 BACKSPACE( 11 )
3892	READ( 11 , '(A)') line
3893	CALL parin_fail_message( 'radiation_parameters', line )
3894	!
3895	!-- Try to find old namelist
3896	12 REWIND ( 11 )
3897	line = ' '
3898	DO WHILE ( INDEX( line, '&radiation_par' ) == 0 )
3899	READ ( 11, '(A)', END=14 ) line
3900	ENDDO
3901	BACKSPACE ( 11 )
3902
3903	!
3904	!-- Read user-defined namelist
3905	READ ( 11, radiation_par, ERR = 13, END = 14 )
3906
3907	message_string = 'namelist radiation_par is deprecated and will be ' // &
3908	'removed in near future. Please use namelist ' // &
3909	'radiation_parameters instead'
3910	CALL message( 'radiation_parin', 'PA0487', 0, 1, 0, 6, 0 )
3911
3912	!
3913	!-- Set flag that indicates that the radiation model is switched on
3914	radiation = .TRUE.
3915
3916	IF ( .NOT. radiation_interactions_on .AND. surface_reflections ) THEN
3917	message_string = 'surface_reflections is allowed only when ' // &
3918	'radiation_interactions_on is set to TRUE'
3919	CALL message( 'radiation_parin', 'PA0293',1, 2, 0, 6, 0 )
3920	ENDIF
3921
3922	GOTO 14
3923
3924	13 BACKSPACE( 11 )
3925	READ( 11 , '(A)') line
3926	CALL parin_fail_message( 'radiation_par', line )
3927
3928	14 CONTINUE
3929
3930	END SUBROUTINE radiation_parin
3931
3932
3933	!------------------------------------------------------------------------------!
3934	! Description:
3935	! ------------
3936	!> Implementation of the RRTMG radiation_scheme
3937	!------------------------------------------------------------------------------!
3938	SUBROUTINE radiation_rrtmg
3939
3940	#if defined ( __rrtmg )
3941	USE indices, &
3942	ONLY: nbgp
3943
3944	USE palm_date_time_mod, &
3945	ONLY: hours_per_day
3946
3947	USE particle_attributes, &
3948	ONLY: grid_particles, number_of_particles, particles, prt_count
3949
3950	IMPLICIT NONE
3951
3952
3953	INTEGER(iwp) :: i, j, k, l, m, n !< loop indices
3954	INTEGER(iwp) :: k_topo_l !< topography top index
3955	INTEGER(iwp) :: k_topo !< topography top index
3956
3957	REAL(wp) :: d_hours_day !< 1 / hours-per-day
3958	REAL(wp) :: nc_rad, & !< number concentration of cloud droplets
3959	s_r2, & !< weighted sum over all droplets with r^2
3960	s_r3 !< weighted sum over all droplets with r^3
3961
3962	REAL(wp), DIMENSION(0:nzt+1) :: pt_av, q_av, ql_av
3963	REAL(wp), DIMENSION(0:0) :: zenith !< to provide indexed array
3964	!
3965	!-- Just dummy arguments
3966	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rrtm_lw_taucld_dum, &
3967	rrtm_lw_tauaer_dum, &
3968	rrtm_sw_taucld_dum, &
3969	rrtm_sw_ssacld_dum, &
3970	rrtm_sw_asmcld_dum, &
3971	rrtm_sw_fsfcld_dum, &
3972	rrtm_sw_tauaer_dum, &
3973	rrtm_sw_ssaaer_dum, &
3974	rrtm_sw_asmaer_dum, &
3975	rrtm_sw_ecaer_dum
3976
3977	!
3978	!-- Pre-calculate parameters
3979	d_hours_day = 1.0_wp / REAL( hours_per_day, KIND=wp )
3980
3981	!
3982	!-- Calculate current (cosine of) zenith angle and whether the sun is up
3983	CALL get_date_time( time_since_reference_point, &
3984	day_of_year=day_of_year, &
3985	second_of_day=second_of_day )
3986	CALL calc_zenith( day_of_year, second_of_day )
3987	zenith(0) = cos_zenith
3988	!
3989	!-- Calculate surface albedo. In case average radiation is applied,
3990	!-- this is not required.
3991	#if defined( __netcdf )
3992	IF ( .NOT. constant_albedo ) THEN
3993	!
3994	!-- Horizontally aligned default, natural and urban surfaces
3995	CALL calc_albedo( surf_lsm_h )
3996	CALL calc_albedo( surf_usm_h )
3997	!
3998	!-- Vertically aligned default, natural and urban surfaces
3999	DO l = 0, 3
4000	CALL calc_albedo( surf_lsm_v(l) )
4001	CALL calc_albedo( surf_usm_v(l) )
4002	ENDDO
4003	ENDIF
4004	#endif
4005
4006	!
4007	!-- Prepare input data for RRTMG
4008
4009	!
4010	!-- In case of large scale forcing with surface data, calculate new pressure
4011	!-- profile. nzt_rad might be modified by these calls and all required arrays
4012	!-- will then be re-allocated
4013	IF ( large_scale_forcing .AND. lsf_surf ) THEN
4014	CALL read_sounding_data
4015	CALL read_trace_gas_data
4016	ENDIF
4017
4018
4019	IF ( average_radiation ) THEN
4020	!
4021	!-- Determine minimum topography top index.
4022	k_topo_l = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
4023	#if defined( __parallel )
4024	CALL MPI_ALLREDUCE( k_topo_l, k_topo, 1, MPI_INTEGER, MPI_MIN, &
4025	comm2d, ierr)
4026	#else
4027	k_topo = k_topo_l
4028	#endif
4029
4030	rrtm_asdir(1) = albedo_urb
4031	rrtm_asdif(1) = albedo_urb
4032	rrtm_aldir(1) = albedo_urb
4033	rrtm_aldif(1) = albedo_urb
4034
4035	rrtm_emis = emissivity_urb
4036	!
4037	!-- Calculate mean pt profile.
4038	CALL calc_mean_profile( pt, 4 )
4039	pt_av = hom(:, 1, 4, 0)
4040
4041	IF ( humidity ) THEN
4042	CALL calc_mean_profile( q, 41 )
4043	q_av = hom(:, 1, 41, 0)
4044	ENDIF
4045	!
4046	!-- Prepare profiles of temperature and H2O volume mixing ratio
4047	rrtm_tlev(0,k_topo+1) = t_rad_urb
4048
4049	IF ( bulk_cloud_model ) THEN
4050
4051	CALL calc_mean_profile( ql, 54 )
4052	! average ql is now in hom(:, 1, 54, 0)
4053	ql_av = hom(:, 1, 54, 0)
4054
4055	DO k = nzb+1, nzt+1
4056	rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp &
4057	)*.286_wp + lv_d_cp ql_av(k)
4058	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q_av(k) - ql_av(k))
4059	ENDDO
4060	ELSE
4061	DO k = nzb+1, nzt+1
4062	rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp &
4063	)**.286_wp
4064	ENDDO
4065
4066	IF ( humidity ) THEN
4067	DO k = nzb+1, nzt+1
4068	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q_av(k)
4069	ENDDO
4070	ELSE
4071	rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp
4072	ENDIF
4073	ENDIF
4074
4075	!
4076	!-- Avoid temperature/humidity jumps at the top of the PALM domain by
4077	!-- linear interpolation from nzt+2 to nzt+7. Jumps are induced by
4078	!-- discrepancies between the values in the domain and those above that
4079	!-- are prescribed in RRTMG
4080	DO k = nzt+2, nzt+7
4081	rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) &
4082	+ ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) &
4083	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) &
4084	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
4085
4086	rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) &
4087	+ ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )&
4088	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )&
4089	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
4090
4091	ENDDO
4092
4093	!-- Linear interpolate to zw grid. Loop reaches one level further up
4094	!-- due to the staggered grid in RRTMG
4095	DO k = k_topo+2, nzt+8
4096	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - &
4097	rrtm_tlay(0,k-1)) &
4098	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
4099	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
4100	ENDDO
4101	!
4102	!-- Calculate liquid water path and cloud fraction for each column.
4103	!-- Note that LWP is required in g/m2 instead of kg/kg m.
4104	rrtm_cldfr = 0.0_wp
4105	rrtm_reliq = 0.0_wp
4106	rrtm_cliqwp = 0.0_wp
4107	rrtm_icld = 0
4108
4109	IF ( bulk_cloud_model ) THEN
4110	DO k = nzb+1, nzt+1
4111	rrtm_cliqwp(0,k) = ql_av(k) * 1000._wp * &
4112	(rrtm_plev(0,k) - rrtm_plev(0,k+1)) &
4113	* 100._wp / g
4114
4115	IF ( rrtm_cliqwp(0,k) > 0._wp ) THEN
4116	rrtm_cldfr(0,k) = 1._wp
4117	IF ( rrtm_icld == 0 ) rrtm_icld = 1
4118
4119	!
4120	!-- Calculate cloud droplet effective radius
4121	rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql_av(k) &
4122	* rho_surface &
4123	/ ( 4.0_wp * pi * nc_const * rho_l ) &
4124	)**0.33333333333333_wp &
4125	* EXP( LOG( sigma_gc )**2 )
4126	!
4127	!-- Limit effective radius
4128	IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN
4129	rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp)
4130	rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp)
4131	ENDIF
4132	ENDIF
4133	ENDDO
4134	ENDIF
4135
4136	!
4137	!-- Set surface temperature
4138	rrtm_tsfc = t_rad_urb
4139
4140	IF ( lw_radiation ) THEN
4141	!
4142	!-- Due to technical reasons, copy optical depth to dummy arguments
4143	!-- which are allocated on the exact size as the rrtmg_lw is called.
4144	!-- As one dimesion is allocated with zero size, compiler complains
4145	!-- that rank of the array does not match that of the
4146	!-- assumed-shaped arguments in the RRTMG library. In order to
4147	!-- avoid this, write to dummy arguments and give pass the entire
4148	!-- dummy array. Seems to be the only existing work-around.
4149	ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) )
4150	ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) )
4151
4152	rrtm_lw_taucld_dum = &
4153	rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1)
4154	rrtm_lw_tauaer_dum = &
4155	rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1)
4156
4157	CALL rrtmg_lw( 1, &
4158	nzt_rad-k_topo, &
4159	rrtm_icld, &
4160	rrtm_idrv, &
4161	rrtm_play(:,k_topo+1:), &
4162	rrtm_plev(:,k_topo+1:), &
4163	rrtm_tlay(:,k_topo+1:), &
4164	rrtm_tlev(:,k_topo+1:), &
4165	rrtm_tsfc, &
4166	rrtm_h2ovmr(:,k_topo+1:), &
4167	rrtm_o3vmr(:,k_topo+1:), &
4168	rrtm_co2vmr(:,k_topo+1:), &
4169	rrtm_ch4vmr(:,k_topo+1:), &
4170	rrtm_n2ovmr(:,k_topo+1:), &
4171	rrtm_o2vmr(:,k_topo+1:), &
4172	rrtm_cfc11vmr(:,k_topo+1:), &
4173	rrtm_cfc12vmr(:,k_topo+1:), &
4174	rrtm_cfc22vmr(:,k_topo+1:), &
4175	rrtm_ccl4vmr(:,k_topo+1:), &
4176	rrtm_emis, &
4177	rrtm_inflglw, &
4178	rrtm_iceflglw, &
4179	rrtm_liqflglw, &
4180	rrtm_cldfr(:,k_topo+1:), &
4181	rrtm_lw_taucld_dum, &
4182	rrtm_cicewp(:,k_topo+1:), &
4183	rrtm_cliqwp(:,k_topo+1:), &
4184	rrtm_reice(:,k_topo+1:), &
4185	rrtm_reliq(:,k_topo+1:), &
4186	rrtm_lw_tauaer_dum, &
4187	rrtm_lwuflx(:,k_topo:), &
4188	rrtm_lwdflx(:,k_topo:), &
4189	rrtm_lwhr(:,k_topo+1:), &
4190	rrtm_lwuflxc(:,k_topo:), &
4191	rrtm_lwdflxc(:,k_topo:), &
4192	rrtm_lwhrc(:,k_topo+1:), &
4193	rrtm_lwuflx_dt(:,k_topo:), &
4194	rrtm_lwuflxc_dt(:,k_topo:) )
4195
4196	DEALLOCATE ( rrtm_lw_taucld_dum )
4197	DEALLOCATE ( rrtm_lw_tauaer_dum )
4198	!
4199	!-- Save fluxes
4200	DO k = nzb, nzt+1
4201	rad_lw_in(k,:,:) = rrtm_lwdflx(0,k)
4202	rad_lw_out(k,:,:) = rrtm_lwuflx(0,k)
4203	ENDDO
4204	rad_lw_in_diff(:,:) = rad_lw_in(k_topo,:,:)
4205	!
4206	!-- Save heating rates (convert from K/d to K/h).
4207	!-- Further, even though an aggregated radiation is computed, map
4208	!-- signle-column profiles on top of any topography, in order to
4209	!-- obtain correct near surface radiation heating/cooling rates.
4210	DO i = nxl, nxr
4211	DO j = nys, nyn
4212	k_topo_l = topo_top_ind(j,i,0)
4213	DO k = k_topo_l+1, nzt+1
4214	rad_lw_hr(k,j,i) = rrtm_lwhr(0,k-k_topo_l) * d_hours_day
4215	rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k-k_topo_l) * d_hours_day
4216	ENDDO
4217	ENDDO
4218	ENDDO
4219
4220	ENDIF
4221
4222	IF ( sw_radiation .AND. sun_up ) THEN
4223	!
4224	!-- Due to technical reasons, copy optical depths and other
4225	!-- to dummy arguments which are allocated on the exact size as the
4226	!-- rrtmg_sw is called.
4227	!-- As one dimesion is allocated with zero size, compiler complains
4228	!-- that rank of the array does not match that of the
4229	!-- assumed-shaped arguments in the RRTMG library. In order to
4230	!-- avoid this, write to dummy arguments and give pass the entire
4231	!-- dummy array. Seems to be the only existing work-around.
4232	ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4233	ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4234	ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4235	ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4236	ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4237	ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4238	ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4239	ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) )
4240
4241	rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4242	rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4243	rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4244	rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4245	rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4246	rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4247	rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4248	rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1)
4249
4250	CALL rrtmg_sw( 1, &
4251	nzt_rad-k_topo, &
4252	rrtm_icld, &
4253	rrtm_iaer, &
4254	rrtm_play(:,k_topo+1:nzt_rad+1), &
4255	rrtm_plev(:,k_topo+1:nzt_rad+2), &
4256	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
4257	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
4258	rrtm_tsfc, &
4259	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
4260	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
4261	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
4262	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
4263	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
4264	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
4265	rrtm_asdir, &
4266	rrtm_asdif, &
4267	rrtm_aldir, &
4268	rrtm_aldif, &
4269	zenith, &
4270	0.0_wp, &
4271	day_of_year, &
4272	solar_constant, &
4273	rrtm_inflgsw, &
4274	rrtm_iceflgsw, &
4275	rrtm_liqflgsw, &
4276	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
4277	rrtm_sw_taucld_dum, &
4278	rrtm_sw_ssacld_dum, &
4279	rrtm_sw_asmcld_dum, &
4280	rrtm_sw_fsfcld_dum, &
4281	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
4282	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
4283	rrtm_reice(:,k_topo+1:nzt_rad+1), &
4284	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
4285	rrtm_sw_tauaer_dum, &
4286	rrtm_sw_ssaaer_dum, &
4287	rrtm_sw_asmaer_dum, &
4288	rrtm_sw_ecaer_dum, &
4289	rrtm_swuflx(:,k_topo:nzt_rad+1), &
4290	rrtm_swdflx(:,k_topo:nzt_rad+1), &
4291	rrtm_swhr(:,k_topo+1:nzt_rad+1), &
4292	rrtm_swuflxc(:,k_topo:nzt_rad+1), &
4293	rrtm_swdflxc(:,k_topo:nzt_rad+1), &
4294	rrtm_swhrc(:,k_topo+1:nzt_rad+1), &
4295	rrtm_dirdflux(:,k_topo:nzt_rad+1), &
4296	rrtm_difdflux(:,k_topo:nzt_rad+1) )
4297
4298	DEALLOCATE( rrtm_sw_taucld_dum )
4299	DEALLOCATE( rrtm_sw_ssacld_dum )
4300	DEALLOCATE( rrtm_sw_asmcld_dum )
4301	DEALLOCATE( rrtm_sw_fsfcld_dum )
4302	DEALLOCATE( rrtm_sw_tauaer_dum )
4303	DEALLOCATE( rrtm_sw_ssaaer_dum )
4304	DEALLOCATE( rrtm_sw_asmaer_dum )
4305	DEALLOCATE( rrtm_sw_ecaer_dum )
4306
4307	!
4308	!-- Save radiation fluxes for the entire depth of the model domain
4309	DO k = nzb, nzt+1
4310	rad_sw_in(k,:,:) = rrtm_swdflx(0,k)
4311	rad_sw_out(k,:,:) = rrtm_swuflx(0,k)
4312	ENDDO
4313	!-- Save direct and diffuse SW radiation at the surface (required by RTM)
4314	rad_sw_in_dir(:,:) = rrtm_dirdflux(0,k_topo)
4315	rad_sw_in_diff(:,:) = rrtm_difdflux(0,k_topo)
4316
4317	!
4318	!-- Save heating rates (convert from K/d to K/s)
4319	DO k = nzb+1, nzt+1
4320	rad_sw_hr(k,:,:) = rrtm_swhr(0,k) * d_hours_day
4321	rad_sw_cs_hr(k,:,:) = rrtm_swhrc(0,k) * d_hours_day
4322	ENDDO
4323	!
4324	!-- Solar radiation is zero during night
4325	ELSE
4326	rad_sw_in = 0.0_wp
4327	rad_sw_out = 0.0_wp
4328	rad_sw_in_dir(:,:) = 0.0_wp
4329	rad_sw_in_diff(:,:) = 0.0_wp
4330	ENDIF
4331	!
4332	!-- RRTMG is called for each (j,i) grid point separately, starting at the
4333	!-- highest topography level. Here no RTM is used since average_radiation is false
4334	ELSE
4335	!
4336	!-- Loop over all grid points
4337	DO i = nxl, nxr
4338	DO j = nys, nyn
4339
4340	!
4341	!-- Prepare profiles of temperature and H2O volume mixing ratio
4342	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
4343	rrtm_tlev(0,nzb+1) = surf_lsm_h%pt_surface(m) * exner(nzb)
4344	ENDDO
4345	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
4346	rrtm_tlev(0,nzb+1) = surf_usm_h%pt_surface(m) * exner(nzb)
4347	ENDDO
4348
4349
4350	IF ( bulk_cloud_model ) THEN
4351	DO k = nzb+1, nzt+1
4352	rrtm_tlay(0,k) = pt(k,j,i) * exner(k) &
4353	+ lv_d_cp * ql(k,j,i)
4354	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q(k,j,i) - ql(k,j,i))
4355	ENDDO
4356	ELSEIF ( cloud_droplets ) THEN
4357	DO k = nzb+1, nzt+1
4358	rrtm_tlay(0,k) = pt(k,j,i) * exner(k) &
4359	+ lv_d_cp * ql(k,j,i)
4360	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i)
4361	ENDDO
4362	ELSE
4363	DO k = nzb+1, nzt+1
4364	rrtm_tlay(0,k) = pt(k,j,i) * exner(k)
4365	ENDDO
4366
4367	IF ( humidity ) THEN
4368	DO k = nzb+1, nzt+1
4369	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i)
4370	ENDDO
4371	ELSE
4372	rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp
4373	ENDIF
4374	ENDIF
4375
4376	!
4377	!-- Avoid temperature/humidity jumps at the top of the LES domain by
4378	!-- linear interpolation from nzt+2 to nzt+7
4379	DO k = nzt+2, nzt+7
4380	rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) &
4381	+ ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) &
4382	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) &
4383	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
4384
4385	rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) &
4386	+ ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )&
4387	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )&
4388	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
4389
4390	ENDDO
4391
4392	!-- Linear interpolate to zw grid
4393	DO k = nzb+2, nzt+8
4394	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - &
4395	rrtm_tlay(0,k-1)) &
4396	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
4397	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
4398	ENDDO
4399
4400
4401	!
4402	!-- Calculate liquid water path and cloud fraction for each column.
4403	!-- Note that LWP is required in g/m2 instead of kg/kg m.
4404	rrtm_cldfr = 0.0_wp
4405	rrtm_reliq = 0.0_wp
4406	rrtm_cliqwp = 0.0_wp
4407	rrtm_icld = 0
4408
4409	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
4410	DO k = nzb+1, nzt+1
4411	rrtm_cliqwp(0,k) = ql(k,j,i) * 1000.0_wp * &
4412	(rrtm_plev(0,k) - rrtm_plev(0,k+1)) &
4413	* 100.0_wp / g
4414
4415	IF ( rrtm_cliqwp(0,k) > 0.0_wp ) THEN
4416	rrtm_cldfr(0,k) = 1.0_wp
4417	IF ( rrtm_icld == 0 ) rrtm_icld = 1
4418
4419	!
4420	!-- Calculate cloud droplet effective radius
4421	IF ( bulk_cloud_model ) THEN
4422	!
4423	!-- Calculete effective droplet radius. In case of using
4424	!-- cloud_scheme = 'morrison' and a non reasonable number
4425	!-- of cloud droplets the inital aerosol number
4426	!-- concentration is considered.
4427	IF ( microphysics_morrison ) THEN
4428	IF ( nc(k,j,i) > 1.0E-20_wp ) THEN
4429	nc_rad = nc(k,j,i)
4430	ELSE
4431	nc_rad = na_init
4432	ENDIF
4433	ELSE
4434	nc_rad = nc_const
4435	ENDIF
4436
4437	rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql(k,j,i) &
4438	* rho_surface &
4439	/ ( 4.0_wp * pi * nc_rad * rho_l ) &
4440	)**0.33333333333333_wp &
4441	* EXP( LOG( sigma_gc )**2 )
4442
4443	ELSEIF ( cloud_droplets ) THEN
4444	number_of_particles = prt_count(k,j,i)
4445
4446	IF (number_of_particles <= 0) CYCLE
4447	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
4448	s_r2 = 0.0_wp
4449	s_r3 = 0.0_wp
4450
4451	DO n = 1, number_of_particles
4452	IF ( particles(n)%particle_mask ) THEN
4453	s_r2 = s_r2 + particles(n)%radius*2 &
4454	particles(n)%weight_factor
4455	s_r3 = s_r3 + particles(n)%radius*3 &
4456	particles(n)%weight_factor
4457	ENDIF
4458	ENDDO
4459
4460	IF ( s_r2 > 0.0_wp ) rrtm_reliq(0,k) = s_r3 / s_r2
4461
4462	ENDIF
4463
4464	!
4465	!-- Limit effective radius
4466	IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN
4467	rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp)
4468	rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp)
4469	ENDIF
4470	ENDIF
4471	ENDDO
4472	ENDIF
4473
4474	!
4475	!-- Write surface emissivity and surface temperature at current
4476	!-- surface element on RRTMG-shaped array.
4477	!-- Please note, as RRTMG is a single column model, surface attributes
4478	!-- are only obtained from horizontally aligned surfaces (for
4479	!-- simplicity). Taking surface attributes from horizontal and
4480	!-- vertical walls would lead to multiple solutions.
4481	!-- Moreover, for natural- and urban-type surfaces, several surface
4482	!-- classes can exist at a surface element next to each other.
4483	!-- To obtain bulk parameters, apply a weighted average for these
4484	!-- surfaces.
4485	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
4486	rrtm_emis = surf_lsm_h%frac(ind_veg_wall,m) * &
4487	surf_lsm_h%emissivity(ind_veg_wall,m) + &
4488	surf_lsm_h%frac(ind_pav_green,m) * &
4489	surf_lsm_h%emissivity(ind_pav_green,m) + &
4490	surf_lsm_h%frac(ind_wat_win,m) * &
4491	surf_lsm_h%emissivity(ind_wat_win,m)
4492	rrtm_tsfc = surf_lsm_h%pt_surface(m) * exner(nzb)
4493	ENDDO
4494	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
4495	rrtm_emis = surf_usm_h%frac(ind_veg_wall,m) * &
4496	surf_usm_h%emissivity(ind_veg_wall,m) + &
4497	surf_usm_h%frac(ind_pav_green,m) * &
4498	surf_usm_h%emissivity(ind_pav_green,m) + &
4499	surf_usm_h%frac(ind_wat_win,m) * &
4500	surf_usm_h%emissivity(ind_wat_win,m)
4501	rrtm_tsfc = surf_usm_h%pt_surface(m) * exner(nzb)
4502	ENDDO
4503	!
4504	!-- Obtain topography top index (lower bound of RRTMG)
4505	k_topo = topo_top_ind(j,i,0)
4506
4507	IF ( lw_radiation ) THEN
4508	!
4509	!-- Due to technical reasons, copy optical depth to dummy arguments
4510	!-- which are allocated on the exact size as the rrtmg_lw is called.
4511	!-- As one dimesion is allocated with zero size, compiler complains
4512	!-- that rank of the array does not match that of the
4513	!-- assumed-shaped arguments in the RRTMG library. In order to
4514	!-- avoid this, write to dummy arguments and give pass the entire
4515	!-- dummy array. Seems to be the only existing work-around.
4516	ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) )
4517	ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) )
4518
4519	rrtm_lw_taucld_dum = &
4520	rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1)
4521	rrtm_lw_tauaer_dum = &
4522	rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1)
4523
4524	CALL rrtmg_lw( 1, &
4525	nzt_rad-k_topo, &
4526	rrtm_icld, &
4527	rrtm_idrv, &
4528	rrtm_play(:,k_topo+1:nzt_rad+1), &
4529	rrtm_plev(:,k_topo+1:nzt_rad+2), &
4530	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
4531	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
4532	rrtm_tsfc, &
4533	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
4534	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
4535	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
4536	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
4537	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
4538	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
4539	rrtm_cfc11vmr(:,k_topo+1:nzt_rad+1), &
4540	rrtm_cfc12vmr(:,k_topo+1:nzt_rad+1), &
4541	rrtm_cfc22vmr(:,k_topo+1:nzt_rad+1), &
4542	rrtm_ccl4vmr(:,k_topo+1:nzt_rad+1), &
4543	rrtm_emis, &
4544	rrtm_inflglw, &
4545	rrtm_iceflglw, &
4546	rrtm_liqflglw, &
4547	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
4548	rrtm_lw_taucld_dum, &
4549	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
4550	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
4551	rrtm_reice(:,k_topo+1:nzt_rad+1), &
4552	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
4553	rrtm_lw_tauaer_dum, &
4554	rrtm_lwuflx(:,k_topo:nzt_rad+1), &
4555	rrtm_lwdflx(:,k_topo:nzt_rad+1), &
4556	rrtm_lwhr(:,k_topo+1:nzt_rad+1), &
4557	rrtm_lwuflxc(:,k_topo:nzt_rad+1), &
4558	rrtm_lwdflxc(:,k_topo:nzt_rad+1), &
4559	rrtm_lwhrc(:,k_topo+1:nzt_rad+1), &
4560	rrtm_lwuflx_dt(:,k_topo:nzt_rad+1), &
4561	rrtm_lwuflxc_dt(:,k_topo:nzt_rad+1) )
4562
4563	DEALLOCATE ( rrtm_lw_taucld_dum )
4564	DEALLOCATE ( rrtm_lw_tauaer_dum )
4565	!
4566	!-- Save fluxes
4567	DO k = k_topo, nzt+1
4568	rad_lw_in(k,j,i) = rrtm_lwdflx(0,k)
4569	rad_lw_out(k,j,i) = rrtm_lwuflx(0,k)
4570	ENDDO
4571
4572	!
4573	!-- Save heating rates (convert from K/d to K/h)
4574	DO k = k_topo+1, nzt+1
4575	rad_lw_hr(k,j,i) = rrtm_lwhr(0,k-k_topo) * d_hours_day
4576	rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k-k_topo) * d_hours_day
4577	ENDDO
4578
4579	!
4580	!-- Save surface radiative fluxes and change in LW heating rate
4581	!-- onto respective surface elements
4582	!-- Horizontal surfaces
4583	DO m = surf_lsm_h%start_index(j,i), &
4584	surf_lsm_h%end_index(j,i)
4585	surf_lsm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo)
4586	surf_lsm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo)
4587	surf_lsm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo)
4588	ENDDO
4589	DO m = surf_usm_h%start_index(j,i), &
4590	surf_usm_h%end_index(j,i)
4591	surf_usm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo)
4592	surf_usm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo)
4593	surf_usm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo)
4594	ENDDO
4595	!
4596	!-- Vertical surfaces. Fluxes are obtain at vertical level of the
4597	!-- respective surface element
4598	DO l = 0, 3
4599	DO m = surf_lsm_v(l)%start_index(j,i), &
4600	surf_lsm_v(l)%end_index(j,i)
4601	k = surf_lsm_v(l)%k(m)
4602	surf_lsm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k)
4603	surf_lsm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k)
4604	surf_lsm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
4605	ENDDO
4606	DO m = surf_usm_v(l)%start_index(j,i), &
4607	surf_usm_v(l)%end_index(j,i)
4608	k = surf_usm_v(l)%k(m)
4609	surf_usm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k)
4610	surf_usm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k)
4611	surf_usm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
4612	ENDDO
4613	ENDDO
4614
4615	ENDIF
4616
4617	IF ( sw_radiation .AND. sun_up ) THEN
4618	!
4619	!-- Get albedo for direct/diffusive long/shortwave radiation at
4620	!-- current (y,x)-location from surface variables.
4621	!-- Only obtain it from horizontal surfaces, as RRTMG is a single
4622	!-- column model
4623	!-- (Please note, only one loop will entered, controlled by
4624	!-- start-end index.)
4625	DO m = surf_lsm_h%start_index(j,i), &
4626	surf_lsm_h%end_index(j,i)
4627	rrtm_asdir(1) = SUM( surf_lsm_h%frac(:,m) * &
4628	surf_lsm_h%rrtm_asdir(:,m) )
4629	rrtm_asdif(1) = SUM( surf_lsm_h%frac(:,m) * &
4630	surf_lsm_h%rrtm_asdif(:,m) )
4631	rrtm_aldir(1) = SUM( surf_lsm_h%frac(:,m) * &
4632	surf_lsm_h%rrtm_aldir(:,m) )
4633	rrtm_aldif(1) = SUM( surf_lsm_h%frac(:,m) * &
4634	surf_lsm_h%rrtm_aldif(:,m) )
4635	ENDDO
4636	DO m = surf_usm_h%start_index(j,i), &
4637	surf_usm_h%end_index(j,i)
4638	rrtm_asdir(1) = SUM( surf_usm_h%frac(:,m) * &
4639	surf_usm_h%rrtm_asdir(:,m) )
4640	rrtm_asdif(1) = SUM( surf_usm_h%frac(:,m) * &
4641	surf_usm_h%rrtm_asdif(:,m) )
4642	rrtm_aldir(1) = SUM( surf_usm_h%frac(:,m) * &
4643	surf_usm_h%rrtm_aldir(:,m) )
4644	rrtm_aldif(1) = SUM( surf_usm_h%frac(:,m) * &
4645	surf_usm_h%rrtm_aldif(:,m) )
4646	ENDDO
4647	!
4648	!-- Due to technical reasons, copy optical depths and other
4649	!-- to dummy arguments which are allocated on the exact size as the
4650	!-- rrtmg_sw is called.
4651	!-- As one dimesion is allocated with zero size, compiler complains
4652	!-- that rank of the array does not match that of the
4653	!-- assumed-shaped arguments in the RRTMG library. In order to
4654	!-- avoid this, write to dummy arguments and give pass the entire
4655	!-- dummy array. Seems to be the only existing work-around.
4656	ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4657	ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4658	ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4659	ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4660	ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4661	ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4662	ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4663	ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) )
4664
4665	rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4666	rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4667	rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4668	rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4669	rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4670	rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4671	rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4672	rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1)
4673
4674	CALL rrtmg_sw( 1, &
4675	nzt_rad-k_topo, &
4676	rrtm_icld, &
4677	rrtm_iaer, &
4678	rrtm_play(:,k_topo+1:nzt_rad+1), &
4679	rrtm_plev(:,k_topo+1:nzt_rad+2), &
4680	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
4681	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
4682	rrtm_tsfc, &
4683	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
4684	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
4685	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
4686	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
4687	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
4688	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
4689	rrtm_asdir, &
4690	rrtm_asdif, &
4691	rrtm_aldir, &
4692	rrtm_aldif, &
4693	zenith, &
4694	0.0_wp, &
4695	day_of_year, &
4696	solar_constant, &
4697	rrtm_inflgsw, &
4698	rrtm_iceflgsw, &
4699	rrtm_liqflgsw, &
4700	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
4701	rrtm_sw_taucld_dum, &
4702	rrtm_sw_ssacld_dum, &
4703	rrtm_sw_asmcld_dum, &
4704	rrtm_sw_fsfcld_dum, &
4705	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
4706	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
4707	rrtm_reice(:,k_topo+1:nzt_rad+1), &
4708	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
4709	rrtm_sw_tauaer_dum, &
4710	rrtm_sw_ssaaer_dum, &
4711	rrtm_sw_asmaer_dum, &
4712	rrtm_sw_ecaer_dum, &
4713	rrtm_swuflx(:,k_topo:nzt_rad+1), &
4714	rrtm_swdflx(:,k_topo:nzt_rad+1), &
4715	rrtm_swhr(:,k_topo+1:nzt_rad+1), &
4716	rrtm_swuflxc(:,k_topo:nzt_rad+1), &
4717	rrtm_swdflxc(:,k_topo:nzt_rad+1), &
4718	rrtm_swhrc(:,k_topo+1:nzt_rad+1), &
4719	rrtm_dirdflux(:,k_topo:nzt_rad+1), &
4720	rrtm_difdflux(:,k_topo:nzt_rad+1) )
4721
4722	DEALLOCATE( rrtm_sw_taucld_dum )
4723	DEALLOCATE( rrtm_sw_ssacld_dum )
4724	DEALLOCATE( rrtm_sw_asmcld_dum )
4725	DEALLOCATE( rrtm_sw_fsfcld_dum )
4726	DEALLOCATE( rrtm_sw_tauaer_dum )
4727	DEALLOCATE( rrtm_sw_ssaaer_dum )
4728	DEALLOCATE( rrtm_sw_asmaer_dum )
4729	DEALLOCATE( rrtm_sw_ecaer_dum )
4730	!
4731	!-- Save fluxes
4732	DO k = nzb, nzt+1
4733	rad_sw_in(k,j,i) = rrtm_swdflx(0,k)
4734	rad_sw_out(k,j,i) = rrtm_swuflx(0,k)
4735	ENDDO
4736	!
4737	!-- Save heating rates (convert from K/d to K/s)
4738	DO k = nzb+1, nzt+1
4739	rad_sw_hr(k,j,i) = rrtm_swhr(0,k) * d_hours_day
4740	rad_sw_cs_hr(k,j,i) = rrtm_swhrc(0,k) * d_hours_day
4741	ENDDO
4742
4743	!
4744	!-- Save surface radiative fluxes onto respective surface elements
4745	!-- Horizontal surfaces
4746	DO m = surf_lsm_h%start_index(j,i), &
4747	surf_lsm_h%end_index(j,i)
4748	surf_lsm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo)
4749	surf_lsm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo)
4750	ENDDO
4751	DO m = surf_usm_h%start_index(j,i), &
4752	surf_usm_h%end_index(j,i)
4753	surf_usm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo)
4754	surf_usm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo)
4755	ENDDO
4756	!
4757	!-- Vertical surfaces. Fluxes are obtain at respective vertical
4758	!-- level of the surface element
4759	DO l = 0, 3
4760	DO m = surf_lsm_v(l)%start_index(j,i), &
4761	surf_lsm_v(l)%end_index(j,i)
4762	k = surf_lsm_v(l)%k(m)
4763	surf_lsm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k)
4764	surf_lsm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
4765	ENDDO
4766	DO m = surf_usm_v(l)%start_index(j,i), &
4767	surf_usm_v(l)%end_index(j,i)
4768	k = surf_usm_v(l)%k(m)
4769	surf_usm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k)
4770	surf_usm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
4771	ENDDO
4772	ENDDO
4773	!
4774	!-- Solar radiation is zero during night
4775	ELSE
4776	rad_sw_in = 0.0_wp
4777	rad_sw_out = 0.0_wp
4778	!-- !!!!!!!! ATTENSION !!!!!!!!!!!!!!!
4779	!-- Surface radiative fluxes should be also set to zero here
4780	!-- Save surface radiative fluxes onto respective surface elements
4781	!-- Horizontal surfaces
4782	DO m = surf_lsm_h%start_index(j,i), &
4783	surf_lsm_h%end_index(j,i)
4784	surf_lsm_h%rad_sw_in(m) = 0.0_wp
4785	surf_lsm_h%rad_sw_out(m) = 0.0_wp
4786	ENDDO
4787	DO m = surf_usm_h%start_index(j,i), &
4788	surf_usm_h%end_index(j,i)
4789	surf_usm_h%rad_sw_in(m) = 0.0_wp
4790	surf_usm_h%rad_sw_out(m) = 0.0_wp
4791	ENDDO
4792	!
4793	!-- Vertical surfaces. Fluxes are obtain at respective vertical
4794	!-- level of the surface element
4795	DO l = 0, 3
4796	DO m = surf_lsm_v(l)%start_index(j,i), &
4797	surf_lsm_v(l)%end_index(j,i)
4798	k = surf_lsm_v(l)%k(m)
4799	surf_lsm_v(l)%rad_sw_in(m) = 0.0_wp
4800	surf_lsm_v(l)%rad_sw_out(m) = 0.0_wp
4801	ENDDO
4802	DO m = surf_usm_v(l)%start_index(j,i), &
4803	surf_usm_v(l)%end_index(j,i)
4804	k = surf_usm_v(l)%k(m)
4805	surf_usm_v(l)%rad_sw_in(m) = 0.0_wp
4806	surf_usm_v(l)%rad_sw_out(m) = 0.0_wp
4807	ENDDO
4808	ENDDO
4809	ENDIF
4810
4811	ENDDO
4812	ENDDO
4813
4814	ENDIF
4815	!
4816	!-- Finally, calculate surface net radiation for surface elements.
4817	IF ( .NOT. radiation_interactions ) THEN
4818	!-- First, for horizontal surfaces
4819	DO m = 1, surf_lsm_h%ns
4820	surf_lsm_h%rad_net(m) = surf_lsm_h%rad_sw_in(m) &
4821	- surf_lsm_h%rad_sw_out(m) &
4822	+ surf_lsm_h%rad_lw_in(m) &
4823	- surf_lsm_h%rad_lw_out(m)
4824	ENDDO
4825	DO m = 1, surf_usm_h%ns
4826	surf_usm_h%rad_net(m) = surf_usm_h%rad_sw_in(m) &
4827	- surf_usm_h%rad_sw_out(m) &
4828	+ surf_usm_h%rad_lw_in(m) &
4829	- surf_usm_h%rad_lw_out(m)
4830	ENDDO
4831	!
4832	!-- Vertical surfaces.
4833	!-- Todo: weight with azimuth and zenith angle according to their orientation!
4834	DO l = 0, 3
4835	DO m = 1, surf_lsm_v(l)%ns
4836	surf_lsm_v(l)%rad_net(m) = surf_lsm_v(l)%rad_sw_in(m) &
4837	- surf_lsm_v(l)%rad_sw_out(m) &
4838	+ surf_lsm_v(l)%rad_lw_in(m) &
4839	- surf_lsm_v(l)%rad_lw_out(m)
4840	ENDDO
4841	DO m = 1, surf_usm_v(l)%ns
4842	surf_usm_v(l)%rad_net(m) = surf_usm_v(l)%rad_sw_in(m) &
4843	- surf_usm_v(l)%rad_sw_out(m) &
4844	+ surf_usm_v(l)%rad_lw_in(m) &
4845	- surf_usm_v(l)%rad_lw_out(m)
4846	ENDDO
4847	ENDDO
4848	ENDIF
4849
4850
4851	CALL exchange_horiz( rad_lw_in, nbgp )
4852	CALL exchange_horiz( rad_lw_out, nbgp )
4853	CALL exchange_horiz( rad_lw_hr, nbgp )
4854	CALL exchange_horiz( rad_lw_cs_hr, nbgp )
4855
4856	CALL exchange_horiz( rad_sw_in, nbgp )
4857	CALL exchange_horiz( rad_sw_out, nbgp )
4858	CALL exchange_horiz( rad_sw_hr, nbgp )
4859	CALL exchange_horiz( rad_sw_cs_hr, nbgp )
4860
4861	#endif
4862
4863	END SUBROUTINE radiation_rrtmg
4864
4865
4866	!------------------------------------------------------------------------------!
4867	! Description:
4868	! ------------
4869	!> Calculate the cosine of the zenith angle (variable is called zenith)
4870	!------------------------------------------------------------------------------!
4871	SUBROUTINE calc_zenith( day_of_year, second_of_day )
4872
4873	USE palm_date_time_mod, &
4874	ONLY: seconds_per_day
4875
4876	IMPLICIT NONE
4877
4878	INTEGER(iwp), INTENT(IN) :: day_of_year !< day of the year
4879
4880	REAL(wp) :: declination !< solar declination angle
4881	REAL(wp) :: hour_angle !< solar hour angle
4882	REAL(wp), INTENT(IN) :: second_of_day !< current time of the day in UTC
4883
4884	!
4885	!-- Calculate solar declination and hour angle
4886	declination = ASIN( decl_1 * SIN(decl_2 * REAL(day_of_year, KIND=wp) - decl_3) )
4887	hour_angle = 2.0_wp * pi * ( second_of_day / seconds_per_day ) + lon - pi
4888
4889	!
4890	!-- Calculate cosine of solar zenith angle
4891	cos_zenith = SIN(lat) * SIN(declination) + COS(lat) * COS(declination) &
4892	* COS(hour_angle)
4893	cos_zenith = MAX(0.0_wp,cos_zenith)
4894
4895	!
4896	!-- Calculate solar directional vector
4897	IF ( sun_direction ) THEN
4898
4899	!
4900	!-- Direction in longitudes equals to sin(solar_azimuth) * sin(zenith)
4901	sun_dir_lon = -SIN(hour_angle) * COS(declination)
4902
4903	!
4904	!-- Direction in latitues equals to cos(solar_azimuth) * sin(zenith)
4905	sun_dir_lat = SIN(declination) * COS(lat) - COS(hour_angle) &
4906	* COS(declination) * SIN(lat)
4907	ENDIF
4908
4909	!
4910	!-- Check if the sun is up (otheriwse shortwave calculations can be skipped)
4911	IF ( cos_zenith > 0.0_wp ) THEN
4912	sun_up = .TRUE.
4913	ELSE
4914	sun_up = .FALSE.
4915	END IF
4916
4917	END SUBROUTINE calc_zenith
4918
4919	#if defined ( __rrtmg ) && defined ( __netcdf )
4920	!------------------------------------------------------------------------------!
4921	! Description:
4922	! ------------
4923	!> Calculates surface albedo components based on Briegleb (1992) and
4924	!> Briegleb et al. (1986)
4925	!------------------------------------------------------------------------------!
4926	SUBROUTINE calc_albedo( surf )
4927
4928	IMPLICIT NONE
4929
4930	INTEGER(iwp) :: ind_type !< running index surface tiles
4931	INTEGER(iwp) :: m !< running index surface elements
4932
4933	TYPE(surf_type) :: surf !< treated surfaces
4934
4935	IF ( sun_up .AND. .NOT. average_radiation ) THEN
4936
4937	DO m = 1, surf%ns
4938	!
4939	!-- Loop over surface elements
4940	DO ind_type = 0, SIZE( surf%albedo_type, 1 ) - 1
4941
4942	!
4943	!-- Ocean
4944	IF ( surf%albedo_type(ind_type,m) == 1 ) THEN
4945	surf%rrtm_aldir(ind_type,m) = 0.026_wp / &
4946	( cos_zenith**1.7_wp + 0.065_wp )&
4947	+ 0.15_wp * ( cos_zenith - 0.1_wp ) &
4948	* ( cos_zenith - 0.5_wp ) &
4949	* ( cos_zenith - 1.0_wp )
4950	surf%rrtm_asdir(ind_type,m) = surf%rrtm_aldir(ind_type,m)
4951	!
4952	!-- Snow
4953	ELSEIF ( surf%albedo_type(ind_type,m) == 16 ) THEN
4954	IF ( cos_zenith < 0.5_wp ) THEN
4955	surf%rrtm_aldir(ind_type,m) = &
4956	0.5_wp * ( 1.0_wp - surf%aldif(ind_type,m) ) &
4957	* ( 3.0_wp / ( 1.0_wp + 4.0_wp &
4958	* cos_zenith ) ) - 1.0_wp
4959	surf%rrtm_asdir(ind_type,m) = &
4960	0.5_wp * ( 1.0_wp - surf%asdif(ind_type,m) ) &
4961	* ( 3.0_wp / ( 1.0_wp + 4.0_wp &
4962	* cos_zenith ) ) - 1.0_wp
4963
4964	surf%rrtm_aldir(ind_type,m) = &
4965	MIN(0.98_wp, surf%rrtm_aldir(ind_type,m))
4966	surf%rrtm_asdir(ind_type,m) = &
4967	MIN(0.98_wp, surf%rrtm_asdir(ind_type,m))
4968	ELSE
4969	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4970	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4971	ENDIF
4972	!
4973	!-- Sea ice
4974	ELSEIF ( surf%albedo_type(ind_type,m) == 15 ) THEN
4975	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4976	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4977
4978	!
4979	!-- Asphalt
4980	ELSEIF ( surf%albedo_type(ind_type,m) == 17 ) THEN
4981	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4982	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4983
4984
4985	!
4986	!-- Bare soil
4987	ELSEIF ( surf%albedo_type(ind_type,m) == 18 ) THEN
4988	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4989	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4990
4991	!
4992	!-- Land surfaces
4993	ELSE
4994	SELECT CASE ( surf%albedo_type(ind_type,m) )
4995
4996	!
4997	!-- Surface types with strong zenith dependence
4998	CASE ( 1, 2, 3, 4, 11, 12, 13 )
4999	surf%rrtm_aldir(ind_type,m) = &
5000	surf%aldif(ind_type,m) * 1.4_wp / &
5001	( 1.0_wp + 0.8_wp * cos_zenith )
5002	surf%rrtm_asdir(ind_type,m) = &
5003	surf%asdif(ind_type,m) * 1.4_wp / &
5004	( 1.0_wp + 0.8_wp * cos_zenith )
5005	!
5006	!-- Surface types with weak zenith dependence
5007	CASE ( 5, 6, 7, 8, 9, 10, 14 )
5008	surf%rrtm_aldir(ind_type,m) = &
5009	surf%aldif(ind_type,m) * 1.1_wp / &
5010	( 1.0_wp + 0.2_wp * cos_zenith )
5011	surf%rrtm_asdir(ind_type,m) = &
5012	surf%asdif(ind_type,m) * 1.1_wp / &
5013	( 1.0_wp + 0.2_wp * cos_zenith )
5014
5015	CASE DEFAULT
5016
5017	END SELECT
5018	ENDIF
5019	!
5020	!-- Diffusive albedo is taken from Table 2
5021	surf%rrtm_aldif(ind_type,m) = surf%aldif(ind_type,m)
5022	surf%rrtm_asdif(ind_type,m) = surf%asdif(ind_type,m)
5023	ENDDO
5024	ENDDO
5025	!
5026	!-- Set albedo in case of average radiation
5027	ELSEIF ( sun_up .AND. average_radiation ) THEN
5028	surf%rrtm_asdir = albedo_urb
5029	surf%rrtm_asdif = albedo_urb
5030	surf%rrtm_aldir = albedo_urb
5031	surf%rrtm_aldif = albedo_urb
5032	!
5033	!-- Darkness
5034	ELSE
5035	surf%rrtm_aldir = 0.0_wp
5036	surf%rrtm_asdir = 0.0_wp
5037	surf%rrtm_aldif = 0.0_wp
5038	surf%rrtm_asdif = 0.0_wp
5039	ENDIF
5040
5041	END SUBROUTINE calc_albedo
5042
5043	!------------------------------------------------------------------------------!
5044	! Description:
5045	! ------------
5046	!> Read sounding data (pressure and temperature) from RADIATION_DATA.
5047	!------------------------------------------------------------------------------!
5048	SUBROUTINE read_sounding_data
5049
5050	IMPLICIT NONE
5051
5052	INTEGER(iwp) :: id, & !< NetCDF id of input file
5053	id_dim_zrad, & !< pressure level id in the NetCDF file
5054	id_var, & !< NetCDF variable id
5055	k, & !< loop index
5056	nz_snd, & !< number of vertical levels in the sounding data
5057	nz_snd_start, & !< start vertical index for sounding data to be used
5058	nz_snd_end !< end vertical index for souding data to be used
5059
5060	REAL(wp) :: t_surface !< actual surface temperature
5061
5062	REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd_tmp, & !< temporary hydrostatic pressure profile (sounding)
5063	t_snd_tmp !< temporary temperature profile (sounding)
5064
5065	!
5066	!-- In case of updates, deallocate arrays first (sufficient to check one
5067	!-- array as the others are automatically allocated). This is required
5068	!-- because nzt_rad might change during the update
5069	IF ( ALLOCATED ( hyp_snd ) ) THEN
5070	DEALLOCATE( hyp_snd )
5071	DEALLOCATE( t_snd )
5072	DEALLOCATE ( rrtm_play )
5073	DEALLOCATE ( rrtm_plev )
5074	DEALLOCATE ( rrtm_tlay )
5075	DEALLOCATE ( rrtm_tlev )
5076
5077	DEALLOCATE ( rrtm_cicewp )
5078	DEALLOCATE ( rrtm_cldfr )
5079	DEALLOCATE ( rrtm_cliqwp )
5080	DEALLOCATE ( rrtm_reice )
5081	DEALLOCATE ( rrtm_reliq )
5082	DEALLOCATE ( rrtm_lw_taucld )
5083	DEALLOCATE ( rrtm_lw_tauaer )
5084
5085	DEALLOCATE ( rrtm_lwdflx )
5086	DEALLOCATE ( rrtm_lwdflxc )
5087	DEALLOCATE ( rrtm_lwuflx )
5088	DEALLOCATE ( rrtm_lwuflxc )
5089	DEALLOCATE ( rrtm_lwuflx_dt )
5090	DEALLOCATE ( rrtm_lwuflxc_dt )
5091	DEALLOCATE ( rrtm_lwhr )
5092	DEALLOCATE ( rrtm_lwhrc )
5093
5094	DEALLOCATE ( rrtm_sw_taucld )
5095	DEALLOCATE ( rrtm_sw_ssacld )
5096	DEALLOCATE ( rrtm_sw_asmcld )
5097	DEALLOCATE ( rrtm_sw_fsfcld )
5098	DEALLOCATE ( rrtm_sw_tauaer )
5099	DEALLOCATE ( rrtm_sw_ssaaer )
5100	DEALLOCATE ( rrtm_sw_asmaer )
5101	DEALLOCATE ( rrtm_sw_ecaer )
5102
5103	DEALLOCATE ( rrtm_swdflx )
5104	DEALLOCATE ( rrtm_swdflxc )
5105	DEALLOCATE ( rrtm_swuflx )
5106	DEALLOCATE ( rrtm_swuflxc )
5107	DEALLOCATE ( rrtm_swhr )
5108	DEALLOCATE ( rrtm_swhrc )
5109	DEALLOCATE ( rrtm_dirdflux )
5110	DEALLOCATE ( rrtm_difdflux )
5111
5112	ENDIF
5113
5114	!
5115	!-- Open file for reading
5116	nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id )
5117	CALL netcdf_handle_error_rad( 'read_sounding_data', 549 )
5118
5119	!
5120	!-- Inquire dimension of z axis and save in nz_snd
5121	nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim_zrad )
5122	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim_zrad, len = nz_snd )
5123	CALL netcdf_handle_error_rad( 'read_sounding_data', 551 )
5124
5125	!
5126	! !-- Allocate temporary array for storing pressure data
5127	ALLOCATE( hyp_snd_tmp(1:nz_snd) )
5128	hyp_snd_tmp = 0.0_wp
5129
5130
5131	!-- Read pressure from file
5132	nc_stat = NF90_INQ_VARID( id, "Pressure", id_var )
5133	nc_stat = NF90_GET_VAR( id, id_var, hyp_snd_tmp(:), start = (/1/), &
5134	count = (/nz_snd/) )
5135	CALL netcdf_handle_error_rad( 'read_sounding_data', 552 )
5136
5137	!
5138	!-- Allocate temporary array for storing temperature data
5139	ALLOCATE( t_snd_tmp(1:nz_snd) )
5140	t_snd_tmp = 0.0_wp
5141
5142	!
5143	!-- Read temperature from file
5144	nc_stat = NF90_INQ_VARID( id, "ReferenceTemperature", id_var )
5145	nc_stat = NF90_GET_VAR( id, id_var, t_snd_tmp(:), start = (/1/), &
5146	count = (/nz_snd/) )
5147	CALL netcdf_handle_error_rad( 'read_sounding_data', 553 )
5148
5149	!
5150	!-- Calculate start of sounding data
5151	nz_snd_start = nz_snd + 1
5152	nz_snd_end = nz_snd + 1
5153
5154	!
5155	!-- Start filling vertical dimension at 10hPa above the model domain (hyp is
5156	!-- in Pa, hyp_snd in hPa).
5157	DO k = 1, nz_snd
5158	IF ( hyp_snd_tmp(k) < ( hyp(nzt+1) - 1000.0_wp) * 0.01_wp ) THEN
5159	nz_snd_start = k
5160	EXIT
5161	END IF
5162	END DO
5163
5164	IF ( nz_snd_start <= nz_snd ) THEN
5165	nz_snd_end = nz_snd
5166	END IF
5167
5168
5169	!
5170	!-- Calculate of total grid points for RRTMG calculations
5171	nzt_rad = nzt + nz_snd_end - nz_snd_start + 1
5172
5173	!
5174	!-- Save data above LES domain in hyp_snd, t_snd
5175	ALLOCATE( hyp_snd(nzb+1:nzt_rad) )
5176	ALLOCATE( t_snd(nzb+1:nzt_rad) )
5177	hyp_snd = 0.0_wp
5178	t_snd = 0.0_wp
5179
5180	hyp_snd(nzt+2:nzt_rad) = hyp_snd_tmp(nz_snd_start+1:nz_snd_end)
5181	t_snd(nzt+2:nzt_rad) = t_snd_tmp(nz_snd_start+1:nz_snd_end)
5182
5183	nc_stat = NF90_CLOSE( id )
5184
5185	!
5186	!-- Calculate pressure levels on zu and zw grid. Sounding data is added at
5187	!-- top of the LES domain. This routine does not consider horizontal or
5188	!-- vertical variability of pressure and temperature
5189	ALLOCATE ( rrtm_play(0:0,nzb+1:nzt_rad+1) )
5190	ALLOCATE ( rrtm_plev(0:0,nzb+1:nzt_rad+2) )
5191
5192	t_surface = pt_surface * exner(nzb)
5193	DO k = nzb+1, nzt+1
5194	rrtm_play(0,k) = hyp(k) * 0.01_wp
5195	rrtm_plev(0,k) = barometric_formula(zw(k-1), &
5196	pt_surface * exner(nzb), &
5197	surface_pressure )
5198	ENDDO
5199
5200	DO k = nzt+2, nzt_rad
5201	rrtm_play(0,k) = hyp_snd(k)
5202	rrtm_plev(0,k) = 0.5_wp * ( rrtm_play(0,k) + rrtm_play(0,k-1) )
5203	ENDDO
5204	rrtm_plev(0,nzt_rad+1) = MAX( 0.5 * hyp_snd(nzt_rad), &
5205	1.5 * hyp_snd(nzt_rad) &
5206	- 0.5 * hyp_snd(nzt_rad-1) )
5207	rrtm_plev(0,nzt_rad+2) = MIN( 1.0E-4_wp, &
5208	0.25_wp * rrtm_plev(0,nzt_rad+1) )
5209
5210	rrtm_play(0,nzt_rad+1) = 0.5 * rrtm_plev(0,nzt_rad+1)
5211
5212	!
5213	!-- Calculate temperature/humidity levels at top of the LES domain.
5214	!-- Currently, the temperature is taken from sounding data (might lead to a
5215	!-- temperature jump at interface. To do: Humidity is currently not
5216	!-- calculated above the LES domain.
5217	ALLOCATE ( rrtm_tlay(0:0,nzb+1:nzt_rad+1) )
5218	ALLOCATE ( rrtm_tlev(0:0,nzb+1:nzt_rad+2) )
5219
5220	DO k = nzt+8, nzt_rad
5221	rrtm_tlay(0,k) = t_snd(k)
5222	ENDDO
5223	rrtm_tlay(0,nzt_rad+1) = 2.0_wp * rrtm_tlay(0,nzt_rad) &
5224	- rrtm_tlay(0,nzt_rad-1)
5225	DO k = nzt+9, nzt_rad+1
5226	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) &
5227	- rrtm_tlay(0,k-1)) &
5228	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
5229	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
5230	ENDDO
5231
5232	rrtm_tlev(0,nzt_rad+2) = 2.0_wp * rrtm_tlay(0,nzt_rad+1) &
5233	- rrtm_tlev(0,nzt_rad)
5234	!
5235	!-- Allocate remaining RRTMG arrays
5236	ALLOCATE ( rrtm_cicewp(0:0,nzb+1:nzt_rad+1) )
5237	ALLOCATE ( rrtm_cldfr(0:0,nzb+1:nzt_rad+1) )
5238	ALLOCATE ( rrtm_cliqwp(0:0,nzb+1:nzt_rad+1) )
5239	ALLOCATE ( rrtm_reice(0:0,nzb+1:nzt_rad+1) )
5240	ALLOCATE ( rrtm_reliq(0:0,nzb+1:nzt_rad+1) )
5241	ALLOCATE ( rrtm_lw_taucld(1:nbndlw+1,0:0,nzb+1:nzt_rad+1) )
5242	ALLOCATE ( rrtm_lw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndlw+1) )
5243	ALLOCATE ( rrtm_sw_taucld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
5244	ALLOCATE ( rrtm_sw_ssacld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
5245	ALLOCATE ( rrtm_sw_asmcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
5246	ALLOCATE ( rrtm_sw_fsfcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
5247	ALLOCATE ( rrtm_sw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
5248	ALLOCATE ( rrtm_sw_ssaaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
5249	ALLOCATE ( rrtm_sw_asmaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
5250	ALLOCATE ( rrtm_sw_ecaer(0:0,nzb+1:nzt_rad+1,1:naerec+1) )
5251
5252	!
5253	!-- The ice phase is currently not considered in PALM
5254	rrtm_cicewp = 0.0_wp
5255	rrtm_reice = 0.0_wp
5256
5257	!
5258	!-- Set other parameters (move to NAMELIST parameters in the future)
5259	rrtm_lw_tauaer = 0.0_wp
5260	rrtm_lw_taucld = 0.0_wp
5261	rrtm_sw_taucld = 0.0_wp
5262	rrtm_sw_ssacld = 0.0_wp
5263	rrtm_sw_asmcld = 0.0_wp
5264	rrtm_sw_fsfcld = 0.0_wp
5265	rrtm_sw_tauaer = 0.0_wp
5266	rrtm_sw_ssaaer = 0.0_wp
5267	rrtm_sw_asmaer = 0.0_wp
5268	rrtm_sw_ecaer = 0.0_wp
5269
5270
5271	ALLOCATE ( rrtm_swdflx(0:0,nzb:nzt_rad+1) )
5272	ALLOCATE ( rrtm_swuflx(0:0,nzb:nzt_rad+1) )
5273	ALLOCATE ( rrtm_swhr(0:0,nzb+1:nzt_rad+1) )
5274	ALLOCATE ( rrtm_swuflxc(0:0,nzb:nzt_rad+1) )
5275	ALLOCATE ( rrtm_swdflxc(0:0,nzb:nzt_rad+1) )
5276	ALLOCATE ( rrtm_swhrc(0:0,nzb+1:nzt_rad+1) )
5277	ALLOCATE ( rrtm_dirdflux(0:0,nzb:nzt_rad+1) )
5278	ALLOCATE ( rrtm_difdflux(0:0,nzb:nzt_rad+1) )
5279
5280	rrtm_swdflx = 0.0_wp
5281	rrtm_swuflx = 0.0_wp
5282	rrtm_swhr = 0.0_wp
5283	rrtm_swuflxc = 0.0_wp
5284	rrtm_swdflxc = 0.0_wp
5285	rrtm_swhrc = 0.0_wp
5286	rrtm_dirdflux = 0.0_wp
5287	rrtm_difdflux = 0.0_wp
5288
5289	ALLOCATE ( rrtm_lwdflx(0:0,nzb:nzt_rad+1) )
5290	ALLOCATE ( rrtm_lwuflx(0:0,nzb:nzt_rad+1) )
5291	ALLOCATE ( rrtm_lwhr(0:0,nzb+1:nzt_rad+1) )
5292	ALLOCATE ( rrtm_lwuflxc(0:0,nzb:nzt_rad+1) )
5293	ALLOCATE ( rrtm_lwdflxc(0:0,nzb:nzt_rad+1) )
5294	ALLOCATE ( rrtm_lwhrc(0:0,nzb+1:nzt_rad+1) )
5295
5296	rrtm_lwdflx = 0.0_wp
5297	rrtm_lwuflx = 0.0_wp
5298	rrtm_lwhr = 0.0_wp
5299	rrtm_lwuflxc = 0.0_wp
5300	rrtm_lwdflxc = 0.0_wp
5301	rrtm_lwhrc = 0.0_wp
5302
5303	ALLOCATE ( rrtm_lwuflx_dt(0:0,nzb:nzt_rad+1) )
5304	ALLOCATE ( rrtm_lwuflxc_dt(0:0,nzb:nzt_rad+1) )
5305
5306	rrtm_lwuflx_dt = 0.0_wp
5307	rrtm_lwuflxc_dt = 0.0_wp
5308
5309	END SUBROUTINE read_sounding_data
5310
5311
5312	!------------------------------------------------------------------------------!
5313	! Description:
5314	! ------------
5315	!> Read trace gas data from file and convert into trace gas paths / volume
5316	!> mixing ratios. If a user-defined input file is provided it needs to follow
5317	!> the convections used in RRTMG (see respective netCDF files shipped with
5318	!> RRTMG)
5319	!------------------------------------------------------------------------------!
5320	SUBROUTINE read_trace_gas_data
5321
5322	USE rrsw_ncpar
5323
5324	IMPLICIT NONE
5325
5326	INTEGER(iwp), PARAMETER :: num_trace_gases = 10 !< number of trace gases (absorbers)
5327
5328	CHARACTER(LEN=5), DIMENSION(num_trace_gases), PARAMETER :: & !< trace gas names
5329	trace_names = (/'O3 ', 'CO2 ', 'CH4 ', 'N2O ', 'O2 ', &
5330	'CFC11', 'CFC12', 'CFC22', 'CCL4 ', 'H2O '/)
5331
5332	INTEGER(iwp) :: id, & !< NetCDF id
5333	k, & !< loop index
5334	m, & !< loop index
5335	n, & !< loop index
5336	nabs, & !< number of absorbers
5337	np, & !< number of pressure levels
5338	id_abs, & !< NetCDF id of the respective absorber
5339	id_dim, & !< NetCDF id of asborber's dimension
5340	id_var !< NetCDf id ot the absorber
5341
5342	REAL(wp) :: p_mls_l, & !< pressure lower limit for interpolation
5343	p_mls_u, & !< pressure upper limit for interpolation
5344	p_wgt_l, & !< pressure weight lower limit for interpolation
5345	p_wgt_u, & !< pressure weight upper limit for interpolation
5346	p_mls_m !< mean pressure between upper and lower limits
5347
5348
5349	REAL(wp), DIMENSION(:), ALLOCATABLE :: p_mls, & !< pressure levels for the absorbers
5350	rrtm_play_tmp, & !< temporary array for pressure zu-levels
5351	rrtm_plev_tmp, & !< temporary array for pressure zw-levels
5352	trace_path_tmp !< temporary array for storing trace gas path data
5353
5354	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: trace_mls, & !< array for storing the absorber amounts
5355	trace_mls_path, & !< array for storing trace gas path data
5356	trace_mls_tmp !< temporary array for storing trace gas data
5357
5358
5359	!
5360	!-- In case of updates, deallocate arrays first (sufficient to check one
5361	!-- array as the others are automatically allocated)
5362	IF ( ALLOCATED ( rrtm_o3vmr ) ) THEN
5363	DEALLOCATE ( rrtm_o3vmr )
5364	DEALLOCATE ( rrtm_co2vmr )
5365	DEALLOCATE ( rrtm_ch4vmr )
5366	DEALLOCATE ( rrtm_n2ovmr )
5367	DEALLOCATE ( rrtm_o2vmr )
5368	DEALLOCATE ( rrtm_cfc11vmr )
5369	DEALLOCATE ( rrtm_cfc12vmr )
5370	DEALLOCATE ( rrtm_cfc22vmr )
5371	DEALLOCATE ( rrtm_ccl4vmr )
5372	DEALLOCATE ( rrtm_h2ovmr )
5373	ENDIF
5374
5375	!
5376	!-- Allocate trace gas profiles
5377	ALLOCATE ( rrtm_o3vmr(0:0,1:nzt_rad+1) )
5378	ALLOCATE ( rrtm_co2vmr(0:0,1:nzt_rad+1) )
5379	ALLOCATE ( rrtm_ch4vmr(0:0,1:nzt_rad+1) )
5380	ALLOCATE ( rrtm_n2ovmr(0:0,1:nzt_rad+1) )
5381	ALLOCATE ( rrtm_o2vmr(0:0,1:nzt_rad+1) )
5382	ALLOCATE ( rrtm_cfc11vmr(0:0,1:nzt_rad+1) )
5383	ALLOCATE ( rrtm_cfc12vmr(0:0,1:nzt_rad+1) )
5384	ALLOCATE ( rrtm_cfc22vmr(0:0,1:nzt_rad+1) )
5385	ALLOCATE ( rrtm_ccl4vmr(0:0,1:nzt_rad+1) )
5386	ALLOCATE ( rrtm_h2ovmr(0:0,1:nzt_rad+1) )
5387
5388	!
5389	!-- Open file for reading
5390	nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id )
5391	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 549 )
5392	!
5393	!-- Inquire dimension ids and dimensions
5394	nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim )
5395	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5396	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = np)
5397	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5398
5399	nc_stat = NF90_INQ_DIMID( id, "Absorber", id_dim )
5400	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5401	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = nabs )
5402	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5403
5404
5405	!
5406	!-- Allocate pressure, and trace gas arrays
5407	ALLOCATE( p_mls(1:np) )
5408	ALLOCATE( trace_mls(1:num_trace_gases,1:np) )
5409	ALLOCATE( trace_mls_tmp(1:nabs,1:np) )
5410
5411
5412	nc_stat = NF90_INQ_VARID( id, "Pressure", id_var )
5413	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5414	nc_stat = NF90_GET_VAR( id, id_var, p_mls )
5415	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5416
5417	nc_stat = NF90_INQ_VARID( id, "AbsorberAmountMLS", id_var )
5418	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5419	nc_stat = NF90_GET_VAR( id, id_var, trace_mls_tmp )
5420	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5421
5422
5423	!
5424	!-- Write absorber amounts (mls) to trace_mls
5425	DO n = 1, num_trace_gases
5426	CALL getAbsorberIndex( TRIM( trace_names(n) ), id_abs )
5427
5428	trace_mls(n,1:np) = trace_mls_tmp(id_abs,1:np)
5429
5430	!
5431	!-- Replace missing values by zero
5432	WHERE ( trace_mls(n,:) > 2.0_wp )
5433	trace_mls(n,:) = 0.0_wp
5434	END WHERE
5435	END DO
5436
5437	DEALLOCATE ( trace_mls_tmp )
5438
5439	nc_stat = NF90_CLOSE( id )
5440	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 551 )
5441
5442	!
5443	!-- Add extra pressure level for calculations of the trace gas paths
5444	ALLOCATE ( rrtm_play_tmp(1:nzt_rad+1) )
5445	ALLOCATE ( rrtm_plev_tmp(1:nzt_rad+2) )
5446
5447	rrtm_play_tmp(1:nzt_rad) = rrtm_play(0,1:nzt_rad)
5448	rrtm_plev_tmp(1:nzt_rad+1) = rrtm_plev(0,1:nzt_rad+1)
5449	rrtm_play_tmp(nzt_rad+1) = rrtm_plev(0,nzt_rad+1) * 0.5_wp
5450	rrtm_plev_tmp(nzt_rad+2) = MIN( 1.0E-4_wp, 0.25_wp &
5451	* rrtm_plev(0,nzt_rad+1) )
5452
5453	!
5454	!-- Calculate trace gas path (zero at surface) with interpolation to the
5455	!-- sounding levels
5456	ALLOCATE ( trace_mls_path(1:nzt_rad+2,1:num_trace_gases) )
5457
5458	trace_mls_path(nzb+1,:) = 0.0_wp
5459
5460	DO k = nzb+2, nzt_rad+2
5461	DO m = 1, num_trace_gases
5462	trace_mls_path(k,m) = trace_mls_path(k-1,m)
5463
5464	!
5465	!-- When the pressure level is higher than the trace gas pressure
5466	!-- level, assume that
5467	IF ( rrtm_plev_tmp(k-1) > p_mls(1) ) THEN
5468
5469	trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,1) &
5470	* ( rrtm_plev_tmp(k-1) &
5471	- MAX( p_mls(1), rrtm_plev_tmp(k) ) &
5472	) / g
5473	ENDIF
5474
5475	!
5476	!-- Integrate for each sounding level from the contributing p_mls
5477	!-- levels
5478	DO n = 2, np
5479	!
5480	!-- Limit p_mls so that it is within the model level
5481	p_mls_u = MIN( rrtm_plev_tmp(k-1), &
5482	MAX( rrtm_plev_tmp(k), p_mls(n) ) )
5483	p_mls_l = MIN( rrtm_plev_tmp(k-1), &
5484	MAX( rrtm_plev_tmp(k), p_mls(n-1) ) )
5485
5486	IF ( p_mls_l > p_mls_u ) THEN
5487
5488	!
5489	!-- Calculate weights for interpolation
5490	p_mls_m = 0.5_wp * (p_mls_l + p_mls_u)
5491	p_wgt_u = (p_mls(n-1) - p_mls_m) / (p_mls(n-1) - p_mls(n))
5492	p_wgt_l = (p_mls_m - p_mls(n)) / (p_mls(n-1) - p_mls(n))
5493
5494	!
5495	!-- Add level to trace gas path
5496	trace_mls_path(k,m) = trace_mls_path(k,m) &
5497	+ ( p_wgt_u * trace_mls(m,n) &
5498	+ p_wgt_l * trace_mls(m,n-1) ) &
5499	* (p_mls_l - p_mls_u) / g
5500	ENDIF
5501	ENDDO
5502
5503	IF ( rrtm_plev_tmp(k) < p_mls(np) ) THEN
5504	trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,np) &
5505	* ( MIN( rrtm_plev_tmp(k-1), p_mls(np) ) &
5506	- rrtm_plev_tmp(k) &
5507	) / g
5508	ENDIF
5509	ENDDO
5510	ENDDO
5511
5512
5513	!
5514	!-- Prepare trace gas path profiles
5515	ALLOCATE ( trace_path_tmp(1:nzt_rad+1) )
5516
5517	DO m = 1, num_trace_gases
5518
5519	trace_path_tmp(1:nzt_rad+1) = ( trace_mls_path(2:nzt_rad+2,m) &
5520	- trace_mls_path(1:nzt_rad+1,m) ) * g &
5521	/ ( rrtm_plev_tmp(1:nzt_rad+1) &
5522	- rrtm_plev_tmp(2:nzt_rad+2) )
5523
5524	!
5525	!-- Save trace gas paths to the respective arrays
5526	SELECT CASE ( TRIM( trace_names(m) ) )
5527
5528	CASE ( 'O3' )
5529
5530	rrtm_o3vmr(0,:) = trace_path_tmp(:)
5531
5532	CASE ( 'CO2' )
5533
5534	rrtm_co2vmr(0,:) = trace_path_tmp(:)
5535
5536	CASE ( 'CH4' )
5537
5538	rrtm_ch4vmr(0,:) = trace_path_tmp(:)
5539
5540	CASE ( 'N2O' )
5541
5542	rrtm_n2ovmr(0,:) = trace_path_tmp(:)
5543
5544	CASE ( 'O2' )
5545
5546	rrtm_o2vmr(0,:) = trace_path_tmp(:)
5547
5548	CASE ( 'CFC11' )
5549
5550	rrtm_cfc11vmr(0,:) = trace_path_tmp(:)
5551
5552	CASE ( 'CFC12' )
5553
5554	rrtm_cfc12vmr(0,:) = trace_path_tmp(:)
5555
5556	CASE ( 'CFC22' )
5557
5558	rrtm_cfc22vmr(0,:) = trace_path_tmp(:)
5559
5560	CASE ( 'CCL4' )
5561
5562	rrtm_ccl4vmr(0,:) = trace_path_tmp(:)
5563
5564	CASE ( 'H2O' )
5565
5566	rrtm_h2ovmr(0,:) = trace_path_tmp(:)
5567
5568	CASE DEFAULT
5569
5570	END SELECT
5571
5572	ENDDO
5573
5574	DEALLOCATE ( trace_path_tmp )
5575	DEALLOCATE ( trace_mls_path )
5576	DEALLOCATE ( rrtm_play_tmp )
5577	DEALLOCATE ( rrtm_plev_tmp )
5578	DEALLOCATE ( trace_mls )
5579	DEALLOCATE ( p_mls )
5580
5581	END SUBROUTINE read_trace_gas_data
5582
5583
5584	SUBROUTINE netcdf_handle_error_rad( routine_name, errno )
5585
5586	USE control_parameters, &
5587	ONLY: message_string
5588
5589	USE NETCDF
5590
5591	USE pegrid
5592
5593	IMPLICIT NONE
5594
5595	CHARACTER(LEN=6) :: message_identifier
5596	CHARACTER(LEN=*) :: routine_name
5597
5598	INTEGER(iwp) :: errno
5599
5600	IF ( nc_stat /= NF90_NOERR ) THEN
5601
5602	WRITE( message_identifier, '(''NC'',I4.4)' ) errno
5603	message_string = TRIM( NF90_STRERROR( nc_stat ) )
5604
5605	CALL message( routine_name, message_identifier, 2, 2, 0, 6, 1 )
5606
5607	ENDIF
5608
5609	END SUBROUTINE netcdf_handle_error_rad
5610	#endif
5611
5612
5613	!------------------------------------------------------------------------------!
5614	! Description:
5615	! ------------
5616	!> Calculate temperature tendency due to radiative cooling/heating.
5617	!> Cache-optimized version.
5618	!------------------------------------------------------------------------------!
5619	#if defined( __rrtmg )
5620	SUBROUTINE radiation_tendency_ij ( i, j, tend )
5621
5622	IMPLICIT NONE
5623
5624	INTEGER(iwp) :: i, j, k !< loop indices
5625
5626	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term
5627
5628	IF ( radiation_scheme == 'rrtmg' ) THEN
5629	!
5630	!-- Calculate tendency based on heating rate
5631	DO k = nzb+1, nzt+1
5632	tend(k,j,i) = tend(k,j,i) + (rad_lw_hr(k,j,i) + rad_sw_hr(k,j,i)) &
5633	* d_exner(k) * d_seconds_hour
5634	ENDDO
5635
5636	ENDIF
5637
5638	END SUBROUTINE radiation_tendency_ij
5639	#endif
5640
5641
5642	!------------------------------------------------------------------------------!
5643	! Description:
5644	! ------------
5645	!> Calculate temperature tendency due to radiative cooling/heating.
5646	!> Vector-optimized version
5647	!------------------------------------------------------------------------------!
5648	#if defined( __rrtmg )
5649	SUBROUTINE radiation_tendency ( tend )
5650
5651	USE indices, &
5652	ONLY: nxl, nxr, nyn, nys
5653
5654	IMPLICIT NONE
5655
5656	INTEGER(iwp) :: i, j, k !< loop indices
5657
5658	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term
5659
5660	IF ( radiation_scheme == 'rrtmg' ) THEN
5661	!
5662	!-- Calculate tendency based on heating rate
5663	DO i = nxl, nxr
5664	DO j = nys, nyn
5665	DO k = nzb+1, nzt+1
5666	tend(k,j,i) = tend(k,j,i) + ( rad_lw_hr(k,j,i) &
5667	+ rad_sw_hr(k,j,i) ) * d_exner(k) &
5668	* d_seconds_hour
5669	ENDDO
5670	ENDDO
5671	ENDDO
5672	ENDIF
5673
5674	END SUBROUTINE radiation_tendency
5675	#endif
5676
5677	!------------------------------------------------------------------------------!
5678	! Description:
5679	! ------------
5680	!> This subroutine calculates interaction of the solar radiation
5681	!> with urban and land surfaces and updates all surface heatfluxes.
5682	!> It calculates also the required parameters for RRTMG lower BC.
5683	!>
5684	!> For more info. see Resler et al. 2017
5685	!>
5686	!> The new version 2.0 was radically rewriten, the discretization scheme
5687	!> has been changed. This new version significantly improves effectivity
5688	!> of the paralelization and the scalability of the model.
5689	!------------------------------------------------------------------------------!
5690
5691	SUBROUTINE radiation_interaction
5692
5693	USE control_parameters, &
5694	ONLY: rotation_angle
5695
5696	IMPLICIT NONE
5697
5698	INTEGER(iwp) :: i, j, k, kk, d, refstep, m, mm, l, ll
5699	INTEGER(iwp) :: isurf, isurfsrc, isvf, icsf, ipcgb
5700	INTEGER(iwp) :: imrt, imrtf
5701	INTEGER(iwp) :: isd !< solar direction number
5702	INTEGER(iwp) :: pc_box_dimshift !< transform for best accuracy
5703	INTEGER(iwp), DIMENSION(0:3) :: reorder = (/ 1, 0, 3, 2 /)
5704
5705	REAL(wp), DIMENSION(3,3) :: mrot !< grid rotation matrix (zyx)
5706	REAL(wp), DIMENSION(3,0:nsurf_type):: vnorm !< face direction normal vectors (zyx)
5707	REAL(wp), DIMENSION(3) :: sunorig !< grid rotated solar direction unit vector (zyx)
5708	REAL(wp), DIMENSION(3) :: sunorig_grid !< grid squashed solar direction unit vector (zyx)
5709	REAL(wp), DIMENSION(0:nsurf_type) :: costheta !< direct irradiance factor of solar angle
5710	REAL(wp), DIMENSION(nz_urban_b:nz_urban_t) :: pchf_prep !< precalculated factor for canopy temperature tendency
5711	REAL(wp) :: pc_box_area, pc_abs_frac, pc_abs_eff
5712	REAL(wp) :: asrc !< area of source face
5713	REAL(wp) :: pcrad !< irradiance from plant canopy
5714	REAL(wp) :: pabsswl = 0.0_wp !< total absorbed SW radiation energy in local processor (W)
5715	REAL(wp) :: pabssw = 0.0_wp !< total absorbed SW radiation energy in all processors (W)
5716	REAL(wp) :: pabslwl = 0.0_wp !< total absorbed LW radiation energy in local processor (W)
5717	REAL(wp) :: pabslw = 0.0_wp !< total absorbed LW radiation energy in all processors (W)
5718	REAL(wp) :: pemitlwl = 0.0_wp !< total emitted LW radiation energy in all processors (W)
5719	REAL(wp) :: pemitlw = 0.0_wp !< total emitted LW radiation energy in all processors (W)
5720	REAL(wp) :: pinswl = 0.0_wp !< total received SW radiation energy in local processor (W)
5721	REAL(wp) :: pinsw = 0.0_wp !< total received SW radiation energy in all processor (W)
5722	REAL(wp) :: pinlwl = 0.0_wp !< total received LW radiation energy in local processor (W)
5723	REAL(wp) :: pinlw = 0.0_wp !< total received LW radiation energy in all processor (W)
5724	REAL(wp) :: emiss_sum_surfl !< sum of emissisivity of surfaces in local processor
5725	REAL(wp) :: emiss_sum_surf !< sum of emissisivity of surfaces in all processor
5726	REAL(wp) :: area_surfl !< total area of surfaces in local processor
5727	REAL(wp) :: area_surf !< total area of surfaces in all processor
5728	REAL(wp) :: area_hor !< total horizontal area of domain in all processor
5729	#if defined( __parallel )
5730	REAL(wp), DIMENSION(1:7) :: combine_allreduce !< dummy array used to combine several MPI_ALLREDUCE calls
5731	REAL(wp), DIMENSION(1:7) :: combine_allreduce_l !< dummy array used to combine several MPI_ALLREDUCE calls
5732	#endif
5733
5734	IF ( debug_output_timestep ) CALL debug_message( 'radiation_interaction', 'start' )
5735
5736	IF ( plant_canopy ) THEN
5737	pchf_prep(:) = r_d * exner(nz_urban_b:nz_urban_t) &
5738	/ (c_p * hyp(nz_urban_b:nz_urban_t) * dxdydz(1)) !< equals to 1 / (rho * c_p * Vbox * T)
5739	ENDIF
5740
5741	sun_direction = .TRUE.
5742	CALL get_date_time( time_since_reference_point, &
5743	day_of_year=day_of_year, &
5744	second_of_day=second_of_day )
5745	CALL calc_zenith( day_of_year, second_of_day ) !< required also for diffusion radiation
5746
5747	!
5748	!-- prepare rotated normal vectors and irradiance factor
5749	vnorm(1,:) = kdir(:)
5750	vnorm(2,:) = jdir(:)
5751	vnorm(3,:) = idir(:)
5752	mrot(1, :) = (/ 1._wp, 0._wp, 0._wp /)
5753	mrot(2, :) = (/ 0._wp, COS(rotation_angle), SIN(rotation_angle) /)
5754	mrot(3, :) = (/ 0._wp, -SIN(rotation_angle), COS(rotation_angle) /)
5755	sunorig = (/ cos_zenith, sun_dir_lat, sun_dir_lon /)
5756	sunorig = MATMUL(mrot, sunorig)
5757	DO d = 0, nsurf_type
5758	costheta(d) = DOT_PRODUCT(sunorig, vnorm(:,d))
5759	ENDDO
5760
5761	IF ( cos_zenith > 0 ) THEN
5762	!-- now we will "squash" the sunorig vector by grid box size in
5763	!-- each dimension, so that this new direction vector will allow us
5764	!-- to traverse the ray path within grid coordinates directly
5765	sunorig_grid = (/ sunorig(1)/dz(1), sunorig(2)/dy, sunorig(3)/dx /)
5766	!-- sunorig_grid = sunorig_grid / norm2(sunorig_grid)
5767	sunorig_grid = sunorig_grid / SQRT(SUM(sunorig_grid**2))
5768
5769	IF ( npcbl > 0 ) THEN
5770	!-- precompute effective box depth with prototype Leaf Area Density
5771	pc_box_dimshift = MAXLOC(ABS(sunorig), 1) - 1
5772	CALL box_absorb(CSHIFT((/dz(1),dy,dx/), pc_box_dimshift), &
5773	60, prototype_lad, &
5774	CSHIFT(ABS(sunorig), pc_box_dimshift), &
5775	pc_box_area, pc_abs_frac)
5776	pc_box_area = pc_box_area * ABS(sunorig(pc_box_dimshift+1) &
5777	/ sunorig(1))
5778	pc_abs_eff = LOG(1._wp - pc_abs_frac) / prototype_lad
5779	ENDIF
5780	ENDIF
5781	!
5782	!-- Split downwelling shortwave radiation into a diffuse and a direct part.
5783	!-- Note, if radiation scheme is RRTMG or diffuse radiation is externally
5784	!-- prescribed, this is not required. Please note, in case of external
5785	!-- radiation, the clear-sky model is applied during spinup, so that
5786	!-- radiation need to be split also in this case.
5787	IF ( radiation_scheme == 'constant' .OR. &
5788	radiation_scheme == 'clear-sky' .OR. &
5789	( radiation_scheme == 'external' .AND. &
5790	.NOT. rad_sw_in_dif_f%from_file ) .OR. &
5791	( radiation_scheme == 'external' .AND. &
5792	time_since_reference_point < 0.0_wp ) ) THEN
5793	CALL calc_diffusion_radiation
5794	ENDIF
5795
5796	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5797	!-- First pass: direct + diffuse irradiance + thermal
5798	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5799	surfinswdir = 0._wp !nsurfl
5800	surfins = 0._wp !nsurfl
5801	surfinl = 0._wp !nsurfl
5802	surfoutsl(:) = 0.0_wp !start-end
5803	surfoutll(:) = 0.0_wp !start-end
5804	IF ( nmrtbl > 0 ) THEN
5805	mrtinsw(:) = 0._wp
5806	mrtinlw(:) = 0._wp
5807	ENDIF
5808	surfinlg(:) = 0._wp !global
5809
5810
5811	!-- Set up thermal radiation from surfaces
5812	!-- emiss_surf is defined only for surfaces for which energy balance is calculated
5813	!-- Workaround: reorder surface data type back on 1D array including all surfaces,
5814	!-- which implies to reorder horizontal and vertical surfaces
5815	!
5816	!-- Horizontal walls
5817	mm = 1
5818	DO i = nxl, nxr
5819	DO j = nys, nyn
5820	!-- urban
5821	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
5822	surfoutll(mm) = SUM ( surf_usm_h%frac(:,m) * &
5823	surf_usm_h%emissivity(:,m) ) &
5824	* sigma_sb &
5825	* surf_usm_h%pt_surface(m)**4
5826	albedo_surf(mm) = SUM ( surf_usm_h%frac(:,m) * &
5827	surf_usm_h%albedo(:,m) )
5828	emiss_surf(mm) = SUM ( surf_usm_h%frac(:,m) * &
5829	surf_usm_h%emissivity(:,m) )
5830	mm = mm + 1
5831	ENDDO
5832	!-- land
5833	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
5834	surfoutll(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5835	surf_lsm_h%emissivity(:,m) ) &
5836	* sigma_sb &
5837	* surf_lsm_h%pt_surface(m)**4
5838	albedo_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5839	surf_lsm_h%albedo(:,m) )
5840	emiss_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5841	surf_lsm_h%emissivity(:,m) )
5842	mm = mm + 1
5843	ENDDO
5844	ENDDO
5845	ENDDO
5846	!
5847	!-- Vertical walls
5848	DO i = nxl, nxr
5849	DO j = nys, nyn
5850	DO ll = 0, 3
5851	l = reorder(ll)
5852	!-- urban
5853	DO m = surf_usm_v(l)%start_index(j,i), &
5854	surf_usm_v(l)%end_index(j,i)
5855	surfoutll(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5856	surf_usm_v(l)%emissivity(:,m) ) &
5857	* sigma_sb &
5858	* surf_usm_v(l)%pt_surface(m)**4
5859	albedo_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5860	surf_usm_v(l)%albedo(:,m) )
5861	emiss_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5862	surf_usm_v(l)%emissivity(:,m) )
5863	mm = mm + 1
5864	ENDDO
5865	!-- land
5866	DO m = surf_lsm_v(l)%start_index(j,i), &
5867	surf_lsm_v(l)%end_index(j,i)
5868	surfoutll(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5869	surf_lsm_v(l)%emissivity(:,m) ) &
5870	* sigma_sb &
5871	* surf_lsm_v(l)%pt_surface(m)**4
5872	albedo_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5873	surf_lsm_v(l)%albedo(:,m) )
5874	emiss_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5875	surf_lsm_v(l)%emissivity(:,m) )
5876	mm = mm + 1
5877	ENDDO
5878	ENDDO
5879	ENDDO
5880	ENDDO
5881
5882	#if defined( __parallel )
5883	!-- might be optimized and gather only values relevant for current processor
5884	CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, &
5885	surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) !nsurf global
5886	IF ( ierr /= 0 ) THEN
5887	WRITE(9,*) 'Error MPI_AllGatherv1:', ierr, SIZE(surfoutll), nsurfl, &
5888	SIZE(surfoutl), nsurfs, surfstart
5889	FLUSH(9)
5890	ENDIF
5891	#else
5892	surfoutl(:) = surfoutll(:) !nsurf global
5893	#endif
5894
5895	IF ( surface_reflections) THEN
5896	DO isvf = 1, nsvfl
5897	isurf = svfsurf(1, isvf)
5898	k = surfl(iz, isurf)
5899	j = surfl(iy, isurf)
5900	i = surfl(ix, isurf)
5901	isurfsrc = svfsurf(2, isvf)
5902	!
5903	!-- For surface-to-surface factors we calculate thermal radiation in 1st pass
5904	IF ( plant_lw_interact ) THEN
5905	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc)
5906	ELSE
5907	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)
5908	ENDIF
5909	ENDDO
5910	ENDIF
5911	!
5912	!-- diffuse radiation using sky view factor
5913	DO isurf = 1, nsurfl
5914	j = surfl(iy, isurf)
5915	i = surfl(ix, isurf)
5916	surfinswdif(isurf) = rad_sw_in_diff(j,i) * skyvft(isurf)
5917	IF ( plant_lw_interact ) THEN
5918	surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvft(isurf)
5919	ELSE
5920	surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvf(isurf)
5921	ENDIF
5922	ENDDO
5923	!
5924	!-- MRT diffuse irradiance
5925	DO imrt = 1, nmrtbl
5926	j = mrtbl(iy, imrt)
5927	i = mrtbl(ix, imrt)
5928	mrtinsw(imrt) = mrtskyt(imrt) * rad_sw_in_diff(j,i)
5929	mrtinlw(imrt) = mrtsky(imrt) * rad_lw_in_diff(j,i)
5930	ENDDO
5931
5932	!-- direct radiation
5933	IF ( cos_zenith > 0 ) THEN
5934	!--Identify solar direction vector (discretized number) 1)
5935	!--
5936	j = FLOOR(ACOS(cos_zenith) / pi * raytrace_discrete_elevs)
5937	i = MODULO(NINT(ATAN2(sun_dir_lon, sun_dir_lat) &
5938	/ (2._wppi) raytrace_discrete_azims-.5_wp, iwp), &
5939	raytrace_discrete_azims)
5940	isd = dsidir_rev(j, i)
5941	!-- TODO: check if isd = -1 to report that this solar position is not precalculated
5942	DO isurf = 1, nsurfl
5943	j = surfl(iy, isurf)
5944	i = surfl(ix, isurf)
5945	surfinswdir(isurf) = rad_sw_in_dir(j,i) * &
5946	costheta(surfl(id, isurf)) * dsitrans(isurf, isd) / cos_zenith
5947	ENDDO
5948	!
5949	!-- MRT direct irradiance
5950	DO imrt = 1, nmrtbl
5951	j = mrtbl(iy, imrt)
5952	i = mrtbl(ix, imrt)
5953	mrtinsw(imrt) = mrtinsw(imrt) + mrtdsit(imrt, isd) * rad_sw_in_dir(j,i) &
5954	/ cos_zenith / 4._wp ! normal to sphere
5955	ENDDO
5956	ENDIF
5957	!
5958	!-- MRT first pass thermal
5959	DO imrtf = 1, nmrtf
5960	imrt = mrtfsurf(1, imrtf)
5961	isurfsrc = mrtfsurf(2, imrtf)
5962	mrtinlw(imrt) = mrtinlw(imrt) + mrtf(imrtf) * surfoutl(isurfsrc)
5963	ENDDO
5964	!
5965	!-- Absorption in each local plant canopy grid box from the first atmospheric
5966	!-- pass of radiation
5967	IF ( npcbl > 0 ) THEN
5968
5969	pcbinswdir(:) = 0._wp
5970	pcbinswdif(:) = 0._wp
5971	pcbinlw(:) = 0._wp
5972
5973	DO icsf = 1, ncsfl
5974	ipcgb = csfsurf(1, icsf)
5975	i = pcbl(ix,ipcgb)
5976	j = pcbl(iy,ipcgb)
5977	k = pcbl(iz,ipcgb)
5978	isurfsrc = csfsurf(2, icsf)
5979
5980	IF ( isurfsrc == -1 ) THEN
5981	!
5982	!-- Diffuse radiation from sky
5983	pcbinswdif(ipcgb) = csf(1,icsf) * rad_sw_in_diff(j,i)
5984	!
5985	!-- Absorbed diffuse LW radiation from sky minus emitted to sky
5986	IF ( plant_lw_interact ) THEN
5987	pcbinlw(ipcgb) = csf(1,icsf) &
5988	* (rad_lw_in_diff(j, i) &
5989	- sigma_sb * (pt(k,j,i)exner(k))*4)
5990	ENDIF
5991	!
5992	!-- Direct solar radiation
5993	IF ( cos_zenith > 0 ) THEN
5994	!-- Estimate directed box absorption
5995	pc_abs_frac = 1._wp - exp(pc_abs_eff * lad_s(k,j,i))
5996	!
5997	!-- isd has already been established, see 1)
5998	pcbinswdir(ipcgb) = rad_sw_in_dir(j, i) * pc_box_area &
5999	* pc_abs_frac * dsitransc(ipcgb, isd)
6000	ENDIF
6001	ELSE
6002	IF ( plant_lw_interact ) THEN
6003	!
6004	!-- Thermal emission from plan canopy towards respective face
6005	pcrad = sigma_sb * (pt(k,j,i) * exner(k))*4 csf(1,icsf)
6006	surfinlg(isurfsrc) = surfinlg(isurfsrc) + pcrad
6007	!
6008	!-- Remove the flux above + absorb LW from first pass from surfaces
6009	asrc = facearea(surf(id, isurfsrc))
6010	pcbinlw(ipcgb) = pcbinlw(ipcgb) &
6011	+ (csf(1,icsf) * surfoutl(isurfsrc) & ! Absorb from first pass surf emit
6012	- pcrad) & ! Remove emitted heatflux
6013	* asrc
6014	ENDIF
6015	ENDIF
6016	ENDDO
6017
6018	pcbinsw(:) = pcbinswdir(:) + pcbinswdif(:)
6019	ENDIF
6020
6021	IF ( plant_lw_interact ) THEN
6022	!
6023	!-- Exchange incoming lw radiation from plant canopy
6024	#if defined( __parallel )
6025	CALL MPI_Allreduce(MPI_IN_PLACE, surfinlg, nsurf, MPI_REAL, MPI_SUM, comm2d, ierr)
6026	IF ( ierr /= 0 ) THEN
6027	WRITE (9,*) 'Error MPI_Allreduce:', ierr
6028	FLUSH(9)
6029	ENDIF
6030	surfinl(:) = surfinl(:) + surfinlg(surfstart(myid)+1:surfstart(myid+1))
6031	#else
6032	surfinl(:) = surfinl(:) + surfinlg(:)
6033	#endif
6034	ENDIF
6035
6036	surfins = surfinswdir + surfinswdif
6037	surfinl = surfinl + surfinlwdif
6038	surfinsw = surfins
6039	surfinlw = surfinl
6040	surfoutsw = 0.0_wp
6041	surfoutlw = surfoutll
6042	surfemitlwl = surfoutll
6043
6044	IF ( .NOT. surface_reflections ) THEN
6045	!
6046	!-- Set nrefsteps to 0 to disable reflections
6047	nrefsteps = 0
6048	surfoutsl = albedo_surf * surfins
6049	surfoutll = (1._wp - emiss_surf) * surfinl
6050	surfoutsw = surfoutsw + surfoutsl
6051	surfoutlw = surfoutlw + surfoutll
6052	ENDIF
6053
6054	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6055	!-- Next passes - reflections
6056	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6057	DO refstep = 1, nrefsteps
6058
6059	surfoutsl = albedo_surf * surfins
6060	!
6061	!-- for non-transparent surfaces, longwave albedo is 1 - emissivity
6062	surfoutll = (1._wp - emiss_surf) * surfinl
6063
6064	#if defined( __parallel )
6065	CALL MPI_AllGatherv(surfoutsl, nsurfl, MPI_REAL, &
6066	surfouts, nsurfs, surfstart, MPI_REAL, comm2d, ierr)
6067	IF ( ierr /= 0 ) THEN
6068	WRITE(9,*) 'Error MPI_AllGatherv2:', ierr, SIZE(surfoutsl), nsurfl, &
6069	SIZE(surfouts), nsurfs, surfstart
6070	FLUSH(9)
6071	ENDIF
6072
6073	CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, &
6074	surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr)
6075	IF ( ierr /= 0 ) THEN
6076	WRITE(9,*) 'Error MPI_AllGatherv3:', ierr, SIZE(surfoutll), nsurfl, &
6077	SIZE(surfoutl), nsurfs, surfstart
6078	FLUSH(9)
6079	ENDIF
6080
6081	#else
6082	surfouts = surfoutsl
6083	surfoutl = surfoutll
6084	#endif
6085	!
6086	!-- Reset for the input from next reflective pass
6087	surfins = 0._wp
6088	surfinl = 0._wp
6089	!
6090	!-- Reflected radiation
6091	DO isvf = 1, nsvfl
6092	isurf = svfsurf(1, isvf)
6093	isurfsrc = svfsurf(2, isvf)
6094	surfins(isurf) = surfins(isurf) + svf(1,isvf) * svf(2,isvf) * surfouts(isurfsrc)
6095	IF ( plant_lw_interact ) THEN
6096	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc)
6097	ELSE
6098	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)
6099	ENDIF
6100	ENDDO
6101	!
6102	!-- NOTE: PC absorbtion and MRT from reflected can both be done at once
6103	!-- after all reflections if we do one more MPI_ALLGATHERV on surfout.
6104	!-- Advantage: less local computation. Disadvantage: one more collective
6105	!-- MPI call.
6106	!
6107	!-- Radiation absorbed by plant canopy
6108	DO icsf = 1, ncsfl
6109	ipcgb = csfsurf(1, icsf)
6110	isurfsrc = csfsurf(2, icsf)
6111	IF ( isurfsrc == -1 ) CYCLE ! sky->face only in 1st pass, not here
6112	!
6113	!-- Calculate source surface area. If the `surf' array is removed
6114	!-- before timestepping starts (future version), then asrc must be
6115	!-- stored within `csf'
6116	asrc = facearea(surf(id, isurfsrc))
6117	pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * surfouts(isurfsrc) * asrc
6118	IF ( plant_lw_interact ) THEN
6119	pcbinlw(ipcgb) = pcbinlw(ipcgb) + csf(1,icsf) * surfoutl(isurfsrc) * asrc
6120	ENDIF
6121	ENDDO
6122	!
6123	!-- MRT reflected
6124	DO imrtf = 1, nmrtf
6125	imrt = mrtfsurf(1, imrtf)
6126	isurfsrc = mrtfsurf(2, imrtf)
6127	mrtinsw(imrt) = mrtinsw(imrt) + mrtft(imrtf) * surfouts(isurfsrc)
6128	mrtinlw(imrt) = mrtinlw(imrt) + mrtf(imrtf) * surfoutl(isurfsrc)
6129	ENDDO
6130
6131	surfinsw = surfinsw + surfins
6132	surfinlw = surfinlw + surfinl
6133	surfoutsw = surfoutsw + surfoutsl
6134	surfoutlw = surfoutlw + surfoutll
6135
6136	ENDDO ! refstep
6137
6138	!-- push heat flux absorbed by plant canopy to respective 3D arrays
6139	IF ( npcbl > 0 ) THEN
6140	pc_heating_rate(:,:,:) = 0.0_wp
6141	DO ipcgb = 1, npcbl
6142	j = pcbl(iy, ipcgb)
6143	i = pcbl(ix, ipcgb)
6144	k = pcbl(iz, ipcgb)
6145	!
6146	!-- Following expression equals former kk = k - nzb_s_inner(j,i)
6147	kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat
6148	pc_heating_rate(kk, j, i) = (pcbinsw(ipcgb) + pcbinlw(ipcgb)) &
6149	* pchf_prep(k) * pt(k, j, i) !-- = dT/dt
6150	ENDDO
6151
6152	IF ( humidity .AND. plant_canopy_transpiration ) THEN
6153	!-- Calculation of plant canopy transpiration rate and correspondidng latent heat rate
6154	pc_transpiration_rate(:,:,:) = 0.0_wp
6155	pc_latent_rate(:,:,:) = 0.0_wp
6156	DO ipcgb = 1, npcbl
6157	i = pcbl(ix, ipcgb)
6158	j = pcbl(iy, ipcgb)
6159	k = pcbl(iz, ipcgb)
6160	kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat
6161	CALL pcm_calc_transpiration_rate( i, j, k, kk, pcbinsw(ipcgb), pcbinlw(ipcgb), &
6162	pc_transpiration_rate(kk,j,i), pc_latent_rate(kk,j,i) )
6163	ENDDO
6164	ENDIF
6165	ENDIF
6166	!
6167	!-- Calculate black body MRT (after all reflections)
6168	IF ( nmrtbl > 0 ) THEN
6169	IF ( mrt_include_sw ) THEN
6170	mrt(:) = ((mrtinsw(:) + mrtinlw(:)) / sigma_sb) ** .25_wp
6171	ELSE
6172	mrt(:) = (mrtinlw(:) / sigma_sb) ** .25_wp
6173	ENDIF
6174	ENDIF
6175	!
6176	!-- Transfer radiation arrays required for energy balance to the respective data types
6177	DO i = 1, nsurfl
6178	m = surfl(im,i)
6179	!
6180	!-- (1) Urban surfaces
6181	!-- upward-facing
6182	IF ( surfl(1,i) == iup_u ) THEN
6183	surf_usm_h%rad_sw_in(m) = surfinsw(i)
6184	surf_usm_h%rad_sw_out(m) = surfoutsw(i)
6185	surf_usm_h%rad_sw_dir(m) = surfinswdir(i)
6186	surf_usm_h%rad_sw_dif(m) = surfinswdif(i)
6187	surf_usm_h%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6188	surfinswdif(i)
6189	surf_usm_h%rad_sw_res(m) = surfins(i)
6190	surf_usm_h%rad_lw_in(m) = surfinlw(i)
6191	surf_usm_h%rad_lw_out(m) = surfoutlw(i)
6192	surf_usm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6193	surfinlw(i) - surfoutlw(i)
6194	surf_usm_h%rad_net_l(m) = surf_usm_h%rad_net(m)
6195	surf_usm_h%rad_lw_dif(m) = surfinlwdif(i)
6196	surf_usm_h%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6197	surf_usm_h%rad_lw_res(m) = surfinl(i)
6198	!
6199	!-- northward-facding
6200	ELSEIF ( surfl(1,i) == inorth_u ) THEN
6201	surf_usm_v(0)%rad_sw_in(m) = surfinsw(i)
6202	surf_usm_v(0)%rad_sw_out(m) = surfoutsw(i)
6203	surf_usm_v(0)%rad_sw_dir(m) = surfinswdir(i)
6204	surf_usm_v(0)%rad_sw_dif(m) = surfinswdif(i)
6205	surf_usm_v(0)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6206	surfinswdif(i)
6207	surf_usm_v(0)%rad_sw_res(m) = surfins(i)
6208	surf_usm_v(0)%rad_lw_in(m) = surfinlw(i)
6209	surf_usm_v(0)%rad_lw_out(m) = surfoutlw(i)
6210	surf_usm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6211	surfinlw(i) - surfoutlw(i)
6212	surf_usm_v(0)%rad_net_l(m) = surf_usm_v(0)%rad_net(m)
6213	surf_usm_v(0)%rad_lw_dif(m) = surfinlwdif(i)
6214	surf_usm_v(0)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6215	surf_usm_v(0)%rad_lw_res(m) = surfinl(i)
6216	!
6217	!-- southward-facding
6218	ELSEIF ( surfl(1,i) == isouth_u ) THEN
6219	surf_usm_v(1)%rad_sw_in(m) = surfinsw(i)
6220	surf_usm_v(1)%rad_sw_out(m) = surfoutsw(i)
6221	surf_usm_v(1)%rad_sw_dir(m) = surfinswdir(i)
6222	surf_usm_v(1)%rad_sw_dif(m) = surfinswdif(i)
6223	surf_usm_v(1)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6224	surfinswdif(i)
6225	surf_usm_v(1)%rad_sw_res(m) = surfins(i)
6226	surf_usm_v(1)%rad_lw_in(m) = surfinlw(i)
6227	surf_usm_v(1)%rad_lw_out(m) = surfoutlw(i)
6228	surf_usm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6229	surfinlw(i) - surfoutlw(i)
6230	surf_usm_v(1)%rad_net_l(m) = surf_usm_v(1)%rad_net(m)
6231	surf_usm_v(1)%rad_lw_dif(m) = surfinlwdif(i)
6232	surf_usm_v(1)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6233	surf_usm_v(1)%rad_lw_res(m) = surfinl(i)
6234	!
6235	!-- eastward-facing
6236	ELSEIF ( surfl(1,i) == ieast_u ) THEN
6237	surf_usm_v(2)%rad_sw_in(m) = surfinsw(i)
6238	surf_usm_v(2)%rad_sw_out(m) = surfoutsw(i)
6239	surf_usm_v(2)%rad_sw_dir(m) = surfinswdir(i)
6240	surf_usm_v(2)%rad_sw_dif(m) = surfinswdif(i)
6241	surf_usm_v(2)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6242	surfinswdif(i)
6243	surf_usm_v(2)%rad_sw_res(m) = surfins(i)
6244	surf_usm_v(2)%rad_lw_in(m) = surfinlw(i)
6245	surf_usm_v(2)%rad_lw_out(m) = surfoutlw(i)
6246	surf_usm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6247	surfinlw(i) - surfoutlw(i)
6248	surf_usm_v(2)%rad_net_l(m) = surf_usm_v(2)%rad_net(m)
6249	surf_usm_v(2)%rad_lw_dif(m) = surfinlwdif(i)
6250	surf_usm_v(2)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6251	surf_usm_v(2)%rad_lw_res(m) = surfinl(i)
6252	!
6253	!-- westward-facding
6254	ELSEIF ( surfl(1,i) == iwest_u ) THEN
6255	surf_usm_v(3)%rad_sw_in(m) = surfinsw(i)
6256	surf_usm_v(3)%rad_sw_out(m) = surfoutsw(i)
6257	surf_usm_v(3)%rad_sw_dir(m) = surfinswdir(i)
6258	surf_usm_v(3)%rad_sw_dif(m) = surfinswdif(i)
6259	surf_usm_v(3)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6260	surfinswdif(i)
6261	surf_usm_v(3)%rad_sw_res(m) = surfins(i)
6262	surf_usm_v(3)%rad_lw_in(m) = surfinlw(i)
6263	surf_usm_v(3)%rad_lw_out(m) = surfoutlw(i)
6264	surf_usm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6265	surfinlw(i) - surfoutlw(i)
6266	surf_usm_v(3)%rad_net_l(m) = surf_usm_v(3)%rad_net(m)
6267	surf_usm_v(3)%rad_lw_dif(m) = surfinlwdif(i)
6268	surf_usm_v(3)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6269	surf_usm_v(3)%rad_lw_res(m) = surfinl(i)
6270	!
6271	!-- (2) land surfaces
6272	!-- upward-facing
6273	ELSEIF ( surfl(1,i) == iup_l ) THEN
6274	surf_lsm_h%rad_sw_in(m) = surfinsw(i)
6275	surf_lsm_h%rad_sw_out(m) = surfoutsw(i)
6276	surf_lsm_h%rad_sw_dir(m) = surfinswdir(i)
6277	surf_lsm_h%rad_sw_dif(m) = surfinswdif(i)
6278	surf_lsm_h%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6279	surfinswdif(i)
6280	surf_lsm_h%rad_sw_res(m) = surfins(i)
6281	surf_lsm_h%rad_lw_in(m) = surfinlw(i)
6282	surf_lsm_h%rad_lw_out(m) = surfoutlw(i)
6283	surf_lsm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6284	surfinlw(i) - surfoutlw(i)
6285	surf_lsm_h%rad_lw_dif(m) = surfinlwdif(i)
6286	surf_lsm_h%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6287	surf_lsm_h%rad_lw_res(m) = surfinl(i)
6288	!
6289	!-- northward-facding
6290	ELSEIF ( surfl(1,i) == inorth_l ) THEN
6291	surf_lsm_v(0)%rad_sw_in(m) = surfinsw(i)
6292	surf_lsm_v(0)%rad_sw_out(m) = surfoutsw(i)
6293	surf_lsm_v(0)%rad_sw_dir(m) = surfinswdir(i)
6294	surf_lsm_v(0)%rad_sw_dif(m) = surfinswdif(i)
6295	surf_lsm_v(0)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6296	surfinswdif(i)
6297	surf_lsm_v(0)%rad_sw_res(m) = surfins(i)
6298	surf_lsm_v(0)%rad_lw_in(m) = surfinlw(i)
6299	surf_lsm_v(0)%rad_lw_out(m) = surfoutlw(i)
6300	surf_lsm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6301	surfinlw(i) - surfoutlw(i)
6302	surf_lsm_v(0)%rad_lw_dif(m) = surfinlwdif(i)
6303	surf_lsm_v(0)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6304	surf_lsm_v(0)%rad_lw_res(m) = surfinl(i)
6305	!
6306	!-- southward-facding
6307	ELSEIF ( surfl(1,i) == isouth_l ) THEN
6308	surf_lsm_v(1)%rad_sw_in(m) = surfinsw(i)
6309	surf_lsm_v(1)%rad_sw_out(m) = surfoutsw(i)
6310	surf_lsm_v(1)%rad_sw_dir(m) = surfinswdir(i)
6311	surf_lsm_v(1)%rad_sw_dif(m) = surfinswdif(i)
6312	surf_lsm_v(1)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6313	surfinswdif(i)
6314	surf_lsm_v(1)%rad_sw_res(m) = surfins(i)
6315	surf_lsm_v(1)%rad_lw_in(m) = surfinlw(i)
6316	surf_lsm_v(1)%rad_lw_out(m) = surfoutlw(i)
6317	surf_lsm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6318	surfinlw(i) - surfoutlw(i)
6319	surf_lsm_v(1)%rad_lw_dif(m) = surfinlwdif(i)
6320	surf_lsm_v(1)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6321	surf_lsm_v(1)%rad_lw_res(m) = surfinl(i)
6322	!
6323	!-- eastward-facing
6324	ELSEIF ( surfl(1,i) == ieast_l ) THEN
6325	surf_lsm_v(2)%rad_sw_in(m) = surfinsw(i)
6326	surf_lsm_v(2)%rad_sw_out(m) = surfoutsw(i)
6327	surf_lsm_v(2)%rad_sw_dir(m) = surfinswdir(i)
6328	surf_lsm_v(2)%rad_sw_dif(m) = surfinswdif(i)
6329	surf_lsm_v(2)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6330	surfinswdif(i)
6331	surf_lsm_v(2)%rad_sw_res(m) = surfins(i)
6332	surf_lsm_v(2)%rad_lw_in(m) = surfinlw(i)
6333	surf_lsm_v(2)%rad_lw_out(m) = surfoutlw(i)
6334	surf_lsm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6335	surfinlw(i) - surfoutlw(i)
6336	surf_lsm_v(2)%rad_lw_dif(m) = surfinlwdif(i)
6337	surf_lsm_v(2)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6338	surf_lsm_v(2)%rad_lw_res(m) = surfinl(i)
6339	!
6340	!-- westward-facing
6341	ELSEIF ( surfl(1,i) == iwest_l ) THEN
6342	surf_lsm_v(3)%rad_sw_in(m) = surfinsw(i)
6343	surf_lsm_v(3)%rad_sw_out(m) = surfoutsw(i)
6344	surf_lsm_v(3)%rad_sw_dir(m) = surfinswdir(i)
6345	surf_lsm_v(3)%rad_sw_dif(m) = surfinswdif(i)
6346	surf_lsm_v(3)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
6347	surfinswdif(i)
6348	surf_lsm_v(3)%rad_sw_res(m) = surfins(i)
6349	surf_lsm_v(3)%rad_lw_in(m) = surfinlw(i)
6350	surf_lsm_v(3)%rad_lw_out(m) = surfoutlw(i)
6351	surf_lsm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
6352	surfinlw(i) - surfoutlw(i)
6353	surf_lsm_v(3)%rad_lw_dif(m) = surfinlwdif(i)
6354	surf_lsm_v(3)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6355	surf_lsm_v(3)%rad_lw_res(m) = surfinl(i)
6356	ENDIF
6357
6358	ENDDO
6359
6360	DO m = 1, surf_usm_h%ns
6361	surf_usm_h%surfhf(m) = surf_usm_h%rad_sw_in(m) + &
6362	surf_usm_h%rad_lw_in(m) - &
6363	surf_usm_h%rad_sw_out(m) - &
6364	surf_usm_h%rad_lw_out(m)
6365	ENDDO
6366	DO m = 1, surf_lsm_h%ns
6367	surf_lsm_h%surfhf(m) = surf_lsm_h%rad_sw_in(m) + &
6368	surf_lsm_h%rad_lw_in(m) - &
6369	surf_lsm_h%rad_sw_out(m) - &
6370	surf_lsm_h%rad_lw_out(m)
6371	ENDDO
6372
6373	DO l = 0, 3
6374	!-- urban
6375	DO m = 1, surf_usm_v(l)%ns
6376	surf_usm_v(l)%surfhf(m) = surf_usm_v(l)%rad_sw_in(m) + &
6377	surf_usm_v(l)%rad_lw_in(m) - &
6378	surf_usm_v(l)%rad_sw_out(m) - &
6379	surf_usm_v(l)%rad_lw_out(m)
6380	ENDDO
6381	!-- land
6382	DO m = 1, surf_lsm_v(l)%ns
6383	surf_lsm_v(l)%surfhf(m) = surf_lsm_v(l)%rad_sw_in(m) + &
6384	surf_lsm_v(l)%rad_lw_in(m) - &
6385	surf_lsm_v(l)%rad_sw_out(m) - &
6386	surf_lsm_v(l)%rad_lw_out(m)
6387
6388	ENDDO
6389	ENDDO
6390	!
6391	!-- Calculate the average temperature, albedo, and emissivity for urban/land
6392	!-- domain when using average_radiation in the respective radiation model
6393
6394	!-- calculate horizontal area
6395	! !!! ATTENTION!!! uniform grid is assumed here
6396	area_hor = (nx+1) * (ny+1) * dx * dy
6397	!
6398	!-- absorbed/received SW & LW and emitted LW energy of all physical
6399	!-- surfaces (land and urban) in local processor
6400	pinswl = 0._wp
6401	pinlwl = 0._wp
6402	pabsswl = 0._wp
6403	pabslwl = 0._wp
6404	pemitlwl = 0._wp
6405	emiss_sum_surfl = 0._wp
6406	area_surfl = 0._wp
6407	DO i = 1, nsurfl
6408	d = surfl(id, i)
6409	!-- received SW & LW
6410	pinswl = pinswl + (surfinswdir(i) + surfinswdif(i)) * facearea(d)
6411	pinlwl = pinlwl + surfinlwdif(i) * facearea(d)
6412	!-- absorbed SW & LW
6413	pabsswl = pabsswl + (1._wp - albedo_surf(i)) * &
6414	surfinsw(i) * facearea(d)
6415	pabslwl = pabslwl + emiss_surf(i) * surfinlw(i) * facearea(d)
6416	!-- emitted LW
6417	pemitlwl = pemitlwl + surfemitlwl(i) * facearea(d)
6418	!-- emissivity and area sum
6419	emiss_sum_surfl = emiss_sum_surfl + emiss_surf(i) * facearea(d)
6420	area_surfl = area_surfl + facearea(d)
6421	END DO
6422	!
6423	!-- add the absorbed SW energy by plant canopy
6424	IF ( npcbl > 0 ) THEN
6425	pabsswl = pabsswl + SUM(pcbinsw)
6426	pabslwl = pabslwl + SUM(pcbinlw)
6427	pinswl = pinswl + SUM(pcbinswdir) + SUM(pcbinswdif)
6428	ENDIF
6429	!
6430	!-- gather all rad flux energy in all processors. In order to reduce
6431	!-- the number of MPI calls (to reduce latencies), combine the required
6432	!-- quantities in one array, sum it up, and subsequently re-distribute
6433	!-- back to the respective quantities.
6434	#if defined( __parallel )
6435	combine_allreduce_l(1) = pinswl
6436	combine_allreduce_l(2) = pinlwl
6437	combine_allreduce_l(3) = pabsswl
6438	combine_allreduce_l(4) = pabslwl
6439	combine_allreduce_l(5) = pemitlwl
6440	combine_allreduce_l(6) = emiss_sum_surfl
6441	combine_allreduce_l(7) = area_surfl
6442
6443	CALL MPI_ALLREDUCE( combine_allreduce_l, &
6444	combine_allreduce, &
6445	SIZE( combine_allreduce ), &
6446	MPI_REAL, &
6447	MPI_SUM, &
6448	comm2d, &
6449	ierr )
6450
6451	pinsw = combine_allreduce(1)
6452	pinlw = combine_allreduce(2)
6453	pabssw = combine_allreduce(3)
6454	pabslw = combine_allreduce(4)
6455	pemitlw = combine_allreduce(5)
6456	emiss_sum_surf = combine_allreduce(6)
6457	area_surf = combine_allreduce(7)
6458	#else
6459	pinsw = pinswl
6460	pinlw = pinlwl
6461	pabssw = pabsswl
6462	pabslw = pabslwl
6463	pemitlw = pemitlwl
6464	emiss_sum_surf = emiss_sum_surfl
6465	area_surf = area_surfl
6466	#endif
6467
6468	!-- (1) albedo
6469	IF ( pinsw /= 0.0_wp ) albedo_urb = ( pinsw - pabssw ) / pinsw
6470	!-- (2) average emmsivity
6471	IF ( area_surf /= 0.0_wp ) emissivity_urb = emiss_sum_surf / area_surf
6472	!
6473	!-- Temporally comment out calculation of effective radiative temperature.
6474	!-- See below for more explanation.
6475	!-- (3) temperature
6476	!-- first we calculate an effective horizontal area to account for
6477	!-- the effect of vertical surfaces (which contributes to LW emission)
6478	!-- We simply use the ratio of the total LW to the incoming LW flux
6479	area_hor = pinlw / rad_lw_in_diff(nyn,nxl)
6480	t_rad_urb = ( ( pemitlw - pabslw + emissivity_urb * pinlw ) / &
6481	(emissivity_urb * sigma_sb * area_hor) )**0.25_wp
6482
6483	IF ( debug_output_timestep ) CALL debug_message( 'radiation_interaction', 'end' )
6484
6485
6486	CONTAINS
6487
6488	!------------------------------------------------------------------------------!
6489	!> Calculates radiation absorbed by box with given size and LAD.
6490	!>
6491	!> Simulates resol**2 rays (by equally spacing a bounding horizontal square
6492	!> conatining all possible rays that would cross the box) and calculates
6493	!> average transparency per ray. Returns fraction of absorbed radiation flux
6494	!> and area for which this fraction is effective.
6495	!------------------------------------------------------------------------------!
6496	PURE SUBROUTINE box_absorb(boxsize, resol, dens, uvec, area, absorb)
6497	IMPLICIT NONE
6498
6499	REAL(wp), DIMENSION(3), INTENT(in) :: &
6500	boxsize, & !< z, y, x size of box in m
6501	uvec !< z, y, x unit vector of incoming flux
6502	INTEGER(iwp), INTENT(in) :: &
6503	resol !< No. of rays in x and y dimensions
6504	REAL(wp), INTENT(in) :: &
6505	dens !< box density (e.g. Leaf Area Density)
6506	REAL(wp), INTENT(out) :: &
6507	area, & !< horizontal area for flux absorbtion
6508	absorb !< fraction of absorbed flux
6509	REAL(wp) :: &
6510	xshift, yshift, &
6511	xmin, xmax, ymin, ymax, &
6512	xorig, yorig, &
6513	dx1, dy1, dz1, dx2, dy2, dz2, &
6514	crdist, &
6515	transp
6516	INTEGER(iwp) :: &
6517	i, j
6518
6519	xshift = uvec(3) / uvec(1) * boxsize(1)
6520	xmin = min(0._wp, -xshift)
6521	xmax = boxsize(3) + max(0._wp, -xshift)
6522	yshift = uvec(2) / uvec(1) * boxsize(1)
6523	ymin = min(0._wp, -yshift)
6524	ymax = boxsize(2) + max(0._wp, -yshift)
6525
6526	transp = 0._wp
6527	DO i = 1, resol
6528	xorig = xmin + (xmax-xmin) * (i-.5_wp) / resol
6529	DO j = 1, resol
6530	yorig = ymin + (ymax-ymin) * (j-.5_wp) / resol
6531
6532	dz1 = 0._wp
6533	dz2 = boxsize(1)/uvec(1)
6534
6535	IF ( uvec(2) > 0._wp ) THEN
6536	dy1 = -yorig / uvec(2) !< crossing with y=0
6537	dy2 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2)
6538	ELSE !uvec(2)==0
6539	dy1 = -huge(1._wp)
6540	dy2 = huge(1._wp)
6541	ENDIF
6542
6543	IF ( uvec(3) > 0._wp ) THEN
6544	dx1 = -xorig / uvec(3) !< crossing with x=0
6545	dx2 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3)
6546	ELSE !uvec(3)==0
6547	dx1 = -huge(1._wp)
6548	dx2 = huge(1._wp)
6549	ENDIF
6550
6551	crdist = max(0._wp, (min(dz2, dy2, dx2) - max(dz1, dy1, dx1)))
6552	transp = transp + exp(-ext_coef * dens * crdist)
6553	ENDDO
6554	ENDDO
6555	transp = transp / resol**2
6556	area = (boxsize(3)+xshift)*(boxsize(2)+yshift)
6557	absorb = 1._wp - transp
6558
6559	END SUBROUTINE box_absorb
6560
6561	!------------------------------------------------------------------------------!
6562	! Description:
6563	! ------------
6564	!> This subroutine splits direct and diffusion dw radiation
6565	!> It sould not be called in case the radiation model already does it
6566	!> It follows Boland, Ridley & Brown (2008)
6567	!------------------------------------------------------------------------------!
6568	SUBROUTINE calc_diffusion_radiation
6569
6570	USE palm_date_time_mod, &
6571	ONLY: seconds_per_day
6572
6573	INTEGER(iwp) :: i !< grid index x-direction
6574	INTEGER(iwp) :: j !< grid index y-direction
6575	INTEGER(iwp) :: days_per_year !< days in the current year
6576
6577	REAL(wp) :: clearnessIndex !< clearness index
6578	REAL(wp) :: corrected_solarUp !< corrected solar up radiation
6579	REAL(wp) :: diff_frac !< diffusion fraction of the radiation
6580	REAL(wp) :: etr !< extraterestrial radiation
6581	REAL(wp) :: horizontalETR !< horizontal extraterestrial radiation
6582	REAL(wp), PARAMETER :: lowest_solarUp = 0.1_wp !< limit the sun elevation to protect stability of the calculation
6583	REAL(wp) :: second_of_year !< current second of the year
6584	REAL(wp) :: year_angle !< angle
6585
6586	!
6587	!-- Calculate current day and time based on the initial values and simulation time
6588	CALL get_date_time( time_since_reference_point, &
6589	second_of_year = second_of_year, &
6590	days_per_year = days_per_year )
6591	year_angle = second_of_year / ( REAL( days_per_year, KIND=wp ) * seconds_per_day ) &
6592	* 2.0_wp * pi
6593
6594	etr = solar_constant * (1.00011_wp + &
6595	0.034221_wp * cos(year_angle) + &
6596	0.001280_wp * sin(year_angle) + &
6597	0.000719_wp * cos(2.0_wp * year_angle) + &
6598	0.000077_wp * sin(2.0_wp * year_angle))
6599
6600	!--
6601	!-- Under a very low angle, we keep extraterestrial radiation at
6602	!-- the last small value, therefore the clearness index will be pushed
6603	!-- towards 0 while keeping full continuity.
6604	IF ( cos_zenith <= lowest_solarUp ) THEN
6605	corrected_solarUp = lowest_solarUp
6606	ELSE
6607	corrected_solarUp = cos_zenith
6608	ENDIF
6609
6610	horizontalETR = etr * corrected_solarUp
6611
6612	DO i = nxl, nxr
6613	DO j = nys, nyn
6614	clearnessIndex = rad_sw_in(0,j,i) / horizontalETR
6615	diff_frac = 1.0_wp / (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex))
6616	rad_sw_in_diff(j,i) = rad_sw_in(0,j,i) * diff_frac
6617	rad_sw_in_dir(j,i) = rad_sw_in(0,j,i) * (1.0_wp - diff_frac)
6618	rad_lw_in_diff(j,i) = rad_lw_in(0,j,i)
6619	ENDDO
6620	ENDDO
6621
6622	END SUBROUTINE calc_diffusion_radiation
6623
6624	END SUBROUTINE radiation_interaction
6625
6626	!------------------------------------------------------------------------------!
6627	! Description:
6628	! ------------
6629	!> This subroutine initializes structures needed for radiative transfer
6630	!> model. This model calculates transformation processes of the
6631	!> radiation inside urban and land canopy layer. The module includes also
6632	!> the interaction of the radiation with the resolved plant canopy.
6633	!>
6634	!> For more info. see Resler et al. 2017
6635	!>
6636	!> The new version 2.0 was radically rewriten, the discretization scheme
6637	!> has been changed. This new version significantly improves effectivity
6638	!> of the paralelization and the scalability of the model.
6639	!>
6640	!------------------------------------------------------------------------------!
6641	SUBROUTINE radiation_interaction_init
6642
6643	USE control_parameters, &
6644	ONLY: dz_stretch_level_start
6645
6646	USE plant_canopy_model_mod, &
6647	ONLY: lad_s
6648
6649	IMPLICIT NONE
6650
6651	INTEGER(iwp) :: i, j, k, l, m, d
6652	INTEGER(iwp) :: k_topo !< vertical index indicating topography top for given (j,i)
6653	INTEGER(iwp) :: nzptl, nzubl, nzutl, isurf, ipcgb, imrt
6654	REAL(wp) :: mrl
6655	#if defined( __parallel )
6656	INTEGER(iwp), DIMENSION(:), POINTER, SAVE :: gridsurf_rma !< fortran pointer, but lower bounds are 1
6657	TYPE(c_ptr) :: gridsurf_rma_p !< allocated c pointer
6658	INTEGER(iwp) :: minfo !< MPI RMA window info handle
6659	#endif
6660
6661	!
6662	!-- precalculate face areas for different face directions using normal vector
6663	DO d = 0, nsurf_type
6664	facearea(d) = 1._wp
6665	IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx
6666	IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy
6667	IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz(1)
6668	ENDDO
6669	!
6670	!-- Find nz_urban_b, nz_urban_t, nz_urban via wall_flag_0 array (nzb_s_inner will be
6671	!-- removed later). The following contruct finds the lowest / largest index
6672	!-- for any upward-facing wall (see bit 12).
6673	nzubl = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
6674	nzutl = MAXVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
6675
6676	nzubl = MAX( nzubl, nzb )
6677
6678	IF ( plant_canopy ) THEN
6679	!-- allocate needed arrays
6680	ALLOCATE( pct(nys:nyn,nxl:nxr) )
6681	ALLOCATE( pch(nys:nyn,nxl:nxr) )
6682
6683	!-- calculate plant canopy height
6684	npcbl = 0
6685	pct = 0
6686	pch = 0
6687	DO i = nxl, nxr
6688	DO j = nys, nyn
6689	!
6690	!-- Find topography top index
6691	k_topo = topo_top_ind(j,i,0)
6692
6693	DO k = nzt+1, 0, -1
6694	IF ( lad_s(k,j,i) /= 0.0_wp ) THEN
6695	!-- we are at the top of the pcs
6696	pct(j,i) = k + k_topo
6697	pch(j,i) = k
6698	npcbl = npcbl + pch(j,i)
6699	EXIT
6700	ENDIF
6701	ENDDO
6702	ENDDO
6703	ENDDO
6704
6705	nzutl = MAX( nzutl, MAXVAL( pct ) )
6706	nzptl = MAXVAL( pct )
6707
6708	prototype_lad = MAXVAL( lad_s ) * .9_wp !< better be *1.0 if lad is either 0 or maxval(lad) everywhere
6709	IF ( prototype_lad <= 0._wp ) prototype_lad = .3_wp
6710	!WRITE(message_string, '(a,f6.3)') 'Precomputing effective box optical ' &
6711	! // 'depth using prototype leaf area density = ', prototype_lad
6712	!CALL message('radiation_interaction_init', 'PA0520', 0, 0, -1, 6, 0)
6713	ENDIF
6714
6715	nzutl = MIN( nzutl + nzut_free, nzt )
6716
6717	#if defined( __parallel )
6718	CALL MPI_AllReduce(nzubl, nz_urban_b, 1, MPI_INTEGER, MPI_MIN, comm2d, ierr )
6719	IF ( ierr /= 0 ) THEN
6720	WRITE(9,*) 'Error MPI_AllReduce11:', ierr, nzubl, nz_urban_b
6721	FLUSH(9)
6722	ENDIF
6723	CALL MPI_AllReduce(nzutl, nz_urban_t, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr )
6724	IF ( ierr /= 0 ) THEN
6725	WRITE(9,*) 'Error MPI_AllReduce12:', ierr, nzutl, nz_urban_t
6726	FLUSH(9)
6727	ENDIF
6728	CALL MPI_AllReduce(nzptl, nz_plant_t, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr )
6729	IF ( ierr /= 0 ) THEN
6730	WRITE(9,*) 'Error MPI_AllReduce13:', ierr, nzptl, nz_plant_t
6731	FLUSH(9)
6732	ENDIF
6733	#else
6734	nz_urban_b = nzubl
6735	nz_urban_t = nzutl
6736	nz_plant_t = nzptl
6737	#endif
6738	!
6739	!-- Stretching (non-uniform grid spacing) is not considered in the radiation
6740	!-- model. Therefore, vertical stretching has to be applied above the area
6741	!-- where the parts of the radiation model which assume constant grid spacing
6742	!-- are active. ABS (...) is required because the default value of
6743	!-- dz_stretch_level_start is -9999999.9_wp (negative).
6744	IF ( ABS( dz_stretch_level_start(1) ) <= zw(nz_urban_t) ) THEN
6745	WRITE( message_string, * ) 'The lowest level where vertical ', &
6746	'stretching is applied have to be ', &
6747	'greater than ', zw(nz_urban_t)
6748	CALL message( 'radiation_interaction_init', 'PA0496', 1, 2, 0, 6, 0 )
6749	ENDIF
6750	!
6751	!-- global number of urban and plant layers
6752	nz_urban = nz_urban_t - nz_urban_b + 1
6753	nz_plant = nz_plant_t - nz_urban_b + 1
6754	!
6755	!-- check max_raytracing_dist relative to urban surface layer height
6756	mrl = 2.0_wp * nz_urban * dz(1)
6757	!-- set max_raytracing_dist to double the urban surface layer height, if not set
6758	IF ( max_raytracing_dist == -999.0_wp ) THEN
6759	max_raytracing_dist = mrl
6760	ENDIF
6761	!-- check if max_raytracing_dist set too low (here we only warn the user. Other
6762	! option is to correct the value again to double the urban surface layer height)
6763	IF ( max_raytracing_dist < mrl ) THEN
6764	WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist is set less than ' // &
6765	'double the urban surface layer height, i.e. ', mrl
6766	CALL message('radiation_interaction_init', 'PA0521', 0, 0, 0, 6, 0 )
6767	ENDIF
6768	! IF ( max_raytracing_dist <= mrl ) THEN
6769	! IF ( max_raytracing_dist /= -999.0_wp ) THEN
6770	! !-- max_raytracing_dist too low
6771	! WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist too low, ' &
6772	! // 'override to value ', mrl
6773	! CALL message('radiation_interaction_init', 'PA0521', 0, 0, -1, 6, 0)
6774	! ENDIF
6775	! max_raytracing_dist = mrl
6776	! ENDIF
6777	!
6778	!-- allocate urban surfaces grid
6779	!-- calc number of surfaces in local proc
6780	IF ( debug_output ) CALL debug_message( 'calculation of indices for surfaces', 'info' )
6781
6782	nsurfl = 0
6783	!
6784	!-- Number of horizontal surfaces including land- and roof surfaces in both USM and LSM. Note that
6785	!-- All horizontal surface elements are already counted in surface_mod.
6786	startland = 1
6787	nsurfl = surf_usm_h%ns + surf_lsm_h%ns
6788	endland = nsurfl
6789	nlands = endland - startland + 1
6790
6791	!
6792	!-- Number of vertical surfaces in both USM and LSM. Note that all vertical surface elements are
6793	!-- already counted in surface_mod.
6794	startwall = nsurfl+1
6795	DO i = 0,3
6796	nsurfl = nsurfl + surf_usm_v(i)%ns + surf_lsm_v(i)%ns
6797	ENDDO
6798	endwall = nsurfl
6799	nwalls = endwall - startwall + 1
6800	dirstart = (/ startland, startwall, startwall, startwall, startwall /)
6801	dirend = (/ endland, endwall, endwall, endwall, endwall /)
6802
6803	!-- fill gridpcbl and pcbl
6804	IF ( npcbl > 0 ) THEN
6805	ALLOCATE( pcbl(iz:ix, 1:npcbl) )
6806	ALLOCATE( gridpcbl(nz_urban_b:nz_plant_t,nys:nyn,nxl:nxr) )
6807	pcbl = -1
6808	gridpcbl(:,:,:) = 0
6809	ipcgb = 0
6810	DO i = nxl, nxr
6811	DO j = nys, nyn
6812	!
6813	!-- Find topography top index
6814	k_topo = topo_top_ind(j,i,0)
6815
6816	DO k = k_topo + 1, pct(j,i)
6817	ipcgb = ipcgb + 1
6818	gridpcbl(k,j,i) = ipcgb
6819	pcbl(:,ipcgb) = (/ k, j, i /)
6820	ENDDO
6821	ENDDO
6822	ENDDO
6823	ALLOCATE( pcbinsw( 1:npcbl ) )
6824	ALLOCATE( pcbinswdir( 1:npcbl ) )
6825	ALLOCATE( pcbinswdif( 1:npcbl ) )
6826	ALLOCATE( pcbinlw( 1:npcbl ) )
6827	ENDIF
6828
6829	!
6830	!-- Fill surfl (the ordering of local surfaces given by the following
6831	!-- cycles must not be altered, certain file input routines may depend
6832	!-- on it).
6833	!
6834	!-- We allocate the array as linear and then use a two-dimensional pointer
6835	!-- into it, because some MPI implementations crash with 2D-allocated arrays.
6836	ALLOCATE(surfl_linear(nidx_surf*nsurfl))
6837	surfl(1:nidx_surf,1:nsurfl) => surfl_linear(1:nidx_surf*nsurfl)
6838	isurf = 0
6839	IF ( rad_angular_discretization ) THEN
6840	!
6841	!-- Allocate and fill the reverse indexing array gridsurf
6842	#if defined( __parallel )
6843	!
6844	!-- raytrace_mpi_rma is asserted
6845
6846	CALL MPI_Info_create(minfo, ierr)
6847	IF ( ierr /= 0 ) THEN
6848	WRITE(9,*) 'Error MPI_Info_create1:', ierr
6849	FLUSH(9)
6850	ENDIF
6851	CALL MPI_Info_set(minfo, 'accumulate_ordering', 'none', ierr)
6852	IF ( ierr /= 0 ) THEN
6853	WRITE(9,*) 'Error MPI_Info_set1:', ierr
6854	FLUSH(9)
6855	ENDIF
6856	CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr)
6857	IF ( ierr /= 0 ) THEN
6858	WRITE(9,*) 'Error MPI_Info_set2:', ierr
6859	FLUSH(9)
6860	ENDIF
6861	CALL MPI_Info_set(minfo, 'same_size', 'true', ierr)
6862	IF ( ierr /= 0 ) THEN
6863	WRITE(9,*) 'Error MPI_Info_set3:', ierr
6864	FLUSH(9)
6865	ENDIF
6866	CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr)
6867	IF ( ierr /= 0 ) THEN
6868	WRITE(9,*) 'Error MPI_Info_set4:', ierr
6869	FLUSH(9)
6870	ENDIF
6871
6872	CALL MPI_Win_allocate(INT(STORAGE_SIZE(1_iwp)/8nsurf_type_unz_urbannnynnx, &
6873	kind=MPI_ADDRESS_KIND), STORAGE_SIZE(1_iwp)/8, &
6874	minfo, comm2d, gridsurf_rma_p, win_gridsurf, ierr)
6875	IF ( ierr /= 0 ) THEN
6876	WRITE(9,*) 'Error MPI_Win_allocate1:', ierr, &
6877	INT(STORAGE_SIZE(1_iwp)/8nsurf_type_unz_urbannnynnx,kind=MPI_ADDRESS_KIND), &
6878	STORAGE_SIZE(1_iwp)/8, win_gridsurf
6879	FLUSH(9)
6880	ENDIF
6881
6882	CALL MPI_Info_free(minfo, ierr)
6883	IF ( ierr /= 0 ) THEN
6884	WRITE(9,*) 'Error MPI_Info_free1:', ierr
6885	FLUSH(9)
6886	ENDIF
6887
6888	!
6889	!-- On Intel compilers, calling c_f_pointer to transform a C pointer
6890	!-- directly to a multi-dimensional Fotran pointer leads to strange
6891	!-- errors on dimension boundaries. However, transforming to a 1D
6892	!-- pointer and then redirecting a multidimensional pointer to it works
6893	!-- fine.
6894	CALL c_f_pointer(gridsurf_rma_p, gridsurf_rma, (/ nsurf_type_unz_urbannny*nnx /))
6895	gridsurf(0:nsurf_type_u-1, nz_urban_b:nz_urban_t, nys:nyn, nxl:nxr) => &
6896	gridsurf_rma(1:nsurf_type_unz_urbannny*nnx)
6897	#else
6898	ALLOCATE(gridsurf(0:nsurf_type_u-1,nz_urban_b:nz_urban_t,nys:nyn,nxl:nxr) )
6899	#endif
6900	gridsurf(:,:,:,:) = -999
6901	ENDIF
6902
6903	!-- add horizontal surface elements (land and urban surfaces)
6904	!-- TODO: add urban overhanging surfaces (idown_u)
6905	DO i = nxl, nxr
6906	DO j = nys, nyn
6907	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
6908	k = surf_usm_h%k(m)
6909	isurf = isurf + 1
6910	surfl(:,isurf) = (/iup_u,k,j,i,m/)
6911	IF ( rad_angular_discretization ) THEN
6912	gridsurf(iup_u,k,j,i) = isurf
6913	ENDIF
6914	ENDDO
6915
6916	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
6917	k = surf_lsm_h%k(m)
6918	isurf = isurf + 1
6919	surfl(:,isurf) = (/iup_l,k,j,i,m/)
6920	IF ( rad_angular_discretization ) THEN
6921	gridsurf(iup_u,k,j,i) = isurf
6922	ENDIF
6923	ENDDO
6924
6925	ENDDO
6926	ENDDO
6927
6928	!-- add vertical surface elements (land and urban surfaces)
6929	!-- TODO: remove the hard coding of l = 0 to l = idirection
6930	DO i = nxl, nxr
6931	DO j = nys, nyn
6932	l = 0
6933	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6934	k = surf_usm_v(l)%k(m)
6935	isurf = isurf + 1
6936	surfl(:,isurf) = (/inorth_u,k,j,i,m/)
6937	IF ( rad_angular_discretization ) THEN
6938	gridsurf(inorth_u,k,j,i) = isurf
6939	ENDIF
6940	ENDDO
6941	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6942	k = surf_lsm_v(l)%k(m)
6943	isurf = isurf + 1
6944	surfl(:,isurf) = (/inorth_l,k,j,i,m/)
6945	IF ( rad_angular_discretization ) THEN
6946	gridsurf(inorth_u,k,j,i) = isurf
6947	ENDIF
6948	ENDDO
6949
6950	l = 1
6951	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6952	k = surf_usm_v(l)%k(m)
6953	isurf = isurf + 1
6954	surfl(:,isurf) = (/isouth_u,k,j,i,m/)
6955	IF ( rad_angular_discretization ) THEN
6956	gridsurf(isouth_u,k,j,i) = isurf
6957	ENDIF
6958	ENDDO
6959	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6960	k = surf_lsm_v(l)%k(m)
6961	isurf = isurf + 1
6962	surfl(:,isurf) = (/isouth_l,k,j,i,m/)
6963	IF ( rad_angular_discretization ) THEN
6964	gridsurf(isouth_u,k,j,i) = isurf
6965	ENDIF
6966	ENDDO
6967
6968	l = 2
6969	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6970	k = surf_usm_v(l)%k(m)
6971	isurf = isurf + 1
6972	surfl(:,isurf) = (/ieast_u,k,j,i,m/)
6973	IF ( rad_angular_discretization ) THEN
6974	gridsurf(ieast_u,k,j,i) = isurf
6975	ENDIF
6976	ENDDO
6977	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6978	k = surf_lsm_v(l)%k(m)
6979	isurf = isurf + 1
6980	surfl(:,isurf) = (/ieast_l,k,j,i,m/)
6981	IF ( rad_angular_discretization ) THEN
6982	gridsurf(ieast_u,k,j,i) = isurf
6983	ENDIF
6984	ENDDO
6985
6986	l = 3
6987	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6988	k = surf_usm_v(l)%k(m)
6989	isurf = isurf + 1
6990	surfl(:,isurf) = (/iwest_u,k,j,i,m/)
6991	IF ( rad_angular_discretization ) THEN
6992	gridsurf(iwest_u,k,j,i) = isurf
6993	ENDIF
6994	ENDDO
6995	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6996	k = surf_lsm_v(l)%k(m)
6997	isurf = isurf + 1
6998	surfl(:,isurf) = (/iwest_l,k,j,i,m/)
6999	IF ( rad_angular_discretization ) THEN
7000	gridsurf(iwest_u,k,j,i) = isurf
7001	ENDIF
7002	ENDDO
7003	ENDDO
7004	ENDDO
7005	!
7006	!-- Add local MRT boxes for specified number of levels
7007	nmrtbl = 0
7008	IF ( mrt_nlevels > 0 ) THEN
7009	DO i = nxl, nxr
7010	DO j = nys, nyn
7011	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
7012	!
7013	!-- Skip roof if requested
7014	IF ( mrt_skip_roof .AND. surf_usm_h%isroof_surf(m) ) CYCLE
7015	!
7016	!-- Cycle over specified no of levels
7017	nmrtbl = nmrtbl + mrt_nlevels
7018	ENDDO
7019	!
7020	!-- Dtto for LSM
7021	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
7022	nmrtbl = nmrtbl + mrt_nlevels
7023	ENDDO
7024	ENDDO
7025	ENDDO
7026
7027	ALLOCATE( mrtbl(iz:ix,nmrtbl), mrtsky(nmrtbl), mrtskyt(nmrtbl), &
7028	mrtinsw(nmrtbl), mrtinlw(nmrtbl), mrt(nmrtbl) )
7029
7030	imrt = 0
7031	DO i = nxl, nxr
7032	DO j = nys, nyn
7033	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
7034	!
7035	!-- Skip roof if requested
7036	IF ( mrt_skip_roof .AND. surf_usm_h%isroof_surf(m) ) CYCLE
7037	!
7038	!-- Cycle over specified no of levels
7039	l = surf_usm_h%k(m)
7040	DO k = l, l + mrt_nlevels - 1
7041	imrt = imrt + 1
7042	mrtbl(:,imrt) = (/k,j,i/)
7043	ENDDO
7044	ENDDO
7045	!
7046	!-- Dtto for LSM
7047	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
7048	l = surf_lsm_h%k(m)
7049	DO k = l, l + mrt_nlevels - 1
7050	imrt = imrt + 1
7051	mrtbl(:,imrt) = (/k,j,i/)
7052	ENDDO
7053	ENDDO
7054	ENDDO
7055	ENDDO
7056	ENDIF
7057
7058	!
7059	!-- broadband albedo of the land, roof and wall surface
7060	!-- for domain border and sky set artifically to 1.0
7061	!-- what allows us to calculate heat flux leaving over
7062	!-- side and top borders of the domain
7063	ALLOCATE ( albedo_surf(nsurfl) )
7064	albedo_surf = 1.0_wp
7065	!
7066	!-- Also allocate further array for emissivity with identical order of
7067	!-- surface elements as radiation arrays.
7068	ALLOCATE ( emiss_surf(nsurfl) )
7069
7070
7071	!
7072	!-- global array surf of indices of surfaces and displacement index array surfstart
7073	ALLOCATE(nsurfs(0:numprocs-1))
7074
7075	#if defined( __parallel )
7076	CALL MPI_Allgather(nsurfl,1,MPI_INTEGER,nsurfs,1,MPI_INTEGER,comm2d,ierr)
7077	IF ( ierr /= 0 ) THEN
7078	WRITE(9,*) 'Error MPI_AllGather1:', ierr, nsurfl, nsurfs
7079	FLUSH(9)
7080	ENDIF
7081
7082	#else
7083	nsurfs(0) = nsurfl
7084	#endif
7085	ALLOCATE(surfstart(0:numprocs))
7086	k = 0
7087	DO i=0,numprocs-1
7088	surfstart(i) = k
7089	k = k+nsurfs(i)
7090	ENDDO
7091	surfstart(numprocs) = k
7092	nsurf = k
7093	!
7094	!-- We allocate the array as linear and then use a two-dimensional pointer
7095	!-- into it, because some MPI implementations crash with 2D-allocated arrays.
7096	ALLOCATE(surf_linear(nidx_surf*nsurf))
7097	surf(1:nidx_surf,1:nsurf) => surf_linear(1:nidx_surf*nsurf)
7098
7099	#if defined( __parallel )
7100	CALL MPI_AllGatherv(surfl_linear, nsurfl*nidx_surf, MPI_INTEGER, &
7101	surf_linear, nsurfs*nidx_surf, &
7102	surfstart(0:numprocs-1)*nidx_surf, MPI_INTEGER, &
7103	comm2d, ierr)
7104	IF ( ierr /= 0 ) THEN
7105	WRITE(9,*) 'Error MPI_AllGatherv4:', ierr, SIZE(surfl_linear), &
7106	nsurflnidx_surf, SIZE(surf_linear), nsurfsnidx_surf, &
7107	surfstart(0:numprocs-1)*nidx_surf
7108	FLUSH(9)
7109	ENDIF
7110	#else
7111	surf = surfl
7112	#endif
7113
7114	!--
7115	!-- allocation of the arrays for direct and diffusion radiation
7116	IF ( debug_output ) CALL debug_message( 'allocation of radiation arrays', 'info' )
7117	!-- rad_sw_in, rad_lw_in are computed in radiation model,
7118	!-- splitting of direct and diffusion part is done
7119	!-- in calc_diffusion_radiation for now
7120
7121	ALLOCATE( rad_sw_in_dir(nysg:nyng,nxlg:nxrg) )
7122	ALLOCATE( rad_sw_in_diff(nysg:nyng,nxlg:nxrg) )
7123	ALLOCATE( rad_lw_in_diff(nysg:nyng,nxlg:nxrg) )
7124	rad_sw_in_dir = 0.0_wp
7125	rad_sw_in_diff = 0.0_wp
7126	rad_lw_in_diff = 0.0_wp
7127
7128	!-- allocate radiation arrays
7129	ALLOCATE( surfins(nsurfl) )
7130	ALLOCATE( surfinl(nsurfl) )
7131	ALLOCATE( surfinsw(nsurfl) )
7132	ALLOCATE( surfinlw(nsurfl) )
7133	ALLOCATE( surfinswdir(nsurfl) )
7134	ALLOCATE( surfinswdif(nsurfl) )
7135	ALLOCATE( surfinlwdif(nsurfl) )
7136	ALLOCATE( surfoutsl(nsurfl) )
7137	ALLOCATE( surfoutll(nsurfl) )
7138	ALLOCATE( surfoutsw(nsurfl) )
7139	ALLOCATE( surfoutlw(nsurfl) )
7140	ALLOCATE( surfouts(nsurf) )
7141	ALLOCATE( surfoutl(nsurf) )
7142	ALLOCATE( surfinlg(nsurf) )
7143	ALLOCATE( skyvf(nsurfl) )
7144	ALLOCATE( skyvft(nsurfl) )
7145	ALLOCATE( surfemitlwl(nsurfl) )
7146
7147	!
7148	!-- In case of average_radiation, aggregated surface albedo and emissivity,
7149	!-- also set initial value for t_rad_urb.
7150	!-- For now set an arbitrary initial value.
7151	IF ( average_radiation ) THEN
7152	albedo_urb = 0.1_wp
7153	emissivity_urb = 0.9_wp
7154	t_rad_urb = pt_surface
7155	ENDIF
7156
7157	END SUBROUTINE radiation_interaction_init
7158
7159	!------------------------------------------------------------------------------!
7160	! Description:
7161	! ------------
7162	!> Calculates shape view factors (SVF), plant sink canopy factors (PCSF),
7163	!> sky-view factors, discretized path for direct solar radiation, MRT factors
7164	!> and other preprocessed data needed for radiation_interaction.
7165	!------------------------------------------------------------------------------!
7166	SUBROUTINE radiation_calc_svf
7167
7168	IMPLICIT NONE
7169
7170	INTEGER(iwp) :: i, j, k, d, ip, jp
7171	INTEGER(iwp) :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrt, imrtf, ipcgb
7172	INTEGER(iwp) :: sd, td
7173	INTEGER(iwp) :: iaz, izn !< azimuth, zenith counters
7174	INTEGER(iwp) :: naz, nzn !< azimuth, zenith num of steps
7175	REAL(wp) :: az0, zn0 !< starting azimuth/zenith
7176	REAL(wp) :: azs, zns !< azimuth/zenith cycle step
7177	REAL(wp) :: az1, az2 !< relative azimuth of section borders
7178	REAL(wp) :: azmid !< ray (center) azimuth
7179	REAL(wp) :: yxlen !< \|yxdir\|
7180	REAL(wp), DIMENSION(2) :: yxdir !< y,x unit vector of ray direction (in grid units)
7181	REAL(wp), DIMENSION(:), ALLOCATABLE :: zdirs !< directions in z (tangent of elevation)
7182	REAL(wp), DIMENSION(:), ALLOCATABLE :: zcent !< zenith angle centers
7183	REAL(wp), DIMENSION(:), ALLOCATABLE :: zbdry !< zenith angle boundaries
7184	REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac !< view factor fractions for individual rays
7185	REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac0 !< dtto (original values)
7186	REAL(wp), DIMENSION(:), ALLOCATABLE :: ztransp !< array of transparency in z steps
7187	INTEGER(iwp) :: lowest_free_ray !< index into zdirs
7188	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: itarget !< face indices of detected obstacles
7189	INTEGER(iwp) :: itarg0, itarg1
7190
7191	INTEGER(iwp) :: udim
7192	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: nzterrl_l
7193	INTEGER(iwp), DIMENSION(:,:), POINTER :: nzterrl
7194	REAL(wp), DIMENSION(:), ALLOCATABLE,TARGET:: csflt_l, pcsflt_l
7195	REAL(wp), DIMENSION(:,:), POINTER :: csflt, pcsflt
7196	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: kcsflt_l,kpcsflt_l
7197	INTEGER(iwp), DIMENSION(:,:), POINTER :: kcsflt,kpcsflt
7198	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: icsflt,dcsflt,ipcsflt,dpcsflt
7199	REAL(wp), DIMENSION(3) :: uv
7200	LOGICAL :: visible
7201	REAL(wp), DIMENSION(3) :: sa, ta !< real coordinates z,y,x of source and target
7202	REAL(wp) :: difvf !< differential view factor
7203	REAL(wp) :: transparency, rirrf, sqdist, svfsum
7204	INTEGER(iwp) :: isurflt, isurfs, isurflt_prev
7205	INTEGER(idp) :: ray_skip_maxdist, ray_skip_minval !< skipped raytracing counts
7206	INTEGER(iwp) :: max_track_len !< maximum 2d track length
7207	INTEGER(iwp) :: minfo
7208	REAL(wp), DIMENSION(:), POINTER, SAVE :: lad_s_rma !< fortran 1D pointer
7209	TYPE(c_ptr) :: lad_s_rma_p !< allocated c pointer
7210	#if defined( __parallel )
7211	INTEGER(kind=MPI_ADDRESS_KIND) :: size_lad_rma
7212	#endif
7213	!
7214	INTEGER(iwp), DIMENSION(0:svfnorm_report_num) :: svfnorm_counts
7215
7216
7217	!-- calculation of the SVF
7218	CALL location_message( 'calculating view factors for radiation interaction', 'start' )
7219
7220	!-- initialize variables and temporary arrays for calculation of svf and csf
7221	nsvfl = 0
7222	ncsfl = 0
7223	nsvfla = gasize
7224	msvf = 1
7225	ALLOCATE( asvf1(nsvfla) )
7226	asvf => asvf1
7227	IF ( plant_canopy ) THEN
7228	ncsfla = gasize
7229	mcsf = 1
7230	ALLOCATE( acsf1(ncsfla) )
7231	acsf => acsf1
7232	ENDIF
7233	nmrtf = 0
7234	IF ( mrt_nlevels > 0 ) THEN
7235	nmrtfa = gasize
7236	mmrtf = 1
7237	ALLOCATE ( amrtf1(nmrtfa) )
7238	amrtf => amrtf1
7239	ENDIF
7240	ray_skip_maxdist = 0
7241	ray_skip_minval = 0
7242
7243	!-- initialize temporary terrain and plant canopy height arrays (global 2D array!)
7244	ALLOCATE( nzterr(0:(nx+1)*(ny+1)-1) )
7245	#if defined( __parallel )
7246	!ALLOCATE( nzterrl(nys:nyn,nxl:nxr) )
7247	ALLOCATE( nzterrl_l((nyn-nys+1)*(nxr-nxl+1)) )
7248	nzterrl(nys:nyn,nxl:nxr) => nzterrl_l(1:(nyn-nys+1)*(nxr-nxl+1))
7249	nzterrl = topo_top_ind(nys:nyn,nxl:nxr,0)
7250	CALL MPI_AllGather( nzterrl_l, nnx*nny, MPI_INTEGER, &
7251	nzterr, nnx*nny, MPI_INTEGER, comm2d, ierr )
7252	IF ( ierr /= 0 ) THEN
7253	WRITE(9,) 'Error MPI_AllGather1:', ierr, SIZE(nzterrl_l), nnxnny, &
7254	SIZE(nzterr), nnx*nny
7255	FLUSH(9)
7256	ENDIF
7257	DEALLOCATE(nzterrl_l)
7258	#else
7259	nzterr = RESHAPE( topo_top_ind(nys:nyn,nxl:nxr,0), (/(nx+1)*(ny+1)/) )
7260	#endif
7261	IF ( plant_canopy ) THEN
7262	ALLOCATE( plantt(0:(nx+1)*(ny+1)-1) )
7263	maxboxesg = nx + ny + nz_plant + 1
7264	max_track_len = nx + ny + 1
7265	!-- temporary arrays storing values for csf calculation during raytracing
7266	ALLOCATE( boxes(3, maxboxesg) )
7267	ALLOCATE( crlens(maxboxesg) )
7268
7269	#if defined( __parallel )
7270	CALL MPI_AllGather( pct, nnx*nny, MPI_INTEGER, &
7271	plantt, nnx*nny, MPI_INTEGER, comm2d, ierr )
7272	IF ( ierr /= 0 ) THEN
7273	WRITE(9,) 'Error MPI_AllGather2:', ierr, SIZE(pct), nnxnny, &
7274	SIZE(plantt), nnx*nny
7275	FLUSH(9)
7276	ENDIF
7277
7278	!-- temporary arrays storing values for csf calculation during raytracing
7279	ALLOCATE( lad_ip(maxboxesg) )
7280	ALLOCATE( lad_disp(maxboxesg) )
7281
7282	IF ( raytrace_mpi_rma ) THEN
7283	ALLOCATE( lad_s_ray(maxboxesg) )
7284
7285	! set conditions for RMA communication
7286	CALL MPI_Info_create(minfo, ierr)
7287	IF ( ierr /= 0 ) THEN
7288	WRITE(9,*) 'Error MPI_Info_create2:', ierr
7289	FLUSH(9)
7290	ENDIF
7291	CALL MPI_Info_set(minfo, 'accumulate_ordering', 'none', ierr)
7292	IF ( ierr /= 0 ) THEN
7293	WRITE(9,*) 'Error MPI_Info_set5:', ierr
7294	FLUSH(9)
7295	ENDIF
7296	CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr)
7297	IF ( ierr /= 0 ) THEN
7298	WRITE(9,*) 'Error MPI_Info_set6:', ierr
7299	FLUSH(9)
7300	ENDIF
7301	CALL MPI_Info_set(minfo, 'same_size', 'true', ierr)
7302	IF ( ierr /= 0 ) THEN
7303	WRITE(9,*) 'Error MPI_Info_set7:', ierr
7304	FLUSH(9)
7305	ENDIF
7306	CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr)
7307	IF ( ierr /= 0 ) THEN
7308	WRITE(9,*) 'Error MPI_Info_set8:', ierr
7309	FLUSH(9)
7310	ENDIF
7311
7312	!-- Allocate and initialize the MPI RMA window
7313	!-- must be in accordance with allocation of lad_s in plant_canopy_model
7314	!-- optimization of memory should be done
7315	!-- Argument X of function STORAGE_SIZE(X) needs arbitrary REAL(wp) value, set to 1.0_wp for now
7316	size_lad_rma = STORAGE_SIZE(1.0_wp)/8nnxnny*nz_plant
7317	CALL MPI_Win_allocate(size_lad_rma, STORAGE_SIZE(1.0_wp)/8, minfo, comm2d, &
7318	lad_s_rma_p, win_lad, ierr)
7319	IF ( ierr /= 0 ) THEN
7320	WRITE(9,*) 'Error MPI_Win_allocate2:', ierr, size_lad_rma, &
7321	STORAGE_SIZE(1.0_wp)/8, win_lad
7322	FLUSH(9)
7323	ENDIF
7324	CALL c_f_pointer(lad_s_rma_p, lad_s_rma, (/ nz_plantnnynnx /))
7325	sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr) => lad_s_rma(1:nz_plantnnynnx)
7326	ELSE
7327	ALLOCATE(sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr))
7328	ENDIF
7329	#else
7330	plantt = RESHAPE( pct(nys:nyn,nxl:nxr), (/(nx+1)*(ny+1)/) )
7331	ALLOCATE(sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr))
7332	#endif
7333	plantt_max = MAXVAL(plantt)
7334	ALLOCATE( rt2_track(2, max_track_len), rt2_track_lad(nz_urban_b:plantt_max, max_track_len), &
7335	rt2_track_dist(0:max_track_len), rt2_dist(plantt_max-nz_urban_b+2) )
7336
7337	sub_lad(:,:,:) = 0._wp
7338	DO i = nxl, nxr
7339	DO j = nys, nyn
7340	k = topo_top_ind(j,i,0)
7341
7342	sub_lad(k:nz_plant_t, j, i) = lad_s(0:nz_plant_t-k, j, i)
7343	ENDDO
7344	ENDDO
7345
7346	#if defined( __parallel )
7347	IF ( raytrace_mpi_rma ) THEN
7348	CALL MPI_Info_free(minfo, ierr)
7349	IF ( ierr /= 0 ) THEN
7350	WRITE(9,*) 'Error MPI_Info_free2:', ierr
7351	FLUSH(9)
7352	ENDIF
7353	CALL MPI_Win_lock_all(0, win_lad, ierr)
7354	IF ( ierr /= 0 ) THEN
7355	WRITE(9,*) 'Error MPI_Win_lock_all1:', ierr, win_lad
7356	FLUSH(9)
7357	ENDIF
7358
7359	ELSE
7360	ALLOCATE( sub_lad_g(0:(nx+1)(ny+1)nz_plant-1) )
7361	CALL MPI_AllGather( sub_lad, nnxnnynz_plant, MPI_REAL, &
7362	sub_lad_g, nnxnnynz_plant, MPI_REAL, comm2d, ierr )
7363	IF ( ierr /= 0 ) THEN
7364	WRITE(9,*) 'Error MPI_AllGather3:', ierr, SIZE(sub_lad), &
7365	nnxnnynz_plant, SIZE(sub_lad_g), nnxnnynz_plant
7366	FLUSH(9)
7367	ENDIF
7368	ENDIF
7369	#endif
7370	ENDIF
7371
7372	!-- prepare the MPI_Win for collecting the surface indices
7373	!-- from the reverse index arrays gridsurf from processors of target surfaces
7374	#if defined( __parallel )
7375	IF ( rad_angular_discretization ) THEN
7376	!
7377	!-- raytrace_mpi_rma is asserted
7378	CALL MPI_Win_lock_all(0, win_gridsurf, ierr)
7379	IF ( ierr /= 0 ) THEN
7380	WRITE(9,*) 'Error MPI_Win_lock_all2:', ierr, win_gridsurf
7381	FLUSH(9)
7382	ENDIF
7383	ENDIF
7384	#endif
7385
7386
7387	!--Directions opposite to face normals are not even calculated,
7388	!--they must be preset to 0
7389	!--
7390	dsitrans(:,:) = 0._wp
7391
7392	DO isurflt = 1, nsurfl
7393	!-- determine face centers
7394	td = surfl(id, isurflt)
7395	ta = (/ REAL(surfl(iz, isurflt), wp) - 0.5_wp * kdir(td), &
7396	REAL(surfl(iy, isurflt), wp) - 0.5_wp * jdir(td), &
7397	REAL(surfl(ix, isurflt), wp) - 0.5_wp * idir(td) /)
7398
7399	!--Calculate sky view factor and raytrace DSI paths
7400	skyvf(isurflt) = 0._wp
7401	skyvft(isurflt) = 0._wp
7402
7403	!--Select a proper half-sphere for 2D raytracing
7404	SELECT CASE ( td )
7405	CASE ( iup_u, iup_l )
7406	az0 = 0._wp
7407	naz = raytrace_discrete_azims
7408	azs = 2._wp * pi / REAL(naz, wp)
7409	zn0 = 0._wp
7410	nzn = raytrace_discrete_elevs / 2
7411	zns = pi / 2._wp / REAL(nzn, wp)
7412	CASE ( isouth_u, isouth_l )
7413	az0 = pi / 2._wp
7414	naz = raytrace_discrete_azims / 2
7415	azs = pi / REAL(naz, wp)
7416	zn0 = 0._wp
7417	nzn = raytrace_discrete_elevs
7418	zns = pi / REAL(nzn, wp)
7419	CASE ( inorth_u, inorth_l )
7420	az0 = - pi / 2._wp
7421	naz = raytrace_discrete_azims / 2
7422	azs = pi / REAL(naz, wp)
7423	zn0 = 0._wp
7424	nzn = raytrace_discrete_elevs
7425	zns = pi / REAL(nzn, wp)
7426	CASE ( iwest_u, iwest_l )
7427	az0 = pi
7428	naz = raytrace_discrete_azims / 2
7429	azs = pi / REAL(naz, wp)
7430	zn0 = 0._wp
7431	nzn = raytrace_discrete_elevs
7432	zns = pi / REAL(nzn, wp)
7433	CASE ( ieast_u, ieast_l )
7434	az0 = 0._wp
7435	naz = raytrace_discrete_azims / 2
7436	azs = pi / REAL(naz, wp)
7437	zn0 = 0._wp
7438	nzn = raytrace_discrete_elevs
7439	zns = pi / REAL(nzn, wp)
7440	CASE DEFAULT
7441	WRITE(message_string, *) 'ERROR: the surface type ', td, &
7442	' is not supported for calculating',&
7443	' SVF'
7444	CALL message( 'radiation_calc_svf', 'PA0488', 1, 2, 0, 6, 0 )
7445	END SELECT
7446
7447	ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), &
7448	ztransp(1:nznnaz), itarget(1:nznnaz) ) !FIXME allocate itarget only
7449	!in case of rad_angular_discretization
7450
7451	itarg0 = 1
7452	itarg1 = nzn
7453	zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7454	zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/)
7455	IF ( td == iup_u .OR. td == iup_l ) THEN
7456	vffrac(1:nzn) = (COS(2 * zbdry(0:nzn-1)) - COS(2 * zbdry(1:nzn))) / 2._wp / REAL(naz, wp)
7457	!
7458	!-- For horizontal target, vf fractions are constant per azimuth
7459	DO iaz = 1, naz-1
7460	vffrac(iaznzn+1:(iaz+1)nzn) = vffrac(1:nzn)
7461	ENDDO
7462	!-- sum of whole vffrac equals 1, verified
7463	ENDIF
7464	!
7465	!-- Calculate sky-view factor and direct solar visibility using 2D raytracing
7466	DO iaz = 1, naz
7467	azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7468	IF ( td /= iup_u .AND. td /= iup_l ) THEN
7469	az2 = REAL(iaz, wp) * azs - pi/2._wp
7470	az1 = az2 - azs
7471	!TODO precalculate after 1st line
7472	vffrac(itarg0:itarg1) = (SIN(az2) - SIN(az1)) &
7473	* (zbdry(1:nzn) - zbdry(0:nzn-1) &
7474	+ SIN(zbdry(0:nzn-1))*COS(zbdry(0:nzn-1)) &
7475	- SIN(zbdry(1:nzn))*COS(zbdry(1:nzn))) &
7476	/ (2._wp * pi)
7477	!-- sum of whole vffrac equals 1, verified
7478	ENDIF
7479	yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7480	yxlen = SQRT(SUM(yxdir(:)**2))
7481	zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7482	yxdir(:) = yxdir(:) / yxlen
7483
7484	CALL raytrace_2d(ta, yxdir, nzn, zdirs, &
7485	surfstart(myid) + isurflt, facearea(td), &
7486	vffrac(itarg0:itarg1), .TRUE., .TRUE., &
7487	.FALSE., lowest_free_ray, &
7488	ztransp(itarg0:itarg1), &
7489	itarget(itarg0:itarg1))
7490
7491	skyvf(isurflt) = skyvf(isurflt) + &
7492	SUM(vffrac(itarg0:itarg0+lowest_free_ray-1))
7493	skyvft(isurflt) = skyvft(isurflt) + &
7494	SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) &
7495	* vffrac(itarg0:itarg0+lowest_free_ray-1))
7496
7497	!-- Save direct solar transparency
7498	j = MODULO(NINT(azmid/ &
7499	(2._wppi)raytrace_discrete_azims-.5_wp, iwp), &
7500	raytrace_discrete_azims)
7501
7502	DO k = 1, raytrace_discrete_elevs/2
7503	i = dsidir_rev(k-1, j)
7504	IF ( i /= -1 .AND. k <= lowest_free_ray ) &
7505	dsitrans(isurflt, i) = ztransp(itarg0+k-1)
7506	ENDDO
7507
7508	!
7509	!-- Advance itarget indices
7510	itarg0 = itarg1 + 1
7511	itarg1 = itarg1 + nzn
7512	ENDDO
7513
7514	IF ( rad_angular_discretization ) THEN
7515	!-- sort itarget by face id
7516	CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz)
7517	!
7518	!-- For aggregation, we need fractions multiplied by transmissivities
7519	ztransp(:) = vffrac(:) * ztransp(:)
7520	!
7521	!-- find the first valid position
7522	itarg0 = 1
7523	DO WHILE ( itarg0 <= nzn*naz )
7524	IF ( itarget(itarg0) /= -1 ) EXIT
7525	itarg0 = itarg0 + 1
7526	ENDDO
7527
7528	DO i = itarg0, nzn*naz
7529	!
7530	!-- For duplicate values, only sum up vf fraction value
7531	IF ( i < nzn*naz ) THEN
7532	IF ( itarget(i+1) == itarget(i) ) THEN
7533	vffrac(i+1) = vffrac(i+1) + vffrac(i)
7534	ztransp(i+1) = ztransp(i+1) + ztransp(i)
7535	CYCLE
7536	ENDIF
7537	ENDIF
7538	!
7539	!-- write to the svf array
7540	nsvfl = nsvfl + 1
7541	!-- check dimmension of asvf array and enlarge it if needed
7542	IF ( nsvfla < nsvfl ) THEN
7543	k = CEILING(REAL(nsvfla, kind=wp) * grow_factor)
7544	IF ( msvf == 0 ) THEN
7545	msvf = 1
7546	ALLOCATE( asvf1(k) )
7547	asvf => asvf1
7548	asvf1(1:nsvfla) = asvf2
7549	DEALLOCATE( asvf2 )
7550	ELSE
7551	msvf = 0
7552	ALLOCATE( asvf2(k) )
7553	asvf => asvf2
7554	asvf2(1:nsvfla) = asvf1
7555	DEALLOCATE( asvf1 )
7556	ENDIF
7557
7558	IF ( debug_output ) THEN
7559	WRITE( debug_string, '(A,3I12)' ) 'Grow asvf:', nsvfl, nsvfla, k
7560	CALL debug_message( debug_string, 'info' )
7561	ENDIF
7562
7563	nsvfla = k
7564	ENDIF
7565	!-- write svf values into the array
7566	asvf(nsvfl)%isurflt = isurflt
7567	asvf(nsvfl)%isurfs = itarget(i)
7568	asvf(nsvfl)%rsvf = vffrac(i)
7569	asvf(nsvfl)%rtransp = ztransp(i) / vffrac(i)
7570	END DO
7571
7572	ENDIF ! rad_angular_discretization
7573
7574	DEALLOCATE ( zdirs, zcent, zbdry, vffrac, ztransp, itarget ) !FIXME itarget shall be allocated only
7575	!in case of rad_angular_discretization
7576	!
7577	!-- Following calculations only required for surface_reflections
7578	IF ( surface_reflections .AND. .NOT. rad_angular_discretization ) THEN
7579
7580	DO isurfs = 1, nsurf
7581	IF ( .NOT. surface_facing(surfl(ix, isurflt), surfl(iy, isurflt), &
7582	surfl(iz, isurflt), surfl(id, isurflt), &
7583	surf(ix, isurfs), surf(iy, isurfs), &
7584	surf(iz, isurfs), surf(id, isurfs)) ) THEN
7585	CYCLE
7586	ENDIF
7587
7588	sd = surf(id, isurfs)
7589	sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd), &
7590	REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd), &
7591	REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd) /)
7592
7593	!-- unit vector source -> target
7594	uv = (/ (ta(1)-sa(1))dz(1), (ta(2)-sa(2))dy, (ta(3)-sa(3))*dx /)
7595	sqdist = SUM(uv(:)**2)
7596	uv = uv / SQRT(sqdist)
7597
7598	!-- reject raytracing above max distance
7599	IF ( SQRT(sqdist) > max_raytracing_dist ) THEN
7600	ray_skip_maxdist = ray_skip_maxdist + 1
7601	CYCLE
7602	ENDIF
7603
7604	difvf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) & ! cosine of source normal and direction
7605	* dot_product((/ kdir(td), jdir(td), idir(td) /), -uv) & ! cosine of target normal and reverse direction
7606	/ (pi * sqdist) ! square of distance between centers
7607	!
7608	!-- irradiance factor (our unshaded shape view factor) = view factor per differential target area * source area
7609	rirrf = difvf * facearea(sd)
7610
7611	!-- reject raytracing for potentially too small view factor values
7612	IF ( rirrf < min_irrf_value ) THEN
7613	ray_skip_minval = ray_skip_minval + 1
7614	CYCLE
7615	ENDIF
7616
7617	!-- raytrace + process plant canopy sinks within
7618	CALL raytrace(sa, ta, isurfs, difvf, facearea(td), .TRUE., &
7619	visible, transparency)
7620
7621	IF ( .NOT. visible ) CYCLE
7622	! rsvf = rirrf * transparency
7623
7624	!-- write to the svf array
7625	nsvfl = nsvfl + 1
7626	!-- check dimmension of asvf array and enlarge it if needed
7627	IF ( nsvfla < nsvfl ) THEN
7628	k = CEILING(REAL(nsvfla, kind=wp) * grow_factor)
7629	IF ( msvf == 0 ) THEN
7630	msvf = 1
7631	ALLOCATE( asvf1(k) )
7632	asvf => asvf1
7633	asvf1(1:nsvfla) = asvf2
7634	DEALLOCATE( asvf2 )
7635	ELSE
7636	msvf = 0
7637	ALLOCATE( asvf2(k) )
7638	asvf => asvf2
7639	asvf2(1:nsvfla) = asvf1
7640	DEALLOCATE( asvf1 )
7641	ENDIF
7642
7643	IF ( debug_output ) THEN
7644	WRITE( debug_string, '(A,3I12)' ) 'Grow asvf:', nsvfl, nsvfla, k
7645	CALL debug_message( debug_string, 'info' )
7646	ENDIF
7647
7648	nsvfla = k
7649	ENDIF
7650	!-- write svf values into the array
7651	asvf(nsvfl)%isurflt = isurflt
7652	asvf(nsvfl)%isurfs = isurfs
7653	asvf(nsvfl)%rsvf = rirrf !we postopne multiplication by transparency
7654	asvf(nsvfl)%rtransp = transparency !a.k.a. Direct Irradiance Factor
7655	ENDDO
7656	ENDIF
7657	ENDDO
7658
7659	!--
7660	!-- Raytrace to canopy boxes to fill dsitransc TODO optimize
7661	dsitransc(:,:) = 0._wp
7662	az0 = 0._wp
7663	naz = raytrace_discrete_azims
7664	azs = 2._wp * pi / REAL(naz, wp)
7665	zn0 = 0._wp
7666	nzn = raytrace_discrete_elevs / 2
7667	zns = pi / 2._wp / REAL(nzn, wp)
7668	ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), vffrac(1:nzn), ztransp(1:nzn), &
7669	itarget(1:nzn) )
7670	zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7671	vffrac(:) = 0._wp
7672
7673	DO ipcgb = 1, npcbl
7674	ta = (/ REAL(pcbl(iz, ipcgb), wp), &
7675	REAL(pcbl(iy, ipcgb), wp), &
7676	REAL(pcbl(ix, ipcgb), wp) /)
7677	!-- Calculate direct solar visibility using 2D raytracing
7678	DO iaz = 1, naz
7679	azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7680	yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7681	yxlen = SQRT(SUM(yxdir(:)**2))
7682	zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7683	yxdir(:) = yxdir(:) / yxlen
7684	CALL raytrace_2d(ta, yxdir, nzn, zdirs, &
7685	-999, -999._wp, vffrac, .FALSE., .FALSE., .TRUE., &
7686	lowest_free_ray, ztransp, itarget)
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	DO k = 1, raytrace_discrete_elevs/2
7693	i = dsidir_rev(k-1, j)
7694	IF ( i /= -1 .AND. k <= lowest_free_ray ) &
7695	dsitransc(ipcgb, i) = ztransp(k)
7696	ENDDO
7697	ENDDO
7698	ENDDO
7699	DEALLOCATE ( zdirs, zcent, vffrac, ztransp, itarget )
7700	!--
7701	!-- Raytrace to MRT boxes
7702	IF ( nmrtbl > 0 ) THEN
7703	mrtdsit(:,:) = 0._wp
7704	mrtsky(:) = 0._wp
7705	mrtskyt(:) = 0._wp
7706	az0 = 0._wp
7707	naz = raytrace_discrete_azims
7708	azs = 2._wp * pi / REAL(naz, wp)
7709	zn0 = 0._wp
7710	nzn = raytrace_discrete_elevs
7711	zns = pi / REAL(nzn, wp)
7712	ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), vffrac0(1:nzn), &
7713	ztransp(1:nznnaz), itarget(1:nznnaz) ) !FIXME allocate itarget only
7714	!in case of rad_angular_discretization
7715
7716	zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7717	zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/)
7718	vffrac0(:) = (COS(zbdry(0:nzn-1)) - COS(zbdry(1:nzn))) / 2._wp / REAL(naz, wp)
7719	!
7720	!--Modify direction weights to simulate human body (lower weight for top-down)
7721	IF ( mrt_geom_human ) THEN
7722	vffrac0(:) = vffrac0(:) * MAX(0._wp, SIN(zcent(:))0.88_wp + COS(zcent(:))0.12_wp)
7723	vffrac0(:) = vffrac0(:) / (SUM(vffrac0) * REAL(naz, wp))
7724	ENDIF
7725
7726	DO imrt = 1, nmrtbl
7727	ta = (/ REAL(mrtbl(iz, imrt), wp), &
7728	REAL(mrtbl(iy, imrt), wp), &
7729	REAL(mrtbl(ix, imrt), wp) /)
7730	!
7731	!-- vf fractions are constant per azimuth
7732	DO iaz = 0, naz-1
7733	vffrac(iaznzn+1:(iaz+1)nzn) = vffrac0(:)
7734	ENDDO
7735	!-- sum of whole vffrac equals 1, verified
7736	itarg0 = 1
7737	itarg1 = nzn
7738	!
7739	!-- Calculate sky-view factor and direct solar visibility using 2D raytracing
7740	DO iaz = 1, naz
7741	azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7742	yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7743	yxlen = SQRT(SUM(yxdir(:)**2))
7744	zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7745	yxdir(:) = yxdir(:) / yxlen
7746
7747	CALL raytrace_2d(ta, yxdir, nzn, zdirs, &
7748	-999, -999._wp, vffrac(itarg0:itarg1), .TRUE., &
7749	.FALSE., .TRUE., lowest_free_ray, &
7750	ztransp(itarg0:itarg1), &
7751	itarget(itarg0:itarg1))
7752
7753	!-- Sky view factors for MRT
7754	mrtsky(imrt) = mrtsky(imrt) + &
7755	SUM(vffrac(itarg0:itarg0+lowest_free_ray-1))
7756	mrtskyt(imrt) = mrtskyt(imrt) + &
7757	SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) &
7758	* vffrac(itarg0:itarg0+lowest_free_ray-1))
7759	!-- Direct solar transparency for MRT
7760	j = MODULO(NINT(azmid/ &
7761	(2._wppi)raytrace_discrete_azims-.5_wp, iwp), &
7762	raytrace_discrete_azims)
7763	DO k = 1, raytrace_discrete_elevs/2
7764	i = dsidir_rev(k-1, j)
7765	IF ( i /= -1 .AND. k <= lowest_free_ray ) &
7766	mrtdsit(imrt, i) = ztransp(itarg0+k-1)
7767	ENDDO
7768	!
7769	!-- Advance itarget indices
7770	itarg0 = itarg1 + 1
7771	itarg1 = itarg1 + nzn
7772	ENDDO
7773
7774	!-- sort itarget by face id
7775	CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz)
7776	!
7777	!-- find the first valid position
7778	itarg0 = 1
7779	DO WHILE ( itarg0 <= nzn*naz )
7780	IF ( itarget(itarg0) /= -1 ) EXIT
7781	itarg0 = itarg0 + 1
7782	ENDDO
7783
7784	DO i = itarg0, nzn*naz
7785	!
7786	!-- For duplicate values, only sum up vf fraction value
7787	IF ( i < nzn*naz ) THEN
7788	IF ( itarget(i+1) == itarget(i) ) THEN
7789	vffrac(i+1) = vffrac(i+1) + vffrac(i)
7790	CYCLE
7791	ENDIF
7792	ENDIF
7793	!
7794	!-- write to the mrtf array
7795	nmrtf = nmrtf + 1
7796	!-- check dimmension of mrtf array and enlarge it if needed
7797	IF ( nmrtfa < nmrtf ) THEN
7798	k = CEILING(REAL(nmrtfa, kind=wp) * grow_factor)
7799	IF ( mmrtf == 0 ) THEN
7800	mmrtf = 1
7801	ALLOCATE( amrtf1(k) )
7802	amrtf => amrtf1
7803	amrtf1(1:nmrtfa) = amrtf2
7804	DEALLOCATE( amrtf2 )
7805	ELSE
7806	mmrtf = 0
7807	ALLOCATE( amrtf2(k) )
7808	amrtf => amrtf2
7809	amrtf2(1:nmrtfa) = amrtf1
7810	DEALLOCATE( amrtf1 )
7811	ENDIF
7812
7813	IF ( debug_output ) THEN
7814	WRITE( debug_string, '(A,3I12)' ) 'Grow amrtf:', nmrtf, nmrtfa, k
7815	CALL debug_message( debug_string, 'info' )
7816	ENDIF
7817
7818	nmrtfa = k
7819	ENDIF
7820	!-- write mrtf values into the array
7821	amrtf(nmrtf)%isurflt = imrt
7822	amrtf(nmrtf)%isurfs = itarget(i)
7823	amrtf(nmrtf)%rsvf = vffrac(i)
7824	amrtf(nmrtf)%rtransp = ztransp(i)
7825	ENDDO ! itarg
7826
7827	ENDDO ! imrt
7828	DEALLOCATE ( zdirs, zcent, zbdry, vffrac, vffrac0, ztransp, itarget )
7829	!
7830	!-- Move MRT factors to final arrays
7831	ALLOCATE ( mrtf(nmrtf), mrtft(nmrtf), mrtfsurf(2,nmrtf) )
7832	DO imrtf = 1, nmrtf
7833	mrtf(imrtf) = amrtf(imrtf)%rsvf
7834	mrtft(imrtf) = amrtf(imrtf)%rsvf * amrtf(imrtf)%rtransp
7835	mrtfsurf(:,imrtf) = (/amrtf(imrtf)%isurflt, amrtf(imrtf)%isurfs /)
7836	ENDDO
7837	IF ( ALLOCATED(amrtf1) ) DEALLOCATE( amrtf1 )
7838	IF ( ALLOCATED(amrtf2) ) DEALLOCATE( amrtf2 )
7839	ENDIF ! nmrtbl > 0
7840
7841	IF ( rad_angular_discretization ) THEN
7842	#if defined( __parallel )
7843	!-- finalize MPI_RMA communication established to get global index of the surface from grid indices
7844	!-- flush all MPI window pending requests
7845	CALL MPI_Win_flush_all(win_gridsurf, ierr)
7846	IF ( ierr /= 0 ) THEN
7847	WRITE(9,*) 'Error MPI_Win_flush_all1:', ierr, win_gridsurf
7848	FLUSH(9)
7849	ENDIF
7850	!-- unlock MPI window
7851	CALL MPI_Win_unlock_all(win_gridsurf, ierr)
7852	IF ( ierr /= 0 ) THEN
7853	WRITE(9,*) 'Error MPI_Win_unlock_all1:', ierr, win_gridsurf
7854	FLUSH(9)
7855	ENDIF
7856	!-- free MPI window
7857	CALL MPI_Win_free(win_gridsurf, ierr)
7858	IF ( ierr /= 0 ) THEN
7859	WRITE(9,*) 'Error MPI_Win_free1:', ierr, win_gridsurf
7860	FLUSH(9)
7861	ENDIF
7862	#else
7863	DEALLOCATE ( gridsurf )
7864	#endif
7865	ENDIF
7866
7867	IF ( debug_output ) CALL debug_message( 'waiting for completion of SVF and CSF calculation in all processes', 'info' )
7868
7869	!-- deallocate temporary global arrays
7870	DEALLOCATE(nzterr)
7871
7872	IF ( plant_canopy ) THEN
7873	!-- finalize mpi_rma communication and deallocate temporary arrays
7874	#if defined( __parallel )
7875	IF ( raytrace_mpi_rma ) THEN
7876	CALL MPI_Win_flush_all(win_lad, ierr)
7877	IF ( ierr /= 0 ) THEN
7878	WRITE(9,*) 'Error MPI_Win_flush_all2:', ierr, win_lad
7879	FLUSH(9)
7880	ENDIF
7881	!-- unlock MPI window
7882	CALL MPI_Win_unlock_all(win_lad, ierr)
7883	IF ( ierr /= 0 ) THEN
7884	WRITE(9,*) 'Error MPI_Win_unlock_all2:', ierr, win_lad
7885	FLUSH(9)
7886	ENDIF
7887	!-- free MPI window
7888	CALL MPI_Win_free(win_lad, ierr)
7889	IF ( ierr /= 0 ) THEN
7890	WRITE(9,*) 'Error MPI_Win_free2:', ierr, win_lad
7891	FLUSH(9)
7892	ENDIF
7893	!-- deallocate temporary arrays storing values for csf calculation during raytracing
7894	DEALLOCATE( lad_s_ray )
7895	!-- sub_lad is the pointer to lad_s_rma in case of raytrace_mpi_rma
7896	!-- and must not be deallocated here
7897	ELSE
7898	DEALLOCATE(sub_lad)
7899	DEALLOCATE(sub_lad_g)
7900	ENDIF
7901	#else
7902	DEALLOCATE(sub_lad)
7903	#endif
7904	DEALLOCATE( boxes )
7905	DEALLOCATE( crlens )
7906	DEALLOCATE( plantt )
7907	DEALLOCATE( rt2_track, rt2_track_lad, rt2_track_dist, rt2_dist )
7908	ENDIF
7909
7910	IF ( debug_output ) CALL debug_message( 'calculation of the complete SVF array', 'info' )
7911
7912	IF ( rad_angular_discretization ) THEN
7913	IF ( debug_output ) CALL debug_message( 'Load svf from the structure array to plain arrays', 'info' )
7914	ALLOCATE( svf(ndsvf,nsvfl) )
7915	ALLOCATE( svfsurf(idsvf,nsvfl) )
7916
7917	DO isvf = 1, nsvfl
7918	svf(:, isvf) = (/ asvf(isvf)%rsvf, asvf(isvf)%rtransp /)
7919	svfsurf(:, isvf) = (/ asvf(isvf)%isurflt, asvf(isvf)%isurfs /)
7920	ENDDO
7921	ELSE
7922	IF ( debug_output ) CALL debug_message( 'Start SVF sort', 'info' )
7923	!-- sort svf ( a version of quicksort )
7924	CALL quicksort_svf(asvf,1,nsvfl)
7925
7926	!< load svf from the structure array to plain arrays
7927	IF ( debug_output ) CALL debug_message( 'Load svf from the structure array to plain arrays', 'info' )
7928	ALLOCATE( svf(ndsvf,nsvfl) )
7929	ALLOCATE( svfsurf(idsvf,nsvfl) )
7930	svfnorm_counts(:) = 0._wp
7931	isurflt_prev = -1
7932	ksvf = 1
7933	svfsum = 0._wp
7934	DO isvf = 1, nsvfl
7935	!-- normalize svf per target face
7936	IF ( asvf(ksvf)%isurflt /= isurflt_prev ) THEN
7937	IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN
7938	!< update histogram of logged svf normalization values
7939	i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev)))
7940	svfnorm_counts(i) = svfnorm_counts(i) + 1
7941
7942	svf(1, isvf_surflt:isvf-1) = svf(1, isvf_surflt:isvf-1) / svfsum * (1._wp-skyvf(isurflt_prev))
7943	ENDIF
7944	isurflt_prev = asvf(ksvf)%isurflt
7945	isvf_surflt = isvf
7946	svfsum = asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp
7947	ELSE
7948	svfsum = svfsum + asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp
7949	ENDIF
7950
7951	svf(:, isvf) = (/ asvf(ksvf)%rsvf, asvf(ksvf)%rtransp /)
7952	svfsurf(:, isvf) = (/ asvf(ksvf)%isurflt, asvf(ksvf)%isurfs /)
7953
7954	!-- next element
7955	ksvf = ksvf + 1
7956	ENDDO
7957
7958	IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN
7959	i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev)))
7960	svfnorm_counts(i) = svfnorm_counts(i) + 1
7961
7962	svf(1, isvf_surflt:nsvfl) = svf(1, isvf_surflt:nsvfl) / svfsum * (1._wp-skyvf(isurflt_prev))
7963	ENDIF
7964	WRITE(9, *) 'SVF normalization histogram:', svfnorm_counts, &
7965	'on thresholds:', svfnorm_report_thresh(1:svfnorm_report_num), '(val < thresh <= val)'
7966	!TODO we should be able to deallocate skyvf, from now on we only need skyvft
7967	ENDIF ! rad_angular_discretization
7968
7969	!-- deallocate temporary asvf array
7970	!-- DEALLOCATE(asvf) - ifort has a problem with deallocation of allocatable target
7971	!-- via pointing pointer - we need to test original targets
7972	IF ( ALLOCATED(asvf1) ) THEN
7973	DEALLOCATE(asvf1)
7974	ENDIF
7975	IF ( ALLOCATED(asvf2) ) THEN
7976	DEALLOCATE(asvf2)
7977	ENDIF
7978
7979	npcsfl = 0
7980	IF ( plant_canopy ) THEN
7981
7982	IF ( debug_output ) CALL debug_message( 'Calculation of the complete CSF array', 'info' )
7983	!-- sort and merge csf for the last time, keeping the array size to minimum
7984	CALL merge_and_grow_csf(-1)
7985
7986	!-- aggregate csb among processors
7987	!-- allocate necessary arrays
7988	udim = max(ncsfl,1)
7989	ALLOCATE( csflt_l(ndcsf*udim) )
7990	csflt(1:ndcsf,1:udim) => csflt_l(1:ndcsf*udim)
7991	ALLOCATE( kcsflt_l(kdcsf*udim) )
7992	kcsflt(1:kdcsf,1:udim) => kcsflt_l(1:kdcsf*udim)
7993	ALLOCATE( icsflt(0:numprocs-1) )
7994	ALLOCATE( dcsflt(0:numprocs-1) )
7995	ALLOCATE( ipcsflt(0:numprocs-1) )
7996	ALLOCATE( dpcsflt(0:numprocs-1) )
7997
7998	!-- fill out arrays of csf values and
7999	!-- arrays of number of elements and displacements
8000	!-- for particular precessors
8001	icsflt = 0
8002	dcsflt = 0
8003	ip = -1
8004	j = -1
8005	d = 0
8006	DO kcsf = 1, ncsfl
8007	j = j+1
8008	IF ( acsf(kcsf)%ip /= ip ) THEN
8009	!-- new block of the processor
8010	!-- number of elements of previous block
8011	IF ( ip>=0) icsflt(ip) = j
8012	d = d+j
8013	!-- blank blocks
8014	DO jp = ip+1, acsf(kcsf)%ip-1
8015	!-- number of elements is zero, displacement is equal to previous
8016	icsflt(jp) = 0
8017	dcsflt(jp) = d
8018	ENDDO
8019	!-- the actual block
8020	ip = acsf(kcsf)%ip
8021	dcsflt(ip) = d
8022	j = 0
8023	ENDIF
8024	csflt(1,kcsf) = acsf(kcsf)%rcvf
8025	!-- fill out integer values of itz,ity,itx,isurfs
8026	kcsflt(1,kcsf) = acsf(kcsf)%itz
8027	kcsflt(2,kcsf) = acsf(kcsf)%ity
8028	kcsflt(3,kcsf) = acsf(kcsf)%itx
8029	kcsflt(4,kcsf) = acsf(kcsf)%isurfs
8030	ENDDO
8031	!-- last blank blocks at the end of array
8032	j = j+1
8033	IF ( ip>=0 ) icsflt(ip) = j
8034	d = d+j
8035	DO jp = ip+1, numprocs-1
8036	!-- number of elements is zero, displacement is equal to previous
8037	icsflt(jp) = 0
8038	dcsflt(jp) = d
8039	ENDDO
8040
8041	!-- deallocate temporary acsf array
8042	!-- DEALLOCATE(acsf) - ifort has a problem with deallocation of allocatable target
8043	!-- via pointing pointer - we need to test original targets
8044	IF ( ALLOCATED(acsf1) ) THEN
8045	DEALLOCATE(acsf1)
8046	ENDIF
8047	IF ( ALLOCATED(acsf2) ) THEN
8048	DEALLOCATE(acsf2)
8049	ENDIF
8050
8051	#if defined( __parallel )
8052	!-- scatter and gather the number of elements to and from all processor
8053	!-- and calculate displacements
8054	IF ( debug_output ) CALL debug_message( 'Scatter and gather the number of elements to and from all processor', 'info' )
8055
8056	CALL MPI_AlltoAll(icsflt,1,MPI_INTEGER,ipcsflt,1,MPI_INTEGER,comm2d, ierr)
8057
8058	IF ( ierr /= 0 ) THEN
8059	WRITE(9,*) 'Error MPI_AlltoAll1:', ierr, SIZE(icsflt), SIZE(ipcsflt)
8060	FLUSH(9)
8061	ENDIF
8062
8063	npcsfl = SUM(ipcsflt)
8064	d = 0
8065	DO i = 0, numprocs-1
8066	dpcsflt(i) = d
8067	d = d + ipcsflt(i)
8068	ENDDO
8069
8070	!-- exchange csf fields between processors
8071	IF ( debug_output ) CALL debug_message( 'Exchange csf fields between processors', 'info' )
8072	udim = max(npcsfl,1)
8073	ALLOCATE( pcsflt_l(ndcsf*udim) )
8074	pcsflt(1:ndcsf,1:udim) => pcsflt_l(1:ndcsf*udim)
8075	ALLOCATE( kpcsflt_l(kdcsf*udim) )
8076	kpcsflt(1:kdcsf,1:udim) => kpcsflt_l(1:kdcsf*udim)
8077	CALL MPI_AlltoAllv(csflt_l, ndcsficsflt, ndcsfdcsflt, MPI_REAL, &
8078	pcsflt_l, ndcsfipcsflt, ndcsfdpcsflt, MPI_REAL, comm2d, ierr)
8079	IF ( ierr /= 0 ) THEN
8080	WRITE(9,) 'Error MPI_AlltoAllv1:', ierr, SIZE(ipcsflt), ndcsficsflt, &
8081	ndcsfdcsflt, SIZE(pcsflt_l),ndcsfipcsflt, ndcsf*dpcsflt
8082	FLUSH(9)
8083	ENDIF
8084
8085	CALL MPI_AlltoAllv(kcsflt_l, kdcsficsflt, kdcsfdcsflt, MPI_INTEGER, &
8086	kpcsflt_l, kdcsfipcsflt, kdcsfdpcsflt, MPI_INTEGER, comm2d, ierr)
8087	IF ( ierr /= 0 ) THEN
8088	WRITE(9,) 'Error MPI_AlltoAllv2:', ierr, SIZE(kcsflt_l),kdcsficsflt, &
8089	kdcsfdcsflt, SIZE(kpcsflt_l), kdcsfipcsflt, kdcsf*dpcsflt
8090	FLUSH(9)
8091	ENDIF
8092
8093	#else
8094	npcsfl = ncsfl
8095	ALLOCATE( pcsflt(ndcsf,max(npcsfl,ndcsf)) )
8096	ALLOCATE( kpcsflt(kdcsf,max(npcsfl,kdcsf)) )
8097	pcsflt = csflt
8098	kpcsflt = kcsflt
8099	#endif
8100
8101	!-- deallocate temporary arrays
8102	DEALLOCATE( csflt_l )
8103	DEALLOCATE( kcsflt_l )
8104	DEALLOCATE( icsflt )
8105	DEALLOCATE( dcsflt )
8106	DEALLOCATE( ipcsflt )
8107	DEALLOCATE( dpcsflt )
8108
8109	!-- sort csf ( a version of quicksort )
8110	IF ( debug_output ) CALL debug_message( 'Sort csf', 'info' )
8111	CALL quicksort_csf2(kpcsflt, pcsflt, 1, npcsfl)
8112
8113	!-- aggregate canopy sink factor records with identical box & source
8114	!-- againg across all values from all processors
8115	IF ( debug_output ) CALL debug_message( 'Aggregate canopy sink factor records with identical box', 'info' )
8116
8117	IF ( npcsfl > 0 ) THEN
8118	icsf = 1 !< reading index
8119	kcsf = 1 !< writing index
8120	DO WHILE (icsf < npcsfl)
8121	!-- here kpcsf(kcsf) already has values from kpcsf(icsf)
8122	IF ( kpcsflt(3,icsf) == kpcsflt(3,icsf+1) .AND. &
8123	kpcsflt(2,icsf) == kpcsflt(2,icsf+1) .AND. &
8124	kpcsflt(1,icsf) == kpcsflt(1,icsf+1) .AND. &
8125	kpcsflt(4,icsf) == kpcsflt(4,icsf+1) ) THEN
8126
8127	pcsflt(1,kcsf) = pcsflt(1,kcsf) + pcsflt(1,icsf+1)
8128
8129	!-- advance reading index, keep writing index
8130	icsf = icsf + 1
8131	ELSE
8132	!-- not identical, just advance and copy
8133	icsf = icsf + 1
8134	kcsf = kcsf + 1
8135	kpcsflt(:,kcsf) = kpcsflt(:,icsf)
8136	pcsflt(:,kcsf) = pcsflt(:,icsf)
8137	ENDIF
8138	ENDDO
8139	!-- last written item is now also the last item in valid part of array
8140	npcsfl = kcsf
8141	ENDIF
8142
8143	ncsfl = npcsfl
8144	IF ( ncsfl > 0 ) THEN
8145	ALLOCATE( csf(ndcsf,ncsfl) )
8146	ALLOCATE( csfsurf(idcsf,ncsfl) )
8147	DO icsf = 1, ncsfl
8148	csf(:,icsf) = pcsflt(:,icsf)
8149	csfsurf(1,icsf) = gridpcbl(kpcsflt(1,icsf),kpcsflt(2,icsf),kpcsflt(3,icsf))
8150	csfsurf(2,icsf) = kpcsflt(4,icsf)
8151	ENDDO
8152	ENDIF
8153
8154	!-- deallocation of temporary arrays
8155	IF ( npcbl > 0 ) DEALLOCATE( gridpcbl )
8156	DEALLOCATE( pcsflt_l )
8157	DEALLOCATE( kpcsflt_l )
8158	IF ( debug_output ) CALL debug_message( 'End of aggregate csf', 'info' )
8159
8160	ENDIF
8161
8162	#if defined( __parallel )
8163	CALL MPI_BARRIER( comm2d, ierr )
8164	#endif
8165	CALL location_message( 'calculating view factors for radiation interaction', 'finished' )
8166
8167	RETURN !todo: remove
8168
8169	! WRITE( message_string, * ) &
8170	! 'I/O error when processing shape view factors / ', &
8171	! 'plant canopy sink factors / direct irradiance factors.'
8172	! CALL message( 'init_urban_surface', 'PA0502', 2, 2, 0, 6, 0 )
8173
8174	END SUBROUTINE radiation_calc_svf
8175
8176
8177	!------------------------------------------------------------------------------!
8178	! Description:
8179	! ------------
8180	!> Raytracing for detecting obstacles and calculating compound canopy sink
8181	!> factors. (A simple obstacle detection would only need to process faces in
8182	!> 3 dimensions without any ordering.)
8183	!> Assumtions:
8184	!> -----------
8185	!> 1. The ray always originates from a face midpoint (only one coordinate equals
8186	!> *.5, i.e. wall) and doesn't travel parallel to the surface (that would mean
8187	!> shape factor=0). Therefore, the ray may never travel exactly along a face
8188	!> or an edge.
8189	!> 2. From grid bottom to urban surface top the grid has to be equidistant
8190	!> within each of the dimensions, including vertical (but the resolution
8191	!> doesn't need to be the same in all three dimensions).
8192	!------------------------------------------------------------------------------!
8193	SUBROUTINE raytrace(src, targ, isrc, difvf, atarg, create_csf, visible, transparency)
8194	IMPLICIT NONE
8195
8196	REAL(wp), DIMENSION(3), INTENT(in) :: src, targ !< real coordinates z,y,x
8197	INTEGER(iwp), INTENT(in) :: isrc !< index of source face for csf
8198	REAL(wp), INTENT(in) :: difvf !< differential view factor for csf
8199	REAL(wp), INTENT(in) :: atarg !< target surface area for csf
8200	LOGICAL, INTENT(in) :: create_csf !< whether to generate new CSFs during raytracing
8201	LOGICAL, INTENT(out) :: visible
8202	REAL(wp), INTENT(out) :: transparency !< along whole path
8203	INTEGER(iwp) :: i, k, d
8204	INTEGER(iwp) :: seldim !< dimension to be incremented
8205	INTEGER(iwp) :: ncsb !< no of written plant canopy sinkboxes
8206	INTEGER(iwp) :: maxboxes !< max no of gridboxes visited
8207	REAL(wp) :: distance !< euclidean along path
8208	REAL(wp) :: crlen !< length of gridbox crossing
8209	REAL(wp) :: lastdist !< beginning of current crossing
8210	REAL(wp) :: nextdist !< end of current crossing
8211	REAL(wp) :: realdist !< distance in meters per unit distance
8212	REAL(wp) :: crmid !< midpoint of crossing
8213	REAL(wp) :: cursink !< sink factor for current canopy box
8214	REAL(wp), DIMENSION(3) :: delta !< path vector
8215	REAL(wp), DIMENSION(3) :: uvect !< unit vector
8216	REAL(wp), DIMENSION(3) :: dimnextdist !< distance for each dimension increments
8217	INTEGER(iwp), DIMENSION(3) :: box !< gridbox being crossed
8218	INTEGER(iwp), DIMENSION(3) :: dimnext !< next dimension increments along path
8219	INTEGER(iwp), DIMENSION(3) :: dimdelta !< dimension direction = +- 1
8220	INTEGER(iwp) :: px, py !< number of processors in x and y dir before
8221	!< the processor in the question
8222	INTEGER(iwp) :: ip !< number of processor where gridbox reside
8223	INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array
8224
8225	REAL(wp) :: eps = 1E-10_wp !< epsilon for value comparison
8226	REAL(wp) :: lad_s_target !< recieved lad_s of particular grid box
8227
8228	!
8229	!-- Maximum number of gridboxes visited equals to maximum number of boundaries crossed in each dimension plus one. That's also
8230	!-- the maximum number of plant canopy boxes written. We grow the acsf array accordingly using exponential factor.
8231	maxboxes = SUM(ABS(NINT(targ, iwp) - NINT(src, iwp))) + 1
8232	IF ( plant_canopy .AND. ncsfl + maxboxes > ncsfla ) THEN
8233	!-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1)
8234	!-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) &
8235	!-- / log(grow_factor)), kind=wp))
8236	!-- or use this code to simply always keep some extra space after growing
8237	k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor)
8238
8239	CALL merge_and_grow_csf(k)
8240	ENDIF
8241
8242	transparency = 1._wp
8243	ncsb = 0
8244
8245	delta(:) = targ(:) - src(:)
8246	distance = SQRT(SUM(delta(:)**2))
8247	IF ( distance == 0._wp ) THEN
8248	visible = .TRUE.
8249	RETURN
8250	ENDIF
8251	uvect(:) = delta(:) / distance
8252	realdist = SQRT(SUM( (uvect(:)(/dz(1),dy,dx/))*2 ))
8253
8254	lastdist = 0._wp
8255
8256	!-- Since all face coordinates have values *.5 and we'd like to use
8257	!-- integers, all these have .5 added
8258	DO d = 1, 3
8259	IF ( uvect(d) == 0._wp ) THEN
8260	dimnext(d) = 999999999
8261	dimdelta(d) = 999999999
8262	dimnextdist(d) = 1.0E20_wp
8263	ELSE IF ( uvect(d) > 0._wp ) THEN
8264	dimnext(d) = CEILING(src(d) + .5_wp)
8265	dimdelta(d) = 1
8266	dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d)
8267	ELSE
8268	dimnext(d) = FLOOR(src(d) + .5_wp)
8269	dimdelta(d) = -1
8270	dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d)
8271	ENDIF
8272	ENDDO
8273
8274	DO
8275	!-- along what dimension will the next wall crossing be?
8276	seldim = minloc(dimnextdist, 1)
8277	nextdist = dimnextdist(seldim)
8278	IF ( nextdist > distance ) nextdist = distance
8279
8280	crlen = nextdist - lastdist
8281	IF ( crlen > .001_wp ) THEN
8282	crmid = (lastdist + nextdist) * .5_wp
8283	box = NINT(src(:) + uvect(:) * crmid, iwp)
8284
8285	!-- calculate index of the grid with global indices (box(2),box(3))
8286	!-- in the array nzterr and plantt and id of the coresponding processor
8287	px = box(3)/nnx
8288	py = box(2)/nny
8289	ip = px*pdims(2)+py
8290	ig = ipnnxnny + (box(3)-pxnnx)nny + box(2)-py*nny
8291	IF ( box(1) <= nzterr(ig) ) THEN
8292	visible = .FALSE.
8293	RETURN
8294	ENDIF
8295
8296	IF ( plant_canopy ) THEN
8297	IF ( box(1) <= plantt(ig) ) THEN
8298	ncsb = ncsb + 1
8299	boxes(:,ncsb) = box
8300	crlens(ncsb) = crlen
8301	#if defined( __parallel )
8302	lad_ip(ncsb) = ip
8303	lad_disp(ncsb) = (box(3)-pxnnx)(nnynz_plant) + (box(2)-pynny)*nz_plant + box(1)-nz_urban_b
8304	#endif
8305	ENDIF
8306	ENDIF
8307	ENDIF
8308
8309	IF ( ABS(distance - nextdist) < eps ) EXIT
8310	lastdist = nextdist
8311	dimnext(seldim) = dimnext(seldim) + dimdelta(seldim)
8312	dimnextdist(seldim) = (dimnext(seldim) - .5_wp - src(seldim)) / uvect(seldim)
8313	ENDDO
8314
8315	IF ( plant_canopy ) THEN
8316	#if defined( __parallel )
8317	IF ( raytrace_mpi_rma ) THEN
8318	!-- send requests for lad_s to appropriate processor
8319	CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'start' )
8320	DO i = 1, ncsb
8321	CALL MPI_Get(lad_s_ray(i), 1, MPI_REAL, lad_ip(i), lad_disp(i), &
8322	1, MPI_REAL, win_lad, ierr)
8323	IF ( ierr /= 0 ) THEN
8324	WRITE(9,*) 'Error MPI_Get1:', ierr, lad_s_ray(i), &
8325	lad_ip(i), lad_disp(i), win_lad
8326	FLUSH(9)
8327	ENDIF
8328	ENDDO
8329
8330	!-- wait for all pending local requests complete
8331	CALL MPI_Win_flush_local_all(win_lad, ierr)
8332	IF ( ierr /= 0 ) THEN
8333	WRITE(9,*) 'Error MPI_Win_flush_local_all1:', ierr, win_lad
8334	FLUSH(9)
8335	ENDIF
8336	CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'stop' )
8337
8338	ENDIF
8339	#endif
8340
8341	!-- calculate csf and transparency
8342	DO i = 1, ncsb
8343	#if defined( __parallel )
8344	IF ( raytrace_mpi_rma ) THEN
8345	lad_s_target = lad_s_ray(i)
8346	ELSE
8347	lad_s_target = sub_lad_g(lad_ip(i)nnxnny*nz_plant + lad_disp(i))
8348	ENDIF
8349	#else
8350	lad_s_target = sub_lad(boxes(1,i),boxes(2,i),boxes(3,i))
8351	#endif
8352	cursink = 1._wp - exp(-ext_coef * lad_s_target * crlens(i)*realdist)
8353
8354	IF ( create_csf ) THEN
8355	!-- write svf values into the array
8356	ncsfl = ncsfl + 1
8357	acsf(ncsfl)%ip = lad_ip(i)
8358	acsf(ncsfl)%itx = boxes(3,i)
8359	acsf(ncsfl)%ity = boxes(2,i)
8360	acsf(ncsfl)%itz = boxes(1,i)
8361	acsf(ncsfl)%isurfs = isrc
8362	acsf(ncsfl)%rcvf = cursinktransparencydifvf*atarg
8363	ENDIF !< create_csf
8364
8365	transparency = transparency * (1._wp - cursink)
8366
8367	ENDDO
8368	ENDIF
8369
8370	visible = .TRUE.
8371
8372	END SUBROUTINE raytrace
8373
8374
8375	!------------------------------------------------------------------------------!
8376	! Description:
8377	! ------------
8378	!> A new, more efficient version of ray tracing algorithm that processes a whole
8379	!> arc instead of a single ray.
8380	!>
8381	!> In all comments, horizon means tangent of horizon angle, i.e.
8382	!> vertical_delta / horizontal_distance
8383	!------------------------------------------------------------------------------!
8384	SUBROUTINE raytrace_2d(origin, yxdir, nrays, zdirs, iorig, aorig, vffrac, &
8385	calc_svf, create_csf, skip_1st_pcb, &
8386	lowest_free_ray, transparency, itarget)
8387	IMPLICIT NONE
8388
8389	REAL(wp), DIMENSION(3), INTENT(IN) :: origin !< z,y,x coordinates of ray origin
8390	REAL(wp), DIMENSION(2), INTENT(IN) :: yxdir !< y,x unit vector of ray direction (in grid units)
8391	INTEGER(iwp) :: nrays !< number of rays (z directions) to raytrace
8392	REAL(wp), DIMENSION(nrays), INTENT(IN) :: zdirs !< list of z directions to raytrace (z/hdist, grid, zenith->nadir)
8393	INTEGER(iwp), INTENT(in) :: iorig !< index of origin face for csf
8394	REAL(wp), INTENT(in) :: aorig !< origin face area for csf
8395	REAL(wp), DIMENSION(nrays), INTENT(in) :: vffrac !< view factor fractions of each ray for csf
8396	LOGICAL, INTENT(in) :: calc_svf !< whether to calculate SFV (identify obstacle surfaces)
8397	LOGICAL, INTENT(in) :: create_csf !< whether to create canopy sink factors
8398	LOGICAL, INTENT(in) :: skip_1st_pcb !< whether to skip first plant canopy box during raytracing
8399	INTEGER(iwp), INTENT(out) :: lowest_free_ray !< index into zdirs
8400	REAL(wp), DIMENSION(nrays), INTENT(OUT) :: transparency !< transparencies of zdirs paths
8401	INTEGER(iwp), DIMENSION(nrays), INTENT(OUT) :: itarget !< global indices of target faces for zdirs
8402
8403	INTEGER(iwp), DIMENSION(nrays) :: target_procs
8404	REAL(wp) :: horizon !< highest horizon found after raytracing (z/hdist)
8405	INTEGER(iwp) :: i, k, l, d
8406	INTEGER(iwp) :: seldim !< dimension to be incremented
8407	REAL(wp), DIMENSION(2) :: yxorigin !< horizontal copy of origin (y,x)
8408	REAL(wp) :: distance !< euclidean along path
8409	REAL(wp) :: lastdist !< beginning of current crossing
8410	REAL(wp) :: nextdist !< end of current crossing
8411	REAL(wp) :: crmid !< midpoint of crossing
8412	REAL(wp) :: horz_entry !< horizon at entry to column
8413	REAL(wp) :: horz_exit !< horizon at exit from column
8414	REAL(wp) :: bdydim !< boundary for current dimension
8415	REAL(wp), DIMENSION(2) :: crossdist !< distances to boundary for dimensions
8416	REAL(wp), DIMENSION(2) :: dimnextdist !< distance for each dimension increments
8417	INTEGER(iwp), DIMENSION(2) :: column !< grid column being crossed
8418	INTEGER(iwp), DIMENSION(2) :: dimnext !< next dimension increments along path
8419	INTEGER(iwp), DIMENSION(2) :: dimdelta !< dimension direction = +- 1
8420	INTEGER(iwp) :: px, py !< number of processors in x and y dir before
8421	!< the processor in the question
8422	INTEGER(iwp) :: ip !< number of processor where gridbox reside
8423	INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array
8424	INTEGER(iwp) :: wcount !< RMA window item count
8425	INTEGER(iwp) :: maxboxes !< max no of CSF created
8426	INTEGER(iwp) :: nly !< maximum plant canopy height
8427	INTEGER(iwp) :: ntrack
8428
8429	INTEGER(iwp) :: zb0
8430	INTEGER(iwp) :: zb1
8431	INTEGER(iwp) :: nz
8432	INTEGER(iwp) :: iz
8433	INTEGER(iwp) :: zsgn
8434	INTEGER(iwp) :: lowest_lad !< lowest column cell for which we need LAD
8435	INTEGER(iwp) :: lastdir !< wall direction before hitting this column
8436	INTEGER(iwp), DIMENSION(2) :: lastcolumn
8437
8438	#if defined( __parallel )
8439	INTEGER(MPI_ADDRESS_KIND) :: wdisp !< RMA window displacement
8440	#endif
8441
8442	REAL(wp) :: eps = 1E-10_wp !< epsilon for value comparison
8443	REAL(wp) :: zbottom, ztop !< urban surface boundary in real numbers
8444	REAL(wp) :: zorig !< z coordinate of ray column entry
8445	REAL(wp) :: zexit !< z coordinate of ray column exit
8446	REAL(wp) :: qdist !< ratio of real distance to z coord difference
8447	REAL(wp) :: dxxyy !< square of real horizontal distance
8448	REAL(wp) :: curtrans !< transparency of current PC box crossing
8449
8450
8451
8452	yxorigin(:) = origin(2:3)
8453	transparency(:) = 1._wp !-- Pre-set the all rays to transparent before reducing
8454	horizon = -HUGE(1._wp)
8455	lowest_free_ray = nrays
8456	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8457	ALLOCATE(target_surfl(nrays))
8458	target_surfl(:) = -1
8459	lastdir = -999
8460	lastcolumn(:) = -999
8461	ENDIF
8462
8463	!-- Determine distance to boundary (in 2D xy)
8464	IF ( yxdir(1) > 0._wp ) THEN
8465	bdydim = ny + .5_wp !< north global boundary
8466	crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1)
8467	ELSEIF ( yxdir(1) == 0._wp ) THEN
8468	crossdist(1) = HUGE(1._wp)
8469	ELSE
8470	bdydim = -.5_wp !< south global boundary
8471	crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1)
8472	ENDIF
8473
8474	IF ( yxdir(2) > 0._wp ) THEN
8475	bdydim = nx + .5_wp !< east global boundary
8476	crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2)
8477	ELSEIF ( yxdir(2) == 0._wp ) THEN
8478	crossdist(2) = HUGE(1._wp)
8479	ELSE
8480	bdydim = -.5_wp !< west global boundary
8481	crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2)
8482	ENDIF
8483	distance = minval(crossdist, 1)
8484
8485	IF ( plant_canopy ) THEN
8486	rt2_track_dist(0) = 0._wp
8487	rt2_track_lad(:,:) = 0._wp
8488	nly = plantt_max - nz_urban_b + 1
8489	ENDIF
8490
8491	lastdist = 0._wp
8492
8493	!-- Since all face coordinates have values *.5 and we'd like to use
8494	!-- integers, all these have .5 added
8495	DO d = 1, 2
8496	IF ( yxdir(d) == 0._wp ) THEN
8497	dimnext(d) = HUGE(1_iwp)
8498	dimdelta(d) = HUGE(1_iwp)
8499	dimnextdist(d) = HUGE(1._wp)
8500	ELSE IF ( yxdir(d) > 0._wp ) THEN
8501	dimnext(d) = FLOOR(yxorigin(d) + .5_wp) + 1
8502	dimdelta(d) = 1
8503	dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d)
8504	ELSE
8505	dimnext(d) = CEILING(yxorigin(d) + .5_wp) - 1
8506	dimdelta(d) = -1
8507	dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d)
8508	ENDIF
8509	ENDDO
8510
8511	ntrack = 0
8512	DO
8513	!-- along what dimension will the next wall crossing be?
8514	seldim = minloc(dimnextdist, 1)
8515	nextdist = dimnextdist(seldim)
8516	IF ( nextdist > distance ) nextdist = distance
8517
8518	IF ( nextdist > lastdist ) THEN
8519	ntrack = ntrack + 1
8520	crmid = (lastdist + nextdist) * .5_wp
8521	column = NINT(yxorigin(:) + yxdir(:) * crmid, iwp)
8522
8523	!-- calculate index of the grid with global indices (column(1),column(2))
8524	!-- in the array nzterr and plantt and id of the coresponding processor
8525	px = column(2)/nnx
8526	py = column(1)/nny
8527	ip = px*pdims(2)+py
8528	ig = ipnnxnny + (column(2)-pxnnx)nny + column(1)-py*nny
8529
8530	IF ( lastdist == 0._wp ) THEN
8531	horz_entry = -HUGE(1._wp)
8532	ELSE
8533	horz_entry = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / lastdist
8534	ENDIF
8535	horz_exit = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / nextdist
8536
8537	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8538	!
8539	!-- Identify vertical obstacles hit by rays in current column
8540	DO WHILE ( lowest_free_ray > 0 )
8541	IF ( zdirs(lowest_free_ray) > horz_entry ) EXIT
8542	!
8543	!-- This may only happen after 1st column, so lastdir and lastcolumn are valid
8544	CALL request_itarget(lastdir, &
8545	CEILING(-0.5_wp + origin(1) + zdirs(lowest_free_ray)*lastdist), &
8546	lastcolumn(1), lastcolumn(2), &
8547	target_surfl(lowest_free_ray), target_procs(lowest_free_ray))
8548	lowest_free_ray = lowest_free_ray - 1
8549	ENDDO
8550	!
8551	!-- Identify horizontal obstacles hit by rays in current column
8552	DO WHILE ( lowest_free_ray > 0 )
8553	IF ( zdirs(lowest_free_ray) > horz_exit ) EXIT
8554	CALL request_itarget(iup_u, nzterr(ig)+1, column(1), column(2), &
8555	target_surfl(lowest_free_ray), &
8556	target_procs(lowest_free_ray))
8557	lowest_free_ray = lowest_free_ray - 1
8558	ENDDO
8559	ENDIF
8560
8561	horizon = MAX(horizon, horz_entry, horz_exit)
8562
8563	IF ( plant_canopy ) THEN
8564	rt2_track(:, ntrack) = column(:)
8565	rt2_track_dist(ntrack) = nextdist
8566	ENDIF
8567	ENDIF
8568
8569	IF ( nextdist + eps >= distance ) EXIT
8570
8571	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8572	!
8573	!-- Save wall direction of coming building column (= this air column)
8574	IF ( seldim == 1 ) THEN
8575	IF ( dimdelta(seldim) == 1 ) THEN
8576	lastdir = isouth_u
8577	ELSE
8578	lastdir = inorth_u
8579	ENDIF
8580	ELSE
8581	IF ( dimdelta(seldim) == 1 ) THEN
8582	lastdir = iwest_u
8583	ELSE
8584	lastdir = ieast_u
8585	ENDIF
8586	ENDIF
8587	lastcolumn = column
8588	ENDIF
8589	lastdist = nextdist
8590	dimnext(seldim) = dimnext(seldim) + dimdelta(seldim)
8591	dimnextdist(seldim) = (dimnext(seldim) - .5_wp - yxorigin(seldim)) / yxdir(seldim)
8592	ENDDO
8593
8594	IF ( plant_canopy ) THEN
8595	!-- Request LAD WHERE applicable
8596	!--
8597	#if defined( __parallel )
8598	IF ( raytrace_mpi_rma ) THEN
8599	!-- send requests for lad_s to appropriate processor
8600	!CALL cpu_log( log_point_s(77), 'usm_init_rma', 'start' )
8601	DO i = 1, ntrack
8602	px = rt2_track(2,i)/nnx
8603	py = rt2_track(1,i)/nny
8604	ip = px*pdims(2)+py
8605	ig = ipnnxnny + (rt2_track(2,i)-pxnnx)nny + rt2_track(1,i)-py*nny
8606
8607	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8608	!
8609	!-- For fixed view resolution, we need plant canopy even for rays
8610	!-- to opposing surfaces
8611	lowest_lad = nzterr(ig) + 1
8612	ELSE
8613	!
8614	!-- We only need LAD for rays directed above horizon (to sky)
8615	lowest_lad = CEILING( -0.5_wp + origin(1) + &
8616	MIN( horizon * rt2_track_dist(i-1), & ! entry
8617	horizon * rt2_track_dist(i) ) ) ! exit
8618	ENDIF
8619	!
8620	!-- Skip asking for LAD where all plant canopy is under requested level
8621	IF ( plantt(ig) < lowest_lad ) CYCLE
8622
8623	wdisp = (rt2_track(2,i)-pxnnx)(nnynz_plant) + (rt2_track(1,i)-pynny)*nz_plant + lowest_lad-nz_urban_b
8624	wcount = plantt(ig)-lowest_lad+1
8625	! TODO send request ASAP - even during raytracing
8626	CALL MPI_Get(rt2_track_lad(lowest_lad:plantt(ig), i), wcount, MPI_REAL, ip, &
8627	wdisp, wcount, MPI_REAL, win_lad, ierr)
8628	IF ( ierr /= 0 ) THEN
8629	WRITE(9,*) 'Error MPI_Get2:', ierr, rt2_track_lad(lowest_lad:plantt(ig), i), &
8630	wcount, ip, wdisp, win_lad
8631	FLUSH(9)
8632	ENDIF
8633	ENDDO
8634
8635	!-- wait for all pending local requests complete
8636	! TODO WAIT selectively for each column later when needed
8637	CALL MPI_Win_flush_local_all(win_lad, ierr)
8638	IF ( ierr /= 0 ) THEN
8639	WRITE(9,*) 'Error MPI_Win_flush_local_all2:', ierr, win_lad
8640	FLUSH(9)
8641	ENDIF
8642	!CALL cpu_log( log_point_s(77), 'usm_init_rma', 'stop' )
8643
8644	ELSE ! raytrace_mpi_rma = .F.
8645	DO i = 1, ntrack
8646	px = rt2_track(2,i)/nnx
8647	py = rt2_track(1,i)/nny
8648	ip = px*pdims(2)+py
8649	ig = ipnnxnnynz_plant + (rt2_track(2,i)-pxnnx)(nnynz_plant) + (rt2_track(1,i)-pynny)nz_plant
8650	rt2_track_lad(nz_urban_b:plantt_max, i) = sub_lad_g(ig:ig+nly-1)
8651	ENDDO
8652	ENDIF
8653	#else
8654	DO i = 1, ntrack
8655	rt2_track_lad(nz_urban_b:plantt_max, i) = sub_lad(rt2_track(1,i), rt2_track(2,i), nz_urban_b:plantt_max)
8656	ENDDO
8657	#endif
8658	ENDIF ! plant_canopy
8659
8660	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8661	#if defined( __parallel )
8662	!-- wait for all gridsurf requests to complete
8663	CALL MPI_Win_flush_local_all(win_gridsurf, ierr)
8664	IF ( ierr /= 0 ) THEN
8665	WRITE(9,*) 'Error MPI_Win_flush_local_all3:', ierr, win_gridsurf
8666	FLUSH(9)
8667	ENDIF
8668	#endif
8669	!
8670	!-- recalculate local surf indices into global ones
8671	DO i = 1, nrays
8672	IF ( target_surfl(i) == -1 ) THEN
8673	itarget(i) = -1
8674	ELSE
8675	itarget(i) = target_surfl(i) + surfstart(target_procs(i))
8676	ENDIF
8677	ENDDO
8678
8679	DEALLOCATE( target_surfl )
8680
8681	ELSE
8682	itarget(:) = -1
8683	ENDIF ! rad_angular_discretization
8684
8685	IF ( plant_canopy ) THEN
8686	!-- Skip the PCB around origin if requested (for MRT, the PCB might not be there)
8687	!--
8688	IF ( skip_1st_pcb .AND. NINT(origin(1)) <= plantt_max ) THEN
8689	rt2_track_lad(NINT(origin(1), iwp), 1) = 0._wp
8690	ENDIF
8691
8692	!-- Assert that we have space allocated for CSFs
8693	!--
8694	maxboxes = (ntrack + MAX(CEILING(origin(1)-.5_wp) - nz_urban_b, &
8695	nz_urban_t - CEILING(origin(1)-.5_wp))) * nrays
8696	IF ( ncsfl + maxboxes > ncsfla ) THEN
8697	!-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1)
8698	!-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) &
8699	!-- / log(grow_factor)), kind=wp))
8700	!-- or use this code to simply always keep some extra space after growing
8701	k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor)
8702	CALL merge_and_grow_csf(k)
8703	ENDIF
8704
8705	!-- Calculate transparencies and store new CSFs
8706	!--
8707	zbottom = REAL(nz_urban_b, wp) - .5_wp
8708	ztop = REAL(plantt_max, wp) + .5_wp
8709
8710	!-- Reverse direction of radiation (face->sky), only when calc_svf
8711	!--
8712	IF ( calc_svf ) THEN
8713	DO i = 1, ntrack ! for each column
8714	dxxyy = ((dyyxdir(1))2 + (dxyxdir(2))*2) (rt2_track_dist(i)-rt2_track_dist(i-1))**2
8715	px = rt2_track(2,i)/nnx
8716	py = rt2_track(1,i)/nny
8717	ip = px*pdims(2)+py
8718
8719	DO k = 1, nrays ! for each ray
8720	!
8721	!-- NOTE 6778:
8722	!-- With traditional svf discretization, CSFs under the horizon
8723	!-- (i.e. for surface to surface radiation) are created in
8724	!-- raytrace(). With rad_angular_discretization, we must create
8725	!-- CSFs under horizon only for one direction, otherwise we would
8726	!-- have duplicate amount of energy. Although we could choose
8727	!-- either of the two directions (they differ only by
8728	!-- discretization error with no bias), we choose the the backward
8729	!-- direction, because it tends to cumulate high canopy sink
8730	!-- factors closer to raytrace origin, i.e. it should potentially
8731	!-- cause less moiree.
8732	IF ( .NOT. rad_angular_discretization ) THEN
8733	IF ( zdirs(k) <= horizon ) CYCLE
8734	ENDIF
8735
8736	zorig = origin(1) + zdirs(k) * rt2_track_dist(i-1)
8737	IF ( zorig <= zbottom .OR. zorig >= ztop ) CYCLE
8738
8739	zsgn = INT(SIGN(1._wp, zdirs(k)), iwp)
8740	rt2_dist(1) = 0._wp
8741	IF ( zdirs(k) == 0._wp ) THEN ! ray is exactly horizontal
8742	nz = 2
8743	rt2_dist(nz) = SQRT(dxxyy)
8744	iz = CEILING(-.5_wp + zorig, iwp)
8745	ELSE
8746	zexit = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop)
8747
8748	zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! because it must be greater than orig
8749	zb1 = CEILING(zexit * zsgn - .5_wp) - 1 ! because it must be smaller than exit
8750	nz = MAX(zb1 - zb0 + 3, 2)
8751	rt2_dist(nz) = SQRT(((zexit-zorig)dz(1))*2 + dxxyy)
8752	qdist = rt2_dist(nz) / (zexit-zorig)
8753	rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/)
8754	iz = zb0 * zsgn
8755	ENDIF
8756
8757	DO l = 2, nz
8758	IF ( rt2_track_lad(iz, i) > 0._wp ) THEN
8759	curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1)))
8760
8761	IF ( create_csf ) THEN
8762	ncsfl = ncsfl + 1
8763	acsf(ncsfl)%ip = ip
8764	acsf(ncsfl)%itx = rt2_track(2,i)
8765	acsf(ncsfl)%ity = rt2_track(1,i)
8766	acsf(ncsfl)%itz = iz
8767	acsf(ncsfl)%isurfs = iorig
8768	acsf(ncsfl)%rcvf = (1._wp - curtrans)transparency(k)vffrac(k)
8769	ENDIF
8770
8771	transparency(k) = transparency(k) * curtrans
8772	ENDIF
8773	iz = iz + zsgn
8774	ENDDO ! l = 1, nz - 1
8775	ENDDO ! k = 1, nrays
8776	ENDDO ! i = 1, ntrack
8777
8778	transparency(1:lowest_free_ray) = 1._wp !-- Reset rays above horizon to transparent (see NOTE 6778)
8779	ENDIF
8780
8781	!-- Forward direction of radiation (sky->face), always
8782	!--
8783	DO i = ntrack, 1, -1 ! for each column backwards
8784	dxxyy = ((dyyxdir(1))2 + (dxyxdir(2))*2) (rt2_track_dist(i)-rt2_track_dist(i-1))**2
8785	px = rt2_track(2,i)/nnx
8786	py = rt2_track(1,i)/nny
8787	ip = px*pdims(2)+py
8788
8789	DO k = 1, nrays ! for each ray
8790	!
8791	!-- See NOTE 6778 above
8792	IF ( zdirs(k) <= horizon ) CYCLE
8793
8794	zexit = origin(1) + zdirs(k) * rt2_track_dist(i-1)
8795	IF ( zexit <= zbottom .OR. zexit >= ztop ) CYCLE
8796
8797	zsgn = -INT(SIGN(1._wp, zdirs(k)), iwp)
8798	rt2_dist(1) = 0._wp
8799	IF ( zdirs(k) == 0._wp ) THEN ! ray is exactly horizontal
8800	nz = 2
8801	rt2_dist(nz) = SQRT(dxxyy)
8802	iz = NINT(zexit, iwp)
8803	ELSE
8804	zorig = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop)
8805
8806	zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! because it must be greater than orig
8807	zb1 = CEILING(zexit * zsgn - .5_wp) - 1 ! because it must be smaller than exit
8808	nz = MAX(zb1 - zb0 + 3, 2)
8809	rt2_dist(nz) = SQRT(((zexit-zorig)dz(1))*2 + dxxyy)
8810	qdist = rt2_dist(nz) / (zexit-zorig)
8811	rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/)
8812	iz = zb0 * zsgn
8813	ENDIF
8814
8815	DO l = 2, nz
8816	IF ( rt2_track_lad(iz, i) > 0._wp ) THEN
8817	curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1)))
8818
8819	IF ( create_csf ) THEN
8820	ncsfl = ncsfl + 1
8821	acsf(ncsfl)%ip = ip
8822	acsf(ncsfl)%itx = rt2_track(2,i)
8823	acsf(ncsfl)%ity = rt2_track(1,i)
8824	acsf(ncsfl)%itz = iz
8825	IF ( itarget(k) /= -1 ) STOP 1 !FIXME remove after test
8826	acsf(ncsfl)%isurfs = -1
8827	acsf(ncsfl)%rcvf = (1._wp - curtrans)transparency(k)aorig*vffrac(k)
8828	ENDIF ! create_csf
8829
8830	transparency(k) = transparency(k) * curtrans
8831	ENDIF
8832	iz = iz + zsgn
8833	ENDDO ! l = 1, nz - 1
8834	ENDDO ! k = 1, nrays
8835	ENDDO ! i = 1, ntrack
8836	ENDIF ! plant_canopy
8837
8838	IF ( .NOT. (rad_angular_discretization .AND. calc_svf) ) THEN
8839	!
8840	!-- Just update lowest_free_ray according to horizon
8841	DO WHILE ( lowest_free_ray > 0 )
8842	IF ( zdirs(lowest_free_ray) > horizon ) EXIT
8843	lowest_free_ray = lowest_free_ray - 1
8844	ENDDO
8845	ENDIF
8846
8847	CONTAINS
8848
8849	SUBROUTINE request_itarget( d, z, y, x, isurfl, iproc )
8850
8851	INTEGER(iwp), INTENT(in) :: d, z, y, x
8852	INTEGER(iwp), TARGET, INTENT(out) :: isurfl
8853	INTEGER(iwp), INTENT(out) :: iproc
8854	#if defined( __parallel )
8855	#else
8856	INTEGER(iwp) :: target_displ !< index of the grid in the local gridsurf array
8857	#endif
8858	INTEGER(iwp) :: px, py !< number of processors in x and y direction
8859	!< before the processor in the question
8860	#if defined( __parallel )
8861	INTEGER(KIND=MPI_ADDRESS_KIND) :: target_displ !< index of the grid in the local gridsurf array
8862
8863	!
8864	!-- Calculate target processor and index in the remote local target gridsurf array
8865	px = x / nnx
8866	py = y / nny
8867	iproc = px * pdims(2) + py
8868	target_displ = ((x-pxnnx) nny + y - pynny ) nz_urban * nsurf_type_u +&
8869	( z-nz_urban_b ) * nsurf_type_u + d
8870	!
8871	!-- Send MPI_Get request to obtain index target_surfl(i)
8872	CALL MPI_GET( isurfl, 1, MPI_INTEGER, iproc, target_displ, &
8873	1, MPI_INTEGER, win_gridsurf, ierr)
8874	IF ( ierr /= 0 ) THEN
8875	WRITE( 9,* ) 'Error MPI_Get3:', ierr, isurfl, iproc, target_displ, &
8876	win_gridsurf
8877	FLUSH( 9 )
8878	ENDIF
8879	#else
8880	!-- set index target_surfl(i)
8881	isurfl = gridsurf(d,z,y,x)
8882	#endif
8883
8884	END SUBROUTINE request_itarget
8885
8886	END SUBROUTINE raytrace_2d
8887
8888
8889	!------------------------------------------------------------------------------!
8890	!
8891	! Description:
8892	! ------------
8893	!> Calculates apparent solar positions for all timesteps and stores discretized
8894	!> positions.
8895	!------------------------------------------------------------------------------!
8896	SUBROUTINE radiation_presimulate_solar_pos
8897
8898	IMPLICIT NONE
8899
8900	INTEGER(iwp) :: it, i, j !< loop indices
8901
8902	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir_tmp !< dsidir_tmp[:,i] = unit vector of i-th
8903	!< appreant solar direction
8904
8905	ALLOCATE ( dsidir_rev(0:raytrace_discrete_elevs/2-1, &
8906	0:raytrace_discrete_azims-1) )
8907	dsidir_rev(:,:) = -1
8908	ALLOCATE ( dsidir_tmp(3, &
8909	raytrace_discrete_elevs/2*raytrace_discrete_azims) )
8910	ndsidir = 0
8911	sun_direction = .TRUE.
8912
8913	!
8914	!-- Process spinup time if configured
8915	IF ( spinup_time > 0._wp ) THEN
8916	DO it = 0, CEILING(spinup_time / dt_spinup)
8917	CALL simulate_pos( it * dt_spinup - spinup_time )
8918	ENDDO
8919	ENDIF
8920	!
8921	!-- Process simulation time
8922	DO it = 0, CEILING(( end_time - spinup_time ) / dt_radiation)
8923	CALL simulate_pos( it * dt_radiation )
8924	ENDDO
8925	!
8926	!-- Allocate global vars which depend on ndsidir
8927	ALLOCATE ( dsidir ( 3, ndsidir ) )
8928	dsidir(:,:) = dsidir_tmp(:, 1:ndsidir)
8929	DEALLOCATE ( dsidir_tmp )
8930
8931	ALLOCATE ( dsitrans(nsurfl, ndsidir) )
8932	ALLOCATE ( dsitransc(npcbl, ndsidir) )
8933	IF ( nmrtbl > 0 ) ALLOCATE ( mrtdsit(nmrtbl, ndsidir) )
8934
8935	WRITE ( message_string, * ) 'Precalculated', ndsidir, ' solar positions', &
8936	' from', it, ' timesteps.'
8937	CALL message( 'radiation_presimulate_solar_pos', 'UI0013', 0, 0, 0, 6, 0 )
8938
8939	CONTAINS
8940
8941	!------------------------------------------------------------------------!
8942	! Description:
8943	! ------------
8944	!> Simuates a single position
8945	!------------------------------------------------------------------------!
8946	SUBROUTINE simulate_pos( time_since_reference_local )
8947
8948	REAL(wp), INTENT(IN) :: time_since_reference_local !< local time since reference
8949	!
8950	!-- Update apparent solar position based on modified t_s_r_p
8951	CALL get_date_time( time_since_reference_local, &
8952	day_of_year=day_of_year, &
8953	second_of_day=second_of_day )
8954	CALL calc_zenith( day_of_year, second_of_day )
8955	IF ( cos_zenith > 0 ) THEN
8956	!--
8957	!-- Identify solar direction vector (discretized number) 1)
8958	i = MODULO(NINT(ATAN2(sun_dir_lon, sun_dir_lat) &
8959	/ (2._wppi) raytrace_discrete_azims-.5_wp, iwp), &
8960	raytrace_discrete_azims)
8961	j = FLOOR(ACOS(cos_zenith) / pi * raytrace_discrete_elevs)
8962	IF ( dsidir_rev(j, i) == -1 ) THEN
8963	ndsidir = ndsidir + 1
8964	dsidir_tmp(:, ndsidir) = &
8965	(/ COS((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs), &
8966	SIN((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs) &
8967	* COS((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims), &
8968	SIN((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs) &
8969	* SIN((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims) /)
8970	dsidir_rev(j, i) = ndsidir
8971	ENDIF
8972	ENDIF
8973	END SUBROUTINE simulate_pos
8974
8975	END SUBROUTINE radiation_presimulate_solar_pos
8976
8977
8978
8979	!------------------------------------------------------------------------------!
8980	! Description:
8981	! ------------
8982	!> Determines whether two faces are oriented towards each other. Since the
8983	!> surfaces follow the gird box surfaces, it checks first whether the two surfaces
8984	!> are directed in the same direction, then it checks if the two surfaces are
8985	!> located in confronted direction but facing away from each other, e.g. <--\| \|-->
8986	!------------------------------------------------------------------------------!
8987	PURE LOGICAL FUNCTION surface_facing(x, y, z, d, x2, y2, z2, d2)
8988	IMPLICIT NONE
8989	INTEGER(iwp), INTENT(in) :: x, y, z, d, x2, y2, z2, d2
8990
8991	surface_facing = .FALSE.
8992
8993	!-- first check: are the two surfaces directed in the same direction
8994	IF ( (d==iup_u .OR. d==iup_l ) &
8995	.AND. (d2==iup_u .OR. d2==iup_l) ) RETURN
8996	IF ( (d==isouth_u .OR. d==isouth_l ) &
8997	.AND. (d2==isouth_u .OR. d2==isouth_l) ) RETURN
8998	IF ( (d==inorth_u .OR. d==inorth_l ) &
8999	.AND. (d2==inorth_u .OR. d2==inorth_l) ) RETURN
9000	IF ( (d==iwest_u .OR. d==iwest_l ) &
9001	.AND. (d2==iwest_u .OR. d2==iwest_l ) ) RETURN
9002	IF ( (d==ieast_u .OR. d==ieast_l ) &
9003	.AND. (d2==ieast_u .OR. d2==ieast_l ) ) RETURN
9004
9005	!-- second check: are surfaces facing away from each other
9006	SELECT CASE (d)
9007	CASE (iup_u, iup_l) !< upward facing surfaces
9008	IF ( z2 < z ) RETURN
9009	CASE (isouth_u, isouth_l) !< southward facing surfaces
9010	IF ( y2 > y ) RETURN
9011	CASE (inorth_u, inorth_l) !< northward facing surfaces
9012	IF ( y2 < y ) RETURN
9013	CASE (iwest_u, iwest_l) !< westward facing surfaces
9014	IF ( x2 > x ) RETURN
9015	CASE (ieast_u, ieast_l) !< eastward facing surfaces
9016	IF ( x2 < x ) RETURN
9017	END SELECT
9018
9019	SELECT CASE (d2)
9020	CASE (iup_u) !< ground, roof
9021	IF ( z < z2 ) RETURN
9022	CASE (isouth_u, isouth_l) !< south facing
9023	IF ( y > y2 ) RETURN
9024	CASE (inorth_u, inorth_l) !< north facing
9025	IF ( y < y2 ) RETURN
9026	CASE (iwest_u, iwest_l) !< west facing
9027	IF ( x > x2 ) RETURN
9028	CASE (ieast_u, ieast_l) !< east facing
9029	IF ( x < x2 ) RETURN
9030	CASE (-1)
9031	CONTINUE
9032	END SELECT
9033
9034	surface_facing = .TRUE.
9035
9036	END FUNCTION surface_facing
9037
9038
9039	!------------------------------------------------------------------------------!
9040	!
9041	! Description:
9042	! ------------
9043	!> Reads svf, svfsurf, csf, csfsurf and mrt factors data from saved file
9044	!> SVF means sky view factors and CSF means canopy sink factors
9045	!------------------------------------------------------------------------------!
9046	SUBROUTINE radiation_read_svf
9047
9048	IMPLICIT NONE
9049
9050	CHARACTER(rad_version_len) :: rad_version_field
9051
9052	INTEGER(iwp) :: i
9053	INTEGER(iwp) :: ndsidir_from_file = 0
9054	INTEGER(iwp) :: npcbl_from_file = 0
9055	INTEGER(iwp) :: nsurfl_from_file = 0
9056	INTEGER(iwp) :: nmrtbl_from_file = 0
9057
9058
9059	CALL location_message( 'reading view factors for radiation interaction', 'start' )
9060
9061	DO i = 0, io_blocks-1
9062	IF ( i == io_group ) THEN
9063
9064	!
9065	!-- numprocs_previous_run is only known in case of reading restart
9066	!-- data. If a new initial run which reads svf data is started the
9067	!-- following query will be skipped
9068	IF ( initializing_actions == 'read_restart_data' ) THEN
9069
9070	IF ( numprocs_previous_run /= numprocs ) THEN
9071	WRITE( message_string, * ) 'A different number of ', &
9072	'processors between the run ', &
9073	'that has written the svf data ',&
9074	'and the one that will read it ',&
9075	'is not allowed'
9076	CALL message( 'check_open', 'PA0491', 1, 2, 0, 6, 0 )
9077	ENDIF
9078
9079	ENDIF
9080
9081	!
9082	!-- Open binary file
9083	CALL check_open( 88 )
9084
9085	!
9086	!-- read and check version
9087	READ ( 88 ) rad_version_field
9088	IF ( TRIM(rad_version_field) /= TRIM(rad_version) ) THEN
9089	WRITE( message_string, * ) 'Version of binary SVF file "', &
9090	TRIM(rad_version_field), '" does not match ', &
9091	'the version of model "', TRIM(rad_version), '"'
9092	CALL message( 'radiation_read_svf', 'PA0482', 1, 2, 0, 6, 0 )
9093	ENDIF
9094
9095	!
9096	!-- read nsvfl, ncsfl, nsurfl, nmrtf
9097	READ ( 88 ) nsvfl, ncsfl, nsurfl_from_file, npcbl_from_file, &
9098	ndsidir_from_file, nmrtbl_from_file, nmrtf
9099
9100	IF ( nsvfl < 0 .OR. ncsfl < 0 ) THEN
9101	WRITE( message_string, * ) 'Wrong number of SVF or CSF'
9102	CALL message( 'radiation_read_svf', 'PA0483', 1, 2, 0, 6, 0 )
9103	ELSE
9104	WRITE(debug_string,*) 'Number of SVF, CSF, and nsurfl ', &
9105	'to read', nsvfl, ncsfl, &
9106	nsurfl_from_file
9107	IF ( debug_output ) CALL debug_message( debug_string, 'info' )
9108	ENDIF
9109
9110	IF ( nsurfl_from_file /= nsurfl ) THEN
9111	WRITE( message_string, * ) 'nsurfl from SVF file does not ', &
9112	'match calculated nsurfl from ', &
9113	'radiation_interaction_init'
9114	CALL message( 'radiation_read_svf', 'PA0490', 1, 2, 0, 6, 0 )
9115	ENDIF
9116
9117	IF ( npcbl_from_file /= npcbl ) THEN
9118	WRITE( message_string, * ) 'npcbl from SVF file does not ', &
9119	'match calculated npcbl from ', &
9120	'radiation_interaction_init'
9121	CALL message( 'radiation_read_svf', 'PA0493', 1, 2, 0, 6, 0 )
9122	ENDIF
9123
9124	IF ( ndsidir_from_file /= ndsidir ) THEN
9125	WRITE( message_string, * ) 'ndsidir from SVF file does not ', &
9126	'match calculated ndsidir from ', &
9127	'radiation_presimulate_solar_pos'
9128	CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 )
9129	ENDIF
9130	IF ( nmrtbl_from_file /= nmrtbl ) THEN
9131	WRITE( message_string, * ) 'nmrtbl from SVF file does not ', &
9132	'match calculated nmrtbl from ', &
9133	'radiation_interaction_init'
9134	CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 )
9135	ELSE
9136	WRITE(debug_string,*) 'Number of nmrtf to read ', nmrtf
9137	IF ( debug_output ) CALL debug_message( debug_string, 'info' )
9138	ENDIF
9139
9140	!
9141	!-- Arrays skyvf, skyvft, dsitrans and dsitransc are allready
9142	!-- allocated in radiation_interaction_init and
9143	!-- radiation_presimulate_solar_pos
9144	IF ( nsurfl > 0 ) THEN
9145	READ(88) skyvf
9146	READ(88) skyvft
9147	READ(88) dsitrans
9148	ENDIF
9149
9150	IF ( plant_canopy .AND. npcbl > 0 ) THEN
9151	READ ( 88 ) dsitransc
9152	ENDIF
9153
9154	!
9155	!-- The allocation of svf, svfsurf, csf, csfsurf, mrtf, mrtft, and
9156	!-- mrtfsurf happens in routine radiation_calc_svf which is not
9157	!-- called if the program enters radiation_read_svf. Therefore
9158	!-- these arrays has to allocate in the following
9159	IF ( nsvfl > 0 ) THEN
9160	ALLOCATE( svf(ndsvf,nsvfl) )
9161	ALLOCATE( svfsurf(idsvf,nsvfl) )
9162	READ(88) svf
9163	READ(88) svfsurf
9164	ENDIF
9165
9166	IF ( plant_canopy .AND. ncsfl > 0 ) THEN
9167	ALLOCATE( csf(ndcsf,ncsfl) )
9168	ALLOCATE( csfsurf(idcsf,ncsfl) )
9169	READ(88) csf
9170	READ(88) csfsurf
9171	ENDIF
9172
9173	IF ( nmrtbl > 0 ) THEN
9174	READ(88) mrtsky
9175	READ(88) mrtskyt
9176	READ(88) mrtdsit
9177	ENDIF
9178
9179	IF ( nmrtf > 0 ) THEN
9180	ALLOCATE ( mrtf(nmrtf) )
9181	ALLOCATE ( mrtft(nmrtf) )
9182	ALLOCATE ( mrtfsurf(2,nmrtf) )
9183	READ(88) mrtf
9184	READ(88) mrtft
9185	READ(88) mrtfsurf
9186	ENDIF
9187
9188	!
9189	!-- Close binary file
9190	CALL close_file( 88 )
9191
9192	ENDIF
9193	#if defined( __parallel )
9194	CALL MPI_BARRIER( comm2d, ierr )
9195	#endif
9196	ENDDO
9197
9198	CALL location_message( 'reading view factors for radiation interaction', 'finished' )
9199
9200
9201	END SUBROUTINE radiation_read_svf
9202
9203
9204	!------------------------------------------------------------------------------!
9205	!
9206	! Description:
9207	! ------------
9208	!> Subroutine stores svf, svfsurf, csf, csfsurf and mrt data to a file.
9209	!------------------------------------------------------------------------------!
9210	SUBROUTINE radiation_write_svf
9211
9212	IMPLICIT NONE
9213
9214	INTEGER(iwp) :: i
9215
9216
9217	CALL location_message( 'writing view factors for radiation interaction', 'start' )
9218
9219	DO i = 0, io_blocks-1
9220	IF ( i == io_group ) THEN
9221	!
9222	!-- Open binary file
9223	CALL check_open( 89 )
9224
9225	WRITE ( 89 ) rad_version
9226	WRITE ( 89 ) nsvfl, ncsfl, nsurfl, npcbl, ndsidir, nmrtbl, nmrtf
9227	IF ( nsurfl > 0 ) THEN
9228	WRITE ( 89 ) skyvf
9229	WRITE ( 89 ) skyvft
9230	WRITE ( 89 ) dsitrans
9231	ENDIF
9232	IF ( npcbl > 0 ) THEN
9233	WRITE ( 89 ) dsitransc
9234	ENDIF
9235	IF ( nsvfl > 0 ) THEN
9236	WRITE ( 89 ) svf
9237	WRITE ( 89 ) svfsurf
9238	ENDIF
9239	IF ( plant_canopy .AND. ncsfl > 0 ) THEN
9240	WRITE ( 89 ) csf
9241	WRITE ( 89 ) csfsurf
9242	ENDIF
9243	IF ( nmrtbl > 0 ) THEN
9244	WRITE ( 89 ) mrtsky
9245	WRITE ( 89 ) mrtskyt
9246	WRITE ( 89 ) mrtdsit
9247	ENDIF
9248	IF ( nmrtf > 0 ) THEN
9249	WRITE ( 89 ) mrtf
9250	WRITE ( 89 ) mrtft
9251	WRITE ( 89 ) mrtfsurf
9252	ENDIF
9253	!
9254	!-- Close binary file
9255	CALL close_file( 89 )
9256
9257	ENDIF
9258	#if defined( __parallel )
9259	CALL MPI_BARRIER( comm2d, ierr )
9260	#endif
9261	ENDDO
9262
9263	CALL location_message( 'writing view factors for radiation interaction', 'finished' )
9264
9265
9266	END SUBROUTINE radiation_write_svf
9267
9268
9269	!------------------------------------------------------------------------------!
9270	!
9271	! Description:
9272	! ------------
9273	!> Block of auxiliary subroutines:
9274	!> 1. quicksort and corresponding comparison
9275	!> 2. merge_and_grow_csf for implementation of "dynamical growing"
9276	!> array for csf
9277	!------------------------------------------------------------------------------!
9278	!-- quicksort.f --f90--
9279	!-- Author: t-nissie, adaptation J.Resler
9280	!-- License: GPLv3
9281	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9282	RECURSIVE SUBROUTINE quicksort_itarget(itarget, vffrac, ztransp, first, last)
9283	IMPLICIT NONE
9284	INTEGER(iwp), DIMENSION(:), INTENT(INOUT) :: itarget
9285	REAL(wp), DIMENSION(:), INTENT(INOUT) :: vffrac, ztransp
9286	INTEGER(iwp), INTENT(IN) :: first, last
9287	INTEGER(iwp) :: x, t
9288	INTEGER(iwp) :: i, j
9289	REAL(wp) :: tr
9290
9291	IF ( first>=last ) RETURN
9292	x = itarget((first+last)/2)
9293	i = first
9294	j = last
9295	DO
9296	DO WHILE ( itarget(i) < x )
9297	i=i+1
9298	ENDDO
9299	DO WHILE ( x < itarget(j) )
9300	j=j-1
9301	ENDDO
9302	IF ( i >= j ) EXIT
9303	t = itarget(i); itarget(i) = itarget(j); itarget(j) = t
9304	tr = vffrac(i); vffrac(i) = vffrac(j); vffrac(j) = tr
9305	tr = ztransp(i); ztransp(i) = ztransp(j); ztransp(j) = tr
9306	i=i+1
9307	j=j-1
9308	ENDDO
9309	IF ( first < i-1 ) CALL quicksort_itarget(itarget, vffrac, ztransp, first, i-1)
9310	IF ( j+1 < last ) CALL quicksort_itarget(itarget, vffrac, ztransp, j+1, last)
9311	END SUBROUTINE quicksort_itarget
9312
9313	PURE FUNCTION svf_lt(svf1,svf2) result (res)
9314	TYPE (t_svf), INTENT(in) :: svf1,svf2
9315	LOGICAL :: res
9316	IF ( svf1%isurflt < svf2%isurflt .OR. &
9317	(svf1%isurflt == svf2%isurflt .AND. svf1%isurfs < svf2%isurfs) ) THEN
9318	res = .TRUE.
9319	ELSE
9320	res = .FALSE.
9321	ENDIF
9322	END FUNCTION svf_lt
9323
9324
9325	!-- quicksort.f --f90--
9326	!-- Author: t-nissie, adaptation J.Resler
9327	!-- License: GPLv3
9328	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9329	RECURSIVE SUBROUTINE quicksort_svf(svfl, first, last)
9330	IMPLICIT NONE
9331	TYPE(t_svf), DIMENSION(:), INTENT(INOUT) :: svfl
9332	INTEGER(iwp), INTENT(IN) :: first, last
9333	TYPE(t_svf) :: x, t
9334	INTEGER(iwp) :: i, j
9335
9336	IF ( first>=last ) RETURN
9337	x = svfl( (first+last) / 2 )
9338	i = first
9339	j = last
9340	DO
9341	DO while ( svf_lt(svfl(i),x) )
9342	i=i+1
9343	ENDDO
9344	DO while ( svf_lt(x,svfl(j)) )
9345	j=j-1
9346	ENDDO
9347	IF ( i >= j ) EXIT
9348	t = svfl(i); svfl(i) = svfl(j); svfl(j) = t
9349	i=i+1
9350	j=j-1
9351	ENDDO
9352	IF ( first < i-1 ) CALL quicksort_svf(svfl, first, i-1)
9353	IF ( j+1 < last ) CALL quicksort_svf(svfl, j+1, last)
9354	END SUBROUTINE quicksort_svf
9355
9356	PURE FUNCTION csf_lt(csf1,csf2) result (res)
9357	TYPE (t_csf), INTENT(in) :: csf1,csf2
9358	LOGICAL :: res
9359	IF ( csf1%ip < csf2%ip .OR. &
9360	(csf1%ip == csf2%ip .AND. csf1%itx < csf2%itx) .OR. &
9361	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity < csf2%ity) .OR. &
9362	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. &
9363	csf1%itz < csf2%itz) .OR. &
9364	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. &
9365	csf1%itz == csf2%itz .AND. csf1%isurfs < csf2%isurfs) ) THEN
9366	res = .TRUE.
9367	ELSE
9368	res = .FALSE.
9369	ENDIF
9370	END FUNCTION csf_lt
9371
9372
9373	!-- quicksort.f --f90--
9374	!-- Author: t-nissie, adaptation J.Resler
9375	!-- License: GPLv3
9376	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9377	RECURSIVE SUBROUTINE quicksort_csf(csfl, first, last)
9378	IMPLICIT NONE
9379	TYPE(t_csf), DIMENSION(:), INTENT(INOUT) :: csfl
9380	INTEGER(iwp), INTENT(IN) :: first, last
9381	TYPE(t_csf) :: x, t
9382	INTEGER(iwp) :: i, j
9383
9384	IF ( first>=last ) RETURN
9385	x = csfl( (first+last)/2 )
9386	i = first
9387	j = last
9388	DO
9389	DO while ( csf_lt(csfl(i),x) )
9390	i=i+1
9391	ENDDO
9392	DO while ( csf_lt(x,csfl(j)) )
9393	j=j-1
9394	ENDDO
9395	IF ( i >= j ) EXIT
9396	t = csfl(i); csfl(i) = csfl(j); csfl(j) = t
9397	i=i+1
9398	j=j-1
9399	ENDDO
9400	IF ( first < i-1 ) CALL quicksort_csf(csfl, first, i-1)
9401	IF ( j+1 < last ) CALL quicksort_csf(csfl, j+1, last)
9402	END SUBROUTINE quicksort_csf
9403
9404
9405	!------------------------------------------------------------------------------!
9406	!
9407	! Description:
9408	! ------------
9409	!> Grows the CSF array exponentially after it is full. During that, the ray
9410	!> canopy sink factors with common source face and target plant canopy grid
9411	!> cell are merged together so that the size doesn't grow out of control.
9412	!------------------------------------------------------------------------------!
9413	SUBROUTINE merge_and_grow_csf(newsize)
9414	INTEGER(iwp), INTENT(in) :: newsize !< new array size after grow, must be >= ncsfl
9415	!< or -1 to shrink to minimum
9416	INTEGER(iwp) :: iread, iwrite
9417	TYPE(t_csf), DIMENSION(:), POINTER :: acsfnew
9418
9419
9420	IF ( newsize == -1 ) THEN
9421	!-- merge in-place
9422	acsfnew => acsf
9423	ELSE
9424	!-- allocate new array
9425	IF ( mcsf == 0 ) THEN
9426	ALLOCATE( acsf1(newsize) )
9427	acsfnew => acsf1
9428	ELSE
9429	ALLOCATE( acsf2(newsize) )
9430	acsfnew => acsf2
9431	ENDIF
9432	ENDIF
9433
9434	IF ( ncsfl >= 1 ) THEN
9435	!-- sort csf in place (quicksort)
9436	CALL quicksort_csf(acsf,1,ncsfl)
9437
9438	!-- while moving to a new array, aggregate canopy sink factor records with identical box & source
9439	acsfnew(1) = acsf(1)
9440	iwrite = 1
9441	DO iread = 2, ncsfl
9442	!-- here acsf(kcsf) already has values from acsf(icsf)
9443	IF ( acsfnew(iwrite)%itx == acsf(iread)%itx &
9444	.AND. acsfnew(iwrite)%ity == acsf(iread)%ity &
9445	.AND. acsfnew(iwrite)%itz == acsf(iread)%itz &
9446	.AND. acsfnew(iwrite)%isurfs == acsf(iread)%isurfs ) THEN
9447
9448	acsfnew(iwrite)%rcvf = acsfnew(iwrite)%rcvf + acsf(iread)%rcvf
9449	!-- advance reading index, keep writing index
9450	ELSE
9451	!-- not identical, just advance and copy
9452	iwrite = iwrite + 1
9453	acsfnew(iwrite) = acsf(iread)
9454	ENDIF
9455	ENDDO
9456	ncsfl = iwrite
9457	ENDIF
9458
9459	IF ( newsize == -1 ) THEN
9460	!-- allocate new array and copy shrinked data
9461	IF ( mcsf == 0 ) THEN
9462	ALLOCATE( acsf1(ncsfl) )
9463	acsf1(1:ncsfl) = acsf2(1:ncsfl)
9464	ELSE
9465	ALLOCATE( acsf2(ncsfl) )
9466	acsf2(1:ncsfl) = acsf1(1:ncsfl)
9467	ENDIF
9468	ENDIF
9469
9470	!-- deallocate old array
9471	IF ( mcsf == 0 ) THEN
9472	mcsf = 1
9473	acsf => acsf1
9474	DEALLOCATE( acsf2 )
9475	ELSE
9476	mcsf = 0
9477	acsf => acsf2
9478	DEALLOCATE( acsf1 )
9479	ENDIF
9480	ncsfla = newsize
9481
9482	IF ( debug_output ) THEN
9483	WRITE( debug_string, '(A,2I12)' ) 'Grow acsf2:', ncsfl, ncsfla
9484	CALL debug_message( debug_string, 'info' )
9485	ENDIF
9486
9487	END SUBROUTINE merge_and_grow_csf
9488
9489
9490	!-- quicksort.f --f90--
9491	!-- Author: t-nissie, adaptation J.Resler
9492	!-- License: GPLv3
9493	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9494	RECURSIVE SUBROUTINE quicksort_csf2(kpcsflt, pcsflt, first, last)
9495	IMPLICIT NONE
9496	INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT) :: kpcsflt
9497	REAL(wp), DIMENSION(:,:), INTENT(INOUT) :: pcsflt
9498	INTEGER(iwp), INTENT(IN) :: first, last
9499	REAL(wp), DIMENSION(ndcsf) :: t2
9500	INTEGER(iwp), DIMENSION(kdcsf) :: x, t1
9501	INTEGER(iwp) :: i, j
9502
9503	IF ( first>=last ) RETURN
9504	x = kpcsflt(:, (first+last)/2 )
9505	i = first
9506	j = last
9507	DO
9508	DO while ( csf_lt2(kpcsflt(:,i),x) )
9509	i=i+1
9510	ENDDO
9511	DO while ( csf_lt2(x,kpcsflt(:,j)) )
9512	j=j-1
9513	ENDDO
9514	IF ( i >= j ) EXIT
9515	t1 = kpcsflt(:,i); kpcsflt(:,i) = kpcsflt(:,j); kpcsflt(:,j) = t1
9516	t2 = pcsflt(:,i); pcsflt(:,i) = pcsflt(:,j); pcsflt(:,j) = t2
9517	i=i+1
9518	j=j-1
9519	ENDDO
9520	IF ( first < i-1 ) CALL quicksort_csf2(kpcsflt, pcsflt, first, i-1)
9521	IF ( j+1 < last ) CALL quicksort_csf2(kpcsflt, pcsflt, j+1, last)
9522	END SUBROUTINE quicksort_csf2
9523
9524
9525	PURE FUNCTION csf_lt2(item1, item2) result(res)
9526	INTEGER(iwp), DIMENSION(kdcsf), INTENT(in) :: item1, item2
9527	LOGICAL :: res
9528	res = ( (item1(3) < item2(3)) &
9529	.OR. (item1(3) == item2(3) .AND. item1(2) < item2(2)) &
9530	.OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) < item2(1)) &
9531	.OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) == item2(1) &
9532	.AND. item1(4) < item2(4)) )
9533	END FUNCTION csf_lt2
9534
9535	PURE FUNCTION searchsorted(athresh, val) result(ind)
9536	REAL(wp), DIMENSION(:), INTENT(IN) :: athresh
9537	REAL(wp), INTENT(IN) :: val
9538	INTEGER(iwp) :: ind
9539	INTEGER(iwp) :: i
9540
9541	DO i = LBOUND(athresh, 1), UBOUND(athresh, 1)
9542	IF ( val < athresh(i) ) THEN
9543	ind = i - 1
9544	RETURN
9545	ENDIF
9546	ENDDO
9547	ind = UBOUND(athresh, 1)
9548	END FUNCTION searchsorted
9549
9550
9551	!------------------------------------------------------------------------------!
9552	!
9553	! Description:
9554	! ------------
9555	!> Subroutine for averaging 3D data
9556	!------------------------------------------------------------------------------!
9557	SUBROUTINE radiation_3d_data_averaging( mode, variable )
9558
9559
9560	USE control_parameters
9561
9562	USE indices
9563
9564	USE kinds
9565
9566	IMPLICIT NONE
9567
9568	CHARACTER (LEN=*) :: mode !<
9569	CHARACTER (LEN=*) :: variable !<
9570
9571	LOGICAL :: match_lsm !< flag indicating natural-type surface
9572	LOGICAL :: match_usm !< flag indicating urban-type surface
9573
9574	INTEGER(iwp) :: i !<
9575	INTEGER(iwp) :: j !<
9576	INTEGER(iwp) :: k !<
9577	INTEGER(iwp) :: l, m !< index of current surface element
9578
9579	INTEGER(iwp) :: ids, idsint_u, idsint_l, isurf
9580	CHARACTER(LEN=varnamelength) :: var
9581
9582	!-- find the real name of the variable
9583	ids = -1
9584	l = -1
9585	var = TRIM(variable)
9586	DO i = 0, nd-1
9587	k = len(TRIM(var))
9588	j = len(TRIM(dirname(i)))
9589	IF ( k-j+1 >= 1_iwp ) THEN
9590	IF ( TRIM(var(k-j+1:k)) == TRIM(dirname(i)) ) THEN
9591	ids = i
9592	idsint_u = dirint_u(ids)
9593	idsint_l = dirint_l(ids)
9594	var = var(:k-j)
9595	EXIT
9596	ENDIF
9597	ENDIF
9598	ENDDO
9599	IF ( ids == -1 ) THEN
9600	var = TRIM(variable)
9601	ENDIF
9602
9603	IF ( mode == 'allocate' ) THEN
9604
9605	SELECT CASE ( TRIM( var ) )
9606	!-- block of large scale (e.g. RRTMG) radiation output variables
9607	CASE ( 'rad_net*' )
9608	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
9609	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
9610	ENDIF
9611	rad_net_av = 0.0_wp
9612
9613	CASE ( 'rad_lw_in*' )
9614	IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
9615	ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
9616	ENDIF
9617	rad_lw_in_xy_av = 0.0_wp
9618
9619	CASE ( 'rad_lw_out*' )
9620	IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
9621	ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
9622	ENDIF
9623	rad_lw_out_xy_av = 0.0_wp
9624
9625	CASE ( 'rad_sw_in*' )
9626	IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
9627	ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
9628	ENDIF
9629	rad_sw_in_xy_av = 0.0_wp
9630
9631	CASE ( 'rad_sw_out*' )
9632	IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
9633	ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
9634	ENDIF
9635	rad_sw_out_xy_av = 0.0_wp
9636
9637	CASE ( 'rad_lw_in' )
9638	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
9639	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9640	ENDIF
9641	rad_lw_in_av = 0.0_wp
9642
9643	CASE ( 'rad_lw_out' )
9644	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
9645	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9646	ENDIF
9647	rad_lw_out_av = 0.0_wp
9648
9649	CASE ( 'rad_lw_cs_hr' )
9650	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
9651	ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9652	ENDIF
9653	rad_lw_cs_hr_av = 0.0_wp
9654
9655	CASE ( 'rad_lw_hr' )
9656	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
9657	ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9658	ENDIF
9659	rad_lw_hr_av = 0.0_wp
9660
9661	CASE ( 'rad_sw_in' )
9662	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
9663	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9664	ENDIF
9665	rad_sw_in_av = 0.0_wp
9666
9667	CASE ( 'rad_sw_out' )
9668	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
9669	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9670	ENDIF
9671	rad_sw_out_av = 0.0_wp
9672
9673	CASE ( 'rad_sw_cs_hr' )
9674	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
9675	ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9676	ENDIF
9677	rad_sw_cs_hr_av = 0.0_wp
9678
9679	CASE ( 'rad_sw_hr' )
9680	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
9681	ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9682	ENDIF
9683	rad_sw_hr_av = 0.0_wp
9684
9685	!-- block of RTM output variables
9686	CASE ( 'rtm_rad_net' )
9687	!-- array of complete radiation balance
9688	IF ( .NOT. ALLOCATED(surfradnet_av) ) THEN
9689	ALLOCATE( surfradnet_av(nsurfl) )
9690	surfradnet_av = 0.0_wp
9691	ENDIF
9692
9693	CASE ( 'rtm_rad_insw' )
9694	!-- array of sw radiation falling to surface after i-th reflection
9695	IF ( .NOT. ALLOCATED(surfinsw_av) ) THEN
9696	ALLOCATE( surfinsw_av(nsurfl) )
9697	surfinsw_av = 0.0_wp
9698	ENDIF
9699
9700	CASE ( 'rtm_rad_inlw' )
9701	!-- array of lw radiation falling to surface after i-th reflection
9702	IF ( .NOT. ALLOCATED(surfinlw_av) ) THEN
9703	ALLOCATE( surfinlw_av(nsurfl) )
9704	surfinlw_av = 0.0_wp
9705	ENDIF
9706
9707	CASE ( 'rtm_rad_inswdir' )
9708	!-- array of direct sw radiation falling to surface from sun
9709	IF ( .NOT. ALLOCATED(surfinswdir_av) ) THEN
9710	ALLOCATE( surfinswdir_av(nsurfl) )
9711	surfinswdir_av = 0.0_wp
9712	ENDIF
9713
9714	CASE ( 'rtm_rad_inswdif' )
9715	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
9716	IF ( .NOT. ALLOCATED(surfinswdif_av) ) THEN
9717	ALLOCATE( surfinswdif_av(nsurfl) )
9718	surfinswdif_av = 0.0_wp
9719	ENDIF
9720
9721	CASE ( 'rtm_rad_inswref' )
9722	!-- array of sw radiation falling to surface from reflections
9723	IF ( .NOT. ALLOCATED(surfinswref_av) ) THEN
9724	ALLOCATE( surfinswref_av(nsurfl) )
9725	surfinswref_av = 0.0_wp
9726	ENDIF
9727
9728	CASE ( 'rtm_rad_inlwdif' )
9729	!-- array of sw radiation falling to surface after i-th reflection
9730	IF ( .NOT. ALLOCATED(surfinlwdif_av) ) THEN
9731	ALLOCATE( surfinlwdif_av(nsurfl) )
9732	surfinlwdif_av = 0.0_wp
9733	ENDIF
9734
9735	CASE ( 'rtm_rad_inlwref' )
9736	!-- array of lw radiation falling to surface from reflections
9737	IF ( .NOT. ALLOCATED(surfinlwref_av) ) THEN
9738	ALLOCATE( surfinlwref_av(nsurfl) )
9739	surfinlwref_av = 0.0_wp
9740	ENDIF
9741
9742	CASE ( 'rtm_rad_outsw' )
9743	!-- array of sw radiation emitted from surface after i-th reflection
9744	IF ( .NOT. ALLOCATED(surfoutsw_av) ) THEN
9745	ALLOCATE( surfoutsw_av(nsurfl) )
9746	surfoutsw_av = 0.0_wp
9747	ENDIF
9748
9749	CASE ( 'rtm_rad_outlw' )
9750	!-- array of lw radiation emitted from surface after i-th reflection
9751	IF ( .NOT. ALLOCATED(surfoutlw_av) ) THEN
9752	ALLOCATE( surfoutlw_av(nsurfl) )
9753	surfoutlw_av = 0.0_wp
9754	ENDIF
9755	CASE ( 'rtm_rad_ressw' )
9756	!-- array of residua of sw radiation absorbed in surface after last reflection
9757	IF ( .NOT. ALLOCATED(surfins_av) ) THEN
9758	ALLOCATE( surfins_av(nsurfl) )
9759	surfins_av = 0.0_wp
9760	ENDIF
9761
9762	CASE ( 'rtm_rad_reslw' )
9763	!-- array of residua of lw radiation absorbed in surface after last reflection
9764	IF ( .NOT. ALLOCATED(surfinl_av) ) THEN
9765	ALLOCATE( surfinl_av(nsurfl) )
9766	surfinl_av = 0.0_wp
9767	ENDIF
9768
9769	CASE ( 'rtm_rad_pc_inlw' )
9770	!-- array of of lw radiation absorbed in plant canopy
9771	IF ( .NOT. ALLOCATED(pcbinlw_av) ) THEN
9772	ALLOCATE( pcbinlw_av(1:npcbl) )
9773	pcbinlw_av = 0.0_wp
9774	ENDIF
9775
9776	CASE ( 'rtm_rad_pc_insw' )
9777	!-- array of of sw radiation absorbed in plant canopy
9778	IF ( .NOT. ALLOCATED(pcbinsw_av) ) THEN
9779	ALLOCATE( pcbinsw_av(1:npcbl) )
9780	pcbinsw_av = 0.0_wp
9781	ENDIF
9782
9783	CASE ( 'rtm_rad_pc_inswdir' )
9784	!-- array of of direct sw radiation absorbed in plant canopy
9785	IF ( .NOT. ALLOCATED(pcbinswdir_av) ) THEN
9786	ALLOCATE( pcbinswdir_av(1:npcbl) )
9787	pcbinswdir_av = 0.0_wp
9788	ENDIF
9789
9790	CASE ( 'rtm_rad_pc_inswdif' )
9791	!-- array of of diffuse sw radiation absorbed in plant canopy
9792	IF ( .NOT. ALLOCATED(pcbinswdif_av) ) THEN
9793	ALLOCATE( pcbinswdif_av(1:npcbl) )
9794	pcbinswdif_av = 0.0_wp
9795	ENDIF
9796
9797	CASE ( 'rtm_rad_pc_inswref' )
9798	!-- array of of reflected sw radiation absorbed in plant canopy
9799	IF ( .NOT. ALLOCATED(pcbinswref_av) ) THEN
9800	ALLOCATE( pcbinswref_av(1:npcbl) )
9801	pcbinswref_av = 0.0_wp
9802	ENDIF
9803
9804	CASE ( 'rtm_mrt_sw' )
9805	IF ( .NOT. ALLOCATED( mrtinsw_av ) ) THEN
9806	ALLOCATE( mrtinsw_av(nmrtbl) )
9807	ENDIF
9808	mrtinsw_av = 0.0_wp
9809
9810	CASE ( 'rtm_mrt_lw' )
9811	IF ( .NOT. ALLOCATED( mrtinlw_av ) ) THEN
9812	ALLOCATE( mrtinlw_av(nmrtbl) )
9813	ENDIF
9814	mrtinlw_av = 0.0_wp
9815
9816	CASE ( 'rtm_mrt' )
9817	IF ( .NOT. ALLOCATED( mrt_av ) ) THEN
9818	ALLOCATE( mrt_av(nmrtbl) )
9819	ENDIF
9820	mrt_av = 0.0_wp
9821
9822	CASE DEFAULT
9823	CONTINUE
9824
9825	END SELECT
9826
9827	ELSEIF ( mode == 'sum' ) THEN
9828
9829	SELECT CASE ( TRIM( var ) )
9830	!-- block of large scale (e.g. RRTMG) radiation output variables
9831	CASE ( 'rad_net*' )
9832	IF ( ALLOCATED( rad_net_av ) ) THEN
9833	DO i = nxl, nxr
9834	DO j = nys, nyn
9835	match_lsm = surf_lsm_h%start_index(j,i) <= &
9836	surf_lsm_h%end_index(j,i)
9837	match_usm = surf_usm_h%start_index(j,i) <= &
9838	surf_usm_h%end_index(j,i)
9839
9840	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9841	m = surf_lsm_h%end_index(j,i)
9842	rad_net_av(j,i) = rad_net_av(j,i) + &
9843	surf_lsm_h%rad_net(m)
9844	ELSEIF ( match_usm ) THEN
9845	m = surf_usm_h%end_index(j,i)
9846	rad_net_av(j,i) = rad_net_av(j,i) + &
9847	surf_usm_h%rad_net(m)
9848	ENDIF
9849	ENDDO
9850	ENDDO
9851	ENDIF
9852
9853	CASE ( 'rad_lw_in*' )
9854	IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
9855	DO i = nxl, nxr
9856	DO j = nys, nyn
9857	match_lsm = surf_lsm_h%start_index(j,i) <= &
9858	surf_lsm_h%end_index(j,i)
9859	match_usm = surf_usm_h%start_index(j,i) <= &
9860	surf_usm_h%end_index(j,i)
9861
9862	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9863	m = surf_lsm_h%end_index(j,i)
9864	rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) + &
9865	surf_lsm_h%rad_lw_in(m)
9866	ELSEIF ( match_usm ) THEN
9867	m = surf_usm_h%end_index(j,i)
9868	rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) + &
9869	surf_usm_h%rad_lw_in(m)
9870	ENDIF
9871	ENDDO
9872	ENDDO
9873	ENDIF
9874
9875	CASE ( 'rad_lw_out*' )
9876	IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
9877	DO i = nxl, nxr
9878	DO j = nys, nyn
9879	match_lsm = surf_lsm_h%start_index(j,i) <= &
9880	surf_lsm_h%end_index(j,i)
9881	match_usm = surf_usm_h%start_index(j,i) <= &
9882	surf_usm_h%end_index(j,i)
9883
9884	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9885	m = surf_lsm_h%end_index(j,i)
9886	rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) + &
9887	surf_lsm_h%rad_lw_out(m)
9888	ELSEIF ( match_usm ) THEN
9889	m = surf_usm_h%end_index(j,i)
9890	rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) + &
9891	surf_usm_h%rad_lw_out(m)
9892	ENDIF
9893	ENDDO
9894	ENDDO
9895	ENDIF
9896
9897	CASE ( 'rad_sw_in*' )
9898	IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
9899	DO i = nxl, nxr
9900	DO j = nys, nyn
9901	match_lsm = surf_lsm_h%start_index(j,i) <= &
9902	surf_lsm_h%end_index(j,i)
9903	match_usm = surf_usm_h%start_index(j,i) <= &
9904	surf_usm_h%end_index(j,i)
9905
9906	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9907	m = surf_lsm_h%end_index(j,i)
9908	rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) + &
9909	surf_lsm_h%rad_sw_in(m)
9910	ELSEIF ( match_usm ) THEN
9911	m = surf_usm_h%end_index(j,i)
9912	rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) + &
9913	surf_usm_h%rad_sw_in(m)
9914	ENDIF
9915	ENDDO
9916	ENDDO
9917	ENDIF
9918
9919	CASE ( 'rad_sw_out*' )
9920	IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
9921	DO i = nxl, nxr
9922	DO j = nys, nyn
9923	match_lsm = surf_lsm_h%start_index(j,i) <= &
9924	surf_lsm_h%end_index(j,i)
9925	match_usm = surf_usm_h%start_index(j,i) <= &
9926	surf_usm_h%end_index(j,i)
9927
9928	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9929	m = surf_lsm_h%end_index(j,i)
9930	rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) + &
9931	surf_lsm_h%rad_sw_out(m)
9932	ELSEIF ( match_usm ) THEN
9933	m = surf_usm_h%end_index(j,i)
9934	rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) + &
9935	surf_usm_h%rad_sw_out(m)
9936	ENDIF
9937	ENDDO
9938	ENDDO
9939	ENDIF
9940
9941	CASE ( 'rad_lw_in' )
9942	IF ( ALLOCATED( rad_lw_in_av ) ) THEN
9943	DO i = nxlg, nxrg
9944	DO j = nysg, nyng
9945	DO k = nzb, nzt+1
9946	rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) &
9947	+ rad_lw_in(k,j,i)
9948	ENDDO
9949	ENDDO
9950	ENDDO
9951	ENDIF
9952
9953	CASE ( 'rad_lw_out' )
9954	IF ( ALLOCATED( rad_lw_out_av ) ) THEN
9955	DO i = nxlg, nxrg
9956	DO j = nysg, nyng
9957	DO k = nzb, nzt+1
9958	rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) &
9959	+ rad_lw_out(k,j,i)
9960	ENDDO
9961	ENDDO
9962	ENDDO
9963	ENDIF
9964
9965	CASE ( 'rad_lw_cs_hr' )
9966	IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN
9967	DO i = nxlg, nxrg
9968	DO j = nysg, nyng
9969	DO k = nzb, nzt+1
9970	rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) &
9971	+ rad_lw_cs_hr(k,j,i)
9972	ENDDO
9973	ENDDO
9974	ENDDO
9975	ENDIF
9976
9977	CASE ( 'rad_lw_hr' )
9978	IF ( ALLOCATED( rad_lw_hr_av ) ) THEN
9979	DO i = nxlg, nxrg
9980	DO j = nysg, nyng
9981	DO k = nzb, nzt+1
9982	rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) &
9983	+ rad_lw_hr(k,j,i)
9984	ENDDO
9985	ENDDO
9986	ENDDO
9987	ENDIF
9988
9989	CASE ( 'rad_sw_in' )
9990	IF ( ALLOCATED( rad_sw_in_av ) ) THEN
9991	DO i = nxlg, nxrg
9992	DO j = nysg, nyng
9993	DO k = nzb, nzt+1
9994	rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) &
9995	+ rad_sw_in(k,j,i)
9996	ENDDO
9997	ENDDO
9998	ENDDO
9999	ENDIF
10000
10001	CASE ( 'rad_sw_out' )
10002	IF ( ALLOCATED( rad_sw_out_av ) ) THEN
10003	DO i = nxlg, nxrg
10004	DO j = nysg, nyng
10005	DO k = nzb, nzt+1
10006	rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) &
10007	+ rad_sw_out(k,j,i)
10008	ENDDO
10009	ENDDO
10010	ENDDO
10011	ENDIF
10012
10013	CASE ( 'rad_sw_cs_hr' )
10014	IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN
10015	DO i = nxlg, nxrg
10016	DO j = nysg, nyng
10017	DO k = nzb, nzt+1
10018	rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) &
10019	+ rad_sw_cs_hr(k,j,i)
10020	ENDDO
10021	ENDDO
10022	ENDDO
10023	ENDIF
10024
10025	CASE ( 'rad_sw_hr' )
10026	IF ( ALLOCATED( rad_sw_hr_av ) ) THEN
10027	DO i = nxlg, nxrg
10028	DO j = nysg, nyng
10029	DO k = nzb, nzt+1
10030	rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) &
10031	+ rad_sw_hr(k,j,i)
10032	ENDDO
10033	ENDDO
10034	ENDDO
10035	ENDIF
10036
10037	!-- block of RTM output variables
10038	CASE ( 'rtm_rad_net' )
10039	!-- array of complete radiation balance
10040	DO isurf = dirstart(ids), dirend(ids)
10041	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10042	surfradnet_av(isurf) = surfinsw(isurf) - surfoutsw(isurf) + surfinlw(isurf) - surfoutlw(isurf)
10043	ENDIF
10044	ENDDO
10045
10046	CASE ( 'rtm_rad_insw' )
10047	!-- array of sw radiation falling to surface after i-th reflection
10048	DO isurf = dirstart(ids), dirend(ids)
10049	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10050	surfinsw_av(isurf) = surfinsw_av(isurf) + surfinsw(isurf)
10051	ENDIF
10052	ENDDO
10053
10054	CASE ( 'rtm_rad_inlw' )
10055	!-- array of lw radiation falling to surface after i-th reflection
10056	DO isurf = dirstart(ids), dirend(ids)
10057	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10058	surfinlw_av(isurf) = surfinlw_av(isurf) + surfinlw(isurf)
10059	ENDIF
10060	ENDDO
10061
10062	CASE ( 'rtm_rad_inswdir' )
10063	!-- array of direct sw radiation falling to surface from sun
10064	DO isurf = dirstart(ids), dirend(ids)
10065	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10066	surfinswdir_av(isurf) = surfinswdir_av(isurf) + surfinswdir(isurf)
10067	ENDIF
10068	ENDDO
10069
10070	CASE ( 'rtm_rad_inswdif' )
10071	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
10072	DO isurf = dirstart(ids), dirend(ids)
10073	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10074	surfinswdif_av(isurf) = surfinswdif_av(isurf) + surfinswdif(isurf)
10075	ENDIF
10076	ENDDO
10077
10078	CASE ( 'rtm_rad_inswref' )
10079	!-- array of sw radiation falling to surface from reflections
10080	DO isurf = dirstart(ids), dirend(ids)
10081	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10082	surfinswref_av(isurf) = surfinswref_av(isurf) + surfinsw(isurf) - &
10083	surfinswdir(isurf) - surfinswdif(isurf)
10084	ENDIF
10085	ENDDO
10086
10087
10088	CASE ( 'rtm_rad_inlwdif' )
10089	!-- array of sw radiation falling to surface after i-th reflection
10090	DO isurf = dirstart(ids), dirend(ids)
10091	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10092	surfinlwdif_av(isurf) = surfinlwdif_av(isurf) + surfinlwdif(isurf)
10093	ENDIF
10094	ENDDO
10095	!
10096	CASE ( 'rtm_rad_inlwref' )
10097	!-- array of lw radiation falling to surface from reflections
10098	DO isurf = dirstart(ids), dirend(ids)
10099	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10100	surfinlwref_av(isurf) = surfinlwref_av(isurf) + &
10101	surfinlw(isurf) - surfinlwdif(isurf)
10102	ENDIF
10103	ENDDO
10104
10105	CASE ( 'rtm_rad_outsw' )
10106	!-- array of sw radiation emitted from surface after i-th reflection
10107	DO isurf = dirstart(ids), dirend(ids)
10108	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10109	surfoutsw_av(isurf) = surfoutsw_av(isurf) + surfoutsw(isurf)
10110	ENDIF
10111	ENDDO
10112
10113	CASE ( 'rtm_rad_outlw' )
10114	!-- array of lw radiation emitted from surface after i-th reflection
10115	DO isurf = dirstart(ids), dirend(ids)
10116	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10117	surfoutlw_av(isurf) = surfoutlw_av(isurf) + surfoutlw(isurf)
10118	ENDIF
10119	ENDDO
10120
10121	CASE ( 'rtm_rad_ressw' )
10122	!-- array of residua of sw radiation absorbed in surface after last reflection
10123	DO isurf = dirstart(ids), dirend(ids)
10124	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10125	surfins_av(isurf) = surfins_av(isurf) + surfins(isurf)
10126	ENDIF
10127	ENDDO
10128
10129	CASE ( 'rtm_rad_reslw' )
10130	!-- array of residua of lw radiation absorbed in surface after last reflection
10131	DO isurf = dirstart(ids), dirend(ids)
10132	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10133	surfinl_av(isurf) = surfinl_av(isurf) + surfinl(isurf)
10134	ENDIF
10135	ENDDO
10136
10137	CASE ( 'rtm_rad_pc_inlw' )
10138	DO l = 1, npcbl
10139	pcbinlw_av(l) = pcbinlw_av(l) + pcbinlw(l)
10140	ENDDO
10141
10142	CASE ( 'rtm_rad_pc_insw' )
10143	DO l = 1, npcbl
10144	pcbinsw_av(l) = pcbinsw_av(l) + pcbinsw(l)
10145	ENDDO
10146
10147	CASE ( 'rtm_rad_pc_inswdir' )
10148	DO l = 1, npcbl
10149	pcbinswdir_av(l) = pcbinswdir_av(l) + pcbinswdir(l)
10150	ENDDO
10151
10152	CASE ( 'rtm_rad_pc_inswdif' )
10153	DO l = 1, npcbl
10154	pcbinswdif_av(l) = pcbinswdif_av(l) + pcbinswdif(l)
10155	ENDDO
10156
10157	CASE ( 'rtm_rad_pc_inswref' )
10158	DO l = 1, npcbl
10159	pcbinswref_av(l) = pcbinswref_av(l) + pcbinsw(l) - pcbinswdir(l) - pcbinswdif(l)
10160	ENDDO
10161
10162	CASE ( 'rad_mrt_sw' )
10163	IF ( ALLOCATED( mrtinsw_av ) ) THEN
10164	mrtinsw_av(:) = mrtinsw_av(:) + mrtinsw(:)
10165	ENDIF
10166
10167	CASE ( 'rad_mrt_lw' )
10168	IF ( ALLOCATED( mrtinlw_av ) ) THEN
10169	mrtinlw_av(:) = mrtinlw_av(:) + mrtinlw(:)
10170	ENDIF
10171
10172	CASE ( 'rad_mrt' )
10173	IF ( ALLOCATED( mrt_av ) ) THEN
10174	mrt_av(:) = mrt_av(:) + mrt(:)
10175	ENDIF
10176
10177	CASE DEFAULT
10178	CONTINUE
10179
10180	END SELECT
10181
10182	ELSEIF ( mode == 'average' ) THEN
10183
10184	SELECT CASE ( TRIM( var ) )
10185	!-- block of large scale (e.g. RRTMG) radiation output variables
10186	CASE ( 'rad_net*' )
10187	IF ( ALLOCATED( rad_net_av ) ) THEN
10188	DO i = nxlg, nxrg
10189	DO j = nysg, nyng
10190	rad_net_av(j,i) = rad_net_av(j,i) &
10191	/ REAL( average_count_3d, KIND=wp )
10192	ENDDO
10193	ENDDO
10194	ENDIF
10195
10196	CASE ( 'rad_lw_in*' )
10197	IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
10198	DO i = nxlg, nxrg
10199	DO j = nysg, nyng
10200	rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) &
10201	/ REAL( average_count_3d, KIND=wp )
10202	ENDDO
10203	ENDDO
10204	ENDIF
10205
10206	CASE ( 'rad_lw_out*' )
10207	IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
10208	DO i = nxlg, nxrg
10209	DO j = nysg, nyng
10210	rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) &
10211	/ REAL( average_count_3d, KIND=wp )
10212	ENDDO
10213	ENDDO
10214	ENDIF
10215
10216	CASE ( 'rad_sw_in*' )
10217	IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
10218	DO i = nxlg, nxrg
10219	DO j = nysg, nyng
10220	rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) &
10221	/ REAL( average_count_3d, KIND=wp )
10222	ENDDO
10223	ENDDO
10224	ENDIF
10225
10226	CASE ( 'rad_sw_out*' )
10227	IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
10228	DO i = nxlg, nxrg
10229	DO j = nysg, nyng
10230	rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) &
10231	/ REAL( average_count_3d, KIND=wp )
10232	ENDDO
10233	ENDDO
10234	ENDIF
10235
10236	CASE ( 'rad_lw_in' )
10237	IF ( ALLOCATED( rad_lw_in_av ) ) THEN
10238	DO i = nxlg, nxrg
10239	DO j = nysg, nyng
10240	DO k = nzb, nzt+1
10241	rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) &
10242	/ REAL( average_count_3d, KIND=wp )
10243	ENDDO
10244	ENDDO
10245	ENDDO
10246	ENDIF
10247
10248	CASE ( 'rad_lw_out' )
10249	IF ( ALLOCATED( rad_lw_out_av ) ) THEN
10250	DO i = nxlg, nxrg
10251	DO j = nysg, nyng
10252	DO k = nzb, nzt+1
10253	rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) &
10254	/ REAL( average_count_3d, KIND=wp )
10255	ENDDO
10256	ENDDO
10257	ENDDO
10258	ENDIF
10259
10260	CASE ( 'rad_lw_cs_hr' )
10261	IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN
10262	DO i = nxlg, nxrg
10263	DO j = nysg, nyng
10264	DO k = nzb, nzt+1
10265	rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) &
10266	/ REAL( average_count_3d, KIND=wp )
10267	ENDDO
10268	ENDDO
10269	ENDDO
10270	ENDIF
10271
10272	CASE ( 'rad_lw_hr' )
10273	IF ( ALLOCATED( rad_lw_hr_av ) ) THEN
10274	DO i = nxlg, nxrg
10275	DO j = nysg, nyng
10276	DO k = nzb, nzt+1
10277	rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) &
10278	/ REAL( average_count_3d, KIND=wp )
10279	ENDDO
10280	ENDDO
10281	ENDDO
10282	ENDIF
10283
10284	CASE ( 'rad_sw_in' )
10285	IF ( ALLOCATED( rad_sw_in_av ) ) THEN
10286	DO i = nxlg, nxrg
10287	DO j = nysg, nyng
10288	DO k = nzb, nzt+1
10289	rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) &
10290	/ REAL( average_count_3d, KIND=wp )
10291	ENDDO
10292	ENDDO
10293	ENDDO
10294	ENDIF
10295
10296	CASE ( 'rad_sw_out' )
10297	IF ( ALLOCATED( rad_sw_out_av ) ) THEN
10298	DO i = nxlg, nxrg
10299	DO j = nysg, nyng
10300	DO k = nzb, nzt+1
10301	rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) &
10302	/ REAL( average_count_3d, KIND=wp )
10303	ENDDO
10304	ENDDO
10305	ENDDO
10306	ENDIF
10307
10308	CASE ( 'rad_sw_cs_hr' )
10309	IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN
10310	DO i = nxlg, nxrg
10311	DO j = nysg, nyng
10312	DO k = nzb, nzt+1
10313	rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) &
10314	/ REAL( average_count_3d, KIND=wp )
10315	ENDDO
10316	ENDDO
10317	ENDDO
10318	ENDIF
10319
10320	CASE ( 'rad_sw_hr' )
10321	IF ( ALLOCATED( rad_sw_hr_av ) ) THEN
10322	DO i = nxlg, nxrg
10323	DO j = nysg, nyng
10324	DO k = nzb, nzt+1
10325	rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) &
10326	/ REAL( average_count_3d, KIND=wp )
10327	ENDDO
10328	ENDDO
10329	ENDDO
10330	ENDIF
10331
10332	!-- block of RTM output variables
10333	CASE ( 'rtm_rad_net' )
10334	!-- array of complete radiation balance
10335	DO isurf = dirstart(ids), dirend(ids)
10336	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10337	surfradnet_av(isurf) = surfinsw_av(isurf) / REAL( average_count_3d, kind=wp )
10338	ENDIF
10339	ENDDO
10340
10341	CASE ( 'rtm_rad_insw' )
10342	!-- array of sw radiation falling to surface after i-th reflection
10343	DO isurf = dirstart(ids), dirend(ids)
10344	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10345	surfinsw_av(isurf) = surfinsw_av(isurf) / REAL( average_count_3d, kind=wp )
10346	ENDIF
10347	ENDDO
10348
10349	CASE ( 'rtm_rad_inlw' )
10350	!-- array of lw radiation falling to surface after i-th reflection
10351	DO isurf = dirstart(ids), dirend(ids)
10352	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10353	surfinlw_av(isurf) = surfinlw_av(isurf) / REAL( average_count_3d, kind=wp )
10354	ENDIF
10355	ENDDO
10356
10357	CASE ( 'rtm_rad_inswdir' )
10358	!-- array of direct sw radiation falling to surface from sun
10359	DO isurf = dirstart(ids), dirend(ids)
10360	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10361	surfinswdir_av(isurf) = surfinswdir_av(isurf) / REAL( average_count_3d, kind=wp )
10362	ENDIF
10363	ENDDO
10364
10365	CASE ( 'rtm_rad_inswdif' )
10366	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
10367	DO isurf = dirstart(ids), dirend(ids)
10368	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10369	surfinswdif_av(isurf) = surfinswdif_av(isurf) / REAL( average_count_3d, kind=wp )
10370	ENDIF
10371	ENDDO
10372
10373	CASE ( 'rtm_rad_inswref' )
10374	!-- array of sw radiation falling to surface from reflections
10375	DO isurf = dirstart(ids), dirend(ids)
10376	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10377	surfinswref_av(isurf) = surfinswref_av(isurf) / REAL( average_count_3d, kind=wp )
10378	ENDIF
10379	ENDDO
10380
10381	CASE ( 'rtm_rad_inlwdif' )
10382	!-- array of sw radiation falling to surface after i-th reflection
10383	DO isurf = dirstart(ids), dirend(ids)
10384	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10385	surfinlwdif_av(isurf) = surfinlwdif_av(isurf) / REAL( average_count_3d, kind=wp )
10386	ENDIF
10387	ENDDO
10388
10389	CASE ( 'rtm_rad_inlwref' )
10390	!-- array of lw radiation falling to surface from reflections
10391	DO isurf = dirstart(ids), dirend(ids)
10392	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10393	surfinlwref_av(isurf) = surfinlwref_av(isurf) / REAL( average_count_3d, kind=wp )
10394	ENDIF
10395	ENDDO
10396
10397	CASE ( 'rtm_rad_outsw' )
10398	!-- array of sw radiation emitted from surface after i-th reflection
10399	DO isurf = dirstart(ids), dirend(ids)
10400	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10401	surfoutsw_av(isurf) = surfoutsw_av(isurf) / REAL( average_count_3d, kind=wp )
10402	ENDIF
10403	ENDDO
10404
10405	CASE ( 'rtm_rad_outlw' )
10406	!-- array of lw radiation emitted from surface after i-th reflection
10407	DO isurf = dirstart(ids), dirend(ids)
10408	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10409	surfoutlw_av(isurf) = surfoutlw_av(isurf) / REAL( average_count_3d, kind=wp )
10410	ENDIF
10411	ENDDO
10412
10413	CASE ( 'rtm_rad_ressw' )
10414	!-- array of residua of sw radiation absorbed in surface after last reflection
10415	DO isurf = dirstart(ids), dirend(ids)
10416	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10417	surfins_av(isurf) = surfins_av(isurf) / REAL( average_count_3d, kind=wp )
10418	ENDIF
10419	ENDDO
10420
10421	CASE ( 'rtm_rad_reslw' )
10422	!-- array of residua of lw radiation absorbed in surface after last reflection
10423	DO isurf = dirstart(ids), dirend(ids)
10424	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10425	surfinl_av(isurf) = surfinl_av(isurf) / REAL( average_count_3d, kind=wp )
10426	ENDIF
10427	ENDDO
10428
10429	CASE ( 'rtm_rad_pc_inlw' )
10430	DO l = 1, npcbl
10431	pcbinlw_av(:) = pcbinlw_av(:) / REAL( average_count_3d, kind=wp )
10432	ENDDO
10433
10434	CASE ( 'rtm_rad_pc_insw' )
10435	DO l = 1, npcbl
10436	pcbinsw_av(:) = pcbinsw_av(:) / REAL( average_count_3d, kind=wp )
10437	ENDDO
10438
10439	CASE ( 'rtm_rad_pc_inswdir' )
10440	DO l = 1, npcbl
10441	pcbinswdir_av(:) = pcbinswdir_av(:) / REAL( average_count_3d, kind=wp )
10442	ENDDO
10443
10444	CASE ( 'rtm_rad_pc_inswdif' )
10445	DO l = 1, npcbl
10446	pcbinswdif_av(:) = pcbinswdif_av(:) / REAL( average_count_3d, kind=wp )
10447	ENDDO
10448
10449	CASE ( 'rtm_rad_pc_inswref' )
10450	DO l = 1, npcbl
10451	pcbinswref_av(:) = pcbinswref_av(:) / REAL( average_count_3d, kind=wp )
10452	ENDDO
10453
10454	CASE ( 'rad_mrt_lw' )
10455	IF ( ALLOCATED( mrtinlw_av ) ) THEN
10456	mrtinlw_av(:) = mrtinlw_av(:) / REAL( average_count_3d, KIND=wp )
10457	ENDIF
10458
10459	CASE ( 'rad_mrt' )
10460	IF ( ALLOCATED( mrt_av ) ) THEN
10461	mrt_av(:) = mrt_av(:) / REAL( average_count_3d, KIND=wp )
10462	ENDIF
10463
10464	END SELECT
10465
10466	ENDIF
10467
10468	END SUBROUTINE radiation_3d_data_averaging
10469
10470
10471	!------------------------------------------------------------------------------!
10472	!
10473	! Description:
10474	! ------------
10475	!> Subroutine defining appropriate grid for netcdf variables.
10476	!> It is called out from subroutine netcdf.
10477	!------------------------------------------------------------------------------!
10478	SUBROUTINE radiation_define_netcdf_grid( variable, found, grid_x, grid_y, grid_z )
10479
10480	IMPLICIT NONE
10481
10482	CHARACTER (LEN=*), INTENT(IN) :: variable !<
10483	LOGICAL, INTENT(OUT) :: found !<
10484	CHARACTER (LEN=*), INTENT(OUT) :: grid_x !<
10485	CHARACTER (LEN=*), INTENT(OUT) :: grid_y !<
10486	CHARACTER (LEN=*), INTENT(OUT) :: grid_z !<
10487
10488	CHARACTER (len=varnamelength) :: var
10489
10490	found = .TRUE.
10491
10492	!
10493	!-- Check for the grid
10494	var = TRIM(variable)
10495	!-- RTM directional variables
10496	IF ( var(1:12) == 'rtm_rad_net_' .OR. var(1:13) == 'rtm_rad_insw_' .OR. &
10497	var(1:13) == 'rtm_rad_inlw_' .OR. var(1:16) == 'rtm_rad_inswdir_' .OR. &
10498	var(1:16) == 'rtm_rad_inswdif_' .OR. var(1:16) == 'rtm_rad_inswref_' .OR. &
10499	var(1:16) == 'rtm_rad_inlwdif_' .OR. var(1:16) == 'rtm_rad_inlwref_' .OR. &
10500	var(1:14) == 'rtm_rad_outsw_' .OR. var(1:14) == 'rtm_rad_outlw_' .OR. &
10501	var(1:14) == 'rtm_rad_ressw_' .OR. var(1:14) == 'rtm_rad_reslw_' .OR. &
10502	var == 'rtm_rad_pc_inlw' .OR. &
10503	var == 'rtm_rad_pc_insw' .OR. var == 'rtm_rad_pc_inswdir' .OR. &
10504	var == 'rtm_rad_pc_inswdif' .OR. var == 'rtm_rad_pc_inswref' .OR. &
10505	var(1:7) == 'rtm_svf' .OR. var(1:7) == 'rtm_dif' .OR. &
10506	var(1:9) == 'rtm_skyvf' .OR. var(1:10) == 'rtm_skyvft' .OR. &
10507	var(1:12) == 'rtm_surfalb_' .OR. var(1:13) == 'rtm_surfemis_' .OR. &
10508	var == 'rtm_mrt' .OR. var == 'rtm_mrt_sw' .OR. var == 'rtm_mrt_lw' ) THEN
10509
10510	found = .TRUE.
10511	grid_x = 'x'
10512	grid_y = 'y'
10513	grid_z = 'zu'
10514	ELSE
10515
10516	SELECT CASE ( TRIM( var ) )
10517
10518	CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_sw_cs_hr', 'rad_sw_hr', &
10519	'rad_lw_cs_hr_xy', 'rad_lw_hr_xy', 'rad_sw_cs_hr_xy', &
10520	'rad_sw_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_hr_xz', &
10521	'rad_sw_cs_hr_xz', 'rad_sw_hr_xz', 'rad_lw_cs_hr_yz', &
10522	'rad_lw_hr_yz', 'rad_sw_cs_hr_yz', 'rad_sw_hr_yz', &
10523	'rad_mrt', 'rad_mrt_sw', 'rad_mrt_lw' )
10524	grid_x = 'x'
10525	grid_y = 'y'
10526	grid_z = 'zu'
10527
10528	CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out', &
10529	'rad_lw_in_xy', 'rad_lw_out_xy', 'rad_sw_in_xy','rad_sw_out_xy', &
10530	'rad_lw_in_xz', 'rad_lw_out_xz', 'rad_sw_in_xz','rad_sw_out_xz', &
10531	'rad_lw_in_yz', 'rad_lw_out_yz', 'rad_sw_in_yz','rad_sw_out_yz' )
10532	grid_x = 'x'
10533	grid_y = 'y'
10534	grid_z = 'zw'
10535
10536
10537	CASE DEFAULT
10538	found = .FALSE.
10539	grid_x = 'none'
10540	grid_y = 'none'
10541	grid_z = 'none'
10542
10543	END SELECT
10544	ENDIF
10545
10546	END SUBROUTINE radiation_define_netcdf_grid
10547
10548	!------------------------------------------------------------------------------!
10549	!
10550	! Description:
10551	! ------------
10552	!> Subroutine defining 2D output variables
10553	!------------------------------------------------------------------------------!
10554	SUBROUTINE radiation_data_output_2d( av, variable, found, grid, mode, &
10555	local_pf, two_d, nzb_do, nzt_do )
10556
10557	USE indices
10558
10559	USE kinds
10560
10561
10562	IMPLICIT NONE
10563
10564	CHARACTER (LEN=*) :: grid !<
10565	CHARACTER (LEN=*) :: mode !<
10566	CHARACTER (LEN=*) :: variable !<
10567
10568	INTEGER(iwp) :: av !<
10569	INTEGER(iwp) :: i !<
10570	INTEGER(iwp) :: j !<
10571	INTEGER(iwp) :: k !<
10572	INTEGER(iwp) :: m !< index of surface element at grid point (j,i)
10573	INTEGER(iwp) :: nzb_do !<
10574	INTEGER(iwp) :: nzt_do !<
10575
10576	LOGICAL :: found !<
10577	LOGICAL :: two_d !< flag parameter that indicates 2D variables (horizontal cross sections)
10578
10579	REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute
10580
10581	REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !<
10582
10583	found = .TRUE.
10584
10585	SELECT CASE ( TRIM( variable ) )
10586
10587	CASE ( 'rad_net*_xy' ) ! 2d-array
10588	IF ( av == 0 ) THEN
10589	DO i = nxl, nxr
10590	DO j = nys, nyn
10591	!
10592	!-- Obtain rad_net from its respective surface type
10593	!-- Natural-type surfaces
10594	DO m = surf_lsm_h%start_index(j,i), &
10595	surf_lsm_h%end_index(j,i)
10596	local_pf(i,j,nzb+1) = surf_lsm_h%rad_net(m)
10597	ENDDO
10598	!
10599	!-- Urban-type surfaces
10600	DO m = surf_usm_h%start_index(j,i), &
10601	surf_usm_h%end_index(j,i)
10602	local_pf(i,j,nzb+1) = surf_usm_h%rad_net(m)
10603	ENDDO
10604	ENDDO
10605	ENDDO
10606	ELSE
10607	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
10608	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
10609	rad_net_av = REAL( fill_value, KIND = wp )
10610	ENDIF
10611	DO i = nxl, nxr
10612	DO j = nys, nyn
10613	local_pf(i,j,nzb+1) = rad_net_av(j,i)
10614	ENDDO
10615	ENDDO
10616	ENDIF
10617	two_d = .TRUE.
10618	grid = 'zu1'
10619
10620	CASE ( 'rad_lw_in*_xy' ) ! 2d-array
10621	IF ( av == 0 ) THEN
10622	DO i = nxl, nxr
10623	DO j = nys, nyn
10624	!
10625	!-- Obtain rad_net from its respective surface type
10626	!-- Natural-type surfaces
10627	DO m = surf_lsm_h%start_index(j,i), &
10628	surf_lsm_h%end_index(j,i)
10629	local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_in(m)
10630	ENDDO
10631	!
10632	!-- Urban-type surfaces
10633	DO m = surf_usm_h%start_index(j,i), &
10634	surf_usm_h%end_index(j,i)
10635	local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_in(m)
10636	ENDDO
10637	ENDDO
10638	ENDDO
10639	ELSE
10640	IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
10641	ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
10642	rad_lw_in_xy_av = REAL( fill_value, KIND = wp )
10643	ENDIF
10644	DO i = nxl, nxr
10645	DO j = nys, nyn
10646	local_pf(i,j,nzb+1) = rad_lw_in_xy_av(j,i)
10647	ENDDO
10648	ENDDO
10649	ENDIF
10650	two_d = .TRUE.
10651	grid = 'zu1'
10652
10653	CASE ( 'rad_lw_out*_xy' ) ! 2d-array
10654	IF ( av == 0 ) THEN
10655	DO i = nxl, nxr
10656	DO j = nys, nyn
10657	!
10658	!-- Obtain rad_net from its respective surface type
10659	!-- Natural-type surfaces
10660	DO m = surf_lsm_h%start_index(j,i), &
10661	surf_lsm_h%end_index(j,i)
10662	local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_out(m)
10663	ENDDO
10664	!
10665	!-- Urban-type surfaces
10666	DO m = surf_usm_h%start_index(j,i), &
10667	surf_usm_h%end_index(j,i)
10668	local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_out(m)
10669	ENDDO
10670	ENDDO
10671	ENDDO
10672	ELSE
10673	IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
10674	ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
10675	rad_lw_out_xy_av = REAL( fill_value, KIND = wp )
10676	ENDIF
10677	DO i = nxl, nxr
10678	DO j = nys, nyn
10679	local_pf(i,j,nzb+1) = rad_lw_out_xy_av(j,i)
10680	ENDDO
10681	ENDDO
10682	ENDIF
10683	two_d = .TRUE.
10684	grid = 'zu1'
10685
10686	CASE ( 'rad_sw_in*_xy' ) ! 2d-array
10687	IF ( av == 0 ) THEN
10688	DO i = nxl, nxr
10689	DO j = nys, nyn
10690	!
10691	!-- Obtain rad_net from its respective surface type
10692	!-- Natural-type surfaces
10693	DO m = surf_lsm_h%start_index(j,i), &
10694	surf_lsm_h%end_index(j,i)
10695	local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_in(m)
10696	ENDDO
10697	!
10698	!-- Urban-type surfaces
10699	DO m = surf_usm_h%start_index(j,i), &
10700	surf_usm_h%end_index(j,i)
10701	local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_in(m)
10702	ENDDO
10703	ENDDO
10704	ENDDO
10705	ELSE
10706	IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
10707	ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
10708	rad_sw_in_xy_av = REAL( fill_value, KIND = wp )
10709	ENDIF
10710	DO i = nxl, nxr
10711	DO j = nys, nyn
10712	local_pf(i,j,nzb+1) = rad_sw_in_xy_av(j,i)
10713	ENDDO
10714	ENDDO
10715	ENDIF
10716	two_d = .TRUE.
10717	grid = 'zu1'
10718
10719	CASE ( 'rad_sw_out*_xy' ) ! 2d-array
10720	IF ( av == 0 ) THEN
10721	DO i = nxl, nxr
10722	DO j = nys, nyn
10723	!
10724	!-- Obtain rad_net from its respective surface type
10725	!-- Natural-type surfaces
10726	DO m = surf_lsm_h%start_index(j,i), &
10727	surf_lsm_h%end_index(j,i)
10728	local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_out(m)
10729	ENDDO
10730	!
10731	!-- Urban-type surfaces
10732	DO m = surf_usm_h%start_index(j,i), &
10733	surf_usm_h%end_index(j,i)
10734	local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_out(m)
10735	ENDDO
10736	ENDDO
10737	ENDDO
10738	ELSE
10739	IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
10740	ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
10741	rad_sw_out_xy_av = REAL( fill_value, KIND = wp )
10742	ENDIF
10743	DO i = nxl, nxr
10744	DO j = nys, nyn
10745	local_pf(i,j,nzb+1) = rad_sw_out_xy_av(j,i)
10746	ENDDO
10747	ENDDO
10748	ENDIF
10749	two_d = .TRUE.
10750	grid = 'zu1'
10751
10752	CASE ( 'rad_lw_in_xy', 'rad_lw_in_xz', 'rad_lw_in_yz' )
10753	IF ( av == 0 ) THEN
10754	DO i = nxl, nxr
10755	DO j = nys, nyn
10756	DO k = nzb_do, nzt_do
10757	local_pf(i,j,k) = rad_lw_in(k,j,i)
10758	ENDDO
10759	ENDDO
10760	ENDDO
10761	ELSE
10762	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
10763	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10764	rad_lw_in_av = REAL( fill_value, KIND = wp )
10765	ENDIF
10766	DO i = nxl, nxr
10767	DO j = nys, nyn
10768	DO k = nzb_do, nzt_do
10769	local_pf(i,j,k) = rad_lw_in_av(k,j,i)
10770	ENDDO
10771	ENDDO
10772	ENDDO
10773	ENDIF
10774	IF ( mode == 'xy' ) grid = 'zu'
10775
10776	CASE ( 'rad_lw_out_xy', 'rad_lw_out_xz', 'rad_lw_out_yz' )
10777	IF ( av == 0 ) THEN
10778	DO i = nxl, nxr
10779	DO j = nys, nyn
10780	DO k = nzb_do, nzt_do
10781	local_pf(i,j,k) = rad_lw_out(k,j,i)
10782	ENDDO
10783	ENDDO
10784	ENDDO
10785	ELSE
10786	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
10787	ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10788	rad_lw_out_av = REAL( fill_value, KIND = wp )
10789	ENDIF
10790	DO i = nxl, nxr
10791	DO j = nys, nyn
10792	DO k = nzb_do, nzt_do
10793	local_pf(i,j,k) = rad_lw_out_av(k,j,i)
10794	ENDDO
10795	ENDDO
10796	ENDDO
10797	ENDIF
10798	IF ( mode == 'xy' ) grid = 'zu'
10799
10800	CASE ( 'rad_lw_cs_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_cs_hr_yz' )
10801	IF ( av == 0 ) THEN
10802	DO i = nxl, nxr
10803	DO j = nys, nyn
10804	DO k = nzb_do, nzt_do
10805	local_pf(i,j,k) = rad_lw_cs_hr(k,j,i)
10806	ENDDO
10807	ENDDO
10808	ENDDO
10809	ELSE
10810	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
10811	ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10812	rad_lw_cs_hr_av = REAL( fill_value, KIND = wp )
10813	ENDIF
10814	DO i = nxl, nxr
10815	DO j = nys, nyn
10816	DO k = nzb_do, nzt_do
10817	local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i)
10818	ENDDO
10819	ENDDO
10820	ENDDO
10821	ENDIF
10822	IF ( mode == 'xy' ) grid = 'zw'
10823
10824	CASE ( 'rad_lw_hr_xy', 'rad_lw_hr_xz', 'rad_lw_hr_yz' )
10825	IF ( av == 0 ) THEN
10826	DO i = nxl, nxr
10827	DO j = nys, nyn
10828	DO k = nzb_do, nzt_do
10829	local_pf(i,j,k) = rad_lw_hr(k,j,i)
10830	ENDDO
10831	ENDDO
10832	ENDDO
10833	ELSE
10834	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
10835	ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10836	rad_lw_hr_av= REAL( fill_value, KIND = wp )
10837	ENDIF
10838	DO i = nxl, nxr
10839	DO j = nys, nyn
10840	DO k = nzb_do, nzt_do
10841	local_pf(i,j,k) = rad_lw_hr_av(k,j,i)
10842	ENDDO
10843	ENDDO
10844	ENDDO
10845	ENDIF
10846	IF ( mode == 'xy' ) grid = 'zw'
10847
10848	CASE ( 'rad_sw_in_xy', 'rad_sw_in_xz', 'rad_sw_in_yz' )
10849	IF ( av == 0 ) THEN
10850	DO i = nxl, nxr
10851	DO j = nys, nyn
10852	DO k = nzb_do, nzt_do
10853	local_pf(i,j,k) = rad_sw_in(k,j,i)
10854	ENDDO
10855	ENDDO
10856	ENDDO
10857	ELSE
10858	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
10859	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10860	rad_sw_in_av = REAL( fill_value, KIND = wp )
10861	ENDIF
10862	DO i = nxl, nxr
10863	DO j = nys, nyn
10864	DO k = nzb_do, nzt_do
10865	local_pf(i,j,k) = rad_sw_in_av(k,j,i)
10866	ENDDO
10867	ENDDO
10868	ENDDO
10869	ENDIF
10870	IF ( mode == 'xy' ) grid = 'zu'
10871
10872	CASE ( 'rad_sw_out_xy', 'rad_sw_out_xz', 'rad_sw_out_yz' )
10873	IF ( av == 0 ) THEN
10874	DO i = nxl, nxr
10875	DO j = nys, nyn
10876	DO k = nzb_do, nzt_do
10877	local_pf(i,j,k) = rad_sw_out(k,j,i)
10878	ENDDO
10879	ENDDO
10880	ENDDO
10881	ELSE
10882	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
10883	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10884	rad_sw_out_av = REAL( fill_value, KIND = wp )
10885	ENDIF
10886	DO i = nxl, nxr
10887	DO j = nys, nyn
10888	DO k = nzb, nzt+1
10889	local_pf(i,j,k) = rad_sw_out_av(k,j,i)
10890	ENDDO
10891	ENDDO
10892	ENDDO
10893	ENDIF
10894	IF ( mode == 'xy' ) grid = 'zu'
10895
10896	CASE ( 'rad_sw_cs_hr_xy', 'rad_sw_cs_hr_xz', 'rad_sw_cs_hr_yz' )
10897	IF ( av == 0 ) THEN
10898	DO i = nxl, nxr
10899	DO j = nys, nyn
10900	DO k = nzb_do, nzt_do
10901	local_pf(i,j,k) = rad_sw_cs_hr(k,j,i)
10902	ENDDO
10903	ENDDO
10904	ENDDO
10905	ELSE
10906	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
10907	ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10908	rad_sw_cs_hr_av = REAL( fill_value, KIND = wp )
10909	ENDIF
10910	DO i = nxl, nxr
10911	DO j = nys, nyn
10912	DO k = nzb_do, nzt_do
10913	local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i)
10914	ENDDO
10915	ENDDO
10916	ENDDO
10917	ENDIF
10918	IF ( mode == 'xy' ) grid = 'zw'
10919
10920	CASE ( 'rad_sw_hr_xy', 'rad_sw_hr_xz', 'rad_sw_hr_yz' )
10921	IF ( av == 0 ) THEN
10922	DO i = nxl, nxr
10923	DO j = nys, nyn
10924	DO k = nzb_do, nzt_do
10925	local_pf(i,j,k) = rad_sw_hr(k,j,i)
10926	ENDDO
10927	ENDDO
10928	ENDDO
10929	ELSE
10930	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
10931	ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10932	rad_sw_hr_av = REAL( fill_value, KIND = wp )
10933	ENDIF
10934	DO i = nxl, nxr
10935	DO j = nys, nyn
10936	DO k = nzb_do, nzt_do
10937	local_pf(i,j,k) = rad_sw_hr_av(k,j,i)
10938	ENDDO
10939	ENDDO
10940	ENDDO
10941	ENDIF
10942	IF ( mode == 'xy' ) grid = 'zw'
10943
10944	CASE DEFAULT
10945	found = .FALSE.
10946	grid = 'none'
10947
10948	END SELECT
10949
10950	END SUBROUTINE radiation_data_output_2d
10951
10952
10953	!------------------------------------------------------------------------------!
10954	!
10955	! Description:
10956	! ------------
10957	!> Subroutine defining 3D output variables
10958	!------------------------------------------------------------------------------!
10959	SUBROUTINE radiation_data_output_3d( av, variable, found, local_pf, nzb_do, nzt_do )
10960
10961
10962	USE indices
10963
10964	USE kinds
10965
10966
10967	IMPLICIT NONE
10968
10969	CHARACTER (LEN=*) :: variable !<
10970
10971	INTEGER(iwp) :: av !<
10972	INTEGER(iwp) :: i, j, k, l !<
10973	INTEGER(iwp) :: nzb_do !<
10974	INTEGER(iwp) :: nzt_do !<
10975
10976	LOGICAL :: found !<
10977
10978	REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute
10979
10980	REAL(sp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !<
10981
10982	CHARACTER (len=varnamelength) :: var, surfid
10983	INTEGER(iwp) :: ids,idsint_u,idsint_l,isurf,isvf,isurfs,isurflt,ipcgb
10984	INTEGER(iwp) :: is, js, ks, istat
10985
10986	found = .TRUE.
10987	var = TRIM(variable)
10988
10989	!-- check if variable belongs to radiation related variables (starts with rad or rtm)
10990	IF ( len(var) < 3_iwp ) THEN
10991	found = .FALSE.
10992	RETURN
10993	ENDIF
10994
10995	IF ( var(1:3) /= 'rad' .AND. var(1:3) /= 'rtm' ) THEN
10996	found = .FALSE.
10997	RETURN
10998	ENDIF
10999
11000	ids = -1
11001	DO i = 0, nd-1
11002	k = len(TRIM(var))
11003	j = len(TRIM(dirname(i)))
11004	IF ( k-j+1 >= 1_iwp ) THEN
11005	IF ( TRIM(var(k-j+1:k)) == TRIM(dirname(i)) ) THEN
11006	ids = i
11007	idsint_u = dirint_u(ids)
11008	idsint_l = dirint_l(ids)
11009	var = var(:k-j)
11010	EXIT
11011	ENDIF
11012	ENDIF
11013	ENDDO
11014	IF ( ids == -1 ) THEN
11015	var = TRIM(variable)
11016	ENDIF
11017
11018	IF ( (var(1:8) == 'rtm_svf_' .OR. var(1:8) == 'rtm_dif_') .AND. len(TRIM(var)) >= 13 ) THEN
11019	!-- svf values to particular surface
11020	surfid = var(9:)
11021	i = index(surfid,'_')
11022	j = index(surfid(i+1:),'_')
11023	READ(surfid(1:i-1),*, iostat=istat ) is
11024	IF ( istat == 0 ) THEN
11025	READ(surfid(i+1:i+j-1),*, iostat=istat ) js
11026	ENDIF
11027	IF ( istat == 0 ) THEN
11028	READ(surfid(i+j+1:),*, iostat=istat ) ks
11029	ENDIF
11030	IF ( istat == 0 ) THEN
11031	var = var(1:7)
11032	ENDIF
11033	ENDIF
11034
11035	local_pf = fill_value
11036
11037	SELECT CASE ( TRIM( var ) )
11038	!-- block of large scale radiation model (e.g. RRTMG) output variables
11039	CASE ( 'rad_sw_in' )
11040	IF ( av == 0 ) THEN
11041	DO i = nxl, nxr
11042	DO j = nys, nyn
11043	DO k = nzb_do, nzt_do
11044	local_pf(i,j,k) = rad_sw_in(k,j,i)
11045	ENDDO
11046	ENDDO
11047	ENDDO
11048	ELSE
11049	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
11050	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11051	rad_sw_in_av = REAL( fill_value, KIND = wp )
11052	ENDIF
11053	DO i = nxl, nxr
11054	DO j = nys, nyn
11055	DO k = nzb_do, nzt_do
11056	local_pf(i,j,k) = rad_sw_in_av(k,j,i)
11057	ENDDO
11058	ENDDO
11059	ENDDO
11060	ENDIF
11061
11062	CASE ( 'rad_sw_out' )
11063	IF ( av == 0 ) THEN
11064	DO i = nxl, nxr
11065	DO j = nys, nyn
11066	DO k = nzb_do, nzt_do
11067	local_pf(i,j,k) = rad_sw_out(k,j,i)
11068	ENDDO
11069	ENDDO
11070	ENDDO
11071	ELSE
11072	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
11073	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11074	rad_sw_out_av = REAL( fill_value, KIND = wp )
11075	ENDIF
11076	DO i = nxl, nxr
11077	DO j = nys, nyn
11078	DO k = nzb_do, nzt_do
11079	local_pf(i,j,k) = rad_sw_out_av(k,j,i)
11080	ENDDO
11081	ENDDO
11082	ENDDO
11083	ENDIF
11084
11085	CASE ( 'rad_sw_cs_hr' )
11086	IF ( av == 0 ) THEN
11087	DO i = nxl, nxr
11088	DO j = nys, nyn
11089	DO k = nzb_do, nzt_do
11090	local_pf(i,j,k) = rad_sw_cs_hr(k,j,i)
11091	ENDDO
11092	ENDDO
11093	ENDDO
11094	ELSE
11095	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
11096	ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
11097	rad_sw_cs_hr_av = REAL( fill_value, KIND = wp )
11098	ENDIF
11099	DO i = nxl, nxr
11100	DO j = nys, nyn
11101	DO k = nzb_do, nzt_do
11102	local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i)
11103	ENDDO
11104	ENDDO
11105	ENDDO
11106	ENDIF
11107
11108	CASE ( 'rad_sw_hr' )
11109	IF ( av == 0 ) THEN
11110	DO i = nxl, nxr
11111	DO j = nys, nyn
11112	DO k = nzb_do, nzt_do
11113	local_pf(i,j,k) = rad_sw_hr(k,j,i)
11114	ENDDO
11115	ENDDO
11116	ENDDO
11117	ELSE
11118	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
11119	ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
11120	rad_sw_hr_av = REAL( fill_value, KIND = wp )
11121	ENDIF
11122	DO i = nxl, nxr
11123	DO j = nys, nyn
11124	DO k = nzb_do, nzt_do
11125	local_pf(i,j,k) = rad_sw_hr_av(k,j,i)
11126	ENDDO
11127	ENDDO
11128	ENDDO
11129	ENDIF
11130
11131	CASE ( 'rad_lw_in' )
11132	IF ( av == 0 ) THEN
11133	DO i = nxl, nxr
11134	DO j = nys, nyn
11135	DO k = nzb_do, nzt_do
11136	local_pf(i,j,k) = rad_lw_in(k,j,i)
11137	ENDDO
11138	ENDDO
11139	ENDDO
11140	ELSE
11141	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
11142	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11143	rad_lw_in_av = REAL( fill_value, KIND = wp )
11144	ENDIF
11145	DO i = nxl, nxr
11146	DO j = nys, nyn
11147	DO k = nzb_do, nzt_do
11148	local_pf(i,j,k) = rad_lw_in_av(k,j,i)
11149	ENDDO
11150	ENDDO
11151	ENDDO
11152	ENDIF
11153
11154	CASE ( 'rad_lw_out' )
11155	IF ( av == 0 ) THEN
11156	DO i = nxl, nxr
11157	DO j = nys, nyn
11158	DO k = nzb_do, nzt_do
11159	local_pf(i,j,k) = rad_lw_out(k,j,i)
11160	ENDDO
11161	ENDDO
11162	ENDDO
11163	ELSE
11164	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
11165	ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11166	rad_lw_out_av = REAL( fill_value, KIND = wp )
11167	ENDIF
11168	DO i = nxl, nxr
11169	DO j = nys, nyn
11170	DO k = nzb_do, nzt_do
11171	local_pf(i,j,k) = rad_lw_out_av(k,j,i)
11172	ENDDO
11173	ENDDO
11174	ENDDO
11175	ENDIF
11176
11177	CASE ( 'rad_lw_cs_hr' )
11178	IF ( av == 0 ) THEN
11179	DO i = nxl, nxr
11180	DO j = nys, nyn
11181	DO k = nzb_do, nzt_do
11182	local_pf(i,j,k) = rad_lw_cs_hr(k,j,i)
11183	ENDDO
11184	ENDDO
11185	ENDDO
11186	ELSE
11187	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
11188	ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
11189	rad_lw_cs_hr_av = REAL( fill_value, KIND = wp )
11190	ENDIF
11191	DO i = nxl, nxr
11192	DO j = nys, nyn
11193	DO k = nzb_do, nzt_do
11194	local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i)
11195	ENDDO
11196	ENDDO
11197	ENDDO
11198	ENDIF
11199
11200	CASE ( 'rad_lw_hr' )
11201	IF ( av == 0 ) THEN
11202	DO i = nxl, nxr
11203	DO j = nys, nyn
11204	DO k = nzb_do, nzt_do
11205	local_pf(i,j,k) = rad_lw_hr(k,j,i)
11206	ENDDO
11207	ENDDO
11208	ENDDO
11209	ELSE
11210	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
11211	ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
11212	rad_lw_hr_av = REAL( fill_value, KIND = wp )
11213	ENDIF
11214	DO i = nxl, nxr
11215	DO j = nys, nyn
11216	DO k = nzb_do, nzt_do
11217	local_pf(i,j,k) = rad_lw_hr_av(k,j,i)
11218	ENDDO
11219	ENDDO
11220	ENDDO
11221	ENDIF
11222
11223	CASE ( 'rtm_rad_net' )
11224	!-- array of complete radiation balance
11225	DO isurf = dirstart(ids), dirend(ids)
11226	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11227	IF ( av == 0 ) THEN
11228	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = &
11229	surfinsw(isurf) - surfoutsw(isurf) + surfinlw(isurf) - surfoutlw(isurf)
11230	ELSE
11231	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfradnet_av(isurf)
11232	ENDIF
11233	ENDIF
11234	ENDDO
11235
11236	CASE ( 'rtm_rad_insw' )
11237	!-- array of sw radiation falling to surface after i-th reflection
11238	DO isurf = dirstart(ids), dirend(ids)
11239	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11240	IF ( av == 0 ) THEN
11241	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinsw(isurf)
11242	ELSE
11243	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinsw_av(isurf)
11244	ENDIF
11245	ENDIF
11246	ENDDO
11247
11248	CASE ( 'rtm_rad_inlw' )
11249	!-- array of lw radiation falling to surface after i-th reflection
11250	DO isurf = dirstart(ids), dirend(ids)
11251	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11252	IF ( av == 0 ) THEN
11253	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw(isurf)
11254	ELSE
11255	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw_av(isurf)
11256	ENDIF
11257	ENDIF
11258	ENDDO
11259
11260	CASE ( 'rtm_rad_inswdir' )
11261	!-- array of direct sw radiation falling to surface from sun
11262	DO isurf = dirstart(ids), dirend(ids)
11263	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11264	IF ( av == 0 ) THEN
11265	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdir(isurf)
11266	ELSE
11267	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdir_av(isurf)
11268	ENDIF
11269	ENDIF
11270	ENDDO
11271
11272	CASE ( 'rtm_rad_inswdif' )
11273	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
11274	DO isurf = dirstart(ids), dirend(ids)
11275	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11276	IF ( av == 0 ) THEN
11277	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdif(isurf)
11278	ELSE
11279	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdif_av(isurf)
11280	ENDIF
11281	ENDIF
11282	ENDDO
11283
11284	CASE ( 'rtm_rad_inswref' )
11285	!-- array of sw radiation falling to surface from reflections
11286	DO isurf = dirstart(ids), dirend(ids)
11287	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11288	IF ( av == 0 ) THEN
11289	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = &
11290	surfinsw(isurf) - surfinswdir(isurf) - surfinswdif(isurf)
11291	ELSE
11292	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswref_av(isurf)
11293	ENDIF
11294	ENDIF
11295	ENDDO
11296
11297	CASE ( 'rtm_rad_inlwdif' )
11298	!-- array of difusion lw radiation falling to surface from sky and borders of the domain
11299	DO isurf = dirstart(ids), dirend(ids)
11300	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11301	IF ( av == 0 ) THEN
11302	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwdif(isurf)
11303	ELSE
11304	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwdif_av(isurf)
11305	ENDIF
11306	ENDIF
11307	ENDDO
11308
11309	CASE ( 'rtm_rad_inlwref' )
11310	!-- array of lw radiation falling to surface from reflections
11311	DO isurf = dirstart(ids), dirend(ids)
11312	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11313	IF ( av == 0 ) THEN
11314	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw(isurf) - surfinlwdif(isurf)
11315	ELSE
11316	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwref_av(isurf)
11317	ENDIF
11318	ENDIF
11319	ENDDO
11320
11321	CASE ( 'rtm_rad_outsw' )
11322	!-- array of sw radiation emitted from surface after i-th reflection
11323	DO isurf = dirstart(ids), dirend(ids)
11324	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11325	IF ( av == 0 ) THEN
11326	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutsw(isurf)
11327	ELSE
11328	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutsw_av(isurf)
11329	ENDIF
11330	ENDIF
11331	ENDDO
11332
11333	CASE ( 'rtm_rad_outlw' )
11334	!-- array of lw radiation emitted from surface after i-th reflection
11335	DO isurf = dirstart(ids), dirend(ids)
11336	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11337	IF ( av == 0 ) THEN
11338	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutlw(isurf)
11339	ELSE
11340	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutlw_av(isurf)
11341	ENDIF
11342	ENDIF
11343	ENDDO
11344
11345	CASE ( 'rtm_rad_ressw' )
11346	!-- average of array of residua of sw radiation absorbed in surface after last reflection
11347	DO isurf = dirstart(ids), dirend(ids)
11348	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11349	IF ( av == 0 ) THEN
11350	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfins(isurf)
11351	ELSE
11352	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfins_av(isurf)
11353	ENDIF
11354	ENDIF
11355	ENDDO
11356
11357	CASE ( 'rtm_rad_reslw' )
11358	!-- average of array of residua of lw radiation absorbed in surface after last reflection
11359	DO isurf = dirstart(ids), dirend(ids)
11360	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11361	IF ( av == 0 ) THEN
11362	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinl(isurf)
11363	ELSE
11364	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinl_av(isurf)
11365	ENDIF
11366	ENDIF
11367	ENDDO
11368
11369	CASE ( 'rtm_rad_pc_inlw' )
11370	!-- array of lw radiation absorbed by plant canopy
11371	DO ipcgb = 1, npcbl
11372	IF ( av == 0 ) THEN
11373	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinlw(ipcgb)
11374	ELSE
11375	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinlw_av(ipcgb)
11376	ENDIF
11377	ENDDO
11378
11379	CASE ( 'rtm_rad_pc_insw' )
11380	!-- array of sw radiation absorbed by plant canopy
11381	DO ipcgb = 1, npcbl
11382	IF ( av == 0 ) THEN
11383	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinsw(ipcgb)
11384	ELSE
11385	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinsw_av(ipcgb)
11386	ENDIF
11387	ENDDO
11388
11389	CASE ( 'rtm_rad_pc_inswdir' )
11390	!-- array of direct sw radiation absorbed by plant canopy
11391	DO ipcgb = 1, npcbl
11392	IF ( av == 0 ) THEN
11393	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdir(ipcgb)
11394	ELSE
11395	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdir_av(ipcgb)
11396	ENDIF
11397	ENDDO
11398
11399	CASE ( 'rtm_rad_pc_inswdif' )
11400	!-- array of diffuse sw radiation absorbed by plant canopy
11401	DO ipcgb = 1, npcbl
11402	IF ( av == 0 ) THEN
11403	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdif(ipcgb)
11404	ELSE
11405	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdif_av(ipcgb)
11406	ENDIF
11407	ENDDO
11408
11409	CASE ( 'rtm_rad_pc_inswref' )
11410	!-- array of reflected sw radiation absorbed by plant canopy
11411	DO ipcgb = 1, npcbl
11412	IF ( av == 0 ) THEN
11413	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = &
11414	pcbinsw(ipcgb) - pcbinswdir(ipcgb) - pcbinswdif(ipcgb)
11415	ELSE
11416	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswref_av(ipcgb)
11417	ENDIF
11418	ENDDO
11419
11420	CASE ( 'rtm_mrt_sw' )
11421	local_pf = REAL( fill_value, KIND = wp )
11422	IF ( av == 0 ) THEN
11423	DO l = 1, nmrtbl
11424	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinsw(l)
11425	ENDDO
11426	ELSE
11427	IF ( ALLOCATED( mrtinsw_av ) ) THEN
11428	DO l = 1, nmrtbl
11429	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinsw_av(l)
11430	ENDDO
11431	ENDIF
11432	ENDIF
11433
11434	CASE ( 'rtm_mrt_lw' )
11435	local_pf = REAL( fill_value, KIND = wp )
11436	IF ( av == 0 ) THEN
11437	DO l = 1, nmrtbl
11438	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinlw(l)
11439	ENDDO
11440	ELSE
11441	IF ( ALLOCATED( mrtinlw_av ) ) THEN
11442	DO l = 1, nmrtbl
11443	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinlw_av(l)
11444	ENDDO
11445	ENDIF
11446	ENDIF
11447
11448	CASE ( 'rtm_mrt' )
11449	local_pf = REAL( fill_value, KIND = wp )
11450	IF ( av == 0 ) THEN
11451	DO l = 1, nmrtbl
11452	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrt(l)
11453	ENDDO
11454	ELSE
11455	IF ( ALLOCATED( mrt_av ) ) THEN
11456	DO l = 1, nmrtbl
11457	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrt_av(l)
11458	ENDDO
11459	ENDIF
11460	ENDIF
11461	!
11462	!-- block of RTM output variables
11463	!-- variables are intended mainly for debugging and detailed analyse purposes
11464	CASE ( 'rtm_skyvf' )
11465	!
11466	!-- sky view factor
11467	DO isurf = dirstart(ids), dirend(ids)
11468	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11469	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = skyvf(isurf)
11470	ENDIF
11471	ENDDO
11472
11473	CASE ( 'rtm_skyvft' )
11474	!
11475	!-- sky view factor
11476	DO isurf = dirstart(ids), dirend(ids)
11477	IF ( surfl(id,isurf) == ids ) THEN
11478	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = skyvft(isurf)
11479	ENDIF
11480	ENDDO
11481
11482	CASE ( 'rtm_svf', 'rtm_dif' )
11483	!
11484	!-- shape view factors or iradiance factors to selected surface
11485	IF ( TRIM(var)=='rtm_svf' ) THEN
11486	k = 1
11487	ELSE
11488	k = 2
11489	ENDIF
11490	DO isvf = 1, nsvfl
11491	isurflt = svfsurf(1, isvf)
11492	isurfs = svfsurf(2, isvf)
11493
11494	IF ( surf(ix,isurfs) == is .AND. surf(iy,isurfs) == js .AND. surf(iz,isurfs) == ks .AND. &
11495	(surf(id,isurfs) == idsint_u .OR. surfl(id,isurfs) == idsint_l ) ) THEN
11496	!
11497	!-- correct source surface
11498	local_pf(surfl(ix,isurflt),surfl(iy,isurflt),surfl(iz,isurflt)) = svf(k,isvf)
11499	ENDIF
11500	ENDDO
11501
11502	CASE ( 'rtm_surfalb' )
11503	!
11504	!-- surface albedo
11505	DO isurf = dirstart(ids), dirend(ids)
11506	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11507	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = albedo_surf(isurf)
11508	ENDIF
11509	ENDDO
11510
11511	CASE ( 'rtm_surfemis' )
11512	!
11513	!-- surface emissivity, weighted average
11514	DO isurf = dirstart(ids), dirend(ids)
11515	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11516	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = emiss_surf(isurf)
11517	ENDIF
11518	ENDDO
11519
11520	CASE DEFAULT
11521	found = .FALSE.
11522
11523	END SELECT
11524
11525
11526	END SUBROUTINE radiation_data_output_3d
11527
11528	!------------------------------------------------------------------------------!
11529	!
11530	! Description:
11531	! ------------
11532	!> Subroutine defining masked data output
11533	!------------------------------------------------------------------------------!
11534	SUBROUTINE radiation_data_output_mask( av, variable, found, local_pf, mid )
11535
11536	USE control_parameters
11537
11538	USE indices
11539
11540	USE kinds
11541
11542
11543	IMPLICIT NONE
11544
11545	CHARACTER (LEN=*) :: variable !<
11546
11547	CHARACTER(LEN=5) :: grid !< flag to distinquish between staggered grids
11548
11549	INTEGER(iwp) :: av !<
11550	INTEGER(iwp) :: i !<
11551	INTEGER(iwp) :: j !<
11552	INTEGER(iwp) :: k !<
11553	INTEGER(iwp) :: mid !< masked output running index
11554	INTEGER(iwp) :: topo_top_index !< k index of highest horizontal surface
11555
11556	LOGICAL :: found !< true if output array was found
11557	LOGICAL :: resorted !< true if array is resorted
11558
11559
11560	REAL(wp), &
11561	DIMENSION(mask_size_l(mid,1),mask_size_l(mid,2),mask_size_l(mid,3)) :: &
11562	local_pf !<
11563
11564	REAL(wp), DIMENSION(:,:,:), POINTER :: to_be_resorted !< points to array which needs to be resorted for output
11565
11566
11567	found = .TRUE.
11568	grid = 's'
11569	resorted = .FALSE.
11570
11571	SELECT CASE ( TRIM( variable ) )
11572
11573
11574	CASE ( 'rad_lw_in' )
11575	IF ( av == 0 ) THEN
11576	to_be_resorted => rad_lw_in
11577	ELSE
11578	to_be_resorted => rad_lw_in_av
11579	ENDIF
11580
11581	CASE ( 'rad_lw_out' )
11582	IF ( av == 0 ) THEN
11583	to_be_resorted => rad_lw_out
11584	ELSE
11585	to_be_resorted => rad_lw_out_av
11586	ENDIF
11587
11588	CASE ( 'rad_lw_cs_hr' )
11589	IF ( av == 0 ) THEN
11590	to_be_resorted => rad_lw_cs_hr
11591	ELSE
11592	to_be_resorted => rad_lw_cs_hr_av
11593	ENDIF
11594
11595	CASE ( 'rad_lw_hr' )
11596	IF ( av == 0 ) THEN
11597	to_be_resorted => rad_lw_hr
11598	ELSE
11599	to_be_resorted => rad_lw_hr_av
11600	ENDIF
11601
11602	CASE ( 'rad_sw_in' )
11603	IF ( av == 0 ) THEN
11604	to_be_resorted => rad_sw_in
11605	ELSE
11606	to_be_resorted => rad_sw_in_av
11607	ENDIF
11608
11609	CASE ( 'rad_sw_out' )
11610	IF ( av == 0 ) THEN
11611	to_be_resorted => rad_sw_out
11612	ELSE
11613	to_be_resorted => rad_sw_out_av
11614	ENDIF
11615
11616	CASE ( 'rad_sw_cs_hr' )
11617	IF ( av == 0 ) THEN
11618	to_be_resorted => rad_sw_cs_hr
11619	ELSE
11620	to_be_resorted => rad_sw_cs_hr_av
11621	ENDIF
11622
11623	CASE ( 'rad_sw_hr' )
11624	IF ( av == 0 ) THEN
11625	to_be_resorted => rad_sw_hr
11626	ELSE
11627	to_be_resorted => rad_sw_hr_av
11628	ENDIF
11629
11630	CASE DEFAULT
11631	found = .FALSE.
11632
11633	END SELECT
11634
11635	!
11636	!-- Resort the array to be output, if not done above
11637	IF ( found .AND. .NOT. resorted ) THEN
11638	IF ( .NOT. mask_surface(mid) ) THEN
11639	!
11640	!-- Default masked output
11641	DO i = 1, mask_size_l(mid,1)
11642	DO j = 1, mask_size_l(mid,2)
11643	DO k = 1, mask_size_l(mid,3)
11644	local_pf(i,j,k) = to_be_resorted(mask_k(mid,k), &
11645	mask_j(mid,j),mask_i(mid,i))
11646	ENDDO
11647	ENDDO
11648	ENDDO
11649
11650	ELSE
11651	!
11652	!-- Terrain-following masked output
11653	DO i = 1, mask_size_l(mid,1)
11654	DO j = 1, mask_size_l(mid,2)
11655	!
11656	!-- Get k index of highest horizontal surface
11657	topo_top_index = topo_top_ind(mask_j(mid,j), &
11658	mask_i(mid,i), &
11659	0 )
11660	!
11661	!-- Save output array
11662	DO k = 1, mask_size_l(mid,3)
11663	local_pf(i,j,k) = to_be_resorted( &
11664	MIN( topo_top_index+mask_k(mid,k), &
11665	nzt+1 ), &
11666	mask_j(mid,j), &
11667	mask_i(mid,i) )
11668	ENDDO
11669	ENDDO
11670	ENDDO
11671
11672	ENDIF
11673	ENDIF
11674
11675
11676
11677	END SUBROUTINE radiation_data_output_mask
11678
11679
11680	!------------------------------------------------------------------------------!
11681	! Description:
11682	! ------------
11683	!> Subroutine writes local (subdomain) restart data
11684	!------------------------------------------------------------------------------!
11685	SUBROUTINE radiation_wrd_local
11686
11687
11688	IMPLICIT NONE
11689
11690
11691	IF ( ALLOCATED( rad_net_av ) ) THEN
11692	CALL wrd_write_string( 'rad_net_av' )
11693	WRITE ( 14 ) rad_net_av
11694	ENDIF
11695
11696	IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
11697	CALL wrd_write_string( 'rad_lw_in_xy_av' )
11698	WRITE ( 14 ) rad_lw_in_xy_av
11699	ENDIF
11700
11701	IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
11702	CALL wrd_write_string( 'rad_lw_out_xy_av' )
11703	WRITE ( 14 ) rad_lw_out_xy_av
11704	ENDIF
11705
11706	IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
11707	CALL wrd_write_string( 'rad_sw_in_xy_av' )
11708	WRITE ( 14 ) rad_sw_in_xy_av
11709	ENDIF
11710
11711	IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
11712	CALL wrd_write_string( 'rad_sw_out_xy_av' )
11713	WRITE ( 14 ) rad_sw_out_xy_av
11714	ENDIF
11715
11716	IF ( ALLOCATED( rad_lw_in ) ) THEN
11717	CALL wrd_write_string( 'rad_lw_in' )
11718	WRITE ( 14 ) rad_lw_in
11719	ENDIF
11720
11721	IF ( ALLOCATED( rad_lw_in_av ) ) THEN
11722	CALL wrd_write_string( 'rad_lw_in_av' )
11723	WRITE ( 14 ) rad_lw_in_av
11724	ENDIF
11725
11726	IF ( ALLOCATED( rad_lw_out ) ) THEN
11727	CALL wrd_write_string( 'rad_lw_out' )
11728	WRITE ( 14 ) rad_lw_out
11729	ENDIF
11730
11731	IF ( ALLOCATED( rad_lw_out_av) ) THEN
11732	CALL wrd_write_string( 'rad_lw_out_av' )
11733	WRITE ( 14 ) rad_lw_out_av
11734	ENDIF
11735
11736	IF ( ALLOCATED( rad_lw_cs_hr) ) THEN
11737	CALL wrd_write_string( 'rad_lw_cs_hr' )
11738	WRITE ( 14 ) rad_lw_cs_hr
11739	ENDIF
11740
11741	IF ( ALLOCATED( rad_lw_cs_hr_av) ) THEN
11742	CALL wrd_write_string( 'rad_lw_cs_hr_av' )
11743	WRITE ( 14 ) rad_lw_cs_hr_av
11744	ENDIF
11745
11746	IF ( ALLOCATED( rad_lw_hr) ) THEN
11747	CALL wrd_write_string( 'rad_lw_hr' )
11748	WRITE ( 14 ) rad_lw_hr
11749	ENDIF
11750
11751	IF ( ALLOCATED( rad_lw_hr_av) ) THEN
11752	CALL wrd_write_string( 'rad_lw_hr_av' )
11753	WRITE ( 14 ) rad_lw_hr_av
11754	ENDIF
11755
11756	IF ( ALLOCATED( rad_sw_in) ) THEN
11757	CALL wrd_write_string( 'rad_sw_in' )
11758	WRITE ( 14 ) rad_sw_in
11759	ENDIF
11760
11761	IF ( ALLOCATED( rad_sw_in_av) ) THEN
11762	CALL wrd_write_string( 'rad_sw_in_av' )
11763	WRITE ( 14 ) rad_sw_in_av
11764	ENDIF
11765
11766	IF ( ALLOCATED( rad_sw_out) ) THEN
11767	CALL wrd_write_string( 'rad_sw_out' )
11768	WRITE ( 14 ) rad_sw_out
11769	ENDIF
11770
11771	IF ( ALLOCATED( rad_sw_out_av) ) THEN
11772	CALL wrd_write_string( 'rad_sw_out_av' )
11773	WRITE ( 14 ) rad_sw_out_av
11774	ENDIF
11775
11776	IF ( ALLOCATED( rad_sw_cs_hr) ) THEN
11777	CALL wrd_write_string( 'rad_sw_cs_hr' )
11778	WRITE ( 14 ) rad_sw_cs_hr
11779	ENDIF
11780
11781	IF ( ALLOCATED( rad_sw_cs_hr_av) ) THEN
11782	CALL wrd_write_string( 'rad_sw_cs_hr_av' )
11783	WRITE ( 14 ) rad_sw_cs_hr_av
11784	ENDIF
11785
11786	IF ( ALLOCATED( rad_sw_hr) ) THEN
11787	CALL wrd_write_string( 'rad_sw_hr' )
11788	WRITE ( 14 ) rad_sw_hr
11789	ENDIF
11790
11791	IF ( ALLOCATED( rad_sw_hr_av) ) THEN
11792	CALL wrd_write_string( 'rad_sw_hr_av' )
11793	WRITE ( 14 ) rad_sw_hr_av
11794	ENDIF
11795
11796
11797	END SUBROUTINE radiation_wrd_local
11798
11799	!------------------------------------------------------------------------------!
11800	! Description:
11801	! ------------
11802	!> Subroutine reads local (subdomain) restart data
11803	!------------------------------------------------------------------------------!
11804	SUBROUTINE radiation_rrd_local( k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, &
11805	nxr_on_file, nynf, nync, nyn_on_file, nysf, &
11806	nysc, nys_on_file, tmp_2d, tmp_3d, found )
11807
11808
11809	USE control_parameters
11810
11811	USE indices
11812
11813	USE kinds
11814
11815	USE pegrid
11816
11817
11818	IMPLICIT NONE
11819
11820	INTEGER(iwp) :: k !<
11821	INTEGER(iwp) :: nxlc !<
11822	INTEGER(iwp) :: nxlf !<
11823	INTEGER(iwp) :: nxl_on_file !<
11824	INTEGER(iwp) :: nxrc !<
11825	INTEGER(iwp) :: nxrf !<
11826	INTEGER(iwp) :: nxr_on_file !<
11827	INTEGER(iwp) :: nync !<
11828	INTEGER(iwp) :: nynf !<
11829	INTEGER(iwp) :: nyn_on_file !<
11830	INTEGER(iwp) :: nysc !<
11831	INTEGER(iwp) :: nysf !<
11832	INTEGER(iwp) :: nys_on_file !<
11833
11834	LOGICAL, INTENT(OUT) :: found
11835
11836	REAL(wp), DIMENSION(nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_2d !<
11837
11838	REAL(wp), DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d !<
11839
11840	REAL(wp), DIMENSION(0:0,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d2 !<
11841
11842
11843	found = .TRUE.
11844
11845
11846	SELECT CASE ( restart_string(1:length) )
11847
11848	CASE ( 'rad_net_av' )
11849	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
11850	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
11851	ENDIF
11852	IF ( k == 1 ) READ ( 13 ) tmp_2d
11853	rad_net_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11854	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11855
11856	CASE ( 'rad_lw_in_xy_av' )
11857	IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
11858	ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
11859	ENDIF
11860	IF ( k == 1 ) READ ( 13 ) tmp_2d
11861	rad_lw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11862	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11863
11864	CASE ( 'rad_lw_out_xy_av' )
11865	IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
11866	ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
11867	ENDIF
11868	IF ( k == 1 ) READ ( 13 ) tmp_2d
11869	rad_lw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11870	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11871
11872	CASE ( 'rad_sw_in_xy_av' )
11873	IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
11874	ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
11875	ENDIF
11876	IF ( k == 1 ) READ ( 13 ) tmp_2d
11877	rad_sw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11878	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11879
11880	CASE ( 'rad_sw_out_xy_av' )
11881	IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
11882	ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
11883	ENDIF
11884	IF ( k == 1 ) READ ( 13 ) tmp_2d
11885	rad_sw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11886	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11887
11888	CASE ( 'rad_lw_in' )
11889	IF ( .NOT. ALLOCATED( rad_lw_in ) ) THEN
11890	IF ( radiation_scheme == 'clear-sky' .OR. &
11891	radiation_scheme == 'constant' .OR. &
11892	radiation_scheme == 'external' ) THEN
11893	ALLOCATE( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) )
11894	ELSE
11895	ALLOCATE( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11896	ENDIF
11897	ENDIF
11898	IF ( k == 1 ) THEN
11899	IF ( radiation_scheme == 'clear-sky' .OR. &
11900	radiation_scheme == 'constant' .OR. &
11901	radiation_scheme == 'external' ) THEN
11902	READ ( 13 ) tmp_3d2
11903	rad_lw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11904	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11905	ELSE
11906	READ ( 13 ) tmp_3d
11907	rad_lw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11908	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11909	ENDIF
11910	ENDIF
11911
11912	CASE ( 'rad_lw_in_av' )
11913	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
11914	IF ( radiation_scheme == 'clear-sky' .OR. &
11915	radiation_scheme == 'constant' .OR. &
11916	radiation_scheme == 'external' ) THEN
11917	ALLOCATE( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
11918	ELSE
11919	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11920	ENDIF
11921	ENDIF
11922	IF ( k == 1 ) THEN
11923	IF ( radiation_scheme == 'clear-sky' .OR. &
11924	radiation_scheme == 'constant' .OR. &
11925	radiation_scheme == 'external' ) THEN
11926	READ ( 13 ) tmp_3d2
11927	rad_lw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&
11928	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11929	ELSE
11930	READ ( 13 ) tmp_3d
11931	rad_lw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11932	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11933	ENDIF
11934	ENDIF
11935
11936	CASE ( 'rad_lw_out' )
11937	IF ( .NOT. ALLOCATED( rad_lw_out ) ) THEN
11938	IF ( radiation_scheme == 'clear-sky' .OR. &
11939	radiation_scheme == 'constant' .OR. &
11940	radiation_scheme == 'external' ) THEN
11941	ALLOCATE( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) )
11942	ELSE
11943	ALLOCATE( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11944	ENDIF
11945	ENDIF
11946	IF ( k == 1 ) THEN
11947	IF ( radiation_scheme == 'clear-sky' .OR. &
11948	radiation_scheme == 'constant' .OR. &
11949	radiation_scheme == 'external' ) THEN
11950	READ ( 13 ) tmp_3d2
11951	rad_lw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11952	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11953	ELSE
11954	READ ( 13 ) tmp_3d
11955	rad_lw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11956	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11957	ENDIF
11958	ENDIF
11959
11960	CASE ( 'rad_lw_out_av' )
11961	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
11962	IF ( radiation_scheme == 'clear-sky' .OR. &
11963	radiation_scheme == 'constant' .OR. &
11964	radiation_scheme == 'external' ) THEN
11965	ALLOCATE( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
11966	ELSE
11967	ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11968	ENDIF
11969	ENDIF
11970	IF ( k == 1 ) THEN
11971	IF ( radiation_scheme == 'clear-sky' .OR. &
11972	radiation_scheme == 'constant' .OR. &
11973	radiation_scheme == 'external' ) THEN
11974	READ ( 13 ) tmp_3d2
11975	rad_lw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) &
11976	= tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11977	ELSE
11978	READ ( 13 ) tmp_3d
11979	rad_lw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11980	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11981	ENDIF
11982	ENDIF
11983
11984	CASE ( 'rad_lw_cs_hr' )
11985	IF ( .NOT. ALLOCATED( rad_lw_cs_hr ) ) THEN
11986	ALLOCATE( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11987	ENDIF
11988	IF ( k == 1 ) READ ( 13 ) tmp_3d
11989	rad_lw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11990	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11991
11992	CASE ( 'rad_lw_cs_hr_av' )
11993	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
11994	ALLOCATE( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11995	ENDIF
11996	IF ( k == 1 ) READ ( 13 ) tmp_3d
11997	rad_lw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11998	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11999
12000	CASE ( 'rad_lw_hr' )
12001	IF ( .NOT. ALLOCATED( rad_lw_hr ) ) THEN
12002	ALLOCATE( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12003	ENDIF
12004	IF ( k == 1 ) READ ( 13 ) tmp_3d
12005	rad_lw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12006	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12007
12008	CASE ( 'rad_lw_hr_av' )
12009	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
12010	ALLOCATE( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12011	ENDIF
12012	IF ( k == 1 ) READ ( 13 ) tmp_3d
12013	rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12014	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12015
12016	CASE ( 'rad_sw_in' )
12017	IF ( .NOT. ALLOCATED( rad_sw_in ) ) THEN
12018	IF ( radiation_scheme == 'clear-sky' .OR. &
12019	radiation_scheme == 'constant' .OR. &
12020	radiation_scheme == 'external' ) THEN
12021	ALLOCATE( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) )
12022	ELSE
12023	ALLOCATE( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12024	ENDIF
12025	ENDIF
12026	IF ( k == 1 ) THEN
12027	IF ( radiation_scheme == 'clear-sky' .OR. &
12028	radiation_scheme == 'constant' .OR. &
12029	radiation_scheme == 'external' ) THEN
12030	READ ( 13 ) tmp_3d2
12031	rad_sw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12032	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12033	ELSE
12034	READ ( 13 ) tmp_3d
12035	rad_sw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12036	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12037	ENDIF
12038	ENDIF
12039
12040	CASE ( 'rad_sw_in_av' )
12041	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
12042	IF ( radiation_scheme == 'clear-sky' .OR. &
12043	radiation_scheme == 'constant' .OR. &
12044	radiation_scheme == 'external' ) THEN
12045	ALLOCATE( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
12046	ELSE
12047	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12048	ENDIF
12049	ENDIF
12050	IF ( k == 1 ) THEN
12051	IF ( radiation_scheme == 'clear-sky' .OR. &
12052	radiation_scheme == 'constant' .OR. &
12053	radiation_scheme == 'external' ) THEN
12054	READ ( 13 ) tmp_3d2
12055	rad_sw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&
12056	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12057	ELSE
12058	READ ( 13 ) tmp_3d
12059	rad_sw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12060	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12061	ENDIF
12062	ENDIF
12063
12064	CASE ( 'rad_sw_out' )
12065	IF ( .NOT. ALLOCATED( rad_sw_out ) ) THEN
12066	IF ( radiation_scheme == 'clear-sky' .OR. &
12067	radiation_scheme == 'constant' .OR. &
12068	radiation_scheme == 'external' ) THEN
12069	ALLOCATE( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) )
12070	ELSE
12071	ALLOCATE( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12072	ENDIF
12073	ENDIF
12074	IF ( k == 1 ) THEN
12075	IF ( radiation_scheme == 'clear-sky' .OR. &
12076	radiation_scheme == 'constant' .OR. &
12077	radiation_scheme == 'external' ) THEN
12078	READ ( 13 ) tmp_3d2
12079	rad_sw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12080	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12081	ELSE
12082	READ ( 13 ) tmp_3d
12083	rad_sw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12084	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12085	ENDIF
12086	ENDIF
12087
12088	CASE ( 'rad_sw_out_av' )
12089	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
12090	IF ( radiation_scheme == 'clear-sky' .OR. &
12091	radiation_scheme == 'constant' .OR. &
12092	radiation_scheme == 'external' ) THEN
12093	ALLOCATE( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
12094	ELSE
12095	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12096	ENDIF
12097	ENDIF
12098	IF ( k == 1 ) THEN
12099	IF ( radiation_scheme == 'clear-sky' .OR. &
12100	radiation_scheme == 'constant' .OR. &
12101	radiation_scheme == 'external' ) THEN
12102	READ ( 13 ) tmp_3d2
12103	rad_sw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) &
12104	= tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12105	ELSE
12106	READ ( 13 ) tmp_3d
12107	rad_sw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12108	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12109	ENDIF
12110	ENDIF
12111
12112	CASE ( 'rad_sw_cs_hr' )
12113	IF ( .NOT. ALLOCATED( rad_sw_cs_hr ) ) THEN
12114	ALLOCATE( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12115	ENDIF
12116	IF ( k == 1 ) READ ( 13 ) tmp_3d
12117	rad_sw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12118	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12119
12120	CASE ( 'rad_sw_cs_hr_av' )
12121	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
12122	ALLOCATE( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12123	ENDIF
12124	IF ( k == 1 ) READ ( 13 ) tmp_3d
12125	rad_sw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12126	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12127
12128	CASE ( 'rad_sw_hr' )
12129	IF ( .NOT. ALLOCATED( rad_sw_hr ) ) THEN
12130	ALLOCATE( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12131	ENDIF
12132	IF ( k == 1 ) READ ( 13 ) tmp_3d
12133	rad_sw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12134	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12135
12136	CASE ( 'rad_sw_hr_av' )
12137	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
12138	ALLOCATE( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12139	ENDIF
12140	IF ( k == 1 ) READ ( 13 ) tmp_3d
12141	rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12142	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12143
12144	CASE DEFAULT
12145
12146	found = .FALSE.
12147
12148	END SELECT
12149
12150	END SUBROUTINE radiation_rrd_local
12151
12152
12153	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 @ 4245

Download in other formats: