Home

Context Navigation

radiation_model_mod.f90 @ 4197

Last change on this file since 4197 was 4197, checked in by suehring, 6 years ago

Revise steering of surface albedo initialization when albedo_pars is provided

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.1 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 4197 2019-08-29 14:33:32Z suehring $
30	! Revise steering of surface albedo initialization when albedo_pars is provided
31	!
32	! 4190 2019-08-27 15:42:37Z suehring
33	! Implement external radiation forcing also for level-of-detail = 2
34	! (horizontally 2D radiation)
35	!
36	! 4188 2019-08-26 14:15:47Z suehring
37	! Minor adjustment in error message
38	!
39	! 4187 2019-08-26 12:43:15Z suehring
40	! - Take external radiation from root domain dynamic input if not provided for
41	! each nested domain
42	! - Combine MPI_ALLREDUCE calls to reduce mpi overhead
43	!
44	! 4182 2019-08-22 15:20:23Z scharf
45	! Corrected "Former revisions" section
46	!
47	! 4179 2019-08-21 11:16:12Z suehring
48	! Remove debug prints
49	!
50	! 4178 2019-08-21 11:13:06Z suehring
51	! External radiation forcing implemented.
52	!
53	! 4168 2019-08-16 13:50:17Z suehring
54	! Replace function get_topography_top_index by topo_top_ind
55	!
56	! 4157 2019-08-14 09:19:12Z suehring
57	! Give informative message on raytracing distance only by core zero
58	!
59	! 4148 2019-08-08 11:26:00Z suehring
60	! Comments added
61	!
62	! 4134 2019-08-02 18:39:57Z suehring
63	! Bugfix in formatted write statement
64	!
65	! 4127 2019-07-30 14:47:10Z suehring
66	! Remove unused pch_index (merge from branch resler)
67	!
68	! 4089 2019-07-11 14:30:27Z suehring
69	! - Correct level 2 initialization of spectral albedos in rrtmg branch, long- and
70	! shortwave albedos were mixed-up.
71	! - Change order of albedo_pars so that it is now consistent with the defined
72	! order of albedo_pars in PIDS
73	!
74	! 4069 2019-07-01 14:05:51Z Giersch
75	! Masked output running index mid has been introduced as a local variable to
76	! avoid runtime error (Loop variable has been modified) in time_integration
77	!
78	! 4067 2019-07-01 13:29:25Z suehring
79	! Bugfix, pass dummy string to MPI_INFO_SET (J. Resler)
80	!
81	! 4039 2019-06-18 10:32:41Z suehring
82	! Bugfix for masked data output
83	!
84	! 4008 2019-05-30 09:50:11Z moh.hefny
85	! Bugfix in check variable when a variable's string is less than 3
86	! characters is processed. All variables now are checked if they
87	! belong to radiation
88	!
89	! 3992 2019-05-22 16:49:38Z suehring
90	! Bugfix in rrtmg radiation branch in a nested run when the lowest prognistic
91	! grid points in a child domain are all inside topography
92	!
93	! 3987 2019-05-22 09:52:13Z kanani
94	! Introduce alternative switch for debug output during timestepping
95	!
96	! 3943 2019-05-02 09:50:41Z maronga
97	! Missing blank characteer added.
98	!
99	! 3900 2019-04-16 15:17:43Z suehring
100	! Fixed initialization problem
101	!
102	! 3885 2019-04-11 11:29:34Z kanani
103	! Changes related to global restructuring of location messages and introduction
104	! of additional debug messages
105	!
106	! 3881 2019-04-10 09:31:22Z suehring
107	! Output of albedo and emissivity moved from USM, bugfixes in initialization
108	! of albedo
109	!
110	! 3861 2019-04-04 06:27:41Z maronga
111	! Bugfix: factor of 4.0 required instead of 3.0 in calculation of rad_lw_out_change_0
112	!
113	! 3859 2019-04-03 20:30:31Z maronga
114	! Added some descriptions
115	!
116	! 3847 2019-04-01 14:51:44Z suehring
117	! Implement check for dt_radiation (must be > 0)
118	!
119	! 3846 2019-04-01 13:55:30Z suehring
120	! unused variable removed
121	!
122	! 3814 2019-03-26 08:40:31Z pavelkrc
123	! Change zenith(0:0) and others to scalar.
124	! Code review.
125	! Rename exported nzu, nzp and related variables due to name conflict
126	!
127	! 3771 2019-02-28 12:19:33Z raasch
128	! rrtmg preprocessor for directives moved/added, save attribute added to temporary
129	! pointers to avoid compiler warnings about outlived pointer targets,
130	! statement added to avoid compiler warning about unused variable
131	!
132	! 3769 2019-02-28 10:16:49Z moh.hefny
133	! removed unused variables and subroutine radiation_radflux_gridbox
134	!
135	! 3767 2019-02-27 08:18:02Z raasch
136	! unused variable for file index removed from rrd-subroutines parameter list
137	!
138	! 3760 2019-02-21 18:47:35Z moh.hefny
139	! Bugfix: initialized simulated_time before calculating solar position
140	! to enable restart option with reading in SVF from file(s).
141	!
142	! 3754 2019-02-19 17:02:26Z kanani
143	! (resler, pavelkrc)
144	! Bugfixes: add further required MRT factors to read/write_svf,
145	! fix for aggregating view factors to eliminate local noise in reflected
146	! irradiance at mutually close surfaces (corners, presence of trees) in the
147	! angular discretization scheme.
148	!
149	! 3752 2019-02-19 09:37:22Z resler
150	! added read/write number of MRT factors to the respective routines
151	!
152	! 3705 2019-01-29 19:56:39Z suehring
153	! Make variables that are sampled in virtual measurement module public
154	!
155	! 3704 2019-01-29 19:51:41Z suehring
156	! Some interface calls moved to module_interface + cleanup
157	!
158	! 3667 2019-01-10 14:26:24Z schwenkel
159	! Modified check for rrtmg input files
160	!
161	! 3655 2019-01-07 16:51:22Z knoop
162	! nopointer option removed
163	!
164	! 1496 2014-12-02 17:25:50Z maronga
165	! Initial revision
166	!
167	!
168	! Description:
169	! ------------
170	!> Radiation models and interfaces
171	!> @todo Replace dz(1) appropriatly to account for grid stretching
172	!> @todo move variable definitions used in radiation_init only to the subroutine
173	!> as they are no longer required after initialization.
174	!> @todo Output of full column vertical profiles used in RRTMG
175	!> @todo Output of other rrtm arrays (such as volume mixing ratios)
176	!> @todo Check for mis-used NINT() calls in raytrace_2d
177	!> RESULT: Original was correct (carefully verified formula), the change
178	!> to INT broke raytracing -- P. Krc
179	!> @todo Optimize radiation_tendency routines
180	!>
181	!> @note Many variables have a leading dummy dimension (0:0) in order to
182	!> match the assume-size shape expected by the RRTMG model.
183	!------------------------------------------------------------------------------!
184	MODULE radiation_model_mod
185
186	USE arrays_3d, &
187	ONLY: dzw, hyp, nc, pt, p, q, ql, u, v, w, zu, zw, exner, d_exner
188
189	USE basic_constants_and_equations_mod, &
190	ONLY: c_p, g, lv_d_cp, l_v, pi, r_d, rho_l, solar_constant, sigma_sb, &
191	barometric_formula
192
193	USE calc_mean_profile_mod, &
194	ONLY: calc_mean_profile
195
196	USE control_parameters, &
197	ONLY: cloud_droplets, coupling_char, &
198	debug_output, debug_output_timestep, debug_string, &
199	dt_3d, &
200	dz, dt_spinup, end_time, &
201	humidity, &
202	initializing_actions, io_blocks, io_group, &
203	land_surface, large_scale_forcing, &
204	latitude, longitude, lsf_surf, &
205	message_string, plant_canopy, pt_surface, &
206	rho_surface, simulated_time, spinup_time, surface_pressure, &
207	read_svf, write_svf, &
208	time_since_reference_point, urban_surface, varnamelength
209
210	USE cpulog, &
211	ONLY: cpu_log, log_point, log_point_s
212
213	USE grid_variables, &
214	ONLY: ddx, ddy, dx, dy
215
216	USE date_and_time_mod, &
217	ONLY: calc_date_and_time, d_hours_day, d_seconds_hour, d_seconds_year,&
218	day_of_year, d_seconds_year, day_of_month, day_of_year_init, &
219	init_date_and_time, month_of_year, time_utc_init, time_utc
220
221	USE indices, &
222	ONLY: nnx, nny, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, &
223	nzb, nzt, topo_top_ind
224
225	USE, INTRINSIC :: iso_c_binding
226
227	USE kinds
228
229	USE bulk_cloud_model_mod, &
230	ONLY: bulk_cloud_model, microphysics_morrison, na_init, nc_const, sigma_gc
231
232	#if defined ( __netcdf )
233	USE NETCDF
234	#endif
235
236	USE netcdf_data_input_mod, &
237	ONLY: albedo_type_f, &
238	albedo_pars_f, &
239	building_type_f, &
240	pavement_type_f, &
241	vegetation_type_f, &
242	water_type_f, &
243	char_fill, &
244	char_lod, &
245	check_existence, &
246	close_input_file, &
247	get_attribute, &
248	get_variable, &
249	inquire_num_variables, &
250	inquire_variable_names, &
251	input_file_dynamic, &
252	input_pids_dynamic, &
253	netcdf_data_input_get_dimension_length, &
254	num_var_pids, &
255	pids_id, &
256	open_read_file, &
257	real_1d_3d, &
258	vars_pids
259
260	USE plant_canopy_model_mod, &
261	ONLY: lad_s, pc_heating_rate, pc_transpiration_rate, pc_latent_rate, &
262	plant_canopy_transpiration, pcm_calc_transpiration_rate
263
264	USE pegrid
265
266	#if defined ( __rrtmg )
267	USE parrrsw, &
268	ONLY: naerec, nbndsw
269
270	USE parrrtm, &
271	ONLY: nbndlw
272
273	USE rrtmg_lw_init, &
274	ONLY: rrtmg_lw_ini
275
276	USE rrtmg_sw_init, &
277	ONLY: rrtmg_sw_ini
278
279	USE rrtmg_lw_rad, &
280	ONLY: rrtmg_lw
281
282	USE rrtmg_sw_rad, &
283	ONLY: rrtmg_sw
284	#endif
285	USE statistics, &
286	ONLY: hom
287
288	USE surface_mod, &
289	ONLY: ind_pav_green, ind_veg_wall, ind_wat_win, &
290	surf_lsm_h, surf_lsm_v, surf_type, surf_usm_h, surf_usm_v, &
291	vertical_surfaces_exist
292
293	IMPLICIT NONE
294
295	CHARACTER(10) :: radiation_scheme = 'clear-sky' ! 'constant', 'clear-sky', or 'rrtmg'
296
297	!
298	!-- Predefined Land surface classes (albedo_type) after Briegleb (1992)
299	CHARACTER(37), DIMENSION(0:33), PARAMETER :: albedo_type_name = (/ &
300	'user defined ', & ! 0
301	'ocean ', & ! 1
302	'mixed farming, tall grassland ', & ! 2
303	'tall/medium grassland ', & ! 3
304	'evergreen shrubland ', & ! 4
305	'short grassland/meadow/shrubland ', & ! 5
306	'evergreen needleleaf forest ', & ! 6
307	'mixed deciduous evergreen forest ', & ! 7
308	'deciduous forest ', & ! 8
309	'tropical evergreen broadleaved forest', & ! 9
310	'medium/tall grassland/woodland ', & ! 10
311	'desert, sandy ', & ! 11
312	'desert, rocky ', & ! 12
313	'tundra ', & ! 13
314	'land ice ', & ! 14
315	'sea ice ', & ! 15
316	'snow ', & ! 16
317	'bare soil ', & ! 17
318	'asphalt/concrete mix ', & ! 18
319	'asphalt (asphalt concrete) ', & ! 19
320	'concrete (Portland concrete) ', & ! 20
321	'sett ', & ! 21
322	'paving stones ', & ! 22
323	'cobblestone ', & ! 23
324	'metal ', & ! 24
325	'wood ', & ! 25
326	'gravel ', & ! 26
327	'fine gravel ', & ! 27
328	'pebblestone ', & ! 28
329	'woodchips ', & ! 29
330	'tartan (sports) ', & ! 30
331	'artifical turf (sports) ', & ! 31
332	'clay (sports) ', & ! 32
333	'building (dummy) ' & ! 33
334	/)
335
336	INTEGER(iwp) :: albedo_type = 9999999_iwp, & !< Albedo surface type
337	dots_rad = 0_iwp !< starting index for timeseries output
338
339	LOGICAL :: unscheduled_radiation_calls = .TRUE., & !< flag parameter indicating whether additional calls of the radiation code are allowed
340	constant_albedo = .FALSE., & !< flag parameter indicating whether the albedo may change depending on zenith
341	force_radiation_call = .FALSE., & !< flag parameter for unscheduled radiation calls
342	lw_radiation = .TRUE., & !< flag parameter indicating whether longwave radiation shall be calculated
343	radiation = .FALSE., & !< flag parameter indicating whether the radiation model is used
344	sun_up = .TRUE., & !< flag parameter indicating whether the sun is up or down
345	sw_radiation = .TRUE., & !< flag parameter indicating whether shortwave radiation shall be calculated
346	sun_direction = .FALSE., & !< flag parameter indicating whether solar direction shall be calculated
347	average_radiation = .FALSE., & !< flag to set the calculation of radiation averaging for the domain
348	radiation_interactions = .FALSE., & !< flag to activiate RTM (TRUE only if vertical urban/land surface and trees exist)
349	surface_reflections = .TRUE., & !< flag to switch the calculation of radiation interaction between surfaces.
350	!< When it switched off, only the effect of buildings and trees shadow
351	!< will be considered. However fewer SVFs are expected.
352	radiation_interactions_on = .TRUE. !< namelist flag to force RTM activiation regardless to vertical urban/land surface and trees
353
354	REAL(wp) :: albedo = 9999999.9_wp, & !< NAMELIST alpha
355	albedo_lw_dif = 9999999.9_wp, & !< NAMELIST aldif
356	albedo_lw_dir = 9999999.9_wp, & !< NAMELIST aldir
357	albedo_sw_dif = 9999999.9_wp, & !< NAMELIST asdif
358	albedo_sw_dir = 9999999.9_wp, & !< NAMELIST asdir
359	decl_1, & !< declination coef. 1
360	decl_2, & !< declination coef. 2
361	decl_3, & !< declination coef. 3
362	dt_radiation = 0.0_wp, & !< radiation model timestep
363	emissivity = 9999999.9_wp, & !< NAMELIST surface emissivity
364	lon = 0.0_wp, & !< longitude in radians
365	lat = 0.0_wp, & !< latitude in radians
366	net_radiation = 0.0_wp, & !< net radiation at surface
367	skip_time_do_radiation = 0.0_wp, & !< Radiation model is not called before this time
368	sky_trans, & !< sky transmissivity
369	time_radiation = 0.0_wp !< time since last call of radiation code
370
371
372	REAL(wp) :: cos_zenith !< cosine of solar zenith angle, also z-coordinate of solar unit vector
373	REAL(wp) :: sun_dir_lat !< y-coordinate of solar unit vector
374	REAL(wp) :: sun_dir_lon !< x-coordinate of solar unit vector
375
376	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_net_av !< average of net radiation (rad_net) at surface
377	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_xy_av !< average of incoming longwave radiation at surface
378	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_out_xy_av !< average of outgoing longwave radiation at surface
379	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_xy_av !< average of incoming shortwave radiation at surface
380	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_out_xy_av !< average of outgoing shortwave radiation at surface
381
382	REAL(wp), PARAMETER :: emissivity_atm_clsky = 0.8_wp !< emissivity of the clear-sky atmosphere
383	!
384	!-- Land surface albedos for solar zenith angle of 60degree after Briegleb (1992)
385	!-- (broadband, longwave, shortwave ): bb, lw, sw,
386	REAL(wp), DIMENSION(0:2,1:33), PARAMETER :: albedo_pars = RESHAPE( (/&
387	0.06_wp, 0.06_wp, 0.06_wp, & ! 1
388	0.19_wp, 0.28_wp, 0.09_wp, & ! 2
389	0.23_wp, 0.33_wp, 0.11_wp, & ! 3
390	0.23_wp, 0.33_wp, 0.11_wp, & ! 4
391	0.25_wp, 0.34_wp, 0.14_wp, & ! 5
392	0.14_wp, 0.22_wp, 0.06_wp, & ! 6
393	0.17_wp, 0.27_wp, 0.06_wp, & ! 7
394	0.19_wp, 0.31_wp, 0.06_wp, & ! 8
395	0.14_wp, 0.22_wp, 0.06_wp, & ! 9
396	0.18_wp, 0.28_wp, 0.06_wp, & ! 10
397	0.43_wp, 0.51_wp, 0.35_wp, & ! 11
398	0.32_wp, 0.40_wp, 0.24_wp, & ! 12
399	0.19_wp, 0.27_wp, 0.10_wp, & ! 13
400	0.77_wp, 0.65_wp, 0.90_wp, & ! 14
401	0.77_wp, 0.65_wp, 0.90_wp, & ! 15
402	0.82_wp, 0.70_wp, 0.95_wp, & ! 16
403	0.08_wp, 0.08_wp, 0.08_wp, & ! 17
404	0.17_wp, 0.17_wp, 0.17_wp, & ! 18
405	0.17_wp, 0.17_wp, 0.17_wp, & ! 19
406	0.30_wp, 0.30_wp, 0.30_wp, & ! 20
407	0.17_wp, 0.17_wp, 0.17_wp, & ! 21
408	0.17_wp, 0.17_wp, 0.17_wp, & ! 22
409	0.17_wp, 0.17_wp, 0.17_wp, & ! 23
410	0.17_wp, 0.17_wp, 0.17_wp, & ! 24
411	0.17_wp, 0.17_wp, 0.17_wp, & ! 25
412	0.17_wp, 0.17_wp, 0.17_wp, & ! 26
413	0.17_wp, 0.17_wp, 0.17_wp, & ! 27
414	0.17_wp, 0.17_wp, 0.17_wp, & ! 28
415	0.17_wp, 0.17_wp, 0.17_wp, & ! 29
416	0.17_wp, 0.17_wp, 0.17_wp, & ! 30
417	0.17_wp, 0.17_wp, 0.17_wp, & ! 31
418	0.17_wp, 0.17_wp, 0.17_wp, & ! 32
419	0.17_wp, 0.17_wp, 0.17_wp & ! 33
420	/), (/ 3, 33 /) )
421
422	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: &
423	rad_lw_cs_hr, & !< longwave clear sky radiation heating rate (K/s)
424	rad_lw_cs_hr_av, & !< average of rad_lw_cs_hr
425	rad_lw_hr, & !< longwave radiation heating rate (K/s)
426	rad_lw_hr_av, & !< average of rad_sw_hr
427	rad_lw_in, & !< incoming longwave radiation (W/m2)
428	rad_lw_in_av, & !< average of rad_lw_in
429	rad_lw_out, & !< outgoing longwave radiation (W/m2)
430	rad_lw_out_av, & !< average of rad_lw_out
431	rad_sw_cs_hr, & !< shortwave clear sky radiation heating rate (K/s)
432	rad_sw_cs_hr_av, & !< average of rad_sw_cs_hr
433	rad_sw_hr, & !< shortwave radiation heating rate (K/s)
434	rad_sw_hr_av, & !< average of rad_sw_hr
435	rad_sw_in, & !< incoming shortwave radiation (W/m2)
436	rad_sw_in_av, & !< average of rad_sw_in
437	rad_sw_out, & !< outgoing shortwave radiation (W/m2)
438	rad_sw_out_av !< average of rad_sw_out
439
440
441	!
442	!-- Variables and parameters used in RRTMG only
443	#if defined ( __rrtmg )
444	CHARACTER(LEN=12) :: rrtm_input_file = "RAD_SND_DATA" !< name of the NetCDF input file (sounding data)
445
446
447	!
448	!-- Flag parameters to be passed to RRTMG (should not be changed until ice phase in clouds is allowed)
449	INTEGER(iwp), PARAMETER :: rrtm_idrv = 1, & !< flag for longwave upward flux calculation option (0,1)
450	rrtm_inflglw = 2, & !< flag for lw cloud optical properties (0,1,2)
451	rrtm_iceflglw = 0, & !< flag for lw ice particle specifications (0,1,2,3)
452	rrtm_liqflglw = 1, & !< flag for lw liquid droplet specifications
453	rrtm_inflgsw = 2, & !< flag for sw cloud optical properties (0,1,2)
454	rrtm_iceflgsw = 0, & !< flag for sw ice particle specifications (0,1,2,3)
455	rrtm_liqflgsw = 1 !< flag for sw liquid droplet specifications
456
457	!
458	!-- The following variables should be only changed with care, as this will
459	!-- require further setting of some variables, which is currently not
460	!-- implemented (aerosols, ice phase).
461	INTEGER(iwp) :: nzt_rad, & !< upper vertical limit for radiation calculations
462	rrtm_icld = 0, & !< cloud flag (0: clear sky column, 1: cloudy column)
463	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)
464
465	INTEGER(iwp) :: nc_stat !< local variable for storin the result of netCDF calls for error message handling
466
467	LOGICAL :: snd_exists = .FALSE. !< flag parameter to check whether a user-defined input files exists
468	LOGICAL :: sw_exists = .FALSE. !< flag parameter to check whether that required rrtmg sw file exists
469	LOGICAL :: lw_exists = .FALSE. !< flag parameter to check whether that required rrtmg lw file exists
470
471
472	REAL(wp), PARAMETER :: mol_mass_air_d_wv = 1.607793_wp !< molecular weight dry air / water vapor
473
474	REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd, & !< hypostatic pressure from sounding data (hPa)
475	rrtm_tsfc, & !< dummy array for storing surface temperature
476	t_snd !< actual temperature from sounding data (hPa)
477
478	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rrtm_ccl4vmr, & !< CCL4 volume mixing ratio (g/mol)
479	rrtm_cfc11vmr, & !< CFC11 volume mixing ratio (g/mol)
480	rrtm_cfc12vmr, & !< CFC12 volume mixing ratio (g/mol)
481	rrtm_cfc22vmr, & !< CFC22 volume mixing ratio (g/mol)
482	rrtm_ch4vmr, & !< CH4 volume mixing ratio
483	rrtm_cicewp, & !< in-cloud ice water path (g/m2)
484	rrtm_cldfr, & !< cloud fraction (0,1)
485	rrtm_cliqwp, & !< in-cloud liquid water path (g/m2)
486	rrtm_co2vmr, & !< CO2 volume mixing ratio (g/mol)
487	rrtm_emis, & !< surface emissivity (0-1)
488	rrtm_h2ovmr, & !< H2O volume mixing ratio
489	rrtm_n2ovmr, & !< N2O volume mixing ratio
490	rrtm_o2vmr, & !< O2 volume mixing ratio
491	rrtm_o3vmr, & !< O3 volume mixing ratio
492	rrtm_play, & !< pressure layers (hPa, zu-grid)
493	rrtm_plev, & !< pressure layers (hPa, zw-grid)
494	rrtm_reice, & !< cloud ice effective radius (microns)
495	rrtm_reliq, & !< cloud water drop effective radius (microns)
496	rrtm_tlay, & !< actual temperature (K, zu-grid)
497	rrtm_tlev, & !< actual temperature (K, zw-grid)
498	rrtm_lwdflx, & !< RRTM output of incoming longwave radiation flux (W/m2)
499	rrtm_lwdflxc, & !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)
500	rrtm_lwuflx, & !< RRTM output of outgoing longwave radiation flux (W/m2)
501	rrtm_lwuflxc, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)
502	rrtm_lwuflx_dt, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)
503	rrtm_lwuflxc_dt,& !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)
504	rrtm_lwhr, & !< RRTM output of longwave radiation heating rate (K/d)
505	rrtm_lwhrc, & !< RRTM output of incoming longwave clear sky radiation heating rate (K/d)
506	rrtm_swdflx, & !< RRTM output of incoming shortwave radiation flux (W/m2)
507	rrtm_swdflxc, & !< RRTM output of outgoing clear sky shortwave radiation flux (W/m2)
508	rrtm_swuflx, & !< RRTM output of outgoing shortwave radiation flux (W/m2)
509	rrtm_swuflxc, & !< RRTM output of incoming clear sky shortwave radiation flux (W/m2)
510	rrtm_swhr, & !< RRTM output of shortwave radiation heating rate (K/d)
511	rrtm_swhrc, & !< RRTM output of incoming shortwave clear sky radiation heating rate (K/d)
512	rrtm_dirdflux, & !< RRTM output of incoming direct shortwave (W/m2)
513	rrtm_difdflux !< RRTM output of incoming diffuse shortwave (W/m2)
514
515	REAL(wp), DIMENSION(1) :: rrtm_aldif, & !< surface albedo for longwave diffuse radiation
516	rrtm_aldir, & !< surface albedo for longwave direct radiation
517	rrtm_asdif, & !< surface albedo for shortwave diffuse radiation
518	rrtm_asdir !< surface albedo for shortwave direct radiation
519
520	!
521	!-- Definition of arrays that are currently not used for calling RRTMG (due to setting of flag parameters)
522	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rad_lw_cs_in, & !< incoming clear sky longwave radiation (W/m2) (not used)
523	rad_lw_cs_out, & !< outgoing clear sky longwave radiation (W/m2) (not used)
524	rad_sw_cs_in, & !< incoming clear sky shortwave radiation (W/m2) (not used)
525	rad_sw_cs_out, & !< outgoing clear sky shortwave radiation (W/m2) (not used)
526	rrtm_lw_tauaer, & !< lw aerosol optical depth
527	rrtm_lw_taucld, & !< lw in-cloud optical depth
528	rrtm_sw_taucld, & !< sw in-cloud optical depth
529	rrtm_sw_ssacld, & !< sw in-cloud single scattering albedo
530	rrtm_sw_asmcld, & !< sw in-cloud asymmetry parameter
531	rrtm_sw_fsfcld, & !< sw in-cloud forward scattering fraction
532	rrtm_sw_tauaer, & !< sw aerosol optical depth
533	rrtm_sw_ssaaer, & !< sw aerosol single scattering albedo
534	rrtm_sw_asmaer, & !< sw aerosol asymmetry parameter
535	rrtm_sw_ecaer !< sw aerosol optical detph at 0.55 microns (rrtm_iaer = 6 only)
536
537	#endif
538	!
539	!-- Parameters of urban and land surface models
540	INTEGER(iwp) :: nz_urban !< number of layers of urban surface (will be calculated)
541	INTEGER(iwp) :: nz_plant !< number of layers of plant canopy (will be calculated)
542	INTEGER(iwp) :: nz_urban_b !< bottom layer of urban surface (will be calculated)
543	INTEGER(iwp) :: nz_urban_t !< top layer of urban surface (will be calculated)
544	INTEGER(iwp) :: nz_plant_t !< top layer of plant canopy (will be calculated)
545	!-- parameters of urban and land surface models
546	INTEGER(iwp), PARAMETER :: nzut_free = 3 !< number of free layers above top of of topography
547	INTEGER(iwp), PARAMETER :: ndsvf = 2 !< number of dimensions of real values in SVF
548	INTEGER(iwp), PARAMETER :: idsvf = 2 !< number of dimensions of integer values in SVF
549	INTEGER(iwp), PARAMETER :: ndcsf = 1 !< number of dimensions of real values in CSF
550	INTEGER(iwp), PARAMETER :: idcsf = 2 !< number of dimensions of integer values in CSF
551	INTEGER(iwp), PARAMETER :: kdcsf = 4 !< number of dimensions of integer values in CSF calculation array
552	INTEGER(iwp), PARAMETER :: id = 1 !< position of d-index in surfl and surf
553	INTEGER(iwp), PARAMETER :: iz = 2 !< position of k-index in surfl and surf
554	INTEGER(iwp), PARAMETER :: iy = 3 !< position of j-index in surfl and surf
555	INTEGER(iwp), PARAMETER :: ix = 4 !< position of i-index in surfl and surf
556	INTEGER(iwp), PARAMETER :: im = 5 !< position of surface m-index in surfl and surf
557	INTEGER(iwp), PARAMETER :: nidx_surf = 5 !< number of indices in surfl and surf
558
559	INTEGER(iwp), PARAMETER :: nsurf_type = 10 !< number of surf types incl. phys.(land+urban) & (atm.,sky,boundary) surfaces - 1
560
561	INTEGER(iwp), PARAMETER :: iup_u = 0 !< 0 - index of urban upward surface (ground or roof)
562	INTEGER(iwp), PARAMETER :: idown_u = 1 !< 1 - index of urban downward surface (overhanging)
563	INTEGER(iwp), PARAMETER :: inorth_u = 2 !< 2 - index of urban northward facing wall
564	INTEGER(iwp), PARAMETER :: isouth_u = 3 !< 3 - index of urban southward facing wall
565	INTEGER(iwp), PARAMETER :: ieast_u = 4 !< 4 - index of urban eastward facing wall
566	INTEGER(iwp), PARAMETER :: iwest_u = 5 !< 5 - index of urban westward facing wall
567
568	INTEGER(iwp), PARAMETER :: iup_l = 6 !< 6 - index of land upward surface (ground or roof)
569	INTEGER(iwp), PARAMETER :: inorth_l = 7 !< 7 - index of land northward facing wall
570	INTEGER(iwp), PARAMETER :: isouth_l = 8 !< 8 - index of land southward facing wall
571	INTEGER(iwp), PARAMETER :: ieast_l = 9 !< 9 - index of land eastward facing wall
572	INTEGER(iwp), PARAMETER :: iwest_l = 10 !< 10- index of land westward facing wall
573
574	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: idir = (/0, 0,0, 0,1,-1,0,0, 0,1,-1/) !< surface normal direction x indices
575	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: jdir = (/0, 0,1,-1,0, 0,0,1,-1,0, 0/) !< surface normal direction y indices
576	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: kdir = (/1,-1,0, 0,0, 0,1,0, 0,0, 0/) !< surface normal direction z indices
577	REAL(wp), DIMENSION(0:nsurf_type) :: facearea !< area of single face in respective
578	!< direction (will be calc'd)
579
580
581	!-- indices and sizes of urban and land surface models
582	INTEGER(iwp) :: startland !< start index of block of land and roof surfaces
583	INTEGER(iwp) :: endland !< end index of block of land and roof surfaces
584	INTEGER(iwp) :: nlands !< number of land and roof surfaces in local processor
585	INTEGER(iwp) :: startwall !< start index of block of wall surfaces
586	INTEGER(iwp) :: endwall !< end index of block of wall surfaces
587	INTEGER(iwp) :: nwalls !< number of wall surfaces in local processor
588
589	!-- indices needed for RTM netcdf output subroutines
590	INTEGER(iwp), PARAMETER :: nd = 5
591	CHARACTER(LEN=6), DIMENSION(0:nd-1), PARAMETER :: dirname = (/ '_roof ', '_south', '_north', '_west ', '_east ' /)
592	INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint_u = (/ iup_u, isouth_u, inorth_u, iwest_u, ieast_u /)
593	INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint_l = (/ iup_l, isouth_l, inorth_l, iwest_l, ieast_l /)
594	INTEGER(iwp), DIMENSION(0:nd-1) :: dirstart
595	INTEGER(iwp), DIMENSION(0:nd-1) :: dirend
596
597	!-- indices and sizes of urban and land surface models
598	INTEGER(iwp), DIMENSION(:,:), POINTER :: surfl !< coordinates of i-th local surface in local grid - surfl[:,k] = [d, z, y, x, m]
599	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surfl_linear !< dtto (linearly allocated array)
600	INTEGER(iwp), DIMENSION(:,:), POINTER :: surf !< coordinates of i-th surface in grid - surf[:,k] = [d, z, y, x, m]
601	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surf_linear !< dtto (linearly allocated array)
602	INTEGER(iwp) :: nsurfl !< number of all surfaces in local processor
603	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: nsurfs !< array of number of all surfaces in individual processors
604	INTEGER(iwp) :: nsurf !< global number of surfaces in index array of surfaces (nsurf = proc nsurfs)
605	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surfstart !< starts of blocks of surfaces for individual processors in array surf (indexed from 1)
606	!< respective block for particular processor is surfstart[iproc+1]+1 : surfstart[iproc+1]+nsurfs[iproc+1]
607
608	!-- block variables needed for calculation of the plant canopy model inside the urban surface model
609	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pct !< top layer of the plant canopy
610	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pch !< heights of the plant canopy
611	INTEGER(iwp) :: npcbl = 0 !< number of the plant canopy gridboxes in local processor
612	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pcbl !< k,j,i coordinates of l-th local plant canopy box pcbl[:,l] = [k, j, i]
613	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw !< array of absorbed sw radiation for local plant canopy box
614	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdir !< array of absorbed direct sw radiation for local plant canopy box
615	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdif !< array of absorbed diffusion sw radiation for local plant canopy box
616	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw !< array of absorbed lw radiation for local plant canopy box
617
618	!-- configuration parameters (they can be setup in PALM config)
619	LOGICAL :: raytrace_mpi_rma = .TRUE. !< use MPI RMA to access LAD and gridsurf from remote processes during raytracing
620	LOGICAL :: rad_angular_discretization = .TRUE.!< whether to use fixed resolution discretization of view factors for
621	!< reflected radiation (as opposed to all mutually visible pairs)
622	LOGICAL :: plant_lw_interact = .TRUE. !< whether plant canopy interacts with LW radiation (in addition to SW)
623	INTEGER(iwp) :: mrt_nlevels = 0 !< number of vertical boxes above surface for which to calculate MRT
624	LOGICAL :: mrt_skip_roof = .TRUE. !< do not calculate MRT above roof surfaces
625	LOGICAL :: mrt_include_sw = .TRUE. !< should MRT calculation include SW radiation as well?
626	LOGICAL :: mrt_geom_human = .TRUE. !< MRT direction weights simulate human body instead of a sphere
627	INTEGER(iwp) :: nrefsteps = 3 !< number of reflection steps to perform
628	REAL(wp), PARAMETER :: ext_coef = 0.6_wp !< extinction coefficient (a.k.a. alpha)
629	INTEGER(iwp), PARAMETER :: rad_version_len = 10 !< length of identification string of rad version
630	CHARACTER(rad_version_len), PARAMETER :: rad_version = 'RAD v. 3.0' !< identification of version of binary svf and restart files
631	INTEGER(iwp) :: raytrace_discrete_elevs = 40 !< number of discretization steps for elevation (nadir to zenith)
632	INTEGER(iwp) :: raytrace_discrete_azims = 80 !< number of discretization steps for azimuth (out of 360 degrees)
633	REAL(wp) :: max_raytracing_dist = -999.0_wp !< maximum distance for raytracing (in metres)
634	REAL(wp) :: min_irrf_value = 1e-6_wp !< minimum potential irradiance factor value for raytracing
635	REAL(wp), DIMENSION(1:30) :: svfnorm_report_thresh = 1e21_wp !< thresholds of SVF normalization values to report
636	INTEGER(iwp) :: svfnorm_report_num !< number of SVF normalization thresholds to report
637
638	!-- radiation related arrays to be used in radiation_interaction routine
639	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_dir !< direct sw radiation
640	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_diff !< diffusion sw radiation
641	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_diff !< diffusion lw radiation
642
643	!-- parameters required for RRTMG lower boundary condition
644	REAL(wp) :: albedo_urb !< albedo value retuned to RRTMG boundary cond.
645	REAL(wp) :: emissivity_urb !< emissivity value retuned to RRTMG boundary cond.
646	REAL(wp) :: t_rad_urb !< temperature value retuned to RRTMG boundary cond.
647
648	!-- type for calculation of svf
649	TYPE t_svf
650	INTEGER(iwp) :: isurflt !<
651	INTEGER(iwp) :: isurfs !<
652	REAL(wp) :: rsvf !<
653	REAL(wp) :: rtransp !<
654	END TYPE
655
656	!-- type for calculation of csf
657	TYPE t_csf
658	INTEGER(iwp) :: ip !<
659	INTEGER(iwp) :: itx !<
660	INTEGER(iwp) :: ity !<
661	INTEGER(iwp) :: itz !<
662	INTEGER(iwp) :: isurfs !< Idx of source face / -1 for sky
663	REAL(wp) :: rcvf !< Canopy view factor for faces /
664	!< canopy sink factor for sky (-1)
665	END TYPE
666
667	!-- arrays storing the values of USM
668	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: svfsurf !< svfsurf[:,isvf] = index of target and source surface for svf[isvf]
669	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: svf !< array of shape view factors+direct irradiation factors for local surfaces
670	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins !< array of sw radiation falling to local surface after i-th reflection
671	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl !< array of lw radiation for local surface after i-th reflection
672
673	REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvf !< array of sky view factor for each local surface
674	REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvft !< array of sky view factor including transparency for each local surface
675	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitrans !< dsidir[isvfl,i] = path transmittance of i-th
676	!< direction of direct solar irradiance per target surface
677	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitransc !< dtto per plant canopy box
678	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir !< dsidir[:,i] = unit vector of i-th
679	!< direction of direct solar irradiance
680	INTEGER(iwp) :: ndsidir !< number of apparent solar directions used
681	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: dsidir_rev !< dsidir_rev[ielev,iazim] = i for dsidir or -1 if not present
682
683	INTEGER(iwp) :: nmrtbl !< No. of local grid boxes for which MRT is calculated
684	INTEGER(iwp) :: nmrtf !< number of MRT factors for local processor
685	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mrtbl !< coordinates of i-th local MRT box - surfl[:,i] = [z, y, x]
686	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mrtfsurf !< mrtfsurf[:,imrtf] = index of target MRT box and source surface for mrtf[imrtf]
687	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtf !< array of MRT factors for each local MRT box
688	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtft !< array of MRT factors including transparency for each local MRT box
689	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtsky !< array of sky view factor for each local MRT box
690	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtskyt !< array of sky view factor including transparency for each local MRT box
691	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: mrtdsit !< array of direct solar transparencies for each local MRT box
692	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinsw !< mean SW radiant flux for each MRT box
693	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinlw !< mean LW radiant flux for each MRT box
694	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt !< mean radiant temperature for each MRT box
695	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinsw_av !< time average mean SW radiant flux for each MRT box
696	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinlw_av !< time average mean LW radiant flux for each MRT box
697	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt_av !< time average mean radiant temperature for each MRT box
698
699	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw !< array of sw radiation falling to local surface including radiation from reflections
700	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw !< array of lw radiation falling to local surface including radiation from reflections
701	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir !< array of direct sw radiation falling to local surface
702	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif !< array of diffuse sw radiation from sky and model boundary falling to local surface
703	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif !< array of diffuse lw radiation from sky and model boundary falling to local surface
704
705	!< Outward radiation is only valid for nonvirtual surfaces
706	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsl !< array of reflected sw radiation for local surface in i-th reflection
707	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutll !< array of reflected + emitted lw radiation for local surface in i-th reflection
708	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfouts !< array of reflected sw radiation for all surfaces in i-th reflection
709	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutl !< array of reflected + emitted lw radiation for all surfaces in i-th reflection
710	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlg !< global array of incoming lw radiation from plant canopy
711	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw !< array of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection
712	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw !< array of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection
713	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfemitlwl !< array of emitted lw radiation for local surface used to calculate effective surface temperature for radiation model
714
715	!-- block variables needed for calculation of the plant canopy model inside the urban surface model
716	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: csfsurf !< csfsurf[:,icsf] = index of target surface and csf grid index for csf[icsf]
717	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csf !< array of plant canopy sink fators + direct irradiation factors (transparency)
718	REAL(wp), DIMENSION(:,:,:), POINTER :: sub_lad !< subset of lad_s within urban surface, transformed to plain Z coordinate
719	REAL(wp), DIMENSION(:), POINTER :: sub_lad_g !< sub_lad globalized (used to avoid MPI RMA calls in raytracing)
720	REAL(wp) :: prototype_lad !< prototype leaf area density for computing effective optical depth
721	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nzterr, plantt !< temporary global arrays for raytracing
722	INTEGER(iwp) :: plantt_max
723
724	!-- arrays and variables for calculation of svf and csf
725	TYPE(t_svf), DIMENSION(:), POINTER :: asvf !< pointer to growing svc array
726	TYPE(t_csf), DIMENSION(:), POINTER :: acsf !< pointer to growing csf array
727	TYPE(t_svf), DIMENSION(:), POINTER :: amrtf !< pointer to growing mrtf array
728	TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: asvf1, asvf2 !< realizations of svf array
729	TYPE(t_csf), DIMENSION(:), ALLOCATABLE, TARGET :: acsf1, acsf2 !< realizations of csf array
730	TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: amrtf1, amrtf2 !< realizations of mftf array
731	INTEGER(iwp) :: nsvfla !< dimmension of array allocated for storage of svf in local processor
732	INTEGER(iwp) :: ncsfla !< dimmension of array allocated for storage of csf in local processor
733	INTEGER(iwp) :: nmrtfa !< dimmension of array allocated for storage of mrt
734	INTEGER(iwp) :: msvf, mcsf, mmrtf!< mod for swapping the growing array
735	INTEGER(iwp), PARAMETER :: gasize = 100000_iwp !< initial size of growing arrays
736	REAL(wp), PARAMETER :: grow_factor = 1.4_wp !< growth factor of growing arrays
737	INTEGER(iwp) :: nsvfl !< number of svf for local processor
738	INTEGER(iwp) :: ncsfl !< no. of csf in local processor
739	!< needed only during calc_svf but must be here because it is
740	!< shared between subroutines calc_svf and raytrace
741	INTEGER(iwp), DIMENSION(:,:,:,:), POINTER :: gridsurf !< reverse index of local surfl[d,k,j,i] (for case rad_angular_discretization)
742	INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: gridpcbl !< reverse index of local pcbl[k,j,i]
743	INTEGER(iwp), PARAMETER :: nsurf_type_u = 6 !< number of urban surf types (used in gridsurf)
744
745	!-- temporary arrays for calculation of csf in raytracing
746	INTEGER(iwp) :: maxboxesg !< max number of boxes ray can cross in the domain
747	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: boxes !< coordinates of gridboxes being crossed by ray
748	REAL(wp), DIMENSION(:), ALLOCATABLE :: crlens !< array of crossing lengths of ray for particular grid boxes
749	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: lad_ip !< array of numbers of process where lad is stored
750	#if defined( __parallel )
751	INTEGER(kind=MPI_ADDRESS_KIND), &
752	DIMENSION(:), ALLOCATABLE :: lad_disp !< array of displaycements of lad in local array of proc lad_ip
753	INTEGER(iwp) :: win_lad !< MPI RMA window for leaf area density
754	INTEGER(iwp) :: win_gridsurf !< MPI RMA window for reverse grid surface index
755	#endif
756	REAL(wp), DIMENSION(:), ALLOCATABLE :: lad_s_ray !< array of received lad_s for appropriate gridboxes crossed by ray
757	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: target_surfl
758	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: rt2_track
759	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rt2_track_lad
760	REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_track_dist
761	REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_dist
762
763	!-- arrays for time averages
764	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfradnet_av !< average of net radiation to local surface including radiation from reflections
765	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw_av !< average of sw radiation falling to local surface including radiation from reflections
766	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw_av !< average of lw radiation falling to local surface including radiation from reflections
767	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir_av !< average of direct sw radiation falling to local surface
768	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif_av !< average of diffuse sw radiation from sky and model boundary falling to local surface
769	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif_av !< average of diffuse lw radiation from sky and model boundary falling to local surface
770	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswref_av !< average of sw radiation falling to surface from reflections
771	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwref_av !< average of lw radiation falling to surface from reflections
772	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw_av !< average of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection
773	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw_av !< average of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection
774	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins_av !< average of array of residua of sw radiation absorbed in surface after last reflection
775	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl_av !< average of array of residua of lw radiation absorbed in surface after last reflection
776	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw_av !< Average of pcbinlw
777	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw_av !< Average of pcbinsw
778	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdir_av !< Average of pcbinswdir
779	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdif_av !< Average of pcbinswdif
780	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswref_av !< Average of pcbinswref
781
782
783	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
784	!-- Energy balance variables
785	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
786	!-- parameters of the land, roof and wall surfaces
787	REAL(wp), DIMENSION(:), ALLOCATABLE :: albedo_surf !< albedo of the surface
788	REAL(wp), DIMENSION(:), ALLOCATABLE :: emiss_surf !< emissivity of the wall surface
789	!
790	!-- External radiation. Depending on the given level of detail either a 1D or
791	!-- a 3D array will be allocated.
792	TYPE( real_1d_3d ) :: rad_lw_in_f !< external incoming longwave radiation, from observation or model
793	TYPE( real_1d_3d ) :: rad_sw_in_f !< external incoming shortwave radiation, from observation or model
794	TYPE( real_1d_3d ) :: rad_sw_in_dif_f !< external incoming shortwave radiation, diffuse part, from observation or model
795	TYPE( real_1d_3d ) :: time_rad_f !< time dimension for external radiation, from observation or model
796
797	INTERFACE radiation_check_data_output
798	MODULE PROCEDURE radiation_check_data_output
799	END INTERFACE radiation_check_data_output
800
801	INTERFACE radiation_check_data_output_ts
802	MODULE PROCEDURE radiation_check_data_output_ts
803	END INTERFACE radiation_check_data_output_ts
804
805	INTERFACE radiation_check_data_output_pr
806	MODULE PROCEDURE radiation_check_data_output_pr
807	END INTERFACE radiation_check_data_output_pr
808
809	INTERFACE radiation_check_parameters
810	MODULE PROCEDURE radiation_check_parameters
811	END INTERFACE radiation_check_parameters
812
813	INTERFACE radiation_clearsky
814	MODULE PROCEDURE radiation_clearsky
815	END INTERFACE radiation_clearsky
816
817	INTERFACE radiation_constant
818	MODULE PROCEDURE radiation_constant
819	END INTERFACE radiation_constant
820
821	INTERFACE radiation_control
822	MODULE PROCEDURE radiation_control
823	END INTERFACE radiation_control
824
825	INTERFACE radiation_3d_data_averaging
826	MODULE PROCEDURE radiation_3d_data_averaging
827	END INTERFACE radiation_3d_data_averaging
828
829	INTERFACE radiation_data_output_2d
830	MODULE PROCEDURE radiation_data_output_2d
831	END INTERFACE radiation_data_output_2d
832
833	INTERFACE radiation_data_output_3d
834	MODULE PROCEDURE radiation_data_output_3d
835	END INTERFACE radiation_data_output_3d
836
837	INTERFACE radiation_data_output_mask
838	MODULE PROCEDURE radiation_data_output_mask
839	END INTERFACE radiation_data_output_mask
840
841	INTERFACE radiation_define_netcdf_grid
842	MODULE PROCEDURE radiation_define_netcdf_grid
843	END INTERFACE radiation_define_netcdf_grid
844
845	INTERFACE radiation_header
846	MODULE PROCEDURE radiation_header
847	END INTERFACE radiation_header
848
849	INTERFACE radiation_init
850	MODULE PROCEDURE radiation_init
851	END INTERFACE radiation_init
852
853	INTERFACE radiation_parin
854	MODULE PROCEDURE radiation_parin
855	END INTERFACE radiation_parin
856
857	INTERFACE radiation_rrtmg
858	MODULE PROCEDURE radiation_rrtmg
859	END INTERFACE radiation_rrtmg
860
861	#if defined( __rrtmg )
862	INTERFACE radiation_tendency
863	MODULE PROCEDURE radiation_tendency
864	MODULE PROCEDURE radiation_tendency_ij
865	END INTERFACE radiation_tendency
866	#endif
867
868	INTERFACE radiation_rrd_local
869	MODULE PROCEDURE radiation_rrd_local
870	END INTERFACE radiation_rrd_local
871
872	INTERFACE radiation_wrd_local
873	MODULE PROCEDURE radiation_wrd_local
874	END INTERFACE radiation_wrd_local
875
876	INTERFACE radiation_interaction
877	MODULE PROCEDURE radiation_interaction
878	END INTERFACE radiation_interaction
879
880	INTERFACE radiation_interaction_init
881	MODULE PROCEDURE radiation_interaction_init
882	END INTERFACE radiation_interaction_init
883
884	INTERFACE radiation_presimulate_solar_pos
885	MODULE PROCEDURE radiation_presimulate_solar_pos
886	END INTERFACE radiation_presimulate_solar_pos
887
888	INTERFACE radiation_calc_svf
889	MODULE PROCEDURE radiation_calc_svf
890	END INTERFACE radiation_calc_svf
891
892	INTERFACE radiation_write_svf
893	MODULE PROCEDURE radiation_write_svf
894	END INTERFACE radiation_write_svf
895
896	INTERFACE radiation_read_svf
897	MODULE PROCEDURE radiation_read_svf
898	END INTERFACE radiation_read_svf
899
900
901	SAVE
902
903	PRIVATE
904
905	!
906	!-- Public functions / NEEDS SORTING
907	PUBLIC radiation_check_data_output, radiation_check_data_output_pr, &
908	radiation_check_data_output_ts, &
909	radiation_check_parameters, radiation_control, &
910	radiation_header, radiation_init, radiation_parin, &
911	radiation_3d_data_averaging, &
912	radiation_data_output_2d, radiation_data_output_3d, &
913	radiation_define_netcdf_grid, radiation_wrd_local, &
914	radiation_rrd_local, radiation_data_output_mask, &
915	radiation_calc_svf, radiation_write_svf, &
916	radiation_interaction, radiation_interaction_init, &
917	radiation_read_svf, radiation_presimulate_solar_pos
918
919
920	!
921	!-- Public variables and constants / NEEDS SORTING
922	PUBLIC albedo, albedo_type, decl_1, decl_2, decl_3, dots_rad, dt_radiation,&
923	emissivity, force_radiation_call, lat, lon, mrt_geom_human, &
924	mrt_include_sw, mrt_nlevels, mrtbl, mrtinsw, mrtinlw, nmrtbl, &
925	rad_net_av, radiation, radiation_scheme, rad_lw_in, &
926	rad_lw_in_av, rad_lw_out, rad_lw_out_av, &
927	rad_lw_cs_hr, rad_lw_cs_hr_av, rad_lw_hr, rad_lw_hr_av, rad_sw_in, &
928	rad_sw_in_av, rad_sw_out, rad_sw_out_av, rad_sw_cs_hr, &
929	rad_sw_cs_hr_av, rad_sw_hr, rad_sw_hr_av, solar_constant, &
930	skip_time_do_radiation, time_radiation, unscheduled_radiation_calls,&
931	cos_zenith, calc_zenith, sun_direction, sun_dir_lat, sun_dir_lon, &
932	idir, jdir, kdir, id, iz, iy, ix, &
933	iup_u, inorth_u, isouth_u, ieast_u, iwest_u, &
934	iup_l, inorth_l, isouth_l, ieast_l, iwest_l, &
935	nsurf_type, nz_urban_b, nz_urban_t, nz_urban, pch, nsurf, &
936	idsvf, ndsvf, idcsf, ndcsf, kdcsf, pct, &
937	radiation_interactions, startwall, startland, endland, endwall, &
938	skyvf, skyvft, radiation_interactions_on, average_radiation, &
939	rad_sw_in_diff, rad_sw_in_dir
940
941
942	#if defined ( __rrtmg )
943	PUBLIC radiation_tendency, rrtm_aldif, rrtm_aldir, rrtm_asdif, rrtm_asdir
944	#endif
945
946	CONTAINS
947
948
949	!------------------------------------------------------------------------------!
950	! Description:
951	! ------------
952	!> This subroutine controls the calls of the radiation schemes
953	!------------------------------------------------------------------------------!
954	SUBROUTINE radiation_control
955
956
957	IMPLICIT NONE
958
959
960	IF ( debug_output_timestep ) CALL debug_message( 'radiation_control', 'start' )
961
962
963	SELECT CASE ( TRIM( radiation_scheme ) )
964
965	CASE ( 'constant' )
966	CALL radiation_constant
967
968	CASE ( 'clear-sky' )
969	CALL radiation_clearsky
970
971	CASE ( 'rrtmg' )
972	CALL radiation_rrtmg
973
974	CASE ( 'external' )
975	!
976	!-- During spinup apply clear-sky model
977	IF ( time_since_reference_point < 0.0_wp ) THEN
978	CALL radiation_clearsky
979	ELSE
980	CALL radiation_external
981	ENDIF
982
983	CASE DEFAULT
984
985	END SELECT
986
987	IF ( debug_output_timestep ) CALL debug_message( 'radiation_control', 'end' )
988
989	END SUBROUTINE radiation_control
990
991	!------------------------------------------------------------------------------!
992	! Description:
993	! ------------
994	!> Check data output for radiation model
995	!------------------------------------------------------------------------------!
996	SUBROUTINE radiation_check_data_output( variable, unit, i, ilen, k )
997
998
999	USE control_parameters, &
1000	ONLY: data_output, message_string
1001
1002	IMPLICIT NONE
1003
1004	CHARACTER (LEN=*) :: unit !<
1005	CHARACTER (LEN=*) :: variable !<
1006
1007	INTEGER(iwp) :: i, k
1008	INTEGER(iwp) :: ilen
1009	CHARACTER(LEN=varnamelength) :: var !< TRIM(variable)
1010
1011	var = TRIM(variable)
1012
1013	IF ( len(var) < 3_iwp ) THEN
1014	unit = 'illegal'
1015	RETURN
1016	ENDIF
1017
1018	IF ( var(1:3) /= 'rad' .AND. var(1:3) /= 'rtm' ) THEN
1019	unit = 'illegal'
1020	RETURN
1021	ENDIF
1022
1023	!-- first process diractional variables
1024	IF ( var(1:12) == 'rtm_rad_net_' .OR. var(1:13) == 'rtm_rad_insw_' .OR. &
1025	var(1:13) == 'rtm_rad_inlw_' .OR. var(1:16) == 'rtm_rad_inswdir_' .OR. &
1026	var(1:16) == 'rtm_rad_inswdif_' .OR. var(1:16) == 'rtm_rad_inswref_' .OR. &
1027	var(1:16) == 'rtm_rad_inlwdif_' .OR. var(1:16) == 'rtm_rad_inlwref_' .OR. &
1028	var(1:14) == 'rtm_rad_outsw_' .OR. var(1:14) == 'rtm_rad_outlw_' .OR. &
1029	var(1:14) == 'rtm_rad_ressw_' .OR. var(1:14) == 'rtm_rad_reslw_' ) THEN
1030	IF ( .NOT. radiation ) THEN
1031	message_string = 'output of "' // TRIM( var ) // '" require'&
1032	// 's radiation = .TRUE.'
1033	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1034	ENDIF
1035	unit = 'W/m2'
1036	ELSE IF ( var(1:7) == 'rtm_svf' .OR. var(1:7) == 'rtm_dif' .OR. &
1037	var(1:9) == 'rtm_skyvf' .OR. var(1:9) == 'rtm_skyvft' .OR. &
1038	var(1:12) == 'rtm_surfalb_' .OR. var(1:13) == 'rtm_surfemis_' ) THEN
1039	IF ( .NOT. radiation ) THEN
1040	message_string = 'output of "' // TRIM( var ) // '" require'&
1041	// 's radiation = .TRUE.'
1042	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1043	ENDIF
1044	unit = '1'
1045	ELSE
1046	!-- non-directional variables
1047	SELECT CASE ( TRIM( var ) )
1048	CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_lw_in', 'rad_lw_out', &
1049	'rad_sw_cs_hr', 'rad_sw_hr', 'rad_sw_in', 'rad_sw_out' )
1050	IF ( .NOT. radiation .OR. radiation_scheme /= 'rrtmg' ) THEN
1051	message_string = '"output of "' // TRIM( var ) // '" requi' // &
1052	'res radiation = .TRUE. and ' // &
1053	'radiation_scheme = "rrtmg"'
1054	CALL message( 'check_parameters', 'PA0406', 1, 2, 0, 6, 0 )
1055	ENDIF
1056	unit = 'K/h'
1057
1058	CASE ( 'rad_net', 'rrtm_aldif', 'rrtm_aldir', 'rrtm_asdif', &
1059	'rrtm_asdir', 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', &
1060	'rad_sw_out*')
1061	IF ( i == 0 .AND. ilen == 0 .AND. k == 0) THEN
1062	! Workaround for masked output (calls with i=ilen=k=0)
1063	unit = 'illegal'
1064	RETURN
1065	ENDIF
1066	IF ( k == 0 .OR. data_output(i)(ilen-2:ilen) /= '_xy' ) THEN
1067	message_string = 'illegal value for data_output: "' // &
1068	TRIM( var ) // '" & only 2d-horizontal ' // &
1069	'cross sections are allowed for this value'
1070	CALL message( 'check_parameters', 'PA0111', 1, 2, 0, 6, 0 )
1071	ENDIF
1072	IF ( .NOT. radiation .OR. radiation_scheme /= "rrtmg" ) THEN
1073	IF ( TRIM( var ) == 'rrtm_aldif*' .OR. &
1074	TRIM( var ) == 'rrtm_aldir*' .OR. &
1075	TRIM( var ) == 'rrtm_asdif*' .OR. &
1076	TRIM( var ) == 'rrtm_asdir*' ) &
1077	THEN
1078	message_string = 'output of "' // TRIM( var ) // '" require'&
1079	// 's radiation = .TRUE. and radiation_sch'&
1080	// 'eme = "rrtmg"'
1081	CALL message( 'check_parameters', 'PA0409', 1, 2, 0, 6, 0 )
1082	ENDIF
1083	ENDIF
1084
1085	IF ( TRIM( var ) == 'rad_net*' ) unit = 'W/m2'
1086	IF ( TRIM( var ) == 'rad_lw_in*' ) unit = 'W/m2'
1087	IF ( TRIM( var ) == 'rad_lw_out*' ) unit = 'W/m2'
1088	IF ( TRIM( var ) == 'rad_sw_in*' ) unit = 'W/m2'
1089	IF ( TRIM( var ) == 'rad_sw_out*' ) unit = 'W/m2'
1090	IF ( TRIM( var ) == 'rad_sw_in' ) unit = 'W/m2'
1091	IF ( TRIM( var ) == 'rrtm_aldif*' ) unit = ''
1092	IF ( TRIM( var ) == 'rrtm_aldir*' ) unit = ''
1093	IF ( TRIM( var ) == 'rrtm_asdif*' ) unit = ''
1094	IF ( TRIM( var ) == 'rrtm_asdir*' ) unit = ''
1095
1096	CASE ( 'rtm_rad_pc_inlw', 'rtm_rad_pc_insw', 'rtm_rad_pc_inswdir', &
1097	'rtm_rad_pc_inswdif', 'rtm_rad_pc_inswref')
1098	IF ( .NOT. radiation ) THEN
1099	message_string = 'output of "' // TRIM( var ) // '" require'&
1100	// 's radiation = .TRUE.'
1101	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1102	ENDIF
1103	unit = 'W'
1104
1105	CASE ( 'rtm_mrt', 'rtm_mrt_sw', 'rtm_mrt_lw' )
1106	IF ( i == 0 .AND. ilen == 0 .AND. k == 0) THEN
1107	! Workaround for masked output (calls with i=ilen=k=0)
1108	unit = 'illegal'
1109	RETURN
1110	ENDIF
1111
1112	IF ( .NOT. radiation ) THEN
1113	message_string = 'output of "' // TRIM( var ) // '" require'&
1114	// 's radiation = .TRUE.'
1115	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1116	ENDIF
1117	IF ( mrt_nlevels == 0 ) THEN
1118	message_string = 'output of "' // TRIM( var ) // '" require'&
1119	// 's mrt_nlevels > 0'
1120	CALL message( 'check_parameters', 'PA0510', 1, 2, 0, 6, 0 )
1121	ENDIF
1122	IF ( TRIM( var ) == 'rtm_mrt_sw' .AND. .NOT. mrt_include_sw ) THEN
1123	message_string = 'output of "' // TRIM( var ) // '" require'&
1124	// 's rtm_mrt_sw = .TRUE.'
1125	CALL message( 'check_parameters', 'PA0511', 1, 2, 0, 6, 0 )
1126	ENDIF
1127	IF ( TRIM( var ) == 'rtm_mrt' ) THEN
1128	unit = 'K'
1129	ELSE
1130	unit = 'W m-2'
1131	ENDIF
1132
1133	CASE DEFAULT
1134	unit = 'illegal'
1135
1136	END SELECT
1137	ENDIF
1138
1139	END SUBROUTINE radiation_check_data_output
1140
1141
1142	!------------------------------------------------------------------------------!
1143	! Description:
1144	! ------------
1145	!> Set module-specific timeseries units and labels
1146	!------------------------------------------------------------------------------!
1147	SUBROUTINE radiation_check_data_output_ts( dots_max, dots_num )
1148
1149
1150	INTEGER(iwp), INTENT(IN) :: dots_max
1151	INTEGER(iwp), INTENT(INOUT) :: dots_num
1152
1153	!
1154	!-- Next line is just to avoid compiler warning about unused variable.
1155	IF ( dots_max == 0 ) CONTINUE
1156
1157	!
1158	!-- Temporary solution to add LSM and radiation time series to the default
1159	!-- output
1160	IF ( land_surface .OR. radiation ) THEN
1161	IF ( TRIM( radiation_scheme ) == 'rrtmg' ) THEN
1162	dots_num = dots_num + 15
1163	ELSE
1164	dots_num = dots_num + 11
1165	ENDIF
1166	ENDIF
1167
1168
1169	END SUBROUTINE radiation_check_data_output_ts
1170
1171	!------------------------------------------------------------------------------!
1172	! Description:
1173	! ------------
1174	!> Check data output of profiles for radiation model
1175	!------------------------------------------------------------------------------!
1176	SUBROUTINE radiation_check_data_output_pr( variable, var_count, unit, &
1177	dopr_unit )
1178
1179	USE arrays_3d, &
1180	ONLY: zu
1181
1182	USE control_parameters, &
1183	ONLY: data_output_pr, message_string
1184
1185	USE indices
1186
1187	USE profil_parameter
1188
1189	USE statistics
1190
1191	IMPLICIT NONE
1192
1193	CHARACTER (LEN=*) :: unit !<
1194	CHARACTER (LEN=*) :: variable !<
1195	CHARACTER (LEN=*) :: dopr_unit !< local value of dopr_unit
1196
1197	INTEGER(iwp) :: var_count !<
1198
1199	SELECT CASE ( TRIM( variable ) )
1200
1201	CASE ( 'rad_net' )
1202	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )&
1203	THEN
1204	message_string = 'data_output_pr = ' // &
1205	TRIM( data_output_pr(var_count) ) // ' is' // &
1206	'not available for radiation = .FALSE. or ' //&
1207	'radiation_scheme = "constant"'
1208	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1209	ELSE
1210	dopr_index(var_count) = 99
1211	dopr_unit = 'W/m2'
1212	hom(:,2,99,:) = SPREAD( zw, 2, statistic_regions+1 )
1213	unit = dopr_unit
1214	ENDIF
1215
1216	CASE ( 'rad_lw_in' )
1217	IF ( ( .NOT. radiation) .OR. radiation_scheme == 'constant' ) &
1218	THEN
1219	message_string = 'data_output_pr = ' // &
1220	TRIM( data_output_pr(var_count) ) // ' is' // &
1221	'not available for radiation = .FALSE. or ' //&
1222	'radiation_scheme = "constant"'
1223	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1224	ELSE
1225	dopr_index(var_count) = 100
1226	dopr_unit = 'W/m2'
1227	hom(:,2,100,:) = SPREAD( zw, 2, statistic_regions+1 )
1228	unit = dopr_unit
1229	ENDIF
1230
1231	CASE ( 'rad_lw_out' )
1232	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) &
1233	THEN
1234	message_string = 'data_output_pr = ' // &
1235	TRIM( data_output_pr(var_count) ) // ' is' // &
1236	'not available for radiation = .FALSE. or ' //&
1237	'radiation_scheme = "constant"'
1238	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1239	ELSE
1240	dopr_index(var_count) = 101
1241	dopr_unit = 'W/m2'
1242	hom(:,2,101,:) = SPREAD( zw, 2, statistic_regions+1 )
1243	unit = dopr_unit
1244	ENDIF
1245
1246	CASE ( 'rad_sw_in' )
1247	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) &
1248	THEN
1249	message_string = 'data_output_pr = ' // &
1250	TRIM( data_output_pr(var_count) ) // ' is' // &
1251	'not available for radiation = .FALSE. or ' //&
1252	'radiation_scheme = "constant"'
1253	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1254	ELSE
1255	dopr_index(var_count) = 102
1256	dopr_unit = 'W/m2'
1257	hom(:,2,102,:) = SPREAD( zw, 2, statistic_regions+1 )
1258	unit = dopr_unit
1259	ENDIF
1260
1261	CASE ( 'rad_sw_out')
1262	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )&
1263	THEN
1264	message_string = 'data_output_pr = ' // &
1265	TRIM( data_output_pr(var_count) ) // ' is' // &
1266	'not available for radiation = .FALSE. or ' //&
1267	'radiation_scheme = "constant"'
1268	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1269	ELSE
1270	dopr_index(var_count) = 103
1271	dopr_unit = 'W/m2'
1272	hom(:,2,103,:) = SPREAD( zw, 2, statistic_regions+1 )
1273	unit = dopr_unit
1274	ENDIF
1275
1276	CASE ( 'rad_lw_cs_hr' )
1277	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1278	THEN
1279	message_string = 'data_output_pr = ' // &
1280	TRIM( data_output_pr(var_count) ) // ' is' // &
1281	'not available for radiation = .FALSE. or ' //&
1282	'radiation_scheme /= "rrtmg"'
1283	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1284	ELSE
1285	dopr_index(var_count) = 104
1286	dopr_unit = 'K/h'
1287	hom(:,2,104,:) = SPREAD( zu, 2, statistic_regions+1 )
1288	unit = dopr_unit
1289	ENDIF
1290
1291	CASE ( 'rad_lw_hr' )
1292	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1293	THEN
1294	message_string = 'data_output_pr = ' // &
1295	TRIM( data_output_pr(var_count) ) // ' is' // &
1296	'not available for radiation = .FALSE. or ' //&
1297	'radiation_scheme /= "rrtmg"'
1298	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1299	ELSE
1300	dopr_index(var_count) = 105
1301	dopr_unit = 'K/h'
1302	hom(:,2,105,:) = SPREAD( zu, 2, statistic_regions+1 )
1303	unit = dopr_unit
1304	ENDIF
1305
1306	CASE ( 'rad_sw_cs_hr' )
1307	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1308	THEN
1309	message_string = 'data_output_pr = ' // &
1310	TRIM( data_output_pr(var_count) ) // ' is' // &
1311	'not available for radiation = .FALSE. or ' //&
1312	'radiation_scheme /= "rrtmg"'
1313	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1314	ELSE
1315	dopr_index(var_count) = 106
1316	dopr_unit = 'K/h'
1317	hom(:,2,106,:) = SPREAD( zu, 2, statistic_regions+1 )
1318	unit = dopr_unit
1319	ENDIF
1320
1321	CASE ( 'rad_sw_hr' )
1322	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1323	THEN
1324	message_string = 'data_output_pr = ' // &
1325	TRIM( data_output_pr(var_count) ) // ' is' // &
1326	'not available for radiation = .FALSE. or ' //&
1327	'radiation_scheme /= "rrtmg"'
1328	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1329	ELSE
1330	dopr_index(var_count) = 107
1331	dopr_unit = 'K/h'
1332	hom(:,2,107,:) = SPREAD( zu, 2, statistic_regions+1 )
1333	unit = dopr_unit
1334	ENDIF
1335
1336
1337	CASE DEFAULT
1338	unit = 'illegal'
1339
1340	END SELECT
1341
1342
1343	END SUBROUTINE radiation_check_data_output_pr
1344
1345
1346	!------------------------------------------------------------------------------!
1347	! Description:
1348	! ------------
1349	!> Check parameters routine for radiation model
1350	!------------------------------------------------------------------------------!
1351	SUBROUTINE radiation_check_parameters
1352
1353	USE control_parameters, &
1354	ONLY: land_surface, message_string, urban_surface
1355
1356	USE netcdf_data_input_mod, &
1357	ONLY: input_pids_static
1358
1359	IMPLICIT NONE
1360
1361	!
1362	!-- In case no urban-surface or land-surface model is applied, usage of
1363	!-- a radiation model make no sense.
1364	IF ( .NOT. land_surface .AND. .NOT. urban_surface ) THEN
1365	message_string = 'Usage of radiation module is only allowed if ' // &
1366	'land-surface and/or urban-surface model is applied.'
1367	CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 )
1368	ENDIF
1369
1370	IF ( radiation_scheme /= 'constant' .AND. &
1371	radiation_scheme /= 'clear-sky' .AND. &
1372	radiation_scheme /= 'rrtmg' .AND. &
1373	radiation_scheme /= 'external' ) THEN
1374	message_string = 'unknown radiation_scheme = '// &
1375	TRIM( radiation_scheme )
1376	CALL message( 'check_parameters', 'PA0405', 1, 2, 0, 6, 0 )
1377	ELSEIF ( radiation_scheme == 'rrtmg' ) THEN
1378	#if ! defined ( __rrtmg )
1379	message_string = 'radiation_scheme = "rrtmg" requires ' // &
1380	'compilation of PALM with pre-processor ' // &
1381	'directive -D__rrtmg'
1382	CALL message( 'check_parameters', 'PA0407', 1, 2, 0, 6, 0 )
1383	#endif
1384	#if defined ( __rrtmg ) && ! defined( __netcdf )
1385	message_string = 'radiation_scheme = "rrtmg" requires ' // &
1386	'the use of NetCDF (preprocessor directive ' // &
1387	'-D__netcdf'
1388	CALL message( 'check_parameters', 'PA0412', 1, 2, 0, 6, 0 )
1389	#endif
1390
1391	ENDIF
1392	!
1393	!-- Checks performed only if data is given via namelist only.
1394	IF ( .NOT. input_pids_static ) THEN
1395	IF ( albedo_type == 0 .AND. albedo == 9999999.9_wp .AND. &
1396	radiation_scheme == 'clear-sky') THEN
1397	message_string = 'radiation_scheme = "clear-sky" in combination'//&
1398	'with albedo_type = 0 requires setting of'// &
1399	'albedo /= 9999999.9'
1400	CALL message( 'check_parameters', 'PA0410', 1, 2, 0, 6, 0 )
1401	ENDIF
1402
1403	IF ( albedo_type == 0 .AND. radiation_scheme == 'rrtmg' .AND. &
1404	( albedo_lw_dif == 9999999.9_wp .OR. albedo_lw_dir == 9999999.9_wp&
1405	.OR. albedo_sw_dif == 9999999.9_wp .OR. albedo_sw_dir == 9999999.9_wp&
1406	) ) THEN
1407	message_string = 'radiation_scheme = "rrtmg" in combination' // &
1408	'with albedo_type = 0 requires setting of ' // &
1409	'albedo_lw_dif /= 9999999.9' // &
1410	'albedo_lw_dir /= 9999999.9' // &
1411	'albedo_sw_dif /= 9999999.9 and' // &
1412	'albedo_sw_dir /= 9999999.9'
1413	CALL message( 'check_parameters', 'PA0411', 1, 2, 0, 6, 0 )
1414	ENDIF
1415	ENDIF
1416	!
1417	!-- Parallel rad_angular_discretization without raytrace_mpi_rma is not implemented
1418	#if defined( __parallel )
1419	IF ( rad_angular_discretization .AND. .NOT. raytrace_mpi_rma ) THEN
1420	message_string = 'rad_angular_discretization can only be used ' // &
1421	'together with raytrace_mpi_rma or when ' // &
1422	'no parallelization is applied.'
1423	CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 )
1424	ENDIF
1425	#endif
1426
1427	IF ( cloud_droplets .AND. radiation_scheme == 'rrtmg' .AND. &
1428	average_radiation ) THEN
1429	message_string = 'average_radiation = .T. with radiation_scheme'// &
1430	'= "rrtmg" in combination cloud_droplets = .T.'// &
1431	'is not implementd'
1432	CALL message( 'check_parameters', 'PA0560', 1, 2, 0, 6, 0 )
1433	ENDIF
1434
1435	!
1436	!-- Incialize svf normalization reporting histogram
1437	svfnorm_report_num = 1
1438	DO WHILE ( svfnorm_report_thresh(svfnorm_report_num) < 1e20_wp &
1439	.AND. svfnorm_report_num <= 30 )
1440	svfnorm_report_num = svfnorm_report_num + 1
1441	ENDDO
1442	svfnorm_report_num = svfnorm_report_num - 1
1443	!
1444	!-- Check for dt_radiation
1445	IF ( dt_radiation <= 0.0 ) THEN
1446	message_string = 'dt_radiation must be > 0.0'
1447	CALL message( 'check_parameters', 'PA0591', 1, 2, 0, 6, 0 )
1448	ENDIF
1449
1450	END SUBROUTINE radiation_check_parameters
1451
1452
1453	!------------------------------------------------------------------------------!
1454	! Description:
1455	! ------------
1456	!> Initialization of the radiation model
1457	!------------------------------------------------------------------------------!
1458	SUBROUTINE radiation_init
1459
1460	IMPLICIT NONE
1461
1462	INTEGER(iwp) :: i !< running index x-direction
1463	INTEGER(iwp) :: ioff !< offset in x between surface element reference grid point in atmosphere and actual surface
1464	INTEGER(iwp) :: j !< running index y-direction
1465	INTEGER(iwp) :: joff !< offset in y between surface element reference grid point in atmosphere and actual surface
1466	INTEGER(iwp) :: l !< running index for orientation of vertical surfaces
1467	INTEGER(iwp) :: m !< running index for surface elements
1468	INTEGER(iwp) :: ntime = 0 !< number of available external radiation timesteps
1469	#if defined( __rrtmg )
1470	INTEGER(iwp) :: ind_type !< running index for subgrid-surface tiles
1471	#endif
1472	LOGICAL :: radiation_input_root_domain !< flag indicating the existence of a dynamic input file for the root domain
1473
1474
1475	IF ( debug_output ) CALL debug_message( 'radiation_init', 'start' )
1476	!
1477	!-- Activate radiation_interactions according to the existence of vertical surfaces and/or trees.
1478	!-- The namelist parameter radiation_interactions_on can override this behavior.
1479	!-- (This check cannot be performed in check_parameters, because vertical_surfaces_exist is first set in
1480	!-- init_surface_arrays.)
1481	IF ( radiation_interactions_on ) THEN
1482	IF ( vertical_surfaces_exist .OR. plant_canopy ) THEN
1483	radiation_interactions = .TRUE.
1484	average_radiation = .TRUE.
1485	ELSE
1486	radiation_interactions_on = .FALSE. !< reset namelist parameter: no interactions
1487	!< calculations necessary in case of flat surface
1488	ENDIF
1489	ELSEIF ( vertical_surfaces_exist .OR. plant_canopy ) THEN
1490	message_string = 'radiation_interactions_on is set to .FALSE. although ' // &
1491	'vertical surfaces and/or trees exist. The model will run ' // &
1492	'without RTM (no shadows, no radiation reflections)'
1493	CALL message( 'init_3d_model', 'PA0348', 0, 1, 0, 6, 0 )
1494	ENDIF
1495	!
1496	!-- If required, initialize radiation interactions between surfaces
1497	!-- via sky-view factors. This must be done before radiation is initialized.
1498	IF ( radiation_interactions ) CALL radiation_interaction_init
1499	!
1500	!-- Allocate array for storing the surface net radiation
1501	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_net ) .AND. &
1502	surf_lsm_h%ns > 0 ) THEN
1503	ALLOCATE( surf_lsm_h%rad_net(1:surf_lsm_h%ns) )
1504	surf_lsm_h%rad_net = 0.0_wp
1505	ENDIF
1506	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_net ) .AND. &
1507	surf_usm_h%ns > 0 ) THEN
1508	ALLOCATE( surf_usm_h%rad_net(1:surf_usm_h%ns) )
1509	surf_usm_h%rad_net = 0.0_wp
1510	ENDIF
1511	DO l = 0, 3
1512	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_net ) .AND. &
1513	surf_lsm_v(l)%ns > 0 ) THEN
1514	ALLOCATE( surf_lsm_v(l)%rad_net(1:surf_lsm_v(l)%ns) )
1515	surf_lsm_v(l)%rad_net = 0.0_wp
1516	ENDIF
1517	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_net ) .AND. &
1518	surf_usm_v(l)%ns > 0 ) THEN
1519	ALLOCATE( surf_usm_v(l)%rad_net(1:surf_usm_v(l)%ns) )
1520	surf_usm_v(l)%rad_net = 0.0_wp
1521	ENDIF
1522	ENDDO
1523
1524
1525	!
1526	!-- Allocate array for storing the surface longwave (out) radiation change
1527	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_lw_out_change_0 ) .AND. &
1528	surf_lsm_h%ns > 0 ) THEN
1529	ALLOCATE( surf_lsm_h%rad_lw_out_change_0(1:surf_lsm_h%ns) )
1530	surf_lsm_h%rad_lw_out_change_0 = 0.0_wp
1531	ENDIF
1532	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_lw_out_change_0 ) .AND. &
1533	surf_usm_h%ns > 0 ) THEN
1534	ALLOCATE( surf_usm_h%rad_lw_out_change_0(1:surf_usm_h%ns) )
1535	surf_usm_h%rad_lw_out_change_0 = 0.0_wp
1536	ENDIF
1537	DO l = 0, 3
1538	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_lw_out_change_0 ) .AND. &
1539	surf_lsm_v(l)%ns > 0 ) THEN
1540	ALLOCATE( surf_lsm_v(l)%rad_lw_out_change_0(1:surf_lsm_v(l)%ns) )
1541	surf_lsm_v(l)%rad_lw_out_change_0 = 0.0_wp
1542	ENDIF
1543	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_lw_out_change_0 ) .AND. &
1544	surf_usm_v(l)%ns > 0 ) THEN
1545	ALLOCATE( surf_usm_v(l)%rad_lw_out_change_0(1:surf_usm_v(l)%ns) )
1546	surf_usm_v(l)%rad_lw_out_change_0 = 0.0_wp
1547	ENDIF
1548	ENDDO
1549
1550	!
1551	!-- Allocate surface arrays for incoming/outgoing short/longwave radiation
1552	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_sw_in ) .AND. &
1553	surf_lsm_h%ns > 0 ) THEN
1554	ALLOCATE( surf_lsm_h%rad_sw_in(1:surf_lsm_h%ns) )
1555	ALLOCATE( surf_lsm_h%rad_sw_out(1:surf_lsm_h%ns) )
1556	ALLOCATE( surf_lsm_h%rad_sw_dir(1:surf_lsm_h%ns) )
1557	ALLOCATE( surf_lsm_h%rad_sw_dif(1:surf_lsm_h%ns) )
1558	ALLOCATE( surf_lsm_h%rad_sw_ref(1:surf_lsm_h%ns) )
1559	ALLOCATE( surf_lsm_h%rad_sw_res(1:surf_lsm_h%ns) )
1560	ALLOCATE( surf_lsm_h%rad_lw_in(1:surf_lsm_h%ns) )
1561	ALLOCATE( surf_lsm_h%rad_lw_out(1:surf_lsm_h%ns) )
1562	ALLOCATE( surf_lsm_h%rad_lw_dif(1:surf_lsm_h%ns) )
1563	ALLOCATE( surf_lsm_h%rad_lw_ref(1:surf_lsm_h%ns) )
1564	ALLOCATE( surf_lsm_h%rad_lw_res(1:surf_lsm_h%ns) )
1565	surf_lsm_h%rad_sw_in = 0.0_wp
1566	surf_lsm_h%rad_sw_out = 0.0_wp
1567	surf_lsm_h%rad_sw_dir = 0.0_wp
1568	surf_lsm_h%rad_sw_dif = 0.0_wp
1569	surf_lsm_h%rad_sw_ref = 0.0_wp
1570	surf_lsm_h%rad_sw_res = 0.0_wp
1571	surf_lsm_h%rad_lw_in = 0.0_wp
1572	surf_lsm_h%rad_lw_out = 0.0_wp
1573	surf_lsm_h%rad_lw_dif = 0.0_wp
1574	surf_lsm_h%rad_lw_ref = 0.0_wp
1575	surf_lsm_h%rad_lw_res = 0.0_wp
1576	ENDIF
1577	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_sw_in ) .AND. &
1578	surf_usm_h%ns > 0 ) THEN
1579	ALLOCATE( surf_usm_h%rad_sw_in(1:surf_usm_h%ns) )
1580	ALLOCATE( surf_usm_h%rad_sw_out(1:surf_usm_h%ns) )
1581	ALLOCATE( surf_usm_h%rad_sw_dir(1:surf_usm_h%ns) )
1582	ALLOCATE( surf_usm_h%rad_sw_dif(1:surf_usm_h%ns) )
1583	ALLOCATE( surf_usm_h%rad_sw_ref(1:surf_usm_h%ns) )
1584	ALLOCATE( surf_usm_h%rad_sw_res(1:surf_usm_h%ns) )
1585	ALLOCATE( surf_usm_h%rad_lw_in(1:surf_usm_h%ns) )
1586	ALLOCATE( surf_usm_h%rad_lw_out(1:surf_usm_h%ns) )
1587	ALLOCATE( surf_usm_h%rad_lw_dif(1:surf_usm_h%ns) )
1588	ALLOCATE( surf_usm_h%rad_lw_ref(1:surf_usm_h%ns) )
1589	ALLOCATE( surf_usm_h%rad_lw_res(1:surf_usm_h%ns) )
1590	surf_usm_h%rad_sw_in = 0.0_wp
1591	surf_usm_h%rad_sw_out = 0.0_wp
1592	surf_usm_h%rad_sw_dir = 0.0_wp
1593	surf_usm_h%rad_sw_dif = 0.0_wp
1594	surf_usm_h%rad_sw_ref = 0.0_wp
1595	surf_usm_h%rad_sw_res = 0.0_wp
1596	surf_usm_h%rad_lw_in = 0.0_wp
1597	surf_usm_h%rad_lw_out = 0.0_wp
1598	surf_usm_h%rad_lw_dif = 0.0_wp
1599	surf_usm_h%rad_lw_ref = 0.0_wp
1600	surf_usm_h%rad_lw_res = 0.0_wp
1601	ENDIF
1602	DO l = 0, 3
1603	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_sw_in ) .AND. &
1604	surf_lsm_v(l)%ns > 0 ) THEN
1605	ALLOCATE( surf_lsm_v(l)%rad_sw_in(1:surf_lsm_v(l)%ns) )
1606	ALLOCATE( surf_lsm_v(l)%rad_sw_out(1:surf_lsm_v(l)%ns) )
1607	ALLOCATE( surf_lsm_v(l)%rad_sw_dir(1:surf_lsm_v(l)%ns) )
1608	ALLOCATE( surf_lsm_v(l)%rad_sw_dif(1:surf_lsm_v(l)%ns) )
1609	ALLOCATE( surf_lsm_v(l)%rad_sw_ref(1:surf_lsm_v(l)%ns) )
1610	ALLOCATE( surf_lsm_v(l)%rad_sw_res(1:surf_lsm_v(l)%ns) )
1611
1612	ALLOCATE( surf_lsm_v(l)%rad_lw_in(1:surf_lsm_v(l)%ns) )
1613	ALLOCATE( surf_lsm_v(l)%rad_lw_out(1:surf_lsm_v(l)%ns) )
1614	ALLOCATE( surf_lsm_v(l)%rad_lw_dif(1:surf_lsm_v(l)%ns) )
1615	ALLOCATE( surf_lsm_v(l)%rad_lw_ref(1:surf_lsm_v(l)%ns) )
1616	ALLOCATE( surf_lsm_v(l)%rad_lw_res(1:surf_lsm_v(l)%ns) )
1617
1618	surf_lsm_v(l)%rad_sw_in = 0.0_wp
1619	surf_lsm_v(l)%rad_sw_out = 0.0_wp
1620	surf_lsm_v(l)%rad_sw_dir = 0.0_wp
1621	surf_lsm_v(l)%rad_sw_dif = 0.0_wp
1622	surf_lsm_v(l)%rad_sw_ref = 0.0_wp
1623	surf_lsm_v(l)%rad_sw_res = 0.0_wp
1624
1625	surf_lsm_v(l)%rad_lw_in = 0.0_wp
1626	surf_lsm_v(l)%rad_lw_out = 0.0_wp
1627	surf_lsm_v(l)%rad_lw_dif = 0.0_wp
1628	surf_lsm_v(l)%rad_lw_ref = 0.0_wp
1629	surf_lsm_v(l)%rad_lw_res = 0.0_wp
1630	ENDIF
1631	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_sw_in ) .AND. &
1632	surf_usm_v(l)%ns > 0 ) THEN
1633	ALLOCATE( surf_usm_v(l)%rad_sw_in(1:surf_usm_v(l)%ns) )
1634	ALLOCATE( surf_usm_v(l)%rad_sw_out(1:surf_usm_v(l)%ns) )
1635	ALLOCATE( surf_usm_v(l)%rad_sw_dir(1:surf_usm_v(l)%ns) )
1636	ALLOCATE( surf_usm_v(l)%rad_sw_dif(1:surf_usm_v(l)%ns) )
1637	ALLOCATE( surf_usm_v(l)%rad_sw_ref(1:surf_usm_v(l)%ns) )
1638	ALLOCATE( surf_usm_v(l)%rad_sw_res(1:surf_usm_v(l)%ns) )
1639	ALLOCATE( surf_usm_v(l)%rad_lw_in(1:surf_usm_v(l)%ns) )
1640	ALLOCATE( surf_usm_v(l)%rad_lw_out(1:surf_usm_v(l)%ns) )
1641	ALLOCATE( surf_usm_v(l)%rad_lw_dif(1:surf_usm_v(l)%ns) )
1642	ALLOCATE( surf_usm_v(l)%rad_lw_ref(1:surf_usm_v(l)%ns) )
1643	ALLOCATE( surf_usm_v(l)%rad_lw_res(1:surf_usm_v(l)%ns) )
1644	surf_usm_v(l)%rad_sw_in = 0.0_wp
1645	surf_usm_v(l)%rad_sw_out = 0.0_wp
1646	surf_usm_v(l)%rad_sw_dir = 0.0_wp
1647	surf_usm_v(l)%rad_sw_dif = 0.0_wp
1648	surf_usm_v(l)%rad_sw_ref = 0.0_wp
1649	surf_usm_v(l)%rad_sw_res = 0.0_wp
1650	surf_usm_v(l)%rad_lw_in = 0.0_wp
1651	surf_usm_v(l)%rad_lw_out = 0.0_wp
1652	surf_usm_v(l)%rad_lw_dif = 0.0_wp
1653	surf_usm_v(l)%rad_lw_ref = 0.0_wp
1654	surf_usm_v(l)%rad_lw_res = 0.0_wp
1655	ENDIF
1656	ENDDO
1657	!
1658	!-- Fix net radiation in case of radiation_scheme = 'constant'
1659	IF ( radiation_scheme == 'constant' ) THEN
1660	IF ( ALLOCATED( surf_lsm_h%rad_net ) ) &
1661	surf_lsm_h%rad_net = net_radiation
1662	IF ( ALLOCATED( surf_usm_h%rad_net ) ) &
1663	surf_usm_h%rad_net = net_radiation
1664	!
1665	!-- Todo: weight with inclination angle
1666	DO l = 0, 3
1667	IF ( ALLOCATED( surf_lsm_v(l)%rad_net ) ) &
1668	surf_lsm_v(l)%rad_net = net_radiation
1669	IF ( ALLOCATED( surf_usm_v(l)%rad_net ) ) &
1670	surf_usm_v(l)%rad_net = net_radiation
1671	ENDDO
1672	! radiation = .FALSE.
1673	!
1674	!-- Calculate orbital constants
1675	ELSE
1676	decl_1 = SIN(23.45_wp * pi / 180.0_wp)
1677	decl_2 = 2.0_wp * pi / 365.0_wp
1678	decl_3 = decl_2 * 81.0_wp
1679	lat = latitude * pi / 180.0_wp
1680	lon = longitude * pi / 180.0_wp
1681	ENDIF
1682
1683	IF ( radiation_scheme == 'clear-sky' .OR. &
1684	radiation_scheme == 'constant' .OR. &
1685	radiation_scheme == 'external' ) THEN
1686	!
1687	!-- Allocate arrays for incoming/outgoing short/longwave radiation
1688	IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN
1689	ALLOCATE ( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) )
1690	ENDIF
1691	IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN
1692	ALLOCATE ( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) )
1693	ENDIF
1694
1695	IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN
1696	ALLOCATE ( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) )
1697	ENDIF
1698	IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN
1699	ALLOCATE ( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) )
1700	ENDIF
1701
1702	!
1703	!-- Allocate average arrays for incoming/outgoing short/longwave radiation
1704	IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN
1705	ALLOCATE ( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
1706	ENDIF
1707	IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN
1708	ALLOCATE ( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
1709	ENDIF
1710
1711	IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN
1712	ALLOCATE ( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
1713	ENDIF
1714	IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN
1715	ALLOCATE ( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
1716	ENDIF
1717	!
1718	!-- Allocate arrays for broadband albedo, and level 1 initialization
1719	!-- via namelist paramter, unless not already allocated.
1720	IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) THEN
1721	ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) )
1722	surf_lsm_h%albedo = albedo
1723	ENDIF
1724	IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) THEN
1725	ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) )
1726	surf_usm_h%albedo = albedo
1727	ENDIF
1728
1729	DO l = 0, 3
1730	IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) THEN
1731	ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) )
1732	surf_lsm_v(l)%albedo = albedo
1733	ENDIF
1734	IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) THEN
1735	ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) )
1736	surf_usm_v(l)%albedo = albedo
1737	ENDIF
1738	ENDDO
1739	!
1740	!-- Level 2 initialization of broadband albedo via given albedo_type.
1741	!-- Only if albedo_type is non-zero. In case of urban surface and
1742	!-- input data is read from ASCII file, albedo_type will be zero, so that
1743	!-- albedo won't be overwritten.
1744	DO m = 1, surf_lsm_h%ns
1745	IF ( surf_lsm_h%albedo_type(ind_veg_wall,m) /= 0 ) &
1746	surf_lsm_h%albedo(ind_veg_wall,m) = &
1747	albedo_pars(0,surf_lsm_h%albedo_type(ind_veg_wall,m))
1748	IF ( surf_lsm_h%albedo_type(ind_pav_green,m) /= 0 ) &
1749	surf_lsm_h%albedo(ind_pav_green,m) = &
1750	albedo_pars(0,surf_lsm_h%albedo_type(ind_pav_green,m))
1751	IF ( surf_lsm_h%albedo_type(ind_wat_win,m) /= 0 ) &
1752	surf_lsm_h%albedo(ind_wat_win,m) = &
1753	albedo_pars(0,surf_lsm_h%albedo_type(ind_wat_win,m))
1754	ENDDO
1755	DO m = 1, surf_usm_h%ns
1756	IF ( surf_usm_h%albedo_type(ind_veg_wall,m) /= 0 ) &
1757	surf_usm_h%albedo(ind_veg_wall,m) = &
1758	albedo_pars(0,surf_usm_h%albedo_type(ind_veg_wall,m))
1759	IF ( surf_usm_h%albedo_type(ind_pav_green,m) /= 0 ) &
1760	surf_usm_h%albedo(ind_pav_green,m) = &
1761	albedo_pars(0,surf_usm_h%albedo_type(ind_pav_green,m))
1762	IF ( surf_usm_h%albedo_type(ind_wat_win,m) /= 0 ) &
1763	surf_usm_h%albedo(ind_wat_win,m) = &
1764	albedo_pars(0,surf_usm_h%albedo_type(ind_wat_win,m))
1765	ENDDO
1766
1767	DO l = 0, 3
1768	DO m = 1, surf_lsm_v(l)%ns
1769	IF ( surf_lsm_v(l)%albedo_type(ind_veg_wall,m) /= 0 ) &
1770	surf_lsm_v(l)%albedo(ind_veg_wall,m) = &
1771	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_veg_wall,m))
1772	IF ( surf_lsm_v(l)%albedo_type(ind_pav_green,m) /= 0 ) &
1773	surf_lsm_v(l)%albedo(ind_pav_green,m) = &
1774	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_pav_green,m))
1775	IF ( surf_lsm_v(l)%albedo_type(ind_wat_win,m) /= 0 ) &
1776	surf_lsm_v(l)%albedo(ind_wat_win,m) = &
1777	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_wat_win,m))
1778	ENDDO
1779	DO m = 1, surf_usm_v(l)%ns
1780	IF ( surf_usm_v(l)%albedo_type(ind_veg_wall,m) /= 0 ) &
1781	surf_usm_v(l)%albedo(ind_veg_wall,m) = &
1782	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_veg_wall,m))
1783	IF ( surf_usm_v(l)%albedo_type(ind_pav_green,m) /= 0 ) &
1784	surf_usm_v(l)%albedo(ind_pav_green,m) = &
1785	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_pav_green,m))
1786	IF ( surf_usm_v(l)%albedo_type(ind_wat_win,m) /= 0 ) &
1787	surf_usm_v(l)%albedo(ind_wat_win,m) = &
1788	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_wat_win,m))
1789	ENDDO
1790	ENDDO
1791
1792	!
1793	!-- Level 3 initialization at grid points where albedo type is zero.
1794	!-- This case, albedo is taken from file. In case of constant radiation
1795	!-- or clear sky, only broadband albedo is given.
1796	IF ( albedo_pars_f%from_file ) THEN
1797	!
1798	!-- Horizontal surfaces
1799	DO m = 1, surf_lsm_h%ns
1800	i = surf_lsm_h%i(m)
1801	j = surf_lsm_h%j(m)
1802	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1803	surf_lsm_h%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1804	surf_lsm_h%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1805	surf_lsm_h%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1806	ENDIF
1807	ENDDO
1808	DO m = 1, surf_usm_h%ns
1809	i = surf_usm_h%i(m)
1810	j = surf_usm_h%j(m)
1811	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1812	surf_usm_h%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1813	surf_usm_h%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1814	surf_usm_h%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1815	ENDIF
1816	ENDDO
1817	!
1818	!-- Vertical surfaces
1819	DO l = 0, 3
1820
1821	ioff = surf_lsm_v(l)%ioff
1822	joff = surf_lsm_v(l)%joff
1823	DO m = 1, surf_lsm_v(l)%ns
1824	i = surf_lsm_v(l)%i(m) + ioff
1825	j = surf_lsm_v(l)%j(m) + joff
1826	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1827	surf_lsm_v(l)%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1828	surf_lsm_v(l)%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1829	surf_lsm_v(l)%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1830	ENDIF
1831	ENDDO
1832
1833	ioff = surf_usm_v(l)%ioff
1834	joff = surf_usm_v(l)%joff
1835	DO m = 1, surf_usm_v(l)%ns
1836	i = surf_usm_v(l)%i(m) + joff
1837	j = surf_usm_v(l)%j(m) + joff
1838	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1839	surf_usm_v(l)%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1840	surf_usm_v(l)%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1841	surf_usm_v(l)%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1842	ENDIF
1843	ENDDO
1844	ENDDO
1845
1846	ENDIF
1847	!
1848	!-- Initialization actions for RRTMG
1849	ELSEIF ( radiation_scheme == 'rrtmg' ) THEN
1850	#if defined ( __rrtmg )
1851	!
1852	!-- Allocate albedos for short/longwave radiation, horizontal surfaces
1853	!-- for wall/green/window (USM) or vegetation/pavement/water surfaces
1854	!-- (LSM).
1855	ALLOCATE ( surf_lsm_h%aldif(0:2,1:surf_lsm_h%ns) )
1856	ALLOCATE ( surf_lsm_h%aldir(0:2,1:surf_lsm_h%ns) )
1857	ALLOCATE ( surf_lsm_h%asdif(0:2,1:surf_lsm_h%ns) )
1858	ALLOCATE ( surf_lsm_h%asdir(0:2,1:surf_lsm_h%ns) )
1859	ALLOCATE ( surf_lsm_h%rrtm_aldif(0:2,1:surf_lsm_h%ns) )
1860	ALLOCATE ( surf_lsm_h%rrtm_aldir(0:2,1:surf_lsm_h%ns) )
1861	ALLOCATE ( surf_lsm_h%rrtm_asdif(0:2,1:surf_lsm_h%ns) )
1862	ALLOCATE ( surf_lsm_h%rrtm_asdir(0:2,1:surf_lsm_h%ns) )
1863
1864	ALLOCATE ( surf_usm_h%aldif(0:2,1:surf_usm_h%ns) )
1865	ALLOCATE ( surf_usm_h%aldir(0:2,1:surf_usm_h%ns) )
1866	ALLOCATE ( surf_usm_h%asdif(0:2,1:surf_usm_h%ns) )
1867	ALLOCATE ( surf_usm_h%asdir(0:2,1:surf_usm_h%ns) )
1868	ALLOCATE ( surf_usm_h%rrtm_aldif(0:2,1:surf_usm_h%ns) )
1869	ALLOCATE ( surf_usm_h%rrtm_aldir(0:2,1:surf_usm_h%ns) )
1870	ALLOCATE ( surf_usm_h%rrtm_asdif(0:2,1:surf_usm_h%ns) )
1871	ALLOCATE ( surf_usm_h%rrtm_asdir(0:2,1:surf_usm_h%ns) )
1872
1873	!
1874	!-- Allocate broadband albedo (temporary for the current radiation
1875	!-- implementations)
1876	IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) &
1877	ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) )
1878	IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) &
1879	ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) )
1880
1881	!
1882	!-- Allocate albedos for short/longwave radiation, vertical surfaces
1883	DO l = 0, 3
1884
1885	ALLOCATE ( surf_lsm_v(l)%aldif(0:2,1:surf_lsm_v(l)%ns) )
1886	ALLOCATE ( surf_lsm_v(l)%aldir(0:2,1:surf_lsm_v(l)%ns) )
1887	ALLOCATE ( surf_lsm_v(l)%asdif(0:2,1:surf_lsm_v(l)%ns) )
1888	ALLOCATE ( surf_lsm_v(l)%asdir(0:2,1:surf_lsm_v(l)%ns) )
1889
1890	ALLOCATE ( surf_lsm_v(l)%rrtm_aldif(0:2,1:surf_lsm_v(l)%ns) )
1891	ALLOCATE ( surf_lsm_v(l)%rrtm_aldir(0:2,1:surf_lsm_v(l)%ns) )
1892	ALLOCATE ( surf_lsm_v(l)%rrtm_asdif(0:2,1:surf_lsm_v(l)%ns) )
1893	ALLOCATE ( surf_lsm_v(l)%rrtm_asdir(0:2,1:surf_lsm_v(l)%ns) )
1894
1895	ALLOCATE ( surf_usm_v(l)%aldif(0:2,1:surf_usm_v(l)%ns) )
1896	ALLOCATE ( surf_usm_v(l)%aldir(0:2,1:surf_usm_v(l)%ns) )
1897	ALLOCATE ( surf_usm_v(l)%asdif(0:2,1:surf_usm_v(l)%ns) )
1898	ALLOCATE ( surf_usm_v(l)%asdir(0:2,1:surf_usm_v(l)%ns) )
1899
1900	ALLOCATE ( surf_usm_v(l)%rrtm_aldif(0:2,1:surf_usm_v(l)%ns) )
1901	ALLOCATE ( surf_usm_v(l)%rrtm_aldir(0:2,1:surf_usm_v(l)%ns) )
1902	ALLOCATE ( surf_usm_v(l)%rrtm_asdif(0:2,1:surf_usm_v(l)%ns) )
1903	ALLOCATE ( surf_usm_v(l)%rrtm_asdir(0:2,1:surf_usm_v(l)%ns) )
1904	!
1905	!-- Allocate broadband albedo (temporary for the current radiation
1906	!-- implementations)
1907	IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) &
1908	ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) )
1909	IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) &
1910	ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) )
1911
1912	ENDDO
1913	!
1914	!-- Level 1 initialization of spectral albedos via namelist
1915	!-- paramters. Please note, this case all surface tiles are initialized
1916	!-- the same.
1917	IF ( surf_lsm_h%ns > 0 ) THEN
1918	surf_lsm_h%aldif = albedo_lw_dif
1919	surf_lsm_h%aldir = albedo_lw_dir
1920	surf_lsm_h%asdif = albedo_sw_dif
1921	surf_lsm_h%asdir = albedo_sw_dir
1922	surf_lsm_h%albedo = albedo_sw_dif
1923	ENDIF
1924	IF ( surf_usm_h%ns > 0 ) THEN
1925	IF ( surf_usm_h%albedo_from_ascii ) THEN
1926	surf_usm_h%aldif = surf_usm_h%albedo
1927	surf_usm_h%aldir = surf_usm_h%albedo
1928	surf_usm_h%asdif = surf_usm_h%albedo
1929	surf_usm_h%asdir = surf_usm_h%albedo
1930	ELSE
1931	surf_usm_h%aldif = albedo_lw_dif
1932	surf_usm_h%aldir = albedo_lw_dir
1933	surf_usm_h%asdif = albedo_sw_dif
1934	surf_usm_h%asdir = albedo_sw_dir
1935	surf_usm_h%albedo = albedo_sw_dif
1936	ENDIF
1937	ENDIF
1938
1939	DO l = 0, 3
1940
1941	IF ( surf_lsm_v(l)%ns > 0 ) THEN
1942	surf_lsm_v(l)%aldif = albedo_lw_dif
1943	surf_lsm_v(l)%aldir = albedo_lw_dir
1944	surf_lsm_v(l)%asdif = albedo_sw_dif
1945	surf_lsm_v(l)%asdir = albedo_sw_dir
1946	surf_lsm_v(l)%albedo = albedo_sw_dif
1947	ENDIF
1948
1949	IF ( surf_usm_v(l)%ns > 0 ) THEN
1950	IF ( surf_usm_v(l)%albedo_from_ascii ) THEN
1951	surf_usm_v(l)%aldif = surf_usm_v(l)%albedo
1952	surf_usm_v(l)%aldir = surf_usm_v(l)%albedo
1953	surf_usm_v(l)%asdif = surf_usm_v(l)%albedo
1954	surf_usm_v(l)%asdir = surf_usm_v(l)%albedo
1955	ELSE
1956	surf_usm_v(l)%aldif = albedo_lw_dif
1957	surf_usm_v(l)%aldir = albedo_lw_dir
1958	surf_usm_v(l)%asdif = albedo_sw_dif
1959	surf_usm_v(l)%asdir = albedo_sw_dir
1960	ENDIF
1961	ENDIF
1962	ENDDO
1963
1964	!
1965	!-- Level 2 initialization of spectral albedos via albedo_type.
1966	!-- Please note, for natural- and urban-type surfaces, a tile approach
1967	!-- is applied so that the resulting albedo is calculated via the weighted
1968	!-- average of respective surface fractions.
1969	DO m = 1, surf_lsm_h%ns
1970	!
1971	!-- Spectral albedos for vegetation/pavement/water surfaces
1972	DO ind_type = 0, 2
1973	IF ( surf_lsm_h%albedo_type(ind_type,m) /= 0 ) THEN
1974	surf_lsm_h%aldif(ind_type,m) = &
1975	albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m))
1976	surf_lsm_h%asdif(ind_type,m) = &
1977	albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m))
1978	surf_lsm_h%aldir(ind_type,m) = &
1979	albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m))
1980	surf_lsm_h%asdir(ind_type,m) = &
1981	albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m))
1982	surf_lsm_h%albedo(ind_type,m) = &
1983	albedo_pars(0,surf_lsm_h%albedo_type(ind_type,m))
1984	ENDIF
1985	ENDDO
1986
1987	ENDDO
1988	!
1989	!-- For urban surface only if albedo has not been already initialized
1990	!-- in the urban-surface model via the ASCII file.
1991	IF ( .NOT. surf_usm_h%albedo_from_ascii ) THEN
1992	DO m = 1, surf_usm_h%ns
1993	!
1994	!-- Spectral albedos for wall/green/window surfaces
1995	DO ind_type = 0, 2
1996	IF ( surf_usm_h%albedo_type(ind_type,m) /= 0 ) THEN
1997	surf_usm_h%aldif(ind_type,m) = &
1998	albedo_pars(1,surf_usm_h%albedo_type(ind_type,m))
1999	surf_usm_h%asdif(ind_type,m) = &
2000	albedo_pars(2,surf_usm_h%albedo_type(ind_type,m))
2001	surf_usm_h%aldir(ind_type,m) = &
2002	albedo_pars(1,surf_usm_h%albedo_type(ind_type,m))
2003	surf_usm_h%asdir(ind_type,m) = &
2004	albedo_pars(2,surf_usm_h%albedo_type(ind_type,m))
2005	surf_usm_h%albedo(ind_type,m) = &
2006	albedo_pars(0,surf_usm_h%albedo_type(ind_type,m))
2007	ENDIF
2008	ENDDO
2009
2010	ENDDO
2011	ENDIF
2012
2013	DO l = 0, 3
2014
2015	DO m = 1, surf_lsm_v(l)%ns
2016	!
2017	!-- Spectral albedos for vegetation/pavement/water surfaces
2018	DO ind_type = 0, 2
2019	IF ( surf_lsm_v(l)%albedo_type(ind_type,m) /= 0 ) THEN
2020	surf_lsm_v(l)%aldif(ind_type,m) = &
2021	albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m))
2022	surf_lsm_v(l)%asdif(ind_type,m) = &
2023	albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m))
2024	surf_lsm_v(l)%aldir(ind_type,m) = &
2025	albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m))
2026	surf_lsm_v(l)%asdir(ind_type,m) = &
2027	albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m))
2028	surf_lsm_v(l)%albedo(ind_type,m) = &
2029	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_type,m))
2030	ENDIF
2031	ENDDO
2032	ENDDO
2033	!
2034	!-- For urban surface only if albedo has not been already initialized
2035	!-- in the urban-surface model via the ASCII file.
2036	IF ( .NOT. surf_usm_v(l)%albedo_from_ascii ) THEN
2037	DO m = 1, surf_usm_v(l)%ns
2038	!
2039	!-- Spectral albedos for wall/green/window surfaces
2040	DO ind_type = 0, 2
2041	IF ( surf_usm_v(l)%albedo_type(ind_type,m) /= 0 ) THEN
2042	surf_usm_v(l)%aldif(ind_type,m) = &
2043	albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m))
2044	surf_usm_v(l)%asdif(ind_type,m) = &
2045	albedo_pars(2,surf_usm_v(l)%albedo_type(ind_type,m))
2046	surf_usm_v(l)%aldir(ind_type,m) = &
2047	albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m))
2048	surf_usm_v(l)%asdir(ind_type,m) = &
2049	albedo_pars(2,surf_usm_v(l)%albedo_type(ind_type,m))
2050	surf_usm_v(l)%albedo(ind_type,m) = &
2051	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_type,m))
2052	ENDIF
2053	ENDDO
2054
2055	ENDDO
2056	ENDIF
2057	ENDDO
2058	!
2059	!-- Level 3 initialization at grid points where albedo type is zero.
2060	!-- This case, spectral albedos are taken from file if available
2061	IF ( albedo_pars_f%from_file ) THEN
2062	!
2063	!-- Horizontal
2064	DO m = 1, surf_lsm_h%ns
2065	i = surf_lsm_h%i(m)
2066	j = surf_lsm_h%j(m)
2067	!
2068	!-- Spectral albedos for vegetation/pavement/water surfaces
2069	DO ind_type = 0, 2
2070	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) &
2071	surf_lsm_h%albedo(ind_type,m) = &
2072	albedo_pars_f%pars_xy(0,j,i)
2073	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) &
2074	surf_lsm_h%aldir(ind_type,m) = &
2075	albedo_pars_f%pars_xy(1,j,i)
2076	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) &
2077	surf_lsm_h%aldif(ind_type,m) = &
2078	albedo_pars_f%pars_xy(1,j,i)
2079	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) &
2080	surf_lsm_h%asdir(ind_type,m) = &
2081	albedo_pars_f%pars_xy(2,j,i)
2082	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) &
2083	surf_lsm_h%asdif(ind_type,m) = &
2084	albedo_pars_f%pars_xy(2,j,i)
2085	ENDDO
2086	ENDDO
2087	!
2088	!-- For urban surface only if albedo has not been already initialized
2089	!-- in the urban-surface model via the ASCII file.
2090	IF ( .NOT. surf_usm_h%albedo_from_ascii ) THEN
2091	DO m = 1, surf_usm_h%ns
2092	i = surf_usm_h%i(m)
2093	j = surf_usm_h%j(m)
2094	!
2095	!-- Broadband albedos for wall/green/window surfaces
2096	DO ind_type = 0, 2
2097	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )&
2098	surf_usm_h%albedo(ind_type,m) = &
2099	albedo_pars_f%pars_xy(0,j,i)
2100	ENDDO
2101	!
2102	!-- Spectral albedos especially for building wall surfaces
2103	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) THEN
2104	surf_usm_h%aldir(ind_veg_wall,m) = &
2105	albedo_pars_f%pars_xy(1,j,i)
2106	surf_usm_h%aldif(ind_veg_wall,m) = &
2107	albedo_pars_f%pars_xy(1,j,i)
2108	ENDIF
2109	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) THEN
2110	surf_usm_h%asdir(ind_veg_wall,m) = &
2111	albedo_pars_f%pars_xy(2,j,i)
2112	surf_usm_h%asdif(ind_veg_wall,m) = &
2113	albedo_pars_f%pars_xy(2,j,i)
2114	ENDIF
2115	!
2116	!-- Spectral albedos especially for building green surfaces
2117	IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill ) THEN
2118	surf_usm_h%aldir(ind_pav_green,m) = &
2119	albedo_pars_f%pars_xy(3,j,i)
2120	surf_usm_h%aldif(ind_pav_green,m) = &
2121	albedo_pars_f%pars_xy(3,j,i)
2122	ENDIF
2123	IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill ) THEN
2124	surf_usm_h%asdir(ind_pav_green,m) = &
2125	albedo_pars_f%pars_xy(4,j,i)
2126	surf_usm_h%asdif(ind_pav_green,m) = &
2127	albedo_pars_f%pars_xy(4,j,i)
2128	ENDIF
2129	!
2130	!-- Spectral albedos especially for building window surfaces
2131	IF ( albedo_pars_f%pars_xy(5,j,i) /= albedo_pars_f%fill ) THEN
2132	surf_usm_h%aldir(ind_wat_win,m) = &
2133	albedo_pars_f%pars_xy(5,j,i)
2134	surf_usm_h%aldif(ind_wat_win,m) = &
2135	albedo_pars_f%pars_xy(5,j,i)
2136	ENDIF
2137	IF ( albedo_pars_f%pars_xy(6,j,i) /= albedo_pars_f%fill ) THEN
2138	surf_usm_h%asdir(ind_wat_win,m) = &
2139	albedo_pars_f%pars_xy(6,j,i)
2140	surf_usm_h%asdif(ind_wat_win,m) = &
2141	albedo_pars_f%pars_xy(6,j,i)
2142	ENDIF
2143
2144	ENDDO
2145	ENDIF
2146	!
2147	!-- Vertical
2148	DO l = 0, 3
2149	ioff = surf_lsm_v(l)%ioff
2150	joff = surf_lsm_v(l)%joff
2151
2152	DO m = 1, surf_lsm_v(l)%ns
2153	i = surf_lsm_v(l)%i(m)
2154	j = surf_lsm_v(l)%j(m)
2155	!
2156	!-- Spectral albedos for vegetation/pavement/water surfaces
2157	DO ind_type = 0, 2
2158	IF ( albedo_pars_f%pars_xy(0,j+joff,i+ioff) /= &
2159	albedo_pars_f%fill ) &
2160	surf_lsm_v(l)%albedo(ind_type,m) = &
2161	albedo_pars_f%pars_xy(0,j+joff,i+ioff)
2162	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2163	albedo_pars_f%fill ) &
2164	surf_lsm_v(l)%aldir(ind_type,m) = &
2165	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2166	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2167	albedo_pars_f%fill ) &
2168	surf_lsm_v(l)%aldif(ind_type,m) = &
2169	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2170	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2171	albedo_pars_f%fill ) &
2172	surf_lsm_v(l)%asdir(ind_type,m) = &
2173	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2174	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2175	albedo_pars_f%fill ) &
2176	surf_lsm_v(l)%asdif(ind_type,m) = &
2177	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2178	ENDDO
2179	ENDDO
2180	!
2181	!-- For urban surface only if albedo has not been already initialized
2182	!-- in the urban-surface model via the ASCII file.
2183	IF ( .NOT. surf_usm_v(l)%albedo_from_ascii ) THEN
2184	ioff = surf_usm_v(l)%ioff
2185	joff = surf_usm_v(l)%joff
2186
2187	DO m = 1, surf_usm_v(l)%ns
2188	i = surf_usm_v(l)%i(m)
2189	j = surf_usm_v(l)%j(m)
2190	!
2191	!-- Broadband albedos for wall/green/window surfaces
2192	DO ind_type = 0, 2
2193	IF ( albedo_pars_f%pars_xy(0,j+joff,i+ioff) /= &
2194	albedo_pars_f%fill ) &
2195	surf_usm_v(l)%albedo(ind_type,m) = &
2196	albedo_pars_f%pars_xy(0,j+joff,i+ioff)
2197	ENDDO
2198	!
2199	!-- Spectral albedos especially for building wall surfaces
2200	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2201	albedo_pars_f%fill ) THEN
2202	surf_usm_v(l)%aldir(ind_veg_wall,m) = &
2203	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2204	surf_usm_v(l)%aldif(ind_veg_wall,m) = &
2205	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2206	ENDIF
2207	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2208	albedo_pars_f%fill ) THEN
2209	surf_usm_v(l)%asdir(ind_veg_wall,m) = &
2210	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2211	surf_usm_v(l)%asdif(ind_veg_wall,m) = &
2212	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2213	ENDIF
2214	!
2215	!-- Spectral albedos especially for building green surfaces
2216	IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= &
2217	albedo_pars_f%fill ) THEN
2218	surf_usm_v(l)%aldir(ind_pav_green,m) = &
2219	albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2220	surf_usm_v(l)%aldif(ind_pav_green,m) = &
2221	albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2222	ENDIF
2223	IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= &
2224	albedo_pars_f%fill ) THEN
2225	surf_usm_v(l)%asdir(ind_pav_green,m) = &
2226	albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2227	surf_usm_v(l)%asdif(ind_pav_green,m) = &
2228	albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2229	ENDIF
2230	!
2231	!-- Spectral albedos especially for building window surfaces
2232	IF ( albedo_pars_f%pars_xy(5,j+joff,i+ioff) /= &
2233	albedo_pars_f%fill ) THEN
2234	surf_usm_v(l)%aldir(ind_wat_win,m) = &
2235	albedo_pars_f%pars_xy(5,j+joff,i+ioff)
2236	surf_usm_v(l)%aldif(ind_wat_win,m) = &
2237	albedo_pars_f%pars_xy(5,j+joff,i+ioff)
2238	ENDIF
2239	IF ( albedo_pars_f%pars_xy(6,j+joff,i+ioff) /= &
2240	albedo_pars_f%fill ) THEN
2241	surf_usm_v(l)%asdir(ind_wat_win,m) = &
2242	albedo_pars_f%pars_xy(6,j+joff,i+ioff)
2243	surf_usm_v(l)%asdif(ind_wat_win,m) = &
2244	albedo_pars_f%pars_xy(6,j+joff,i+ioff)
2245	ENDIF
2246	ENDDO
2247	ENDIF
2248	ENDDO
2249
2250	ENDIF
2251
2252	!
2253	!-- Calculate initial values of current (cosine of) the zenith angle and
2254	!-- whether the sun is up
2255	CALL calc_zenith
2256	!
2257	!-- readjust date and time to its initial value
2258	CALL init_date_and_time
2259	!
2260	!-- Calculate initial surface albedo for different surfaces
2261	IF ( .NOT. constant_albedo ) THEN
2262	#if defined( __netcdf )
2263	!
2264	!-- Horizontally aligned natural and urban surfaces
2265	CALL calc_albedo( surf_lsm_h )
2266	CALL calc_albedo( surf_usm_h )
2267	!
2268	!-- Vertically aligned natural and urban surfaces
2269	DO l = 0, 3
2270	CALL calc_albedo( surf_lsm_v(l) )
2271	CALL calc_albedo( surf_usm_v(l) )
2272	ENDDO
2273	#endif
2274	ELSE
2275	!
2276	!-- Initialize sun-inclination independent spectral albedos
2277	!-- Horizontal surfaces
2278	IF ( surf_lsm_h%ns > 0 ) THEN
2279	surf_lsm_h%rrtm_aldir = surf_lsm_h%aldir
2280	surf_lsm_h%rrtm_asdir = surf_lsm_h%asdir
2281	surf_lsm_h%rrtm_aldif = surf_lsm_h%aldif
2282	surf_lsm_h%rrtm_asdif = surf_lsm_h%asdif
2283	ENDIF
2284	IF ( surf_usm_h%ns > 0 ) THEN
2285	surf_usm_h%rrtm_aldir = surf_usm_h%aldir
2286	surf_usm_h%rrtm_asdir = surf_usm_h%asdir
2287	surf_usm_h%rrtm_aldif = surf_usm_h%aldif
2288	surf_usm_h%rrtm_asdif = surf_usm_h%asdif
2289	ENDIF
2290	!
2291	!-- Vertical surfaces
2292	DO l = 0, 3
2293	IF ( surf_lsm_v(l)%ns > 0 ) THEN
2294	surf_lsm_v(l)%rrtm_aldir = surf_lsm_v(l)%aldir
2295	surf_lsm_v(l)%rrtm_asdir = surf_lsm_v(l)%asdir
2296	surf_lsm_v(l)%rrtm_aldif = surf_lsm_v(l)%aldif
2297	surf_lsm_v(l)%rrtm_asdif = surf_lsm_v(l)%asdif
2298	ENDIF
2299	IF ( surf_usm_v(l)%ns > 0 ) THEN
2300	surf_usm_v(l)%rrtm_aldir = surf_usm_v(l)%aldir
2301	surf_usm_v(l)%rrtm_asdir = surf_usm_v(l)%asdir
2302	surf_usm_v(l)%rrtm_aldif = surf_usm_v(l)%aldif
2303	surf_usm_v(l)%rrtm_asdif = surf_usm_v(l)%asdif
2304	ENDIF
2305	ENDDO
2306
2307	ENDIF
2308
2309	!
2310	!-- Allocate 3d arrays of radiative fluxes and heating rates
2311	IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN
2312	ALLOCATE ( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2313	rad_sw_in = 0.0_wp
2314	ENDIF
2315
2316	IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN
2317	ALLOCATE ( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2318	ENDIF
2319
2320	IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN
2321	ALLOCATE ( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2322	rad_sw_out = 0.0_wp
2323	ENDIF
2324
2325	IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN
2326	ALLOCATE ( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2327	ENDIF
2328
2329	IF ( .NOT. ALLOCATED ( rad_sw_hr ) ) THEN
2330	ALLOCATE ( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2331	rad_sw_hr = 0.0_wp
2332	ENDIF
2333
2334	IF ( .NOT. ALLOCATED ( rad_sw_hr_av ) ) THEN
2335	ALLOCATE ( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2336	rad_sw_hr_av = 0.0_wp
2337	ENDIF
2338
2339	IF ( .NOT. ALLOCATED ( rad_sw_cs_hr ) ) THEN
2340	ALLOCATE ( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2341	rad_sw_cs_hr = 0.0_wp
2342	ENDIF
2343
2344	IF ( .NOT. ALLOCATED ( rad_sw_cs_hr_av ) ) THEN
2345	ALLOCATE ( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2346	rad_sw_cs_hr_av = 0.0_wp
2347	ENDIF
2348
2349	IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN
2350	ALLOCATE ( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2351	rad_lw_in = 0.0_wp
2352	ENDIF
2353
2354	IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN
2355	ALLOCATE ( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2356	ENDIF
2357
2358	IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN
2359	ALLOCATE ( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2360	rad_lw_out = 0.0_wp
2361	ENDIF
2362
2363	IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN
2364	ALLOCATE ( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2365	ENDIF
2366
2367	IF ( .NOT. ALLOCATED ( rad_lw_hr ) ) THEN
2368	ALLOCATE ( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2369	rad_lw_hr = 0.0_wp
2370	ENDIF
2371
2372	IF ( .NOT. ALLOCATED ( rad_lw_hr_av ) ) THEN
2373	ALLOCATE ( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2374	rad_lw_hr_av = 0.0_wp
2375	ENDIF
2376
2377	IF ( .NOT. ALLOCATED ( rad_lw_cs_hr ) ) THEN
2378	ALLOCATE ( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2379	rad_lw_cs_hr = 0.0_wp
2380	ENDIF
2381
2382	IF ( .NOT. ALLOCATED ( rad_lw_cs_hr_av ) ) THEN
2383	ALLOCATE ( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2384	rad_lw_cs_hr_av = 0.0_wp
2385	ENDIF
2386
2387	ALLOCATE ( rad_sw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2388	ALLOCATE ( rad_sw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2389	rad_sw_cs_in = 0.0_wp
2390	rad_sw_cs_out = 0.0_wp
2391
2392	ALLOCATE ( rad_lw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2393	ALLOCATE ( rad_lw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2394	rad_lw_cs_in = 0.0_wp
2395	rad_lw_cs_out = 0.0_wp
2396
2397	!
2398	!-- Allocate 1-element array for surface temperature
2399	!-- (RRTMG anticipates an array as passed argument).
2400	ALLOCATE ( rrtm_tsfc(1) )
2401	!
2402	!-- Allocate surface emissivity.
2403	!-- Values will be given directly before calling rrtm_lw.
2404	ALLOCATE ( rrtm_emis(0:0,1:nbndlw+1) )
2405
2406	!
2407	!-- Initialize RRTMG, before check if files are existent
2408	INQUIRE( FILE='rrtmg_lw.nc', EXIST=lw_exists )
2409	IF ( .NOT. lw_exists ) THEN
2410	message_string = 'Input file rrtmg_lw.nc' // &
2411	'&for rrtmg missing. ' // &
2412	'&Please provide <jobname>_lsw file in the INPUT directory.'
2413	CALL message( 'radiation_init', 'PA0583', 1, 2, 0, 6, 0 )
2414	ENDIF
2415	INQUIRE( FILE='rrtmg_sw.nc', EXIST=sw_exists )
2416	IF ( .NOT. sw_exists ) THEN
2417	message_string = 'Input file rrtmg_sw.nc' // &
2418	'&for rrtmg missing. ' // &
2419	'&Please provide <jobname>_rsw file in the INPUT directory.'
2420	CALL message( 'radiation_init', 'PA0584', 1, 2, 0, 6, 0 )
2421	ENDIF
2422
2423	IF ( lw_radiation ) CALL rrtmg_lw_ini ( c_p )
2424	IF ( sw_radiation ) CALL rrtmg_sw_ini ( c_p )
2425
2426	!
2427	!-- Set input files for RRTMG
2428	INQUIRE(FILE="RAD_SND_DATA", EXIST=snd_exists)
2429	IF ( .NOT. snd_exists ) THEN
2430	rrtm_input_file = "rrtmg_lw.nc"
2431	ENDIF
2432
2433	!
2434	!-- Read vertical layers for RRTMG from sounding data
2435	!-- The routine provides nzt_rad, hyp_snd(1:nzt_rad),
2436	!-- t_snd(nzt+2:nzt_rad), rrtm_play(1:nzt_rad), rrtm_plev(1_nzt_rad+1),
2437	!-- rrtm_tlay(nzt+2:nzt_rad), rrtm_tlev(nzt+2:nzt_rad+1)
2438	CALL read_sounding_data
2439
2440	!
2441	!-- Read trace gas profiles from file. This routine provides
2442	!-- the rrtm_ arrays (1:nzt_rad+1)
2443	CALL read_trace_gas_data
2444	#endif
2445	ENDIF
2446	!
2447	!-- Initializaion actions exclusively required for external
2448	!-- radiation forcing
2449	IF ( radiation_scheme == 'external' ) THEN
2450	!
2451	!-- Open the radiation input file. Note, for child domain, a dynamic
2452	!-- input file is often not provided. In order to do not need to
2453	!-- duplicate the dynamic input file just for the radiation input, take
2454	!-- it from the dynamic file for the parent if not available for the
2455	!-- child domain(s). In this case this is possible because radiation
2456	!-- input should be the same for each model.
2457	INQUIRE( FILE = TRIM( input_file_dynamic ), &
2458	EXIST = radiation_input_root_domain )
2459
2460	IF ( .NOT. input_pids_dynamic .AND. &
2461	.NOT. radiation_input_root_domain ) THEN
2462	message_string = 'In case of external radiation forcing ' // &
2463	'a dynamic input file is required. If no ' // &
2464	'dynamic input for the child domain(s) is ' // &
2465	'provided, at least one for the root domain ' // &
2466	'is needed.'
2467	CALL message( 'radiation_init', 'PA0315', 1, 2, 0, 6, 0 )
2468	ENDIF
2469	#if defined( __netcdf )
2470	!
2471	!-- Open dynamic input file for child domain if available, else, open
2472	!-- dynamic input file for the root domain.
2473	IF ( input_pids_dynamic ) THEN
2474	CALL open_read_file( TRIM( input_file_dynamic ) // &
2475	TRIM( coupling_char ), &
2476	pids_id )
2477	ELSEIF ( radiation_input_root_domain ) THEN
2478	CALL open_read_file( TRIM( input_file_dynamic ), &
2479	pids_id )
2480	ENDIF
2481
2482	CALL inquire_num_variables( pids_id, num_var_pids )
2483	!
2484	!-- Allocate memory to store variable names and read them
2485	ALLOCATE( vars_pids(1:num_var_pids) )
2486	CALL inquire_variable_names( pids_id, vars_pids )
2487	!
2488	!-- Input time dimension.
2489	IF ( check_existence( vars_pids, 'time_rad' ) ) THEN
2490	CALL netcdf_data_input_get_dimension_length( pids_id, &
2491	ntime, &
2492	'time_rad' )
2493
2494	ALLOCATE( time_rad_f%var1d(0:ntime-1) )
2495	!
2496	!-- Read variable
2497	CALL get_variable( pids_id, 'time_rad', time_rad_f%var1d )
2498
2499	time_rad_f%from_file = .TRUE.
2500	ENDIF
2501	!
2502	!-- Input shortwave downwelling.
2503	IF ( check_existence( vars_pids, 'rad_sw_in' ) ) THEN
2504	!
2505	!-- Get _FillValue attribute
2506	CALL get_attribute( pids_id, char_fill, rad_sw_in_f%fill, &
2507	.FALSE., 'rad_sw_in' )
2508	!
2509	!-- Get level-of-detail
2510	CALL get_attribute( pids_id, char_lod, rad_sw_in_f%lod, &
2511	.FALSE., 'rad_sw_in' )
2512	!
2513	!-- Level-of-detail 1 - radiation depends only on time_rad
2514	IF ( rad_sw_in_f%lod == 1 ) THEN
2515	ALLOCATE( rad_sw_in_f%var1d(0:ntime-1) )
2516	CALL get_variable( pids_id, 'rad_sw_in', rad_sw_in_f%var1d )
2517	rad_sw_in_f%from_file = .TRUE.
2518	!
2519	!-- Level-of-detail 2 - radiation depends on time_rad, y, x
2520	ELSEIF ( rad_sw_in_f%lod == 2 ) THEN
2521	ALLOCATE( rad_sw_in_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2522
2523	CALL get_variable( pids_id, 'rad_sw_in', rad_sw_in_f%var3d, &
2524	nxl, nxr, nys, nyn, 0, ntime-1 )
2525
2526	rad_sw_in_f%from_file = .TRUE.
2527	ELSE
2528	message_string = '"rad_sw_in" has no valid lod attribute'
2529	CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2530	ENDIF
2531	ENDIF
2532	!
2533	!-- Input longwave downwelling.
2534	IF ( check_existence( vars_pids, 'rad_lw_in' ) ) THEN
2535	!
2536	!-- Get _FillValue attribute
2537	CALL get_attribute( pids_id, char_fill, rad_lw_in_f%fill, &
2538	.FALSE., 'rad_lw_in' )
2539	!
2540	!-- Get level-of-detail
2541	CALL get_attribute( pids_id, char_lod, rad_lw_in_f%lod, &
2542	.FALSE., 'rad_lw_in' )
2543	!
2544	!-- Level-of-detail 1 - radiation depends only on time_rad
2545	IF ( rad_lw_in_f%lod == 1 ) THEN
2546	ALLOCATE( rad_lw_in_f%var1d(0:ntime-1) )
2547	CALL get_variable( pids_id, 'rad_lw_in', rad_lw_in_f%var1d )
2548	rad_lw_in_f%from_file = .TRUE.
2549	!
2550	!-- Level-of-detail 2 - radiation depends on time_rad, y, x
2551	ELSEIF ( rad_lw_in_f%lod == 2 ) THEN
2552	ALLOCATE( rad_lw_in_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2553
2554	CALL get_variable( pids_id, 'rad_lw_in', rad_lw_in_f%var3d, &
2555	nxl, nxr, nys, nyn, 0, ntime-1 )
2556
2557	rad_lw_in_f%from_file = .TRUE.
2558	ELSE
2559	message_string = '"rad_lw_in" has no valid lod attribute'
2560	CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2561	ENDIF
2562	ENDIF
2563	!
2564	!-- Input shortwave downwelling, diffuse part.
2565	IF ( check_existence( vars_pids, 'rad_sw_in_dif' ) ) THEN
2566	!
2567	!-- Read _FillValue attribute
2568	CALL get_attribute( pids_id, char_fill, rad_sw_in_dif_f%fill, &
2569	.FALSE., 'rad_sw_in_dif' )
2570	!
2571	!-- Get level-of-detail
2572	CALL get_attribute( pids_id, char_lod, rad_sw_in_dif_f%lod, &
2573	.FALSE., 'rad_sw_in_dif' )
2574	!
2575	!-- Level-of-detail 1 - radiation depends only on time_rad
2576	IF ( rad_sw_in_dif_f%lod == 1 ) THEN
2577	ALLOCATE( rad_sw_in_dif_f%var1d(0:ntime-1) )
2578	CALL get_variable( pids_id, 'rad_sw_in_dif', &
2579	rad_sw_in_dif_f%var1d )
2580	rad_sw_in_dif_f%from_file = .TRUE.
2581	!
2582	!-- Level-of-detail 2 - radiation depends on time_rad, y, x
2583	ELSEIF ( rad_sw_in_dif_f%lod == 2 ) THEN
2584	ALLOCATE( rad_sw_in_dif_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2585
2586	CALL get_variable( pids_id, 'rad_sw_in_dif', &
2587	rad_sw_in_dif_f%var3d, &
2588	nxl, nxr, nys, nyn, 0, ntime-1 )
2589
2590	rad_sw_in_dif_f%from_file = .TRUE.
2591	ELSE
2592	message_string = '"rad_sw_in_dif" has no valid lod attribute'
2593	CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2594	ENDIF
2595	ENDIF
2596	!
2597	!-- Finally, close the input file and deallocate temporary arrays
2598	DEALLOCATE( vars_pids )
2599
2600	CALL close_input_file( pids_id )
2601	#endif
2602	!
2603	!-- Make some consistency checks.
2604	IF ( .NOT. rad_sw_in_f%from_file .OR. &
2605	.NOT. rad_lw_in_f%from_file ) THEN
2606	message_string = 'In case of external radiation forcing ' // &
2607	'both, rad_sw_in and rad_lw_in are required.'
2608	CALL message( 'radiation_init', 'PA0195', 1, 2, 0, 6, 0 )
2609	ENDIF
2610
2611	IF ( .NOT. time_rad_f%from_file ) THEN
2612	message_string = 'In case of external radiation forcing ' // &
2613	'dimension time_rad is required.'
2614	CALL message( 'radiation_init', 'PA0196', 1, 2, 0, 6, 0 )
2615	ENDIF
2616
2617	IF ( time_rad_f%var1d(0) /= 0.0_wp ) THEN
2618	message_string = 'External radiation forcing: first point in ' // &
2619	'time is /= 0.0.'
2620	CALL message( 'radiation_init', 'PA0313', 1, 2, 0, 6, 0 )
2621	ENDIF
2622
2623	IF ( end_time - spinup_time > time_rad_f%var1d(ntime-1) ) THEN
2624	message_string = 'External radiation forcing does not cover ' // &
2625	'the entire simulation time.'
2626	CALL message( 'radiation_init', 'PA0314', 1, 2, 0, 6, 0 )
2627	ENDIF
2628	!
2629	!-- Check for fill values in radiation
2630	IF ( ALLOCATED( rad_sw_in_f%var1d ) ) THEN
2631	IF ( ANY( rad_sw_in_f%var1d == rad_sw_in_f%fill ) ) THEN
2632	message_string = 'External radiation array "rad_sw_in" ' // &
2633	'must not contain any fill values.'
2634	CALL message( 'radiation_init', 'PA0197', 1, 2, 0, 6, 0 )
2635	ENDIF
2636	ENDIF
2637
2638	IF ( ALLOCATED( rad_lw_in_f%var1d ) ) THEN
2639	IF ( ANY( rad_lw_in_f%var1d == rad_lw_in_f%fill ) ) THEN
2640	message_string = 'External radiation array "rad_lw_in" ' // &
2641	'must not contain any fill values.'
2642	CALL message( 'radiation_init', 'PA0198', 1, 2, 0, 6, 0 )
2643	ENDIF
2644	ENDIF
2645
2646	IF ( ALLOCATED( rad_sw_in_dif_f%var1d ) ) THEN
2647	IF ( ANY( rad_sw_in_dif_f%var1d == rad_sw_in_dif_f%fill ) ) THEN
2648	message_string = 'External radiation array "rad_sw_in_dif" ' //&
2649	'must not contain any fill values.'
2650	CALL message( 'radiation_init', 'PA0199', 1, 2, 0, 6, 0 )
2651	ENDIF
2652	ENDIF
2653
2654	IF ( ALLOCATED( rad_sw_in_f%var3d ) ) THEN
2655	IF ( ANY( rad_sw_in_f%var3d == rad_sw_in_f%fill ) ) THEN
2656	message_string = 'External radiation array "rad_sw_in" ' // &
2657	'must not contain any fill values.'
2658	CALL message( 'radiation_init', 'PA0197', 1, 2, 0, 6, 0 )
2659	ENDIF
2660	ENDIF
2661
2662	IF ( ALLOCATED( rad_lw_in_f%var3d ) ) THEN
2663	IF ( ANY( rad_lw_in_f%var3d == rad_lw_in_f%fill ) ) THEN
2664	message_string = 'External radiation array "rad_lw_in" ' // &
2665	'must not contain any fill values.'
2666	CALL message( 'radiation_init', 'PA0198', 1, 2, 0, 6, 0 )
2667	ENDIF
2668	ENDIF
2669
2670	IF ( ALLOCATED( rad_sw_in_dif_f%var3d ) ) THEN
2671	IF ( ANY( rad_sw_in_dif_f%var3d == rad_sw_in_dif_f%fill ) ) THEN
2672	message_string = 'External radiation array "rad_sw_in_dif" ' //&
2673	'must not contain any fill values.'
2674	CALL message( 'radiation_init', 'PA0199', 1, 2, 0, 6, 0 )
2675	ENDIF
2676	ENDIF
2677	!
2678	!-- Currently, 2D external radiation input is not possible in
2679	!-- combination with topography where average radiation is used.
2680	IF ( ( rad_sw_in_f%lod == 2 .OR. rad_sw_in_f%lod == 2 .OR. &
2681	rad_sw_in_dif_f%lod == 2 ) .AND. average_radiation ) THEN
2682	message_string = 'External radiation with lod = 2 is currently '//&
2683	'not possible with average_radiation = .T..'
2684	CALL message( 'radiation_init', 'PA0670', 1, 2, 0, 6, 0 )
2685	ENDIF
2686	!
2687	!-- All radiation input should have the same level of detail. The sum
2688	!-- of lods divided by the number of available radiation arrays must be
2689	!-- 1 (if all are lod = 1) or 2 (if all are lod = 2).
2690	IF ( REAL( MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + &
2691	MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + &
2692	MERGE( rad_sw_in_dif_f%lod, 0, rad_sw_in_dif_f%from_file ),&
2693	KIND = wp ) / &
2694	( MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + &
2695	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + &
2696	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_dif_f%from_file ) ) &
2697	/= 1.0_wp .AND. &
2698	REAL( MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + &
2699	MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + &
2700	MERGE( rad_sw_in_dif_f%lod, 0, rad_sw_in_dif_f%from_file ),&
2701	KIND = wp ) / &
2702	( MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + &
2703	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + &
2704	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_dif_f%from_file ) ) &
2705	/= 2.0_wp ) THEN
2706	message_string = 'External radiation input should have the same '//&
2707	'lod.'
2708	CALL message( 'radiation_init', 'PA0673', 1, 2, 0, 6, 0 )
2709	ENDIF
2710
2711	ENDIF
2712	!
2713	!-- Perform user actions if required
2714	CALL user_init_radiation
2715
2716	!
2717	!-- Calculate radiative fluxes at model start
2718	SELECT CASE ( TRIM( radiation_scheme ) )
2719
2720	CASE ( 'rrtmg' )
2721	CALL radiation_rrtmg
2722
2723	CASE ( 'clear-sky' )
2724	CALL radiation_clearsky
2725
2726	CASE ( 'constant' )
2727	CALL radiation_constant
2728
2729	CASE ( 'external' )
2730	!
2731	!-- During spinup apply clear-sky model
2732	IF ( time_since_reference_point < 0.0_wp ) THEN
2733	CALL radiation_clearsky
2734	ELSE
2735	CALL radiation_external
2736	ENDIF
2737
2738	CASE DEFAULT
2739
2740	END SELECT
2741	!
2742	!-- Readjust date and time to its initial value
2743	CALL init_date_and_time
2744
2745	!
2746	!-- Find all discretized apparent solar positions for radiation interaction.
2747	IF ( radiation_interactions ) CALL radiation_presimulate_solar_pos
2748
2749	!
2750	!-- If required, read or calculate and write out the SVF
2751	IF ( radiation_interactions .AND. read_svf) THEN
2752	!
2753	!-- Read sky-view factors and further required data from file
2754	CALL radiation_read_svf()
2755
2756	ELSEIF ( radiation_interactions .AND. .NOT. read_svf) THEN
2757	!
2758	!-- calculate SFV and CSF
2759	CALL radiation_calc_svf()
2760	ENDIF
2761
2762	IF ( radiation_interactions .AND. write_svf) THEN
2763	!
2764	!-- Write svf, csf svfsurf and csfsurf data to file
2765	CALL radiation_write_svf()
2766	ENDIF
2767
2768	!
2769	!-- Adjust radiative fluxes. In case of urban and land surfaces, also
2770	!-- call an initial interaction.
2771	IF ( radiation_interactions ) THEN
2772	CALL radiation_interaction
2773	ENDIF
2774
2775	IF ( debug_output ) CALL debug_message( 'radiation_init', 'end' )
2776
2777	RETURN !todo: remove, I don't see what we need this for here
2778
2779	END SUBROUTINE radiation_init
2780
2781
2782	!------------------------------------------------------------------------------!
2783	! Description:
2784	! ------------
2785	!> A simple clear sky radiation model
2786	!------------------------------------------------------------------------------!
2787	SUBROUTINE radiation_external
2788
2789	IMPLICIT NONE
2790
2791	INTEGER(iwp) :: l !< running index for surface orientation
2792	INTEGER(iwp) :: t !< index of current timestep
2793	INTEGER(iwp) :: tm !< index of previous timestep
2794
2795	REAL(wp) :: fac_dt !< interpolation factor
2796
2797	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
2798
2799	!
2800	!-- Calculate current zenith angle
2801	CALL calc_zenith
2802	!
2803	!-- Interpolate external radiation on current timestep
2804	IF ( time_since_reference_point <= 0.0_wp ) THEN
2805	t = 0
2806	tm = 0
2807	fac_dt = 0
2808	ELSE
2809	t = 0
2810	DO WHILE ( time_rad_f%var1d(t) <= time_since_reference_point )
2811	t = t + 1
2812	ENDDO
2813
2814	tm = MAX( t-1, 0 )
2815
2816	fac_dt = ( time_since_reference_point - time_rad_f%var1d(tm) + dt_3d ) &
2817	/ ( time_rad_f%var1d(t) - time_rad_f%var1d(tm) )
2818	fac_dt = MIN( 1.0_wp, fac_dt )
2819	ENDIF
2820	!
2821	!-- Call clear-sky calculation for each surface orientation.
2822	!-- First, horizontal surfaces
2823	surf => surf_lsm_h
2824	CALL radiation_external_surf
2825	surf => surf_usm_h
2826	CALL radiation_external_surf
2827	!
2828	!-- Vertical surfaces
2829	DO l = 0, 3
2830	surf => surf_lsm_v(l)
2831	CALL radiation_external_surf
2832	surf => surf_usm_v(l)
2833	CALL radiation_external_surf
2834	ENDDO
2835
2836	CONTAINS
2837
2838	SUBROUTINE radiation_external_surf
2839
2840	USE control_parameters
2841
2842	IMPLICIT NONE
2843
2844	INTEGER(iwp) :: i !< grid index along x-dimension
2845	INTEGER(iwp) :: j !< grid index along y-dimension
2846	INTEGER(iwp) :: k !< grid index along z-dimension
2847	INTEGER(iwp) :: m !< running index for surface elements
2848
2849	REAL(wp) :: lw_in !< downwelling longwave radiation, interpolated value
2850	REAL(wp) :: sw_in !< downwelling shortwave radiation, interpolated value
2851	REAL(wp) :: sw_in_dif !< downwelling diffuse shortwave radiation, interpolated value
2852
2853	IF ( surf%ns < 1 ) RETURN
2854	!
2855	!-- level-of-detail = 1. Note, here it must be distinguished between
2856	!-- averaged radiation and non-averaged radiation for the upwelling
2857	!-- fluxes.
2858	IF ( rad_sw_in_f%lod == 1 ) THEN
2859
2860	sw_in = ( 1.0_wp - fac_dt ) * rad_sw_in_f%var1d(tm) &
2861	+ fac_dt * rad_sw_in_f%var1d(t)
2862
2863	lw_in = ( 1.0_wp - fac_dt ) * rad_lw_in_f%var1d(tm) &
2864	+ fac_dt * rad_lw_in_f%var1d(t)
2865	!
2866	!-- Limit shortwave incoming radiation to positive values, in order
2867	!-- to overcome possible observation errors.
2868	sw_in = MAX( 0.0_wp, sw_in )
2869	sw_in = MERGE( sw_in, 0.0_wp, sun_up )
2870
2871	surf%rad_sw_in = sw_in
2872	surf%rad_lw_in = lw_in
2873
2874	IF ( average_radiation ) THEN
2875	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
2876
2877	surf%rad_lw_out = emissivity_urb * sigma_sb * t_rad_urb**4 &
2878	+ ( 1.0_wp - emissivity_urb ) * surf%rad_lw_in
2879
2880	surf%rad_net = surf%rad_sw_in - surf%rad_sw_out &
2881	+ surf%rad_lw_in - surf%rad_lw_out
2882
2883	surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb &
2884	* sigma_sb &
2885	* t_rad_urb**3
2886	ELSE
2887	DO m = 1, surf%ns
2888	k = surf%k(m)
2889	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
2890	surf%albedo(ind_veg_wall,m) &
2891	+ surf%frac(ind_pav_green,m) * &
2892	surf%albedo(ind_pav_green,m) &
2893	+ surf%frac(ind_wat_win,m) * &
2894	surf%albedo(ind_wat_win,m) ) &
2895	* surf%rad_sw_in(m)
2896
2897	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
2898	surf%emissivity(ind_veg_wall,m) &
2899	+ surf%frac(ind_pav_green,m) * &
2900	surf%emissivity(ind_pav_green,m) &
2901	+ surf%frac(ind_wat_win,m) * &
2902	surf%emissivity(ind_wat_win,m) &
2903	) &
2904	* sigma_sb &
2905	* ( surf%pt_surface(m) * exner(k) )**4
2906
2907	surf%rad_lw_out_change_0(m) = &
2908	( surf%frac(ind_veg_wall,m) * &
2909	surf%emissivity(ind_veg_wall,m) &
2910	+ surf%frac(ind_pav_green,m) * &
2911	surf%emissivity(ind_pav_green,m) &
2912	+ surf%frac(ind_wat_win,m) * &
2913	surf%emissivity(ind_wat_win,m) &
2914	) * 4.0_wp * sigma_sb &
2915	* ( surf%pt_surface(m) * exner(k) )**3
2916	ENDDO
2917
2918	ENDIF
2919	!
2920	!-- If diffuse shortwave radiation is available, store it on
2921	!-- the respective files.
2922	IF ( rad_sw_in_dif_f%from_file ) THEN
2923	sw_in_dif= ( 1.0_wp - fac_dt ) * rad_sw_in_dif_f%var1d(tm) &
2924	+ fac_dt * rad_sw_in_dif_f%var1d(t)
2925
2926	IF ( ALLOCATED( rad_sw_in_diff ) ) rad_sw_in_diff = sw_in_dif
2927	IF ( ALLOCATED( rad_sw_in_dir ) ) rad_sw_in_dir = sw_in &
2928	- sw_in_dif
2929	!
2930	!-- Diffuse longwave radiation equals the total downwelling
2931	!-- longwave radiation
2932	IF ( ALLOCATED( rad_lw_in_diff ) ) rad_lw_in_diff = lw_in
2933	ENDIF
2934	!
2935	!-- level-of-detail = 2
2936	ELSE
2937
2938	DO m = 1, surf%ns
2939	i = surf%i(m)
2940	j = surf%j(m)
2941	k = surf%k(m)
2942
2943	surf%rad_sw_in(m) = ( 1.0_wp - fac_dt ) &
2944	* rad_sw_in_f%var3d(tm,j,i) &
2945	+ fac_dt * rad_sw_in_f%var3d(t,j,i)
2946	!
2947	!-- Limit shortwave incoming radiation to positive values, in
2948	!-- order to overcome possible observation errors.
2949	surf%rad_sw_in(m) = MAX( 0.0_wp, surf%rad_sw_in(m) )
2950	surf%rad_sw_in(m) = MERGE( surf%rad_sw_in(m), 0.0_wp, sun_up )
2951
2952	surf%rad_lw_in(m) = ( 1.0_wp - fac_dt ) &
2953	* rad_lw_in_f%var3d(tm,j,i) &
2954	+ fac_dt * rad_lw_in_f%var3d(t,j,i)
2955	!
2956	!-- Weighted average according to surface fraction.
2957	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
2958	surf%albedo(ind_veg_wall,m) &
2959	+ surf%frac(ind_pav_green,m) * &
2960	surf%albedo(ind_pav_green,m) &
2961	+ surf%frac(ind_wat_win,m) * &
2962	surf%albedo(ind_wat_win,m) ) &
2963	* surf%rad_sw_in(m)
2964
2965	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
2966	surf%emissivity(ind_veg_wall,m) &
2967	+ surf%frac(ind_pav_green,m) * &
2968	surf%emissivity(ind_pav_green,m) &
2969	+ surf%frac(ind_wat_win,m) * &
2970	surf%emissivity(ind_wat_win,m) &
2971	) &
2972	* sigma_sb &
2973	* ( surf%pt_surface(m) * exner(k) )**4
2974
2975	surf%rad_lw_out_change_0(m) = &
2976	( surf%frac(ind_veg_wall,m) * &
2977	surf%emissivity(ind_veg_wall,m) &
2978	+ surf%frac(ind_pav_green,m) * &
2979	surf%emissivity(ind_pav_green,m) &
2980	+ surf%frac(ind_wat_win,m) * &
2981	surf%emissivity(ind_wat_win,m) &
2982	) * 4.0_wp * sigma_sb &
2983	* ( surf%pt_surface(m) * exner(k) )**3
2984
2985	surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) &
2986	+ surf%rad_lw_in(m) - surf%rad_lw_out(m)
2987	!
2988	!-- If diffuse shortwave radiation is available, store it on
2989	!-- the respective files.
2990	IF ( rad_sw_in_dif_f%from_file ) THEN
2991	IF ( ALLOCATED( rad_sw_in_diff ) ) &
2992	rad_sw_in_diff(j,i) = ( 1.0_wp - fac_dt ) &
2993	* rad_sw_in_dif_f%var3d(tm,j,i) &
2994	+ fac_dt * rad_sw_in_dif_f%var3d(t,j,i)
2995	!
2996	!-- dir = sw_in - sw_in_dif.
2997	IF ( ALLOCATED( rad_sw_in_dir ) ) &
2998	rad_sw_in_dir(j,i) = surf%rad_sw_in(m) - &
2999	rad_sw_in_diff(j,i)
3000	!
3001	!-- Diffuse longwave radiation equals the total downwelling
3002	!-- longwave radiation
3003	IF ( ALLOCATED( rad_lw_in_diff ) ) &
3004	rad_lw_in_diff = surf%rad_lw_in(m)
3005	ENDIF
3006
3007	ENDDO
3008
3009	ENDIF
3010	!
3011	!-- Store radiation also on 2D arrays, which are still used for
3012	!-- direct-diffuse splitting.
3013	DO m = 1, surf%ns
3014	i = surf%i(m)
3015	j = surf%j(m)
3016
3017	rad_sw_in(0,:,:) = surf%rad_sw_in(m)
3018	rad_lw_in(0,:,:) = surf%rad_lw_in(m)
3019	rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3020	rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3021	ENDDO
3022
3023	END SUBROUTINE radiation_external_surf
3024
3025	END SUBROUTINE radiation_external
3026
3027	!------------------------------------------------------------------------------!
3028	! Description:
3029	! ------------
3030	!> A simple clear sky radiation model
3031	!------------------------------------------------------------------------------!
3032	SUBROUTINE radiation_clearsky
3033
3034
3035	IMPLICIT NONE
3036
3037	INTEGER(iwp) :: l !< running index for surface orientation
3038	REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top
3039	REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain
3040	REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top
3041	REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain
3042
3043	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
3044
3045	!
3046	!-- Calculate current zenith angle
3047	CALL calc_zenith
3048
3049	!
3050	!-- Calculate sky transmissivity
3051	sky_trans = 0.6_wp + 0.2_wp * cos_zenith
3052
3053	!
3054	!-- Calculate value of the Exner function at model surface
3055	!
3056	!-- In case averaged radiation is used, calculate mean temperature and
3057	!-- liquid water mixing ratio at the urban-layer top.
3058	IF ( average_radiation ) THEN
3059	pt1 = 0.0_wp
3060	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = 0.0_wp
3061
3062	pt1_l = SUM( pt(nz_urban_t,nys:nyn,nxl:nxr) )
3063	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1_l = SUM( ql(nz_urban_t,nys:nyn,nxl:nxr) )
3064
3065	#if defined( __parallel )
3066	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
3067	CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3068	IF ( ierr /= 0 ) THEN
3069	WRITE(9,*) 'Error MPI_AllReduce1:', ierr, pt1_l, pt1
3070	FLUSH(9)
3071	ENDIF
3072
3073	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3074	CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3075	IF ( ierr /= 0 ) THEN
3076	WRITE(9,*) 'Error MPI_AllReduce2:', ierr, ql1_l, ql1
3077	FLUSH(9)
3078	ENDIF
3079	ENDIF
3080	#else
3081	pt1 = pt1_l
3082	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = ql1_l
3083	#endif
3084
3085	IF ( bulk_cloud_model .OR. cloud_droplets ) pt1 = pt1 + lv_d_cp / exner(nz_urban_t) * ql1
3086	!
3087	!-- Finally, divide by number of grid points
3088	pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp )
3089	ENDIF
3090	!
3091	!-- Call clear-sky calculation for each surface orientation.
3092	!-- First, horizontal surfaces
3093	surf => surf_lsm_h
3094	CALL radiation_clearsky_surf
3095	surf => surf_usm_h
3096	CALL radiation_clearsky_surf
3097	!
3098	!-- Vertical surfaces
3099	DO l = 0, 3
3100	surf => surf_lsm_v(l)
3101	CALL radiation_clearsky_surf
3102	surf => surf_usm_v(l)
3103	CALL radiation_clearsky_surf
3104	ENDDO
3105
3106	CONTAINS
3107
3108	SUBROUTINE radiation_clearsky_surf
3109
3110	IMPLICIT NONE
3111
3112	INTEGER(iwp) :: i !< index x-direction
3113	INTEGER(iwp) :: j !< index y-direction
3114	INTEGER(iwp) :: k !< index z-direction
3115	INTEGER(iwp) :: m !< running index for surface elements
3116
3117	IF ( surf%ns < 1 ) RETURN
3118
3119	!
3120	!-- Calculate radiation fluxes and net radiation (rad_net) assuming
3121	!-- homogeneous urban radiation conditions.
3122	IF ( average_radiation ) THEN
3123
3124	k = nz_urban_t
3125
3126	surf%rad_sw_in = solar_constant * sky_trans * cos_zenith
3127	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
3128
3129	surf%rad_lw_in = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k+1))**4
3130
3131	surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 &
3132	+ (1.0_wp - emissivity_urb) * surf%rad_lw_in
3133
3134	surf%rad_net = surf%rad_sw_in - surf%rad_sw_out &
3135	+ surf%rad_lw_in - surf%rad_lw_out
3136
3137	surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb &
3138	* (t_rad_urb)**3
3139
3140	!
3141	!-- Calculate radiation fluxes and net radiation (rad_net) for each surface
3142	!-- element.
3143	ELSE
3144
3145	DO m = 1, surf%ns
3146	i = surf%i(m)
3147	j = surf%j(m)
3148	k = surf%k(m)
3149
3150	surf%rad_sw_in(m) = solar_constant * sky_trans * cos_zenith
3151
3152	!
3153	!-- Weighted average according to surface fraction.
3154	!-- ATTENTION: when radiation interactions are switched on the
3155	!-- calculated fluxes below are not actually used as they are
3156	!-- overwritten in radiation_interaction.
3157	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3158	surf%albedo(ind_veg_wall,m) &
3159	+ surf%frac(ind_pav_green,m) * &
3160	surf%albedo(ind_pav_green,m) &
3161	+ surf%frac(ind_wat_win,m) * &
3162	surf%albedo(ind_wat_win,m) ) &
3163	* surf%rad_sw_in(m)
3164
3165	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3166	surf%emissivity(ind_veg_wall,m) &
3167	+ surf%frac(ind_pav_green,m) * &
3168	surf%emissivity(ind_pav_green,m) &
3169	+ surf%frac(ind_wat_win,m) * &
3170	surf%emissivity(ind_wat_win,m) &
3171	) &
3172	* sigma_sb &
3173	* ( surf%pt_surface(m) * exner(nzb) )**4
3174
3175	surf%rad_lw_out_change_0(m) = &
3176	( surf%frac(ind_veg_wall,m) * &
3177	surf%emissivity(ind_veg_wall,m) &
3178	+ surf%frac(ind_pav_green,m) * &
3179	surf%emissivity(ind_pav_green,m) &
3180	+ surf%frac(ind_wat_win,m) * &
3181	surf%emissivity(ind_wat_win,m) &
3182	) * 4.0_wp * sigma_sb &
3183	* ( surf%pt_surface(m) * exner(nzb) )** 3
3184
3185
3186	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3187	pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i)
3188	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k))**4
3189	ELSE
3190	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt(k,j,i) * exner(k))**4
3191	ENDIF
3192
3193	surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) &
3194	+ surf%rad_lw_in(m) - surf%rad_lw_out(m)
3195
3196	ENDDO
3197
3198	ENDIF
3199
3200	!
3201	!-- Fill out values in radiation arrays
3202	DO m = 1, surf%ns
3203	i = surf%i(m)
3204	j = surf%j(m)
3205	rad_sw_in(0,j,i) = surf%rad_sw_in(m)
3206	rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3207	rad_lw_in(0,j,i) = surf%rad_lw_in(m)
3208	rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3209	ENDDO
3210
3211	END SUBROUTINE radiation_clearsky_surf
3212
3213	END SUBROUTINE radiation_clearsky
3214
3215
3216	!------------------------------------------------------------------------------!
3217	! Description:
3218	! ------------
3219	!> This scheme keeps the prescribed net radiation constant during the run
3220	!------------------------------------------------------------------------------!
3221	SUBROUTINE radiation_constant
3222
3223
3224	IMPLICIT NONE
3225
3226	INTEGER(iwp) :: l !< running index for surface orientation
3227
3228	REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top
3229	REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain
3230	REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top
3231	REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain
3232
3233	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
3234
3235	!
3236	!-- In case averaged radiation is used, calculate mean temperature and
3237	!-- liquid water mixing ratio at the urban-layer top.
3238	IF ( average_radiation ) THEN
3239	pt1 = 0.0_wp
3240	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = 0.0_wp
3241
3242	pt1_l = SUM( pt(nz_urban_t,nys:nyn,nxl:nxr) )
3243	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1_l = SUM( ql(nz_urban_t,nys:nyn,nxl:nxr) )
3244
3245	#if defined( __parallel )
3246	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
3247	CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3248	IF ( ierr /= 0 ) THEN
3249	WRITE(9,*) 'Error MPI_AllReduce3:', ierr, pt1_l, pt1
3250	FLUSH(9)
3251	ENDIF
3252	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3253	CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3254	IF ( ierr /= 0 ) THEN
3255	WRITE(9,*) 'Error MPI_AllReduce4:', ierr, ql1_l, ql1
3256	FLUSH(9)
3257	ENDIF
3258	ENDIF
3259	#else
3260	pt1 = pt1_l
3261	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = ql1_l
3262	#endif
3263	IF ( bulk_cloud_model .OR. cloud_droplets ) pt1 = pt1 + lv_d_cp / exner(nz_urban_t+1) * ql1
3264	!
3265	!-- Finally, divide by number of grid points
3266	pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp )
3267	ENDIF
3268
3269	!
3270	!-- First, horizontal surfaces
3271	surf => surf_lsm_h
3272	CALL radiation_constant_surf
3273	surf => surf_usm_h
3274	CALL radiation_constant_surf
3275	!
3276	!-- Vertical surfaces
3277	DO l = 0, 3
3278	surf => surf_lsm_v(l)
3279	CALL radiation_constant_surf
3280	surf => surf_usm_v(l)
3281	CALL radiation_constant_surf
3282	ENDDO
3283
3284	CONTAINS
3285
3286	SUBROUTINE radiation_constant_surf
3287
3288	IMPLICIT NONE
3289
3290	INTEGER(iwp) :: i !< index x-direction
3291	INTEGER(iwp) :: ioff !< offset between surface element and adjacent grid point along x
3292	INTEGER(iwp) :: j !< index y-direction
3293	INTEGER(iwp) :: joff !< offset between surface element and adjacent grid point along y
3294	INTEGER(iwp) :: k !< index z-direction
3295	INTEGER(iwp) :: koff !< offset between surface element and adjacent grid point along z
3296	INTEGER(iwp) :: m !< running index for surface elements
3297
3298	IF ( surf%ns < 1 ) RETURN
3299
3300	!-- Calculate homogenoeus urban radiation fluxes
3301	IF ( average_radiation ) THEN
3302
3303	surf%rad_net = net_radiation
3304
3305	surf%rad_lw_in = emissivity_atm_clsky * sigma_sb * (pt1 * exner(nz_urban_t+1))**4
3306
3307	surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 &
3308	+ ( 1.0_wp - emissivity_urb ) & ! shouldn't be this a bulk value -- emissivity_urb?
3309	* surf%rad_lw_in
3310
3311	surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb &
3312	* t_rad_urb**3
3313
3314	surf%rad_sw_in = ( surf%rad_net - surf%rad_lw_in &
3315	+ surf%rad_lw_out ) &
3316	/ ( 1.0_wp - albedo_urb )
3317
3318	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
3319
3320	!
3321	!-- Calculate radiation fluxes for each surface element
3322	ELSE
3323	!
3324	!-- Determine index offset between surface element and adjacent
3325	!-- atmospheric grid point
3326	ioff = surf%ioff
3327	joff = surf%joff
3328	koff = surf%koff
3329
3330	!
3331	!-- Prescribe net radiation and estimate the remaining radiative fluxes
3332	DO m = 1, surf%ns
3333	i = surf%i(m)
3334	j = surf%j(m)
3335	k = surf%k(m)
3336
3337	surf%rad_net(m) = net_radiation
3338
3339	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3340	pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i)
3341	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k))**4
3342	ELSE
3343	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * &
3344	( pt(k,j,i) * exner(k) )**4
3345	ENDIF
3346
3347	!
3348	!-- Weighted average according to surface fraction.
3349	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3350	surf%emissivity(ind_veg_wall,m) &
3351	+ surf%frac(ind_pav_green,m) * &
3352	surf%emissivity(ind_pav_green,m) &
3353	+ surf%frac(ind_wat_win,m) * &
3354	surf%emissivity(ind_wat_win,m) &
3355	) &
3356	* sigma_sb &
3357	* ( surf%pt_surface(m) * exner(nzb) )**4
3358
3359	surf%rad_sw_in(m) = ( surf%rad_net(m) - surf%rad_lw_in(m) &
3360	+ surf%rad_lw_out(m) ) &
3361	/ ( 1.0_wp - &
3362	( surf%frac(ind_veg_wall,m) * &
3363	surf%albedo(ind_veg_wall,m) &
3364	+ surf%frac(ind_pav_green,m) * &
3365	surf%albedo(ind_pav_green,m) &
3366	+ surf%frac(ind_wat_win,m) * &
3367	surf%albedo(ind_wat_win,m) ) &
3368	)
3369
3370	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3371	surf%albedo(ind_veg_wall,m) &
3372	+ surf%frac(ind_pav_green,m) * &
3373	surf%albedo(ind_pav_green,m) &
3374	+ surf%frac(ind_wat_win,m) * &
3375	surf%albedo(ind_wat_win,m) ) &
3376	* surf%rad_sw_in(m)
3377
3378	ENDDO
3379
3380	ENDIF
3381
3382	!
3383	!-- Fill out values in radiation arrays
3384	DO m = 1, surf%ns
3385	i = surf%i(m)
3386	j = surf%j(m)
3387	rad_sw_in(0,j,i) = surf%rad_sw_in(m)
3388	rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3389	rad_lw_in(0,j,i) = surf%rad_lw_in(m)
3390	rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3391	ENDDO
3392
3393	END SUBROUTINE radiation_constant_surf
3394
3395
3396	END SUBROUTINE radiation_constant
3397
3398	!------------------------------------------------------------------------------!
3399	! Description:
3400	! ------------
3401	!> Header output for radiation model
3402	!------------------------------------------------------------------------------!
3403	SUBROUTINE radiation_header ( io )
3404
3405
3406	IMPLICIT NONE
3407
3408	INTEGER(iwp), INTENT(IN) :: io !< Unit of the output file
3409
3410
3411
3412	!
3413	!-- Write radiation model header
3414	WRITE( io, 3 )
3415
3416	IF ( radiation_scheme == "constant" ) THEN
3417	WRITE( io, 4 ) net_radiation
3418	ELSEIF ( radiation_scheme == "clear-sky" ) THEN
3419	WRITE( io, 5 )
3420	ELSEIF ( radiation_scheme == "rrtmg" ) THEN
3421	WRITE( io, 6 )
3422	IF ( .NOT. lw_radiation ) WRITE( io, 10 )
3423	IF ( .NOT. sw_radiation ) WRITE( io, 11 )
3424	ELSEIF ( radiation_scheme == "external" ) THEN
3425	WRITE( io, 14 )
3426	ENDIF
3427
3428	IF ( albedo_type_f%from_file .OR. vegetation_type_f%from_file .OR. &
3429	pavement_type_f%from_file .OR. water_type_f%from_file .OR. &
3430	building_type_f%from_file ) THEN
3431	WRITE( io, 13 )
3432	ELSE
3433	IF ( albedo_type == 0 ) THEN
3434	WRITE( io, 7 ) albedo
3435	ELSE
3436	WRITE( io, 8 ) TRIM( albedo_type_name(albedo_type) )
3437	ENDIF
3438	ENDIF
3439	IF ( constant_albedo ) THEN
3440	WRITE( io, 9 )
3441	ENDIF
3442
3443	WRITE( io, 12 ) dt_radiation
3444
3445
3446	3 FORMAT (//' Radiation model information:'/ &
3447	' ----------------------------'/)
3448	4 FORMAT (' --> Using constant net radiation: net_radiation = ', F6.2, &
3449	// 'W/m**2')
3450	5 FORMAT (' --> Simple radiation scheme for clear sky is used (no clouds,',&
3451	' default)')
3452	6 FORMAT (' --> RRTMG scheme is used')
3453	7 FORMAT (/' User-specific surface albedo: albedo =', F6.3)
3454	8 FORMAT (/' Albedo is set for land surface type: ', A)
3455	9 FORMAT (/' --> Albedo is fixed during the run')
3456	10 FORMAT (/' --> Longwave radiation is disabled')
3457	11 FORMAT (/' --> Shortwave radiation is disabled.')
3458	12 FORMAT (' Timestep: dt_radiation = ', F6.2, ' s')
3459	13 FORMAT (/' Albedo is set individually for each xy-location, according ', &
3460	'to given surface type.')
3461	14 FORMAT (' --> External radiation forcing is used')
3462
3463
3464	END SUBROUTINE radiation_header
3465
3466
3467	!------------------------------------------------------------------------------!
3468	! Description:
3469	! ------------
3470	!> Parin for &radiation_parameters for radiation model
3471	!------------------------------------------------------------------------------!
3472	SUBROUTINE radiation_parin
3473
3474
3475	IMPLICIT NONE
3476
3477	CHARACTER (LEN=80) :: line !< dummy string that contains the current line of the parameter file
3478
3479	NAMELIST /radiation_par/ albedo, albedo_lw_dif, albedo_lw_dir, &
3480	albedo_sw_dif, albedo_sw_dir, albedo_type, &
3481	constant_albedo, dt_radiation, emissivity, &
3482	lw_radiation, max_raytracing_dist, &
3483	min_irrf_value, mrt_geom_human, &
3484	mrt_include_sw, mrt_nlevels, &
3485	mrt_skip_roof, net_radiation, nrefsteps, &
3486	plant_lw_interact, rad_angular_discretization,&
3487	radiation_interactions_on, radiation_scheme, &
3488	raytrace_discrete_azims, &
3489	raytrace_discrete_elevs, raytrace_mpi_rma, &
3490	skip_time_do_radiation, surface_reflections, &
3491	svfnorm_report_thresh, sw_radiation, &
3492	unscheduled_radiation_calls
3493
3494
3495	NAMELIST /radiation_parameters/ albedo, albedo_lw_dif, albedo_lw_dir, &
3496	albedo_sw_dif, albedo_sw_dir, albedo_type, &
3497	constant_albedo, dt_radiation, emissivity, &
3498	lw_radiation, max_raytracing_dist, &
3499	min_irrf_value, mrt_geom_human, &
3500	mrt_include_sw, mrt_nlevels, &
3501	mrt_skip_roof, net_radiation, nrefsteps, &
3502	plant_lw_interact, rad_angular_discretization,&
3503	radiation_interactions_on, radiation_scheme, &
3504	raytrace_discrete_azims, &
3505	raytrace_discrete_elevs, raytrace_mpi_rma, &
3506	skip_time_do_radiation, surface_reflections, &
3507	svfnorm_report_thresh, sw_radiation, &
3508	unscheduled_radiation_calls
3509
3510	line = ' '
3511
3512	!
3513	!-- Try to find radiation model namelist
3514	REWIND ( 11 )
3515	line = ' '
3516	DO WHILE ( INDEX( line, '&radiation_parameters' ) == 0 )
3517	READ ( 11, '(A)', END=12 ) line
3518	ENDDO
3519	BACKSPACE ( 11 )
3520
3521	!
3522	!-- Read user-defined namelist
3523	READ ( 11, radiation_parameters, ERR = 10 )
3524
3525	!
3526	!-- Set flag that indicates that the radiation model is switched on
3527	radiation = .TRUE.
3528
3529	GOTO 14
3530
3531	10 BACKSPACE( 11 )
3532	READ( 11 , '(A)') line
3533	CALL parin_fail_message( 'radiation_parameters', line )
3534	!
3535	!-- Try to find old namelist
3536	12 REWIND ( 11 )
3537	line = ' '
3538	DO WHILE ( INDEX( line, '&radiation_par' ) == 0 )
3539	READ ( 11, '(A)', END=14 ) line
3540	ENDDO
3541	BACKSPACE ( 11 )
3542
3543	!
3544	!-- Read user-defined namelist
3545	READ ( 11, radiation_par, ERR = 13, END = 14 )
3546
3547	message_string = 'namelist radiation_par is deprecated and will be ' // &
3548	'removed in near future. Please use namelist ' // &
3549	'radiation_parameters instead'
3550	CALL message( 'radiation_parin', 'PA0487', 0, 1, 0, 6, 0 )
3551
3552	!
3553	!-- Set flag that indicates that the radiation model is switched on
3554	radiation = .TRUE.
3555
3556	IF ( .NOT. radiation_interactions_on .AND. surface_reflections ) THEN
3557	message_string = 'surface_reflections is allowed only when ' // &
3558	'radiation_interactions_on is set to TRUE'
3559	CALL message( 'radiation_parin', 'PA0293',1, 2, 0, 6, 0 )
3560	ENDIF
3561
3562	GOTO 14
3563
3564	13 BACKSPACE( 11 )
3565	READ( 11 , '(A)') line
3566	CALL parin_fail_message( 'radiation_par', line )
3567
3568	14 CONTINUE
3569
3570	END SUBROUTINE radiation_parin
3571
3572
3573	!------------------------------------------------------------------------------!
3574	! Description:
3575	! ------------
3576	!> Implementation of the RRTMG radiation_scheme
3577	!------------------------------------------------------------------------------!
3578	SUBROUTINE radiation_rrtmg
3579
3580	#if defined ( __rrtmg )
3581	USE indices, &
3582	ONLY: nbgp
3583
3584	USE particle_attributes, &
3585	ONLY: grid_particles, number_of_particles, particles, prt_count
3586
3587	IMPLICIT NONE
3588
3589
3590	INTEGER(iwp) :: i, j, k, l, m, n !< loop indices
3591	INTEGER(iwp) :: k_topo_l !< topography top index
3592	INTEGER(iwp) :: k_topo !< topography top index
3593
3594	REAL(wp) :: nc_rad, & !< number concentration of cloud droplets
3595	s_r2, & !< weighted sum over all droplets with r^2
3596	s_r3 !< weighted sum over all droplets with r^3
3597
3598	REAL(wp), DIMENSION(0:nzt+1) :: pt_av, q_av, ql_av
3599	REAL(wp), DIMENSION(0:0) :: zenith !< to provide indexed array
3600	!
3601	!-- Just dummy arguments
3602	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rrtm_lw_taucld_dum, &
3603	rrtm_lw_tauaer_dum, &
3604	rrtm_sw_taucld_dum, &
3605	rrtm_sw_ssacld_dum, &
3606	rrtm_sw_asmcld_dum, &
3607	rrtm_sw_fsfcld_dum, &
3608	rrtm_sw_tauaer_dum, &
3609	rrtm_sw_ssaaer_dum, &
3610	rrtm_sw_asmaer_dum, &
3611	rrtm_sw_ecaer_dum
3612
3613	!
3614	!-- Calculate current (cosine of) zenith angle and whether the sun is up
3615	CALL calc_zenith
3616	zenith(0) = cos_zenith
3617	!
3618	!-- Calculate surface albedo. In case average radiation is applied,
3619	!-- this is not required.
3620	#if defined( __netcdf )
3621	IF ( .NOT. constant_albedo ) THEN
3622	!
3623	!-- Horizontally aligned default, natural and urban surfaces
3624	CALL calc_albedo( surf_lsm_h )
3625	CALL calc_albedo( surf_usm_h )
3626	!
3627	!-- Vertically aligned default, natural and urban surfaces
3628	DO l = 0, 3
3629	CALL calc_albedo( surf_lsm_v(l) )
3630	CALL calc_albedo( surf_usm_v(l) )
3631	ENDDO
3632	ENDIF
3633	#endif
3634
3635	!
3636	!-- Prepare input data for RRTMG
3637
3638	!
3639	!-- In case of large scale forcing with surface data, calculate new pressure
3640	!-- profile. nzt_rad might be modified by these calls and all required arrays
3641	!-- will then be re-allocated
3642	IF ( large_scale_forcing .AND. lsf_surf ) THEN
3643	CALL read_sounding_data
3644	CALL read_trace_gas_data
3645	ENDIF
3646
3647
3648	IF ( average_radiation ) THEN
3649	!
3650	!-- Determine minimum topography top index.
3651	k_topo_l = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
3652	#if defined( __parallel )
3653	CALL MPI_ALLREDUCE( k_topo_l, k_topo, 1, MPI_INTEGER, MPI_MIN, &
3654	comm2d, ierr)
3655	#else
3656	k_topo = k_topo_l
3657	#endif
3658
3659	rrtm_asdir(1) = albedo_urb
3660	rrtm_asdif(1) = albedo_urb
3661	rrtm_aldir(1) = albedo_urb
3662	rrtm_aldif(1) = albedo_urb
3663
3664	rrtm_emis = emissivity_urb
3665	!
3666	!-- Calculate mean pt profile.
3667	CALL calc_mean_profile( pt, 4 )
3668	pt_av = hom(:, 1, 4, 0)
3669
3670	IF ( humidity ) THEN
3671	CALL calc_mean_profile( q, 41 )
3672	q_av = hom(:, 1, 41, 0)
3673	ENDIF
3674	!
3675	!-- Prepare profiles of temperature and H2O volume mixing ratio
3676	rrtm_tlev(0,k_topo+1) = t_rad_urb
3677
3678	IF ( bulk_cloud_model ) THEN
3679
3680	CALL calc_mean_profile( ql, 54 )
3681	! average ql is now in hom(:, 1, 54, 0)
3682	ql_av = hom(:, 1, 54, 0)
3683
3684	DO k = nzb+1, nzt+1
3685	rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp &
3686	)*.286_wp + lv_d_cp ql_av(k)
3687	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q_av(k) - ql_av(k))
3688	ENDDO
3689	ELSE
3690	DO k = nzb+1, nzt+1
3691	rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp &
3692	)**.286_wp
3693	ENDDO
3694
3695	IF ( humidity ) THEN
3696	DO k = nzb+1, nzt+1
3697	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q_av(k)
3698	ENDDO
3699	ELSE
3700	rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp
3701	ENDIF
3702	ENDIF
3703
3704	!
3705	!-- Avoid temperature/humidity jumps at the top of the PALM domain by
3706	!-- linear interpolation from nzt+2 to nzt+7. Jumps are induced by
3707	!-- discrepancies between the values in the domain and those above that
3708	!-- are prescribed in RRTMG
3709	DO k = nzt+2, nzt+7
3710	rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) &
3711	+ ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) &
3712	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) &
3713	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
3714
3715	rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) &
3716	+ ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )&
3717	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )&
3718	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
3719
3720	ENDDO
3721
3722	!-- Linear interpolate to zw grid. Loop reaches one level further up
3723	!-- due to the staggered grid in RRTMG
3724	DO k = k_topo+2, nzt+8
3725	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - &
3726	rrtm_tlay(0,k-1)) &
3727	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
3728	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
3729	ENDDO
3730	!
3731	!-- Calculate liquid water path and cloud fraction for each column.
3732	!-- Note that LWP is required in g/m2 instead of kg/kg m.
3733	rrtm_cldfr = 0.0_wp
3734	rrtm_reliq = 0.0_wp
3735	rrtm_cliqwp = 0.0_wp
3736	rrtm_icld = 0
3737
3738	IF ( bulk_cloud_model ) THEN
3739	DO k = nzb+1, nzt+1
3740	rrtm_cliqwp(0,k) = ql_av(k) * 1000._wp * &
3741	(rrtm_plev(0,k) - rrtm_plev(0,k+1)) &
3742	* 100._wp / g
3743
3744	IF ( rrtm_cliqwp(0,k) > 0._wp ) THEN
3745	rrtm_cldfr(0,k) = 1._wp
3746	IF ( rrtm_icld == 0 ) rrtm_icld = 1
3747
3748	!
3749	!-- Calculate cloud droplet effective radius
3750	rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql_av(k) &
3751	* rho_surface &
3752	/ ( 4.0_wp * pi * nc_const * rho_l ) &
3753	)**0.33333333333333_wp &
3754	* EXP( LOG( sigma_gc )**2 )
3755	!
3756	!-- Limit effective radius
3757	IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN
3758	rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp)
3759	rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp)
3760	ENDIF
3761	ENDIF
3762	ENDDO
3763	ENDIF
3764
3765	!
3766	!-- Set surface temperature
3767	rrtm_tsfc = t_rad_urb
3768
3769	IF ( lw_radiation ) THEN
3770	!
3771	!-- Due to technical reasons, copy optical depth to dummy arguments
3772	!-- which are allocated on the exact size as the rrtmg_lw is called.
3773	!-- As one dimesion is allocated with zero size, compiler complains
3774	!-- that rank of the array does not match that of the
3775	!-- assumed-shaped arguments in the RRTMG library. In order to
3776	!-- avoid this, write to dummy arguments and give pass the entire
3777	!-- dummy array. Seems to be the only existing work-around.
3778	ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) )
3779	ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) )
3780
3781	rrtm_lw_taucld_dum = &
3782	rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1)
3783	rrtm_lw_tauaer_dum = &
3784	rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1)
3785
3786	CALL rrtmg_lw( 1, &
3787	nzt_rad-k_topo, &
3788	rrtm_icld, &
3789	rrtm_idrv, &
3790	rrtm_play(:,k_topo+1:), &
3791	rrtm_plev(:,k_topo+1:), &
3792	rrtm_tlay(:,k_topo+1:), &
3793	rrtm_tlev(:,k_topo+1:), &
3794	rrtm_tsfc, &
3795	rrtm_h2ovmr(:,k_topo+1:), &
3796	rrtm_o3vmr(:,k_topo+1:), &
3797	rrtm_co2vmr(:,k_topo+1:), &
3798	rrtm_ch4vmr(:,k_topo+1:), &
3799	rrtm_n2ovmr(:,k_topo+1:), &
3800	rrtm_o2vmr(:,k_topo+1:), &
3801	rrtm_cfc11vmr(:,k_topo+1:), &
3802	rrtm_cfc12vmr(:,k_topo+1:), &
3803	rrtm_cfc22vmr(:,k_topo+1:), &
3804	rrtm_ccl4vmr(:,k_topo+1:), &
3805	rrtm_emis, &
3806	rrtm_inflglw, &
3807	rrtm_iceflglw, &
3808	rrtm_liqflglw, &
3809	rrtm_cldfr(:,k_topo+1:), &
3810	rrtm_lw_taucld_dum, &
3811	rrtm_cicewp(:,k_topo+1:), &
3812	rrtm_cliqwp(:,k_topo+1:), &
3813	rrtm_reice(:,k_topo+1:), &
3814	rrtm_reliq(:,k_topo+1:), &
3815	rrtm_lw_tauaer_dum, &
3816	rrtm_lwuflx(:,k_topo:), &
3817	rrtm_lwdflx(:,k_topo:), &
3818	rrtm_lwhr(:,k_topo+1:), &
3819	rrtm_lwuflxc(:,k_topo:), &
3820	rrtm_lwdflxc(:,k_topo:), &
3821	rrtm_lwhrc(:,k_topo+1:), &
3822	rrtm_lwuflx_dt(:,k_topo:), &
3823	rrtm_lwuflxc_dt(:,k_topo:) )
3824
3825	DEALLOCATE ( rrtm_lw_taucld_dum )
3826	DEALLOCATE ( rrtm_lw_tauaer_dum )
3827	!
3828	!-- Save fluxes
3829	DO k = nzb, nzt+1
3830	rad_lw_in(k,:,:) = rrtm_lwdflx(0,k)
3831	rad_lw_out(k,:,:) = rrtm_lwuflx(0,k)
3832	ENDDO
3833	rad_lw_in_diff(:,:) = rad_lw_in(k_topo,:,:)
3834	!
3835	!-- Save heating rates (convert from K/d to K/h).
3836	!-- Further, even though an aggregated radiation is computed, map
3837	!-- signle-column profiles on top of any topography, in order to
3838	!-- obtain correct near surface radiation heating/cooling rates.
3839	DO i = nxl, nxr
3840	DO j = nys, nyn
3841	k_topo_l = topo_top_ind(j,i,0)
3842	DO k = k_topo_l+1, nzt+1
3843	rad_lw_hr(k,j,i) = rrtm_lwhr(0,k-k_topo_l) * d_hours_day
3844	rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k-k_topo_l) * d_hours_day
3845	ENDDO
3846	ENDDO
3847	ENDDO
3848
3849	ENDIF
3850
3851	IF ( sw_radiation .AND. sun_up ) THEN
3852	!
3853	!-- Due to technical reasons, copy optical depths and other
3854	!-- to dummy arguments which are allocated on the exact size as the
3855	!-- rrtmg_sw is called.
3856	!-- As one dimesion is allocated with zero size, compiler complains
3857	!-- that rank of the array does not match that of the
3858	!-- assumed-shaped arguments in the RRTMG library. In order to
3859	!-- avoid this, write to dummy arguments and give pass the entire
3860	!-- dummy array. Seems to be the only existing work-around.
3861	ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3862	ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3863	ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3864	ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3865	ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
3866	ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
3867	ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
3868	ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) )
3869
3870	rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3871	rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3872	rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3873	rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3874	rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
3875	rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
3876	rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
3877	rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1)
3878
3879	CALL rrtmg_sw( 1, &
3880	nzt_rad-k_topo, &
3881	rrtm_icld, &
3882	rrtm_iaer, &
3883	rrtm_play(:,k_topo+1:nzt_rad+1), &
3884	rrtm_plev(:,k_topo+1:nzt_rad+2), &
3885	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
3886	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
3887	rrtm_tsfc, &
3888	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
3889	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
3890	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
3891	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
3892	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
3893	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
3894	rrtm_asdir, &
3895	rrtm_asdif, &
3896	rrtm_aldir, &
3897	rrtm_aldif, &
3898	zenith, &
3899	0.0_wp, &
3900	day_of_year, &
3901	solar_constant, &
3902	rrtm_inflgsw, &
3903	rrtm_iceflgsw, &
3904	rrtm_liqflgsw, &
3905	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
3906	rrtm_sw_taucld_dum, &
3907	rrtm_sw_ssacld_dum, &
3908	rrtm_sw_asmcld_dum, &
3909	rrtm_sw_fsfcld_dum, &
3910	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
3911	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
3912	rrtm_reice(:,k_topo+1:nzt_rad+1), &
3913	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
3914	rrtm_sw_tauaer_dum, &
3915	rrtm_sw_ssaaer_dum, &
3916	rrtm_sw_asmaer_dum, &
3917	rrtm_sw_ecaer_dum, &
3918	rrtm_swuflx(:,k_topo:nzt_rad+1), &
3919	rrtm_swdflx(:,k_topo:nzt_rad+1), &
3920	rrtm_swhr(:,k_topo+1:nzt_rad+1), &
3921	rrtm_swuflxc(:,k_topo:nzt_rad+1), &
3922	rrtm_swdflxc(:,k_topo:nzt_rad+1), &
3923	rrtm_swhrc(:,k_topo+1:nzt_rad+1), &
3924	rrtm_dirdflux(:,k_topo:nzt_rad+1), &
3925	rrtm_difdflux(:,k_topo:nzt_rad+1) )
3926
3927	DEALLOCATE( rrtm_sw_taucld_dum )
3928	DEALLOCATE( rrtm_sw_ssacld_dum )
3929	DEALLOCATE( rrtm_sw_asmcld_dum )
3930	DEALLOCATE( rrtm_sw_fsfcld_dum )
3931	DEALLOCATE( rrtm_sw_tauaer_dum )
3932	DEALLOCATE( rrtm_sw_ssaaer_dum )
3933	DEALLOCATE( rrtm_sw_asmaer_dum )
3934	DEALLOCATE( rrtm_sw_ecaer_dum )
3935
3936	!
3937	!-- Save radiation fluxes for the entire depth of the model domain
3938	DO k = nzb, nzt+1
3939	rad_sw_in(k,:,:) = rrtm_swdflx(0,k)
3940	rad_sw_out(k,:,:) = rrtm_swuflx(0,k)
3941	ENDDO
3942	!-- Save direct and diffuse SW radiation at the surface (required by RTM)
3943	rad_sw_in_dir(:,:) = rrtm_dirdflux(0,k_topo)
3944	rad_sw_in_diff(:,:) = rrtm_difdflux(0,k_topo)
3945
3946	!
3947	!-- Save heating rates (convert from K/d to K/s)
3948	DO k = nzb+1, nzt+1
3949	rad_sw_hr(k,:,:) = rrtm_swhr(0,k) * d_hours_day
3950	rad_sw_cs_hr(k,:,:) = rrtm_swhrc(0,k) * d_hours_day
3951	ENDDO
3952	!
3953	!-- Solar radiation is zero during night
3954	ELSE
3955	rad_sw_in = 0.0_wp
3956	rad_sw_out = 0.0_wp
3957	rad_sw_in_dir(:,:) = 0.0_wp
3958	rad_sw_in_diff(:,:) = 0.0_wp
3959	ENDIF
3960	!
3961	!-- RRTMG is called for each (j,i) grid point separately, starting at the
3962	!-- highest topography level. Here no RTM is used since average_radiation is false
3963	ELSE
3964	!
3965	!-- Loop over all grid points
3966	DO i = nxl, nxr
3967	DO j = nys, nyn
3968
3969	!
3970	!-- Prepare profiles of temperature and H2O volume mixing ratio
3971	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
3972	rrtm_tlev(0,nzb+1) = surf_lsm_h%pt_surface(m) * exner(nzb)
3973	ENDDO
3974	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
3975	rrtm_tlev(0,nzb+1) = surf_usm_h%pt_surface(m) * exner(nzb)
3976	ENDDO
3977
3978
3979	IF ( bulk_cloud_model ) THEN
3980	DO k = nzb+1, nzt+1
3981	rrtm_tlay(0,k) = pt(k,j,i) * exner(k) &
3982	+ lv_d_cp * ql(k,j,i)
3983	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q(k,j,i) - ql(k,j,i))
3984	ENDDO
3985	ELSEIF ( cloud_droplets ) THEN
3986	DO k = nzb+1, nzt+1
3987	rrtm_tlay(0,k) = pt(k,j,i) * exner(k) &
3988	+ lv_d_cp * ql(k,j,i)
3989	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i)
3990	ENDDO
3991	ELSE
3992	DO k = nzb+1, nzt+1
3993	rrtm_tlay(0,k) = pt(k,j,i) * exner(k)
3994	ENDDO
3995
3996	IF ( humidity ) THEN
3997	DO k = nzb+1, nzt+1
3998	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i)
3999	ENDDO
4000	ELSE
4001	rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp
4002	ENDIF
4003	ENDIF
4004
4005	!
4006	!-- Avoid temperature/humidity jumps at the top of the LES domain by
4007	!-- linear interpolation from nzt+2 to nzt+7
4008	DO k = nzt+2, nzt+7
4009	rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) &
4010	+ ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) &
4011	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) &
4012	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
4013
4014	rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) &
4015	+ ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )&
4016	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )&
4017	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
4018
4019	ENDDO
4020
4021	!-- Linear interpolate to zw grid
4022	DO k = nzb+2, nzt+8
4023	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - &
4024	rrtm_tlay(0,k-1)) &
4025	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
4026	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
4027	ENDDO
4028
4029
4030	!
4031	!-- Calculate liquid water path and cloud fraction for each column.
4032	!-- Note that LWP is required in g/m2 instead of kg/kg m.
4033	rrtm_cldfr = 0.0_wp
4034	rrtm_reliq = 0.0_wp
4035	rrtm_cliqwp = 0.0_wp
4036	rrtm_icld = 0
4037
4038	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
4039	DO k = nzb+1, nzt+1
4040	rrtm_cliqwp(0,k) = ql(k,j,i) * 1000.0_wp * &
4041	(rrtm_plev(0,k) - rrtm_plev(0,k+1)) &
4042	* 100.0_wp / g
4043
4044	IF ( rrtm_cliqwp(0,k) > 0.0_wp ) THEN
4045	rrtm_cldfr(0,k) = 1.0_wp
4046	IF ( rrtm_icld == 0 ) rrtm_icld = 1
4047
4048	!
4049	!-- Calculate cloud droplet effective radius
4050	IF ( bulk_cloud_model ) THEN
4051	!
4052	!-- Calculete effective droplet radius. In case of using
4053	!-- cloud_scheme = 'morrison' and a non reasonable number
4054	!-- of cloud droplets the inital aerosol number
4055	!-- concentration is considered.
4056	IF ( microphysics_morrison ) THEN
4057	IF ( nc(k,j,i) > 1.0E-20_wp ) THEN
4058	nc_rad = nc(k,j,i)
4059	ELSE
4060	nc_rad = na_init
4061	ENDIF
4062	ELSE
4063	nc_rad = nc_const
4064	ENDIF
4065
4066	rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql(k,j,i) &
4067	* rho_surface &
4068	/ ( 4.0_wp * pi * nc_rad * rho_l ) &
4069	)**0.33333333333333_wp &
4070	* EXP( LOG( sigma_gc )**2 )
4071
4072	ELSEIF ( cloud_droplets ) THEN
4073	number_of_particles = prt_count(k,j,i)
4074
4075	IF (number_of_particles <= 0) CYCLE
4076	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
4077	s_r2 = 0.0_wp
4078	s_r3 = 0.0_wp
4079
4080	DO n = 1, number_of_particles
4081	IF ( particles(n)%particle_mask ) THEN
4082	s_r2 = s_r2 + particles(n)%radius*2 &
4083	particles(n)%weight_factor
4084	s_r3 = s_r3 + particles(n)%radius*3 &
4085	particles(n)%weight_factor
4086	ENDIF
4087	ENDDO
4088
4089	IF ( s_r2 > 0.0_wp ) rrtm_reliq(0,k) = s_r3 / s_r2
4090
4091	ENDIF
4092
4093	!
4094	!-- Limit effective radius
4095	IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN
4096	rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp)
4097	rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp)
4098	ENDIF
4099	ENDIF
4100	ENDDO
4101	ENDIF
4102
4103	!
4104	!-- Write surface emissivity and surface temperature at current
4105	!-- surface element on RRTMG-shaped array.
4106	!-- Please note, as RRTMG is a single column model, surface attributes
4107	!-- are only obtained from horizontally aligned surfaces (for
4108	!-- simplicity). Taking surface attributes from horizontal and
4109	!-- vertical walls would lead to multiple solutions.
4110	!-- Moreover, for natural- and urban-type surfaces, several surface
4111	!-- classes can exist at a surface element next to each other.
4112	!-- To obtain bulk parameters, apply a weighted average for these
4113	!-- surfaces.
4114	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
4115	rrtm_emis = surf_lsm_h%frac(ind_veg_wall,m) * &
4116	surf_lsm_h%emissivity(ind_veg_wall,m) + &
4117	surf_lsm_h%frac(ind_pav_green,m) * &
4118	surf_lsm_h%emissivity(ind_pav_green,m) + &
4119	surf_lsm_h%frac(ind_wat_win,m) * &
4120	surf_lsm_h%emissivity(ind_wat_win,m)
4121	rrtm_tsfc = surf_lsm_h%pt_surface(m) * exner(nzb)
4122	ENDDO
4123	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
4124	rrtm_emis = surf_usm_h%frac(ind_veg_wall,m) * &
4125	surf_usm_h%emissivity(ind_veg_wall,m) + &
4126	surf_usm_h%frac(ind_pav_green,m) * &
4127	surf_usm_h%emissivity(ind_pav_green,m) + &
4128	surf_usm_h%frac(ind_wat_win,m) * &
4129	surf_usm_h%emissivity(ind_wat_win,m)
4130	rrtm_tsfc = surf_usm_h%pt_surface(m) * exner(nzb)
4131	ENDDO
4132	!
4133	!-- Obtain topography top index (lower bound of RRTMG)
4134	k_topo = topo_top_ind(j,i,0)
4135
4136	IF ( lw_radiation ) THEN
4137	!
4138	!-- Due to technical reasons, copy optical depth to dummy arguments
4139	!-- which are allocated on the exact size as the rrtmg_lw is called.
4140	!-- As one dimesion is allocated with zero size, compiler complains
4141	!-- that rank of the array does not match that of the
4142	!-- assumed-shaped arguments in the RRTMG library. In order to
4143	!-- avoid this, write to dummy arguments and give pass the entire
4144	!-- dummy array. Seems to be the only existing work-around.
4145	ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) )
4146	ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) )
4147
4148	rrtm_lw_taucld_dum = &
4149	rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1)
4150	rrtm_lw_tauaer_dum = &
4151	rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1)
4152
4153	CALL rrtmg_lw( 1, &
4154	nzt_rad-k_topo, &
4155	rrtm_icld, &
4156	rrtm_idrv, &
4157	rrtm_play(:,k_topo+1:nzt_rad+1), &
4158	rrtm_plev(:,k_topo+1:nzt_rad+2), &
4159	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
4160	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
4161	rrtm_tsfc, &
4162	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
4163	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
4164	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
4165	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
4166	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
4167	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
4168	rrtm_cfc11vmr(:,k_topo+1:nzt_rad+1), &
4169	rrtm_cfc12vmr(:,k_topo+1:nzt_rad+1), &
4170	rrtm_cfc22vmr(:,k_topo+1:nzt_rad+1), &
4171	rrtm_ccl4vmr(:,k_topo+1:nzt_rad+1), &
4172	rrtm_emis, &
4173	rrtm_inflglw, &
4174	rrtm_iceflglw, &
4175	rrtm_liqflglw, &
4176	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
4177	rrtm_lw_taucld_dum, &
4178	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
4179	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
4180	rrtm_reice(:,k_topo+1:nzt_rad+1), &
4181	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
4182	rrtm_lw_tauaer_dum, &
4183	rrtm_lwuflx(:,k_topo:nzt_rad+1), &
4184	rrtm_lwdflx(:,k_topo:nzt_rad+1), &
4185	rrtm_lwhr(:,k_topo+1:nzt_rad+1), &
4186	rrtm_lwuflxc(:,k_topo:nzt_rad+1), &
4187	rrtm_lwdflxc(:,k_topo:nzt_rad+1), &
4188	rrtm_lwhrc(:,k_topo+1:nzt_rad+1), &
4189	rrtm_lwuflx_dt(:,k_topo:nzt_rad+1), &
4190	rrtm_lwuflxc_dt(:,k_topo:nzt_rad+1) )
4191
4192	DEALLOCATE ( rrtm_lw_taucld_dum )
4193	DEALLOCATE ( rrtm_lw_tauaer_dum )
4194	!
4195	!-- Save fluxes
4196	DO k = k_topo, nzt+1
4197	rad_lw_in(k,j,i) = rrtm_lwdflx(0,k)
4198	rad_lw_out(k,j,i) = rrtm_lwuflx(0,k)
4199	ENDDO
4200
4201	!
4202	!-- Save heating rates (convert from K/d to K/h)
4203	DO k = k_topo+1, nzt+1
4204	rad_lw_hr(k,j,i) = rrtm_lwhr(0,k-k_topo) * d_hours_day
4205	rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k-k_topo) * d_hours_day
4206	ENDDO
4207
4208	!
4209	!-- Save surface radiative fluxes and change in LW heating rate
4210	!-- onto respective surface elements
4211	!-- Horizontal surfaces
4212	DO m = surf_lsm_h%start_index(j,i), &
4213	surf_lsm_h%end_index(j,i)
4214	surf_lsm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo)
4215	surf_lsm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo)
4216	surf_lsm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo)
4217	ENDDO
4218	DO m = surf_usm_h%start_index(j,i), &
4219	surf_usm_h%end_index(j,i)
4220	surf_usm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo)
4221	surf_usm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo)
4222	surf_usm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo)
4223	ENDDO
4224	!
4225	!-- Vertical surfaces. Fluxes are obtain at vertical level of the
4226	!-- respective surface element
4227	DO l = 0, 3
4228	DO m = surf_lsm_v(l)%start_index(j,i), &
4229	surf_lsm_v(l)%end_index(j,i)
4230	k = surf_lsm_v(l)%k(m)
4231	surf_lsm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k)
4232	surf_lsm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k)
4233	surf_lsm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
4234	ENDDO
4235	DO m = surf_usm_v(l)%start_index(j,i), &
4236	surf_usm_v(l)%end_index(j,i)
4237	k = surf_usm_v(l)%k(m)
4238	surf_usm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k)
4239	surf_usm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k)
4240	surf_usm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
4241	ENDDO
4242	ENDDO
4243
4244	ENDIF
4245
4246	IF ( sw_radiation .AND. sun_up ) THEN
4247	!
4248	!-- Get albedo for direct/diffusive long/shortwave radiation at
4249	!-- current (y,x)-location from surface variables.
4250	!-- Only obtain it from horizontal surfaces, as RRTMG is a single
4251	!-- column model
4252	!-- (Please note, only one loop will entered, controlled by
4253	!-- start-end index.)
4254	DO m = surf_lsm_h%start_index(j,i), &
4255	surf_lsm_h%end_index(j,i)
4256	rrtm_asdir(1) = SUM( surf_lsm_h%frac(:,m) * &
4257	surf_lsm_h%rrtm_asdir(:,m) )
4258	rrtm_asdif(1) = SUM( surf_lsm_h%frac(:,m) * &
4259	surf_lsm_h%rrtm_asdif(:,m) )
4260	rrtm_aldir(1) = SUM( surf_lsm_h%frac(:,m) * &
4261	surf_lsm_h%rrtm_aldir(:,m) )
4262	rrtm_aldif(1) = SUM( surf_lsm_h%frac(:,m) * &
4263	surf_lsm_h%rrtm_aldif(:,m) )
4264	ENDDO
4265	DO m = surf_usm_h%start_index(j,i), &
4266	surf_usm_h%end_index(j,i)
4267	rrtm_asdir(1) = SUM( surf_usm_h%frac(:,m) * &
4268	surf_usm_h%rrtm_asdir(:,m) )
4269	rrtm_asdif(1) = SUM( surf_usm_h%frac(:,m) * &
4270	surf_usm_h%rrtm_asdif(:,m) )
4271	rrtm_aldir(1) = SUM( surf_usm_h%frac(:,m) * &
4272	surf_usm_h%rrtm_aldir(:,m) )
4273	rrtm_aldif(1) = SUM( surf_usm_h%frac(:,m) * &
4274	surf_usm_h%rrtm_aldif(:,m) )
4275	ENDDO
4276	!
4277	!-- Due to technical reasons, copy optical depths and other
4278	!-- to dummy arguments which are allocated on the exact size as the
4279	!-- rrtmg_sw is called.
4280	!-- As one dimesion is allocated with zero size, compiler complains
4281	!-- that rank of the array does not match that of the
4282	!-- assumed-shaped arguments in the RRTMG library. In order to
4283	!-- avoid this, write to dummy arguments and give pass the entire
4284	!-- dummy array. Seems to be the only existing work-around.
4285	ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4286	ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4287	ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4288	ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4289	ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4290	ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4291	ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4292	ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) )
4293
4294	rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4295	rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4296	rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4297	rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4298	rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4299	rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4300	rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4301	rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1)
4302
4303	CALL rrtmg_sw( 1, &
4304	nzt_rad-k_topo, &
4305	rrtm_icld, &
4306	rrtm_iaer, &
4307	rrtm_play(:,k_topo+1:nzt_rad+1), &
4308	rrtm_plev(:,k_topo+1:nzt_rad+2), &
4309	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
4310	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
4311	rrtm_tsfc, &
4312	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
4313	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
4314	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
4315	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
4316	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
4317	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
4318	rrtm_asdir, &
4319	rrtm_asdif, &
4320	rrtm_aldir, &
4321	rrtm_aldif, &
4322	zenith, &
4323	0.0_wp, &
4324	day_of_year, &
4325	solar_constant, &
4326	rrtm_inflgsw, &
4327	rrtm_iceflgsw, &
4328	rrtm_liqflgsw, &
4329	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
4330	rrtm_sw_taucld_dum, &
4331	rrtm_sw_ssacld_dum, &
4332	rrtm_sw_asmcld_dum, &
4333	rrtm_sw_fsfcld_dum, &
4334	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
4335	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
4336	rrtm_reice(:,k_topo+1:nzt_rad+1), &
4337	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
4338	rrtm_sw_tauaer_dum, &
4339	rrtm_sw_ssaaer_dum, &
4340	rrtm_sw_asmaer_dum, &
4341	rrtm_sw_ecaer_dum, &
4342	rrtm_swuflx(:,k_topo:nzt_rad+1), &
4343	rrtm_swdflx(:,k_topo:nzt_rad+1), &
4344	rrtm_swhr(:,k_topo+1:nzt_rad+1), &
4345	rrtm_swuflxc(:,k_topo:nzt_rad+1), &
4346	rrtm_swdflxc(:,k_topo:nzt_rad+1), &
4347	rrtm_swhrc(:,k_topo+1:nzt_rad+1), &
4348	rrtm_dirdflux(:,k_topo:nzt_rad+1), &
4349	rrtm_difdflux(:,k_topo:nzt_rad+1) )
4350
4351	DEALLOCATE( rrtm_sw_taucld_dum )
4352	DEALLOCATE( rrtm_sw_ssacld_dum )
4353	DEALLOCATE( rrtm_sw_asmcld_dum )
4354	DEALLOCATE( rrtm_sw_fsfcld_dum )
4355	DEALLOCATE( rrtm_sw_tauaer_dum )
4356	DEALLOCATE( rrtm_sw_ssaaer_dum )
4357	DEALLOCATE( rrtm_sw_asmaer_dum )
4358	DEALLOCATE( rrtm_sw_ecaer_dum )
4359	!
4360	!-- Save fluxes
4361	DO k = nzb, nzt+1
4362	rad_sw_in(k,j,i) = rrtm_swdflx(0,k)
4363	rad_sw_out(k,j,i) = rrtm_swuflx(0,k)
4364	ENDDO
4365	!
4366	!-- Save heating rates (convert from K/d to K/s)
4367	DO k = nzb+1, nzt+1
4368	rad_sw_hr(k,j,i) = rrtm_swhr(0,k) * d_hours_day
4369	rad_sw_cs_hr(k,j,i) = rrtm_swhrc(0,k) * d_hours_day
4370	ENDDO
4371
4372	!
4373	!-- Save surface radiative fluxes onto respective surface elements
4374	!-- Horizontal surfaces
4375	DO m = surf_lsm_h%start_index(j,i), &
4376	surf_lsm_h%end_index(j,i)
4377	surf_lsm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo)
4378	surf_lsm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo)
4379	ENDDO
4380	DO m = surf_usm_h%start_index(j,i), &
4381	surf_usm_h%end_index(j,i)
4382	surf_usm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo)
4383	surf_usm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo)
4384	ENDDO
4385	!
4386	!-- Vertical surfaces. Fluxes are obtain at respective vertical
4387	!-- level of the surface element
4388	DO l = 0, 3
4389	DO m = surf_lsm_v(l)%start_index(j,i), &
4390	surf_lsm_v(l)%end_index(j,i)
4391	k = surf_lsm_v(l)%k(m)
4392	surf_lsm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k)
4393	surf_lsm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
4394	ENDDO
4395	DO m = surf_usm_v(l)%start_index(j,i), &
4396	surf_usm_v(l)%end_index(j,i)
4397	k = surf_usm_v(l)%k(m)
4398	surf_usm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k)
4399	surf_usm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
4400	ENDDO
4401	ENDDO
4402	!
4403	!-- Solar radiation is zero during night
4404	ELSE
4405	rad_sw_in = 0.0_wp
4406	rad_sw_out = 0.0_wp
4407	!-- !!!!!!!! ATTENSION !!!!!!!!!!!!!!!
4408	!-- Surface radiative fluxes should be also set to zero here
4409	!-- Save surface radiative fluxes onto respective surface elements
4410	!-- Horizontal surfaces
4411	DO m = surf_lsm_h%start_index(j,i), &
4412	surf_lsm_h%end_index(j,i)
4413	surf_lsm_h%rad_sw_in(m) = 0.0_wp
4414	surf_lsm_h%rad_sw_out(m) = 0.0_wp
4415	ENDDO
4416	DO m = surf_usm_h%start_index(j,i), &
4417	surf_usm_h%end_index(j,i)
4418	surf_usm_h%rad_sw_in(m) = 0.0_wp
4419	surf_usm_h%rad_sw_out(m) = 0.0_wp
4420	ENDDO
4421	!
4422	!-- Vertical surfaces. Fluxes are obtain at respective vertical
4423	!-- level of the surface element
4424	DO l = 0, 3
4425	DO m = surf_lsm_v(l)%start_index(j,i), &
4426	surf_lsm_v(l)%end_index(j,i)
4427	k = surf_lsm_v(l)%k(m)
4428	surf_lsm_v(l)%rad_sw_in(m) = 0.0_wp
4429	surf_lsm_v(l)%rad_sw_out(m) = 0.0_wp
4430	ENDDO
4431	DO m = surf_usm_v(l)%start_index(j,i), &
4432	surf_usm_v(l)%end_index(j,i)
4433	k = surf_usm_v(l)%k(m)
4434	surf_usm_v(l)%rad_sw_in(m) = 0.0_wp
4435	surf_usm_v(l)%rad_sw_out(m) = 0.0_wp
4436	ENDDO
4437	ENDDO
4438	ENDIF
4439
4440	ENDDO
4441	ENDDO
4442
4443	ENDIF
4444	!
4445	!-- Finally, calculate surface net radiation for surface elements.
4446	IF ( .NOT. radiation_interactions ) THEN
4447	!-- First, for horizontal surfaces
4448	DO m = 1, surf_lsm_h%ns
4449	surf_lsm_h%rad_net(m) = surf_lsm_h%rad_sw_in(m) &
4450	- surf_lsm_h%rad_sw_out(m) &
4451	+ surf_lsm_h%rad_lw_in(m) &
4452	- surf_lsm_h%rad_lw_out(m)
4453	ENDDO
4454	DO m = 1, surf_usm_h%ns
4455	surf_usm_h%rad_net(m) = surf_usm_h%rad_sw_in(m) &
4456	- surf_usm_h%rad_sw_out(m) &
4457	+ surf_usm_h%rad_lw_in(m) &
4458	- surf_usm_h%rad_lw_out(m)
4459	ENDDO
4460	!
4461	!-- Vertical surfaces.
4462	!-- Todo: weight with azimuth and zenith angle according to their orientation!
4463	DO l = 0, 3
4464	DO m = 1, surf_lsm_v(l)%ns
4465	surf_lsm_v(l)%rad_net(m) = surf_lsm_v(l)%rad_sw_in(m) &
4466	- surf_lsm_v(l)%rad_sw_out(m) &
4467	+ surf_lsm_v(l)%rad_lw_in(m) &
4468	- surf_lsm_v(l)%rad_lw_out(m)
4469	ENDDO
4470	DO m = 1, surf_usm_v(l)%ns
4471	surf_usm_v(l)%rad_net(m) = surf_usm_v(l)%rad_sw_in(m) &
4472	- surf_usm_v(l)%rad_sw_out(m) &
4473	+ surf_usm_v(l)%rad_lw_in(m) &
4474	- surf_usm_v(l)%rad_lw_out(m)
4475	ENDDO
4476	ENDDO
4477	ENDIF
4478
4479
4480	CALL exchange_horiz( rad_lw_in, nbgp )
4481	CALL exchange_horiz( rad_lw_out, nbgp )
4482	CALL exchange_horiz( rad_lw_hr, nbgp )
4483	CALL exchange_horiz( rad_lw_cs_hr, nbgp )
4484
4485	CALL exchange_horiz( rad_sw_in, nbgp )
4486	CALL exchange_horiz( rad_sw_out, nbgp )
4487	CALL exchange_horiz( rad_sw_hr, nbgp )
4488	CALL exchange_horiz( rad_sw_cs_hr, nbgp )
4489
4490	#endif
4491
4492	END SUBROUTINE radiation_rrtmg
4493
4494
4495	!------------------------------------------------------------------------------!
4496	! Description:
4497	! ------------
4498	!> Calculate the cosine of the zenith angle (variable is called zenith)
4499	!------------------------------------------------------------------------------!
4500	SUBROUTINE calc_zenith
4501
4502	IMPLICIT NONE
4503
4504	REAL(wp) :: declination, & !< solar declination angle
4505	hour_angle !< solar hour angle
4506	!
4507	!-- Calculate current day and time based on the initial values and simulation
4508	!-- time
4509	CALL calc_date_and_time
4510
4511	!
4512	!-- Calculate solar declination and hour angle
4513	declination = ASIN( decl_1 * SIN(decl_2 * REAL(day_of_year, KIND=wp) - decl_3) )
4514	hour_angle = 2.0_wp * pi * (time_utc / 86400.0_wp) + lon - pi
4515
4516	!
4517	!-- Calculate cosine of solar zenith angle
4518	cos_zenith = SIN(lat) * SIN(declination) + COS(lat) * COS(declination) &
4519	* COS(hour_angle)
4520	cos_zenith = MAX(0.0_wp,cos_zenith)
4521
4522	!
4523	!-- Calculate solar directional vector
4524	IF ( sun_direction ) THEN
4525
4526	!
4527	!-- Direction in longitudes equals to sin(solar_azimuth) * sin(zenith)
4528	sun_dir_lon = -SIN(hour_angle) * COS(declination)
4529
4530	!
4531	!-- Direction in latitues equals to cos(solar_azimuth) * sin(zenith)
4532	sun_dir_lat = SIN(declination) * COS(lat) - COS(hour_angle) &
4533	* COS(declination) * SIN(lat)
4534	ENDIF
4535
4536	!
4537	!-- Check if the sun is up (otheriwse shortwave calculations can be skipped)
4538	IF ( cos_zenith > 0.0_wp ) THEN
4539	sun_up = .TRUE.
4540	ELSE
4541	sun_up = .FALSE.
4542	END IF
4543
4544	END SUBROUTINE calc_zenith
4545
4546	#if defined ( __rrtmg ) && defined ( __netcdf )
4547	!------------------------------------------------------------------------------!
4548	! Description:
4549	! ------------
4550	!> Calculates surface albedo components based on Briegleb (1992) and
4551	!> Briegleb et al. (1986)
4552	!------------------------------------------------------------------------------!
4553	SUBROUTINE calc_albedo( surf )
4554
4555	IMPLICIT NONE
4556
4557	INTEGER(iwp) :: ind_type !< running index surface tiles
4558	INTEGER(iwp) :: m !< running index surface elements
4559
4560	TYPE(surf_type) :: surf !< treated surfaces
4561
4562	IF ( sun_up .AND. .NOT. average_radiation ) THEN
4563
4564	DO m = 1, surf%ns
4565	!
4566	!-- Loop over surface elements
4567	DO ind_type = 0, SIZE( surf%albedo_type, 1 ) - 1
4568
4569	!
4570	!-- Ocean
4571	IF ( surf%albedo_type(ind_type,m) == 1 ) THEN
4572	surf%rrtm_aldir(ind_type,m) = 0.026_wp / &
4573	( cos_zenith**1.7_wp + 0.065_wp )&
4574	+ 0.15_wp * ( cos_zenith - 0.1_wp ) &
4575	* ( cos_zenith - 0.5_wp ) &
4576	* ( cos_zenith - 1.0_wp )
4577	surf%rrtm_asdir(ind_type,m) = surf%rrtm_aldir(ind_type,m)
4578	!
4579	!-- Snow
4580	ELSEIF ( surf%albedo_type(ind_type,m) == 16 ) THEN
4581	IF ( cos_zenith < 0.5_wp ) THEN
4582	surf%rrtm_aldir(ind_type,m) = &
4583	0.5_wp * ( 1.0_wp - surf%aldif(ind_type,m) ) &
4584	* ( 3.0_wp / ( 1.0_wp + 4.0_wp &
4585	* cos_zenith ) ) - 1.0_wp
4586	surf%rrtm_asdir(ind_type,m) = &
4587	0.5_wp * ( 1.0_wp - surf%asdif(ind_type,m) ) &
4588	* ( 3.0_wp / ( 1.0_wp + 4.0_wp &
4589	* cos_zenith ) ) - 1.0_wp
4590
4591	surf%rrtm_aldir(ind_type,m) = &
4592	MIN(0.98_wp, surf%rrtm_aldir(ind_type,m))
4593	surf%rrtm_asdir(ind_type,m) = &
4594	MIN(0.98_wp, surf%rrtm_asdir(ind_type,m))
4595	ELSE
4596	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4597	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4598	ENDIF
4599	!
4600	!-- Sea ice
4601	ELSEIF ( surf%albedo_type(ind_type,m) == 15 ) THEN
4602	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4603	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4604
4605	!
4606	!-- Asphalt
4607	ELSEIF ( surf%albedo_type(ind_type,m) == 17 ) THEN
4608	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4609	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4610
4611
4612	!
4613	!-- Bare soil
4614	ELSEIF ( surf%albedo_type(ind_type,m) == 18 ) 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	!-- Land surfaces
4620	ELSE
4621	SELECT CASE ( surf%albedo_type(ind_type,m) )
4622
4623	!
4624	!-- Surface types with strong zenith dependence
4625	CASE ( 1, 2, 3, 4, 11, 12, 13 )
4626	surf%rrtm_aldir(ind_type,m) = &
4627	surf%aldif(ind_type,m) * 1.4_wp / &
4628	( 1.0_wp + 0.8_wp * cos_zenith )
4629	surf%rrtm_asdir(ind_type,m) = &
4630	surf%asdif(ind_type,m) * 1.4_wp / &
4631	( 1.0_wp + 0.8_wp * cos_zenith )
4632	!
4633	!-- Surface types with weak zenith dependence
4634	CASE ( 5, 6, 7, 8, 9, 10, 14 )
4635	surf%rrtm_aldir(ind_type,m) = &
4636	surf%aldif(ind_type,m) * 1.1_wp / &
4637	( 1.0_wp + 0.2_wp * cos_zenith )
4638	surf%rrtm_asdir(ind_type,m) = &
4639	surf%asdif(ind_type,m) * 1.1_wp / &
4640	( 1.0_wp + 0.2_wp * cos_zenith )
4641
4642	CASE DEFAULT
4643
4644	END SELECT
4645	ENDIF
4646	!
4647	!-- Diffusive albedo is taken from Table 2
4648	surf%rrtm_aldif(ind_type,m) = surf%aldif(ind_type,m)
4649	surf%rrtm_asdif(ind_type,m) = surf%asdif(ind_type,m)
4650	ENDDO
4651	ENDDO
4652	!
4653	!-- Set albedo in case of average radiation
4654	ELSEIF ( sun_up .AND. average_radiation ) THEN
4655	surf%rrtm_asdir = albedo_urb
4656	surf%rrtm_asdif = albedo_urb
4657	surf%rrtm_aldir = albedo_urb
4658	surf%rrtm_aldif = albedo_urb
4659	!
4660	!-- Darkness
4661	ELSE
4662	surf%rrtm_aldir = 0.0_wp
4663	surf%rrtm_asdir = 0.0_wp
4664	surf%rrtm_aldif = 0.0_wp
4665	surf%rrtm_asdif = 0.0_wp
4666	ENDIF
4667
4668	END SUBROUTINE calc_albedo
4669
4670	!------------------------------------------------------------------------------!
4671	! Description:
4672	! ------------
4673	!> Read sounding data (pressure and temperature) from RADIATION_DATA.
4674	!------------------------------------------------------------------------------!
4675	SUBROUTINE read_sounding_data
4676
4677	IMPLICIT NONE
4678
4679	INTEGER(iwp) :: id, & !< NetCDF id of input file
4680	id_dim_zrad, & !< pressure level id in the NetCDF file
4681	id_var, & !< NetCDF variable id
4682	k, & !< loop index
4683	nz_snd, & !< number of vertical levels in the sounding data
4684	nz_snd_start, & !< start vertical index for sounding data to be used
4685	nz_snd_end !< end vertical index for souding data to be used
4686
4687	REAL(wp) :: t_surface !< actual surface temperature
4688
4689	REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd_tmp, & !< temporary hydrostatic pressure profile (sounding)
4690	t_snd_tmp !< temporary temperature profile (sounding)
4691
4692	!
4693	!-- In case of updates, deallocate arrays first (sufficient to check one
4694	!-- array as the others are automatically allocated). This is required
4695	!-- because nzt_rad might change during the update
4696	IF ( ALLOCATED ( hyp_snd ) ) THEN
4697	DEALLOCATE( hyp_snd )
4698	DEALLOCATE( t_snd )
4699	DEALLOCATE ( rrtm_play )
4700	DEALLOCATE ( rrtm_plev )
4701	DEALLOCATE ( rrtm_tlay )
4702	DEALLOCATE ( rrtm_tlev )
4703
4704	DEALLOCATE ( rrtm_cicewp )
4705	DEALLOCATE ( rrtm_cldfr )
4706	DEALLOCATE ( rrtm_cliqwp )
4707	DEALLOCATE ( rrtm_reice )
4708	DEALLOCATE ( rrtm_reliq )
4709	DEALLOCATE ( rrtm_lw_taucld )
4710	DEALLOCATE ( rrtm_lw_tauaer )
4711
4712	DEALLOCATE ( rrtm_lwdflx )
4713	DEALLOCATE ( rrtm_lwdflxc )
4714	DEALLOCATE ( rrtm_lwuflx )
4715	DEALLOCATE ( rrtm_lwuflxc )
4716	DEALLOCATE ( rrtm_lwuflx_dt )
4717	DEALLOCATE ( rrtm_lwuflxc_dt )
4718	DEALLOCATE ( rrtm_lwhr )
4719	DEALLOCATE ( rrtm_lwhrc )
4720
4721	DEALLOCATE ( rrtm_sw_taucld )
4722	DEALLOCATE ( rrtm_sw_ssacld )
4723	DEALLOCATE ( rrtm_sw_asmcld )
4724	DEALLOCATE ( rrtm_sw_fsfcld )
4725	DEALLOCATE ( rrtm_sw_tauaer )
4726	DEALLOCATE ( rrtm_sw_ssaaer )
4727	DEALLOCATE ( rrtm_sw_asmaer )
4728	DEALLOCATE ( rrtm_sw_ecaer )
4729
4730	DEALLOCATE ( rrtm_swdflx )
4731	DEALLOCATE ( rrtm_swdflxc )
4732	DEALLOCATE ( rrtm_swuflx )
4733	DEALLOCATE ( rrtm_swuflxc )
4734	DEALLOCATE ( rrtm_swhr )
4735	DEALLOCATE ( rrtm_swhrc )
4736	DEALLOCATE ( rrtm_dirdflux )
4737	DEALLOCATE ( rrtm_difdflux )
4738
4739	ENDIF
4740
4741	!
4742	!-- Open file for reading
4743	nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id )
4744	CALL netcdf_handle_error_rad( 'read_sounding_data', 549 )
4745
4746	!
4747	!-- Inquire dimension of z axis and save in nz_snd
4748	nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim_zrad )
4749	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim_zrad, len = nz_snd )
4750	CALL netcdf_handle_error_rad( 'read_sounding_data', 551 )
4751
4752	!
4753	! !-- Allocate temporary array for storing pressure data
4754	ALLOCATE( hyp_snd_tmp(1:nz_snd) )
4755	hyp_snd_tmp = 0.0_wp
4756
4757
4758	!-- Read pressure from file
4759	nc_stat = NF90_INQ_VARID( id, "Pressure", id_var )
4760	nc_stat = NF90_GET_VAR( id, id_var, hyp_snd_tmp(:), start = (/1/), &
4761	count = (/nz_snd/) )
4762	CALL netcdf_handle_error_rad( 'read_sounding_data', 552 )
4763
4764	!
4765	!-- Allocate temporary array for storing temperature data
4766	ALLOCATE( t_snd_tmp(1:nz_snd) )
4767	t_snd_tmp = 0.0_wp
4768
4769	!
4770	!-- Read temperature from file
4771	nc_stat = NF90_INQ_VARID( id, "ReferenceTemperature", id_var )
4772	nc_stat = NF90_GET_VAR( id, id_var, t_snd_tmp(:), start = (/1/), &
4773	count = (/nz_snd/) )
4774	CALL netcdf_handle_error_rad( 'read_sounding_data', 553 )
4775
4776	!
4777	!-- Calculate start of sounding data
4778	nz_snd_start = nz_snd + 1
4779	nz_snd_end = nz_snd + 1
4780
4781	!
4782	!-- Start filling vertical dimension at 10hPa above the model domain (hyp is
4783	!-- in Pa, hyp_snd in hPa).
4784	DO k = 1, nz_snd
4785	IF ( hyp_snd_tmp(k) < ( hyp(nzt+1) - 1000.0_wp) * 0.01_wp ) THEN
4786	nz_snd_start = k
4787	EXIT
4788	END IF
4789	END DO
4790
4791	IF ( nz_snd_start <= nz_snd ) THEN
4792	nz_snd_end = nz_snd
4793	END IF
4794
4795
4796	!
4797	!-- Calculate of total grid points for RRTMG calculations
4798	nzt_rad = nzt + nz_snd_end - nz_snd_start + 1
4799
4800	!
4801	!-- Save data above LES domain in hyp_snd, t_snd
4802	ALLOCATE( hyp_snd(nzb+1:nzt_rad) )
4803	ALLOCATE( t_snd(nzb+1:nzt_rad) )
4804	hyp_snd = 0.0_wp
4805	t_snd = 0.0_wp
4806
4807	hyp_snd(nzt+2:nzt_rad) = hyp_snd_tmp(nz_snd_start+1:nz_snd_end)
4808	t_snd(nzt+2:nzt_rad) = t_snd_tmp(nz_snd_start+1:nz_snd_end)
4809
4810	nc_stat = NF90_CLOSE( id )
4811
4812	!
4813	!-- Calculate pressure levels on zu and zw grid. Sounding data is added at
4814	!-- top of the LES domain. This routine does not consider horizontal or
4815	!-- vertical variability of pressure and temperature
4816	ALLOCATE ( rrtm_play(0:0,nzb+1:nzt_rad+1) )
4817	ALLOCATE ( rrtm_plev(0:0,nzb+1:nzt_rad+2) )
4818
4819	t_surface = pt_surface * exner(nzb)
4820	DO k = nzb+1, nzt+1
4821	rrtm_play(0,k) = hyp(k) * 0.01_wp
4822	rrtm_plev(0,k) = barometric_formula(zw(k-1), &
4823	pt_surface * exner(nzb), &
4824	surface_pressure )
4825	ENDDO
4826
4827	DO k = nzt+2, nzt_rad
4828	rrtm_play(0,k) = hyp_snd(k)
4829	rrtm_plev(0,k) = 0.5_wp * ( rrtm_play(0,k) + rrtm_play(0,k-1) )
4830	ENDDO
4831	rrtm_plev(0,nzt_rad+1) = MAX( 0.5 * hyp_snd(nzt_rad), &
4832	1.5 * hyp_snd(nzt_rad) &
4833	- 0.5 * hyp_snd(nzt_rad-1) )
4834	rrtm_plev(0,nzt_rad+2) = MIN( 1.0E-4_wp, &
4835	0.25_wp * rrtm_plev(0,nzt_rad+1) )
4836
4837	rrtm_play(0,nzt_rad+1) = 0.5 * rrtm_plev(0,nzt_rad+1)
4838
4839	!
4840	!-- Calculate temperature/humidity levels at top of the LES domain.
4841	!-- Currently, the temperature is taken from sounding data (might lead to a
4842	!-- temperature jump at interface. To do: Humidity is currently not
4843	!-- calculated above the LES domain.
4844	ALLOCATE ( rrtm_tlay(0:0,nzb+1:nzt_rad+1) )
4845	ALLOCATE ( rrtm_tlev(0:0,nzb+1:nzt_rad+2) )
4846
4847	DO k = nzt+8, nzt_rad
4848	rrtm_tlay(0,k) = t_snd(k)
4849	ENDDO
4850	rrtm_tlay(0,nzt_rad+1) = 2.0_wp * rrtm_tlay(0,nzt_rad) &
4851	- rrtm_tlay(0,nzt_rad-1)
4852	DO k = nzt+9, nzt_rad+1
4853	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) &
4854	- rrtm_tlay(0,k-1)) &
4855	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
4856	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
4857	ENDDO
4858
4859	rrtm_tlev(0,nzt_rad+2) = 2.0_wp * rrtm_tlay(0,nzt_rad+1) &
4860	- rrtm_tlev(0,nzt_rad)
4861	!
4862	!-- Allocate remaining RRTMG arrays
4863	ALLOCATE ( rrtm_cicewp(0:0,nzb+1:nzt_rad+1) )
4864	ALLOCATE ( rrtm_cldfr(0:0,nzb+1:nzt_rad+1) )
4865	ALLOCATE ( rrtm_cliqwp(0:0,nzb+1:nzt_rad+1) )
4866	ALLOCATE ( rrtm_reice(0:0,nzb+1:nzt_rad+1) )
4867	ALLOCATE ( rrtm_reliq(0:0,nzb+1:nzt_rad+1) )
4868	ALLOCATE ( rrtm_lw_taucld(1:nbndlw+1,0:0,nzb+1:nzt_rad+1) )
4869	ALLOCATE ( rrtm_lw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndlw+1) )
4870	ALLOCATE ( rrtm_sw_taucld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4871	ALLOCATE ( rrtm_sw_ssacld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4872	ALLOCATE ( rrtm_sw_asmcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4873	ALLOCATE ( rrtm_sw_fsfcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4874	ALLOCATE ( rrtm_sw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
4875	ALLOCATE ( rrtm_sw_ssaaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
4876	ALLOCATE ( rrtm_sw_asmaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
4877	ALLOCATE ( rrtm_sw_ecaer(0:0,nzb+1:nzt_rad+1,1:naerec+1) )
4878
4879	!
4880	!-- The ice phase is currently not considered in PALM
4881	rrtm_cicewp = 0.0_wp
4882	rrtm_reice = 0.0_wp
4883
4884	!
4885	!-- Set other parameters (move to NAMELIST parameters in the future)
4886	rrtm_lw_tauaer = 0.0_wp
4887	rrtm_lw_taucld = 0.0_wp
4888	rrtm_sw_taucld = 0.0_wp
4889	rrtm_sw_ssacld = 0.0_wp
4890	rrtm_sw_asmcld = 0.0_wp
4891	rrtm_sw_fsfcld = 0.0_wp
4892	rrtm_sw_tauaer = 0.0_wp
4893	rrtm_sw_ssaaer = 0.0_wp
4894	rrtm_sw_asmaer = 0.0_wp
4895	rrtm_sw_ecaer = 0.0_wp
4896
4897
4898	ALLOCATE ( rrtm_swdflx(0:0,nzb:nzt_rad+1) )
4899	ALLOCATE ( rrtm_swuflx(0:0,nzb:nzt_rad+1) )
4900	ALLOCATE ( rrtm_swhr(0:0,nzb+1:nzt_rad+1) )
4901	ALLOCATE ( rrtm_swuflxc(0:0,nzb:nzt_rad+1) )
4902	ALLOCATE ( rrtm_swdflxc(0:0,nzb:nzt_rad+1) )
4903	ALLOCATE ( rrtm_swhrc(0:0,nzb+1:nzt_rad+1) )
4904	ALLOCATE ( rrtm_dirdflux(0:0,nzb:nzt_rad+1) )
4905	ALLOCATE ( rrtm_difdflux(0:0,nzb:nzt_rad+1) )
4906
4907	rrtm_swdflx = 0.0_wp
4908	rrtm_swuflx = 0.0_wp
4909	rrtm_swhr = 0.0_wp
4910	rrtm_swuflxc = 0.0_wp
4911	rrtm_swdflxc = 0.0_wp
4912	rrtm_swhrc = 0.0_wp
4913	rrtm_dirdflux = 0.0_wp
4914	rrtm_difdflux = 0.0_wp
4915
4916	ALLOCATE ( rrtm_lwdflx(0:0,nzb:nzt_rad+1) )
4917	ALLOCATE ( rrtm_lwuflx(0:0,nzb:nzt_rad+1) )
4918	ALLOCATE ( rrtm_lwhr(0:0,nzb+1:nzt_rad+1) )
4919	ALLOCATE ( rrtm_lwuflxc(0:0,nzb:nzt_rad+1) )
4920	ALLOCATE ( rrtm_lwdflxc(0:0,nzb:nzt_rad+1) )
4921	ALLOCATE ( rrtm_lwhrc(0:0,nzb+1:nzt_rad+1) )
4922
4923	rrtm_lwdflx = 0.0_wp
4924	rrtm_lwuflx = 0.0_wp
4925	rrtm_lwhr = 0.0_wp
4926	rrtm_lwuflxc = 0.0_wp
4927	rrtm_lwdflxc = 0.0_wp
4928	rrtm_lwhrc = 0.0_wp
4929
4930	ALLOCATE ( rrtm_lwuflx_dt(0:0,nzb:nzt_rad+1) )
4931	ALLOCATE ( rrtm_lwuflxc_dt(0:0,nzb:nzt_rad+1) )
4932
4933	rrtm_lwuflx_dt = 0.0_wp
4934	rrtm_lwuflxc_dt = 0.0_wp
4935
4936	END SUBROUTINE read_sounding_data
4937
4938
4939	!------------------------------------------------------------------------------!
4940	! Description:
4941	! ------------
4942	!> Read trace gas data from file and convert into trace gas paths / volume
4943	!> mixing ratios. If a user-defined input file is provided it needs to follow
4944	!> the convections used in RRTMG (see respective netCDF files shipped with
4945	!> RRTMG)
4946	!------------------------------------------------------------------------------!
4947	SUBROUTINE read_trace_gas_data
4948
4949	USE rrsw_ncpar
4950
4951	IMPLICIT NONE
4952
4953	INTEGER(iwp), PARAMETER :: num_trace_gases = 10 !< number of trace gases (absorbers)
4954
4955	CHARACTER(LEN=5), DIMENSION(num_trace_gases), PARAMETER :: & !< trace gas names
4956	trace_names = (/'O3 ', 'CO2 ', 'CH4 ', 'N2O ', 'O2 ', &
4957	'CFC11', 'CFC12', 'CFC22', 'CCL4 ', 'H2O '/)
4958
4959	INTEGER(iwp) :: id, & !< NetCDF id
4960	k, & !< loop index
4961	m, & !< loop index
4962	n, & !< loop index
4963	nabs, & !< number of absorbers
4964	np, & !< number of pressure levels
4965	id_abs, & !< NetCDF id of the respective absorber
4966	id_dim, & !< NetCDF id of asborber's dimension
4967	id_var !< NetCDf id ot the absorber
4968
4969	REAL(wp) :: p_mls_l, & !< pressure lower limit for interpolation
4970	p_mls_u, & !< pressure upper limit for interpolation
4971	p_wgt_l, & !< pressure weight lower limit for interpolation
4972	p_wgt_u, & !< pressure weight upper limit for interpolation
4973	p_mls_m !< mean pressure between upper and lower limits
4974
4975
4976	REAL(wp), DIMENSION(:), ALLOCATABLE :: p_mls, & !< pressure levels for the absorbers
4977	rrtm_play_tmp, & !< temporary array for pressure zu-levels
4978	rrtm_plev_tmp, & !< temporary array for pressure zw-levels
4979	trace_path_tmp !< temporary array for storing trace gas path data
4980
4981	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: trace_mls, & !< array for storing the absorber amounts
4982	trace_mls_path, & !< array for storing trace gas path data
4983	trace_mls_tmp !< temporary array for storing trace gas data
4984
4985
4986	!
4987	!-- In case of updates, deallocate arrays first (sufficient to check one
4988	!-- array as the others are automatically allocated)
4989	IF ( ALLOCATED ( rrtm_o3vmr ) ) THEN
4990	DEALLOCATE ( rrtm_o3vmr )
4991	DEALLOCATE ( rrtm_co2vmr )
4992	DEALLOCATE ( rrtm_ch4vmr )
4993	DEALLOCATE ( rrtm_n2ovmr )
4994	DEALLOCATE ( rrtm_o2vmr )
4995	DEALLOCATE ( rrtm_cfc11vmr )
4996	DEALLOCATE ( rrtm_cfc12vmr )
4997	DEALLOCATE ( rrtm_cfc22vmr )
4998	DEALLOCATE ( rrtm_ccl4vmr )
4999	DEALLOCATE ( rrtm_h2ovmr )
5000	ENDIF
5001
5002	!
5003	!-- Allocate trace gas profiles
5004	ALLOCATE ( rrtm_o3vmr(0:0,1:nzt_rad+1) )
5005	ALLOCATE ( rrtm_co2vmr(0:0,1:nzt_rad+1) )
5006	ALLOCATE ( rrtm_ch4vmr(0:0,1:nzt_rad+1) )
5007	ALLOCATE ( rrtm_n2ovmr(0:0,1:nzt_rad+1) )
5008	ALLOCATE ( rrtm_o2vmr(0:0,1:nzt_rad+1) )
5009	ALLOCATE ( rrtm_cfc11vmr(0:0,1:nzt_rad+1) )
5010	ALLOCATE ( rrtm_cfc12vmr(0:0,1:nzt_rad+1) )
5011	ALLOCATE ( rrtm_cfc22vmr(0:0,1:nzt_rad+1) )
5012	ALLOCATE ( rrtm_ccl4vmr(0:0,1:nzt_rad+1) )
5013	ALLOCATE ( rrtm_h2ovmr(0:0,1:nzt_rad+1) )
5014
5015	!
5016	!-- Open file for reading
5017	nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id )
5018	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 549 )
5019	!
5020	!-- Inquire dimension ids and dimensions
5021	nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim )
5022	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5023	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = np)
5024	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5025
5026	nc_stat = NF90_INQ_DIMID( id, "Absorber", id_dim )
5027	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5028	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = nabs )
5029	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5030
5031
5032	!
5033	!-- Allocate pressure, and trace gas arrays
5034	ALLOCATE( p_mls(1:np) )
5035	ALLOCATE( trace_mls(1:num_trace_gases,1:np) )
5036	ALLOCATE( trace_mls_tmp(1:nabs,1:np) )
5037
5038
5039	nc_stat = NF90_INQ_VARID( id, "Pressure", id_var )
5040	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5041	nc_stat = NF90_GET_VAR( id, id_var, p_mls )
5042	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5043
5044	nc_stat = NF90_INQ_VARID( id, "AbsorberAmountMLS", id_var )
5045	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5046	nc_stat = NF90_GET_VAR( id, id_var, trace_mls_tmp )
5047	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5048
5049
5050	!
5051	!-- Write absorber amounts (mls) to trace_mls
5052	DO n = 1, num_trace_gases
5053	CALL getAbsorberIndex( TRIM( trace_names(n) ), id_abs )
5054
5055	trace_mls(n,1:np) = trace_mls_tmp(id_abs,1:np)
5056
5057	!
5058	!-- Replace missing values by zero
5059	WHERE ( trace_mls(n,:) > 2.0_wp )
5060	trace_mls(n,:) = 0.0_wp
5061	END WHERE
5062	END DO
5063
5064	DEALLOCATE ( trace_mls_tmp )
5065
5066	nc_stat = NF90_CLOSE( id )
5067	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 551 )
5068
5069	!
5070	!-- Add extra pressure level for calculations of the trace gas paths
5071	ALLOCATE ( rrtm_play_tmp(1:nzt_rad+1) )
5072	ALLOCATE ( rrtm_plev_tmp(1:nzt_rad+2) )
5073
5074	rrtm_play_tmp(1:nzt_rad) = rrtm_play(0,1:nzt_rad)
5075	rrtm_plev_tmp(1:nzt_rad+1) = rrtm_plev(0,1:nzt_rad+1)
5076	rrtm_play_tmp(nzt_rad+1) = rrtm_plev(0,nzt_rad+1) * 0.5_wp
5077	rrtm_plev_tmp(nzt_rad+2) = MIN( 1.0E-4_wp, 0.25_wp &
5078	* rrtm_plev(0,nzt_rad+1) )
5079
5080	!
5081	!-- Calculate trace gas path (zero at surface) with interpolation to the
5082	!-- sounding levels
5083	ALLOCATE ( trace_mls_path(1:nzt_rad+2,1:num_trace_gases) )
5084
5085	trace_mls_path(nzb+1,:) = 0.0_wp
5086
5087	DO k = nzb+2, nzt_rad+2
5088	DO m = 1, num_trace_gases
5089	trace_mls_path(k,m) = trace_mls_path(k-1,m)
5090
5091	!
5092	!-- When the pressure level is higher than the trace gas pressure
5093	!-- level, assume that
5094	IF ( rrtm_plev_tmp(k-1) > p_mls(1) ) THEN
5095
5096	trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,1) &
5097	* ( rrtm_plev_tmp(k-1) &
5098	- MAX( p_mls(1), rrtm_plev_tmp(k) ) &
5099	) / g
5100	ENDIF
5101
5102	!
5103	!-- Integrate for each sounding level from the contributing p_mls
5104	!-- levels
5105	DO n = 2, np
5106	!
5107	!-- Limit p_mls so that it is within the model level
5108	p_mls_u = MIN( rrtm_plev_tmp(k-1), &
5109	MAX( rrtm_plev_tmp(k), p_mls(n) ) )
5110	p_mls_l = MIN( rrtm_plev_tmp(k-1), &
5111	MAX( rrtm_plev_tmp(k), p_mls(n-1) ) )
5112
5113	IF ( p_mls_l > p_mls_u ) THEN
5114
5115	!
5116	!-- Calculate weights for interpolation
5117	p_mls_m = 0.5_wp * (p_mls_l + p_mls_u)
5118	p_wgt_u = (p_mls(n-1) - p_mls_m) / (p_mls(n-1) - p_mls(n))
5119	p_wgt_l = (p_mls_m - p_mls(n)) / (p_mls(n-1) - p_mls(n))
5120
5121	!
5122	!-- Add level to trace gas path
5123	trace_mls_path(k,m) = trace_mls_path(k,m) &
5124	+ ( p_wgt_u * trace_mls(m,n) &
5125	+ p_wgt_l * trace_mls(m,n-1) ) &
5126	* (p_mls_l - p_mls_u) / g
5127	ENDIF
5128	ENDDO
5129
5130	IF ( rrtm_plev_tmp(k) < p_mls(np) ) THEN
5131	trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,np) &
5132	* ( MIN( rrtm_plev_tmp(k-1), p_mls(np) ) &
5133	- rrtm_plev_tmp(k) &
5134	) / g
5135	ENDIF
5136	ENDDO
5137	ENDDO
5138
5139
5140	!
5141	!-- Prepare trace gas path profiles
5142	ALLOCATE ( trace_path_tmp(1:nzt_rad+1) )
5143
5144	DO m = 1, num_trace_gases
5145
5146	trace_path_tmp(1:nzt_rad+1) = ( trace_mls_path(2:nzt_rad+2,m) &
5147	- trace_mls_path(1:nzt_rad+1,m) ) * g &
5148	/ ( rrtm_plev_tmp(1:nzt_rad+1) &
5149	- rrtm_plev_tmp(2:nzt_rad+2) )
5150
5151	!
5152	!-- Save trace gas paths to the respective arrays
5153	SELECT CASE ( TRIM( trace_names(m) ) )
5154
5155	CASE ( 'O3' )
5156
5157	rrtm_o3vmr(0,:) = trace_path_tmp(:)
5158
5159	CASE ( 'CO2' )
5160
5161	rrtm_co2vmr(0,:) = trace_path_tmp(:)
5162
5163	CASE ( 'CH4' )
5164
5165	rrtm_ch4vmr(0,:) = trace_path_tmp(:)
5166
5167	CASE ( 'N2O' )
5168
5169	rrtm_n2ovmr(0,:) = trace_path_tmp(:)
5170
5171	CASE ( 'O2' )
5172
5173	rrtm_o2vmr(0,:) = trace_path_tmp(:)
5174
5175	CASE ( 'CFC11' )
5176
5177	rrtm_cfc11vmr(0,:) = trace_path_tmp(:)
5178
5179	CASE ( 'CFC12' )
5180
5181	rrtm_cfc12vmr(0,:) = trace_path_tmp(:)
5182
5183	CASE ( 'CFC22' )
5184
5185	rrtm_cfc22vmr(0,:) = trace_path_tmp(:)
5186
5187	CASE ( 'CCL4' )
5188
5189	rrtm_ccl4vmr(0,:) = trace_path_tmp(:)
5190
5191	CASE ( 'H2O' )
5192
5193	rrtm_h2ovmr(0,:) = trace_path_tmp(:)
5194
5195	CASE DEFAULT
5196
5197	END SELECT
5198
5199	ENDDO
5200
5201	DEALLOCATE ( trace_path_tmp )
5202	DEALLOCATE ( trace_mls_path )
5203	DEALLOCATE ( rrtm_play_tmp )
5204	DEALLOCATE ( rrtm_plev_tmp )
5205	DEALLOCATE ( trace_mls )
5206	DEALLOCATE ( p_mls )
5207
5208	END SUBROUTINE read_trace_gas_data
5209
5210
5211	SUBROUTINE netcdf_handle_error_rad( routine_name, errno )
5212
5213	USE control_parameters, &
5214	ONLY: message_string
5215
5216	USE NETCDF
5217
5218	USE pegrid
5219
5220	IMPLICIT NONE
5221
5222	CHARACTER(LEN=6) :: message_identifier
5223	CHARACTER(LEN=*) :: routine_name
5224
5225	INTEGER(iwp) :: errno
5226
5227	IF ( nc_stat /= NF90_NOERR ) THEN
5228
5229	WRITE( message_identifier, '(''NC'',I4.4)' ) errno
5230	message_string = TRIM( NF90_STRERROR( nc_stat ) )
5231
5232	CALL message( routine_name, message_identifier, 2, 2, 0, 6, 1 )
5233
5234	ENDIF
5235
5236	END SUBROUTINE netcdf_handle_error_rad
5237	#endif
5238
5239
5240	!------------------------------------------------------------------------------!
5241	! Description:
5242	! ------------
5243	!> Calculate temperature tendency due to radiative cooling/heating.
5244	!> Cache-optimized version.
5245	!------------------------------------------------------------------------------!
5246	#if defined( __rrtmg )
5247	SUBROUTINE radiation_tendency_ij ( i, j, tend )
5248
5249	IMPLICIT NONE
5250
5251	INTEGER(iwp) :: i, j, k !< loop indices
5252
5253	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term
5254
5255	IF ( radiation_scheme == 'rrtmg' ) THEN
5256	!
5257	!-- Calculate tendency based on heating rate
5258	DO k = nzb+1, nzt+1
5259	tend(k,j,i) = tend(k,j,i) + (rad_lw_hr(k,j,i) + rad_sw_hr(k,j,i)) &
5260	* d_exner(k) * d_seconds_hour
5261	ENDDO
5262
5263	ENDIF
5264
5265	END SUBROUTINE radiation_tendency_ij
5266	#endif
5267
5268
5269	!------------------------------------------------------------------------------!
5270	! Description:
5271	! ------------
5272	!> Calculate temperature tendency due to radiative cooling/heating.
5273	!> Vector-optimized version
5274	!------------------------------------------------------------------------------!
5275	#if defined( __rrtmg )
5276	SUBROUTINE radiation_tendency ( tend )
5277
5278	USE indices, &
5279	ONLY: nxl, nxr, nyn, nys
5280
5281	IMPLICIT NONE
5282
5283	INTEGER(iwp) :: i, j, k !< loop indices
5284
5285	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term
5286
5287	IF ( radiation_scheme == 'rrtmg' ) THEN
5288	!
5289	!-- Calculate tendency based on heating rate
5290	DO i = nxl, nxr
5291	DO j = nys, nyn
5292	DO k = nzb+1, nzt+1
5293	tend(k,j,i) = tend(k,j,i) + ( rad_lw_hr(k,j,i) &
5294	+ rad_sw_hr(k,j,i) ) * d_exner(k) &
5295	* d_seconds_hour
5296	ENDDO
5297	ENDDO
5298	ENDDO
5299	ENDIF
5300
5301	END SUBROUTINE radiation_tendency
5302	#endif
5303
5304	!------------------------------------------------------------------------------!
5305	! Description:
5306	! ------------
5307	!> This subroutine calculates interaction of the solar radiation
5308	!> with urban and land surfaces and updates all surface heatfluxes.
5309	!> It calculates also the required parameters for RRTMG lower BC.
5310	!>
5311	!> For more info. see Resler et al. 2017
5312	!>
5313	!> The new version 2.0 was radically rewriten, the discretization scheme
5314	!> has been changed. This new version significantly improves effectivity
5315	!> of the paralelization and the scalability of the model.
5316	!------------------------------------------------------------------------------!
5317
5318	SUBROUTINE radiation_interaction
5319
5320	IMPLICIT NONE
5321
5322	INTEGER(iwp) :: i, j, k, kk, d, refstep, m, mm, l, ll
5323	INTEGER(iwp) :: isurf, isurfsrc, isvf, icsf, ipcgb
5324	INTEGER(iwp) :: imrt, imrtf
5325	INTEGER(iwp) :: isd !< solar direction number
5326	INTEGER(iwp) :: pc_box_dimshift !< transform for best accuracy
5327	INTEGER(iwp), DIMENSION(0:3) :: reorder = (/ 1, 0, 3, 2 /)
5328
5329	REAL(wp), DIMENSION(3,3) :: mrot !< grid rotation matrix (zyx)
5330	REAL(wp), DIMENSION(3,0:nsurf_type):: vnorm !< face direction normal vectors (zyx)
5331	REAL(wp), DIMENSION(3) :: sunorig !< grid rotated solar direction unit vector (zyx)
5332	REAL(wp), DIMENSION(3) :: sunorig_grid !< grid squashed solar direction unit vector (zyx)
5333	REAL(wp), DIMENSION(0:nsurf_type) :: costheta !< direct irradiance factor of solar angle
5334	REAL(wp), DIMENSION(nz_urban_b:nz_urban_t) :: pchf_prep !< precalculated factor for canopy temperature tendency
5335	REAL(wp), PARAMETER :: alpha = 0._wp !< grid rotation (TODO: synchronize with rotation_angle
5336	!< from netcdf_data_input_mod)
5337	REAL(wp) :: pc_box_area, pc_abs_frac, pc_abs_eff
5338	REAL(wp) :: asrc !< area of source face
5339	REAL(wp) :: pcrad !< irradiance from plant canopy
5340	REAL(wp) :: pabsswl = 0.0_wp !< total absorbed SW radiation energy in local processor (W)
5341	REAL(wp) :: pabssw = 0.0_wp !< total absorbed SW radiation energy in all processors (W)
5342	REAL(wp) :: pabslwl = 0.0_wp !< total absorbed LW radiation energy in local processor (W)
5343	REAL(wp) :: pabslw = 0.0_wp !< total absorbed LW radiation energy in all processors (W)
5344	REAL(wp) :: pemitlwl = 0.0_wp !< total emitted LW radiation energy in all processors (W)
5345	REAL(wp) :: pemitlw = 0.0_wp !< total emitted LW radiation energy in all processors (W)
5346	REAL(wp) :: pinswl = 0.0_wp !< total received SW radiation energy in local processor (W)
5347	REAL(wp) :: pinsw = 0.0_wp !< total received SW radiation energy in all processor (W)
5348	REAL(wp) :: pinlwl = 0.0_wp !< total received LW radiation energy in local processor (W)
5349	REAL(wp) :: pinlw = 0.0_wp !< total received LW radiation energy in all processor (W)
5350	REAL(wp) :: emiss_sum_surfl !< sum of emissisivity of surfaces in local processor
5351	REAL(wp) :: emiss_sum_surf !< sum of emissisivity of surfaces in all processor
5352	REAL(wp) :: area_surfl !< total area of surfaces in local processor
5353	REAL(wp) :: area_surf !< total area of surfaces in all processor
5354	REAL(wp) :: area_hor !< total horizontal area of domain in all processor
5355	#if defined( __parallel )
5356	REAL(wp), DIMENSION(1:7) :: combine_allreduce !< dummy array used to combine several MPI_ALLREDUCE calls
5357	REAL(wp), DIMENSION(1:7) :: combine_allreduce_l !< dummy array used to combine several MPI_ALLREDUCE calls
5358	#endif
5359
5360	IF ( debug_output_timestep ) CALL debug_message( 'radiation_interaction', 'start' )
5361
5362	IF ( plant_canopy ) THEN
5363	pchf_prep(:) = r_d * exner(nz_urban_b:nz_urban_t) &
5364	/ (c_p * hyp(nz_urban_b:nz_urban_t) * dxdydz(1)) !< equals to 1 / (rho * c_p * Vbox * T)
5365	ENDIF
5366
5367	sun_direction = .TRUE.
5368	CALL calc_zenith !< required also for diffusion radiation
5369
5370	!-- prepare rotated normal vectors and irradiance factor
5371	vnorm(1,:) = kdir(:)
5372	vnorm(2,:) = jdir(:)
5373	vnorm(3,:) = idir(:)
5374	mrot(1, :) = (/ 1._wp, 0._wp, 0._wp /)
5375	mrot(2, :) = (/ 0._wp, COS(alpha), SIN(alpha) /)
5376	mrot(3, :) = (/ 0._wp, -SIN(alpha), COS(alpha) /)
5377	sunorig = (/ cos_zenith, sun_dir_lat, sun_dir_lon /)
5378	sunorig = MATMUL(mrot, sunorig)
5379	DO d = 0, nsurf_type
5380	costheta(d) = DOT_PRODUCT(sunorig, vnorm(:,d))
5381	ENDDO
5382
5383	IF ( cos_zenith > 0 ) THEN
5384	!-- now we will "squash" the sunorig vector by grid box size in
5385	!-- each dimension, so that this new direction vector will allow us
5386	!-- to traverse the ray path within grid coordinates directly
5387	sunorig_grid = (/ sunorig(1)/dz(1), sunorig(2)/dy, sunorig(3)/dx /)
5388	!-- sunorig_grid = sunorig_grid / norm2(sunorig_grid)
5389	sunorig_grid = sunorig_grid / SQRT(SUM(sunorig_grid**2))
5390
5391	IF ( npcbl > 0 ) THEN
5392	!-- precompute effective box depth with prototype Leaf Area Density
5393	pc_box_dimshift = MAXLOC(ABS(sunorig), 1) - 1
5394	CALL box_absorb(CSHIFT((/dz(1),dy,dx/), pc_box_dimshift), &
5395	60, prototype_lad, &
5396	CSHIFT(ABS(sunorig), pc_box_dimshift), &
5397	pc_box_area, pc_abs_frac)
5398	pc_box_area = pc_box_area * ABS(sunorig(pc_box_dimshift+1) &
5399	/ sunorig(1))
5400	pc_abs_eff = LOG(1._wp - pc_abs_frac) / prototype_lad
5401	ENDIF
5402	ENDIF
5403	!
5404	!-- Split downwelling shortwave radiation into a diffuse and a direct part.
5405	!-- Note, if radiation scheme is RRTMG or diffuse radiation is externally
5406	!-- prescribed, this is not required.
5407	IF ( radiation_scheme /= 'rrtmg' .AND. &
5408	.NOT. rad_sw_in_dif_f%from_file ) CALL calc_diffusion_radiation
5409
5410	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5411	!-- First pass: direct + diffuse irradiance + thermal
5412	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5413	surfinswdir = 0._wp !nsurfl
5414	surfins = 0._wp !nsurfl
5415	surfinl = 0._wp !nsurfl
5416	surfoutsl(:) = 0.0_wp !start-end
5417	surfoutll(:) = 0.0_wp !start-end
5418	IF ( nmrtbl > 0 ) THEN
5419	mrtinsw(:) = 0._wp
5420	mrtinlw(:) = 0._wp
5421	ENDIF
5422	surfinlg(:) = 0._wp !global
5423
5424
5425	!-- Set up thermal radiation from surfaces
5426	!-- emiss_surf is defined only for surfaces for which energy balance is calculated
5427	!-- Workaround: reorder surface data type back on 1D array including all surfaces,
5428	!-- which implies to reorder horizontal and vertical surfaces
5429	!
5430	!-- Horizontal walls
5431	mm = 1
5432	DO i = nxl, nxr
5433	DO j = nys, nyn
5434	!-- urban
5435	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
5436	surfoutll(mm) = SUM ( surf_usm_h%frac(:,m) * &
5437	surf_usm_h%emissivity(:,m) ) &
5438	* sigma_sb &
5439	* surf_usm_h%pt_surface(m)**4
5440	albedo_surf(mm) = SUM ( surf_usm_h%frac(:,m) * &
5441	surf_usm_h%albedo(:,m) )
5442	emiss_surf(mm) = SUM ( surf_usm_h%frac(:,m) * &
5443	surf_usm_h%emissivity(:,m) )
5444	mm = mm + 1
5445	ENDDO
5446	!-- land
5447	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
5448	surfoutll(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5449	surf_lsm_h%emissivity(:,m) ) &
5450	* sigma_sb &
5451	* surf_lsm_h%pt_surface(m)**4
5452	albedo_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5453	surf_lsm_h%albedo(:,m) )
5454	emiss_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5455	surf_lsm_h%emissivity(:,m) )
5456	mm = mm + 1
5457	ENDDO
5458	ENDDO
5459	ENDDO
5460	!
5461	!-- Vertical walls
5462	DO i = nxl, nxr
5463	DO j = nys, nyn
5464	DO ll = 0, 3
5465	l = reorder(ll)
5466	!-- urban
5467	DO m = surf_usm_v(l)%start_index(j,i), &
5468	surf_usm_v(l)%end_index(j,i)
5469	surfoutll(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5470	surf_usm_v(l)%emissivity(:,m) ) &
5471	* sigma_sb &
5472	* surf_usm_v(l)%pt_surface(m)**4
5473	albedo_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5474	surf_usm_v(l)%albedo(:,m) )
5475	emiss_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5476	surf_usm_v(l)%emissivity(:,m) )
5477	mm = mm + 1
5478	ENDDO
5479	!-- land
5480	DO m = surf_lsm_v(l)%start_index(j,i), &
5481	surf_lsm_v(l)%end_index(j,i)
5482	surfoutll(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5483	surf_lsm_v(l)%emissivity(:,m) ) &
5484	* sigma_sb &
5485	* surf_lsm_v(l)%pt_surface(m)**4
5486	albedo_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5487	surf_lsm_v(l)%albedo(:,m) )
5488	emiss_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5489	surf_lsm_v(l)%emissivity(:,m) )
5490	mm = mm + 1
5491	ENDDO
5492	ENDDO
5493	ENDDO
5494	ENDDO
5495
5496	#if defined( __parallel )
5497	!-- might be optimized and gather only values relevant for current processor
5498	CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, &
5499	surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) !nsurf global
5500	IF ( ierr /= 0 ) THEN
5501	WRITE(9,*) 'Error MPI_AllGatherv1:', ierr, SIZE(surfoutll), nsurfl, &
5502	SIZE(surfoutl), nsurfs, surfstart
5503	FLUSH(9)
5504	ENDIF
5505	#else
5506	surfoutl(:) = surfoutll(:) !nsurf global
5507	#endif
5508
5509	IF ( surface_reflections) THEN
5510	DO isvf = 1, nsvfl
5511	isurf = svfsurf(1, isvf)
5512	k = surfl(iz, isurf)
5513	j = surfl(iy, isurf)
5514	i = surfl(ix, isurf)
5515	isurfsrc = svfsurf(2, isvf)
5516	!
5517	!-- For surface-to-surface factors we calculate thermal radiation in 1st pass
5518	IF ( plant_lw_interact ) THEN
5519	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc)
5520	ELSE
5521	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)
5522	ENDIF
5523	ENDDO
5524	ENDIF
5525	!
5526	!-- diffuse radiation using sky view factor
5527	DO isurf = 1, nsurfl
5528	j = surfl(iy, isurf)
5529	i = surfl(ix, isurf)
5530	surfinswdif(isurf) = rad_sw_in_diff(j,i) * skyvft(isurf)
5531	IF ( plant_lw_interact ) THEN
5532	surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvft(isurf)
5533	ELSE
5534	surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvf(isurf)
5535	ENDIF
5536	ENDDO
5537	!
5538	!-- MRT diffuse irradiance
5539	DO imrt = 1, nmrtbl
5540	j = mrtbl(iy, imrt)
5541	i = mrtbl(ix, imrt)
5542	mrtinsw(imrt) = mrtskyt(imrt) * rad_sw_in_diff(j,i)
5543	mrtinlw(imrt) = mrtsky(imrt) * rad_lw_in_diff(j,i)
5544	ENDDO
5545
5546	!-- direct radiation
5547	IF ( cos_zenith > 0 ) THEN
5548	!--Identify solar direction vector (discretized number) 1)
5549	!--
5550	j = FLOOR(ACOS(cos_zenith) / pi * raytrace_discrete_elevs)
5551	i = MODULO(NINT(ATAN2(sun_dir_lon, sun_dir_lat) &
5552	/ (2._wppi) raytrace_discrete_azims-.5_wp, iwp), &
5553	raytrace_discrete_azims)
5554	isd = dsidir_rev(j, i)
5555	!-- TODO: check if isd = -1 to report that this solar position is not precalculated
5556	DO isurf = 1, nsurfl
5557	j = surfl(iy, isurf)
5558	i = surfl(ix, isurf)
5559	surfinswdir(isurf) = rad_sw_in_dir(j,i) * &
5560	costheta(surfl(id, isurf)) * dsitrans(isurf, isd) / cos_zenith
5561	ENDDO
5562	!
5563	!-- MRT direct irradiance
5564	DO imrt = 1, nmrtbl
5565	j = mrtbl(iy, imrt)
5566	i = mrtbl(ix, imrt)
5567	mrtinsw(imrt) = mrtinsw(imrt) + mrtdsit(imrt, isd) * rad_sw_in_dir(j,i) &
5568	/ cos_zenith / 4._wp ! normal to sphere
5569	ENDDO
5570	ENDIF
5571	!
5572	!-- MRT first pass thermal
5573	DO imrtf = 1, nmrtf
5574	imrt = mrtfsurf(1, imrtf)
5575	isurfsrc = mrtfsurf(2, imrtf)
5576	mrtinlw(imrt) = mrtinlw(imrt) + mrtf(imrtf) * surfoutl(isurfsrc)
5577	ENDDO
5578	!
5579	!-- Absorption in each local plant canopy grid box from the first atmospheric
5580	!-- pass of radiation
5581	IF ( npcbl > 0 ) THEN
5582
5583	pcbinswdir(:) = 0._wp
5584	pcbinswdif(:) = 0._wp
5585	pcbinlw(:) = 0._wp
5586
5587	DO icsf = 1, ncsfl
5588	ipcgb = csfsurf(1, icsf)
5589	i = pcbl(ix,ipcgb)
5590	j = pcbl(iy,ipcgb)
5591	k = pcbl(iz,ipcgb)
5592	isurfsrc = csfsurf(2, icsf)
5593
5594	IF ( isurfsrc == -1 ) THEN
5595	!
5596	!-- Diffuse radiation from sky
5597	pcbinswdif(ipcgb) = csf(1,icsf) * rad_sw_in_diff(j,i)
5598	!
5599	!-- Absorbed diffuse LW radiation from sky minus emitted to sky
5600	IF ( plant_lw_interact ) THEN
5601	pcbinlw(ipcgb) = csf(1,icsf) &
5602	* (rad_lw_in_diff(j, i) &
5603	- sigma_sb * (pt(k,j,i)exner(k))*4)
5604	ENDIF
5605	!
5606	!-- Direct solar radiation
5607	IF ( cos_zenith > 0 ) THEN
5608	!-- Estimate directed box absorption
5609	pc_abs_frac = 1._wp - exp(pc_abs_eff * lad_s(k,j,i))
5610	!
5611	!-- isd has already been established, see 1)
5612	pcbinswdir(ipcgb) = rad_sw_in_dir(j, i) * pc_box_area &
5613	* pc_abs_frac * dsitransc(ipcgb, isd)
5614	ENDIF
5615	ELSE
5616	IF ( plant_lw_interact ) THEN
5617	!
5618	!-- Thermal emission from plan canopy towards respective face
5619	pcrad = sigma_sb * (pt(k,j,i) * exner(k))*4 csf(1,icsf)
5620	surfinlg(isurfsrc) = surfinlg(isurfsrc) + pcrad
5621	!
5622	!-- Remove the flux above + absorb LW from first pass from surfaces
5623	asrc = facearea(surf(id, isurfsrc))
5624	pcbinlw(ipcgb) = pcbinlw(ipcgb) &
5625	+ (csf(1,icsf) * surfoutl(isurfsrc) & ! Absorb from first pass surf emit
5626	- pcrad) & ! Remove emitted heatflux
5627	* asrc
5628	ENDIF
5629	ENDIF
5630	ENDDO
5631
5632	pcbinsw(:) = pcbinswdir(:) + pcbinswdif(:)
5633	ENDIF
5634
5635	IF ( plant_lw_interact ) THEN
5636	!
5637	!-- Exchange incoming lw radiation from plant canopy
5638	#if defined( __parallel )
5639	CALL MPI_Allreduce(MPI_IN_PLACE, surfinlg, nsurf, MPI_REAL, MPI_SUM, comm2d, ierr)
5640	IF ( ierr /= 0 ) THEN
5641	WRITE (9,*) 'Error MPI_Allreduce:', ierr
5642	FLUSH(9)
5643	ENDIF
5644	surfinl(:) = surfinl(:) + surfinlg(surfstart(myid)+1:surfstart(myid+1))
5645	#else
5646	surfinl(:) = surfinl(:) + surfinlg(:)
5647	#endif
5648	ENDIF
5649
5650	surfins = surfinswdir + surfinswdif
5651	surfinl = surfinl + surfinlwdif
5652	surfinsw = surfins
5653	surfinlw = surfinl
5654	surfoutsw = 0.0_wp
5655	surfoutlw = surfoutll
5656	surfemitlwl = surfoutll
5657
5658	IF ( .NOT. surface_reflections ) THEN
5659	!
5660	!-- Set nrefsteps to 0 to disable reflections
5661	nrefsteps = 0
5662	surfoutsl = albedo_surf * surfins
5663	surfoutll = (1._wp - emiss_surf) * surfinl
5664	surfoutsw = surfoutsw + surfoutsl
5665	surfoutlw = surfoutlw + surfoutll
5666	ENDIF
5667
5668	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5669	!-- Next passes - reflections
5670	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5671	DO refstep = 1, nrefsteps
5672
5673	surfoutsl = albedo_surf * surfins
5674	!
5675	!-- for non-transparent surfaces, longwave albedo is 1 - emissivity
5676	surfoutll = (1._wp - emiss_surf) * surfinl
5677
5678	#if defined( __parallel )
5679	CALL MPI_AllGatherv(surfoutsl, nsurfl, MPI_REAL, &
5680	surfouts, nsurfs, surfstart, MPI_REAL, comm2d, ierr)
5681	IF ( ierr /= 0 ) THEN
5682	WRITE(9,*) 'Error MPI_AllGatherv2:', ierr, SIZE(surfoutsl), nsurfl, &
5683	SIZE(surfouts), nsurfs, surfstart
5684	FLUSH(9)
5685	ENDIF
5686
5687	CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, &
5688	surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr)
5689	IF ( ierr /= 0 ) THEN
5690	WRITE(9,*) 'Error MPI_AllGatherv3:', ierr, SIZE(surfoutll), nsurfl, &
5691	SIZE(surfoutl), nsurfs, surfstart
5692	FLUSH(9)
5693	ENDIF
5694
5695	#else
5696	surfouts = surfoutsl
5697	surfoutl = surfoutll
5698	#endif
5699	!
5700	!-- Reset for the input from next reflective pass
5701	surfins = 0._wp
5702	surfinl = 0._wp
5703	!
5704	!-- Reflected radiation
5705	DO isvf = 1, nsvfl
5706	isurf = svfsurf(1, isvf)
5707	isurfsrc = svfsurf(2, isvf)
5708	surfins(isurf) = surfins(isurf) + svf(1,isvf) * svf(2,isvf) * surfouts(isurfsrc)
5709	IF ( plant_lw_interact ) THEN
5710	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc)
5711	ELSE
5712	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)
5713	ENDIF
5714	ENDDO
5715	!
5716	!-- NOTE: PC absorbtion and MRT from reflected can both be done at once
5717	!-- after all reflections if we do one more MPI_ALLGATHERV on surfout.
5718	!-- Advantage: less local computation. Disadvantage: one more collective
5719	!-- MPI call.
5720	!
5721	!-- Radiation absorbed by plant canopy
5722	DO icsf = 1, ncsfl
5723	ipcgb = csfsurf(1, icsf)
5724	isurfsrc = csfsurf(2, icsf)
5725	IF ( isurfsrc == -1 ) CYCLE ! sky->face only in 1st pass, not here
5726	!
5727	!-- Calculate source surface area. If the `surf' array is removed
5728	!-- before timestepping starts (future version), then asrc must be
5729	!-- stored within `csf'
5730	asrc = facearea(surf(id, isurfsrc))
5731	pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * surfouts(isurfsrc) * asrc
5732	IF ( plant_lw_interact ) THEN
5733	pcbinlw(ipcgb) = pcbinlw(ipcgb) + csf(1,icsf) * surfoutl(isurfsrc) * asrc
5734	ENDIF
5735	ENDDO
5736	!
5737	!-- MRT reflected
5738	DO imrtf = 1, nmrtf
5739	imrt = mrtfsurf(1, imrtf)
5740	isurfsrc = mrtfsurf(2, imrtf)
5741	mrtinsw(imrt) = mrtinsw(imrt) + mrtft(imrtf) * surfouts(isurfsrc)
5742	mrtinlw(imrt) = mrtinlw(imrt) + mrtf(imrtf) * surfoutl(isurfsrc)
5743	ENDDO
5744
5745	surfinsw = surfinsw + surfins
5746	surfinlw = surfinlw + surfinl
5747	surfoutsw = surfoutsw + surfoutsl
5748	surfoutlw = surfoutlw + surfoutll
5749
5750	ENDDO ! refstep
5751
5752	!-- push heat flux absorbed by plant canopy to respective 3D arrays
5753	IF ( npcbl > 0 ) THEN
5754	pc_heating_rate(:,:,:) = 0.0_wp
5755	DO ipcgb = 1, npcbl
5756	j = pcbl(iy, ipcgb)
5757	i = pcbl(ix, ipcgb)
5758	k = pcbl(iz, ipcgb)
5759	!
5760	!-- Following expression equals former kk = k - nzb_s_inner(j,i)
5761	kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat
5762	pc_heating_rate(kk, j, i) = (pcbinsw(ipcgb) + pcbinlw(ipcgb)) &
5763	* pchf_prep(k) * pt(k, j, i) !-- = dT/dt
5764	ENDDO
5765
5766	IF ( humidity .AND. plant_canopy_transpiration ) THEN
5767	!-- Calculation of plant canopy transpiration rate and correspondidng latent heat rate
5768	pc_transpiration_rate(:,:,:) = 0.0_wp
5769	pc_latent_rate(:,:,:) = 0.0_wp
5770	DO ipcgb = 1, npcbl
5771	i = pcbl(ix, ipcgb)
5772	j = pcbl(iy, ipcgb)
5773	k = pcbl(iz, ipcgb)
5774	kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat
5775	CALL pcm_calc_transpiration_rate( i, j, k, kk, pcbinsw(ipcgb), pcbinlw(ipcgb), &
5776	pc_transpiration_rate(kk,j,i), pc_latent_rate(kk,j,i) )
5777	ENDDO
5778	ENDIF
5779	ENDIF
5780	!
5781	!-- Calculate black body MRT (after all reflections)
5782	IF ( nmrtbl > 0 ) THEN
5783	IF ( mrt_include_sw ) THEN
5784	mrt(:) = ((mrtinsw(:) + mrtinlw(:)) / sigma_sb) ** .25_wp
5785	ELSE
5786	mrt(:) = (mrtinlw(:) / sigma_sb) ** .25_wp
5787	ENDIF
5788	ENDIF
5789	!
5790	!-- Transfer radiation arrays required for energy balance to the respective data types
5791	DO i = 1, nsurfl
5792	m = surfl(im,i)
5793	!
5794	!-- (1) Urban surfaces
5795	!-- upward-facing
5796	IF ( surfl(1,i) == iup_u ) THEN
5797	surf_usm_h%rad_sw_in(m) = surfinsw(i)
5798	surf_usm_h%rad_sw_out(m) = surfoutsw(i)
5799	surf_usm_h%rad_sw_dir(m) = surfinswdir(i)
5800	surf_usm_h%rad_sw_dif(m) = surfinswdif(i)
5801	surf_usm_h%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5802	surfinswdif(i)
5803	surf_usm_h%rad_sw_res(m) = surfins(i)
5804	surf_usm_h%rad_lw_in(m) = surfinlw(i)
5805	surf_usm_h%rad_lw_out(m) = surfoutlw(i)
5806	surf_usm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5807	surfinlw(i) - surfoutlw(i)
5808	surf_usm_h%rad_net_l(m) = surf_usm_h%rad_net(m)
5809	surf_usm_h%rad_lw_dif(m) = surfinlwdif(i)
5810	surf_usm_h%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5811	surf_usm_h%rad_lw_res(m) = surfinl(i)
5812	!
5813	!-- northward-facding
5814	ELSEIF ( surfl(1,i) == inorth_u ) THEN
5815	surf_usm_v(0)%rad_sw_in(m) = surfinsw(i)
5816	surf_usm_v(0)%rad_sw_out(m) = surfoutsw(i)
5817	surf_usm_v(0)%rad_sw_dir(m) = surfinswdir(i)
5818	surf_usm_v(0)%rad_sw_dif(m) = surfinswdif(i)
5819	surf_usm_v(0)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5820	surfinswdif(i)
5821	surf_usm_v(0)%rad_sw_res(m) = surfins(i)
5822	surf_usm_v(0)%rad_lw_in(m) = surfinlw(i)
5823	surf_usm_v(0)%rad_lw_out(m) = surfoutlw(i)
5824	surf_usm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5825	surfinlw(i) - surfoutlw(i)
5826	surf_usm_v(0)%rad_net_l(m) = surf_usm_v(0)%rad_net(m)
5827	surf_usm_v(0)%rad_lw_dif(m) = surfinlwdif(i)
5828	surf_usm_v(0)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5829	surf_usm_v(0)%rad_lw_res(m) = surfinl(i)
5830	!
5831	!-- southward-facding
5832	ELSEIF ( surfl(1,i) == isouth_u ) THEN
5833	surf_usm_v(1)%rad_sw_in(m) = surfinsw(i)
5834	surf_usm_v(1)%rad_sw_out(m) = surfoutsw(i)
5835	surf_usm_v(1)%rad_sw_dir(m) = surfinswdir(i)
5836	surf_usm_v(1)%rad_sw_dif(m) = surfinswdif(i)
5837	surf_usm_v(1)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5838	surfinswdif(i)
5839	surf_usm_v(1)%rad_sw_res(m) = surfins(i)
5840	surf_usm_v(1)%rad_lw_in(m) = surfinlw(i)
5841	surf_usm_v(1)%rad_lw_out(m) = surfoutlw(i)
5842	surf_usm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5843	surfinlw(i) - surfoutlw(i)
5844	surf_usm_v(1)%rad_net_l(m) = surf_usm_v(1)%rad_net(m)
5845	surf_usm_v(1)%rad_lw_dif(m) = surfinlwdif(i)
5846	surf_usm_v(1)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5847	surf_usm_v(1)%rad_lw_res(m) = surfinl(i)
5848	!
5849	!-- eastward-facing
5850	ELSEIF ( surfl(1,i) == ieast_u ) THEN
5851	surf_usm_v(2)%rad_sw_in(m) = surfinsw(i)
5852	surf_usm_v(2)%rad_sw_out(m) = surfoutsw(i)
5853	surf_usm_v(2)%rad_sw_dir(m) = surfinswdir(i)
5854	surf_usm_v(2)%rad_sw_dif(m) = surfinswdif(i)
5855	surf_usm_v(2)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5856	surfinswdif(i)
5857	surf_usm_v(2)%rad_sw_res(m) = surfins(i)
5858	surf_usm_v(2)%rad_lw_in(m) = surfinlw(i)
5859	surf_usm_v(2)%rad_lw_out(m) = surfoutlw(i)
5860	surf_usm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5861	surfinlw(i) - surfoutlw(i)
5862	surf_usm_v(2)%rad_net_l(m) = surf_usm_v(2)%rad_net(m)
5863	surf_usm_v(2)%rad_lw_dif(m) = surfinlwdif(i)
5864	surf_usm_v(2)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5865	surf_usm_v(2)%rad_lw_res(m) = surfinl(i)
5866	!
5867	!-- westward-facding
5868	ELSEIF ( surfl(1,i) == iwest_u ) THEN
5869	surf_usm_v(3)%rad_sw_in(m) = surfinsw(i)
5870	surf_usm_v(3)%rad_sw_out(m) = surfoutsw(i)
5871	surf_usm_v(3)%rad_sw_dir(m) = surfinswdir(i)
5872	surf_usm_v(3)%rad_sw_dif(m) = surfinswdif(i)
5873	surf_usm_v(3)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5874	surfinswdif(i)
5875	surf_usm_v(3)%rad_sw_res(m) = surfins(i)
5876	surf_usm_v(3)%rad_lw_in(m) = surfinlw(i)
5877	surf_usm_v(3)%rad_lw_out(m) = surfoutlw(i)
5878	surf_usm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5879	surfinlw(i) - surfoutlw(i)
5880	surf_usm_v(3)%rad_net_l(m) = surf_usm_v(3)%rad_net(m)
5881	surf_usm_v(3)%rad_lw_dif(m) = surfinlwdif(i)
5882	surf_usm_v(3)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5883	surf_usm_v(3)%rad_lw_res(m) = surfinl(i)
5884	!
5885	!-- (2) land surfaces
5886	!-- upward-facing
5887	ELSEIF ( surfl(1,i) == iup_l ) THEN
5888	surf_lsm_h%rad_sw_in(m) = surfinsw(i)
5889	surf_lsm_h%rad_sw_out(m) = surfoutsw(i)
5890	surf_lsm_h%rad_sw_dir(m) = surfinswdir(i)
5891	surf_lsm_h%rad_sw_dif(m) = surfinswdif(i)
5892	surf_lsm_h%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5893	surfinswdif(i)
5894	surf_lsm_h%rad_sw_res(m) = surfins(i)
5895	surf_lsm_h%rad_lw_in(m) = surfinlw(i)
5896	surf_lsm_h%rad_lw_out(m) = surfoutlw(i)
5897	surf_lsm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5898	surfinlw(i) - surfoutlw(i)
5899	surf_lsm_h%rad_lw_dif(m) = surfinlwdif(i)
5900	surf_lsm_h%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5901	surf_lsm_h%rad_lw_res(m) = surfinl(i)
5902	!
5903	!-- northward-facding
5904	ELSEIF ( surfl(1,i) == inorth_l ) THEN
5905	surf_lsm_v(0)%rad_sw_in(m) = surfinsw(i)
5906	surf_lsm_v(0)%rad_sw_out(m) = surfoutsw(i)
5907	surf_lsm_v(0)%rad_sw_dir(m) = surfinswdir(i)
5908	surf_lsm_v(0)%rad_sw_dif(m) = surfinswdif(i)
5909	surf_lsm_v(0)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5910	surfinswdif(i)
5911	surf_lsm_v(0)%rad_sw_res(m) = surfins(i)
5912	surf_lsm_v(0)%rad_lw_in(m) = surfinlw(i)
5913	surf_lsm_v(0)%rad_lw_out(m) = surfoutlw(i)
5914	surf_lsm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5915	surfinlw(i) - surfoutlw(i)
5916	surf_lsm_v(0)%rad_lw_dif(m) = surfinlwdif(i)
5917	surf_lsm_v(0)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5918	surf_lsm_v(0)%rad_lw_res(m) = surfinl(i)
5919	!
5920	!-- southward-facding
5921	ELSEIF ( surfl(1,i) == isouth_l ) THEN
5922	surf_lsm_v(1)%rad_sw_in(m) = surfinsw(i)
5923	surf_lsm_v(1)%rad_sw_out(m) = surfoutsw(i)
5924	surf_lsm_v(1)%rad_sw_dir(m) = surfinswdir(i)
5925	surf_lsm_v(1)%rad_sw_dif(m) = surfinswdif(i)
5926	surf_lsm_v(1)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5927	surfinswdif(i)
5928	surf_lsm_v(1)%rad_sw_res(m) = surfins(i)
5929	surf_lsm_v(1)%rad_lw_in(m) = surfinlw(i)
5930	surf_lsm_v(1)%rad_lw_out(m) = surfoutlw(i)
5931	surf_lsm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5932	surfinlw(i) - surfoutlw(i)
5933	surf_lsm_v(1)%rad_lw_dif(m) = surfinlwdif(i)
5934	surf_lsm_v(1)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5935	surf_lsm_v(1)%rad_lw_res(m) = surfinl(i)
5936	!
5937	!-- eastward-facing
5938	ELSEIF ( surfl(1,i) == ieast_l ) THEN
5939	surf_lsm_v(2)%rad_sw_in(m) = surfinsw(i)
5940	surf_lsm_v(2)%rad_sw_out(m) = surfoutsw(i)
5941	surf_lsm_v(2)%rad_sw_dir(m) = surfinswdir(i)
5942	surf_lsm_v(2)%rad_sw_dif(m) = surfinswdif(i)
5943	surf_lsm_v(2)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5944	surfinswdif(i)
5945	surf_lsm_v(2)%rad_sw_res(m) = surfins(i)
5946	surf_lsm_v(2)%rad_lw_in(m) = surfinlw(i)
5947	surf_lsm_v(2)%rad_lw_out(m) = surfoutlw(i)
5948	surf_lsm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5949	surfinlw(i) - surfoutlw(i)
5950	surf_lsm_v(2)%rad_lw_dif(m) = surfinlwdif(i)
5951	surf_lsm_v(2)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5952	surf_lsm_v(2)%rad_lw_res(m) = surfinl(i)
5953	!
5954	!-- westward-facing
5955	ELSEIF ( surfl(1,i) == iwest_l ) THEN
5956	surf_lsm_v(3)%rad_sw_in(m) = surfinsw(i)
5957	surf_lsm_v(3)%rad_sw_out(m) = surfoutsw(i)
5958	surf_lsm_v(3)%rad_sw_dir(m) = surfinswdir(i)
5959	surf_lsm_v(3)%rad_sw_dif(m) = surfinswdif(i)
5960	surf_lsm_v(3)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5961	surfinswdif(i)
5962	surf_lsm_v(3)%rad_sw_res(m) = surfins(i)
5963	surf_lsm_v(3)%rad_lw_in(m) = surfinlw(i)
5964	surf_lsm_v(3)%rad_lw_out(m) = surfoutlw(i)
5965	surf_lsm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5966	surfinlw(i) - surfoutlw(i)
5967	surf_lsm_v(3)%rad_lw_dif(m) = surfinlwdif(i)
5968	surf_lsm_v(3)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5969	surf_lsm_v(3)%rad_lw_res(m) = surfinl(i)
5970	ENDIF
5971
5972	ENDDO
5973
5974	DO m = 1, surf_usm_h%ns
5975	surf_usm_h%surfhf(m) = surf_usm_h%rad_sw_in(m) + &
5976	surf_usm_h%rad_lw_in(m) - &
5977	surf_usm_h%rad_sw_out(m) - &
5978	surf_usm_h%rad_lw_out(m)
5979	ENDDO
5980	DO m = 1, surf_lsm_h%ns
5981	surf_lsm_h%surfhf(m) = surf_lsm_h%rad_sw_in(m) + &
5982	surf_lsm_h%rad_lw_in(m) - &
5983	surf_lsm_h%rad_sw_out(m) - &
5984	surf_lsm_h%rad_lw_out(m)
5985	ENDDO
5986
5987	DO l = 0, 3
5988	!-- urban
5989	DO m = 1, surf_usm_v(l)%ns
5990	surf_usm_v(l)%surfhf(m) = surf_usm_v(l)%rad_sw_in(m) + &
5991	surf_usm_v(l)%rad_lw_in(m) - &
5992	surf_usm_v(l)%rad_sw_out(m) - &
5993	surf_usm_v(l)%rad_lw_out(m)
5994	ENDDO
5995	!-- land
5996	DO m = 1, surf_lsm_v(l)%ns
5997	surf_lsm_v(l)%surfhf(m) = surf_lsm_v(l)%rad_sw_in(m) + &
5998	surf_lsm_v(l)%rad_lw_in(m) - &
5999	surf_lsm_v(l)%rad_sw_out(m) - &
6000	surf_lsm_v(l)%rad_lw_out(m)
6001
6002	ENDDO
6003	ENDDO
6004	!
6005	!-- Calculate the average temperature, albedo, and emissivity for urban/land
6006	!-- domain when using average_radiation in the respective radiation model
6007
6008	!-- calculate horizontal area
6009	! !!! ATTENTION!!! uniform grid is assumed here
6010	area_hor = (nx+1) * (ny+1) * dx * dy
6011	!
6012	!-- absorbed/received SW & LW and emitted LW energy of all physical
6013	!-- surfaces (land and urban) in local processor
6014	pinswl = 0._wp
6015	pinlwl = 0._wp
6016	pabsswl = 0._wp
6017	pabslwl = 0._wp
6018	pemitlwl = 0._wp
6019	emiss_sum_surfl = 0._wp
6020	area_surfl = 0._wp
6021	DO i = 1, nsurfl
6022	d = surfl(id, i)
6023	!-- received SW & LW
6024	pinswl = pinswl + (surfinswdir(i) + surfinswdif(i)) * facearea(d)
6025	pinlwl = pinlwl + surfinlwdif(i) * facearea(d)
6026	!-- absorbed SW & LW
6027	pabsswl = pabsswl + (1._wp - albedo_surf(i)) * &
6028	surfinsw(i) * facearea(d)
6029	pabslwl = pabslwl + emiss_surf(i) * surfinlw(i) * facearea(d)
6030	!-- emitted LW
6031	pemitlwl = pemitlwl + surfemitlwl(i) * facearea(d)
6032	!-- emissivity and area sum
6033	emiss_sum_surfl = emiss_sum_surfl + emiss_surf(i) * facearea(d)
6034	area_surfl = area_surfl + facearea(d)
6035	END DO
6036	!
6037	!-- add the absorbed SW energy by plant canopy
6038	IF ( npcbl > 0 ) THEN
6039	pabsswl = pabsswl + SUM(pcbinsw)
6040	pabslwl = pabslwl + SUM(pcbinlw)
6041	pinswl = pinswl + SUM(pcbinswdir) + SUM(pcbinswdif)
6042	ENDIF
6043	!
6044	!-- gather all rad flux energy in all processors. In order to reduce
6045	!-- the number of MPI calls (to reduce latencies), combine the required
6046	!-- quantities in one array, sum it up, and subsequently re-distribute
6047	!-- back to the respective quantities.
6048	#if defined( __parallel )
6049	combine_allreduce_l(1) = pinswl
6050	combine_allreduce_l(2) = pinlwl
6051	combine_allreduce_l(3) = pabsswl
6052	combine_allreduce_l(4) = pabslwl
6053	combine_allreduce_l(5) = pemitlwl
6054	combine_allreduce_l(6) = emiss_sum_surfl
6055	combine_allreduce_l(7) = area_surfl
6056
6057	CALL MPI_ALLREDUCE( combine_allreduce_l, &
6058	combine_allreduce, &
6059	SIZE( combine_allreduce ), &
6060	MPI_REAL, &
6061	MPI_SUM, &
6062	comm2d, &
6063	ierr )
6064
6065	pinsw = combine_allreduce(1)
6066	pinlw = combine_allreduce(2)
6067	pabssw = combine_allreduce(3)
6068	pabslw = combine_allreduce(4)
6069	pemitlw = combine_allreduce(5)
6070	emiss_sum_surf = combine_allreduce(6)
6071	area_surf = combine_allreduce(7)
6072	#else
6073	pinsw = pinswl
6074	pinlw = pinlwl
6075	pabssw = pabsswl
6076	pabslw = pabslwl
6077	pemitlw = pemitlwl
6078	emiss_sum_surf = emiss_sum_surfl
6079	area_surf = area_surfl
6080	#endif
6081
6082	!-- (1) albedo
6083	IF ( pinsw /= 0.0_wp ) albedo_urb = ( pinsw - pabssw ) / pinsw
6084	!-- (2) average emmsivity
6085	IF ( area_surf /= 0.0_wp ) emissivity_urb = emiss_sum_surf / area_surf
6086	!
6087	!-- Temporally comment out calculation of effective radiative temperature.
6088	!-- See below for more explanation.
6089	!-- (3) temperature
6090	!-- first we calculate an effective horizontal area to account for
6091	!-- the effect of vertical surfaces (which contributes to LW emission)
6092	!-- We simply use the ratio of the total LW to the incoming LW flux
6093	area_hor = pinlw / rad_lw_in_diff(nyn,nxl)
6094	t_rad_urb = ( ( pemitlw - pabslw + emissivity_urb * pinlw ) / &
6095	(emissivity_urb * sigma_sb * area_hor) )**0.25_wp
6096
6097	IF ( debug_output_timestep ) CALL debug_message( 'radiation_interaction', 'end' )
6098
6099
6100	CONTAINS
6101
6102	!------------------------------------------------------------------------------!
6103	!> Calculates radiation absorbed by box with given size and LAD.
6104	!>
6105	!> Simulates resol**2 rays (by equally spacing a bounding horizontal square
6106	!> conatining all possible rays that would cross the box) and calculates
6107	!> average transparency per ray. Returns fraction of absorbed radiation flux
6108	!> and area for which this fraction is effective.
6109	!------------------------------------------------------------------------------!
6110	PURE SUBROUTINE box_absorb(boxsize, resol, dens, uvec, area, absorb)
6111	IMPLICIT NONE
6112
6113	REAL(wp), DIMENSION(3), INTENT(in) :: &
6114	boxsize, & !< z, y, x size of box in m
6115	uvec !< z, y, x unit vector of incoming flux
6116	INTEGER(iwp), INTENT(in) :: &
6117	resol !< No. of rays in x and y dimensions
6118	REAL(wp), INTENT(in) :: &
6119	dens !< box density (e.g. Leaf Area Density)
6120	REAL(wp), INTENT(out) :: &
6121	area, & !< horizontal area for flux absorbtion
6122	absorb !< fraction of absorbed flux
6123	REAL(wp) :: &
6124	xshift, yshift, &
6125	xmin, xmax, ymin, ymax, &
6126	xorig, yorig, &
6127	dx1, dy1, dz1, dx2, dy2, dz2, &
6128	crdist, &
6129	transp
6130	INTEGER(iwp) :: &
6131	i, j
6132
6133	xshift = uvec(3) / uvec(1) * boxsize(1)
6134	xmin = min(0._wp, -xshift)
6135	xmax = boxsize(3) + max(0._wp, -xshift)
6136	yshift = uvec(2) / uvec(1) * boxsize(1)
6137	ymin = min(0._wp, -yshift)
6138	ymax = boxsize(2) + max(0._wp, -yshift)
6139
6140	transp = 0._wp
6141	DO i = 1, resol
6142	xorig = xmin + (xmax-xmin) * (i-.5_wp) / resol
6143	DO j = 1, resol
6144	yorig = ymin + (ymax-ymin) * (j-.5_wp) / resol
6145
6146	dz1 = 0._wp
6147	dz2 = boxsize(1)/uvec(1)
6148
6149	IF ( uvec(2) > 0._wp ) THEN
6150	dy1 = -yorig / uvec(2) !< crossing with y=0
6151	dy2 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2)
6152	ELSE !uvec(2)==0
6153	dy1 = -huge(1._wp)
6154	dy2 = huge(1._wp)
6155	ENDIF
6156
6157	IF ( uvec(3) > 0._wp ) THEN
6158	dx1 = -xorig / uvec(3) !< crossing with x=0
6159	dx2 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3)
6160	ELSE !uvec(3)==0
6161	dx1 = -huge(1._wp)
6162	dx2 = huge(1._wp)
6163	ENDIF
6164
6165	crdist = max(0._wp, (min(dz2, dy2, dx2) - max(dz1, dy1, dx1)))
6166	transp = transp + exp(-ext_coef * dens * crdist)
6167	ENDDO
6168	ENDDO
6169	transp = transp / resol**2
6170	area = (boxsize(3)+xshift)*(boxsize(2)+yshift)
6171	absorb = 1._wp - transp
6172
6173	END SUBROUTINE box_absorb
6174
6175	!------------------------------------------------------------------------------!
6176	! Description:
6177	! ------------
6178	!> This subroutine splits direct and diffusion dw radiation
6179	!> It sould not be called in case the radiation model already does it
6180	!> It follows Boland, Ridley & Brown (2008)
6181	!------------------------------------------------------------------------------!
6182	SUBROUTINE calc_diffusion_radiation
6183
6184	INTEGER(iwp) :: i !< grid index x-direction
6185	INTEGER(iwp) :: j !< grid index y-direction
6186
6187	REAL(wp) :: year_angle !< angle
6188	REAL(wp) :: etr !< extraterestrial radiation
6189	REAL(wp) :: corrected_solarUp !< corrected solar up radiation
6190	REAL(wp) :: horizontalETR !< horizontal extraterestrial radiation
6191	REAL(wp) :: clearnessIndex !< clearness index
6192	REAL(wp) :: diff_frac !< diffusion fraction of the radiation
6193
6194	REAL(wp), PARAMETER :: lowest_solarUp = 0.1_wp !< limit the sun elevation to protect stability of the calculation
6195	!
6196	!-- Calculate current day and time based on the initial values and simulation time
6197	year_angle = ( (day_of_year_init * 86400) + time_utc_init &
6198	+ time_since_reference_point ) * d_seconds_year &
6199	* 2.0_wp * pi
6200
6201	etr = solar_constant * (1.00011_wp + &
6202	0.034221_wp * cos(year_angle) + &
6203	0.001280_wp * sin(year_angle) + &
6204	0.000719_wp * cos(2.0_wp * year_angle) + &
6205	0.000077_wp * sin(2.0_wp * year_angle))
6206	!
6207	!--
6208	!-- Under a very low angle, we keep extraterestrial radiation at
6209	!-- the last small value, therefore the clearness index will be pushed
6210	!-- towards 0 while keeping full continuity.
6211	IF ( cos_zenith <= lowest_solarUp ) THEN
6212	corrected_solarUp = lowest_solarUp
6213	ELSE
6214	corrected_solarUp = cos_zenith
6215	ENDIF
6216
6217	horizontalETR = etr * corrected_solarUp
6218
6219	DO i = nxl, nxr
6220	DO j = nys, nyn
6221	clearnessIndex = rad_sw_in(0,j,i) / horizontalETR
6222	diff_frac = 1.0_wp / (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex))
6223	rad_sw_in_diff(j,i) = rad_sw_in(0,j,i) * diff_frac
6224	rad_sw_in_dir(j,i) = rad_sw_in(0,j,i) * (1.0_wp - diff_frac)
6225	rad_lw_in_diff(j,i) = rad_lw_in(0,j,i)
6226	ENDDO
6227	ENDDO
6228
6229	END SUBROUTINE calc_diffusion_radiation
6230
6231	END SUBROUTINE radiation_interaction
6232
6233	!------------------------------------------------------------------------------!
6234	! Description:
6235	! ------------
6236	!> This subroutine initializes structures needed for radiative transfer
6237	!> model. This model calculates transformation processes of the
6238	!> radiation inside urban and land canopy layer. The module includes also
6239	!> the interaction of the radiation with the resolved plant canopy.
6240	!>
6241	!> For more info. see Resler et al. 2017
6242	!>
6243	!> The new version 2.0 was radically rewriten, the discretization scheme
6244	!> has been changed. This new version significantly improves effectivity
6245	!> of the paralelization and the scalability of the model.
6246	!>
6247	!------------------------------------------------------------------------------!
6248	SUBROUTINE radiation_interaction_init
6249
6250	USE control_parameters, &
6251	ONLY: dz_stretch_level_start
6252
6253	USE plant_canopy_model_mod, &
6254	ONLY: lad_s
6255
6256	IMPLICIT NONE
6257
6258	INTEGER(iwp) :: i, j, k, l, m, d
6259	INTEGER(iwp) :: k_topo !< vertical index indicating topography top for given (j,i)
6260	INTEGER(iwp) :: nzptl, nzubl, nzutl, isurf, ipcgb, imrt
6261	REAL(wp) :: mrl
6262	#if defined( __parallel )
6263	INTEGER(iwp), DIMENSION(:), POINTER, SAVE :: gridsurf_rma !< fortran pointer, but lower bounds are 1
6264	TYPE(c_ptr) :: gridsurf_rma_p !< allocated c pointer
6265	INTEGER(iwp) :: minfo !< MPI RMA window info handle
6266	#endif
6267
6268	!
6269	!-- precalculate face areas for different face directions using normal vector
6270	DO d = 0, nsurf_type
6271	facearea(d) = 1._wp
6272	IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx
6273	IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy
6274	IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz(1)
6275	ENDDO
6276	!
6277	!-- Find nz_urban_b, nz_urban_t, nz_urban via wall_flag_0 array (nzb_s_inner will be
6278	!-- removed later). The following contruct finds the lowest / largest index
6279	!-- for any upward-facing wall (see bit 12).
6280	nzubl = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
6281	nzutl = MAXVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
6282
6283	nzubl = MAX( nzubl, nzb )
6284
6285	IF ( plant_canopy ) THEN
6286	!-- allocate needed arrays
6287	ALLOCATE( pct(nys:nyn,nxl:nxr) )
6288	ALLOCATE( pch(nys:nyn,nxl:nxr) )
6289
6290	!-- calculate plant canopy height
6291	npcbl = 0
6292	pct = 0
6293	pch = 0
6294	DO i = nxl, nxr
6295	DO j = nys, nyn
6296	!
6297	!-- Find topography top index
6298	k_topo = topo_top_ind(j,i,0)
6299
6300	DO k = nzt+1, 0, -1
6301	IF ( lad_s(k,j,i) /= 0.0_wp ) THEN
6302	!-- we are at the top of the pcs
6303	pct(j,i) = k + k_topo
6304	pch(j,i) = k
6305	npcbl = npcbl + pch(j,i)
6306	EXIT
6307	ENDIF
6308	ENDDO
6309	ENDDO
6310	ENDDO
6311
6312	nzutl = MAX( nzutl, MAXVAL( pct ) )
6313	nzptl = MAXVAL( pct )
6314
6315	prototype_lad = MAXVAL( lad_s ) * .9_wp !< better be *1.0 if lad is either 0 or maxval(lad) everywhere
6316	IF ( prototype_lad <= 0._wp ) prototype_lad = .3_wp
6317	!WRITE(message_string, '(a,f6.3)') 'Precomputing effective box optical ' &
6318	! // 'depth using prototype leaf area density = ', prototype_lad
6319	!CALL message('radiation_interaction_init', 'PA0520', 0, 0, -1, 6, 0)
6320	ENDIF
6321
6322	nzutl = MIN( nzutl + nzut_free, nzt )
6323
6324	#if defined( __parallel )
6325	CALL MPI_AllReduce(nzubl, nz_urban_b, 1, MPI_INTEGER, MPI_MIN, comm2d, ierr )
6326	IF ( ierr /= 0 ) THEN
6327	WRITE(9,*) 'Error MPI_AllReduce11:', ierr, nzubl, nz_urban_b
6328	FLUSH(9)
6329	ENDIF
6330	CALL MPI_AllReduce(nzutl, nz_urban_t, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr )
6331	IF ( ierr /= 0 ) THEN
6332	WRITE(9,*) 'Error MPI_AllReduce12:', ierr, nzutl, nz_urban_t
6333	FLUSH(9)
6334	ENDIF
6335	CALL MPI_AllReduce(nzptl, nz_plant_t, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr )
6336	IF ( ierr /= 0 ) THEN
6337	WRITE(9,*) 'Error MPI_AllReduce13:', ierr, nzptl, nz_plant_t
6338	FLUSH(9)
6339	ENDIF
6340	#else
6341	nz_urban_b = nzubl
6342	nz_urban_t = nzutl
6343	nz_plant_t = nzptl
6344	#endif
6345	!
6346	!-- Stretching (non-uniform grid spacing) is not considered in the radiation
6347	!-- model. Therefore, vertical stretching has to be applied above the area
6348	!-- where the parts of the radiation model which assume constant grid spacing
6349	!-- are active. ABS (...) is required because the default value of
6350	!-- dz_stretch_level_start is -9999999.9_wp (negative).
6351	IF ( ABS( dz_stretch_level_start(1) ) <= zw(nz_urban_t) ) THEN
6352	WRITE( message_string, * ) 'The lowest level where vertical ', &
6353	'stretching is applied have to be ', &
6354	'greater than ', zw(nz_urban_t)
6355	CALL message( 'radiation_interaction_init', 'PA0496', 1, 2, 0, 6, 0 )
6356	ENDIF
6357	!
6358	!-- global number of urban and plant layers
6359	nz_urban = nz_urban_t - nz_urban_b + 1
6360	nz_plant = nz_plant_t - nz_urban_b + 1
6361	!
6362	!-- check max_raytracing_dist relative to urban surface layer height
6363	mrl = 2.0_wp * nz_urban * dz(1)
6364	!-- set max_raytracing_dist to double the urban surface layer height, if not set
6365	IF ( max_raytracing_dist == -999.0_wp ) THEN
6366	max_raytracing_dist = mrl
6367	ENDIF
6368	!-- check if max_raytracing_dist set too low (here we only warn the user. Other
6369	! option is to correct the value again to double the urban surface layer height)
6370	IF ( max_raytracing_dist < mrl ) THEN
6371	WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist is set less than ' // &
6372	'double the urban surface layer height, i.e. ', mrl
6373	CALL message('radiation_interaction_init', 'PA0521', 0, 0, 0, 6, 0 )
6374	ENDIF
6375	! IF ( max_raytracing_dist <= mrl ) THEN
6376	! IF ( max_raytracing_dist /= -999.0_wp ) THEN
6377	! !-- max_raytracing_dist too low
6378	! WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist too low, ' &
6379	! // 'override to value ', mrl
6380	! CALL message('radiation_interaction_init', 'PA0521', 0, 0, -1, 6, 0)
6381	! ENDIF
6382	! max_raytracing_dist = mrl
6383	! ENDIF
6384	!
6385	!-- allocate urban surfaces grid
6386	!-- calc number of surfaces in local proc
6387	IF ( debug_output ) CALL debug_message( 'calculation of indices for surfaces', 'info' )
6388
6389	nsurfl = 0
6390	!
6391	!-- Number of horizontal surfaces including land- and roof surfaces in both USM and LSM. Note that
6392	!-- All horizontal surface elements are already counted in surface_mod.
6393	startland = 1
6394	nsurfl = surf_usm_h%ns + surf_lsm_h%ns
6395	endland = nsurfl
6396	nlands = endland - startland + 1
6397
6398	!
6399	!-- Number of vertical surfaces in both USM and LSM. Note that all vertical surface elements are
6400	!-- already counted in surface_mod.
6401	startwall = nsurfl+1
6402	DO i = 0,3
6403	nsurfl = nsurfl + surf_usm_v(i)%ns + surf_lsm_v(i)%ns
6404	ENDDO
6405	endwall = nsurfl
6406	nwalls = endwall - startwall + 1
6407	dirstart = (/ startland, startwall, startwall, startwall, startwall /)
6408	dirend = (/ endland, endwall, endwall, endwall, endwall /)
6409
6410	!-- fill gridpcbl and pcbl
6411	IF ( npcbl > 0 ) THEN
6412	ALLOCATE( pcbl(iz:ix, 1:npcbl) )
6413	ALLOCATE( gridpcbl(nz_urban_b:nz_plant_t,nys:nyn,nxl:nxr) )
6414	pcbl = -1
6415	gridpcbl(:,:,:) = 0
6416	ipcgb = 0
6417	DO i = nxl, nxr
6418	DO j = nys, nyn
6419	!
6420	!-- Find topography top index
6421	k_topo = topo_top_ind(j,i,0)
6422
6423	DO k = k_topo + 1, pct(j,i)
6424	ipcgb = ipcgb + 1
6425	gridpcbl(k,j,i) = ipcgb
6426	pcbl(:,ipcgb) = (/ k, j, i /)
6427	ENDDO
6428	ENDDO
6429	ENDDO
6430	ALLOCATE( pcbinsw( 1:npcbl ) )
6431	ALLOCATE( pcbinswdir( 1:npcbl ) )
6432	ALLOCATE( pcbinswdif( 1:npcbl ) )
6433	ALLOCATE( pcbinlw( 1:npcbl ) )
6434	ENDIF
6435
6436	!
6437	!-- Fill surfl (the ordering of local surfaces given by the following
6438	!-- cycles must not be altered, certain file input routines may depend
6439	!-- on it).
6440	!
6441	!-- We allocate the array as linear and then use a two-dimensional pointer
6442	!-- into it, because some MPI implementations crash with 2D-allocated arrays.
6443	ALLOCATE(surfl_linear(nidx_surf*nsurfl))
6444	surfl(1:nidx_surf,1:nsurfl) => surfl_linear(1:nidx_surf*nsurfl)
6445	isurf = 0
6446	IF ( rad_angular_discretization ) THEN
6447	!
6448	!-- Allocate and fill the reverse indexing array gridsurf
6449	#if defined( __parallel )
6450	!
6451	!-- raytrace_mpi_rma is asserted
6452
6453	CALL MPI_Info_create(minfo, ierr)
6454	IF ( ierr /= 0 ) THEN
6455	WRITE(9,*) 'Error MPI_Info_create1:', ierr
6456	FLUSH(9)
6457	ENDIF
6458	CALL MPI_Info_set(minfo, 'accumulate_ordering', 'none', ierr)
6459	IF ( ierr /= 0 ) THEN
6460	WRITE(9,*) 'Error MPI_Info_set1:', ierr
6461	FLUSH(9)
6462	ENDIF
6463	CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr)
6464	IF ( ierr /= 0 ) THEN
6465	WRITE(9,*) 'Error MPI_Info_set2:', ierr
6466	FLUSH(9)
6467	ENDIF
6468	CALL MPI_Info_set(minfo, 'same_size', 'true', ierr)
6469	IF ( ierr /= 0 ) THEN
6470	WRITE(9,*) 'Error MPI_Info_set3:', ierr
6471	FLUSH(9)
6472	ENDIF
6473	CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr)
6474	IF ( ierr /= 0 ) THEN
6475	WRITE(9,*) 'Error MPI_Info_set4:', ierr
6476	FLUSH(9)
6477	ENDIF
6478
6479	CALL MPI_Win_allocate(INT(STORAGE_SIZE(1_iwp)/8nsurf_type_unz_urbannnynnx, &
6480	kind=MPI_ADDRESS_KIND), STORAGE_SIZE(1_iwp)/8, &
6481	minfo, comm2d, gridsurf_rma_p, win_gridsurf, ierr)
6482	IF ( ierr /= 0 ) THEN
6483	WRITE(9,*) 'Error MPI_Win_allocate1:', ierr, &
6484	INT(STORAGE_SIZE(1_iwp)/8nsurf_type_unz_urbannnynnx,kind=MPI_ADDRESS_KIND), &
6485	STORAGE_SIZE(1_iwp)/8, win_gridsurf
6486	FLUSH(9)
6487	ENDIF
6488
6489	CALL MPI_Info_free(minfo, ierr)
6490	IF ( ierr /= 0 ) THEN
6491	WRITE(9,*) 'Error MPI_Info_free1:', ierr
6492	FLUSH(9)
6493	ENDIF
6494
6495	!
6496	!-- On Intel compilers, calling c_f_pointer to transform a C pointer
6497	!-- directly to a multi-dimensional Fotran pointer leads to strange
6498	!-- errors on dimension boundaries. However, transforming to a 1D
6499	!-- pointer and then redirecting a multidimensional pointer to it works
6500	!-- fine.
6501	CALL c_f_pointer(gridsurf_rma_p, gridsurf_rma, (/ nsurf_type_unz_urbannny*nnx /))
6502	gridsurf(0:nsurf_type_u-1, nz_urban_b:nz_urban_t, nys:nyn, nxl:nxr) => &
6503	gridsurf_rma(1:nsurf_type_unz_urbannny*nnx)
6504	#else
6505	ALLOCATE(gridsurf(0:nsurf_type_u-1,nz_urban_b:nz_urban_t,nys:nyn,nxl:nxr) )
6506	#endif
6507	gridsurf(:,:,:,:) = -999
6508	ENDIF
6509
6510	!-- add horizontal surface elements (land and urban surfaces)
6511	!-- TODO: add urban overhanging surfaces (idown_u)
6512	DO i = nxl, nxr
6513	DO j = nys, nyn
6514	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
6515	k = surf_usm_h%k(m)
6516	isurf = isurf + 1
6517	surfl(:,isurf) = (/iup_u,k,j,i,m/)
6518	IF ( rad_angular_discretization ) THEN
6519	gridsurf(iup_u,k,j,i) = isurf
6520	ENDIF
6521	ENDDO
6522
6523	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
6524	k = surf_lsm_h%k(m)
6525	isurf = isurf + 1
6526	surfl(:,isurf) = (/iup_l,k,j,i,m/)
6527	IF ( rad_angular_discretization ) THEN
6528	gridsurf(iup_u,k,j,i) = isurf
6529	ENDIF
6530	ENDDO
6531
6532	ENDDO
6533	ENDDO
6534
6535	!-- add vertical surface elements (land and urban surfaces)
6536	!-- TODO: remove the hard coding of l = 0 to l = idirection
6537	DO i = nxl, nxr
6538	DO j = nys, nyn
6539	l = 0
6540	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6541	k = surf_usm_v(l)%k(m)
6542	isurf = isurf + 1
6543	surfl(:,isurf) = (/inorth_u,k,j,i,m/)
6544	IF ( rad_angular_discretization ) THEN
6545	gridsurf(inorth_u,k,j,i) = isurf
6546	ENDIF
6547	ENDDO
6548	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6549	k = surf_lsm_v(l)%k(m)
6550	isurf = isurf + 1
6551	surfl(:,isurf) = (/inorth_l,k,j,i,m/)
6552	IF ( rad_angular_discretization ) THEN
6553	gridsurf(inorth_u,k,j,i) = isurf
6554	ENDIF
6555	ENDDO
6556
6557	l = 1
6558	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6559	k = surf_usm_v(l)%k(m)
6560	isurf = isurf + 1
6561	surfl(:,isurf) = (/isouth_u,k,j,i,m/)
6562	IF ( rad_angular_discretization ) THEN
6563	gridsurf(isouth_u,k,j,i) = isurf
6564	ENDIF
6565	ENDDO
6566	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6567	k = surf_lsm_v(l)%k(m)
6568	isurf = isurf + 1
6569	surfl(:,isurf) = (/isouth_l,k,j,i,m/)
6570	IF ( rad_angular_discretization ) THEN
6571	gridsurf(isouth_u,k,j,i) = isurf
6572	ENDIF
6573	ENDDO
6574
6575	l = 2
6576	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6577	k = surf_usm_v(l)%k(m)
6578	isurf = isurf + 1
6579	surfl(:,isurf) = (/ieast_u,k,j,i,m/)
6580	IF ( rad_angular_discretization ) THEN
6581	gridsurf(ieast_u,k,j,i) = isurf
6582	ENDIF
6583	ENDDO
6584	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6585	k = surf_lsm_v(l)%k(m)
6586	isurf = isurf + 1
6587	surfl(:,isurf) = (/ieast_l,k,j,i,m/)
6588	IF ( rad_angular_discretization ) THEN
6589	gridsurf(ieast_u,k,j,i) = isurf
6590	ENDIF
6591	ENDDO
6592
6593	l = 3
6594	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6595	k = surf_usm_v(l)%k(m)
6596	isurf = isurf + 1
6597	surfl(:,isurf) = (/iwest_u,k,j,i,m/)
6598	IF ( rad_angular_discretization ) THEN
6599	gridsurf(iwest_u,k,j,i) = isurf
6600	ENDIF
6601	ENDDO
6602	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6603	k = surf_lsm_v(l)%k(m)
6604	isurf = isurf + 1
6605	surfl(:,isurf) = (/iwest_l,k,j,i,m/)
6606	IF ( rad_angular_discretization ) THEN
6607	gridsurf(iwest_u,k,j,i) = isurf
6608	ENDIF
6609	ENDDO
6610	ENDDO
6611	ENDDO
6612	!
6613	!-- Add local MRT boxes for specified number of levels
6614	nmrtbl = 0
6615	IF ( mrt_nlevels > 0 ) THEN
6616	DO i = nxl, nxr
6617	DO j = nys, nyn
6618	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
6619	!
6620	!-- Skip roof if requested
6621	IF ( mrt_skip_roof .AND. surf_usm_h%isroof_surf(m) ) CYCLE
6622	!
6623	!-- Cycle over specified no of levels
6624	nmrtbl = nmrtbl + mrt_nlevels
6625	ENDDO
6626	!
6627	!-- Dtto for LSM
6628	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
6629	nmrtbl = nmrtbl + mrt_nlevels
6630	ENDDO
6631	ENDDO
6632	ENDDO
6633
6634	ALLOCATE( mrtbl(iz:ix,nmrtbl), mrtsky(nmrtbl), mrtskyt(nmrtbl), &
6635	mrtinsw(nmrtbl), mrtinlw(nmrtbl), mrt(nmrtbl) )
6636
6637	imrt = 0
6638	DO i = nxl, nxr
6639	DO j = nys, nyn
6640	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
6641	!
6642	!-- Skip roof if requested
6643	IF ( mrt_skip_roof .AND. surf_usm_h%isroof_surf(m) ) CYCLE
6644	!
6645	!-- Cycle over specified no of levels
6646	l = surf_usm_h%k(m)
6647	DO k = l, l + mrt_nlevels - 1
6648	imrt = imrt + 1
6649	mrtbl(:,imrt) = (/k,j,i/)
6650	ENDDO
6651	ENDDO
6652	!
6653	!-- Dtto for LSM
6654	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
6655	l = surf_lsm_h%k(m)
6656	DO k = l, l + mrt_nlevels - 1
6657	imrt = imrt + 1
6658	mrtbl(:,imrt) = (/k,j,i/)
6659	ENDDO
6660	ENDDO
6661	ENDDO
6662	ENDDO
6663	ENDIF
6664
6665	!
6666	!-- broadband albedo of the land, roof and wall surface
6667	!-- for domain border and sky set artifically to 1.0
6668	!-- what allows us to calculate heat flux leaving over
6669	!-- side and top borders of the domain
6670	ALLOCATE ( albedo_surf(nsurfl) )
6671	albedo_surf = 1.0_wp
6672	!
6673	!-- Also allocate further array for emissivity with identical order of
6674	!-- surface elements as radiation arrays.
6675	ALLOCATE ( emiss_surf(nsurfl) )
6676
6677
6678	!
6679	!-- global array surf of indices of surfaces and displacement index array surfstart
6680	ALLOCATE(nsurfs(0:numprocs-1))
6681
6682	#if defined( __parallel )
6683	CALL MPI_Allgather(nsurfl,1,MPI_INTEGER,nsurfs,1,MPI_INTEGER,comm2d,ierr)
6684	IF ( ierr /= 0 ) THEN
6685	WRITE(9,*) 'Error MPI_AllGather1:', ierr, nsurfl, nsurfs
6686	FLUSH(9)
6687	ENDIF
6688
6689	#else
6690	nsurfs(0) = nsurfl
6691	#endif
6692	ALLOCATE(surfstart(0:numprocs))
6693	k = 0
6694	DO i=0,numprocs-1
6695	surfstart(i) = k
6696	k = k+nsurfs(i)
6697	ENDDO
6698	surfstart(numprocs) = k
6699	nsurf = k
6700	!
6701	!-- We allocate the array as linear and then use a two-dimensional pointer
6702	!-- into it, because some MPI implementations crash with 2D-allocated arrays.
6703	ALLOCATE(surf_linear(nidx_surf*nsurf))
6704	surf(1:nidx_surf,1:nsurf) => surf_linear(1:nidx_surf*nsurf)
6705
6706	#if defined( __parallel )
6707	CALL MPI_AllGatherv(surfl_linear, nsurfl*nidx_surf, MPI_INTEGER, &
6708	surf_linear, nsurfs*nidx_surf, &
6709	surfstart(0:numprocs-1)*nidx_surf, MPI_INTEGER, &
6710	comm2d, ierr)
6711	IF ( ierr /= 0 ) THEN
6712	WRITE(9,*) 'Error MPI_AllGatherv4:', ierr, SIZE(surfl_linear), &
6713	nsurflnidx_surf, SIZE(surf_linear), nsurfsnidx_surf, &
6714	surfstart(0:numprocs-1)*nidx_surf
6715	FLUSH(9)
6716	ENDIF
6717	#else
6718	surf = surfl
6719	#endif
6720
6721	!--
6722	!-- allocation of the arrays for direct and diffusion radiation
6723	IF ( debug_output ) CALL debug_message( 'allocation of radiation arrays', 'info' )
6724	!-- rad_sw_in, rad_lw_in are computed in radiation model,
6725	!-- splitting of direct and diffusion part is done
6726	!-- in calc_diffusion_radiation for now
6727
6728	ALLOCATE( rad_sw_in_dir(nysg:nyng,nxlg:nxrg) )
6729	ALLOCATE( rad_sw_in_diff(nysg:nyng,nxlg:nxrg) )
6730	ALLOCATE( rad_lw_in_diff(nysg:nyng,nxlg:nxrg) )
6731	rad_sw_in_dir = 0.0_wp
6732	rad_sw_in_diff = 0.0_wp
6733	rad_lw_in_diff = 0.0_wp
6734
6735	!-- allocate radiation arrays
6736	ALLOCATE( surfins(nsurfl) )
6737	ALLOCATE( surfinl(nsurfl) )
6738	ALLOCATE( surfinsw(nsurfl) )
6739	ALLOCATE( surfinlw(nsurfl) )
6740	ALLOCATE( surfinswdir(nsurfl) )
6741	ALLOCATE( surfinswdif(nsurfl) )
6742	ALLOCATE( surfinlwdif(nsurfl) )
6743	ALLOCATE( surfoutsl(nsurfl) )
6744	ALLOCATE( surfoutll(nsurfl) )
6745	ALLOCATE( surfoutsw(nsurfl) )
6746	ALLOCATE( surfoutlw(nsurfl) )
6747	ALLOCATE( surfouts(nsurf) )
6748	ALLOCATE( surfoutl(nsurf) )
6749	ALLOCATE( surfinlg(nsurf) )
6750	ALLOCATE( skyvf(nsurfl) )
6751	ALLOCATE( skyvft(nsurfl) )
6752	ALLOCATE( surfemitlwl(nsurfl) )
6753
6754	!
6755	!-- In case of average_radiation, aggregated surface albedo and emissivity,
6756	!-- also set initial value for t_rad_urb.
6757	!-- For now set an arbitrary initial value.
6758	IF ( average_radiation ) THEN
6759	albedo_urb = 0.1_wp
6760	emissivity_urb = 0.9_wp
6761	t_rad_urb = pt_surface
6762	ENDIF
6763
6764	END SUBROUTINE radiation_interaction_init
6765
6766	!------------------------------------------------------------------------------!
6767	! Description:
6768	! ------------
6769	!> Calculates shape view factors (SVF), plant sink canopy factors (PCSF),
6770	!> sky-view factors, discretized path for direct solar radiation, MRT factors
6771	!> and other preprocessed data needed for radiation_interaction.
6772	!------------------------------------------------------------------------------!
6773	SUBROUTINE radiation_calc_svf
6774
6775	IMPLICIT NONE
6776
6777	INTEGER(iwp) :: i, j, k, d, ip, jp
6778	INTEGER(iwp) :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrt, imrtf, ipcgb
6779	INTEGER(iwp) :: sd, td
6780	INTEGER(iwp) :: iaz, izn !< azimuth, zenith counters
6781	INTEGER(iwp) :: naz, nzn !< azimuth, zenith num of steps
6782	REAL(wp) :: az0, zn0 !< starting azimuth/zenith
6783	REAL(wp) :: azs, zns !< azimuth/zenith cycle step
6784	REAL(wp) :: az1, az2 !< relative azimuth of section borders
6785	REAL(wp) :: azmid !< ray (center) azimuth
6786	REAL(wp) :: yxlen !< \|yxdir\|
6787	REAL(wp), DIMENSION(2) :: yxdir !< y,x unit vector of ray direction (in grid units)
6788	REAL(wp), DIMENSION(:), ALLOCATABLE :: zdirs !< directions in z (tangent of elevation)
6789	REAL(wp), DIMENSION(:), ALLOCATABLE :: zcent !< zenith angle centers
6790	REAL(wp), DIMENSION(:), ALLOCATABLE :: zbdry !< zenith angle boundaries
6791	REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac !< view factor fractions for individual rays
6792	REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac0 !< dtto (original values)
6793	REAL(wp), DIMENSION(:), ALLOCATABLE :: ztransp !< array of transparency in z steps
6794	INTEGER(iwp) :: lowest_free_ray !< index into zdirs
6795	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: itarget !< face indices of detected obstacles
6796	INTEGER(iwp) :: itarg0, itarg1
6797
6798	INTEGER(iwp) :: udim
6799	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: nzterrl_l
6800	INTEGER(iwp), DIMENSION(:,:), POINTER :: nzterrl
6801	REAL(wp), DIMENSION(:), ALLOCATABLE,TARGET:: csflt_l, pcsflt_l
6802	REAL(wp), DIMENSION(:,:), POINTER :: csflt, pcsflt
6803	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: kcsflt_l,kpcsflt_l
6804	INTEGER(iwp), DIMENSION(:,:), POINTER :: kcsflt,kpcsflt
6805	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: icsflt,dcsflt,ipcsflt,dpcsflt
6806	REAL(wp), DIMENSION(3) :: uv
6807	LOGICAL :: visible
6808	REAL(wp), DIMENSION(3) :: sa, ta !< real coordinates z,y,x of source and target
6809	REAL(wp) :: difvf !< differential view factor
6810	REAL(wp) :: transparency, rirrf, sqdist, svfsum
6811	INTEGER(iwp) :: isurflt, isurfs, isurflt_prev
6812	INTEGER(idp) :: ray_skip_maxdist, ray_skip_minval !< skipped raytracing counts
6813	INTEGER(iwp) :: max_track_len !< maximum 2d track length
6814	INTEGER(iwp) :: minfo
6815	REAL(wp), DIMENSION(:), POINTER, SAVE :: lad_s_rma !< fortran 1D pointer
6816	TYPE(c_ptr) :: lad_s_rma_p !< allocated c pointer
6817	#if defined( __parallel )
6818	INTEGER(kind=MPI_ADDRESS_KIND) :: size_lad_rma
6819	#endif
6820	!
6821	INTEGER(iwp), DIMENSION(0:svfnorm_report_num) :: svfnorm_counts
6822
6823
6824	!-- calculation of the SVF
6825	CALL location_message( 'calculating view factors for radiation interaction', 'start' )
6826
6827	!-- initialize variables and temporary arrays for calculation of svf and csf
6828	nsvfl = 0
6829	ncsfl = 0
6830	nsvfla = gasize
6831	msvf = 1
6832	ALLOCATE( asvf1(nsvfla) )
6833	asvf => asvf1
6834	IF ( plant_canopy ) THEN
6835	ncsfla = gasize
6836	mcsf = 1
6837	ALLOCATE( acsf1(ncsfla) )
6838	acsf => acsf1
6839	ENDIF
6840	nmrtf = 0
6841	IF ( mrt_nlevels > 0 ) THEN
6842	nmrtfa = gasize
6843	mmrtf = 1
6844	ALLOCATE ( amrtf1(nmrtfa) )
6845	amrtf => amrtf1
6846	ENDIF
6847	ray_skip_maxdist = 0
6848	ray_skip_minval = 0
6849
6850	!-- initialize temporary terrain and plant canopy height arrays (global 2D array!)
6851	ALLOCATE( nzterr(0:(nx+1)*(ny+1)-1) )
6852	#if defined( __parallel )
6853	!ALLOCATE( nzterrl(nys:nyn,nxl:nxr) )
6854	ALLOCATE( nzterrl_l((nyn-nys+1)*(nxr-nxl+1)) )
6855	nzterrl(nys:nyn,nxl:nxr) => nzterrl_l(1:(nyn-nys+1)*(nxr-nxl+1))
6856	nzterrl = topo_top_ind(nys:nyn,nxl:nxr,0)
6857	CALL MPI_AllGather( nzterrl_l, nnx*nny, MPI_INTEGER, &
6858	nzterr, nnx*nny, MPI_INTEGER, comm2d, ierr )
6859	IF ( ierr /= 0 ) THEN
6860	WRITE(9,) 'Error MPI_AllGather1:', ierr, SIZE(nzterrl_l), nnxnny, &
6861	SIZE(nzterr), nnx*nny
6862	FLUSH(9)
6863	ENDIF
6864	DEALLOCATE(nzterrl_l)
6865	#else
6866	nzterr = RESHAPE( topo_top_ind(nys:nyn,nxl:nxr,0), (/(nx+1)*(ny+1)/) )
6867	#endif
6868	IF ( plant_canopy ) THEN
6869	ALLOCATE( plantt(0:(nx+1)*(ny+1)-1) )
6870	maxboxesg = nx + ny + nz_plant + 1
6871	max_track_len = nx + ny + 1
6872	!-- temporary arrays storing values for csf calculation during raytracing
6873	ALLOCATE( boxes(3, maxboxesg) )
6874	ALLOCATE( crlens(maxboxesg) )
6875
6876	#if defined( __parallel )
6877	CALL MPI_AllGather( pct, nnx*nny, MPI_INTEGER, &
6878	plantt, nnx*nny, MPI_INTEGER, comm2d, ierr )
6879	IF ( ierr /= 0 ) THEN
6880	WRITE(9,) 'Error MPI_AllGather2:', ierr, SIZE(pct), nnxnny, &
6881	SIZE(plantt), nnx*nny
6882	FLUSH(9)
6883	ENDIF
6884
6885	!-- temporary arrays storing values for csf calculation during raytracing
6886	ALLOCATE( lad_ip(maxboxesg) )
6887	ALLOCATE( lad_disp(maxboxesg) )
6888
6889	IF ( raytrace_mpi_rma ) THEN
6890	ALLOCATE( lad_s_ray(maxboxesg) )
6891
6892	! set conditions for RMA communication
6893	CALL MPI_Info_create(minfo, ierr)
6894	IF ( ierr /= 0 ) THEN
6895	WRITE(9,*) 'Error MPI_Info_create2:', ierr
6896	FLUSH(9)
6897	ENDIF
6898	CALL MPI_Info_set(minfo, 'accumulate_ordering', 'none', ierr)
6899	IF ( ierr /= 0 ) THEN
6900	WRITE(9,*) 'Error MPI_Info_set5:', ierr
6901	FLUSH(9)
6902	ENDIF
6903	CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr)
6904	IF ( ierr /= 0 ) THEN
6905	WRITE(9,*) 'Error MPI_Info_set6:', ierr
6906	FLUSH(9)
6907	ENDIF
6908	CALL MPI_Info_set(minfo, 'same_size', 'true', ierr)
6909	IF ( ierr /= 0 ) THEN
6910	WRITE(9,*) 'Error MPI_Info_set7:', ierr
6911	FLUSH(9)
6912	ENDIF
6913	CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr)
6914	IF ( ierr /= 0 ) THEN
6915	WRITE(9,*) 'Error MPI_Info_set8:', ierr
6916	FLUSH(9)
6917	ENDIF
6918
6919	!-- Allocate and initialize the MPI RMA window
6920	!-- must be in accordance with allocation of lad_s in plant_canopy_model
6921	!-- optimization of memory should be done
6922	!-- Argument X of function STORAGE_SIZE(X) needs arbitrary REAL(wp) value, set to 1.0_wp for now
6923	size_lad_rma = STORAGE_SIZE(1.0_wp)/8nnxnny*nz_plant
6924	CALL MPI_Win_allocate(size_lad_rma, STORAGE_SIZE(1.0_wp)/8, minfo, comm2d, &
6925	lad_s_rma_p, win_lad, ierr)
6926	IF ( ierr /= 0 ) THEN
6927	WRITE(9,*) 'Error MPI_Win_allocate2:', ierr, size_lad_rma, &
6928	STORAGE_SIZE(1.0_wp)/8, win_lad
6929	FLUSH(9)
6930	ENDIF
6931	CALL c_f_pointer(lad_s_rma_p, lad_s_rma, (/ nz_plantnnynnx /))
6932	sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr) => lad_s_rma(1:nz_plantnnynnx)
6933	ELSE
6934	ALLOCATE(sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr))
6935	ENDIF
6936	#else
6937	plantt = RESHAPE( pct(nys:nyn,nxl:nxr), (/(nx+1)*(ny+1)/) )
6938	ALLOCATE(sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr))
6939	#endif
6940	plantt_max = MAXVAL(plantt)
6941	ALLOCATE( rt2_track(2, max_track_len), rt2_track_lad(nz_urban_b:plantt_max, max_track_len), &
6942	rt2_track_dist(0:max_track_len), rt2_dist(plantt_max-nz_urban_b+2) )
6943
6944	sub_lad(:,:,:) = 0._wp
6945	DO i = nxl, nxr
6946	DO j = nys, nyn
6947	k = topo_top_ind(j,i,0)
6948
6949	sub_lad(k:nz_plant_t, j, i) = lad_s(0:nz_plant_t-k, j, i)
6950	ENDDO
6951	ENDDO
6952
6953	#if defined( __parallel )
6954	IF ( raytrace_mpi_rma ) THEN
6955	CALL MPI_Info_free(minfo, ierr)
6956	IF ( ierr /= 0 ) THEN
6957	WRITE(9,*) 'Error MPI_Info_free2:', ierr
6958	FLUSH(9)
6959	ENDIF
6960	CALL MPI_Win_lock_all(0, win_lad, ierr)
6961	IF ( ierr /= 0 ) THEN
6962	WRITE(9,*) 'Error MPI_Win_lock_all1:', ierr, win_lad
6963	FLUSH(9)
6964	ENDIF
6965
6966	ELSE
6967	ALLOCATE( sub_lad_g(0:(nx+1)(ny+1)nz_plant-1) )
6968	CALL MPI_AllGather( sub_lad, nnxnnynz_plant, MPI_REAL, &
6969	sub_lad_g, nnxnnynz_plant, MPI_REAL, comm2d, ierr )
6970	IF ( ierr /= 0 ) THEN
6971	WRITE(9,*) 'Error MPI_AllGather3:', ierr, SIZE(sub_lad), &
6972	nnxnnynz_plant, SIZE(sub_lad_g), nnxnnynz_plant
6973	FLUSH(9)
6974	ENDIF
6975	ENDIF
6976	#endif
6977	ENDIF
6978
6979	!-- prepare the MPI_Win for collecting the surface indices
6980	!-- from the reverse index arrays gridsurf from processors of target surfaces
6981	#if defined( __parallel )
6982	IF ( rad_angular_discretization ) THEN
6983	!
6984	!-- raytrace_mpi_rma is asserted
6985	CALL MPI_Win_lock_all(0, win_gridsurf, ierr)
6986	IF ( ierr /= 0 ) THEN
6987	WRITE(9,*) 'Error MPI_Win_lock_all2:', ierr, win_gridsurf
6988	FLUSH(9)
6989	ENDIF
6990	ENDIF
6991	#endif
6992
6993
6994	!--Directions opposite to face normals are not even calculated,
6995	!--they must be preset to 0
6996	!--
6997	dsitrans(:,:) = 0._wp
6998
6999	DO isurflt = 1, nsurfl
7000	!-- determine face centers
7001	td = surfl(id, isurflt)
7002	ta = (/ REAL(surfl(iz, isurflt), wp) - 0.5_wp * kdir(td), &
7003	REAL(surfl(iy, isurflt), wp) - 0.5_wp * jdir(td), &
7004	REAL(surfl(ix, isurflt), wp) - 0.5_wp * idir(td) /)
7005
7006	!--Calculate sky view factor and raytrace DSI paths
7007	skyvf(isurflt) = 0._wp
7008	skyvft(isurflt) = 0._wp
7009
7010	!--Select a proper half-sphere for 2D raytracing
7011	SELECT CASE ( td )
7012	CASE ( iup_u, iup_l )
7013	az0 = 0._wp
7014	naz = raytrace_discrete_azims
7015	azs = 2._wp * pi / REAL(naz, wp)
7016	zn0 = 0._wp
7017	nzn = raytrace_discrete_elevs / 2
7018	zns = pi / 2._wp / REAL(nzn, wp)
7019	CASE ( isouth_u, isouth_l )
7020	az0 = pi / 2._wp
7021	naz = raytrace_discrete_azims / 2
7022	azs = pi / REAL(naz, wp)
7023	zn0 = 0._wp
7024	nzn = raytrace_discrete_elevs
7025	zns = pi / REAL(nzn, wp)
7026	CASE ( inorth_u, inorth_l )
7027	az0 = - pi / 2._wp
7028	naz = raytrace_discrete_azims / 2
7029	azs = pi / REAL(naz, wp)
7030	zn0 = 0._wp
7031	nzn = raytrace_discrete_elevs
7032	zns = pi / REAL(nzn, wp)
7033	CASE ( iwest_u, iwest_l )
7034	az0 = pi
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 ( ieast_u, ieast_l )
7041	az0 = 0._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 DEFAULT
7048	WRITE(message_string, *) 'ERROR: the surface type ', td, &
7049	' is not supported for calculating',&
7050	' SVF'
7051	CALL message( 'radiation_calc_svf', 'PA0488', 1, 2, 0, 6, 0 )
7052	END SELECT
7053
7054	ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), &
7055	ztransp(1:nznnaz), itarget(1:nznnaz) ) !FIXME allocate itarget only
7056	!in case of rad_angular_discretization
7057
7058	itarg0 = 1
7059	itarg1 = nzn
7060	zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7061	zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/)
7062	IF ( td == iup_u .OR. td == iup_l ) THEN
7063	vffrac(1:nzn) = (COS(2 * zbdry(0:nzn-1)) - COS(2 * zbdry(1:nzn))) / 2._wp / REAL(naz, wp)
7064	!
7065	!-- For horizontal target, vf fractions are constant per azimuth
7066	DO iaz = 1, naz-1
7067	vffrac(iaznzn+1:(iaz+1)nzn) = vffrac(1:nzn)
7068	ENDDO
7069	!-- sum of whole vffrac equals 1, verified
7070	ENDIF
7071	!
7072	!-- Calculate sky-view factor and direct solar visibility using 2D raytracing
7073	DO iaz = 1, naz
7074	azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7075	IF ( td /= iup_u .AND. td /= iup_l ) THEN
7076	az2 = REAL(iaz, wp) * azs - pi/2._wp
7077	az1 = az2 - azs
7078	!TODO precalculate after 1st line
7079	vffrac(itarg0:itarg1) = (SIN(az2) - SIN(az1)) &
7080	* (zbdry(1:nzn) - zbdry(0:nzn-1) &
7081	+ SIN(zbdry(0:nzn-1))*COS(zbdry(0:nzn-1)) &
7082	- SIN(zbdry(1:nzn))*COS(zbdry(1:nzn))) &
7083	/ (2._wp * pi)
7084	!-- sum of whole vffrac equals 1, verified
7085	ENDIF
7086	yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7087	yxlen = SQRT(SUM(yxdir(:)**2))
7088	zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7089	yxdir(:) = yxdir(:) / yxlen
7090
7091	CALL raytrace_2d(ta, yxdir, nzn, zdirs, &
7092	surfstart(myid) + isurflt, facearea(td), &
7093	vffrac(itarg0:itarg1), .TRUE., .TRUE., &
7094	.FALSE., lowest_free_ray, &
7095	ztransp(itarg0:itarg1), &
7096	itarget(itarg0:itarg1))
7097
7098	skyvf(isurflt) = skyvf(isurflt) + &
7099	SUM(vffrac(itarg0:itarg0+lowest_free_ray-1))
7100	skyvft(isurflt) = skyvft(isurflt) + &
7101	SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) &
7102	* vffrac(itarg0:itarg0+lowest_free_ray-1))
7103
7104	!-- Save direct solar transparency
7105	j = MODULO(NINT(azmid/ &
7106	(2._wppi)raytrace_discrete_azims-.5_wp, iwp), &
7107	raytrace_discrete_azims)
7108
7109	DO k = 1, raytrace_discrete_elevs/2
7110	i = dsidir_rev(k-1, j)
7111	IF ( i /= -1 .AND. k <= lowest_free_ray ) &
7112	dsitrans(isurflt, i) = ztransp(itarg0+k-1)
7113	ENDDO
7114
7115	!
7116	!-- Advance itarget indices
7117	itarg0 = itarg1 + 1
7118	itarg1 = itarg1 + nzn
7119	ENDDO
7120
7121	IF ( rad_angular_discretization ) THEN
7122	!-- sort itarget by face id
7123	CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz)
7124	!
7125	!-- For aggregation, we need fractions multiplied by transmissivities
7126	ztransp(:) = vffrac(:) * ztransp(:)
7127	!
7128	!-- find the first valid position
7129	itarg0 = 1
7130	DO WHILE ( itarg0 <= nzn*naz )
7131	IF ( itarget(itarg0) /= -1 ) EXIT
7132	itarg0 = itarg0 + 1
7133	ENDDO
7134
7135	DO i = itarg0, nzn*naz
7136	!
7137	!-- For duplicate values, only sum up vf fraction value
7138	IF ( i < nzn*naz ) THEN
7139	IF ( itarget(i+1) == itarget(i) ) THEN
7140	vffrac(i+1) = vffrac(i+1) + vffrac(i)
7141	ztransp(i+1) = ztransp(i+1) + ztransp(i)
7142	CYCLE
7143	ENDIF
7144	ENDIF
7145	!
7146	!-- write to the svf array
7147	nsvfl = nsvfl + 1
7148	!-- check dimmension of asvf array and enlarge it if needed
7149	IF ( nsvfla < nsvfl ) THEN
7150	k = CEILING(REAL(nsvfla, kind=wp) * grow_factor)
7151	IF ( msvf == 0 ) THEN
7152	msvf = 1
7153	ALLOCATE( asvf1(k) )
7154	asvf => asvf1
7155	asvf1(1:nsvfla) = asvf2
7156	DEALLOCATE( asvf2 )
7157	ELSE
7158	msvf = 0
7159	ALLOCATE( asvf2(k) )
7160	asvf => asvf2
7161	asvf2(1:nsvfla) = asvf1
7162	DEALLOCATE( asvf1 )
7163	ENDIF
7164
7165	IF ( debug_output ) THEN
7166	WRITE( debug_string, '(A,3I12)' ) 'Grow asvf:', nsvfl, nsvfla, k
7167	CALL debug_message( debug_string, 'info' )
7168	ENDIF
7169
7170	nsvfla = k
7171	ENDIF
7172	!-- write svf values into the array
7173	asvf(nsvfl)%isurflt = isurflt
7174	asvf(nsvfl)%isurfs = itarget(i)
7175	asvf(nsvfl)%rsvf = vffrac(i)
7176	asvf(nsvfl)%rtransp = ztransp(i) / vffrac(i)
7177	END DO
7178
7179	ENDIF ! rad_angular_discretization
7180
7181	DEALLOCATE ( zdirs, zcent, zbdry, vffrac, ztransp, itarget ) !FIXME itarget shall be allocated only
7182	!in case of rad_angular_discretization
7183	!
7184	!-- Following calculations only required for surface_reflections
7185	IF ( surface_reflections .AND. .NOT. rad_angular_discretization ) THEN
7186
7187	DO isurfs = 1, nsurf
7188	IF ( .NOT. surface_facing(surfl(ix, isurflt), surfl(iy, isurflt), &
7189	surfl(iz, isurflt), surfl(id, isurflt), &
7190	surf(ix, isurfs), surf(iy, isurfs), &
7191	surf(iz, isurfs), surf(id, isurfs)) ) THEN
7192	CYCLE
7193	ENDIF
7194
7195	sd = surf(id, isurfs)
7196	sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd), &
7197	REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd), &
7198	REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd) /)
7199
7200	!-- unit vector source -> target
7201	uv = (/ (ta(1)-sa(1))dz(1), (ta(2)-sa(2))dy, (ta(3)-sa(3))*dx /)
7202	sqdist = SUM(uv(:)**2)
7203	uv = uv / SQRT(sqdist)
7204
7205	!-- reject raytracing above max distance
7206	IF ( SQRT(sqdist) > max_raytracing_dist ) THEN
7207	ray_skip_maxdist = ray_skip_maxdist + 1
7208	CYCLE
7209	ENDIF
7210
7211	difvf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) & ! cosine of source normal and direction
7212	* dot_product((/ kdir(td), jdir(td), idir(td) /), -uv) & ! cosine of target normal and reverse direction
7213	/ (pi * sqdist) ! square of distance between centers
7214	!
7215	!-- irradiance factor (our unshaded shape view factor) = view factor per differential target area * source area
7216	rirrf = difvf * facearea(sd)
7217
7218	!-- reject raytracing for potentially too small view factor values
7219	IF ( rirrf < min_irrf_value ) THEN
7220	ray_skip_minval = ray_skip_minval + 1
7221	CYCLE
7222	ENDIF
7223
7224	!-- raytrace + process plant canopy sinks within
7225	CALL raytrace(sa, ta, isurfs, difvf, facearea(td), .TRUE., &
7226	visible, transparency)
7227
7228	IF ( .NOT. visible ) CYCLE
7229	! rsvf = rirrf * transparency
7230
7231	!-- write to the svf array
7232	nsvfl = nsvfl + 1
7233	!-- check dimmension of asvf array and enlarge it if needed
7234	IF ( nsvfla < nsvfl ) THEN
7235	k = CEILING(REAL(nsvfla, kind=wp) * grow_factor)
7236	IF ( msvf == 0 ) THEN
7237	msvf = 1
7238	ALLOCATE( asvf1(k) )
7239	asvf => asvf1
7240	asvf1(1:nsvfla) = asvf2
7241	DEALLOCATE( asvf2 )
7242	ELSE
7243	msvf = 0
7244	ALLOCATE( asvf2(k) )
7245	asvf => asvf2
7246	asvf2(1:nsvfla) = asvf1
7247	DEALLOCATE( asvf1 )
7248	ENDIF
7249
7250	IF ( debug_output ) THEN
7251	WRITE( debug_string, '(A,3I12)' ) 'Grow asvf:', nsvfl, nsvfla, k
7252	CALL debug_message( debug_string, 'info' )
7253	ENDIF
7254
7255	nsvfla = k
7256	ENDIF
7257	!-- write svf values into the array
7258	asvf(nsvfl)%isurflt = isurflt
7259	asvf(nsvfl)%isurfs = isurfs
7260	asvf(nsvfl)%rsvf = rirrf !we postopne multiplication by transparency
7261	asvf(nsvfl)%rtransp = transparency !a.k.a. Direct Irradiance Factor
7262	ENDDO
7263	ENDIF
7264	ENDDO
7265
7266	!--
7267	!-- Raytrace to canopy boxes to fill dsitransc TODO optimize
7268	dsitransc(:,:) = 0._wp
7269	az0 = 0._wp
7270	naz = raytrace_discrete_azims
7271	azs = 2._wp * pi / REAL(naz, wp)
7272	zn0 = 0._wp
7273	nzn = raytrace_discrete_elevs / 2
7274	zns = pi / 2._wp / REAL(nzn, wp)
7275	ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), vffrac(1:nzn), ztransp(1:nzn), &
7276	itarget(1:nzn) )
7277	zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7278	vffrac(:) = 0._wp
7279
7280	DO ipcgb = 1, npcbl
7281	ta = (/ REAL(pcbl(iz, ipcgb), wp), &
7282	REAL(pcbl(iy, ipcgb), wp), &
7283	REAL(pcbl(ix, ipcgb), wp) /)
7284	!-- Calculate direct solar visibility using 2D raytracing
7285	DO iaz = 1, naz
7286	azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7287	yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7288	yxlen = SQRT(SUM(yxdir(:)**2))
7289	zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7290	yxdir(:) = yxdir(:) / yxlen
7291	CALL raytrace_2d(ta, yxdir, nzn, zdirs, &
7292	-999, -999._wp, vffrac, .FALSE., .FALSE., .TRUE., &
7293	lowest_free_ray, ztransp, itarget)
7294
7295	!-- Save direct solar transparency
7296	j = MODULO(NINT(azmid/ &
7297	(2._wppi)raytrace_discrete_azims-.5_wp, iwp), &
7298	raytrace_discrete_azims)
7299	DO k = 1, raytrace_discrete_elevs/2
7300	i = dsidir_rev(k-1, j)
7301	IF ( i /= -1 .AND. k <= lowest_free_ray ) &
7302	dsitransc(ipcgb, i) = ztransp(k)
7303	ENDDO
7304	ENDDO
7305	ENDDO
7306	DEALLOCATE ( zdirs, zcent, vffrac, ztransp, itarget )
7307	!--
7308	!-- Raytrace to MRT boxes
7309	IF ( nmrtbl > 0 ) THEN
7310	mrtdsit(:,:) = 0._wp
7311	mrtsky(:) = 0._wp
7312	mrtskyt(:) = 0._wp
7313	az0 = 0._wp
7314	naz = raytrace_discrete_azims
7315	azs = 2._wp * pi / REAL(naz, wp)
7316	zn0 = 0._wp
7317	nzn = raytrace_discrete_elevs
7318	zns = pi / REAL(nzn, wp)
7319	ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), vffrac0(1:nzn), &
7320	ztransp(1:nznnaz), itarget(1:nznnaz) ) !FIXME allocate itarget only
7321	!in case of rad_angular_discretization
7322
7323	zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7324	zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/)
7325	vffrac0(:) = (COS(zbdry(0:nzn-1)) - COS(zbdry(1:nzn))) / 2._wp / REAL(naz, wp)
7326	!
7327	!--Modify direction weights to simulate human body (lower weight for top-down)
7328	IF ( mrt_geom_human ) THEN
7329	vffrac0(:) = vffrac0(:) * MAX(0._wp, SIN(zcent(:))0.88_wp + COS(zcent(:))0.12_wp)
7330	vffrac0(:) = vffrac0(:) / (SUM(vffrac0) * REAL(naz, wp))
7331	ENDIF
7332
7333	DO imrt = 1, nmrtbl
7334	ta = (/ REAL(mrtbl(iz, imrt), wp), &
7335	REAL(mrtbl(iy, imrt), wp), &
7336	REAL(mrtbl(ix, imrt), wp) /)
7337	!
7338	!-- vf fractions are constant per azimuth
7339	DO iaz = 0, naz-1
7340	vffrac(iaznzn+1:(iaz+1)nzn) = vffrac0(:)
7341	ENDDO
7342	!-- sum of whole vffrac equals 1, verified
7343	itarg0 = 1
7344	itarg1 = nzn
7345	!
7346	!-- Calculate sky-view factor and direct solar visibility using 2D raytracing
7347	DO iaz = 1, naz
7348	azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7349	yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7350	yxlen = SQRT(SUM(yxdir(:)**2))
7351	zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7352	yxdir(:) = yxdir(:) / yxlen
7353
7354	CALL raytrace_2d(ta, yxdir, nzn, zdirs, &
7355	-999, -999._wp, vffrac(itarg0:itarg1), .TRUE., &
7356	.FALSE., .TRUE., lowest_free_ray, &
7357	ztransp(itarg0:itarg1), &
7358	itarget(itarg0:itarg1))
7359
7360	!-- Sky view factors for MRT
7361	mrtsky(imrt) = mrtsky(imrt) + &
7362	SUM(vffrac(itarg0:itarg0+lowest_free_ray-1))
7363	mrtskyt(imrt) = mrtskyt(imrt) + &
7364	SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) &
7365	* vffrac(itarg0:itarg0+lowest_free_ray-1))
7366	!-- Direct solar transparency for MRT
7367	j = MODULO(NINT(azmid/ &
7368	(2._wppi)raytrace_discrete_azims-.5_wp, iwp), &
7369	raytrace_discrete_azims)
7370	DO k = 1, raytrace_discrete_elevs/2
7371	i = dsidir_rev(k-1, j)
7372	IF ( i /= -1 .AND. k <= lowest_free_ray ) &
7373	mrtdsit(imrt, i) = ztransp(itarg0+k-1)
7374	ENDDO
7375	!
7376	!-- Advance itarget indices
7377	itarg0 = itarg1 + 1
7378	itarg1 = itarg1 + nzn
7379	ENDDO
7380
7381	!-- sort itarget by face id
7382	CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz)
7383	!
7384	!-- find the first valid position
7385	itarg0 = 1
7386	DO WHILE ( itarg0 <= nzn*naz )
7387	IF ( itarget(itarg0) /= -1 ) EXIT
7388	itarg0 = itarg0 + 1
7389	ENDDO
7390
7391	DO i = itarg0, nzn*naz
7392	!
7393	!-- For duplicate values, only sum up vf fraction value
7394	IF ( i < nzn*naz ) THEN
7395	IF ( itarget(i+1) == itarget(i) ) THEN
7396	vffrac(i+1) = vffrac(i+1) + vffrac(i)
7397	CYCLE
7398	ENDIF
7399	ENDIF
7400	!
7401	!-- write to the mrtf array
7402	nmrtf = nmrtf + 1
7403	!-- check dimmension of mrtf array and enlarge it if needed
7404	IF ( nmrtfa < nmrtf ) THEN
7405	k = CEILING(REAL(nmrtfa, kind=wp) * grow_factor)
7406	IF ( mmrtf == 0 ) THEN
7407	mmrtf = 1
7408	ALLOCATE( amrtf1(k) )
7409	amrtf => amrtf1
7410	amrtf1(1:nmrtfa) = amrtf2
7411	DEALLOCATE( amrtf2 )
7412	ELSE
7413	mmrtf = 0
7414	ALLOCATE( amrtf2(k) )
7415	amrtf => amrtf2
7416	amrtf2(1:nmrtfa) = amrtf1
7417	DEALLOCATE( amrtf1 )
7418	ENDIF
7419
7420	IF ( debug_output ) THEN
7421	WRITE( debug_string, '(A,3I12)' ) 'Grow amrtf:', nmrtf, nmrtfa, k
7422	CALL debug_message( debug_string, 'info' )
7423	ENDIF
7424
7425	nmrtfa = k
7426	ENDIF
7427	!-- write mrtf values into the array
7428	amrtf(nmrtf)%isurflt = imrt
7429	amrtf(nmrtf)%isurfs = itarget(i)
7430	amrtf(nmrtf)%rsvf = vffrac(i)
7431	amrtf(nmrtf)%rtransp = ztransp(i)
7432	ENDDO ! itarg
7433
7434	ENDDO ! imrt
7435	DEALLOCATE ( zdirs, zcent, zbdry, vffrac, vffrac0, ztransp, itarget )
7436	!
7437	!-- Move MRT factors to final arrays
7438	ALLOCATE ( mrtf(nmrtf), mrtft(nmrtf), mrtfsurf(2,nmrtf) )
7439	DO imrtf = 1, nmrtf
7440	mrtf(imrtf) = amrtf(imrtf)%rsvf
7441	mrtft(imrtf) = amrtf(imrtf)%rsvf * amrtf(imrtf)%rtransp
7442	mrtfsurf(:,imrtf) = (/amrtf(imrtf)%isurflt, amrtf(imrtf)%isurfs /)
7443	ENDDO
7444	IF ( ALLOCATED(amrtf1) ) DEALLOCATE( amrtf1 )
7445	IF ( ALLOCATED(amrtf2) ) DEALLOCATE( amrtf2 )
7446	ENDIF ! nmrtbl > 0
7447
7448	IF ( rad_angular_discretization ) THEN
7449	#if defined( __parallel )
7450	!-- finalize MPI_RMA communication established to get global index of the surface from grid indices
7451	!-- flush all MPI window pending requests
7452	CALL MPI_Win_flush_all(win_gridsurf, ierr)
7453	IF ( ierr /= 0 ) THEN
7454	WRITE(9,*) 'Error MPI_Win_flush_all1:', ierr, win_gridsurf
7455	FLUSH(9)
7456	ENDIF
7457	!-- unlock MPI window
7458	CALL MPI_Win_unlock_all(win_gridsurf, ierr)
7459	IF ( ierr /= 0 ) THEN
7460	WRITE(9,*) 'Error MPI_Win_unlock_all1:', ierr, win_gridsurf
7461	FLUSH(9)
7462	ENDIF
7463	!-- free MPI window
7464	CALL MPI_Win_free(win_gridsurf, ierr)
7465	IF ( ierr /= 0 ) THEN
7466	WRITE(9,*) 'Error MPI_Win_free1:', ierr, win_gridsurf
7467	FLUSH(9)
7468	ENDIF
7469	#else
7470	DEALLOCATE ( gridsurf )
7471	#endif
7472	ENDIF
7473
7474	IF ( debug_output ) CALL debug_message( 'waiting for completion of SVF and CSF calculation in all processes', 'info' )
7475
7476	!-- deallocate temporary global arrays
7477	DEALLOCATE(nzterr)
7478
7479	IF ( plant_canopy ) THEN
7480	!-- finalize mpi_rma communication and deallocate temporary arrays
7481	#if defined( __parallel )
7482	IF ( raytrace_mpi_rma ) THEN
7483	CALL MPI_Win_flush_all(win_lad, ierr)
7484	IF ( ierr /= 0 ) THEN
7485	WRITE(9,*) 'Error MPI_Win_flush_all2:', ierr, win_lad
7486	FLUSH(9)
7487	ENDIF
7488	!-- unlock MPI window
7489	CALL MPI_Win_unlock_all(win_lad, ierr)
7490	IF ( ierr /= 0 ) THEN
7491	WRITE(9,*) 'Error MPI_Win_unlock_all2:', ierr, win_lad
7492	FLUSH(9)
7493	ENDIF
7494	!-- free MPI window
7495	CALL MPI_Win_free(win_lad, ierr)
7496	IF ( ierr /= 0 ) THEN
7497	WRITE(9,*) 'Error MPI_Win_free2:', ierr, win_lad
7498	FLUSH(9)
7499	ENDIF
7500	!-- deallocate temporary arrays storing values for csf calculation during raytracing
7501	DEALLOCATE( lad_s_ray )
7502	!-- sub_lad is the pointer to lad_s_rma in case of raytrace_mpi_rma
7503	!-- and must not be deallocated here
7504	ELSE
7505	DEALLOCATE(sub_lad)
7506	DEALLOCATE(sub_lad_g)
7507	ENDIF
7508	#else
7509	DEALLOCATE(sub_lad)
7510	#endif
7511	DEALLOCATE( boxes )
7512	DEALLOCATE( crlens )
7513	DEALLOCATE( plantt )
7514	DEALLOCATE( rt2_track, rt2_track_lad, rt2_track_dist, rt2_dist )
7515	ENDIF
7516
7517	IF ( debug_output ) CALL debug_message( 'calculation of the complete SVF array', 'info' )
7518
7519	IF ( rad_angular_discretization ) THEN
7520	IF ( debug_output ) CALL debug_message( 'Load svf from the structure array to plain arrays', 'info' )
7521	ALLOCATE( svf(ndsvf,nsvfl) )
7522	ALLOCATE( svfsurf(idsvf,nsvfl) )
7523
7524	DO isvf = 1, nsvfl
7525	svf(:, isvf) = (/ asvf(isvf)%rsvf, asvf(isvf)%rtransp /)
7526	svfsurf(:, isvf) = (/ asvf(isvf)%isurflt, asvf(isvf)%isurfs /)
7527	ENDDO
7528	ELSE
7529	IF ( debug_output ) CALL debug_message( 'Start SVF sort', 'info' )
7530	!-- sort svf ( a version of quicksort )
7531	CALL quicksort_svf(asvf,1,nsvfl)
7532
7533	!< load svf from the structure array to plain arrays
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	svfnorm_counts(:) = 0._wp
7538	isurflt_prev = -1
7539	ksvf = 1
7540	svfsum = 0._wp
7541	DO isvf = 1, nsvfl
7542	!-- normalize svf per target face
7543	IF ( asvf(ksvf)%isurflt /= isurflt_prev ) THEN
7544	IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN
7545	!< update histogram of logged svf normalization values
7546	i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev)))
7547	svfnorm_counts(i) = svfnorm_counts(i) + 1
7548
7549	svf(1, isvf_surflt:isvf-1) = svf(1, isvf_surflt:isvf-1) / svfsum * (1._wp-skyvf(isurflt_prev))
7550	ENDIF
7551	isurflt_prev = asvf(ksvf)%isurflt
7552	isvf_surflt = isvf
7553	svfsum = asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp
7554	ELSE
7555	svfsum = svfsum + asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp
7556	ENDIF
7557
7558	svf(:, isvf) = (/ asvf(ksvf)%rsvf, asvf(ksvf)%rtransp /)
7559	svfsurf(:, isvf) = (/ asvf(ksvf)%isurflt, asvf(ksvf)%isurfs /)
7560
7561	!-- next element
7562	ksvf = ksvf + 1
7563	ENDDO
7564
7565	IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN
7566	i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev)))
7567	svfnorm_counts(i) = svfnorm_counts(i) + 1
7568
7569	svf(1, isvf_surflt:nsvfl) = svf(1, isvf_surflt:nsvfl) / svfsum * (1._wp-skyvf(isurflt_prev))
7570	ENDIF
7571	WRITE(9, *) 'SVF normalization histogram:', svfnorm_counts, &
7572	'on thresholds:', svfnorm_report_thresh(1:svfnorm_report_num), '(val < thresh <= val)'
7573	!TODO we should be able to deallocate skyvf, from now on we only need skyvft
7574	ENDIF ! rad_angular_discretization
7575
7576	!-- deallocate temporary asvf array
7577	!-- DEALLOCATE(asvf) - ifort has a problem with deallocation of allocatable target
7578	!-- via pointing pointer - we need to test original targets
7579	IF ( ALLOCATED(asvf1) ) THEN
7580	DEALLOCATE(asvf1)
7581	ENDIF
7582	IF ( ALLOCATED(asvf2) ) THEN
7583	DEALLOCATE(asvf2)
7584	ENDIF
7585
7586	npcsfl = 0
7587	IF ( plant_canopy ) THEN
7588
7589	IF ( debug_output ) CALL debug_message( 'Calculation of the complete CSF array', 'info' )
7590	!-- sort and merge csf for the last time, keeping the array size to minimum
7591	CALL merge_and_grow_csf(-1)
7592
7593	!-- aggregate csb among processors
7594	!-- allocate necessary arrays
7595	udim = max(ncsfl,1)
7596	ALLOCATE( csflt_l(ndcsf*udim) )
7597	csflt(1:ndcsf,1:udim) => csflt_l(1:ndcsf*udim)
7598	ALLOCATE( kcsflt_l(kdcsf*udim) )
7599	kcsflt(1:kdcsf,1:udim) => kcsflt_l(1:kdcsf*udim)
7600	ALLOCATE( icsflt(0:numprocs-1) )
7601	ALLOCATE( dcsflt(0:numprocs-1) )
7602	ALLOCATE( ipcsflt(0:numprocs-1) )
7603	ALLOCATE( dpcsflt(0:numprocs-1) )
7604
7605	!-- fill out arrays of csf values and
7606	!-- arrays of number of elements and displacements
7607	!-- for particular precessors
7608	icsflt = 0
7609	dcsflt = 0
7610	ip = -1
7611	j = -1
7612	d = 0
7613	DO kcsf = 1, ncsfl
7614	j = j+1
7615	IF ( acsf(kcsf)%ip /= ip ) THEN
7616	!-- new block of the processor
7617	!-- number of elements of previous block
7618	IF ( ip>=0) icsflt(ip) = j
7619	d = d+j
7620	!-- blank blocks
7621	DO jp = ip+1, acsf(kcsf)%ip-1
7622	!-- number of elements is zero, displacement is equal to previous
7623	icsflt(jp) = 0
7624	dcsflt(jp) = d
7625	ENDDO
7626	!-- the actual block
7627	ip = acsf(kcsf)%ip
7628	dcsflt(ip) = d
7629	j = 0
7630	ENDIF
7631	csflt(1,kcsf) = acsf(kcsf)%rcvf
7632	!-- fill out integer values of itz,ity,itx,isurfs
7633	kcsflt(1,kcsf) = acsf(kcsf)%itz
7634	kcsflt(2,kcsf) = acsf(kcsf)%ity
7635	kcsflt(3,kcsf) = acsf(kcsf)%itx
7636	kcsflt(4,kcsf) = acsf(kcsf)%isurfs
7637	ENDDO
7638	!-- last blank blocks at the end of array
7639	j = j+1
7640	IF ( ip>=0 ) icsflt(ip) = j
7641	d = d+j
7642	DO jp = ip+1, numprocs-1
7643	!-- number of elements is zero, displacement is equal to previous
7644	icsflt(jp) = 0
7645	dcsflt(jp) = d
7646	ENDDO
7647
7648	!-- deallocate temporary acsf array
7649	!-- DEALLOCATE(acsf) - ifort has a problem with deallocation of allocatable target
7650	!-- via pointing pointer - we need to test original targets
7651	IF ( ALLOCATED(acsf1) ) THEN
7652	DEALLOCATE(acsf1)
7653	ENDIF
7654	IF ( ALLOCATED(acsf2) ) THEN
7655	DEALLOCATE(acsf2)
7656	ENDIF
7657
7658	#if defined( __parallel )
7659	!-- scatter and gather the number of elements to and from all processor
7660	!-- and calculate displacements
7661	IF ( debug_output ) CALL debug_message( 'Scatter and gather the number of elements to and from all processor', 'info' )
7662
7663	CALL MPI_AlltoAll(icsflt,1,MPI_INTEGER,ipcsflt,1,MPI_INTEGER,comm2d, ierr)
7664
7665	IF ( ierr /= 0 ) THEN
7666	WRITE(9,*) 'Error MPI_AlltoAll1:', ierr, SIZE(icsflt), SIZE(ipcsflt)
7667	FLUSH(9)
7668	ENDIF
7669
7670	npcsfl = SUM(ipcsflt)
7671	d = 0
7672	DO i = 0, numprocs-1
7673	dpcsflt(i) = d
7674	d = d + ipcsflt(i)
7675	ENDDO
7676
7677	!-- exchange csf fields between processors
7678	IF ( debug_output ) CALL debug_message( 'Exchange csf fields between processors', 'info' )
7679	udim = max(npcsfl,1)
7680	ALLOCATE( pcsflt_l(ndcsf*udim) )
7681	pcsflt(1:ndcsf,1:udim) => pcsflt_l(1:ndcsf*udim)
7682	ALLOCATE( kpcsflt_l(kdcsf*udim) )
7683	kpcsflt(1:kdcsf,1:udim) => kpcsflt_l(1:kdcsf*udim)
7684	CALL MPI_AlltoAllv(csflt_l, ndcsficsflt, ndcsfdcsflt, MPI_REAL, &
7685	pcsflt_l, ndcsfipcsflt, ndcsfdpcsflt, MPI_REAL, comm2d, ierr)
7686	IF ( ierr /= 0 ) THEN
7687	WRITE(9,) 'Error MPI_AlltoAllv1:', ierr, SIZE(ipcsflt), ndcsficsflt, &
7688	ndcsfdcsflt, SIZE(pcsflt_l),ndcsfipcsflt, ndcsf*dpcsflt
7689	FLUSH(9)
7690	ENDIF
7691
7692	CALL MPI_AlltoAllv(kcsflt_l, kdcsficsflt, kdcsfdcsflt, MPI_INTEGER, &
7693	kpcsflt_l, kdcsfipcsflt, kdcsfdpcsflt, MPI_INTEGER, comm2d, ierr)
7694	IF ( ierr /= 0 ) THEN
7695	WRITE(9,) 'Error MPI_AlltoAllv2:', ierr, SIZE(kcsflt_l),kdcsficsflt, &
7696	kdcsfdcsflt, SIZE(kpcsflt_l), kdcsfipcsflt, kdcsf*dpcsflt
7697	FLUSH(9)
7698	ENDIF
7699
7700	#else
7701	npcsfl = ncsfl
7702	ALLOCATE( pcsflt(ndcsf,max(npcsfl,ndcsf)) )
7703	ALLOCATE( kpcsflt(kdcsf,max(npcsfl,kdcsf)) )
7704	pcsflt = csflt
7705	kpcsflt = kcsflt
7706	#endif
7707
7708	!-- deallocate temporary arrays
7709	DEALLOCATE( csflt_l )
7710	DEALLOCATE( kcsflt_l )
7711	DEALLOCATE( icsflt )
7712	DEALLOCATE( dcsflt )
7713	DEALLOCATE( ipcsflt )
7714	DEALLOCATE( dpcsflt )
7715
7716	!-- sort csf ( a version of quicksort )
7717	IF ( debug_output ) CALL debug_message( 'Sort csf', 'info' )
7718	CALL quicksort_csf2(kpcsflt, pcsflt, 1, npcsfl)
7719
7720	!-- aggregate canopy sink factor records with identical box & source
7721	!-- againg across all values from all processors
7722	IF ( debug_output ) CALL debug_message( 'Aggregate canopy sink factor records with identical box', 'info' )
7723
7724	IF ( npcsfl > 0 ) THEN
7725	icsf = 1 !< reading index
7726	kcsf = 1 !< writing index
7727	DO WHILE (icsf < npcsfl)
7728	!-- here kpcsf(kcsf) already has values from kpcsf(icsf)
7729	IF ( kpcsflt(3,icsf) == kpcsflt(3,icsf+1) .AND. &
7730	kpcsflt(2,icsf) == kpcsflt(2,icsf+1) .AND. &
7731	kpcsflt(1,icsf) == kpcsflt(1,icsf+1) .AND. &
7732	kpcsflt(4,icsf) == kpcsflt(4,icsf+1) ) THEN
7733
7734	pcsflt(1,kcsf) = pcsflt(1,kcsf) + pcsflt(1,icsf+1)
7735
7736	!-- advance reading index, keep writing index
7737	icsf = icsf + 1
7738	ELSE
7739	!-- not identical, just advance and copy
7740	icsf = icsf + 1
7741	kcsf = kcsf + 1
7742	kpcsflt(:,kcsf) = kpcsflt(:,icsf)
7743	pcsflt(:,kcsf) = pcsflt(:,icsf)
7744	ENDIF
7745	ENDDO
7746	!-- last written item is now also the last item in valid part of array
7747	npcsfl = kcsf
7748	ENDIF
7749
7750	ncsfl = npcsfl
7751	IF ( ncsfl > 0 ) THEN
7752	ALLOCATE( csf(ndcsf,ncsfl) )
7753	ALLOCATE( csfsurf(idcsf,ncsfl) )
7754	DO icsf = 1, ncsfl
7755	csf(:,icsf) = pcsflt(:,icsf)
7756	csfsurf(1,icsf) = gridpcbl(kpcsflt(1,icsf),kpcsflt(2,icsf),kpcsflt(3,icsf))
7757	csfsurf(2,icsf) = kpcsflt(4,icsf)
7758	ENDDO
7759	ENDIF
7760
7761	!-- deallocation of temporary arrays
7762	IF ( npcbl > 0 ) DEALLOCATE( gridpcbl )
7763	DEALLOCATE( pcsflt_l )
7764	DEALLOCATE( kpcsflt_l )
7765	IF ( debug_output ) CALL debug_message( 'End of aggregate csf', 'info' )
7766
7767	ENDIF
7768
7769	#if defined( __parallel )
7770	CALL MPI_BARRIER( comm2d, ierr )
7771	#endif
7772	CALL location_message( 'calculating view factors for radiation interaction', 'finished' )
7773
7774	RETURN !todo: remove
7775
7776	! WRITE( message_string, * ) &
7777	! 'I/O error when processing shape view factors / ', &
7778	! 'plant canopy sink factors / direct irradiance factors.'
7779	! CALL message( 'init_urban_surface', 'PA0502', 2, 2, 0, 6, 0 )
7780
7781	END SUBROUTINE radiation_calc_svf
7782
7783
7784	!------------------------------------------------------------------------------!
7785	! Description:
7786	! ------------
7787	!> Raytracing for detecting obstacles and calculating compound canopy sink
7788	!> factors. (A simple obstacle detection would only need to process faces in
7789	!> 3 dimensions without any ordering.)
7790	!> Assumtions:
7791	!> -----------
7792	!> 1. The ray always originates from a face midpoint (only one coordinate equals
7793	!> *.5, i.e. wall) and doesn't travel parallel to the surface (that would mean
7794	!> shape factor=0). Therefore, the ray may never travel exactly along a face
7795	!> or an edge.
7796	!> 2. From grid bottom to urban surface top the grid has to be equidistant
7797	!> within each of the dimensions, including vertical (but the resolution
7798	!> doesn't need to be the same in all three dimensions).
7799	!------------------------------------------------------------------------------!
7800	SUBROUTINE raytrace(src, targ, isrc, difvf, atarg, create_csf, visible, transparency)
7801	IMPLICIT NONE
7802
7803	REAL(wp), DIMENSION(3), INTENT(in) :: src, targ !< real coordinates z,y,x
7804	INTEGER(iwp), INTENT(in) :: isrc !< index of source face for csf
7805	REAL(wp), INTENT(in) :: difvf !< differential view factor for csf
7806	REAL(wp), INTENT(in) :: atarg !< target surface area for csf
7807	LOGICAL, INTENT(in) :: create_csf !< whether to generate new CSFs during raytracing
7808	LOGICAL, INTENT(out) :: visible
7809	REAL(wp), INTENT(out) :: transparency !< along whole path
7810	INTEGER(iwp) :: i, k, d
7811	INTEGER(iwp) :: seldim !< dimension to be incremented
7812	INTEGER(iwp) :: ncsb !< no of written plant canopy sinkboxes
7813	INTEGER(iwp) :: maxboxes !< max no of gridboxes visited
7814	REAL(wp) :: distance !< euclidean along path
7815	REAL(wp) :: crlen !< length of gridbox crossing
7816	REAL(wp) :: lastdist !< beginning of current crossing
7817	REAL(wp) :: nextdist !< end of current crossing
7818	REAL(wp) :: realdist !< distance in meters per unit distance
7819	REAL(wp) :: crmid !< midpoint of crossing
7820	REAL(wp) :: cursink !< sink factor for current canopy box
7821	REAL(wp), DIMENSION(3) :: delta !< path vector
7822	REAL(wp), DIMENSION(3) :: uvect !< unit vector
7823	REAL(wp), DIMENSION(3) :: dimnextdist !< distance for each dimension increments
7824	INTEGER(iwp), DIMENSION(3) :: box !< gridbox being crossed
7825	INTEGER(iwp), DIMENSION(3) :: dimnext !< next dimension increments along path
7826	INTEGER(iwp), DIMENSION(3) :: dimdelta !< dimension direction = +- 1
7827	INTEGER(iwp) :: px, py !< number of processors in x and y dir before
7828	!< the processor in the question
7829	INTEGER(iwp) :: ip !< number of processor where gridbox reside
7830	INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array
7831
7832	REAL(wp) :: eps = 1E-10_wp !< epsilon for value comparison
7833	REAL(wp) :: lad_s_target !< recieved lad_s of particular grid box
7834
7835	!
7836	!-- Maximum number of gridboxes visited equals to maximum number of boundaries crossed in each dimension plus one. That's also
7837	!-- the maximum number of plant canopy boxes written. We grow the acsf array accordingly using exponential factor.
7838	maxboxes = SUM(ABS(NINT(targ, iwp) - NINT(src, iwp))) + 1
7839	IF ( plant_canopy .AND. ncsfl + maxboxes > ncsfla ) THEN
7840	!-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1)
7841	!-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) &
7842	!-- / log(grow_factor)), kind=wp))
7843	!-- or use this code to simply always keep some extra space after growing
7844	k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor)
7845
7846	CALL merge_and_grow_csf(k)
7847	ENDIF
7848
7849	transparency = 1._wp
7850	ncsb = 0
7851
7852	delta(:) = targ(:) - src(:)
7853	distance = SQRT(SUM(delta(:)**2))
7854	IF ( distance == 0._wp ) THEN
7855	visible = .TRUE.
7856	RETURN
7857	ENDIF
7858	uvect(:) = delta(:) / distance
7859	realdist = SQRT(SUM( (uvect(:)(/dz(1),dy,dx/))*2 ))
7860
7861	lastdist = 0._wp
7862
7863	!-- Since all face coordinates have values *.5 and we'd like to use
7864	!-- integers, all these have .5 added
7865	DO d = 1, 3
7866	IF ( uvect(d) == 0._wp ) THEN
7867	dimnext(d) = 999999999
7868	dimdelta(d) = 999999999
7869	dimnextdist(d) = 1.0E20_wp
7870	ELSE IF ( uvect(d) > 0._wp ) THEN
7871	dimnext(d) = CEILING(src(d) + .5_wp)
7872	dimdelta(d) = 1
7873	dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d)
7874	ELSE
7875	dimnext(d) = FLOOR(src(d) + .5_wp)
7876	dimdelta(d) = -1
7877	dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d)
7878	ENDIF
7879	ENDDO
7880
7881	DO
7882	!-- along what dimension will the next wall crossing be?
7883	seldim = minloc(dimnextdist, 1)
7884	nextdist = dimnextdist(seldim)
7885	IF ( nextdist > distance ) nextdist = distance
7886
7887	crlen = nextdist - lastdist
7888	IF ( crlen > .001_wp ) THEN
7889	crmid = (lastdist + nextdist) * .5_wp
7890	box = NINT(src(:) + uvect(:) * crmid, iwp)
7891
7892	!-- calculate index of the grid with global indices (box(2),box(3))
7893	!-- in the array nzterr and plantt and id of the coresponding processor
7894	px = box(3)/nnx
7895	py = box(2)/nny
7896	ip = px*pdims(2)+py
7897	ig = ipnnxnny + (box(3)-pxnnx)nny + box(2)-py*nny
7898	IF ( box(1) <= nzterr(ig) ) THEN
7899	visible = .FALSE.
7900	RETURN
7901	ENDIF
7902
7903	IF ( plant_canopy ) THEN
7904	IF ( box(1) <= plantt(ig) ) THEN
7905	ncsb = ncsb + 1
7906	boxes(:,ncsb) = box
7907	crlens(ncsb) = crlen
7908	#if defined( __parallel )
7909	lad_ip(ncsb) = ip
7910	lad_disp(ncsb) = (box(3)-pxnnx)(nnynz_plant) + (box(2)-pynny)*nz_plant + box(1)-nz_urban_b
7911	#endif
7912	ENDIF
7913	ENDIF
7914	ENDIF
7915
7916	IF ( ABS(distance - nextdist) < eps ) EXIT
7917	lastdist = nextdist
7918	dimnext(seldim) = dimnext(seldim) + dimdelta(seldim)
7919	dimnextdist(seldim) = (dimnext(seldim) - .5_wp - src(seldim)) / uvect(seldim)
7920	ENDDO
7921
7922	IF ( plant_canopy ) THEN
7923	#if defined( __parallel )
7924	IF ( raytrace_mpi_rma ) THEN
7925	!-- send requests for lad_s to appropriate processor
7926	CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'start' )
7927	DO i = 1, ncsb
7928	CALL MPI_Get(lad_s_ray(i), 1, MPI_REAL, lad_ip(i), lad_disp(i), &
7929	1, MPI_REAL, win_lad, ierr)
7930	IF ( ierr /= 0 ) THEN
7931	WRITE(9,*) 'Error MPI_Get1:', ierr, lad_s_ray(i), &
7932	lad_ip(i), lad_disp(i), win_lad
7933	FLUSH(9)
7934	ENDIF
7935	ENDDO
7936
7937	!-- wait for all pending local requests complete
7938	CALL MPI_Win_flush_local_all(win_lad, ierr)
7939	IF ( ierr /= 0 ) THEN
7940	WRITE(9,*) 'Error MPI_Win_flush_local_all1:', ierr, win_lad
7941	FLUSH(9)
7942	ENDIF
7943	CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'stop' )
7944
7945	ENDIF
7946	#endif
7947
7948	!-- calculate csf and transparency
7949	DO i = 1, ncsb
7950	#if defined( __parallel )
7951	IF ( raytrace_mpi_rma ) THEN
7952	lad_s_target = lad_s_ray(i)
7953	ELSE
7954	lad_s_target = sub_lad_g(lad_ip(i)nnxnny*nz_plant + lad_disp(i))
7955	ENDIF
7956	#else
7957	lad_s_target = sub_lad(boxes(1,i),boxes(2,i),boxes(3,i))
7958	#endif
7959	cursink = 1._wp - exp(-ext_coef * lad_s_target * crlens(i)*realdist)
7960
7961	IF ( create_csf ) THEN
7962	!-- write svf values into the array
7963	ncsfl = ncsfl + 1
7964	acsf(ncsfl)%ip = lad_ip(i)
7965	acsf(ncsfl)%itx = boxes(3,i)
7966	acsf(ncsfl)%ity = boxes(2,i)
7967	acsf(ncsfl)%itz = boxes(1,i)
7968	acsf(ncsfl)%isurfs = isrc
7969	acsf(ncsfl)%rcvf = cursinktransparencydifvf*atarg
7970	ENDIF !< create_csf
7971
7972	transparency = transparency * (1._wp - cursink)
7973
7974	ENDDO
7975	ENDIF
7976
7977	visible = .TRUE.
7978
7979	END SUBROUTINE raytrace
7980
7981
7982	!------------------------------------------------------------------------------!
7983	! Description:
7984	! ------------
7985	!> A new, more efficient version of ray tracing algorithm that processes a whole
7986	!> arc instead of a single ray.
7987	!>
7988	!> In all comments, horizon means tangent of horizon angle, i.e.
7989	!> vertical_delta / horizontal_distance
7990	!------------------------------------------------------------------------------!
7991	SUBROUTINE raytrace_2d(origin, yxdir, nrays, zdirs, iorig, aorig, vffrac, &
7992	calc_svf, create_csf, skip_1st_pcb, &
7993	lowest_free_ray, transparency, itarget)
7994	IMPLICIT NONE
7995
7996	REAL(wp), DIMENSION(3), INTENT(IN) :: origin !< z,y,x coordinates of ray origin
7997	REAL(wp), DIMENSION(2), INTENT(IN) :: yxdir !< y,x unit vector of ray direction (in grid units)
7998	INTEGER(iwp) :: nrays !< number of rays (z directions) to raytrace
7999	REAL(wp), DIMENSION(nrays), INTENT(IN) :: zdirs !< list of z directions to raytrace (z/hdist, grid, zenith->nadir)
8000	INTEGER(iwp), INTENT(in) :: iorig !< index of origin face for csf
8001	REAL(wp), INTENT(in) :: aorig !< origin face area for csf
8002	REAL(wp), DIMENSION(nrays), INTENT(in) :: vffrac !< view factor fractions of each ray for csf
8003	LOGICAL, INTENT(in) :: calc_svf !< whether to calculate SFV (identify obstacle surfaces)
8004	LOGICAL, INTENT(in) :: create_csf !< whether to create canopy sink factors
8005	LOGICAL, INTENT(in) :: skip_1st_pcb !< whether to skip first plant canopy box during raytracing
8006	INTEGER(iwp), INTENT(out) :: lowest_free_ray !< index into zdirs
8007	REAL(wp), DIMENSION(nrays), INTENT(OUT) :: transparency !< transparencies of zdirs paths
8008	INTEGER(iwp), DIMENSION(nrays), INTENT(OUT) :: itarget !< global indices of target faces for zdirs
8009
8010	INTEGER(iwp), DIMENSION(nrays) :: target_procs
8011	REAL(wp) :: horizon !< highest horizon found after raytracing (z/hdist)
8012	INTEGER(iwp) :: i, k, l, d
8013	INTEGER(iwp) :: seldim !< dimension to be incremented
8014	REAL(wp), DIMENSION(2) :: yxorigin !< horizontal copy of origin (y,x)
8015	REAL(wp) :: distance !< euclidean along path
8016	REAL(wp) :: lastdist !< beginning of current crossing
8017	REAL(wp) :: nextdist !< end of current crossing
8018	REAL(wp) :: crmid !< midpoint of crossing
8019	REAL(wp) :: horz_entry !< horizon at entry to column
8020	REAL(wp) :: horz_exit !< horizon at exit from column
8021	REAL(wp) :: bdydim !< boundary for current dimension
8022	REAL(wp), DIMENSION(2) :: crossdist !< distances to boundary for dimensions
8023	REAL(wp), DIMENSION(2) :: dimnextdist !< distance for each dimension increments
8024	INTEGER(iwp), DIMENSION(2) :: column !< grid column being crossed
8025	INTEGER(iwp), DIMENSION(2) :: dimnext !< next dimension increments along path
8026	INTEGER(iwp), DIMENSION(2) :: dimdelta !< dimension direction = +- 1
8027	INTEGER(iwp) :: px, py !< number of processors in x and y dir before
8028	!< the processor in the question
8029	INTEGER(iwp) :: ip !< number of processor where gridbox reside
8030	INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array
8031	INTEGER(iwp) :: wcount !< RMA window item count
8032	INTEGER(iwp) :: maxboxes !< max no of CSF created
8033	INTEGER(iwp) :: nly !< maximum plant canopy height
8034	INTEGER(iwp) :: ntrack
8035
8036	INTEGER(iwp) :: zb0
8037	INTEGER(iwp) :: zb1
8038	INTEGER(iwp) :: nz
8039	INTEGER(iwp) :: iz
8040	INTEGER(iwp) :: zsgn
8041	INTEGER(iwp) :: lowest_lad !< lowest column cell for which we need LAD
8042	INTEGER(iwp) :: lastdir !< wall direction before hitting this column
8043	INTEGER(iwp), DIMENSION(2) :: lastcolumn
8044
8045	#if defined( __parallel )
8046	INTEGER(MPI_ADDRESS_KIND) :: wdisp !< RMA window displacement
8047	#endif
8048
8049	REAL(wp) :: eps = 1E-10_wp !< epsilon for value comparison
8050	REAL(wp) :: zbottom, ztop !< urban surface boundary in real numbers
8051	REAL(wp) :: zorig !< z coordinate of ray column entry
8052	REAL(wp) :: zexit !< z coordinate of ray column exit
8053	REAL(wp) :: qdist !< ratio of real distance to z coord difference
8054	REAL(wp) :: dxxyy !< square of real horizontal distance
8055	REAL(wp) :: curtrans !< transparency of current PC box crossing
8056
8057
8058
8059	yxorigin(:) = origin(2:3)
8060	transparency(:) = 1._wp !-- Pre-set the all rays to transparent before reducing
8061	horizon = -HUGE(1._wp)
8062	lowest_free_ray = nrays
8063	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8064	ALLOCATE(target_surfl(nrays))
8065	target_surfl(:) = -1
8066	lastdir = -999
8067	lastcolumn(:) = -999
8068	ENDIF
8069
8070	!-- Determine distance to boundary (in 2D xy)
8071	IF ( yxdir(1) > 0._wp ) THEN
8072	bdydim = ny + .5_wp !< north global boundary
8073	crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1)
8074	ELSEIF ( yxdir(1) == 0._wp ) THEN
8075	crossdist(1) = HUGE(1._wp)
8076	ELSE
8077	bdydim = -.5_wp !< south global boundary
8078	crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1)
8079	ENDIF
8080
8081	IF ( yxdir(2) > 0._wp ) THEN
8082	bdydim = nx + .5_wp !< east global boundary
8083	crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2)
8084	ELSEIF ( yxdir(2) == 0._wp ) THEN
8085	crossdist(2) = HUGE(1._wp)
8086	ELSE
8087	bdydim = -.5_wp !< west global boundary
8088	crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2)
8089	ENDIF
8090	distance = minval(crossdist, 1)
8091
8092	IF ( plant_canopy ) THEN
8093	rt2_track_dist(0) = 0._wp
8094	rt2_track_lad(:,:) = 0._wp
8095	nly = plantt_max - nz_urban_b + 1
8096	ENDIF
8097
8098	lastdist = 0._wp
8099
8100	!-- Since all face coordinates have values *.5 and we'd like to use
8101	!-- integers, all these have .5 added
8102	DO d = 1, 2
8103	IF ( yxdir(d) == 0._wp ) THEN
8104	dimnext(d) = HUGE(1_iwp)
8105	dimdelta(d) = HUGE(1_iwp)
8106	dimnextdist(d) = HUGE(1._wp)
8107	ELSE IF ( yxdir(d) > 0._wp ) THEN
8108	dimnext(d) = FLOOR(yxorigin(d) + .5_wp) + 1
8109	dimdelta(d) = 1
8110	dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d)
8111	ELSE
8112	dimnext(d) = CEILING(yxorigin(d) + .5_wp) - 1
8113	dimdelta(d) = -1
8114	dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d)
8115	ENDIF
8116	ENDDO
8117
8118	ntrack = 0
8119	DO
8120	!-- along what dimension will the next wall crossing be?
8121	seldim = minloc(dimnextdist, 1)
8122	nextdist = dimnextdist(seldim)
8123	IF ( nextdist > distance ) nextdist = distance
8124
8125	IF ( nextdist > lastdist ) THEN
8126	ntrack = ntrack + 1
8127	crmid = (lastdist + nextdist) * .5_wp
8128	column = NINT(yxorigin(:) + yxdir(:) * crmid, iwp)
8129
8130	!-- calculate index of the grid with global indices (column(1),column(2))
8131	!-- in the array nzterr and plantt and id of the coresponding processor
8132	px = column(2)/nnx
8133	py = column(1)/nny
8134	ip = px*pdims(2)+py
8135	ig = ipnnxnny + (column(2)-pxnnx)nny + column(1)-py*nny
8136
8137	IF ( lastdist == 0._wp ) THEN
8138	horz_entry = -HUGE(1._wp)
8139	ELSE
8140	horz_entry = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / lastdist
8141	ENDIF
8142	horz_exit = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / nextdist
8143
8144	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8145	!
8146	!-- Identify vertical obstacles hit by rays in current column
8147	DO WHILE ( lowest_free_ray > 0 )
8148	IF ( zdirs(lowest_free_ray) > horz_entry ) EXIT
8149	!
8150	!-- This may only happen after 1st column, so lastdir and lastcolumn are valid
8151	CALL request_itarget(lastdir, &
8152	CEILING(-0.5_wp + origin(1) + zdirs(lowest_free_ray)*lastdist), &
8153	lastcolumn(1), lastcolumn(2), &
8154	target_surfl(lowest_free_ray), target_procs(lowest_free_ray))
8155	lowest_free_ray = lowest_free_ray - 1
8156	ENDDO
8157	!
8158	!-- Identify horizontal obstacles hit by rays in current column
8159	DO WHILE ( lowest_free_ray > 0 )
8160	IF ( zdirs(lowest_free_ray) > horz_exit ) EXIT
8161	CALL request_itarget(iup_u, nzterr(ig)+1, column(1), column(2), &
8162	target_surfl(lowest_free_ray), &
8163	target_procs(lowest_free_ray))
8164	lowest_free_ray = lowest_free_ray - 1
8165	ENDDO
8166	ENDIF
8167
8168	horizon = MAX(horizon, horz_entry, horz_exit)
8169
8170	IF ( plant_canopy ) THEN
8171	rt2_track(:, ntrack) = column(:)
8172	rt2_track_dist(ntrack) = nextdist
8173	ENDIF
8174	ENDIF
8175
8176	IF ( nextdist + eps >= distance ) EXIT
8177
8178	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8179	!
8180	!-- Save wall direction of coming building column (= this air column)
8181	IF ( seldim == 1 ) THEN
8182	IF ( dimdelta(seldim) == 1 ) THEN
8183	lastdir = isouth_u
8184	ELSE
8185	lastdir = inorth_u
8186	ENDIF
8187	ELSE
8188	IF ( dimdelta(seldim) == 1 ) THEN
8189	lastdir = iwest_u
8190	ELSE
8191	lastdir = ieast_u
8192	ENDIF
8193	ENDIF
8194	lastcolumn = column
8195	ENDIF
8196	lastdist = nextdist
8197	dimnext(seldim) = dimnext(seldim) + dimdelta(seldim)
8198	dimnextdist(seldim) = (dimnext(seldim) - .5_wp - yxorigin(seldim)) / yxdir(seldim)
8199	ENDDO
8200
8201	IF ( plant_canopy ) THEN
8202	!-- Request LAD WHERE applicable
8203	!--
8204	#if defined( __parallel )
8205	IF ( raytrace_mpi_rma ) THEN
8206	!-- send requests for lad_s to appropriate processor
8207	!CALL cpu_log( log_point_s(77), 'usm_init_rma', 'start' )
8208	DO i = 1, ntrack
8209	px = rt2_track(2,i)/nnx
8210	py = rt2_track(1,i)/nny
8211	ip = px*pdims(2)+py
8212	ig = ipnnxnny + (rt2_track(2,i)-pxnnx)nny + rt2_track(1,i)-py*nny
8213
8214	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8215	!
8216	!-- For fixed view resolution, we need plant canopy even for rays
8217	!-- to opposing surfaces
8218	lowest_lad = nzterr(ig) + 1
8219	ELSE
8220	!
8221	!-- We only need LAD for rays directed above horizon (to sky)
8222	lowest_lad = CEILING( -0.5_wp + origin(1) + &
8223	MIN( horizon * rt2_track_dist(i-1), & ! entry
8224	horizon * rt2_track_dist(i) ) ) ! exit
8225	ENDIF
8226	!
8227	!-- Skip asking for LAD where all plant canopy is under requested level
8228	IF ( plantt(ig) < lowest_lad ) CYCLE
8229
8230	wdisp = (rt2_track(2,i)-pxnnx)(nnynz_plant) + (rt2_track(1,i)-pynny)*nz_plant + lowest_lad-nz_urban_b
8231	wcount = plantt(ig)-lowest_lad+1
8232	! TODO send request ASAP - even during raytracing
8233	CALL MPI_Get(rt2_track_lad(lowest_lad:plantt(ig), i), wcount, MPI_REAL, ip, &
8234	wdisp, wcount, MPI_REAL, win_lad, ierr)
8235	IF ( ierr /= 0 ) THEN
8236	WRITE(9,*) 'Error MPI_Get2:', ierr, rt2_track_lad(lowest_lad:plantt(ig), i), &
8237	wcount, ip, wdisp, win_lad
8238	FLUSH(9)
8239	ENDIF
8240	ENDDO
8241
8242	!-- wait for all pending local requests complete
8243	! TODO WAIT selectively for each column later when needed
8244	CALL MPI_Win_flush_local_all(win_lad, ierr)
8245	IF ( ierr /= 0 ) THEN
8246	WRITE(9,*) 'Error MPI_Win_flush_local_all2:', ierr, win_lad
8247	FLUSH(9)
8248	ENDIF
8249	!CALL cpu_log( log_point_s(77), 'usm_init_rma', 'stop' )
8250
8251	ELSE ! raytrace_mpi_rma = .F.
8252	DO i = 1, ntrack
8253	px = rt2_track(2,i)/nnx
8254	py = rt2_track(1,i)/nny
8255	ip = px*pdims(2)+py
8256	ig = ipnnxnnynz_plant + (rt2_track(2,i)-pxnnx)(nnynz_plant) + (rt2_track(1,i)-pynny)nz_plant
8257	rt2_track_lad(nz_urban_b:plantt_max, i) = sub_lad_g(ig:ig+nly-1)
8258	ENDDO
8259	ENDIF
8260	#else
8261	DO i = 1, ntrack
8262	rt2_track_lad(nz_urban_b:plantt_max, i) = sub_lad(rt2_track(1,i), rt2_track(2,i), nz_urban_b:plantt_max)
8263	ENDDO
8264	#endif
8265	ENDIF ! plant_canopy
8266
8267	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8268	#if defined( __parallel )
8269	!-- wait for all gridsurf requests to complete
8270	CALL MPI_Win_flush_local_all(win_gridsurf, ierr)
8271	IF ( ierr /= 0 ) THEN
8272	WRITE(9,*) 'Error MPI_Win_flush_local_all3:', ierr, win_gridsurf
8273	FLUSH(9)
8274	ENDIF
8275	#endif
8276	!
8277	!-- recalculate local surf indices into global ones
8278	DO i = 1, nrays
8279	IF ( target_surfl(i) == -1 ) THEN
8280	itarget(i) = -1
8281	ELSE
8282	itarget(i) = target_surfl(i) + surfstart(target_procs(i))
8283	ENDIF
8284	ENDDO
8285
8286	DEALLOCATE( target_surfl )
8287
8288	ELSE
8289	itarget(:) = -1
8290	ENDIF ! rad_angular_discretization
8291
8292	IF ( plant_canopy ) THEN
8293	!-- Skip the PCB around origin if requested (for MRT, the PCB might not be there)
8294	!--
8295	IF ( skip_1st_pcb .AND. NINT(origin(1)) <= plantt_max ) THEN
8296	rt2_track_lad(NINT(origin(1), iwp), 1) = 0._wp
8297	ENDIF
8298
8299	!-- Assert that we have space allocated for CSFs
8300	!--
8301	maxboxes = (ntrack + MAX(CEILING(origin(1)-.5_wp) - nz_urban_b, &
8302	nz_urban_t - CEILING(origin(1)-.5_wp))) * nrays
8303	IF ( ncsfl + maxboxes > ncsfla ) THEN
8304	!-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1)
8305	!-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) &
8306	!-- / log(grow_factor)), kind=wp))
8307	!-- or use this code to simply always keep some extra space after growing
8308	k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor)
8309	CALL merge_and_grow_csf(k)
8310	ENDIF
8311
8312	!-- Calculate transparencies and store new CSFs
8313	!--
8314	zbottom = REAL(nz_urban_b, wp) - .5_wp
8315	ztop = REAL(plantt_max, wp) + .5_wp
8316
8317	!-- Reverse direction of radiation (face->sky), only when calc_svf
8318	!--
8319	IF ( calc_svf ) THEN
8320	DO i = 1, ntrack ! for each column
8321	dxxyy = ((dyyxdir(1))2 + (dxyxdir(2))*2) (rt2_track_dist(i)-rt2_track_dist(i-1))**2
8322	px = rt2_track(2,i)/nnx
8323	py = rt2_track(1,i)/nny
8324	ip = px*pdims(2)+py
8325
8326	DO k = 1, nrays ! for each ray
8327	!
8328	!-- NOTE 6778:
8329	!-- With traditional svf discretization, CSFs under the horizon
8330	!-- (i.e. for surface to surface radiation) are created in
8331	!-- raytrace(). With rad_angular_discretization, we must create
8332	!-- CSFs under horizon only for one direction, otherwise we would
8333	!-- have duplicate amount of energy. Although we could choose
8334	!-- either of the two directions (they differ only by
8335	!-- discretization error with no bias), we choose the the backward
8336	!-- direction, because it tends to cumulate high canopy sink
8337	!-- factors closer to raytrace origin, i.e. it should potentially
8338	!-- cause less moiree.
8339	IF ( .NOT. rad_angular_discretization ) THEN
8340	IF ( zdirs(k) <= horizon ) CYCLE
8341	ENDIF
8342
8343	zorig = origin(1) + zdirs(k) * rt2_track_dist(i-1)
8344	IF ( zorig <= zbottom .OR. zorig >= ztop ) CYCLE
8345
8346	zsgn = INT(SIGN(1._wp, zdirs(k)), iwp)
8347	rt2_dist(1) = 0._wp
8348	IF ( zdirs(k) == 0._wp ) THEN ! ray is exactly horizontal
8349	nz = 2
8350	rt2_dist(nz) = SQRT(dxxyy)
8351	iz = CEILING(-.5_wp + zorig, iwp)
8352	ELSE
8353	zexit = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop)
8354
8355	zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! because it must be greater than orig
8356	zb1 = CEILING(zexit * zsgn - .5_wp) - 1 ! because it must be smaller than exit
8357	nz = MAX(zb1 - zb0 + 3, 2)
8358	rt2_dist(nz) = SQRT(((zexit-zorig)dz(1))*2 + dxxyy)
8359	qdist = rt2_dist(nz) / (zexit-zorig)
8360	rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/)
8361	iz = zb0 * zsgn
8362	ENDIF
8363
8364	DO l = 2, nz
8365	IF ( rt2_track_lad(iz, i) > 0._wp ) THEN
8366	curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1)))
8367
8368	IF ( create_csf ) THEN
8369	ncsfl = ncsfl + 1
8370	acsf(ncsfl)%ip = ip
8371	acsf(ncsfl)%itx = rt2_track(2,i)
8372	acsf(ncsfl)%ity = rt2_track(1,i)
8373	acsf(ncsfl)%itz = iz
8374	acsf(ncsfl)%isurfs = iorig
8375	acsf(ncsfl)%rcvf = (1._wp - curtrans)transparency(k)vffrac(k)
8376	ENDIF
8377
8378	transparency(k) = transparency(k) * curtrans
8379	ENDIF
8380	iz = iz + zsgn
8381	ENDDO ! l = 1, nz - 1
8382	ENDDO ! k = 1, nrays
8383	ENDDO ! i = 1, ntrack
8384
8385	transparency(1:lowest_free_ray) = 1._wp !-- Reset rays above horizon to transparent (see NOTE 6778)
8386	ENDIF
8387
8388	!-- Forward direction of radiation (sky->face), always
8389	!--
8390	DO i = ntrack, 1, -1 ! for each column backwards
8391	dxxyy = ((dyyxdir(1))2 + (dxyxdir(2))*2) (rt2_track_dist(i)-rt2_track_dist(i-1))**2
8392	px = rt2_track(2,i)/nnx
8393	py = rt2_track(1,i)/nny
8394	ip = px*pdims(2)+py
8395
8396	DO k = 1, nrays ! for each ray
8397	!
8398	!-- See NOTE 6778 above
8399	IF ( zdirs(k) <= horizon ) CYCLE
8400
8401	zexit = origin(1) + zdirs(k) * rt2_track_dist(i-1)
8402	IF ( zexit <= zbottom .OR. zexit >= ztop ) CYCLE
8403
8404	zsgn = -INT(SIGN(1._wp, zdirs(k)), iwp)
8405	rt2_dist(1) = 0._wp
8406	IF ( zdirs(k) == 0._wp ) THEN ! ray is exactly horizontal
8407	nz = 2
8408	rt2_dist(nz) = SQRT(dxxyy)
8409	iz = NINT(zexit, iwp)
8410	ELSE
8411	zorig = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop)
8412
8413	zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! because it must be greater than orig
8414	zb1 = CEILING(zexit * zsgn - .5_wp) - 1 ! because it must be smaller than exit
8415	nz = MAX(zb1 - zb0 + 3, 2)
8416	rt2_dist(nz) = SQRT(((zexit-zorig)dz(1))*2 + dxxyy)
8417	qdist = rt2_dist(nz) / (zexit-zorig)
8418	rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/)
8419	iz = zb0 * zsgn
8420	ENDIF
8421
8422	DO l = 2, nz
8423	IF ( rt2_track_lad(iz, i) > 0._wp ) THEN
8424	curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1)))
8425
8426	IF ( create_csf ) THEN
8427	ncsfl = ncsfl + 1
8428	acsf(ncsfl)%ip = ip
8429	acsf(ncsfl)%itx = rt2_track(2,i)
8430	acsf(ncsfl)%ity = rt2_track(1,i)
8431	acsf(ncsfl)%itz = iz
8432	IF ( itarget(k) /= -1 ) STOP 1 !FIXME remove after test
8433	acsf(ncsfl)%isurfs = -1
8434	acsf(ncsfl)%rcvf = (1._wp - curtrans)transparency(k)aorig*vffrac(k)
8435	ENDIF ! create_csf
8436
8437	transparency(k) = transparency(k) * curtrans
8438	ENDIF
8439	iz = iz + zsgn
8440	ENDDO ! l = 1, nz - 1
8441	ENDDO ! k = 1, nrays
8442	ENDDO ! i = 1, ntrack
8443	ENDIF ! plant_canopy
8444
8445	IF ( .NOT. (rad_angular_discretization .AND. calc_svf) ) THEN
8446	!
8447	!-- Just update lowest_free_ray according to horizon
8448	DO WHILE ( lowest_free_ray > 0 )
8449	IF ( zdirs(lowest_free_ray) > horizon ) EXIT
8450	lowest_free_ray = lowest_free_ray - 1
8451	ENDDO
8452	ENDIF
8453
8454	CONTAINS
8455
8456	SUBROUTINE request_itarget( d, z, y, x, isurfl, iproc )
8457
8458	INTEGER(iwp), INTENT(in) :: d, z, y, x
8459	INTEGER(iwp), TARGET, INTENT(out) :: isurfl
8460	INTEGER(iwp), INTENT(out) :: iproc
8461	#if defined( __parallel )
8462	#else
8463	INTEGER(iwp) :: target_displ !< index of the grid in the local gridsurf array
8464	#endif
8465	INTEGER(iwp) :: px, py !< number of processors in x and y direction
8466	!< before the processor in the question
8467	#if defined( __parallel )
8468	INTEGER(KIND=MPI_ADDRESS_KIND) :: target_displ !< index of the grid in the local gridsurf array
8469
8470	!
8471	!-- Calculate target processor and index in the remote local target gridsurf array
8472	px = x / nnx
8473	py = y / nny
8474	iproc = px * pdims(2) + py
8475	target_displ = ((x-pxnnx) nny + y - pynny ) nz_urban * nsurf_type_u +&
8476	( z-nz_urban_b ) * nsurf_type_u + d
8477	!
8478	!-- Send MPI_Get request to obtain index target_surfl(i)
8479	CALL MPI_GET( isurfl, 1, MPI_INTEGER, iproc, target_displ, &
8480	1, MPI_INTEGER, win_gridsurf, ierr)
8481	IF ( ierr /= 0 ) THEN
8482	WRITE( 9,* ) 'Error MPI_Get3:', ierr, isurfl, iproc, target_displ, &
8483	win_gridsurf
8484	FLUSH( 9 )
8485	ENDIF
8486	#else
8487	!-- set index target_surfl(i)
8488	isurfl = gridsurf(d,z,y,x)
8489	#endif
8490
8491	END SUBROUTINE request_itarget
8492
8493	END SUBROUTINE raytrace_2d
8494
8495
8496	!------------------------------------------------------------------------------!
8497	!
8498	! Description:
8499	! ------------
8500	!> Calculates apparent solar positions for all timesteps and stores discretized
8501	!> positions.
8502	!------------------------------------------------------------------------------!
8503	SUBROUTINE radiation_presimulate_solar_pos
8504
8505	IMPLICIT NONE
8506
8507	INTEGER(iwp) :: it, i, j
8508	INTEGER(iwp) :: day_of_month_prev,month_of_year_prev
8509	REAL(wp) :: tsrp_prev
8510	REAL(wp) :: simulated_time_prev
8511	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir_tmp !< dsidir_tmp[:,i] = unit vector of i-th
8512	!< appreant solar direction
8513
8514	ALLOCATE ( dsidir_rev(0:raytrace_discrete_elevs/2-1, &
8515	0:raytrace_discrete_azims-1) )
8516	dsidir_rev(:,:) = -1
8517	ALLOCATE ( dsidir_tmp(3, &
8518	raytrace_discrete_elevs/2*raytrace_discrete_azims) )
8519	ndsidir = 0
8520
8521	!
8522	!-- We will artificialy update time_since_reference_point and return to
8523	!-- true value later
8524	tsrp_prev = time_since_reference_point
8525	simulated_time_prev = simulated_time
8526	day_of_month_prev = day_of_month
8527	month_of_year_prev = month_of_year
8528	sun_direction = .TRUE.
8529
8530	!
8531	!-- initialize the simulated_time
8532	simulated_time = 0._wp
8533	!
8534	!-- Process spinup time if configured
8535	IF ( spinup_time > 0._wp ) THEN
8536	DO it = 0, CEILING(spinup_time / dt_spinup)
8537	time_since_reference_point = -spinup_time + REAL(it, wp) * dt_spinup
8538	simulated_time = simulated_time + dt_spinup
8539	CALL simulate_pos
8540	ENDDO
8541	ENDIF
8542	!
8543	!-- Process simulation time
8544	DO it = 0, CEILING(( end_time - spinup_time ) / dt_radiation)
8545	time_since_reference_point = REAL(it, wp) * dt_radiation
8546	simulated_time = simulated_time + dt_radiation
8547	CALL simulate_pos
8548	ENDDO
8549	!
8550	!-- Return date and time to its original values
8551	time_since_reference_point = tsrp_prev
8552	simulated_time = simulated_time_prev
8553	day_of_month = day_of_month_prev
8554	month_of_year = month_of_year_prev
8555	CALL init_date_and_time
8556
8557	!-- Allocate global vars which depend on ndsidir
8558	ALLOCATE ( dsidir ( 3, ndsidir ) )
8559	dsidir(:,:) = dsidir_tmp(:, 1:ndsidir)
8560	DEALLOCATE ( dsidir_tmp )
8561
8562	ALLOCATE ( dsitrans(nsurfl, ndsidir) )
8563	ALLOCATE ( dsitransc(npcbl, ndsidir) )
8564	IF ( nmrtbl > 0 ) ALLOCATE ( mrtdsit(nmrtbl, ndsidir) )
8565
8566	WRITE ( message_string, * ) 'Precalculated', ndsidir, ' solar positions', &
8567	' from', it, ' timesteps.'
8568	CALL message( 'radiation_presimulate_solar_pos', 'UI0013', 0, 0, 0, 6, 0 )
8569
8570	CONTAINS
8571
8572	!------------------------------------------------------------------------!
8573	! Description:
8574	! ------------
8575	!> Simuates a single position
8576	!------------------------------------------------------------------------!
8577	SUBROUTINE simulate_pos
8578	IMPLICIT NONE
8579	!
8580	!-- Update apparent solar position based on modified t_s_r_p
8581	CALL calc_zenith
8582	IF ( cos_zenith > 0 ) THEN
8583	!--
8584	!-- Identify solar direction vector (discretized number) 1)
8585	i = MODULO(NINT(ATAN2(sun_dir_lon, sun_dir_lat) &
8586	/ (2._wppi) raytrace_discrete_azims-.5_wp, iwp), &
8587	raytrace_discrete_azims)
8588	j = FLOOR(ACOS(cos_zenith) / pi * raytrace_discrete_elevs)
8589	IF ( dsidir_rev(j, i) == -1 ) THEN
8590	ndsidir = ndsidir + 1
8591	dsidir_tmp(:, ndsidir) = &
8592	(/ COS((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs), &
8593	SIN((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs) &
8594	* COS((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims), &
8595	SIN((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs) &
8596	* SIN((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims) /)
8597	dsidir_rev(j, i) = ndsidir
8598	ENDIF
8599	ENDIF
8600	END SUBROUTINE simulate_pos
8601
8602	END SUBROUTINE radiation_presimulate_solar_pos
8603
8604
8605
8606	!------------------------------------------------------------------------------!
8607	! Description:
8608	! ------------
8609	!> Determines whether two faces are oriented towards each other. Since the
8610	!> surfaces follow the gird box surfaces, it checks first whether the two surfaces
8611	!> are directed in the same direction, then it checks if the two surfaces are
8612	!> located in confronted direction but facing away from each other, e.g. <--\| \|-->
8613	!------------------------------------------------------------------------------!
8614	PURE LOGICAL FUNCTION surface_facing(x, y, z, d, x2, y2, z2, d2)
8615	IMPLICIT NONE
8616	INTEGER(iwp), INTENT(in) :: x, y, z, d, x2, y2, z2, d2
8617
8618	surface_facing = .FALSE.
8619
8620	!-- first check: are the two surfaces directed in the same direction
8621	IF ( (d==iup_u .OR. d==iup_l ) &
8622	.AND. (d2==iup_u .OR. d2==iup_l) ) RETURN
8623	IF ( (d==isouth_u .OR. d==isouth_l ) &
8624	.AND. (d2==isouth_u .OR. d2==isouth_l) ) RETURN
8625	IF ( (d==inorth_u .OR. d==inorth_l ) &
8626	.AND. (d2==inorth_u .OR. d2==inorth_l) ) RETURN
8627	IF ( (d==iwest_u .OR. d==iwest_l ) &
8628	.AND. (d2==iwest_u .OR. d2==iwest_l ) ) RETURN
8629	IF ( (d==ieast_u .OR. d==ieast_l ) &
8630	.AND. (d2==ieast_u .OR. d2==ieast_l ) ) RETURN
8631
8632	!-- second check: are surfaces facing away from each other
8633	SELECT CASE (d)
8634	CASE (iup_u, iup_l) !< upward facing surfaces
8635	IF ( z2 < z ) RETURN
8636	CASE (isouth_u, isouth_l) !< southward facing surfaces
8637	IF ( y2 > y ) RETURN
8638	CASE (inorth_u, inorth_l) !< northward facing surfaces
8639	IF ( y2 < y ) RETURN
8640	CASE (iwest_u, iwest_l) !< westward facing surfaces
8641	IF ( x2 > x ) RETURN
8642	CASE (ieast_u, ieast_l) !< eastward facing surfaces
8643	IF ( x2 < x ) RETURN
8644	END SELECT
8645
8646	SELECT CASE (d2)
8647	CASE (iup_u) !< ground, roof
8648	IF ( z < z2 ) RETURN
8649	CASE (isouth_u, isouth_l) !< south facing
8650	IF ( y > y2 ) RETURN
8651	CASE (inorth_u, inorth_l) !< north facing
8652	IF ( y < y2 ) RETURN
8653	CASE (iwest_u, iwest_l) !< west facing
8654	IF ( x > x2 ) RETURN
8655	CASE (ieast_u, ieast_l) !< east facing
8656	IF ( x < x2 ) RETURN
8657	CASE (-1)
8658	CONTINUE
8659	END SELECT
8660
8661	surface_facing = .TRUE.
8662
8663	END FUNCTION surface_facing
8664
8665
8666	!------------------------------------------------------------------------------!
8667	!
8668	! Description:
8669	! ------------
8670	!> Reads svf, svfsurf, csf, csfsurf and mrt factors data from saved file
8671	!> SVF means sky view factors and CSF means canopy sink factors
8672	!------------------------------------------------------------------------------!
8673	SUBROUTINE radiation_read_svf
8674
8675	IMPLICIT NONE
8676
8677	CHARACTER(rad_version_len) :: rad_version_field
8678
8679	INTEGER(iwp) :: i
8680	INTEGER(iwp) :: ndsidir_from_file = 0
8681	INTEGER(iwp) :: npcbl_from_file = 0
8682	INTEGER(iwp) :: nsurfl_from_file = 0
8683	INTEGER(iwp) :: nmrtbl_from_file = 0
8684
8685
8686	CALL location_message( 'reading view factors for radiation interaction', 'start' )
8687
8688	DO i = 0, io_blocks-1
8689	IF ( i == io_group ) THEN
8690
8691	!
8692	!-- numprocs_previous_run is only known in case of reading restart
8693	!-- data. If a new initial run which reads svf data is started the
8694	!-- following query will be skipped
8695	IF ( initializing_actions == 'read_restart_data' ) THEN
8696
8697	IF ( numprocs_previous_run /= numprocs ) THEN
8698	WRITE( message_string, * ) 'A different number of ', &
8699	'processors between the run ', &
8700	'that has written the svf data ',&
8701	'and the one that will read it ',&
8702	'is not allowed'
8703	CALL message( 'check_open', 'PA0491', 1, 2, 0, 6, 0 )
8704	ENDIF
8705
8706	ENDIF
8707
8708	!
8709	!-- Open binary file
8710	CALL check_open( 88 )
8711
8712	!
8713	!-- read and check version
8714	READ ( 88 ) rad_version_field
8715	IF ( TRIM(rad_version_field) /= TRIM(rad_version) ) THEN
8716	WRITE( message_string, * ) 'Version of binary SVF file "', &
8717	TRIM(rad_version_field), '" does not match ', &
8718	'the version of model "', TRIM(rad_version), '"'
8719	CALL message( 'radiation_read_svf', 'PA0482', 1, 2, 0, 6, 0 )
8720	ENDIF
8721
8722	!
8723	!-- read nsvfl, ncsfl, nsurfl, nmrtf
8724	READ ( 88 ) nsvfl, ncsfl, nsurfl_from_file, npcbl_from_file, &
8725	ndsidir_from_file, nmrtbl_from_file, nmrtf
8726
8727	IF ( nsvfl < 0 .OR. ncsfl < 0 ) THEN
8728	WRITE( message_string, * ) 'Wrong number of SVF or CSF'
8729	CALL message( 'radiation_read_svf', 'PA0483', 1, 2, 0, 6, 0 )
8730	ELSE
8731	WRITE(debug_string,*) 'Number of SVF, CSF, and nsurfl ', &
8732	'to read', nsvfl, ncsfl, &
8733	nsurfl_from_file
8734	IF ( debug_output ) CALL debug_message( debug_string, 'info' )
8735	ENDIF
8736
8737	IF ( nsurfl_from_file /= nsurfl ) THEN
8738	WRITE( message_string, * ) 'nsurfl from SVF file does not ', &
8739	'match calculated nsurfl from ', &
8740	'radiation_interaction_init'
8741	CALL message( 'radiation_read_svf', 'PA0490', 1, 2, 0, 6, 0 )
8742	ENDIF
8743
8744	IF ( npcbl_from_file /= npcbl ) THEN
8745	WRITE( message_string, * ) 'npcbl from SVF file does not ', &
8746	'match calculated npcbl from ', &
8747	'radiation_interaction_init'
8748	CALL message( 'radiation_read_svf', 'PA0493', 1, 2, 0, 6, 0 )
8749	ENDIF
8750
8751	IF ( ndsidir_from_file /= ndsidir ) THEN
8752	WRITE( message_string, * ) 'ndsidir from SVF file does not ', &
8753	'match calculated ndsidir from ', &
8754	'radiation_presimulate_solar_pos'
8755	CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 )
8756	ENDIF
8757	IF ( nmrtbl_from_file /= nmrtbl ) THEN
8758	WRITE( message_string, * ) 'nmrtbl from SVF file does not ', &
8759	'match calculated nmrtbl from ', &
8760	'radiation_interaction_init'
8761	CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 )
8762	ELSE
8763	WRITE(debug_string,*) 'Number of nmrtf to read ', nmrtf
8764	IF ( debug_output ) CALL debug_message( debug_string, 'info' )
8765	ENDIF
8766
8767	!
8768	!-- Arrays skyvf, skyvft, dsitrans and dsitransc are allready
8769	!-- allocated in radiation_interaction_init and
8770	!-- radiation_presimulate_solar_pos
8771	IF ( nsurfl > 0 ) THEN
8772	READ(88) skyvf
8773	READ(88) skyvft
8774	READ(88) dsitrans
8775	ENDIF
8776
8777	IF ( plant_canopy .AND. npcbl > 0 ) THEN
8778	READ ( 88 ) dsitransc
8779	ENDIF
8780
8781	!
8782	!-- The allocation of svf, svfsurf, csf, csfsurf, mrtf, mrtft, and
8783	!-- mrtfsurf happens in routine radiation_calc_svf which is not
8784	!-- called if the program enters radiation_read_svf. Therefore
8785	!-- these arrays has to allocate in the following
8786	IF ( nsvfl > 0 ) THEN
8787	ALLOCATE( svf(ndsvf,nsvfl) )
8788	ALLOCATE( svfsurf(idsvf,nsvfl) )
8789	READ(88) svf
8790	READ(88) svfsurf
8791	ENDIF
8792
8793	IF ( plant_canopy .AND. ncsfl > 0 ) THEN
8794	ALLOCATE( csf(ndcsf,ncsfl) )
8795	ALLOCATE( csfsurf(idcsf,ncsfl) )
8796	READ(88) csf
8797	READ(88) csfsurf
8798	ENDIF
8799
8800	IF ( nmrtbl > 0 ) THEN
8801	READ(88) mrtsky
8802	READ(88) mrtskyt
8803	READ(88) mrtdsit
8804	ENDIF
8805
8806	IF ( nmrtf > 0 ) THEN
8807	ALLOCATE ( mrtf(nmrtf) )
8808	ALLOCATE ( mrtft(nmrtf) )
8809	ALLOCATE ( mrtfsurf(2,nmrtf) )
8810	READ(88) mrtf
8811	READ(88) mrtft
8812	READ(88) mrtfsurf
8813	ENDIF
8814
8815	!
8816	!-- Close binary file
8817	CALL close_file( 88 )
8818
8819	ENDIF
8820	#if defined( __parallel )
8821	CALL MPI_BARRIER( comm2d, ierr )
8822	#endif
8823	ENDDO
8824
8825	CALL location_message( 'reading view factors for radiation interaction', 'finished' )
8826
8827
8828	END SUBROUTINE radiation_read_svf
8829
8830
8831	!------------------------------------------------------------------------------!
8832	!
8833	! Description:
8834	! ------------
8835	!> Subroutine stores svf, svfsurf, csf, csfsurf and mrt data to a file.
8836	!------------------------------------------------------------------------------!
8837	SUBROUTINE radiation_write_svf
8838
8839	IMPLICIT NONE
8840
8841	INTEGER(iwp) :: i
8842
8843
8844	CALL location_message( 'writing view factors for radiation interaction', 'start' )
8845
8846	DO i = 0, io_blocks-1
8847	IF ( i == io_group ) THEN
8848	!
8849	!-- Open binary file
8850	CALL check_open( 89 )
8851
8852	WRITE ( 89 ) rad_version
8853	WRITE ( 89 ) nsvfl, ncsfl, nsurfl, npcbl, ndsidir, nmrtbl, nmrtf
8854	IF ( nsurfl > 0 ) THEN
8855	WRITE ( 89 ) skyvf
8856	WRITE ( 89 ) skyvft
8857	WRITE ( 89 ) dsitrans
8858	ENDIF
8859	IF ( npcbl > 0 ) THEN
8860	WRITE ( 89 ) dsitransc
8861	ENDIF
8862	IF ( nsvfl > 0 ) THEN
8863	WRITE ( 89 ) svf
8864	WRITE ( 89 ) svfsurf
8865	ENDIF
8866	IF ( plant_canopy .AND. ncsfl > 0 ) THEN
8867	WRITE ( 89 ) csf
8868	WRITE ( 89 ) csfsurf
8869	ENDIF
8870	IF ( nmrtbl > 0 ) THEN
8871	WRITE ( 89 ) mrtsky
8872	WRITE ( 89 ) mrtskyt
8873	WRITE ( 89 ) mrtdsit
8874	ENDIF
8875	IF ( nmrtf > 0 ) THEN
8876	WRITE ( 89 ) mrtf
8877	WRITE ( 89 ) mrtft
8878	WRITE ( 89 ) mrtfsurf
8879	ENDIF
8880	!
8881	!-- Close binary file
8882	CALL close_file( 89 )
8883
8884	ENDIF
8885	#if defined( __parallel )
8886	CALL MPI_BARRIER( comm2d, ierr )
8887	#endif
8888	ENDDO
8889
8890	CALL location_message( 'writing view factors for radiation interaction', 'finished' )
8891
8892
8893	END SUBROUTINE radiation_write_svf
8894
8895
8896	!------------------------------------------------------------------------------!
8897	!
8898	! Description:
8899	! ------------
8900	!> Block of auxiliary subroutines:
8901	!> 1. quicksort and corresponding comparison
8902	!> 2. merge_and_grow_csf for implementation of "dynamical growing"
8903	!> array for csf
8904	!------------------------------------------------------------------------------!
8905	!-- quicksort.f --f90--
8906	!-- Author: t-nissie, adaptation J.Resler
8907	!-- License: GPLv3
8908	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
8909	RECURSIVE SUBROUTINE quicksort_itarget(itarget, vffrac, ztransp, first, last)
8910	IMPLICIT NONE
8911	INTEGER(iwp), DIMENSION(:), INTENT(INOUT) :: itarget
8912	REAL(wp), DIMENSION(:), INTENT(INOUT) :: vffrac, ztransp
8913	INTEGER(iwp), INTENT(IN) :: first, last
8914	INTEGER(iwp) :: x, t
8915	INTEGER(iwp) :: i, j
8916	REAL(wp) :: tr
8917
8918	IF ( first>=last ) RETURN
8919	x = itarget((first+last)/2)
8920	i = first
8921	j = last
8922	DO
8923	DO WHILE ( itarget(i) < x )
8924	i=i+1
8925	ENDDO
8926	DO WHILE ( x < itarget(j) )
8927	j=j-1
8928	ENDDO
8929	IF ( i >= j ) EXIT
8930	t = itarget(i); itarget(i) = itarget(j); itarget(j) = t
8931	tr = vffrac(i); vffrac(i) = vffrac(j); vffrac(j) = tr
8932	tr = ztransp(i); ztransp(i) = ztransp(j); ztransp(j) = tr
8933	i=i+1
8934	j=j-1
8935	ENDDO
8936	IF ( first < i-1 ) CALL quicksort_itarget(itarget, vffrac, ztransp, first, i-1)
8937	IF ( j+1 < last ) CALL quicksort_itarget(itarget, vffrac, ztransp, j+1, last)
8938	END SUBROUTINE quicksort_itarget
8939
8940	PURE FUNCTION svf_lt(svf1,svf2) result (res)
8941	TYPE (t_svf), INTENT(in) :: svf1,svf2
8942	LOGICAL :: res
8943	IF ( svf1%isurflt < svf2%isurflt .OR. &
8944	(svf1%isurflt == svf2%isurflt .AND. svf1%isurfs < svf2%isurfs) ) THEN
8945	res = .TRUE.
8946	ELSE
8947	res = .FALSE.
8948	ENDIF
8949	END FUNCTION svf_lt
8950
8951
8952	!-- quicksort.f --f90--
8953	!-- Author: t-nissie, adaptation J.Resler
8954	!-- License: GPLv3
8955	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
8956	RECURSIVE SUBROUTINE quicksort_svf(svfl, first, last)
8957	IMPLICIT NONE
8958	TYPE(t_svf), DIMENSION(:), INTENT(INOUT) :: svfl
8959	INTEGER(iwp), INTENT(IN) :: first, last
8960	TYPE(t_svf) :: x, t
8961	INTEGER(iwp) :: i, j
8962
8963	IF ( first>=last ) RETURN
8964	x = svfl( (first+last) / 2 )
8965	i = first
8966	j = last
8967	DO
8968	DO while ( svf_lt(svfl(i),x) )
8969	i=i+1
8970	ENDDO
8971	DO while ( svf_lt(x,svfl(j)) )
8972	j=j-1
8973	ENDDO
8974	IF ( i >= j ) EXIT
8975	t = svfl(i); svfl(i) = svfl(j); svfl(j) = t
8976	i=i+1
8977	j=j-1
8978	ENDDO
8979	IF ( first < i-1 ) CALL quicksort_svf(svfl, first, i-1)
8980	IF ( j+1 < last ) CALL quicksort_svf(svfl, j+1, last)
8981	END SUBROUTINE quicksort_svf
8982
8983	PURE FUNCTION csf_lt(csf1,csf2) result (res)
8984	TYPE (t_csf), INTENT(in) :: csf1,csf2
8985	LOGICAL :: res
8986	IF ( csf1%ip < csf2%ip .OR. &
8987	(csf1%ip == csf2%ip .AND. csf1%itx < csf2%itx) .OR. &
8988	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity < csf2%ity) .OR. &
8989	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. &
8990	csf1%itz < csf2%itz) .OR. &
8991	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. &
8992	csf1%itz == csf2%itz .AND. csf1%isurfs < csf2%isurfs) ) THEN
8993	res = .TRUE.
8994	ELSE
8995	res = .FALSE.
8996	ENDIF
8997	END FUNCTION csf_lt
8998
8999
9000	!-- quicksort.f --f90--
9001	!-- Author: t-nissie, adaptation J.Resler
9002	!-- License: GPLv3
9003	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9004	RECURSIVE SUBROUTINE quicksort_csf(csfl, first, last)
9005	IMPLICIT NONE
9006	TYPE(t_csf), DIMENSION(:), INTENT(INOUT) :: csfl
9007	INTEGER(iwp), INTENT(IN) :: first, last
9008	TYPE(t_csf) :: x, t
9009	INTEGER(iwp) :: i, j
9010
9011	IF ( first>=last ) RETURN
9012	x = csfl( (first+last)/2 )
9013	i = first
9014	j = last
9015	DO
9016	DO while ( csf_lt(csfl(i),x) )
9017	i=i+1
9018	ENDDO
9019	DO while ( csf_lt(x,csfl(j)) )
9020	j=j-1
9021	ENDDO
9022	IF ( i >= j ) EXIT
9023	t = csfl(i); csfl(i) = csfl(j); csfl(j) = t
9024	i=i+1
9025	j=j-1
9026	ENDDO
9027	IF ( first < i-1 ) CALL quicksort_csf(csfl, first, i-1)
9028	IF ( j+1 < last ) CALL quicksort_csf(csfl, j+1, last)
9029	END SUBROUTINE quicksort_csf
9030
9031
9032	!------------------------------------------------------------------------------!
9033	!
9034	! Description:
9035	! ------------
9036	!> Grows the CSF array exponentially after it is full. During that, the ray
9037	!> canopy sink factors with common source face and target plant canopy grid
9038	!> cell are merged together so that the size doesn't grow out of control.
9039	!------------------------------------------------------------------------------!
9040	SUBROUTINE merge_and_grow_csf(newsize)
9041	INTEGER(iwp), INTENT(in) :: newsize !< new array size after grow, must be >= ncsfl
9042	!< or -1 to shrink to minimum
9043	INTEGER(iwp) :: iread, iwrite
9044	TYPE(t_csf), DIMENSION(:), POINTER :: acsfnew
9045
9046
9047	IF ( newsize == -1 ) THEN
9048	!-- merge in-place
9049	acsfnew => acsf
9050	ELSE
9051	!-- allocate new array
9052	IF ( mcsf == 0 ) THEN
9053	ALLOCATE( acsf1(newsize) )
9054	acsfnew => acsf1
9055	ELSE
9056	ALLOCATE( acsf2(newsize) )
9057	acsfnew => acsf2
9058	ENDIF
9059	ENDIF
9060
9061	IF ( ncsfl >= 1 ) THEN
9062	!-- sort csf in place (quicksort)
9063	CALL quicksort_csf(acsf,1,ncsfl)
9064
9065	!-- while moving to a new array, aggregate canopy sink factor records with identical box & source
9066	acsfnew(1) = acsf(1)
9067	iwrite = 1
9068	DO iread = 2, ncsfl
9069	!-- here acsf(kcsf) already has values from acsf(icsf)
9070	IF ( acsfnew(iwrite)%itx == acsf(iread)%itx &
9071	.AND. acsfnew(iwrite)%ity == acsf(iread)%ity &
9072	.AND. acsfnew(iwrite)%itz == acsf(iread)%itz &
9073	.AND. acsfnew(iwrite)%isurfs == acsf(iread)%isurfs ) THEN
9074
9075	acsfnew(iwrite)%rcvf = acsfnew(iwrite)%rcvf + acsf(iread)%rcvf
9076	!-- advance reading index, keep writing index
9077	ELSE
9078	!-- not identical, just advance and copy
9079	iwrite = iwrite + 1
9080	acsfnew(iwrite) = acsf(iread)
9081	ENDIF
9082	ENDDO
9083	ncsfl = iwrite
9084	ENDIF
9085
9086	IF ( newsize == -1 ) THEN
9087	!-- allocate new array and copy shrinked data
9088	IF ( mcsf == 0 ) THEN
9089	ALLOCATE( acsf1(ncsfl) )
9090	acsf1(1:ncsfl) = acsf2(1:ncsfl)
9091	ELSE
9092	ALLOCATE( acsf2(ncsfl) )
9093	acsf2(1:ncsfl) = acsf1(1:ncsfl)
9094	ENDIF
9095	ENDIF
9096
9097	!-- deallocate old array
9098	IF ( mcsf == 0 ) THEN
9099	mcsf = 1
9100	acsf => acsf1
9101	DEALLOCATE( acsf2 )
9102	ELSE
9103	mcsf = 0
9104	acsf => acsf2
9105	DEALLOCATE( acsf1 )
9106	ENDIF
9107	ncsfla = newsize
9108
9109	IF ( debug_output ) THEN
9110	WRITE( debug_string, '(A,2I12)' ) 'Grow acsf2:', ncsfl, ncsfla
9111	CALL debug_message( debug_string, 'info' )
9112	ENDIF
9113
9114	END SUBROUTINE merge_and_grow_csf
9115
9116
9117	!-- quicksort.f --f90--
9118	!-- Author: t-nissie, adaptation J.Resler
9119	!-- License: GPLv3
9120	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9121	RECURSIVE SUBROUTINE quicksort_csf2(kpcsflt, pcsflt, first, last)
9122	IMPLICIT NONE
9123	INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT) :: kpcsflt
9124	REAL(wp), DIMENSION(:,:), INTENT(INOUT) :: pcsflt
9125	INTEGER(iwp), INTENT(IN) :: first, last
9126	REAL(wp), DIMENSION(ndcsf) :: t2
9127	INTEGER(iwp), DIMENSION(kdcsf) :: x, t1
9128	INTEGER(iwp) :: i, j
9129
9130	IF ( first>=last ) RETURN
9131	x = kpcsflt(:, (first+last)/2 )
9132	i = first
9133	j = last
9134	DO
9135	DO while ( csf_lt2(kpcsflt(:,i),x) )
9136	i=i+1
9137	ENDDO
9138	DO while ( csf_lt2(x,kpcsflt(:,j)) )
9139	j=j-1
9140	ENDDO
9141	IF ( i >= j ) EXIT
9142	t1 = kpcsflt(:,i); kpcsflt(:,i) = kpcsflt(:,j); kpcsflt(:,j) = t1
9143	t2 = pcsflt(:,i); pcsflt(:,i) = pcsflt(:,j); pcsflt(:,j) = t2
9144	i=i+1
9145	j=j-1
9146	ENDDO
9147	IF ( first < i-1 ) CALL quicksort_csf2(kpcsflt, pcsflt, first, i-1)
9148	IF ( j+1 < last ) CALL quicksort_csf2(kpcsflt, pcsflt, j+1, last)
9149	END SUBROUTINE quicksort_csf2
9150
9151
9152	PURE FUNCTION csf_lt2(item1, item2) result(res)
9153	INTEGER(iwp), DIMENSION(kdcsf), INTENT(in) :: item1, item2
9154	LOGICAL :: res
9155	res = ( (item1(3) < item2(3)) &
9156	.OR. (item1(3) == item2(3) .AND. item1(2) < item2(2)) &
9157	.OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) < item2(1)) &
9158	.OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) == item2(1) &
9159	.AND. item1(4) < item2(4)) )
9160	END FUNCTION csf_lt2
9161
9162	PURE FUNCTION searchsorted(athresh, val) result(ind)
9163	REAL(wp), DIMENSION(:), INTENT(IN) :: athresh
9164	REAL(wp), INTENT(IN) :: val
9165	INTEGER(iwp) :: ind
9166	INTEGER(iwp) :: i
9167
9168	DO i = LBOUND(athresh, 1), UBOUND(athresh, 1)
9169	IF ( val < athresh(i) ) THEN
9170	ind = i - 1
9171	RETURN
9172	ENDIF
9173	ENDDO
9174	ind = UBOUND(athresh, 1)
9175	END FUNCTION searchsorted
9176
9177
9178	!------------------------------------------------------------------------------!
9179	!
9180	! Description:
9181	! ------------
9182	!> Subroutine for averaging 3D data
9183	!------------------------------------------------------------------------------!
9184	SUBROUTINE radiation_3d_data_averaging( mode, variable )
9185
9186
9187	USE control_parameters
9188
9189	USE indices
9190
9191	USE kinds
9192
9193	IMPLICIT NONE
9194
9195	CHARACTER (LEN=*) :: mode !<
9196	CHARACTER (LEN=*) :: variable !<
9197
9198	LOGICAL :: match_lsm !< flag indicating natural-type surface
9199	LOGICAL :: match_usm !< flag indicating urban-type surface
9200
9201	INTEGER(iwp) :: i !<
9202	INTEGER(iwp) :: j !<
9203	INTEGER(iwp) :: k !<
9204	INTEGER(iwp) :: l, m !< index of current surface element
9205
9206	INTEGER(iwp) :: ids, idsint_u, idsint_l, isurf
9207	CHARACTER(LEN=varnamelength) :: var
9208
9209	!-- find the real name of the variable
9210	ids = -1
9211	l = -1
9212	var = TRIM(variable)
9213	DO i = 0, nd-1
9214	k = len(TRIM(var))
9215	j = len(TRIM(dirname(i)))
9216	IF ( k-j+1 >= 1_iwp ) THEN
9217	IF ( TRIM(var(k-j+1:k)) == TRIM(dirname(i)) ) THEN
9218	ids = i
9219	idsint_u = dirint_u(ids)
9220	idsint_l = dirint_l(ids)
9221	var = var(:k-j)
9222	EXIT
9223	ENDIF
9224	ENDIF
9225	ENDDO
9226	IF ( ids == -1 ) THEN
9227	var = TRIM(variable)
9228	ENDIF
9229
9230	IF ( mode == 'allocate' ) THEN
9231
9232	SELECT CASE ( TRIM( var ) )
9233	!-- block of large scale (e.g. RRTMG) radiation output variables
9234	CASE ( 'rad_net*' )
9235	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
9236	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
9237	ENDIF
9238	rad_net_av = 0.0_wp
9239
9240	CASE ( 'rad_lw_in*' )
9241	IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
9242	ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
9243	ENDIF
9244	rad_lw_in_xy_av = 0.0_wp
9245
9246	CASE ( 'rad_lw_out*' )
9247	IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
9248	ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
9249	ENDIF
9250	rad_lw_out_xy_av = 0.0_wp
9251
9252	CASE ( 'rad_sw_in*' )
9253	IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
9254	ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
9255	ENDIF
9256	rad_sw_in_xy_av = 0.0_wp
9257
9258	CASE ( 'rad_sw_out*' )
9259	IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
9260	ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
9261	ENDIF
9262	rad_sw_out_xy_av = 0.0_wp
9263
9264	CASE ( 'rad_lw_in' )
9265	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
9266	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9267	ENDIF
9268	rad_lw_in_av = 0.0_wp
9269
9270	CASE ( 'rad_lw_out' )
9271	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
9272	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9273	ENDIF
9274	rad_lw_out_av = 0.0_wp
9275
9276	CASE ( 'rad_lw_cs_hr' )
9277	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
9278	ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9279	ENDIF
9280	rad_lw_cs_hr_av = 0.0_wp
9281
9282	CASE ( 'rad_lw_hr' )
9283	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
9284	ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9285	ENDIF
9286	rad_lw_hr_av = 0.0_wp
9287
9288	CASE ( 'rad_sw_in' )
9289	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
9290	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9291	ENDIF
9292	rad_sw_in_av = 0.0_wp
9293
9294	CASE ( 'rad_sw_out' )
9295	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
9296	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9297	ENDIF
9298	rad_sw_out_av = 0.0_wp
9299
9300	CASE ( 'rad_sw_cs_hr' )
9301	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
9302	ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9303	ENDIF
9304	rad_sw_cs_hr_av = 0.0_wp
9305
9306	CASE ( 'rad_sw_hr' )
9307	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
9308	ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9309	ENDIF
9310	rad_sw_hr_av = 0.0_wp
9311
9312	!-- block of RTM output variables
9313	CASE ( 'rtm_rad_net' )
9314	!-- array of complete radiation balance
9315	IF ( .NOT. ALLOCATED(surfradnet_av) ) THEN
9316	ALLOCATE( surfradnet_av(nsurfl) )
9317	surfradnet_av = 0.0_wp
9318	ENDIF
9319
9320	CASE ( 'rtm_rad_insw' )
9321	!-- array of sw radiation falling to surface after i-th reflection
9322	IF ( .NOT. ALLOCATED(surfinsw_av) ) THEN
9323	ALLOCATE( surfinsw_av(nsurfl) )
9324	surfinsw_av = 0.0_wp
9325	ENDIF
9326
9327	CASE ( 'rtm_rad_inlw' )
9328	!-- array of lw radiation falling to surface after i-th reflection
9329	IF ( .NOT. ALLOCATED(surfinlw_av) ) THEN
9330	ALLOCATE( surfinlw_av(nsurfl) )
9331	surfinlw_av = 0.0_wp
9332	ENDIF
9333
9334	CASE ( 'rtm_rad_inswdir' )
9335	!-- array of direct sw radiation falling to surface from sun
9336	IF ( .NOT. ALLOCATED(surfinswdir_av) ) THEN
9337	ALLOCATE( surfinswdir_av(nsurfl) )
9338	surfinswdir_av = 0.0_wp
9339	ENDIF
9340
9341	CASE ( 'rtm_rad_inswdif' )
9342	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
9343	IF ( .NOT. ALLOCATED(surfinswdif_av) ) THEN
9344	ALLOCATE( surfinswdif_av(nsurfl) )
9345	surfinswdif_av = 0.0_wp
9346	ENDIF
9347
9348	CASE ( 'rtm_rad_inswref' )
9349	!-- array of sw radiation falling to surface from reflections
9350	IF ( .NOT. ALLOCATED(surfinswref_av) ) THEN
9351	ALLOCATE( surfinswref_av(nsurfl) )
9352	surfinswref_av = 0.0_wp
9353	ENDIF
9354
9355	CASE ( 'rtm_rad_inlwdif' )
9356	!-- array of sw radiation falling to surface after i-th reflection
9357	IF ( .NOT. ALLOCATED(surfinlwdif_av) ) THEN
9358	ALLOCATE( surfinlwdif_av(nsurfl) )
9359	surfinlwdif_av = 0.0_wp
9360	ENDIF
9361
9362	CASE ( 'rtm_rad_inlwref' )
9363	!-- array of lw radiation falling to surface from reflections
9364	IF ( .NOT. ALLOCATED(surfinlwref_av) ) THEN
9365	ALLOCATE( surfinlwref_av(nsurfl) )
9366	surfinlwref_av = 0.0_wp
9367	ENDIF
9368
9369	CASE ( 'rtm_rad_outsw' )
9370	!-- array of sw radiation emitted from surface after i-th reflection
9371	IF ( .NOT. ALLOCATED(surfoutsw_av) ) THEN
9372	ALLOCATE( surfoutsw_av(nsurfl) )
9373	surfoutsw_av = 0.0_wp
9374	ENDIF
9375
9376	CASE ( 'rtm_rad_outlw' )
9377	!-- array of lw radiation emitted from surface after i-th reflection
9378	IF ( .NOT. ALLOCATED(surfoutlw_av) ) THEN
9379	ALLOCATE( surfoutlw_av(nsurfl) )
9380	surfoutlw_av = 0.0_wp
9381	ENDIF
9382	CASE ( 'rtm_rad_ressw' )
9383	!-- array of residua of sw radiation absorbed in surface after last reflection
9384	IF ( .NOT. ALLOCATED(surfins_av) ) THEN
9385	ALLOCATE( surfins_av(nsurfl) )
9386	surfins_av = 0.0_wp
9387	ENDIF
9388
9389	CASE ( 'rtm_rad_reslw' )
9390	!-- array of residua of lw radiation absorbed in surface after last reflection
9391	IF ( .NOT. ALLOCATED(surfinl_av) ) THEN
9392	ALLOCATE( surfinl_av(nsurfl) )
9393	surfinl_av = 0.0_wp
9394	ENDIF
9395
9396	CASE ( 'rtm_rad_pc_inlw' )
9397	!-- array of of lw radiation absorbed in plant canopy
9398	IF ( .NOT. ALLOCATED(pcbinlw_av) ) THEN
9399	ALLOCATE( pcbinlw_av(1:npcbl) )
9400	pcbinlw_av = 0.0_wp
9401	ENDIF
9402
9403	CASE ( 'rtm_rad_pc_insw' )
9404	!-- array of of sw radiation absorbed in plant canopy
9405	IF ( .NOT. ALLOCATED(pcbinsw_av) ) THEN
9406	ALLOCATE( pcbinsw_av(1:npcbl) )
9407	pcbinsw_av = 0.0_wp
9408	ENDIF
9409
9410	CASE ( 'rtm_rad_pc_inswdir' )
9411	!-- array of of direct sw radiation absorbed in plant canopy
9412	IF ( .NOT. ALLOCATED(pcbinswdir_av) ) THEN
9413	ALLOCATE( pcbinswdir_av(1:npcbl) )
9414	pcbinswdir_av = 0.0_wp
9415	ENDIF
9416
9417	CASE ( 'rtm_rad_pc_inswdif' )
9418	!-- array of of diffuse sw radiation absorbed in plant canopy
9419	IF ( .NOT. ALLOCATED(pcbinswdif_av) ) THEN
9420	ALLOCATE( pcbinswdif_av(1:npcbl) )
9421	pcbinswdif_av = 0.0_wp
9422	ENDIF
9423
9424	CASE ( 'rtm_rad_pc_inswref' )
9425	!-- array of of reflected sw radiation absorbed in plant canopy
9426	IF ( .NOT. ALLOCATED(pcbinswref_av) ) THEN
9427	ALLOCATE( pcbinswref_av(1:npcbl) )
9428	pcbinswref_av = 0.0_wp
9429	ENDIF
9430
9431	CASE ( 'rtm_mrt_sw' )
9432	IF ( .NOT. ALLOCATED( mrtinsw_av ) ) THEN
9433	ALLOCATE( mrtinsw_av(nmrtbl) )
9434	ENDIF
9435	mrtinsw_av = 0.0_wp
9436
9437	CASE ( 'rtm_mrt_lw' )
9438	IF ( .NOT. ALLOCATED( mrtinlw_av ) ) THEN
9439	ALLOCATE( mrtinlw_av(nmrtbl) )
9440	ENDIF
9441	mrtinlw_av = 0.0_wp
9442
9443	CASE ( 'rtm_mrt' )
9444	IF ( .NOT. ALLOCATED( mrt_av ) ) THEN
9445	ALLOCATE( mrt_av(nmrtbl) )
9446	ENDIF
9447	mrt_av = 0.0_wp
9448
9449	CASE DEFAULT
9450	CONTINUE
9451
9452	END SELECT
9453
9454	ELSEIF ( mode == 'sum' ) THEN
9455
9456	SELECT CASE ( TRIM( var ) )
9457	!-- block of large scale (e.g. RRTMG) radiation output variables
9458	CASE ( 'rad_net*' )
9459	IF ( ALLOCATED( rad_net_av ) ) THEN
9460	DO i = nxl, nxr
9461	DO j = nys, nyn
9462	match_lsm = surf_lsm_h%start_index(j,i) <= &
9463	surf_lsm_h%end_index(j,i)
9464	match_usm = surf_usm_h%start_index(j,i) <= &
9465	surf_usm_h%end_index(j,i)
9466
9467	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9468	m = surf_lsm_h%end_index(j,i)
9469	rad_net_av(j,i) = rad_net_av(j,i) + &
9470	surf_lsm_h%rad_net(m)
9471	ELSEIF ( match_usm ) THEN
9472	m = surf_usm_h%end_index(j,i)
9473	rad_net_av(j,i) = rad_net_av(j,i) + &
9474	surf_usm_h%rad_net(m)
9475	ENDIF
9476	ENDDO
9477	ENDDO
9478	ENDIF
9479
9480	CASE ( 'rad_lw_in*' )
9481	IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
9482	DO i = nxl, nxr
9483	DO j = nys, nyn
9484	match_lsm = surf_lsm_h%start_index(j,i) <= &
9485	surf_lsm_h%end_index(j,i)
9486	match_usm = surf_usm_h%start_index(j,i) <= &
9487	surf_usm_h%end_index(j,i)
9488
9489	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9490	m = surf_lsm_h%end_index(j,i)
9491	rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) + &
9492	surf_lsm_h%rad_lw_in(m)
9493	ELSEIF ( match_usm ) THEN
9494	m = surf_usm_h%end_index(j,i)
9495	rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) + &
9496	surf_usm_h%rad_lw_in(m)
9497	ENDIF
9498	ENDDO
9499	ENDDO
9500	ENDIF
9501
9502	CASE ( 'rad_lw_out*' )
9503	IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
9504	DO i = nxl, nxr
9505	DO j = nys, nyn
9506	match_lsm = surf_lsm_h%start_index(j,i) <= &
9507	surf_lsm_h%end_index(j,i)
9508	match_usm = surf_usm_h%start_index(j,i) <= &
9509	surf_usm_h%end_index(j,i)
9510
9511	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9512	m = surf_lsm_h%end_index(j,i)
9513	rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) + &
9514	surf_lsm_h%rad_lw_out(m)
9515	ELSEIF ( match_usm ) THEN
9516	m = surf_usm_h%end_index(j,i)
9517	rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) + &
9518	surf_usm_h%rad_lw_out(m)
9519	ENDIF
9520	ENDDO
9521	ENDDO
9522	ENDIF
9523
9524	CASE ( 'rad_sw_in*' )
9525	IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
9526	DO i = nxl, nxr
9527	DO j = nys, nyn
9528	match_lsm = surf_lsm_h%start_index(j,i) <= &
9529	surf_lsm_h%end_index(j,i)
9530	match_usm = surf_usm_h%start_index(j,i) <= &
9531	surf_usm_h%end_index(j,i)
9532
9533	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9534	m = surf_lsm_h%end_index(j,i)
9535	rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) + &
9536	surf_lsm_h%rad_sw_in(m)
9537	ELSEIF ( match_usm ) THEN
9538	m = surf_usm_h%end_index(j,i)
9539	rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) + &
9540	surf_usm_h%rad_sw_in(m)
9541	ENDIF
9542	ENDDO
9543	ENDDO
9544	ENDIF
9545
9546	CASE ( 'rad_sw_out*' )
9547	IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
9548	DO i = nxl, nxr
9549	DO j = nys, nyn
9550	match_lsm = surf_lsm_h%start_index(j,i) <= &
9551	surf_lsm_h%end_index(j,i)
9552	match_usm = surf_usm_h%start_index(j,i) <= &
9553	surf_usm_h%end_index(j,i)
9554
9555	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9556	m = surf_lsm_h%end_index(j,i)
9557	rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) + &
9558	surf_lsm_h%rad_sw_out(m)
9559	ELSEIF ( match_usm ) THEN
9560	m = surf_usm_h%end_index(j,i)
9561	rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) + &
9562	surf_usm_h%rad_sw_out(m)
9563	ENDIF
9564	ENDDO
9565	ENDDO
9566	ENDIF
9567
9568	CASE ( 'rad_lw_in' )
9569	IF ( ALLOCATED( rad_lw_in_av ) ) THEN
9570	DO i = nxlg, nxrg
9571	DO j = nysg, nyng
9572	DO k = nzb, nzt+1
9573	rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) &
9574	+ rad_lw_in(k,j,i)
9575	ENDDO
9576	ENDDO
9577	ENDDO
9578	ENDIF
9579
9580	CASE ( 'rad_lw_out' )
9581	IF ( ALLOCATED( rad_lw_out_av ) ) THEN
9582	DO i = nxlg, nxrg
9583	DO j = nysg, nyng
9584	DO k = nzb, nzt+1
9585	rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) &
9586	+ rad_lw_out(k,j,i)
9587	ENDDO
9588	ENDDO
9589	ENDDO
9590	ENDIF
9591
9592	CASE ( 'rad_lw_cs_hr' )
9593	IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN
9594	DO i = nxlg, nxrg
9595	DO j = nysg, nyng
9596	DO k = nzb, nzt+1
9597	rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) &
9598	+ rad_lw_cs_hr(k,j,i)
9599	ENDDO
9600	ENDDO
9601	ENDDO
9602	ENDIF
9603
9604	CASE ( 'rad_lw_hr' )
9605	IF ( ALLOCATED( rad_lw_hr_av ) ) THEN
9606	DO i = nxlg, nxrg
9607	DO j = nysg, nyng
9608	DO k = nzb, nzt+1
9609	rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) &
9610	+ rad_lw_hr(k,j,i)
9611	ENDDO
9612	ENDDO
9613	ENDDO
9614	ENDIF
9615
9616	CASE ( 'rad_sw_in' )
9617	IF ( ALLOCATED( rad_sw_in_av ) ) THEN
9618	DO i = nxlg, nxrg
9619	DO j = nysg, nyng
9620	DO k = nzb, nzt+1
9621	rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) &
9622	+ rad_sw_in(k,j,i)
9623	ENDDO
9624	ENDDO
9625	ENDDO
9626	ENDIF
9627
9628	CASE ( 'rad_sw_out' )
9629	IF ( ALLOCATED( rad_sw_out_av ) ) THEN
9630	DO i = nxlg, nxrg
9631	DO j = nysg, nyng
9632	DO k = nzb, nzt+1
9633	rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) &
9634	+ rad_sw_out(k,j,i)
9635	ENDDO
9636	ENDDO
9637	ENDDO
9638	ENDIF
9639
9640	CASE ( 'rad_sw_cs_hr' )
9641	IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN
9642	DO i = nxlg, nxrg
9643	DO j = nysg, nyng
9644	DO k = nzb, nzt+1
9645	rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) &
9646	+ rad_sw_cs_hr(k,j,i)
9647	ENDDO
9648	ENDDO
9649	ENDDO
9650	ENDIF
9651
9652	CASE ( 'rad_sw_hr' )
9653	IF ( ALLOCATED( rad_sw_hr_av ) ) THEN
9654	DO i = nxlg, nxrg
9655	DO j = nysg, nyng
9656	DO k = nzb, nzt+1
9657	rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) &
9658	+ rad_sw_hr(k,j,i)
9659	ENDDO
9660	ENDDO
9661	ENDDO
9662	ENDIF
9663
9664	!-- block of RTM output variables
9665	CASE ( 'rtm_rad_net' )
9666	!-- array of complete radiation balance
9667	DO isurf = dirstart(ids), dirend(ids)
9668	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9669	surfradnet_av(isurf) = surfinsw(isurf) - surfoutsw(isurf) + surfinlw(isurf) - surfoutlw(isurf)
9670	ENDIF
9671	ENDDO
9672
9673	CASE ( 'rtm_rad_insw' )
9674	!-- array of sw radiation falling to surface after i-th reflection
9675	DO isurf = dirstart(ids), dirend(ids)
9676	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9677	surfinsw_av(isurf) = surfinsw_av(isurf) + surfinsw(isurf)
9678	ENDIF
9679	ENDDO
9680
9681	CASE ( 'rtm_rad_inlw' )
9682	!-- array of lw radiation falling to surface after i-th reflection
9683	DO isurf = dirstart(ids), dirend(ids)
9684	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9685	surfinlw_av(isurf) = surfinlw_av(isurf) + surfinlw(isurf)
9686	ENDIF
9687	ENDDO
9688
9689	CASE ( 'rtm_rad_inswdir' )
9690	!-- array of direct sw radiation falling to surface from sun
9691	DO isurf = dirstart(ids), dirend(ids)
9692	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9693	surfinswdir_av(isurf) = surfinswdir_av(isurf) + surfinswdir(isurf)
9694	ENDIF
9695	ENDDO
9696
9697	CASE ( 'rtm_rad_inswdif' )
9698	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
9699	DO isurf = dirstart(ids), dirend(ids)
9700	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9701	surfinswdif_av(isurf) = surfinswdif_av(isurf) + surfinswdif(isurf)
9702	ENDIF
9703	ENDDO
9704
9705	CASE ( 'rtm_rad_inswref' )
9706	!-- array of sw radiation falling to surface from reflections
9707	DO isurf = dirstart(ids), dirend(ids)
9708	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9709	surfinswref_av(isurf) = surfinswref_av(isurf) + surfinsw(isurf) - &
9710	surfinswdir(isurf) - surfinswdif(isurf)
9711	ENDIF
9712	ENDDO
9713
9714
9715	CASE ( 'rtm_rad_inlwdif' )
9716	!-- array of sw radiation falling to surface after i-th reflection
9717	DO isurf = dirstart(ids), dirend(ids)
9718	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9719	surfinlwdif_av(isurf) = surfinlwdif_av(isurf) + surfinlwdif(isurf)
9720	ENDIF
9721	ENDDO
9722	!
9723	CASE ( 'rtm_rad_inlwref' )
9724	!-- array of lw radiation falling to surface from reflections
9725	DO isurf = dirstart(ids), dirend(ids)
9726	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9727	surfinlwref_av(isurf) = surfinlwref_av(isurf) + &
9728	surfinlw(isurf) - surfinlwdif(isurf)
9729	ENDIF
9730	ENDDO
9731
9732	CASE ( 'rtm_rad_outsw' )
9733	!-- array of sw radiation emitted from surface after i-th reflection
9734	DO isurf = dirstart(ids), dirend(ids)
9735	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9736	surfoutsw_av(isurf) = surfoutsw_av(isurf) + surfoutsw(isurf)
9737	ENDIF
9738	ENDDO
9739
9740	CASE ( 'rtm_rad_outlw' )
9741	!-- array of lw radiation emitted from surface after i-th reflection
9742	DO isurf = dirstart(ids), dirend(ids)
9743	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9744	surfoutlw_av(isurf) = surfoutlw_av(isurf) + surfoutlw(isurf)
9745	ENDIF
9746	ENDDO
9747
9748	CASE ( 'rtm_rad_ressw' )
9749	!-- array of residua of sw radiation absorbed in surface after last reflection
9750	DO isurf = dirstart(ids), dirend(ids)
9751	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9752	surfins_av(isurf) = surfins_av(isurf) + surfins(isurf)
9753	ENDIF
9754	ENDDO
9755
9756	CASE ( 'rtm_rad_reslw' )
9757	!-- array of residua of lw radiation absorbed in surface after last reflection
9758	DO isurf = dirstart(ids), dirend(ids)
9759	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9760	surfinl_av(isurf) = surfinl_av(isurf) + surfinl(isurf)
9761	ENDIF
9762	ENDDO
9763
9764	CASE ( 'rtm_rad_pc_inlw' )
9765	DO l = 1, npcbl
9766	pcbinlw_av(l) = pcbinlw_av(l) + pcbinlw(l)
9767	ENDDO
9768
9769	CASE ( 'rtm_rad_pc_insw' )
9770	DO l = 1, npcbl
9771	pcbinsw_av(l) = pcbinsw_av(l) + pcbinsw(l)
9772	ENDDO
9773
9774	CASE ( 'rtm_rad_pc_inswdir' )
9775	DO l = 1, npcbl
9776	pcbinswdir_av(l) = pcbinswdir_av(l) + pcbinswdir(l)
9777	ENDDO
9778
9779	CASE ( 'rtm_rad_pc_inswdif' )
9780	DO l = 1, npcbl
9781	pcbinswdif_av(l) = pcbinswdif_av(l) + pcbinswdif(l)
9782	ENDDO
9783
9784	CASE ( 'rtm_rad_pc_inswref' )
9785	DO l = 1, npcbl
9786	pcbinswref_av(l) = pcbinswref_av(l) + pcbinsw(l) - pcbinswdir(l) - pcbinswdif(l)
9787	ENDDO
9788
9789	CASE ( 'rad_mrt_sw' )
9790	IF ( ALLOCATED( mrtinsw_av ) ) THEN
9791	mrtinsw_av(:) = mrtinsw_av(:) + mrtinsw(:)
9792	ENDIF
9793
9794	CASE ( 'rad_mrt_lw' )
9795	IF ( ALLOCATED( mrtinlw_av ) ) THEN
9796	mrtinlw_av(:) = mrtinlw_av(:) + mrtinlw(:)
9797	ENDIF
9798
9799	CASE ( 'rad_mrt' )
9800	IF ( ALLOCATED( mrt_av ) ) THEN
9801	mrt_av(:) = mrt_av(:) + mrt(:)
9802	ENDIF
9803
9804	CASE DEFAULT
9805	CONTINUE
9806
9807	END SELECT
9808
9809	ELSEIF ( mode == 'average' ) THEN
9810
9811	SELECT CASE ( TRIM( var ) )
9812	!-- block of large scale (e.g. RRTMG) radiation output variables
9813	CASE ( 'rad_net*' )
9814	IF ( ALLOCATED( rad_net_av ) ) THEN
9815	DO i = nxlg, nxrg
9816	DO j = nysg, nyng
9817	rad_net_av(j,i) = rad_net_av(j,i) &
9818	/ REAL( average_count_3d, KIND=wp )
9819	ENDDO
9820	ENDDO
9821	ENDIF
9822
9823	CASE ( 'rad_lw_in*' )
9824	IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
9825	DO i = nxlg, nxrg
9826	DO j = nysg, nyng
9827	rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) &
9828	/ REAL( average_count_3d, KIND=wp )
9829	ENDDO
9830	ENDDO
9831	ENDIF
9832
9833	CASE ( 'rad_lw_out*' )
9834	IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
9835	DO i = nxlg, nxrg
9836	DO j = nysg, nyng
9837	rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) &
9838	/ REAL( average_count_3d, KIND=wp )
9839	ENDDO
9840	ENDDO
9841	ENDIF
9842
9843	CASE ( 'rad_sw_in*' )
9844	IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
9845	DO i = nxlg, nxrg
9846	DO j = nysg, nyng
9847	rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) &
9848	/ REAL( average_count_3d, KIND=wp )
9849	ENDDO
9850	ENDDO
9851	ENDIF
9852
9853	CASE ( 'rad_sw_out*' )
9854	IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
9855	DO i = nxlg, nxrg
9856	DO j = nysg, nyng
9857	rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) &
9858	/ REAL( average_count_3d, KIND=wp )
9859	ENDDO
9860	ENDDO
9861	ENDIF
9862
9863	CASE ( 'rad_lw_in' )
9864	IF ( ALLOCATED( rad_lw_in_av ) ) THEN
9865	DO i = nxlg, nxrg
9866	DO j = nysg, nyng
9867	DO k = nzb, nzt+1
9868	rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) &
9869	/ REAL( average_count_3d, KIND=wp )
9870	ENDDO
9871	ENDDO
9872	ENDDO
9873	ENDIF
9874
9875	CASE ( 'rad_lw_out' )
9876	IF ( ALLOCATED( rad_lw_out_av ) ) THEN
9877	DO i = nxlg, nxrg
9878	DO j = nysg, nyng
9879	DO k = nzb, nzt+1
9880	rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) &
9881	/ REAL( average_count_3d, KIND=wp )
9882	ENDDO
9883	ENDDO
9884	ENDDO
9885	ENDIF
9886
9887	CASE ( 'rad_lw_cs_hr' )
9888	IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN
9889	DO i = nxlg, nxrg
9890	DO j = nysg, nyng
9891	DO k = nzb, nzt+1
9892	rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) &
9893	/ REAL( average_count_3d, KIND=wp )
9894	ENDDO
9895	ENDDO
9896	ENDDO
9897	ENDIF
9898
9899	CASE ( 'rad_lw_hr' )
9900	IF ( ALLOCATED( rad_lw_hr_av ) ) THEN
9901	DO i = nxlg, nxrg
9902	DO j = nysg, nyng
9903	DO k = nzb, nzt+1
9904	rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) &
9905	/ REAL( average_count_3d, KIND=wp )
9906	ENDDO
9907	ENDDO
9908	ENDDO
9909	ENDIF
9910
9911	CASE ( 'rad_sw_in' )
9912	IF ( ALLOCATED( rad_sw_in_av ) ) THEN
9913	DO i = nxlg, nxrg
9914	DO j = nysg, nyng
9915	DO k = nzb, nzt+1
9916	rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) &
9917	/ REAL( average_count_3d, KIND=wp )
9918	ENDDO
9919	ENDDO
9920	ENDDO
9921	ENDIF
9922
9923	CASE ( 'rad_sw_out' )
9924	IF ( ALLOCATED( rad_sw_out_av ) ) THEN
9925	DO i = nxlg, nxrg
9926	DO j = nysg, nyng
9927	DO k = nzb, nzt+1
9928	rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) &
9929	/ REAL( average_count_3d, KIND=wp )
9930	ENDDO
9931	ENDDO
9932	ENDDO
9933	ENDIF
9934
9935	CASE ( 'rad_sw_cs_hr' )
9936	IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN
9937	DO i = nxlg, nxrg
9938	DO j = nysg, nyng
9939	DO k = nzb, nzt+1
9940	rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) &
9941	/ REAL( average_count_3d, KIND=wp )
9942	ENDDO
9943	ENDDO
9944	ENDDO
9945	ENDIF
9946
9947	CASE ( 'rad_sw_hr' )
9948	IF ( ALLOCATED( rad_sw_hr_av ) ) THEN
9949	DO i = nxlg, nxrg
9950	DO j = nysg, nyng
9951	DO k = nzb, nzt+1
9952	rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) &
9953	/ REAL( average_count_3d, KIND=wp )
9954	ENDDO
9955	ENDDO
9956	ENDDO
9957	ENDIF
9958
9959	!-- block of RTM output variables
9960	CASE ( 'rtm_rad_net' )
9961	!-- array of complete radiation balance
9962	DO isurf = dirstart(ids), dirend(ids)
9963	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9964	surfradnet_av(isurf) = surfinsw_av(isurf) / REAL( average_count_3d, kind=wp )
9965	ENDIF
9966	ENDDO
9967
9968	CASE ( 'rtm_rad_insw' )
9969	!-- array of sw radiation falling to surface after i-th reflection
9970	DO isurf = dirstart(ids), dirend(ids)
9971	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9972	surfinsw_av(isurf) = surfinsw_av(isurf) / REAL( average_count_3d, kind=wp )
9973	ENDIF
9974	ENDDO
9975
9976	CASE ( 'rtm_rad_inlw' )
9977	!-- array of lw radiation falling to surface after i-th reflection
9978	DO isurf = dirstart(ids), dirend(ids)
9979	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9980	surfinlw_av(isurf) = surfinlw_av(isurf) / REAL( average_count_3d, kind=wp )
9981	ENDIF
9982	ENDDO
9983
9984	CASE ( 'rtm_rad_inswdir' )
9985	!-- array of direct sw radiation falling to surface from sun
9986	DO isurf = dirstart(ids), dirend(ids)
9987	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9988	surfinswdir_av(isurf) = surfinswdir_av(isurf) / REAL( average_count_3d, kind=wp )
9989	ENDIF
9990	ENDDO
9991
9992	CASE ( 'rtm_rad_inswdif' )
9993	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
9994	DO isurf = dirstart(ids), dirend(ids)
9995	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9996	surfinswdif_av(isurf) = surfinswdif_av(isurf) / REAL( average_count_3d, kind=wp )
9997	ENDIF
9998	ENDDO
9999
10000	CASE ( 'rtm_rad_inswref' )
10001	!-- array of sw radiation falling to surface from reflections
10002	DO isurf = dirstart(ids), dirend(ids)
10003	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10004	surfinswref_av(isurf) = surfinswref_av(isurf) / REAL( average_count_3d, kind=wp )
10005	ENDIF
10006	ENDDO
10007
10008	CASE ( 'rtm_rad_inlwdif' )
10009	!-- array of sw radiation falling to surface after i-th reflection
10010	DO isurf = dirstart(ids), dirend(ids)
10011	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10012	surfinlwdif_av(isurf) = surfinlwdif_av(isurf) / REAL( average_count_3d, kind=wp )
10013	ENDIF
10014	ENDDO
10015
10016	CASE ( 'rtm_rad_inlwref' )
10017	!-- array of lw radiation falling to surface from reflections
10018	DO isurf = dirstart(ids), dirend(ids)
10019	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10020	surfinlwref_av(isurf) = surfinlwref_av(isurf) / REAL( average_count_3d, kind=wp )
10021	ENDIF
10022	ENDDO
10023
10024	CASE ( 'rtm_rad_outsw' )
10025	!-- array of sw radiation emitted from surface after i-th reflection
10026	DO isurf = dirstart(ids), dirend(ids)
10027	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10028	surfoutsw_av(isurf) = surfoutsw_av(isurf) / REAL( average_count_3d, kind=wp )
10029	ENDIF
10030	ENDDO
10031
10032	CASE ( 'rtm_rad_outlw' )
10033	!-- array of lw radiation emitted from surface after i-th reflection
10034	DO isurf = dirstart(ids), dirend(ids)
10035	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10036	surfoutlw_av(isurf) = surfoutlw_av(isurf) / REAL( average_count_3d, kind=wp )
10037	ENDIF
10038	ENDDO
10039
10040	CASE ( 'rtm_rad_ressw' )
10041	!-- array of residua of sw radiation absorbed in surface after last reflection
10042	DO isurf = dirstart(ids), dirend(ids)
10043	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10044	surfins_av(isurf) = surfins_av(isurf) / REAL( average_count_3d, kind=wp )
10045	ENDIF
10046	ENDDO
10047
10048	CASE ( 'rtm_rad_reslw' )
10049	!-- array of residua of lw radiation absorbed in surface after last reflection
10050	DO isurf = dirstart(ids), dirend(ids)
10051	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10052	surfinl_av(isurf) = surfinl_av(isurf) / REAL( average_count_3d, kind=wp )
10053	ENDIF
10054	ENDDO
10055
10056	CASE ( 'rtm_rad_pc_inlw' )
10057	DO l = 1, npcbl
10058	pcbinlw_av(:) = pcbinlw_av(:) / REAL( average_count_3d, kind=wp )
10059	ENDDO
10060
10061	CASE ( 'rtm_rad_pc_insw' )
10062	DO l = 1, npcbl
10063	pcbinsw_av(:) = pcbinsw_av(:) / REAL( average_count_3d, kind=wp )
10064	ENDDO
10065
10066	CASE ( 'rtm_rad_pc_inswdir' )
10067	DO l = 1, npcbl
10068	pcbinswdir_av(:) = pcbinswdir_av(:) / REAL( average_count_3d, kind=wp )
10069	ENDDO
10070
10071	CASE ( 'rtm_rad_pc_inswdif' )
10072	DO l = 1, npcbl
10073	pcbinswdif_av(:) = pcbinswdif_av(:) / REAL( average_count_3d, kind=wp )
10074	ENDDO
10075
10076	CASE ( 'rtm_rad_pc_inswref' )
10077	DO l = 1, npcbl
10078	pcbinswref_av(:) = pcbinswref_av(:) / REAL( average_count_3d, kind=wp )
10079	ENDDO
10080
10081	CASE ( 'rad_mrt_lw' )
10082	IF ( ALLOCATED( mrtinlw_av ) ) THEN
10083	mrtinlw_av(:) = mrtinlw_av(:) / REAL( average_count_3d, KIND=wp )
10084	ENDIF
10085
10086	CASE ( 'rad_mrt' )
10087	IF ( ALLOCATED( mrt_av ) ) THEN
10088	mrt_av(:) = mrt_av(:) / REAL( average_count_3d, KIND=wp )
10089	ENDIF
10090
10091	END SELECT
10092
10093	ENDIF
10094
10095	END SUBROUTINE radiation_3d_data_averaging
10096
10097
10098	!------------------------------------------------------------------------------!
10099	!
10100	! Description:
10101	! ------------
10102	!> Subroutine defining appropriate grid for netcdf variables.
10103	!> It is called out from subroutine netcdf.
10104	!------------------------------------------------------------------------------!
10105	SUBROUTINE radiation_define_netcdf_grid( variable, found, grid_x, grid_y, grid_z )
10106
10107	IMPLICIT NONE
10108
10109	CHARACTER (LEN=*), INTENT(IN) :: variable !<
10110	LOGICAL, INTENT(OUT) :: found !<
10111	CHARACTER (LEN=*), INTENT(OUT) :: grid_x !<
10112	CHARACTER (LEN=*), INTENT(OUT) :: grid_y !<
10113	CHARACTER (LEN=*), INTENT(OUT) :: grid_z !<
10114
10115	CHARACTER (len=varnamelength) :: var
10116
10117	found = .TRUE.
10118
10119	!
10120	!-- Check for the grid
10121	var = TRIM(variable)
10122	!-- RTM directional variables
10123	IF ( var(1:12) == 'rtm_rad_net_' .OR. var(1:13) == 'rtm_rad_insw_' .OR. &
10124	var(1:13) == 'rtm_rad_inlw_' .OR. var(1:16) == 'rtm_rad_inswdir_' .OR. &
10125	var(1:16) == 'rtm_rad_inswdif_' .OR. var(1:16) == 'rtm_rad_inswref_' .OR. &
10126	var(1:16) == 'rtm_rad_inlwdif_' .OR. var(1:16) == 'rtm_rad_inlwref_' .OR. &
10127	var(1:14) == 'rtm_rad_outsw_' .OR. var(1:14) == 'rtm_rad_outlw_' .OR. &
10128	var(1:14) == 'rtm_rad_ressw_' .OR. var(1:14) == 'rtm_rad_reslw_' .OR. &
10129	var == 'rtm_rad_pc_inlw' .OR. &
10130	var == 'rtm_rad_pc_insw' .OR. var == 'rtm_rad_pc_inswdir' .OR. &
10131	var == 'rtm_rad_pc_inswdif' .OR. var == 'rtm_rad_pc_inswref' .OR. &
10132	var(1:7) == 'rtm_svf' .OR. var(1:7) == 'rtm_dif' .OR. &
10133	var(1:9) == 'rtm_skyvf' .OR. var(1:10) == 'rtm_skyvft' .OR. &
10134	var(1:12) == 'rtm_surfalb_' .OR. var(1:13) == 'rtm_surfemis_' .OR. &
10135	var == 'rtm_mrt' .OR. var == 'rtm_mrt_sw' .OR. var == 'rtm_mrt_lw' ) THEN
10136
10137	found = .TRUE.
10138	grid_x = 'x'
10139	grid_y = 'y'
10140	grid_z = 'zu'
10141	ELSE
10142
10143	SELECT CASE ( TRIM( var ) )
10144
10145	CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_sw_cs_hr', 'rad_sw_hr', &
10146	'rad_lw_cs_hr_xy', 'rad_lw_hr_xy', 'rad_sw_cs_hr_xy', &
10147	'rad_sw_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_hr_xz', &
10148	'rad_sw_cs_hr_xz', 'rad_sw_hr_xz', 'rad_lw_cs_hr_yz', &
10149	'rad_lw_hr_yz', 'rad_sw_cs_hr_yz', 'rad_sw_hr_yz', &
10150	'rad_mrt', 'rad_mrt_sw', 'rad_mrt_lw' )
10151	grid_x = 'x'
10152	grid_y = 'y'
10153	grid_z = 'zu'
10154
10155	CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out', &
10156	'rad_lw_in_xy', 'rad_lw_out_xy', 'rad_sw_in_xy','rad_sw_out_xy', &
10157	'rad_lw_in_xz', 'rad_lw_out_xz', 'rad_sw_in_xz','rad_sw_out_xz', &
10158	'rad_lw_in_yz', 'rad_lw_out_yz', 'rad_sw_in_yz','rad_sw_out_yz' )
10159	grid_x = 'x'
10160	grid_y = 'y'
10161	grid_z = 'zw'
10162
10163
10164	CASE DEFAULT
10165	found = .FALSE.
10166	grid_x = 'none'
10167	grid_y = 'none'
10168	grid_z = 'none'
10169
10170	END SELECT
10171	ENDIF
10172
10173	END SUBROUTINE radiation_define_netcdf_grid
10174
10175	!------------------------------------------------------------------------------!
10176	!
10177	! Description:
10178	! ------------
10179	!> Subroutine defining 2D output variables
10180	!------------------------------------------------------------------------------!
10181	SUBROUTINE radiation_data_output_2d( av, variable, found, grid, mode, &
10182	local_pf, two_d, nzb_do, nzt_do )
10183
10184	USE indices
10185
10186	USE kinds
10187
10188
10189	IMPLICIT NONE
10190
10191	CHARACTER (LEN=*) :: grid !<
10192	CHARACTER (LEN=*) :: mode !<
10193	CHARACTER (LEN=*) :: variable !<
10194
10195	INTEGER(iwp) :: av !<
10196	INTEGER(iwp) :: i !<
10197	INTEGER(iwp) :: j !<
10198	INTEGER(iwp) :: k !<
10199	INTEGER(iwp) :: m !< index of surface element at grid point (j,i)
10200	INTEGER(iwp) :: nzb_do !<
10201	INTEGER(iwp) :: nzt_do !<
10202
10203	LOGICAL :: found !<
10204	LOGICAL :: two_d !< flag parameter that indicates 2D variables (horizontal cross sections)
10205
10206	REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute
10207
10208	REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !<
10209
10210	found = .TRUE.
10211
10212	SELECT CASE ( TRIM( variable ) )
10213
10214	CASE ( 'rad_net*_xy' ) ! 2d-array
10215	IF ( av == 0 ) THEN
10216	DO i = nxl, nxr
10217	DO j = nys, nyn
10218	!
10219	!-- Obtain rad_net from its respective surface type
10220	!-- Natural-type surfaces
10221	DO m = surf_lsm_h%start_index(j,i), &
10222	surf_lsm_h%end_index(j,i)
10223	local_pf(i,j,nzb+1) = surf_lsm_h%rad_net(m)
10224	ENDDO
10225	!
10226	!-- Urban-type surfaces
10227	DO m = surf_usm_h%start_index(j,i), &
10228	surf_usm_h%end_index(j,i)
10229	local_pf(i,j,nzb+1) = surf_usm_h%rad_net(m)
10230	ENDDO
10231	ENDDO
10232	ENDDO
10233	ELSE
10234	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
10235	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
10236	rad_net_av = REAL( fill_value, KIND = wp )
10237	ENDIF
10238	DO i = nxl, nxr
10239	DO j = nys, nyn
10240	local_pf(i,j,nzb+1) = rad_net_av(j,i)
10241	ENDDO
10242	ENDDO
10243	ENDIF
10244	two_d = .TRUE.
10245	grid = 'zu1'
10246
10247	CASE ( 'rad_lw_in*_xy' ) ! 2d-array
10248	IF ( av == 0 ) THEN
10249	DO i = nxl, nxr
10250	DO j = nys, nyn
10251	!
10252	!-- Obtain rad_net from its respective surface type
10253	!-- Natural-type surfaces
10254	DO m = surf_lsm_h%start_index(j,i), &
10255	surf_lsm_h%end_index(j,i)
10256	local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_in(m)
10257	ENDDO
10258	!
10259	!-- Urban-type surfaces
10260	DO m = surf_usm_h%start_index(j,i), &
10261	surf_usm_h%end_index(j,i)
10262	local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_in(m)
10263	ENDDO
10264	ENDDO
10265	ENDDO
10266	ELSE
10267	IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
10268	ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
10269	rad_lw_in_xy_av = REAL( fill_value, KIND = wp )
10270	ENDIF
10271	DO i = nxl, nxr
10272	DO j = nys, nyn
10273	local_pf(i,j,nzb+1) = rad_lw_in_xy_av(j,i)
10274	ENDDO
10275	ENDDO
10276	ENDIF
10277	two_d = .TRUE.
10278	grid = 'zu1'
10279
10280	CASE ( 'rad_lw_out*_xy' ) ! 2d-array
10281	IF ( av == 0 ) THEN
10282	DO i = nxl, nxr
10283	DO j = nys, nyn
10284	!
10285	!-- Obtain rad_net from its respective surface type
10286	!-- Natural-type surfaces
10287	DO m = surf_lsm_h%start_index(j,i), &
10288	surf_lsm_h%end_index(j,i)
10289	local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_out(m)
10290	ENDDO
10291	!
10292	!-- Urban-type surfaces
10293	DO m = surf_usm_h%start_index(j,i), &
10294	surf_usm_h%end_index(j,i)
10295	local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_out(m)
10296	ENDDO
10297	ENDDO
10298	ENDDO
10299	ELSE
10300	IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
10301	ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
10302	rad_lw_out_xy_av = REAL( fill_value, KIND = wp )
10303	ENDIF
10304	DO i = nxl, nxr
10305	DO j = nys, nyn
10306	local_pf(i,j,nzb+1) = rad_lw_out_xy_av(j,i)
10307	ENDDO
10308	ENDDO
10309	ENDIF
10310	two_d = .TRUE.
10311	grid = 'zu1'
10312
10313	CASE ( 'rad_sw_in*_xy' ) ! 2d-array
10314	IF ( av == 0 ) THEN
10315	DO i = nxl, nxr
10316	DO j = nys, nyn
10317	!
10318	!-- Obtain rad_net from its respective surface type
10319	!-- Natural-type surfaces
10320	DO m = surf_lsm_h%start_index(j,i), &
10321	surf_lsm_h%end_index(j,i)
10322	local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_in(m)
10323	ENDDO
10324	!
10325	!-- Urban-type surfaces
10326	DO m = surf_usm_h%start_index(j,i), &
10327	surf_usm_h%end_index(j,i)
10328	local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_in(m)
10329	ENDDO
10330	ENDDO
10331	ENDDO
10332	ELSE
10333	IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
10334	ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
10335	rad_sw_in_xy_av = REAL( fill_value, KIND = wp )
10336	ENDIF
10337	DO i = nxl, nxr
10338	DO j = nys, nyn
10339	local_pf(i,j,nzb+1) = rad_sw_in_xy_av(j,i)
10340	ENDDO
10341	ENDDO
10342	ENDIF
10343	two_d = .TRUE.
10344	grid = 'zu1'
10345
10346	CASE ( 'rad_sw_out*_xy' ) ! 2d-array
10347	IF ( av == 0 ) THEN
10348	DO i = nxl, nxr
10349	DO j = nys, nyn
10350	!
10351	!-- Obtain rad_net from its respective surface type
10352	!-- Natural-type surfaces
10353	DO m = surf_lsm_h%start_index(j,i), &
10354	surf_lsm_h%end_index(j,i)
10355	local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_out(m)
10356	ENDDO
10357	!
10358	!-- Urban-type surfaces
10359	DO m = surf_usm_h%start_index(j,i), &
10360	surf_usm_h%end_index(j,i)
10361	local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_out(m)
10362	ENDDO
10363	ENDDO
10364	ENDDO
10365	ELSE
10366	IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
10367	ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
10368	rad_sw_out_xy_av = REAL( fill_value, KIND = wp )
10369	ENDIF
10370	DO i = nxl, nxr
10371	DO j = nys, nyn
10372	local_pf(i,j,nzb+1) = rad_sw_out_xy_av(j,i)
10373	ENDDO
10374	ENDDO
10375	ENDIF
10376	two_d = .TRUE.
10377	grid = 'zu1'
10378
10379	CASE ( 'rad_lw_in_xy', 'rad_lw_in_xz', 'rad_lw_in_yz' )
10380	IF ( av == 0 ) THEN
10381	DO i = nxl, nxr
10382	DO j = nys, nyn
10383	DO k = nzb_do, nzt_do
10384	local_pf(i,j,k) = rad_lw_in(k,j,i)
10385	ENDDO
10386	ENDDO
10387	ENDDO
10388	ELSE
10389	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
10390	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10391	rad_lw_in_av = REAL( fill_value, KIND = wp )
10392	ENDIF
10393	DO i = nxl, nxr
10394	DO j = nys, nyn
10395	DO k = nzb_do, nzt_do
10396	local_pf(i,j,k) = rad_lw_in_av(k,j,i)
10397	ENDDO
10398	ENDDO
10399	ENDDO
10400	ENDIF
10401	IF ( mode == 'xy' ) grid = 'zu'
10402
10403	CASE ( 'rad_lw_out_xy', 'rad_lw_out_xz', 'rad_lw_out_yz' )
10404	IF ( av == 0 ) THEN
10405	DO i = nxl, nxr
10406	DO j = nys, nyn
10407	DO k = nzb_do, nzt_do
10408	local_pf(i,j,k) = rad_lw_out(k,j,i)
10409	ENDDO
10410	ENDDO
10411	ENDDO
10412	ELSE
10413	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
10414	ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10415	rad_lw_out_av = REAL( fill_value, KIND = wp )
10416	ENDIF
10417	DO i = nxl, nxr
10418	DO j = nys, nyn
10419	DO k = nzb_do, nzt_do
10420	local_pf(i,j,k) = rad_lw_out_av(k,j,i)
10421	ENDDO
10422	ENDDO
10423	ENDDO
10424	ENDIF
10425	IF ( mode == 'xy' ) grid = 'zu'
10426
10427	CASE ( 'rad_lw_cs_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_cs_hr_yz' )
10428	IF ( av == 0 ) THEN
10429	DO i = nxl, nxr
10430	DO j = nys, nyn
10431	DO k = nzb_do, nzt_do
10432	local_pf(i,j,k) = rad_lw_cs_hr(k,j,i)
10433	ENDDO
10434	ENDDO
10435	ENDDO
10436	ELSE
10437	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
10438	ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10439	rad_lw_cs_hr_av = REAL( fill_value, KIND = wp )
10440	ENDIF
10441	DO i = nxl, nxr
10442	DO j = nys, nyn
10443	DO k = nzb_do, nzt_do
10444	local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i)
10445	ENDDO
10446	ENDDO
10447	ENDDO
10448	ENDIF
10449	IF ( mode == 'xy' ) grid = 'zw'
10450
10451	CASE ( 'rad_lw_hr_xy', 'rad_lw_hr_xz', 'rad_lw_hr_yz' )
10452	IF ( av == 0 ) THEN
10453	DO i = nxl, nxr
10454	DO j = nys, nyn
10455	DO k = nzb_do, nzt_do
10456	local_pf(i,j,k) = rad_lw_hr(k,j,i)
10457	ENDDO
10458	ENDDO
10459	ENDDO
10460	ELSE
10461	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
10462	ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10463	rad_lw_hr_av= REAL( fill_value, KIND = wp )
10464	ENDIF
10465	DO i = nxl, nxr
10466	DO j = nys, nyn
10467	DO k = nzb_do, nzt_do
10468	local_pf(i,j,k) = rad_lw_hr_av(k,j,i)
10469	ENDDO
10470	ENDDO
10471	ENDDO
10472	ENDIF
10473	IF ( mode == 'xy' ) grid = 'zw'
10474
10475	CASE ( 'rad_sw_in_xy', 'rad_sw_in_xz', 'rad_sw_in_yz' )
10476	IF ( av == 0 ) THEN
10477	DO i = nxl, nxr
10478	DO j = nys, nyn
10479	DO k = nzb_do, nzt_do
10480	local_pf(i,j,k) = rad_sw_in(k,j,i)
10481	ENDDO
10482	ENDDO
10483	ENDDO
10484	ELSE
10485	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
10486	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10487	rad_sw_in_av = REAL( fill_value, KIND = wp )
10488	ENDIF
10489	DO i = nxl, nxr
10490	DO j = nys, nyn
10491	DO k = nzb_do, nzt_do
10492	local_pf(i,j,k) = rad_sw_in_av(k,j,i)
10493	ENDDO
10494	ENDDO
10495	ENDDO
10496	ENDIF
10497	IF ( mode == 'xy' ) grid = 'zu'
10498
10499	CASE ( 'rad_sw_out_xy', 'rad_sw_out_xz', 'rad_sw_out_yz' )
10500	IF ( av == 0 ) THEN
10501	DO i = nxl, nxr
10502	DO j = nys, nyn
10503	DO k = nzb_do, nzt_do
10504	local_pf(i,j,k) = rad_sw_out(k,j,i)
10505	ENDDO
10506	ENDDO
10507	ENDDO
10508	ELSE
10509	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
10510	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10511	rad_sw_out_av = REAL( fill_value, KIND = wp )
10512	ENDIF
10513	DO i = nxl, nxr
10514	DO j = nys, nyn
10515	DO k = nzb, nzt+1
10516	local_pf(i,j,k) = rad_sw_out_av(k,j,i)
10517	ENDDO
10518	ENDDO
10519	ENDDO
10520	ENDIF
10521	IF ( mode == 'xy' ) grid = 'zu'
10522
10523	CASE ( 'rad_sw_cs_hr_xy', 'rad_sw_cs_hr_xz', 'rad_sw_cs_hr_yz' )
10524	IF ( av == 0 ) THEN
10525	DO i = nxl, nxr
10526	DO j = nys, nyn
10527	DO k = nzb_do, nzt_do
10528	local_pf(i,j,k) = rad_sw_cs_hr(k,j,i)
10529	ENDDO
10530	ENDDO
10531	ENDDO
10532	ELSE
10533	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
10534	ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10535	rad_sw_cs_hr_av = REAL( fill_value, KIND = wp )
10536	ENDIF
10537	DO i = nxl, nxr
10538	DO j = nys, nyn
10539	DO k = nzb_do, nzt_do
10540	local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i)
10541	ENDDO
10542	ENDDO
10543	ENDDO
10544	ENDIF
10545	IF ( mode == 'xy' ) grid = 'zw'
10546
10547	CASE ( 'rad_sw_hr_xy', 'rad_sw_hr_xz', 'rad_sw_hr_yz' )
10548	IF ( av == 0 ) THEN
10549	DO i = nxl, nxr
10550	DO j = nys, nyn
10551	DO k = nzb_do, nzt_do
10552	local_pf(i,j,k) = rad_sw_hr(k,j,i)
10553	ENDDO
10554	ENDDO
10555	ENDDO
10556	ELSE
10557	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
10558	ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10559	rad_sw_hr_av = REAL( fill_value, KIND = wp )
10560	ENDIF
10561	DO i = nxl, nxr
10562	DO j = nys, nyn
10563	DO k = nzb_do, nzt_do
10564	local_pf(i,j,k) = rad_sw_hr_av(k,j,i)
10565	ENDDO
10566	ENDDO
10567	ENDDO
10568	ENDIF
10569	IF ( mode == 'xy' ) grid = 'zw'
10570
10571	CASE DEFAULT
10572	found = .FALSE.
10573	grid = 'none'
10574
10575	END SELECT
10576
10577	END SUBROUTINE radiation_data_output_2d
10578
10579
10580	!------------------------------------------------------------------------------!
10581	!
10582	! Description:
10583	! ------------
10584	!> Subroutine defining 3D output variables
10585	!------------------------------------------------------------------------------!
10586	SUBROUTINE radiation_data_output_3d( av, variable, found, local_pf, nzb_do, nzt_do )
10587
10588
10589	USE indices
10590
10591	USE kinds
10592
10593
10594	IMPLICIT NONE
10595
10596	CHARACTER (LEN=*) :: variable !<
10597
10598	INTEGER(iwp) :: av !<
10599	INTEGER(iwp) :: i, j, k, l !<
10600	INTEGER(iwp) :: nzb_do !<
10601	INTEGER(iwp) :: nzt_do !<
10602
10603	LOGICAL :: found !<
10604
10605	REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute
10606
10607	REAL(sp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !<
10608
10609	CHARACTER (len=varnamelength) :: var, surfid
10610	INTEGER(iwp) :: ids,idsint_u,idsint_l,isurf,isvf,isurfs,isurflt,ipcgb
10611	INTEGER(iwp) :: is, js, ks, istat
10612
10613	found = .TRUE.
10614	var = TRIM(variable)
10615
10616	!-- check if variable belongs to radiation related variables (starts with rad or rtm)
10617	IF ( len(var) < 3_iwp ) THEN
10618	found = .FALSE.
10619	RETURN
10620	ENDIF
10621
10622	IF ( var(1:3) /= 'rad' .AND. var(1:3) /= 'rtm' ) THEN
10623	found = .FALSE.
10624	RETURN
10625	ENDIF
10626
10627	ids = -1
10628	DO i = 0, nd-1
10629	k = len(TRIM(var))
10630	j = len(TRIM(dirname(i)))
10631	IF ( k-j+1 >= 1_iwp ) THEN
10632	IF ( TRIM(var(k-j+1:k)) == TRIM(dirname(i)) ) THEN
10633	ids = i
10634	idsint_u = dirint_u(ids)
10635	idsint_l = dirint_l(ids)
10636	var = var(:k-j)
10637	EXIT
10638	ENDIF
10639	ENDIF
10640	ENDDO
10641	IF ( ids == -1 ) THEN
10642	var = TRIM(variable)
10643	ENDIF
10644
10645	IF ( (var(1:8) == 'rtm_svf_' .OR. var(1:8) == 'rtm_dif_') .AND. len(TRIM(var)) >= 13 ) THEN
10646	!-- svf values to particular surface
10647	surfid = var(9:)
10648	i = index(surfid,'_')
10649	j = index(surfid(i+1:),'_')
10650	READ(surfid(1:i-1),*, iostat=istat ) is
10651	IF ( istat == 0 ) THEN
10652	READ(surfid(i+1:i+j-1),*, iostat=istat ) js
10653	ENDIF
10654	IF ( istat == 0 ) THEN
10655	READ(surfid(i+j+1:),*, iostat=istat ) ks
10656	ENDIF
10657	IF ( istat == 0 ) THEN
10658	var = var(1:7)
10659	ENDIF
10660	ENDIF
10661
10662	local_pf = fill_value
10663
10664	SELECT CASE ( TRIM( var ) )
10665	!-- block of large scale radiation model (e.g. RRTMG) output variables
10666	CASE ( 'rad_sw_in' )
10667	IF ( av == 0 ) THEN
10668	DO i = nxl, nxr
10669	DO j = nys, nyn
10670	DO k = nzb_do, nzt_do
10671	local_pf(i,j,k) = rad_sw_in(k,j,i)
10672	ENDDO
10673	ENDDO
10674	ENDDO
10675	ELSE
10676	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
10677	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10678	rad_sw_in_av = REAL( fill_value, KIND = wp )
10679	ENDIF
10680	DO i = nxl, nxr
10681	DO j = nys, nyn
10682	DO k = nzb_do, nzt_do
10683	local_pf(i,j,k) = rad_sw_in_av(k,j,i)
10684	ENDDO
10685	ENDDO
10686	ENDDO
10687	ENDIF
10688
10689	CASE ( 'rad_sw_out' )
10690	IF ( av == 0 ) THEN
10691	DO i = nxl, nxr
10692	DO j = nys, nyn
10693	DO k = nzb_do, nzt_do
10694	local_pf(i,j,k) = rad_sw_out(k,j,i)
10695	ENDDO
10696	ENDDO
10697	ENDDO
10698	ELSE
10699	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
10700	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10701	rad_sw_out_av = REAL( fill_value, KIND = wp )
10702	ENDIF
10703	DO i = nxl, nxr
10704	DO j = nys, nyn
10705	DO k = nzb_do, nzt_do
10706	local_pf(i,j,k) = rad_sw_out_av(k,j,i)
10707	ENDDO
10708	ENDDO
10709	ENDDO
10710	ENDIF
10711
10712	CASE ( 'rad_sw_cs_hr' )
10713	IF ( av == 0 ) THEN
10714	DO i = nxl, nxr
10715	DO j = nys, nyn
10716	DO k = nzb_do, nzt_do
10717	local_pf(i,j,k) = rad_sw_cs_hr(k,j,i)
10718	ENDDO
10719	ENDDO
10720	ENDDO
10721	ELSE
10722	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
10723	ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10724	rad_sw_cs_hr_av = REAL( fill_value, KIND = wp )
10725	ENDIF
10726	DO i = nxl, nxr
10727	DO j = nys, nyn
10728	DO k = nzb_do, nzt_do
10729	local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i)
10730	ENDDO
10731	ENDDO
10732	ENDDO
10733	ENDIF
10734
10735	CASE ( 'rad_sw_hr' )
10736	IF ( av == 0 ) THEN
10737	DO i = nxl, nxr
10738	DO j = nys, nyn
10739	DO k = nzb_do, nzt_do
10740	local_pf(i,j,k) = rad_sw_hr(k,j,i)
10741	ENDDO
10742	ENDDO
10743	ENDDO
10744	ELSE
10745	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
10746	ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10747	rad_sw_hr_av = REAL( fill_value, KIND = wp )
10748	ENDIF
10749	DO i = nxl, nxr
10750	DO j = nys, nyn
10751	DO k = nzb_do, nzt_do
10752	local_pf(i,j,k) = rad_sw_hr_av(k,j,i)
10753	ENDDO
10754	ENDDO
10755	ENDDO
10756	ENDIF
10757
10758	CASE ( 'rad_lw_in' )
10759	IF ( av == 0 ) THEN
10760	DO i = nxl, nxr
10761	DO j = nys, nyn
10762	DO k = nzb_do, nzt_do
10763	local_pf(i,j,k) = rad_lw_in(k,j,i)
10764	ENDDO
10765	ENDDO
10766	ENDDO
10767	ELSE
10768	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
10769	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10770	rad_lw_in_av = REAL( fill_value, KIND = wp )
10771	ENDIF
10772	DO i = nxl, nxr
10773	DO j = nys, nyn
10774	DO k = nzb_do, nzt_do
10775	local_pf(i,j,k) = rad_lw_in_av(k,j,i)
10776	ENDDO
10777	ENDDO
10778	ENDDO
10779	ENDIF
10780
10781	CASE ( 'rad_lw_out' )
10782	IF ( av == 0 ) THEN
10783	DO i = nxl, nxr
10784	DO j = nys, nyn
10785	DO k = nzb_do, nzt_do
10786	local_pf(i,j,k) = rad_lw_out(k,j,i)
10787	ENDDO
10788	ENDDO
10789	ENDDO
10790	ELSE
10791	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
10792	ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10793	rad_lw_out_av = REAL( fill_value, KIND = wp )
10794	ENDIF
10795	DO i = nxl, nxr
10796	DO j = nys, nyn
10797	DO k = nzb_do, nzt_do
10798	local_pf(i,j,k) = rad_lw_out_av(k,j,i)
10799	ENDDO
10800	ENDDO
10801	ENDDO
10802	ENDIF
10803
10804	CASE ( 'rad_lw_cs_hr' )
10805	IF ( av == 0 ) THEN
10806	DO i = nxl, nxr
10807	DO j = nys, nyn
10808	DO k = nzb_do, nzt_do
10809	local_pf(i,j,k) = rad_lw_cs_hr(k,j,i)
10810	ENDDO
10811	ENDDO
10812	ENDDO
10813	ELSE
10814	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
10815	ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10816	rad_lw_cs_hr_av = REAL( fill_value, KIND = wp )
10817	ENDIF
10818	DO i = nxl, nxr
10819	DO j = nys, nyn
10820	DO k = nzb_do, nzt_do
10821	local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i)
10822	ENDDO
10823	ENDDO
10824	ENDDO
10825	ENDIF
10826
10827	CASE ( 'rad_lw_hr' )
10828	IF ( av == 0 ) THEN
10829	DO i = nxl, nxr
10830	DO j = nys, nyn
10831	DO k = nzb_do, nzt_do
10832	local_pf(i,j,k) = rad_lw_hr(k,j,i)
10833	ENDDO
10834	ENDDO
10835	ENDDO
10836	ELSE
10837	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
10838	ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10839	rad_lw_hr_av = REAL( fill_value, KIND = wp )
10840	ENDIF
10841	DO i = nxl, nxr
10842	DO j = nys, nyn
10843	DO k = nzb_do, nzt_do
10844	local_pf(i,j,k) = rad_lw_hr_av(k,j,i)
10845	ENDDO
10846	ENDDO
10847	ENDDO
10848	ENDIF
10849
10850	CASE ( 'rtm_rad_net' )
10851	!-- array of complete radiation balance
10852	DO isurf = dirstart(ids), dirend(ids)
10853	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10854	IF ( av == 0 ) THEN
10855	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = &
10856	surfinsw(isurf) - surfoutsw(isurf) + surfinlw(isurf) - surfoutlw(isurf)
10857	ELSE
10858	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfradnet_av(isurf)
10859	ENDIF
10860	ENDIF
10861	ENDDO
10862
10863	CASE ( 'rtm_rad_insw' )
10864	!-- array of sw radiation falling to surface after i-th reflection
10865	DO isurf = dirstart(ids), dirend(ids)
10866	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10867	IF ( av == 0 ) THEN
10868	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinsw(isurf)
10869	ELSE
10870	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinsw_av(isurf)
10871	ENDIF
10872	ENDIF
10873	ENDDO
10874
10875	CASE ( 'rtm_rad_inlw' )
10876	!-- array of lw radiation falling to surface after i-th reflection
10877	DO isurf = dirstart(ids), dirend(ids)
10878	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10879	IF ( av == 0 ) THEN
10880	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw(isurf)
10881	ELSE
10882	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw_av(isurf)
10883	ENDIF
10884	ENDIF
10885	ENDDO
10886
10887	CASE ( 'rtm_rad_inswdir' )
10888	!-- array of direct sw radiation falling to surface from sun
10889	DO isurf = dirstart(ids), dirend(ids)
10890	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10891	IF ( av == 0 ) THEN
10892	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdir(isurf)
10893	ELSE
10894	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdir_av(isurf)
10895	ENDIF
10896	ENDIF
10897	ENDDO
10898
10899	CASE ( 'rtm_rad_inswdif' )
10900	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
10901	DO isurf = dirstart(ids), dirend(ids)
10902	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10903	IF ( av == 0 ) THEN
10904	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdif(isurf)
10905	ELSE
10906	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdif_av(isurf)
10907	ENDIF
10908	ENDIF
10909	ENDDO
10910
10911	CASE ( 'rtm_rad_inswref' )
10912	!-- array of sw radiation falling to surface from reflections
10913	DO isurf = dirstart(ids), dirend(ids)
10914	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10915	IF ( av == 0 ) THEN
10916	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = &
10917	surfinsw(isurf) - surfinswdir(isurf) - surfinswdif(isurf)
10918	ELSE
10919	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswref_av(isurf)
10920	ENDIF
10921	ENDIF
10922	ENDDO
10923
10924	CASE ( 'rtm_rad_inlwdif' )
10925	!-- array of difusion lw radiation falling to surface from sky and borders of the domain
10926	DO isurf = dirstart(ids), dirend(ids)
10927	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10928	IF ( av == 0 ) THEN
10929	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwdif(isurf)
10930	ELSE
10931	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwdif_av(isurf)
10932	ENDIF
10933	ENDIF
10934	ENDDO
10935
10936	CASE ( 'rtm_rad_inlwref' )
10937	!-- array of lw radiation falling to surface from reflections
10938	DO isurf = dirstart(ids), dirend(ids)
10939	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10940	IF ( av == 0 ) THEN
10941	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw(isurf) - surfinlwdif(isurf)
10942	ELSE
10943	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwref_av(isurf)
10944	ENDIF
10945	ENDIF
10946	ENDDO
10947
10948	CASE ( 'rtm_rad_outsw' )
10949	!-- array of sw radiation emitted from surface after i-th reflection
10950	DO isurf = dirstart(ids), dirend(ids)
10951	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10952	IF ( av == 0 ) THEN
10953	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutsw(isurf)
10954	ELSE
10955	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutsw_av(isurf)
10956	ENDIF
10957	ENDIF
10958	ENDDO
10959
10960	CASE ( 'rtm_rad_outlw' )
10961	!-- array of lw radiation emitted from surface after i-th reflection
10962	DO isurf = dirstart(ids), dirend(ids)
10963	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10964	IF ( av == 0 ) THEN
10965	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutlw(isurf)
10966	ELSE
10967	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutlw_av(isurf)
10968	ENDIF
10969	ENDIF
10970	ENDDO
10971
10972	CASE ( 'rtm_rad_ressw' )
10973	!-- average of array of residua of sw radiation absorbed in surface after last reflection
10974	DO isurf = dirstart(ids), dirend(ids)
10975	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10976	IF ( av == 0 ) THEN
10977	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfins(isurf)
10978	ELSE
10979	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfins_av(isurf)
10980	ENDIF
10981	ENDIF
10982	ENDDO
10983
10984	CASE ( 'rtm_rad_reslw' )
10985	!-- average of array of residua of lw radiation absorbed in surface after last reflection
10986	DO isurf = dirstart(ids), dirend(ids)
10987	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10988	IF ( av == 0 ) THEN
10989	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinl(isurf)
10990	ELSE
10991	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinl_av(isurf)
10992	ENDIF
10993	ENDIF
10994	ENDDO
10995
10996	CASE ( 'rtm_rad_pc_inlw' )
10997	!-- array of lw radiation absorbed by plant canopy
10998	DO ipcgb = 1, npcbl
10999	IF ( av == 0 ) THEN
11000	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinlw(ipcgb)
11001	ELSE
11002	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinlw_av(ipcgb)
11003	ENDIF
11004	ENDDO
11005
11006	CASE ( 'rtm_rad_pc_insw' )
11007	!-- array of sw radiation absorbed by plant canopy
11008	DO ipcgb = 1, npcbl
11009	IF ( av == 0 ) THEN
11010	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinsw(ipcgb)
11011	ELSE
11012	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinsw_av(ipcgb)
11013	ENDIF
11014	ENDDO
11015
11016	CASE ( 'rtm_rad_pc_inswdir' )
11017	!-- array of direct sw radiation absorbed by plant canopy
11018	DO ipcgb = 1, npcbl
11019	IF ( av == 0 ) THEN
11020	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdir(ipcgb)
11021	ELSE
11022	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdir_av(ipcgb)
11023	ENDIF
11024	ENDDO
11025
11026	CASE ( 'rtm_rad_pc_inswdif' )
11027	!-- array of diffuse sw radiation absorbed by plant canopy
11028	DO ipcgb = 1, npcbl
11029	IF ( av == 0 ) THEN
11030	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdif(ipcgb)
11031	ELSE
11032	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdif_av(ipcgb)
11033	ENDIF
11034	ENDDO
11035
11036	CASE ( 'rtm_rad_pc_inswref' )
11037	!-- array of reflected sw radiation absorbed by plant canopy
11038	DO ipcgb = 1, npcbl
11039	IF ( av == 0 ) THEN
11040	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = &
11041	pcbinsw(ipcgb) - pcbinswdir(ipcgb) - pcbinswdif(ipcgb)
11042	ELSE
11043	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswref_av(ipcgb)
11044	ENDIF
11045	ENDDO
11046
11047	CASE ( 'rtm_mrt_sw' )
11048	local_pf = REAL( fill_value, KIND = wp )
11049	IF ( av == 0 ) THEN
11050	DO l = 1, nmrtbl
11051	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinsw(l)
11052	ENDDO
11053	ELSE
11054	IF ( ALLOCATED( mrtinsw_av ) ) THEN
11055	DO l = 1, nmrtbl
11056	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinsw_av(l)
11057	ENDDO
11058	ENDIF
11059	ENDIF
11060
11061	CASE ( 'rtm_mrt_lw' )
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)) = mrtinlw(l)
11066	ENDDO
11067	ELSE
11068	IF ( ALLOCATED( mrtinlw_av ) ) THEN
11069	DO l = 1, nmrtbl
11070	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinlw_av(l)
11071	ENDDO
11072	ENDIF
11073	ENDIF
11074
11075	CASE ( 'rtm_mrt' )
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)) = mrt(l)
11080	ENDDO
11081	ELSE
11082	IF ( ALLOCATED( mrt_av ) ) THEN
11083	DO l = 1, nmrtbl
11084	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrt_av(l)
11085	ENDDO
11086	ENDIF
11087	ENDIF
11088	!
11089	!-- block of RTM output variables
11090	!-- variables are intended mainly for debugging and detailed analyse purposes
11091	CASE ( 'rtm_skyvf' )
11092	!
11093	!-- sky view factor
11094	DO isurf = dirstart(ids), dirend(ids)
11095	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11096	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = skyvf(isurf)
11097	ENDIF
11098	ENDDO
11099
11100	CASE ( 'rtm_skyvft' )
11101	!
11102	!-- sky view factor
11103	DO isurf = dirstart(ids), dirend(ids)
11104	IF ( surfl(id,isurf) == ids ) THEN
11105	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = skyvft(isurf)
11106	ENDIF
11107	ENDDO
11108
11109	CASE ( 'rtm_svf', 'rtm_dif' )
11110	!
11111	!-- shape view factors or iradiance factors to selected surface
11112	IF ( TRIM(var)=='rtm_svf' ) THEN
11113	k = 1
11114	ELSE
11115	k = 2
11116	ENDIF
11117	DO isvf = 1, nsvfl
11118	isurflt = svfsurf(1, isvf)
11119	isurfs = svfsurf(2, isvf)
11120
11121	IF ( surf(ix,isurfs) == is .AND. surf(iy,isurfs) == js .AND. surf(iz,isurfs) == ks .AND. &
11122	(surf(id,isurfs) == idsint_u .OR. surfl(id,isurfs) == idsint_l ) ) THEN
11123	!
11124	!-- correct source surface
11125	local_pf(surfl(ix,isurflt),surfl(iy,isurflt),surfl(iz,isurflt)) = svf(k,isvf)
11126	ENDIF
11127	ENDDO
11128
11129	CASE ( 'rtm_surfalb' )
11130	!
11131	!-- surface albedo
11132	DO isurf = dirstart(ids), dirend(ids)
11133	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11134	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = albedo_surf(isurf)
11135	ENDIF
11136	ENDDO
11137
11138	CASE ( 'rtm_surfemis' )
11139	!
11140	!-- surface emissivity, weighted average
11141	DO isurf = dirstart(ids), dirend(ids)
11142	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11143	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = emiss_surf(isurf)
11144	ENDIF
11145	ENDDO
11146
11147	CASE DEFAULT
11148	found = .FALSE.
11149
11150	END SELECT
11151
11152
11153	END SUBROUTINE radiation_data_output_3d
11154
11155	!------------------------------------------------------------------------------!
11156	!
11157	! Description:
11158	! ------------
11159	!> Subroutine defining masked data output
11160	!------------------------------------------------------------------------------!
11161	SUBROUTINE radiation_data_output_mask( av, variable, found, local_pf, mid )
11162
11163	USE control_parameters
11164
11165	USE indices
11166
11167	USE kinds
11168
11169
11170	IMPLICIT NONE
11171
11172	CHARACTER (LEN=*) :: variable !<
11173
11174	CHARACTER(LEN=5) :: grid !< flag to distinquish between staggered grids
11175
11176	INTEGER(iwp) :: av !<
11177	INTEGER(iwp) :: i !<
11178	INTEGER(iwp) :: j !<
11179	INTEGER(iwp) :: k !<
11180	INTEGER(iwp) :: mid !< masked output running index
11181	INTEGER(iwp) :: topo_top_index !< k index of highest horizontal surface
11182
11183	LOGICAL :: found !< true if output array was found
11184	LOGICAL :: resorted !< true if array is resorted
11185
11186
11187	REAL(wp), &
11188	DIMENSION(mask_size_l(mid,1),mask_size_l(mid,2),mask_size_l(mid,3)) :: &
11189	local_pf !<
11190
11191	REAL(wp), DIMENSION(:,:,:), POINTER :: to_be_resorted !< points to array which needs to be resorted for output
11192
11193
11194	found = .TRUE.
11195	grid = 's'
11196	resorted = .FALSE.
11197
11198	SELECT CASE ( TRIM( variable ) )
11199
11200
11201	CASE ( 'rad_lw_in' )
11202	IF ( av == 0 ) THEN
11203	to_be_resorted => rad_lw_in
11204	ELSE
11205	to_be_resorted => rad_lw_in_av
11206	ENDIF
11207
11208	CASE ( 'rad_lw_out' )
11209	IF ( av == 0 ) THEN
11210	to_be_resorted => rad_lw_out
11211	ELSE
11212	to_be_resorted => rad_lw_out_av
11213	ENDIF
11214
11215	CASE ( 'rad_lw_cs_hr' )
11216	IF ( av == 0 ) THEN
11217	to_be_resorted => rad_lw_cs_hr
11218	ELSE
11219	to_be_resorted => rad_lw_cs_hr_av
11220	ENDIF
11221
11222	CASE ( 'rad_lw_hr' )
11223	IF ( av == 0 ) THEN
11224	to_be_resorted => rad_lw_hr
11225	ELSE
11226	to_be_resorted => rad_lw_hr_av
11227	ENDIF
11228
11229	CASE ( 'rad_sw_in' )
11230	IF ( av == 0 ) THEN
11231	to_be_resorted => rad_sw_in
11232	ELSE
11233	to_be_resorted => rad_sw_in_av
11234	ENDIF
11235
11236	CASE ( 'rad_sw_out' )
11237	IF ( av == 0 ) THEN
11238	to_be_resorted => rad_sw_out
11239	ELSE
11240	to_be_resorted => rad_sw_out_av
11241	ENDIF
11242
11243	CASE ( 'rad_sw_cs_hr' )
11244	IF ( av == 0 ) THEN
11245	to_be_resorted => rad_sw_cs_hr
11246	ELSE
11247	to_be_resorted => rad_sw_cs_hr_av
11248	ENDIF
11249
11250	CASE ( 'rad_sw_hr' )
11251	IF ( av == 0 ) THEN
11252	to_be_resorted => rad_sw_hr
11253	ELSE
11254	to_be_resorted => rad_sw_hr_av
11255	ENDIF
11256
11257	CASE DEFAULT
11258	found = .FALSE.
11259
11260	END SELECT
11261
11262	!
11263	!-- Resort the array to be output, if not done above
11264	IF ( found .AND. .NOT. resorted ) THEN
11265	IF ( .NOT. mask_surface(mid) ) THEN
11266	!
11267	!-- Default masked output
11268	DO i = 1, mask_size_l(mid,1)
11269	DO j = 1, mask_size_l(mid,2)
11270	DO k = 1, mask_size_l(mid,3)
11271	local_pf(i,j,k) = to_be_resorted(mask_k(mid,k), &
11272	mask_j(mid,j),mask_i(mid,i))
11273	ENDDO
11274	ENDDO
11275	ENDDO
11276
11277	ELSE
11278	!
11279	!-- Terrain-following masked output
11280	DO i = 1, mask_size_l(mid,1)
11281	DO j = 1, mask_size_l(mid,2)
11282	!
11283	!-- Get k index of highest horizontal surface
11284	topo_top_index = topo_top_ind(mask_j(mid,j), &
11285	mask_i(mid,i), &
11286	0 )
11287	!
11288	!-- Save output array
11289	DO k = 1, mask_size_l(mid,3)
11290	local_pf(i,j,k) = to_be_resorted( &
11291	MIN( topo_top_index+mask_k(mid,k), &
11292	nzt+1 ), &
11293	mask_j(mid,j), &
11294	mask_i(mid,i) )
11295	ENDDO
11296	ENDDO
11297	ENDDO
11298
11299	ENDIF
11300	ENDIF
11301
11302
11303
11304	END SUBROUTINE radiation_data_output_mask
11305
11306
11307	!------------------------------------------------------------------------------!
11308	! Description:
11309	! ------------
11310	!> Subroutine writes local (subdomain) restart data
11311	!------------------------------------------------------------------------------!
11312	SUBROUTINE radiation_wrd_local
11313
11314
11315	IMPLICIT NONE
11316
11317
11318	IF ( ALLOCATED( rad_net_av ) ) THEN
11319	CALL wrd_write_string( 'rad_net_av' )
11320	WRITE ( 14 ) rad_net_av
11321	ENDIF
11322
11323	IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
11324	CALL wrd_write_string( 'rad_lw_in_xy_av' )
11325	WRITE ( 14 ) rad_lw_in_xy_av
11326	ENDIF
11327
11328	IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
11329	CALL wrd_write_string( 'rad_lw_out_xy_av' )
11330	WRITE ( 14 ) rad_lw_out_xy_av
11331	ENDIF
11332
11333	IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
11334	CALL wrd_write_string( 'rad_sw_in_xy_av' )
11335	WRITE ( 14 ) rad_sw_in_xy_av
11336	ENDIF
11337
11338	IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
11339	CALL wrd_write_string( 'rad_sw_out_xy_av' )
11340	WRITE ( 14 ) rad_sw_out_xy_av
11341	ENDIF
11342
11343	IF ( ALLOCATED( rad_lw_in ) ) THEN
11344	CALL wrd_write_string( 'rad_lw_in' )
11345	WRITE ( 14 ) rad_lw_in
11346	ENDIF
11347
11348	IF ( ALLOCATED( rad_lw_in_av ) ) THEN
11349	CALL wrd_write_string( 'rad_lw_in_av' )
11350	WRITE ( 14 ) rad_lw_in_av
11351	ENDIF
11352
11353	IF ( ALLOCATED( rad_lw_out ) ) THEN
11354	CALL wrd_write_string( 'rad_lw_out' )
11355	WRITE ( 14 ) rad_lw_out
11356	ENDIF
11357
11358	IF ( ALLOCATED( rad_lw_out_av) ) THEN
11359	CALL wrd_write_string( 'rad_lw_out_av' )
11360	WRITE ( 14 ) rad_lw_out_av
11361	ENDIF
11362
11363	IF ( ALLOCATED( rad_lw_cs_hr) ) THEN
11364	CALL wrd_write_string( 'rad_lw_cs_hr' )
11365	WRITE ( 14 ) rad_lw_cs_hr
11366	ENDIF
11367
11368	IF ( ALLOCATED( rad_lw_cs_hr_av) ) THEN
11369	CALL wrd_write_string( 'rad_lw_cs_hr_av' )
11370	WRITE ( 14 ) rad_lw_cs_hr_av
11371	ENDIF
11372
11373	IF ( ALLOCATED( rad_lw_hr) ) THEN
11374	CALL wrd_write_string( 'rad_lw_hr' )
11375	WRITE ( 14 ) rad_lw_hr
11376	ENDIF
11377
11378	IF ( ALLOCATED( rad_lw_hr_av) ) THEN
11379	CALL wrd_write_string( 'rad_lw_hr_av' )
11380	WRITE ( 14 ) rad_lw_hr_av
11381	ENDIF
11382
11383	IF ( ALLOCATED( rad_sw_in) ) THEN
11384	CALL wrd_write_string( 'rad_sw_in' )
11385	WRITE ( 14 ) rad_sw_in
11386	ENDIF
11387
11388	IF ( ALLOCATED( rad_sw_in_av) ) THEN
11389	CALL wrd_write_string( 'rad_sw_in_av' )
11390	WRITE ( 14 ) rad_sw_in_av
11391	ENDIF
11392
11393	IF ( ALLOCATED( rad_sw_out) ) THEN
11394	CALL wrd_write_string( 'rad_sw_out' )
11395	WRITE ( 14 ) rad_sw_out
11396	ENDIF
11397
11398	IF ( ALLOCATED( rad_sw_out_av) ) THEN
11399	CALL wrd_write_string( 'rad_sw_out_av' )
11400	WRITE ( 14 ) rad_sw_out_av
11401	ENDIF
11402
11403	IF ( ALLOCATED( rad_sw_cs_hr) ) THEN
11404	CALL wrd_write_string( 'rad_sw_cs_hr' )
11405	WRITE ( 14 ) rad_sw_cs_hr
11406	ENDIF
11407
11408	IF ( ALLOCATED( rad_sw_cs_hr_av) ) THEN
11409	CALL wrd_write_string( 'rad_sw_cs_hr_av' )
11410	WRITE ( 14 ) rad_sw_cs_hr_av
11411	ENDIF
11412
11413	IF ( ALLOCATED( rad_sw_hr) ) THEN
11414	CALL wrd_write_string( 'rad_sw_hr' )
11415	WRITE ( 14 ) rad_sw_hr
11416	ENDIF
11417
11418	IF ( ALLOCATED( rad_sw_hr_av) ) THEN
11419	CALL wrd_write_string( 'rad_sw_hr_av' )
11420	WRITE ( 14 ) rad_sw_hr_av
11421	ENDIF
11422
11423
11424	END SUBROUTINE radiation_wrd_local
11425
11426	!------------------------------------------------------------------------------!
11427	! Description:
11428	! ------------
11429	!> Subroutine reads local (subdomain) restart data
11430	!------------------------------------------------------------------------------!
11431	SUBROUTINE radiation_rrd_local( k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, &
11432	nxr_on_file, nynf, nync, nyn_on_file, nysf, &
11433	nysc, nys_on_file, tmp_2d, tmp_3d, found )
11434
11435
11436	USE control_parameters
11437
11438	USE indices
11439
11440	USE kinds
11441
11442	USE pegrid
11443
11444
11445	IMPLICIT NONE
11446
11447	INTEGER(iwp) :: k !<
11448	INTEGER(iwp) :: nxlc !<
11449	INTEGER(iwp) :: nxlf !<
11450	INTEGER(iwp) :: nxl_on_file !<
11451	INTEGER(iwp) :: nxrc !<
11452	INTEGER(iwp) :: nxrf !<
11453	INTEGER(iwp) :: nxr_on_file !<
11454	INTEGER(iwp) :: nync !<
11455	INTEGER(iwp) :: nynf !<
11456	INTEGER(iwp) :: nyn_on_file !<
11457	INTEGER(iwp) :: nysc !<
11458	INTEGER(iwp) :: nysf !<
11459	INTEGER(iwp) :: nys_on_file !<
11460
11461	LOGICAL, INTENT(OUT) :: found
11462
11463	REAL(wp), DIMENSION(nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_2d !<
11464
11465	REAL(wp), DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d !<
11466
11467	REAL(wp), DIMENSION(0:0,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d2 !<
11468
11469
11470	found = .TRUE.
11471
11472
11473	SELECT CASE ( restart_string(1:length) )
11474
11475	CASE ( 'rad_net_av' )
11476	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
11477	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
11478	ENDIF
11479	IF ( k == 1 ) READ ( 13 ) tmp_2d
11480	rad_net_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11481	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11482
11483	CASE ( 'rad_lw_in_xy_av' )
11484	IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
11485	ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
11486	ENDIF
11487	IF ( k == 1 ) READ ( 13 ) tmp_2d
11488	rad_lw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11489	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11490
11491	CASE ( 'rad_lw_out_xy_av' )
11492	IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
11493	ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
11494	ENDIF
11495	IF ( k == 1 ) READ ( 13 ) tmp_2d
11496	rad_lw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11497	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11498
11499	CASE ( 'rad_sw_in_xy_av' )
11500	IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
11501	ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
11502	ENDIF
11503	IF ( k == 1 ) READ ( 13 ) tmp_2d
11504	rad_sw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11505	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11506
11507	CASE ( 'rad_sw_out_xy_av' )
11508	IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
11509	ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
11510	ENDIF
11511	IF ( k == 1 ) READ ( 13 ) tmp_2d
11512	rad_sw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11513	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11514
11515	CASE ( 'rad_lw_in' )
11516	IF ( .NOT. ALLOCATED( rad_lw_in ) ) THEN
11517	IF ( radiation_scheme == 'clear-sky' .OR. &
11518	radiation_scheme == 'constant' .OR. &
11519	radiation_scheme == 'external' ) THEN
11520	ALLOCATE( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) )
11521	ELSE
11522	ALLOCATE( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11523	ENDIF
11524	ENDIF
11525	IF ( k == 1 ) THEN
11526	IF ( radiation_scheme == 'clear-sky' .OR. &
11527	radiation_scheme == 'constant' .OR. &
11528	radiation_scheme == 'external' ) THEN
11529	READ ( 13 ) tmp_3d2
11530	rad_lw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11531	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11532	ELSE
11533	READ ( 13 ) tmp_3d
11534	rad_lw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11535	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11536	ENDIF
11537	ENDIF
11538
11539	CASE ( 'rad_lw_in_av' )
11540	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
11541	IF ( radiation_scheme == 'clear-sky' .OR. &
11542	radiation_scheme == 'constant' .OR. &
11543	radiation_scheme == 'external' ) THEN
11544	ALLOCATE( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
11545	ELSE
11546	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11547	ENDIF
11548	ENDIF
11549	IF ( k == 1 ) THEN
11550	IF ( radiation_scheme == 'clear-sky' .OR. &
11551	radiation_scheme == 'constant' .OR. &
11552	radiation_scheme == 'external' ) THEN
11553	READ ( 13 ) tmp_3d2
11554	rad_lw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&
11555	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11556	ELSE
11557	READ ( 13 ) tmp_3d
11558	rad_lw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11559	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11560	ENDIF
11561	ENDIF
11562
11563	CASE ( 'rad_lw_out' )
11564	IF ( .NOT. ALLOCATED( rad_lw_out ) ) THEN
11565	IF ( radiation_scheme == 'clear-sky' .OR. &
11566	radiation_scheme == 'constant' .OR. &
11567	radiation_scheme == 'external' ) THEN
11568	ALLOCATE( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) )
11569	ELSE
11570	ALLOCATE( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11571	ENDIF
11572	ENDIF
11573	IF ( k == 1 ) THEN
11574	IF ( radiation_scheme == 'clear-sky' .OR. &
11575	radiation_scheme == 'constant' .OR. &
11576	radiation_scheme == 'external' ) THEN
11577	READ ( 13 ) tmp_3d2
11578	rad_lw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11579	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11580	ELSE
11581	READ ( 13 ) tmp_3d
11582	rad_lw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11583	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11584	ENDIF
11585	ENDIF
11586
11587	CASE ( 'rad_lw_out_av' )
11588	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
11589	IF ( radiation_scheme == 'clear-sky' .OR. &
11590	radiation_scheme == 'constant' .OR. &
11591	radiation_scheme == 'external' ) THEN
11592	ALLOCATE( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
11593	ELSE
11594	ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11595	ENDIF
11596	ENDIF
11597	IF ( k == 1 ) THEN
11598	IF ( radiation_scheme == 'clear-sky' .OR. &
11599	radiation_scheme == 'constant' .OR. &
11600	radiation_scheme == 'external' ) THEN
11601	READ ( 13 ) tmp_3d2
11602	rad_lw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) &
11603	= tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11604	ELSE
11605	READ ( 13 ) tmp_3d
11606	rad_lw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11607	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11608	ENDIF
11609	ENDIF
11610
11611	CASE ( 'rad_lw_cs_hr' )
11612	IF ( .NOT. ALLOCATED( rad_lw_cs_hr ) ) THEN
11613	ALLOCATE( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11614	ENDIF
11615	IF ( k == 1 ) READ ( 13 ) tmp_3d
11616	rad_lw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11617	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11618
11619	CASE ( 'rad_lw_cs_hr_av' )
11620	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
11621	ALLOCATE( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11622	ENDIF
11623	IF ( k == 1 ) READ ( 13 ) tmp_3d
11624	rad_lw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11625	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11626
11627	CASE ( 'rad_lw_hr' )
11628	IF ( .NOT. ALLOCATED( rad_lw_hr ) ) THEN
11629	ALLOCATE( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11630	ENDIF
11631	IF ( k == 1 ) READ ( 13 ) tmp_3d
11632	rad_lw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11633	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11634
11635	CASE ( 'rad_lw_hr_av' )
11636	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
11637	ALLOCATE( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11638	ENDIF
11639	IF ( k == 1 ) READ ( 13 ) tmp_3d
11640	rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11641	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11642
11643	CASE ( 'rad_sw_in' )
11644	IF ( .NOT. ALLOCATED( rad_sw_in ) ) THEN
11645	IF ( radiation_scheme == 'clear-sky' .OR. &
11646	radiation_scheme == 'constant' .OR. &
11647	radiation_scheme == 'external' ) THEN
11648	ALLOCATE( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) )
11649	ELSE
11650	ALLOCATE( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11651	ENDIF
11652	ENDIF
11653	IF ( k == 1 ) THEN
11654	IF ( radiation_scheme == 'clear-sky' .OR. &
11655	radiation_scheme == 'constant' .OR. &
11656	radiation_scheme == 'external' ) THEN
11657	READ ( 13 ) tmp_3d2
11658	rad_sw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11659	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11660	ELSE
11661	READ ( 13 ) tmp_3d
11662	rad_sw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11663	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11664	ENDIF
11665	ENDIF
11666
11667	CASE ( 'rad_sw_in_av' )
11668	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
11669	IF ( radiation_scheme == 'clear-sky' .OR. &
11670	radiation_scheme == 'constant' .OR. &
11671	radiation_scheme == 'external' ) THEN
11672	ALLOCATE( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
11673	ELSE
11674	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11675	ENDIF
11676	ENDIF
11677	IF ( k == 1 ) THEN
11678	IF ( radiation_scheme == 'clear-sky' .OR. &
11679	radiation_scheme == 'constant' .OR. &
11680	radiation_scheme == 'external' ) THEN
11681	READ ( 13 ) tmp_3d2
11682	rad_sw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&
11683	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11684	ELSE
11685	READ ( 13 ) tmp_3d
11686	rad_sw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11687	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11688	ENDIF
11689	ENDIF
11690
11691	CASE ( 'rad_sw_out' )
11692	IF ( .NOT. ALLOCATED( rad_sw_out ) ) THEN
11693	IF ( radiation_scheme == 'clear-sky' .OR. &
11694	radiation_scheme == 'constant' .OR. &
11695	radiation_scheme == 'external' ) THEN
11696	ALLOCATE( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) )
11697	ELSE
11698	ALLOCATE( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11699	ENDIF
11700	ENDIF
11701	IF ( k == 1 ) THEN
11702	IF ( radiation_scheme == 'clear-sky' .OR. &
11703	radiation_scheme == 'constant' .OR. &
11704	radiation_scheme == 'external' ) THEN
11705	READ ( 13 ) tmp_3d2
11706	rad_sw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11707	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11708	ELSE
11709	READ ( 13 ) tmp_3d
11710	rad_sw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11711	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11712	ENDIF
11713	ENDIF
11714
11715	CASE ( 'rad_sw_out_av' )
11716	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
11717	IF ( radiation_scheme == 'clear-sky' .OR. &
11718	radiation_scheme == 'constant' .OR. &
11719	radiation_scheme == 'external' ) THEN
11720	ALLOCATE( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
11721	ELSE
11722	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11723	ENDIF
11724	ENDIF
11725	IF ( k == 1 ) THEN
11726	IF ( radiation_scheme == 'clear-sky' .OR. &
11727	radiation_scheme == 'constant' .OR. &
11728	radiation_scheme == 'external' ) THEN
11729	READ ( 13 ) tmp_3d2
11730	rad_sw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) &
11731	= tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11732	ELSE
11733	READ ( 13 ) tmp_3d
11734	rad_sw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11735	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11736	ENDIF
11737	ENDIF
11738
11739	CASE ( 'rad_sw_cs_hr' )
11740	IF ( .NOT. ALLOCATED( rad_sw_cs_hr ) ) THEN
11741	ALLOCATE( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11742	ENDIF
11743	IF ( k == 1 ) READ ( 13 ) tmp_3d
11744	rad_sw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11745	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11746
11747	CASE ( 'rad_sw_cs_hr_av' )
11748	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
11749	ALLOCATE( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11750	ENDIF
11751	IF ( k == 1 ) READ ( 13 ) tmp_3d
11752	rad_sw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11753	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11754
11755	CASE ( 'rad_sw_hr' )
11756	IF ( .NOT. ALLOCATED( rad_sw_hr ) ) THEN
11757	ALLOCATE( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11758	ENDIF
11759	IF ( k == 1 ) READ ( 13 ) tmp_3d
11760	rad_sw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11761	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11762
11763	CASE ( 'rad_sw_hr_av' )
11764	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
11765	ALLOCATE( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11766	ENDIF
11767	IF ( k == 1 ) READ ( 13 ) tmp_3d
11768	rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11769	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11770
11771	CASE DEFAULT
11772
11773	found = .FALSE.
11774
11775	END SELECT
11776
11777	END SUBROUTINE radiation_rrd_local
11778
11779
11780	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 @ 4197

Download in other formats: