Home

Context Navigation

radiation_model_mod.f90 @ 4198

Last change on this file since 4198 was 4198, checked in by gronemeier, 6 years ago

Add check into radiation_check_parameters if rotation angle is set to 0. Using the radiation model for a rotated model domain is not allowed due to missing implementation within the radiation model.

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-4166
/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: 524.7 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 4198 2019-08-29 15:17:48Z gronemeier $
30	! Prohibit execution of radiation model if rotation_angle is not zero
31	!
32	! 4197 2019-08-29 14:33:32Z suehring
33	! Revise steering of surface albedo initialization when albedo_pars is provided
34	!
35	! 4190 2019-08-27 15:42:37Z suehring
36	! Implement external radiation forcing also for level-of-detail = 2
37	! (horizontally 2D radiation)
38	!
39	! 4188 2019-08-26 14:15:47Z suehring
40	! Minor adjustment in error message
41	!
42	! 4187 2019-08-26 12:43:15Z suehring
43	! - Take external radiation from root domain dynamic input if not provided for
44	! each nested domain
45	! - Combine MPI_ALLREDUCE calls to reduce mpi overhead
46	!
47	! 4182 2019-08-22 15:20:23Z scharf
48	! Corrected "Former revisions" section
49	!
50	! 4179 2019-08-21 11:16:12Z suehring
51	! Remove debug prints
52	!
53	! 4178 2019-08-21 11:13:06Z suehring
54	! External radiation forcing implemented.
55	!
56	! 4168 2019-08-16 13:50:17Z suehring
57	! Replace function get_topography_top_index by topo_top_ind
58	!
59	! 4157 2019-08-14 09:19:12Z suehring
60	! Give informative message on raytracing distance only by core zero
61	!
62	! 4148 2019-08-08 11:26:00Z suehring
63	! Comments added
64	!
65	! 4134 2019-08-02 18:39:57Z suehring
66	! Bugfix in formatted write statement
67	!
68	! 4127 2019-07-30 14:47:10Z suehring
69	! Remove unused pch_index (merge from branch resler)
70	!
71	! 4089 2019-07-11 14:30:27Z suehring
72	! - Correct level 2 initialization of spectral albedos in rrtmg branch, long- and
73	! shortwave albedos were mixed-up.
74	! - Change order of albedo_pars so that it is now consistent with the defined
75	! order of albedo_pars in PIDS
76	!
77	! 4069 2019-07-01 14:05:51Z Giersch
78	! Masked output running index mid has been introduced as a local variable to
79	! avoid runtime error (Loop variable has been modified) in time_integration
80	!
81	! 4067 2019-07-01 13:29:25Z suehring
82	! Bugfix, pass dummy string to MPI_INFO_SET (J. Resler)
83	!
84	! 4039 2019-06-18 10:32:41Z suehring
85	! Bugfix for masked data output
86	!
87	! 4008 2019-05-30 09:50:11Z moh.hefny
88	! Bugfix in check variable when a variable's string is less than 3
89	! characters is processed. All variables now are checked if they
90	! belong to radiation
91	!
92	! 3992 2019-05-22 16:49:38Z suehring
93	! Bugfix in rrtmg radiation branch in a nested run when the lowest prognistic
94	! grid points in a child domain are all inside topography
95	!
96	! 3987 2019-05-22 09:52:13Z kanani
97	! Introduce alternative switch for debug output during timestepping
98	!
99	! 3943 2019-05-02 09:50:41Z maronga
100	! Missing blank characteer added.
101	!
102	! 3900 2019-04-16 15:17:43Z suehring
103	! Fixed initialization problem
104	!
105	! 3885 2019-04-11 11:29:34Z kanani
106	! Changes related to global restructuring of location messages and introduction
107	! of additional debug messages
108	!
109	! 3881 2019-04-10 09:31:22Z suehring
110	! Output of albedo and emissivity moved from USM, bugfixes in initialization
111	! of albedo
112	!
113	! 3861 2019-04-04 06:27:41Z maronga
114	! Bugfix: factor of 4.0 required instead of 3.0 in calculation of rad_lw_out_change_0
115	!
116	! 3859 2019-04-03 20:30:31Z maronga
117	! Added some descriptions
118	!
119	! 3847 2019-04-01 14:51:44Z suehring
120	! Implement check for dt_radiation (must be > 0)
121	!
122	! 3846 2019-04-01 13:55:30Z suehring
123	! unused variable removed
124	!
125	! 3814 2019-03-26 08:40:31Z pavelkrc
126	! Change zenith(0:0) and others to scalar.
127	! Code review.
128	! Rename exported nzu, nzp and related variables due to name conflict
129	!
130	! 3771 2019-02-28 12:19:33Z raasch
131	! rrtmg preprocessor for directives moved/added, save attribute added to temporary
132	! pointers to avoid compiler warnings about outlived pointer targets,
133	! statement added to avoid compiler warning about unused variable
134	!
135	! 3769 2019-02-28 10:16:49Z moh.hefny
136	! removed unused variables and subroutine radiation_radflux_gridbox
137	!
138	! 3767 2019-02-27 08:18:02Z raasch
139	! unused variable for file index removed from rrd-subroutines parameter list
140	!
141	! 3760 2019-02-21 18:47:35Z moh.hefny
142	! Bugfix: initialized simulated_time before calculating solar position
143	! to enable restart option with reading in SVF from file(s).
144	!
145	! 3754 2019-02-19 17:02:26Z kanani
146	! (resler, pavelkrc)
147	! Bugfixes: add further required MRT factors to read/write_svf,
148	! fix for aggregating view factors to eliminate local noise in reflected
149	! irradiance at mutually close surfaces (corners, presence of trees) in the
150	! angular discretization scheme.
151	!
152	! 3752 2019-02-19 09:37:22Z resler
153	! added read/write number of MRT factors to the respective routines
154	!
155	! 3705 2019-01-29 19:56:39Z suehring
156	! Make variables that are sampled in virtual measurement module public
157	!
158	! 3704 2019-01-29 19:51:41Z suehring
159	! Some interface calls moved to module_interface + cleanup
160	!
161	! 3667 2019-01-10 14:26:24Z schwenkel
162	! Modified check for rrtmg input files
163	!
164	! 3655 2019-01-07 16:51:22Z knoop
165	! nopointer option removed
166	!
167	! 1496 2014-12-02 17:25:50Z maronga
168	! Initial revision
169	!
170	!
171	! Description:
172	! ------------
173	!> Radiation models and interfaces
174	!> @todo Replace dz(1) appropriatly to account for grid stretching
175	!> @todo move variable definitions used in radiation_init only to the subroutine
176	!> as they are no longer required after initialization.
177	!> @todo Output of full column vertical profiles used in RRTMG
178	!> @todo Output of other rrtm arrays (such as volume mixing ratios)
179	!> @todo Check for mis-used NINT() calls in raytrace_2d
180	!> RESULT: Original was correct (carefully verified formula), the change
181	!> to INT broke raytracing -- P. Krc
182	!> @todo Optimize radiation_tendency routines
183	!> @todo Consider rotated model domains (rotation_angle/=0.0)
184	!>
185	!> @note Many variables have a leading dummy dimension (0:0) in order to
186	!> match the assume-size shape expected by the RRTMG model.
187	!------------------------------------------------------------------------------!
188	MODULE radiation_model_mod
189
190	USE arrays_3d, &
191	ONLY: dzw, hyp, nc, pt, p, q, ql, u, v, w, zu, zw, exner, d_exner
192
193	USE basic_constants_and_equations_mod, &
194	ONLY: c_p, g, lv_d_cp, l_v, pi, r_d, rho_l, solar_constant, sigma_sb, &
195	barometric_formula
196
197	USE calc_mean_profile_mod, &
198	ONLY: calc_mean_profile
199
200	USE control_parameters, &
201	ONLY: cloud_droplets, coupling_char, &
202	debug_output, debug_output_timestep, debug_string, &
203	dt_3d, &
204	dz, dt_spinup, end_time, &
205	humidity, &
206	initializing_actions, io_blocks, io_group, &
207	land_surface, large_scale_forcing, &
208	latitude, longitude, lsf_surf, &
209	message_string, plant_canopy, pt_surface, &
210	rho_surface, simulated_time, spinup_time, surface_pressure, &
211	read_svf, write_svf, &
212	time_since_reference_point, urban_surface, varnamelength
213
214	USE cpulog, &
215	ONLY: cpu_log, log_point, log_point_s
216
217	USE grid_variables, &
218	ONLY: ddx, ddy, dx, dy
219
220	USE date_and_time_mod, &
221	ONLY: calc_date_and_time, d_hours_day, d_seconds_hour, d_seconds_year,&
222	day_of_year, d_seconds_year, day_of_month, day_of_year_init, &
223	init_date_and_time, month_of_year, time_utc_init, time_utc
224
225	USE indices, &
226	ONLY: nnx, nny, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, &
227	nzb, nzt, topo_top_ind
228
229	USE, INTRINSIC :: iso_c_binding
230
231	USE kinds
232
233	USE bulk_cloud_model_mod, &
234	ONLY: bulk_cloud_model, microphysics_morrison, na_init, nc_const, sigma_gc
235
236	#if defined ( __netcdf )
237	USE NETCDF
238	#endif
239
240	USE netcdf_data_input_mod, &
241	ONLY: albedo_type_f, &
242	albedo_pars_f, &
243	building_type_f, &
244	pavement_type_f, &
245	vegetation_type_f, &
246	water_type_f, &
247	char_fill, &
248	char_lod, &
249	check_existence, &
250	close_input_file, &
251	get_attribute, &
252	get_variable, &
253	inquire_num_variables, &
254	inquire_variable_names, &
255	input_file_dynamic, &
256	input_pids_dynamic, &
257	netcdf_data_input_get_dimension_length, &
258	num_var_pids, &
259	pids_id, &
260	open_read_file, &
261	real_1d_3d, &
262	vars_pids
263
264	USE plant_canopy_model_mod, &
265	ONLY: lad_s, pc_heating_rate, pc_transpiration_rate, pc_latent_rate, &
266	plant_canopy_transpiration, pcm_calc_transpiration_rate
267
268	USE pegrid
269
270	#if defined ( __rrtmg )
271	USE parrrsw, &
272	ONLY: naerec, nbndsw
273
274	USE parrrtm, &
275	ONLY: nbndlw
276
277	USE rrtmg_lw_init, &
278	ONLY: rrtmg_lw_ini
279
280	USE rrtmg_sw_init, &
281	ONLY: rrtmg_sw_ini
282
283	USE rrtmg_lw_rad, &
284	ONLY: rrtmg_lw
285
286	USE rrtmg_sw_rad, &
287	ONLY: rrtmg_sw
288	#endif
289	USE statistics, &
290	ONLY: hom
291
292	USE surface_mod, &
293	ONLY: ind_pav_green, ind_veg_wall, ind_wat_win, &
294	surf_lsm_h, surf_lsm_v, surf_type, surf_usm_h, surf_usm_v, &
295	vertical_surfaces_exist
296
297	IMPLICIT NONE
298
299	CHARACTER(10) :: radiation_scheme = 'clear-sky' ! 'constant', 'clear-sky', or 'rrtmg'
300
301	!
302	!-- Predefined Land surface classes (albedo_type) after Briegleb (1992)
303	CHARACTER(37), DIMENSION(0:33), PARAMETER :: albedo_type_name = (/ &
304	'user defined ', & ! 0
305	'ocean ', & ! 1
306	'mixed farming, tall grassland ', & ! 2
307	'tall/medium grassland ', & ! 3
308	'evergreen shrubland ', & ! 4
309	'short grassland/meadow/shrubland ', & ! 5
310	'evergreen needleleaf forest ', & ! 6
311	'mixed deciduous evergreen forest ', & ! 7
312	'deciduous forest ', & ! 8
313	'tropical evergreen broadleaved forest', & ! 9
314	'medium/tall grassland/woodland ', & ! 10
315	'desert, sandy ', & ! 11
316	'desert, rocky ', & ! 12
317	'tundra ', & ! 13
318	'land ice ', & ! 14
319	'sea ice ', & ! 15
320	'snow ', & ! 16
321	'bare soil ', & ! 17
322	'asphalt/concrete mix ', & ! 18
323	'asphalt (asphalt concrete) ', & ! 19
324	'concrete (Portland concrete) ', & ! 20
325	'sett ', & ! 21
326	'paving stones ', & ! 22
327	'cobblestone ', & ! 23
328	'metal ', & ! 24
329	'wood ', & ! 25
330	'gravel ', & ! 26
331	'fine gravel ', & ! 27
332	'pebblestone ', & ! 28
333	'woodchips ', & ! 29
334	'tartan (sports) ', & ! 30
335	'artifical turf (sports) ', & ! 31
336	'clay (sports) ', & ! 32
337	'building (dummy) ' & ! 33
338	/)
339
340	INTEGER(iwp) :: albedo_type = 9999999_iwp, & !< Albedo surface type
341	dots_rad = 0_iwp !< starting index for timeseries output
342
343	LOGICAL :: unscheduled_radiation_calls = .TRUE., & !< flag parameter indicating whether additional calls of the radiation code are allowed
344	constant_albedo = .FALSE., & !< flag parameter indicating whether the albedo may change depending on zenith
345	force_radiation_call = .FALSE., & !< flag parameter for unscheduled radiation calls
346	lw_radiation = .TRUE., & !< flag parameter indicating whether longwave radiation shall be calculated
347	radiation = .FALSE., & !< flag parameter indicating whether the radiation model is used
348	sun_up = .TRUE., & !< flag parameter indicating whether the sun is up or down
349	sw_radiation = .TRUE., & !< flag parameter indicating whether shortwave radiation shall be calculated
350	sun_direction = .FALSE., & !< flag parameter indicating whether solar direction shall be calculated
351	average_radiation = .FALSE., & !< flag to set the calculation of radiation averaging for the domain
352	radiation_interactions = .FALSE., & !< flag to activiate RTM (TRUE only if vertical urban/land surface and trees exist)
353	surface_reflections = .TRUE., & !< flag to switch the calculation of radiation interaction between surfaces.
354	!< When it switched off, only the effect of buildings and trees shadow
355	!< will be considered. However fewer SVFs are expected.
356	radiation_interactions_on = .TRUE. !< namelist flag to force RTM activiation regardless to vertical urban/land surface and trees
357
358	REAL(wp) :: albedo = 9999999.9_wp, & !< NAMELIST alpha
359	albedo_lw_dif = 9999999.9_wp, & !< NAMELIST aldif
360	albedo_lw_dir = 9999999.9_wp, & !< NAMELIST aldir
361	albedo_sw_dif = 9999999.9_wp, & !< NAMELIST asdif
362	albedo_sw_dir = 9999999.9_wp, & !< NAMELIST asdir
363	decl_1, & !< declination coef. 1
364	decl_2, & !< declination coef. 2
365	decl_3, & !< declination coef. 3
366	dt_radiation = 0.0_wp, & !< radiation model timestep
367	emissivity = 9999999.9_wp, & !< NAMELIST surface emissivity
368	lon = 0.0_wp, & !< longitude in radians
369	lat = 0.0_wp, & !< latitude in radians
370	net_radiation = 0.0_wp, & !< net radiation at surface
371	skip_time_do_radiation = 0.0_wp, & !< Radiation model is not called before this time
372	sky_trans, & !< sky transmissivity
373	time_radiation = 0.0_wp !< time since last call of radiation code
374
375
376	REAL(wp) :: cos_zenith !< cosine of solar zenith angle, also z-coordinate of solar unit vector
377	REAL(wp) :: sun_dir_lat !< y-coordinate of solar unit vector
378	REAL(wp) :: sun_dir_lon !< x-coordinate of solar unit vector
379
380	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_net_av !< average of net radiation (rad_net) at surface
381	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_xy_av !< average of incoming longwave radiation at surface
382	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_out_xy_av !< average of outgoing longwave radiation at surface
383	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_xy_av !< average of incoming shortwave radiation at surface
384	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_out_xy_av !< average of outgoing shortwave radiation at surface
385
386	REAL(wp), PARAMETER :: emissivity_atm_clsky = 0.8_wp !< emissivity of the clear-sky atmosphere
387	!
388	!-- Land surface albedos for solar zenith angle of 60degree after Briegleb (1992)
389	!-- (broadband, longwave, shortwave ): bb, lw, sw,
390	REAL(wp), DIMENSION(0:2,1:33), PARAMETER :: albedo_pars = RESHAPE( (/&
391	0.06_wp, 0.06_wp, 0.06_wp, & ! 1
392	0.19_wp, 0.28_wp, 0.09_wp, & ! 2
393	0.23_wp, 0.33_wp, 0.11_wp, & ! 3
394	0.23_wp, 0.33_wp, 0.11_wp, & ! 4
395	0.25_wp, 0.34_wp, 0.14_wp, & ! 5
396	0.14_wp, 0.22_wp, 0.06_wp, & ! 6
397	0.17_wp, 0.27_wp, 0.06_wp, & ! 7
398	0.19_wp, 0.31_wp, 0.06_wp, & ! 8
399	0.14_wp, 0.22_wp, 0.06_wp, & ! 9
400	0.18_wp, 0.28_wp, 0.06_wp, & ! 10
401	0.43_wp, 0.51_wp, 0.35_wp, & ! 11
402	0.32_wp, 0.40_wp, 0.24_wp, & ! 12
403	0.19_wp, 0.27_wp, 0.10_wp, & ! 13
404	0.77_wp, 0.65_wp, 0.90_wp, & ! 14
405	0.77_wp, 0.65_wp, 0.90_wp, & ! 15
406	0.82_wp, 0.70_wp, 0.95_wp, & ! 16
407	0.08_wp, 0.08_wp, 0.08_wp, & ! 17
408	0.17_wp, 0.17_wp, 0.17_wp, & ! 18
409	0.17_wp, 0.17_wp, 0.17_wp, & ! 19
410	0.30_wp, 0.30_wp, 0.30_wp, & ! 20
411	0.17_wp, 0.17_wp, 0.17_wp, & ! 21
412	0.17_wp, 0.17_wp, 0.17_wp, & ! 22
413	0.17_wp, 0.17_wp, 0.17_wp, & ! 23
414	0.17_wp, 0.17_wp, 0.17_wp, & ! 24
415	0.17_wp, 0.17_wp, 0.17_wp, & ! 25
416	0.17_wp, 0.17_wp, 0.17_wp, & ! 26
417	0.17_wp, 0.17_wp, 0.17_wp, & ! 27
418	0.17_wp, 0.17_wp, 0.17_wp, & ! 28
419	0.17_wp, 0.17_wp, 0.17_wp, & ! 29
420	0.17_wp, 0.17_wp, 0.17_wp, & ! 30
421	0.17_wp, 0.17_wp, 0.17_wp, & ! 31
422	0.17_wp, 0.17_wp, 0.17_wp, & ! 32
423	0.17_wp, 0.17_wp, 0.17_wp & ! 33
424	/), (/ 3, 33 /) )
425
426	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: &
427	rad_lw_cs_hr, & !< longwave clear sky radiation heating rate (K/s)
428	rad_lw_cs_hr_av, & !< average of rad_lw_cs_hr
429	rad_lw_hr, & !< longwave radiation heating rate (K/s)
430	rad_lw_hr_av, & !< average of rad_sw_hr
431	rad_lw_in, & !< incoming longwave radiation (W/m2)
432	rad_lw_in_av, & !< average of rad_lw_in
433	rad_lw_out, & !< outgoing longwave radiation (W/m2)
434	rad_lw_out_av, & !< average of rad_lw_out
435	rad_sw_cs_hr, & !< shortwave clear sky radiation heating rate (K/s)
436	rad_sw_cs_hr_av, & !< average of rad_sw_cs_hr
437	rad_sw_hr, & !< shortwave radiation heating rate (K/s)
438	rad_sw_hr_av, & !< average of rad_sw_hr
439	rad_sw_in, & !< incoming shortwave radiation (W/m2)
440	rad_sw_in_av, & !< average of rad_sw_in
441	rad_sw_out, & !< outgoing shortwave radiation (W/m2)
442	rad_sw_out_av !< average of rad_sw_out
443
444
445	!
446	!-- Variables and parameters used in RRTMG only
447	#if defined ( __rrtmg )
448	CHARACTER(LEN=12) :: rrtm_input_file = "RAD_SND_DATA" !< name of the NetCDF input file (sounding data)
449
450
451	!
452	!-- Flag parameters to be passed to RRTMG (should not be changed until ice phase in clouds is allowed)
453	INTEGER(iwp), PARAMETER :: rrtm_idrv = 1, & !< flag for longwave upward flux calculation option (0,1)
454	rrtm_inflglw = 2, & !< flag for lw cloud optical properties (0,1,2)
455	rrtm_iceflglw = 0, & !< flag for lw ice particle specifications (0,1,2,3)
456	rrtm_liqflglw = 1, & !< flag for lw liquid droplet specifications
457	rrtm_inflgsw = 2, & !< flag for sw cloud optical properties (0,1,2)
458	rrtm_iceflgsw = 0, & !< flag for sw ice particle specifications (0,1,2,3)
459	rrtm_liqflgsw = 1 !< flag for sw liquid droplet specifications
460
461	!
462	!-- The following variables should be only changed with care, as this will
463	!-- require further setting of some variables, which is currently not
464	!-- implemented (aerosols, ice phase).
465	INTEGER(iwp) :: nzt_rad, & !< upper vertical limit for radiation calculations
466	rrtm_icld = 0, & !< cloud flag (0: clear sky column, 1: cloudy column)
467	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)
468
469	INTEGER(iwp) :: nc_stat !< local variable for storin the result of netCDF calls for error message handling
470
471	LOGICAL :: snd_exists = .FALSE. !< flag parameter to check whether a user-defined input files exists
472	LOGICAL :: sw_exists = .FALSE. !< flag parameter to check whether that required rrtmg sw file exists
473	LOGICAL :: lw_exists = .FALSE. !< flag parameter to check whether that required rrtmg lw file exists
474
475
476	REAL(wp), PARAMETER :: mol_mass_air_d_wv = 1.607793_wp !< molecular weight dry air / water vapor
477
478	REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd, & !< hypostatic pressure from sounding data (hPa)
479	rrtm_tsfc, & !< dummy array for storing surface temperature
480	t_snd !< actual temperature from sounding data (hPa)
481
482	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rrtm_ccl4vmr, & !< CCL4 volume mixing ratio (g/mol)
483	rrtm_cfc11vmr, & !< CFC11 volume mixing ratio (g/mol)
484	rrtm_cfc12vmr, & !< CFC12 volume mixing ratio (g/mol)
485	rrtm_cfc22vmr, & !< CFC22 volume mixing ratio (g/mol)
486	rrtm_ch4vmr, & !< CH4 volume mixing ratio
487	rrtm_cicewp, & !< in-cloud ice water path (g/m2)
488	rrtm_cldfr, & !< cloud fraction (0,1)
489	rrtm_cliqwp, & !< in-cloud liquid water path (g/m2)
490	rrtm_co2vmr, & !< CO2 volume mixing ratio (g/mol)
491	rrtm_emis, & !< surface emissivity (0-1)
492	rrtm_h2ovmr, & !< H2O volume mixing ratio
493	rrtm_n2ovmr, & !< N2O volume mixing ratio
494	rrtm_o2vmr, & !< O2 volume mixing ratio
495	rrtm_o3vmr, & !< O3 volume mixing ratio
496	rrtm_play, & !< pressure layers (hPa, zu-grid)
497	rrtm_plev, & !< pressure layers (hPa, zw-grid)
498	rrtm_reice, & !< cloud ice effective radius (microns)
499	rrtm_reliq, & !< cloud water drop effective radius (microns)
500	rrtm_tlay, & !< actual temperature (K, zu-grid)
501	rrtm_tlev, & !< actual temperature (K, zw-grid)
502	rrtm_lwdflx, & !< RRTM output of incoming longwave radiation flux (W/m2)
503	rrtm_lwdflxc, & !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)
504	rrtm_lwuflx, & !< RRTM output of outgoing longwave radiation flux (W/m2)
505	rrtm_lwuflxc, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)
506	rrtm_lwuflx_dt, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)
507	rrtm_lwuflxc_dt,& !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)
508	rrtm_lwhr, & !< RRTM output of longwave radiation heating rate (K/d)
509	rrtm_lwhrc, & !< RRTM output of incoming longwave clear sky radiation heating rate (K/d)
510	rrtm_swdflx, & !< RRTM output of incoming shortwave radiation flux (W/m2)
511	rrtm_swdflxc, & !< RRTM output of outgoing clear sky shortwave radiation flux (W/m2)
512	rrtm_swuflx, & !< RRTM output of outgoing shortwave radiation flux (W/m2)
513	rrtm_swuflxc, & !< RRTM output of incoming clear sky shortwave radiation flux (W/m2)
514	rrtm_swhr, & !< RRTM output of shortwave radiation heating rate (K/d)
515	rrtm_swhrc, & !< RRTM output of incoming shortwave clear sky radiation heating rate (K/d)
516	rrtm_dirdflux, & !< RRTM output of incoming direct shortwave (W/m2)
517	rrtm_difdflux !< RRTM output of incoming diffuse shortwave (W/m2)
518
519	REAL(wp), DIMENSION(1) :: rrtm_aldif, & !< surface albedo for longwave diffuse radiation
520	rrtm_aldir, & !< surface albedo for longwave direct radiation
521	rrtm_asdif, & !< surface albedo for shortwave diffuse radiation
522	rrtm_asdir !< surface albedo for shortwave direct radiation
523
524	!
525	!-- Definition of arrays that are currently not used for calling RRTMG (due to setting of flag parameters)
526	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rad_lw_cs_in, & !< incoming clear sky longwave radiation (W/m2) (not used)
527	rad_lw_cs_out, & !< outgoing clear sky longwave radiation (W/m2) (not used)
528	rad_sw_cs_in, & !< incoming clear sky shortwave radiation (W/m2) (not used)
529	rad_sw_cs_out, & !< outgoing clear sky shortwave radiation (W/m2) (not used)
530	rrtm_lw_tauaer, & !< lw aerosol optical depth
531	rrtm_lw_taucld, & !< lw in-cloud optical depth
532	rrtm_sw_taucld, & !< sw in-cloud optical depth
533	rrtm_sw_ssacld, & !< sw in-cloud single scattering albedo
534	rrtm_sw_asmcld, & !< sw in-cloud asymmetry parameter
535	rrtm_sw_fsfcld, & !< sw in-cloud forward scattering fraction
536	rrtm_sw_tauaer, & !< sw aerosol optical depth
537	rrtm_sw_ssaaer, & !< sw aerosol single scattering albedo
538	rrtm_sw_asmaer, & !< sw aerosol asymmetry parameter
539	rrtm_sw_ecaer !< sw aerosol optical detph at 0.55 microns (rrtm_iaer = 6 only)
540
541	#endif
542	!
543	!-- Parameters of urban and land surface models
544	INTEGER(iwp) :: nz_urban !< number of layers of urban surface (will be calculated)
545	INTEGER(iwp) :: nz_plant !< number of layers of plant canopy (will be calculated)
546	INTEGER(iwp) :: nz_urban_b !< bottom layer of urban surface (will be calculated)
547	INTEGER(iwp) :: nz_urban_t !< top layer of urban surface (will be calculated)
548	INTEGER(iwp) :: nz_plant_t !< top layer of plant canopy (will be calculated)
549	!-- parameters of urban and land surface models
550	INTEGER(iwp), PARAMETER :: nzut_free = 3 !< number of free layers above top of of topography
551	INTEGER(iwp), PARAMETER :: ndsvf = 2 !< number of dimensions of real values in SVF
552	INTEGER(iwp), PARAMETER :: idsvf = 2 !< number of dimensions of integer values in SVF
553	INTEGER(iwp), PARAMETER :: ndcsf = 1 !< number of dimensions of real values in CSF
554	INTEGER(iwp), PARAMETER :: idcsf = 2 !< number of dimensions of integer values in CSF
555	INTEGER(iwp), PARAMETER :: kdcsf = 4 !< number of dimensions of integer values in CSF calculation array
556	INTEGER(iwp), PARAMETER :: id = 1 !< position of d-index in surfl and surf
557	INTEGER(iwp), PARAMETER :: iz = 2 !< position of k-index in surfl and surf
558	INTEGER(iwp), PARAMETER :: iy = 3 !< position of j-index in surfl and surf
559	INTEGER(iwp), PARAMETER :: ix = 4 !< position of i-index in surfl and surf
560	INTEGER(iwp), PARAMETER :: im = 5 !< position of surface m-index in surfl and surf
561	INTEGER(iwp), PARAMETER :: nidx_surf = 5 !< number of indices in surfl and surf
562
563	INTEGER(iwp), PARAMETER :: nsurf_type = 10 !< number of surf types incl. phys.(land+urban) & (atm.,sky,boundary) surfaces - 1
564
565	INTEGER(iwp), PARAMETER :: iup_u = 0 !< 0 - index of urban upward surface (ground or roof)
566	INTEGER(iwp), PARAMETER :: idown_u = 1 !< 1 - index of urban downward surface (overhanging)
567	INTEGER(iwp), PARAMETER :: inorth_u = 2 !< 2 - index of urban northward facing wall
568	INTEGER(iwp), PARAMETER :: isouth_u = 3 !< 3 - index of urban southward facing wall
569	INTEGER(iwp), PARAMETER :: ieast_u = 4 !< 4 - index of urban eastward facing wall
570	INTEGER(iwp), PARAMETER :: iwest_u = 5 !< 5 - index of urban westward facing wall
571
572	INTEGER(iwp), PARAMETER :: iup_l = 6 !< 6 - index of land upward surface (ground or roof)
573	INTEGER(iwp), PARAMETER :: inorth_l = 7 !< 7 - index of land northward facing wall
574	INTEGER(iwp), PARAMETER :: isouth_l = 8 !< 8 - index of land southward facing wall
575	INTEGER(iwp), PARAMETER :: ieast_l = 9 !< 9 - index of land eastward facing wall
576	INTEGER(iwp), PARAMETER :: iwest_l = 10 !< 10- index of land westward facing wall
577
578	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: idir = (/0, 0,0, 0,1,-1,0,0, 0,1,-1/) !< surface normal direction x indices
579	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: jdir = (/0, 0,1,-1,0, 0,0,1,-1,0, 0/) !< surface normal direction y indices
580	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: kdir = (/1,-1,0, 0,0, 0,1,0, 0,0, 0/) !< surface normal direction z indices
581	REAL(wp), DIMENSION(0:nsurf_type) :: facearea !< area of single face in respective
582	!< direction (will be calc'd)
583
584
585	!-- indices and sizes of urban and land surface models
586	INTEGER(iwp) :: startland !< start index of block of land and roof surfaces
587	INTEGER(iwp) :: endland !< end index of block of land and roof surfaces
588	INTEGER(iwp) :: nlands !< number of land and roof surfaces in local processor
589	INTEGER(iwp) :: startwall !< start index of block of wall surfaces
590	INTEGER(iwp) :: endwall !< end index of block of wall surfaces
591	INTEGER(iwp) :: nwalls !< number of wall surfaces in local processor
592
593	!-- indices needed for RTM netcdf output subroutines
594	INTEGER(iwp), PARAMETER :: nd = 5
595	CHARACTER(LEN=6), DIMENSION(0:nd-1), PARAMETER :: dirname = (/ '_roof ', '_south', '_north', '_west ', '_east ' /)
596	INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint_u = (/ iup_u, isouth_u, inorth_u, iwest_u, ieast_u /)
597	INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint_l = (/ iup_l, isouth_l, inorth_l, iwest_l, ieast_l /)
598	INTEGER(iwp), DIMENSION(0:nd-1) :: dirstart
599	INTEGER(iwp), DIMENSION(0:nd-1) :: dirend
600
601	!-- indices and sizes of urban and land surface models
602	INTEGER(iwp), DIMENSION(:,:), POINTER :: surfl !< coordinates of i-th local surface in local grid - surfl[:,k] = [d, z, y, x, m]
603	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surfl_linear !< dtto (linearly allocated array)
604	INTEGER(iwp), DIMENSION(:,:), POINTER :: surf !< coordinates of i-th surface in grid - surf[:,k] = [d, z, y, x, m]
605	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surf_linear !< dtto (linearly allocated array)
606	INTEGER(iwp) :: nsurfl !< number of all surfaces in local processor
607	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: nsurfs !< array of number of all surfaces in individual processors
608	INTEGER(iwp) :: nsurf !< global number of surfaces in index array of surfaces (nsurf = proc nsurfs)
609	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surfstart !< starts of blocks of surfaces for individual processors in array surf (indexed from 1)
610	!< respective block for particular processor is surfstart[iproc+1]+1 : surfstart[iproc+1]+nsurfs[iproc+1]
611
612	!-- block variables needed for calculation of the plant canopy model inside the urban surface model
613	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pct !< top layer of the plant canopy
614	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pch !< heights of the plant canopy
615	INTEGER(iwp) :: npcbl = 0 !< number of the plant canopy gridboxes in local processor
616	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pcbl !< k,j,i coordinates of l-th local plant canopy box pcbl[:,l] = [k, j, i]
617	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw !< array of absorbed sw radiation for local plant canopy box
618	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdir !< array of absorbed direct sw radiation for local plant canopy box
619	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdif !< array of absorbed diffusion sw radiation for local plant canopy box
620	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw !< array of absorbed lw radiation for local plant canopy box
621
622	!-- configuration parameters (they can be setup in PALM config)
623	LOGICAL :: raytrace_mpi_rma = .TRUE. !< use MPI RMA to access LAD and gridsurf from remote processes during raytracing
624	LOGICAL :: rad_angular_discretization = .TRUE.!< whether to use fixed resolution discretization of view factors for
625	!< reflected radiation (as opposed to all mutually visible pairs)
626	LOGICAL :: plant_lw_interact = .TRUE. !< whether plant canopy interacts with LW radiation (in addition to SW)
627	INTEGER(iwp) :: mrt_nlevels = 0 !< number of vertical boxes above surface for which to calculate MRT
628	LOGICAL :: mrt_skip_roof = .TRUE. !< do not calculate MRT above roof surfaces
629	LOGICAL :: mrt_include_sw = .TRUE. !< should MRT calculation include SW radiation as well?
630	LOGICAL :: mrt_geom_human = .TRUE. !< MRT direction weights simulate human body instead of a sphere
631	INTEGER(iwp) :: nrefsteps = 3 !< number of reflection steps to perform
632	REAL(wp), PARAMETER :: ext_coef = 0.6_wp !< extinction coefficient (a.k.a. alpha)
633	INTEGER(iwp), PARAMETER :: rad_version_len = 10 !< length of identification string of rad version
634	CHARACTER(rad_version_len), PARAMETER :: rad_version = 'RAD v. 3.0' !< identification of version of binary svf and restart files
635	INTEGER(iwp) :: raytrace_discrete_elevs = 40 !< number of discretization steps for elevation (nadir to zenith)
636	INTEGER(iwp) :: raytrace_discrete_azims = 80 !< number of discretization steps for azimuth (out of 360 degrees)
637	REAL(wp) :: max_raytracing_dist = -999.0_wp !< maximum distance for raytracing (in metres)
638	REAL(wp) :: min_irrf_value = 1e-6_wp !< minimum potential irradiance factor value for raytracing
639	REAL(wp), DIMENSION(1:30) :: svfnorm_report_thresh = 1e21_wp !< thresholds of SVF normalization values to report
640	INTEGER(iwp) :: svfnorm_report_num !< number of SVF normalization thresholds to report
641
642	!-- radiation related arrays to be used in radiation_interaction routine
643	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_dir !< direct sw radiation
644	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_diff !< diffusion sw radiation
645	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_diff !< diffusion lw radiation
646
647	!-- parameters required for RRTMG lower boundary condition
648	REAL(wp) :: albedo_urb !< albedo value retuned to RRTMG boundary cond.
649	REAL(wp) :: emissivity_urb !< emissivity value retuned to RRTMG boundary cond.
650	REAL(wp) :: t_rad_urb !< temperature value retuned to RRTMG boundary cond.
651
652	!-- type for calculation of svf
653	TYPE t_svf
654	INTEGER(iwp) :: isurflt !<
655	INTEGER(iwp) :: isurfs !<
656	REAL(wp) :: rsvf !<
657	REAL(wp) :: rtransp !<
658	END TYPE
659
660	!-- type for calculation of csf
661	TYPE t_csf
662	INTEGER(iwp) :: ip !<
663	INTEGER(iwp) :: itx !<
664	INTEGER(iwp) :: ity !<
665	INTEGER(iwp) :: itz !<
666	INTEGER(iwp) :: isurfs !< Idx of source face / -1 for sky
667	REAL(wp) :: rcvf !< Canopy view factor for faces /
668	!< canopy sink factor for sky (-1)
669	END TYPE
670
671	!-- arrays storing the values of USM
672	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: svfsurf !< svfsurf[:,isvf] = index of target and source surface for svf[isvf]
673	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: svf !< array of shape view factors+direct irradiation factors for local surfaces
674	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins !< array of sw radiation falling to local surface after i-th reflection
675	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl !< array of lw radiation for local surface after i-th reflection
676
677	REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvf !< array of sky view factor for each local surface
678	REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvft !< array of sky view factor including transparency for each local surface
679	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitrans !< dsidir[isvfl,i] = path transmittance of i-th
680	!< direction of direct solar irradiance per target surface
681	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitransc !< dtto per plant canopy box
682	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir !< dsidir[:,i] = unit vector of i-th
683	!< direction of direct solar irradiance
684	INTEGER(iwp) :: ndsidir !< number of apparent solar directions used
685	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: dsidir_rev !< dsidir_rev[ielev,iazim] = i for dsidir or -1 if not present
686
687	INTEGER(iwp) :: nmrtbl !< No. of local grid boxes for which MRT is calculated
688	INTEGER(iwp) :: nmrtf !< number of MRT factors for local processor
689	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mrtbl !< coordinates of i-th local MRT box - surfl[:,i] = [z, y, x]
690	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mrtfsurf !< mrtfsurf[:,imrtf] = index of target MRT box and source surface for mrtf[imrtf]
691	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtf !< array of MRT factors for each local MRT box
692	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtft !< array of MRT factors including transparency for each local MRT box
693	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtsky !< array of sky view factor for each local MRT box
694	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtskyt !< array of sky view factor including transparency for each local MRT box
695	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: mrtdsit !< array of direct solar transparencies for each local MRT box
696	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinsw !< mean SW radiant flux for each MRT box
697	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinlw !< mean LW radiant flux for each MRT box
698	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt !< mean radiant temperature for each MRT box
699	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinsw_av !< time average mean SW radiant flux for each MRT box
700	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinlw_av !< time average mean LW radiant flux for each MRT box
701	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt_av !< time average mean radiant temperature for each MRT box
702
703	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw !< array of sw radiation falling to local surface including radiation from reflections
704	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw !< array of lw radiation falling to local surface including radiation from reflections
705	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir !< array of direct sw radiation falling to local surface
706	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif !< array of diffuse sw radiation from sky and model boundary falling to local surface
707	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif !< array of diffuse lw radiation from sky and model boundary falling to local surface
708
709	!< Outward radiation is only valid for nonvirtual surfaces
710	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsl !< array of reflected sw radiation for local surface in i-th reflection
711	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutll !< array of reflected + emitted lw radiation for local surface in i-th reflection
712	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfouts !< array of reflected sw radiation for all surfaces in i-th reflection
713	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutl !< array of reflected + emitted lw radiation for all surfaces in i-th reflection
714	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlg !< global array of incoming lw radiation from plant canopy
715	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw !< array of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection
716	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw !< array of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection
717	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfemitlwl !< array of emitted lw radiation for local surface used to calculate effective surface temperature for radiation model
718
719	!-- block variables needed for calculation of the plant canopy model inside the urban surface model
720	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: csfsurf !< csfsurf[:,icsf] = index of target surface and csf grid index for csf[icsf]
721	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csf !< array of plant canopy sink fators + direct irradiation factors (transparency)
722	REAL(wp), DIMENSION(:,:,:), POINTER :: sub_lad !< subset of lad_s within urban surface, transformed to plain Z coordinate
723	REAL(wp), DIMENSION(:), POINTER :: sub_lad_g !< sub_lad globalized (used to avoid MPI RMA calls in raytracing)
724	REAL(wp) :: prototype_lad !< prototype leaf area density for computing effective optical depth
725	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nzterr, plantt !< temporary global arrays for raytracing
726	INTEGER(iwp) :: plantt_max
727
728	!-- arrays and variables for calculation of svf and csf
729	TYPE(t_svf), DIMENSION(:), POINTER :: asvf !< pointer to growing svc array
730	TYPE(t_csf), DIMENSION(:), POINTER :: acsf !< pointer to growing csf array
731	TYPE(t_svf), DIMENSION(:), POINTER :: amrtf !< pointer to growing mrtf array
732	TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: asvf1, asvf2 !< realizations of svf array
733	TYPE(t_csf), DIMENSION(:), ALLOCATABLE, TARGET :: acsf1, acsf2 !< realizations of csf array
734	TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: amrtf1, amrtf2 !< realizations of mftf array
735	INTEGER(iwp) :: nsvfla !< dimmension of array allocated for storage of svf in local processor
736	INTEGER(iwp) :: ncsfla !< dimmension of array allocated for storage of csf in local processor
737	INTEGER(iwp) :: nmrtfa !< dimmension of array allocated for storage of mrt
738	INTEGER(iwp) :: msvf, mcsf, mmrtf!< mod for swapping the growing array
739	INTEGER(iwp), PARAMETER :: gasize = 100000_iwp !< initial size of growing arrays
740	REAL(wp), PARAMETER :: grow_factor = 1.4_wp !< growth factor of growing arrays
741	INTEGER(iwp) :: nsvfl !< number of svf for local processor
742	INTEGER(iwp) :: ncsfl !< no. of csf in local processor
743	!< needed only during calc_svf but must be here because it is
744	!< shared between subroutines calc_svf and raytrace
745	INTEGER(iwp), DIMENSION(:,:,:,:), POINTER :: gridsurf !< reverse index of local surfl[d,k,j,i] (for case rad_angular_discretization)
746	INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: gridpcbl !< reverse index of local pcbl[k,j,i]
747	INTEGER(iwp), PARAMETER :: nsurf_type_u = 6 !< number of urban surf types (used in gridsurf)
748
749	!-- temporary arrays for calculation of csf in raytracing
750	INTEGER(iwp) :: maxboxesg !< max number of boxes ray can cross in the domain
751	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: boxes !< coordinates of gridboxes being crossed by ray
752	REAL(wp), DIMENSION(:), ALLOCATABLE :: crlens !< array of crossing lengths of ray for particular grid boxes
753	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: lad_ip !< array of numbers of process where lad is stored
754	#if defined( __parallel )
755	INTEGER(kind=MPI_ADDRESS_KIND), &
756	DIMENSION(:), ALLOCATABLE :: lad_disp !< array of displaycements of lad in local array of proc lad_ip
757	INTEGER(iwp) :: win_lad !< MPI RMA window for leaf area density
758	INTEGER(iwp) :: win_gridsurf !< MPI RMA window for reverse grid surface index
759	#endif
760	REAL(wp), DIMENSION(:), ALLOCATABLE :: lad_s_ray !< array of received lad_s for appropriate gridboxes crossed by ray
761	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: target_surfl
762	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: rt2_track
763	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rt2_track_lad
764	REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_track_dist
765	REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_dist
766
767	!-- arrays for time averages
768	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfradnet_av !< average of net radiation to local surface including radiation from reflections
769	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw_av !< average of sw radiation falling to local surface including radiation from reflections
770	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw_av !< average of lw radiation falling to local surface including radiation from reflections
771	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir_av !< average of direct sw radiation falling to local surface
772	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif_av !< average of diffuse sw radiation from sky and model boundary falling to local surface
773	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif_av !< average of diffuse lw radiation from sky and model boundary falling to local surface
774	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswref_av !< average of sw radiation falling to surface from reflections
775	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwref_av !< average of lw radiation falling to surface from reflections
776	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw_av !< average of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection
777	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw_av !< average of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection
778	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins_av !< average of array of residua of sw radiation absorbed in surface after last reflection
779	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl_av !< average of array of residua of lw radiation absorbed in surface after last reflection
780	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw_av !< Average of pcbinlw
781	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw_av !< Average of pcbinsw
782	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdir_av !< Average of pcbinswdir
783	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdif_av !< Average of pcbinswdif
784	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswref_av !< Average of pcbinswref
785
786
787	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
788	!-- Energy balance variables
789	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
790	!-- parameters of the land, roof and wall surfaces
791	REAL(wp), DIMENSION(:), ALLOCATABLE :: albedo_surf !< albedo of the surface
792	REAL(wp), DIMENSION(:), ALLOCATABLE :: emiss_surf !< emissivity of the wall surface
793	!
794	!-- External radiation. Depending on the given level of detail either a 1D or
795	!-- a 3D array will be allocated.
796	TYPE( real_1d_3d ) :: rad_lw_in_f !< external incoming longwave radiation, from observation or model
797	TYPE( real_1d_3d ) :: rad_sw_in_f !< external incoming shortwave radiation, from observation or model
798	TYPE( real_1d_3d ) :: rad_sw_in_dif_f !< external incoming shortwave radiation, diffuse part, from observation or model
799	TYPE( real_1d_3d ) :: time_rad_f !< time dimension for external radiation, from observation or model
800
801	INTERFACE radiation_check_data_output
802	MODULE PROCEDURE radiation_check_data_output
803	END INTERFACE radiation_check_data_output
804
805	INTERFACE radiation_check_data_output_ts
806	MODULE PROCEDURE radiation_check_data_output_ts
807	END INTERFACE radiation_check_data_output_ts
808
809	INTERFACE radiation_check_data_output_pr
810	MODULE PROCEDURE radiation_check_data_output_pr
811	END INTERFACE radiation_check_data_output_pr
812
813	INTERFACE radiation_check_parameters
814	MODULE PROCEDURE radiation_check_parameters
815	END INTERFACE radiation_check_parameters
816
817	INTERFACE radiation_clearsky
818	MODULE PROCEDURE radiation_clearsky
819	END INTERFACE radiation_clearsky
820
821	INTERFACE radiation_constant
822	MODULE PROCEDURE radiation_constant
823	END INTERFACE radiation_constant
824
825	INTERFACE radiation_control
826	MODULE PROCEDURE radiation_control
827	END INTERFACE radiation_control
828
829	INTERFACE radiation_3d_data_averaging
830	MODULE PROCEDURE radiation_3d_data_averaging
831	END INTERFACE radiation_3d_data_averaging
832
833	INTERFACE radiation_data_output_2d
834	MODULE PROCEDURE radiation_data_output_2d
835	END INTERFACE radiation_data_output_2d
836
837	INTERFACE radiation_data_output_3d
838	MODULE PROCEDURE radiation_data_output_3d
839	END INTERFACE radiation_data_output_3d
840
841	INTERFACE radiation_data_output_mask
842	MODULE PROCEDURE radiation_data_output_mask
843	END INTERFACE radiation_data_output_mask
844
845	INTERFACE radiation_define_netcdf_grid
846	MODULE PROCEDURE radiation_define_netcdf_grid
847	END INTERFACE radiation_define_netcdf_grid
848
849	INTERFACE radiation_header
850	MODULE PROCEDURE radiation_header
851	END INTERFACE radiation_header
852
853	INTERFACE radiation_init
854	MODULE PROCEDURE radiation_init
855	END INTERFACE radiation_init
856
857	INTERFACE radiation_parin
858	MODULE PROCEDURE radiation_parin
859	END INTERFACE radiation_parin
860
861	INTERFACE radiation_rrtmg
862	MODULE PROCEDURE radiation_rrtmg
863	END INTERFACE radiation_rrtmg
864
865	#if defined( __rrtmg )
866	INTERFACE radiation_tendency
867	MODULE PROCEDURE radiation_tendency
868	MODULE PROCEDURE radiation_tendency_ij
869	END INTERFACE radiation_tendency
870	#endif
871
872	INTERFACE radiation_rrd_local
873	MODULE PROCEDURE radiation_rrd_local
874	END INTERFACE radiation_rrd_local
875
876	INTERFACE radiation_wrd_local
877	MODULE PROCEDURE radiation_wrd_local
878	END INTERFACE radiation_wrd_local
879
880	INTERFACE radiation_interaction
881	MODULE PROCEDURE radiation_interaction
882	END INTERFACE radiation_interaction
883
884	INTERFACE radiation_interaction_init
885	MODULE PROCEDURE radiation_interaction_init
886	END INTERFACE radiation_interaction_init
887
888	INTERFACE radiation_presimulate_solar_pos
889	MODULE PROCEDURE radiation_presimulate_solar_pos
890	END INTERFACE radiation_presimulate_solar_pos
891
892	INTERFACE radiation_calc_svf
893	MODULE PROCEDURE radiation_calc_svf
894	END INTERFACE radiation_calc_svf
895
896	INTERFACE radiation_write_svf
897	MODULE PROCEDURE radiation_write_svf
898	END INTERFACE radiation_write_svf
899
900	INTERFACE radiation_read_svf
901	MODULE PROCEDURE radiation_read_svf
902	END INTERFACE radiation_read_svf
903
904
905	SAVE
906
907	PRIVATE
908
909	!
910	!-- Public functions / NEEDS SORTING
911	PUBLIC radiation_check_data_output, radiation_check_data_output_pr, &
912	radiation_check_data_output_ts, &
913	radiation_check_parameters, radiation_control, &
914	radiation_header, radiation_init, radiation_parin, &
915	radiation_3d_data_averaging, &
916	radiation_data_output_2d, radiation_data_output_3d, &
917	radiation_define_netcdf_grid, radiation_wrd_local, &
918	radiation_rrd_local, radiation_data_output_mask, &
919	radiation_calc_svf, radiation_write_svf, &
920	radiation_interaction, radiation_interaction_init, &
921	radiation_read_svf, radiation_presimulate_solar_pos
922
923
924	!
925	!-- Public variables and constants / NEEDS SORTING
926	PUBLIC albedo, albedo_type, decl_1, decl_2, decl_3, dots_rad, dt_radiation,&
927	emissivity, force_radiation_call, lat, lon, mrt_geom_human, &
928	mrt_include_sw, mrt_nlevels, mrtbl, mrtinsw, mrtinlw, nmrtbl, &
929	rad_net_av, radiation, radiation_scheme, rad_lw_in, &
930	rad_lw_in_av, rad_lw_out, rad_lw_out_av, &
931	rad_lw_cs_hr, rad_lw_cs_hr_av, rad_lw_hr, rad_lw_hr_av, rad_sw_in, &
932	rad_sw_in_av, rad_sw_out, rad_sw_out_av, rad_sw_cs_hr, &
933	rad_sw_cs_hr_av, rad_sw_hr, rad_sw_hr_av, solar_constant, &
934	skip_time_do_radiation, time_radiation, unscheduled_radiation_calls,&
935	cos_zenith, calc_zenith, sun_direction, sun_dir_lat, sun_dir_lon, &
936	idir, jdir, kdir, id, iz, iy, ix, &
937	iup_u, inorth_u, isouth_u, ieast_u, iwest_u, &
938	iup_l, inorth_l, isouth_l, ieast_l, iwest_l, &
939	nsurf_type, nz_urban_b, nz_urban_t, nz_urban, pch, nsurf, &
940	idsvf, ndsvf, idcsf, ndcsf, kdcsf, pct, &
941	radiation_interactions, startwall, startland, endland, endwall, &
942	skyvf, skyvft, radiation_interactions_on, average_radiation, &
943	rad_sw_in_diff, rad_sw_in_dir
944
945
946	#if defined ( __rrtmg )
947	PUBLIC radiation_tendency, rrtm_aldif, rrtm_aldir, rrtm_asdif, rrtm_asdir
948	#endif
949
950	CONTAINS
951
952
953	!------------------------------------------------------------------------------!
954	! Description:
955	! ------------
956	!> This subroutine controls the calls of the radiation schemes
957	!------------------------------------------------------------------------------!
958	SUBROUTINE radiation_control
959
960
961	IMPLICIT NONE
962
963
964	IF ( debug_output_timestep ) CALL debug_message( 'radiation_control', 'start' )
965
966
967	SELECT CASE ( TRIM( radiation_scheme ) )
968
969	CASE ( 'constant' )
970	CALL radiation_constant
971
972	CASE ( 'clear-sky' )
973	CALL radiation_clearsky
974
975	CASE ( 'rrtmg' )
976	CALL radiation_rrtmg
977
978	CASE ( 'external' )
979	!
980	!-- During spinup apply clear-sky model
981	IF ( time_since_reference_point < 0.0_wp ) THEN
982	CALL radiation_clearsky
983	ELSE
984	CALL radiation_external
985	ENDIF
986
987	CASE DEFAULT
988
989	END SELECT
990
991	IF ( debug_output_timestep ) CALL debug_message( 'radiation_control', 'end' )
992
993	END SUBROUTINE radiation_control
994
995	!------------------------------------------------------------------------------!
996	! Description:
997	! ------------
998	!> Check data output for radiation model
999	!------------------------------------------------------------------------------!
1000	SUBROUTINE radiation_check_data_output( variable, unit, i, ilen, k )
1001
1002
1003	USE control_parameters, &
1004	ONLY: data_output, message_string
1005
1006	IMPLICIT NONE
1007
1008	CHARACTER (LEN=*) :: unit !<
1009	CHARACTER (LEN=*) :: variable !<
1010
1011	INTEGER(iwp) :: i, k
1012	INTEGER(iwp) :: ilen
1013	CHARACTER(LEN=varnamelength) :: var !< TRIM(variable)
1014
1015	var = TRIM(variable)
1016
1017	IF ( len(var) < 3_iwp ) THEN
1018	unit = 'illegal'
1019	RETURN
1020	ENDIF
1021
1022	IF ( var(1:3) /= 'rad' .AND. var(1:3) /= 'rtm' ) THEN
1023	unit = 'illegal'
1024	RETURN
1025	ENDIF
1026
1027	!-- first process diractional variables
1028	IF ( var(1:12) == 'rtm_rad_net_' .OR. var(1:13) == 'rtm_rad_insw_' .OR. &
1029	var(1:13) == 'rtm_rad_inlw_' .OR. var(1:16) == 'rtm_rad_inswdir_' .OR. &
1030	var(1:16) == 'rtm_rad_inswdif_' .OR. var(1:16) == 'rtm_rad_inswref_' .OR. &
1031	var(1:16) == 'rtm_rad_inlwdif_' .OR. var(1:16) == 'rtm_rad_inlwref_' .OR. &
1032	var(1:14) == 'rtm_rad_outsw_' .OR. var(1:14) == 'rtm_rad_outlw_' .OR. &
1033	var(1:14) == 'rtm_rad_ressw_' .OR. var(1:14) == 'rtm_rad_reslw_' ) THEN
1034	IF ( .NOT. radiation ) THEN
1035	message_string = 'output of "' // TRIM( var ) // '" require'&
1036	// 's radiation = .TRUE.'
1037	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1038	ENDIF
1039	unit = 'W/m2'
1040	ELSE IF ( var(1:7) == 'rtm_svf' .OR. var(1:7) == 'rtm_dif' .OR. &
1041	var(1:9) == 'rtm_skyvf' .OR. var(1:9) == 'rtm_skyvft' .OR. &
1042	var(1:12) == 'rtm_surfalb_' .OR. var(1:13) == 'rtm_surfemis_' ) THEN
1043	IF ( .NOT. radiation ) THEN
1044	message_string = 'output of "' // TRIM( var ) // '" require'&
1045	// 's radiation = .TRUE.'
1046	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1047	ENDIF
1048	unit = '1'
1049	ELSE
1050	!-- non-directional variables
1051	SELECT CASE ( TRIM( var ) )
1052	CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_lw_in', 'rad_lw_out', &
1053	'rad_sw_cs_hr', 'rad_sw_hr', 'rad_sw_in', 'rad_sw_out' )
1054	IF ( .NOT. radiation .OR. radiation_scheme /= 'rrtmg' ) THEN
1055	message_string = '"output of "' // TRIM( var ) // '" requi' // &
1056	'res radiation = .TRUE. and ' // &
1057	'radiation_scheme = "rrtmg"'
1058	CALL message( 'check_parameters', 'PA0406', 1, 2, 0, 6, 0 )
1059	ENDIF
1060	unit = 'K/h'
1061
1062	CASE ( 'rad_net', 'rrtm_aldif', 'rrtm_aldir', 'rrtm_asdif', &
1063	'rrtm_asdir', 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', &
1064	'rad_sw_out*')
1065	IF ( i == 0 .AND. ilen == 0 .AND. k == 0) THEN
1066	! Workaround for masked output (calls with i=ilen=k=0)
1067	unit = 'illegal'
1068	RETURN
1069	ENDIF
1070	IF ( k == 0 .OR. data_output(i)(ilen-2:ilen) /= '_xy' ) THEN
1071	message_string = 'illegal value for data_output: "' // &
1072	TRIM( var ) // '" & only 2d-horizontal ' // &
1073	'cross sections are allowed for this value'
1074	CALL message( 'check_parameters', 'PA0111', 1, 2, 0, 6, 0 )
1075	ENDIF
1076	IF ( .NOT. radiation .OR. radiation_scheme /= "rrtmg" ) THEN
1077	IF ( TRIM( var ) == 'rrtm_aldif*' .OR. &
1078	TRIM( var ) == 'rrtm_aldir*' .OR. &
1079	TRIM( var ) == 'rrtm_asdif*' .OR. &
1080	TRIM( var ) == 'rrtm_asdir*' ) &
1081	THEN
1082	message_string = 'output of "' // TRIM( var ) // '" require'&
1083	// 's radiation = .TRUE. and radiation_sch'&
1084	// 'eme = "rrtmg"'
1085	CALL message( 'check_parameters', 'PA0409', 1, 2, 0, 6, 0 )
1086	ENDIF
1087	ENDIF
1088
1089	IF ( TRIM( var ) == 'rad_net*' ) unit = 'W/m2'
1090	IF ( TRIM( var ) == 'rad_lw_in*' ) unit = 'W/m2'
1091	IF ( TRIM( var ) == 'rad_lw_out*' ) unit = 'W/m2'
1092	IF ( TRIM( var ) == 'rad_sw_in*' ) unit = 'W/m2'
1093	IF ( TRIM( var ) == 'rad_sw_out*' ) unit = 'W/m2'
1094	IF ( TRIM( var ) == 'rad_sw_in' ) unit = 'W/m2'
1095	IF ( TRIM( var ) == 'rrtm_aldif*' ) unit = ''
1096	IF ( TRIM( var ) == 'rrtm_aldir*' ) unit = ''
1097	IF ( TRIM( var ) == 'rrtm_asdif*' ) unit = ''
1098	IF ( TRIM( var ) == 'rrtm_asdir*' ) unit = ''
1099
1100	CASE ( 'rtm_rad_pc_inlw', 'rtm_rad_pc_insw', 'rtm_rad_pc_inswdir', &
1101	'rtm_rad_pc_inswdif', 'rtm_rad_pc_inswref')
1102	IF ( .NOT. radiation ) THEN
1103	message_string = 'output of "' // TRIM( var ) // '" require'&
1104	// 's radiation = .TRUE.'
1105	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1106	ENDIF
1107	unit = 'W'
1108
1109	CASE ( 'rtm_mrt', 'rtm_mrt_sw', 'rtm_mrt_lw' )
1110	IF ( i == 0 .AND. ilen == 0 .AND. k == 0) THEN
1111	! Workaround for masked output (calls with i=ilen=k=0)
1112	unit = 'illegal'
1113	RETURN
1114	ENDIF
1115
1116	IF ( .NOT. radiation ) THEN
1117	message_string = 'output of "' // TRIM( var ) // '" require'&
1118	// 's radiation = .TRUE.'
1119	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1120	ENDIF
1121	IF ( mrt_nlevels == 0 ) THEN
1122	message_string = 'output of "' // TRIM( var ) // '" require'&
1123	// 's mrt_nlevels > 0'
1124	CALL message( 'check_parameters', 'PA0510', 1, 2, 0, 6, 0 )
1125	ENDIF
1126	IF ( TRIM( var ) == 'rtm_mrt_sw' .AND. .NOT. mrt_include_sw ) THEN
1127	message_string = 'output of "' // TRIM( var ) // '" require'&
1128	// 's rtm_mrt_sw = .TRUE.'
1129	CALL message( 'check_parameters', 'PA0511', 1, 2, 0, 6, 0 )
1130	ENDIF
1131	IF ( TRIM( var ) == 'rtm_mrt' ) THEN
1132	unit = 'K'
1133	ELSE
1134	unit = 'W m-2'
1135	ENDIF
1136
1137	CASE DEFAULT
1138	unit = 'illegal'
1139
1140	END SELECT
1141	ENDIF
1142
1143	END SUBROUTINE radiation_check_data_output
1144
1145
1146	!------------------------------------------------------------------------------!
1147	! Description:
1148	! ------------
1149	!> Set module-specific timeseries units and labels
1150	!------------------------------------------------------------------------------!
1151	SUBROUTINE radiation_check_data_output_ts( dots_max, dots_num )
1152
1153
1154	INTEGER(iwp), INTENT(IN) :: dots_max
1155	INTEGER(iwp), INTENT(INOUT) :: dots_num
1156
1157	!
1158	!-- Next line is just to avoid compiler warning about unused variable.
1159	IF ( dots_max == 0 ) CONTINUE
1160
1161	!
1162	!-- Temporary solution to add LSM and radiation time series to the default
1163	!-- output
1164	IF ( land_surface .OR. radiation ) THEN
1165	IF ( TRIM( radiation_scheme ) == 'rrtmg' ) THEN
1166	dots_num = dots_num + 15
1167	ELSE
1168	dots_num = dots_num + 11
1169	ENDIF
1170	ENDIF
1171
1172
1173	END SUBROUTINE radiation_check_data_output_ts
1174
1175	!------------------------------------------------------------------------------!
1176	! Description:
1177	! ------------
1178	!> Check data output of profiles for radiation model
1179	!------------------------------------------------------------------------------!
1180	SUBROUTINE radiation_check_data_output_pr( variable, var_count, unit, &
1181	dopr_unit )
1182
1183	USE arrays_3d, &
1184	ONLY: zu
1185
1186	USE control_parameters, &
1187	ONLY: data_output_pr, message_string
1188
1189	USE indices
1190
1191	USE profil_parameter
1192
1193	USE statistics
1194
1195	IMPLICIT NONE
1196
1197	CHARACTER (LEN=*) :: unit !<
1198	CHARACTER (LEN=*) :: variable !<
1199	CHARACTER (LEN=*) :: dopr_unit !< local value of dopr_unit
1200
1201	INTEGER(iwp) :: var_count !<
1202
1203	SELECT CASE ( TRIM( variable ) )
1204
1205	CASE ( 'rad_net' )
1206	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )&
1207	THEN
1208	message_string = 'data_output_pr = ' // &
1209	TRIM( data_output_pr(var_count) ) // ' is' // &
1210	'not available for radiation = .FALSE. or ' //&
1211	'radiation_scheme = "constant"'
1212	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1213	ELSE
1214	dopr_index(var_count) = 99
1215	dopr_unit = 'W/m2'
1216	hom(:,2,99,:) = SPREAD( zw, 2, statistic_regions+1 )
1217	unit = dopr_unit
1218	ENDIF
1219
1220	CASE ( 'rad_lw_in' )
1221	IF ( ( .NOT. radiation) .OR. radiation_scheme == 'constant' ) &
1222	THEN
1223	message_string = 'data_output_pr = ' // &
1224	TRIM( data_output_pr(var_count) ) // ' is' // &
1225	'not available for radiation = .FALSE. or ' //&
1226	'radiation_scheme = "constant"'
1227	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1228	ELSE
1229	dopr_index(var_count) = 100
1230	dopr_unit = 'W/m2'
1231	hom(:,2,100,:) = SPREAD( zw, 2, statistic_regions+1 )
1232	unit = dopr_unit
1233	ENDIF
1234
1235	CASE ( 'rad_lw_out' )
1236	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) &
1237	THEN
1238	message_string = 'data_output_pr = ' // &
1239	TRIM( data_output_pr(var_count) ) // ' is' // &
1240	'not available for radiation = .FALSE. or ' //&
1241	'radiation_scheme = "constant"'
1242	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1243	ELSE
1244	dopr_index(var_count) = 101
1245	dopr_unit = 'W/m2'
1246	hom(:,2,101,:) = SPREAD( zw, 2, statistic_regions+1 )
1247	unit = dopr_unit
1248	ENDIF
1249
1250	CASE ( 'rad_sw_in' )
1251	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) &
1252	THEN
1253	message_string = 'data_output_pr = ' // &
1254	TRIM( data_output_pr(var_count) ) // ' is' // &
1255	'not available for radiation = .FALSE. or ' //&
1256	'radiation_scheme = "constant"'
1257	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1258	ELSE
1259	dopr_index(var_count) = 102
1260	dopr_unit = 'W/m2'
1261	hom(:,2,102,:) = SPREAD( zw, 2, statistic_regions+1 )
1262	unit = dopr_unit
1263	ENDIF
1264
1265	CASE ( 'rad_sw_out')
1266	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )&
1267	THEN
1268	message_string = 'data_output_pr = ' // &
1269	TRIM( data_output_pr(var_count) ) // ' is' // &
1270	'not available for radiation = .FALSE. or ' //&
1271	'radiation_scheme = "constant"'
1272	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1273	ELSE
1274	dopr_index(var_count) = 103
1275	dopr_unit = 'W/m2'
1276	hom(:,2,103,:) = SPREAD( zw, 2, statistic_regions+1 )
1277	unit = dopr_unit
1278	ENDIF
1279
1280	CASE ( 'rad_lw_cs_hr' )
1281	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1282	THEN
1283	message_string = 'data_output_pr = ' // &
1284	TRIM( data_output_pr(var_count) ) // ' is' // &
1285	'not available for radiation = .FALSE. or ' //&
1286	'radiation_scheme /= "rrtmg"'
1287	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1288	ELSE
1289	dopr_index(var_count) = 104
1290	dopr_unit = 'K/h'
1291	hom(:,2,104,:) = SPREAD( zu, 2, statistic_regions+1 )
1292	unit = dopr_unit
1293	ENDIF
1294
1295	CASE ( 'rad_lw_hr' )
1296	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1297	THEN
1298	message_string = 'data_output_pr = ' // &
1299	TRIM( data_output_pr(var_count) ) // ' is' // &
1300	'not available for radiation = .FALSE. or ' //&
1301	'radiation_scheme /= "rrtmg"'
1302	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1303	ELSE
1304	dopr_index(var_count) = 105
1305	dopr_unit = 'K/h'
1306	hom(:,2,105,:) = SPREAD( zu, 2, statistic_regions+1 )
1307	unit = dopr_unit
1308	ENDIF
1309
1310	CASE ( 'rad_sw_cs_hr' )
1311	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1312	THEN
1313	message_string = 'data_output_pr = ' // &
1314	TRIM( data_output_pr(var_count) ) // ' is' // &
1315	'not available for radiation = .FALSE. or ' //&
1316	'radiation_scheme /= "rrtmg"'
1317	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1318	ELSE
1319	dopr_index(var_count) = 106
1320	dopr_unit = 'K/h'
1321	hom(:,2,106,:) = SPREAD( zu, 2, statistic_regions+1 )
1322	unit = dopr_unit
1323	ENDIF
1324
1325	CASE ( 'rad_sw_hr' )
1326	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1327	THEN
1328	message_string = 'data_output_pr = ' // &
1329	TRIM( data_output_pr(var_count) ) // ' is' // &
1330	'not available for radiation = .FALSE. or ' //&
1331	'radiation_scheme /= "rrtmg"'
1332	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1333	ELSE
1334	dopr_index(var_count) = 107
1335	dopr_unit = 'K/h'
1336	hom(:,2,107,:) = SPREAD( zu, 2, statistic_regions+1 )
1337	unit = dopr_unit
1338	ENDIF
1339
1340
1341	CASE DEFAULT
1342	unit = 'illegal'
1343
1344	END SELECT
1345
1346
1347	END SUBROUTINE radiation_check_data_output_pr
1348
1349
1350	!------------------------------------------------------------------------------!
1351	! Description:
1352	! ------------
1353	!> Check parameters routine for radiation model
1354	!------------------------------------------------------------------------------!
1355	SUBROUTINE radiation_check_parameters
1356
1357	USE control_parameters, &
1358	ONLY: land_surface, message_string, rotation_angle, urban_surface
1359
1360	USE netcdf_data_input_mod, &
1361	ONLY: input_pids_static
1362
1363	IMPLICIT NONE
1364
1365	!
1366	!-- In case no urban-surface or land-surface model is applied, usage of
1367	!-- a radiation model make no sense.
1368	IF ( .NOT. land_surface .AND. .NOT. urban_surface ) THEN
1369	message_string = 'Usage of radiation module is only allowed if ' // &
1370	'land-surface and/or urban-surface model is applied.'
1371	CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 )
1372	ENDIF
1373
1374	IF ( radiation_scheme /= 'constant' .AND. &
1375	radiation_scheme /= 'clear-sky' .AND. &
1376	radiation_scheme /= 'rrtmg' .AND. &
1377	radiation_scheme /= 'external' ) THEN
1378	message_string = 'unknown radiation_scheme = '// &
1379	TRIM( radiation_scheme )
1380	CALL message( 'check_parameters', 'PA0405', 1, 2, 0, 6, 0 )
1381	ELSEIF ( radiation_scheme == 'rrtmg' ) THEN
1382	#if ! defined ( __rrtmg )
1383	message_string = 'radiation_scheme = "rrtmg" requires ' // &
1384	'compilation of PALM with pre-processor ' // &
1385	'directive -D__rrtmg'
1386	CALL message( 'check_parameters', 'PA0407', 1, 2, 0, 6, 0 )
1387	#endif
1388	#if defined ( __rrtmg ) && ! defined( __netcdf )
1389	message_string = 'radiation_scheme = "rrtmg" requires ' // &
1390	'the use of NetCDF (preprocessor directive ' // &
1391	'-D__netcdf'
1392	CALL message( 'check_parameters', 'PA0412', 1, 2, 0, 6, 0 )
1393	#endif
1394
1395	ENDIF
1396	!
1397	!-- Checks performed only if data is given via namelist only.
1398	IF ( .NOT. input_pids_static ) THEN
1399	IF ( albedo_type == 0 .AND. albedo == 9999999.9_wp .AND. &
1400	radiation_scheme == 'clear-sky') THEN
1401	message_string = 'radiation_scheme = "clear-sky" in combination'//&
1402	'with albedo_type = 0 requires setting of'// &
1403	'albedo /= 9999999.9'
1404	CALL message( 'check_parameters', 'PA0410', 1, 2, 0, 6, 0 )
1405	ENDIF
1406
1407	IF ( albedo_type == 0 .AND. radiation_scheme == 'rrtmg' .AND. &
1408	( albedo_lw_dif == 9999999.9_wp .OR. albedo_lw_dir == 9999999.9_wp&
1409	.OR. albedo_sw_dif == 9999999.9_wp .OR. albedo_sw_dir == 9999999.9_wp&
1410	) ) THEN
1411	message_string = 'radiation_scheme = "rrtmg" in combination' // &
1412	'with albedo_type = 0 requires setting of ' // &
1413	'albedo_lw_dif /= 9999999.9' // &
1414	'albedo_lw_dir /= 9999999.9' // &
1415	'albedo_sw_dif /= 9999999.9 and' // &
1416	'albedo_sw_dir /= 9999999.9'
1417	CALL message( 'check_parameters', 'PA0411', 1, 2, 0, 6, 0 )
1418	ENDIF
1419	ENDIF
1420	!
1421	!-- Parallel rad_angular_discretization without raytrace_mpi_rma is not implemented
1422	#if defined( __parallel )
1423	IF ( rad_angular_discretization .AND. .NOT. raytrace_mpi_rma ) THEN
1424	message_string = 'rad_angular_discretization can only be used ' // &
1425	'together with raytrace_mpi_rma or when ' // &
1426	'no parallelization is applied.'
1427	CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 )
1428	ENDIF
1429	#endif
1430
1431	IF ( cloud_droplets .AND. radiation_scheme == 'rrtmg' .AND. &
1432	average_radiation ) THEN
1433	message_string = 'average_radiation = .T. with radiation_scheme'// &
1434	'= "rrtmg" in combination cloud_droplets = .T.'// &
1435	'is not implementd'
1436	CALL message( 'check_parameters', 'PA0560', 1, 2, 0, 6, 0 )
1437	ENDIF
1438
1439	!
1440	!-- Incialize svf normalization reporting histogram
1441	svfnorm_report_num = 1
1442	DO WHILE ( svfnorm_report_thresh(svfnorm_report_num) < 1e20_wp &
1443	.AND. svfnorm_report_num <= 30 )
1444	svfnorm_report_num = svfnorm_report_num + 1
1445	ENDDO
1446	svfnorm_report_num = svfnorm_report_num - 1
1447	!
1448	!-- Check for dt_radiation
1449	IF ( dt_radiation <= 0.0 ) THEN
1450	message_string = 'dt_radiation must be > 0.0'
1451	CALL message( 'check_parameters', 'PA0591', 1, 2, 0, 6, 0 )
1452	ENDIF
1453	!
1454	!-- Check rotation angle
1455	!> @todo Remove this limitation
1456	IF ( rotation_angle /= 0.0 ) THEN
1457	message_string = 'rotation of the model domain is not considered in the radiation ' // &
1458	'model.&Using rotation_angle /= 0.0 is not allowed in combination ' // &
1459	'with the radiation model at the moment!'
1460	CALL message( 'check_parameters', 'PA0675', 1, 2, 0, 6, 0 )
1461	ENDIF
1462
1463	END SUBROUTINE radiation_check_parameters
1464
1465
1466	!------------------------------------------------------------------------------!
1467	! Description:
1468	! ------------
1469	!> Initialization of the radiation model
1470	!------------------------------------------------------------------------------!
1471	SUBROUTINE radiation_init
1472
1473	IMPLICIT NONE
1474
1475	INTEGER(iwp) :: i !< running index x-direction
1476	INTEGER(iwp) :: ioff !< offset in x between surface element reference grid point in atmosphere and actual surface
1477	INTEGER(iwp) :: j !< running index y-direction
1478	INTEGER(iwp) :: joff !< offset in y between surface element reference grid point in atmosphere and actual surface
1479	INTEGER(iwp) :: l !< running index for orientation of vertical surfaces
1480	INTEGER(iwp) :: m !< running index for surface elements
1481	INTEGER(iwp) :: ntime = 0 !< number of available external radiation timesteps
1482	#if defined( __rrtmg )
1483	INTEGER(iwp) :: ind_type !< running index for subgrid-surface tiles
1484	#endif
1485	LOGICAL :: radiation_input_root_domain !< flag indicating the existence of a dynamic input file for the root domain
1486
1487
1488	IF ( debug_output ) CALL debug_message( 'radiation_init', 'start' )
1489	!
1490	!-- Activate radiation_interactions according to the existence of vertical surfaces and/or trees.
1491	!-- The namelist parameter radiation_interactions_on can override this behavior.
1492	!-- (This check cannot be performed in check_parameters, because vertical_surfaces_exist is first set in
1493	!-- init_surface_arrays.)
1494	IF ( radiation_interactions_on ) THEN
1495	IF ( vertical_surfaces_exist .OR. plant_canopy ) THEN
1496	radiation_interactions = .TRUE.
1497	average_radiation = .TRUE.
1498	ELSE
1499	radiation_interactions_on = .FALSE. !< reset namelist parameter: no interactions
1500	!< calculations necessary in case of flat surface
1501	ENDIF
1502	ELSEIF ( vertical_surfaces_exist .OR. plant_canopy ) THEN
1503	message_string = 'radiation_interactions_on is set to .FALSE. although ' // &
1504	'vertical surfaces and/or trees exist. The model will run ' // &
1505	'without RTM (no shadows, no radiation reflections)'
1506	CALL message( 'init_3d_model', 'PA0348', 0, 1, 0, 6, 0 )
1507	ENDIF
1508	!
1509	!-- If required, initialize radiation interactions between surfaces
1510	!-- via sky-view factors. This must be done before radiation is initialized.
1511	IF ( radiation_interactions ) CALL radiation_interaction_init
1512	!
1513	!-- Allocate array for storing the surface net radiation
1514	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_net ) .AND. &
1515	surf_lsm_h%ns > 0 ) THEN
1516	ALLOCATE( surf_lsm_h%rad_net(1:surf_lsm_h%ns) )
1517	surf_lsm_h%rad_net = 0.0_wp
1518	ENDIF
1519	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_net ) .AND. &
1520	surf_usm_h%ns > 0 ) THEN
1521	ALLOCATE( surf_usm_h%rad_net(1:surf_usm_h%ns) )
1522	surf_usm_h%rad_net = 0.0_wp
1523	ENDIF
1524	DO l = 0, 3
1525	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_net ) .AND. &
1526	surf_lsm_v(l)%ns > 0 ) THEN
1527	ALLOCATE( surf_lsm_v(l)%rad_net(1:surf_lsm_v(l)%ns) )
1528	surf_lsm_v(l)%rad_net = 0.0_wp
1529	ENDIF
1530	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_net ) .AND. &
1531	surf_usm_v(l)%ns > 0 ) THEN
1532	ALLOCATE( surf_usm_v(l)%rad_net(1:surf_usm_v(l)%ns) )
1533	surf_usm_v(l)%rad_net = 0.0_wp
1534	ENDIF
1535	ENDDO
1536
1537
1538	!
1539	!-- Allocate array for storing the surface longwave (out) radiation change
1540	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_lw_out_change_0 ) .AND. &
1541	surf_lsm_h%ns > 0 ) THEN
1542	ALLOCATE( surf_lsm_h%rad_lw_out_change_0(1:surf_lsm_h%ns) )
1543	surf_lsm_h%rad_lw_out_change_0 = 0.0_wp
1544	ENDIF
1545	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_lw_out_change_0 ) .AND. &
1546	surf_usm_h%ns > 0 ) THEN
1547	ALLOCATE( surf_usm_h%rad_lw_out_change_0(1:surf_usm_h%ns) )
1548	surf_usm_h%rad_lw_out_change_0 = 0.0_wp
1549	ENDIF
1550	DO l = 0, 3
1551	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_lw_out_change_0 ) .AND. &
1552	surf_lsm_v(l)%ns > 0 ) THEN
1553	ALLOCATE( surf_lsm_v(l)%rad_lw_out_change_0(1:surf_lsm_v(l)%ns) )
1554	surf_lsm_v(l)%rad_lw_out_change_0 = 0.0_wp
1555	ENDIF
1556	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_lw_out_change_0 ) .AND. &
1557	surf_usm_v(l)%ns > 0 ) THEN
1558	ALLOCATE( surf_usm_v(l)%rad_lw_out_change_0(1:surf_usm_v(l)%ns) )
1559	surf_usm_v(l)%rad_lw_out_change_0 = 0.0_wp
1560	ENDIF
1561	ENDDO
1562
1563	!
1564	!-- Allocate surface arrays for incoming/outgoing short/longwave radiation
1565	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_sw_in ) .AND. &
1566	surf_lsm_h%ns > 0 ) THEN
1567	ALLOCATE( surf_lsm_h%rad_sw_in(1:surf_lsm_h%ns) )
1568	ALLOCATE( surf_lsm_h%rad_sw_out(1:surf_lsm_h%ns) )
1569	ALLOCATE( surf_lsm_h%rad_sw_dir(1:surf_lsm_h%ns) )
1570	ALLOCATE( surf_lsm_h%rad_sw_dif(1:surf_lsm_h%ns) )
1571	ALLOCATE( surf_lsm_h%rad_sw_ref(1:surf_lsm_h%ns) )
1572	ALLOCATE( surf_lsm_h%rad_sw_res(1:surf_lsm_h%ns) )
1573	ALLOCATE( surf_lsm_h%rad_lw_in(1:surf_lsm_h%ns) )
1574	ALLOCATE( surf_lsm_h%rad_lw_out(1:surf_lsm_h%ns) )
1575	ALLOCATE( surf_lsm_h%rad_lw_dif(1:surf_lsm_h%ns) )
1576	ALLOCATE( surf_lsm_h%rad_lw_ref(1:surf_lsm_h%ns) )
1577	ALLOCATE( surf_lsm_h%rad_lw_res(1:surf_lsm_h%ns) )
1578	surf_lsm_h%rad_sw_in = 0.0_wp
1579	surf_lsm_h%rad_sw_out = 0.0_wp
1580	surf_lsm_h%rad_sw_dir = 0.0_wp
1581	surf_lsm_h%rad_sw_dif = 0.0_wp
1582	surf_lsm_h%rad_sw_ref = 0.0_wp
1583	surf_lsm_h%rad_sw_res = 0.0_wp
1584	surf_lsm_h%rad_lw_in = 0.0_wp
1585	surf_lsm_h%rad_lw_out = 0.0_wp
1586	surf_lsm_h%rad_lw_dif = 0.0_wp
1587	surf_lsm_h%rad_lw_ref = 0.0_wp
1588	surf_lsm_h%rad_lw_res = 0.0_wp
1589	ENDIF
1590	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_sw_in ) .AND. &
1591	surf_usm_h%ns > 0 ) THEN
1592	ALLOCATE( surf_usm_h%rad_sw_in(1:surf_usm_h%ns) )
1593	ALLOCATE( surf_usm_h%rad_sw_out(1:surf_usm_h%ns) )
1594	ALLOCATE( surf_usm_h%rad_sw_dir(1:surf_usm_h%ns) )
1595	ALLOCATE( surf_usm_h%rad_sw_dif(1:surf_usm_h%ns) )
1596	ALLOCATE( surf_usm_h%rad_sw_ref(1:surf_usm_h%ns) )
1597	ALLOCATE( surf_usm_h%rad_sw_res(1:surf_usm_h%ns) )
1598	ALLOCATE( surf_usm_h%rad_lw_in(1:surf_usm_h%ns) )
1599	ALLOCATE( surf_usm_h%rad_lw_out(1:surf_usm_h%ns) )
1600	ALLOCATE( surf_usm_h%rad_lw_dif(1:surf_usm_h%ns) )
1601	ALLOCATE( surf_usm_h%rad_lw_ref(1:surf_usm_h%ns) )
1602	ALLOCATE( surf_usm_h%rad_lw_res(1:surf_usm_h%ns) )
1603	surf_usm_h%rad_sw_in = 0.0_wp
1604	surf_usm_h%rad_sw_out = 0.0_wp
1605	surf_usm_h%rad_sw_dir = 0.0_wp
1606	surf_usm_h%rad_sw_dif = 0.0_wp
1607	surf_usm_h%rad_sw_ref = 0.0_wp
1608	surf_usm_h%rad_sw_res = 0.0_wp
1609	surf_usm_h%rad_lw_in = 0.0_wp
1610	surf_usm_h%rad_lw_out = 0.0_wp
1611	surf_usm_h%rad_lw_dif = 0.0_wp
1612	surf_usm_h%rad_lw_ref = 0.0_wp
1613	surf_usm_h%rad_lw_res = 0.0_wp
1614	ENDIF
1615	DO l = 0, 3
1616	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_sw_in ) .AND. &
1617	surf_lsm_v(l)%ns > 0 ) THEN
1618	ALLOCATE( surf_lsm_v(l)%rad_sw_in(1:surf_lsm_v(l)%ns) )
1619	ALLOCATE( surf_lsm_v(l)%rad_sw_out(1:surf_lsm_v(l)%ns) )
1620	ALLOCATE( surf_lsm_v(l)%rad_sw_dir(1:surf_lsm_v(l)%ns) )
1621	ALLOCATE( surf_lsm_v(l)%rad_sw_dif(1:surf_lsm_v(l)%ns) )
1622	ALLOCATE( surf_lsm_v(l)%rad_sw_ref(1:surf_lsm_v(l)%ns) )
1623	ALLOCATE( surf_lsm_v(l)%rad_sw_res(1:surf_lsm_v(l)%ns) )
1624
1625	ALLOCATE( surf_lsm_v(l)%rad_lw_in(1:surf_lsm_v(l)%ns) )
1626	ALLOCATE( surf_lsm_v(l)%rad_lw_out(1:surf_lsm_v(l)%ns) )
1627	ALLOCATE( surf_lsm_v(l)%rad_lw_dif(1:surf_lsm_v(l)%ns) )
1628	ALLOCATE( surf_lsm_v(l)%rad_lw_ref(1:surf_lsm_v(l)%ns) )
1629	ALLOCATE( surf_lsm_v(l)%rad_lw_res(1:surf_lsm_v(l)%ns) )
1630
1631	surf_lsm_v(l)%rad_sw_in = 0.0_wp
1632	surf_lsm_v(l)%rad_sw_out = 0.0_wp
1633	surf_lsm_v(l)%rad_sw_dir = 0.0_wp
1634	surf_lsm_v(l)%rad_sw_dif = 0.0_wp
1635	surf_lsm_v(l)%rad_sw_ref = 0.0_wp
1636	surf_lsm_v(l)%rad_sw_res = 0.0_wp
1637
1638	surf_lsm_v(l)%rad_lw_in = 0.0_wp
1639	surf_lsm_v(l)%rad_lw_out = 0.0_wp
1640	surf_lsm_v(l)%rad_lw_dif = 0.0_wp
1641	surf_lsm_v(l)%rad_lw_ref = 0.0_wp
1642	surf_lsm_v(l)%rad_lw_res = 0.0_wp
1643	ENDIF
1644	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_sw_in ) .AND. &
1645	surf_usm_v(l)%ns > 0 ) THEN
1646	ALLOCATE( surf_usm_v(l)%rad_sw_in(1:surf_usm_v(l)%ns) )
1647	ALLOCATE( surf_usm_v(l)%rad_sw_out(1:surf_usm_v(l)%ns) )
1648	ALLOCATE( surf_usm_v(l)%rad_sw_dir(1:surf_usm_v(l)%ns) )
1649	ALLOCATE( surf_usm_v(l)%rad_sw_dif(1:surf_usm_v(l)%ns) )
1650	ALLOCATE( surf_usm_v(l)%rad_sw_ref(1:surf_usm_v(l)%ns) )
1651	ALLOCATE( surf_usm_v(l)%rad_sw_res(1:surf_usm_v(l)%ns) )
1652	ALLOCATE( surf_usm_v(l)%rad_lw_in(1:surf_usm_v(l)%ns) )
1653	ALLOCATE( surf_usm_v(l)%rad_lw_out(1:surf_usm_v(l)%ns) )
1654	ALLOCATE( surf_usm_v(l)%rad_lw_dif(1:surf_usm_v(l)%ns) )
1655	ALLOCATE( surf_usm_v(l)%rad_lw_ref(1:surf_usm_v(l)%ns) )
1656	ALLOCATE( surf_usm_v(l)%rad_lw_res(1:surf_usm_v(l)%ns) )
1657	surf_usm_v(l)%rad_sw_in = 0.0_wp
1658	surf_usm_v(l)%rad_sw_out = 0.0_wp
1659	surf_usm_v(l)%rad_sw_dir = 0.0_wp
1660	surf_usm_v(l)%rad_sw_dif = 0.0_wp
1661	surf_usm_v(l)%rad_sw_ref = 0.0_wp
1662	surf_usm_v(l)%rad_sw_res = 0.0_wp
1663	surf_usm_v(l)%rad_lw_in = 0.0_wp
1664	surf_usm_v(l)%rad_lw_out = 0.0_wp
1665	surf_usm_v(l)%rad_lw_dif = 0.0_wp
1666	surf_usm_v(l)%rad_lw_ref = 0.0_wp
1667	surf_usm_v(l)%rad_lw_res = 0.0_wp
1668	ENDIF
1669	ENDDO
1670	!
1671	!-- Fix net radiation in case of radiation_scheme = 'constant'
1672	IF ( radiation_scheme == 'constant' ) THEN
1673	IF ( ALLOCATED( surf_lsm_h%rad_net ) ) &
1674	surf_lsm_h%rad_net = net_radiation
1675	IF ( ALLOCATED( surf_usm_h%rad_net ) ) &
1676	surf_usm_h%rad_net = net_radiation
1677	!
1678	!-- Todo: weight with inclination angle
1679	DO l = 0, 3
1680	IF ( ALLOCATED( surf_lsm_v(l)%rad_net ) ) &
1681	surf_lsm_v(l)%rad_net = net_radiation
1682	IF ( ALLOCATED( surf_usm_v(l)%rad_net ) ) &
1683	surf_usm_v(l)%rad_net = net_radiation
1684	ENDDO
1685	! radiation = .FALSE.
1686	!
1687	!-- Calculate orbital constants
1688	ELSE
1689	decl_1 = SIN(23.45_wp * pi / 180.0_wp)
1690	decl_2 = 2.0_wp * pi / 365.0_wp
1691	decl_3 = decl_2 * 81.0_wp
1692	lat = latitude * pi / 180.0_wp
1693	lon = longitude * pi / 180.0_wp
1694	ENDIF
1695
1696	IF ( radiation_scheme == 'clear-sky' .OR. &
1697	radiation_scheme == 'constant' .OR. &
1698	radiation_scheme == 'external' ) THEN
1699	!
1700	!-- Allocate arrays for incoming/outgoing short/longwave radiation
1701	IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN
1702	ALLOCATE ( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) )
1703	ENDIF
1704	IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN
1705	ALLOCATE ( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) )
1706	ENDIF
1707
1708	IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN
1709	ALLOCATE ( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) )
1710	ENDIF
1711	IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN
1712	ALLOCATE ( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) )
1713	ENDIF
1714
1715	!
1716	!-- Allocate average arrays for incoming/outgoing short/longwave radiation
1717	IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN
1718	ALLOCATE ( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
1719	ENDIF
1720	IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN
1721	ALLOCATE ( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
1722	ENDIF
1723
1724	IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN
1725	ALLOCATE ( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
1726	ENDIF
1727	IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN
1728	ALLOCATE ( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
1729	ENDIF
1730	!
1731	!-- Allocate arrays for broadband albedo, and level 1 initialization
1732	!-- via namelist paramter, unless not already allocated.
1733	IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) THEN
1734	ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) )
1735	surf_lsm_h%albedo = albedo
1736	ENDIF
1737	IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) THEN
1738	ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) )
1739	surf_usm_h%albedo = albedo
1740	ENDIF
1741
1742	DO l = 0, 3
1743	IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) THEN
1744	ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) )
1745	surf_lsm_v(l)%albedo = albedo
1746	ENDIF
1747	IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) THEN
1748	ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) )
1749	surf_usm_v(l)%albedo = albedo
1750	ENDIF
1751	ENDDO
1752	!
1753	!-- Level 2 initialization of broadband albedo via given albedo_type.
1754	!-- Only if albedo_type is non-zero. In case of urban surface and
1755	!-- input data is read from ASCII file, albedo_type will be zero, so that
1756	!-- albedo won't be overwritten.
1757	DO m = 1, surf_lsm_h%ns
1758	IF ( surf_lsm_h%albedo_type(ind_veg_wall,m) /= 0 ) &
1759	surf_lsm_h%albedo(ind_veg_wall,m) = &
1760	albedo_pars(0,surf_lsm_h%albedo_type(ind_veg_wall,m))
1761	IF ( surf_lsm_h%albedo_type(ind_pav_green,m) /= 0 ) &
1762	surf_lsm_h%albedo(ind_pav_green,m) = &
1763	albedo_pars(0,surf_lsm_h%albedo_type(ind_pav_green,m))
1764	IF ( surf_lsm_h%albedo_type(ind_wat_win,m) /= 0 ) &
1765	surf_lsm_h%albedo(ind_wat_win,m) = &
1766	albedo_pars(0,surf_lsm_h%albedo_type(ind_wat_win,m))
1767	ENDDO
1768	DO m = 1, surf_usm_h%ns
1769	IF ( surf_usm_h%albedo_type(ind_veg_wall,m) /= 0 ) &
1770	surf_usm_h%albedo(ind_veg_wall,m) = &
1771	albedo_pars(0,surf_usm_h%albedo_type(ind_veg_wall,m))
1772	IF ( surf_usm_h%albedo_type(ind_pav_green,m) /= 0 ) &
1773	surf_usm_h%albedo(ind_pav_green,m) = &
1774	albedo_pars(0,surf_usm_h%albedo_type(ind_pav_green,m))
1775	IF ( surf_usm_h%albedo_type(ind_wat_win,m) /= 0 ) &
1776	surf_usm_h%albedo(ind_wat_win,m) = &
1777	albedo_pars(0,surf_usm_h%albedo_type(ind_wat_win,m))
1778	ENDDO
1779
1780	DO l = 0, 3
1781	DO m = 1, surf_lsm_v(l)%ns
1782	IF ( surf_lsm_v(l)%albedo_type(ind_veg_wall,m) /= 0 ) &
1783	surf_lsm_v(l)%albedo(ind_veg_wall,m) = &
1784	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_veg_wall,m))
1785	IF ( surf_lsm_v(l)%albedo_type(ind_pav_green,m) /= 0 ) &
1786	surf_lsm_v(l)%albedo(ind_pav_green,m) = &
1787	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_pav_green,m))
1788	IF ( surf_lsm_v(l)%albedo_type(ind_wat_win,m) /= 0 ) &
1789	surf_lsm_v(l)%albedo(ind_wat_win,m) = &
1790	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_wat_win,m))
1791	ENDDO
1792	DO m = 1, surf_usm_v(l)%ns
1793	IF ( surf_usm_v(l)%albedo_type(ind_veg_wall,m) /= 0 ) &
1794	surf_usm_v(l)%albedo(ind_veg_wall,m) = &
1795	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_veg_wall,m))
1796	IF ( surf_usm_v(l)%albedo_type(ind_pav_green,m) /= 0 ) &
1797	surf_usm_v(l)%albedo(ind_pav_green,m) = &
1798	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_pav_green,m))
1799	IF ( surf_usm_v(l)%albedo_type(ind_wat_win,m) /= 0 ) &
1800	surf_usm_v(l)%albedo(ind_wat_win,m) = &
1801	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_wat_win,m))
1802	ENDDO
1803	ENDDO
1804
1805	!
1806	!-- Level 3 initialization at grid points where albedo type is zero.
1807	!-- This case, albedo is taken from file. In case of constant radiation
1808	!-- or clear sky, only broadband albedo is given.
1809	IF ( albedo_pars_f%from_file ) THEN
1810	!
1811	!-- Horizontal surfaces
1812	DO m = 1, surf_lsm_h%ns
1813	i = surf_lsm_h%i(m)
1814	j = surf_lsm_h%j(m)
1815	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1816	surf_lsm_h%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1817	surf_lsm_h%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1818	surf_lsm_h%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1819	ENDIF
1820	ENDDO
1821	DO m = 1, surf_usm_h%ns
1822	i = surf_usm_h%i(m)
1823	j = surf_usm_h%j(m)
1824	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1825	surf_usm_h%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1826	surf_usm_h%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1827	surf_usm_h%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1828	ENDIF
1829	ENDDO
1830	!
1831	!-- Vertical surfaces
1832	DO l = 0, 3
1833
1834	ioff = surf_lsm_v(l)%ioff
1835	joff = surf_lsm_v(l)%joff
1836	DO m = 1, surf_lsm_v(l)%ns
1837	i = surf_lsm_v(l)%i(m) + ioff
1838	j = surf_lsm_v(l)%j(m) + joff
1839	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1840	surf_lsm_v(l)%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1841	surf_lsm_v(l)%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1842	surf_lsm_v(l)%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1843	ENDIF
1844	ENDDO
1845
1846	ioff = surf_usm_v(l)%ioff
1847	joff = surf_usm_v(l)%joff
1848	DO m = 1, surf_usm_v(l)%ns
1849	i = surf_usm_v(l)%i(m) + joff
1850	j = surf_usm_v(l)%j(m) + joff
1851	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1852	surf_usm_v(l)%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1853	surf_usm_v(l)%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1854	surf_usm_v(l)%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1855	ENDIF
1856	ENDDO
1857	ENDDO
1858
1859	ENDIF
1860	!
1861	!-- Initialization actions for RRTMG
1862	ELSEIF ( radiation_scheme == 'rrtmg' ) THEN
1863	#if defined ( __rrtmg )
1864	!
1865	!-- Allocate albedos for short/longwave radiation, horizontal surfaces
1866	!-- for wall/green/window (USM) or vegetation/pavement/water surfaces
1867	!-- (LSM).
1868	ALLOCATE ( surf_lsm_h%aldif(0:2,1:surf_lsm_h%ns) )
1869	ALLOCATE ( surf_lsm_h%aldir(0:2,1:surf_lsm_h%ns) )
1870	ALLOCATE ( surf_lsm_h%asdif(0:2,1:surf_lsm_h%ns) )
1871	ALLOCATE ( surf_lsm_h%asdir(0:2,1:surf_lsm_h%ns) )
1872	ALLOCATE ( surf_lsm_h%rrtm_aldif(0:2,1:surf_lsm_h%ns) )
1873	ALLOCATE ( surf_lsm_h%rrtm_aldir(0:2,1:surf_lsm_h%ns) )
1874	ALLOCATE ( surf_lsm_h%rrtm_asdif(0:2,1:surf_lsm_h%ns) )
1875	ALLOCATE ( surf_lsm_h%rrtm_asdir(0:2,1:surf_lsm_h%ns) )
1876
1877	ALLOCATE ( surf_usm_h%aldif(0:2,1:surf_usm_h%ns) )
1878	ALLOCATE ( surf_usm_h%aldir(0:2,1:surf_usm_h%ns) )
1879	ALLOCATE ( surf_usm_h%asdif(0:2,1:surf_usm_h%ns) )
1880	ALLOCATE ( surf_usm_h%asdir(0:2,1:surf_usm_h%ns) )
1881	ALLOCATE ( surf_usm_h%rrtm_aldif(0:2,1:surf_usm_h%ns) )
1882	ALLOCATE ( surf_usm_h%rrtm_aldir(0:2,1:surf_usm_h%ns) )
1883	ALLOCATE ( surf_usm_h%rrtm_asdif(0:2,1:surf_usm_h%ns) )
1884	ALLOCATE ( surf_usm_h%rrtm_asdir(0:2,1:surf_usm_h%ns) )
1885
1886	!
1887	!-- Allocate broadband albedo (temporary for the current radiation
1888	!-- implementations)
1889	IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) &
1890	ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) )
1891	IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) &
1892	ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) )
1893
1894	!
1895	!-- Allocate albedos for short/longwave radiation, vertical surfaces
1896	DO l = 0, 3
1897
1898	ALLOCATE ( surf_lsm_v(l)%aldif(0:2,1:surf_lsm_v(l)%ns) )
1899	ALLOCATE ( surf_lsm_v(l)%aldir(0:2,1:surf_lsm_v(l)%ns) )
1900	ALLOCATE ( surf_lsm_v(l)%asdif(0:2,1:surf_lsm_v(l)%ns) )
1901	ALLOCATE ( surf_lsm_v(l)%asdir(0:2,1:surf_lsm_v(l)%ns) )
1902
1903	ALLOCATE ( surf_lsm_v(l)%rrtm_aldif(0:2,1:surf_lsm_v(l)%ns) )
1904	ALLOCATE ( surf_lsm_v(l)%rrtm_aldir(0:2,1:surf_lsm_v(l)%ns) )
1905	ALLOCATE ( surf_lsm_v(l)%rrtm_asdif(0:2,1:surf_lsm_v(l)%ns) )
1906	ALLOCATE ( surf_lsm_v(l)%rrtm_asdir(0:2,1:surf_lsm_v(l)%ns) )
1907
1908	ALLOCATE ( surf_usm_v(l)%aldif(0:2,1:surf_usm_v(l)%ns) )
1909	ALLOCATE ( surf_usm_v(l)%aldir(0:2,1:surf_usm_v(l)%ns) )
1910	ALLOCATE ( surf_usm_v(l)%asdif(0:2,1:surf_usm_v(l)%ns) )
1911	ALLOCATE ( surf_usm_v(l)%asdir(0:2,1:surf_usm_v(l)%ns) )
1912
1913	ALLOCATE ( surf_usm_v(l)%rrtm_aldif(0:2,1:surf_usm_v(l)%ns) )
1914	ALLOCATE ( surf_usm_v(l)%rrtm_aldir(0:2,1:surf_usm_v(l)%ns) )
1915	ALLOCATE ( surf_usm_v(l)%rrtm_asdif(0:2,1:surf_usm_v(l)%ns) )
1916	ALLOCATE ( surf_usm_v(l)%rrtm_asdir(0:2,1:surf_usm_v(l)%ns) )
1917	!
1918	!-- Allocate broadband albedo (temporary for the current radiation
1919	!-- implementations)
1920	IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) &
1921	ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) )
1922	IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) &
1923	ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) )
1924
1925	ENDDO
1926	!
1927	!-- Level 1 initialization of spectral albedos via namelist
1928	!-- paramters. Please note, this case all surface tiles are initialized
1929	!-- the same.
1930	IF ( surf_lsm_h%ns > 0 ) THEN
1931	surf_lsm_h%aldif = albedo_lw_dif
1932	surf_lsm_h%aldir = albedo_lw_dir
1933	surf_lsm_h%asdif = albedo_sw_dif
1934	surf_lsm_h%asdir = albedo_sw_dir
1935	surf_lsm_h%albedo = albedo_sw_dif
1936	ENDIF
1937	IF ( surf_usm_h%ns > 0 ) THEN
1938	IF ( surf_usm_h%albedo_from_ascii ) THEN
1939	surf_usm_h%aldif = surf_usm_h%albedo
1940	surf_usm_h%aldir = surf_usm_h%albedo
1941	surf_usm_h%asdif = surf_usm_h%albedo
1942	surf_usm_h%asdir = surf_usm_h%albedo
1943	ELSE
1944	surf_usm_h%aldif = albedo_lw_dif
1945	surf_usm_h%aldir = albedo_lw_dir
1946	surf_usm_h%asdif = albedo_sw_dif
1947	surf_usm_h%asdir = albedo_sw_dir
1948	surf_usm_h%albedo = albedo_sw_dif
1949	ENDIF
1950	ENDIF
1951
1952	DO l = 0, 3
1953
1954	IF ( surf_lsm_v(l)%ns > 0 ) THEN
1955	surf_lsm_v(l)%aldif = albedo_lw_dif
1956	surf_lsm_v(l)%aldir = albedo_lw_dir
1957	surf_lsm_v(l)%asdif = albedo_sw_dif
1958	surf_lsm_v(l)%asdir = albedo_sw_dir
1959	surf_lsm_v(l)%albedo = albedo_sw_dif
1960	ENDIF
1961
1962	IF ( surf_usm_v(l)%ns > 0 ) THEN
1963	IF ( surf_usm_v(l)%albedo_from_ascii ) THEN
1964	surf_usm_v(l)%aldif = surf_usm_v(l)%albedo
1965	surf_usm_v(l)%aldir = surf_usm_v(l)%albedo
1966	surf_usm_v(l)%asdif = surf_usm_v(l)%albedo
1967	surf_usm_v(l)%asdir = surf_usm_v(l)%albedo
1968	ELSE
1969	surf_usm_v(l)%aldif = albedo_lw_dif
1970	surf_usm_v(l)%aldir = albedo_lw_dir
1971	surf_usm_v(l)%asdif = albedo_sw_dif
1972	surf_usm_v(l)%asdir = albedo_sw_dir
1973	ENDIF
1974	ENDIF
1975	ENDDO
1976
1977	!
1978	!-- Level 2 initialization of spectral albedos via albedo_type.
1979	!-- Please note, for natural- and urban-type surfaces, a tile approach
1980	!-- is applied so that the resulting albedo is calculated via the weighted
1981	!-- average of respective surface fractions.
1982	DO m = 1, surf_lsm_h%ns
1983	!
1984	!-- Spectral albedos for vegetation/pavement/water surfaces
1985	DO ind_type = 0, 2
1986	IF ( surf_lsm_h%albedo_type(ind_type,m) /= 0 ) THEN
1987	surf_lsm_h%aldif(ind_type,m) = &
1988	albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m))
1989	surf_lsm_h%asdif(ind_type,m) = &
1990	albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m))
1991	surf_lsm_h%aldir(ind_type,m) = &
1992	albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m))
1993	surf_lsm_h%asdir(ind_type,m) = &
1994	albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m))
1995	surf_lsm_h%albedo(ind_type,m) = &
1996	albedo_pars(0,surf_lsm_h%albedo_type(ind_type,m))
1997	ENDIF
1998	ENDDO
1999
2000	ENDDO
2001	!
2002	!-- For urban surface only if albedo has not been already initialized
2003	!-- in the urban-surface model via the ASCII file.
2004	IF ( .NOT. surf_usm_h%albedo_from_ascii ) THEN
2005	DO m = 1, surf_usm_h%ns
2006	!
2007	!-- Spectral albedos for wall/green/window surfaces
2008	DO ind_type = 0, 2
2009	IF ( surf_usm_h%albedo_type(ind_type,m) /= 0 ) THEN
2010	surf_usm_h%aldif(ind_type,m) = &
2011	albedo_pars(1,surf_usm_h%albedo_type(ind_type,m))
2012	surf_usm_h%asdif(ind_type,m) = &
2013	albedo_pars(2,surf_usm_h%albedo_type(ind_type,m))
2014	surf_usm_h%aldir(ind_type,m) = &
2015	albedo_pars(1,surf_usm_h%albedo_type(ind_type,m))
2016	surf_usm_h%asdir(ind_type,m) = &
2017	albedo_pars(2,surf_usm_h%albedo_type(ind_type,m))
2018	surf_usm_h%albedo(ind_type,m) = &
2019	albedo_pars(0,surf_usm_h%albedo_type(ind_type,m))
2020	ENDIF
2021	ENDDO
2022
2023	ENDDO
2024	ENDIF
2025
2026	DO l = 0, 3
2027
2028	DO m = 1, surf_lsm_v(l)%ns
2029	!
2030	!-- Spectral albedos for vegetation/pavement/water surfaces
2031	DO ind_type = 0, 2
2032	IF ( surf_lsm_v(l)%albedo_type(ind_type,m) /= 0 ) THEN
2033	surf_lsm_v(l)%aldif(ind_type,m) = &
2034	albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m))
2035	surf_lsm_v(l)%asdif(ind_type,m) = &
2036	albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m))
2037	surf_lsm_v(l)%aldir(ind_type,m) = &
2038	albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m))
2039	surf_lsm_v(l)%asdir(ind_type,m) = &
2040	albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m))
2041	surf_lsm_v(l)%albedo(ind_type,m) = &
2042	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_type,m))
2043	ENDIF
2044	ENDDO
2045	ENDDO
2046	!
2047	!-- For urban surface only if albedo has not been already initialized
2048	!-- in the urban-surface model via the ASCII file.
2049	IF ( .NOT. surf_usm_v(l)%albedo_from_ascii ) THEN
2050	DO m = 1, surf_usm_v(l)%ns
2051	!
2052	!-- Spectral albedos for wall/green/window surfaces
2053	DO ind_type = 0, 2
2054	IF ( surf_usm_v(l)%albedo_type(ind_type,m) /= 0 ) THEN
2055	surf_usm_v(l)%aldif(ind_type,m) = &
2056	albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m))
2057	surf_usm_v(l)%asdif(ind_type,m) = &
2058	albedo_pars(2,surf_usm_v(l)%albedo_type(ind_type,m))
2059	surf_usm_v(l)%aldir(ind_type,m) = &
2060	albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m))
2061	surf_usm_v(l)%asdir(ind_type,m) = &
2062	albedo_pars(2,surf_usm_v(l)%albedo_type(ind_type,m))
2063	surf_usm_v(l)%albedo(ind_type,m) = &
2064	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_type,m))
2065	ENDIF
2066	ENDDO
2067
2068	ENDDO
2069	ENDIF
2070	ENDDO
2071	!
2072	!-- Level 3 initialization at grid points where albedo type is zero.
2073	!-- This case, spectral albedos are taken from file if available
2074	IF ( albedo_pars_f%from_file ) THEN
2075	!
2076	!-- Horizontal
2077	DO m = 1, surf_lsm_h%ns
2078	i = surf_lsm_h%i(m)
2079	j = surf_lsm_h%j(m)
2080	!
2081	!-- Spectral albedos for vegetation/pavement/water surfaces
2082	DO ind_type = 0, 2
2083	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) &
2084	surf_lsm_h%albedo(ind_type,m) = &
2085	albedo_pars_f%pars_xy(0,j,i)
2086	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) &
2087	surf_lsm_h%aldir(ind_type,m) = &
2088	albedo_pars_f%pars_xy(1,j,i)
2089	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) &
2090	surf_lsm_h%aldif(ind_type,m) = &
2091	albedo_pars_f%pars_xy(1,j,i)
2092	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) &
2093	surf_lsm_h%asdir(ind_type,m) = &
2094	albedo_pars_f%pars_xy(2,j,i)
2095	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) &
2096	surf_lsm_h%asdif(ind_type,m) = &
2097	albedo_pars_f%pars_xy(2,j,i)
2098	ENDDO
2099	ENDDO
2100	!
2101	!-- For urban surface only if albedo has not been already initialized
2102	!-- in the urban-surface model via the ASCII file.
2103	IF ( .NOT. surf_usm_h%albedo_from_ascii ) THEN
2104	DO m = 1, surf_usm_h%ns
2105	i = surf_usm_h%i(m)
2106	j = surf_usm_h%j(m)
2107	!
2108	!-- Broadband albedos for wall/green/window surfaces
2109	DO ind_type = 0, 2
2110	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )&
2111	surf_usm_h%albedo(ind_type,m) = &
2112	albedo_pars_f%pars_xy(0,j,i)
2113	ENDDO
2114	!
2115	!-- Spectral albedos especially for building wall surfaces
2116	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) THEN
2117	surf_usm_h%aldir(ind_veg_wall,m) = &
2118	albedo_pars_f%pars_xy(1,j,i)
2119	surf_usm_h%aldif(ind_veg_wall,m) = &
2120	albedo_pars_f%pars_xy(1,j,i)
2121	ENDIF
2122	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) THEN
2123	surf_usm_h%asdir(ind_veg_wall,m) = &
2124	albedo_pars_f%pars_xy(2,j,i)
2125	surf_usm_h%asdif(ind_veg_wall,m) = &
2126	albedo_pars_f%pars_xy(2,j,i)
2127	ENDIF
2128	!
2129	!-- Spectral albedos especially for building green surfaces
2130	IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill ) THEN
2131	surf_usm_h%aldir(ind_pav_green,m) = &
2132	albedo_pars_f%pars_xy(3,j,i)
2133	surf_usm_h%aldif(ind_pav_green,m) = &
2134	albedo_pars_f%pars_xy(3,j,i)
2135	ENDIF
2136	IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill ) THEN
2137	surf_usm_h%asdir(ind_pav_green,m) = &
2138	albedo_pars_f%pars_xy(4,j,i)
2139	surf_usm_h%asdif(ind_pav_green,m) = &
2140	albedo_pars_f%pars_xy(4,j,i)
2141	ENDIF
2142	!
2143	!-- Spectral albedos especially for building window surfaces
2144	IF ( albedo_pars_f%pars_xy(5,j,i) /= albedo_pars_f%fill ) THEN
2145	surf_usm_h%aldir(ind_wat_win,m) = &
2146	albedo_pars_f%pars_xy(5,j,i)
2147	surf_usm_h%aldif(ind_wat_win,m) = &
2148	albedo_pars_f%pars_xy(5,j,i)
2149	ENDIF
2150	IF ( albedo_pars_f%pars_xy(6,j,i) /= albedo_pars_f%fill ) THEN
2151	surf_usm_h%asdir(ind_wat_win,m) = &
2152	albedo_pars_f%pars_xy(6,j,i)
2153	surf_usm_h%asdif(ind_wat_win,m) = &
2154	albedo_pars_f%pars_xy(6,j,i)
2155	ENDIF
2156
2157	ENDDO
2158	ENDIF
2159	!
2160	!-- Vertical
2161	DO l = 0, 3
2162	ioff = surf_lsm_v(l)%ioff
2163	joff = surf_lsm_v(l)%joff
2164
2165	DO m = 1, surf_lsm_v(l)%ns
2166	i = surf_lsm_v(l)%i(m)
2167	j = surf_lsm_v(l)%j(m)
2168	!
2169	!-- Spectral albedos for vegetation/pavement/water surfaces
2170	DO ind_type = 0, 2
2171	IF ( albedo_pars_f%pars_xy(0,j+joff,i+ioff) /= &
2172	albedo_pars_f%fill ) &
2173	surf_lsm_v(l)%albedo(ind_type,m) = &
2174	albedo_pars_f%pars_xy(0,j+joff,i+ioff)
2175	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2176	albedo_pars_f%fill ) &
2177	surf_lsm_v(l)%aldir(ind_type,m) = &
2178	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2179	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2180	albedo_pars_f%fill ) &
2181	surf_lsm_v(l)%aldif(ind_type,m) = &
2182	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2183	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2184	albedo_pars_f%fill ) &
2185	surf_lsm_v(l)%asdir(ind_type,m) = &
2186	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2187	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2188	albedo_pars_f%fill ) &
2189	surf_lsm_v(l)%asdif(ind_type,m) = &
2190	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2191	ENDDO
2192	ENDDO
2193	!
2194	!-- For urban surface only if albedo has not been already initialized
2195	!-- in the urban-surface model via the ASCII file.
2196	IF ( .NOT. surf_usm_v(l)%albedo_from_ascii ) THEN
2197	ioff = surf_usm_v(l)%ioff
2198	joff = surf_usm_v(l)%joff
2199
2200	DO m = 1, surf_usm_v(l)%ns
2201	i = surf_usm_v(l)%i(m)
2202	j = surf_usm_v(l)%j(m)
2203	!
2204	!-- Broadband albedos for wall/green/window surfaces
2205	DO ind_type = 0, 2
2206	IF ( albedo_pars_f%pars_xy(0,j+joff,i+ioff) /= &
2207	albedo_pars_f%fill ) &
2208	surf_usm_v(l)%albedo(ind_type,m) = &
2209	albedo_pars_f%pars_xy(0,j+joff,i+ioff)
2210	ENDDO
2211	!
2212	!-- Spectral albedos especially for building wall surfaces
2213	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2214	albedo_pars_f%fill ) THEN
2215	surf_usm_v(l)%aldir(ind_veg_wall,m) = &
2216	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2217	surf_usm_v(l)%aldif(ind_veg_wall,m) = &
2218	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2219	ENDIF
2220	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2221	albedo_pars_f%fill ) THEN
2222	surf_usm_v(l)%asdir(ind_veg_wall,m) = &
2223	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2224	surf_usm_v(l)%asdif(ind_veg_wall,m) = &
2225	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2226	ENDIF
2227	!
2228	!-- Spectral albedos especially for building green surfaces
2229	IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= &
2230	albedo_pars_f%fill ) THEN
2231	surf_usm_v(l)%aldir(ind_pav_green,m) = &
2232	albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2233	surf_usm_v(l)%aldif(ind_pav_green,m) = &
2234	albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2235	ENDIF
2236	IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= &
2237	albedo_pars_f%fill ) THEN
2238	surf_usm_v(l)%asdir(ind_pav_green,m) = &
2239	albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2240	surf_usm_v(l)%asdif(ind_pav_green,m) = &
2241	albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2242	ENDIF
2243	!
2244	!-- Spectral albedos especially for building window surfaces
2245	IF ( albedo_pars_f%pars_xy(5,j+joff,i+ioff) /= &
2246	albedo_pars_f%fill ) THEN
2247	surf_usm_v(l)%aldir(ind_wat_win,m) = &
2248	albedo_pars_f%pars_xy(5,j+joff,i+ioff)
2249	surf_usm_v(l)%aldif(ind_wat_win,m) = &
2250	albedo_pars_f%pars_xy(5,j+joff,i+ioff)
2251	ENDIF
2252	IF ( albedo_pars_f%pars_xy(6,j+joff,i+ioff) /= &
2253	albedo_pars_f%fill ) THEN
2254	surf_usm_v(l)%asdir(ind_wat_win,m) = &
2255	albedo_pars_f%pars_xy(6,j+joff,i+ioff)
2256	surf_usm_v(l)%asdif(ind_wat_win,m) = &
2257	albedo_pars_f%pars_xy(6,j+joff,i+ioff)
2258	ENDIF
2259	ENDDO
2260	ENDIF
2261	ENDDO
2262
2263	ENDIF
2264
2265	!
2266	!-- Calculate initial values of current (cosine of) the zenith angle and
2267	!-- whether the sun is up
2268	CALL calc_zenith
2269	!
2270	!-- readjust date and time to its initial value
2271	CALL init_date_and_time
2272	!
2273	!-- Calculate initial surface albedo for different surfaces
2274	IF ( .NOT. constant_albedo ) THEN
2275	#if defined( __netcdf )
2276	!
2277	!-- Horizontally aligned natural and urban surfaces
2278	CALL calc_albedo( surf_lsm_h )
2279	CALL calc_albedo( surf_usm_h )
2280	!
2281	!-- Vertically aligned natural and urban surfaces
2282	DO l = 0, 3
2283	CALL calc_albedo( surf_lsm_v(l) )
2284	CALL calc_albedo( surf_usm_v(l) )
2285	ENDDO
2286	#endif
2287	ELSE
2288	!
2289	!-- Initialize sun-inclination independent spectral albedos
2290	!-- Horizontal surfaces
2291	IF ( surf_lsm_h%ns > 0 ) THEN
2292	surf_lsm_h%rrtm_aldir = surf_lsm_h%aldir
2293	surf_lsm_h%rrtm_asdir = surf_lsm_h%asdir
2294	surf_lsm_h%rrtm_aldif = surf_lsm_h%aldif
2295	surf_lsm_h%rrtm_asdif = surf_lsm_h%asdif
2296	ENDIF
2297	IF ( surf_usm_h%ns > 0 ) THEN
2298	surf_usm_h%rrtm_aldir = surf_usm_h%aldir
2299	surf_usm_h%rrtm_asdir = surf_usm_h%asdir
2300	surf_usm_h%rrtm_aldif = surf_usm_h%aldif
2301	surf_usm_h%rrtm_asdif = surf_usm_h%asdif
2302	ENDIF
2303	!
2304	!-- Vertical surfaces
2305	DO l = 0, 3
2306	IF ( surf_lsm_v(l)%ns > 0 ) THEN
2307	surf_lsm_v(l)%rrtm_aldir = surf_lsm_v(l)%aldir
2308	surf_lsm_v(l)%rrtm_asdir = surf_lsm_v(l)%asdir
2309	surf_lsm_v(l)%rrtm_aldif = surf_lsm_v(l)%aldif
2310	surf_lsm_v(l)%rrtm_asdif = surf_lsm_v(l)%asdif
2311	ENDIF
2312	IF ( surf_usm_v(l)%ns > 0 ) THEN
2313	surf_usm_v(l)%rrtm_aldir = surf_usm_v(l)%aldir
2314	surf_usm_v(l)%rrtm_asdir = surf_usm_v(l)%asdir
2315	surf_usm_v(l)%rrtm_aldif = surf_usm_v(l)%aldif
2316	surf_usm_v(l)%rrtm_asdif = surf_usm_v(l)%asdif
2317	ENDIF
2318	ENDDO
2319
2320	ENDIF
2321
2322	!
2323	!-- Allocate 3d arrays of radiative fluxes and heating rates
2324	IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN
2325	ALLOCATE ( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2326	rad_sw_in = 0.0_wp
2327	ENDIF
2328
2329	IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN
2330	ALLOCATE ( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2331	ENDIF
2332
2333	IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN
2334	ALLOCATE ( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2335	rad_sw_out = 0.0_wp
2336	ENDIF
2337
2338	IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN
2339	ALLOCATE ( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2340	ENDIF
2341
2342	IF ( .NOT. ALLOCATED ( rad_sw_hr ) ) THEN
2343	ALLOCATE ( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2344	rad_sw_hr = 0.0_wp
2345	ENDIF
2346
2347	IF ( .NOT. ALLOCATED ( rad_sw_hr_av ) ) THEN
2348	ALLOCATE ( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2349	rad_sw_hr_av = 0.0_wp
2350	ENDIF
2351
2352	IF ( .NOT. ALLOCATED ( rad_sw_cs_hr ) ) THEN
2353	ALLOCATE ( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2354	rad_sw_cs_hr = 0.0_wp
2355	ENDIF
2356
2357	IF ( .NOT. ALLOCATED ( rad_sw_cs_hr_av ) ) THEN
2358	ALLOCATE ( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2359	rad_sw_cs_hr_av = 0.0_wp
2360	ENDIF
2361
2362	IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN
2363	ALLOCATE ( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2364	rad_lw_in = 0.0_wp
2365	ENDIF
2366
2367	IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN
2368	ALLOCATE ( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2369	ENDIF
2370
2371	IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN
2372	ALLOCATE ( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2373	rad_lw_out = 0.0_wp
2374	ENDIF
2375
2376	IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN
2377	ALLOCATE ( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2378	ENDIF
2379
2380	IF ( .NOT. ALLOCATED ( rad_lw_hr ) ) THEN
2381	ALLOCATE ( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2382	rad_lw_hr = 0.0_wp
2383	ENDIF
2384
2385	IF ( .NOT. ALLOCATED ( rad_lw_hr_av ) ) THEN
2386	ALLOCATE ( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2387	rad_lw_hr_av = 0.0_wp
2388	ENDIF
2389
2390	IF ( .NOT. ALLOCATED ( rad_lw_cs_hr ) ) THEN
2391	ALLOCATE ( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2392	rad_lw_cs_hr = 0.0_wp
2393	ENDIF
2394
2395	IF ( .NOT. ALLOCATED ( rad_lw_cs_hr_av ) ) THEN
2396	ALLOCATE ( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2397	rad_lw_cs_hr_av = 0.0_wp
2398	ENDIF
2399
2400	ALLOCATE ( rad_sw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2401	ALLOCATE ( rad_sw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2402	rad_sw_cs_in = 0.0_wp
2403	rad_sw_cs_out = 0.0_wp
2404
2405	ALLOCATE ( rad_lw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2406	ALLOCATE ( rad_lw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2407	rad_lw_cs_in = 0.0_wp
2408	rad_lw_cs_out = 0.0_wp
2409
2410	!
2411	!-- Allocate 1-element array for surface temperature
2412	!-- (RRTMG anticipates an array as passed argument).
2413	ALLOCATE ( rrtm_tsfc(1) )
2414	!
2415	!-- Allocate surface emissivity.
2416	!-- Values will be given directly before calling rrtm_lw.
2417	ALLOCATE ( rrtm_emis(0:0,1:nbndlw+1) )
2418
2419	!
2420	!-- Initialize RRTMG, before check if files are existent
2421	INQUIRE( FILE='rrtmg_lw.nc', EXIST=lw_exists )
2422	IF ( .NOT. lw_exists ) THEN
2423	message_string = 'Input file rrtmg_lw.nc' // &
2424	'&for rrtmg missing. ' // &
2425	'&Please provide <jobname>_lsw file in the INPUT directory.'
2426	CALL message( 'radiation_init', 'PA0583', 1, 2, 0, 6, 0 )
2427	ENDIF
2428	INQUIRE( FILE='rrtmg_sw.nc', EXIST=sw_exists )
2429	IF ( .NOT. sw_exists ) THEN
2430	message_string = 'Input file rrtmg_sw.nc' // &
2431	'&for rrtmg missing. ' // &
2432	'&Please provide <jobname>_rsw file in the INPUT directory.'
2433	CALL message( 'radiation_init', 'PA0584', 1, 2, 0, 6, 0 )
2434	ENDIF
2435
2436	IF ( lw_radiation ) CALL rrtmg_lw_ini ( c_p )
2437	IF ( sw_radiation ) CALL rrtmg_sw_ini ( c_p )
2438
2439	!
2440	!-- Set input files for RRTMG
2441	INQUIRE(FILE="RAD_SND_DATA", EXIST=snd_exists)
2442	IF ( .NOT. snd_exists ) THEN
2443	rrtm_input_file = "rrtmg_lw.nc"
2444	ENDIF
2445
2446	!
2447	!-- Read vertical layers for RRTMG from sounding data
2448	!-- The routine provides nzt_rad, hyp_snd(1:nzt_rad),
2449	!-- t_snd(nzt+2:nzt_rad), rrtm_play(1:nzt_rad), rrtm_plev(1_nzt_rad+1),
2450	!-- rrtm_tlay(nzt+2:nzt_rad), rrtm_tlev(nzt+2:nzt_rad+1)
2451	CALL read_sounding_data
2452
2453	!
2454	!-- Read trace gas profiles from file. This routine provides
2455	!-- the rrtm_ arrays (1:nzt_rad+1)
2456	CALL read_trace_gas_data
2457	#endif
2458	ENDIF
2459	!
2460	!-- Initializaion actions exclusively required for external
2461	!-- radiation forcing
2462	IF ( radiation_scheme == 'external' ) THEN
2463	!
2464	!-- Open the radiation input file. Note, for child domain, a dynamic
2465	!-- input file is often not provided. In order to do not need to
2466	!-- duplicate the dynamic input file just for the radiation input, take
2467	!-- it from the dynamic file for the parent if not available for the
2468	!-- child domain(s). In this case this is possible because radiation
2469	!-- input should be the same for each model.
2470	INQUIRE( FILE = TRIM( input_file_dynamic ), &
2471	EXIST = radiation_input_root_domain )
2472
2473	IF ( .NOT. input_pids_dynamic .AND. &
2474	.NOT. radiation_input_root_domain ) THEN
2475	message_string = 'In case of external radiation forcing ' // &
2476	'a dynamic input file is required. If no ' // &
2477	'dynamic input for the child domain(s) is ' // &
2478	'provided, at least one for the root domain ' // &
2479	'is needed.'
2480	CALL message( 'radiation_init', 'PA0315', 1, 2, 0, 6, 0 )
2481	ENDIF
2482	#if defined( __netcdf )
2483	!
2484	!-- Open dynamic input file for child domain if available, else, open
2485	!-- dynamic input file for the root domain.
2486	IF ( input_pids_dynamic ) THEN
2487	CALL open_read_file( TRIM( input_file_dynamic ) // &
2488	TRIM( coupling_char ), &
2489	pids_id )
2490	ELSEIF ( radiation_input_root_domain ) THEN
2491	CALL open_read_file( TRIM( input_file_dynamic ), &
2492	pids_id )
2493	ENDIF
2494
2495	CALL inquire_num_variables( pids_id, num_var_pids )
2496	!
2497	!-- Allocate memory to store variable names and read them
2498	ALLOCATE( vars_pids(1:num_var_pids) )
2499	CALL inquire_variable_names( pids_id, vars_pids )
2500	!
2501	!-- Input time dimension.
2502	IF ( check_existence( vars_pids, 'time_rad' ) ) THEN
2503	CALL netcdf_data_input_get_dimension_length( pids_id, &
2504	ntime, &
2505	'time_rad' )
2506
2507	ALLOCATE( time_rad_f%var1d(0:ntime-1) )
2508	!
2509	!-- Read variable
2510	CALL get_variable( pids_id, 'time_rad', time_rad_f%var1d )
2511
2512	time_rad_f%from_file = .TRUE.
2513	ENDIF
2514	!
2515	!-- Input shortwave downwelling.
2516	IF ( check_existence( vars_pids, 'rad_sw_in' ) ) THEN
2517	!
2518	!-- Get _FillValue attribute
2519	CALL get_attribute( pids_id, char_fill, rad_sw_in_f%fill, &
2520	.FALSE., 'rad_sw_in' )
2521	!
2522	!-- Get level-of-detail
2523	CALL get_attribute( pids_id, char_lod, rad_sw_in_f%lod, &
2524	.FALSE., 'rad_sw_in' )
2525	!
2526	!-- Level-of-detail 1 - radiation depends only on time_rad
2527	IF ( rad_sw_in_f%lod == 1 ) THEN
2528	ALLOCATE( rad_sw_in_f%var1d(0:ntime-1) )
2529	CALL get_variable( pids_id, 'rad_sw_in', rad_sw_in_f%var1d )
2530	rad_sw_in_f%from_file = .TRUE.
2531	!
2532	!-- Level-of-detail 2 - radiation depends on time_rad, y, x
2533	ELSEIF ( rad_sw_in_f%lod == 2 ) THEN
2534	ALLOCATE( rad_sw_in_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2535
2536	CALL get_variable( pids_id, 'rad_sw_in', rad_sw_in_f%var3d, &
2537	nxl, nxr, nys, nyn, 0, ntime-1 )
2538
2539	rad_sw_in_f%from_file = .TRUE.
2540	ELSE
2541	message_string = '"rad_sw_in" has no valid lod attribute'
2542	CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2543	ENDIF
2544	ENDIF
2545	!
2546	!-- Input longwave downwelling.
2547	IF ( check_existence( vars_pids, 'rad_lw_in' ) ) THEN
2548	!
2549	!-- Get _FillValue attribute
2550	CALL get_attribute( pids_id, char_fill, rad_lw_in_f%fill, &
2551	.FALSE., 'rad_lw_in' )
2552	!
2553	!-- Get level-of-detail
2554	CALL get_attribute( pids_id, char_lod, rad_lw_in_f%lod, &
2555	.FALSE., 'rad_lw_in' )
2556	!
2557	!-- Level-of-detail 1 - radiation depends only on time_rad
2558	IF ( rad_lw_in_f%lod == 1 ) THEN
2559	ALLOCATE( rad_lw_in_f%var1d(0:ntime-1) )
2560	CALL get_variable( pids_id, 'rad_lw_in', rad_lw_in_f%var1d )
2561	rad_lw_in_f%from_file = .TRUE.
2562	!
2563	!-- Level-of-detail 2 - radiation depends on time_rad, y, x
2564	ELSEIF ( rad_lw_in_f%lod == 2 ) THEN
2565	ALLOCATE( rad_lw_in_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2566
2567	CALL get_variable( pids_id, 'rad_lw_in', rad_lw_in_f%var3d, &
2568	nxl, nxr, nys, nyn, 0, ntime-1 )
2569
2570	rad_lw_in_f%from_file = .TRUE.
2571	ELSE
2572	message_string = '"rad_lw_in" has no valid lod attribute'
2573	CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2574	ENDIF
2575	ENDIF
2576	!
2577	!-- Input shortwave downwelling, diffuse part.
2578	IF ( check_existence( vars_pids, 'rad_sw_in_dif' ) ) THEN
2579	!
2580	!-- Read _FillValue attribute
2581	CALL get_attribute( pids_id, char_fill, rad_sw_in_dif_f%fill, &
2582	.FALSE., 'rad_sw_in_dif' )
2583	!
2584	!-- Get level-of-detail
2585	CALL get_attribute( pids_id, char_lod, rad_sw_in_dif_f%lod, &
2586	.FALSE., 'rad_sw_in_dif' )
2587	!
2588	!-- Level-of-detail 1 - radiation depends only on time_rad
2589	IF ( rad_sw_in_dif_f%lod == 1 ) THEN
2590	ALLOCATE( rad_sw_in_dif_f%var1d(0:ntime-1) )
2591	CALL get_variable( pids_id, 'rad_sw_in_dif', &
2592	rad_sw_in_dif_f%var1d )
2593	rad_sw_in_dif_f%from_file = .TRUE.
2594	!
2595	!-- Level-of-detail 2 - radiation depends on time_rad, y, x
2596	ELSEIF ( rad_sw_in_dif_f%lod == 2 ) THEN
2597	ALLOCATE( rad_sw_in_dif_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2598
2599	CALL get_variable( pids_id, 'rad_sw_in_dif', &
2600	rad_sw_in_dif_f%var3d, &
2601	nxl, nxr, nys, nyn, 0, ntime-1 )
2602
2603	rad_sw_in_dif_f%from_file = .TRUE.
2604	ELSE
2605	message_string = '"rad_sw_in_dif" has no valid lod attribute'
2606	CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2607	ENDIF
2608	ENDIF
2609	!
2610	!-- Finally, close the input file and deallocate temporary arrays
2611	DEALLOCATE( vars_pids )
2612
2613	CALL close_input_file( pids_id )
2614	#endif
2615	!
2616	!-- Make some consistency checks.
2617	IF ( .NOT. rad_sw_in_f%from_file .OR. &
2618	.NOT. rad_lw_in_f%from_file ) THEN
2619	message_string = 'In case of external radiation forcing ' // &
2620	'both, rad_sw_in and rad_lw_in are required.'
2621	CALL message( 'radiation_init', 'PA0195', 1, 2, 0, 6, 0 )
2622	ENDIF
2623
2624	IF ( .NOT. time_rad_f%from_file ) THEN
2625	message_string = 'In case of external radiation forcing ' // &
2626	'dimension time_rad is required.'
2627	CALL message( 'radiation_init', 'PA0196', 1, 2, 0, 6, 0 )
2628	ENDIF
2629
2630	IF ( time_rad_f%var1d(0) /= 0.0_wp ) THEN
2631	message_string = 'External radiation forcing: first point in ' // &
2632	'time is /= 0.0.'
2633	CALL message( 'radiation_init', 'PA0313', 1, 2, 0, 6, 0 )
2634	ENDIF
2635
2636	IF ( end_time - spinup_time > time_rad_f%var1d(ntime-1) ) THEN
2637	message_string = 'External radiation forcing does not cover ' // &
2638	'the entire simulation time.'
2639	CALL message( 'radiation_init', 'PA0314', 1, 2, 0, 6, 0 )
2640	ENDIF
2641	!
2642	!-- Check for fill values in radiation
2643	IF ( ALLOCATED( rad_sw_in_f%var1d ) ) THEN
2644	IF ( ANY( rad_sw_in_f%var1d == rad_sw_in_f%fill ) ) THEN
2645	message_string = 'External radiation array "rad_sw_in" ' // &
2646	'must not contain any fill values.'
2647	CALL message( 'radiation_init', 'PA0197', 1, 2, 0, 6, 0 )
2648	ENDIF
2649	ENDIF
2650
2651	IF ( ALLOCATED( rad_lw_in_f%var1d ) ) THEN
2652	IF ( ANY( rad_lw_in_f%var1d == rad_lw_in_f%fill ) ) THEN
2653	message_string = 'External radiation array "rad_lw_in" ' // &
2654	'must not contain any fill values.'
2655	CALL message( 'radiation_init', 'PA0198', 1, 2, 0, 6, 0 )
2656	ENDIF
2657	ENDIF
2658
2659	IF ( ALLOCATED( rad_sw_in_dif_f%var1d ) ) THEN
2660	IF ( ANY( rad_sw_in_dif_f%var1d == rad_sw_in_dif_f%fill ) ) THEN
2661	message_string = 'External radiation array "rad_sw_in_dif" ' //&
2662	'must not contain any fill values.'
2663	CALL message( 'radiation_init', 'PA0199', 1, 2, 0, 6, 0 )
2664	ENDIF
2665	ENDIF
2666
2667	IF ( ALLOCATED( rad_sw_in_f%var3d ) ) THEN
2668	IF ( ANY( rad_sw_in_f%var3d == rad_sw_in_f%fill ) ) THEN
2669	message_string = 'External radiation array "rad_sw_in" ' // &
2670	'must not contain any fill values.'
2671	CALL message( 'radiation_init', 'PA0197', 1, 2, 0, 6, 0 )
2672	ENDIF
2673	ENDIF
2674
2675	IF ( ALLOCATED( rad_lw_in_f%var3d ) ) THEN
2676	IF ( ANY( rad_lw_in_f%var3d == rad_lw_in_f%fill ) ) THEN
2677	message_string = 'External radiation array "rad_lw_in" ' // &
2678	'must not contain any fill values.'
2679	CALL message( 'radiation_init', 'PA0198', 1, 2, 0, 6, 0 )
2680	ENDIF
2681	ENDIF
2682
2683	IF ( ALLOCATED( rad_sw_in_dif_f%var3d ) ) THEN
2684	IF ( ANY( rad_sw_in_dif_f%var3d == rad_sw_in_dif_f%fill ) ) THEN
2685	message_string = 'External radiation array "rad_sw_in_dif" ' //&
2686	'must not contain any fill values.'
2687	CALL message( 'radiation_init', 'PA0199', 1, 2, 0, 6, 0 )
2688	ENDIF
2689	ENDIF
2690	!
2691	!-- Currently, 2D external radiation input is not possible in
2692	!-- combination with topography where average radiation is used.
2693	IF ( ( rad_sw_in_f%lod == 2 .OR. rad_sw_in_f%lod == 2 .OR. &
2694	rad_sw_in_dif_f%lod == 2 ) .AND. average_radiation ) THEN
2695	message_string = 'External radiation with lod = 2 is currently '//&
2696	'not possible with average_radiation = .T..'
2697	CALL message( 'radiation_init', 'PA0670', 1, 2, 0, 6, 0 )
2698	ENDIF
2699	!
2700	!-- All radiation input should have the same level of detail. The sum
2701	!-- of lods divided by the number of available radiation arrays must be
2702	!-- 1 (if all are lod = 1) or 2 (if all are lod = 2).
2703	IF ( REAL( MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + &
2704	MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + &
2705	MERGE( rad_sw_in_dif_f%lod, 0, rad_sw_in_dif_f%from_file ),&
2706	KIND = wp ) / &
2707	( MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + &
2708	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + &
2709	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_dif_f%from_file ) ) &
2710	/= 1.0_wp .AND. &
2711	REAL( MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + &
2712	MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + &
2713	MERGE( rad_sw_in_dif_f%lod, 0, rad_sw_in_dif_f%from_file ),&
2714	KIND = wp ) / &
2715	( MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + &
2716	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + &
2717	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_dif_f%from_file ) ) &
2718	/= 2.0_wp ) THEN
2719	message_string = 'External radiation input should have the same '//&
2720	'lod.'
2721	CALL message( 'radiation_init', 'PA0673', 1, 2, 0, 6, 0 )
2722	ENDIF
2723
2724	ENDIF
2725	!
2726	!-- Perform user actions if required
2727	CALL user_init_radiation
2728
2729	!
2730	!-- Calculate radiative fluxes at model start
2731	SELECT CASE ( TRIM( radiation_scheme ) )
2732
2733	CASE ( 'rrtmg' )
2734	CALL radiation_rrtmg
2735
2736	CASE ( 'clear-sky' )
2737	CALL radiation_clearsky
2738
2739	CASE ( 'constant' )
2740	CALL radiation_constant
2741
2742	CASE ( 'external' )
2743	!
2744	!-- During spinup apply clear-sky model
2745	IF ( time_since_reference_point < 0.0_wp ) THEN
2746	CALL radiation_clearsky
2747	ELSE
2748	CALL radiation_external
2749	ENDIF
2750
2751	CASE DEFAULT
2752
2753	END SELECT
2754	!
2755	!-- Readjust date and time to its initial value
2756	CALL init_date_and_time
2757
2758	!
2759	!-- Find all discretized apparent solar positions for radiation interaction.
2760	IF ( radiation_interactions ) CALL radiation_presimulate_solar_pos
2761
2762	!
2763	!-- If required, read or calculate and write out the SVF
2764	IF ( radiation_interactions .AND. read_svf) THEN
2765	!
2766	!-- Read sky-view factors and further required data from file
2767	CALL radiation_read_svf()
2768
2769	ELSEIF ( radiation_interactions .AND. .NOT. read_svf) THEN
2770	!
2771	!-- calculate SFV and CSF
2772	CALL radiation_calc_svf()
2773	ENDIF
2774
2775	IF ( radiation_interactions .AND. write_svf) THEN
2776	!
2777	!-- Write svf, csf svfsurf and csfsurf data to file
2778	CALL radiation_write_svf()
2779	ENDIF
2780
2781	!
2782	!-- Adjust radiative fluxes. In case of urban and land surfaces, also
2783	!-- call an initial interaction.
2784	IF ( radiation_interactions ) THEN
2785	CALL radiation_interaction
2786	ENDIF
2787
2788	IF ( debug_output ) CALL debug_message( 'radiation_init', 'end' )
2789
2790	RETURN !todo: remove, I don't see what we need this for here
2791
2792	END SUBROUTINE radiation_init
2793
2794
2795	!------------------------------------------------------------------------------!
2796	! Description:
2797	! ------------
2798	!> A simple clear sky radiation model
2799	!------------------------------------------------------------------------------!
2800	SUBROUTINE radiation_external
2801
2802	IMPLICIT NONE
2803
2804	INTEGER(iwp) :: l !< running index for surface orientation
2805	INTEGER(iwp) :: t !< index of current timestep
2806	INTEGER(iwp) :: tm !< index of previous timestep
2807
2808	REAL(wp) :: fac_dt !< interpolation factor
2809
2810	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
2811
2812	!
2813	!-- Calculate current zenith angle
2814	CALL calc_zenith
2815	!
2816	!-- Interpolate external radiation on current timestep
2817	IF ( time_since_reference_point <= 0.0_wp ) THEN
2818	t = 0
2819	tm = 0
2820	fac_dt = 0
2821	ELSE
2822	t = 0
2823	DO WHILE ( time_rad_f%var1d(t) <= time_since_reference_point )
2824	t = t + 1
2825	ENDDO
2826
2827	tm = MAX( t-1, 0 )
2828
2829	fac_dt = ( time_since_reference_point - time_rad_f%var1d(tm) + dt_3d ) &
2830	/ ( time_rad_f%var1d(t) - time_rad_f%var1d(tm) )
2831	fac_dt = MIN( 1.0_wp, fac_dt )
2832	ENDIF
2833	!
2834	!-- Call clear-sky calculation for each surface orientation.
2835	!-- First, horizontal surfaces
2836	surf => surf_lsm_h
2837	CALL radiation_external_surf
2838	surf => surf_usm_h
2839	CALL radiation_external_surf
2840	!
2841	!-- Vertical surfaces
2842	DO l = 0, 3
2843	surf => surf_lsm_v(l)
2844	CALL radiation_external_surf
2845	surf => surf_usm_v(l)
2846	CALL radiation_external_surf
2847	ENDDO
2848
2849	CONTAINS
2850
2851	SUBROUTINE radiation_external_surf
2852
2853	USE control_parameters
2854
2855	IMPLICIT NONE
2856
2857	INTEGER(iwp) :: i !< grid index along x-dimension
2858	INTEGER(iwp) :: j !< grid index along y-dimension
2859	INTEGER(iwp) :: k !< grid index along z-dimension
2860	INTEGER(iwp) :: m !< running index for surface elements
2861
2862	REAL(wp) :: lw_in !< downwelling longwave radiation, interpolated value
2863	REAL(wp) :: sw_in !< downwelling shortwave radiation, interpolated value
2864	REAL(wp) :: sw_in_dif !< downwelling diffuse shortwave radiation, interpolated value
2865
2866	IF ( surf%ns < 1 ) RETURN
2867	!
2868	!-- level-of-detail = 1. Note, here it must be distinguished between
2869	!-- averaged radiation and non-averaged radiation for the upwelling
2870	!-- fluxes.
2871	IF ( rad_sw_in_f%lod == 1 ) THEN
2872
2873	sw_in = ( 1.0_wp - fac_dt ) * rad_sw_in_f%var1d(tm) &
2874	+ fac_dt * rad_sw_in_f%var1d(t)
2875
2876	lw_in = ( 1.0_wp - fac_dt ) * rad_lw_in_f%var1d(tm) &
2877	+ fac_dt * rad_lw_in_f%var1d(t)
2878	!
2879	!-- Limit shortwave incoming radiation to positive values, in order
2880	!-- to overcome possible observation errors.
2881	sw_in = MAX( 0.0_wp, sw_in )
2882	sw_in = MERGE( sw_in, 0.0_wp, sun_up )
2883
2884	surf%rad_sw_in = sw_in
2885	surf%rad_lw_in = lw_in
2886
2887	IF ( average_radiation ) THEN
2888	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
2889
2890	surf%rad_lw_out = emissivity_urb * sigma_sb * t_rad_urb**4 &
2891	+ ( 1.0_wp - emissivity_urb ) * surf%rad_lw_in
2892
2893	surf%rad_net = surf%rad_sw_in - surf%rad_sw_out &
2894	+ surf%rad_lw_in - surf%rad_lw_out
2895
2896	surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb &
2897	* sigma_sb &
2898	* t_rad_urb**3
2899	ELSE
2900	DO m = 1, surf%ns
2901	k = surf%k(m)
2902	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
2903	surf%albedo(ind_veg_wall,m) &
2904	+ surf%frac(ind_pav_green,m) * &
2905	surf%albedo(ind_pav_green,m) &
2906	+ surf%frac(ind_wat_win,m) * &
2907	surf%albedo(ind_wat_win,m) ) &
2908	* surf%rad_sw_in(m)
2909
2910	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
2911	surf%emissivity(ind_veg_wall,m) &
2912	+ surf%frac(ind_pav_green,m) * &
2913	surf%emissivity(ind_pav_green,m) &
2914	+ surf%frac(ind_wat_win,m) * &
2915	surf%emissivity(ind_wat_win,m) &
2916	) &
2917	* sigma_sb &
2918	* ( surf%pt_surface(m) * exner(k) )**4
2919
2920	surf%rad_lw_out_change_0(m) = &
2921	( surf%frac(ind_veg_wall,m) * &
2922	surf%emissivity(ind_veg_wall,m) &
2923	+ surf%frac(ind_pav_green,m) * &
2924	surf%emissivity(ind_pav_green,m) &
2925	+ surf%frac(ind_wat_win,m) * &
2926	surf%emissivity(ind_wat_win,m) &
2927	) * 4.0_wp * sigma_sb &
2928	* ( surf%pt_surface(m) * exner(k) )**3
2929	ENDDO
2930
2931	ENDIF
2932	!
2933	!-- If diffuse shortwave radiation is available, store it on
2934	!-- the respective files.
2935	IF ( rad_sw_in_dif_f%from_file ) THEN
2936	sw_in_dif= ( 1.0_wp - fac_dt ) * rad_sw_in_dif_f%var1d(tm) &
2937	+ fac_dt * rad_sw_in_dif_f%var1d(t)
2938
2939	IF ( ALLOCATED( rad_sw_in_diff ) ) rad_sw_in_diff = sw_in_dif
2940	IF ( ALLOCATED( rad_sw_in_dir ) ) rad_sw_in_dir = sw_in &
2941	- sw_in_dif
2942	!
2943	!-- Diffuse longwave radiation equals the total downwelling
2944	!-- longwave radiation
2945	IF ( ALLOCATED( rad_lw_in_diff ) ) rad_lw_in_diff = lw_in
2946	ENDIF
2947	!
2948	!-- level-of-detail = 2
2949	ELSE
2950
2951	DO m = 1, surf%ns
2952	i = surf%i(m)
2953	j = surf%j(m)
2954	k = surf%k(m)
2955
2956	surf%rad_sw_in(m) = ( 1.0_wp - fac_dt ) &
2957	* rad_sw_in_f%var3d(tm,j,i) &
2958	+ fac_dt * rad_sw_in_f%var3d(t,j,i)
2959	!
2960	!-- Limit shortwave incoming radiation to positive values, in
2961	!-- order to overcome possible observation errors.
2962	surf%rad_sw_in(m) = MAX( 0.0_wp, surf%rad_sw_in(m) )
2963	surf%rad_sw_in(m) = MERGE( surf%rad_sw_in(m), 0.0_wp, sun_up )
2964
2965	surf%rad_lw_in(m) = ( 1.0_wp - fac_dt ) &
2966	* rad_lw_in_f%var3d(tm,j,i) &
2967	+ fac_dt * rad_lw_in_f%var3d(t,j,i)
2968	!
2969	!-- Weighted average according to surface fraction.
2970	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
2971	surf%albedo(ind_veg_wall,m) &
2972	+ surf%frac(ind_pav_green,m) * &
2973	surf%albedo(ind_pav_green,m) &
2974	+ surf%frac(ind_wat_win,m) * &
2975	surf%albedo(ind_wat_win,m) ) &
2976	* surf%rad_sw_in(m)
2977
2978	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
2979	surf%emissivity(ind_veg_wall,m) &
2980	+ surf%frac(ind_pav_green,m) * &
2981	surf%emissivity(ind_pav_green,m) &
2982	+ surf%frac(ind_wat_win,m) * &
2983	surf%emissivity(ind_wat_win,m) &
2984	) &
2985	* sigma_sb &
2986	* ( surf%pt_surface(m) * exner(k) )**4
2987
2988	surf%rad_lw_out_change_0(m) = &
2989	( surf%frac(ind_veg_wall,m) * &
2990	surf%emissivity(ind_veg_wall,m) &
2991	+ surf%frac(ind_pav_green,m) * &
2992	surf%emissivity(ind_pav_green,m) &
2993	+ surf%frac(ind_wat_win,m) * &
2994	surf%emissivity(ind_wat_win,m) &
2995	) * 4.0_wp * sigma_sb &
2996	* ( surf%pt_surface(m) * exner(k) )**3
2997
2998	surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) &
2999	+ surf%rad_lw_in(m) - surf%rad_lw_out(m)
3000	!
3001	!-- If diffuse shortwave radiation is available, store it on
3002	!-- the respective files.
3003	IF ( rad_sw_in_dif_f%from_file ) THEN
3004	IF ( ALLOCATED( rad_sw_in_diff ) ) &
3005	rad_sw_in_diff(j,i) = ( 1.0_wp - fac_dt ) &
3006	* rad_sw_in_dif_f%var3d(tm,j,i) &
3007	+ fac_dt * rad_sw_in_dif_f%var3d(t,j,i)
3008	!
3009	!-- dir = sw_in - sw_in_dif.
3010	IF ( ALLOCATED( rad_sw_in_dir ) ) &
3011	rad_sw_in_dir(j,i) = surf%rad_sw_in(m) - &
3012	rad_sw_in_diff(j,i)
3013	!
3014	!-- Diffuse longwave radiation equals the total downwelling
3015	!-- longwave radiation
3016	IF ( ALLOCATED( rad_lw_in_diff ) ) &
3017	rad_lw_in_diff = surf%rad_lw_in(m)
3018	ENDIF
3019
3020	ENDDO
3021
3022	ENDIF
3023	!
3024	!-- Store radiation also on 2D arrays, which are still used for
3025	!-- direct-diffuse splitting.
3026	DO m = 1, surf%ns
3027	i = surf%i(m)
3028	j = surf%j(m)
3029
3030	rad_sw_in(0,:,:) = surf%rad_sw_in(m)
3031	rad_lw_in(0,:,:) = surf%rad_lw_in(m)
3032	rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3033	rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3034	ENDDO
3035
3036	END SUBROUTINE radiation_external_surf
3037
3038	END SUBROUTINE radiation_external
3039
3040	!------------------------------------------------------------------------------!
3041	! Description:
3042	! ------------
3043	!> A simple clear sky radiation model
3044	!------------------------------------------------------------------------------!
3045	SUBROUTINE radiation_clearsky
3046
3047
3048	IMPLICIT NONE
3049
3050	INTEGER(iwp) :: l !< running index for surface orientation
3051	REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top
3052	REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain
3053	REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top
3054	REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain
3055
3056	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
3057
3058	!
3059	!-- Calculate current zenith angle
3060	CALL calc_zenith
3061
3062	!
3063	!-- Calculate sky transmissivity
3064	sky_trans = 0.6_wp + 0.2_wp * cos_zenith
3065
3066	!
3067	!-- Calculate value of the Exner function at model surface
3068	!
3069	!-- In case averaged radiation is used, calculate mean temperature and
3070	!-- liquid water mixing ratio at the urban-layer top.
3071	IF ( average_radiation ) THEN
3072	pt1 = 0.0_wp
3073	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = 0.0_wp
3074
3075	pt1_l = SUM( pt(nz_urban_t,nys:nyn,nxl:nxr) )
3076	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1_l = SUM( ql(nz_urban_t,nys:nyn,nxl:nxr) )
3077
3078	#if defined( __parallel )
3079	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
3080	CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3081	IF ( ierr /= 0 ) THEN
3082	WRITE(9,*) 'Error MPI_AllReduce1:', ierr, pt1_l, pt1
3083	FLUSH(9)
3084	ENDIF
3085
3086	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3087	CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3088	IF ( ierr /= 0 ) THEN
3089	WRITE(9,*) 'Error MPI_AllReduce2:', ierr, ql1_l, ql1
3090	FLUSH(9)
3091	ENDIF
3092	ENDIF
3093	#else
3094	pt1 = pt1_l
3095	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = ql1_l
3096	#endif
3097
3098	IF ( bulk_cloud_model .OR. cloud_droplets ) pt1 = pt1 + lv_d_cp / exner(nz_urban_t) * ql1
3099	!
3100	!-- Finally, divide by number of grid points
3101	pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp )
3102	ENDIF
3103	!
3104	!-- Call clear-sky calculation for each surface orientation.
3105	!-- First, horizontal surfaces
3106	surf => surf_lsm_h
3107	CALL radiation_clearsky_surf
3108	surf => surf_usm_h
3109	CALL radiation_clearsky_surf
3110	!
3111	!-- Vertical surfaces
3112	DO l = 0, 3
3113	surf => surf_lsm_v(l)
3114	CALL radiation_clearsky_surf
3115	surf => surf_usm_v(l)
3116	CALL radiation_clearsky_surf
3117	ENDDO
3118
3119	CONTAINS
3120
3121	SUBROUTINE radiation_clearsky_surf
3122
3123	IMPLICIT NONE
3124
3125	INTEGER(iwp) :: i !< index x-direction
3126	INTEGER(iwp) :: j !< index y-direction
3127	INTEGER(iwp) :: k !< index z-direction
3128	INTEGER(iwp) :: m !< running index for surface elements
3129
3130	IF ( surf%ns < 1 ) RETURN
3131
3132	!
3133	!-- Calculate radiation fluxes and net radiation (rad_net) assuming
3134	!-- homogeneous urban radiation conditions.
3135	IF ( average_radiation ) THEN
3136
3137	k = nz_urban_t
3138
3139	surf%rad_sw_in = solar_constant * sky_trans * cos_zenith
3140	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
3141
3142	surf%rad_lw_in = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k+1))**4
3143
3144	surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 &
3145	+ (1.0_wp - emissivity_urb) * surf%rad_lw_in
3146
3147	surf%rad_net = surf%rad_sw_in - surf%rad_sw_out &
3148	+ surf%rad_lw_in - surf%rad_lw_out
3149
3150	surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb &
3151	* (t_rad_urb)**3
3152
3153	!
3154	!-- Calculate radiation fluxes and net radiation (rad_net) for each surface
3155	!-- element.
3156	ELSE
3157
3158	DO m = 1, surf%ns
3159	i = surf%i(m)
3160	j = surf%j(m)
3161	k = surf%k(m)
3162
3163	surf%rad_sw_in(m) = solar_constant * sky_trans * cos_zenith
3164
3165	!
3166	!-- Weighted average according to surface fraction.
3167	!-- ATTENTION: when radiation interactions are switched on the
3168	!-- calculated fluxes below are not actually used as they are
3169	!-- overwritten in radiation_interaction.
3170	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3171	surf%albedo(ind_veg_wall,m) &
3172	+ surf%frac(ind_pav_green,m) * &
3173	surf%albedo(ind_pav_green,m) &
3174	+ surf%frac(ind_wat_win,m) * &
3175	surf%albedo(ind_wat_win,m) ) &
3176	* surf%rad_sw_in(m)
3177
3178	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3179	surf%emissivity(ind_veg_wall,m) &
3180	+ surf%frac(ind_pav_green,m) * &
3181	surf%emissivity(ind_pav_green,m) &
3182	+ surf%frac(ind_wat_win,m) * &
3183	surf%emissivity(ind_wat_win,m) &
3184	) &
3185	* sigma_sb &
3186	* ( surf%pt_surface(m) * exner(nzb) )**4
3187
3188	surf%rad_lw_out_change_0(m) = &
3189	( surf%frac(ind_veg_wall,m) * &
3190	surf%emissivity(ind_veg_wall,m) &
3191	+ surf%frac(ind_pav_green,m) * &
3192	surf%emissivity(ind_pav_green,m) &
3193	+ surf%frac(ind_wat_win,m) * &
3194	surf%emissivity(ind_wat_win,m) &
3195	) * 4.0_wp * sigma_sb &
3196	* ( surf%pt_surface(m) * exner(nzb) )** 3
3197
3198
3199	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3200	pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i)
3201	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k))**4
3202	ELSE
3203	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt(k,j,i) * exner(k))**4
3204	ENDIF
3205
3206	surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) &
3207	+ surf%rad_lw_in(m) - surf%rad_lw_out(m)
3208
3209	ENDDO
3210
3211	ENDIF
3212
3213	!
3214	!-- Fill out values in radiation arrays
3215	DO m = 1, surf%ns
3216	i = surf%i(m)
3217	j = surf%j(m)
3218	rad_sw_in(0,j,i) = surf%rad_sw_in(m)
3219	rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3220	rad_lw_in(0,j,i) = surf%rad_lw_in(m)
3221	rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3222	ENDDO
3223
3224	END SUBROUTINE radiation_clearsky_surf
3225
3226	END SUBROUTINE radiation_clearsky
3227
3228
3229	!------------------------------------------------------------------------------!
3230	! Description:
3231	! ------------
3232	!> This scheme keeps the prescribed net radiation constant during the run
3233	!------------------------------------------------------------------------------!
3234	SUBROUTINE radiation_constant
3235
3236
3237	IMPLICIT NONE
3238
3239	INTEGER(iwp) :: l !< running index for surface orientation
3240
3241	REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top
3242	REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain
3243	REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top
3244	REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain
3245
3246	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
3247
3248	!
3249	!-- In case averaged radiation is used, calculate mean temperature and
3250	!-- liquid water mixing ratio at the urban-layer top.
3251	IF ( average_radiation ) THEN
3252	pt1 = 0.0_wp
3253	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = 0.0_wp
3254
3255	pt1_l = SUM( pt(nz_urban_t,nys:nyn,nxl:nxr) )
3256	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1_l = SUM( ql(nz_urban_t,nys:nyn,nxl:nxr) )
3257
3258	#if defined( __parallel )
3259	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
3260	CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3261	IF ( ierr /= 0 ) THEN
3262	WRITE(9,*) 'Error MPI_AllReduce3:', ierr, pt1_l, pt1
3263	FLUSH(9)
3264	ENDIF
3265	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3266	CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3267	IF ( ierr /= 0 ) THEN
3268	WRITE(9,*) 'Error MPI_AllReduce4:', ierr, ql1_l, ql1
3269	FLUSH(9)
3270	ENDIF
3271	ENDIF
3272	#else
3273	pt1 = pt1_l
3274	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = ql1_l
3275	#endif
3276	IF ( bulk_cloud_model .OR. cloud_droplets ) pt1 = pt1 + lv_d_cp / exner(nz_urban_t+1) * ql1
3277	!
3278	!-- Finally, divide by number of grid points
3279	pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp )
3280	ENDIF
3281
3282	!
3283	!-- First, horizontal surfaces
3284	surf => surf_lsm_h
3285	CALL radiation_constant_surf
3286	surf => surf_usm_h
3287	CALL radiation_constant_surf
3288	!
3289	!-- Vertical surfaces
3290	DO l = 0, 3
3291	surf => surf_lsm_v(l)
3292	CALL radiation_constant_surf
3293	surf => surf_usm_v(l)
3294	CALL radiation_constant_surf
3295	ENDDO
3296
3297	CONTAINS
3298
3299	SUBROUTINE radiation_constant_surf
3300
3301	IMPLICIT NONE
3302
3303	INTEGER(iwp) :: i !< index x-direction
3304	INTEGER(iwp) :: ioff !< offset between surface element and adjacent grid point along x
3305	INTEGER(iwp) :: j !< index y-direction
3306	INTEGER(iwp) :: joff !< offset between surface element and adjacent grid point along y
3307	INTEGER(iwp) :: k !< index z-direction
3308	INTEGER(iwp) :: koff !< offset between surface element and adjacent grid point along z
3309	INTEGER(iwp) :: m !< running index for surface elements
3310
3311	IF ( surf%ns < 1 ) RETURN
3312
3313	!-- Calculate homogenoeus urban radiation fluxes
3314	IF ( average_radiation ) THEN
3315
3316	surf%rad_net = net_radiation
3317
3318	surf%rad_lw_in = emissivity_atm_clsky * sigma_sb * (pt1 * exner(nz_urban_t+1))**4
3319
3320	surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 &
3321	+ ( 1.0_wp - emissivity_urb ) & ! shouldn't be this a bulk value -- emissivity_urb?
3322	* surf%rad_lw_in
3323
3324	surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb &
3325	* t_rad_urb**3
3326
3327	surf%rad_sw_in = ( surf%rad_net - surf%rad_lw_in &
3328	+ surf%rad_lw_out ) &
3329	/ ( 1.0_wp - albedo_urb )
3330
3331	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
3332
3333	!
3334	!-- Calculate radiation fluxes for each surface element
3335	ELSE
3336	!
3337	!-- Determine index offset between surface element and adjacent
3338	!-- atmospheric grid point
3339	ioff = surf%ioff
3340	joff = surf%joff
3341	koff = surf%koff
3342
3343	!
3344	!-- Prescribe net radiation and estimate the remaining radiative fluxes
3345	DO m = 1, surf%ns
3346	i = surf%i(m)
3347	j = surf%j(m)
3348	k = surf%k(m)
3349
3350	surf%rad_net(m) = net_radiation
3351
3352	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3353	pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i)
3354	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k))**4
3355	ELSE
3356	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * &
3357	( pt(k,j,i) * exner(k) )**4
3358	ENDIF
3359
3360	!
3361	!-- Weighted average according to surface fraction.
3362	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3363	surf%emissivity(ind_veg_wall,m) &
3364	+ surf%frac(ind_pav_green,m) * &
3365	surf%emissivity(ind_pav_green,m) &
3366	+ surf%frac(ind_wat_win,m) * &
3367	surf%emissivity(ind_wat_win,m) &
3368	) &
3369	* sigma_sb &
3370	* ( surf%pt_surface(m) * exner(nzb) )**4
3371
3372	surf%rad_sw_in(m) = ( surf%rad_net(m) - surf%rad_lw_in(m) &
3373	+ surf%rad_lw_out(m) ) &
3374	/ ( 1.0_wp - &
3375	( surf%frac(ind_veg_wall,m) * &
3376	surf%albedo(ind_veg_wall,m) &
3377	+ surf%frac(ind_pav_green,m) * &
3378	surf%albedo(ind_pav_green,m) &
3379	+ surf%frac(ind_wat_win,m) * &
3380	surf%albedo(ind_wat_win,m) ) &
3381	)
3382
3383	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3384	surf%albedo(ind_veg_wall,m) &
3385	+ surf%frac(ind_pav_green,m) * &
3386	surf%albedo(ind_pav_green,m) &
3387	+ surf%frac(ind_wat_win,m) * &
3388	surf%albedo(ind_wat_win,m) ) &
3389	* surf%rad_sw_in(m)
3390
3391	ENDDO
3392
3393	ENDIF
3394
3395	!
3396	!-- Fill out values in radiation arrays
3397	DO m = 1, surf%ns
3398	i = surf%i(m)
3399	j = surf%j(m)
3400	rad_sw_in(0,j,i) = surf%rad_sw_in(m)
3401	rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3402	rad_lw_in(0,j,i) = surf%rad_lw_in(m)
3403	rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3404	ENDDO
3405
3406	END SUBROUTINE radiation_constant_surf
3407
3408
3409	END SUBROUTINE radiation_constant
3410
3411	!------------------------------------------------------------------------------!
3412	! Description:
3413	! ------------
3414	!> Header output for radiation model
3415	!------------------------------------------------------------------------------!
3416	SUBROUTINE radiation_header ( io )
3417
3418
3419	IMPLICIT NONE
3420
3421	INTEGER(iwp), INTENT(IN) :: io !< Unit of the output file
3422
3423
3424
3425	!
3426	!-- Write radiation model header
3427	WRITE( io, 3 )
3428
3429	IF ( radiation_scheme == "constant" ) THEN
3430	WRITE( io, 4 ) net_radiation
3431	ELSEIF ( radiation_scheme == "clear-sky" ) THEN
3432	WRITE( io, 5 )
3433	ELSEIF ( radiation_scheme == "rrtmg" ) THEN
3434	WRITE( io, 6 )
3435	IF ( .NOT. lw_radiation ) WRITE( io, 10 )
3436	IF ( .NOT. sw_radiation ) WRITE( io, 11 )
3437	ELSEIF ( radiation_scheme == "external" ) THEN
3438	WRITE( io, 14 )
3439	ENDIF
3440
3441	IF ( albedo_type_f%from_file .OR. vegetation_type_f%from_file .OR. &
3442	pavement_type_f%from_file .OR. water_type_f%from_file .OR. &
3443	building_type_f%from_file ) THEN
3444	WRITE( io, 13 )
3445	ELSE
3446	IF ( albedo_type == 0 ) THEN
3447	WRITE( io, 7 ) albedo
3448	ELSE
3449	WRITE( io, 8 ) TRIM( albedo_type_name(albedo_type) )
3450	ENDIF
3451	ENDIF
3452	IF ( constant_albedo ) THEN
3453	WRITE( io, 9 )
3454	ENDIF
3455
3456	WRITE( io, 12 ) dt_radiation
3457
3458
3459	3 FORMAT (//' Radiation model information:'/ &
3460	' ----------------------------'/)
3461	4 FORMAT (' --> Using constant net radiation: net_radiation = ', F6.2, &
3462	// 'W/m**2')
3463	5 FORMAT (' --> Simple radiation scheme for clear sky is used (no clouds,',&
3464	' default)')
3465	6 FORMAT (' --> RRTMG scheme is used')
3466	7 FORMAT (/' User-specific surface albedo: albedo =', F6.3)
3467	8 FORMAT (/' Albedo is set for land surface type: ', A)
3468	9 FORMAT (/' --> Albedo is fixed during the run')
3469	10 FORMAT (/' --> Longwave radiation is disabled')
3470	11 FORMAT (/' --> Shortwave radiation is disabled.')
3471	12 FORMAT (' Timestep: dt_radiation = ', F6.2, ' s')
3472	13 FORMAT (/' Albedo is set individually for each xy-location, according ', &
3473	'to given surface type.')
3474	14 FORMAT (' --> External radiation forcing is used')
3475
3476
3477	END SUBROUTINE radiation_header
3478
3479
3480	!------------------------------------------------------------------------------!
3481	! Description:
3482	! ------------
3483	!> Parin for &radiation_parameters for radiation model
3484	!------------------------------------------------------------------------------!
3485	SUBROUTINE radiation_parin
3486
3487
3488	IMPLICIT NONE
3489
3490	CHARACTER (LEN=80) :: line !< dummy string that contains the current line of the parameter file
3491
3492	NAMELIST /radiation_par/ albedo, albedo_lw_dif, albedo_lw_dir, &
3493	albedo_sw_dif, albedo_sw_dir, albedo_type, &
3494	constant_albedo, dt_radiation, emissivity, &
3495	lw_radiation, max_raytracing_dist, &
3496	min_irrf_value, mrt_geom_human, &
3497	mrt_include_sw, mrt_nlevels, &
3498	mrt_skip_roof, net_radiation, nrefsteps, &
3499	plant_lw_interact, rad_angular_discretization,&
3500	radiation_interactions_on, radiation_scheme, &
3501	raytrace_discrete_azims, &
3502	raytrace_discrete_elevs, raytrace_mpi_rma, &
3503	skip_time_do_radiation, surface_reflections, &
3504	svfnorm_report_thresh, sw_radiation, &
3505	unscheduled_radiation_calls
3506
3507
3508	NAMELIST /radiation_parameters/ albedo, albedo_lw_dif, albedo_lw_dir, &
3509	albedo_sw_dif, albedo_sw_dir, albedo_type, &
3510	constant_albedo, dt_radiation, emissivity, &
3511	lw_radiation, max_raytracing_dist, &
3512	min_irrf_value, mrt_geom_human, &
3513	mrt_include_sw, mrt_nlevels, &
3514	mrt_skip_roof, net_radiation, nrefsteps, &
3515	plant_lw_interact, rad_angular_discretization,&
3516	radiation_interactions_on, radiation_scheme, &
3517	raytrace_discrete_azims, &
3518	raytrace_discrete_elevs, raytrace_mpi_rma, &
3519	skip_time_do_radiation, surface_reflections, &
3520	svfnorm_report_thresh, sw_radiation, &
3521	unscheduled_radiation_calls
3522
3523	line = ' '
3524
3525	!
3526	!-- Try to find radiation model namelist
3527	REWIND ( 11 )
3528	line = ' '
3529	DO WHILE ( INDEX( line, '&radiation_parameters' ) == 0 )
3530	READ ( 11, '(A)', END=12 ) line
3531	ENDDO
3532	BACKSPACE ( 11 )
3533
3534	!
3535	!-- Read user-defined namelist
3536	READ ( 11, radiation_parameters, ERR = 10 )
3537
3538	!
3539	!-- Set flag that indicates that the radiation model is switched on
3540	radiation = .TRUE.
3541
3542	GOTO 14
3543
3544	10 BACKSPACE( 11 )
3545	READ( 11 , '(A)') line
3546	CALL parin_fail_message( 'radiation_parameters', line )
3547	!
3548	!-- Try to find old namelist
3549	12 REWIND ( 11 )
3550	line = ' '
3551	DO WHILE ( INDEX( line, '&radiation_par' ) == 0 )
3552	READ ( 11, '(A)', END=14 ) line
3553	ENDDO
3554	BACKSPACE ( 11 )
3555
3556	!
3557	!-- Read user-defined namelist
3558	READ ( 11, radiation_par, ERR = 13, END = 14 )
3559
3560	message_string = 'namelist radiation_par is deprecated and will be ' // &
3561	'removed in near future. Please use namelist ' // &
3562	'radiation_parameters instead'
3563	CALL message( 'radiation_parin', 'PA0487', 0, 1, 0, 6, 0 )
3564
3565	!
3566	!-- Set flag that indicates that the radiation model is switched on
3567	radiation = .TRUE.
3568
3569	IF ( .NOT. radiation_interactions_on .AND. surface_reflections ) THEN
3570	message_string = 'surface_reflections is allowed only when ' // &
3571	'radiation_interactions_on is set to TRUE'
3572	CALL message( 'radiation_parin', 'PA0293',1, 2, 0, 6, 0 )
3573	ENDIF
3574
3575	GOTO 14
3576
3577	13 BACKSPACE( 11 )
3578	READ( 11 , '(A)') line
3579	CALL parin_fail_message( 'radiation_par', line )
3580
3581	14 CONTINUE
3582
3583	END SUBROUTINE radiation_parin
3584
3585
3586	!------------------------------------------------------------------------------!
3587	! Description:
3588	! ------------
3589	!> Implementation of the RRTMG radiation_scheme
3590	!------------------------------------------------------------------------------!
3591	SUBROUTINE radiation_rrtmg
3592
3593	#if defined ( __rrtmg )
3594	USE indices, &
3595	ONLY: nbgp
3596
3597	USE particle_attributes, &
3598	ONLY: grid_particles, number_of_particles, particles, prt_count
3599
3600	IMPLICIT NONE
3601
3602
3603	INTEGER(iwp) :: i, j, k, l, m, n !< loop indices
3604	INTEGER(iwp) :: k_topo_l !< topography top index
3605	INTEGER(iwp) :: k_topo !< topography top index
3606
3607	REAL(wp) :: nc_rad, & !< number concentration of cloud droplets
3608	s_r2, & !< weighted sum over all droplets with r^2
3609	s_r3 !< weighted sum over all droplets with r^3
3610
3611	REAL(wp), DIMENSION(0:nzt+1) :: pt_av, q_av, ql_av
3612	REAL(wp), DIMENSION(0:0) :: zenith !< to provide indexed array
3613	!
3614	!-- Just dummy arguments
3615	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rrtm_lw_taucld_dum, &
3616	rrtm_lw_tauaer_dum, &
3617	rrtm_sw_taucld_dum, &
3618	rrtm_sw_ssacld_dum, &
3619	rrtm_sw_asmcld_dum, &
3620	rrtm_sw_fsfcld_dum, &
3621	rrtm_sw_tauaer_dum, &
3622	rrtm_sw_ssaaer_dum, &
3623	rrtm_sw_asmaer_dum, &
3624	rrtm_sw_ecaer_dum
3625
3626	!
3627	!-- Calculate current (cosine of) zenith angle and whether the sun is up
3628	CALL calc_zenith
3629	zenith(0) = cos_zenith
3630	!
3631	!-- Calculate surface albedo. In case average radiation is applied,
3632	!-- this is not required.
3633	#if defined( __netcdf )
3634	IF ( .NOT. constant_albedo ) THEN
3635	!
3636	!-- Horizontally aligned default, natural and urban surfaces
3637	CALL calc_albedo( surf_lsm_h )
3638	CALL calc_albedo( surf_usm_h )
3639	!
3640	!-- Vertically aligned default, natural and urban surfaces
3641	DO l = 0, 3
3642	CALL calc_albedo( surf_lsm_v(l) )
3643	CALL calc_albedo( surf_usm_v(l) )
3644	ENDDO
3645	ENDIF
3646	#endif
3647
3648	!
3649	!-- Prepare input data for RRTMG
3650
3651	!
3652	!-- In case of large scale forcing with surface data, calculate new pressure
3653	!-- profile. nzt_rad might be modified by these calls and all required arrays
3654	!-- will then be re-allocated
3655	IF ( large_scale_forcing .AND. lsf_surf ) THEN
3656	CALL read_sounding_data
3657	CALL read_trace_gas_data
3658	ENDIF
3659
3660
3661	IF ( average_radiation ) THEN
3662	!
3663	!-- Determine minimum topography top index.
3664	k_topo_l = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
3665	#if defined( __parallel )
3666	CALL MPI_ALLREDUCE( k_topo_l, k_topo, 1, MPI_INTEGER, MPI_MIN, &
3667	comm2d, ierr)
3668	#else
3669	k_topo = k_topo_l
3670	#endif
3671
3672	rrtm_asdir(1) = albedo_urb
3673	rrtm_asdif(1) = albedo_urb
3674	rrtm_aldir(1) = albedo_urb
3675	rrtm_aldif(1) = albedo_urb
3676
3677	rrtm_emis = emissivity_urb
3678	!
3679	!-- Calculate mean pt profile.
3680	CALL calc_mean_profile( pt, 4 )
3681	pt_av = hom(:, 1, 4, 0)
3682
3683	IF ( humidity ) THEN
3684	CALL calc_mean_profile( q, 41 )
3685	q_av = hom(:, 1, 41, 0)
3686	ENDIF
3687	!
3688	!-- Prepare profiles of temperature and H2O volume mixing ratio
3689	rrtm_tlev(0,k_topo+1) = t_rad_urb
3690
3691	IF ( bulk_cloud_model ) THEN
3692
3693	CALL calc_mean_profile( ql, 54 )
3694	! average ql is now in hom(:, 1, 54, 0)
3695	ql_av = hom(:, 1, 54, 0)
3696
3697	DO k = nzb+1, nzt+1
3698	rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp &
3699	)*.286_wp + lv_d_cp ql_av(k)
3700	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q_av(k) - ql_av(k))
3701	ENDDO
3702	ELSE
3703	DO k = nzb+1, nzt+1
3704	rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp &
3705	)**.286_wp
3706	ENDDO
3707
3708	IF ( humidity ) THEN
3709	DO k = nzb+1, nzt+1
3710	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q_av(k)
3711	ENDDO
3712	ELSE
3713	rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp
3714	ENDIF
3715	ENDIF
3716
3717	!
3718	!-- Avoid temperature/humidity jumps at the top of the PALM domain by
3719	!-- linear interpolation from nzt+2 to nzt+7. Jumps are induced by
3720	!-- discrepancies between the values in the domain and those above that
3721	!-- are prescribed in RRTMG
3722	DO k = nzt+2, nzt+7
3723	rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) &
3724	+ ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) &
3725	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) &
3726	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
3727
3728	rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) &
3729	+ ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )&
3730	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )&
3731	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
3732
3733	ENDDO
3734
3735	!-- Linear interpolate to zw grid. Loop reaches one level further up
3736	!-- due to the staggered grid in RRTMG
3737	DO k = k_topo+2, nzt+8
3738	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - &
3739	rrtm_tlay(0,k-1)) &
3740	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
3741	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
3742	ENDDO
3743	!
3744	!-- Calculate liquid water path and cloud fraction for each column.
3745	!-- Note that LWP is required in g/m2 instead of kg/kg m.
3746	rrtm_cldfr = 0.0_wp
3747	rrtm_reliq = 0.0_wp
3748	rrtm_cliqwp = 0.0_wp
3749	rrtm_icld = 0
3750
3751	IF ( bulk_cloud_model ) THEN
3752	DO k = nzb+1, nzt+1
3753	rrtm_cliqwp(0,k) = ql_av(k) * 1000._wp * &
3754	(rrtm_plev(0,k) - rrtm_plev(0,k+1)) &
3755	* 100._wp / g
3756
3757	IF ( rrtm_cliqwp(0,k) > 0._wp ) THEN
3758	rrtm_cldfr(0,k) = 1._wp
3759	IF ( rrtm_icld == 0 ) rrtm_icld = 1
3760
3761	!
3762	!-- Calculate cloud droplet effective radius
3763	rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql_av(k) &
3764	* rho_surface &
3765	/ ( 4.0_wp * pi * nc_const * rho_l ) &
3766	)**0.33333333333333_wp &
3767	* EXP( LOG( sigma_gc )**2 )
3768	!
3769	!-- Limit effective radius
3770	IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN
3771	rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp)
3772	rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp)
3773	ENDIF
3774	ENDIF
3775	ENDDO
3776	ENDIF
3777
3778	!
3779	!-- Set surface temperature
3780	rrtm_tsfc = t_rad_urb
3781
3782	IF ( lw_radiation ) THEN
3783	!
3784	!-- Due to technical reasons, copy optical depth to dummy arguments
3785	!-- which are allocated on the exact size as the rrtmg_lw is called.
3786	!-- As one dimesion is allocated with zero size, compiler complains
3787	!-- that rank of the array does not match that of the
3788	!-- assumed-shaped arguments in the RRTMG library. In order to
3789	!-- avoid this, write to dummy arguments and give pass the entire
3790	!-- dummy array. Seems to be the only existing work-around.
3791	ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) )
3792	ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) )
3793
3794	rrtm_lw_taucld_dum = &
3795	rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1)
3796	rrtm_lw_tauaer_dum = &
3797	rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1)
3798
3799	CALL rrtmg_lw( 1, &
3800	nzt_rad-k_topo, &
3801	rrtm_icld, &
3802	rrtm_idrv, &
3803	rrtm_play(:,k_topo+1:), &
3804	rrtm_plev(:,k_topo+1:), &
3805	rrtm_tlay(:,k_topo+1:), &
3806	rrtm_tlev(:,k_topo+1:), &
3807	rrtm_tsfc, &
3808	rrtm_h2ovmr(:,k_topo+1:), &
3809	rrtm_o3vmr(:,k_topo+1:), &
3810	rrtm_co2vmr(:,k_topo+1:), &
3811	rrtm_ch4vmr(:,k_topo+1:), &
3812	rrtm_n2ovmr(:,k_topo+1:), &
3813	rrtm_o2vmr(:,k_topo+1:), &
3814	rrtm_cfc11vmr(:,k_topo+1:), &
3815	rrtm_cfc12vmr(:,k_topo+1:), &
3816	rrtm_cfc22vmr(:,k_topo+1:), &
3817	rrtm_ccl4vmr(:,k_topo+1:), &
3818	rrtm_emis, &
3819	rrtm_inflglw, &
3820	rrtm_iceflglw, &
3821	rrtm_liqflglw, &
3822	rrtm_cldfr(:,k_topo+1:), &
3823	rrtm_lw_taucld_dum, &
3824	rrtm_cicewp(:,k_topo+1:), &
3825	rrtm_cliqwp(:,k_topo+1:), &
3826	rrtm_reice(:,k_topo+1:), &
3827	rrtm_reliq(:,k_topo+1:), &
3828	rrtm_lw_tauaer_dum, &
3829	rrtm_lwuflx(:,k_topo:), &
3830	rrtm_lwdflx(:,k_topo:), &
3831	rrtm_lwhr(:,k_topo+1:), &
3832	rrtm_lwuflxc(:,k_topo:), &
3833	rrtm_lwdflxc(:,k_topo:), &
3834	rrtm_lwhrc(:,k_topo+1:), &
3835	rrtm_lwuflx_dt(:,k_topo:), &
3836	rrtm_lwuflxc_dt(:,k_topo:) )
3837
3838	DEALLOCATE ( rrtm_lw_taucld_dum )
3839	DEALLOCATE ( rrtm_lw_tauaer_dum )
3840	!
3841	!-- Save fluxes
3842	DO k = nzb, nzt+1
3843	rad_lw_in(k,:,:) = rrtm_lwdflx(0,k)
3844	rad_lw_out(k,:,:) = rrtm_lwuflx(0,k)
3845	ENDDO
3846	rad_lw_in_diff(:,:) = rad_lw_in(k_topo,:,:)
3847	!
3848	!-- Save heating rates (convert from K/d to K/h).
3849	!-- Further, even though an aggregated radiation is computed, map
3850	!-- signle-column profiles on top of any topography, in order to
3851	!-- obtain correct near surface radiation heating/cooling rates.
3852	DO i = nxl, nxr
3853	DO j = nys, nyn
3854	k_topo_l = topo_top_ind(j,i,0)
3855	DO k = k_topo_l+1, nzt+1
3856	rad_lw_hr(k,j,i) = rrtm_lwhr(0,k-k_topo_l) * d_hours_day
3857	rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k-k_topo_l) * d_hours_day
3858	ENDDO
3859	ENDDO
3860	ENDDO
3861
3862	ENDIF
3863
3864	IF ( sw_radiation .AND. sun_up ) THEN
3865	!
3866	!-- Due to technical reasons, copy optical depths and other
3867	!-- to dummy arguments which are allocated on the exact size as the
3868	!-- rrtmg_sw is called.
3869	!-- As one dimesion is allocated with zero size, compiler complains
3870	!-- that rank of the array does not match that of the
3871	!-- assumed-shaped arguments in the RRTMG library. In order to
3872	!-- avoid this, write to dummy arguments and give pass the entire
3873	!-- dummy array. Seems to be the only existing work-around.
3874	ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3875	ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3876	ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3877	ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3878	ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
3879	ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
3880	ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
3881	ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) )
3882
3883	rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3884	rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3885	rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3886	rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3887	rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
3888	rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
3889	rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
3890	rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1)
3891
3892	CALL rrtmg_sw( 1, &
3893	nzt_rad-k_topo, &
3894	rrtm_icld, &
3895	rrtm_iaer, &
3896	rrtm_play(:,k_topo+1:nzt_rad+1), &
3897	rrtm_plev(:,k_topo+1:nzt_rad+2), &
3898	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
3899	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
3900	rrtm_tsfc, &
3901	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
3902	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
3903	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
3904	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
3905	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
3906	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
3907	rrtm_asdir, &
3908	rrtm_asdif, &
3909	rrtm_aldir, &
3910	rrtm_aldif, &
3911	zenith, &
3912	0.0_wp, &
3913	day_of_year, &
3914	solar_constant, &
3915	rrtm_inflgsw, &
3916	rrtm_iceflgsw, &
3917	rrtm_liqflgsw, &
3918	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
3919	rrtm_sw_taucld_dum, &
3920	rrtm_sw_ssacld_dum, &
3921	rrtm_sw_asmcld_dum, &
3922	rrtm_sw_fsfcld_dum, &
3923	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
3924	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
3925	rrtm_reice(:,k_topo+1:nzt_rad+1), &
3926	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
3927	rrtm_sw_tauaer_dum, &
3928	rrtm_sw_ssaaer_dum, &
3929	rrtm_sw_asmaer_dum, &
3930	rrtm_sw_ecaer_dum, &
3931	rrtm_swuflx(:,k_topo:nzt_rad+1), &
3932	rrtm_swdflx(:,k_topo:nzt_rad+1), &
3933	rrtm_swhr(:,k_topo+1:nzt_rad+1), &
3934	rrtm_swuflxc(:,k_topo:nzt_rad+1), &
3935	rrtm_swdflxc(:,k_topo:nzt_rad+1), &
3936	rrtm_swhrc(:,k_topo+1:nzt_rad+1), &
3937	rrtm_dirdflux(:,k_topo:nzt_rad+1), &
3938	rrtm_difdflux(:,k_topo:nzt_rad+1) )
3939
3940	DEALLOCATE( rrtm_sw_taucld_dum )
3941	DEALLOCATE( rrtm_sw_ssacld_dum )
3942	DEALLOCATE( rrtm_sw_asmcld_dum )
3943	DEALLOCATE( rrtm_sw_fsfcld_dum )
3944	DEALLOCATE( rrtm_sw_tauaer_dum )
3945	DEALLOCATE( rrtm_sw_ssaaer_dum )
3946	DEALLOCATE( rrtm_sw_asmaer_dum )
3947	DEALLOCATE( rrtm_sw_ecaer_dum )
3948
3949	!
3950	!-- Save radiation fluxes for the entire depth of the model domain
3951	DO k = nzb, nzt+1
3952	rad_sw_in(k,:,:) = rrtm_swdflx(0,k)
3953	rad_sw_out(k,:,:) = rrtm_swuflx(0,k)
3954	ENDDO
3955	!-- Save direct and diffuse SW radiation at the surface (required by RTM)
3956	rad_sw_in_dir(:,:) = rrtm_dirdflux(0,k_topo)
3957	rad_sw_in_diff(:,:) = rrtm_difdflux(0,k_topo)
3958
3959	!
3960	!-- Save heating rates (convert from K/d to K/s)
3961	DO k = nzb+1, nzt+1
3962	rad_sw_hr(k,:,:) = rrtm_swhr(0,k) * d_hours_day
3963	rad_sw_cs_hr(k,:,:) = rrtm_swhrc(0,k) * d_hours_day
3964	ENDDO
3965	!
3966	!-- Solar radiation is zero during night
3967	ELSE
3968	rad_sw_in = 0.0_wp
3969	rad_sw_out = 0.0_wp
3970	rad_sw_in_dir(:,:) = 0.0_wp
3971	rad_sw_in_diff(:,:) = 0.0_wp
3972	ENDIF
3973	!
3974	!-- RRTMG is called for each (j,i) grid point separately, starting at the
3975	!-- highest topography level. Here no RTM is used since average_radiation is false
3976	ELSE
3977	!
3978	!-- Loop over all grid points
3979	DO i = nxl, nxr
3980	DO j = nys, nyn
3981
3982	!
3983	!-- Prepare profiles of temperature and H2O volume mixing ratio
3984	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
3985	rrtm_tlev(0,nzb+1) = surf_lsm_h%pt_surface(m) * exner(nzb)
3986	ENDDO
3987	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
3988	rrtm_tlev(0,nzb+1) = surf_usm_h%pt_surface(m) * exner(nzb)
3989	ENDDO
3990
3991
3992	IF ( bulk_cloud_model ) THEN
3993	DO k = nzb+1, nzt+1
3994	rrtm_tlay(0,k) = pt(k,j,i) * exner(k) &
3995	+ lv_d_cp * ql(k,j,i)
3996	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q(k,j,i) - ql(k,j,i))
3997	ENDDO
3998	ELSEIF ( cloud_droplets ) THEN
3999	DO k = nzb+1, nzt+1
4000	rrtm_tlay(0,k) = pt(k,j,i) * exner(k) &
4001	+ lv_d_cp * ql(k,j,i)
4002	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i)
4003	ENDDO
4004	ELSE
4005	DO k = nzb+1, nzt+1
4006	rrtm_tlay(0,k) = pt(k,j,i) * exner(k)
4007	ENDDO
4008
4009	IF ( humidity ) THEN
4010	DO k = nzb+1, nzt+1
4011	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i)
4012	ENDDO
4013	ELSE
4014	rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp
4015	ENDIF
4016	ENDIF
4017
4018	!
4019	!-- Avoid temperature/humidity jumps at the top of the LES domain by
4020	!-- linear interpolation from nzt+2 to nzt+7
4021	DO k = nzt+2, nzt+7
4022	rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) &
4023	+ ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) &
4024	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) &
4025	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
4026
4027	rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) &
4028	+ ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )&
4029	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )&
4030	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
4031
4032	ENDDO
4033
4034	!-- Linear interpolate to zw grid
4035	DO k = nzb+2, nzt+8
4036	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - &
4037	rrtm_tlay(0,k-1)) &
4038	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
4039	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
4040	ENDDO
4041
4042
4043	!
4044	!-- Calculate liquid water path and cloud fraction for each column.
4045	!-- Note that LWP is required in g/m2 instead of kg/kg m.
4046	rrtm_cldfr = 0.0_wp
4047	rrtm_reliq = 0.0_wp
4048	rrtm_cliqwp = 0.0_wp
4049	rrtm_icld = 0
4050
4051	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
4052	DO k = nzb+1, nzt+1
4053	rrtm_cliqwp(0,k) = ql(k,j,i) * 1000.0_wp * &
4054	(rrtm_plev(0,k) - rrtm_plev(0,k+1)) &
4055	* 100.0_wp / g
4056
4057	IF ( rrtm_cliqwp(0,k) > 0.0_wp ) THEN
4058	rrtm_cldfr(0,k) = 1.0_wp
4059	IF ( rrtm_icld == 0 ) rrtm_icld = 1
4060
4061	!
4062	!-- Calculate cloud droplet effective radius
4063	IF ( bulk_cloud_model ) THEN
4064	!
4065	!-- Calculete effective droplet radius. In case of using
4066	!-- cloud_scheme = 'morrison' and a non reasonable number
4067	!-- of cloud droplets the inital aerosol number
4068	!-- concentration is considered.
4069	IF ( microphysics_morrison ) THEN
4070	IF ( nc(k,j,i) > 1.0E-20_wp ) THEN
4071	nc_rad = nc(k,j,i)
4072	ELSE
4073	nc_rad = na_init
4074	ENDIF
4075	ELSE
4076	nc_rad = nc_const
4077	ENDIF
4078
4079	rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql(k,j,i) &
4080	* rho_surface &
4081	/ ( 4.0_wp * pi * nc_rad * rho_l ) &
4082	)**0.33333333333333_wp &
4083	* EXP( LOG( sigma_gc )**2 )
4084
4085	ELSEIF ( cloud_droplets ) THEN
4086	number_of_particles = prt_count(k,j,i)
4087
4088	IF (number_of_particles <= 0) CYCLE
4089	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
4090	s_r2 = 0.0_wp
4091	s_r3 = 0.0_wp
4092
4093	DO n = 1, number_of_particles
4094	IF ( particles(n)%particle_mask ) THEN
4095	s_r2 = s_r2 + particles(n)%radius*2 &
4096	particles(n)%weight_factor
4097	s_r3 = s_r3 + particles(n)%radius*3 &
4098	particles(n)%weight_factor
4099	ENDIF
4100	ENDDO
4101
4102	IF ( s_r2 > 0.0_wp ) rrtm_reliq(0,k) = s_r3 / s_r2
4103
4104	ENDIF
4105
4106	!
4107	!-- Limit effective radius
4108	IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN
4109	rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp)
4110	rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp)
4111	ENDIF
4112	ENDIF
4113	ENDDO
4114	ENDIF
4115
4116	!
4117	!-- Write surface emissivity and surface temperature at current
4118	!-- surface element on RRTMG-shaped array.
4119	!-- Please note, as RRTMG is a single column model, surface attributes
4120	!-- are only obtained from horizontally aligned surfaces (for
4121	!-- simplicity). Taking surface attributes from horizontal and
4122	!-- vertical walls would lead to multiple solutions.
4123	!-- Moreover, for natural- and urban-type surfaces, several surface
4124	!-- classes can exist at a surface element next to each other.
4125	!-- To obtain bulk parameters, apply a weighted average for these
4126	!-- surfaces.
4127	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
4128	rrtm_emis = surf_lsm_h%frac(ind_veg_wall,m) * &
4129	surf_lsm_h%emissivity(ind_veg_wall,m) + &
4130	surf_lsm_h%frac(ind_pav_green,m) * &
4131	surf_lsm_h%emissivity(ind_pav_green,m) + &
4132	surf_lsm_h%frac(ind_wat_win,m) * &
4133	surf_lsm_h%emissivity(ind_wat_win,m)
4134	rrtm_tsfc = surf_lsm_h%pt_surface(m) * exner(nzb)
4135	ENDDO
4136	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
4137	rrtm_emis = surf_usm_h%frac(ind_veg_wall,m) * &
4138	surf_usm_h%emissivity(ind_veg_wall,m) + &
4139	surf_usm_h%frac(ind_pav_green,m) * &
4140	surf_usm_h%emissivity(ind_pav_green,m) + &
4141	surf_usm_h%frac(ind_wat_win,m) * &
4142	surf_usm_h%emissivity(ind_wat_win,m)
4143	rrtm_tsfc = surf_usm_h%pt_surface(m) * exner(nzb)
4144	ENDDO
4145	!
4146	!-- Obtain topography top index (lower bound of RRTMG)
4147	k_topo = topo_top_ind(j,i,0)
4148
4149	IF ( lw_radiation ) THEN
4150	!
4151	!-- Due to technical reasons, copy optical depth to dummy arguments
4152	!-- which are allocated on the exact size as the rrtmg_lw is called.
4153	!-- As one dimesion is allocated with zero size, compiler complains
4154	!-- that rank of the array does not match that of the
4155	!-- assumed-shaped arguments in the RRTMG library. In order to
4156	!-- avoid this, write to dummy arguments and give pass the entire
4157	!-- dummy array. Seems to be the only existing work-around.
4158	ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) )
4159	ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) )
4160
4161	rrtm_lw_taucld_dum = &
4162	rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1)
4163	rrtm_lw_tauaer_dum = &
4164	rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1)
4165
4166	CALL rrtmg_lw( 1, &
4167	nzt_rad-k_topo, &
4168	rrtm_icld, &
4169	rrtm_idrv, &
4170	rrtm_play(:,k_topo+1:nzt_rad+1), &
4171	rrtm_plev(:,k_topo+1:nzt_rad+2), &
4172	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
4173	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
4174	rrtm_tsfc, &
4175	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
4176	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
4177	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
4178	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
4179	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
4180	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
4181	rrtm_cfc11vmr(:,k_topo+1:nzt_rad+1), &
4182	rrtm_cfc12vmr(:,k_topo+1:nzt_rad+1), &
4183	rrtm_cfc22vmr(:,k_topo+1:nzt_rad+1), &
4184	rrtm_ccl4vmr(:,k_topo+1:nzt_rad+1), &
4185	rrtm_emis, &
4186	rrtm_inflglw, &
4187	rrtm_iceflglw, &
4188	rrtm_liqflglw, &
4189	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
4190	rrtm_lw_taucld_dum, &
4191	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
4192	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
4193	rrtm_reice(:,k_topo+1:nzt_rad+1), &
4194	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
4195	rrtm_lw_tauaer_dum, &
4196	rrtm_lwuflx(:,k_topo:nzt_rad+1), &
4197	rrtm_lwdflx(:,k_topo:nzt_rad+1), &
4198	rrtm_lwhr(:,k_topo+1:nzt_rad+1), &
4199	rrtm_lwuflxc(:,k_topo:nzt_rad+1), &
4200	rrtm_lwdflxc(:,k_topo:nzt_rad+1), &
4201	rrtm_lwhrc(:,k_topo+1:nzt_rad+1), &
4202	rrtm_lwuflx_dt(:,k_topo:nzt_rad+1), &
4203	rrtm_lwuflxc_dt(:,k_topo:nzt_rad+1) )
4204
4205	DEALLOCATE ( rrtm_lw_taucld_dum )
4206	DEALLOCATE ( rrtm_lw_tauaer_dum )
4207	!
4208	!-- Save fluxes
4209	DO k = k_topo, nzt+1
4210	rad_lw_in(k,j,i) = rrtm_lwdflx(0,k)
4211	rad_lw_out(k,j,i) = rrtm_lwuflx(0,k)
4212	ENDDO
4213
4214	!
4215	!-- Save heating rates (convert from K/d to K/h)
4216	DO k = k_topo+1, nzt+1
4217	rad_lw_hr(k,j,i) = rrtm_lwhr(0,k-k_topo) * d_hours_day
4218	rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k-k_topo) * d_hours_day
4219	ENDDO
4220
4221	!
4222	!-- Save surface radiative fluxes and change in LW heating rate
4223	!-- onto respective surface elements
4224	!-- Horizontal surfaces
4225	DO m = surf_lsm_h%start_index(j,i), &
4226	surf_lsm_h%end_index(j,i)
4227	surf_lsm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo)
4228	surf_lsm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo)
4229	surf_lsm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo)
4230	ENDDO
4231	DO m = surf_usm_h%start_index(j,i), &
4232	surf_usm_h%end_index(j,i)
4233	surf_usm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo)
4234	surf_usm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo)
4235	surf_usm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo)
4236	ENDDO
4237	!
4238	!-- Vertical surfaces. Fluxes are obtain at vertical level of the
4239	!-- respective surface element
4240	DO l = 0, 3
4241	DO m = surf_lsm_v(l)%start_index(j,i), &
4242	surf_lsm_v(l)%end_index(j,i)
4243	k = surf_lsm_v(l)%k(m)
4244	surf_lsm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k)
4245	surf_lsm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k)
4246	surf_lsm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
4247	ENDDO
4248	DO m = surf_usm_v(l)%start_index(j,i), &
4249	surf_usm_v(l)%end_index(j,i)
4250	k = surf_usm_v(l)%k(m)
4251	surf_usm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k)
4252	surf_usm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k)
4253	surf_usm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
4254	ENDDO
4255	ENDDO
4256
4257	ENDIF
4258
4259	IF ( sw_radiation .AND. sun_up ) THEN
4260	!
4261	!-- Get albedo for direct/diffusive long/shortwave radiation at
4262	!-- current (y,x)-location from surface variables.
4263	!-- Only obtain it from horizontal surfaces, as RRTMG is a single
4264	!-- column model
4265	!-- (Please note, only one loop will entered, controlled by
4266	!-- start-end index.)
4267	DO m = surf_lsm_h%start_index(j,i), &
4268	surf_lsm_h%end_index(j,i)
4269	rrtm_asdir(1) = SUM( surf_lsm_h%frac(:,m) * &
4270	surf_lsm_h%rrtm_asdir(:,m) )
4271	rrtm_asdif(1) = SUM( surf_lsm_h%frac(:,m) * &
4272	surf_lsm_h%rrtm_asdif(:,m) )
4273	rrtm_aldir(1) = SUM( surf_lsm_h%frac(:,m) * &
4274	surf_lsm_h%rrtm_aldir(:,m) )
4275	rrtm_aldif(1) = SUM( surf_lsm_h%frac(:,m) * &
4276	surf_lsm_h%rrtm_aldif(:,m) )
4277	ENDDO
4278	DO m = surf_usm_h%start_index(j,i), &
4279	surf_usm_h%end_index(j,i)
4280	rrtm_asdir(1) = SUM( surf_usm_h%frac(:,m) * &
4281	surf_usm_h%rrtm_asdir(:,m) )
4282	rrtm_asdif(1) = SUM( surf_usm_h%frac(:,m) * &
4283	surf_usm_h%rrtm_asdif(:,m) )
4284	rrtm_aldir(1) = SUM( surf_usm_h%frac(:,m) * &
4285	surf_usm_h%rrtm_aldir(:,m) )
4286	rrtm_aldif(1) = SUM( surf_usm_h%frac(:,m) * &
4287	surf_usm_h%rrtm_aldif(:,m) )
4288	ENDDO
4289	!
4290	!-- Due to technical reasons, copy optical depths and other
4291	!-- to dummy arguments which are allocated on the exact size as the
4292	!-- rrtmg_sw is called.
4293	!-- As one dimesion is allocated with zero size, compiler complains
4294	!-- that rank of the array does not match that of the
4295	!-- assumed-shaped arguments in the RRTMG library. In order to
4296	!-- avoid this, write to dummy arguments and give pass the entire
4297	!-- dummy array. Seems to be the only existing work-around.
4298	ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4299	ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4300	ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4301	ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4302	ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4303	ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4304	ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4305	ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) )
4306
4307	rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4308	rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4309	rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4310	rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4311	rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4312	rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4313	rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4314	rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1)
4315
4316	CALL rrtmg_sw( 1, &
4317	nzt_rad-k_topo, &
4318	rrtm_icld, &
4319	rrtm_iaer, &
4320	rrtm_play(:,k_topo+1:nzt_rad+1), &
4321	rrtm_plev(:,k_topo+1:nzt_rad+2), &
4322	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
4323	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
4324	rrtm_tsfc, &
4325	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
4326	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
4327	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
4328	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
4329	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
4330	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
4331	rrtm_asdir, &
4332	rrtm_asdif, &
4333	rrtm_aldir, &
4334	rrtm_aldif, &
4335	zenith, &
4336	0.0_wp, &
4337	day_of_year, &
4338	solar_constant, &
4339	rrtm_inflgsw, &
4340	rrtm_iceflgsw, &
4341	rrtm_liqflgsw, &
4342	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
4343	rrtm_sw_taucld_dum, &
4344	rrtm_sw_ssacld_dum, &
4345	rrtm_sw_asmcld_dum, &
4346	rrtm_sw_fsfcld_dum, &
4347	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
4348	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
4349	rrtm_reice(:,k_topo+1:nzt_rad+1), &
4350	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
4351	rrtm_sw_tauaer_dum, &
4352	rrtm_sw_ssaaer_dum, &
4353	rrtm_sw_asmaer_dum, &
4354	rrtm_sw_ecaer_dum, &
4355	rrtm_swuflx(:,k_topo:nzt_rad+1), &
4356	rrtm_swdflx(:,k_topo:nzt_rad+1), &
4357	rrtm_swhr(:,k_topo+1:nzt_rad+1), &
4358	rrtm_swuflxc(:,k_topo:nzt_rad+1), &
4359	rrtm_swdflxc(:,k_topo:nzt_rad+1), &
4360	rrtm_swhrc(:,k_topo+1:nzt_rad+1), &
4361	rrtm_dirdflux(:,k_topo:nzt_rad+1), &
4362	rrtm_difdflux(:,k_topo:nzt_rad+1) )
4363
4364	DEALLOCATE( rrtm_sw_taucld_dum )
4365	DEALLOCATE( rrtm_sw_ssacld_dum )
4366	DEALLOCATE( rrtm_sw_asmcld_dum )
4367	DEALLOCATE( rrtm_sw_fsfcld_dum )
4368	DEALLOCATE( rrtm_sw_tauaer_dum )
4369	DEALLOCATE( rrtm_sw_ssaaer_dum )
4370	DEALLOCATE( rrtm_sw_asmaer_dum )
4371	DEALLOCATE( rrtm_sw_ecaer_dum )
4372	!
4373	!-- Save fluxes
4374	DO k = nzb, nzt+1
4375	rad_sw_in(k,j,i) = rrtm_swdflx(0,k)
4376	rad_sw_out(k,j,i) = rrtm_swuflx(0,k)
4377	ENDDO
4378	!
4379	!-- Save heating rates (convert from K/d to K/s)
4380	DO k = nzb+1, nzt+1
4381	rad_sw_hr(k,j,i) = rrtm_swhr(0,k) * d_hours_day
4382	rad_sw_cs_hr(k,j,i) = rrtm_swhrc(0,k) * d_hours_day
4383	ENDDO
4384
4385	!
4386	!-- Save surface radiative fluxes onto respective surface elements
4387	!-- Horizontal surfaces
4388	DO m = surf_lsm_h%start_index(j,i), &
4389	surf_lsm_h%end_index(j,i)
4390	surf_lsm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo)
4391	surf_lsm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo)
4392	ENDDO
4393	DO m = surf_usm_h%start_index(j,i), &
4394	surf_usm_h%end_index(j,i)
4395	surf_usm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo)
4396	surf_usm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo)
4397	ENDDO
4398	!
4399	!-- Vertical surfaces. Fluxes are obtain at respective vertical
4400	!-- level of the surface element
4401	DO l = 0, 3
4402	DO m = surf_lsm_v(l)%start_index(j,i), &
4403	surf_lsm_v(l)%end_index(j,i)
4404	k = surf_lsm_v(l)%k(m)
4405	surf_lsm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k)
4406	surf_lsm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
4407	ENDDO
4408	DO m = surf_usm_v(l)%start_index(j,i), &
4409	surf_usm_v(l)%end_index(j,i)
4410	k = surf_usm_v(l)%k(m)
4411	surf_usm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k)
4412	surf_usm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
4413	ENDDO
4414	ENDDO
4415	!
4416	!-- Solar radiation is zero during night
4417	ELSE
4418	rad_sw_in = 0.0_wp
4419	rad_sw_out = 0.0_wp
4420	!-- !!!!!!!! ATTENSION !!!!!!!!!!!!!!!
4421	!-- Surface radiative fluxes should be also set to zero here
4422	!-- Save surface radiative fluxes onto respective surface elements
4423	!-- Horizontal surfaces
4424	DO m = surf_lsm_h%start_index(j,i), &
4425	surf_lsm_h%end_index(j,i)
4426	surf_lsm_h%rad_sw_in(m) = 0.0_wp
4427	surf_lsm_h%rad_sw_out(m) = 0.0_wp
4428	ENDDO
4429	DO m = surf_usm_h%start_index(j,i), &
4430	surf_usm_h%end_index(j,i)
4431	surf_usm_h%rad_sw_in(m) = 0.0_wp
4432	surf_usm_h%rad_sw_out(m) = 0.0_wp
4433	ENDDO
4434	!
4435	!-- Vertical surfaces. Fluxes are obtain at respective vertical
4436	!-- level of the surface element
4437	DO l = 0, 3
4438	DO m = surf_lsm_v(l)%start_index(j,i), &
4439	surf_lsm_v(l)%end_index(j,i)
4440	k = surf_lsm_v(l)%k(m)
4441	surf_lsm_v(l)%rad_sw_in(m) = 0.0_wp
4442	surf_lsm_v(l)%rad_sw_out(m) = 0.0_wp
4443	ENDDO
4444	DO m = surf_usm_v(l)%start_index(j,i), &
4445	surf_usm_v(l)%end_index(j,i)
4446	k = surf_usm_v(l)%k(m)
4447	surf_usm_v(l)%rad_sw_in(m) = 0.0_wp
4448	surf_usm_v(l)%rad_sw_out(m) = 0.0_wp
4449	ENDDO
4450	ENDDO
4451	ENDIF
4452
4453	ENDDO
4454	ENDDO
4455
4456	ENDIF
4457	!
4458	!-- Finally, calculate surface net radiation for surface elements.
4459	IF ( .NOT. radiation_interactions ) THEN
4460	!-- First, for horizontal surfaces
4461	DO m = 1, surf_lsm_h%ns
4462	surf_lsm_h%rad_net(m) = surf_lsm_h%rad_sw_in(m) &
4463	- surf_lsm_h%rad_sw_out(m) &
4464	+ surf_lsm_h%rad_lw_in(m) &
4465	- surf_lsm_h%rad_lw_out(m)
4466	ENDDO
4467	DO m = 1, surf_usm_h%ns
4468	surf_usm_h%rad_net(m) = surf_usm_h%rad_sw_in(m) &
4469	- surf_usm_h%rad_sw_out(m) &
4470	+ surf_usm_h%rad_lw_in(m) &
4471	- surf_usm_h%rad_lw_out(m)
4472	ENDDO
4473	!
4474	!-- Vertical surfaces.
4475	!-- Todo: weight with azimuth and zenith angle according to their orientation!
4476	DO l = 0, 3
4477	DO m = 1, surf_lsm_v(l)%ns
4478	surf_lsm_v(l)%rad_net(m) = surf_lsm_v(l)%rad_sw_in(m) &
4479	- surf_lsm_v(l)%rad_sw_out(m) &
4480	+ surf_lsm_v(l)%rad_lw_in(m) &
4481	- surf_lsm_v(l)%rad_lw_out(m)
4482	ENDDO
4483	DO m = 1, surf_usm_v(l)%ns
4484	surf_usm_v(l)%rad_net(m) = surf_usm_v(l)%rad_sw_in(m) &
4485	- surf_usm_v(l)%rad_sw_out(m) &
4486	+ surf_usm_v(l)%rad_lw_in(m) &
4487	- surf_usm_v(l)%rad_lw_out(m)
4488	ENDDO
4489	ENDDO
4490	ENDIF
4491
4492
4493	CALL exchange_horiz( rad_lw_in, nbgp )
4494	CALL exchange_horiz( rad_lw_out, nbgp )
4495	CALL exchange_horiz( rad_lw_hr, nbgp )
4496	CALL exchange_horiz( rad_lw_cs_hr, nbgp )
4497
4498	CALL exchange_horiz( rad_sw_in, nbgp )
4499	CALL exchange_horiz( rad_sw_out, nbgp )
4500	CALL exchange_horiz( rad_sw_hr, nbgp )
4501	CALL exchange_horiz( rad_sw_cs_hr, nbgp )
4502
4503	#endif
4504
4505	END SUBROUTINE radiation_rrtmg
4506
4507
4508	!------------------------------------------------------------------------------!
4509	! Description:
4510	! ------------
4511	!> Calculate the cosine of the zenith angle (variable is called zenith)
4512	!------------------------------------------------------------------------------!
4513	SUBROUTINE calc_zenith
4514
4515	IMPLICIT NONE
4516
4517	REAL(wp) :: declination, & !< solar declination angle
4518	hour_angle !< solar hour angle
4519	!
4520	!-- Calculate current day and time based on the initial values and simulation
4521	!-- time
4522	CALL calc_date_and_time
4523
4524	!
4525	!-- Calculate solar declination and hour angle
4526	declination = ASIN( decl_1 * SIN(decl_2 * REAL(day_of_year, KIND=wp) - decl_3) )
4527	hour_angle = 2.0_wp * pi * (time_utc / 86400.0_wp) + lon - pi
4528
4529	!
4530	!-- Calculate cosine of solar zenith angle
4531	cos_zenith = SIN(lat) * SIN(declination) + COS(lat) * COS(declination) &
4532	* COS(hour_angle)
4533	cos_zenith = MAX(0.0_wp,cos_zenith)
4534
4535	!
4536	!-- Calculate solar directional vector
4537	IF ( sun_direction ) THEN
4538
4539	!
4540	!-- Direction in longitudes equals to sin(solar_azimuth) * sin(zenith)
4541	sun_dir_lon = -SIN(hour_angle) * COS(declination)
4542
4543	!
4544	!-- Direction in latitues equals to cos(solar_azimuth) * sin(zenith)
4545	sun_dir_lat = SIN(declination) * COS(lat) - COS(hour_angle) &
4546	* COS(declination) * SIN(lat)
4547	ENDIF
4548
4549	!
4550	!-- Check if the sun is up (otheriwse shortwave calculations can be skipped)
4551	IF ( cos_zenith > 0.0_wp ) THEN
4552	sun_up = .TRUE.
4553	ELSE
4554	sun_up = .FALSE.
4555	END IF
4556
4557	END SUBROUTINE calc_zenith
4558
4559	#if defined ( __rrtmg ) && defined ( __netcdf )
4560	!------------------------------------------------------------------------------!
4561	! Description:
4562	! ------------
4563	!> Calculates surface albedo components based on Briegleb (1992) and
4564	!> Briegleb et al. (1986)
4565	!------------------------------------------------------------------------------!
4566	SUBROUTINE calc_albedo( surf )
4567
4568	IMPLICIT NONE
4569
4570	INTEGER(iwp) :: ind_type !< running index surface tiles
4571	INTEGER(iwp) :: m !< running index surface elements
4572
4573	TYPE(surf_type) :: surf !< treated surfaces
4574
4575	IF ( sun_up .AND. .NOT. average_radiation ) THEN
4576
4577	DO m = 1, surf%ns
4578	!
4579	!-- Loop over surface elements
4580	DO ind_type = 0, SIZE( surf%albedo_type, 1 ) - 1
4581
4582	!
4583	!-- Ocean
4584	IF ( surf%albedo_type(ind_type,m) == 1 ) THEN
4585	surf%rrtm_aldir(ind_type,m) = 0.026_wp / &
4586	( cos_zenith**1.7_wp + 0.065_wp )&
4587	+ 0.15_wp * ( cos_zenith - 0.1_wp ) &
4588	* ( cos_zenith - 0.5_wp ) &
4589	* ( cos_zenith - 1.0_wp )
4590	surf%rrtm_asdir(ind_type,m) = surf%rrtm_aldir(ind_type,m)
4591	!
4592	!-- Snow
4593	ELSEIF ( surf%albedo_type(ind_type,m) == 16 ) THEN
4594	IF ( cos_zenith < 0.5_wp ) THEN
4595	surf%rrtm_aldir(ind_type,m) = &
4596	0.5_wp * ( 1.0_wp - surf%aldif(ind_type,m) ) &
4597	* ( 3.0_wp / ( 1.0_wp + 4.0_wp &
4598	* cos_zenith ) ) - 1.0_wp
4599	surf%rrtm_asdir(ind_type,m) = &
4600	0.5_wp * ( 1.0_wp - surf%asdif(ind_type,m) ) &
4601	* ( 3.0_wp / ( 1.0_wp + 4.0_wp &
4602	* cos_zenith ) ) - 1.0_wp
4603
4604	surf%rrtm_aldir(ind_type,m) = &
4605	MIN(0.98_wp, surf%rrtm_aldir(ind_type,m))
4606	surf%rrtm_asdir(ind_type,m) = &
4607	MIN(0.98_wp, surf%rrtm_asdir(ind_type,m))
4608	ELSE
4609	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4610	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4611	ENDIF
4612	!
4613	!-- Sea ice
4614	ELSEIF ( surf%albedo_type(ind_type,m) == 15 ) THEN
4615	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4616	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4617
4618	!
4619	!-- Asphalt
4620	ELSEIF ( surf%albedo_type(ind_type,m) == 17 ) THEN
4621	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4622	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4623
4624
4625	!
4626	!-- Bare soil
4627	ELSEIF ( surf%albedo_type(ind_type,m) == 18 ) THEN
4628	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4629	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4630
4631	!
4632	!-- Land surfaces
4633	ELSE
4634	SELECT CASE ( surf%albedo_type(ind_type,m) )
4635
4636	!
4637	!-- Surface types with strong zenith dependence
4638	CASE ( 1, 2, 3, 4, 11, 12, 13 )
4639	surf%rrtm_aldir(ind_type,m) = &
4640	surf%aldif(ind_type,m) * 1.4_wp / &
4641	( 1.0_wp + 0.8_wp * cos_zenith )
4642	surf%rrtm_asdir(ind_type,m) = &
4643	surf%asdif(ind_type,m) * 1.4_wp / &
4644	( 1.0_wp + 0.8_wp * cos_zenith )
4645	!
4646	!-- Surface types with weak zenith dependence
4647	CASE ( 5, 6, 7, 8, 9, 10, 14 )
4648	surf%rrtm_aldir(ind_type,m) = &
4649	surf%aldif(ind_type,m) * 1.1_wp / &
4650	( 1.0_wp + 0.2_wp * cos_zenith )
4651	surf%rrtm_asdir(ind_type,m) = &
4652	surf%asdif(ind_type,m) * 1.1_wp / &
4653	( 1.0_wp + 0.2_wp * cos_zenith )
4654
4655	CASE DEFAULT
4656
4657	END SELECT
4658	ENDIF
4659	!
4660	!-- Diffusive albedo is taken from Table 2
4661	surf%rrtm_aldif(ind_type,m) = surf%aldif(ind_type,m)
4662	surf%rrtm_asdif(ind_type,m) = surf%asdif(ind_type,m)
4663	ENDDO
4664	ENDDO
4665	!
4666	!-- Set albedo in case of average radiation
4667	ELSEIF ( sun_up .AND. average_radiation ) THEN
4668	surf%rrtm_asdir = albedo_urb
4669	surf%rrtm_asdif = albedo_urb
4670	surf%rrtm_aldir = albedo_urb
4671	surf%rrtm_aldif = albedo_urb
4672	!
4673	!-- Darkness
4674	ELSE
4675	surf%rrtm_aldir = 0.0_wp
4676	surf%rrtm_asdir = 0.0_wp
4677	surf%rrtm_aldif = 0.0_wp
4678	surf%rrtm_asdif = 0.0_wp
4679	ENDIF
4680
4681	END SUBROUTINE calc_albedo
4682
4683	!------------------------------------------------------------------------------!
4684	! Description:
4685	! ------------
4686	!> Read sounding data (pressure and temperature) from RADIATION_DATA.
4687	!------------------------------------------------------------------------------!
4688	SUBROUTINE read_sounding_data
4689
4690	IMPLICIT NONE
4691
4692	INTEGER(iwp) :: id, & !< NetCDF id of input file
4693	id_dim_zrad, & !< pressure level id in the NetCDF file
4694	id_var, & !< NetCDF variable id
4695	k, & !< loop index
4696	nz_snd, & !< number of vertical levels in the sounding data
4697	nz_snd_start, & !< start vertical index for sounding data to be used
4698	nz_snd_end !< end vertical index for souding data to be used
4699
4700	REAL(wp) :: t_surface !< actual surface temperature
4701
4702	REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd_tmp, & !< temporary hydrostatic pressure profile (sounding)
4703	t_snd_tmp !< temporary temperature profile (sounding)
4704
4705	!
4706	!-- In case of updates, deallocate arrays first (sufficient to check one
4707	!-- array as the others are automatically allocated). This is required
4708	!-- because nzt_rad might change during the update
4709	IF ( ALLOCATED ( hyp_snd ) ) THEN
4710	DEALLOCATE( hyp_snd )
4711	DEALLOCATE( t_snd )
4712	DEALLOCATE ( rrtm_play )
4713	DEALLOCATE ( rrtm_plev )
4714	DEALLOCATE ( rrtm_tlay )
4715	DEALLOCATE ( rrtm_tlev )
4716
4717	DEALLOCATE ( rrtm_cicewp )
4718	DEALLOCATE ( rrtm_cldfr )
4719	DEALLOCATE ( rrtm_cliqwp )
4720	DEALLOCATE ( rrtm_reice )
4721	DEALLOCATE ( rrtm_reliq )
4722	DEALLOCATE ( rrtm_lw_taucld )
4723	DEALLOCATE ( rrtm_lw_tauaer )
4724
4725	DEALLOCATE ( rrtm_lwdflx )
4726	DEALLOCATE ( rrtm_lwdflxc )
4727	DEALLOCATE ( rrtm_lwuflx )
4728	DEALLOCATE ( rrtm_lwuflxc )
4729	DEALLOCATE ( rrtm_lwuflx_dt )
4730	DEALLOCATE ( rrtm_lwuflxc_dt )
4731	DEALLOCATE ( rrtm_lwhr )
4732	DEALLOCATE ( rrtm_lwhrc )
4733
4734	DEALLOCATE ( rrtm_sw_taucld )
4735	DEALLOCATE ( rrtm_sw_ssacld )
4736	DEALLOCATE ( rrtm_sw_asmcld )
4737	DEALLOCATE ( rrtm_sw_fsfcld )
4738	DEALLOCATE ( rrtm_sw_tauaer )
4739	DEALLOCATE ( rrtm_sw_ssaaer )
4740	DEALLOCATE ( rrtm_sw_asmaer )
4741	DEALLOCATE ( rrtm_sw_ecaer )
4742
4743	DEALLOCATE ( rrtm_swdflx )
4744	DEALLOCATE ( rrtm_swdflxc )
4745	DEALLOCATE ( rrtm_swuflx )
4746	DEALLOCATE ( rrtm_swuflxc )
4747	DEALLOCATE ( rrtm_swhr )
4748	DEALLOCATE ( rrtm_swhrc )
4749	DEALLOCATE ( rrtm_dirdflux )
4750	DEALLOCATE ( rrtm_difdflux )
4751
4752	ENDIF
4753
4754	!
4755	!-- Open file for reading
4756	nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id )
4757	CALL netcdf_handle_error_rad( 'read_sounding_data', 549 )
4758
4759	!
4760	!-- Inquire dimension of z axis and save in nz_snd
4761	nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim_zrad )
4762	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim_zrad, len = nz_snd )
4763	CALL netcdf_handle_error_rad( 'read_sounding_data', 551 )
4764
4765	!
4766	! !-- Allocate temporary array for storing pressure data
4767	ALLOCATE( hyp_snd_tmp(1:nz_snd) )
4768	hyp_snd_tmp = 0.0_wp
4769
4770
4771	!-- Read pressure from file
4772	nc_stat = NF90_INQ_VARID( id, "Pressure", id_var )
4773	nc_stat = NF90_GET_VAR( id, id_var, hyp_snd_tmp(:), start = (/1/), &
4774	count = (/nz_snd/) )
4775	CALL netcdf_handle_error_rad( 'read_sounding_data', 552 )
4776
4777	!
4778	!-- Allocate temporary array for storing temperature data
4779	ALLOCATE( t_snd_tmp(1:nz_snd) )
4780	t_snd_tmp = 0.0_wp
4781
4782	!
4783	!-- Read temperature from file
4784	nc_stat = NF90_INQ_VARID( id, "ReferenceTemperature", id_var )
4785	nc_stat = NF90_GET_VAR( id, id_var, t_snd_tmp(:), start = (/1/), &
4786	count = (/nz_snd/) )
4787	CALL netcdf_handle_error_rad( 'read_sounding_data', 553 )
4788
4789	!
4790	!-- Calculate start of sounding data
4791	nz_snd_start = nz_snd + 1
4792	nz_snd_end = nz_snd + 1
4793
4794	!
4795	!-- Start filling vertical dimension at 10hPa above the model domain (hyp is
4796	!-- in Pa, hyp_snd in hPa).
4797	DO k = 1, nz_snd
4798	IF ( hyp_snd_tmp(k) < ( hyp(nzt+1) - 1000.0_wp) * 0.01_wp ) THEN
4799	nz_snd_start = k
4800	EXIT
4801	END IF
4802	END DO
4803
4804	IF ( nz_snd_start <= nz_snd ) THEN
4805	nz_snd_end = nz_snd
4806	END IF
4807
4808
4809	!
4810	!-- Calculate of total grid points for RRTMG calculations
4811	nzt_rad = nzt + nz_snd_end - nz_snd_start + 1
4812
4813	!
4814	!-- Save data above LES domain in hyp_snd, t_snd
4815	ALLOCATE( hyp_snd(nzb+1:nzt_rad) )
4816	ALLOCATE( t_snd(nzb+1:nzt_rad) )
4817	hyp_snd = 0.0_wp
4818	t_snd = 0.0_wp
4819
4820	hyp_snd(nzt+2:nzt_rad) = hyp_snd_tmp(nz_snd_start+1:nz_snd_end)
4821	t_snd(nzt+2:nzt_rad) = t_snd_tmp(nz_snd_start+1:nz_snd_end)
4822
4823	nc_stat = NF90_CLOSE( id )
4824
4825	!
4826	!-- Calculate pressure levels on zu and zw grid. Sounding data is added at
4827	!-- top of the LES domain. This routine does not consider horizontal or
4828	!-- vertical variability of pressure and temperature
4829	ALLOCATE ( rrtm_play(0:0,nzb+1:nzt_rad+1) )
4830	ALLOCATE ( rrtm_plev(0:0,nzb+1:nzt_rad+2) )
4831
4832	t_surface = pt_surface * exner(nzb)
4833	DO k = nzb+1, nzt+1
4834	rrtm_play(0,k) = hyp(k) * 0.01_wp
4835	rrtm_plev(0,k) = barometric_formula(zw(k-1), &
4836	pt_surface * exner(nzb), &
4837	surface_pressure )
4838	ENDDO
4839
4840	DO k = nzt+2, nzt_rad
4841	rrtm_play(0,k) = hyp_snd(k)
4842	rrtm_plev(0,k) = 0.5_wp * ( rrtm_play(0,k) + rrtm_play(0,k-1) )
4843	ENDDO
4844	rrtm_plev(0,nzt_rad+1) = MAX( 0.5 * hyp_snd(nzt_rad), &
4845	1.5 * hyp_snd(nzt_rad) &
4846	- 0.5 * hyp_snd(nzt_rad-1) )
4847	rrtm_plev(0,nzt_rad+2) = MIN( 1.0E-4_wp, &
4848	0.25_wp * rrtm_plev(0,nzt_rad+1) )
4849
4850	rrtm_play(0,nzt_rad+1) = 0.5 * rrtm_plev(0,nzt_rad+1)
4851
4852	!
4853	!-- Calculate temperature/humidity levels at top of the LES domain.
4854	!-- Currently, the temperature is taken from sounding data (might lead to a
4855	!-- temperature jump at interface. To do: Humidity is currently not
4856	!-- calculated above the LES domain.
4857	ALLOCATE ( rrtm_tlay(0:0,nzb+1:nzt_rad+1) )
4858	ALLOCATE ( rrtm_tlev(0:0,nzb+1:nzt_rad+2) )
4859
4860	DO k = nzt+8, nzt_rad
4861	rrtm_tlay(0,k) = t_snd(k)
4862	ENDDO
4863	rrtm_tlay(0,nzt_rad+1) = 2.0_wp * rrtm_tlay(0,nzt_rad) &
4864	- rrtm_tlay(0,nzt_rad-1)
4865	DO k = nzt+9, nzt_rad+1
4866	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) &
4867	- rrtm_tlay(0,k-1)) &
4868	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
4869	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
4870	ENDDO
4871
4872	rrtm_tlev(0,nzt_rad+2) = 2.0_wp * rrtm_tlay(0,nzt_rad+1) &
4873	- rrtm_tlev(0,nzt_rad)
4874	!
4875	!-- Allocate remaining RRTMG arrays
4876	ALLOCATE ( rrtm_cicewp(0:0,nzb+1:nzt_rad+1) )
4877	ALLOCATE ( rrtm_cldfr(0:0,nzb+1:nzt_rad+1) )
4878	ALLOCATE ( rrtm_cliqwp(0:0,nzb+1:nzt_rad+1) )
4879	ALLOCATE ( rrtm_reice(0:0,nzb+1:nzt_rad+1) )
4880	ALLOCATE ( rrtm_reliq(0:0,nzb+1:nzt_rad+1) )
4881	ALLOCATE ( rrtm_lw_taucld(1:nbndlw+1,0:0,nzb+1:nzt_rad+1) )
4882	ALLOCATE ( rrtm_lw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndlw+1) )
4883	ALLOCATE ( rrtm_sw_taucld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4884	ALLOCATE ( rrtm_sw_ssacld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4885	ALLOCATE ( rrtm_sw_asmcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4886	ALLOCATE ( rrtm_sw_fsfcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4887	ALLOCATE ( rrtm_sw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
4888	ALLOCATE ( rrtm_sw_ssaaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
4889	ALLOCATE ( rrtm_sw_asmaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
4890	ALLOCATE ( rrtm_sw_ecaer(0:0,nzb+1:nzt_rad+1,1:naerec+1) )
4891
4892	!
4893	!-- The ice phase is currently not considered in PALM
4894	rrtm_cicewp = 0.0_wp
4895	rrtm_reice = 0.0_wp
4896
4897	!
4898	!-- Set other parameters (move to NAMELIST parameters in the future)
4899	rrtm_lw_tauaer = 0.0_wp
4900	rrtm_lw_taucld = 0.0_wp
4901	rrtm_sw_taucld = 0.0_wp
4902	rrtm_sw_ssacld = 0.0_wp
4903	rrtm_sw_asmcld = 0.0_wp
4904	rrtm_sw_fsfcld = 0.0_wp
4905	rrtm_sw_tauaer = 0.0_wp
4906	rrtm_sw_ssaaer = 0.0_wp
4907	rrtm_sw_asmaer = 0.0_wp
4908	rrtm_sw_ecaer = 0.0_wp
4909
4910
4911	ALLOCATE ( rrtm_swdflx(0:0,nzb:nzt_rad+1) )
4912	ALLOCATE ( rrtm_swuflx(0:0,nzb:nzt_rad+1) )
4913	ALLOCATE ( rrtm_swhr(0:0,nzb+1:nzt_rad+1) )
4914	ALLOCATE ( rrtm_swuflxc(0:0,nzb:nzt_rad+1) )
4915	ALLOCATE ( rrtm_swdflxc(0:0,nzb:nzt_rad+1) )
4916	ALLOCATE ( rrtm_swhrc(0:0,nzb+1:nzt_rad+1) )
4917	ALLOCATE ( rrtm_dirdflux(0:0,nzb:nzt_rad+1) )
4918	ALLOCATE ( rrtm_difdflux(0:0,nzb:nzt_rad+1) )
4919
4920	rrtm_swdflx = 0.0_wp
4921	rrtm_swuflx = 0.0_wp
4922	rrtm_swhr = 0.0_wp
4923	rrtm_swuflxc = 0.0_wp
4924	rrtm_swdflxc = 0.0_wp
4925	rrtm_swhrc = 0.0_wp
4926	rrtm_dirdflux = 0.0_wp
4927	rrtm_difdflux = 0.0_wp
4928
4929	ALLOCATE ( rrtm_lwdflx(0:0,nzb:nzt_rad+1) )
4930	ALLOCATE ( rrtm_lwuflx(0:0,nzb:nzt_rad+1) )
4931	ALLOCATE ( rrtm_lwhr(0:0,nzb+1:nzt_rad+1) )
4932	ALLOCATE ( rrtm_lwuflxc(0:0,nzb:nzt_rad+1) )
4933	ALLOCATE ( rrtm_lwdflxc(0:0,nzb:nzt_rad+1) )
4934	ALLOCATE ( rrtm_lwhrc(0:0,nzb+1:nzt_rad+1) )
4935
4936	rrtm_lwdflx = 0.0_wp
4937	rrtm_lwuflx = 0.0_wp
4938	rrtm_lwhr = 0.0_wp
4939	rrtm_lwuflxc = 0.0_wp
4940	rrtm_lwdflxc = 0.0_wp
4941	rrtm_lwhrc = 0.0_wp
4942
4943	ALLOCATE ( rrtm_lwuflx_dt(0:0,nzb:nzt_rad+1) )
4944	ALLOCATE ( rrtm_lwuflxc_dt(0:0,nzb:nzt_rad+1) )
4945
4946	rrtm_lwuflx_dt = 0.0_wp
4947	rrtm_lwuflxc_dt = 0.0_wp
4948
4949	END SUBROUTINE read_sounding_data
4950
4951
4952	!------------------------------------------------------------------------------!
4953	! Description:
4954	! ------------
4955	!> Read trace gas data from file and convert into trace gas paths / volume
4956	!> mixing ratios. If a user-defined input file is provided it needs to follow
4957	!> the convections used in RRTMG (see respective netCDF files shipped with
4958	!> RRTMG)
4959	!------------------------------------------------------------------------------!
4960	SUBROUTINE read_trace_gas_data
4961
4962	USE rrsw_ncpar
4963
4964	IMPLICIT NONE
4965
4966	INTEGER(iwp), PARAMETER :: num_trace_gases = 10 !< number of trace gases (absorbers)
4967
4968	CHARACTER(LEN=5), DIMENSION(num_trace_gases), PARAMETER :: & !< trace gas names
4969	trace_names = (/'O3 ', 'CO2 ', 'CH4 ', 'N2O ', 'O2 ', &
4970	'CFC11', 'CFC12', 'CFC22', 'CCL4 ', 'H2O '/)
4971
4972	INTEGER(iwp) :: id, & !< NetCDF id
4973	k, & !< loop index
4974	m, & !< loop index
4975	n, & !< loop index
4976	nabs, & !< number of absorbers
4977	np, & !< number of pressure levels
4978	id_abs, & !< NetCDF id of the respective absorber
4979	id_dim, & !< NetCDF id of asborber's dimension
4980	id_var !< NetCDf id ot the absorber
4981
4982	REAL(wp) :: p_mls_l, & !< pressure lower limit for interpolation
4983	p_mls_u, & !< pressure upper limit for interpolation
4984	p_wgt_l, & !< pressure weight lower limit for interpolation
4985	p_wgt_u, & !< pressure weight upper limit for interpolation
4986	p_mls_m !< mean pressure between upper and lower limits
4987
4988
4989	REAL(wp), DIMENSION(:), ALLOCATABLE :: p_mls, & !< pressure levels for the absorbers
4990	rrtm_play_tmp, & !< temporary array for pressure zu-levels
4991	rrtm_plev_tmp, & !< temporary array for pressure zw-levels
4992	trace_path_tmp !< temporary array for storing trace gas path data
4993
4994	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: trace_mls, & !< array for storing the absorber amounts
4995	trace_mls_path, & !< array for storing trace gas path data
4996	trace_mls_tmp !< temporary array for storing trace gas data
4997
4998
4999	!
5000	!-- In case of updates, deallocate arrays first (sufficient to check one
5001	!-- array as the others are automatically allocated)
5002	IF ( ALLOCATED ( rrtm_o3vmr ) ) THEN
5003	DEALLOCATE ( rrtm_o3vmr )
5004	DEALLOCATE ( rrtm_co2vmr )
5005	DEALLOCATE ( rrtm_ch4vmr )
5006	DEALLOCATE ( rrtm_n2ovmr )
5007	DEALLOCATE ( rrtm_o2vmr )
5008	DEALLOCATE ( rrtm_cfc11vmr )
5009	DEALLOCATE ( rrtm_cfc12vmr )
5010	DEALLOCATE ( rrtm_cfc22vmr )
5011	DEALLOCATE ( rrtm_ccl4vmr )
5012	DEALLOCATE ( rrtm_h2ovmr )
5013	ENDIF
5014
5015	!
5016	!-- Allocate trace gas profiles
5017	ALLOCATE ( rrtm_o3vmr(0:0,1:nzt_rad+1) )
5018	ALLOCATE ( rrtm_co2vmr(0:0,1:nzt_rad+1) )
5019	ALLOCATE ( rrtm_ch4vmr(0:0,1:nzt_rad+1) )
5020	ALLOCATE ( rrtm_n2ovmr(0:0,1:nzt_rad+1) )
5021	ALLOCATE ( rrtm_o2vmr(0:0,1:nzt_rad+1) )
5022	ALLOCATE ( rrtm_cfc11vmr(0:0,1:nzt_rad+1) )
5023	ALLOCATE ( rrtm_cfc12vmr(0:0,1:nzt_rad+1) )
5024	ALLOCATE ( rrtm_cfc22vmr(0:0,1:nzt_rad+1) )
5025	ALLOCATE ( rrtm_ccl4vmr(0:0,1:nzt_rad+1) )
5026	ALLOCATE ( rrtm_h2ovmr(0:0,1:nzt_rad+1) )
5027
5028	!
5029	!-- Open file for reading
5030	nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id )
5031	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 549 )
5032	!
5033	!-- Inquire dimension ids and dimensions
5034	nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim )
5035	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5036	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = np)
5037	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5038
5039	nc_stat = NF90_INQ_DIMID( id, "Absorber", id_dim )
5040	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5041	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = nabs )
5042	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5043
5044
5045	!
5046	!-- Allocate pressure, and trace gas arrays
5047	ALLOCATE( p_mls(1:np) )
5048	ALLOCATE( trace_mls(1:num_trace_gases,1:np) )
5049	ALLOCATE( trace_mls_tmp(1:nabs,1:np) )
5050
5051
5052	nc_stat = NF90_INQ_VARID( id, "Pressure", id_var )
5053	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5054	nc_stat = NF90_GET_VAR( id, id_var, p_mls )
5055	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5056
5057	nc_stat = NF90_INQ_VARID( id, "AbsorberAmountMLS", id_var )
5058	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5059	nc_stat = NF90_GET_VAR( id, id_var, trace_mls_tmp )
5060	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5061
5062
5063	!
5064	!-- Write absorber amounts (mls) to trace_mls
5065	DO n = 1, num_trace_gases
5066	CALL getAbsorberIndex( TRIM( trace_names(n) ), id_abs )
5067
5068	trace_mls(n,1:np) = trace_mls_tmp(id_abs,1:np)
5069
5070	!
5071	!-- Replace missing values by zero
5072	WHERE ( trace_mls(n,:) > 2.0_wp )
5073	trace_mls(n,:) = 0.0_wp
5074	END WHERE
5075	END DO
5076
5077	DEALLOCATE ( trace_mls_tmp )
5078
5079	nc_stat = NF90_CLOSE( id )
5080	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 551 )
5081
5082	!
5083	!-- Add extra pressure level for calculations of the trace gas paths
5084	ALLOCATE ( rrtm_play_tmp(1:nzt_rad+1) )
5085	ALLOCATE ( rrtm_plev_tmp(1:nzt_rad+2) )
5086
5087	rrtm_play_tmp(1:nzt_rad) = rrtm_play(0,1:nzt_rad)
5088	rrtm_plev_tmp(1:nzt_rad+1) = rrtm_plev(0,1:nzt_rad+1)
5089	rrtm_play_tmp(nzt_rad+1) = rrtm_plev(0,nzt_rad+1) * 0.5_wp
5090	rrtm_plev_tmp(nzt_rad+2) = MIN( 1.0E-4_wp, 0.25_wp &
5091	* rrtm_plev(0,nzt_rad+1) )
5092
5093	!
5094	!-- Calculate trace gas path (zero at surface) with interpolation to the
5095	!-- sounding levels
5096	ALLOCATE ( trace_mls_path(1:nzt_rad+2,1:num_trace_gases) )
5097
5098	trace_mls_path(nzb+1,:) = 0.0_wp
5099
5100	DO k = nzb+2, nzt_rad+2
5101	DO m = 1, num_trace_gases
5102	trace_mls_path(k,m) = trace_mls_path(k-1,m)
5103
5104	!
5105	!-- When the pressure level is higher than the trace gas pressure
5106	!-- level, assume that
5107	IF ( rrtm_plev_tmp(k-1) > p_mls(1) ) THEN
5108
5109	trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,1) &
5110	* ( rrtm_plev_tmp(k-1) &
5111	- MAX( p_mls(1), rrtm_plev_tmp(k) ) &
5112	) / g
5113	ENDIF
5114
5115	!
5116	!-- Integrate for each sounding level from the contributing p_mls
5117	!-- levels
5118	DO n = 2, np
5119	!
5120	!-- Limit p_mls so that it is within the model level
5121	p_mls_u = MIN( rrtm_plev_tmp(k-1), &
5122	MAX( rrtm_plev_tmp(k), p_mls(n) ) )
5123	p_mls_l = MIN( rrtm_plev_tmp(k-1), &
5124	MAX( rrtm_plev_tmp(k), p_mls(n-1) ) )
5125
5126	IF ( p_mls_l > p_mls_u ) THEN
5127
5128	!
5129	!-- Calculate weights for interpolation
5130	p_mls_m = 0.5_wp * (p_mls_l + p_mls_u)
5131	p_wgt_u = (p_mls(n-1) - p_mls_m) / (p_mls(n-1) - p_mls(n))
5132	p_wgt_l = (p_mls_m - p_mls(n)) / (p_mls(n-1) - p_mls(n))
5133
5134	!
5135	!-- Add level to trace gas path
5136	trace_mls_path(k,m) = trace_mls_path(k,m) &
5137	+ ( p_wgt_u * trace_mls(m,n) &
5138	+ p_wgt_l * trace_mls(m,n-1) ) &
5139	* (p_mls_l - p_mls_u) / g
5140	ENDIF
5141	ENDDO
5142
5143	IF ( rrtm_plev_tmp(k) < p_mls(np) ) THEN
5144	trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,np) &
5145	* ( MIN( rrtm_plev_tmp(k-1), p_mls(np) ) &
5146	- rrtm_plev_tmp(k) &
5147	) / g
5148	ENDIF
5149	ENDDO
5150	ENDDO
5151
5152
5153	!
5154	!-- Prepare trace gas path profiles
5155	ALLOCATE ( trace_path_tmp(1:nzt_rad+1) )
5156
5157	DO m = 1, num_trace_gases
5158
5159	trace_path_tmp(1:nzt_rad+1) = ( trace_mls_path(2:nzt_rad+2,m) &
5160	- trace_mls_path(1:nzt_rad+1,m) ) * g &
5161	/ ( rrtm_plev_tmp(1:nzt_rad+1) &
5162	- rrtm_plev_tmp(2:nzt_rad+2) )
5163
5164	!
5165	!-- Save trace gas paths to the respective arrays
5166	SELECT CASE ( TRIM( trace_names(m) ) )
5167
5168	CASE ( 'O3' )
5169
5170	rrtm_o3vmr(0,:) = trace_path_tmp(:)
5171
5172	CASE ( 'CO2' )
5173
5174	rrtm_co2vmr(0,:) = trace_path_tmp(:)
5175
5176	CASE ( 'CH4' )
5177
5178	rrtm_ch4vmr(0,:) = trace_path_tmp(:)
5179
5180	CASE ( 'N2O' )
5181
5182	rrtm_n2ovmr(0,:) = trace_path_tmp(:)
5183
5184	CASE ( 'O2' )
5185
5186	rrtm_o2vmr(0,:) = trace_path_tmp(:)
5187
5188	CASE ( 'CFC11' )
5189
5190	rrtm_cfc11vmr(0,:) = trace_path_tmp(:)
5191
5192	CASE ( 'CFC12' )
5193
5194	rrtm_cfc12vmr(0,:) = trace_path_tmp(:)
5195
5196	CASE ( 'CFC22' )
5197
5198	rrtm_cfc22vmr(0,:) = trace_path_tmp(:)
5199
5200	CASE ( 'CCL4' )
5201
5202	rrtm_ccl4vmr(0,:) = trace_path_tmp(:)
5203
5204	CASE ( 'H2O' )
5205
5206	rrtm_h2ovmr(0,:) = trace_path_tmp(:)
5207
5208	CASE DEFAULT
5209
5210	END SELECT
5211
5212	ENDDO
5213
5214	DEALLOCATE ( trace_path_tmp )
5215	DEALLOCATE ( trace_mls_path )
5216	DEALLOCATE ( rrtm_play_tmp )
5217	DEALLOCATE ( rrtm_plev_tmp )
5218	DEALLOCATE ( trace_mls )
5219	DEALLOCATE ( p_mls )
5220
5221	END SUBROUTINE read_trace_gas_data
5222
5223
5224	SUBROUTINE netcdf_handle_error_rad( routine_name, errno )
5225
5226	USE control_parameters, &
5227	ONLY: message_string
5228
5229	USE NETCDF
5230
5231	USE pegrid
5232
5233	IMPLICIT NONE
5234
5235	CHARACTER(LEN=6) :: message_identifier
5236	CHARACTER(LEN=*) :: routine_name
5237
5238	INTEGER(iwp) :: errno
5239
5240	IF ( nc_stat /= NF90_NOERR ) THEN
5241
5242	WRITE( message_identifier, '(''NC'',I4.4)' ) errno
5243	message_string = TRIM( NF90_STRERROR( nc_stat ) )
5244
5245	CALL message( routine_name, message_identifier, 2, 2, 0, 6, 1 )
5246
5247	ENDIF
5248
5249	END SUBROUTINE netcdf_handle_error_rad
5250	#endif
5251
5252
5253	!------------------------------------------------------------------------------!
5254	! Description:
5255	! ------------
5256	!> Calculate temperature tendency due to radiative cooling/heating.
5257	!> Cache-optimized version.
5258	!------------------------------------------------------------------------------!
5259	#if defined( __rrtmg )
5260	SUBROUTINE radiation_tendency_ij ( i, j, tend )
5261
5262	IMPLICIT NONE
5263
5264	INTEGER(iwp) :: i, j, k !< loop indices
5265
5266	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term
5267
5268	IF ( radiation_scheme == 'rrtmg' ) THEN
5269	!
5270	!-- Calculate tendency based on heating rate
5271	DO k = nzb+1, nzt+1
5272	tend(k,j,i) = tend(k,j,i) + (rad_lw_hr(k,j,i) + rad_sw_hr(k,j,i)) &
5273	* d_exner(k) * d_seconds_hour
5274	ENDDO
5275
5276	ENDIF
5277
5278	END SUBROUTINE radiation_tendency_ij
5279	#endif
5280
5281
5282	!------------------------------------------------------------------------------!
5283	! Description:
5284	! ------------
5285	!> Calculate temperature tendency due to radiative cooling/heating.
5286	!> Vector-optimized version
5287	!------------------------------------------------------------------------------!
5288	#if defined( __rrtmg )
5289	SUBROUTINE radiation_tendency ( tend )
5290
5291	USE indices, &
5292	ONLY: nxl, nxr, nyn, nys
5293
5294	IMPLICIT NONE
5295
5296	INTEGER(iwp) :: i, j, k !< loop indices
5297
5298	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term
5299
5300	IF ( radiation_scheme == 'rrtmg' ) THEN
5301	!
5302	!-- Calculate tendency based on heating rate
5303	DO i = nxl, nxr
5304	DO j = nys, nyn
5305	DO k = nzb+1, nzt+1
5306	tend(k,j,i) = tend(k,j,i) + ( rad_lw_hr(k,j,i) &
5307	+ rad_sw_hr(k,j,i) ) * d_exner(k) &
5308	* d_seconds_hour
5309	ENDDO
5310	ENDDO
5311	ENDDO
5312	ENDIF
5313
5314	END SUBROUTINE radiation_tendency
5315	#endif
5316
5317	!------------------------------------------------------------------------------!
5318	! Description:
5319	! ------------
5320	!> This subroutine calculates interaction of the solar radiation
5321	!> with urban and land surfaces and updates all surface heatfluxes.
5322	!> It calculates also the required parameters for RRTMG lower BC.
5323	!>
5324	!> For more info. see Resler et al. 2017
5325	!>
5326	!> The new version 2.0 was radically rewriten, the discretization scheme
5327	!> has been changed. This new version significantly improves effectivity
5328	!> of the paralelization and the scalability of the model.
5329	!------------------------------------------------------------------------------!
5330
5331	SUBROUTINE radiation_interaction
5332
5333	USE control_parameters, &
5334	ONLY: rotation_angle
5335
5336	IMPLICIT NONE
5337
5338	INTEGER(iwp) :: i, j, k, kk, d, refstep, m, mm, l, ll
5339	INTEGER(iwp) :: isurf, isurfsrc, isvf, icsf, ipcgb
5340	INTEGER(iwp) :: imrt, imrtf
5341	INTEGER(iwp) :: isd !< solar direction number
5342	INTEGER(iwp) :: pc_box_dimshift !< transform for best accuracy
5343	INTEGER(iwp), DIMENSION(0:3) :: reorder = (/ 1, 0, 3, 2 /)
5344
5345	REAL(wp), DIMENSION(3,3) :: mrot !< grid rotation matrix (zyx)
5346	REAL(wp), DIMENSION(3,0:nsurf_type):: vnorm !< face direction normal vectors (zyx)
5347	REAL(wp), DIMENSION(3) :: sunorig !< grid rotated solar direction unit vector (zyx)
5348	REAL(wp), DIMENSION(3) :: sunorig_grid !< grid squashed solar direction unit vector (zyx)
5349	REAL(wp), DIMENSION(0:nsurf_type) :: costheta !< direct irradiance factor of solar angle
5350	REAL(wp), DIMENSION(nz_urban_b:nz_urban_t) :: pchf_prep !< precalculated factor for canopy temperature tendency
5351	REAL(wp) :: pc_box_area, pc_abs_frac, pc_abs_eff
5352	REAL(wp) :: asrc !< area of source face
5353	REAL(wp) :: pcrad !< irradiance from plant canopy
5354	REAL(wp) :: pabsswl = 0.0_wp !< total absorbed SW radiation energy in local processor (W)
5355	REAL(wp) :: pabssw = 0.0_wp !< total absorbed SW radiation energy in all processors (W)
5356	REAL(wp) :: pabslwl = 0.0_wp !< total absorbed LW radiation energy in local processor (W)
5357	REAL(wp) :: pabslw = 0.0_wp !< total absorbed LW radiation energy in all processors (W)
5358	REAL(wp) :: pemitlwl = 0.0_wp !< total emitted LW radiation energy in all processors (W)
5359	REAL(wp) :: pemitlw = 0.0_wp !< total emitted LW radiation energy in all processors (W)
5360	REAL(wp) :: pinswl = 0.0_wp !< total received SW radiation energy in local processor (W)
5361	REAL(wp) :: pinsw = 0.0_wp !< total received SW radiation energy in all processor (W)
5362	REAL(wp) :: pinlwl = 0.0_wp !< total received LW radiation energy in local processor (W)
5363	REAL(wp) :: pinlw = 0.0_wp !< total received LW radiation energy in all processor (W)
5364	REAL(wp) :: emiss_sum_surfl !< sum of emissisivity of surfaces in local processor
5365	REAL(wp) :: emiss_sum_surf !< sum of emissisivity of surfaces in all processor
5366	REAL(wp) :: area_surfl !< total area of surfaces in local processor
5367	REAL(wp) :: area_surf !< total area of surfaces in all processor
5368	REAL(wp) :: area_hor !< total horizontal area of domain in all processor
5369	#if defined( __parallel )
5370	REAL(wp), DIMENSION(1:7) :: combine_allreduce !< dummy array used to combine several MPI_ALLREDUCE calls
5371	REAL(wp), DIMENSION(1:7) :: combine_allreduce_l !< dummy array used to combine several MPI_ALLREDUCE calls
5372	#endif
5373
5374	IF ( debug_output_timestep ) CALL debug_message( 'radiation_interaction', 'start' )
5375
5376	IF ( plant_canopy ) THEN
5377	pchf_prep(:) = r_d * exner(nz_urban_b:nz_urban_t) &
5378	/ (c_p * hyp(nz_urban_b:nz_urban_t) * dxdydz(1)) !< equals to 1 / (rho * c_p * Vbox * T)
5379	ENDIF
5380
5381	sun_direction = .TRUE.
5382	CALL calc_zenith !< required also for diffusion radiation
5383
5384	!-- prepare rotated normal vectors and irradiance factor
5385	vnorm(1,:) = kdir(:)
5386	vnorm(2,:) = jdir(:)
5387	vnorm(3,:) = idir(:)
5388	mrot(1, :) = (/ 1._wp, 0._wp, 0._wp /)
5389	mrot(2, :) = (/ 0._wp, COS(rotation_angle), SIN(rotation_angle) /)
5390	mrot(3, :) = (/ 0._wp, -SIN(rotation_angle), COS(rotation_angle) /)
5391	sunorig = (/ cos_zenith, sun_dir_lat, sun_dir_lon /)
5392	sunorig = MATMUL(mrot, sunorig)
5393	DO d = 0, nsurf_type
5394	costheta(d) = DOT_PRODUCT(sunorig, vnorm(:,d))
5395	ENDDO
5396
5397	IF ( cos_zenith > 0 ) THEN
5398	!-- now we will "squash" the sunorig vector by grid box size in
5399	!-- each dimension, so that this new direction vector will allow us
5400	!-- to traverse the ray path within grid coordinates directly
5401	sunorig_grid = (/ sunorig(1)/dz(1), sunorig(2)/dy, sunorig(3)/dx /)
5402	!-- sunorig_grid = sunorig_grid / norm2(sunorig_grid)
5403	sunorig_grid = sunorig_grid / SQRT(SUM(sunorig_grid**2))
5404
5405	IF ( npcbl > 0 ) THEN
5406	!-- precompute effective box depth with prototype Leaf Area Density
5407	pc_box_dimshift = MAXLOC(ABS(sunorig), 1) - 1
5408	CALL box_absorb(CSHIFT((/dz(1),dy,dx/), pc_box_dimshift), &
5409	60, prototype_lad, &
5410	CSHIFT(ABS(sunorig), pc_box_dimshift), &
5411	pc_box_area, pc_abs_frac)
5412	pc_box_area = pc_box_area * ABS(sunorig(pc_box_dimshift+1) &
5413	/ sunorig(1))
5414	pc_abs_eff = LOG(1._wp - pc_abs_frac) / prototype_lad
5415	ENDIF
5416	ENDIF
5417	!
5418	!-- Split downwelling shortwave radiation into a diffuse and a direct part.
5419	!-- Note, if radiation scheme is RRTMG or diffuse radiation is externally
5420	!-- prescribed, this is not required.
5421	IF ( radiation_scheme /= 'rrtmg' .AND. &
5422	.NOT. rad_sw_in_dif_f%from_file ) CALL calc_diffusion_radiation
5423
5424	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5425	!-- First pass: direct + diffuse irradiance + thermal
5426	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5427	surfinswdir = 0._wp !nsurfl
5428	surfins = 0._wp !nsurfl
5429	surfinl = 0._wp !nsurfl
5430	surfoutsl(:) = 0.0_wp !start-end
5431	surfoutll(:) = 0.0_wp !start-end
5432	IF ( nmrtbl > 0 ) THEN
5433	mrtinsw(:) = 0._wp
5434	mrtinlw(:) = 0._wp
5435	ENDIF
5436	surfinlg(:) = 0._wp !global
5437
5438
5439	!-- Set up thermal radiation from surfaces
5440	!-- emiss_surf is defined only for surfaces for which energy balance is calculated
5441	!-- Workaround: reorder surface data type back on 1D array including all surfaces,
5442	!-- which implies to reorder horizontal and vertical surfaces
5443	!
5444	!-- Horizontal walls
5445	mm = 1
5446	DO i = nxl, nxr
5447	DO j = nys, nyn
5448	!-- urban
5449	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
5450	surfoutll(mm) = SUM ( surf_usm_h%frac(:,m) * &
5451	surf_usm_h%emissivity(:,m) ) &
5452	* sigma_sb &
5453	* surf_usm_h%pt_surface(m)**4
5454	albedo_surf(mm) = SUM ( surf_usm_h%frac(:,m) * &
5455	surf_usm_h%albedo(:,m) )
5456	emiss_surf(mm) = SUM ( surf_usm_h%frac(:,m) * &
5457	surf_usm_h%emissivity(:,m) )
5458	mm = mm + 1
5459	ENDDO
5460	!-- land
5461	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
5462	surfoutll(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5463	surf_lsm_h%emissivity(:,m) ) &
5464	* sigma_sb &
5465	* surf_lsm_h%pt_surface(m)**4
5466	albedo_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5467	surf_lsm_h%albedo(:,m) )
5468	emiss_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5469	surf_lsm_h%emissivity(:,m) )
5470	mm = mm + 1
5471	ENDDO
5472	ENDDO
5473	ENDDO
5474	!
5475	!-- Vertical walls
5476	DO i = nxl, nxr
5477	DO j = nys, nyn
5478	DO ll = 0, 3
5479	l = reorder(ll)
5480	!-- urban
5481	DO m = surf_usm_v(l)%start_index(j,i), &
5482	surf_usm_v(l)%end_index(j,i)
5483	surfoutll(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5484	surf_usm_v(l)%emissivity(:,m) ) &
5485	* sigma_sb &
5486	* surf_usm_v(l)%pt_surface(m)**4
5487	albedo_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5488	surf_usm_v(l)%albedo(:,m) )
5489	emiss_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5490	surf_usm_v(l)%emissivity(:,m) )
5491	mm = mm + 1
5492	ENDDO
5493	!-- land
5494	DO m = surf_lsm_v(l)%start_index(j,i), &
5495	surf_lsm_v(l)%end_index(j,i)
5496	surfoutll(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5497	surf_lsm_v(l)%emissivity(:,m) ) &
5498	* sigma_sb &
5499	* surf_lsm_v(l)%pt_surface(m)**4
5500	albedo_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5501	surf_lsm_v(l)%albedo(:,m) )
5502	emiss_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5503	surf_lsm_v(l)%emissivity(:,m) )
5504	mm = mm + 1
5505	ENDDO
5506	ENDDO
5507	ENDDO
5508	ENDDO
5509
5510	#if defined( __parallel )
5511	!-- might be optimized and gather only values relevant for current processor
5512	CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, &
5513	surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) !nsurf global
5514	IF ( ierr /= 0 ) THEN
5515	WRITE(9,*) 'Error MPI_AllGatherv1:', ierr, SIZE(surfoutll), nsurfl, &
5516	SIZE(surfoutl), nsurfs, surfstart
5517	FLUSH(9)
5518	ENDIF
5519	#else
5520	surfoutl(:) = surfoutll(:) !nsurf global
5521	#endif
5522
5523	IF ( surface_reflections) THEN
5524	DO isvf = 1, nsvfl
5525	isurf = svfsurf(1, isvf)
5526	k = surfl(iz, isurf)
5527	j = surfl(iy, isurf)
5528	i = surfl(ix, isurf)
5529	isurfsrc = svfsurf(2, isvf)
5530	!
5531	!-- For surface-to-surface factors we calculate thermal radiation in 1st pass
5532	IF ( plant_lw_interact ) THEN
5533	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc)
5534	ELSE
5535	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)
5536	ENDIF
5537	ENDDO
5538	ENDIF
5539	!
5540	!-- diffuse radiation using sky view factor
5541	DO isurf = 1, nsurfl
5542	j = surfl(iy, isurf)
5543	i = surfl(ix, isurf)
5544	surfinswdif(isurf) = rad_sw_in_diff(j,i) * skyvft(isurf)
5545	IF ( plant_lw_interact ) THEN
5546	surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvft(isurf)
5547	ELSE
5548	surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvf(isurf)
5549	ENDIF
5550	ENDDO
5551	!
5552	!-- MRT diffuse irradiance
5553	DO imrt = 1, nmrtbl
5554	j = mrtbl(iy, imrt)
5555	i = mrtbl(ix, imrt)
5556	mrtinsw(imrt) = mrtskyt(imrt) * rad_sw_in_diff(j,i)
5557	mrtinlw(imrt) = mrtsky(imrt) * rad_lw_in_diff(j,i)
5558	ENDDO
5559
5560	!-- direct radiation
5561	IF ( cos_zenith > 0 ) THEN
5562	!--Identify solar direction vector (discretized number) 1)
5563	!--
5564	j = FLOOR(ACOS(cos_zenith) / pi * raytrace_discrete_elevs)
5565	i = MODULO(NINT(ATAN2(sun_dir_lon, sun_dir_lat) &
5566	/ (2._wppi) raytrace_discrete_azims-.5_wp, iwp), &
5567	raytrace_discrete_azims)
5568	isd = dsidir_rev(j, i)
5569	!-- TODO: check if isd = -1 to report that this solar position is not precalculated
5570	DO isurf = 1, nsurfl
5571	j = surfl(iy, isurf)
5572	i = surfl(ix, isurf)
5573	surfinswdir(isurf) = rad_sw_in_dir(j,i) * &
5574	costheta(surfl(id, isurf)) * dsitrans(isurf, isd) / cos_zenith
5575	ENDDO
5576	!
5577	!-- MRT direct irradiance
5578	DO imrt = 1, nmrtbl
5579	j = mrtbl(iy, imrt)
5580	i = mrtbl(ix, imrt)
5581	mrtinsw(imrt) = mrtinsw(imrt) + mrtdsit(imrt, isd) * rad_sw_in_dir(j,i) &
5582	/ cos_zenith / 4._wp ! normal to sphere
5583	ENDDO
5584	ENDIF
5585	!
5586	!-- MRT first pass thermal
5587	DO imrtf = 1, nmrtf
5588	imrt = mrtfsurf(1, imrtf)
5589	isurfsrc = mrtfsurf(2, imrtf)
5590	mrtinlw(imrt) = mrtinlw(imrt) + mrtf(imrtf) * surfoutl(isurfsrc)
5591	ENDDO
5592	!
5593	!-- Absorption in each local plant canopy grid box from the first atmospheric
5594	!-- pass of radiation
5595	IF ( npcbl > 0 ) THEN
5596
5597	pcbinswdir(:) = 0._wp
5598	pcbinswdif(:) = 0._wp
5599	pcbinlw(:) = 0._wp
5600
5601	DO icsf = 1, ncsfl
5602	ipcgb = csfsurf(1, icsf)
5603	i = pcbl(ix,ipcgb)
5604	j = pcbl(iy,ipcgb)
5605	k = pcbl(iz,ipcgb)
5606	isurfsrc = csfsurf(2, icsf)
5607
5608	IF ( isurfsrc == -1 ) THEN
5609	!
5610	!-- Diffuse radiation from sky
5611	pcbinswdif(ipcgb) = csf(1,icsf) * rad_sw_in_diff(j,i)
5612	!
5613	!-- Absorbed diffuse LW radiation from sky minus emitted to sky
5614	IF ( plant_lw_interact ) THEN
5615	pcbinlw(ipcgb) = csf(1,icsf) &
5616	* (rad_lw_in_diff(j, i) &
5617	- sigma_sb * (pt(k,j,i)exner(k))*4)
5618	ENDIF
5619	!
5620	!-- Direct solar radiation
5621	IF ( cos_zenith > 0 ) THEN
5622	!-- Estimate directed box absorption
5623	pc_abs_frac = 1._wp - exp(pc_abs_eff * lad_s(k,j,i))
5624	!
5625	!-- isd has already been established, see 1)
5626	pcbinswdir(ipcgb) = rad_sw_in_dir(j, i) * pc_box_area &
5627	* pc_abs_frac * dsitransc(ipcgb, isd)
5628	ENDIF
5629	ELSE
5630	IF ( plant_lw_interact ) THEN
5631	!
5632	!-- Thermal emission from plan canopy towards respective face
5633	pcrad = sigma_sb * (pt(k,j,i) * exner(k))*4 csf(1,icsf)
5634	surfinlg(isurfsrc) = surfinlg(isurfsrc) + pcrad
5635	!
5636	!-- Remove the flux above + absorb LW from first pass from surfaces
5637	asrc = facearea(surf(id, isurfsrc))
5638	pcbinlw(ipcgb) = pcbinlw(ipcgb) &
5639	+ (csf(1,icsf) * surfoutl(isurfsrc) & ! Absorb from first pass surf emit
5640	- pcrad) & ! Remove emitted heatflux
5641	* asrc
5642	ENDIF
5643	ENDIF
5644	ENDDO
5645
5646	pcbinsw(:) = pcbinswdir(:) + pcbinswdif(:)
5647	ENDIF
5648
5649	IF ( plant_lw_interact ) THEN
5650	!
5651	!-- Exchange incoming lw radiation from plant canopy
5652	#if defined( __parallel )
5653	CALL MPI_Allreduce(MPI_IN_PLACE, surfinlg, nsurf, MPI_REAL, MPI_SUM, comm2d, ierr)
5654	IF ( ierr /= 0 ) THEN
5655	WRITE (9,*) 'Error MPI_Allreduce:', ierr
5656	FLUSH(9)
5657	ENDIF
5658	surfinl(:) = surfinl(:) + surfinlg(surfstart(myid)+1:surfstart(myid+1))
5659	#else
5660	surfinl(:) = surfinl(:) + surfinlg(:)
5661	#endif
5662	ENDIF
5663
5664	surfins = surfinswdir + surfinswdif
5665	surfinl = surfinl + surfinlwdif
5666	surfinsw = surfins
5667	surfinlw = surfinl
5668	surfoutsw = 0.0_wp
5669	surfoutlw = surfoutll
5670	surfemitlwl = surfoutll
5671
5672	IF ( .NOT. surface_reflections ) THEN
5673	!
5674	!-- Set nrefsteps to 0 to disable reflections
5675	nrefsteps = 0
5676	surfoutsl = albedo_surf * surfins
5677	surfoutll = (1._wp - emiss_surf) * surfinl
5678	surfoutsw = surfoutsw + surfoutsl
5679	surfoutlw = surfoutlw + surfoutll
5680	ENDIF
5681
5682	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5683	!-- Next passes - reflections
5684	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5685	DO refstep = 1, nrefsteps
5686
5687	surfoutsl = albedo_surf * surfins
5688	!
5689	!-- for non-transparent surfaces, longwave albedo is 1 - emissivity
5690	surfoutll = (1._wp - emiss_surf) * surfinl
5691
5692	#if defined( __parallel )
5693	CALL MPI_AllGatherv(surfoutsl, nsurfl, MPI_REAL, &
5694	surfouts, nsurfs, surfstart, MPI_REAL, comm2d, ierr)
5695	IF ( ierr /= 0 ) THEN
5696	WRITE(9,*) 'Error MPI_AllGatherv2:', ierr, SIZE(surfoutsl), nsurfl, &
5697	SIZE(surfouts), nsurfs, surfstart
5698	FLUSH(9)
5699	ENDIF
5700
5701	CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, &
5702	surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr)
5703	IF ( ierr /= 0 ) THEN
5704	WRITE(9,*) 'Error MPI_AllGatherv3:', ierr, SIZE(surfoutll), nsurfl, &
5705	SIZE(surfoutl), nsurfs, surfstart
5706	FLUSH(9)
5707	ENDIF
5708
5709	#else
5710	surfouts = surfoutsl
5711	surfoutl = surfoutll
5712	#endif
5713	!
5714	!-- Reset for the input from next reflective pass
5715	surfins = 0._wp
5716	surfinl = 0._wp
5717	!
5718	!-- Reflected radiation
5719	DO isvf = 1, nsvfl
5720	isurf = svfsurf(1, isvf)
5721	isurfsrc = svfsurf(2, isvf)
5722	surfins(isurf) = surfins(isurf) + svf(1,isvf) * svf(2,isvf) * surfouts(isurfsrc)
5723	IF ( plant_lw_interact ) THEN
5724	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc)
5725	ELSE
5726	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)
5727	ENDIF
5728	ENDDO
5729	!
5730	!-- NOTE: PC absorbtion and MRT from reflected can both be done at once
5731	!-- after all reflections if we do one more MPI_ALLGATHERV on surfout.
5732	!-- Advantage: less local computation. Disadvantage: one more collective
5733	!-- MPI call.
5734	!
5735	!-- Radiation absorbed by plant canopy
5736	DO icsf = 1, ncsfl
5737	ipcgb = csfsurf(1, icsf)
5738	isurfsrc = csfsurf(2, icsf)
5739	IF ( isurfsrc == -1 ) CYCLE ! sky->face only in 1st pass, not here
5740	!
5741	!-- Calculate source surface area. If the `surf' array is removed
5742	!-- before timestepping starts (future version), then asrc must be
5743	!-- stored within `csf'
5744	asrc = facearea(surf(id, isurfsrc))
5745	pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * surfouts(isurfsrc) * asrc
5746	IF ( plant_lw_interact ) THEN
5747	pcbinlw(ipcgb) = pcbinlw(ipcgb) + csf(1,icsf) * surfoutl(isurfsrc) * asrc
5748	ENDIF
5749	ENDDO
5750	!
5751	!-- MRT reflected
5752	DO imrtf = 1, nmrtf
5753	imrt = mrtfsurf(1, imrtf)
5754	isurfsrc = mrtfsurf(2, imrtf)
5755	mrtinsw(imrt) = mrtinsw(imrt) + mrtft(imrtf) * surfouts(isurfsrc)
5756	mrtinlw(imrt) = mrtinlw(imrt) + mrtf(imrtf) * surfoutl(isurfsrc)
5757	ENDDO
5758
5759	surfinsw = surfinsw + surfins
5760	surfinlw = surfinlw + surfinl
5761	surfoutsw = surfoutsw + surfoutsl
5762	surfoutlw = surfoutlw + surfoutll
5763
5764	ENDDO ! refstep
5765
5766	!-- push heat flux absorbed by plant canopy to respective 3D arrays
5767	IF ( npcbl > 0 ) THEN
5768	pc_heating_rate(:,:,:) = 0.0_wp
5769	DO ipcgb = 1, npcbl
5770	j = pcbl(iy, ipcgb)
5771	i = pcbl(ix, ipcgb)
5772	k = pcbl(iz, ipcgb)
5773	!
5774	!-- Following expression equals former kk = k - nzb_s_inner(j,i)
5775	kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat
5776	pc_heating_rate(kk, j, i) = (pcbinsw(ipcgb) + pcbinlw(ipcgb)) &
5777	* pchf_prep(k) * pt(k, j, i) !-- = dT/dt
5778	ENDDO
5779
5780	IF ( humidity .AND. plant_canopy_transpiration ) THEN
5781	!-- Calculation of plant canopy transpiration rate and correspondidng latent heat rate
5782	pc_transpiration_rate(:,:,:) = 0.0_wp
5783	pc_latent_rate(:,:,:) = 0.0_wp
5784	DO ipcgb = 1, npcbl
5785	i = pcbl(ix, ipcgb)
5786	j = pcbl(iy, ipcgb)
5787	k = pcbl(iz, ipcgb)
5788	kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat
5789	CALL pcm_calc_transpiration_rate( i, j, k, kk, pcbinsw(ipcgb), pcbinlw(ipcgb), &
5790	pc_transpiration_rate(kk,j,i), pc_latent_rate(kk,j,i) )
5791	ENDDO
5792	ENDIF
5793	ENDIF
5794	!
5795	!-- Calculate black body MRT (after all reflections)
5796	IF ( nmrtbl > 0 ) THEN
5797	IF ( mrt_include_sw ) THEN
5798	mrt(:) = ((mrtinsw(:) + mrtinlw(:)) / sigma_sb) ** .25_wp
5799	ELSE
5800	mrt(:) = (mrtinlw(:) / sigma_sb) ** .25_wp
5801	ENDIF
5802	ENDIF
5803	!
5804	!-- Transfer radiation arrays required for energy balance to the respective data types
5805	DO i = 1, nsurfl
5806	m = surfl(im,i)
5807	!
5808	!-- (1) Urban surfaces
5809	!-- upward-facing
5810	IF ( surfl(1,i) == iup_u ) THEN
5811	surf_usm_h%rad_sw_in(m) = surfinsw(i)
5812	surf_usm_h%rad_sw_out(m) = surfoutsw(i)
5813	surf_usm_h%rad_sw_dir(m) = surfinswdir(i)
5814	surf_usm_h%rad_sw_dif(m) = surfinswdif(i)
5815	surf_usm_h%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5816	surfinswdif(i)
5817	surf_usm_h%rad_sw_res(m) = surfins(i)
5818	surf_usm_h%rad_lw_in(m) = surfinlw(i)
5819	surf_usm_h%rad_lw_out(m) = surfoutlw(i)
5820	surf_usm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5821	surfinlw(i) - surfoutlw(i)
5822	surf_usm_h%rad_net_l(m) = surf_usm_h%rad_net(m)
5823	surf_usm_h%rad_lw_dif(m) = surfinlwdif(i)
5824	surf_usm_h%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5825	surf_usm_h%rad_lw_res(m) = surfinl(i)
5826	!
5827	!-- northward-facding
5828	ELSEIF ( surfl(1,i) == inorth_u ) THEN
5829	surf_usm_v(0)%rad_sw_in(m) = surfinsw(i)
5830	surf_usm_v(0)%rad_sw_out(m) = surfoutsw(i)
5831	surf_usm_v(0)%rad_sw_dir(m) = surfinswdir(i)
5832	surf_usm_v(0)%rad_sw_dif(m) = surfinswdif(i)
5833	surf_usm_v(0)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5834	surfinswdif(i)
5835	surf_usm_v(0)%rad_sw_res(m) = surfins(i)
5836	surf_usm_v(0)%rad_lw_in(m) = surfinlw(i)
5837	surf_usm_v(0)%rad_lw_out(m) = surfoutlw(i)
5838	surf_usm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5839	surfinlw(i) - surfoutlw(i)
5840	surf_usm_v(0)%rad_net_l(m) = surf_usm_v(0)%rad_net(m)
5841	surf_usm_v(0)%rad_lw_dif(m) = surfinlwdif(i)
5842	surf_usm_v(0)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5843	surf_usm_v(0)%rad_lw_res(m) = surfinl(i)
5844	!
5845	!-- southward-facding
5846	ELSEIF ( surfl(1,i) == isouth_u ) THEN
5847	surf_usm_v(1)%rad_sw_in(m) = surfinsw(i)
5848	surf_usm_v(1)%rad_sw_out(m) = surfoutsw(i)
5849	surf_usm_v(1)%rad_sw_dir(m) = surfinswdir(i)
5850	surf_usm_v(1)%rad_sw_dif(m) = surfinswdif(i)
5851	surf_usm_v(1)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5852	surfinswdif(i)
5853	surf_usm_v(1)%rad_sw_res(m) = surfins(i)
5854	surf_usm_v(1)%rad_lw_in(m) = surfinlw(i)
5855	surf_usm_v(1)%rad_lw_out(m) = surfoutlw(i)
5856	surf_usm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5857	surfinlw(i) - surfoutlw(i)
5858	surf_usm_v(1)%rad_net_l(m) = surf_usm_v(1)%rad_net(m)
5859	surf_usm_v(1)%rad_lw_dif(m) = surfinlwdif(i)
5860	surf_usm_v(1)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5861	surf_usm_v(1)%rad_lw_res(m) = surfinl(i)
5862	!
5863	!-- eastward-facing
5864	ELSEIF ( surfl(1,i) == ieast_u ) THEN
5865	surf_usm_v(2)%rad_sw_in(m) = surfinsw(i)
5866	surf_usm_v(2)%rad_sw_out(m) = surfoutsw(i)
5867	surf_usm_v(2)%rad_sw_dir(m) = surfinswdir(i)
5868	surf_usm_v(2)%rad_sw_dif(m) = surfinswdif(i)
5869	surf_usm_v(2)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5870	surfinswdif(i)
5871	surf_usm_v(2)%rad_sw_res(m) = surfins(i)
5872	surf_usm_v(2)%rad_lw_in(m) = surfinlw(i)
5873	surf_usm_v(2)%rad_lw_out(m) = surfoutlw(i)
5874	surf_usm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5875	surfinlw(i) - surfoutlw(i)
5876	surf_usm_v(2)%rad_net_l(m) = surf_usm_v(2)%rad_net(m)
5877	surf_usm_v(2)%rad_lw_dif(m) = surfinlwdif(i)
5878	surf_usm_v(2)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5879	surf_usm_v(2)%rad_lw_res(m) = surfinl(i)
5880	!
5881	!-- westward-facding
5882	ELSEIF ( surfl(1,i) == iwest_u ) THEN
5883	surf_usm_v(3)%rad_sw_in(m) = surfinsw(i)
5884	surf_usm_v(3)%rad_sw_out(m) = surfoutsw(i)
5885	surf_usm_v(3)%rad_sw_dir(m) = surfinswdir(i)
5886	surf_usm_v(3)%rad_sw_dif(m) = surfinswdif(i)
5887	surf_usm_v(3)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5888	surfinswdif(i)
5889	surf_usm_v(3)%rad_sw_res(m) = surfins(i)
5890	surf_usm_v(3)%rad_lw_in(m) = surfinlw(i)
5891	surf_usm_v(3)%rad_lw_out(m) = surfoutlw(i)
5892	surf_usm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5893	surfinlw(i) - surfoutlw(i)
5894	surf_usm_v(3)%rad_net_l(m) = surf_usm_v(3)%rad_net(m)
5895	surf_usm_v(3)%rad_lw_dif(m) = surfinlwdif(i)
5896	surf_usm_v(3)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5897	surf_usm_v(3)%rad_lw_res(m) = surfinl(i)
5898	!
5899	!-- (2) land surfaces
5900	!-- upward-facing
5901	ELSEIF ( surfl(1,i) == iup_l ) THEN
5902	surf_lsm_h%rad_sw_in(m) = surfinsw(i)
5903	surf_lsm_h%rad_sw_out(m) = surfoutsw(i)
5904	surf_lsm_h%rad_sw_dir(m) = surfinswdir(i)
5905	surf_lsm_h%rad_sw_dif(m) = surfinswdif(i)
5906	surf_lsm_h%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5907	surfinswdif(i)
5908	surf_lsm_h%rad_sw_res(m) = surfins(i)
5909	surf_lsm_h%rad_lw_in(m) = surfinlw(i)
5910	surf_lsm_h%rad_lw_out(m) = surfoutlw(i)
5911	surf_lsm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5912	surfinlw(i) - surfoutlw(i)
5913	surf_lsm_h%rad_lw_dif(m) = surfinlwdif(i)
5914	surf_lsm_h%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5915	surf_lsm_h%rad_lw_res(m) = surfinl(i)
5916	!
5917	!-- northward-facding
5918	ELSEIF ( surfl(1,i) == inorth_l ) THEN
5919	surf_lsm_v(0)%rad_sw_in(m) = surfinsw(i)
5920	surf_lsm_v(0)%rad_sw_out(m) = surfoutsw(i)
5921	surf_lsm_v(0)%rad_sw_dir(m) = surfinswdir(i)
5922	surf_lsm_v(0)%rad_sw_dif(m) = surfinswdif(i)
5923	surf_lsm_v(0)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5924	surfinswdif(i)
5925	surf_lsm_v(0)%rad_sw_res(m) = surfins(i)
5926	surf_lsm_v(0)%rad_lw_in(m) = surfinlw(i)
5927	surf_lsm_v(0)%rad_lw_out(m) = surfoutlw(i)
5928	surf_lsm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5929	surfinlw(i) - surfoutlw(i)
5930	surf_lsm_v(0)%rad_lw_dif(m) = surfinlwdif(i)
5931	surf_lsm_v(0)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5932	surf_lsm_v(0)%rad_lw_res(m) = surfinl(i)
5933	!
5934	!-- southward-facding
5935	ELSEIF ( surfl(1,i) == isouth_l ) THEN
5936	surf_lsm_v(1)%rad_sw_in(m) = surfinsw(i)
5937	surf_lsm_v(1)%rad_sw_out(m) = surfoutsw(i)
5938	surf_lsm_v(1)%rad_sw_dir(m) = surfinswdir(i)
5939	surf_lsm_v(1)%rad_sw_dif(m) = surfinswdif(i)
5940	surf_lsm_v(1)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5941	surfinswdif(i)
5942	surf_lsm_v(1)%rad_sw_res(m) = surfins(i)
5943	surf_lsm_v(1)%rad_lw_in(m) = surfinlw(i)
5944	surf_lsm_v(1)%rad_lw_out(m) = surfoutlw(i)
5945	surf_lsm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5946	surfinlw(i) - surfoutlw(i)
5947	surf_lsm_v(1)%rad_lw_dif(m) = surfinlwdif(i)
5948	surf_lsm_v(1)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5949	surf_lsm_v(1)%rad_lw_res(m) = surfinl(i)
5950	!
5951	!-- eastward-facing
5952	ELSEIF ( surfl(1,i) == ieast_l ) THEN
5953	surf_lsm_v(2)%rad_sw_in(m) = surfinsw(i)
5954	surf_lsm_v(2)%rad_sw_out(m) = surfoutsw(i)
5955	surf_lsm_v(2)%rad_sw_dir(m) = surfinswdir(i)
5956	surf_lsm_v(2)%rad_sw_dif(m) = surfinswdif(i)
5957	surf_lsm_v(2)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5958	surfinswdif(i)
5959	surf_lsm_v(2)%rad_sw_res(m) = surfins(i)
5960	surf_lsm_v(2)%rad_lw_in(m) = surfinlw(i)
5961	surf_lsm_v(2)%rad_lw_out(m) = surfoutlw(i)
5962	surf_lsm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5963	surfinlw(i) - surfoutlw(i)
5964	surf_lsm_v(2)%rad_lw_dif(m) = surfinlwdif(i)
5965	surf_lsm_v(2)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5966	surf_lsm_v(2)%rad_lw_res(m) = surfinl(i)
5967	!
5968	!-- westward-facing
5969	ELSEIF ( surfl(1,i) == iwest_l ) THEN
5970	surf_lsm_v(3)%rad_sw_in(m) = surfinsw(i)
5971	surf_lsm_v(3)%rad_sw_out(m) = surfoutsw(i)
5972	surf_lsm_v(3)%rad_sw_dir(m) = surfinswdir(i)
5973	surf_lsm_v(3)%rad_sw_dif(m) = surfinswdif(i)
5974	surf_lsm_v(3)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5975	surfinswdif(i)
5976	surf_lsm_v(3)%rad_sw_res(m) = surfins(i)
5977	surf_lsm_v(3)%rad_lw_in(m) = surfinlw(i)
5978	surf_lsm_v(3)%rad_lw_out(m) = surfoutlw(i)
5979	surf_lsm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5980	surfinlw(i) - surfoutlw(i)
5981	surf_lsm_v(3)%rad_lw_dif(m) = surfinlwdif(i)
5982	surf_lsm_v(3)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5983	surf_lsm_v(3)%rad_lw_res(m) = surfinl(i)
5984	ENDIF
5985
5986	ENDDO
5987
5988	DO m = 1, surf_usm_h%ns
5989	surf_usm_h%surfhf(m) = surf_usm_h%rad_sw_in(m) + &
5990	surf_usm_h%rad_lw_in(m) - &
5991	surf_usm_h%rad_sw_out(m) - &
5992	surf_usm_h%rad_lw_out(m)
5993	ENDDO
5994	DO m = 1, surf_lsm_h%ns
5995	surf_lsm_h%surfhf(m) = surf_lsm_h%rad_sw_in(m) + &
5996	surf_lsm_h%rad_lw_in(m) - &
5997	surf_lsm_h%rad_sw_out(m) - &
5998	surf_lsm_h%rad_lw_out(m)
5999	ENDDO
6000
6001	DO l = 0, 3
6002	!-- urban
6003	DO m = 1, surf_usm_v(l)%ns
6004	surf_usm_v(l)%surfhf(m) = surf_usm_v(l)%rad_sw_in(m) + &
6005	surf_usm_v(l)%rad_lw_in(m) - &
6006	surf_usm_v(l)%rad_sw_out(m) - &
6007	surf_usm_v(l)%rad_lw_out(m)
6008	ENDDO
6009	!-- land
6010	DO m = 1, surf_lsm_v(l)%ns
6011	surf_lsm_v(l)%surfhf(m) = surf_lsm_v(l)%rad_sw_in(m) + &
6012	surf_lsm_v(l)%rad_lw_in(m) - &
6013	surf_lsm_v(l)%rad_sw_out(m) - &
6014	surf_lsm_v(l)%rad_lw_out(m)
6015
6016	ENDDO
6017	ENDDO
6018	!
6019	!-- Calculate the average temperature, albedo, and emissivity for urban/land
6020	!-- domain when using average_radiation in the respective radiation model
6021
6022	!-- calculate horizontal area
6023	! !!! ATTENTION!!! uniform grid is assumed here
6024	area_hor = (nx+1) * (ny+1) * dx * dy
6025	!
6026	!-- absorbed/received SW & LW and emitted LW energy of all physical
6027	!-- surfaces (land and urban) in local processor
6028	pinswl = 0._wp
6029	pinlwl = 0._wp
6030	pabsswl = 0._wp
6031	pabslwl = 0._wp
6032	pemitlwl = 0._wp
6033	emiss_sum_surfl = 0._wp
6034	area_surfl = 0._wp
6035	DO i = 1, nsurfl
6036	d = surfl(id, i)
6037	!-- received SW & LW
6038	pinswl = pinswl + (surfinswdir(i) + surfinswdif(i)) * facearea(d)
6039	pinlwl = pinlwl + surfinlwdif(i) * facearea(d)
6040	!-- absorbed SW & LW
6041	pabsswl = pabsswl + (1._wp - albedo_surf(i)) * &
6042	surfinsw(i) * facearea(d)
6043	pabslwl = pabslwl + emiss_surf(i) * surfinlw(i) * facearea(d)
6044	!-- emitted LW
6045	pemitlwl = pemitlwl + surfemitlwl(i) * facearea(d)
6046	!-- emissivity and area sum
6047	emiss_sum_surfl = emiss_sum_surfl + emiss_surf(i) * facearea(d)
6048	area_surfl = area_surfl + facearea(d)
6049	END DO
6050	!
6051	!-- add the absorbed SW energy by plant canopy
6052	IF ( npcbl > 0 ) THEN
6053	pabsswl = pabsswl + SUM(pcbinsw)
6054	pabslwl = pabslwl + SUM(pcbinlw)
6055	pinswl = pinswl + SUM(pcbinswdir) + SUM(pcbinswdif)
6056	ENDIF
6057	!
6058	!-- gather all rad flux energy in all processors. In order to reduce
6059	!-- the number of MPI calls (to reduce latencies), combine the required
6060	!-- quantities in one array, sum it up, and subsequently re-distribute
6061	!-- back to the respective quantities.
6062	#if defined( __parallel )
6063	combine_allreduce_l(1) = pinswl
6064	combine_allreduce_l(2) = pinlwl
6065	combine_allreduce_l(3) = pabsswl
6066	combine_allreduce_l(4) = pabslwl
6067	combine_allreduce_l(5) = pemitlwl
6068	combine_allreduce_l(6) = emiss_sum_surfl
6069	combine_allreduce_l(7) = area_surfl
6070
6071	CALL MPI_ALLREDUCE( combine_allreduce_l, &
6072	combine_allreduce, &
6073	SIZE( combine_allreduce ), &
6074	MPI_REAL, &
6075	MPI_SUM, &
6076	comm2d, &
6077	ierr )
6078
6079	pinsw = combine_allreduce(1)
6080	pinlw = combine_allreduce(2)
6081	pabssw = combine_allreduce(3)
6082	pabslw = combine_allreduce(4)
6083	pemitlw = combine_allreduce(5)
6084	emiss_sum_surf = combine_allreduce(6)
6085	area_surf = combine_allreduce(7)
6086	#else
6087	pinsw = pinswl
6088	pinlw = pinlwl
6089	pabssw = pabsswl
6090	pabslw = pabslwl
6091	pemitlw = pemitlwl
6092	emiss_sum_surf = emiss_sum_surfl
6093	area_surf = area_surfl
6094	#endif
6095
6096	!-- (1) albedo
6097	IF ( pinsw /= 0.0_wp ) albedo_urb = ( pinsw - pabssw ) / pinsw
6098	!-- (2) average emmsivity
6099	IF ( area_surf /= 0.0_wp ) emissivity_urb = emiss_sum_surf / area_surf
6100	!
6101	!-- Temporally comment out calculation of effective radiative temperature.
6102	!-- See below for more explanation.
6103	!-- (3) temperature
6104	!-- first we calculate an effective horizontal area to account for
6105	!-- the effect of vertical surfaces (which contributes to LW emission)
6106	!-- We simply use the ratio of the total LW to the incoming LW flux
6107	area_hor = pinlw / rad_lw_in_diff(nyn,nxl)
6108	t_rad_urb = ( ( pemitlw - pabslw + emissivity_urb * pinlw ) / &
6109	(emissivity_urb * sigma_sb * area_hor) )**0.25_wp
6110
6111	IF ( debug_output_timestep ) CALL debug_message( 'radiation_interaction', 'end' )
6112
6113
6114	CONTAINS
6115
6116	!------------------------------------------------------------------------------!
6117	!> Calculates radiation absorbed by box with given size and LAD.
6118	!>
6119	!> Simulates resol**2 rays (by equally spacing a bounding horizontal square
6120	!> conatining all possible rays that would cross the box) and calculates
6121	!> average transparency per ray. Returns fraction of absorbed radiation flux
6122	!> and area for which this fraction is effective.
6123	!------------------------------------------------------------------------------!
6124	PURE SUBROUTINE box_absorb(boxsize, resol, dens, uvec, area, absorb)
6125	IMPLICIT NONE
6126
6127	REAL(wp), DIMENSION(3), INTENT(in) :: &
6128	boxsize, & !< z, y, x size of box in m
6129	uvec !< z, y, x unit vector of incoming flux
6130	INTEGER(iwp), INTENT(in) :: &
6131	resol !< No. of rays in x and y dimensions
6132	REAL(wp), INTENT(in) :: &
6133	dens !< box density (e.g. Leaf Area Density)
6134	REAL(wp), INTENT(out) :: &
6135	area, & !< horizontal area for flux absorbtion
6136	absorb !< fraction of absorbed flux
6137	REAL(wp) :: &
6138	xshift, yshift, &
6139	xmin, xmax, ymin, ymax, &
6140	xorig, yorig, &
6141	dx1, dy1, dz1, dx2, dy2, dz2, &
6142	crdist, &
6143	transp
6144	INTEGER(iwp) :: &
6145	i, j
6146
6147	xshift = uvec(3) / uvec(1) * boxsize(1)
6148	xmin = min(0._wp, -xshift)
6149	xmax = boxsize(3) + max(0._wp, -xshift)
6150	yshift = uvec(2) / uvec(1) * boxsize(1)
6151	ymin = min(0._wp, -yshift)
6152	ymax = boxsize(2) + max(0._wp, -yshift)
6153
6154	transp = 0._wp
6155	DO i = 1, resol
6156	xorig = xmin + (xmax-xmin) * (i-.5_wp) / resol
6157	DO j = 1, resol
6158	yorig = ymin + (ymax-ymin) * (j-.5_wp) / resol
6159
6160	dz1 = 0._wp
6161	dz2 = boxsize(1)/uvec(1)
6162
6163	IF ( uvec(2) > 0._wp ) THEN
6164	dy1 = -yorig / uvec(2) !< crossing with y=0
6165	dy2 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2)
6166	ELSE !uvec(2)==0
6167	dy1 = -huge(1._wp)
6168	dy2 = huge(1._wp)
6169	ENDIF
6170
6171	IF ( uvec(3) > 0._wp ) THEN
6172	dx1 = -xorig / uvec(3) !< crossing with x=0
6173	dx2 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3)
6174	ELSE !uvec(3)==0
6175	dx1 = -huge(1._wp)
6176	dx2 = huge(1._wp)
6177	ENDIF
6178
6179	crdist = max(0._wp, (min(dz2, dy2, dx2) - max(dz1, dy1, dx1)))
6180	transp = transp + exp(-ext_coef * dens * crdist)
6181	ENDDO
6182	ENDDO
6183	transp = transp / resol**2
6184	area = (boxsize(3)+xshift)*(boxsize(2)+yshift)
6185	absorb = 1._wp - transp
6186
6187	END SUBROUTINE box_absorb
6188
6189	!------------------------------------------------------------------------------!
6190	! Description:
6191	! ------------
6192	!> This subroutine splits direct and diffusion dw radiation
6193	!> It sould not be called in case the radiation model already does it
6194	!> It follows Boland, Ridley & Brown (2008)
6195	!------------------------------------------------------------------------------!
6196	SUBROUTINE calc_diffusion_radiation
6197
6198	INTEGER(iwp) :: i !< grid index x-direction
6199	INTEGER(iwp) :: j !< grid index y-direction
6200
6201	REAL(wp) :: year_angle !< angle
6202	REAL(wp) :: etr !< extraterestrial radiation
6203	REAL(wp) :: corrected_solarUp !< corrected solar up radiation
6204	REAL(wp) :: horizontalETR !< horizontal extraterestrial radiation
6205	REAL(wp) :: clearnessIndex !< clearness index
6206	REAL(wp) :: diff_frac !< diffusion fraction of the radiation
6207
6208	REAL(wp), PARAMETER :: lowest_solarUp = 0.1_wp !< limit the sun elevation to protect stability of the calculation
6209	!
6210	!-- Calculate current day and time based on the initial values and simulation time
6211	year_angle = ( (day_of_year_init * 86400) + time_utc_init &
6212	+ time_since_reference_point ) * d_seconds_year &
6213	* 2.0_wp * pi
6214
6215	etr = solar_constant * (1.00011_wp + &
6216	0.034221_wp * cos(year_angle) + &
6217	0.001280_wp * sin(year_angle) + &
6218	0.000719_wp * cos(2.0_wp * year_angle) + &
6219	0.000077_wp * sin(2.0_wp * year_angle))
6220	!
6221	!--
6222	!-- Under a very low angle, we keep extraterestrial radiation at
6223	!-- the last small value, therefore the clearness index will be pushed
6224	!-- towards 0 while keeping full continuity.
6225	IF ( cos_zenith <= lowest_solarUp ) THEN
6226	corrected_solarUp = lowest_solarUp
6227	ELSE
6228	corrected_solarUp = cos_zenith
6229	ENDIF
6230
6231	horizontalETR = etr * corrected_solarUp
6232
6233	DO i = nxl, nxr
6234	DO j = nys, nyn
6235	clearnessIndex = rad_sw_in(0,j,i) / horizontalETR
6236	diff_frac = 1.0_wp / (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex))
6237	rad_sw_in_diff(j,i) = rad_sw_in(0,j,i) * diff_frac
6238	rad_sw_in_dir(j,i) = rad_sw_in(0,j,i) * (1.0_wp - diff_frac)
6239	rad_lw_in_diff(j,i) = rad_lw_in(0,j,i)
6240	ENDDO
6241	ENDDO
6242
6243	END SUBROUTINE calc_diffusion_radiation
6244
6245	END SUBROUTINE radiation_interaction
6246
6247	!------------------------------------------------------------------------------!
6248	! Description:
6249	! ------------
6250	!> This subroutine initializes structures needed for radiative transfer
6251	!> model. This model calculates transformation processes of the
6252	!> radiation inside urban and land canopy layer. The module includes also
6253	!> the interaction of the radiation with the resolved plant canopy.
6254	!>
6255	!> For more info. see Resler et al. 2017
6256	!>
6257	!> The new version 2.0 was radically rewriten, the discretization scheme
6258	!> has been changed. This new version significantly improves effectivity
6259	!> of the paralelization and the scalability of the model.
6260	!>
6261	!------------------------------------------------------------------------------!
6262	SUBROUTINE radiation_interaction_init
6263
6264	USE control_parameters, &
6265	ONLY: dz_stretch_level_start
6266
6267	USE plant_canopy_model_mod, &
6268	ONLY: lad_s
6269
6270	IMPLICIT NONE
6271
6272	INTEGER(iwp) :: i, j, k, l, m, d
6273	INTEGER(iwp) :: k_topo !< vertical index indicating topography top for given (j,i)
6274	INTEGER(iwp) :: nzptl, nzubl, nzutl, isurf, ipcgb, imrt
6275	REAL(wp) :: mrl
6276	#if defined( __parallel )
6277	INTEGER(iwp), DIMENSION(:), POINTER, SAVE :: gridsurf_rma !< fortran pointer, but lower bounds are 1
6278	TYPE(c_ptr) :: gridsurf_rma_p !< allocated c pointer
6279	INTEGER(iwp) :: minfo !< MPI RMA window info handle
6280	#endif
6281
6282	!
6283	!-- precalculate face areas for different face directions using normal vector
6284	DO d = 0, nsurf_type
6285	facearea(d) = 1._wp
6286	IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx
6287	IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy
6288	IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz(1)
6289	ENDDO
6290	!
6291	!-- Find nz_urban_b, nz_urban_t, nz_urban via wall_flag_0 array (nzb_s_inner will be
6292	!-- removed later). The following contruct finds the lowest / largest index
6293	!-- for any upward-facing wall (see bit 12).
6294	nzubl = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
6295	nzutl = MAXVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
6296
6297	nzubl = MAX( nzubl, nzb )
6298
6299	IF ( plant_canopy ) THEN
6300	!-- allocate needed arrays
6301	ALLOCATE( pct(nys:nyn,nxl:nxr) )
6302	ALLOCATE( pch(nys:nyn,nxl:nxr) )
6303
6304	!-- calculate plant canopy height
6305	npcbl = 0
6306	pct = 0
6307	pch = 0
6308	DO i = nxl, nxr
6309	DO j = nys, nyn
6310	!
6311	!-- Find topography top index
6312	k_topo = topo_top_ind(j,i,0)
6313
6314	DO k = nzt+1, 0, -1
6315	IF ( lad_s(k,j,i) /= 0.0_wp ) THEN
6316	!-- we are at the top of the pcs
6317	pct(j,i) = k + k_topo
6318	pch(j,i) = k
6319	npcbl = npcbl + pch(j,i)
6320	EXIT
6321	ENDIF
6322	ENDDO
6323	ENDDO
6324	ENDDO
6325
6326	nzutl = MAX( nzutl, MAXVAL( pct ) )
6327	nzptl = MAXVAL( pct )
6328
6329	prototype_lad = MAXVAL( lad_s ) * .9_wp !< better be *1.0 if lad is either 0 or maxval(lad) everywhere
6330	IF ( prototype_lad <= 0._wp ) prototype_lad = .3_wp
6331	!WRITE(message_string, '(a,f6.3)') 'Precomputing effective box optical ' &
6332	! // 'depth using prototype leaf area density = ', prototype_lad
6333	!CALL message('radiation_interaction_init', 'PA0520', 0, 0, -1, 6, 0)
6334	ENDIF
6335
6336	nzutl = MIN( nzutl + nzut_free, nzt )
6337
6338	#if defined( __parallel )
6339	CALL MPI_AllReduce(nzubl, nz_urban_b, 1, MPI_INTEGER, MPI_MIN, comm2d, ierr )
6340	IF ( ierr /= 0 ) THEN
6341	WRITE(9,*) 'Error MPI_AllReduce11:', ierr, nzubl, nz_urban_b
6342	FLUSH(9)
6343	ENDIF
6344	CALL MPI_AllReduce(nzutl, nz_urban_t, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr )
6345	IF ( ierr /= 0 ) THEN
6346	WRITE(9,*) 'Error MPI_AllReduce12:', ierr, nzutl, nz_urban_t
6347	FLUSH(9)
6348	ENDIF
6349	CALL MPI_AllReduce(nzptl, nz_plant_t, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr )
6350	IF ( ierr /= 0 ) THEN
6351	WRITE(9,*) 'Error MPI_AllReduce13:', ierr, nzptl, nz_plant_t
6352	FLUSH(9)
6353	ENDIF
6354	#else
6355	nz_urban_b = nzubl
6356	nz_urban_t = nzutl
6357	nz_plant_t = nzptl
6358	#endif
6359	!
6360	!-- Stretching (non-uniform grid spacing) is not considered in the radiation
6361	!-- model. Therefore, vertical stretching has to be applied above the area
6362	!-- where the parts of the radiation model which assume constant grid spacing
6363	!-- are active. ABS (...) is required because the default value of
6364	!-- dz_stretch_level_start is -9999999.9_wp (negative).
6365	IF ( ABS( dz_stretch_level_start(1) ) <= zw(nz_urban_t) ) THEN
6366	WRITE( message_string, * ) 'The lowest level where vertical ', &
6367	'stretching is applied have to be ', &
6368	'greater than ', zw(nz_urban_t)
6369	CALL message( 'radiation_interaction_init', 'PA0496', 1, 2, 0, 6, 0 )
6370	ENDIF
6371	!
6372	!-- global number of urban and plant layers
6373	nz_urban = nz_urban_t - nz_urban_b + 1
6374	nz_plant = nz_plant_t - nz_urban_b + 1
6375	!
6376	!-- check max_raytracing_dist relative to urban surface layer height
6377	mrl = 2.0_wp * nz_urban * dz(1)
6378	!-- set max_raytracing_dist to double the urban surface layer height, if not set
6379	IF ( max_raytracing_dist == -999.0_wp ) THEN
6380	max_raytracing_dist = mrl
6381	ENDIF
6382	!-- check if max_raytracing_dist set too low (here we only warn the user. Other
6383	! option is to correct the value again to double the urban surface layer height)
6384	IF ( max_raytracing_dist < mrl ) THEN
6385	WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist is set less than ' // &
6386	'double the urban surface layer height, i.e. ', mrl
6387	CALL message('radiation_interaction_init', 'PA0521', 0, 0, 0, 6, 0 )
6388	ENDIF
6389	! IF ( max_raytracing_dist <= mrl ) THEN
6390	! IF ( max_raytracing_dist /= -999.0_wp ) THEN
6391	! !-- max_raytracing_dist too low
6392	! WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist too low, ' &
6393	! // 'override to value ', mrl
6394	! CALL message('radiation_interaction_init', 'PA0521', 0, 0, -1, 6, 0)
6395	! ENDIF
6396	! max_raytracing_dist = mrl
6397	! ENDIF
6398	!
6399	!-- allocate urban surfaces grid
6400	!-- calc number of surfaces in local proc
6401	IF ( debug_output ) CALL debug_message( 'calculation of indices for surfaces', 'info' )
6402
6403	nsurfl = 0
6404	!
6405	!-- Number of horizontal surfaces including land- and roof surfaces in both USM and LSM. Note that
6406	!-- All horizontal surface elements are already counted in surface_mod.
6407	startland = 1
6408	nsurfl = surf_usm_h%ns + surf_lsm_h%ns
6409	endland = nsurfl
6410	nlands = endland - startland + 1
6411
6412	!
6413	!-- Number of vertical surfaces in both USM and LSM. Note that all vertical surface elements are
6414	!-- already counted in surface_mod.
6415	startwall = nsurfl+1
6416	DO i = 0,3
6417	nsurfl = nsurfl + surf_usm_v(i)%ns + surf_lsm_v(i)%ns
6418	ENDDO
6419	endwall = nsurfl
6420	nwalls = endwall - startwall + 1
6421	dirstart = (/ startland, startwall, startwall, startwall, startwall /)
6422	dirend = (/ endland, endwall, endwall, endwall, endwall /)
6423
6424	!-- fill gridpcbl and pcbl
6425	IF ( npcbl > 0 ) THEN
6426	ALLOCATE( pcbl(iz:ix, 1:npcbl) )
6427	ALLOCATE( gridpcbl(nz_urban_b:nz_plant_t,nys:nyn,nxl:nxr) )
6428	pcbl = -1
6429	gridpcbl(:,:,:) = 0
6430	ipcgb = 0
6431	DO i = nxl, nxr
6432	DO j = nys, nyn
6433	!
6434	!-- Find topography top index
6435	k_topo = topo_top_ind(j,i,0)
6436
6437	DO k = k_topo + 1, pct(j,i)
6438	ipcgb = ipcgb + 1
6439	gridpcbl(k,j,i) = ipcgb
6440	pcbl(:,ipcgb) = (/ k, j, i /)
6441	ENDDO
6442	ENDDO
6443	ENDDO
6444	ALLOCATE( pcbinsw( 1:npcbl ) )
6445	ALLOCATE( pcbinswdir( 1:npcbl ) )
6446	ALLOCATE( pcbinswdif( 1:npcbl ) )
6447	ALLOCATE( pcbinlw( 1:npcbl ) )
6448	ENDIF
6449
6450	!
6451	!-- Fill surfl (the ordering of local surfaces given by the following
6452	!-- cycles must not be altered, certain file input routines may depend
6453	!-- on it).
6454	!
6455	!-- We allocate the array as linear and then use a two-dimensional pointer
6456	!-- into it, because some MPI implementations crash with 2D-allocated arrays.
6457	ALLOCATE(surfl_linear(nidx_surf*nsurfl))
6458	surfl(1:nidx_surf,1:nsurfl) => surfl_linear(1:nidx_surf*nsurfl)
6459	isurf = 0
6460	IF ( rad_angular_discretization ) THEN
6461	!
6462	!-- Allocate and fill the reverse indexing array gridsurf
6463	#if defined( __parallel )
6464	!
6465	!-- raytrace_mpi_rma is asserted
6466
6467	CALL MPI_Info_create(minfo, ierr)
6468	IF ( ierr /= 0 ) THEN
6469	WRITE(9,*) 'Error MPI_Info_create1:', ierr
6470	FLUSH(9)
6471	ENDIF
6472	CALL MPI_Info_set(minfo, 'accumulate_ordering', 'none', ierr)
6473	IF ( ierr /= 0 ) THEN
6474	WRITE(9,*) 'Error MPI_Info_set1:', ierr
6475	FLUSH(9)
6476	ENDIF
6477	CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr)
6478	IF ( ierr /= 0 ) THEN
6479	WRITE(9,*) 'Error MPI_Info_set2:', ierr
6480	FLUSH(9)
6481	ENDIF
6482	CALL MPI_Info_set(minfo, 'same_size', 'true', ierr)
6483	IF ( ierr /= 0 ) THEN
6484	WRITE(9,*) 'Error MPI_Info_set3:', ierr
6485	FLUSH(9)
6486	ENDIF
6487	CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr)
6488	IF ( ierr /= 0 ) THEN
6489	WRITE(9,*) 'Error MPI_Info_set4:', ierr
6490	FLUSH(9)
6491	ENDIF
6492
6493	CALL MPI_Win_allocate(INT(STORAGE_SIZE(1_iwp)/8nsurf_type_unz_urbannnynnx, &
6494	kind=MPI_ADDRESS_KIND), STORAGE_SIZE(1_iwp)/8, &
6495	minfo, comm2d, gridsurf_rma_p, win_gridsurf, ierr)
6496	IF ( ierr /= 0 ) THEN
6497	WRITE(9,*) 'Error MPI_Win_allocate1:', ierr, &
6498	INT(STORAGE_SIZE(1_iwp)/8nsurf_type_unz_urbannnynnx,kind=MPI_ADDRESS_KIND), &
6499	STORAGE_SIZE(1_iwp)/8, win_gridsurf
6500	FLUSH(9)
6501	ENDIF
6502
6503	CALL MPI_Info_free(minfo, ierr)
6504	IF ( ierr /= 0 ) THEN
6505	WRITE(9,*) 'Error MPI_Info_free1:', ierr
6506	FLUSH(9)
6507	ENDIF
6508
6509	!
6510	!-- On Intel compilers, calling c_f_pointer to transform a C pointer
6511	!-- directly to a multi-dimensional Fotran pointer leads to strange
6512	!-- errors on dimension boundaries. However, transforming to a 1D
6513	!-- pointer and then redirecting a multidimensional pointer to it works
6514	!-- fine.
6515	CALL c_f_pointer(gridsurf_rma_p, gridsurf_rma, (/ nsurf_type_unz_urbannny*nnx /))
6516	gridsurf(0:nsurf_type_u-1, nz_urban_b:nz_urban_t, nys:nyn, nxl:nxr) => &
6517	gridsurf_rma(1:nsurf_type_unz_urbannny*nnx)
6518	#else
6519	ALLOCATE(gridsurf(0:nsurf_type_u-1,nz_urban_b:nz_urban_t,nys:nyn,nxl:nxr) )
6520	#endif
6521	gridsurf(:,:,:,:) = -999
6522	ENDIF
6523
6524	!-- add horizontal surface elements (land and urban surfaces)
6525	!-- TODO: add urban overhanging surfaces (idown_u)
6526	DO i = nxl, nxr
6527	DO j = nys, nyn
6528	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
6529	k = surf_usm_h%k(m)
6530	isurf = isurf + 1
6531	surfl(:,isurf) = (/iup_u,k,j,i,m/)
6532	IF ( rad_angular_discretization ) THEN
6533	gridsurf(iup_u,k,j,i) = isurf
6534	ENDIF
6535	ENDDO
6536
6537	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
6538	k = surf_lsm_h%k(m)
6539	isurf = isurf + 1
6540	surfl(:,isurf) = (/iup_l,k,j,i,m/)
6541	IF ( rad_angular_discretization ) THEN
6542	gridsurf(iup_u,k,j,i) = isurf
6543	ENDIF
6544	ENDDO
6545
6546	ENDDO
6547	ENDDO
6548
6549	!-- add vertical surface elements (land and urban surfaces)
6550	!-- TODO: remove the hard coding of l = 0 to l = idirection
6551	DO i = nxl, nxr
6552	DO j = nys, nyn
6553	l = 0
6554	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6555	k = surf_usm_v(l)%k(m)
6556	isurf = isurf + 1
6557	surfl(:,isurf) = (/inorth_u,k,j,i,m/)
6558	IF ( rad_angular_discretization ) THEN
6559	gridsurf(inorth_u,k,j,i) = isurf
6560	ENDIF
6561	ENDDO
6562	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6563	k = surf_lsm_v(l)%k(m)
6564	isurf = isurf + 1
6565	surfl(:,isurf) = (/inorth_l,k,j,i,m/)
6566	IF ( rad_angular_discretization ) THEN
6567	gridsurf(inorth_u,k,j,i) = isurf
6568	ENDIF
6569	ENDDO
6570
6571	l = 1
6572	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6573	k = surf_usm_v(l)%k(m)
6574	isurf = isurf + 1
6575	surfl(:,isurf) = (/isouth_u,k,j,i,m/)
6576	IF ( rad_angular_discretization ) THEN
6577	gridsurf(isouth_u,k,j,i) = isurf
6578	ENDIF
6579	ENDDO
6580	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6581	k = surf_lsm_v(l)%k(m)
6582	isurf = isurf + 1
6583	surfl(:,isurf) = (/isouth_l,k,j,i,m/)
6584	IF ( rad_angular_discretization ) THEN
6585	gridsurf(isouth_u,k,j,i) = isurf
6586	ENDIF
6587	ENDDO
6588
6589	l = 2
6590	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6591	k = surf_usm_v(l)%k(m)
6592	isurf = isurf + 1
6593	surfl(:,isurf) = (/ieast_u,k,j,i,m/)
6594	IF ( rad_angular_discretization ) THEN
6595	gridsurf(ieast_u,k,j,i) = isurf
6596	ENDIF
6597	ENDDO
6598	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6599	k = surf_lsm_v(l)%k(m)
6600	isurf = isurf + 1
6601	surfl(:,isurf) = (/ieast_l,k,j,i,m/)
6602	IF ( rad_angular_discretization ) THEN
6603	gridsurf(ieast_u,k,j,i) = isurf
6604	ENDIF
6605	ENDDO
6606
6607	l = 3
6608	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6609	k = surf_usm_v(l)%k(m)
6610	isurf = isurf + 1
6611	surfl(:,isurf) = (/iwest_u,k,j,i,m/)
6612	IF ( rad_angular_discretization ) THEN
6613	gridsurf(iwest_u,k,j,i) = isurf
6614	ENDIF
6615	ENDDO
6616	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6617	k = surf_lsm_v(l)%k(m)
6618	isurf = isurf + 1
6619	surfl(:,isurf) = (/iwest_l,k,j,i,m/)
6620	IF ( rad_angular_discretization ) THEN
6621	gridsurf(iwest_u,k,j,i) = isurf
6622	ENDIF
6623	ENDDO
6624	ENDDO
6625	ENDDO
6626	!
6627	!-- Add local MRT boxes for specified number of levels
6628	nmrtbl = 0
6629	IF ( mrt_nlevels > 0 ) THEN
6630	DO i = nxl, nxr
6631	DO j = nys, nyn
6632	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
6633	!
6634	!-- Skip roof if requested
6635	IF ( mrt_skip_roof .AND. surf_usm_h%isroof_surf(m) ) CYCLE
6636	!
6637	!-- Cycle over specified no of levels
6638	nmrtbl = nmrtbl + mrt_nlevels
6639	ENDDO
6640	!
6641	!-- Dtto for LSM
6642	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
6643	nmrtbl = nmrtbl + mrt_nlevels
6644	ENDDO
6645	ENDDO
6646	ENDDO
6647
6648	ALLOCATE( mrtbl(iz:ix,nmrtbl), mrtsky(nmrtbl), mrtskyt(nmrtbl), &
6649	mrtinsw(nmrtbl), mrtinlw(nmrtbl), mrt(nmrtbl) )
6650
6651	imrt = 0
6652	DO i = nxl, nxr
6653	DO j = nys, nyn
6654	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
6655	!
6656	!-- Skip roof if requested
6657	IF ( mrt_skip_roof .AND. surf_usm_h%isroof_surf(m) ) CYCLE
6658	!
6659	!-- Cycle over specified no of levels
6660	l = surf_usm_h%k(m)
6661	DO k = l, l + mrt_nlevels - 1
6662	imrt = imrt + 1
6663	mrtbl(:,imrt) = (/k,j,i/)
6664	ENDDO
6665	ENDDO
6666	!
6667	!-- Dtto for LSM
6668	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
6669	l = surf_lsm_h%k(m)
6670	DO k = l, l + mrt_nlevels - 1
6671	imrt = imrt + 1
6672	mrtbl(:,imrt) = (/k,j,i/)
6673	ENDDO
6674	ENDDO
6675	ENDDO
6676	ENDDO
6677	ENDIF
6678
6679	!
6680	!-- broadband albedo of the land, roof and wall surface
6681	!-- for domain border and sky set artifically to 1.0
6682	!-- what allows us to calculate heat flux leaving over
6683	!-- side and top borders of the domain
6684	ALLOCATE ( albedo_surf(nsurfl) )
6685	albedo_surf = 1.0_wp
6686	!
6687	!-- Also allocate further array for emissivity with identical order of
6688	!-- surface elements as radiation arrays.
6689	ALLOCATE ( emiss_surf(nsurfl) )
6690
6691
6692	!
6693	!-- global array surf of indices of surfaces and displacement index array surfstart
6694	ALLOCATE(nsurfs(0:numprocs-1))
6695
6696	#if defined( __parallel )
6697	CALL MPI_Allgather(nsurfl,1,MPI_INTEGER,nsurfs,1,MPI_INTEGER,comm2d,ierr)
6698	IF ( ierr /= 0 ) THEN
6699	WRITE(9,*) 'Error MPI_AllGather1:', ierr, nsurfl, nsurfs
6700	FLUSH(9)
6701	ENDIF
6702
6703	#else
6704	nsurfs(0) = nsurfl
6705	#endif
6706	ALLOCATE(surfstart(0:numprocs))
6707	k = 0
6708	DO i=0,numprocs-1
6709	surfstart(i) = k
6710	k = k+nsurfs(i)
6711	ENDDO
6712	surfstart(numprocs) = k
6713	nsurf = k
6714	!
6715	!-- We allocate the array as linear and then use a two-dimensional pointer
6716	!-- into it, because some MPI implementations crash with 2D-allocated arrays.
6717	ALLOCATE(surf_linear(nidx_surf*nsurf))
6718	surf(1:nidx_surf,1:nsurf) => surf_linear(1:nidx_surf*nsurf)
6719
6720	#if defined( __parallel )
6721	CALL MPI_AllGatherv(surfl_linear, nsurfl*nidx_surf, MPI_INTEGER, &
6722	surf_linear, nsurfs*nidx_surf, &
6723	surfstart(0:numprocs-1)*nidx_surf, MPI_INTEGER, &
6724	comm2d, ierr)
6725	IF ( ierr /= 0 ) THEN
6726	WRITE(9,*) 'Error MPI_AllGatherv4:', ierr, SIZE(surfl_linear), &
6727	nsurflnidx_surf, SIZE(surf_linear), nsurfsnidx_surf, &
6728	surfstart(0:numprocs-1)*nidx_surf
6729	FLUSH(9)
6730	ENDIF
6731	#else
6732	surf = surfl
6733	#endif
6734
6735	!--
6736	!-- allocation of the arrays for direct and diffusion radiation
6737	IF ( debug_output ) CALL debug_message( 'allocation of radiation arrays', 'info' )
6738	!-- rad_sw_in, rad_lw_in are computed in radiation model,
6739	!-- splitting of direct and diffusion part is done
6740	!-- in calc_diffusion_radiation for now
6741
6742	ALLOCATE( rad_sw_in_dir(nysg:nyng,nxlg:nxrg) )
6743	ALLOCATE( rad_sw_in_diff(nysg:nyng,nxlg:nxrg) )
6744	ALLOCATE( rad_lw_in_diff(nysg:nyng,nxlg:nxrg) )
6745	rad_sw_in_dir = 0.0_wp
6746	rad_sw_in_diff = 0.0_wp
6747	rad_lw_in_diff = 0.0_wp
6748
6749	!-- allocate radiation arrays
6750	ALLOCATE( surfins(nsurfl) )
6751	ALLOCATE( surfinl(nsurfl) )
6752	ALLOCATE( surfinsw(nsurfl) )
6753	ALLOCATE( surfinlw(nsurfl) )
6754	ALLOCATE( surfinswdir(nsurfl) )
6755	ALLOCATE( surfinswdif(nsurfl) )
6756	ALLOCATE( surfinlwdif(nsurfl) )
6757	ALLOCATE( surfoutsl(nsurfl) )
6758	ALLOCATE( surfoutll(nsurfl) )
6759	ALLOCATE( surfoutsw(nsurfl) )
6760	ALLOCATE( surfoutlw(nsurfl) )
6761	ALLOCATE( surfouts(nsurf) )
6762	ALLOCATE( surfoutl(nsurf) )
6763	ALLOCATE( surfinlg(nsurf) )
6764	ALLOCATE( skyvf(nsurfl) )
6765	ALLOCATE( skyvft(nsurfl) )
6766	ALLOCATE( surfemitlwl(nsurfl) )
6767
6768	!
6769	!-- In case of average_radiation, aggregated surface albedo and emissivity,
6770	!-- also set initial value for t_rad_urb.
6771	!-- For now set an arbitrary initial value.
6772	IF ( average_radiation ) THEN
6773	albedo_urb = 0.1_wp
6774	emissivity_urb = 0.9_wp
6775	t_rad_urb = pt_surface
6776	ENDIF
6777
6778	END SUBROUTINE radiation_interaction_init
6779
6780	!------------------------------------------------------------------------------!
6781	! Description:
6782	! ------------
6783	!> Calculates shape view factors (SVF), plant sink canopy factors (PCSF),
6784	!> sky-view factors, discretized path for direct solar radiation, MRT factors
6785	!> and other preprocessed data needed for radiation_interaction.
6786	!------------------------------------------------------------------------------!
6787	SUBROUTINE radiation_calc_svf
6788
6789	IMPLICIT NONE
6790
6791	INTEGER(iwp) :: i, j, k, d, ip, jp
6792	INTEGER(iwp) :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrt, imrtf, ipcgb
6793	INTEGER(iwp) :: sd, td
6794	INTEGER(iwp) :: iaz, izn !< azimuth, zenith counters
6795	INTEGER(iwp) :: naz, nzn !< azimuth, zenith num of steps
6796	REAL(wp) :: az0, zn0 !< starting azimuth/zenith
6797	REAL(wp) :: azs, zns !< azimuth/zenith cycle step
6798	REAL(wp) :: az1, az2 !< relative azimuth of section borders
6799	REAL(wp) :: azmid !< ray (center) azimuth
6800	REAL(wp) :: yxlen !< \|yxdir\|
6801	REAL(wp), DIMENSION(2) :: yxdir !< y,x unit vector of ray direction (in grid units)
6802	REAL(wp), DIMENSION(:), ALLOCATABLE :: zdirs !< directions in z (tangent of elevation)
6803	REAL(wp), DIMENSION(:), ALLOCATABLE :: zcent !< zenith angle centers
6804	REAL(wp), DIMENSION(:), ALLOCATABLE :: zbdry !< zenith angle boundaries
6805	REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac !< view factor fractions for individual rays
6806	REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac0 !< dtto (original values)
6807	REAL(wp), DIMENSION(:), ALLOCATABLE :: ztransp !< array of transparency in z steps
6808	INTEGER(iwp) :: lowest_free_ray !< index into zdirs
6809	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: itarget !< face indices of detected obstacles
6810	INTEGER(iwp) :: itarg0, itarg1
6811
6812	INTEGER(iwp) :: udim
6813	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: nzterrl_l
6814	INTEGER(iwp), DIMENSION(:,:), POINTER :: nzterrl
6815	REAL(wp), DIMENSION(:), ALLOCATABLE,TARGET:: csflt_l, pcsflt_l
6816	REAL(wp), DIMENSION(:,:), POINTER :: csflt, pcsflt
6817	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: kcsflt_l,kpcsflt_l
6818	INTEGER(iwp), DIMENSION(:,:), POINTER :: kcsflt,kpcsflt
6819	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: icsflt,dcsflt,ipcsflt,dpcsflt
6820	REAL(wp), DIMENSION(3) :: uv
6821	LOGICAL :: visible
6822	REAL(wp), DIMENSION(3) :: sa, ta !< real coordinates z,y,x of source and target
6823	REAL(wp) :: difvf !< differential view factor
6824	REAL(wp) :: transparency, rirrf, sqdist, svfsum
6825	INTEGER(iwp) :: isurflt, isurfs, isurflt_prev
6826	INTEGER(idp) :: ray_skip_maxdist, ray_skip_minval !< skipped raytracing counts
6827	INTEGER(iwp) :: max_track_len !< maximum 2d track length
6828	INTEGER(iwp) :: minfo
6829	REAL(wp), DIMENSION(:), POINTER, SAVE :: lad_s_rma !< fortran 1D pointer
6830	TYPE(c_ptr) :: lad_s_rma_p !< allocated c pointer
6831	#if defined( __parallel )
6832	INTEGER(kind=MPI_ADDRESS_KIND) :: size_lad_rma
6833	#endif
6834	!
6835	INTEGER(iwp), DIMENSION(0:svfnorm_report_num) :: svfnorm_counts
6836
6837
6838	!-- calculation of the SVF
6839	CALL location_message( 'calculating view factors for radiation interaction', 'start' )
6840
6841	!-- initialize variables and temporary arrays for calculation of svf and csf
6842	nsvfl = 0
6843	ncsfl = 0
6844	nsvfla = gasize
6845	msvf = 1
6846	ALLOCATE( asvf1(nsvfla) )
6847	asvf => asvf1
6848	IF ( plant_canopy ) THEN
6849	ncsfla = gasize
6850	mcsf = 1
6851	ALLOCATE( acsf1(ncsfla) )
6852	acsf => acsf1
6853	ENDIF
6854	nmrtf = 0
6855	IF ( mrt_nlevels > 0 ) THEN
6856	nmrtfa = gasize
6857	mmrtf = 1
6858	ALLOCATE ( amrtf1(nmrtfa) )
6859	amrtf => amrtf1
6860	ENDIF
6861	ray_skip_maxdist = 0
6862	ray_skip_minval = 0
6863
6864	!-- initialize temporary terrain and plant canopy height arrays (global 2D array!)
6865	ALLOCATE( nzterr(0:(nx+1)*(ny+1)-1) )
6866	#if defined( __parallel )
6867	!ALLOCATE( nzterrl(nys:nyn,nxl:nxr) )
6868	ALLOCATE( nzterrl_l((nyn-nys+1)*(nxr-nxl+1)) )
6869	nzterrl(nys:nyn,nxl:nxr) => nzterrl_l(1:(nyn-nys+1)*(nxr-nxl+1))
6870	nzterrl = topo_top_ind(nys:nyn,nxl:nxr,0)
6871	CALL MPI_AllGather( nzterrl_l, nnx*nny, MPI_INTEGER, &
6872	nzterr, nnx*nny, MPI_INTEGER, comm2d, ierr )
6873	IF ( ierr /= 0 ) THEN
6874	WRITE(9,) 'Error MPI_AllGather1:', ierr, SIZE(nzterrl_l), nnxnny, &
6875	SIZE(nzterr), nnx*nny
6876	FLUSH(9)
6877	ENDIF
6878	DEALLOCATE(nzterrl_l)
6879	#else
6880	nzterr = RESHAPE( topo_top_ind(nys:nyn,nxl:nxr,0), (/(nx+1)*(ny+1)/) )
6881	#endif
6882	IF ( plant_canopy ) THEN
6883	ALLOCATE( plantt(0:(nx+1)*(ny+1)-1) )
6884	maxboxesg = nx + ny + nz_plant + 1
6885	max_track_len = nx + ny + 1
6886	!-- temporary arrays storing values for csf calculation during raytracing
6887	ALLOCATE( boxes(3, maxboxesg) )
6888	ALLOCATE( crlens(maxboxesg) )
6889
6890	#if defined( __parallel )
6891	CALL MPI_AllGather( pct, nnx*nny, MPI_INTEGER, &
6892	plantt, nnx*nny, MPI_INTEGER, comm2d, ierr )
6893	IF ( ierr /= 0 ) THEN
6894	WRITE(9,) 'Error MPI_AllGather2:', ierr, SIZE(pct), nnxnny, &
6895	SIZE(plantt), nnx*nny
6896	FLUSH(9)
6897	ENDIF
6898
6899	!-- temporary arrays storing values for csf calculation during raytracing
6900	ALLOCATE( lad_ip(maxboxesg) )
6901	ALLOCATE( lad_disp(maxboxesg) )
6902
6903	IF ( raytrace_mpi_rma ) THEN
6904	ALLOCATE( lad_s_ray(maxboxesg) )
6905
6906	! set conditions for RMA communication
6907	CALL MPI_Info_create(minfo, ierr)
6908	IF ( ierr /= 0 ) THEN
6909	WRITE(9,*) 'Error MPI_Info_create2:', ierr
6910	FLUSH(9)
6911	ENDIF
6912	CALL MPI_Info_set(minfo, 'accumulate_ordering', 'none', ierr)
6913	IF ( ierr /= 0 ) THEN
6914	WRITE(9,*) 'Error MPI_Info_set5:', ierr
6915	FLUSH(9)
6916	ENDIF
6917	CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr)
6918	IF ( ierr /= 0 ) THEN
6919	WRITE(9,*) 'Error MPI_Info_set6:', ierr
6920	FLUSH(9)
6921	ENDIF
6922	CALL MPI_Info_set(minfo, 'same_size', 'true', ierr)
6923	IF ( ierr /= 0 ) THEN
6924	WRITE(9,*) 'Error MPI_Info_set7:', ierr
6925	FLUSH(9)
6926	ENDIF
6927	CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr)
6928	IF ( ierr /= 0 ) THEN
6929	WRITE(9,*) 'Error MPI_Info_set8:', ierr
6930	FLUSH(9)
6931	ENDIF
6932
6933	!-- Allocate and initialize the MPI RMA window
6934	!-- must be in accordance with allocation of lad_s in plant_canopy_model
6935	!-- optimization of memory should be done
6936	!-- Argument X of function STORAGE_SIZE(X) needs arbitrary REAL(wp) value, set to 1.0_wp for now
6937	size_lad_rma = STORAGE_SIZE(1.0_wp)/8nnxnny*nz_plant
6938	CALL MPI_Win_allocate(size_lad_rma, STORAGE_SIZE(1.0_wp)/8, minfo, comm2d, &
6939	lad_s_rma_p, win_lad, ierr)
6940	IF ( ierr /= 0 ) THEN
6941	WRITE(9,*) 'Error MPI_Win_allocate2:', ierr, size_lad_rma, &
6942	STORAGE_SIZE(1.0_wp)/8, win_lad
6943	FLUSH(9)
6944	ENDIF
6945	CALL c_f_pointer(lad_s_rma_p, lad_s_rma, (/ nz_plantnnynnx /))
6946	sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr) => lad_s_rma(1:nz_plantnnynnx)
6947	ELSE
6948	ALLOCATE(sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr))
6949	ENDIF
6950	#else
6951	plantt = RESHAPE( pct(nys:nyn,nxl:nxr), (/(nx+1)*(ny+1)/) )
6952	ALLOCATE(sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr))
6953	#endif
6954	plantt_max = MAXVAL(plantt)
6955	ALLOCATE( rt2_track(2, max_track_len), rt2_track_lad(nz_urban_b:plantt_max, max_track_len), &
6956	rt2_track_dist(0:max_track_len), rt2_dist(plantt_max-nz_urban_b+2) )
6957
6958	sub_lad(:,:,:) = 0._wp
6959	DO i = nxl, nxr
6960	DO j = nys, nyn
6961	k = topo_top_ind(j,i,0)
6962
6963	sub_lad(k:nz_plant_t, j, i) = lad_s(0:nz_plant_t-k, j, i)
6964	ENDDO
6965	ENDDO
6966
6967	#if defined( __parallel )
6968	IF ( raytrace_mpi_rma ) THEN
6969	CALL MPI_Info_free(minfo, ierr)
6970	IF ( ierr /= 0 ) THEN
6971	WRITE(9,*) 'Error MPI_Info_free2:', ierr
6972	FLUSH(9)
6973	ENDIF
6974	CALL MPI_Win_lock_all(0, win_lad, ierr)
6975	IF ( ierr /= 0 ) THEN
6976	WRITE(9,*) 'Error MPI_Win_lock_all1:', ierr, win_lad
6977	FLUSH(9)
6978	ENDIF
6979
6980	ELSE
6981	ALLOCATE( sub_lad_g(0:(nx+1)(ny+1)nz_plant-1) )
6982	CALL MPI_AllGather( sub_lad, nnxnnynz_plant, MPI_REAL, &
6983	sub_lad_g, nnxnnynz_plant, MPI_REAL, comm2d, ierr )
6984	IF ( ierr /= 0 ) THEN
6985	WRITE(9,*) 'Error MPI_AllGather3:', ierr, SIZE(sub_lad), &
6986	nnxnnynz_plant, SIZE(sub_lad_g), nnxnnynz_plant
6987	FLUSH(9)
6988	ENDIF
6989	ENDIF
6990	#endif
6991	ENDIF
6992
6993	!-- prepare the MPI_Win for collecting the surface indices
6994	!-- from the reverse index arrays gridsurf from processors of target surfaces
6995	#if defined( __parallel )
6996	IF ( rad_angular_discretization ) THEN
6997	!
6998	!-- raytrace_mpi_rma is asserted
6999	CALL MPI_Win_lock_all(0, win_gridsurf, ierr)
7000	IF ( ierr /= 0 ) THEN
7001	WRITE(9,*) 'Error MPI_Win_lock_all2:', ierr, win_gridsurf
7002	FLUSH(9)
7003	ENDIF
7004	ENDIF
7005	#endif
7006
7007
7008	!--Directions opposite to face normals are not even calculated,
7009	!--they must be preset to 0
7010	!--
7011	dsitrans(:,:) = 0._wp
7012
7013	DO isurflt = 1, nsurfl
7014	!-- determine face centers
7015	td = surfl(id, isurflt)
7016	ta = (/ REAL(surfl(iz, isurflt), wp) - 0.5_wp * kdir(td), &
7017	REAL(surfl(iy, isurflt), wp) - 0.5_wp * jdir(td), &
7018	REAL(surfl(ix, isurflt), wp) - 0.5_wp * idir(td) /)
7019
7020	!--Calculate sky view factor and raytrace DSI paths
7021	skyvf(isurflt) = 0._wp
7022	skyvft(isurflt) = 0._wp
7023
7024	!--Select a proper half-sphere for 2D raytracing
7025	SELECT CASE ( td )
7026	CASE ( iup_u, iup_l )
7027	az0 = 0._wp
7028	naz = raytrace_discrete_azims
7029	azs = 2._wp * pi / REAL(naz, wp)
7030	zn0 = 0._wp
7031	nzn = raytrace_discrete_elevs / 2
7032	zns = pi / 2._wp / REAL(nzn, wp)
7033	CASE ( isouth_u, isouth_l )
7034	az0 = pi / 2._wp
7035	naz = raytrace_discrete_azims / 2
7036	azs = pi / REAL(naz, wp)
7037	zn0 = 0._wp
7038	nzn = raytrace_discrete_elevs
7039	zns = pi / REAL(nzn, wp)
7040	CASE ( inorth_u, inorth_l )
7041	az0 = - pi / 2._wp
7042	naz = raytrace_discrete_azims / 2
7043	azs = pi / REAL(naz, wp)
7044	zn0 = 0._wp
7045	nzn = raytrace_discrete_elevs
7046	zns = pi / REAL(nzn, wp)
7047	CASE ( iwest_u, iwest_l )
7048	az0 = pi
7049	naz = raytrace_discrete_azims / 2
7050	azs = pi / REAL(naz, wp)
7051	zn0 = 0._wp
7052	nzn = raytrace_discrete_elevs
7053	zns = pi / REAL(nzn, wp)
7054	CASE ( ieast_u, ieast_l )
7055	az0 = 0._wp
7056	naz = raytrace_discrete_azims / 2
7057	azs = pi / REAL(naz, wp)
7058	zn0 = 0._wp
7059	nzn = raytrace_discrete_elevs
7060	zns = pi / REAL(nzn, wp)
7061	CASE DEFAULT
7062	WRITE(message_string, *) 'ERROR: the surface type ', td, &
7063	' is not supported for calculating',&
7064	' SVF'
7065	CALL message( 'radiation_calc_svf', 'PA0488', 1, 2, 0, 6, 0 )
7066	END SELECT
7067
7068	ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), &
7069	ztransp(1:nznnaz), itarget(1:nznnaz) ) !FIXME allocate itarget only
7070	!in case of rad_angular_discretization
7071
7072	itarg0 = 1
7073	itarg1 = nzn
7074	zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7075	zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/)
7076	IF ( td == iup_u .OR. td == iup_l ) THEN
7077	vffrac(1:nzn) = (COS(2 * zbdry(0:nzn-1)) - COS(2 * zbdry(1:nzn))) / 2._wp / REAL(naz, wp)
7078	!
7079	!-- For horizontal target, vf fractions are constant per azimuth
7080	DO iaz = 1, naz-1
7081	vffrac(iaznzn+1:(iaz+1)nzn) = vffrac(1:nzn)
7082	ENDDO
7083	!-- sum of whole vffrac equals 1, verified
7084	ENDIF
7085	!
7086	!-- Calculate sky-view factor and direct solar visibility using 2D raytracing
7087	DO iaz = 1, naz
7088	azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7089	IF ( td /= iup_u .AND. td /= iup_l ) THEN
7090	az2 = REAL(iaz, wp) * azs - pi/2._wp
7091	az1 = az2 - azs
7092	!TODO precalculate after 1st line
7093	vffrac(itarg0:itarg1) = (SIN(az2) - SIN(az1)) &
7094	* (zbdry(1:nzn) - zbdry(0:nzn-1) &
7095	+ SIN(zbdry(0:nzn-1))*COS(zbdry(0:nzn-1)) &
7096	- SIN(zbdry(1:nzn))*COS(zbdry(1:nzn))) &
7097	/ (2._wp * pi)
7098	!-- sum of whole vffrac equals 1, verified
7099	ENDIF
7100	yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7101	yxlen = SQRT(SUM(yxdir(:)**2))
7102	zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7103	yxdir(:) = yxdir(:) / yxlen
7104
7105	CALL raytrace_2d(ta, yxdir, nzn, zdirs, &
7106	surfstart(myid) + isurflt, facearea(td), &
7107	vffrac(itarg0:itarg1), .TRUE., .TRUE., &
7108	.FALSE., lowest_free_ray, &
7109	ztransp(itarg0:itarg1), &
7110	itarget(itarg0:itarg1))
7111
7112	skyvf(isurflt) = skyvf(isurflt) + &
7113	SUM(vffrac(itarg0:itarg0+lowest_free_ray-1))
7114	skyvft(isurflt) = skyvft(isurflt) + &
7115	SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) &
7116	* vffrac(itarg0:itarg0+lowest_free_ray-1))
7117
7118	!-- Save direct solar transparency
7119	j = MODULO(NINT(azmid/ &
7120	(2._wppi)raytrace_discrete_azims-.5_wp, iwp), &
7121	raytrace_discrete_azims)
7122
7123	DO k = 1, raytrace_discrete_elevs/2
7124	i = dsidir_rev(k-1, j)
7125	IF ( i /= -1 .AND. k <= lowest_free_ray ) &
7126	dsitrans(isurflt, i) = ztransp(itarg0+k-1)
7127	ENDDO
7128
7129	!
7130	!-- Advance itarget indices
7131	itarg0 = itarg1 + 1
7132	itarg1 = itarg1 + nzn
7133	ENDDO
7134
7135	IF ( rad_angular_discretization ) THEN
7136	!-- sort itarget by face id
7137	CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz)
7138	!
7139	!-- For aggregation, we need fractions multiplied by transmissivities
7140	ztransp(:) = vffrac(:) * ztransp(:)
7141	!
7142	!-- find the first valid position
7143	itarg0 = 1
7144	DO WHILE ( itarg0 <= nzn*naz )
7145	IF ( itarget(itarg0) /= -1 ) EXIT
7146	itarg0 = itarg0 + 1
7147	ENDDO
7148
7149	DO i = itarg0, nzn*naz
7150	!
7151	!-- For duplicate values, only sum up vf fraction value
7152	IF ( i < nzn*naz ) THEN
7153	IF ( itarget(i+1) == itarget(i) ) THEN
7154	vffrac(i+1) = vffrac(i+1) + vffrac(i)
7155	ztransp(i+1) = ztransp(i+1) + ztransp(i)
7156	CYCLE
7157	ENDIF
7158	ENDIF
7159	!
7160	!-- write to the svf array
7161	nsvfl = nsvfl + 1
7162	!-- check dimmension of asvf array and enlarge it if needed
7163	IF ( nsvfla < nsvfl ) THEN
7164	k = CEILING(REAL(nsvfla, kind=wp) * grow_factor)
7165	IF ( msvf == 0 ) THEN
7166	msvf = 1
7167	ALLOCATE( asvf1(k) )
7168	asvf => asvf1
7169	asvf1(1:nsvfla) = asvf2
7170	DEALLOCATE( asvf2 )
7171	ELSE
7172	msvf = 0
7173	ALLOCATE( asvf2(k) )
7174	asvf => asvf2
7175	asvf2(1:nsvfla) = asvf1
7176	DEALLOCATE( asvf1 )
7177	ENDIF
7178
7179	IF ( debug_output ) THEN
7180	WRITE( debug_string, '(A,3I12)' ) 'Grow asvf:', nsvfl, nsvfla, k
7181	CALL debug_message( debug_string, 'info' )
7182	ENDIF
7183
7184	nsvfla = k
7185	ENDIF
7186	!-- write svf values into the array
7187	asvf(nsvfl)%isurflt = isurflt
7188	asvf(nsvfl)%isurfs = itarget(i)
7189	asvf(nsvfl)%rsvf = vffrac(i)
7190	asvf(nsvfl)%rtransp = ztransp(i) / vffrac(i)
7191	END DO
7192
7193	ENDIF ! rad_angular_discretization
7194
7195	DEALLOCATE ( zdirs, zcent, zbdry, vffrac, ztransp, itarget ) !FIXME itarget shall be allocated only
7196	!in case of rad_angular_discretization
7197	!
7198	!-- Following calculations only required for surface_reflections
7199	IF ( surface_reflections .AND. .NOT. rad_angular_discretization ) THEN
7200
7201	DO isurfs = 1, nsurf
7202	IF ( .NOT. surface_facing(surfl(ix, isurflt), surfl(iy, isurflt), &
7203	surfl(iz, isurflt), surfl(id, isurflt), &
7204	surf(ix, isurfs), surf(iy, isurfs), &
7205	surf(iz, isurfs), surf(id, isurfs)) ) THEN
7206	CYCLE
7207	ENDIF
7208
7209	sd = surf(id, isurfs)
7210	sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd), &
7211	REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd), &
7212	REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd) /)
7213
7214	!-- unit vector source -> target
7215	uv = (/ (ta(1)-sa(1))dz(1), (ta(2)-sa(2))dy, (ta(3)-sa(3))*dx /)
7216	sqdist = SUM(uv(:)**2)
7217	uv = uv / SQRT(sqdist)
7218
7219	!-- reject raytracing above max distance
7220	IF ( SQRT(sqdist) > max_raytracing_dist ) THEN
7221	ray_skip_maxdist = ray_skip_maxdist + 1
7222	CYCLE
7223	ENDIF
7224
7225	difvf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) & ! cosine of source normal and direction
7226	* dot_product((/ kdir(td), jdir(td), idir(td) /), -uv) & ! cosine of target normal and reverse direction
7227	/ (pi * sqdist) ! square of distance between centers
7228	!
7229	!-- irradiance factor (our unshaded shape view factor) = view factor per differential target area * source area
7230	rirrf = difvf * facearea(sd)
7231
7232	!-- reject raytracing for potentially too small view factor values
7233	IF ( rirrf < min_irrf_value ) THEN
7234	ray_skip_minval = ray_skip_minval + 1
7235	CYCLE
7236	ENDIF
7237
7238	!-- raytrace + process plant canopy sinks within
7239	CALL raytrace(sa, ta, isurfs, difvf, facearea(td), .TRUE., &
7240	visible, transparency)
7241
7242	IF ( .NOT. visible ) CYCLE
7243	! rsvf = rirrf * transparency
7244
7245	!-- write to the svf array
7246	nsvfl = nsvfl + 1
7247	!-- check dimmension of asvf array and enlarge it if needed
7248	IF ( nsvfla < nsvfl ) THEN
7249	k = CEILING(REAL(nsvfla, kind=wp) * grow_factor)
7250	IF ( msvf == 0 ) THEN
7251	msvf = 1
7252	ALLOCATE( asvf1(k) )
7253	asvf => asvf1
7254	asvf1(1:nsvfla) = asvf2
7255	DEALLOCATE( asvf2 )
7256	ELSE
7257	msvf = 0
7258	ALLOCATE( asvf2(k) )
7259	asvf => asvf2
7260	asvf2(1:nsvfla) = asvf1
7261	DEALLOCATE( asvf1 )
7262	ENDIF
7263
7264	IF ( debug_output ) THEN
7265	WRITE( debug_string, '(A,3I12)' ) 'Grow asvf:', nsvfl, nsvfla, k
7266	CALL debug_message( debug_string, 'info' )
7267	ENDIF
7268
7269	nsvfla = k
7270	ENDIF
7271	!-- write svf values into the array
7272	asvf(nsvfl)%isurflt = isurflt
7273	asvf(nsvfl)%isurfs = isurfs
7274	asvf(nsvfl)%rsvf = rirrf !we postopne multiplication by transparency
7275	asvf(nsvfl)%rtransp = transparency !a.k.a. Direct Irradiance Factor
7276	ENDDO
7277	ENDIF
7278	ENDDO
7279
7280	!--
7281	!-- Raytrace to canopy boxes to fill dsitransc TODO optimize
7282	dsitransc(:,:) = 0._wp
7283	az0 = 0._wp
7284	naz = raytrace_discrete_azims
7285	azs = 2._wp * pi / REAL(naz, wp)
7286	zn0 = 0._wp
7287	nzn = raytrace_discrete_elevs / 2
7288	zns = pi / 2._wp / REAL(nzn, wp)
7289	ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), vffrac(1:nzn), ztransp(1:nzn), &
7290	itarget(1:nzn) )
7291	zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7292	vffrac(:) = 0._wp
7293
7294	DO ipcgb = 1, npcbl
7295	ta = (/ REAL(pcbl(iz, ipcgb), wp), &
7296	REAL(pcbl(iy, ipcgb), wp), &
7297	REAL(pcbl(ix, ipcgb), wp) /)
7298	!-- Calculate direct solar visibility using 2D raytracing
7299	DO iaz = 1, naz
7300	azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7301	yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7302	yxlen = SQRT(SUM(yxdir(:)**2))
7303	zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7304	yxdir(:) = yxdir(:) / yxlen
7305	CALL raytrace_2d(ta, yxdir, nzn, zdirs, &
7306	-999, -999._wp, vffrac, .FALSE., .FALSE., .TRUE., &
7307	lowest_free_ray, ztransp, itarget)
7308
7309	!-- Save direct solar transparency
7310	j = MODULO(NINT(azmid/ &
7311	(2._wppi)raytrace_discrete_azims-.5_wp, iwp), &
7312	raytrace_discrete_azims)
7313	DO k = 1, raytrace_discrete_elevs/2
7314	i = dsidir_rev(k-1, j)
7315	IF ( i /= -1 .AND. k <= lowest_free_ray ) &
7316	dsitransc(ipcgb, i) = ztransp(k)
7317	ENDDO
7318	ENDDO
7319	ENDDO
7320	DEALLOCATE ( zdirs, zcent, vffrac, ztransp, itarget )
7321	!--
7322	!-- Raytrace to MRT boxes
7323	IF ( nmrtbl > 0 ) THEN
7324	mrtdsit(:,:) = 0._wp
7325	mrtsky(:) = 0._wp
7326	mrtskyt(:) = 0._wp
7327	az0 = 0._wp
7328	naz = raytrace_discrete_azims
7329	azs = 2._wp * pi / REAL(naz, wp)
7330	zn0 = 0._wp
7331	nzn = raytrace_discrete_elevs
7332	zns = pi / REAL(nzn, wp)
7333	ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), vffrac0(1:nzn), &
7334	ztransp(1:nznnaz), itarget(1:nznnaz) ) !FIXME allocate itarget only
7335	!in case of rad_angular_discretization
7336
7337	zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7338	zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/)
7339	vffrac0(:) = (COS(zbdry(0:nzn-1)) - COS(zbdry(1:nzn))) / 2._wp / REAL(naz, wp)
7340	!
7341	!--Modify direction weights to simulate human body (lower weight for top-down)
7342	IF ( mrt_geom_human ) THEN
7343	vffrac0(:) = vffrac0(:) * MAX(0._wp, SIN(zcent(:))0.88_wp + COS(zcent(:))0.12_wp)
7344	vffrac0(:) = vffrac0(:) / (SUM(vffrac0) * REAL(naz, wp))
7345	ENDIF
7346
7347	DO imrt = 1, nmrtbl
7348	ta = (/ REAL(mrtbl(iz, imrt), wp), &
7349	REAL(mrtbl(iy, imrt), wp), &
7350	REAL(mrtbl(ix, imrt), wp) /)
7351	!
7352	!-- vf fractions are constant per azimuth
7353	DO iaz = 0, naz-1
7354	vffrac(iaznzn+1:(iaz+1)nzn) = vffrac0(:)
7355	ENDDO
7356	!-- sum of whole vffrac equals 1, verified
7357	itarg0 = 1
7358	itarg1 = nzn
7359	!
7360	!-- Calculate sky-view factor and direct solar visibility using 2D raytracing
7361	DO iaz = 1, naz
7362	azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7363	yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7364	yxlen = SQRT(SUM(yxdir(:)**2))
7365	zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7366	yxdir(:) = yxdir(:) / yxlen
7367
7368	CALL raytrace_2d(ta, yxdir, nzn, zdirs, &
7369	-999, -999._wp, vffrac(itarg0:itarg1), .TRUE., &
7370	.FALSE., .TRUE., lowest_free_ray, &
7371	ztransp(itarg0:itarg1), &
7372	itarget(itarg0:itarg1))
7373
7374	!-- Sky view factors for MRT
7375	mrtsky(imrt) = mrtsky(imrt) + &
7376	SUM(vffrac(itarg0:itarg0+lowest_free_ray-1))
7377	mrtskyt(imrt) = mrtskyt(imrt) + &
7378	SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) &
7379	* vffrac(itarg0:itarg0+lowest_free_ray-1))
7380	!-- Direct solar transparency for MRT
7381	j = MODULO(NINT(azmid/ &
7382	(2._wppi)raytrace_discrete_azims-.5_wp, iwp), &
7383	raytrace_discrete_azims)
7384	DO k = 1, raytrace_discrete_elevs/2
7385	i = dsidir_rev(k-1, j)
7386	IF ( i /= -1 .AND. k <= lowest_free_ray ) &
7387	mrtdsit(imrt, i) = ztransp(itarg0+k-1)
7388	ENDDO
7389	!
7390	!-- Advance itarget indices
7391	itarg0 = itarg1 + 1
7392	itarg1 = itarg1 + nzn
7393	ENDDO
7394
7395	!-- sort itarget by face id
7396	CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz)
7397	!
7398	!-- find the first valid position
7399	itarg0 = 1
7400	DO WHILE ( itarg0 <= nzn*naz )
7401	IF ( itarget(itarg0) /= -1 ) EXIT
7402	itarg0 = itarg0 + 1
7403	ENDDO
7404
7405	DO i = itarg0, nzn*naz
7406	!
7407	!-- For duplicate values, only sum up vf fraction value
7408	IF ( i < nzn*naz ) THEN
7409	IF ( itarget(i+1) == itarget(i) ) THEN
7410	vffrac(i+1) = vffrac(i+1) + vffrac(i)
7411	CYCLE
7412	ENDIF
7413	ENDIF
7414	!
7415	!-- write to the mrtf array
7416	nmrtf = nmrtf + 1
7417	!-- check dimmension of mrtf array and enlarge it if needed
7418	IF ( nmrtfa < nmrtf ) THEN
7419	k = CEILING(REAL(nmrtfa, kind=wp) * grow_factor)
7420	IF ( mmrtf == 0 ) THEN
7421	mmrtf = 1
7422	ALLOCATE( amrtf1(k) )
7423	amrtf => amrtf1
7424	amrtf1(1:nmrtfa) = amrtf2
7425	DEALLOCATE( amrtf2 )
7426	ELSE
7427	mmrtf = 0
7428	ALLOCATE( amrtf2(k) )
7429	amrtf => amrtf2
7430	amrtf2(1:nmrtfa) = amrtf1
7431	DEALLOCATE( amrtf1 )
7432	ENDIF
7433
7434	IF ( debug_output ) THEN
7435	WRITE( debug_string, '(A,3I12)' ) 'Grow amrtf:', nmrtf, nmrtfa, k
7436	CALL debug_message( debug_string, 'info' )
7437	ENDIF
7438
7439	nmrtfa = k
7440	ENDIF
7441	!-- write mrtf values into the array
7442	amrtf(nmrtf)%isurflt = imrt
7443	amrtf(nmrtf)%isurfs = itarget(i)
7444	amrtf(nmrtf)%rsvf = vffrac(i)
7445	amrtf(nmrtf)%rtransp = ztransp(i)
7446	ENDDO ! itarg
7447
7448	ENDDO ! imrt
7449	DEALLOCATE ( zdirs, zcent, zbdry, vffrac, vffrac0, ztransp, itarget )
7450	!
7451	!-- Move MRT factors to final arrays
7452	ALLOCATE ( mrtf(nmrtf), mrtft(nmrtf), mrtfsurf(2,nmrtf) )
7453	DO imrtf = 1, nmrtf
7454	mrtf(imrtf) = amrtf(imrtf)%rsvf
7455	mrtft(imrtf) = amrtf(imrtf)%rsvf * amrtf(imrtf)%rtransp
7456	mrtfsurf(:,imrtf) = (/amrtf(imrtf)%isurflt, amrtf(imrtf)%isurfs /)
7457	ENDDO
7458	IF ( ALLOCATED(amrtf1) ) DEALLOCATE( amrtf1 )
7459	IF ( ALLOCATED(amrtf2) ) DEALLOCATE( amrtf2 )
7460	ENDIF ! nmrtbl > 0
7461
7462	IF ( rad_angular_discretization ) THEN
7463	#if defined( __parallel )
7464	!-- finalize MPI_RMA communication established to get global index of the surface from grid indices
7465	!-- flush all MPI window pending requests
7466	CALL MPI_Win_flush_all(win_gridsurf, ierr)
7467	IF ( ierr /= 0 ) THEN
7468	WRITE(9,*) 'Error MPI_Win_flush_all1:', ierr, win_gridsurf
7469	FLUSH(9)
7470	ENDIF
7471	!-- unlock MPI window
7472	CALL MPI_Win_unlock_all(win_gridsurf, ierr)
7473	IF ( ierr /= 0 ) THEN
7474	WRITE(9,*) 'Error MPI_Win_unlock_all1:', ierr, win_gridsurf
7475	FLUSH(9)
7476	ENDIF
7477	!-- free MPI window
7478	CALL MPI_Win_free(win_gridsurf, ierr)
7479	IF ( ierr /= 0 ) THEN
7480	WRITE(9,*) 'Error MPI_Win_free1:', ierr, win_gridsurf
7481	FLUSH(9)
7482	ENDIF
7483	#else
7484	DEALLOCATE ( gridsurf )
7485	#endif
7486	ENDIF
7487
7488	IF ( debug_output ) CALL debug_message( 'waiting for completion of SVF and CSF calculation in all processes', 'info' )
7489
7490	!-- deallocate temporary global arrays
7491	DEALLOCATE(nzterr)
7492
7493	IF ( plant_canopy ) THEN
7494	!-- finalize mpi_rma communication and deallocate temporary arrays
7495	#if defined( __parallel )
7496	IF ( raytrace_mpi_rma ) THEN
7497	CALL MPI_Win_flush_all(win_lad, ierr)
7498	IF ( ierr /= 0 ) THEN
7499	WRITE(9,*) 'Error MPI_Win_flush_all2:', ierr, win_lad
7500	FLUSH(9)
7501	ENDIF
7502	!-- unlock MPI window
7503	CALL MPI_Win_unlock_all(win_lad, ierr)
7504	IF ( ierr /= 0 ) THEN
7505	WRITE(9,*) 'Error MPI_Win_unlock_all2:', ierr, win_lad
7506	FLUSH(9)
7507	ENDIF
7508	!-- free MPI window
7509	CALL MPI_Win_free(win_lad, ierr)
7510	IF ( ierr /= 0 ) THEN
7511	WRITE(9,*) 'Error MPI_Win_free2:', ierr, win_lad
7512	FLUSH(9)
7513	ENDIF
7514	!-- deallocate temporary arrays storing values for csf calculation during raytracing
7515	DEALLOCATE( lad_s_ray )
7516	!-- sub_lad is the pointer to lad_s_rma in case of raytrace_mpi_rma
7517	!-- and must not be deallocated here
7518	ELSE
7519	DEALLOCATE(sub_lad)
7520	DEALLOCATE(sub_lad_g)
7521	ENDIF
7522	#else
7523	DEALLOCATE(sub_lad)
7524	#endif
7525	DEALLOCATE( boxes )
7526	DEALLOCATE( crlens )
7527	DEALLOCATE( plantt )
7528	DEALLOCATE( rt2_track, rt2_track_lad, rt2_track_dist, rt2_dist )
7529	ENDIF
7530
7531	IF ( debug_output ) CALL debug_message( 'calculation of the complete SVF array', 'info' )
7532
7533	IF ( rad_angular_discretization ) THEN
7534	IF ( debug_output ) CALL debug_message( 'Load svf from the structure array to plain arrays', 'info' )
7535	ALLOCATE( svf(ndsvf,nsvfl) )
7536	ALLOCATE( svfsurf(idsvf,nsvfl) )
7537
7538	DO isvf = 1, nsvfl
7539	svf(:, isvf) = (/ asvf(isvf)%rsvf, asvf(isvf)%rtransp /)
7540	svfsurf(:, isvf) = (/ asvf(isvf)%isurflt, asvf(isvf)%isurfs /)
7541	ENDDO
7542	ELSE
7543	IF ( debug_output ) CALL debug_message( 'Start SVF sort', 'info' )
7544	!-- sort svf ( a version of quicksort )
7545	CALL quicksort_svf(asvf,1,nsvfl)
7546
7547	!< load svf from the structure array to plain arrays
7548	IF ( debug_output ) CALL debug_message( 'Load svf from the structure array to plain arrays', 'info' )
7549	ALLOCATE( svf(ndsvf,nsvfl) )
7550	ALLOCATE( svfsurf(idsvf,nsvfl) )
7551	svfnorm_counts(:) = 0._wp
7552	isurflt_prev = -1
7553	ksvf = 1
7554	svfsum = 0._wp
7555	DO isvf = 1, nsvfl
7556	!-- normalize svf per target face
7557	IF ( asvf(ksvf)%isurflt /= isurflt_prev ) THEN
7558	IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN
7559	!< update histogram of logged svf normalization values
7560	i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev)))
7561	svfnorm_counts(i) = svfnorm_counts(i) + 1
7562
7563	svf(1, isvf_surflt:isvf-1) = svf(1, isvf_surflt:isvf-1) / svfsum * (1._wp-skyvf(isurflt_prev))
7564	ENDIF
7565	isurflt_prev = asvf(ksvf)%isurflt
7566	isvf_surflt = isvf
7567	svfsum = asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp
7568	ELSE
7569	svfsum = svfsum + asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp
7570	ENDIF
7571
7572	svf(:, isvf) = (/ asvf(ksvf)%rsvf, asvf(ksvf)%rtransp /)
7573	svfsurf(:, isvf) = (/ asvf(ksvf)%isurflt, asvf(ksvf)%isurfs /)
7574
7575	!-- next element
7576	ksvf = ksvf + 1
7577	ENDDO
7578
7579	IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN
7580	i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev)))
7581	svfnorm_counts(i) = svfnorm_counts(i) + 1
7582
7583	svf(1, isvf_surflt:nsvfl) = svf(1, isvf_surflt:nsvfl) / svfsum * (1._wp-skyvf(isurflt_prev))
7584	ENDIF
7585	WRITE(9, *) 'SVF normalization histogram:', svfnorm_counts, &
7586	'on thresholds:', svfnorm_report_thresh(1:svfnorm_report_num), '(val < thresh <= val)'
7587	!TODO we should be able to deallocate skyvf, from now on we only need skyvft
7588	ENDIF ! rad_angular_discretization
7589
7590	!-- deallocate temporary asvf array
7591	!-- DEALLOCATE(asvf) - ifort has a problem with deallocation of allocatable target
7592	!-- via pointing pointer - we need to test original targets
7593	IF ( ALLOCATED(asvf1) ) THEN
7594	DEALLOCATE(asvf1)
7595	ENDIF
7596	IF ( ALLOCATED(asvf2) ) THEN
7597	DEALLOCATE(asvf2)
7598	ENDIF
7599
7600	npcsfl = 0
7601	IF ( plant_canopy ) THEN
7602
7603	IF ( debug_output ) CALL debug_message( 'Calculation of the complete CSF array', 'info' )
7604	!-- sort and merge csf for the last time, keeping the array size to minimum
7605	CALL merge_and_grow_csf(-1)
7606
7607	!-- aggregate csb among processors
7608	!-- allocate necessary arrays
7609	udim = max(ncsfl,1)
7610	ALLOCATE( csflt_l(ndcsf*udim) )
7611	csflt(1:ndcsf,1:udim) => csflt_l(1:ndcsf*udim)
7612	ALLOCATE( kcsflt_l(kdcsf*udim) )
7613	kcsflt(1:kdcsf,1:udim) => kcsflt_l(1:kdcsf*udim)
7614	ALLOCATE( icsflt(0:numprocs-1) )
7615	ALLOCATE( dcsflt(0:numprocs-1) )
7616	ALLOCATE( ipcsflt(0:numprocs-1) )
7617	ALLOCATE( dpcsflt(0:numprocs-1) )
7618
7619	!-- fill out arrays of csf values and
7620	!-- arrays of number of elements and displacements
7621	!-- for particular precessors
7622	icsflt = 0
7623	dcsflt = 0
7624	ip = -1
7625	j = -1
7626	d = 0
7627	DO kcsf = 1, ncsfl
7628	j = j+1
7629	IF ( acsf(kcsf)%ip /= ip ) THEN
7630	!-- new block of the processor
7631	!-- number of elements of previous block
7632	IF ( ip>=0) icsflt(ip) = j
7633	d = d+j
7634	!-- blank blocks
7635	DO jp = ip+1, acsf(kcsf)%ip-1
7636	!-- number of elements is zero, displacement is equal to previous
7637	icsflt(jp) = 0
7638	dcsflt(jp) = d
7639	ENDDO
7640	!-- the actual block
7641	ip = acsf(kcsf)%ip
7642	dcsflt(ip) = d
7643	j = 0
7644	ENDIF
7645	csflt(1,kcsf) = acsf(kcsf)%rcvf
7646	!-- fill out integer values of itz,ity,itx,isurfs
7647	kcsflt(1,kcsf) = acsf(kcsf)%itz
7648	kcsflt(2,kcsf) = acsf(kcsf)%ity
7649	kcsflt(3,kcsf) = acsf(kcsf)%itx
7650	kcsflt(4,kcsf) = acsf(kcsf)%isurfs
7651	ENDDO
7652	!-- last blank blocks at the end of array
7653	j = j+1
7654	IF ( ip>=0 ) icsflt(ip) = j
7655	d = d+j
7656	DO jp = ip+1, numprocs-1
7657	!-- number of elements is zero, displacement is equal to previous
7658	icsflt(jp) = 0
7659	dcsflt(jp) = d
7660	ENDDO
7661
7662	!-- deallocate temporary acsf array
7663	!-- DEALLOCATE(acsf) - ifort has a problem with deallocation of allocatable target
7664	!-- via pointing pointer - we need to test original targets
7665	IF ( ALLOCATED(acsf1) ) THEN
7666	DEALLOCATE(acsf1)
7667	ENDIF
7668	IF ( ALLOCATED(acsf2) ) THEN
7669	DEALLOCATE(acsf2)
7670	ENDIF
7671
7672	#if defined( __parallel )
7673	!-- scatter and gather the number of elements to and from all processor
7674	!-- and calculate displacements
7675	IF ( debug_output ) CALL debug_message( 'Scatter and gather the number of elements to and from all processor', 'info' )
7676
7677	CALL MPI_AlltoAll(icsflt,1,MPI_INTEGER,ipcsflt,1,MPI_INTEGER,comm2d, ierr)
7678
7679	IF ( ierr /= 0 ) THEN
7680	WRITE(9,*) 'Error MPI_AlltoAll1:', ierr, SIZE(icsflt), SIZE(ipcsflt)
7681	FLUSH(9)
7682	ENDIF
7683
7684	npcsfl = SUM(ipcsflt)
7685	d = 0
7686	DO i = 0, numprocs-1
7687	dpcsflt(i) = d
7688	d = d + ipcsflt(i)
7689	ENDDO
7690
7691	!-- exchange csf fields between processors
7692	IF ( debug_output ) CALL debug_message( 'Exchange csf fields between processors', 'info' )
7693	udim = max(npcsfl,1)
7694	ALLOCATE( pcsflt_l(ndcsf*udim) )
7695	pcsflt(1:ndcsf,1:udim) => pcsflt_l(1:ndcsf*udim)
7696	ALLOCATE( kpcsflt_l(kdcsf*udim) )
7697	kpcsflt(1:kdcsf,1:udim) => kpcsflt_l(1:kdcsf*udim)
7698	CALL MPI_AlltoAllv(csflt_l, ndcsficsflt, ndcsfdcsflt, MPI_REAL, &
7699	pcsflt_l, ndcsfipcsflt, ndcsfdpcsflt, MPI_REAL, comm2d, ierr)
7700	IF ( ierr /= 0 ) THEN
7701	WRITE(9,) 'Error MPI_AlltoAllv1:', ierr, SIZE(ipcsflt), ndcsficsflt, &
7702	ndcsfdcsflt, SIZE(pcsflt_l),ndcsfipcsflt, ndcsf*dpcsflt
7703	FLUSH(9)
7704	ENDIF
7705
7706	CALL MPI_AlltoAllv(kcsflt_l, kdcsficsflt, kdcsfdcsflt, MPI_INTEGER, &
7707	kpcsflt_l, kdcsfipcsflt, kdcsfdpcsflt, MPI_INTEGER, comm2d, ierr)
7708	IF ( ierr /= 0 ) THEN
7709	WRITE(9,) 'Error MPI_AlltoAllv2:', ierr, SIZE(kcsflt_l),kdcsficsflt, &
7710	kdcsfdcsflt, SIZE(kpcsflt_l), kdcsfipcsflt, kdcsf*dpcsflt
7711	FLUSH(9)
7712	ENDIF
7713
7714	#else
7715	npcsfl = ncsfl
7716	ALLOCATE( pcsflt(ndcsf,max(npcsfl,ndcsf)) )
7717	ALLOCATE( kpcsflt(kdcsf,max(npcsfl,kdcsf)) )
7718	pcsflt = csflt
7719	kpcsflt = kcsflt
7720	#endif
7721
7722	!-- deallocate temporary arrays
7723	DEALLOCATE( csflt_l )
7724	DEALLOCATE( kcsflt_l )
7725	DEALLOCATE( icsflt )
7726	DEALLOCATE( dcsflt )
7727	DEALLOCATE( ipcsflt )
7728	DEALLOCATE( dpcsflt )
7729
7730	!-- sort csf ( a version of quicksort )
7731	IF ( debug_output ) CALL debug_message( 'Sort csf', 'info' )
7732	CALL quicksort_csf2(kpcsflt, pcsflt, 1, npcsfl)
7733
7734	!-- aggregate canopy sink factor records with identical box & source
7735	!-- againg across all values from all processors
7736	IF ( debug_output ) CALL debug_message( 'Aggregate canopy sink factor records with identical box', 'info' )
7737
7738	IF ( npcsfl > 0 ) THEN
7739	icsf = 1 !< reading index
7740	kcsf = 1 !< writing index
7741	DO WHILE (icsf < npcsfl)
7742	!-- here kpcsf(kcsf) already has values from kpcsf(icsf)
7743	IF ( kpcsflt(3,icsf) == kpcsflt(3,icsf+1) .AND. &
7744	kpcsflt(2,icsf) == kpcsflt(2,icsf+1) .AND. &
7745	kpcsflt(1,icsf) == kpcsflt(1,icsf+1) .AND. &
7746	kpcsflt(4,icsf) == kpcsflt(4,icsf+1) ) THEN
7747
7748	pcsflt(1,kcsf) = pcsflt(1,kcsf) + pcsflt(1,icsf+1)
7749
7750	!-- advance reading index, keep writing index
7751	icsf = icsf + 1
7752	ELSE
7753	!-- not identical, just advance and copy
7754	icsf = icsf + 1
7755	kcsf = kcsf + 1
7756	kpcsflt(:,kcsf) = kpcsflt(:,icsf)
7757	pcsflt(:,kcsf) = pcsflt(:,icsf)
7758	ENDIF
7759	ENDDO
7760	!-- last written item is now also the last item in valid part of array
7761	npcsfl = kcsf
7762	ENDIF
7763
7764	ncsfl = npcsfl
7765	IF ( ncsfl > 0 ) THEN
7766	ALLOCATE( csf(ndcsf,ncsfl) )
7767	ALLOCATE( csfsurf(idcsf,ncsfl) )
7768	DO icsf = 1, ncsfl
7769	csf(:,icsf) = pcsflt(:,icsf)
7770	csfsurf(1,icsf) = gridpcbl(kpcsflt(1,icsf),kpcsflt(2,icsf),kpcsflt(3,icsf))
7771	csfsurf(2,icsf) = kpcsflt(4,icsf)
7772	ENDDO
7773	ENDIF
7774
7775	!-- deallocation of temporary arrays
7776	IF ( npcbl > 0 ) DEALLOCATE( gridpcbl )
7777	DEALLOCATE( pcsflt_l )
7778	DEALLOCATE( kpcsflt_l )
7779	IF ( debug_output ) CALL debug_message( 'End of aggregate csf', 'info' )
7780
7781	ENDIF
7782
7783	#if defined( __parallel )
7784	CALL MPI_BARRIER( comm2d, ierr )
7785	#endif
7786	CALL location_message( 'calculating view factors for radiation interaction', 'finished' )
7787
7788	RETURN !todo: remove
7789
7790	! WRITE( message_string, * ) &
7791	! 'I/O error when processing shape view factors / ', &
7792	! 'plant canopy sink factors / direct irradiance factors.'
7793	! CALL message( 'init_urban_surface', 'PA0502', 2, 2, 0, 6, 0 )
7794
7795	END SUBROUTINE radiation_calc_svf
7796
7797
7798	!------------------------------------------------------------------------------!
7799	! Description:
7800	! ------------
7801	!> Raytracing for detecting obstacles and calculating compound canopy sink
7802	!> factors. (A simple obstacle detection would only need to process faces in
7803	!> 3 dimensions without any ordering.)
7804	!> Assumtions:
7805	!> -----------
7806	!> 1. The ray always originates from a face midpoint (only one coordinate equals
7807	!> *.5, i.e. wall) and doesn't travel parallel to the surface (that would mean
7808	!> shape factor=0). Therefore, the ray may never travel exactly along a face
7809	!> or an edge.
7810	!> 2. From grid bottom to urban surface top the grid has to be equidistant
7811	!> within each of the dimensions, including vertical (but the resolution
7812	!> doesn't need to be the same in all three dimensions).
7813	!------------------------------------------------------------------------------!
7814	SUBROUTINE raytrace(src, targ, isrc, difvf, atarg, create_csf, visible, transparency)
7815	IMPLICIT NONE
7816
7817	REAL(wp), DIMENSION(3), INTENT(in) :: src, targ !< real coordinates z,y,x
7818	INTEGER(iwp), INTENT(in) :: isrc !< index of source face for csf
7819	REAL(wp), INTENT(in) :: difvf !< differential view factor for csf
7820	REAL(wp), INTENT(in) :: atarg !< target surface area for csf
7821	LOGICAL, INTENT(in) :: create_csf !< whether to generate new CSFs during raytracing
7822	LOGICAL, INTENT(out) :: visible
7823	REAL(wp), INTENT(out) :: transparency !< along whole path
7824	INTEGER(iwp) :: i, k, d
7825	INTEGER(iwp) :: seldim !< dimension to be incremented
7826	INTEGER(iwp) :: ncsb !< no of written plant canopy sinkboxes
7827	INTEGER(iwp) :: maxboxes !< max no of gridboxes visited
7828	REAL(wp) :: distance !< euclidean along path
7829	REAL(wp) :: crlen !< length of gridbox crossing
7830	REAL(wp) :: lastdist !< beginning of current crossing
7831	REAL(wp) :: nextdist !< end of current crossing
7832	REAL(wp) :: realdist !< distance in meters per unit distance
7833	REAL(wp) :: crmid !< midpoint of crossing
7834	REAL(wp) :: cursink !< sink factor for current canopy box
7835	REAL(wp), DIMENSION(3) :: delta !< path vector
7836	REAL(wp), DIMENSION(3) :: uvect !< unit vector
7837	REAL(wp), DIMENSION(3) :: dimnextdist !< distance for each dimension increments
7838	INTEGER(iwp), DIMENSION(3) :: box !< gridbox being crossed
7839	INTEGER(iwp), DIMENSION(3) :: dimnext !< next dimension increments along path
7840	INTEGER(iwp), DIMENSION(3) :: dimdelta !< dimension direction = +- 1
7841	INTEGER(iwp) :: px, py !< number of processors in x and y dir before
7842	!< the processor in the question
7843	INTEGER(iwp) :: ip !< number of processor where gridbox reside
7844	INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array
7845
7846	REAL(wp) :: eps = 1E-10_wp !< epsilon for value comparison
7847	REAL(wp) :: lad_s_target !< recieved lad_s of particular grid box
7848
7849	!
7850	!-- Maximum number of gridboxes visited equals to maximum number of boundaries crossed in each dimension plus one. That's also
7851	!-- the maximum number of plant canopy boxes written. We grow the acsf array accordingly using exponential factor.
7852	maxboxes = SUM(ABS(NINT(targ, iwp) - NINT(src, iwp))) + 1
7853	IF ( plant_canopy .AND. ncsfl + maxboxes > ncsfla ) THEN
7854	!-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1)
7855	!-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) &
7856	!-- / log(grow_factor)), kind=wp))
7857	!-- or use this code to simply always keep some extra space after growing
7858	k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor)
7859
7860	CALL merge_and_grow_csf(k)
7861	ENDIF
7862
7863	transparency = 1._wp
7864	ncsb = 0
7865
7866	delta(:) = targ(:) - src(:)
7867	distance = SQRT(SUM(delta(:)**2))
7868	IF ( distance == 0._wp ) THEN
7869	visible = .TRUE.
7870	RETURN
7871	ENDIF
7872	uvect(:) = delta(:) / distance
7873	realdist = SQRT(SUM( (uvect(:)(/dz(1),dy,dx/))*2 ))
7874
7875	lastdist = 0._wp
7876
7877	!-- Since all face coordinates have values *.5 and we'd like to use
7878	!-- integers, all these have .5 added
7879	DO d = 1, 3
7880	IF ( uvect(d) == 0._wp ) THEN
7881	dimnext(d) = 999999999
7882	dimdelta(d) = 999999999
7883	dimnextdist(d) = 1.0E20_wp
7884	ELSE IF ( uvect(d) > 0._wp ) THEN
7885	dimnext(d) = CEILING(src(d) + .5_wp)
7886	dimdelta(d) = 1
7887	dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d)
7888	ELSE
7889	dimnext(d) = FLOOR(src(d) + .5_wp)
7890	dimdelta(d) = -1
7891	dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d)
7892	ENDIF
7893	ENDDO
7894
7895	DO
7896	!-- along what dimension will the next wall crossing be?
7897	seldim = minloc(dimnextdist, 1)
7898	nextdist = dimnextdist(seldim)
7899	IF ( nextdist > distance ) nextdist = distance
7900
7901	crlen = nextdist - lastdist
7902	IF ( crlen > .001_wp ) THEN
7903	crmid = (lastdist + nextdist) * .5_wp
7904	box = NINT(src(:) + uvect(:) * crmid, iwp)
7905
7906	!-- calculate index of the grid with global indices (box(2),box(3))
7907	!-- in the array nzterr and plantt and id of the coresponding processor
7908	px = box(3)/nnx
7909	py = box(2)/nny
7910	ip = px*pdims(2)+py
7911	ig = ipnnxnny + (box(3)-pxnnx)nny + box(2)-py*nny
7912	IF ( box(1) <= nzterr(ig) ) THEN
7913	visible = .FALSE.
7914	RETURN
7915	ENDIF
7916
7917	IF ( plant_canopy ) THEN
7918	IF ( box(1) <= plantt(ig) ) THEN
7919	ncsb = ncsb + 1
7920	boxes(:,ncsb) = box
7921	crlens(ncsb) = crlen
7922	#if defined( __parallel )
7923	lad_ip(ncsb) = ip
7924	lad_disp(ncsb) = (box(3)-pxnnx)(nnynz_plant) + (box(2)-pynny)*nz_plant + box(1)-nz_urban_b
7925	#endif
7926	ENDIF
7927	ENDIF
7928	ENDIF
7929
7930	IF ( ABS(distance - nextdist) < eps ) EXIT
7931	lastdist = nextdist
7932	dimnext(seldim) = dimnext(seldim) + dimdelta(seldim)
7933	dimnextdist(seldim) = (dimnext(seldim) - .5_wp - src(seldim)) / uvect(seldim)
7934	ENDDO
7935
7936	IF ( plant_canopy ) THEN
7937	#if defined( __parallel )
7938	IF ( raytrace_mpi_rma ) THEN
7939	!-- send requests for lad_s to appropriate processor
7940	CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'start' )
7941	DO i = 1, ncsb
7942	CALL MPI_Get(lad_s_ray(i), 1, MPI_REAL, lad_ip(i), lad_disp(i), &
7943	1, MPI_REAL, win_lad, ierr)
7944	IF ( ierr /= 0 ) THEN
7945	WRITE(9,*) 'Error MPI_Get1:', ierr, lad_s_ray(i), &
7946	lad_ip(i), lad_disp(i), win_lad
7947	FLUSH(9)
7948	ENDIF
7949	ENDDO
7950
7951	!-- wait for all pending local requests complete
7952	CALL MPI_Win_flush_local_all(win_lad, ierr)
7953	IF ( ierr /= 0 ) THEN
7954	WRITE(9,*) 'Error MPI_Win_flush_local_all1:', ierr, win_lad
7955	FLUSH(9)
7956	ENDIF
7957	CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'stop' )
7958
7959	ENDIF
7960	#endif
7961
7962	!-- calculate csf and transparency
7963	DO i = 1, ncsb
7964	#if defined( __parallel )
7965	IF ( raytrace_mpi_rma ) THEN
7966	lad_s_target = lad_s_ray(i)
7967	ELSE
7968	lad_s_target = sub_lad_g(lad_ip(i)nnxnny*nz_plant + lad_disp(i))
7969	ENDIF
7970	#else
7971	lad_s_target = sub_lad(boxes(1,i),boxes(2,i),boxes(3,i))
7972	#endif
7973	cursink = 1._wp - exp(-ext_coef * lad_s_target * crlens(i)*realdist)
7974
7975	IF ( create_csf ) THEN
7976	!-- write svf values into the array
7977	ncsfl = ncsfl + 1
7978	acsf(ncsfl)%ip = lad_ip(i)
7979	acsf(ncsfl)%itx = boxes(3,i)
7980	acsf(ncsfl)%ity = boxes(2,i)
7981	acsf(ncsfl)%itz = boxes(1,i)
7982	acsf(ncsfl)%isurfs = isrc
7983	acsf(ncsfl)%rcvf = cursinktransparencydifvf*atarg
7984	ENDIF !< create_csf
7985
7986	transparency = transparency * (1._wp - cursink)
7987
7988	ENDDO
7989	ENDIF
7990
7991	visible = .TRUE.
7992
7993	END SUBROUTINE raytrace
7994
7995
7996	!------------------------------------------------------------------------------!
7997	! Description:
7998	! ------------
7999	!> A new, more efficient version of ray tracing algorithm that processes a whole
8000	!> arc instead of a single ray.
8001	!>
8002	!> In all comments, horizon means tangent of horizon angle, i.e.
8003	!> vertical_delta / horizontal_distance
8004	!------------------------------------------------------------------------------!
8005	SUBROUTINE raytrace_2d(origin, yxdir, nrays, zdirs, iorig, aorig, vffrac, &
8006	calc_svf, create_csf, skip_1st_pcb, &
8007	lowest_free_ray, transparency, itarget)
8008	IMPLICIT NONE
8009
8010	REAL(wp), DIMENSION(3), INTENT(IN) :: origin !< z,y,x coordinates of ray origin
8011	REAL(wp), DIMENSION(2), INTENT(IN) :: yxdir !< y,x unit vector of ray direction (in grid units)
8012	INTEGER(iwp) :: nrays !< number of rays (z directions) to raytrace
8013	REAL(wp), DIMENSION(nrays), INTENT(IN) :: zdirs !< list of z directions to raytrace (z/hdist, grid, zenith->nadir)
8014	INTEGER(iwp), INTENT(in) :: iorig !< index of origin face for csf
8015	REAL(wp), INTENT(in) :: aorig !< origin face area for csf
8016	REAL(wp), DIMENSION(nrays), INTENT(in) :: vffrac !< view factor fractions of each ray for csf
8017	LOGICAL, INTENT(in) :: calc_svf !< whether to calculate SFV (identify obstacle surfaces)
8018	LOGICAL, INTENT(in) :: create_csf !< whether to create canopy sink factors
8019	LOGICAL, INTENT(in) :: skip_1st_pcb !< whether to skip first plant canopy box during raytracing
8020	INTEGER(iwp), INTENT(out) :: lowest_free_ray !< index into zdirs
8021	REAL(wp), DIMENSION(nrays), INTENT(OUT) :: transparency !< transparencies of zdirs paths
8022	INTEGER(iwp), DIMENSION(nrays), INTENT(OUT) :: itarget !< global indices of target faces for zdirs
8023
8024	INTEGER(iwp), DIMENSION(nrays) :: target_procs
8025	REAL(wp) :: horizon !< highest horizon found after raytracing (z/hdist)
8026	INTEGER(iwp) :: i, k, l, d
8027	INTEGER(iwp) :: seldim !< dimension to be incremented
8028	REAL(wp), DIMENSION(2) :: yxorigin !< horizontal copy of origin (y,x)
8029	REAL(wp) :: distance !< euclidean along path
8030	REAL(wp) :: lastdist !< beginning of current crossing
8031	REAL(wp) :: nextdist !< end of current crossing
8032	REAL(wp) :: crmid !< midpoint of crossing
8033	REAL(wp) :: horz_entry !< horizon at entry to column
8034	REAL(wp) :: horz_exit !< horizon at exit from column
8035	REAL(wp) :: bdydim !< boundary for current dimension
8036	REAL(wp), DIMENSION(2) :: crossdist !< distances to boundary for dimensions
8037	REAL(wp), DIMENSION(2) :: dimnextdist !< distance for each dimension increments
8038	INTEGER(iwp), DIMENSION(2) :: column !< grid column being crossed
8039	INTEGER(iwp), DIMENSION(2) :: dimnext !< next dimension increments along path
8040	INTEGER(iwp), DIMENSION(2) :: dimdelta !< dimension direction = +- 1
8041	INTEGER(iwp) :: px, py !< number of processors in x and y dir before
8042	!< the processor in the question
8043	INTEGER(iwp) :: ip !< number of processor where gridbox reside
8044	INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array
8045	INTEGER(iwp) :: wcount !< RMA window item count
8046	INTEGER(iwp) :: maxboxes !< max no of CSF created
8047	INTEGER(iwp) :: nly !< maximum plant canopy height
8048	INTEGER(iwp) :: ntrack
8049
8050	INTEGER(iwp) :: zb0
8051	INTEGER(iwp) :: zb1
8052	INTEGER(iwp) :: nz
8053	INTEGER(iwp) :: iz
8054	INTEGER(iwp) :: zsgn
8055	INTEGER(iwp) :: lowest_lad !< lowest column cell for which we need LAD
8056	INTEGER(iwp) :: lastdir !< wall direction before hitting this column
8057	INTEGER(iwp), DIMENSION(2) :: lastcolumn
8058
8059	#if defined( __parallel )
8060	INTEGER(MPI_ADDRESS_KIND) :: wdisp !< RMA window displacement
8061	#endif
8062
8063	REAL(wp) :: eps = 1E-10_wp !< epsilon for value comparison
8064	REAL(wp) :: zbottom, ztop !< urban surface boundary in real numbers
8065	REAL(wp) :: zorig !< z coordinate of ray column entry
8066	REAL(wp) :: zexit !< z coordinate of ray column exit
8067	REAL(wp) :: qdist !< ratio of real distance to z coord difference
8068	REAL(wp) :: dxxyy !< square of real horizontal distance
8069	REAL(wp) :: curtrans !< transparency of current PC box crossing
8070
8071
8072
8073	yxorigin(:) = origin(2:3)
8074	transparency(:) = 1._wp !-- Pre-set the all rays to transparent before reducing
8075	horizon = -HUGE(1._wp)
8076	lowest_free_ray = nrays
8077	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8078	ALLOCATE(target_surfl(nrays))
8079	target_surfl(:) = -1
8080	lastdir = -999
8081	lastcolumn(:) = -999
8082	ENDIF
8083
8084	!-- Determine distance to boundary (in 2D xy)
8085	IF ( yxdir(1) > 0._wp ) THEN
8086	bdydim = ny + .5_wp !< north global boundary
8087	crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1)
8088	ELSEIF ( yxdir(1) == 0._wp ) THEN
8089	crossdist(1) = HUGE(1._wp)
8090	ELSE
8091	bdydim = -.5_wp !< south global boundary
8092	crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1)
8093	ENDIF
8094
8095	IF ( yxdir(2) > 0._wp ) THEN
8096	bdydim = nx + .5_wp !< east global boundary
8097	crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2)
8098	ELSEIF ( yxdir(2) == 0._wp ) THEN
8099	crossdist(2) = HUGE(1._wp)
8100	ELSE
8101	bdydim = -.5_wp !< west global boundary
8102	crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2)
8103	ENDIF
8104	distance = minval(crossdist, 1)
8105
8106	IF ( plant_canopy ) THEN
8107	rt2_track_dist(0) = 0._wp
8108	rt2_track_lad(:,:) = 0._wp
8109	nly = plantt_max - nz_urban_b + 1
8110	ENDIF
8111
8112	lastdist = 0._wp
8113
8114	!-- Since all face coordinates have values *.5 and we'd like to use
8115	!-- integers, all these have .5 added
8116	DO d = 1, 2
8117	IF ( yxdir(d) == 0._wp ) THEN
8118	dimnext(d) = HUGE(1_iwp)
8119	dimdelta(d) = HUGE(1_iwp)
8120	dimnextdist(d) = HUGE(1._wp)
8121	ELSE IF ( yxdir(d) > 0._wp ) THEN
8122	dimnext(d) = FLOOR(yxorigin(d) + .5_wp) + 1
8123	dimdelta(d) = 1
8124	dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d)
8125	ELSE
8126	dimnext(d) = CEILING(yxorigin(d) + .5_wp) - 1
8127	dimdelta(d) = -1
8128	dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d)
8129	ENDIF
8130	ENDDO
8131
8132	ntrack = 0
8133	DO
8134	!-- along what dimension will the next wall crossing be?
8135	seldim = minloc(dimnextdist, 1)
8136	nextdist = dimnextdist(seldim)
8137	IF ( nextdist > distance ) nextdist = distance
8138
8139	IF ( nextdist > lastdist ) THEN
8140	ntrack = ntrack + 1
8141	crmid = (lastdist + nextdist) * .5_wp
8142	column = NINT(yxorigin(:) + yxdir(:) * crmid, iwp)
8143
8144	!-- calculate index of the grid with global indices (column(1),column(2))
8145	!-- in the array nzterr and plantt and id of the coresponding processor
8146	px = column(2)/nnx
8147	py = column(1)/nny
8148	ip = px*pdims(2)+py
8149	ig = ipnnxnny + (column(2)-pxnnx)nny + column(1)-py*nny
8150
8151	IF ( lastdist == 0._wp ) THEN
8152	horz_entry = -HUGE(1._wp)
8153	ELSE
8154	horz_entry = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / lastdist
8155	ENDIF
8156	horz_exit = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / nextdist
8157
8158	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8159	!
8160	!-- Identify vertical obstacles hit by rays in current column
8161	DO WHILE ( lowest_free_ray > 0 )
8162	IF ( zdirs(lowest_free_ray) > horz_entry ) EXIT
8163	!
8164	!-- This may only happen after 1st column, so lastdir and lastcolumn are valid
8165	CALL request_itarget(lastdir, &
8166	CEILING(-0.5_wp + origin(1) + zdirs(lowest_free_ray)*lastdist), &
8167	lastcolumn(1), lastcolumn(2), &
8168	target_surfl(lowest_free_ray), target_procs(lowest_free_ray))
8169	lowest_free_ray = lowest_free_ray - 1
8170	ENDDO
8171	!
8172	!-- Identify horizontal obstacles hit by rays in current column
8173	DO WHILE ( lowest_free_ray > 0 )
8174	IF ( zdirs(lowest_free_ray) > horz_exit ) EXIT
8175	CALL request_itarget(iup_u, nzterr(ig)+1, column(1), column(2), &
8176	target_surfl(lowest_free_ray), &
8177	target_procs(lowest_free_ray))
8178	lowest_free_ray = lowest_free_ray - 1
8179	ENDDO
8180	ENDIF
8181
8182	horizon = MAX(horizon, horz_entry, horz_exit)
8183
8184	IF ( plant_canopy ) THEN
8185	rt2_track(:, ntrack) = column(:)
8186	rt2_track_dist(ntrack) = nextdist
8187	ENDIF
8188	ENDIF
8189
8190	IF ( nextdist + eps >= distance ) EXIT
8191
8192	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8193	!
8194	!-- Save wall direction of coming building column (= this air column)
8195	IF ( seldim == 1 ) THEN
8196	IF ( dimdelta(seldim) == 1 ) THEN
8197	lastdir = isouth_u
8198	ELSE
8199	lastdir = inorth_u
8200	ENDIF
8201	ELSE
8202	IF ( dimdelta(seldim) == 1 ) THEN
8203	lastdir = iwest_u
8204	ELSE
8205	lastdir = ieast_u
8206	ENDIF
8207	ENDIF
8208	lastcolumn = column
8209	ENDIF
8210	lastdist = nextdist
8211	dimnext(seldim) = dimnext(seldim) + dimdelta(seldim)
8212	dimnextdist(seldim) = (dimnext(seldim) - .5_wp - yxorigin(seldim)) / yxdir(seldim)
8213	ENDDO
8214
8215	IF ( plant_canopy ) THEN
8216	!-- Request LAD WHERE applicable
8217	!--
8218	#if defined( __parallel )
8219	IF ( raytrace_mpi_rma ) THEN
8220	!-- send requests for lad_s to appropriate processor
8221	!CALL cpu_log( log_point_s(77), 'usm_init_rma', 'start' )
8222	DO i = 1, ntrack
8223	px = rt2_track(2,i)/nnx
8224	py = rt2_track(1,i)/nny
8225	ip = px*pdims(2)+py
8226	ig = ipnnxnny + (rt2_track(2,i)-pxnnx)nny + rt2_track(1,i)-py*nny
8227
8228	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8229	!
8230	!-- For fixed view resolution, we need plant canopy even for rays
8231	!-- to opposing surfaces
8232	lowest_lad = nzterr(ig) + 1
8233	ELSE
8234	!
8235	!-- We only need LAD for rays directed above horizon (to sky)
8236	lowest_lad = CEILING( -0.5_wp + origin(1) + &
8237	MIN( horizon * rt2_track_dist(i-1), & ! entry
8238	horizon * rt2_track_dist(i) ) ) ! exit
8239	ENDIF
8240	!
8241	!-- Skip asking for LAD where all plant canopy is under requested level
8242	IF ( plantt(ig) < lowest_lad ) CYCLE
8243
8244	wdisp = (rt2_track(2,i)-pxnnx)(nnynz_plant) + (rt2_track(1,i)-pynny)*nz_plant + lowest_lad-nz_urban_b
8245	wcount = plantt(ig)-lowest_lad+1
8246	! TODO send request ASAP - even during raytracing
8247	CALL MPI_Get(rt2_track_lad(lowest_lad:plantt(ig), i), wcount, MPI_REAL, ip, &
8248	wdisp, wcount, MPI_REAL, win_lad, ierr)
8249	IF ( ierr /= 0 ) THEN
8250	WRITE(9,*) 'Error MPI_Get2:', ierr, rt2_track_lad(lowest_lad:plantt(ig), i), &
8251	wcount, ip, wdisp, win_lad
8252	FLUSH(9)
8253	ENDIF
8254	ENDDO
8255
8256	!-- wait for all pending local requests complete
8257	! TODO WAIT selectively for each column later when needed
8258	CALL MPI_Win_flush_local_all(win_lad, ierr)
8259	IF ( ierr /= 0 ) THEN
8260	WRITE(9,*) 'Error MPI_Win_flush_local_all2:', ierr, win_lad
8261	FLUSH(9)
8262	ENDIF
8263	!CALL cpu_log( log_point_s(77), 'usm_init_rma', 'stop' )
8264
8265	ELSE ! raytrace_mpi_rma = .F.
8266	DO i = 1, ntrack
8267	px = rt2_track(2,i)/nnx
8268	py = rt2_track(1,i)/nny
8269	ip = px*pdims(2)+py
8270	ig = ipnnxnnynz_plant + (rt2_track(2,i)-pxnnx)(nnynz_plant) + (rt2_track(1,i)-pynny)nz_plant
8271	rt2_track_lad(nz_urban_b:plantt_max, i) = sub_lad_g(ig:ig+nly-1)
8272	ENDDO
8273	ENDIF
8274	#else
8275	DO i = 1, ntrack
8276	rt2_track_lad(nz_urban_b:plantt_max, i) = sub_lad(rt2_track(1,i), rt2_track(2,i), nz_urban_b:plantt_max)
8277	ENDDO
8278	#endif
8279	ENDIF ! plant_canopy
8280
8281	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8282	#if defined( __parallel )
8283	!-- wait for all gridsurf requests to complete
8284	CALL MPI_Win_flush_local_all(win_gridsurf, ierr)
8285	IF ( ierr /= 0 ) THEN
8286	WRITE(9,*) 'Error MPI_Win_flush_local_all3:', ierr, win_gridsurf
8287	FLUSH(9)
8288	ENDIF
8289	#endif
8290	!
8291	!-- recalculate local surf indices into global ones
8292	DO i = 1, nrays
8293	IF ( target_surfl(i) == -1 ) THEN
8294	itarget(i) = -1
8295	ELSE
8296	itarget(i) = target_surfl(i) + surfstart(target_procs(i))
8297	ENDIF
8298	ENDDO
8299
8300	DEALLOCATE( target_surfl )
8301
8302	ELSE
8303	itarget(:) = -1
8304	ENDIF ! rad_angular_discretization
8305
8306	IF ( plant_canopy ) THEN
8307	!-- Skip the PCB around origin if requested (for MRT, the PCB might not be there)
8308	!--
8309	IF ( skip_1st_pcb .AND. NINT(origin(1)) <= plantt_max ) THEN
8310	rt2_track_lad(NINT(origin(1), iwp), 1) = 0._wp
8311	ENDIF
8312
8313	!-- Assert that we have space allocated for CSFs
8314	!--
8315	maxboxes = (ntrack + MAX(CEILING(origin(1)-.5_wp) - nz_urban_b, &
8316	nz_urban_t - CEILING(origin(1)-.5_wp))) * nrays
8317	IF ( ncsfl + maxboxes > ncsfla ) THEN
8318	!-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1)
8319	!-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) &
8320	!-- / log(grow_factor)), kind=wp))
8321	!-- or use this code to simply always keep some extra space after growing
8322	k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor)
8323	CALL merge_and_grow_csf(k)
8324	ENDIF
8325
8326	!-- Calculate transparencies and store new CSFs
8327	!--
8328	zbottom = REAL(nz_urban_b, wp) - .5_wp
8329	ztop = REAL(plantt_max, wp) + .5_wp
8330
8331	!-- Reverse direction of radiation (face->sky), only when calc_svf
8332	!--
8333	IF ( calc_svf ) THEN
8334	DO i = 1, ntrack ! for each column
8335	dxxyy = ((dyyxdir(1))2 + (dxyxdir(2))*2) (rt2_track_dist(i)-rt2_track_dist(i-1))**2
8336	px = rt2_track(2,i)/nnx
8337	py = rt2_track(1,i)/nny
8338	ip = px*pdims(2)+py
8339
8340	DO k = 1, nrays ! for each ray
8341	!
8342	!-- NOTE 6778:
8343	!-- With traditional svf discretization, CSFs under the horizon
8344	!-- (i.e. for surface to surface radiation) are created in
8345	!-- raytrace(). With rad_angular_discretization, we must create
8346	!-- CSFs under horizon only for one direction, otherwise we would
8347	!-- have duplicate amount of energy. Although we could choose
8348	!-- either of the two directions (they differ only by
8349	!-- discretization error with no bias), we choose the the backward
8350	!-- direction, because it tends to cumulate high canopy sink
8351	!-- factors closer to raytrace origin, i.e. it should potentially
8352	!-- cause less moiree.
8353	IF ( .NOT. rad_angular_discretization ) THEN
8354	IF ( zdirs(k) <= horizon ) CYCLE
8355	ENDIF
8356
8357	zorig = origin(1) + zdirs(k) * rt2_track_dist(i-1)
8358	IF ( zorig <= zbottom .OR. zorig >= ztop ) CYCLE
8359
8360	zsgn = INT(SIGN(1._wp, zdirs(k)), iwp)
8361	rt2_dist(1) = 0._wp
8362	IF ( zdirs(k) == 0._wp ) THEN ! ray is exactly horizontal
8363	nz = 2
8364	rt2_dist(nz) = SQRT(dxxyy)
8365	iz = CEILING(-.5_wp + zorig, iwp)
8366	ELSE
8367	zexit = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop)
8368
8369	zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! because it must be greater than orig
8370	zb1 = CEILING(zexit * zsgn - .5_wp) - 1 ! because it must be smaller than exit
8371	nz = MAX(zb1 - zb0 + 3, 2)
8372	rt2_dist(nz) = SQRT(((zexit-zorig)dz(1))*2 + dxxyy)
8373	qdist = rt2_dist(nz) / (zexit-zorig)
8374	rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/)
8375	iz = zb0 * zsgn
8376	ENDIF
8377
8378	DO l = 2, nz
8379	IF ( rt2_track_lad(iz, i) > 0._wp ) THEN
8380	curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1)))
8381
8382	IF ( create_csf ) THEN
8383	ncsfl = ncsfl + 1
8384	acsf(ncsfl)%ip = ip
8385	acsf(ncsfl)%itx = rt2_track(2,i)
8386	acsf(ncsfl)%ity = rt2_track(1,i)
8387	acsf(ncsfl)%itz = iz
8388	acsf(ncsfl)%isurfs = iorig
8389	acsf(ncsfl)%rcvf = (1._wp - curtrans)transparency(k)vffrac(k)
8390	ENDIF
8391
8392	transparency(k) = transparency(k) * curtrans
8393	ENDIF
8394	iz = iz + zsgn
8395	ENDDO ! l = 1, nz - 1
8396	ENDDO ! k = 1, nrays
8397	ENDDO ! i = 1, ntrack
8398
8399	transparency(1:lowest_free_ray) = 1._wp !-- Reset rays above horizon to transparent (see NOTE 6778)
8400	ENDIF
8401
8402	!-- Forward direction of radiation (sky->face), always
8403	!--
8404	DO i = ntrack, 1, -1 ! for each column backwards
8405	dxxyy = ((dyyxdir(1))2 + (dxyxdir(2))*2) (rt2_track_dist(i)-rt2_track_dist(i-1))**2
8406	px = rt2_track(2,i)/nnx
8407	py = rt2_track(1,i)/nny
8408	ip = px*pdims(2)+py
8409
8410	DO k = 1, nrays ! for each ray
8411	!
8412	!-- See NOTE 6778 above
8413	IF ( zdirs(k) <= horizon ) CYCLE
8414
8415	zexit = origin(1) + zdirs(k) * rt2_track_dist(i-1)
8416	IF ( zexit <= zbottom .OR. zexit >= ztop ) CYCLE
8417
8418	zsgn = -INT(SIGN(1._wp, zdirs(k)), iwp)
8419	rt2_dist(1) = 0._wp
8420	IF ( zdirs(k) == 0._wp ) THEN ! ray is exactly horizontal
8421	nz = 2
8422	rt2_dist(nz) = SQRT(dxxyy)
8423	iz = NINT(zexit, iwp)
8424	ELSE
8425	zorig = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop)
8426
8427	zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! because it must be greater than orig
8428	zb1 = CEILING(zexit * zsgn - .5_wp) - 1 ! because it must be smaller than exit
8429	nz = MAX(zb1 - zb0 + 3, 2)
8430	rt2_dist(nz) = SQRT(((zexit-zorig)dz(1))*2 + dxxyy)
8431	qdist = rt2_dist(nz) / (zexit-zorig)
8432	rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/)
8433	iz = zb0 * zsgn
8434	ENDIF
8435
8436	DO l = 2, nz
8437	IF ( rt2_track_lad(iz, i) > 0._wp ) THEN
8438	curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1)))
8439
8440	IF ( create_csf ) THEN
8441	ncsfl = ncsfl + 1
8442	acsf(ncsfl)%ip = ip
8443	acsf(ncsfl)%itx = rt2_track(2,i)
8444	acsf(ncsfl)%ity = rt2_track(1,i)
8445	acsf(ncsfl)%itz = iz
8446	IF ( itarget(k) /= -1 ) STOP 1 !FIXME remove after test
8447	acsf(ncsfl)%isurfs = -1
8448	acsf(ncsfl)%rcvf = (1._wp - curtrans)transparency(k)aorig*vffrac(k)
8449	ENDIF ! create_csf
8450
8451	transparency(k) = transparency(k) * curtrans
8452	ENDIF
8453	iz = iz + zsgn
8454	ENDDO ! l = 1, nz - 1
8455	ENDDO ! k = 1, nrays
8456	ENDDO ! i = 1, ntrack
8457	ENDIF ! plant_canopy
8458
8459	IF ( .NOT. (rad_angular_discretization .AND. calc_svf) ) THEN
8460	!
8461	!-- Just update lowest_free_ray according to horizon
8462	DO WHILE ( lowest_free_ray > 0 )
8463	IF ( zdirs(lowest_free_ray) > horizon ) EXIT
8464	lowest_free_ray = lowest_free_ray - 1
8465	ENDDO
8466	ENDIF
8467
8468	CONTAINS
8469
8470	SUBROUTINE request_itarget( d, z, y, x, isurfl, iproc )
8471
8472	INTEGER(iwp), INTENT(in) :: d, z, y, x
8473	INTEGER(iwp), TARGET, INTENT(out) :: isurfl
8474	INTEGER(iwp), INTENT(out) :: iproc
8475	#if defined( __parallel )
8476	#else
8477	INTEGER(iwp) :: target_displ !< index of the grid in the local gridsurf array
8478	#endif
8479	INTEGER(iwp) :: px, py !< number of processors in x and y direction
8480	!< before the processor in the question
8481	#if defined( __parallel )
8482	INTEGER(KIND=MPI_ADDRESS_KIND) :: target_displ !< index of the grid in the local gridsurf array
8483
8484	!
8485	!-- Calculate target processor and index in the remote local target gridsurf array
8486	px = x / nnx
8487	py = y / nny
8488	iproc = px * pdims(2) + py
8489	target_displ = ((x-pxnnx) nny + y - pynny ) nz_urban * nsurf_type_u +&
8490	( z-nz_urban_b ) * nsurf_type_u + d
8491	!
8492	!-- Send MPI_Get request to obtain index target_surfl(i)
8493	CALL MPI_GET( isurfl, 1, MPI_INTEGER, iproc, target_displ, &
8494	1, MPI_INTEGER, win_gridsurf, ierr)
8495	IF ( ierr /= 0 ) THEN
8496	WRITE( 9,* ) 'Error MPI_Get3:', ierr, isurfl, iproc, target_displ, &
8497	win_gridsurf
8498	FLUSH( 9 )
8499	ENDIF
8500	#else
8501	!-- set index target_surfl(i)
8502	isurfl = gridsurf(d,z,y,x)
8503	#endif
8504
8505	END SUBROUTINE request_itarget
8506
8507	END SUBROUTINE raytrace_2d
8508
8509
8510	!------------------------------------------------------------------------------!
8511	!
8512	! Description:
8513	! ------------
8514	!> Calculates apparent solar positions for all timesteps and stores discretized
8515	!> positions.
8516	!------------------------------------------------------------------------------!
8517	SUBROUTINE radiation_presimulate_solar_pos
8518
8519	IMPLICIT NONE
8520
8521	INTEGER(iwp) :: it, i, j
8522	INTEGER(iwp) :: day_of_month_prev,month_of_year_prev
8523	REAL(wp) :: tsrp_prev
8524	REAL(wp) :: simulated_time_prev
8525	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir_tmp !< dsidir_tmp[:,i] = unit vector of i-th
8526	!< appreant solar direction
8527
8528	ALLOCATE ( dsidir_rev(0:raytrace_discrete_elevs/2-1, &
8529	0:raytrace_discrete_azims-1) )
8530	dsidir_rev(:,:) = -1
8531	ALLOCATE ( dsidir_tmp(3, &
8532	raytrace_discrete_elevs/2*raytrace_discrete_azims) )
8533	ndsidir = 0
8534
8535	!
8536	!-- We will artificialy update time_since_reference_point and return to
8537	!-- true value later
8538	tsrp_prev = time_since_reference_point
8539	simulated_time_prev = simulated_time
8540	day_of_month_prev = day_of_month
8541	month_of_year_prev = month_of_year
8542	sun_direction = .TRUE.
8543
8544	!
8545	!-- initialize the simulated_time
8546	simulated_time = 0._wp
8547	!
8548	!-- Process spinup time if configured
8549	IF ( spinup_time > 0._wp ) THEN
8550	DO it = 0, CEILING(spinup_time / dt_spinup)
8551	time_since_reference_point = -spinup_time + REAL(it, wp) * dt_spinup
8552	simulated_time = simulated_time + dt_spinup
8553	CALL simulate_pos
8554	ENDDO
8555	ENDIF
8556	!
8557	!-- Process simulation time
8558	DO it = 0, CEILING(( end_time - spinup_time ) / dt_radiation)
8559	time_since_reference_point = REAL(it, wp) * dt_radiation
8560	simulated_time = simulated_time + dt_radiation
8561	CALL simulate_pos
8562	ENDDO
8563	!
8564	!-- Return date and time to its original values
8565	time_since_reference_point = tsrp_prev
8566	simulated_time = simulated_time_prev
8567	day_of_month = day_of_month_prev
8568	month_of_year = month_of_year_prev
8569	CALL init_date_and_time
8570
8571	!-- Allocate global vars which depend on ndsidir
8572	ALLOCATE ( dsidir ( 3, ndsidir ) )
8573	dsidir(:,:) = dsidir_tmp(:, 1:ndsidir)
8574	DEALLOCATE ( dsidir_tmp )
8575
8576	ALLOCATE ( dsitrans(nsurfl, ndsidir) )
8577	ALLOCATE ( dsitransc(npcbl, ndsidir) )
8578	IF ( nmrtbl > 0 ) ALLOCATE ( mrtdsit(nmrtbl, ndsidir) )
8579
8580	WRITE ( message_string, * ) 'Precalculated', ndsidir, ' solar positions', &
8581	' from', it, ' timesteps.'
8582	CALL message( 'radiation_presimulate_solar_pos', 'UI0013', 0, 0, 0, 6, 0 )
8583
8584	CONTAINS
8585
8586	!------------------------------------------------------------------------!
8587	! Description:
8588	! ------------
8589	!> Simuates a single position
8590	!------------------------------------------------------------------------!
8591	SUBROUTINE simulate_pos
8592	IMPLICIT NONE
8593	!
8594	!-- Update apparent solar position based on modified t_s_r_p
8595	CALL calc_zenith
8596	IF ( cos_zenith > 0 ) THEN
8597	!--
8598	!-- Identify solar direction vector (discretized number) 1)
8599	i = MODULO(NINT(ATAN2(sun_dir_lon, sun_dir_lat) &
8600	/ (2._wppi) raytrace_discrete_azims-.5_wp, iwp), &
8601	raytrace_discrete_azims)
8602	j = FLOOR(ACOS(cos_zenith) / pi * raytrace_discrete_elevs)
8603	IF ( dsidir_rev(j, i) == -1 ) THEN
8604	ndsidir = ndsidir + 1
8605	dsidir_tmp(:, ndsidir) = &
8606	(/ COS((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs), &
8607	SIN((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs) &
8608	* COS((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims), &
8609	SIN((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs) &
8610	* SIN((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims) /)
8611	dsidir_rev(j, i) = ndsidir
8612	ENDIF
8613	ENDIF
8614	END SUBROUTINE simulate_pos
8615
8616	END SUBROUTINE radiation_presimulate_solar_pos
8617
8618
8619
8620	!------------------------------------------------------------------------------!
8621	! Description:
8622	! ------------
8623	!> Determines whether two faces are oriented towards each other. Since the
8624	!> surfaces follow the gird box surfaces, it checks first whether the two surfaces
8625	!> are directed in the same direction, then it checks if the two surfaces are
8626	!> located in confronted direction but facing away from each other, e.g. <--\| \|-->
8627	!------------------------------------------------------------------------------!
8628	PURE LOGICAL FUNCTION surface_facing(x, y, z, d, x2, y2, z2, d2)
8629	IMPLICIT NONE
8630	INTEGER(iwp), INTENT(in) :: x, y, z, d, x2, y2, z2, d2
8631
8632	surface_facing = .FALSE.
8633
8634	!-- first check: are the two surfaces directed in the same direction
8635	IF ( (d==iup_u .OR. d==iup_l ) &
8636	.AND. (d2==iup_u .OR. d2==iup_l) ) RETURN
8637	IF ( (d==isouth_u .OR. d==isouth_l ) &
8638	.AND. (d2==isouth_u .OR. d2==isouth_l) ) RETURN
8639	IF ( (d==inorth_u .OR. d==inorth_l ) &
8640	.AND. (d2==inorth_u .OR. d2==inorth_l) ) RETURN
8641	IF ( (d==iwest_u .OR. d==iwest_l ) &
8642	.AND. (d2==iwest_u .OR. d2==iwest_l ) ) RETURN
8643	IF ( (d==ieast_u .OR. d==ieast_l ) &
8644	.AND. (d2==ieast_u .OR. d2==ieast_l ) ) RETURN
8645
8646	!-- second check: are surfaces facing away from each other
8647	SELECT CASE (d)
8648	CASE (iup_u, iup_l) !< upward facing surfaces
8649	IF ( z2 < z ) RETURN
8650	CASE (isouth_u, isouth_l) !< southward facing surfaces
8651	IF ( y2 > y ) RETURN
8652	CASE (inorth_u, inorth_l) !< northward facing surfaces
8653	IF ( y2 < y ) RETURN
8654	CASE (iwest_u, iwest_l) !< westward facing surfaces
8655	IF ( x2 > x ) RETURN
8656	CASE (ieast_u, ieast_l) !< eastward facing surfaces
8657	IF ( x2 < x ) RETURN
8658	END SELECT
8659
8660	SELECT CASE (d2)
8661	CASE (iup_u) !< ground, roof
8662	IF ( z < z2 ) RETURN
8663	CASE (isouth_u, isouth_l) !< south facing
8664	IF ( y > y2 ) RETURN
8665	CASE (inorth_u, inorth_l) !< north facing
8666	IF ( y < y2 ) RETURN
8667	CASE (iwest_u, iwest_l) !< west facing
8668	IF ( x > x2 ) RETURN
8669	CASE (ieast_u, ieast_l) !< east facing
8670	IF ( x < x2 ) RETURN
8671	CASE (-1)
8672	CONTINUE
8673	END SELECT
8674
8675	surface_facing = .TRUE.
8676
8677	END FUNCTION surface_facing
8678
8679
8680	!------------------------------------------------------------------------------!
8681	!
8682	! Description:
8683	! ------------
8684	!> Reads svf, svfsurf, csf, csfsurf and mrt factors data from saved file
8685	!> SVF means sky view factors and CSF means canopy sink factors
8686	!------------------------------------------------------------------------------!
8687	SUBROUTINE radiation_read_svf
8688
8689	IMPLICIT NONE
8690
8691	CHARACTER(rad_version_len) :: rad_version_field
8692
8693	INTEGER(iwp) :: i
8694	INTEGER(iwp) :: ndsidir_from_file = 0
8695	INTEGER(iwp) :: npcbl_from_file = 0
8696	INTEGER(iwp) :: nsurfl_from_file = 0
8697	INTEGER(iwp) :: nmrtbl_from_file = 0
8698
8699
8700	CALL location_message( 'reading view factors for radiation interaction', 'start' )
8701
8702	DO i = 0, io_blocks-1
8703	IF ( i == io_group ) THEN
8704
8705	!
8706	!-- numprocs_previous_run is only known in case of reading restart
8707	!-- data. If a new initial run which reads svf data is started the
8708	!-- following query will be skipped
8709	IF ( initializing_actions == 'read_restart_data' ) THEN
8710
8711	IF ( numprocs_previous_run /= numprocs ) THEN
8712	WRITE( message_string, * ) 'A different number of ', &
8713	'processors between the run ', &
8714	'that has written the svf data ',&
8715	'and the one that will read it ',&
8716	'is not allowed'
8717	CALL message( 'check_open', 'PA0491', 1, 2, 0, 6, 0 )
8718	ENDIF
8719
8720	ENDIF
8721
8722	!
8723	!-- Open binary file
8724	CALL check_open( 88 )
8725
8726	!
8727	!-- read and check version
8728	READ ( 88 ) rad_version_field
8729	IF ( TRIM(rad_version_field) /= TRIM(rad_version) ) THEN
8730	WRITE( message_string, * ) 'Version of binary SVF file "', &
8731	TRIM(rad_version_field), '" does not match ', &
8732	'the version of model "', TRIM(rad_version), '"'
8733	CALL message( 'radiation_read_svf', 'PA0482', 1, 2, 0, 6, 0 )
8734	ENDIF
8735
8736	!
8737	!-- read nsvfl, ncsfl, nsurfl, nmrtf
8738	READ ( 88 ) nsvfl, ncsfl, nsurfl_from_file, npcbl_from_file, &
8739	ndsidir_from_file, nmrtbl_from_file, nmrtf
8740
8741	IF ( nsvfl < 0 .OR. ncsfl < 0 ) THEN
8742	WRITE( message_string, * ) 'Wrong number of SVF or CSF'
8743	CALL message( 'radiation_read_svf', 'PA0483', 1, 2, 0, 6, 0 )
8744	ELSE
8745	WRITE(debug_string,*) 'Number of SVF, CSF, and nsurfl ', &
8746	'to read', nsvfl, ncsfl, &
8747	nsurfl_from_file
8748	IF ( debug_output ) CALL debug_message( debug_string, 'info' )
8749	ENDIF
8750
8751	IF ( nsurfl_from_file /= nsurfl ) THEN
8752	WRITE( message_string, * ) 'nsurfl from SVF file does not ', &
8753	'match calculated nsurfl from ', &
8754	'radiation_interaction_init'
8755	CALL message( 'radiation_read_svf', 'PA0490', 1, 2, 0, 6, 0 )
8756	ENDIF
8757
8758	IF ( npcbl_from_file /= npcbl ) THEN
8759	WRITE( message_string, * ) 'npcbl from SVF file does not ', &
8760	'match calculated npcbl from ', &
8761	'radiation_interaction_init'
8762	CALL message( 'radiation_read_svf', 'PA0493', 1, 2, 0, 6, 0 )
8763	ENDIF
8764
8765	IF ( ndsidir_from_file /= ndsidir ) THEN
8766	WRITE( message_string, * ) 'ndsidir from SVF file does not ', &
8767	'match calculated ndsidir from ', &
8768	'radiation_presimulate_solar_pos'
8769	CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 )
8770	ENDIF
8771	IF ( nmrtbl_from_file /= nmrtbl ) THEN
8772	WRITE( message_string, * ) 'nmrtbl from SVF file does not ', &
8773	'match calculated nmrtbl from ', &
8774	'radiation_interaction_init'
8775	CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 )
8776	ELSE
8777	WRITE(debug_string,*) 'Number of nmrtf to read ', nmrtf
8778	IF ( debug_output ) CALL debug_message( debug_string, 'info' )
8779	ENDIF
8780
8781	!
8782	!-- Arrays skyvf, skyvft, dsitrans and dsitransc are allready
8783	!-- allocated in radiation_interaction_init and
8784	!-- radiation_presimulate_solar_pos
8785	IF ( nsurfl > 0 ) THEN
8786	READ(88) skyvf
8787	READ(88) skyvft
8788	READ(88) dsitrans
8789	ENDIF
8790
8791	IF ( plant_canopy .AND. npcbl > 0 ) THEN
8792	READ ( 88 ) dsitransc
8793	ENDIF
8794
8795	!
8796	!-- The allocation of svf, svfsurf, csf, csfsurf, mrtf, mrtft, and
8797	!-- mrtfsurf happens in routine radiation_calc_svf which is not
8798	!-- called if the program enters radiation_read_svf. Therefore
8799	!-- these arrays has to allocate in the following
8800	IF ( nsvfl > 0 ) THEN
8801	ALLOCATE( svf(ndsvf,nsvfl) )
8802	ALLOCATE( svfsurf(idsvf,nsvfl) )
8803	READ(88) svf
8804	READ(88) svfsurf
8805	ENDIF
8806
8807	IF ( plant_canopy .AND. ncsfl > 0 ) THEN
8808	ALLOCATE( csf(ndcsf,ncsfl) )
8809	ALLOCATE( csfsurf(idcsf,ncsfl) )
8810	READ(88) csf
8811	READ(88) csfsurf
8812	ENDIF
8813
8814	IF ( nmrtbl > 0 ) THEN
8815	READ(88) mrtsky
8816	READ(88) mrtskyt
8817	READ(88) mrtdsit
8818	ENDIF
8819
8820	IF ( nmrtf > 0 ) THEN
8821	ALLOCATE ( mrtf(nmrtf) )
8822	ALLOCATE ( mrtft(nmrtf) )
8823	ALLOCATE ( mrtfsurf(2,nmrtf) )
8824	READ(88) mrtf
8825	READ(88) mrtft
8826	READ(88) mrtfsurf
8827	ENDIF
8828
8829	!
8830	!-- Close binary file
8831	CALL close_file( 88 )
8832
8833	ENDIF
8834	#if defined( __parallel )
8835	CALL MPI_BARRIER( comm2d, ierr )
8836	#endif
8837	ENDDO
8838
8839	CALL location_message( 'reading view factors for radiation interaction', 'finished' )
8840
8841
8842	END SUBROUTINE radiation_read_svf
8843
8844
8845	!------------------------------------------------------------------------------!
8846	!
8847	! Description:
8848	! ------------
8849	!> Subroutine stores svf, svfsurf, csf, csfsurf and mrt data to a file.
8850	!------------------------------------------------------------------------------!
8851	SUBROUTINE radiation_write_svf
8852
8853	IMPLICIT NONE
8854
8855	INTEGER(iwp) :: i
8856
8857
8858	CALL location_message( 'writing view factors for radiation interaction', 'start' )
8859
8860	DO i = 0, io_blocks-1
8861	IF ( i == io_group ) THEN
8862	!
8863	!-- Open binary file
8864	CALL check_open( 89 )
8865
8866	WRITE ( 89 ) rad_version
8867	WRITE ( 89 ) nsvfl, ncsfl, nsurfl, npcbl, ndsidir, nmrtbl, nmrtf
8868	IF ( nsurfl > 0 ) THEN
8869	WRITE ( 89 ) skyvf
8870	WRITE ( 89 ) skyvft
8871	WRITE ( 89 ) dsitrans
8872	ENDIF
8873	IF ( npcbl > 0 ) THEN
8874	WRITE ( 89 ) dsitransc
8875	ENDIF
8876	IF ( nsvfl > 0 ) THEN
8877	WRITE ( 89 ) svf
8878	WRITE ( 89 ) svfsurf
8879	ENDIF
8880	IF ( plant_canopy .AND. ncsfl > 0 ) THEN
8881	WRITE ( 89 ) csf
8882	WRITE ( 89 ) csfsurf
8883	ENDIF
8884	IF ( nmrtbl > 0 ) THEN
8885	WRITE ( 89 ) mrtsky
8886	WRITE ( 89 ) mrtskyt
8887	WRITE ( 89 ) mrtdsit
8888	ENDIF
8889	IF ( nmrtf > 0 ) THEN
8890	WRITE ( 89 ) mrtf
8891	WRITE ( 89 ) mrtft
8892	WRITE ( 89 ) mrtfsurf
8893	ENDIF
8894	!
8895	!-- Close binary file
8896	CALL close_file( 89 )
8897
8898	ENDIF
8899	#if defined( __parallel )
8900	CALL MPI_BARRIER( comm2d, ierr )
8901	#endif
8902	ENDDO
8903
8904	CALL location_message( 'writing view factors for radiation interaction', 'finished' )
8905
8906
8907	END SUBROUTINE radiation_write_svf
8908
8909
8910	!------------------------------------------------------------------------------!
8911	!
8912	! Description:
8913	! ------------
8914	!> Block of auxiliary subroutines:
8915	!> 1. quicksort and corresponding comparison
8916	!> 2. merge_and_grow_csf for implementation of "dynamical growing"
8917	!> array for csf
8918	!------------------------------------------------------------------------------!
8919	!-- quicksort.f --f90--
8920	!-- Author: t-nissie, adaptation J.Resler
8921	!-- License: GPLv3
8922	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
8923	RECURSIVE SUBROUTINE quicksort_itarget(itarget, vffrac, ztransp, first, last)
8924	IMPLICIT NONE
8925	INTEGER(iwp), DIMENSION(:), INTENT(INOUT) :: itarget
8926	REAL(wp), DIMENSION(:), INTENT(INOUT) :: vffrac, ztransp
8927	INTEGER(iwp), INTENT(IN) :: first, last
8928	INTEGER(iwp) :: x, t
8929	INTEGER(iwp) :: i, j
8930	REAL(wp) :: tr
8931
8932	IF ( first>=last ) RETURN
8933	x = itarget((first+last)/2)
8934	i = first
8935	j = last
8936	DO
8937	DO WHILE ( itarget(i) < x )
8938	i=i+1
8939	ENDDO
8940	DO WHILE ( x < itarget(j) )
8941	j=j-1
8942	ENDDO
8943	IF ( i >= j ) EXIT
8944	t = itarget(i); itarget(i) = itarget(j); itarget(j) = t
8945	tr = vffrac(i); vffrac(i) = vffrac(j); vffrac(j) = tr
8946	tr = ztransp(i); ztransp(i) = ztransp(j); ztransp(j) = tr
8947	i=i+1
8948	j=j-1
8949	ENDDO
8950	IF ( first < i-1 ) CALL quicksort_itarget(itarget, vffrac, ztransp, first, i-1)
8951	IF ( j+1 < last ) CALL quicksort_itarget(itarget, vffrac, ztransp, j+1, last)
8952	END SUBROUTINE quicksort_itarget
8953
8954	PURE FUNCTION svf_lt(svf1,svf2) result (res)
8955	TYPE (t_svf), INTENT(in) :: svf1,svf2
8956	LOGICAL :: res
8957	IF ( svf1%isurflt < svf2%isurflt .OR. &
8958	(svf1%isurflt == svf2%isurflt .AND. svf1%isurfs < svf2%isurfs) ) THEN
8959	res = .TRUE.
8960	ELSE
8961	res = .FALSE.
8962	ENDIF
8963	END FUNCTION svf_lt
8964
8965
8966	!-- quicksort.f --f90--
8967	!-- Author: t-nissie, adaptation J.Resler
8968	!-- License: GPLv3
8969	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
8970	RECURSIVE SUBROUTINE quicksort_svf(svfl, first, last)
8971	IMPLICIT NONE
8972	TYPE(t_svf), DIMENSION(:), INTENT(INOUT) :: svfl
8973	INTEGER(iwp), INTENT(IN) :: first, last
8974	TYPE(t_svf) :: x, t
8975	INTEGER(iwp) :: i, j
8976
8977	IF ( first>=last ) RETURN
8978	x = svfl( (first+last) / 2 )
8979	i = first
8980	j = last
8981	DO
8982	DO while ( svf_lt(svfl(i),x) )
8983	i=i+1
8984	ENDDO
8985	DO while ( svf_lt(x,svfl(j)) )
8986	j=j-1
8987	ENDDO
8988	IF ( i >= j ) EXIT
8989	t = svfl(i); svfl(i) = svfl(j); svfl(j) = t
8990	i=i+1
8991	j=j-1
8992	ENDDO
8993	IF ( first < i-1 ) CALL quicksort_svf(svfl, first, i-1)
8994	IF ( j+1 < last ) CALL quicksort_svf(svfl, j+1, last)
8995	END SUBROUTINE quicksort_svf
8996
8997	PURE FUNCTION csf_lt(csf1,csf2) result (res)
8998	TYPE (t_csf), INTENT(in) :: csf1,csf2
8999	LOGICAL :: res
9000	IF ( csf1%ip < csf2%ip .OR. &
9001	(csf1%ip == csf2%ip .AND. csf1%itx < csf2%itx) .OR. &
9002	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity < csf2%ity) .OR. &
9003	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. &
9004	csf1%itz < csf2%itz) .OR. &
9005	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. &
9006	csf1%itz == csf2%itz .AND. csf1%isurfs < csf2%isurfs) ) THEN
9007	res = .TRUE.
9008	ELSE
9009	res = .FALSE.
9010	ENDIF
9011	END FUNCTION csf_lt
9012
9013
9014	!-- quicksort.f --f90--
9015	!-- Author: t-nissie, adaptation J.Resler
9016	!-- License: GPLv3
9017	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9018	RECURSIVE SUBROUTINE quicksort_csf(csfl, first, last)
9019	IMPLICIT NONE
9020	TYPE(t_csf), DIMENSION(:), INTENT(INOUT) :: csfl
9021	INTEGER(iwp), INTENT(IN) :: first, last
9022	TYPE(t_csf) :: x, t
9023	INTEGER(iwp) :: i, j
9024
9025	IF ( first>=last ) RETURN
9026	x = csfl( (first+last)/2 )
9027	i = first
9028	j = last
9029	DO
9030	DO while ( csf_lt(csfl(i),x) )
9031	i=i+1
9032	ENDDO
9033	DO while ( csf_lt(x,csfl(j)) )
9034	j=j-1
9035	ENDDO
9036	IF ( i >= j ) EXIT
9037	t = csfl(i); csfl(i) = csfl(j); csfl(j) = t
9038	i=i+1
9039	j=j-1
9040	ENDDO
9041	IF ( first < i-1 ) CALL quicksort_csf(csfl, first, i-1)
9042	IF ( j+1 < last ) CALL quicksort_csf(csfl, j+1, last)
9043	END SUBROUTINE quicksort_csf
9044
9045
9046	!------------------------------------------------------------------------------!
9047	!
9048	! Description:
9049	! ------------
9050	!> Grows the CSF array exponentially after it is full. During that, the ray
9051	!> canopy sink factors with common source face and target plant canopy grid
9052	!> cell are merged together so that the size doesn't grow out of control.
9053	!------------------------------------------------------------------------------!
9054	SUBROUTINE merge_and_grow_csf(newsize)
9055	INTEGER(iwp), INTENT(in) :: newsize !< new array size after grow, must be >= ncsfl
9056	!< or -1 to shrink to minimum
9057	INTEGER(iwp) :: iread, iwrite
9058	TYPE(t_csf), DIMENSION(:), POINTER :: acsfnew
9059
9060
9061	IF ( newsize == -1 ) THEN
9062	!-- merge in-place
9063	acsfnew => acsf
9064	ELSE
9065	!-- allocate new array
9066	IF ( mcsf == 0 ) THEN
9067	ALLOCATE( acsf1(newsize) )
9068	acsfnew => acsf1
9069	ELSE
9070	ALLOCATE( acsf2(newsize) )
9071	acsfnew => acsf2
9072	ENDIF
9073	ENDIF
9074
9075	IF ( ncsfl >= 1 ) THEN
9076	!-- sort csf in place (quicksort)
9077	CALL quicksort_csf(acsf,1,ncsfl)
9078
9079	!-- while moving to a new array, aggregate canopy sink factor records with identical box & source
9080	acsfnew(1) = acsf(1)
9081	iwrite = 1
9082	DO iread = 2, ncsfl
9083	!-- here acsf(kcsf) already has values from acsf(icsf)
9084	IF ( acsfnew(iwrite)%itx == acsf(iread)%itx &
9085	.AND. acsfnew(iwrite)%ity == acsf(iread)%ity &
9086	.AND. acsfnew(iwrite)%itz == acsf(iread)%itz &
9087	.AND. acsfnew(iwrite)%isurfs == acsf(iread)%isurfs ) THEN
9088
9089	acsfnew(iwrite)%rcvf = acsfnew(iwrite)%rcvf + acsf(iread)%rcvf
9090	!-- advance reading index, keep writing index
9091	ELSE
9092	!-- not identical, just advance and copy
9093	iwrite = iwrite + 1
9094	acsfnew(iwrite) = acsf(iread)
9095	ENDIF
9096	ENDDO
9097	ncsfl = iwrite
9098	ENDIF
9099
9100	IF ( newsize == -1 ) THEN
9101	!-- allocate new array and copy shrinked data
9102	IF ( mcsf == 0 ) THEN
9103	ALLOCATE( acsf1(ncsfl) )
9104	acsf1(1:ncsfl) = acsf2(1:ncsfl)
9105	ELSE
9106	ALLOCATE( acsf2(ncsfl) )
9107	acsf2(1:ncsfl) = acsf1(1:ncsfl)
9108	ENDIF
9109	ENDIF
9110
9111	!-- deallocate old array
9112	IF ( mcsf == 0 ) THEN
9113	mcsf = 1
9114	acsf => acsf1
9115	DEALLOCATE( acsf2 )
9116	ELSE
9117	mcsf = 0
9118	acsf => acsf2
9119	DEALLOCATE( acsf1 )
9120	ENDIF
9121	ncsfla = newsize
9122
9123	IF ( debug_output ) THEN
9124	WRITE( debug_string, '(A,2I12)' ) 'Grow acsf2:', ncsfl, ncsfla
9125	CALL debug_message( debug_string, 'info' )
9126	ENDIF
9127
9128	END SUBROUTINE merge_and_grow_csf
9129
9130
9131	!-- quicksort.f --f90--
9132	!-- Author: t-nissie, adaptation J.Resler
9133	!-- License: GPLv3
9134	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9135	RECURSIVE SUBROUTINE quicksort_csf2(kpcsflt, pcsflt, first, last)
9136	IMPLICIT NONE
9137	INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT) :: kpcsflt
9138	REAL(wp), DIMENSION(:,:), INTENT(INOUT) :: pcsflt
9139	INTEGER(iwp), INTENT(IN) :: first, last
9140	REAL(wp), DIMENSION(ndcsf) :: t2
9141	INTEGER(iwp), DIMENSION(kdcsf) :: x, t1
9142	INTEGER(iwp) :: i, j
9143
9144	IF ( first>=last ) RETURN
9145	x = kpcsflt(:, (first+last)/2 )
9146	i = first
9147	j = last
9148	DO
9149	DO while ( csf_lt2(kpcsflt(:,i),x) )
9150	i=i+1
9151	ENDDO
9152	DO while ( csf_lt2(x,kpcsflt(:,j)) )
9153	j=j-1
9154	ENDDO
9155	IF ( i >= j ) EXIT
9156	t1 = kpcsflt(:,i); kpcsflt(:,i) = kpcsflt(:,j); kpcsflt(:,j) = t1
9157	t2 = pcsflt(:,i); pcsflt(:,i) = pcsflt(:,j); pcsflt(:,j) = t2
9158	i=i+1
9159	j=j-1
9160	ENDDO
9161	IF ( first < i-1 ) CALL quicksort_csf2(kpcsflt, pcsflt, first, i-1)
9162	IF ( j+1 < last ) CALL quicksort_csf2(kpcsflt, pcsflt, j+1, last)
9163	END SUBROUTINE quicksort_csf2
9164
9165
9166	PURE FUNCTION csf_lt2(item1, item2) result(res)
9167	INTEGER(iwp), DIMENSION(kdcsf), INTENT(in) :: item1, item2
9168	LOGICAL :: res
9169	res = ( (item1(3) < item2(3)) &
9170	.OR. (item1(3) == item2(3) .AND. item1(2) < item2(2)) &
9171	.OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) < item2(1)) &
9172	.OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) == item2(1) &
9173	.AND. item1(4) < item2(4)) )
9174	END FUNCTION csf_lt2
9175
9176	PURE FUNCTION searchsorted(athresh, val) result(ind)
9177	REAL(wp), DIMENSION(:), INTENT(IN) :: athresh
9178	REAL(wp), INTENT(IN) :: val
9179	INTEGER(iwp) :: ind
9180	INTEGER(iwp) :: i
9181
9182	DO i = LBOUND(athresh, 1), UBOUND(athresh, 1)
9183	IF ( val < athresh(i) ) THEN
9184	ind = i - 1
9185	RETURN
9186	ENDIF
9187	ENDDO
9188	ind = UBOUND(athresh, 1)
9189	END FUNCTION searchsorted
9190
9191
9192	!------------------------------------------------------------------------------!
9193	!
9194	! Description:
9195	! ------------
9196	!> Subroutine for averaging 3D data
9197	!------------------------------------------------------------------------------!
9198	SUBROUTINE radiation_3d_data_averaging( mode, variable )
9199
9200
9201	USE control_parameters
9202
9203	USE indices
9204
9205	USE kinds
9206
9207	IMPLICIT NONE
9208
9209	CHARACTER (LEN=*) :: mode !<
9210	CHARACTER (LEN=*) :: variable !<
9211
9212	LOGICAL :: match_lsm !< flag indicating natural-type surface
9213	LOGICAL :: match_usm !< flag indicating urban-type surface
9214
9215	INTEGER(iwp) :: i !<
9216	INTEGER(iwp) :: j !<
9217	INTEGER(iwp) :: k !<
9218	INTEGER(iwp) :: l, m !< index of current surface element
9219
9220	INTEGER(iwp) :: ids, idsint_u, idsint_l, isurf
9221	CHARACTER(LEN=varnamelength) :: var
9222
9223	!-- find the real name of the variable
9224	ids = -1
9225	l = -1
9226	var = TRIM(variable)
9227	DO i = 0, nd-1
9228	k = len(TRIM(var))
9229	j = len(TRIM(dirname(i)))
9230	IF ( k-j+1 >= 1_iwp ) THEN
9231	IF ( TRIM(var(k-j+1:k)) == TRIM(dirname(i)) ) THEN
9232	ids = i
9233	idsint_u = dirint_u(ids)
9234	idsint_l = dirint_l(ids)
9235	var = var(:k-j)
9236	EXIT
9237	ENDIF
9238	ENDIF
9239	ENDDO
9240	IF ( ids == -1 ) THEN
9241	var = TRIM(variable)
9242	ENDIF
9243
9244	IF ( mode == 'allocate' ) THEN
9245
9246	SELECT CASE ( TRIM( var ) )
9247	!-- block of large scale (e.g. RRTMG) radiation output variables
9248	CASE ( 'rad_net*' )
9249	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
9250	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
9251	ENDIF
9252	rad_net_av = 0.0_wp
9253
9254	CASE ( 'rad_lw_in*' )
9255	IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
9256	ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
9257	ENDIF
9258	rad_lw_in_xy_av = 0.0_wp
9259
9260	CASE ( 'rad_lw_out*' )
9261	IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
9262	ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
9263	ENDIF
9264	rad_lw_out_xy_av = 0.0_wp
9265
9266	CASE ( 'rad_sw_in*' )
9267	IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
9268	ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
9269	ENDIF
9270	rad_sw_in_xy_av = 0.0_wp
9271
9272	CASE ( 'rad_sw_out*' )
9273	IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
9274	ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
9275	ENDIF
9276	rad_sw_out_xy_av = 0.0_wp
9277
9278	CASE ( 'rad_lw_in' )
9279	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
9280	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9281	ENDIF
9282	rad_lw_in_av = 0.0_wp
9283
9284	CASE ( 'rad_lw_out' )
9285	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
9286	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9287	ENDIF
9288	rad_lw_out_av = 0.0_wp
9289
9290	CASE ( 'rad_lw_cs_hr' )
9291	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
9292	ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9293	ENDIF
9294	rad_lw_cs_hr_av = 0.0_wp
9295
9296	CASE ( 'rad_lw_hr' )
9297	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
9298	ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9299	ENDIF
9300	rad_lw_hr_av = 0.0_wp
9301
9302	CASE ( 'rad_sw_in' )
9303	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
9304	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9305	ENDIF
9306	rad_sw_in_av = 0.0_wp
9307
9308	CASE ( 'rad_sw_out' )
9309	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
9310	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9311	ENDIF
9312	rad_sw_out_av = 0.0_wp
9313
9314	CASE ( 'rad_sw_cs_hr' )
9315	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
9316	ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9317	ENDIF
9318	rad_sw_cs_hr_av = 0.0_wp
9319
9320	CASE ( 'rad_sw_hr' )
9321	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
9322	ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9323	ENDIF
9324	rad_sw_hr_av = 0.0_wp
9325
9326	!-- block of RTM output variables
9327	CASE ( 'rtm_rad_net' )
9328	!-- array of complete radiation balance
9329	IF ( .NOT. ALLOCATED(surfradnet_av) ) THEN
9330	ALLOCATE( surfradnet_av(nsurfl) )
9331	surfradnet_av = 0.0_wp
9332	ENDIF
9333
9334	CASE ( 'rtm_rad_insw' )
9335	!-- array of sw radiation falling to surface after i-th reflection
9336	IF ( .NOT. ALLOCATED(surfinsw_av) ) THEN
9337	ALLOCATE( surfinsw_av(nsurfl) )
9338	surfinsw_av = 0.0_wp
9339	ENDIF
9340
9341	CASE ( 'rtm_rad_inlw' )
9342	!-- array of lw radiation falling to surface after i-th reflection
9343	IF ( .NOT. ALLOCATED(surfinlw_av) ) THEN
9344	ALLOCATE( surfinlw_av(nsurfl) )
9345	surfinlw_av = 0.0_wp
9346	ENDIF
9347
9348	CASE ( 'rtm_rad_inswdir' )
9349	!-- array of direct sw radiation falling to surface from sun
9350	IF ( .NOT. ALLOCATED(surfinswdir_av) ) THEN
9351	ALLOCATE( surfinswdir_av(nsurfl) )
9352	surfinswdir_av = 0.0_wp
9353	ENDIF
9354
9355	CASE ( 'rtm_rad_inswdif' )
9356	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
9357	IF ( .NOT. ALLOCATED(surfinswdif_av) ) THEN
9358	ALLOCATE( surfinswdif_av(nsurfl) )
9359	surfinswdif_av = 0.0_wp
9360	ENDIF
9361
9362	CASE ( 'rtm_rad_inswref' )
9363	!-- array of sw radiation falling to surface from reflections
9364	IF ( .NOT. ALLOCATED(surfinswref_av) ) THEN
9365	ALLOCATE( surfinswref_av(nsurfl) )
9366	surfinswref_av = 0.0_wp
9367	ENDIF
9368
9369	CASE ( 'rtm_rad_inlwdif' )
9370	!-- array of sw radiation falling to surface after i-th reflection
9371	IF ( .NOT. ALLOCATED(surfinlwdif_av) ) THEN
9372	ALLOCATE( surfinlwdif_av(nsurfl) )
9373	surfinlwdif_av = 0.0_wp
9374	ENDIF
9375
9376	CASE ( 'rtm_rad_inlwref' )
9377	!-- array of lw radiation falling to surface from reflections
9378	IF ( .NOT. ALLOCATED(surfinlwref_av) ) THEN
9379	ALLOCATE( surfinlwref_av(nsurfl) )
9380	surfinlwref_av = 0.0_wp
9381	ENDIF
9382
9383	CASE ( 'rtm_rad_outsw' )
9384	!-- array of sw radiation emitted from surface after i-th reflection
9385	IF ( .NOT. ALLOCATED(surfoutsw_av) ) THEN
9386	ALLOCATE( surfoutsw_av(nsurfl) )
9387	surfoutsw_av = 0.0_wp
9388	ENDIF
9389
9390	CASE ( 'rtm_rad_outlw' )
9391	!-- array of lw radiation emitted from surface after i-th reflection
9392	IF ( .NOT. ALLOCATED(surfoutlw_av) ) THEN
9393	ALLOCATE( surfoutlw_av(nsurfl) )
9394	surfoutlw_av = 0.0_wp
9395	ENDIF
9396	CASE ( 'rtm_rad_ressw' )
9397	!-- array of residua of sw radiation absorbed in surface after last reflection
9398	IF ( .NOT. ALLOCATED(surfins_av) ) THEN
9399	ALLOCATE( surfins_av(nsurfl) )
9400	surfins_av = 0.0_wp
9401	ENDIF
9402
9403	CASE ( 'rtm_rad_reslw' )
9404	!-- array of residua of lw radiation absorbed in surface after last reflection
9405	IF ( .NOT. ALLOCATED(surfinl_av) ) THEN
9406	ALLOCATE( surfinl_av(nsurfl) )
9407	surfinl_av = 0.0_wp
9408	ENDIF
9409
9410	CASE ( 'rtm_rad_pc_inlw' )
9411	!-- array of of lw radiation absorbed in plant canopy
9412	IF ( .NOT. ALLOCATED(pcbinlw_av) ) THEN
9413	ALLOCATE( pcbinlw_av(1:npcbl) )
9414	pcbinlw_av = 0.0_wp
9415	ENDIF
9416
9417	CASE ( 'rtm_rad_pc_insw' )
9418	!-- array of of sw radiation absorbed in plant canopy
9419	IF ( .NOT. ALLOCATED(pcbinsw_av) ) THEN
9420	ALLOCATE( pcbinsw_av(1:npcbl) )
9421	pcbinsw_av = 0.0_wp
9422	ENDIF
9423
9424	CASE ( 'rtm_rad_pc_inswdir' )
9425	!-- array of of direct sw radiation absorbed in plant canopy
9426	IF ( .NOT. ALLOCATED(pcbinswdir_av) ) THEN
9427	ALLOCATE( pcbinswdir_av(1:npcbl) )
9428	pcbinswdir_av = 0.0_wp
9429	ENDIF
9430
9431	CASE ( 'rtm_rad_pc_inswdif' )
9432	!-- array of of diffuse sw radiation absorbed in plant canopy
9433	IF ( .NOT. ALLOCATED(pcbinswdif_av) ) THEN
9434	ALLOCATE( pcbinswdif_av(1:npcbl) )
9435	pcbinswdif_av = 0.0_wp
9436	ENDIF
9437
9438	CASE ( 'rtm_rad_pc_inswref' )
9439	!-- array of of reflected sw radiation absorbed in plant canopy
9440	IF ( .NOT. ALLOCATED(pcbinswref_av) ) THEN
9441	ALLOCATE( pcbinswref_av(1:npcbl) )
9442	pcbinswref_av = 0.0_wp
9443	ENDIF
9444
9445	CASE ( 'rtm_mrt_sw' )
9446	IF ( .NOT. ALLOCATED( mrtinsw_av ) ) THEN
9447	ALLOCATE( mrtinsw_av(nmrtbl) )
9448	ENDIF
9449	mrtinsw_av = 0.0_wp
9450
9451	CASE ( 'rtm_mrt_lw' )
9452	IF ( .NOT. ALLOCATED( mrtinlw_av ) ) THEN
9453	ALLOCATE( mrtinlw_av(nmrtbl) )
9454	ENDIF
9455	mrtinlw_av = 0.0_wp
9456
9457	CASE ( 'rtm_mrt' )
9458	IF ( .NOT. ALLOCATED( mrt_av ) ) THEN
9459	ALLOCATE( mrt_av(nmrtbl) )
9460	ENDIF
9461	mrt_av = 0.0_wp
9462
9463	CASE DEFAULT
9464	CONTINUE
9465
9466	END SELECT
9467
9468	ELSEIF ( mode == 'sum' ) THEN
9469
9470	SELECT CASE ( TRIM( var ) )
9471	!-- block of large scale (e.g. RRTMG) radiation output variables
9472	CASE ( 'rad_net*' )
9473	IF ( ALLOCATED( rad_net_av ) ) THEN
9474	DO i = nxl, nxr
9475	DO j = nys, nyn
9476	match_lsm = surf_lsm_h%start_index(j,i) <= &
9477	surf_lsm_h%end_index(j,i)
9478	match_usm = surf_usm_h%start_index(j,i) <= &
9479	surf_usm_h%end_index(j,i)
9480
9481	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9482	m = surf_lsm_h%end_index(j,i)
9483	rad_net_av(j,i) = rad_net_av(j,i) + &
9484	surf_lsm_h%rad_net(m)
9485	ELSEIF ( match_usm ) THEN
9486	m = surf_usm_h%end_index(j,i)
9487	rad_net_av(j,i) = rad_net_av(j,i) + &
9488	surf_usm_h%rad_net(m)
9489	ENDIF
9490	ENDDO
9491	ENDDO
9492	ENDIF
9493
9494	CASE ( 'rad_lw_in*' )
9495	IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
9496	DO i = nxl, nxr
9497	DO j = nys, nyn
9498	match_lsm = surf_lsm_h%start_index(j,i) <= &
9499	surf_lsm_h%end_index(j,i)
9500	match_usm = surf_usm_h%start_index(j,i) <= &
9501	surf_usm_h%end_index(j,i)
9502
9503	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9504	m = surf_lsm_h%end_index(j,i)
9505	rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) + &
9506	surf_lsm_h%rad_lw_in(m)
9507	ELSEIF ( match_usm ) THEN
9508	m = surf_usm_h%end_index(j,i)
9509	rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) + &
9510	surf_usm_h%rad_lw_in(m)
9511	ENDIF
9512	ENDDO
9513	ENDDO
9514	ENDIF
9515
9516	CASE ( 'rad_lw_out*' )
9517	IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
9518	DO i = nxl, nxr
9519	DO j = nys, nyn
9520	match_lsm = surf_lsm_h%start_index(j,i) <= &
9521	surf_lsm_h%end_index(j,i)
9522	match_usm = surf_usm_h%start_index(j,i) <= &
9523	surf_usm_h%end_index(j,i)
9524
9525	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9526	m = surf_lsm_h%end_index(j,i)
9527	rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) + &
9528	surf_lsm_h%rad_lw_out(m)
9529	ELSEIF ( match_usm ) THEN
9530	m = surf_usm_h%end_index(j,i)
9531	rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) + &
9532	surf_usm_h%rad_lw_out(m)
9533	ENDIF
9534	ENDDO
9535	ENDDO
9536	ENDIF
9537
9538	CASE ( 'rad_sw_in*' )
9539	IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
9540	DO i = nxl, nxr
9541	DO j = nys, nyn
9542	match_lsm = surf_lsm_h%start_index(j,i) <= &
9543	surf_lsm_h%end_index(j,i)
9544	match_usm = surf_usm_h%start_index(j,i) <= &
9545	surf_usm_h%end_index(j,i)
9546
9547	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9548	m = surf_lsm_h%end_index(j,i)
9549	rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) + &
9550	surf_lsm_h%rad_sw_in(m)
9551	ELSEIF ( match_usm ) THEN
9552	m = surf_usm_h%end_index(j,i)
9553	rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) + &
9554	surf_usm_h%rad_sw_in(m)
9555	ENDIF
9556	ENDDO
9557	ENDDO
9558	ENDIF
9559
9560	CASE ( 'rad_sw_out*' )
9561	IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
9562	DO i = nxl, nxr
9563	DO j = nys, nyn
9564	match_lsm = surf_lsm_h%start_index(j,i) <= &
9565	surf_lsm_h%end_index(j,i)
9566	match_usm = surf_usm_h%start_index(j,i) <= &
9567	surf_usm_h%end_index(j,i)
9568
9569	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9570	m = surf_lsm_h%end_index(j,i)
9571	rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) + &
9572	surf_lsm_h%rad_sw_out(m)
9573	ELSEIF ( match_usm ) THEN
9574	m = surf_usm_h%end_index(j,i)
9575	rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) + &
9576	surf_usm_h%rad_sw_out(m)
9577	ENDIF
9578	ENDDO
9579	ENDDO
9580	ENDIF
9581
9582	CASE ( 'rad_lw_in' )
9583	IF ( ALLOCATED( rad_lw_in_av ) ) THEN
9584	DO i = nxlg, nxrg
9585	DO j = nysg, nyng
9586	DO k = nzb, nzt+1
9587	rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) &
9588	+ rad_lw_in(k,j,i)
9589	ENDDO
9590	ENDDO
9591	ENDDO
9592	ENDIF
9593
9594	CASE ( 'rad_lw_out' )
9595	IF ( ALLOCATED( rad_lw_out_av ) ) THEN
9596	DO i = nxlg, nxrg
9597	DO j = nysg, nyng
9598	DO k = nzb, nzt+1
9599	rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) &
9600	+ rad_lw_out(k,j,i)
9601	ENDDO
9602	ENDDO
9603	ENDDO
9604	ENDIF
9605
9606	CASE ( 'rad_lw_cs_hr' )
9607	IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN
9608	DO i = nxlg, nxrg
9609	DO j = nysg, nyng
9610	DO k = nzb, nzt+1
9611	rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) &
9612	+ rad_lw_cs_hr(k,j,i)
9613	ENDDO
9614	ENDDO
9615	ENDDO
9616	ENDIF
9617
9618	CASE ( 'rad_lw_hr' )
9619	IF ( ALLOCATED( rad_lw_hr_av ) ) THEN
9620	DO i = nxlg, nxrg
9621	DO j = nysg, nyng
9622	DO k = nzb, nzt+1
9623	rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) &
9624	+ rad_lw_hr(k,j,i)
9625	ENDDO
9626	ENDDO
9627	ENDDO
9628	ENDIF
9629
9630	CASE ( 'rad_sw_in' )
9631	IF ( ALLOCATED( rad_sw_in_av ) ) THEN
9632	DO i = nxlg, nxrg
9633	DO j = nysg, nyng
9634	DO k = nzb, nzt+1
9635	rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) &
9636	+ rad_sw_in(k,j,i)
9637	ENDDO
9638	ENDDO
9639	ENDDO
9640	ENDIF
9641
9642	CASE ( 'rad_sw_out' )
9643	IF ( ALLOCATED( rad_sw_out_av ) ) THEN
9644	DO i = nxlg, nxrg
9645	DO j = nysg, nyng
9646	DO k = nzb, nzt+1
9647	rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) &
9648	+ rad_sw_out(k,j,i)
9649	ENDDO
9650	ENDDO
9651	ENDDO
9652	ENDIF
9653
9654	CASE ( 'rad_sw_cs_hr' )
9655	IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN
9656	DO i = nxlg, nxrg
9657	DO j = nysg, nyng
9658	DO k = nzb, nzt+1
9659	rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) &
9660	+ rad_sw_cs_hr(k,j,i)
9661	ENDDO
9662	ENDDO
9663	ENDDO
9664	ENDIF
9665
9666	CASE ( 'rad_sw_hr' )
9667	IF ( ALLOCATED( rad_sw_hr_av ) ) THEN
9668	DO i = nxlg, nxrg
9669	DO j = nysg, nyng
9670	DO k = nzb, nzt+1
9671	rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) &
9672	+ rad_sw_hr(k,j,i)
9673	ENDDO
9674	ENDDO
9675	ENDDO
9676	ENDIF
9677
9678	!-- block of RTM output variables
9679	CASE ( 'rtm_rad_net' )
9680	!-- array of complete radiation balance
9681	DO isurf = dirstart(ids), dirend(ids)
9682	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9683	surfradnet_av(isurf) = surfinsw(isurf) - surfoutsw(isurf) + surfinlw(isurf) - surfoutlw(isurf)
9684	ENDIF
9685	ENDDO
9686
9687	CASE ( 'rtm_rad_insw' )
9688	!-- array of sw radiation falling to surface after i-th reflection
9689	DO isurf = dirstart(ids), dirend(ids)
9690	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9691	surfinsw_av(isurf) = surfinsw_av(isurf) + surfinsw(isurf)
9692	ENDIF
9693	ENDDO
9694
9695	CASE ( 'rtm_rad_inlw' )
9696	!-- array of lw radiation falling to surface after i-th reflection
9697	DO isurf = dirstart(ids), dirend(ids)
9698	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9699	surfinlw_av(isurf) = surfinlw_av(isurf) + surfinlw(isurf)
9700	ENDIF
9701	ENDDO
9702
9703	CASE ( 'rtm_rad_inswdir' )
9704	!-- array of direct sw radiation falling to surface from sun
9705	DO isurf = dirstart(ids), dirend(ids)
9706	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9707	surfinswdir_av(isurf) = surfinswdir_av(isurf) + surfinswdir(isurf)
9708	ENDIF
9709	ENDDO
9710
9711	CASE ( 'rtm_rad_inswdif' )
9712	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
9713	DO isurf = dirstart(ids), dirend(ids)
9714	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9715	surfinswdif_av(isurf) = surfinswdif_av(isurf) + surfinswdif(isurf)
9716	ENDIF
9717	ENDDO
9718
9719	CASE ( 'rtm_rad_inswref' )
9720	!-- array of sw radiation falling to surface from reflections
9721	DO isurf = dirstart(ids), dirend(ids)
9722	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9723	surfinswref_av(isurf) = surfinswref_av(isurf) + surfinsw(isurf) - &
9724	surfinswdir(isurf) - surfinswdif(isurf)
9725	ENDIF
9726	ENDDO
9727
9728
9729	CASE ( 'rtm_rad_inlwdif' )
9730	!-- array of sw radiation falling to surface after i-th reflection
9731	DO isurf = dirstart(ids), dirend(ids)
9732	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9733	surfinlwdif_av(isurf) = surfinlwdif_av(isurf) + surfinlwdif(isurf)
9734	ENDIF
9735	ENDDO
9736	!
9737	CASE ( 'rtm_rad_inlwref' )
9738	!-- array of lw radiation falling to surface from reflections
9739	DO isurf = dirstart(ids), dirend(ids)
9740	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9741	surfinlwref_av(isurf) = surfinlwref_av(isurf) + &
9742	surfinlw(isurf) - surfinlwdif(isurf)
9743	ENDIF
9744	ENDDO
9745
9746	CASE ( 'rtm_rad_outsw' )
9747	!-- array of sw radiation emitted from surface after i-th reflection
9748	DO isurf = dirstart(ids), dirend(ids)
9749	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9750	surfoutsw_av(isurf) = surfoutsw_av(isurf) + surfoutsw(isurf)
9751	ENDIF
9752	ENDDO
9753
9754	CASE ( 'rtm_rad_outlw' )
9755	!-- array of lw radiation emitted from surface after i-th reflection
9756	DO isurf = dirstart(ids), dirend(ids)
9757	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9758	surfoutlw_av(isurf) = surfoutlw_av(isurf) + surfoutlw(isurf)
9759	ENDIF
9760	ENDDO
9761
9762	CASE ( 'rtm_rad_ressw' )
9763	!-- array of residua of sw radiation absorbed in surface after last reflection
9764	DO isurf = dirstart(ids), dirend(ids)
9765	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9766	surfins_av(isurf) = surfins_av(isurf) + surfins(isurf)
9767	ENDIF
9768	ENDDO
9769
9770	CASE ( 'rtm_rad_reslw' )
9771	!-- array of residua of lw radiation absorbed in surface after last reflection
9772	DO isurf = dirstart(ids), dirend(ids)
9773	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9774	surfinl_av(isurf) = surfinl_av(isurf) + surfinl(isurf)
9775	ENDIF
9776	ENDDO
9777
9778	CASE ( 'rtm_rad_pc_inlw' )
9779	DO l = 1, npcbl
9780	pcbinlw_av(l) = pcbinlw_av(l) + pcbinlw(l)
9781	ENDDO
9782
9783	CASE ( 'rtm_rad_pc_insw' )
9784	DO l = 1, npcbl
9785	pcbinsw_av(l) = pcbinsw_av(l) + pcbinsw(l)
9786	ENDDO
9787
9788	CASE ( 'rtm_rad_pc_inswdir' )
9789	DO l = 1, npcbl
9790	pcbinswdir_av(l) = pcbinswdir_av(l) + pcbinswdir(l)
9791	ENDDO
9792
9793	CASE ( 'rtm_rad_pc_inswdif' )
9794	DO l = 1, npcbl
9795	pcbinswdif_av(l) = pcbinswdif_av(l) + pcbinswdif(l)
9796	ENDDO
9797
9798	CASE ( 'rtm_rad_pc_inswref' )
9799	DO l = 1, npcbl
9800	pcbinswref_av(l) = pcbinswref_av(l) + pcbinsw(l) - pcbinswdir(l) - pcbinswdif(l)
9801	ENDDO
9802
9803	CASE ( 'rad_mrt_sw' )
9804	IF ( ALLOCATED( mrtinsw_av ) ) THEN
9805	mrtinsw_av(:) = mrtinsw_av(:) + mrtinsw(:)
9806	ENDIF
9807
9808	CASE ( 'rad_mrt_lw' )
9809	IF ( ALLOCATED( mrtinlw_av ) ) THEN
9810	mrtinlw_av(:) = mrtinlw_av(:) + mrtinlw(:)
9811	ENDIF
9812
9813	CASE ( 'rad_mrt' )
9814	IF ( ALLOCATED( mrt_av ) ) THEN
9815	mrt_av(:) = mrt_av(:) + mrt(:)
9816	ENDIF
9817
9818	CASE DEFAULT
9819	CONTINUE
9820
9821	END SELECT
9822
9823	ELSEIF ( mode == 'average' ) THEN
9824
9825	SELECT CASE ( TRIM( var ) )
9826	!-- block of large scale (e.g. RRTMG) radiation output variables
9827	CASE ( 'rad_net*' )
9828	IF ( ALLOCATED( rad_net_av ) ) THEN
9829	DO i = nxlg, nxrg
9830	DO j = nysg, nyng
9831	rad_net_av(j,i) = rad_net_av(j,i) &
9832	/ REAL( average_count_3d, KIND=wp )
9833	ENDDO
9834	ENDDO
9835	ENDIF
9836
9837	CASE ( 'rad_lw_in*' )
9838	IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
9839	DO i = nxlg, nxrg
9840	DO j = nysg, nyng
9841	rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) &
9842	/ REAL( average_count_3d, KIND=wp )
9843	ENDDO
9844	ENDDO
9845	ENDIF
9846
9847	CASE ( 'rad_lw_out*' )
9848	IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
9849	DO i = nxlg, nxrg
9850	DO j = nysg, nyng
9851	rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) &
9852	/ REAL( average_count_3d, KIND=wp )
9853	ENDDO
9854	ENDDO
9855	ENDIF
9856
9857	CASE ( 'rad_sw_in*' )
9858	IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
9859	DO i = nxlg, nxrg
9860	DO j = nysg, nyng
9861	rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) &
9862	/ REAL( average_count_3d, KIND=wp )
9863	ENDDO
9864	ENDDO
9865	ENDIF
9866
9867	CASE ( 'rad_sw_out*' )
9868	IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
9869	DO i = nxlg, nxrg
9870	DO j = nysg, nyng
9871	rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) &
9872	/ REAL( average_count_3d, KIND=wp )
9873	ENDDO
9874	ENDDO
9875	ENDIF
9876
9877	CASE ( 'rad_lw_in' )
9878	IF ( ALLOCATED( rad_lw_in_av ) ) THEN
9879	DO i = nxlg, nxrg
9880	DO j = nysg, nyng
9881	DO k = nzb, nzt+1
9882	rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) &
9883	/ REAL( average_count_3d, KIND=wp )
9884	ENDDO
9885	ENDDO
9886	ENDDO
9887	ENDIF
9888
9889	CASE ( 'rad_lw_out' )
9890	IF ( ALLOCATED( rad_lw_out_av ) ) THEN
9891	DO i = nxlg, nxrg
9892	DO j = nysg, nyng
9893	DO k = nzb, nzt+1
9894	rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) &
9895	/ REAL( average_count_3d, KIND=wp )
9896	ENDDO
9897	ENDDO
9898	ENDDO
9899	ENDIF
9900
9901	CASE ( 'rad_lw_cs_hr' )
9902	IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN
9903	DO i = nxlg, nxrg
9904	DO j = nysg, nyng
9905	DO k = nzb, nzt+1
9906	rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) &
9907	/ REAL( average_count_3d, KIND=wp )
9908	ENDDO
9909	ENDDO
9910	ENDDO
9911	ENDIF
9912
9913	CASE ( 'rad_lw_hr' )
9914	IF ( ALLOCATED( rad_lw_hr_av ) ) THEN
9915	DO i = nxlg, nxrg
9916	DO j = nysg, nyng
9917	DO k = nzb, nzt+1
9918	rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) &
9919	/ REAL( average_count_3d, KIND=wp )
9920	ENDDO
9921	ENDDO
9922	ENDDO
9923	ENDIF
9924
9925	CASE ( 'rad_sw_in' )
9926	IF ( ALLOCATED( rad_sw_in_av ) ) THEN
9927	DO i = nxlg, nxrg
9928	DO j = nysg, nyng
9929	DO k = nzb, nzt+1
9930	rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) &
9931	/ REAL( average_count_3d, KIND=wp )
9932	ENDDO
9933	ENDDO
9934	ENDDO
9935	ENDIF
9936
9937	CASE ( 'rad_sw_out' )
9938	IF ( ALLOCATED( rad_sw_out_av ) ) THEN
9939	DO i = nxlg, nxrg
9940	DO j = nysg, nyng
9941	DO k = nzb, nzt+1
9942	rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) &
9943	/ REAL( average_count_3d, KIND=wp )
9944	ENDDO
9945	ENDDO
9946	ENDDO
9947	ENDIF
9948
9949	CASE ( 'rad_sw_cs_hr' )
9950	IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN
9951	DO i = nxlg, nxrg
9952	DO j = nysg, nyng
9953	DO k = nzb, nzt+1
9954	rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) &
9955	/ REAL( average_count_3d, KIND=wp )
9956	ENDDO
9957	ENDDO
9958	ENDDO
9959	ENDIF
9960
9961	CASE ( 'rad_sw_hr' )
9962	IF ( ALLOCATED( rad_sw_hr_av ) ) THEN
9963	DO i = nxlg, nxrg
9964	DO j = nysg, nyng
9965	DO k = nzb, nzt+1
9966	rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) &
9967	/ REAL( average_count_3d, KIND=wp )
9968	ENDDO
9969	ENDDO
9970	ENDDO
9971	ENDIF
9972
9973	!-- block of RTM output variables
9974	CASE ( 'rtm_rad_net' )
9975	!-- array of complete radiation balance
9976	DO isurf = dirstart(ids), dirend(ids)
9977	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9978	surfradnet_av(isurf) = surfinsw_av(isurf) / REAL( average_count_3d, kind=wp )
9979	ENDIF
9980	ENDDO
9981
9982	CASE ( 'rtm_rad_insw' )
9983	!-- array of sw radiation falling to surface after i-th reflection
9984	DO isurf = dirstart(ids), dirend(ids)
9985	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9986	surfinsw_av(isurf) = surfinsw_av(isurf) / REAL( average_count_3d, kind=wp )
9987	ENDIF
9988	ENDDO
9989
9990	CASE ( 'rtm_rad_inlw' )
9991	!-- array of lw radiation falling to surface after i-th reflection
9992	DO isurf = dirstart(ids), dirend(ids)
9993	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9994	surfinlw_av(isurf) = surfinlw_av(isurf) / REAL( average_count_3d, kind=wp )
9995	ENDIF
9996	ENDDO
9997
9998	CASE ( 'rtm_rad_inswdir' )
9999	!-- array of direct sw radiation falling to surface from sun
10000	DO isurf = dirstart(ids), dirend(ids)
10001	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10002	surfinswdir_av(isurf) = surfinswdir_av(isurf) / REAL( average_count_3d, kind=wp )
10003	ENDIF
10004	ENDDO
10005
10006	CASE ( 'rtm_rad_inswdif' )
10007	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
10008	DO isurf = dirstart(ids), dirend(ids)
10009	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10010	surfinswdif_av(isurf) = surfinswdif_av(isurf) / REAL( average_count_3d, kind=wp )
10011	ENDIF
10012	ENDDO
10013
10014	CASE ( 'rtm_rad_inswref' )
10015	!-- array of sw radiation falling to surface from reflections
10016	DO isurf = dirstart(ids), dirend(ids)
10017	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10018	surfinswref_av(isurf) = surfinswref_av(isurf) / REAL( average_count_3d, kind=wp )
10019	ENDIF
10020	ENDDO
10021
10022	CASE ( 'rtm_rad_inlwdif' )
10023	!-- array of sw radiation falling to surface after i-th reflection
10024	DO isurf = dirstart(ids), dirend(ids)
10025	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10026	surfinlwdif_av(isurf) = surfinlwdif_av(isurf) / REAL( average_count_3d, kind=wp )
10027	ENDIF
10028	ENDDO
10029
10030	CASE ( 'rtm_rad_inlwref' )
10031	!-- array of lw radiation falling to surface from reflections
10032	DO isurf = dirstart(ids), dirend(ids)
10033	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10034	surfinlwref_av(isurf) = surfinlwref_av(isurf) / REAL( average_count_3d, kind=wp )
10035	ENDIF
10036	ENDDO
10037
10038	CASE ( 'rtm_rad_outsw' )
10039	!-- array of sw radiation emitted from surface after i-th reflection
10040	DO isurf = dirstart(ids), dirend(ids)
10041	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10042	surfoutsw_av(isurf) = surfoutsw_av(isurf) / REAL( average_count_3d, kind=wp )
10043	ENDIF
10044	ENDDO
10045
10046	CASE ( 'rtm_rad_outlw' )
10047	!-- array of lw radiation emitted from 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	surfoutlw_av(isurf) = surfoutlw_av(isurf) / REAL( average_count_3d, kind=wp )
10051	ENDIF
10052	ENDDO
10053
10054	CASE ( 'rtm_rad_ressw' )
10055	!-- array of residua of sw radiation absorbed in surface after last reflection
10056	DO isurf = dirstart(ids), dirend(ids)
10057	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10058	surfins_av(isurf) = surfins_av(isurf) / REAL( average_count_3d, kind=wp )
10059	ENDIF
10060	ENDDO
10061
10062	CASE ( 'rtm_rad_reslw' )
10063	!-- array of residua of lw radiation absorbed in surface after last reflection
10064	DO isurf = dirstart(ids), dirend(ids)
10065	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10066	surfinl_av(isurf) = surfinl_av(isurf) / REAL( average_count_3d, kind=wp )
10067	ENDIF
10068	ENDDO
10069
10070	CASE ( 'rtm_rad_pc_inlw' )
10071	DO l = 1, npcbl
10072	pcbinlw_av(:) = pcbinlw_av(:) / REAL( average_count_3d, kind=wp )
10073	ENDDO
10074
10075	CASE ( 'rtm_rad_pc_insw' )
10076	DO l = 1, npcbl
10077	pcbinsw_av(:) = pcbinsw_av(:) / REAL( average_count_3d, kind=wp )
10078	ENDDO
10079
10080	CASE ( 'rtm_rad_pc_inswdir' )
10081	DO l = 1, npcbl
10082	pcbinswdir_av(:) = pcbinswdir_av(:) / REAL( average_count_3d, kind=wp )
10083	ENDDO
10084
10085	CASE ( 'rtm_rad_pc_inswdif' )
10086	DO l = 1, npcbl
10087	pcbinswdif_av(:) = pcbinswdif_av(:) / REAL( average_count_3d, kind=wp )
10088	ENDDO
10089
10090	CASE ( 'rtm_rad_pc_inswref' )
10091	DO l = 1, npcbl
10092	pcbinswref_av(:) = pcbinswref_av(:) / REAL( average_count_3d, kind=wp )
10093	ENDDO
10094
10095	CASE ( 'rad_mrt_lw' )
10096	IF ( ALLOCATED( mrtinlw_av ) ) THEN
10097	mrtinlw_av(:) = mrtinlw_av(:) / REAL( average_count_3d, KIND=wp )
10098	ENDIF
10099
10100	CASE ( 'rad_mrt' )
10101	IF ( ALLOCATED( mrt_av ) ) THEN
10102	mrt_av(:) = mrt_av(:) / REAL( average_count_3d, KIND=wp )
10103	ENDIF
10104
10105	END SELECT
10106
10107	ENDIF
10108
10109	END SUBROUTINE radiation_3d_data_averaging
10110
10111
10112	!------------------------------------------------------------------------------!
10113	!
10114	! Description:
10115	! ------------
10116	!> Subroutine defining appropriate grid for netcdf variables.
10117	!> It is called out from subroutine netcdf.
10118	!------------------------------------------------------------------------------!
10119	SUBROUTINE radiation_define_netcdf_grid( variable, found, grid_x, grid_y, grid_z )
10120
10121	IMPLICIT NONE
10122
10123	CHARACTER (LEN=*), INTENT(IN) :: variable !<
10124	LOGICAL, INTENT(OUT) :: found !<
10125	CHARACTER (LEN=*), INTENT(OUT) :: grid_x !<
10126	CHARACTER (LEN=*), INTENT(OUT) :: grid_y !<
10127	CHARACTER (LEN=*), INTENT(OUT) :: grid_z !<
10128
10129	CHARACTER (len=varnamelength) :: var
10130
10131	found = .TRUE.
10132
10133	!
10134	!-- Check for the grid
10135	var = TRIM(variable)
10136	!-- RTM directional variables
10137	IF ( var(1:12) == 'rtm_rad_net_' .OR. var(1:13) == 'rtm_rad_insw_' .OR. &
10138	var(1:13) == 'rtm_rad_inlw_' .OR. var(1:16) == 'rtm_rad_inswdir_' .OR. &
10139	var(1:16) == 'rtm_rad_inswdif_' .OR. var(1:16) == 'rtm_rad_inswref_' .OR. &
10140	var(1:16) == 'rtm_rad_inlwdif_' .OR. var(1:16) == 'rtm_rad_inlwref_' .OR. &
10141	var(1:14) == 'rtm_rad_outsw_' .OR. var(1:14) == 'rtm_rad_outlw_' .OR. &
10142	var(1:14) == 'rtm_rad_ressw_' .OR. var(1:14) == 'rtm_rad_reslw_' .OR. &
10143	var == 'rtm_rad_pc_inlw' .OR. &
10144	var == 'rtm_rad_pc_insw' .OR. var == 'rtm_rad_pc_inswdir' .OR. &
10145	var == 'rtm_rad_pc_inswdif' .OR. var == 'rtm_rad_pc_inswref' .OR. &
10146	var(1:7) == 'rtm_svf' .OR. var(1:7) == 'rtm_dif' .OR. &
10147	var(1:9) == 'rtm_skyvf' .OR. var(1:10) == 'rtm_skyvft' .OR. &
10148	var(1:12) == 'rtm_surfalb_' .OR. var(1:13) == 'rtm_surfemis_' .OR. &
10149	var == 'rtm_mrt' .OR. var == 'rtm_mrt_sw' .OR. var == 'rtm_mrt_lw' ) THEN
10150
10151	found = .TRUE.
10152	grid_x = 'x'
10153	grid_y = 'y'
10154	grid_z = 'zu'
10155	ELSE
10156
10157	SELECT CASE ( TRIM( var ) )
10158
10159	CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_sw_cs_hr', 'rad_sw_hr', &
10160	'rad_lw_cs_hr_xy', 'rad_lw_hr_xy', 'rad_sw_cs_hr_xy', &
10161	'rad_sw_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_hr_xz', &
10162	'rad_sw_cs_hr_xz', 'rad_sw_hr_xz', 'rad_lw_cs_hr_yz', &
10163	'rad_lw_hr_yz', 'rad_sw_cs_hr_yz', 'rad_sw_hr_yz', &
10164	'rad_mrt', 'rad_mrt_sw', 'rad_mrt_lw' )
10165	grid_x = 'x'
10166	grid_y = 'y'
10167	grid_z = 'zu'
10168
10169	CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out', &
10170	'rad_lw_in_xy', 'rad_lw_out_xy', 'rad_sw_in_xy','rad_sw_out_xy', &
10171	'rad_lw_in_xz', 'rad_lw_out_xz', 'rad_sw_in_xz','rad_sw_out_xz', &
10172	'rad_lw_in_yz', 'rad_lw_out_yz', 'rad_sw_in_yz','rad_sw_out_yz' )
10173	grid_x = 'x'
10174	grid_y = 'y'
10175	grid_z = 'zw'
10176
10177
10178	CASE DEFAULT
10179	found = .FALSE.
10180	grid_x = 'none'
10181	grid_y = 'none'
10182	grid_z = 'none'
10183
10184	END SELECT
10185	ENDIF
10186
10187	END SUBROUTINE radiation_define_netcdf_grid
10188
10189	!------------------------------------------------------------------------------!
10190	!
10191	! Description:
10192	! ------------
10193	!> Subroutine defining 2D output variables
10194	!------------------------------------------------------------------------------!
10195	SUBROUTINE radiation_data_output_2d( av, variable, found, grid, mode, &
10196	local_pf, two_d, nzb_do, nzt_do )
10197
10198	USE indices
10199
10200	USE kinds
10201
10202
10203	IMPLICIT NONE
10204
10205	CHARACTER (LEN=*) :: grid !<
10206	CHARACTER (LEN=*) :: mode !<
10207	CHARACTER (LEN=*) :: variable !<
10208
10209	INTEGER(iwp) :: av !<
10210	INTEGER(iwp) :: i !<
10211	INTEGER(iwp) :: j !<
10212	INTEGER(iwp) :: k !<
10213	INTEGER(iwp) :: m !< index of surface element at grid point (j,i)
10214	INTEGER(iwp) :: nzb_do !<
10215	INTEGER(iwp) :: nzt_do !<
10216
10217	LOGICAL :: found !<
10218	LOGICAL :: two_d !< flag parameter that indicates 2D variables (horizontal cross sections)
10219
10220	REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute
10221
10222	REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !<
10223
10224	found = .TRUE.
10225
10226	SELECT CASE ( TRIM( variable ) )
10227
10228	CASE ( 'rad_net*_xy' ) ! 2d-array
10229	IF ( av == 0 ) THEN
10230	DO i = nxl, nxr
10231	DO j = nys, nyn
10232	!
10233	!-- Obtain rad_net from its respective surface type
10234	!-- Natural-type surfaces
10235	DO m = surf_lsm_h%start_index(j,i), &
10236	surf_lsm_h%end_index(j,i)
10237	local_pf(i,j,nzb+1) = surf_lsm_h%rad_net(m)
10238	ENDDO
10239	!
10240	!-- Urban-type surfaces
10241	DO m = surf_usm_h%start_index(j,i), &
10242	surf_usm_h%end_index(j,i)
10243	local_pf(i,j,nzb+1) = surf_usm_h%rad_net(m)
10244	ENDDO
10245	ENDDO
10246	ENDDO
10247	ELSE
10248	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
10249	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
10250	rad_net_av = REAL( fill_value, KIND = wp )
10251	ENDIF
10252	DO i = nxl, nxr
10253	DO j = nys, nyn
10254	local_pf(i,j,nzb+1) = rad_net_av(j,i)
10255	ENDDO
10256	ENDDO
10257	ENDIF
10258	two_d = .TRUE.
10259	grid = 'zu1'
10260
10261	CASE ( 'rad_lw_in*_xy' ) ! 2d-array
10262	IF ( av == 0 ) THEN
10263	DO i = nxl, nxr
10264	DO j = nys, nyn
10265	!
10266	!-- Obtain rad_net from its respective surface type
10267	!-- Natural-type surfaces
10268	DO m = surf_lsm_h%start_index(j,i), &
10269	surf_lsm_h%end_index(j,i)
10270	local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_in(m)
10271	ENDDO
10272	!
10273	!-- Urban-type surfaces
10274	DO m = surf_usm_h%start_index(j,i), &
10275	surf_usm_h%end_index(j,i)
10276	local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_in(m)
10277	ENDDO
10278	ENDDO
10279	ENDDO
10280	ELSE
10281	IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
10282	ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
10283	rad_lw_in_xy_av = REAL( fill_value, KIND = wp )
10284	ENDIF
10285	DO i = nxl, nxr
10286	DO j = nys, nyn
10287	local_pf(i,j,nzb+1) = rad_lw_in_xy_av(j,i)
10288	ENDDO
10289	ENDDO
10290	ENDIF
10291	two_d = .TRUE.
10292	grid = 'zu1'
10293
10294	CASE ( 'rad_lw_out*_xy' ) ! 2d-array
10295	IF ( av == 0 ) THEN
10296	DO i = nxl, nxr
10297	DO j = nys, nyn
10298	!
10299	!-- Obtain rad_net from its respective surface type
10300	!-- Natural-type surfaces
10301	DO m = surf_lsm_h%start_index(j,i), &
10302	surf_lsm_h%end_index(j,i)
10303	local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_out(m)
10304	ENDDO
10305	!
10306	!-- Urban-type surfaces
10307	DO m = surf_usm_h%start_index(j,i), &
10308	surf_usm_h%end_index(j,i)
10309	local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_out(m)
10310	ENDDO
10311	ENDDO
10312	ENDDO
10313	ELSE
10314	IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
10315	ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
10316	rad_lw_out_xy_av = REAL( fill_value, KIND = wp )
10317	ENDIF
10318	DO i = nxl, nxr
10319	DO j = nys, nyn
10320	local_pf(i,j,nzb+1) = rad_lw_out_xy_av(j,i)
10321	ENDDO
10322	ENDDO
10323	ENDIF
10324	two_d = .TRUE.
10325	grid = 'zu1'
10326
10327	CASE ( 'rad_sw_in*_xy' ) ! 2d-array
10328	IF ( av == 0 ) THEN
10329	DO i = nxl, nxr
10330	DO j = nys, nyn
10331	!
10332	!-- Obtain rad_net from its respective surface type
10333	!-- Natural-type surfaces
10334	DO m = surf_lsm_h%start_index(j,i), &
10335	surf_lsm_h%end_index(j,i)
10336	local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_in(m)
10337	ENDDO
10338	!
10339	!-- Urban-type surfaces
10340	DO m = surf_usm_h%start_index(j,i), &
10341	surf_usm_h%end_index(j,i)
10342	local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_in(m)
10343	ENDDO
10344	ENDDO
10345	ENDDO
10346	ELSE
10347	IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
10348	ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
10349	rad_sw_in_xy_av = REAL( fill_value, KIND = wp )
10350	ENDIF
10351	DO i = nxl, nxr
10352	DO j = nys, nyn
10353	local_pf(i,j,nzb+1) = rad_sw_in_xy_av(j,i)
10354	ENDDO
10355	ENDDO
10356	ENDIF
10357	two_d = .TRUE.
10358	grid = 'zu1'
10359
10360	CASE ( 'rad_sw_out*_xy' ) ! 2d-array
10361	IF ( av == 0 ) THEN
10362	DO i = nxl, nxr
10363	DO j = nys, nyn
10364	!
10365	!-- Obtain rad_net from its respective surface type
10366	!-- Natural-type surfaces
10367	DO m = surf_lsm_h%start_index(j,i), &
10368	surf_lsm_h%end_index(j,i)
10369	local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_out(m)
10370	ENDDO
10371	!
10372	!-- Urban-type surfaces
10373	DO m = surf_usm_h%start_index(j,i), &
10374	surf_usm_h%end_index(j,i)
10375	local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_out(m)
10376	ENDDO
10377	ENDDO
10378	ENDDO
10379	ELSE
10380	IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
10381	ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
10382	rad_sw_out_xy_av = REAL( fill_value, KIND = wp )
10383	ENDIF
10384	DO i = nxl, nxr
10385	DO j = nys, nyn
10386	local_pf(i,j,nzb+1) = rad_sw_out_xy_av(j,i)
10387	ENDDO
10388	ENDDO
10389	ENDIF
10390	two_d = .TRUE.
10391	grid = 'zu1'
10392
10393	CASE ( 'rad_lw_in_xy', 'rad_lw_in_xz', 'rad_lw_in_yz' )
10394	IF ( av == 0 ) THEN
10395	DO i = nxl, nxr
10396	DO j = nys, nyn
10397	DO k = nzb_do, nzt_do
10398	local_pf(i,j,k) = rad_lw_in(k,j,i)
10399	ENDDO
10400	ENDDO
10401	ENDDO
10402	ELSE
10403	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
10404	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10405	rad_lw_in_av = REAL( fill_value, KIND = wp )
10406	ENDIF
10407	DO i = nxl, nxr
10408	DO j = nys, nyn
10409	DO k = nzb_do, nzt_do
10410	local_pf(i,j,k) = rad_lw_in_av(k,j,i)
10411	ENDDO
10412	ENDDO
10413	ENDDO
10414	ENDIF
10415	IF ( mode == 'xy' ) grid = 'zu'
10416
10417	CASE ( 'rad_lw_out_xy', 'rad_lw_out_xz', 'rad_lw_out_yz' )
10418	IF ( av == 0 ) THEN
10419	DO i = nxl, nxr
10420	DO j = nys, nyn
10421	DO k = nzb_do, nzt_do
10422	local_pf(i,j,k) = rad_lw_out(k,j,i)
10423	ENDDO
10424	ENDDO
10425	ENDDO
10426	ELSE
10427	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
10428	ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10429	rad_lw_out_av = REAL( fill_value, KIND = wp )
10430	ENDIF
10431	DO i = nxl, nxr
10432	DO j = nys, nyn
10433	DO k = nzb_do, nzt_do
10434	local_pf(i,j,k) = rad_lw_out_av(k,j,i)
10435	ENDDO
10436	ENDDO
10437	ENDDO
10438	ENDIF
10439	IF ( mode == 'xy' ) grid = 'zu'
10440
10441	CASE ( 'rad_lw_cs_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_cs_hr_yz' )
10442	IF ( av == 0 ) THEN
10443	DO i = nxl, nxr
10444	DO j = nys, nyn
10445	DO k = nzb_do, nzt_do
10446	local_pf(i,j,k) = rad_lw_cs_hr(k,j,i)
10447	ENDDO
10448	ENDDO
10449	ENDDO
10450	ELSE
10451	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
10452	ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10453	rad_lw_cs_hr_av = REAL( fill_value, KIND = wp )
10454	ENDIF
10455	DO i = nxl, nxr
10456	DO j = nys, nyn
10457	DO k = nzb_do, nzt_do
10458	local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i)
10459	ENDDO
10460	ENDDO
10461	ENDDO
10462	ENDIF
10463	IF ( mode == 'xy' ) grid = 'zw'
10464
10465	CASE ( 'rad_lw_hr_xy', 'rad_lw_hr_xz', 'rad_lw_hr_yz' )
10466	IF ( av == 0 ) THEN
10467	DO i = nxl, nxr
10468	DO j = nys, nyn
10469	DO k = nzb_do, nzt_do
10470	local_pf(i,j,k) = rad_lw_hr(k,j,i)
10471	ENDDO
10472	ENDDO
10473	ENDDO
10474	ELSE
10475	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
10476	ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10477	rad_lw_hr_av= REAL( fill_value, KIND = wp )
10478	ENDIF
10479	DO i = nxl, nxr
10480	DO j = nys, nyn
10481	DO k = nzb_do, nzt_do
10482	local_pf(i,j,k) = rad_lw_hr_av(k,j,i)
10483	ENDDO
10484	ENDDO
10485	ENDDO
10486	ENDIF
10487	IF ( mode == 'xy' ) grid = 'zw'
10488
10489	CASE ( 'rad_sw_in_xy', 'rad_sw_in_xz', 'rad_sw_in_yz' )
10490	IF ( av == 0 ) THEN
10491	DO i = nxl, nxr
10492	DO j = nys, nyn
10493	DO k = nzb_do, nzt_do
10494	local_pf(i,j,k) = rad_sw_in(k,j,i)
10495	ENDDO
10496	ENDDO
10497	ENDDO
10498	ELSE
10499	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
10500	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10501	rad_sw_in_av = REAL( fill_value, KIND = wp )
10502	ENDIF
10503	DO i = nxl, nxr
10504	DO j = nys, nyn
10505	DO k = nzb_do, nzt_do
10506	local_pf(i,j,k) = rad_sw_in_av(k,j,i)
10507	ENDDO
10508	ENDDO
10509	ENDDO
10510	ENDIF
10511	IF ( mode == 'xy' ) grid = 'zu'
10512
10513	CASE ( 'rad_sw_out_xy', 'rad_sw_out_xz', 'rad_sw_out_yz' )
10514	IF ( av == 0 ) THEN
10515	DO i = nxl, nxr
10516	DO j = nys, nyn
10517	DO k = nzb_do, nzt_do
10518	local_pf(i,j,k) = rad_sw_out(k,j,i)
10519	ENDDO
10520	ENDDO
10521	ENDDO
10522	ELSE
10523	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
10524	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10525	rad_sw_out_av = REAL( fill_value, KIND = wp )
10526	ENDIF
10527	DO i = nxl, nxr
10528	DO j = nys, nyn
10529	DO k = nzb, nzt+1
10530	local_pf(i,j,k) = rad_sw_out_av(k,j,i)
10531	ENDDO
10532	ENDDO
10533	ENDDO
10534	ENDIF
10535	IF ( mode == 'xy' ) grid = 'zu'
10536
10537	CASE ( 'rad_sw_cs_hr_xy', 'rad_sw_cs_hr_xz', 'rad_sw_cs_hr_yz' )
10538	IF ( av == 0 ) THEN
10539	DO i = nxl, nxr
10540	DO j = nys, nyn
10541	DO k = nzb_do, nzt_do
10542	local_pf(i,j,k) = rad_sw_cs_hr(k,j,i)
10543	ENDDO
10544	ENDDO
10545	ENDDO
10546	ELSE
10547	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
10548	ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10549	rad_sw_cs_hr_av = REAL( fill_value, KIND = wp )
10550	ENDIF
10551	DO i = nxl, nxr
10552	DO j = nys, nyn
10553	DO k = nzb_do, nzt_do
10554	local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i)
10555	ENDDO
10556	ENDDO
10557	ENDDO
10558	ENDIF
10559	IF ( mode == 'xy' ) grid = 'zw'
10560
10561	CASE ( 'rad_sw_hr_xy', 'rad_sw_hr_xz', 'rad_sw_hr_yz' )
10562	IF ( av == 0 ) THEN
10563	DO i = nxl, nxr
10564	DO j = nys, nyn
10565	DO k = nzb_do, nzt_do
10566	local_pf(i,j,k) = rad_sw_hr(k,j,i)
10567	ENDDO
10568	ENDDO
10569	ENDDO
10570	ELSE
10571	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
10572	ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10573	rad_sw_hr_av = REAL( fill_value, KIND = wp )
10574	ENDIF
10575	DO i = nxl, nxr
10576	DO j = nys, nyn
10577	DO k = nzb_do, nzt_do
10578	local_pf(i,j,k) = rad_sw_hr_av(k,j,i)
10579	ENDDO
10580	ENDDO
10581	ENDDO
10582	ENDIF
10583	IF ( mode == 'xy' ) grid = 'zw'
10584
10585	CASE DEFAULT
10586	found = .FALSE.
10587	grid = 'none'
10588
10589	END SELECT
10590
10591	END SUBROUTINE radiation_data_output_2d
10592
10593
10594	!------------------------------------------------------------------------------!
10595	!
10596	! Description:
10597	! ------------
10598	!> Subroutine defining 3D output variables
10599	!------------------------------------------------------------------------------!
10600	SUBROUTINE radiation_data_output_3d( av, variable, found, local_pf, nzb_do, nzt_do )
10601
10602
10603	USE indices
10604
10605	USE kinds
10606
10607
10608	IMPLICIT NONE
10609
10610	CHARACTER (LEN=*) :: variable !<
10611
10612	INTEGER(iwp) :: av !<
10613	INTEGER(iwp) :: i, j, k, l !<
10614	INTEGER(iwp) :: nzb_do !<
10615	INTEGER(iwp) :: nzt_do !<
10616
10617	LOGICAL :: found !<
10618
10619	REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute
10620
10621	REAL(sp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !<
10622
10623	CHARACTER (len=varnamelength) :: var, surfid
10624	INTEGER(iwp) :: ids,idsint_u,idsint_l,isurf,isvf,isurfs,isurflt,ipcgb
10625	INTEGER(iwp) :: is, js, ks, istat
10626
10627	found = .TRUE.
10628	var = TRIM(variable)
10629
10630	!-- check if variable belongs to radiation related variables (starts with rad or rtm)
10631	IF ( len(var) < 3_iwp ) THEN
10632	found = .FALSE.
10633	RETURN
10634	ENDIF
10635
10636	IF ( var(1:3) /= 'rad' .AND. var(1:3) /= 'rtm' ) THEN
10637	found = .FALSE.
10638	RETURN
10639	ENDIF
10640
10641	ids = -1
10642	DO i = 0, nd-1
10643	k = len(TRIM(var))
10644	j = len(TRIM(dirname(i)))
10645	IF ( k-j+1 >= 1_iwp ) THEN
10646	IF ( TRIM(var(k-j+1:k)) == TRIM(dirname(i)) ) THEN
10647	ids = i
10648	idsint_u = dirint_u(ids)
10649	idsint_l = dirint_l(ids)
10650	var = var(:k-j)
10651	EXIT
10652	ENDIF
10653	ENDIF
10654	ENDDO
10655	IF ( ids == -1 ) THEN
10656	var = TRIM(variable)
10657	ENDIF
10658
10659	IF ( (var(1:8) == 'rtm_svf_' .OR. var(1:8) == 'rtm_dif_') .AND. len(TRIM(var)) >= 13 ) THEN
10660	!-- svf values to particular surface
10661	surfid = var(9:)
10662	i = index(surfid,'_')
10663	j = index(surfid(i+1:),'_')
10664	READ(surfid(1:i-1),*, iostat=istat ) is
10665	IF ( istat == 0 ) THEN
10666	READ(surfid(i+1:i+j-1),*, iostat=istat ) js
10667	ENDIF
10668	IF ( istat == 0 ) THEN
10669	READ(surfid(i+j+1:),*, iostat=istat ) ks
10670	ENDIF
10671	IF ( istat == 0 ) THEN
10672	var = var(1:7)
10673	ENDIF
10674	ENDIF
10675
10676	local_pf = fill_value
10677
10678	SELECT CASE ( TRIM( var ) )
10679	!-- block of large scale radiation model (e.g. RRTMG) output variables
10680	CASE ( 'rad_sw_in' )
10681	IF ( av == 0 ) THEN
10682	DO i = nxl, nxr
10683	DO j = nys, nyn
10684	DO k = nzb_do, nzt_do
10685	local_pf(i,j,k) = rad_sw_in(k,j,i)
10686	ENDDO
10687	ENDDO
10688	ENDDO
10689	ELSE
10690	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
10691	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10692	rad_sw_in_av = REAL( fill_value, KIND = wp )
10693	ENDIF
10694	DO i = nxl, nxr
10695	DO j = nys, nyn
10696	DO k = nzb_do, nzt_do
10697	local_pf(i,j,k) = rad_sw_in_av(k,j,i)
10698	ENDDO
10699	ENDDO
10700	ENDDO
10701	ENDIF
10702
10703	CASE ( 'rad_sw_out' )
10704	IF ( av == 0 ) THEN
10705	DO i = nxl, nxr
10706	DO j = nys, nyn
10707	DO k = nzb_do, nzt_do
10708	local_pf(i,j,k) = rad_sw_out(k,j,i)
10709	ENDDO
10710	ENDDO
10711	ENDDO
10712	ELSE
10713	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
10714	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10715	rad_sw_out_av = REAL( fill_value, KIND = wp )
10716	ENDIF
10717	DO i = nxl, nxr
10718	DO j = nys, nyn
10719	DO k = nzb_do, nzt_do
10720	local_pf(i,j,k) = rad_sw_out_av(k,j,i)
10721	ENDDO
10722	ENDDO
10723	ENDDO
10724	ENDIF
10725
10726	CASE ( 'rad_sw_cs_hr' )
10727	IF ( av == 0 ) THEN
10728	DO i = nxl, nxr
10729	DO j = nys, nyn
10730	DO k = nzb_do, nzt_do
10731	local_pf(i,j,k) = rad_sw_cs_hr(k,j,i)
10732	ENDDO
10733	ENDDO
10734	ENDDO
10735	ELSE
10736	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
10737	ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10738	rad_sw_cs_hr_av = REAL( fill_value, KIND = wp )
10739	ENDIF
10740	DO i = nxl, nxr
10741	DO j = nys, nyn
10742	DO k = nzb_do, nzt_do
10743	local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i)
10744	ENDDO
10745	ENDDO
10746	ENDDO
10747	ENDIF
10748
10749	CASE ( 'rad_sw_hr' )
10750	IF ( av == 0 ) THEN
10751	DO i = nxl, nxr
10752	DO j = nys, nyn
10753	DO k = nzb_do, nzt_do
10754	local_pf(i,j,k) = rad_sw_hr(k,j,i)
10755	ENDDO
10756	ENDDO
10757	ENDDO
10758	ELSE
10759	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
10760	ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10761	rad_sw_hr_av = REAL( fill_value, KIND = wp )
10762	ENDIF
10763	DO i = nxl, nxr
10764	DO j = nys, nyn
10765	DO k = nzb_do, nzt_do
10766	local_pf(i,j,k) = rad_sw_hr_av(k,j,i)
10767	ENDDO
10768	ENDDO
10769	ENDDO
10770	ENDIF
10771
10772	CASE ( 'rad_lw_in' )
10773	IF ( av == 0 ) THEN
10774	DO i = nxl, nxr
10775	DO j = nys, nyn
10776	DO k = nzb_do, nzt_do
10777	local_pf(i,j,k) = rad_lw_in(k,j,i)
10778	ENDDO
10779	ENDDO
10780	ENDDO
10781	ELSE
10782	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
10783	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10784	rad_lw_in_av = REAL( fill_value, KIND = wp )
10785	ENDIF
10786	DO i = nxl, nxr
10787	DO j = nys, nyn
10788	DO k = nzb_do, nzt_do
10789	local_pf(i,j,k) = rad_lw_in_av(k,j,i)
10790	ENDDO
10791	ENDDO
10792	ENDDO
10793	ENDIF
10794
10795	CASE ( 'rad_lw_out' )
10796	IF ( av == 0 ) THEN
10797	DO i = nxl, nxr
10798	DO j = nys, nyn
10799	DO k = nzb_do, nzt_do
10800	local_pf(i,j,k) = rad_lw_out(k,j,i)
10801	ENDDO
10802	ENDDO
10803	ENDDO
10804	ELSE
10805	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
10806	ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10807	rad_lw_out_av = REAL( fill_value, KIND = wp )
10808	ENDIF
10809	DO i = nxl, nxr
10810	DO j = nys, nyn
10811	DO k = nzb_do, nzt_do
10812	local_pf(i,j,k) = rad_lw_out_av(k,j,i)
10813	ENDDO
10814	ENDDO
10815	ENDDO
10816	ENDIF
10817
10818	CASE ( 'rad_lw_cs_hr' )
10819	IF ( av == 0 ) THEN
10820	DO i = nxl, nxr
10821	DO j = nys, nyn
10822	DO k = nzb_do, nzt_do
10823	local_pf(i,j,k) = rad_lw_cs_hr(k,j,i)
10824	ENDDO
10825	ENDDO
10826	ENDDO
10827	ELSE
10828	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
10829	ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10830	rad_lw_cs_hr_av = REAL( fill_value, KIND = wp )
10831	ENDIF
10832	DO i = nxl, nxr
10833	DO j = nys, nyn
10834	DO k = nzb_do, nzt_do
10835	local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i)
10836	ENDDO
10837	ENDDO
10838	ENDDO
10839	ENDIF
10840
10841	CASE ( 'rad_lw_hr' )
10842	IF ( av == 0 ) THEN
10843	DO i = nxl, nxr
10844	DO j = nys, nyn
10845	DO k = nzb_do, nzt_do
10846	local_pf(i,j,k) = rad_lw_hr(k,j,i)
10847	ENDDO
10848	ENDDO
10849	ENDDO
10850	ELSE
10851	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
10852	ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10853	rad_lw_hr_av = REAL( fill_value, KIND = wp )
10854	ENDIF
10855	DO i = nxl, nxr
10856	DO j = nys, nyn
10857	DO k = nzb_do, nzt_do
10858	local_pf(i,j,k) = rad_lw_hr_av(k,j,i)
10859	ENDDO
10860	ENDDO
10861	ENDDO
10862	ENDIF
10863
10864	CASE ( 'rtm_rad_net' )
10865	!-- array of complete radiation balance
10866	DO isurf = dirstart(ids), dirend(ids)
10867	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10868	IF ( av == 0 ) THEN
10869	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = &
10870	surfinsw(isurf) - surfoutsw(isurf) + surfinlw(isurf) - surfoutlw(isurf)
10871	ELSE
10872	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfradnet_av(isurf)
10873	ENDIF
10874	ENDIF
10875	ENDDO
10876
10877	CASE ( 'rtm_rad_insw' )
10878	!-- array of sw radiation falling to surface after i-th reflection
10879	DO isurf = dirstart(ids), dirend(ids)
10880	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10881	IF ( av == 0 ) THEN
10882	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinsw(isurf)
10883	ELSE
10884	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinsw_av(isurf)
10885	ENDIF
10886	ENDIF
10887	ENDDO
10888
10889	CASE ( 'rtm_rad_inlw' )
10890	!-- array of lw radiation falling to surface after i-th reflection
10891	DO isurf = dirstart(ids), dirend(ids)
10892	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10893	IF ( av == 0 ) THEN
10894	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw(isurf)
10895	ELSE
10896	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw_av(isurf)
10897	ENDIF
10898	ENDIF
10899	ENDDO
10900
10901	CASE ( 'rtm_rad_inswdir' )
10902	!-- array of direct sw radiation falling to surface from sun
10903	DO isurf = dirstart(ids), dirend(ids)
10904	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10905	IF ( av == 0 ) THEN
10906	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdir(isurf)
10907	ELSE
10908	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdir_av(isurf)
10909	ENDIF
10910	ENDIF
10911	ENDDO
10912
10913	CASE ( 'rtm_rad_inswdif' )
10914	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
10915	DO isurf = dirstart(ids), dirend(ids)
10916	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10917	IF ( av == 0 ) THEN
10918	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdif(isurf)
10919	ELSE
10920	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdif_av(isurf)
10921	ENDIF
10922	ENDIF
10923	ENDDO
10924
10925	CASE ( 'rtm_rad_inswref' )
10926	!-- array of sw radiation falling to surface from reflections
10927	DO isurf = dirstart(ids), dirend(ids)
10928	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10929	IF ( av == 0 ) THEN
10930	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = &
10931	surfinsw(isurf) - surfinswdir(isurf) - surfinswdif(isurf)
10932	ELSE
10933	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswref_av(isurf)
10934	ENDIF
10935	ENDIF
10936	ENDDO
10937
10938	CASE ( 'rtm_rad_inlwdif' )
10939	!-- array of difusion lw radiation falling to surface from sky and borders of the domain
10940	DO isurf = dirstart(ids), dirend(ids)
10941	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10942	IF ( av == 0 ) THEN
10943	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwdif(isurf)
10944	ELSE
10945	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwdif_av(isurf)
10946	ENDIF
10947	ENDIF
10948	ENDDO
10949
10950	CASE ( 'rtm_rad_inlwref' )
10951	!-- array of lw radiation falling to surface from reflections
10952	DO isurf = dirstart(ids), dirend(ids)
10953	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10954	IF ( av == 0 ) THEN
10955	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw(isurf) - surfinlwdif(isurf)
10956	ELSE
10957	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwref_av(isurf)
10958	ENDIF
10959	ENDIF
10960	ENDDO
10961
10962	CASE ( 'rtm_rad_outsw' )
10963	!-- array of sw radiation emitted from surface after i-th reflection
10964	DO isurf = dirstart(ids), dirend(ids)
10965	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10966	IF ( av == 0 ) THEN
10967	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutsw(isurf)
10968	ELSE
10969	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutsw_av(isurf)
10970	ENDIF
10971	ENDIF
10972	ENDDO
10973
10974	CASE ( 'rtm_rad_outlw' )
10975	!-- array of lw radiation emitted from surface after i-th reflection
10976	DO isurf = dirstart(ids), dirend(ids)
10977	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10978	IF ( av == 0 ) THEN
10979	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutlw(isurf)
10980	ELSE
10981	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutlw_av(isurf)
10982	ENDIF
10983	ENDIF
10984	ENDDO
10985
10986	CASE ( 'rtm_rad_ressw' )
10987	!-- average of array of residua of sw radiation absorbed in surface after last reflection
10988	DO isurf = dirstart(ids), dirend(ids)
10989	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10990	IF ( av == 0 ) THEN
10991	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfins(isurf)
10992	ELSE
10993	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfins_av(isurf)
10994	ENDIF
10995	ENDIF
10996	ENDDO
10997
10998	CASE ( 'rtm_rad_reslw' )
10999	!-- average of array of residua of lw radiation absorbed in surface after last reflection
11000	DO isurf = dirstart(ids), dirend(ids)
11001	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11002	IF ( av == 0 ) THEN
11003	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinl(isurf)
11004	ELSE
11005	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinl_av(isurf)
11006	ENDIF
11007	ENDIF
11008	ENDDO
11009
11010	CASE ( 'rtm_rad_pc_inlw' )
11011	!-- array of lw radiation absorbed by plant canopy
11012	DO ipcgb = 1, npcbl
11013	IF ( av == 0 ) THEN
11014	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinlw(ipcgb)
11015	ELSE
11016	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinlw_av(ipcgb)
11017	ENDIF
11018	ENDDO
11019
11020	CASE ( 'rtm_rad_pc_insw' )
11021	!-- array of sw radiation absorbed by plant canopy
11022	DO ipcgb = 1, npcbl
11023	IF ( av == 0 ) THEN
11024	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinsw(ipcgb)
11025	ELSE
11026	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinsw_av(ipcgb)
11027	ENDIF
11028	ENDDO
11029
11030	CASE ( 'rtm_rad_pc_inswdir' )
11031	!-- array of direct sw radiation absorbed by plant canopy
11032	DO ipcgb = 1, npcbl
11033	IF ( av == 0 ) THEN
11034	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdir(ipcgb)
11035	ELSE
11036	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdir_av(ipcgb)
11037	ENDIF
11038	ENDDO
11039
11040	CASE ( 'rtm_rad_pc_inswdif' )
11041	!-- array of diffuse sw radiation absorbed by plant canopy
11042	DO ipcgb = 1, npcbl
11043	IF ( av == 0 ) THEN
11044	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdif(ipcgb)
11045	ELSE
11046	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdif_av(ipcgb)
11047	ENDIF
11048	ENDDO
11049
11050	CASE ( 'rtm_rad_pc_inswref' )
11051	!-- array of reflected sw radiation absorbed by plant canopy
11052	DO ipcgb = 1, npcbl
11053	IF ( av == 0 ) THEN
11054	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = &
11055	pcbinsw(ipcgb) - pcbinswdir(ipcgb) - pcbinswdif(ipcgb)
11056	ELSE
11057	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswref_av(ipcgb)
11058	ENDIF
11059	ENDDO
11060
11061	CASE ( 'rtm_mrt_sw' )
11062	local_pf = REAL( fill_value, KIND = wp )
11063	IF ( av == 0 ) THEN
11064	DO l = 1, nmrtbl
11065	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinsw(l)
11066	ENDDO
11067	ELSE
11068	IF ( ALLOCATED( mrtinsw_av ) ) THEN
11069	DO l = 1, nmrtbl
11070	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinsw_av(l)
11071	ENDDO
11072	ENDIF
11073	ENDIF
11074
11075	CASE ( 'rtm_mrt_lw' )
11076	local_pf = REAL( fill_value, KIND = wp )
11077	IF ( av == 0 ) THEN
11078	DO l = 1, nmrtbl
11079	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinlw(l)
11080	ENDDO
11081	ELSE
11082	IF ( ALLOCATED( mrtinlw_av ) ) THEN
11083	DO l = 1, nmrtbl
11084	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinlw_av(l)
11085	ENDDO
11086	ENDIF
11087	ENDIF
11088
11089	CASE ( 'rtm_mrt' )
11090	local_pf = REAL( fill_value, KIND = wp )
11091	IF ( av == 0 ) THEN
11092	DO l = 1, nmrtbl
11093	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrt(l)
11094	ENDDO
11095	ELSE
11096	IF ( ALLOCATED( mrt_av ) ) THEN
11097	DO l = 1, nmrtbl
11098	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrt_av(l)
11099	ENDDO
11100	ENDIF
11101	ENDIF
11102	!
11103	!-- block of RTM output variables
11104	!-- variables are intended mainly for debugging and detailed analyse purposes
11105	CASE ( 'rtm_skyvf' )
11106	!
11107	!-- sky view factor
11108	DO isurf = dirstart(ids), dirend(ids)
11109	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11110	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = skyvf(isurf)
11111	ENDIF
11112	ENDDO
11113
11114	CASE ( 'rtm_skyvft' )
11115	!
11116	!-- sky view factor
11117	DO isurf = dirstart(ids), dirend(ids)
11118	IF ( surfl(id,isurf) == ids ) THEN
11119	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = skyvft(isurf)
11120	ENDIF
11121	ENDDO
11122
11123	CASE ( 'rtm_svf', 'rtm_dif' )
11124	!
11125	!-- shape view factors or iradiance factors to selected surface
11126	IF ( TRIM(var)=='rtm_svf' ) THEN
11127	k = 1
11128	ELSE
11129	k = 2
11130	ENDIF
11131	DO isvf = 1, nsvfl
11132	isurflt = svfsurf(1, isvf)
11133	isurfs = svfsurf(2, isvf)
11134
11135	IF ( surf(ix,isurfs) == is .AND. surf(iy,isurfs) == js .AND. surf(iz,isurfs) == ks .AND. &
11136	(surf(id,isurfs) == idsint_u .OR. surfl(id,isurfs) == idsint_l ) ) THEN
11137	!
11138	!-- correct source surface
11139	local_pf(surfl(ix,isurflt),surfl(iy,isurflt),surfl(iz,isurflt)) = svf(k,isvf)
11140	ENDIF
11141	ENDDO
11142
11143	CASE ( 'rtm_surfalb' )
11144	!
11145	!-- surface albedo
11146	DO isurf = dirstart(ids), dirend(ids)
11147	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11148	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = albedo_surf(isurf)
11149	ENDIF
11150	ENDDO
11151
11152	CASE ( 'rtm_surfemis' )
11153	!
11154	!-- surface emissivity, weighted average
11155	DO isurf = dirstart(ids), dirend(ids)
11156	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11157	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = emiss_surf(isurf)
11158	ENDIF
11159	ENDDO
11160
11161	CASE DEFAULT
11162	found = .FALSE.
11163
11164	END SELECT
11165
11166
11167	END SUBROUTINE radiation_data_output_3d
11168
11169	!------------------------------------------------------------------------------!
11170	!
11171	! Description:
11172	! ------------
11173	!> Subroutine defining masked data output
11174	!------------------------------------------------------------------------------!
11175	SUBROUTINE radiation_data_output_mask( av, variable, found, local_pf, mid )
11176
11177	USE control_parameters
11178
11179	USE indices
11180
11181	USE kinds
11182
11183
11184	IMPLICIT NONE
11185
11186	CHARACTER (LEN=*) :: variable !<
11187
11188	CHARACTER(LEN=5) :: grid !< flag to distinquish between staggered grids
11189
11190	INTEGER(iwp) :: av !<
11191	INTEGER(iwp) :: i !<
11192	INTEGER(iwp) :: j !<
11193	INTEGER(iwp) :: k !<
11194	INTEGER(iwp) :: mid !< masked output running index
11195	INTEGER(iwp) :: topo_top_index !< k index of highest horizontal surface
11196
11197	LOGICAL :: found !< true if output array was found
11198	LOGICAL :: resorted !< true if array is resorted
11199
11200
11201	REAL(wp), &
11202	DIMENSION(mask_size_l(mid,1),mask_size_l(mid,2),mask_size_l(mid,3)) :: &
11203	local_pf !<
11204
11205	REAL(wp), DIMENSION(:,:,:), POINTER :: to_be_resorted !< points to array which needs to be resorted for output
11206
11207
11208	found = .TRUE.
11209	grid = 's'
11210	resorted = .FALSE.
11211
11212	SELECT CASE ( TRIM( variable ) )
11213
11214
11215	CASE ( 'rad_lw_in' )
11216	IF ( av == 0 ) THEN
11217	to_be_resorted => rad_lw_in
11218	ELSE
11219	to_be_resorted => rad_lw_in_av
11220	ENDIF
11221
11222	CASE ( 'rad_lw_out' )
11223	IF ( av == 0 ) THEN
11224	to_be_resorted => rad_lw_out
11225	ELSE
11226	to_be_resorted => rad_lw_out_av
11227	ENDIF
11228
11229	CASE ( 'rad_lw_cs_hr' )
11230	IF ( av == 0 ) THEN
11231	to_be_resorted => rad_lw_cs_hr
11232	ELSE
11233	to_be_resorted => rad_lw_cs_hr_av
11234	ENDIF
11235
11236	CASE ( 'rad_lw_hr' )
11237	IF ( av == 0 ) THEN
11238	to_be_resorted => rad_lw_hr
11239	ELSE
11240	to_be_resorted => rad_lw_hr_av
11241	ENDIF
11242
11243	CASE ( 'rad_sw_in' )
11244	IF ( av == 0 ) THEN
11245	to_be_resorted => rad_sw_in
11246	ELSE
11247	to_be_resorted => rad_sw_in_av
11248	ENDIF
11249
11250	CASE ( 'rad_sw_out' )
11251	IF ( av == 0 ) THEN
11252	to_be_resorted => rad_sw_out
11253	ELSE
11254	to_be_resorted => rad_sw_out_av
11255	ENDIF
11256
11257	CASE ( 'rad_sw_cs_hr' )
11258	IF ( av == 0 ) THEN
11259	to_be_resorted => rad_sw_cs_hr
11260	ELSE
11261	to_be_resorted => rad_sw_cs_hr_av
11262	ENDIF
11263
11264	CASE ( 'rad_sw_hr' )
11265	IF ( av == 0 ) THEN
11266	to_be_resorted => rad_sw_hr
11267	ELSE
11268	to_be_resorted => rad_sw_hr_av
11269	ENDIF
11270
11271	CASE DEFAULT
11272	found = .FALSE.
11273
11274	END SELECT
11275
11276	!
11277	!-- Resort the array to be output, if not done above
11278	IF ( found .AND. .NOT. resorted ) THEN
11279	IF ( .NOT. mask_surface(mid) ) THEN
11280	!
11281	!-- Default masked output
11282	DO i = 1, mask_size_l(mid,1)
11283	DO j = 1, mask_size_l(mid,2)
11284	DO k = 1, mask_size_l(mid,3)
11285	local_pf(i,j,k) = to_be_resorted(mask_k(mid,k), &
11286	mask_j(mid,j),mask_i(mid,i))
11287	ENDDO
11288	ENDDO
11289	ENDDO
11290
11291	ELSE
11292	!
11293	!-- Terrain-following masked output
11294	DO i = 1, mask_size_l(mid,1)
11295	DO j = 1, mask_size_l(mid,2)
11296	!
11297	!-- Get k index of highest horizontal surface
11298	topo_top_index = topo_top_ind(mask_j(mid,j), &
11299	mask_i(mid,i), &
11300	0 )
11301	!
11302	!-- Save output array
11303	DO k = 1, mask_size_l(mid,3)
11304	local_pf(i,j,k) = to_be_resorted( &
11305	MIN( topo_top_index+mask_k(mid,k), &
11306	nzt+1 ), &
11307	mask_j(mid,j), &
11308	mask_i(mid,i) )
11309	ENDDO
11310	ENDDO
11311	ENDDO
11312
11313	ENDIF
11314	ENDIF
11315
11316
11317
11318	END SUBROUTINE radiation_data_output_mask
11319
11320
11321	!------------------------------------------------------------------------------!
11322	! Description:
11323	! ------------
11324	!> Subroutine writes local (subdomain) restart data
11325	!------------------------------------------------------------------------------!
11326	SUBROUTINE radiation_wrd_local
11327
11328
11329	IMPLICIT NONE
11330
11331
11332	IF ( ALLOCATED( rad_net_av ) ) THEN
11333	CALL wrd_write_string( 'rad_net_av' )
11334	WRITE ( 14 ) rad_net_av
11335	ENDIF
11336
11337	IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
11338	CALL wrd_write_string( 'rad_lw_in_xy_av' )
11339	WRITE ( 14 ) rad_lw_in_xy_av
11340	ENDIF
11341
11342	IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
11343	CALL wrd_write_string( 'rad_lw_out_xy_av' )
11344	WRITE ( 14 ) rad_lw_out_xy_av
11345	ENDIF
11346
11347	IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
11348	CALL wrd_write_string( 'rad_sw_in_xy_av' )
11349	WRITE ( 14 ) rad_sw_in_xy_av
11350	ENDIF
11351
11352	IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
11353	CALL wrd_write_string( 'rad_sw_out_xy_av' )
11354	WRITE ( 14 ) rad_sw_out_xy_av
11355	ENDIF
11356
11357	IF ( ALLOCATED( rad_lw_in ) ) THEN
11358	CALL wrd_write_string( 'rad_lw_in' )
11359	WRITE ( 14 ) rad_lw_in
11360	ENDIF
11361
11362	IF ( ALLOCATED( rad_lw_in_av ) ) THEN
11363	CALL wrd_write_string( 'rad_lw_in_av' )
11364	WRITE ( 14 ) rad_lw_in_av
11365	ENDIF
11366
11367	IF ( ALLOCATED( rad_lw_out ) ) THEN
11368	CALL wrd_write_string( 'rad_lw_out' )
11369	WRITE ( 14 ) rad_lw_out
11370	ENDIF
11371
11372	IF ( ALLOCATED( rad_lw_out_av) ) THEN
11373	CALL wrd_write_string( 'rad_lw_out_av' )
11374	WRITE ( 14 ) rad_lw_out_av
11375	ENDIF
11376
11377	IF ( ALLOCATED( rad_lw_cs_hr) ) THEN
11378	CALL wrd_write_string( 'rad_lw_cs_hr' )
11379	WRITE ( 14 ) rad_lw_cs_hr
11380	ENDIF
11381
11382	IF ( ALLOCATED( rad_lw_cs_hr_av) ) THEN
11383	CALL wrd_write_string( 'rad_lw_cs_hr_av' )
11384	WRITE ( 14 ) rad_lw_cs_hr_av
11385	ENDIF
11386
11387	IF ( ALLOCATED( rad_lw_hr) ) THEN
11388	CALL wrd_write_string( 'rad_lw_hr' )
11389	WRITE ( 14 ) rad_lw_hr
11390	ENDIF
11391
11392	IF ( ALLOCATED( rad_lw_hr_av) ) THEN
11393	CALL wrd_write_string( 'rad_lw_hr_av' )
11394	WRITE ( 14 ) rad_lw_hr_av
11395	ENDIF
11396
11397	IF ( ALLOCATED( rad_sw_in) ) THEN
11398	CALL wrd_write_string( 'rad_sw_in' )
11399	WRITE ( 14 ) rad_sw_in
11400	ENDIF
11401
11402	IF ( ALLOCATED( rad_sw_in_av) ) THEN
11403	CALL wrd_write_string( 'rad_sw_in_av' )
11404	WRITE ( 14 ) rad_sw_in_av
11405	ENDIF
11406
11407	IF ( ALLOCATED( rad_sw_out) ) THEN
11408	CALL wrd_write_string( 'rad_sw_out' )
11409	WRITE ( 14 ) rad_sw_out
11410	ENDIF
11411
11412	IF ( ALLOCATED( rad_sw_out_av) ) THEN
11413	CALL wrd_write_string( 'rad_sw_out_av' )
11414	WRITE ( 14 ) rad_sw_out_av
11415	ENDIF
11416
11417	IF ( ALLOCATED( rad_sw_cs_hr) ) THEN
11418	CALL wrd_write_string( 'rad_sw_cs_hr' )
11419	WRITE ( 14 ) rad_sw_cs_hr
11420	ENDIF
11421
11422	IF ( ALLOCATED( rad_sw_cs_hr_av) ) THEN
11423	CALL wrd_write_string( 'rad_sw_cs_hr_av' )
11424	WRITE ( 14 ) rad_sw_cs_hr_av
11425	ENDIF
11426
11427	IF ( ALLOCATED( rad_sw_hr) ) THEN
11428	CALL wrd_write_string( 'rad_sw_hr' )
11429	WRITE ( 14 ) rad_sw_hr
11430	ENDIF
11431
11432	IF ( ALLOCATED( rad_sw_hr_av) ) THEN
11433	CALL wrd_write_string( 'rad_sw_hr_av' )
11434	WRITE ( 14 ) rad_sw_hr_av
11435	ENDIF
11436
11437
11438	END SUBROUTINE radiation_wrd_local
11439
11440	!------------------------------------------------------------------------------!
11441	! Description:
11442	! ------------
11443	!> Subroutine reads local (subdomain) restart data
11444	!------------------------------------------------------------------------------!
11445	SUBROUTINE radiation_rrd_local( k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, &
11446	nxr_on_file, nynf, nync, nyn_on_file, nysf, &
11447	nysc, nys_on_file, tmp_2d, tmp_3d, found )
11448
11449
11450	USE control_parameters
11451
11452	USE indices
11453
11454	USE kinds
11455
11456	USE pegrid
11457
11458
11459	IMPLICIT NONE
11460
11461	INTEGER(iwp) :: k !<
11462	INTEGER(iwp) :: nxlc !<
11463	INTEGER(iwp) :: nxlf !<
11464	INTEGER(iwp) :: nxl_on_file !<
11465	INTEGER(iwp) :: nxrc !<
11466	INTEGER(iwp) :: nxrf !<
11467	INTEGER(iwp) :: nxr_on_file !<
11468	INTEGER(iwp) :: nync !<
11469	INTEGER(iwp) :: nynf !<
11470	INTEGER(iwp) :: nyn_on_file !<
11471	INTEGER(iwp) :: nysc !<
11472	INTEGER(iwp) :: nysf !<
11473	INTEGER(iwp) :: nys_on_file !<
11474
11475	LOGICAL, INTENT(OUT) :: found
11476
11477	REAL(wp), DIMENSION(nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_2d !<
11478
11479	REAL(wp), DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d !<
11480
11481	REAL(wp), DIMENSION(0:0,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d2 !<
11482
11483
11484	found = .TRUE.
11485
11486
11487	SELECT CASE ( restart_string(1:length) )
11488
11489	CASE ( 'rad_net_av' )
11490	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
11491	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
11492	ENDIF
11493	IF ( k == 1 ) READ ( 13 ) tmp_2d
11494	rad_net_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11495	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11496
11497	CASE ( 'rad_lw_in_xy_av' )
11498	IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
11499	ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
11500	ENDIF
11501	IF ( k == 1 ) READ ( 13 ) tmp_2d
11502	rad_lw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11503	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11504
11505	CASE ( 'rad_lw_out_xy_av' )
11506	IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
11507	ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
11508	ENDIF
11509	IF ( k == 1 ) READ ( 13 ) tmp_2d
11510	rad_lw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11511	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11512
11513	CASE ( 'rad_sw_in_xy_av' )
11514	IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
11515	ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
11516	ENDIF
11517	IF ( k == 1 ) READ ( 13 ) tmp_2d
11518	rad_sw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11519	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11520
11521	CASE ( 'rad_sw_out_xy_av' )
11522	IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
11523	ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
11524	ENDIF
11525	IF ( k == 1 ) READ ( 13 ) tmp_2d
11526	rad_sw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11527	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11528
11529	CASE ( 'rad_lw_in' )
11530	IF ( .NOT. ALLOCATED( rad_lw_in ) ) THEN
11531	IF ( radiation_scheme == 'clear-sky' .OR. &
11532	radiation_scheme == 'constant' .OR. &
11533	radiation_scheme == 'external' ) THEN
11534	ALLOCATE( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) )
11535	ELSE
11536	ALLOCATE( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11537	ENDIF
11538	ENDIF
11539	IF ( k == 1 ) THEN
11540	IF ( radiation_scheme == 'clear-sky' .OR. &
11541	radiation_scheme == 'constant' .OR. &
11542	radiation_scheme == 'external' ) THEN
11543	READ ( 13 ) tmp_3d2
11544	rad_lw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11545	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11546	ELSE
11547	READ ( 13 ) tmp_3d
11548	rad_lw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11549	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11550	ENDIF
11551	ENDIF
11552
11553	CASE ( 'rad_lw_in_av' )
11554	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
11555	IF ( radiation_scheme == 'clear-sky' .OR. &
11556	radiation_scheme == 'constant' .OR. &
11557	radiation_scheme == 'external' ) THEN
11558	ALLOCATE( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
11559	ELSE
11560	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11561	ENDIF
11562	ENDIF
11563	IF ( k == 1 ) THEN
11564	IF ( radiation_scheme == 'clear-sky' .OR. &
11565	radiation_scheme == 'constant' .OR. &
11566	radiation_scheme == 'external' ) THEN
11567	READ ( 13 ) tmp_3d2
11568	rad_lw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&
11569	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11570	ELSE
11571	READ ( 13 ) tmp_3d
11572	rad_lw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11573	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11574	ENDIF
11575	ENDIF
11576
11577	CASE ( 'rad_lw_out' )
11578	IF ( .NOT. ALLOCATED( rad_lw_out ) ) THEN
11579	IF ( radiation_scheme == 'clear-sky' .OR. &
11580	radiation_scheme == 'constant' .OR. &
11581	radiation_scheme == 'external' ) THEN
11582	ALLOCATE( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) )
11583	ELSE
11584	ALLOCATE( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11585	ENDIF
11586	ENDIF
11587	IF ( k == 1 ) THEN
11588	IF ( radiation_scheme == 'clear-sky' .OR. &
11589	radiation_scheme == 'constant' .OR. &
11590	radiation_scheme == 'external' ) THEN
11591	READ ( 13 ) tmp_3d2
11592	rad_lw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11593	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11594	ELSE
11595	READ ( 13 ) tmp_3d
11596	rad_lw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11597	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11598	ENDIF
11599	ENDIF
11600
11601	CASE ( 'rad_lw_out_av' )
11602	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
11603	IF ( radiation_scheme == 'clear-sky' .OR. &
11604	radiation_scheme == 'constant' .OR. &
11605	radiation_scheme == 'external' ) THEN
11606	ALLOCATE( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
11607	ELSE
11608	ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11609	ENDIF
11610	ENDIF
11611	IF ( k == 1 ) THEN
11612	IF ( radiation_scheme == 'clear-sky' .OR. &
11613	radiation_scheme == 'constant' .OR. &
11614	radiation_scheme == 'external' ) THEN
11615	READ ( 13 ) tmp_3d2
11616	rad_lw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) &
11617	= tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11618	ELSE
11619	READ ( 13 ) tmp_3d
11620	rad_lw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11621	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11622	ENDIF
11623	ENDIF
11624
11625	CASE ( 'rad_lw_cs_hr' )
11626	IF ( .NOT. ALLOCATED( rad_lw_cs_hr ) ) THEN
11627	ALLOCATE( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11628	ENDIF
11629	IF ( k == 1 ) READ ( 13 ) tmp_3d
11630	rad_lw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11631	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11632
11633	CASE ( 'rad_lw_cs_hr_av' )
11634	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
11635	ALLOCATE( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11636	ENDIF
11637	IF ( k == 1 ) READ ( 13 ) tmp_3d
11638	rad_lw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11639	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11640
11641	CASE ( 'rad_lw_hr' )
11642	IF ( .NOT. ALLOCATED( rad_lw_hr ) ) THEN
11643	ALLOCATE( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11644	ENDIF
11645	IF ( k == 1 ) READ ( 13 ) tmp_3d
11646	rad_lw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11647	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11648
11649	CASE ( 'rad_lw_hr_av' )
11650	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
11651	ALLOCATE( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11652	ENDIF
11653	IF ( k == 1 ) READ ( 13 ) tmp_3d
11654	rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11655	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11656
11657	CASE ( 'rad_sw_in' )
11658	IF ( .NOT. ALLOCATED( rad_sw_in ) ) THEN
11659	IF ( radiation_scheme == 'clear-sky' .OR. &
11660	radiation_scheme == 'constant' .OR. &
11661	radiation_scheme == 'external' ) THEN
11662	ALLOCATE( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) )
11663	ELSE
11664	ALLOCATE( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11665	ENDIF
11666	ENDIF
11667	IF ( k == 1 ) THEN
11668	IF ( radiation_scheme == 'clear-sky' .OR. &
11669	radiation_scheme == 'constant' .OR. &
11670	radiation_scheme == 'external' ) THEN
11671	READ ( 13 ) tmp_3d2
11672	rad_sw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11673	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11674	ELSE
11675	READ ( 13 ) tmp_3d
11676	rad_sw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11677	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11678	ENDIF
11679	ENDIF
11680
11681	CASE ( 'rad_sw_in_av' )
11682	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
11683	IF ( radiation_scheme == 'clear-sky' .OR. &
11684	radiation_scheme == 'constant' .OR. &
11685	radiation_scheme == 'external' ) THEN
11686	ALLOCATE( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
11687	ELSE
11688	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11689	ENDIF
11690	ENDIF
11691	IF ( k == 1 ) THEN
11692	IF ( radiation_scheme == 'clear-sky' .OR. &
11693	radiation_scheme == 'constant' .OR. &
11694	radiation_scheme == 'external' ) THEN
11695	READ ( 13 ) tmp_3d2
11696	rad_sw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&
11697	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11698	ELSE
11699	READ ( 13 ) tmp_3d
11700	rad_sw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11701	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11702	ENDIF
11703	ENDIF
11704
11705	CASE ( 'rad_sw_out' )
11706	IF ( .NOT. ALLOCATED( rad_sw_out ) ) THEN
11707	IF ( radiation_scheme == 'clear-sky' .OR. &
11708	radiation_scheme == 'constant' .OR. &
11709	radiation_scheme == 'external' ) THEN
11710	ALLOCATE( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) )
11711	ELSE
11712	ALLOCATE( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11713	ENDIF
11714	ENDIF
11715	IF ( k == 1 ) THEN
11716	IF ( radiation_scheme == 'clear-sky' .OR. &
11717	radiation_scheme == 'constant' .OR. &
11718	radiation_scheme == 'external' ) THEN
11719	READ ( 13 ) tmp_3d2
11720	rad_sw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11721	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11722	ELSE
11723	READ ( 13 ) tmp_3d
11724	rad_sw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11725	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11726	ENDIF
11727	ENDIF
11728
11729	CASE ( 'rad_sw_out_av' )
11730	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
11731	IF ( radiation_scheme == 'clear-sky' .OR. &
11732	radiation_scheme == 'constant' .OR. &
11733	radiation_scheme == 'external' ) THEN
11734	ALLOCATE( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
11735	ELSE
11736	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11737	ENDIF
11738	ENDIF
11739	IF ( k == 1 ) THEN
11740	IF ( radiation_scheme == 'clear-sky' .OR. &
11741	radiation_scheme == 'constant' .OR. &
11742	radiation_scheme == 'external' ) THEN
11743	READ ( 13 ) tmp_3d2
11744	rad_sw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) &
11745	= tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11746	ELSE
11747	READ ( 13 ) tmp_3d
11748	rad_sw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11749	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11750	ENDIF
11751	ENDIF
11752
11753	CASE ( 'rad_sw_cs_hr' )
11754	IF ( .NOT. ALLOCATED( rad_sw_cs_hr ) ) THEN
11755	ALLOCATE( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11756	ENDIF
11757	IF ( k == 1 ) READ ( 13 ) tmp_3d
11758	rad_sw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11759	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11760
11761	CASE ( 'rad_sw_cs_hr_av' )
11762	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
11763	ALLOCATE( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11764	ENDIF
11765	IF ( k == 1 ) READ ( 13 ) tmp_3d
11766	rad_sw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11767	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11768
11769	CASE ( 'rad_sw_hr' )
11770	IF ( .NOT. ALLOCATED( rad_sw_hr ) ) THEN
11771	ALLOCATE( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11772	ENDIF
11773	IF ( k == 1 ) READ ( 13 ) tmp_3d
11774	rad_sw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11775	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11776
11777	CASE ( 'rad_sw_hr_av' )
11778	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
11779	ALLOCATE( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11780	ENDIF
11781	IF ( k == 1 ) READ ( 13 ) tmp_3d
11782	rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11783	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11784
11785	CASE DEFAULT
11786
11787	found = .FALSE.
11788
11789	END SELECT
11790
11791	END SUBROUTINE radiation_rrd_local
11792
11793
11794	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 @ 4198

Download in other formats: