Home

Context Navigation

radiation_model_mod.f90 @ 4190

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

Implement external radiation forcing also for level-of-detail = 2 (horizontally 2D radiation)

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: 525.4 KB

Line
1	!> @file radiation_model_mod.f90
2	!------------------------------------------------------------------------------!
3	! This file is part of the PALM model system.
4	!
5	! PALM is free software: you can redistribute it and/or modify it under the
6	! terms of the GNU General Public License as published by the Free Software
7	! Foundation, either version 3 of the License, or (at your option) any later
8	! version.
9	!
10	! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11	! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12	! A PARTICULAR PURPOSE. See the GNU General Public License for more details.
13	!
14	! You should have received a copy of the GNU General Public License along with
15	! PALM. If not, see <http://www.gnu.org/licenses/>.
16	!
17	! Copyright 2015-2019 Institute of Computer Science of the
18	! Czech Academy of Sciences, Prague
19	! Copyright 2015-2019 Czech Technical University in Prague
20	! Copyright 1997-2019 Leibniz Universitaet Hannover
21	!------------------------------------------------------------------------------!
22	!
23	! Current revisions:
24	! ------------------
25	!
26	!
27	! Former revisions:
28	! -----------------
29	! $Id: radiation_model_mod.f90 4190 2019-08-27 15:42:37Z suehring $
30	! Implement external radiation forcing also for level-of-detail = 2
31	! (horizontally 2D radiation)
32	!
33	! 4188 2019-08-26 14:15:47Z suehring
34	! Minor adjustment in error message
35	!
36	! 4187 2019-08-26 12:43:15Z suehring
37	! - Take external radiation from root domain dynamic input if not provided for
38	! each nested domain
39	! - Combine MPI_ALLREDUCE calls to reduce mpi overhead
40	!
41	! 4182 2019-08-22 15:20:23Z scharf
42	! Corrected "Former revisions" section
43	!
44	! 4179 2019-08-21 11:16:12Z suehring
45	! Remove debug prints
46	!
47	! 4178 2019-08-21 11:13:06Z suehring
48	! External radiation forcing implemented.
49	!
50	! 4168 2019-08-16 13:50:17Z suehring
51	! Replace function get_topography_top_index by topo_top_ind
52	!
53	! 4157 2019-08-14 09:19:12Z suehring
54	! Give informative message on raytracing distance only by core zero
55	!
56	! 4148 2019-08-08 11:26:00Z suehring
57	! Comments added
58	!
59	! 4134 2019-08-02 18:39:57Z suehring
60	! Bugfix in formatted write statement
61	!
62	! 4127 2019-07-30 14:47:10Z suehring
63	! Remove unused pch_index (merge from branch resler)
64	!
65	! 4089 2019-07-11 14:30:27Z suehring
66	! - Correct level 2 initialization of spectral albedos in rrtmg branch, long- and
67	! shortwave albedos were mixed-up.
68	! - Change order of albedo_pars so that it is now consistent with the defined
69	! order of albedo_pars in PIDS
70	!
71	! 4069 2019-07-01 14:05:51Z Giersch
72	! Masked output running index mid has been introduced as a local variable to
73	! avoid runtime error (Loop variable has been modified) in time_integration
74	!
75	! 4067 2019-07-01 13:29:25Z suehring
76	! Bugfix, pass dummy string to MPI_INFO_SET (J. Resler)
77	!
78	! 4039 2019-06-18 10:32:41Z suehring
79	! Bugfix for masked data output
80	!
81	! 4008 2019-05-30 09:50:11Z moh.hefny
82	! Bugfix in check variable when a variable's string is less than 3
83	! characters is processed. All variables now are checked if they
84	! belong to radiation
85	!
86	! 3992 2019-05-22 16:49:38Z suehring
87	! Bugfix in rrtmg radiation branch in a nested run when the lowest prognistic
88	! grid points in a child domain are all inside topography
89	!
90	! 3987 2019-05-22 09:52:13Z kanani
91	! Introduce alternative switch for debug output during timestepping
92	!
93	! 3943 2019-05-02 09:50:41Z maronga
94	! Missing blank characteer added.
95	!
96	! 3900 2019-04-16 15:17:43Z suehring
97	! Fixed initialization problem
98	!
99	! 3885 2019-04-11 11:29:34Z kanani
100	! Changes related to global restructuring of location messages and introduction
101	! of additional debug messages
102	!
103	! 3881 2019-04-10 09:31:22Z suehring
104	! Output of albedo and emissivity moved from USM, bugfixes in initialization
105	! of albedo
106	!
107	! 3861 2019-04-04 06:27:41Z maronga
108	! Bugfix: factor of 4.0 required instead of 3.0 in calculation of rad_lw_out_change_0
109	!
110	! 3859 2019-04-03 20:30:31Z maronga
111	! Added some descriptions
112	!
113	! 3847 2019-04-01 14:51:44Z suehring
114	! Implement check for dt_radiation (must be > 0)
115	!
116	! 3846 2019-04-01 13:55:30Z suehring
117	! unused variable removed
118	!
119	! 3814 2019-03-26 08:40:31Z pavelkrc
120	! Change zenith(0:0) and others to scalar.
121	! Code review.
122	! Rename exported nzu, nzp and related variables due to name conflict
123	!
124	! 3771 2019-02-28 12:19:33Z raasch
125	! rrtmg preprocessor for directives moved/added, save attribute added to temporary
126	! pointers to avoid compiler warnings about outlived pointer targets,
127	! statement added to avoid compiler warning about unused variable
128	!
129	! 3769 2019-02-28 10:16:49Z moh.hefny
130	! removed unused variables and subroutine radiation_radflux_gridbox
131	!
132	! 3767 2019-02-27 08:18:02Z raasch
133	! unused variable for file index removed from rrd-subroutines parameter list
134	!
135	! 3760 2019-02-21 18:47:35Z moh.hefny
136	! Bugfix: initialized simulated_time before calculating solar position
137	! to enable restart option with reading in SVF from file(s).
138	!
139	! 3754 2019-02-19 17:02:26Z kanani
140	! (resler, pavelkrc)
141	! Bugfixes: add further required MRT factors to read/write_svf,
142	! fix for aggregating view factors to eliminate local noise in reflected
143	! irradiance at mutually close surfaces (corners, presence of trees) in the
144	! angular discretization scheme.
145	!
146	! 3752 2019-02-19 09:37:22Z resler
147	! added read/write number of MRT factors to the respective routines
148	!
149	! 3705 2019-01-29 19:56:39Z suehring
150	! Make variables that are sampled in virtual measurement module public
151	!
152	! 3704 2019-01-29 19:51:41Z suehring
153	! Some interface calls moved to module_interface + cleanup
154	!
155	! 3667 2019-01-10 14:26:24Z schwenkel
156	! Modified check for rrtmg input files
157	!
158	! 3655 2019-01-07 16:51:22Z knoop
159	! nopointer option removed
160	!
161	! 1496 2014-12-02 17:25:50Z maronga
162	! Initial revision
163	!
164	!
165	! Description:
166	! ------------
167	!> Radiation models and interfaces
168	!> @todo Replace dz(1) appropriatly to account for grid stretching
169	!> @todo move variable definitions used in radiation_init only to the subroutine
170	!> as they are no longer required after initialization.
171	!> @todo Output of full column vertical profiles used in RRTMG
172	!> @todo Output of other rrtm arrays (such as volume mixing ratios)
173	!> @todo Check for mis-used NINT() calls in raytrace_2d
174	!> RESULT: Original was correct (carefully verified formula), the change
175	!> to INT broke raytracing -- P. Krc
176	!> @todo Optimize radiation_tendency routines
177	!>
178	!> @note Many variables have a leading dummy dimension (0:0) in order to
179	!> match the assume-size shape expected by the RRTMG model.
180	!------------------------------------------------------------------------------!
181	MODULE radiation_model_mod
182
183	USE arrays_3d, &
184	ONLY: dzw, hyp, nc, pt, p, q, ql, u, v, w, zu, zw, exner, d_exner
185
186	USE basic_constants_and_equations_mod, &
187	ONLY: c_p, g, lv_d_cp, l_v, pi, r_d, rho_l, solar_constant, sigma_sb, &
188	barometric_formula
189
190	USE calc_mean_profile_mod, &
191	ONLY: calc_mean_profile
192
193	USE control_parameters, &
194	ONLY: cloud_droplets, coupling_char, &
195	debug_output, debug_output_timestep, debug_string, &
196	dt_3d, &
197	dz, dt_spinup, end_time, &
198	humidity, &
199	initializing_actions, io_blocks, io_group, &
200	land_surface, large_scale_forcing, &
201	latitude, longitude, lsf_surf, &
202	message_string, plant_canopy, pt_surface, &
203	rho_surface, simulated_time, spinup_time, surface_pressure, &
204	read_svf, write_svf, &
205	time_since_reference_point, urban_surface, varnamelength
206
207	USE cpulog, &
208	ONLY: cpu_log, log_point, log_point_s
209
210	USE grid_variables, &
211	ONLY: ddx, ddy, dx, dy
212
213	USE date_and_time_mod, &
214	ONLY: calc_date_and_time, d_hours_day, d_seconds_hour, d_seconds_year,&
215	day_of_year, d_seconds_year, day_of_month, day_of_year_init, &
216	init_date_and_time, month_of_year, time_utc_init, time_utc
217
218	USE indices, &
219	ONLY: nnx, nny, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, &
220	nzb, nzt, topo_top_ind
221
222	USE, INTRINSIC :: iso_c_binding
223
224	USE kinds
225
226	USE bulk_cloud_model_mod, &
227	ONLY: bulk_cloud_model, microphysics_morrison, na_init, nc_const, sigma_gc
228
229	#if defined ( __netcdf )
230	USE NETCDF
231	#endif
232
233	USE netcdf_data_input_mod, &
234	ONLY: albedo_type_f, &
235	albedo_pars_f, &
236	building_type_f, &
237	pavement_type_f, &
238	vegetation_type_f, &
239	water_type_f, &
240	char_fill, &
241	char_lod, &
242	check_existence, &
243	close_input_file, &
244	get_attribute, &
245	get_variable, &
246	inquire_num_variables, &
247	inquire_variable_names, &
248	input_file_dynamic, &
249	input_pids_dynamic, &
250	netcdf_data_input_get_dimension_length, &
251	num_var_pids, &
252	pids_id, &
253	open_read_file, &
254	real_1d_3d, &
255	vars_pids
256
257	USE plant_canopy_model_mod, &
258	ONLY: lad_s, pc_heating_rate, pc_transpiration_rate, pc_latent_rate, &
259	plant_canopy_transpiration, pcm_calc_transpiration_rate
260
261	USE pegrid
262
263	#if defined ( __rrtmg )
264	USE parrrsw, &
265	ONLY: naerec, nbndsw
266
267	USE parrrtm, &
268	ONLY: nbndlw
269
270	USE rrtmg_lw_init, &
271	ONLY: rrtmg_lw_ini
272
273	USE rrtmg_sw_init, &
274	ONLY: rrtmg_sw_ini
275
276	USE rrtmg_lw_rad, &
277	ONLY: rrtmg_lw
278
279	USE rrtmg_sw_rad, &
280	ONLY: rrtmg_sw
281	#endif
282	USE statistics, &
283	ONLY: hom
284
285	USE surface_mod, &
286	ONLY: ind_pav_green, ind_veg_wall, ind_wat_win, &
287	surf_lsm_h, surf_lsm_v, surf_type, surf_usm_h, surf_usm_v, &
288	vertical_surfaces_exist
289
290	IMPLICIT NONE
291
292	CHARACTER(10) :: radiation_scheme = 'clear-sky' ! 'constant', 'clear-sky', or 'rrtmg'
293
294	!
295	!-- Predefined Land surface classes (albedo_type) after Briegleb (1992)
296	CHARACTER(37), DIMENSION(0:33), PARAMETER :: albedo_type_name = (/ &
297	'user defined ', & ! 0
298	'ocean ', & ! 1
299	'mixed farming, tall grassland ', & ! 2
300	'tall/medium grassland ', & ! 3
301	'evergreen shrubland ', & ! 4
302	'short grassland/meadow/shrubland ', & ! 5
303	'evergreen needleleaf forest ', & ! 6
304	'mixed deciduous evergreen forest ', & ! 7
305	'deciduous forest ', & ! 8
306	'tropical evergreen broadleaved forest', & ! 9
307	'medium/tall grassland/woodland ', & ! 10
308	'desert, sandy ', & ! 11
309	'desert, rocky ', & ! 12
310	'tundra ', & ! 13
311	'land ice ', & ! 14
312	'sea ice ', & ! 15
313	'snow ', & ! 16
314	'bare soil ', & ! 17
315	'asphalt/concrete mix ', & ! 18
316	'asphalt (asphalt concrete) ', & ! 19
317	'concrete (Portland concrete) ', & ! 20
318	'sett ', & ! 21
319	'paving stones ', & ! 22
320	'cobblestone ', & ! 23
321	'metal ', & ! 24
322	'wood ', & ! 25
323	'gravel ', & ! 26
324	'fine gravel ', & ! 27
325	'pebblestone ', & ! 28
326	'woodchips ', & ! 29
327	'tartan (sports) ', & ! 30
328	'artifical turf (sports) ', & ! 31
329	'clay (sports) ', & ! 32
330	'building (dummy) ' & ! 33
331	/)
332
333	INTEGER(iwp) :: albedo_type = 9999999_iwp, & !< Albedo surface type
334	dots_rad = 0_iwp !< starting index for timeseries output
335
336	LOGICAL :: unscheduled_radiation_calls = .TRUE., & !< flag parameter indicating whether additional calls of the radiation code are allowed
337	constant_albedo = .FALSE., & !< flag parameter indicating whether the albedo may change depending on zenith
338	force_radiation_call = .FALSE., & !< flag parameter for unscheduled radiation calls
339	lw_radiation = .TRUE., & !< flag parameter indicating whether longwave radiation shall be calculated
340	radiation = .FALSE., & !< flag parameter indicating whether the radiation model is used
341	sun_up = .TRUE., & !< flag parameter indicating whether the sun is up or down
342	sw_radiation = .TRUE., & !< flag parameter indicating whether shortwave radiation shall be calculated
343	sun_direction = .FALSE., & !< flag parameter indicating whether solar direction shall be calculated
344	average_radiation = .FALSE., & !< flag to set the calculation of radiation averaging for the domain
345	radiation_interactions = .FALSE., & !< flag to activiate RTM (TRUE only if vertical urban/land surface and trees exist)
346	surface_reflections = .TRUE., & !< flag to switch the calculation of radiation interaction between surfaces.
347	!< When it switched off, only the effect of buildings and trees shadow
348	!< will be considered. However fewer SVFs are expected.
349	radiation_interactions_on = .TRUE. !< namelist flag to force RTM activiation regardless to vertical urban/land surface and trees
350
351	REAL(wp) :: albedo = 9999999.9_wp, & !< NAMELIST alpha
352	albedo_lw_dif = 9999999.9_wp, & !< NAMELIST aldif
353	albedo_lw_dir = 9999999.9_wp, & !< NAMELIST aldir
354	albedo_sw_dif = 9999999.9_wp, & !< NAMELIST asdif
355	albedo_sw_dir = 9999999.9_wp, & !< NAMELIST asdir
356	decl_1, & !< declination coef. 1
357	decl_2, & !< declination coef. 2
358	decl_3, & !< declination coef. 3
359	dt_radiation = 0.0_wp, & !< radiation model timestep
360	emissivity = 9999999.9_wp, & !< NAMELIST surface emissivity
361	lon = 0.0_wp, & !< longitude in radians
362	lat = 0.0_wp, & !< latitude in radians
363	net_radiation = 0.0_wp, & !< net radiation at surface
364	skip_time_do_radiation = 0.0_wp, & !< Radiation model is not called before this time
365	sky_trans, & !< sky transmissivity
366	time_radiation = 0.0_wp !< time since last call of radiation code
367
368
369	REAL(wp) :: cos_zenith !< cosine of solar zenith angle, also z-coordinate of solar unit vector
370	REAL(wp) :: sun_dir_lat !< y-coordinate of solar unit vector
371	REAL(wp) :: sun_dir_lon !< x-coordinate of solar unit vector
372
373	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_net_av !< average of net radiation (rad_net) at surface
374	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_xy_av !< average of incoming longwave radiation at surface
375	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_out_xy_av !< average of outgoing longwave radiation at surface
376	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_xy_av !< average of incoming shortwave radiation at surface
377	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_out_xy_av !< average of outgoing shortwave radiation at surface
378
379	REAL(wp), PARAMETER :: emissivity_atm_clsky = 0.8_wp !< emissivity of the clear-sky atmosphere
380	!
381	!-- Land surface albedos for solar zenith angle of 60degree after Briegleb (1992)
382	!-- (broadband, longwave, shortwave ): bb, lw, sw,
383	REAL(wp), DIMENSION(0:2,1:33), PARAMETER :: albedo_pars = RESHAPE( (/&
384	0.06_wp, 0.06_wp, 0.06_wp, & ! 1
385	0.19_wp, 0.28_wp, 0.09_wp, & ! 2
386	0.23_wp, 0.33_wp, 0.11_wp, & ! 3
387	0.23_wp, 0.33_wp, 0.11_wp, & ! 4
388	0.25_wp, 0.34_wp, 0.14_wp, & ! 5
389	0.14_wp, 0.22_wp, 0.06_wp, & ! 6
390	0.17_wp, 0.27_wp, 0.06_wp, & ! 7
391	0.19_wp, 0.31_wp, 0.06_wp, & ! 8
392	0.14_wp, 0.22_wp, 0.06_wp, & ! 9
393	0.18_wp, 0.28_wp, 0.06_wp, & ! 10
394	0.43_wp, 0.51_wp, 0.35_wp, & ! 11
395	0.32_wp, 0.40_wp, 0.24_wp, & ! 12
396	0.19_wp, 0.27_wp, 0.10_wp, & ! 13
397	0.77_wp, 0.65_wp, 0.90_wp, & ! 14
398	0.77_wp, 0.65_wp, 0.90_wp, & ! 15
399	0.82_wp, 0.70_wp, 0.95_wp, & ! 16
400	0.08_wp, 0.08_wp, 0.08_wp, & ! 17
401	0.17_wp, 0.17_wp, 0.17_wp, & ! 18
402	0.17_wp, 0.17_wp, 0.17_wp, & ! 19
403	0.30_wp, 0.30_wp, 0.30_wp, & ! 20
404	0.17_wp, 0.17_wp, 0.17_wp, & ! 21
405	0.17_wp, 0.17_wp, 0.17_wp, & ! 22
406	0.17_wp, 0.17_wp, 0.17_wp, & ! 23
407	0.17_wp, 0.17_wp, 0.17_wp, & ! 24
408	0.17_wp, 0.17_wp, 0.17_wp, & ! 25
409	0.17_wp, 0.17_wp, 0.17_wp, & ! 26
410	0.17_wp, 0.17_wp, 0.17_wp, & ! 27
411	0.17_wp, 0.17_wp, 0.17_wp, & ! 28
412	0.17_wp, 0.17_wp, 0.17_wp, & ! 29
413	0.17_wp, 0.17_wp, 0.17_wp, & ! 30
414	0.17_wp, 0.17_wp, 0.17_wp, & ! 31
415	0.17_wp, 0.17_wp, 0.17_wp, & ! 32
416	0.17_wp, 0.17_wp, 0.17_wp & ! 33
417	/), (/ 3, 33 /) )
418
419	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: &
420	rad_lw_cs_hr, & !< longwave clear sky radiation heating rate (K/s)
421	rad_lw_cs_hr_av, & !< average of rad_lw_cs_hr
422	rad_lw_hr, & !< longwave radiation heating rate (K/s)
423	rad_lw_hr_av, & !< average of rad_sw_hr
424	rad_lw_in, & !< incoming longwave radiation (W/m2)
425	rad_lw_in_av, & !< average of rad_lw_in
426	rad_lw_out, & !< outgoing longwave radiation (W/m2)
427	rad_lw_out_av, & !< average of rad_lw_out
428	rad_sw_cs_hr, & !< shortwave clear sky radiation heating rate (K/s)
429	rad_sw_cs_hr_av, & !< average of rad_sw_cs_hr
430	rad_sw_hr, & !< shortwave radiation heating rate (K/s)
431	rad_sw_hr_av, & !< average of rad_sw_hr
432	rad_sw_in, & !< incoming shortwave radiation (W/m2)
433	rad_sw_in_av, & !< average of rad_sw_in
434	rad_sw_out, & !< outgoing shortwave radiation (W/m2)
435	rad_sw_out_av !< average of rad_sw_out
436
437
438	!
439	!-- Variables and parameters used in RRTMG only
440	#if defined ( __rrtmg )
441	CHARACTER(LEN=12) :: rrtm_input_file = "RAD_SND_DATA" !< name of the NetCDF input file (sounding data)
442
443
444	!
445	!-- Flag parameters to be passed to RRTMG (should not be changed until ice phase in clouds is allowed)
446	INTEGER(iwp), PARAMETER :: rrtm_idrv = 1, & !< flag for longwave upward flux calculation option (0,1)
447	rrtm_inflglw = 2, & !< flag for lw cloud optical properties (0,1,2)
448	rrtm_iceflglw = 0, & !< flag for lw ice particle specifications (0,1,2,3)
449	rrtm_liqflglw = 1, & !< flag for lw liquid droplet specifications
450	rrtm_inflgsw = 2, & !< flag for sw cloud optical properties (0,1,2)
451	rrtm_iceflgsw = 0, & !< flag for sw ice particle specifications (0,1,2,3)
452	rrtm_liqflgsw = 1 !< flag for sw liquid droplet specifications
453
454	!
455	!-- The following variables should be only changed with care, as this will
456	!-- require further setting of some variables, which is currently not
457	!-- implemented (aerosols, ice phase).
458	INTEGER(iwp) :: nzt_rad, & !< upper vertical limit for radiation calculations
459	rrtm_icld = 0, & !< cloud flag (0: clear sky column, 1: cloudy column)
460	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)
461
462	INTEGER(iwp) :: nc_stat !< local variable for storin the result of netCDF calls for error message handling
463
464	LOGICAL :: snd_exists = .FALSE. !< flag parameter to check whether a user-defined input files exists
465	LOGICAL :: sw_exists = .FALSE. !< flag parameter to check whether that required rrtmg sw file exists
466	LOGICAL :: lw_exists = .FALSE. !< flag parameter to check whether that required rrtmg lw file exists
467
468
469	REAL(wp), PARAMETER :: mol_mass_air_d_wv = 1.607793_wp !< molecular weight dry air / water vapor
470
471	REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd, & !< hypostatic pressure from sounding data (hPa)
472	rrtm_tsfc, & !< dummy array for storing surface temperature
473	t_snd !< actual temperature from sounding data (hPa)
474
475	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rrtm_ccl4vmr, & !< CCL4 volume mixing ratio (g/mol)
476	rrtm_cfc11vmr, & !< CFC11 volume mixing ratio (g/mol)
477	rrtm_cfc12vmr, & !< CFC12 volume mixing ratio (g/mol)
478	rrtm_cfc22vmr, & !< CFC22 volume mixing ratio (g/mol)
479	rrtm_ch4vmr, & !< CH4 volume mixing ratio
480	rrtm_cicewp, & !< in-cloud ice water path (g/m2)
481	rrtm_cldfr, & !< cloud fraction (0,1)
482	rrtm_cliqwp, & !< in-cloud liquid water path (g/m2)
483	rrtm_co2vmr, & !< CO2 volume mixing ratio (g/mol)
484	rrtm_emis, & !< surface emissivity (0-1)
485	rrtm_h2ovmr, & !< H2O volume mixing ratio
486	rrtm_n2ovmr, & !< N2O volume mixing ratio
487	rrtm_o2vmr, & !< O2 volume mixing ratio
488	rrtm_o3vmr, & !< O3 volume mixing ratio
489	rrtm_play, & !< pressure layers (hPa, zu-grid)
490	rrtm_plev, & !< pressure layers (hPa, zw-grid)
491	rrtm_reice, & !< cloud ice effective radius (microns)
492	rrtm_reliq, & !< cloud water drop effective radius (microns)
493	rrtm_tlay, & !< actual temperature (K, zu-grid)
494	rrtm_tlev, & !< actual temperature (K, zw-grid)
495	rrtm_lwdflx, & !< RRTM output of incoming longwave radiation flux (W/m2)
496	rrtm_lwdflxc, & !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)
497	rrtm_lwuflx, & !< RRTM output of outgoing longwave radiation flux (W/m2)
498	rrtm_lwuflxc, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)
499	rrtm_lwuflx_dt, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)
500	rrtm_lwuflxc_dt,& !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)
501	rrtm_lwhr, & !< RRTM output of longwave radiation heating rate (K/d)
502	rrtm_lwhrc, & !< RRTM output of incoming longwave clear sky radiation heating rate (K/d)
503	rrtm_swdflx, & !< RRTM output of incoming shortwave radiation flux (W/m2)
504	rrtm_swdflxc, & !< RRTM output of outgoing clear sky shortwave radiation flux (W/m2)
505	rrtm_swuflx, & !< RRTM output of outgoing shortwave radiation flux (W/m2)
506	rrtm_swuflxc, & !< RRTM output of incoming clear sky shortwave radiation flux (W/m2)
507	rrtm_swhr, & !< RRTM output of shortwave radiation heating rate (K/d)
508	rrtm_swhrc, & !< RRTM output of incoming shortwave clear sky radiation heating rate (K/d)
509	rrtm_dirdflux, & !< RRTM output of incoming direct shortwave (W/m2)
510	rrtm_difdflux !< RRTM output of incoming diffuse shortwave (W/m2)
511
512	REAL(wp), DIMENSION(1) :: rrtm_aldif, & !< surface albedo for longwave diffuse radiation
513	rrtm_aldir, & !< surface albedo for longwave direct radiation
514	rrtm_asdif, & !< surface albedo for shortwave diffuse radiation
515	rrtm_asdir !< surface albedo for shortwave direct radiation
516
517	!
518	!-- Definition of arrays that are currently not used for calling RRTMG (due to setting of flag parameters)
519	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rad_lw_cs_in, & !< incoming clear sky longwave radiation (W/m2) (not used)
520	rad_lw_cs_out, & !< outgoing clear sky longwave radiation (W/m2) (not used)
521	rad_sw_cs_in, & !< incoming clear sky shortwave radiation (W/m2) (not used)
522	rad_sw_cs_out, & !< outgoing clear sky shortwave radiation (W/m2) (not used)
523	rrtm_lw_tauaer, & !< lw aerosol optical depth
524	rrtm_lw_taucld, & !< lw in-cloud optical depth
525	rrtm_sw_taucld, & !< sw in-cloud optical depth
526	rrtm_sw_ssacld, & !< sw in-cloud single scattering albedo
527	rrtm_sw_asmcld, & !< sw in-cloud asymmetry parameter
528	rrtm_sw_fsfcld, & !< sw in-cloud forward scattering fraction
529	rrtm_sw_tauaer, & !< sw aerosol optical depth
530	rrtm_sw_ssaaer, & !< sw aerosol single scattering albedo
531	rrtm_sw_asmaer, & !< sw aerosol asymmetry parameter
532	rrtm_sw_ecaer !< sw aerosol optical detph at 0.55 microns (rrtm_iaer = 6 only)
533
534	#endif
535	!
536	!-- Parameters of urban and land surface models
537	INTEGER(iwp) :: nz_urban !< number of layers of urban surface (will be calculated)
538	INTEGER(iwp) :: nz_plant !< number of layers of plant canopy (will be calculated)
539	INTEGER(iwp) :: nz_urban_b !< bottom layer of urban surface (will be calculated)
540	INTEGER(iwp) :: nz_urban_t !< top layer of urban surface (will be calculated)
541	INTEGER(iwp) :: nz_plant_t !< top layer of plant canopy (will be calculated)
542	!-- parameters of urban and land surface models
543	INTEGER(iwp), PARAMETER :: nzut_free = 3 !< number of free layers above top of of topography
544	INTEGER(iwp), PARAMETER :: ndsvf = 2 !< number of dimensions of real values in SVF
545	INTEGER(iwp), PARAMETER :: idsvf = 2 !< number of dimensions of integer values in SVF
546	INTEGER(iwp), PARAMETER :: ndcsf = 1 !< number of dimensions of real values in CSF
547	INTEGER(iwp), PARAMETER :: idcsf = 2 !< number of dimensions of integer values in CSF
548	INTEGER(iwp), PARAMETER :: kdcsf = 4 !< number of dimensions of integer values in CSF calculation array
549	INTEGER(iwp), PARAMETER :: id = 1 !< position of d-index in surfl and surf
550	INTEGER(iwp), PARAMETER :: iz = 2 !< position of k-index in surfl and surf
551	INTEGER(iwp), PARAMETER :: iy = 3 !< position of j-index in surfl and surf
552	INTEGER(iwp), PARAMETER :: ix = 4 !< position of i-index in surfl and surf
553	INTEGER(iwp), PARAMETER :: im = 5 !< position of surface m-index in surfl and surf
554	INTEGER(iwp), PARAMETER :: nidx_surf = 5 !< number of indices in surfl and surf
555
556	INTEGER(iwp), PARAMETER :: nsurf_type = 10 !< number of surf types incl. phys.(land+urban) & (atm.,sky,boundary) surfaces - 1
557
558	INTEGER(iwp), PARAMETER :: iup_u = 0 !< 0 - index of urban upward surface (ground or roof)
559	INTEGER(iwp), PARAMETER :: idown_u = 1 !< 1 - index of urban downward surface (overhanging)
560	INTEGER(iwp), PARAMETER :: inorth_u = 2 !< 2 - index of urban northward facing wall
561	INTEGER(iwp), PARAMETER :: isouth_u = 3 !< 3 - index of urban southward facing wall
562	INTEGER(iwp), PARAMETER :: ieast_u = 4 !< 4 - index of urban eastward facing wall
563	INTEGER(iwp), PARAMETER :: iwest_u = 5 !< 5 - index of urban westward facing wall
564
565	INTEGER(iwp), PARAMETER :: iup_l = 6 !< 6 - index of land upward surface (ground or roof)
566	INTEGER(iwp), PARAMETER :: inorth_l = 7 !< 7 - index of land northward facing wall
567	INTEGER(iwp), PARAMETER :: isouth_l = 8 !< 8 - index of land southward facing wall
568	INTEGER(iwp), PARAMETER :: ieast_l = 9 !< 9 - index of land eastward facing wall
569	INTEGER(iwp), PARAMETER :: iwest_l = 10 !< 10- index of land westward facing wall
570
571	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: idir = (/0, 0,0, 0,1,-1,0,0, 0,1,-1/) !< surface normal direction x indices
572	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: jdir = (/0, 0,1,-1,0, 0,0,1,-1,0, 0/) !< surface normal direction y indices
573	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: kdir = (/1,-1,0, 0,0, 0,1,0, 0,0, 0/) !< surface normal direction z indices
574	REAL(wp), DIMENSION(0:nsurf_type) :: facearea !< area of single face in respective
575	!< direction (will be calc'd)
576
577
578	!-- indices and sizes of urban and land surface models
579	INTEGER(iwp) :: startland !< start index of block of land and roof surfaces
580	INTEGER(iwp) :: endland !< end index of block of land and roof surfaces
581	INTEGER(iwp) :: nlands !< number of land and roof surfaces in local processor
582	INTEGER(iwp) :: startwall !< start index of block of wall surfaces
583	INTEGER(iwp) :: endwall !< end index of block of wall surfaces
584	INTEGER(iwp) :: nwalls !< number of wall surfaces in local processor
585
586	!-- indices needed for RTM netcdf output subroutines
587	INTEGER(iwp), PARAMETER :: nd = 5
588	CHARACTER(LEN=6), DIMENSION(0:nd-1), PARAMETER :: dirname = (/ '_roof ', '_south', '_north', '_west ', '_east ' /)
589	INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint_u = (/ iup_u, isouth_u, inorth_u, iwest_u, ieast_u /)
590	INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint_l = (/ iup_l, isouth_l, inorth_l, iwest_l, ieast_l /)
591	INTEGER(iwp), DIMENSION(0:nd-1) :: dirstart
592	INTEGER(iwp), DIMENSION(0:nd-1) :: dirend
593
594	!-- indices and sizes of urban and land surface models
595	INTEGER(iwp), DIMENSION(:,:), POINTER :: surfl !< coordinates of i-th local surface in local grid - surfl[:,k] = [d, z, y, x, m]
596	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surfl_linear !< dtto (linearly allocated array)
597	INTEGER(iwp), DIMENSION(:,:), POINTER :: surf !< coordinates of i-th surface in grid - surf[:,k] = [d, z, y, x, m]
598	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surf_linear !< dtto (linearly allocated array)
599	INTEGER(iwp) :: nsurfl !< number of all surfaces in local processor
600	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: nsurfs !< array of number of all surfaces in individual processors
601	INTEGER(iwp) :: nsurf !< global number of surfaces in index array of surfaces (nsurf = proc nsurfs)
602	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surfstart !< starts of blocks of surfaces for individual processors in array surf (indexed from 1)
603	!< respective block for particular processor is surfstart[iproc+1]+1 : surfstart[iproc+1]+nsurfs[iproc+1]
604
605	!-- block variables needed for calculation of the plant canopy model inside the urban surface model
606	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pct !< top layer of the plant canopy
607	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pch !< heights of the plant canopy
608	INTEGER(iwp) :: npcbl = 0 !< number of the plant canopy gridboxes in local processor
609	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pcbl !< k,j,i coordinates of l-th local plant canopy box pcbl[:,l] = [k, j, i]
610	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw !< array of absorbed sw radiation for local plant canopy box
611	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdir !< array of absorbed direct sw radiation for local plant canopy box
612	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdif !< array of absorbed diffusion sw radiation for local plant canopy box
613	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw !< array of absorbed lw radiation for local plant canopy box
614
615	!-- configuration parameters (they can be setup in PALM config)
616	LOGICAL :: raytrace_mpi_rma = .TRUE. !< use MPI RMA to access LAD and gridsurf from remote processes during raytracing
617	LOGICAL :: rad_angular_discretization = .TRUE.!< whether to use fixed resolution discretization of view factors for
618	!< reflected radiation (as opposed to all mutually visible pairs)
619	LOGICAL :: plant_lw_interact = .TRUE. !< whether plant canopy interacts with LW radiation (in addition to SW)
620	INTEGER(iwp) :: mrt_nlevels = 0 !< number of vertical boxes above surface for which to calculate MRT
621	LOGICAL :: mrt_skip_roof = .TRUE. !< do not calculate MRT above roof surfaces
622	LOGICAL :: mrt_include_sw = .TRUE. !< should MRT calculation include SW radiation as well?
623	LOGICAL :: mrt_geom_human = .TRUE. !< MRT direction weights simulate human body instead of a sphere
624	INTEGER(iwp) :: nrefsteps = 3 !< number of reflection steps to perform
625	REAL(wp), PARAMETER :: ext_coef = 0.6_wp !< extinction coefficient (a.k.a. alpha)
626	INTEGER(iwp), PARAMETER :: rad_version_len = 10 !< length of identification string of rad version
627	CHARACTER(rad_version_len), PARAMETER :: rad_version = 'RAD v. 3.0' !< identification of version of binary svf and restart files
628	INTEGER(iwp) :: raytrace_discrete_elevs = 40 !< number of discretization steps for elevation (nadir to zenith)
629	INTEGER(iwp) :: raytrace_discrete_azims = 80 !< number of discretization steps for azimuth (out of 360 degrees)
630	REAL(wp) :: max_raytracing_dist = -999.0_wp !< maximum distance for raytracing (in metres)
631	REAL(wp) :: min_irrf_value = 1e-6_wp !< minimum potential irradiance factor value for raytracing
632	REAL(wp), DIMENSION(1:30) :: svfnorm_report_thresh = 1e21_wp !< thresholds of SVF normalization values to report
633	INTEGER(iwp) :: svfnorm_report_num !< number of SVF normalization thresholds to report
634
635	!-- radiation related arrays to be used in radiation_interaction routine
636	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_dir !< direct sw radiation
637	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_diff !< diffusion sw radiation
638	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_diff !< diffusion lw radiation
639
640	!-- parameters required for RRTMG lower boundary condition
641	REAL(wp) :: albedo_urb !< albedo value retuned to RRTMG boundary cond.
642	REAL(wp) :: emissivity_urb !< emissivity value retuned to RRTMG boundary cond.
643	REAL(wp) :: t_rad_urb !< temperature value retuned to RRTMG boundary cond.
644
645	!-- type for calculation of svf
646	TYPE t_svf
647	INTEGER(iwp) :: isurflt !<
648	INTEGER(iwp) :: isurfs !<
649	REAL(wp) :: rsvf !<
650	REAL(wp) :: rtransp !<
651	END TYPE
652
653	!-- type for calculation of csf
654	TYPE t_csf
655	INTEGER(iwp) :: ip !<
656	INTEGER(iwp) :: itx !<
657	INTEGER(iwp) :: ity !<
658	INTEGER(iwp) :: itz !<
659	INTEGER(iwp) :: isurfs !< Idx of source face / -1 for sky
660	REAL(wp) :: rcvf !< Canopy view factor for faces /
661	!< canopy sink factor for sky (-1)
662	END TYPE
663
664	!-- arrays storing the values of USM
665	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: svfsurf !< svfsurf[:,isvf] = index of target and source surface for svf[isvf]
666	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: svf !< array of shape view factors+direct irradiation factors for local surfaces
667	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins !< array of sw radiation falling to local surface after i-th reflection
668	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl !< array of lw radiation for local surface after i-th reflection
669
670	REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvf !< array of sky view factor for each local surface
671	REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvft !< array of sky view factor including transparency for each local surface
672	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitrans !< dsidir[isvfl,i] = path transmittance of i-th
673	!< direction of direct solar irradiance per target surface
674	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitransc !< dtto per plant canopy box
675	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir !< dsidir[:,i] = unit vector of i-th
676	!< direction of direct solar irradiance
677	INTEGER(iwp) :: ndsidir !< number of apparent solar directions used
678	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: dsidir_rev !< dsidir_rev[ielev,iazim] = i for dsidir or -1 if not present
679
680	INTEGER(iwp) :: nmrtbl !< No. of local grid boxes for which MRT is calculated
681	INTEGER(iwp) :: nmrtf !< number of MRT factors for local processor
682	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mrtbl !< coordinates of i-th local MRT box - surfl[:,i] = [z, y, x]
683	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mrtfsurf !< mrtfsurf[:,imrtf] = index of target MRT box and source surface for mrtf[imrtf]
684	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtf !< array of MRT factors for each local MRT box
685	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtft !< array of MRT factors including transparency for each local MRT box
686	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtsky !< array of sky view factor for each local MRT box
687	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtskyt !< array of sky view factor including transparency for each local MRT box
688	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: mrtdsit !< array of direct solar transparencies for each local MRT box
689	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinsw !< mean SW radiant flux for each MRT box
690	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinlw !< mean LW radiant flux for each MRT box
691	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt !< mean radiant temperature for each MRT box
692	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinsw_av !< time average mean SW radiant flux for each MRT box
693	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinlw_av !< time average mean LW radiant flux for each MRT box
694	REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt_av !< time average mean radiant temperature for each MRT box
695
696	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw !< array of sw radiation falling to local surface including radiation from reflections
697	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw !< array of lw radiation falling to local surface including radiation from reflections
698	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir !< array of direct sw radiation falling to local surface
699	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif !< array of diffuse sw radiation from sky and model boundary falling to local surface
700	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif !< array of diffuse lw radiation from sky and model boundary falling to local surface
701
702	!< Outward radiation is only valid for nonvirtual surfaces
703	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsl !< array of reflected sw radiation for local surface in i-th reflection
704	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutll !< array of reflected + emitted lw radiation for local surface in i-th reflection
705	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfouts !< array of reflected sw radiation for all surfaces in i-th reflection
706	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutl !< array of reflected + emitted lw radiation for all surfaces in i-th reflection
707	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlg !< global array of incoming lw radiation from plant canopy
708	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw !< array of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection
709	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw !< array of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection
710	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfemitlwl !< array of emitted lw radiation for local surface used to calculate effective surface temperature for radiation model
711
712	!-- block variables needed for calculation of the plant canopy model inside the urban surface model
713	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: csfsurf !< csfsurf[:,icsf] = index of target surface and csf grid index for csf[icsf]
714	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csf !< array of plant canopy sink fators + direct irradiation factors (transparency)
715	REAL(wp), DIMENSION(:,:,:), POINTER :: sub_lad !< subset of lad_s within urban surface, transformed to plain Z coordinate
716	REAL(wp), DIMENSION(:), POINTER :: sub_lad_g !< sub_lad globalized (used to avoid MPI RMA calls in raytracing)
717	REAL(wp) :: prototype_lad !< prototype leaf area density for computing effective optical depth
718	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nzterr, plantt !< temporary global arrays for raytracing
719	INTEGER(iwp) :: plantt_max
720
721	!-- arrays and variables for calculation of svf and csf
722	TYPE(t_svf), DIMENSION(:), POINTER :: asvf !< pointer to growing svc array
723	TYPE(t_csf), DIMENSION(:), POINTER :: acsf !< pointer to growing csf array
724	TYPE(t_svf), DIMENSION(:), POINTER :: amrtf !< pointer to growing mrtf array
725	TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: asvf1, asvf2 !< realizations of svf array
726	TYPE(t_csf), DIMENSION(:), ALLOCATABLE, TARGET :: acsf1, acsf2 !< realizations of csf array
727	TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: amrtf1, amrtf2 !< realizations of mftf array
728	INTEGER(iwp) :: nsvfla !< dimmension of array allocated for storage of svf in local processor
729	INTEGER(iwp) :: ncsfla !< dimmension of array allocated for storage of csf in local processor
730	INTEGER(iwp) :: nmrtfa !< dimmension of array allocated for storage of mrt
731	INTEGER(iwp) :: msvf, mcsf, mmrtf!< mod for swapping the growing array
732	INTEGER(iwp), PARAMETER :: gasize = 100000_iwp !< initial size of growing arrays
733	REAL(wp), PARAMETER :: grow_factor = 1.4_wp !< growth factor of growing arrays
734	INTEGER(iwp) :: nsvfl !< number of svf for local processor
735	INTEGER(iwp) :: ncsfl !< no. of csf in local processor
736	!< needed only during calc_svf but must be here because it is
737	!< shared between subroutines calc_svf and raytrace
738	INTEGER(iwp), DIMENSION(:,:,:,:), POINTER :: gridsurf !< reverse index of local surfl[d,k,j,i] (for case rad_angular_discretization)
739	INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: gridpcbl !< reverse index of local pcbl[k,j,i]
740	INTEGER(iwp), PARAMETER :: nsurf_type_u = 6 !< number of urban surf types (used in gridsurf)
741
742	!-- temporary arrays for calculation of csf in raytracing
743	INTEGER(iwp) :: maxboxesg !< max number of boxes ray can cross in the domain
744	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: boxes !< coordinates of gridboxes being crossed by ray
745	REAL(wp), DIMENSION(:), ALLOCATABLE :: crlens !< array of crossing lengths of ray for particular grid boxes
746	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: lad_ip !< array of numbers of process where lad is stored
747	#if defined( __parallel )
748	INTEGER(kind=MPI_ADDRESS_KIND), &
749	DIMENSION(:), ALLOCATABLE :: lad_disp !< array of displaycements of lad in local array of proc lad_ip
750	INTEGER(iwp) :: win_lad !< MPI RMA window for leaf area density
751	INTEGER(iwp) :: win_gridsurf !< MPI RMA window for reverse grid surface index
752	#endif
753	REAL(wp), DIMENSION(:), ALLOCATABLE :: lad_s_ray !< array of received lad_s for appropriate gridboxes crossed by ray
754	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: target_surfl
755	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: rt2_track
756	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rt2_track_lad
757	REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_track_dist
758	REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_dist
759
760	!-- arrays for time averages
761	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfradnet_av !< average of net radiation to local surface including radiation from reflections
762	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw_av !< average of sw radiation falling to local surface including radiation from reflections
763	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw_av !< average of lw radiation falling to local surface including radiation from reflections
764	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir_av !< average of direct sw radiation falling to local surface
765	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif_av !< average of diffuse sw radiation from sky and model boundary falling to local surface
766	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif_av !< average of diffuse lw radiation from sky and model boundary falling to local surface
767	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswref_av !< average of sw radiation falling to surface from reflections
768	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwref_av !< average of lw radiation falling to surface from reflections
769	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw_av !< average of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection
770	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw_av !< average of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection
771	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins_av !< average of array of residua of sw radiation absorbed in surface after last reflection
772	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl_av !< average of array of residua of lw radiation absorbed in surface after last reflection
773	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw_av !< Average of pcbinlw
774	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw_av !< Average of pcbinsw
775	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdir_av !< Average of pcbinswdir
776	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdif_av !< Average of pcbinswdif
777	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswref_av !< Average of pcbinswref
778
779
780	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
781	!-- Energy balance variables
782	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
783	!-- parameters of the land, roof and wall surfaces
784	REAL(wp), DIMENSION(:), ALLOCATABLE :: albedo_surf !< albedo of the surface
785	REAL(wp), DIMENSION(:), ALLOCATABLE :: emiss_surf !< emissivity of the wall surface
786	!
787	!-- External radiation. Depending on the given level of detail either a 1D or
788	!-- a 3D array will be allocated.
789	TYPE( real_1d_3d ) :: rad_lw_in_f !< external incoming longwave radiation, from observation or model
790	TYPE( real_1d_3d ) :: rad_sw_in_f !< external incoming shortwave radiation, from observation or model
791	TYPE( real_1d_3d ) :: rad_sw_in_dif_f !< external incoming shortwave radiation, diffuse part, from observation or model
792	TYPE( real_1d_3d ) :: time_rad_f !< time dimension for external radiation, from observation or model
793
794	INTERFACE radiation_check_data_output
795	MODULE PROCEDURE radiation_check_data_output
796	END INTERFACE radiation_check_data_output
797
798	INTERFACE radiation_check_data_output_ts
799	MODULE PROCEDURE radiation_check_data_output_ts
800	END INTERFACE radiation_check_data_output_ts
801
802	INTERFACE radiation_check_data_output_pr
803	MODULE PROCEDURE radiation_check_data_output_pr
804	END INTERFACE radiation_check_data_output_pr
805
806	INTERFACE radiation_check_parameters
807	MODULE PROCEDURE radiation_check_parameters
808	END INTERFACE radiation_check_parameters
809
810	INTERFACE radiation_clearsky
811	MODULE PROCEDURE radiation_clearsky
812	END INTERFACE radiation_clearsky
813
814	INTERFACE radiation_constant
815	MODULE PROCEDURE radiation_constant
816	END INTERFACE radiation_constant
817
818	INTERFACE radiation_control
819	MODULE PROCEDURE radiation_control
820	END INTERFACE radiation_control
821
822	INTERFACE radiation_3d_data_averaging
823	MODULE PROCEDURE radiation_3d_data_averaging
824	END INTERFACE radiation_3d_data_averaging
825
826	INTERFACE radiation_data_output_2d
827	MODULE PROCEDURE radiation_data_output_2d
828	END INTERFACE radiation_data_output_2d
829
830	INTERFACE radiation_data_output_3d
831	MODULE PROCEDURE radiation_data_output_3d
832	END INTERFACE radiation_data_output_3d
833
834	INTERFACE radiation_data_output_mask
835	MODULE PROCEDURE radiation_data_output_mask
836	END INTERFACE radiation_data_output_mask
837
838	INTERFACE radiation_define_netcdf_grid
839	MODULE PROCEDURE radiation_define_netcdf_grid
840	END INTERFACE radiation_define_netcdf_grid
841
842	INTERFACE radiation_header
843	MODULE PROCEDURE radiation_header
844	END INTERFACE radiation_header
845
846	INTERFACE radiation_init
847	MODULE PROCEDURE radiation_init
848	END INTERFACE radiation_init
849
850	INTERFACE radiation_parin
851	MODULE PROCEDURE radiation_parin
852	END INTERFACE radiation_parin
853
854	INTERFACE radiation_rrtmg
855	MODULE PROCEDURE radiation_rrtmg
856	END INTERFACE radiation_rrtmg
857
858	#if defined( __rrtmg )
859	INTERFACE radiation_tendency
860	MODULE PROCEDURE radiation_tendency
861	MODULE PROCEDURE radiation_tendency_ij
862	END INTERFACE radiation_tendency
863	#endif
864
865	INTERFACE radiation_rrd_local
866	MODULE PROCEDURE radiation_rrd_local
867	END INTERFACE radiation_rrd_local
868
869	INTERFACE radiation_wrd_local
870	MODULE PROCEDURE radiation_wrd_local
871	END INTERFACE radiation_wrd_local
872
873	INTERFACE radiation_interaction
874	MODULE PROCEDURE radiation_interaction
875	END INTERFACE radiation_interaction
876
877	INTERFACE radiation_interaction_init
878	MODULE PROCEDURE radiation_interaction_init
879	END INTERFACE radiation_interaction_init
880
881	INTERFACE radiation_presimulate_solar_pos
882	MODULE PROCEDURE radiation_presimulate_solar_pos
883	END INTERFACE radiation_presimulate_solar_pos
884
885	INTERFACE radiation_calc_svf
886	MODULE PROCEDURE radiation_calc_svf
887	END INTERFACE radiation_calc_svf
888
889	INTERFACE radiation_write_svf
890	MODULE PROCEDURE radiation_write_svf
891	END INTERFACE radiation_write_svf
892
893	INTERFACE radiation_read_svf
894	MODULE PROCEDURE radiation_read_svf
895	END INTERFACE radiation_read_svf
896
897
898	SAVE
899
900	PRIVATE
901
902	!
903	!-- Public functions / NEEDS SORTING
904	PUBLIC radiation_check_data_output, radiation_check_data_output_pr, &
905	radiation_check_data_output_ts, &
906	radiation_check_parameters, radiation_control, &
907	radiation_header, radiation_init, radiation_parin, &
908	radiation_3d_data_averaging, &
909	radiation_data_output_2d, radiation_data_output_3d, &
910	radiation_define_netcdf_grid, radiation_wrd_local, &
911	radiation_rrd_local, radiation_data_output_mask, &
912	radiation_calc_svf, radiation_write_svf, &
913	radiation_interaction, radiation_interaction_init, &
914	radiation_read_svf, radiation_presimulate_solar_pos
915
916
917	!
918	!-- Public variables and constants / NEEDS SORTING
919	PUBLIC albedo, albedo_type, decl_1, decl_2, decl_3, dots_rad, dt_radiation,&
920	emissivity, force_radiation_call, lat, lon, mrt_geom_human, &
921	mrt_include_sw, mrt_nlevels, mrtbl, mrtinsw, mrtinlw, nmrtbl, &
922	rad_net_av, radiation, radiation_scheme, rad_lw_in, &
923	rad_lw_in_av, rad_lw_out, rad_lw_out_av, &
924	rad_lw_cs_hr, rad_lw_cs_hr_av, rad_lw_hr, rad_lw_hr_av, rad_sw_in, &
925	rad_sw_in_av, rad_sw_out, rad_sw_out_av, rad_sw_cs_hr, &
926	rad_sw_cs_hr_av, rad_sw_hr, rad_sw_hr_av, solar_constant, &
927	skip_time_do_radiation, time_radiation, unscheduled_radiation_calls,&
928	cos_zenith, calc_zenith, sun_direction, sun_dir_lat, sun_dir_lon, &
929	idir, jdir, kdir, id, iz, iy, ix, &
930	iup_u, inorth_u, isouth_u, ieast_u, iwest_u, &
931	iup_l, inorth_l, isouth_l, ieast_l, iwest_l, &
932	nsurf_type, nz_urban_b, nz_urban_t, nz_urban, pch, nsurf, &
933	idsvf, ndsvf, idcsf, ndcsf, kdcsf, pct, &
934	radiation_interactions, startwall, startland, endland, endwall, &
935	skyvf, skyvft, radiation_interactions_on, average_radiation, &
936	rad_sw_in_diff, rad_sw_in_dir
937
938
939	#if defined ( __rrtmg )
940	PUBLIC radiation_tendency, rrtm_aldif, rrtm_aldir, rrtm_asdif, rrtm_asdir
941	#endif
942
943	CONTAINS
944
945
946	!------------------------------------------------------------------------------!
947	! Description:
948	! ------------
949	!> This subroutine controls the calls of the radiation schemes
950	!------------------------------------------------------------------------------!
951	SUBROUTINE radiation_control
952
953
954	IMPLICIT NONE
955
956
957	IF ( debug_output_timestep ) CALL debug_message( 'radiation_control', 'start' )
958
959
960	SELECT CASE ( TRIM( radiation_scheme ) )
961
962	CASE ( 'constant' )
963	CALL radiation_constant
964
965	CASE ( 'clear-sky' )
966	CALL radiation_clearsky
967
968	CASE ( 'rrtmg' )
969	CALL radiation_rrtmg
970
971	CASE ( 'external' )
972	!
973	!-- During spinup apply clear-sky model
974	IF ( time_since_reference_point < 0.0_wp ) THEN
975	CALL radiation_clearsky
976	ELSE
977	CALL radiation_external
978	ENDIF
979
980	CASE DEFAULT
981
982	END SELECT
983
984	IF ( debug_output_timestep ) CALL debug_message( 'radiation_control', 'end' )
985
986	END SUBROUTINE radiation_control
987
988	!------------------------------------------------------------------------------!
989	! Description:
990	! ------------
991	!> Check data output for radiation model
992	!------------------------------------------------------------------------------!
993	SUBROUTINE radiation_check_data_output( variable, unit, i, ilen, k )
994
995
996	USE control_parameters, &
997	ONLY: data_output, message_string
998
999	IMPLICIT NONE
1000
1001	CHARACTER (LEN=*) :: unit !<
1002	CHARACTER (LEN=*) :: variable !<
1003
1004	INTEGER(iwp) :: i, k
1005	INTEGER(iwp) :: ilen
1006	CHARACTER(LEN=varnamelength) :: var !< TRIM(variable)
1007
1008	var = TRIM(variable)
1009
1010	IF ( len(var) < 3_iwp ) THEN
1011	unit = 'illegal'
1012	RETURN
1013	ENDIF
1014
1015	IF ( var(1:3) /= 'rad' .AND. var(1:3) /= 'rtm' ) THEN
1016	unit = 'illegal'
1017	RETURN
1018	ENDIF
1019
1020	!-- first process diractional variables
1021	IF ( var(1:12) == 'rtm_rad_net_' .OR. var(1:13) == 'rtm_rad_insw_' .OR. &
1022	var(1:13) == 'rtm_rad_inlw_' .OR. var(1:16) == 'rtm_rad_inswdir_' .OR. &
1023	var(1:16) == 'rtm_rad_inswdif_' .OR. var(1:16) == 'rtm_rad_inswref_' .OR. &
1024	var(1:16) == 'rtm_rad_inlwdif_' .OR. var(1:16) == 'rtm_rad_inlwref_' .OR. &
1025	var(1:14) == 'rtm_rad_outsw_' .OR. var(1:14) == 'rtm_rad_outlw_' .OR. &
1026	var(1:14) == 'rtm_rad_ressw_' .OR. var(1:14) == 'rtm_rad_reslw_' ) THEN
1027	IF ( .NOT. radiation ) THEN
1028	message_string = 'output of "' // TRIM( var ) // '" require'&
1029	// 's radiation = .TRUE.'
1030	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1031	ENDIF
1032	unit = 'W/m2'
1033	ELSE IF ( var(1:7) == 'rtm_svf' .OR. var(1:7) == 'rtm_dif' .OR. &
1034	var(1:9) == 'rtm_skyvf' .OR. var(1:9) == 'rtm_skyvft' .OR. &
1035	var(1:12) == 'rtm_surfalb_' .OR. var(1:13) == 'rtm_surfemis_' ) THEN
1036	IF ( .NOT. radiation ) THEN
1037	message_string = 'output of "' // TRIM( var ) // '" require'&
1038	// 's radiation = .TRUE.'
1039	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1040	ENDIF
1041	unit = '1'
1042	ELSE
1043	!-- non-directional variables
1044	SELECT CASE ( TRIM( var ) )
1045	CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_lw_in', 'rad_lw_out', &
1046	'rad_sw_cs_hr', 'rad_sw_hr', 'rad_sw_in', 'rad_sw_out' )
1047	IF ( .NOT. radiation .OR. radiation_scheme /= 'rrtmg' ) THEN
1048	message_string = '"output of "' // TRIM( var ) // '" requi' // &
1049	'res radiation = .TRUE. and ' // &
1050	'radiation_scheme = "rrtmg"'
1051	CALL message( 'check_parameters', 'PA0406', 1, 2, 0, 6, 0 )
1052	ENDIF
1053	unit = 'K/h'
1054
1055	CASE ( 'rad_net', 'rrtm_aldif', 'rrtm_aldir', 'rrtm_asdif', &
1056	'rrtm_asdir', 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', &
1057	'rad_sw_out*')
1058	IF ( i == 0 .AND. ilen == 0 .AND. k == 0) THEN
1059	! Workaround for masked output (calls with i=ilen=k=0)
1060	unit = 'illegal'
1061	RETURN
1062	ENDIF
1063	IF ( k == 0 .OR. data_output(i)(ilen-2:ilen) /= '_xy' ) THEN
1064	message_string = 'illegal value for data_output: "' // &
1065	TRIM( var ) // '" & only 2d-horizontal ' // &
1066	'cross sections are allowed for this value'
1067	CALL message( 'check_parameters', 'PA0111', 1, 2, 0, 6, 0 )
1068	ENDIF
1069	IF ( .NOT. radiation .OR. radiation_scheme /= "rrtmg" ) THEN
1070	IF ( TRIM( var ) == 'rrtm_aldif*' .OR. &
1071	TRIM( var ) == 'rrtm_aldir*' .OR. &
1072	TRIM( var ) == 'rrtm_asdif*' .OR. &
1073	TRIM( var ) == 'rrtm_asdir*' ) &
1074	THEN
1075	message_string = 'output of "' // TRIM( var ) // '" require'&
1076	// 's radiation = .TRUE. and radiation_sch'&
1077	// 'eme = "rrtmg"'
1078	CALL message( 'check_parameters', 'PA0409', 1, 2, 0, 6, 0 )
1079	ENDIF
1080	ENDIF
1081
1082	IF ( TRIM( var ) == 'rad_net*' ) unit = 'W/m2'
1083	IF ( TRIM( var ) == 'rad_lw_in*' ) unit = 'W/m2'
1084	IF ( TRIM( var ) == 'rad_lw_out*' ) unit = 'W/m2'
1085	IF ( TRIM( var ) == 'rad_sw_in*' ) unit = 'W/m2'
1086	IF ( TRIM( var ) == 'rad_sw_out*' ) unit = 'W/m2'
1087	IF ( TRIM( var ) == 'rad_sw_in' ) unit = 'W/m2'
1088	IF ( TRIM( var ) == 'rrtm_aldif*' ) unit = ''
1089	IF ( TRIM( var ) == 'rrtm_aldir*' ) unit = ''
1090	IF ( TRIM( var ) == 'rrtm_asdif*' ) unit = ''
1091	IF ( TRIM( var ) == 'rrtm_asdir*' ) unit = ''
1092
1093	CASE ( 'rtm_rad_pc_inlw', 'rtm_rad_pc_insw', 'rtm_rad_pc_inswdir', &
1094	'rtm_rad_pc_inswdif', 'rtm_rad_pc_inswref')
1095	IF ( .NOT. radiation ) THEN
1096	message_string = 'output of "' // TRIM( var ) // '" require'&
1097	// 's radiation = .TRUE.'
1098	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1099	ENDIF
1100	unit = 'W'
1101
1102	CASE ( 'rtm_mrt', 'rtm_mrt_sw', 'rtm_mrt_lw' )
1103	IF ( i == 0 .AND. ilen == 0 .AND. k == 0) THEN
1104	! Workaround for masked output (calls with i=ilen=k=0)
1105	unit = 'illegal'
1106	RETURN
1107	ENDIF
1108
1109	IF ( .NOT. radiation ) THEN
1110	message_string = 'output of "' // TRIM( var ) // '" require'&
1111	// 's radiation = .TRUE.'
1112	CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1113	ENDIF
1114	IF ( mrt_nlevels == 0 ) THEN
1115	message_string = 'output of "' // TRIM( var ) // '" require'&
1116	// 's mrt_nlevels > 0'
1117	CALL message( 'check_parameters', 'PA0510', 1, 2, 0, 6, 0 )
1118	ENDIF
1119	IF ( TRIM( var ) == 'rtm_mrt_sw' .AND. .NOT. mrt_include_sw ) THEN
1120	message_string = 'output of "' // TRIM( var ) // '" require'&
1121	// 's rtm_mrt_sw = .TRUE.'
1122	CALL message( 'check_parameters', 'PA0511', 1, 2, 0, 6, 0 )
1123	ENDIF
1124	IF ( TRIM( var ) == 'rtm_mrt' ) THEN
1125	unit = 'K'
1126	ELSE
1127	unit = 'W m-2'
1128	ENDIF
1129
1130	CASE DEFAULT
1131	unit = 'illegal'
1132
1133	END SELECT
1134	ENDIF
1135
1136	END SUBROUTINE radiation_check_data_output
1137
1138
1139	!------------------------------------------------------------------------------!
1140	! Description:
1141	! ------------
1142	!> Set module-specific timeseries units and labels
1143	!------------------------------------------------------------------------------!
1144	SUBROUTINE radiation_check_data_output_ts( dots_max, dots_num )
1145
1146
1147	INTEGER(iwp), INTENT(IN) :: dots_max
1148	INTEGER(iwp), INTENT(INOUT) :: dots_num
1149
1150	!
1151	!-- Next line is just to avoid compiler warning about unused variable.
1152	IF ( dots_max == 0 ) CONTINUE
1153
1154	!
1155	!-- Temporary solution to add LSM and radiation time series to the default
1156	!-- output
1157	IF ( land_surface .OR. radiation ) THEN
1158	IF ( TRIM( radiation_scheme ) == 'rrtmg' ) THEN
1159	dots_num = dots_num + 15
1160	ELSE
1161	dots_num = dots_num + 11
1162	ENDIF
1163	ENDIF
1164
1165
1166	END SUBROUTINE radiation_check_data_output_ts
1167
1168	!------------------------------------------------------------------------------!
1169	! Description:
1170	! ------------
1171	!> Check data output of profiles for radiation model
1172	!------------------------------------------------------------------------------!
1173	SUBROUTINE radiation_check_data_output_pr( variable, var_count, unit, &
1174	dopr_unit )
1175
1176	USE arrays_3d, &
1177	ONLY: zu
1178
1179	USE control_parameters, &
1180	ONLY: data_output_pr, message_string
1181
1182	USE indices
1183
1184	USE profil_parameter
1185
1186	USE statistics
1187
1188	IMPLICIT NONE
1189
1190	CHARACTER (LEN=*) :: unit !<
1191	CHARACTER (LEN=*) :: variable !<
1192	CHARACTER (LEN=*) :: dopr_unit !< local value of dopr_unit
1193
1194	INTEGER(iwp) :: var_count !<
1195
1196	SELECT CASE ( TRIM( variable ) )
1197
1198	CASE ( 'rad_net' )
1199	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )&
1200	THEN
1201	message_string = 'data_output_pr = ' // &
1202	TRIM( data_output_pr(var_count) ) // ' is' // &
1203	'not available for radiation = .FALSE. or ' //&
1204	'radiation_scheme = "constant"'
1205	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1206	ELSE
1207	dopr_index(var_count) = 99
1208	dopr_unit = 'W/m2'
1209	hom(:,2,99,:) = SPREAD( zw, 2, statistic_regions+1 )
1210	unit = dopr_unit
1211	ENDIF
1212
1213	CASE ( 'rad_lw_in' )
1214	IF ( ( .NOT. radiation) .OR. radiation_scheme == 'constant' ) &
1215	THEN
1216	message_string = 'data_output_pr = ' // &
1217	TRIM( data_output_pr(var_count) ) // ' is' // &
1218	'not available for radiation = .FALSE. or ' //&
1219	'radiation_scheme = "constant"'
1220	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1221	ELSE
1222	dopr_index(var_count) = 100
1223	dopr_unit = 'W/m2'
1224	hom(:,2,100,:) = SPREAD( zw, 2, statistic_regions+1 )
1225	unit = dopr_unit
1226	ENDIF
1227
1228	CASE ( 'rad_lw_out' )
1229	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) &
1230	THEN
1231	message_string = 'data_output_pr = ' // &
1232	TRIM( data_output_pr(var_count) ) // ' is' // &
1233	'not available for radiation = .FALSE. or ' //&
1234	'radiation_scheme = "constant"'
1235	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1236	ELSE
1237	dopr_index(var_count) = 101
1238	dopr_unit = 'W/m2'
1239	hom(:,2,101,:) = SPREAD( zw, 2, statistic_regions+1 )
1240	unit = dopr_unit
1241	ENDIF
1242
1243	CASE ( 'rad_sw_in' )
1244	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) &
1245	THEN
1246	message_string = 'data_output_pr = ' // &
1247	TRIM( data_output_pr(var_count) ) // ' is' // &
1248	'not available for radiation = .FALSE. or ' //&
1249	'radiation_scheme = "constant"'
1250	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1251	ELSE
1252	dopr_index(var_count) = 102
1253	dopr_unit = 'W/m2'
1254	hom(:,2,102,:) = SPREAD( zw, 2, statistic_regions+1 )
1255	unit = dopr_unit
1256	ENDIF
1257
1258	CASE ( 'rad_sw_out')
1259	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )&
1260	THEN
1261	message_string = 'data_output_pr = ' // &
1262	TRIM( data_output_pr(var_count) ) // ' is' // &
1263	'not available for radiation = .FALSE. or ' //&
1264	'radiation_scheme = "constant"'
1265	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1266	ELSE
1267	dopr_index(var_count) = 103
1268	dopr_unit = 'W/m2'
1269	hom(:,2,103,:) = SPREAD( zw, 2, statistic_regions+1 )
1270	unit = dopr_unit
1271	ENDIF
1272
1273	CASE ( 'rad_lw_cs_hr' )
1274	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1275	THEN
1276	message_string = 'data_output_pr = ' // &
1277	TRIM( data_output_pr(var_count) ) // ' is' // &
1278	'not available for radiation = .FALSE. or ' //&
1279	'radiation_scheme /= "rrtmg"'
1280	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1281	ELSE
1282	dopr_index(var_count) = 104
1283	dopr_unit = 'K/h'
1284	hom(:,2,104,:) = SPREAD( zu, 2, statistic_regions+1 )
1285	unit = dopr_unit
1286	ENDIF
1287
1288	CASE ( 'rad_lw_hr' )
1289	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1290	THEN
1291	message_string = 'data_output_pr = ' // &
1292	TRIM( data_output_pr(var_count) ) // ' is' // &
1293	'not available for radiation = .FALSE. or ' //&
1294	'radiation_scheme /= "rrtmg"'
1295	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1296	ELSE
1297	dopr_index(var_count) = 105
1298	dopr_unit = 'K/h'
1299	hom(:,2,105,:) = SPREAD( zu, 2, statistic_regions+1 )
1300	unit = dopr_unit
1301	ENDIF
1302
1303	CASE ( 'rad_sw_cs_hr' )
1304	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1305	THEN
1306	message_string = 'data_output_pr = ' // &
1307	TRIM( data_output_pr(var_count) ) // ' is' // &
1308	'not available for radiation = .FALSE. or ' //&
1309	'radiation_scheme /= "rrtmg"'
1310	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1311	ELSE
1312	dopr_index(var_count) = 106
1313	dopr_unit = 'K/h'
1314	hom(:,2,106,:) = SPREAD( zu, 2, statistic_regions+1 )
1315	unit = dopr_unit
1316	ENDIF
1317
1318	CASE ( 'rad_sw_hr' )
1319	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1320	THEN
1321	message_string = 'data_output_pr = ' // &
1322	TRIM( data_output_pr(var_count) ) // ' is' // &
1323	'not available for radiation = .FALSE. or ' //&
1324	'radiation_scheme /= "rrtmg"'
1325	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1326	ELSE
1327	dopr_index(var_count) = 107
1328	dopr_unit = 'K/h'
1329	hom(:,2,107,:) = SPREAD( zu, 2, statistic_regions+1 )
1330	unit = dopr_unit
1331	ENDIF
1332
1333
1334	CASE DEFAULT
1335	unit = 'illegal'
1336
1337	END SELECT
1338
1339
1340	END SUBROUTINE radiation_check_data_output_pr
1341
1342
1343	!------------------------------------------------------------------------------!
1344	! Description:
1345	! ------------
1346	!> Check parameters routine for radiation model
1347	!------------------------------------------------------------------------------!
1348	SUBROUTINE radiation_check_parameters
1349
1350	USE control_parameters, &
1351	ONLY: land_surface, message_string, urban_surface
1352
1353	USE netcdf_data_input_mod, &
1354	ONLY: input_pids_static
1355
1356	IMPLICIT NONE
1357
1358	!
1359	!-- In case no urban-surface or land-surface model is applied, usage of
1360	!-- a radiation model make no sense.
1361	IF ( .NOT. land_surface .AND. .NOT. urban_surface ) THEN
1362	message_string = 'Usage of radiation module is only allowed if ' // &
1363	'land-surface and/or urban-surface model is applied.'
1364	CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 )
1365	ENDIF
1366
1367	IF ( radiation_scheme /= 'constant' .AND. &
1368	radiation_scheme /= 'clear-sky' .AND. &
1369	radiation_scheme /= 'rrtmg' .AND. &
1370	radiation_scheme /= 'external' ) THEN
1371	message_string = 'unknown radiation_scheme = '// &
1372	TRIM( radiation_scheme )
1373	CALL message( 'check_parameters', 'PA0405', 1, 2, 0, 6, 0 )
1374	ELSEIF ( radiation_scheme == 'rrtmg' ) THEN
1375	#if ! defined ( __rrtmg )
1376	message_string = 'radiation_scheme = "rrtmg" requires ' // &
1377	'compilation of PALM with pre-processor ' // &
1378	'directive -D__rrtmg'
1379	CALL message( 'check_parameters', 'PA0407', 1, 2, 0, 6, 0 )
1380	#endif
1381	#if defined ( __rrtmg ) && ! defined( __netcdf )
1382	message_string = 'radiation_scheme = "rrtmg" requires ' // &
1383	'the use of NetCDF (preprocessor directive ' // &
1384	'-D__netcdf'
1385	CALL message( 'check_parameters', 'PA0412', 1, 2, 0, 6, 0 )
1386	#endif
1387
1388	ENDIF
1389	!
1390	!-- Checks performed only if data is given via namelist only.
1391	IF ( .NOT. input_pids_static ) THEN
1392	IF ( albedo_type == 0 .AND. albedo == 9999999.9_wp .AND. &
1393	radiation_scheme == 'clear-sky') THEN
1394	message_string = 'radiation_scheme = "clear-sky" in combination'//&
1395	'with albedo_type = 0 requires setting of'// &
1396	'albedo /= 9999999.9'
1397	CALL message( 'check_parameters', 'PA0410', 1, 2, 0, 6, 0 )
1398	ENDIF
1399
1400	IF ( albedo_type == 0 .AND. radiation_scheme == 'rrtmg' .AND. &
1401	( albedo_lw_dif == 9999999.9_wp .OR. albedo_lw_dir == 9999999.9_wp&
1402	.OR. albedo_sw_dif == 9999999.9_wp .OR. albedo_sw_dir == 9999999.9_wp&
1403	) ) THEN
1404	message_string = 'radiation_scheme = "rrtmg" in combination' // &
1405	'with albedo_type = 0 requires setting of ' // &
1406	'albedo_lw_dif /= 9999999.9' // &
1407	'albedo_lw_dir /= 9999999.9' // &
1408	'albedo_sw_dif /= 9999999.9 and' // &
1409	'albedo_sw_dir /= 9999999.9'
1410	CALL message( 'check_parameters', 'PA0411', 1, 2, 0, 6, 0 )
1411	ENDIF
1412	ENDIF
1413	!
1414	!-- Parallel rad_angular_discretization without raytrace_mpi_rma is not implemented
1415	#if defined( __parallel )
1416	IF ( rad_angular_discretization .AND. .NOT. raytrace_mpi_rma ) THEN
1417	message_string = 'rad_angular_discretization can only be used ' // &
1418	'together with raytrace_mpi_rma or when ' // &
1419	'no parallelization is applied.'
1420	CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 )
1421	ENDIF
1422	#endif
1423
1424	IF ( cloud_droplets .AND. radiation_scheme == 'rrtmg' .AND. &
1425	average_radiation ) THEN
1426	message_string = 'average_radiation = .T. with radiation_scheme'// &
1427	'= "rrtmg" in combination cloud_droplets = .T.'// &
1428	'is not implementd'
1429	CALL message( 'check_parameters', 'PA0560', 1, 2, 0, 6, 0 )
1430	ENDIF
1431
1432	!
1433	!-- Incialize svf normalization reporting histogram
1434	svfnorm_report_num = 1
1435	DO WHILE ( svfnorm_report_thresh(svfnorm_report_num) < 1e20_wp &
1436	.AND. svfnorm_report_num <= 30 )
1437	svfnorm_report_num = svfnorm_report_num + 1
1438	ENDDO
1439	svfnorm_report_num = svfnorm_report_num - 1
1440	!
1441	!-- Check for dt_radiation
1442	IF ( dt_radiation <= 0.0 ) THEN
1443	message_string = 'dt_radiation must be > 0.0'
1444	CALL message( 'check_parameters', 'PA0591', 1, 2, 0, 6, 0 )
1445	ENDIF
1446
1447	END SUBROUTINE radiation_check_parameters
1448
1449
1450	!------------------------------------------------------------------------------!
1451	! Description:
1452	! ------------
1453	!> Initialization of the radiation model
1454	!------------------------------------------------------------------------------!
1455	SUBROUTINE radiation_init
1456
1457	IMPLICIT NONE
1458
1459	INTEGER(iwp) :: i !< running index x-direction
1460	INTEGER(iwp) :: ioff !< offset in x between surface element reference grid point in atmosphere and actual surface
1461	INTEGER(iwp) :: j !< running index y-direction
1462	INTEGER(iwp) :: joff !< offset in y between surface element reference grid point in atmosphere and actual surface
1463	INTEGER(iwp) :: l !< running index for orientation of vertical surfaces
1464	INTEGER(iwp) :: m !< running index for surface elements
1465	INTEGER(iwp) :: ntime = 0 !< number of available external radiation timesteps
1466	#if defined( __rrtmg )
1467	INTEGER(iwp) :: ind_type !< running index for subgrid-surface tiles
1468	#endif
1469	LOGICAL :: radiation_input_root_domain !< flag indicating the existence of a dynamic input file for the root domain
1470
1471
1472	IF ( debug_output ) CALL debug_message( 'radiation_init', 'start' )
1473	!
1474	!-- Activate radiation_interactions according to the existence of vertical surfaces and/or trees.
1475	!-- The namelist parameter radiation_interactions_on can override this behavior.
1476	!-- (This check cannot be performed in check_parameters, because vertical_surfaces_exist is first set in
1477	!-- init_surface_arrays.)
1478	IF ( radiation_interactions_on ) THEN
1479	IF ( vertical_surfaces_exist .OR. plant_canopy ) THEN
1480	radiation_interactions = .TRUE.
1481	average_radiation = .TRUE.
1482	ELSE
1483	radiation_interactions_on = .FALSE. !< reset namelist parameter: no interactions
1484	!< calculations necessary in case of flat surface
1485	ENDIF
1486	ELSEIF ( vertical_surfaces_exist .OR. plant_canopy ) THEN
1487	message_string = 'radiation_interactions_on is set to .FALSE. although ' // &
1488	'vertical surfaces and/or trees exist. The model will run ' // &
1489	'without RTM (no shadows, no radiation reflections)'
1490	CALL message( 'init_3d_model', 'PA0348', 0, 1, 0, 6, 0 )
1491	ENDIF
1492	!
1493	!-- If required, initialize radiation interactions between surfaces
1494	!-- via sky-view factors. This must be done before radiation is initialized.
1495	IF ( radiation_interactions ) CALL radiation_interaction_init
1496	!
1497	!-- Allocate array for storing the surface net radiation
1498	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_net ) .AND. &
1499	surf_lsm_h%ns > 0 ) THEN
1500	ALLOCATE( surf_lsm_h%rad_net(1:surf_lsm_h%ns) )
1501	surf_lsm_h%rad_net = 0.0_wp
1502	ENDIF
1503	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_net ) .AND. &
1504	surf_usm_h%ns > 0 ) THEN
1505	ALLOCATE( surf_usm_h%rad_net(1:surf_usm_h%ns) )
1506	surf_usm_h%rad_net = 0.0_wp
1507	ENDIF
1508	DO l = 0, 3
1509	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_net ) .AND. &
1510	surf_lsm_v(l)%ns > 0 ) THEN
1511	ALLOCATE( surf_lsm_v(l)%rad_net(1:surf_lsm_v(l)%ns) )
1512	surf_lsm_v(l)%rad_net = 0.0_wp
1513	ENDIF
1514	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_net ) .AND. &
1515	surf_usm_v(l)%ns > 0 ) THEN
1516	ALLOCATE( surf_usm_v(l)%rad_net(1:surf_usm_v(l)%ns) )
1517	surf_usm_v(l)%rad_net = 0.0_wp
1518	ENDIF
1519	ENDDO
1520
1521
1522	!
1523	!-- Allocate array for storing the surface longwave (out) radiation change
1524	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_lw_out_change_0 ) .AND. &
1525	surf_lsm_h%ns > 0 ) THEN
1526	ALLOCATE( surf_lsm_h%rad_lw_out_change_0(1:surf_lsm_h%ns) )
1527	surf_lsm_h%rad_lw_out_change_0 = 0.0_wp
1528	ENDIF
1529	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_lw_out_change_0 ) .AND. &
1530	surf_usm_h%ns > 0 ) THEN
1531	ALLOCATE( surf_usm_h%rad_lw_out_change_0(1:surf_usm_h%ns) )
1532	surf_usm_h%rad_lw_out_change_0 = 0.0_wp
1533	ENDIF
1534	DO l = 0, 3
1535	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_lw_out_change_0 ) .AND. &
1536	surf_lsm_v(l)%ns > 0 ) THEN
1537	ALLOCATE( surf_lsm_v(l)%rad_lw_out_change_0(1:surf_lsm_v(l)%ns) )
1538	surf_lsm_v(l)%rad_lw_out_change_0 = 0.0_wp
1539	ENDIF
1540	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_lw_out_change_0 ) .AND. &
1541	surf_usm_v(l)%ns > 0 ) THEN
1542	ALLOCATE( surf_usm_v(l)%rad_lw_out_change_0(1:surf_usm_v(l)%ns) )
1543	surf_usm_v(l)%rad_lw_out_change_0 = 0.0_wp
1544	ENDIF
1545	ENDDO
1546
1547	!
1548	!-- Allocate surface arrays for incoming/outgoing short/longwave radiation
1549	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_sw_in ) .AND. &
1550	surf_lsm_h%ns > 0 ) THEN
1551	ALLOCATE( surf_lsm_h%rad_sw_in(1:surf_lsm_h%ns) )
1552	ALLOCATE( surf_lsm_h%rad_sw_out(1:surf_lsm_h%ns) )
1553	ALLOCATE( surf_lsm_h%rad_sw_dir(1:surf_lsm_h%ns) )
1554	ALLOCATE( surf_lsm_h%rad_sw_dif(1:surf_lsm_h%ns) )
1555	ALLOCATE( surf_lsm_h%rad_sw_ref(1:surf_lsm_h%ns) )
1556	ALLOCATE( surf_lsm_h%rad_sw_res(1:surf_lsm_h%ns) )
1557	ALLOCATE( surf_lsm_h%rad_lw_in(1:surf_lsm_h%ns) )
1558	ALLOCATE( surf_lsm_h%rad_lw_out(1:surf_lsm_h%ns) )
1559	ALLOCATE( surf_lsm_h%rad_lw_dif(1:surf_lsm_h%ns) )
1560	ALLOCATE( surf_lsm_h%rad_lw_ref(1:surf_lsm_h%ns) )
1561	ALLOCATE( surf_lsm_h%rad_lw_res(1:surf_lsm_h%ns) )
1562	surf_lsm_h%rad_sw_in = 0.0_wp
1563	surf_lsm_h%rad_sw_out = 0.0_wp
1564	surf_lsm_h%rad_sw_dir = 0.0_wp
1565	surf_lsm_h%rad_sw_dif = 0.0_wp
1566	surf_lsm_h%rad_sw_ref = 0.0_wp
1567	surf_lsm_h%rad_sw_res = 0.0_wp
1568	surf_lsm_h%rad_lw_in = 0.0_wp
1569	surf_lsm_h%rad_lw_out = 0.0_wp
1570	surf_lsm_h%rad_lw_dif = 0.0_wp
1571	surf_lsm_h%rad_lw_ref = 0.0_wp
1572	surf_lsm_h%rad_lw_res = 0.0_wp
1573	ENDIF
1574	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_sw_in ) .AND. &
1575	surf_usm_h%ns > 0 ) THEN
1576	ALLOCATE( surf_usm_h%rad_sw_in(1:surf_usm_h%ns) )
1577	ALLOCATE( surf_usm_h%rad_sw_out(1:surf_usm_h%ns) )
1578	ALLOCATE( surf_usm_h%rad_sw_dir(1:surf_usm_h%ns) )
1579	ALLOCATE( surf_usm_h%rad_sw_dif(1:surf_usm_h%ns) )
1580	ALLOCATE( surf_usm_h%rad_sw_ref(1:surf_usm_h%ns) )
1581	ALLOCATE( surf_usm_h%rad_sw_res(1:surf_usm_h%ns) )
1582	ALLOCATE( surf_usm_h%rad_lw_in(1:surf_usm_h%ns) )
1583	ALLOCATE( surf_usm_h%rad_lw_out(1:surf_usm_h%ns) )
1584	ALLOCATE( surf_usm_h%rad_lw_dif(1:surf_usm_h%ns) )
1585	ALLOCATE( surf_usm_h%rad_lw_ref(1:surf_usm_h%ns) )
1586	ALLOCATE( surf_usm_h%rad_lw_res(1:surf_usm_h%ns) )
1587	surf_usm_h%rad_sw_in = 0.0_wp
1588	surf_usm_h%rad_sw_out = 0.0_wp
1589	surf_usm_h%rad_sw_dir = 0.0_wp
1590	surf_usm_h%rad_sw_dif = 0.0_wp
1591	surf_usm_h%rad_sw_ref = 0.0_wp
1592	surf_usm_h%rad_sw_res = 0.0_wp
1593	surf_usm_h%rad_lw_in = 0.0_wp
1594	surf_usm_h%rad_lw_out = 0.0_wp
1595	surf_usm_h%rad_lw_dif = 0.0_wp
1596	surf_usm_h%rad_lw_ref = 0.0_wp
1597	surf_usm_h%rad_lw_res = 0.0_wp
1598	ENDIF
1599	DO l = 0, 3
1600	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_sw_in ) .AND. &
1601	surf_lsm_v(l)%ns > 0 ) THEN
1602	ALLOCATE( surf_lsm_v(l)%rad_sw_in(1:surf_lsm_v(l)%ns) )
1603	ALLOCATE( surf_lsm_v(l)%rad_sw_out(1:surf_lsm_v(l)%ns) )
1604	ALLOCATE( surf_lsm_v(l)%rad_sw_dir(1:surf_lsm_v(l)%ns) )
1605	ALLOCATE( surf_lsm_v(l)%rad_sw_dif(1:surf_lsm_v(l)%ns) )
1606	ALLOCATE( surf_lsm_v(l)%rad_sw_ref(1:surf_lsm_v(l)%ns) )
1607	ALLOCATE( surf_lsm_v(l)%rad_sw_res(1:surf_lsm_v(l)%ns) )
1608
1609	ALLOCATE( surf_lsm_v(l)%rad_lw_in(1:surf_lsm_v(l)%ns) )
1610	ALLOCATE( surf_lsm_v(l)%rad_lw_out(1:surf_lsm_v(l)%ns) )
1611	ALLOCATE( surf_lsm_v(l)%rad_lw_dif(1:surf_lsm_v(l)%ns) )
1612	ALLOCATE( surf_lsm_v(l)%rad_lw_ref(1:surf_lsm_v(l)%ns) )
1613	ALLOCATE( surf_lsm_v(l)%rad_lw_res(1:surf_lsm_v(l)%ns) )
1614
1615	surf_lsm_v(l)%rad_sw_in = 0.0_wp
1616	surf_lsm_v(l)%rad_sw_out = 0.0_wp
1617	surf_lsm_v(l)%rad_sw_dir = 0.0_wp
1618	surf_lsm_v(l)%rad_sw_dif = 0.0_wp
1619	surf_lsm_v(l)%rad_sw_ref = 0.0_wp
1620	surf_lsm_v(l)%rad_sw_res = 0.0_wp
1621
1622	surf_lsm_v(l)%rad_lw_in = 0.0_wp
1623	surf_lsm_v(l)%rad_lw_out = 0.0_wp
1624	surf_lsm_v(l)%rad_lw_dif = 0.0_wp
1625	surf_lsm_v(l)%rad_lw_ref = 0.0_wp
1626	surf_lsm_v(l)%rad_lw_res = 0.0_wp
1627	ENDIF
1628	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_sw_in ) .AND. &
1629	surf_usm_v(l)%ns > 0 ) THEN
1630	ALLOCATE( surf_usm_v(l)%rad_sw_in(1:surf_usm_v(l)%ns) )
1631	ALLOCATE( surf_usm_v(l)%rad_sw_out(1:surf_usm_v(l)%ns) )
1632	ALLOCATE( surf_usm_v(l)%rad_sw_dir(1:surf_usm_v(l)%ns) )
1633	ALLOCATE( surf_usm_v(l)%rad_sw_dif(1:surf_usm_v(l)%ns) )
1634	ALLOCATE( surf_usm_v(l)%rad_sw_ref(1:surf_usm_v(l)%ns) )
1635	ALLOCATE( surf_usm_v(l)%rad_sw_res(1:surf_usm_v(l)%ns) )
1636	ALLOCATE( surf_usm_v(l)%rad_lw_in(1:surf_usm_v(l)%ns) )
1637	ALLOCATE( surf_usm_v(l)%rad_lw_out(1:surf_usm_v(l)%ns) )
1638	ALLOCATE( surf_usm_v(l)%rad_lw_dif(1:surf_usm_v(l)%ns) )
1639	ALLOCATE( surf_usm_v(l)%rad_lw_ref(1:surf_usm_v(l)%ns) )
1640	ALLOCATE( surf_usm_v(l)%rad_lw_res(1:surf_usm_v(l)%ns) )
1641	surf_usm_v(l)%rad_sw_in = 0.0_wp
1642	surf_usm_v(l)%rad_sw_out = 0.0_wp
1643	surf_usm_v(l)%rad_sw_dir = 0.0_wp
1644	surf_usm_v(l)%rad_sw_dif = 0.0_wp
1645	surf_usm_v(l)%rad_sw_ref = 0.0_wp
1646	surf_usm_v(l)%rad_sw_res = 0.0_wp
1647	surf_usm_v(l)%rad_lw_in = 0.0_wp
1648	surf_usm_v(l)%rad_lw_out = 0.0_wp
1649	surf_usm_v(l)%rad_lw_dif = 0.0_wp
1650	surf_usm_v(l)%rad_lw_ref = 0.0_wp
1651	surf_usm_v(l)%rad_lw_res = 0.0_wp
1652	ENDIF
1653	ENDDO
1654	!
1655	!-- Fix net radiation in case of radiation_scheme = 'constant'
1656	IF ( radiation_scheme == 'constant' ) THEN
1657	IF ( ALLOCATED( surf_lsm_h%rad_net ) ) &
1658	surf_lsm_h%rad_net = net_radiation
1659	IF ( ALLOCATED( surf_usm_h%rad_net ) ) &
1660	surf_usm_h%rad_net = net_radiation
1661	!
1662	!-- Todo: weight with inclination angle
1663	DO l = 0, 3
1664	IF ( ALLOCATED( surf_lsm_v(l)%rad_net ) ) &
1665	surf_lsm_v(l)%rad_net = net_radiation
1666	IF ( ALLOCATED( surf_usm_v(l)%rad_net ) ) &
1667	surf_usm_v(l)%rad_net = net_radiation
1668	ENDDO
1669	! radiation = .FALSE.
1670	!
1671	!-- Calculate orbital constants
1672	ELSE
1673	decl_1 = SIN(23.45_wp * pi / 180.0_wp)
1674	decl_2 = 2.0_wp * pi / 365.0_wp
1675	decl_3 = decl_2 * 81.0_wp
1676	lat = latitude * pi / 180.0_wp
1677	lon = longitude * pi / 180.0_wp
1678	ENDIF
1679
1680	IF ( radiation_scheme == 'clear-sky' .OR. &
1681	radiation_scheme == 'constant' .OR. &
1682	radiation_scheme == 'external' ) THEN
1683	!
1684	!-- Allocate arrays for incoming/outgoing short/longwave radiation
1685	IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN
1686	ALLOCATE ( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) )
1687	ENDIF
1688	IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN
1689	ALLOCATE ( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) )
1690	ENDIF
1691
1692	IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN
1693	ALLOCATE ( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) )
1694	ENDIF
1695	IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN
1696	ALLOCATE ( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) )
1697	ENDIF
1698
1699	!
1700	!-- Allocate average arrays for incoming/outgoing short/longwave radiation
1701	IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN
1702	ALLOCATE ( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
1703	ENDIF
1704	IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN
1705	ALLOCATE ( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
1706	ENDIF
1707
1708	IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN
1709	ALLOCATE ( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
1710	ENDIF
1711	IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN
1712	ALLOCATE ( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
1713	ENDIF
1714	!
1715	!-- Allocate arrays for broadband albedo, and level 1 initialization
1716	!-- via namelist paramter, unless not already allocated.
1717	IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) THEN
1718	ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) )
1719	surf_lsm_h%albedo = albedo
1720	ENDIF
1721	IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) THEN
1722	ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) )
1723	surf_usm_h%albedo = albedo
1724	ENDIF
1725
1726	DO l = 0, 3
1727	IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) THEN
1728	ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) )
1729	surf_lsm_v(l)%albedo = albedo
1730	ENDIF
1731	IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) THEN
1732	ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) )
1733	surf_usm_v(l)%albedo = albedo
1734	ENDIF
1735	ENDDO
1736	!
1737	!-- Level 2 initialization of broadband albedo via given albedo_type.
1738	!-- Only if albedo_type is non-zero. In case of urban surface and
1739	!-- input data is read from ASCII file, albedo_type will be zero, so that
1740	!-- albedo won't be overwritten.
1741	DO m = 1, surf_lsm_h%ns
1742	IF ( surf_lsm_h%albedo_type(ind_veg_wall,m) /= 0 ) &
1743	surf_lsm_h%albedo(ind_veg_wall,m) = &
1744	albedo_pars(0,surf_lsm_h%albedo_type(ind_veg_wall,m))
1745	IF ( surf_lsm_h%albedo_type(ind_pav_green,m) /= 0 ) &
1746	surf_lsm_h%albedo(ind_pav_green,m) = &
1747	albedo_pars(0,surf_lsm_h%albedo_type(ind_pav_green,m))
1748	IF ( surf_lsm_h%albedo_type(ind_wat_win,m) /= 0 ) &
1749	surf_lsm_h%albedo(ind_wat_win,m) = &
1750	albedo_pars(0,surf_lsm_h%albedo_type(ind_wat_win,m))
1751	ENDDO
1752	DO m = 1, surf_usm_h%ns
1753	IF ( surf_usm_h%albedo_type(ind_veg_wall,m) /= 0 ) &
1754	surf_usm_h%albedo(ind_veg_wall,m) = &
1755	albedo_pars(0,surf_usm_h%albedo_type(ind_veg_wall,m))
1756	IF ( surf_usm_h%albedo_type(ind_pav_green,m) /= 0 ) &
1757	surf_usm_h%albedo(ind_pav_green,m) = &
1758	albedo_pars(0,surf_usm_h%albedo_type(ind_pav_green,m))
1759	IF ( surf_usm_h%albedo_type(ind_wat_win,m) /= 0 ) &
1760	surf_usm_h%albedo(ind_wat_win,m) = &
1761	albedo_pars(0,surf_usm_h%albedo_type(ind_wat_win,m))
1762	ENDDO
1763
1764	DO l = 0, 3
1765	DO m = 1, surf_lsm_v(l)%ns
1766	IF ( surf_lsm_v(l)%albedo_type(ind_veg_wall,m) /= 0 ) &
1767	surf_lsm_v(l)%albedo(ind_veg_wall,m) = &
1768	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_veg_wall,m))
1769	IF ( surf_lsm_v(l)%albedo_type(ind_pav_green,m) /= 0 ) &
1770	surf_lsm_v(l)%albedo(ind_pav_green,m) = &
1771	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_pav_green,m))
1772	IF ( surf_lsm_v(l)%albedo_type(ind_wat_win,m) /= 0 ) &
1773	surf_lsm_v(l)%albedo(ind_wat_win,m) = &
1774	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_wat_win,m))
1775	ENDDO
1776	DO m = 1, surf_usm_v(l)%ns
1777	IF ( surf_usm_v(l)%albedo_type(ind_veg_wall,m) /= 0 ) &
1778	surf_usm_v(l)%albedo(ind_veg_wall,m) = &
1779	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_veg_wall,m))
1780	IF ( surf_usm_v(l)%albedo_type(ind_pav_green,m) /= 0 ) &
1781	surf_usm_v(l)%albedo(ind_pav_green,m) = &
1782	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_pav_green,m))
1783	IF ( surf_usm_v(l)%albedo_type(ind_wat_win,m) /= 0 ) &
1784	surf_usm_v(l)%albedo(ind_wat_win,m) = &
1785	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_wat_win,m))
1786	ENDDO
1787	ENDDO
1788
1789	!
1790	!-- Level 3 initialization at grid points where albedo type is zero.
1791	!-- This case, albedo is taken from file. In case of constant radiation
1792	!-- or clear sky, only broadband albedo is given.
1793	IF ( albedo_pars_f%from_file ) THEN
1794	!
1795	!-- Horizontal surfaces
1796	DO m = 1, surf_lsm_h%ns
1797	i = surf_lsm_h%i(m)
1798	j = surf_lsm_h%j(m)
1799	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1800	IF ( surf_lsm_h%albedo_type(ind_veg_wall,m) == 0 ) &
1801	surf_lsm_h%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1802	IF ( surf_lsm_h%albedo_type(ind_pav_green,m) == 0 ) &
1803	surf_lsm_h%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1804	IF ( surf_lsm_h%albedo_type(ind_wat_win,m) == 0 ) &
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	IF ( surf_usm_h%albedo_type(ind_veg_wall,m) == 0 ) &
1813	surf_usm_h%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1814	IF ( surf_usm_h%albedo_type(ind_pav_green,m) == 0 ) &
1815	surf_usm_h%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1816	IF ( surf_usm_h%albedo_type(ind_wat_win,m) == 0 ) &
1817	surf_usm_h%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1818	ENDIF
1819	ENDDO
1820	!
1821	!-- Vertical surfaces
1822	DO l = 0, 3
1823
1824	ioff = surf_lsm_v(l)%ioff
1825	joff = surf_lsm_v(l)%joff
1826	DO m = 1, surf_lsm_v(l)%ns
1827	i = surf_lsm_v(l)%i(m) + ioff
1828	j = surf_lsm_v(l)%j(m) + joff
1829	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1830	IF ( surf_lsm_v(l)%albedo_type(ind_veg_wall,m) == 0 ) &
1831	surf_lsm_v(l)%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1832	IF ( surf_lsm_v(l)%albedo_type(ind_pav_green,m) == 0 ) &
1833	surf_lsm_v(l)%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1834	IF ( surf_lsm_v(l)%albedo_type(ind_wat_win,m) == 0 ) &
1835	surf_lsm_v(l)%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1836	ENDIF
1837	ENDDO
1838
1839	ioff = surf_usm_v(l)%ioff
1840	joff = surf_usm_v(l)%joff
1841	DO m = 1, surf_usm_v(l)%ns
1842	i = surf_usm_v(l)%i(m) + joff
1843	j = surf_usm_v(l)%j(m) + joff
1844	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1845	IF ( surf_usm_v(l)%albedo_type(ind_veg_wall,m) == 0 ) &
1846	surf_usm_v(l)%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1847	IF ( surf_usm_v(l)%albedo_type(ind_pav_green,m) == 0 ) &
1848	surf_usm_v(l)%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1849	IF ( surf_usm_v(l)%albedo_type(ind_wat_win,m) == 0 ) &
1850	surf_usm_v(l)%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1851	ENDIF
1852	ENDDO
1853	ENDDO
1854
1855	ENDIF
1856	!
1857	!-- Initialization actions for RRTMG
1858	ELSEIF ( radiation_scheme == 'rrtmg' ) THEN
1859	#if defined ( __rrtmg )
1860	!
1861	!-- Allocate albedos for short/longwave radiation, horizontal surfaces
1862	!-- for wall/green/window (USM) or vegetation/pavement/water surfaces
1863	!-- (LSM).
1864	ALLOCATE ( surf_lsm_h%aldif(0:2,1:surf_lsm_h%ns) )
1865	ALLOCATE ( surf_lsm_h%aldir(0:2,1:surf_lsm_h%ns) )
1866	ALLOCATE ( surf_lsm_h%asdif(0:2,1:surf_lsm_h%ns) )
1867	ALLOCATE ( surf_lsm_h%asdir(0:2,1:surf_lsm_h%ns) )
1868	ALLOCATE ( surf_lsm_h%rrtm_aldif(0:2,1:surf_lsm_h%ns) )
1869	ALLOCATE ( surf_lsm_h%rrtm_aldir(0:2,1:surf_lsm_h%ns) )
1870	ALLOCATE ( surf_lsm_h%rrtm_asdif(0:2,1:surf_lsm_h%ns) )
1871	ALLOCATE ( surf_lsm_h%rrtm_asdir(0:2,1:surf_lsm_h%ns) )
1872
1873	ALLOCATE ( surf_usm_h%aldif(0:2,1:surf_usm_h%ns) )
1874	ALLOCATE ( surf_usm_h%aldir(0:2,1:surf_usm_h%ns) )
1875	ALLOCATE ( surf_usm_h%asdif(0:2,1:surf_usm_h%ns) )
1876	ALLOCATE ( surf_usm_h%asdir(0:2,1:surf_usm_h%ns) )
1877	ALLOCATE ( surf_usm_h%rrtm_aldif(0:2,1:surf_usm_h%ns) )
1878	ALLOCATE ( surf_usm_h%rrtm_aldir(0:2,1:surf_usm_h%ns) )
1879	ALLOCATE ( surf_usm_h%rrtm_asdif(0:2,1:surf_usm_h%ns) )
1880	ALLOCATE ( surf_usm_h%rrtm_asdir(0:2,1:surf_usm_h%ns) )
1881
1882	!
1883	!-- Allocate broadband albedo (temporary for the current radiation
1884	!-- implementations)
1885	IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) &
1886	ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) )
1887	IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) &
1888	ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) )
1889
1890	!
1891	!-- Allocate albedos for short/longwave radiation, vertical surfaces
1892	DO l = 0, 3
1893
1894	ALLOCATE ( surf_lsm_v(l)%aldif(0:2,1:surf_lsm_v(l)%ns) )
1895	ALLOCATE ( surf_lsm_v(l)%aldir(0:2,1:surf_lsm_v(l)%ns) )
1896	ALLOCATE ( surf_lsm_v(l)%asdif(0:2,1:surf_lsm_v(l)%ns) )
1897	ALLOCATE ( surf_lsm_v(l)%asdir(0:2,1:surf_lsm_v(l)%ns) )
1898
1899	ALLOCATE ( surf_lsm_v(l)%rrtm_aldif(0:2,1:surf_lsm_v(l)%ns) )
1900	ALLOCATE ( surf_lsm_v(l)%rrtm_aldir(0:2,1:surf_lsm_v(l)%ns) )
1901	ALLOCATE ( surf_lsm_v(l)%rrtm_asdif(0:2,1:surf_lsm_v(l)%ns) )
1902	ALLOCATE ( surf_lsm_v(l)%rrtm_asdir(0:2,1:surf_lsm_v(l)%ns) )
1903
1904	ALLOCATE ( surf_usm_v(l)%aldif(0:2,1:surf_usm_v(l)%ns) )
1905	ALLOCATE ( surf_usm_v(l)%aldir(0:2,1:surf_usm_v(l)%ns) )
1906	ALLOCATE ( surf_usm_v(l)%asdif(0:2,1:surf_usm_v(l)%ns) )
1907	ALLOCATE ( surf_usm_v(l)%asdir(0:2,1:surf_usm_v(l)%ns) )
1908
1909	ALLOCATE ( surf_usm_v(l)%rrtm_aldif(0:2,1:surf_usm_v(l)%ns) )
1910	ALLOCATE ( surf_usm_v(l)%rrtm_aldir(0:2,1:surf_usm_v(l)%ns) )
1911	ALLOCATE ( surf_usm_v(l)%rrtm_asdif(0:2,1:surf_usm_v(l)%ns) )
1912	ALLOCATE ( surf_usm_v(l)%rrtm_asdir(0:2,1:surf_usm_v(l)%ns) )
1913	!
1914	!-- Allocate broadband albedo (temporary for the current radiation
1915	!-- implementations)
1916	IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) &
1917	ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) )
1918	IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) &
1919	ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) )
1920
1921	ENDDO
1922	!
1923	!-- Level 1 initialization of spectral albedos via namelist
1924	!-- paramters. Please note, this case all surface tiles are initialized
1925	!-- the same.
1926	IF ( surf_lsm_h%ns > 0 ) THEN
1927	surf_lsm_h%aldif = albedo_lw_dif
1928	surf_lsm_h%aldir = albedo_lw_dir
1929	surf_lsm_h%asdif = albedo_sw_dif
1930	surf_lsm_h%asdir = albedo_sw_dir
1931	surf_lsm_h%albedo = albedo_sw_dif
1932	ENDIF
1933	IF ( surf_usm_h%ns > 0 ) THEN
1934	IF ( surf_usm_h%albedo_from_ascii ) THEN
1935	surf_usm_h%aldif = surf_usm_h%albedo
1936	surf_usm_h%aldir = surf_usm_h%albedo
1937	surf_usm_h%asdif = surf_usm_h%albedo
1938	surf_usm_h%asdir = surf_usm_h%albedo
1939	ELSE
1940	surf_usm_h%aldif = albedo_lw_dif
1941	surf_usm_h%aldir = albedo_lw_dir
1942	surf_usm_h%asdif = albedo_sw_dif
1943	surf_usm_h%asdir = albedo_sw_dir
1944	surf_usm_h%albedo = albedo_sw_dif
1945	ENDIF
1946	ENDIF
1947
1948	DO l = 0, 3
1949
1950	IF ( surf_lsm_v(l)%ns > 0 ) THEN
1951	surf_lsm_v(l)%aldif = albedo_lw_dif
1952	surf_lsm_v(l)%aldir = albedo_lw_dir
1953	surf_lsm_v(l)%asdif = albedo_sw_dif
1954	surf_lsm_v(l)%asdir = albedo_sw_dir
1955	surf_lsm_v(l)%albedo = albedo_sw_dif
1956	ENDIF
1957
1958	IF ( surf_usm_v(l)%ns > 0 ) THEN
1959	IF ( surf_usm_v(l)%albedo_from_ascii ) THEN
1960	surf_usm_v(l)%aldif = surf_usm_v(l)%albedo
1961	surf_usm_v(l)%aldir = surf_usm_v(l)%albedo
1962	surf_usm_v(l)%asdif = surf_usm_v(l)%albedo
1963	surf_usm_v(l)%asdir = surf_usm_v(l)%albedo
1964	ELSE
1965	surf_usm_v(l)%aldif = albedo_lw_dif
1966	surf_usm_v(l)%aldir = albedo_lw_dir
1967	surf_usm_v(l)%asdif = albedo_sw_dif
1968	surf_usm_v(l)%asdir = albedo_sw_dir
1969	ENDIF
1970	ENDIF
1971	ENDDO
1972
1973	!
1974	!-- Level 2 initialization of spectral albedos via albedo_type.
1975	!-- Please note, for natural- and urban-type surfaces, a tile approach
1976	!-- is applied so that the resulting albedo is calculated via the weighted
1977	!-- average of respective surface fractions.
1978	DO m = 1, surf_lsm_h%ns
1979	!
1980	!-- Spectral albedos for vegetation/pavement/water surfaces
1981	DO ind_type = 0, 2
1982	IF ( surf_lsm_h%albedo_type(ind_type,m) /= 0 ) THEN
1983	surf_lsm_h%aldif(ind_type,m) = &
1984	albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m))
1985	surf_lsm_h%asdif(ind_type,m) = &
1986	albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m))
1987	surf_lsm_h%aldir(ind_type,m) = &
1988	albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m))
1989	surf_lsm_h%asdir(ind_type,m) = &
1990	albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m))
1991	surf_lsm_h%albedo(ind_type,m) = &
1992	albedo_pars(0,surf_lsm_h%albedo_type(ind_type,m))
1993	ENDIF
1994	ENDDO
1995
1996	ENDDO
1997	!
1998	!-- For urban surface only if albedo has not been already initialized
1999	!-- in the urban-surface model via the ASCII file.
2000	IF ( .NOT. surf_usm_h%albedo_from_ascii ) THEN
2001	DO m = 1, surf_usm_h%ns
2002	!
2003	!-- Spectral albedos for wall/green/window surfaces
2004	DO ind_type = 0, 2
2005	IF ( surf_usm_h%albedo_type(ind_type,m) /= 0 ) THEN
2006	surf_usm_h%aldif(ind_type,m) = &
2007	albedo_pars(1,surf_usm_h%albedo_type(ind_type,m))
2008	surf_usm_h%asdif(ind_type,m) = &
2009	albedo_pars(2,surf_usm_h%albedo_type(ind_type,m))
2010	surf_usm_h%aldir(ind_type,m) = &
2011	albedo_pars(1,surf_usm_h%albedo_type(ind_type,m))
2012	surf_usm_h%asdir(ind_type,m) = &
2013	albedo_pars(2,surf_usm_h%albedo_type(ind_type,m))
2014	surf_usm_h%albedo(ind_type,m) = &
2015	albedo_pars(0,surf_usm_h%albedo_type(ind_type,m))
2016	ENDIF
2017	ENDDO
2018
2019	ENDDO
2020	ENDIF
2021
2022	DO l = 0, 3
2023
2024	DO m = 1, surf_lsm_v(l)%ns
2025	!
2026	!-- Spectral albedos for vegetation/pavement/water surfaces
2027	DO ind_type = 0, 2
2028	IF ( surf_lsm_v(l)%albedo_type(ind_type,m) /= 0 ) THEN
2029	surf_lsm_v(l)%aldif(ind_type,m) = &
2030	albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m))
2031	surf_lsm_v(l)%asdif(ind_type,m) = &
2032	albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m))
2033	surf_lsm_v(l)%aldir(ind_type,m) = &
2034	albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m))
2035	surf_lsm_v(l)%asdir(ind_type,m) = &
2036	albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m))
2037	surf_lsm_v(l)%albedo(ind_type,m) = &
2038	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_type,m))
2039	ENDIF
2040	ENDDO
2041	ENDDO
2042	!
2043	!-- For urban surface only if albedo has not been already initialized
2044	!-- in the urban-surface model via the ASCII file.
2045	IF ( .NOT. surf_usm_v(l)%albedo_from_ascii ) THEN
2046	DO m = 1, surf_usm_v(l)%ns
2047	!
2048	!-- Spectral albedos for wall/green/window surfaces
2049	DO ind_type = 0, 2
2050	IF ( surf_usm_v(l)%albedo_type(ind_type,m) /= 0 ) THEN
2051	surf_usm_v(l)%aldif(ind_type,m) = &
2052	albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m))
2053	surf_usm_v(l)%asdif(ind_type,m) = &
2054	albedo_pars(2,surf_usm_v(l)%albedo_type(ind_type,m))
2055	surf_usm_v(l)%aldir(ind_type,m) = &
2056	albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m))
2057	surf_usm_v(l)%asdir(ind_type,m) = &
2058	albedo_pars(2,surf_usm_v(l)%albedo_type(ind_type,m))
2059	surf_usm_v(l)%albedo(ind_type,m) = &
2060	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_type,m))
2061	ENDIF
2062	ENDDO
2063
2064	ENDDO
2065	ENDIF
2066	ENDDO
2067	!
2068	!-- Level 3 initialization at grid points where albedo type is zero.
2069	!-- This case, spectral albedos are taken from file if available
2070	IF ( albedo_pars_f%from_file ) THEN
2071	!
2072	!-- Horizontal
2073	DO m = 1, surf_lsm_h%ns
2074	i = surf_lsm_h%i(m)
2075	j = surf_lsm_h%j(m)
2076	!
2077	!-- Spectral albedos for vegetation/pavement/water surfaces
2078	DO ind_type = 0, 2
2079	IF ( surf_lsm_h%albedo_type(ind_type,m) == 0 ) THEN
2080	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )&
2081	surf_lsm_h%albedo(ind_type,m) = &
2082	albedo_pars_f%pars_xy(0,j,i)
2083	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )&
2084	surf_lsm_h%aldir(ind_type,m) = &
2085	albedo_pars_f%pars_xy(1,j,i)
2086	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )&
2087	surf_lsm_h%aldif(ind_type,m) = &
2088	albedo_pars_f%pars_xy(1,j,i)
2089	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill )&
2090	surf_lsm_h%asdir(ind_type,m) = &
2091	albedo_pars_f%pars_xy(2,j,i)
2092	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill )&
2093	surf_lsm_h%asdif(ind_type,m) = &
2094	albedo_pars_f%pars_xy(2,j,i)
2095	ENDIF
2096	ENDDO
2097	ENDDO
2098	!
2099	!-- For urban surface only if albedo has not been already initialized
2100	!-- in the urban-surface model via the ASCII file.
2101	IF ( .NOT. surf_usm_h%albedo_from_ascii ) THEN
2102	DO m = 1, surf_usm_h%ns
2103	i = surf_usm_h%i(m)
2104	j = surf_usm_h%j(m)
2105	!
2106	!-- Broadband albedos for wall/green/window surfaces
2107	DO ind_type = 0, 2
2108	IF ( surf_usm_h%albedo_type(ind_type,m) == 0 ) THEN
2109	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )&
2110	surf_usm_h%albedo(ind_type,m) = &
2111	albedo_pars_f%pars_xy(0,j,i)
2112	ENDIF
2113	ENDDO
2114	!
2115	!-- Spectral albedos especially for building wall surfaces
2116	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) THEN
2117	surf_usm_h%aldir(ind_veg_wall,m) = &
2118	albedo_pars_f%pars_xy(1,j,i)
2119	surf_usm_h%aldif(ind_veg_wall,m) = &
2120	albedo_pars_f%pars_xy(1,j,i)
2121	ENDIF
2122	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) THEN
2123	surf_usm_h%asdir(ind_veg_wall,m) = &
2124	albedo_pars_f%pars_xy(2,j,i)
2125	surf_usm_h%asdif(ind_veg_wall,m) = &
2126	albedo_pars_f%pars_xy(2,j,i)
2127	ENDIF
2128	!
2129	!-- Spectral albedos especially for building green surfaces
2130	IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill ) THEN
2131	surf_usm_h%aldir(ind_pav_green,m) = &
2132	albedo_pars_f%pars_xy(3,j,i)
2133	surf_usm_h%aldif(ind_pav_green,m) = &
2134	albedo_pars_f%pars_xy(3,j,i)
2135	ENDIF
2136	IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill ) THEN
2137	surf_usm_h%asdir(ind_pav_green,m) = &
2138	albedo_pars_f%pars_xy(4,j,i)
2139	surf_usm_h%asdif(ind_pav_green,m) = &
2140	albedo_pars_f%pars_xy(4,j,i)
2141	ENDIF
2142	!
2143	!-- Spectral albedos especially for building window surfaces
2144	IF ( albedo_pars_f%pars_xy(5,j,i) /= albedo_pars_f%fill ) THEN
2145	surf_usm_h%aldir(ind_wat_win,m) = &
2146	albedo_pars_f%pars_xy(5,j,i)
2147	surf_usm_h%aldif(ind_wat_win,m) = &
2148	albedo_pars_f%pars_xy(5,j,i)
2149	ENDIF
2150	IF ( albedo_pars_f%pars_xy(6,j,i) /= albedo_pars_f%fill ) THEN
2151	surf_usm_h%asdir(ind_wat_win,m) = &
2152	albedo_pars_f%pars_xy(6,j,i)
2153	surf_usm_h%asdif(ind_wat_win,m) = &
2154	albedo_pars_f%pars_xy(6,j,i)
2155	ENDIF
2156
2157	ENDDO
2158	ENDIF
2159	!
2160	!-- Vertical
2161	DO l = 0, 3
2162	ioff = surf_lsm_v(l)%ioff
2163	joff = surf_lsm_v(l)%joff
2164
2165	DO m = 1, surf_lsm_v(l)%ns
2166	i = surf_lsm_v(l)%i(m)
2167	j = surf_lsm_v(l)%j(m)
2168	!
2169	!-- Spectral albedos for vegetation/pavement/water surfaces
2170	DO ind_type = 0, 2
2171	IF ( surf_lsm_v(l)%albedo_type(ind_type,m) == 0 ) THEN
2172	IF ( albedo_pars_f%pars_xy(0,j+joff,i+ioff) /= &
2173	albedo_pars_f%fill ) &
2174	surf_lsm_v(l)%albedo(ind_type,m) = &
2175	albedo_pars_f%pars_xy(0,j+joff,i+ioff)
2176	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2177	albedo_pars_f%fill ) &
2178	surf_lsm_v(l)%aldir(ind_type,m) = &
2179	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2180	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2181	albedo_pars_f%fill ) &
2182	surf_lsm_v(l)%aldif(ind_type,m) = &
2183	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2184	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2185	albedo_pars_f%fill ) &
2186	surf_lsm_v(l)%asdir(ind_type,m) = &
2187	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2188	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2189	albedo_pars_f%fill ) &
2190	surf_lsm_v(l)%asdif(ind_type,m) = &
2191	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2192	ENDIF
2193	ENDDO
2194	ENDDO
2195	!
2196	!-- For urban surface only if albedo has not been already initialized
2197	!-- in the urban-surface model via the ASCII file.
2198	IF ( .NOT. surf_usm_v(l)%albedo_from_ascii ) THEN
2199	ioff = surf_usm_v(l)%ioff
2200	joff = surf_usm_v(l)%joff
2201
2202	DO m = 1, surf_usm_v(l)%ns
2203	i = surf_usm_v(l)%i(m)
2204	j = surf_usm_v(l)%j(m)
2205	!
2206	!-- Broadband albedos for wall/green/window surfaces
2207	DO ind_type = 0, 2
2208	IF ( surf_usm_v(l)%albedo_type(ind_type,m) == 0 ) THEN
2209	IF ( albedo_pars_f%pars_xy(0,j+joff,i+ioff) /= &
2210	albedo_pars_f%fill ) &
2211	surf_usm_v(l)%albedo(ind_type,m) = &
2212	albedo_pars_f%pars_xy(0,j+joff,i+ioff)
2213	ENDIF
2214	ENDDO
2215	!
2216	!-- Spectral albedos especially for building wall surfaces
2217	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2218	albedo_pars_f%fill ) THEN
2219	surf_usm_v(l)%aldir(ind_veg_wall,m) = &
2220	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2221	surf_usm_v(l)%aldif(ind_veg_wall,m) = &
2222	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2223	ENDIF
2224	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2225	albedo_pars_f%fill ) THEN
2226	surf_usm_v(l)%asdir(ind_veg_wall,m) = &
2227	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2228	surf_usm_v(l)%asdif(ind_veg_wall,m) = &
2229	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2230	ENDIF
2231	!
2232	!-- Spectral albedos especially for building green surfaces
2233	IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= &
2234	albedo_pars_f%fill ) THEN
2235	surf_usm_v(l)%aldir(ind_pav_green,m) = &
2236	albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2237	surf_usm_v(l)%aldif(ind_pav_green,m) = &
2238	albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2239	ENDIF
2240	IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= &
2241	albedo_pars_f%fill ) THEN
2242	surf_usm_v(l)%asdir(ind_pav_green,m) = &
2243	albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2244	surf_usm_v(l)%asdif(ind_pav_green,m) = &
2245	albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2246	ENDIF
2247	!
2248	!-- Spectral albedos especially for building window surfaces
2249	IF ( albedo_pars_f%pars_xy(5,j+joff,i+ioff) /= &
2250	albedo_pars_f%fill ) THEN
2251	surf_usm_v(l)%aldir(ind_wat_win,m) = &
2252	albedo_pars_f%pars_xy(5,j+joff,i+ioff)
2253	surf_usm_v(l)%aldif(ind_wat_win,m) = &
2254	albedo_pars_f%pars_xy(5,j+joff,i+ioff)
2255	ENDIF
2256	IF ( albedo_pars_f%pars_xy(6,j+joff,i+ioff) /= &
2257	albedo_pars_f%fill ) THEN
2258	surf_usm_v(l)%asdir(ind_wat_win,m) = &
2259	albedo_pars_f%pars_xy(6,j+joff,i+ioff)
2260	surf_usm_v(l)%asdif(ind_wat_win,m) = &
2261	albedo_pars_f%pars_xy(6,j+joff,i+ioff)
2262	ENDIF
2263	ENDDO
2264	ENDIF
2265	ENDDO
2266
2267	ENDIF
2268
2269	!
2270	!-- Calculate initial values of current (cosine of) the zenith angle and
2271	!-- whether the sun is up
2272	CALL calc_zenith
2273	!
2274	!-- readjust date and time to its initial value
2275	CALL init_date_and_time
2276	!
2277	!-- Calculate initial surface albedo for different surfaces
2278	IF ( .NOT. constant_albedo ) THEN
2279	#if defined( __netcdf )
2280	!
2281	!-- Horizontally aligned natural and urban surfaces
2282	CALL calc_albedo( surf_lsm_h )
2283	CALL calc_albedo( surf_usm_h )
2284	!
2285	!-- Vertically aligned natural and urban surfaces
2286	DO l = 0, 3
2287	CALL calc_albedo( surf_lsm_v(l) )
2288	CALL calc_albedo( surf_usm_v(l) )
2289	ENDDO
2290	#endif
2291	ELSE
2292	!
2293	!-- Initialize sun-inclination independent spectral albedos
2294	!-- Horizontal surfaces
2295	IF ( surf_lsm_h%ns > 0 ) THEN
2296	surf_lsm_h%rrtm_aldir = surf_lsm_h%aldir
2297	surf_lsm_h%rrtm_asdir = surf_lsm_h%asdir
2298	surf_lsm_h%rrtm_aldif = surf_lsm_h%aldif
2299	surf_lsm_h%rrtm_asdif = surf_lsm_h%asdif
2300	ENDIF
2301	IF ( surf_usm_h%ns > 0 ) THEN
2302	surf_usm_h%rrtm_aldir = surf_usm_h%aldir
2303	surf_usm_h%rrtm_asdir = surf_usm_h%asdir
2304	surf_usm_h%rrtm_aldif = surf_usm_h%aldif
2305	surf_usm_h%rrtm_asdif = surf_usm_h%asdif
2306	ENDIF
2307	!
2308	!-- Vertical surfaces
2309	DO l = 0, 3
2310	IF ( surf_lsm_v(l)%ns > 0 ) THEN
2311	surf_lsm_v(l)%rrtm_aldir = surf_lsm_v(l)%aldir
2312	surf_lsm_v(l)%rrtm_asdir = surf_lsm_v(l)%asdir
2313	surf_lsm_v(l)%rrtm_aldif = surf_lsm_v(l)%aldif
2314	surf_lsm_v(l)%rrtm_asdif = surf_lsm_v(l)%asdif
2315	ENDIF
2316	IF ( surf_usm_v(l)%ns > 0 ) THEN
2317	surf_usm_v(l)%rrtm_aldir = surf_usm_v(l)%aldir
2318	surf_usm_v(l)%rrtm_asdir = surf_usm_v(l)%asdir
2319	surf_usm_v(l)%rrtm_aldif = surf_usm_v(l)%aldif
2320	surf_usm_v(l)%rrtm_asdif = surf_usm_v(l)%asdif
2321	ENDIF
2322	ENDDO
2323
2324	ENDIF
2325
2326	!
2327	!-- Allocate 3d arrays of radiative fluxes and heating rates
2328	IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN
2329	ALLOCATE ( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2330	rad_sw_in = 0.0_wp
2331	ENDIF
2332
2333	IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN
2334	ALLOCATE ( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2335	ENDIF
2336
2337	IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN
2338	ALLOCATE ( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2339	rad_sw_out = 0.0_wp
2340	ENDIF
2341
2342	IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN
2343	ALLOCATE ( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2344	ENDIF
2345
2346	IF ( .NOT. ALLOCATED ( rad_sw_hr ) ) THEN
2347	ALLOCATE ( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2348	rad_sw_hr = 0.0_wp
2349	ENDIF
2350
2351	IF ( .NOT. ALLOCATED ( rad_sw_hr_av ) ) THEN
2352	ALLOCATE ( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2353	rad_sw_hr_av = 0.0_wp
2354	ENDIF
2355
2356	IF ( .NOT. ALLOCATED ( rad_sw_cs_hr ) ) THEN
2357	ALLOCATE ( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2358	rad_sw_cs_hr = 0.0_wp
2359	ENDIF
2360
2361	IF ( .NOT. ALLOCATED ( rad_sw_cs_hr_av ) ) THEN
2362	ALLOCATE ( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2363	rad_sw_cs_hr_av = 0.0_wp
2364	ENDIF
2365
2366	IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN
2367	ALLOCATE ( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2368	rad_lw_in = 0.0_wp
2369	ENDIF
2370
2371	IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN
2372	ALLOCATE ( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2373	ENDIF
2374
2375	IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN
2376	ALLOCATE ( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2377	rad_lw_out = 0.0_wp
2378	ENDIF
2379
2380	IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN
2381	ALLOCATE ( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2382	ENDIF
2383
2384	IF ( .NOT. ALLOCATED ( rad_lw_hr ) ) THEN
2385	ALLOCATE ( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2386	rad_lw_hr = 0.0_wp
2387	ENDIF
2388
2389	IF ( .NOT. ALLOCATED ( rad_lw_hr_av ) ) THEN
2390	ALLOCATE ( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2391	rad_lw_hr_av = 0.0_wp
2392	ENDIF
2393
2394	IF ( .NOT. ALLOCATED ( rad_lw_cs_hr ) ) THEN
2395	ALLOCATE ( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2396	rad_lw_cs_hr = 0.0_wp
2397	ENDIF
2398
2399	IF ( .NOT. ALLOCATED ( rad_lw_cs_hr_av ) ) THEN
2400	ALLOCATE ( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2401	rad_lw_cs_hr_av = 0.0_wp
2402	ENDIF
2403
2404	ALLOCATE ( rad_sw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2405	ALLOCATE ( rad_sw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2406	rad_sw_cs_in = 0.0_wp
2407	rad_sw_cs_out = 0.0_wp
2408
2409	ALLOCATE ( rad_lw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2410	ALLOCATE ( rad_lw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2411	rad_lw_cs_in = 0.0_wp
2412	rad_lw_cs_out = 0.0_wp
2413
2414	!
2415	!-- Allocate 1-element array for surface temperature
2416	!-- (RRTMG anticipates an array as passed argument).
2417	ALLOCATE ( rrtm_tsfc(1) )
2418	!
2419	!-- Allocate surface emissivity.
2420	!-- Values will be given directly before calling rrtm_lw.
2421	ALLOCATE ( rrtm_emis(0:0,1:nbndlw+1) )
2422
2423	!
2424	!-- Initialize RRTMG, before check if files are existent
2425	INQUIRE( FILE='rrtmg_lw.nc', EXIST=lw_exists )
2426	IF ( .NOT. lw_exists ) THEN
2427	message_string = 'Input file rrtmg_lw.nc' // &
2428	'&for rrtmg missing. ' // &
2429	'&Please provide <jobname>_lsw file in the INPUT directory.'
2430	CALL message( 'radiation_init', 'PA0583', 1, 2, 0, 6, 0 )
2431	ENDIF
2432	INQUIRE( FILE='rrtmg_sw.nc', EXIST=sw_exists )
2433	IF ( .NOT. sw_exists ) THEN
2434	message_string = 'Input file rrtmg_sw.nc' // &
2435	'&for rrtmg missing. ' // &
2436	'&Please provide <jobname>_rsw file in the INPUT directory.'
2437	CALL message( 'radiation_init', 'PA0584', 1, 2, 0, 6, 0 )
2438	ENDIF
2439
2440	IF ( lw_radiation ) CALL rrtmg_lw_ini ( c_p )
2441	IF ( sw_radiation ) CALL rrtmg_sw_ini ( c_p )
2442
2443	!
2444	!-- Set input files for RRTMG
2445	INQUIRE(FILE="RAD_SND_DATA", EXIST=snd_exists)
2446	IF ( .NOT. snd_exists ) THEN
2447	rrtm_input_file = "rrtmg_lw.nc"
2448	ENDIF
2449
2450	!
2451	!-- Read vertical layers for RRTMG from sounding data
2452	!-- The routine provides nzt_rad, hyp_snd(1:nzt_rad),
2453	!-- t_snd(nzt+2:nzt_rad), rrtm_play(1:nzt_rad), rrtm_plev(1_nzt_rad+1),
2454	!-- rrtm_tlay(nzt+2:nzt_rad), rrtm_tlev(nzt+2:nzt_rad+1)
2455	CALL read_sounding_data
2456
2457	!
2458	!-- Read trace gas profiles from file. This routine provides
2459	!-- the rrtm_ arrays (1:nzt_rad+1)
2460	CALL read_trace_gas_data
2461	#endif
2462	ENDIF
2463	!
2464	!-- Initializaion actions exclusively required for external
2465	!-- radiation forcing
2466	IF ( radiation_scheme == 'external' ) THEN
2467	!
2468	!-- Open the radiation input file. Note, for child domain, a dynamic
2469	!-- input file is often not provided. In order to do not need to
2470	!-- duplicate the dynamic input file just for the radiation input, take
2471	!-- it from the dynamic file for the parent if not available for the
2472	!-- child domain(s). In this case this is possible because radiation
2473	!-- input should be the same for each model.
2474	INQUIRE( FILE = TRIM( input_file_dynamic ), &
2475	EXIST = radiation_input_root_domain )
2476
2477	IF ( .NOT. input_pids_dynamic .AND. &
2478	.NOT. radiation_input_root_domain ) THEN
2479	message_string = 'In case of external radiation forcing ' // &
2480	'a dynamic input file is required. If no ' // &
2481	'dynamic input for the child domain(s) is ' // &
2482	'provided, at least one for the root domain ' // &
2483	'is needed.'
2484	CALL message( 'radiation_init', 'PA0315', 1, 2, 0, 6, 0 )
2485	ENDIF
2486	#if defined( __netcdf )
2487	!
2488	!-- Open dynamic input file for child domain if available, else, open
2489	!-- dynamic input file for the root domain.
2490	IF ( input_pids_dynamic ) THEN
2491	CALL open_read_file( TRIM( input_file_dynamic ) // &
2492	TRIM( coupling_char ), &
2493	pids_id )
2494	ELSEIF ( radiation_input_root_domain ) THEN
2495	CALL open_read_file( TRIM( input_file_dynamic ), &
2496	pids_id )
2497	ENDIF
2498
2499	CALL inquire_num_variables( pids_id, num_var_pids )
2500	!
2501	!-- Allocate memory to store variable names and read them
2502	ALLOCATE( vars_pids(1:num_var_pids) )
2503	CALL inquire_variable_names( pids_id, vars_pids )
2504	!
2505	!-- Input time dimension.
2506	IF ( check_existence( vars_pids, 'time_rad' ) ) THEN
2507	CALL netcdf_data_input_get_dimension_length( pids_id, &
2508	ntime, &
2509	'time_rad' )
2510
2511	ALLOCATE( time_rad_f%var1d(0:ntime-1) )
2512	!
2513	!-- Read variable
2514	CALL get_variable( pids_id, 'time_rad', time_rad_f%var1d )
2515
2516	time_rad_f%from_file = .TRUE.
2517	ENDIF
2518	!
2519	!-- Input shortwave downwelling.
2520	IF ( check_existence( vars_pids, 'rad_sw_in' ) ) THEN
2521	!
2522	!-- Get _FillValue attribute
2523	CALL get_attribute( pids_id, char_fill, rad_sw_in_f%fill, &
2524	.FALSE., 'rad_sw_in' )
2525	!
2526	!-- Get level-of-detail
2527	CALL get_attribute( pids_id, char_lod, rad_sw_in_f%lod, &
2528	.FALSE., 'rad_sw_in' )
2529	!
2530	!-- Level-of-detail 1 - radiation depends only on time_rad
2531	IF ( rad_sw_in_f%lod == 1 ) THEN
2532	ALLOCATE( rad_sw_in_f%var1d(0:ntime-1) )
2533	CALL get_variable( pids_id, 'rad_sw_in', rad_sw_in_f%var1d )
2534	rad_sw_in_f%from_file = .TRUE.
2535	!
2536	!-- Level-of-detail 2 - radiation depends on time_rad, y, x
2537	ELSEIF ( rad_sw_in_f%lod == 2 ) THEN
2538	ALLOCATE( rad_sw_in_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2539
2540	CALL get_variable( pids_id, 'rad_sw_in', rad_sw_in_f%var3d, &
2541	nxl, nxr, nys, nyn, 0, ntime-1 )
2542
2543	rad_sw_in_f%from_file = .TRUE.
2544	ELSE
2545	message_string = '"rad_sw_in" has no valid lod attribute'
2546	CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2547	ENDIF
2548	ENDIF
2549	!
2550	!-- Input longwave downwelling.
2551	IF ( check_existence( vars_pids, 'rad_lw_in' ) ) THEN
2552	!
2553	!-- Get _FillValue attribute
2554	CALL get_attribute( pids_id, char_fill, rad_lw_in_f%fill, &
2555	.FALSE., 'rad_lw_in' )
2556	!
2557	!-- Get level-of-detail
2558	CALL get_attribute( pids_id, char_lod, rad_lw_in_f%lod, &
2559	.FALSE., 'rad_lw_in' )
2560	!
2561	!-- Level-of-detail 1 - radiation depends only on time_rad
2562	IF ( rad_lw_in_f%lod == 1 ) THEN
2563	ALLOCATE( rad_lw_in_f%var1d(0:ntime-1) )
2564	CALL get_variable( pids_id, 'rad_lw_in', rad_lw_in_f%var1d )
2565	rad_lw_in_f%from_file = .TRUE.
2566	!
2567	!-- Level-of-detail 2 - radiation depends on time_rad, y, x
2568	ELSEIF ( rad_lw_in_f%lod == 2 ) THEN
2569	ALLOCATE( rad_lw_in_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2570
2571	CALL get_variable( pids_id, 'rad_lw_in', rad_lw_in_f%var3d, &
2572	nxl, nxr, nys, nyn, 0, ntime-1 )
2573
2574	rad_lw_in_f%from_file = .TRUE.
2575	ELSE
2576	message_string = '"rad_lw_in" has no valid lod attribute'
2577	CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2578	ENDIF
2579	ENDIF
2580	!
2581	!-- Input shortwave downwelling, diffuse part.
2582	IF ( check_existence( vars_pids, 'rad_sw_in_dif' ) ) THEN
2583	!
2584	!-- Read _FillValue attribute
2585	CALL get_attribute( pids_id, char_fill, rad_sw_in_dif_f%fill, &
2586	.FALSE., 'rad_sw_in_dif' )
2587	!
2588	!-- Get level-of-detail
2589	CALL get_attribute( pids_id, char_lod, rad_sw_in_dif_f%lod, &
2590	.FALSE., 'rad_sw_in_dif' )
2591	!
2592	!-- Level-of-detail 1 - radiation depends only on time_rad
2593	IF ( rad_sw_in_dif_f%lod == 1 ) THEN
2594	ALLOCATE( rad_sw_in_dif_f%var1d(0:ntime-1) )
2595	CALL get_variable( pids_id, 'rad_sw_in_dif', &
2596	rad_sw_in_dif_f%var1d )
2597	rad_sw_in_dif_f%from_file = .TRUE.
2598	!
2599	!-- Level-of-detail 2 - radiation depends on time_rad, y, x
2600	ELSEIF ( rad_sw_in_dif_f%lod == 2 ) THEN
2601	ALLOCATE( rad_sw_in_dif_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2602
2603	CALL get_variable( pids_id, 'rad_sw_in_dif', &
2604	rad_sw_in_dif_f%var3d, &
2605	nxl, nxr, nys, nyn, 0, ntime-1 )
2606
2607	rad_sw_in_dif_f%from_file = .TRUE.
2608	ELSE
2609	message_string = '"rad_sw_in_dif" has no valid lod attribute'
2610	CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2611	ENDIF
2612	ENDIF
2613	!
2614	!-- Finally, close the input file and deallocate temporary arrays
2615	DEALLOCATE( vars_pids )
2616
2617	CALL close_input_file( pids_id )
2618	#endif
2619	!
2620	!-- Make some consistency checks.
2621	IF ( .NOT. rad_sw_in_f%from_file .OR. &
2622	.NOT. rad_lw_in_f%from_file ) THEN
2623	message_string = 'In case of external radiation forcing ' // &
2624	'both, rad_sw_in and rad_lw_in are required.'
2625	CALL message( 'radiation_init', 'PA0195', 1, 2, 0, 6, 0 )
2626	ENDIF
2627
2628	IF ( .NOT. time_rad_f%from_file ) THEN
2629	message_string = 'In case of external radiation forcing ' // &
2630	'dimension time_rad is required.'
2631	CALL message( 'radiation_init', 'PA0196', 1, 2, 0, 6, 0 )
2632	ENDIF
2633
2634	IF ( time_rad_f%var1d(0) /= 0.0_wp ) THEN
2635	message_string = 'External radiation forcing: first point in ' // &
2636	'time is /= 0.0.'
2637	CALL message( 'radiation_init', 'PA0313', 1, 2, 0, 6, 0 )
2638	ENDIF
2639
2640	IF ( end_time - spinup_time > time_rad_f%var1d(ntime-1) ) THEN
2641	message_string = 'External radiation forcing does not cover ' // &
2642	'the entire simulation time.'
2643	CALL message( 'radiation_init', 'PA0314', 1, 2, 0, 6, 0 )
2644	ENDIF
2645	!
2646	!-- Check for fill values in radiation
2647	IF ( ALLOCATED( rad_sw_in_f%var1d ) ) THEN
2648	IF ( ANY( rad_sw_in_f%var1d == rad_sw_in_f%fill ) ) THEN
2649	message_string = 'External radiation array "rad_sw_in" ' // &
2650	'must not contain any fill values.'
2651	CALL message( 'radiation_init', 'PA0197', 1, 2, 0, 6, 0 )
2652	ENDIF
2653	ENDIF
2654
2655	IF ( ALLOCATED( rad_lw_in_f%var1d ) ) THEN
2656	IF ( ANY( rad_lw_in_f%var1d == rad_lw_in_f%fill ) ) THEN
2657	message_string = 'External radiation array "rad_lw_in" ' // &
2658	'must not contain any fill values.'
2659	CALL message( 'radiation_init', 'PA0198', 1, 2, 0, 6, 0 )
2660	ENDIF
2661	ENDIF
2662
2663	IF ( ALLOCATED( rad_sw_in_dif_f%var1d ) ) THEN
2664	IF ( ANY( rad_sw_in_dif_f%var1d == rad_sw_in_dif_f%fill ) ) THEN
2665	message_string = 'External radiation array "rad_sw_in_dif" ' //&
2666	'must not contain any fill values.'
2667	CALL message( 'radiation_init', 'PA0199', 1, 2, 0, 6, 0 )
2668	ENDIF
2669	ENDIF
2670
2671	IF ( ALLOCATED( rad_sw_in_f%var3d ) ) THEN
2672	IF ( ANY( rad_sw_in_f%var3d == rad_sw_in_f%fill ) ) THEN
2673	message_string = 'External radiation array "rad_sw_in" ' // &
2674	'must not contain any fill values.'
2675	CALL message( 'radiation_init', 'PA0197', 1, 2, 0, 6, 0 )
2676	ENDIF
2677	ENDIF
2678
2679	IF ( ALLOCATED( rad_lw_in_f%var3d ) ) THEN
2680	IF ( ANY( rad_lw_in_f%var3d == rad_lw_in_f%fill ) ) THEN
2681	message_string = 'External radiation array "rad_lw_in" ' // &
2682	'must not contain any fill values.'
2683	CALL message( 'radiation_init', 'PA0198', 1, 2, 0, 6, 0 )
2684	ENDIF
2685	ENDIF
2686
2687	IF ( ALLOCATED( rad_sw_in_dif_f%var3d ) ) THEN
2688	IF ( ANY( rad_sw_in_dif_f%var3d == rad_sw_in_dif_f%fill ) ) THEN
2689	message_string = 'External radiation array "rad_sw_in_dif" ' //&
2690	'must not contain any fill values.'
2691	CALL message( 'radiation_init', 'PA0199', 1, 2, 0, 6, 0 )
2692	ENDIF
2693	ENDIF
2694	!
2695	!-- Currently, 2D external radiation input is not possible in
2696	!-- combination with topography where average radiation is used.
2697	IF ( ( rad_sw_in_f%lod == 2 .OR. rad_sw_in_f%lod == 2 .OR. &
2698	rad_sw_in_dif_f%lod == 2 ) .AND. average_radiation ) THEN
2699	message_string = 'External radiation with lod = 2 is currently '//&
2700	'not possible with average_radiation = .T..'
2701	CALL message( 'radiation_init', 'PA0670', 1, 2, 0, 6, 0 )
2702	ENDIF
2703	!
2704	!-- All radiation input should have the same level of detail. The sum
2705	!-- of lods divided by the number of available radiation arrays must be
2706	!-- 1 (if all are lod = 1) or 2 (if all are lod = 2).
2707	IF ( REAL( MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + &
2708	MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + &
2709	MERGE( rad_sw_in_dif_f%lod, 0, rad_sw_in_dif_f%from_file ),&
2710	KIND = wp ) / &
2711	( MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + &
2712	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + &
2713	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_dif_f%from_file ) ) &
2714	/= 1.0_wp .AND. &
2715	REAL( MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + &
2716	MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + &
2717	MERGE( rad_sw_in_dif_f%lod, 0, rad_sw_in_dif_f%from_file ),&
2718	KIND = wp ) / &
2719	( MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + &
2720	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + &
2721	MERGE( 1.0_wp, 0.0_wp, rad_sw_in_dif_f%from_file ) ) &
2722	/= 2.0_wp ) THEN
2723	message_string = 'External radiation input should have the same '//&
2724	'lod.'
2725	CALL message( 'radiation_init', 'PA0673', 1, 2, 0, 6, 0 )
2726	ENDIF
2727
2728	ENDIF
2729	!
2730	!-- Perform user actions if required
2731	CALL user_init_radiation
2732
2733	!
2734	!-- Calculate radiative fluxes at model start
2735	SELECT CASE ( TRIM( radiation_scheme ) )
2736
2737	CASE ( 'rrtmg' )
2738	CALL radiation_rrtmg
2739
2740	CASE ( 'clear-sky' )
2741	CALL radiation_clearsky
2742
2743	CASE ( 'constant' )
2744	CALL radiation_constant
2745
2746	CASE ( 'external' )
2747	!
2748	!-- During spinup apply clear-sky model
2749	IF ( time_since_reference_point < 0.0_wp ) THEN
2750	CALL radiation_clearsky
2751	ELSE
2752	CALL radiation_external
2753	ENDIF
2754
2755	CASE DEFAULT
2756
2757	END SELECT
2758	!
2759	!-- Readjust date and time to its initial value
2760	CALL init_date_and_time
2761
2762	!
2763	!-- Find all discretized apparent solar positions for radiation interaction.
2764	IF ( radiation_interactions ) CALL radiation_presimulate_solar_pos
2765
2766	!
2767	!-- If required, read or calculate and write out the SVF
2768	IF ( radiation_interactions .AND. read_svf) THEN
2769	!
2770	!-- Read sky-view factors and further required data from file
2771	CALL radiation_read_svf()
2772
2773	ELSEIF ( radiation_interactions .AND. .NOT. read_svf) THEN
2774	!
2775	!-- calculate SFV and CSF
2776	CALL radiation_calc_svf()
2777	ENDIF
2778
2779	IF ( radiation_interactions .AND. write_svf) THEN
2780	!
2781	!-- Write svf, csf svfsurf and csfsurf data to file
2782	CALL radiation_write_svf()
2783	ENDIF
2784
2785	!
2786	!-- Adjust radiative fluxes. In case of urban and land surfaces, also
2787	!-- call an initial interaction.
2788	IF ( radiation_interactions ) THEN
2789	CALL radiation_interaction
2790	ENDIF
2791
2792	IF ( debug_output ) CALL debug_message( 'radiation_init', 'end' )
2793
2794	RETURN !todo: remove, I don't see what we need this for here
2795
2796	END SUBROUTINE radiation_init
2797
2798
2799	!------------------------------------------------------------------------------!
2800	! Description:
2801	! ------------
2802	!> A simple clear sky radiation model
2803	!------------------------------------------------------------------------------!
2804	SUBROUTINE radiation_external
2805
2806	IMPLICIT NONE
2807
2808	INTEGER(iwp) :: l !< running index for surface orientation
2809	INTEGER(iwp) :: t !< index of current timestep
2810	INTEGER(iwp) :: tm !< index of previous timestep
2811
2812	REAL(wp) :: fac_dt !< interpolation factor
2813
2814	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
2815
2816	!
2817	!-- Calculate current zenith angle
2818	CALL calc_zenith
2819	!
2820	!-- Interpolate external radiation on current timestep
2821	IF ( time_since_reference_point <= 0.0_wp ) THEN
2822	t = 0
2823	tm = 0
2824	fac_dt = 0
2825	ELSE
2826	t = 0
2827	DO WHILE ( time_rad_f%var1d(t) <= time_since_reference_point )
2828	t = t + 1
2829	ENDDO
2830
2831	tm = MAX( t-1, 0 )
2832
2833	fac_dt = ( time_since_reference_point - time_rad_f%var1d(tm) + dt_3d ) &
2834	/ ( time_rad_f%var1d(t) - time_rad_f%var1d(tm) )
2835	fac_dt = MIN( 1.0_wp, fac_dt )
2836	ENDIF
2837	!
2838	!-- Call clear-sky calculation for each surface orientation.
2839	!-- First, horizontal surfaces
2840	surf => surf_lsm_h
2841	CALL radiation_external_surf
2842	surf => surf_usm_h
2843	CALL radiation_external_surf
2844	!
2845	!-- Vertical surfaces
2846	DO l = 0, 3
2847	surf => surf_lsm_v(l)
2848	CALL radiation_external_surf
2849	surf => surf_usm_v(l)
2850	CALL radiation_external_surf
2851	ENDDO
2852
2853	CONTAINS
2854
2855	SUBROUTINE radiation_external_surf
2856
2857	USE control_parameters
2858
2859	IMPLICIT NONE
2860
2861	INTEGER(iwp) :: i !< grid index along x-dimension
2862	INTEGER(iwp) :: j !< grid index along y-dimension
2863	INTEGER(iwp) :: k !< grid index along z-dimension
2864	INTEGER(iwp) :: m !< running index for surface elements
2865
2866	REAL(wp) :: lw_in !< downwelling longwave radiation, interpolated value
2867	REAL(wp) :: sw_in !< downwelling shortwave radiation, interpolated value
2868	REAL(wp) :: sw_in_dif !< downwelling diffuse shortwave radiation, interpolated value
2869
2870	IF ( surf%ns < 1 ) RETURN
2871	!
2872	!-- level-of-detail = 1. Note, here it must be distinguished between
2873	!-- averaged radiation and non-averaged radiation for the upwelling
2874	!-- fluxes.
2875	IF ( rad_sw_in_f%lod == 1 ) THEN
2876
2877	sw_in = ( 1.0_wp - fac_dt ) * rad_sw_in_f%var1d(tm) &
2878	+ fac_dt * rad_sw_in_f%var1d(t)
2879
2880	lw_in = ( 1.0_wp - fac_dt ) * rad_lw_in_f%var1d(tm) &
2881	+ fac_dt * rad_lw_in_f%var1d(t)
2882	!
2883	!-- Limit shortwave incoming radiation to positive values, in order
2884	!-- to overcome possible observation errors.
2885	sw_in = MAX( 0.0_wp, sw_in )
2886	sw_in = MERGE( sw_in, 0.0_wp, sun_up )
2887
2888	surf%rad_sw_in = sw_in
2889	surf%rad_lw_in = lw_in
2890
2891	IF ( average_radiation ) THEN
2892	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
2893
2894	surf%rad_lw_out = emissivity_urb * sigma_sb * t_rad_urb**4 &
2895	+ ( 1.0_wp - emissivity_urb ) * surf%rad_lw_in
2896
2897	surf%rad_net = surf%rad_sw_in - surf%rad_sw_out &
2898	+ surf%rad_lw_in - surf%rad_lw_out
2899
2900	surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb &
2901	* sigma_sb &
2902	* t_rad_urb**3
2903	ELSE
2904	DO m = 1, surf%ns
2905	k = surf%k(m)
2906	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
2907	surf%albedo(ind_veg_wall,m) &
2908	+ surf%frac(ind_pav_green,m) * &
2909	surf%albedo(ind_pav_green,m) &
2910	+ surf%frac(ind_wat_win,m) * &
2911	surf%albedo(ind_wat_win,m) ) &
2912	* surf%rad_sw_in(m)
2913
2914	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
2915	surf%emissivity(ind_veg_wall,m) &
2916	+ surf%frac(ind_pav_green,m) * &
2917	surf%emissivity(ind_pav_green,m) &
2918	+ surf%frac(ind_wat_win,m) * &
2919	surf%emissivity(ind_wat_win,m) &
2920	) &
2921	* sigma_sb &
2922	* ( surf%pt_surface(m) * exner(k) )**4
2923
2924	surf%rad_lw_out_change_0(m) = &
2925	( surf%frac(ind_veg_wall,m) * &
2926	surf%emissivity(ind_veg_wall,m) &
2927	+ surf%frac(ind_pav_green,m) * &
2928	surf%emissivity(ind_pav_green,m) &
2929	+ surf%frac(ind_wat_win,m) * &
2930	surf%emissivity(ind_wat_win,m) &
2931	) * 4.0_wp * sigma_sb &
2932	* ( surf%pt_surface(m) * exner(k) )**3
2933	ENDDO
2934
2935	ENDIF
2936	!
2937	!-- If diffuse shortwave radiation is available, store it on
2938	!-- the respective files.
2939	IF ( rad_sw_in_dif_f%from_file ) THEN
2940	sw_in_dif= ( 1.0_wp - fac_dt ) * rad_sw_in_dif_f%var1d(tm) &
2941	+ fac_dt * rad_sw_in_dif_f%var1d(t)
2942
2943	IF ( ALLOCATED( rad_sw_in_diff ) ) rad_sw_in_diff = sw_in_dif
2944	IF ( ALLOCATED( rad_sw_in_dir ) ) rad_sw_in_dir = sw_in &
2945	- sw_in_dif
2946	!
2947	!-- Diffuse longwave radiation equals the total downwelling
2948	!-- longwave radiation
2949	IF ( ALLOCATED( rad_lw_in_diff ) ) rad_lw_in_diff = lw_in
2950	ENDIF
2951	!
2952	!-- level-of-detail = 2
2953	ELSE
2954
2955	DO m = 1, surf%ns
2956	i = surf%i(m)
2957	j = surf%j(m)
2958	k = surf%k(m)
2959
2960	surf%rad_sw_in(m) = ( 1.0_wp - fac_dt ) &
2961	* rad_sw_in_f%var3d(tm,j,i) &
2962	+ fac_dt * rad_sw_in_f%var3d(t,j,i)
2963	!
2964	!-- Limit shortwave incoming radiation to positive values, in
2965	!-- order to overcome possible observation errors.
2966	surf%rad_sw_in(m) = MAX( 0.0_wp, surf%rad_sw_in(m) )
2967	surf%rad_sw_in(m) = MERGE( surf%rad_sw_in(m), 0.0_wp, sun_up )
2968
2969	surf%rad_lw_in(m) = ( 1.0_wp - fac_dt ) &
2970	* rad_lw_in_f%var3d(tm,j,i) &
2971	+ fac_dt * rad_lw_in_f%var3d(t,j,i)
2972	!
2973	!-- Weighted average according to surface fraction.
2974	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
2975	surf%albedo(ind_veg_wall,m) &
2976	+ surf%frac(ind_pav_green,m) * &
2977	surf%albedo(ind_pav_green,m) &
2978	+ surf%frac(ind_wat_win,m) * &
2979	surf%albedo(ind_wat_win,m) ) &
2980	* surf%rad_sw_in(m)
2981
2982	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
2983	surf%emissivity(ind_veg_wall,m) &
2984	+ surf%frac(ind_pav_green,m) * &
2985	surf%emissivity(ind_pav_green,m) &
2986	+ surf%frac(ind_wat_win,m) * &
2987	surf%emissivity(ind_wat_win,m) &
2988	) &
2989	* sigma_sb &
2990	* ( surf%pt_surface(m) * exner(k) )**4
2991
2992	surf%rad_lw_out_change_0(m) = &
2993	( surf%frac(ind_veg_wall,m) * &
2994	surf%emissivity(ind_veg_wall,m) &
2995	+ surf%frac(ind_pav_green,m) * &
2996	surf%emissivity(ind_pav_green,m) &
2997	+ surf%frac(ind_wat_win,m) * &
2998	surf%emissivity(ind_wat_win,m) &
2999	) * 4.0_wp * sigma_sb &
3000	* ( surf%pt_surface(m) * exner(k) )**3
3001
3002	surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) &
3003	+ surf%rad_lw_in(m) - surf%rad_lw_out(m)
3004	!
3005	!-- If diffuse shortwave radiation is available, store it on
3006	!-- the respective files.
3007	IF ( rad_sw_in_dif_f%from_file ) THEN
3008	IF ( ALLOCATED( rad_sw_in_diff ) ) &
3009	rad_sw_in_diff(j,i) = ( 1.0_wp - fac_dt ) &
3010	* rad_sw_in_dif_f%var3d(tm,j,i) &
3011	+ fac_dt * rad_sw_in_dif_f%var3d(t,j,i)
3012	!
3013	!-- dir = sw_in - sw_in_dif.
3014	IF ( ALLOCATED( rad_sw_in_dir ) ) &
3015	rad_sw_in_dir(j,i) = surf%rad_sw_in(m) - &
3016	rad_sw_in_diff(j,i)
3017	!
3018	!-- Diffuse longwave radiation equals the total downwelling
3019	!-- longwave radiation
3020	IF ( ALLOCATED( rad_lw_in_diff ) ) &
3021	rad_lw_in_diff = surf%rad_lw_in(m)
3022	ENDIF
3023
3024	ENDDO
3025
3026	ENDIF
3027	!
3028	!-- Store radiation also on 2D arrays, which are still used for
3029	!-- direct-diffuse splitting.
3030	DO m = 1, surf%ns
3031	i = surf%i(m)
3032	j = surf%j(m)
3033
3034	rad_sw_in(0,:,:) = surf%rad_sw_in(m)
3035	rad_lw_in(0,:,:) = surf%rad_lw_in(m)
3036	rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3037	rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3038	ENDDO
3039
3040	END SUBROUTINE radiation_external_surf
3041
3042	END SUBROUTINE radiation_external
3043
3044	!------------------------------------------------------------------------------!
3045	! Description:
3046	! ------------
3047	!> A simple clear sky radiation model
3048	!------------------------------------------------------------------------------!
3049	SUBROUTINE radiation_clearsky
3050
3051
3052	IMPLICIT NONE
3053
3054	INTEGER(iwp) :: l !< running index for surface orientation
3055	REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top
3056	REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain
3057	REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top
3058	REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain
3059
3060	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
3061
3062	!
3063	!-- Calculate current zenith angle
3064	CALL calc_zenith
3065
3066	!
3067	!-- Calculate sky transmissivity
3068	sky_trans = 0.6_wp + 0.2_wp * cos_zenith
3069
3070	!
3071	!-- Calculate value of the Exner function at model surface
3072	!
3073	!-- In case averaged radiation is used, calculate mean temperature and
3074	!-- liquid water mixing ratio at the urban-layer top.
3075	IF ( average_radiation ) THEN
3076	pt1 = 0.0_wp
3077	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = 0.0_wp
3078
3079	pt1_l = SUM( pt(nz_urban_t,nys:nyn,nxl:nxr) )
3080	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1_l = SUM( ql(nz_urban_t,nys:nyn,nxl:nxr) )
3081
3082	#if defined( __parallel )
3083	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
3084	CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3085	IF ( ierr /= 0 ) THEN
3086	WRITE(9,*) 'Error MPI_AllReduce1:', ierr, pt1_l, pt1
3087	FLUSH(9)
3088	ENDIF
3089
3090	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3091	CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3092	IF ( ierr /= 0 ) THEN
3093	WRITE(9,*) 'Error MPI_AllReduce2:', ierr, ql1_l, ql1
3094	FLUSH(9)
3095	ENDIF
3096	ENDIF
3097	#else
3098	pt1 = pt1_l
3099	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = ql1_l
3100	#endif
3101
3102	IF ( bulk_cloud_model .OR. cloud_droplets ) pt1 = pt1 + lv_d_cp / exner(nz_urban_t) * ql1
3103	!
3104	!-- Finally, divide by number of grid points
3105	pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp )
3106	ENDIF
3107	!
3108	!-- Call clear-sky calculation for each surface orientation.
3109	!-- First, horizontal surfaces
3110	surf => surf_lsm_h
3111	CALL radiation_clearsky_surf
3112	surf => surf_usm_h
3113	CALL radiation_clearsky_surf
3114	!
3115	!-- Vertical surfaces
3116	DO l = 0, 3
3117	surf => surf_lsm_v(l)
3118	CALL radiation_clearsky_surf
3119	surf => surf_usm_v(l)
3120	CALL radiation_clearsky_surf
3121	ENDDO
3122
3123	CONTAINS
3124
3125	SUBROUTINE radiation_clearsky_surf
3126
3127	IMPLICIT NONE
3128
3129	INTEGER(iwp) :: i !< index x-direction
3130	INTEGER(iwp) :: j !< index y-direction
3131	INTEGER(iwp) :: k !< index z-direction
3132	INTEGER(iwp) :: m !< running index for surface elements
3133
3134	IF ( surf%ns < 1 ) RETURN
3135
3136	!
3137	!-- Calculate radiation fluxes and net radiation (rad_net) assuming
3138	!-- homogeneous urban radiation conditions.
3139	IF ( average_radiation ) THEN
3140
3141	k = nz_urban_t
3142
3143	surf%rad_sw_in = solar_constant * sky_trans * cos_zenith
3144	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
3145
3146	surf%rad_lw_in = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k+1))**4
3147
3148	surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 &
3149	+ (1.0_wp - emissivity_urb) * surf%rad_lw_in
3150
3151	surf%rad_net = surf%rad_sw_in - surf%rad_sw_out &
3152	+ surf%rad_lw_in - surf%rad_lw_out
3153
3154	surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb &
3155	* (t_rad_urb)**3
3156
3157	!
3158	!-- Calculate radiation fluxes and net radiation (rad_net) for each surface
3159	!-- element.
3160	ELSE
3161
3162	DO m = 1, surf%ns
3163	i = surf%i(m)
3164	j = surf%j(m)
3165	k = surf%k(m)
3166
3167	surf%rad_sw_in(m) = solar_constant * sky_trans * cos_zenith
3168
3169	!
3170	!-- Weighted average according to surface fraction.
3171	!-- ATTENTION: when radiation interactions are switched on the
3172	!-- calculated fluxes below are not actually used as they are
3173	!-- overwritten in radiation_interaction.
3174	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3175	surf%albedo(ind_veg_wall,m) &
3176	+ surf%frac(ind_pav_green,m) * &
3177	surf%albedo(ind_pav_green,m) &
3178	+ surf%frac(ind_wat_win,m) * &
3179	surf%albedo(ind_wat_win,m) ) &
3180	* surf%rad_sw_in(m)
3181
3182	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3183	surf%emissivity(ind_veg_wall,m) &
3184	+ surf%frac(ind_pav_green,m) * &
3185	surf%emissivity(ind_pav_green,m) &
3186	+ surf%frac(ind_wat_win,m) * &
3187	surf%emissivity(ind_wat_win,m) &
3188	) &
3189	* sigma_sb &
3190	* ( surf%pt_surface(m) * exner(nzb) )**4
3191
3192	surf%rad_lw_out_change_0(m) = &
3193	( surf%frac(ind_veg_wall,m) * &
3194	surf%emissivity(ind_veg_wall,m) &
3195	+ surf%frac(ind_pav_green,m) * &
3196	surf%emissivity(ind_pav_green,m) &
3197	+ surf%frac(ind_wat_win,m) * &
3198	surf%emissivity(ind_wat_win,m) &
3199	) * 4.0_wp * sigma_sb &
3200	* ( surf%pt_surface(m) * exner(nzb) )** 3
3201
3202
3203	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3204	pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i)
3205	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k))**4
3206	ELSE
3207	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt(k,j,i) * exner(k))**4
3208	ENDIF
3209
3210	surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) &
3211	+ surf%rad_lw_in(m) - surf%rad_lw_out(m)
3212
3213	ENDDO
3214
3215	ENDIF
3216
3217	!
3218	!-- Fill out values in radiation arrays
3219	DO m = 1, surf%ns
3220	i = surf%i(m)
3221	j = surf%j(m)
3222	rad_sw_in(0,j,i) = surf%rad_sw_in(m)
3223	rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3224	rad_lw_in(0,j,i) = surf%rad_lw_in(m)
3225	rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3226	ENDDO
3227
3228	END SUBROUTINE radiation_clearsky_surf
3229
3230	END SUBROUTINE radiation_clearsky
3231
3232
3233	!------------------------------------------------------------------------------!
3234	! Description:
3235	! ------------
3236	!> This scheme keeps the prescribed net radiation constant during the run
3237	!------------------------------------------------------------------------------!
3238	SUBROUTINE radiation_constant
3239
3240
3241	IMPLICIT NONE
3242
3243	INTEGER(iwp) :: l !< running index for surface orientation
3244
3245	REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top
3246	REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain
3247	REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top
3248	REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain
3249
3250	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
3251
3252	!
3253	!-- In case averaged radiation is used, calculate mean temperature and
3254	!-- liquid water mixing ratio at the urban-layer top.
3255	IF ( average_radiation ) THEN
3256	pt1 = 0.0_wp
3257	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = 0.0_wp
3258
3259	pt1_l = SUM( pt(nz_urban_t,nys:nyn,nxl:nxr) )
3260	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1_l = SUM( ql(nz_urban_t,nys:nyn,nxl:nxr) )
3261
3262	#if defined( __parallel )
3263	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
3264	CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3265	IF ( ierr /= 0 ) THEN
3266	WRITE(9,*) 'Error MPI_AllReduce3:', ierr, pt1_l, pt1
3267	FLUSH(9)
3268	ENDIF
3269	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3270	CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3271	IF ( ierr /= 0 ) THEN
3272	WRITE(9,*) 'Error MPI_AllReduce4:', ierr, ql1_l, ql1
3273	FLUSH(9)
3274	ENDIF
3275	ENDIF
3276	#else
3277	pt1 = pt1_l
3278	IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = ql1_l
3279	#endif
3280	IF ( bulk_cloud_model .OR. cloud_droplets ) pt1 = pt1 + lv_d_cp / exner(nz_urban_t+1) * ql1
3281	!
3282	!-- Finally, divide by number of grid points
3283	pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp )
3284	ENDIF
3285
3286	!
3287	!-- First, horizontal surfaces
3288	surf => surf_lsm_h
3289	CALL radiation_constant_surf
3290	surf => surf_usm_h
3291	CALL radiation_constant_surf
3292	!
3293	!-- Vertical surfaces
3294	DO l = 0, 3
3295	surf => surf_lsm_v(l)
3296	CALL radiation_constant_surf
3297	surf => surf_usm_v(l)
3298	CALL radiation_constant_surf
3299	ENDDO
3300
3301	CONTAINS
3302
3303	SUBROUTINE radiation_constant_surf
3304
3305	IMPLICIT NONE
3306
3307	INTEGER(iwp) :: i !< index x-direction
3308	INTEGER(iwp) :: ioff !< offset between surface element and adjacent grid point along x
3309	INTEGER(iwp) :: j !< index y-direction
3310	INTEGER(iwp) :: joff !< offset between surface element and adjacent grid point along y
3311	INTEGER(iwp) :: k !< index z-direction
3312	INTEGER(iwp) :: koff !< offset between surface element and adjacent grid point along z
3313	INTEGER(iwp) :: m !< running index for surface elements
3314
3315	IF ( surf%ns < 1 ) RETURN
3316
3317	!-- Calculate homogenoeus urban radiation fluxes
3318	IF ( average_radiation ) THEN
3319
3320	surf%rad_net = net_radiation
3321
3322	surf%rad_lw_in = emissivity_atm_clsky * sigma_sb * (pt1 * exner(nz_urban_t+1))**4
3323
3324	surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 &
3325	+ ( 1.0_wp - emissivity_urb ) & ! shouldn't be this a bulk value -- emissivity_urb?
3326	* surf%rad_lw_in
3327
3328	surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb &
3329	* t_rad_urb**3
3330
3331	surf%rad_sw_in = ( surf%rad_net - surf%rad_lw_in &
3332	+ surf%rad_lw_out ) &
3333	/ ( 1.0_wp - albedo_urb )
3334
3335	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
3336
3337	!
3338	!-- Calculate radiation fluxes for each surface element
3339	ELSE
3340	!
3341	!-- Determine index offset between surface element and adjacent
3342	!-- atmospheric grid point
3343	ioff = surf%ioff
3344	joff = surf%joff
3345	koff = surf%koff
3346
3347	!
3348	!-- Prescribe net radiation and estimate the remaining radiative fluxes
3349	DO m = 1, surf%ns
3350	i = surf%i(m)
3351	j = surf%j(m)
3352	k = surf%k(m)
3353
3354	surf%rad_net(m) = net_radiation
3355
3356	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
3357	pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i)
3358	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k))**4
3359	ELSE
3360	surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * &
3361	( pt(k,j,i) * exner(k) )**4
3362	ENDIF
3363
3364	!
3365	!-- Weighted average according to surface fraction.
3366	surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3367	surf%emissivity(ind_veg_wall,m) &
3368	+ surf%frac(ind_pav_green,m) * &
3369	surf%emissivity(ind_pav_green,m) &
3370	+ surf%frac(ind_wat_win,m) * &
3371	surf%emissivity(ind_wat_win,m) &
3372	) &
3373	* sigma_sb &
3374	* ( surf%pt_surface(m) * exner(nzb) )**4
3375
3376	surf%rad_sw_in(m) = ( surf%rad_net(m) - surf%rad_lw_in(m) &
3377	+ surf%rad_lw_out(m) ) &
3378	/ ( 1.0_wp - &
3379	( surf%frac(ind_veg_wall,m) * &
3380	surf%albedo(ind_veg_wall,m) &
3381	+ surf%frac(ind_pav_green,m) * &
3382	surf%albedo(ind_pav_green,m) &
3383	+ surf%frac(ind_wat_win,m) * &
3384	surf%albedo(ind_wat_win,m) ) &
3385	)
3386
3387	surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m) * &
3388	surf%albedo(ind_veg_wall,m) &
3389	+ surf%frac(ind_pav_green,m) * &
3390	surf%albedo(ind_pav_green,m) &
3391	+ surf%frac(ind_wat_win,m) * &
3392	surf%albedo(ind_wat_win,m) ) &
3393	* surf%rad_sw_in(m)
3394
3395	ENDDO
3396
3397	ENDIF
3398
3399	!
3400	!-- Fill out values in radiation arrays
3401	DO m = 1, surf%ns
3402	i = surf%i(m)
3403	j = surf%j(m)
3404	rad_sw_in(0,j,i) = surf%rad_sw_in(m)
3405	rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3406	rad_lw_in(0,j,i) = surf%rad_lw_in(m)
3407	rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3408	ENDDO
3409
3410	END SUBROUTINE radiation_constant_surf
3411
3412
3413	END SUBROUTINE radiation_constant
3414
3415	!------------------------------------------------------------------------------!
3416	! Description:
3417	! ------------
3418	!> Header output for radiation model
3419	!------------------------------------------------------------------------------!
3420	SUBROUTINE radiation_header ( io )
3421
3422
3423	IMPLICIT NONE
3424
3425	INTEGER(iwp), INTENT(IN) :: io !< Unit of the output file
3426
3427
3428
3429	!
3430	!-- Write radiation model header
3431	WRITE( io, 3 )
3432
3433	IF ( radiation_scheme == "constant" ) THEN
3434	WRITE( io, 4 ) net_radiation
3435	ELSEIF ( radiation_scheme == "clear-sky" ) THEN
3436	WRITE( io, 5 )
3437	ELSEIF ( radiation_scheme == "rrtmg" ) THEN
3438	WRITE( io, 6 )
3439	IF ( .NOT. lw_radiation ) WRITE( io, 10 )
3440	IF ( .NOT. sw_radiation ) WRITE( io, 11 )
3441	ELSEIF ( radiation_scheme == "external" ) THEN
3442	WRITE( io, 14 )
3443	ENDIF
3444
3445	IF ( albedo_type_f%from_file .OR. vegetation_type_f%from_file .OR. &
3446	pavement_type_f%from_file .OR. water_type_f%from_file .OR. &
3447	building_type_f%from_file ) THEN
3448	WRITE( io, 13 )
3449	ELSE
3450	IF ( albedo_type == 0 ) THEN
3451	WRITE( io, 7 ) albedo
3452	ELSE
3453	WRITE( io, 8 ) TRIM( albedo_type_name(albedo_type) )
3454	ENDIF
3455	ENDIF
3456	IF ( constant_albedo ) THEN
3457	WRITE( io, 9 )
3458	ENDIF
3459
3460	WRITE( io, 12 ) dt_radiation
3461
3462
3463	3 FORMAT (//' Radiation model information:'/ &
3464	' ----------------------------'/)
3465	4 FORMAT (' --> Using constant net radiation: net_radiation = ', F6.2, &
3466	// 'W/m**2')
3467	5 FORMAT (' --> Simple radiation scheme for clear sky is used (no clouds,',&
3468	' default)')
3469	6 FORMAT (' --> RRTMG scheme is used')
3470	7 FORMAT (/' User-specific surface albedo: albedo =', F6.3)
3471	8 FORMAT (/' Albedo is set for land surface type: ', A)
3472	9 FORMAT (/' --> Albedo is fixed during the run')
3473	10 FORMAT (/' --> Longwave radiation is disabled')
3474	11 FORMAT (/' --> Shortwave radiation is disabled.')
3475	12 FORMAT (' Timestep: dt_radiation = ', F6.2, ' s')
3476	13 FORMAT (/' Albedo is set individually for each xy-location, according ', &
3477	'to given surface type.')
3478	14 FORMAT (' --> External radiation forcing is used')
3479
3480
3481	END SUBROUTINE radiation_header
3482
3483
3484	!------------------------------------------------------------------------------!
3485	! Description:
3486	! ------------
3487	!> Parin for &radiation_parameters for radiation model
3488	!------------------------------------------------------------------------------!
3489	SUBROUTINE radiation_parin
3490
3491
3492	IMPLICIT NONE
3493
3494	CHARACTER (LEN=80) :: line !< dummy string that contains the current line of the parameter file
3495
3496	NAMELIST /radiation_par/ albedo, albedo_lw_dif, albedo_lw_dir, &
3497	albedo_sw_dif, albedo_sw_dir, albedo_type, &
3498	constant_albedo, dt_radiation, emissivity, &
3499	lw_radiation, max_raytracing_dist, &
3500	min_irrf_value, mrt_geom_human, &
3501	mrt_include_sw, mrt_nlevels, &
3502	mrt_skip_roof, net_radiation, nrefsteps, &
3503	plant_lw_interact, rad_angular_discretization,&
3504	radiation_interactions_on, radiation_scheme, &
3505	raytrace_discrete_azims, &
3506	raytrace_discrete_elevs, raytrace_mpi_rma, &
3507	skip_time_do_radiation, surface_reflections, &
3508	svfnorm_report_thresh, sw_radiation, &
3509	unscheduled_radiation_calls
3510
3511
3512	NAMELIST /radiation_parameters/ albedo, albedo_lw_dif, albedo_lw_dir, &
3513	albedo_sw_dif, albedo_sw_dir, albedo_type, &
3514	constant_albedo, dt_radiation, emissivity, &
3515	lw_radiation, max_raytracing_dist, &
3516	min_irrf_value, mrt_geom_human, &
3517	mrt_include_sw, mrt_nlevels, &
3518	mrt_skip_roof, net_radiation, nrefsteps, &
3519	plant_lw_interact, rad_angular_discretization,&
3520	radiation_interactions_on, radiation_scheme, &
3521	raytrace_discrete_azims, &
3522	raytrace_discrete_elevs, raytrace_mpi_rma, &
3523	skip_time_do_radiation, surface_reflections, &
3524	svfnorm_report_thresh, sw_radiation, &
3525	unscheduled_radiation_calls
3526
3527	line = ' '
3528
3529	!
3530	!-- Try to find radiation model namelist
3531	REWIND ( 11 )
3532	line = ' '
3533	DO WHILE ( INDEX( line, '&radiation_parameters' ) == 0 )
3534	READ ( 11, '(A)', END=12 ) line
3535	ENDDO
3536	BACKSPACE ( 11 )
3537
3538	!
3539	!-- Read user-defined namelist
3540	READ ( 11, radiation_parameters, ERR = 10 )
3541
3542	!
3543	!-- Set flag that indicates that the radiation model is switched on
3544	radiation = .TRUE.
3545
3546	GOTO 14
3547
3548	10 BACKSPACE( 11 )
3549	READ( 11 , '(A)') line
3550	CALL parin_fail_message( 'radiation_parameters', line )
3551	!
3552	!-- Try to find old namelist
3553	12 REWIND ( 11 )
3554	line = ' '
3555	DO WHILE ( INDEX( line, '&radiation_par' ) == 0 )
3556	READ ( 11, '(A)', END=14 ) line
3557	ENDDO
3558	BACKSPACE ( 11 )
3559
3560	!
3561	!-- Read user-defined namelist
3562	READ ( 11, radiation_par, ERR = 13, END = 14 )
3563
3564	message_string = 'namelist radiation_par is deprecated and will be ' // &
3565	'removed in near future. Please use namelist ' // &
3566	'radiation_parameters instead'
3567	CALL message( 'radiation_parin', 'PA0487', 0, 1, 0, 6, 0 )
3568
3569	!
3570	!-- Set flag that indicates that the radiation model is switched on
3571	radiation = .TRUE.
3572
3573	IF ( .NOT. radiation_interactions_on .AND. surface_reflections ) THEN
3574	message_string = 'surface_reflections is allowed only when ' // &
3575	'radiation_interactions_on is set to TRUE'
3576	CALL message( 'radiation_parin', 'PA0293',1, 2, 0, 6, 0 )
3577	ENDIF
3578
3579	GOTO 14
3580
3581	13 BACKSPACE( 11 )
3582	READ( 11 , '(A)') line
3583	CALL parin_fail_message( 'radiation_par', line )
3584
3585	14 CONTINUE
3586
3587	END SUBROUTINE radiation_parin
3588
3589
3590	!------------------------------------------------------------------------------!
3591	! Description:
3592	! ------------
3593	!> Implementation of the RRTMG radiation_scheme
3594	!------------------------------------------------------------------------------!
3595	SUBROUTINE radiation_rrtmg
3596
3597	#if defined ( __rrtmg )
3598	USE indices, &
3599	ONLY: nbgp
3600
3601	USE particle_attributes, &
3602	ONLY: grid_particles, number_of_particles, particles, prt_count
3603
3604	IMPLICIT NONE
3605
3606
3607	INTEGER(iwp) :: i, j, k, l, m, n !< loop indices
3608	INTEGER(iwp) :: k_topo_l !< topography top index
3609	INTEGER(iwp) :: k_topo !< topography top index
3610
3611	REAL(wp) :: nc_rad, & !< number concentration of cloud droplets
3612	s_r2, & !< weighted sum over all droplets with r^2
3613	s_r3 !< weighted sum over all droplets with r^3
3614
3615	REAL(wp), DIMENSION(0:nzt+1) :: pt_av, q_av, ql_av
3616	REAL(wp), DIMENSION(0:0) :: zenith !< to provide indexed array
3617	!
3618	!-- Just dummy arguments
3619	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rrtm_lw_taucld_dum, &
3620	rrtm_lw_tauaer_dum, &
3621	rrtm_sw_taucld_dum, &
3622	rrtm_sw_ssacld_dum, &
3623	rrtm_sw_asmcld_dum, &
3624	rrtm_sw_fsfcld_dum, &
3625	rrtm_sw_tauaer_dum, &
3626	rrtm_sw_ssaaer_dum, &
3627	rrtm_sw_asmaer_dum, &
3628	rrtm_sw_ecaer_dum
3629
3630	!
3631	!-- Calculate current (cosine of) zenith angle and whether the sun is up
3632	CALL calc_zenith
3633	zenith(0) = cos_zenith
3634	!
3635	!-- Calculate surface albedo. In case average radiation is applied,
3636	!-- this is not required.
3637	#if defined( __netcdf )
3638	IF ( .NOT. constant_albedo ) THEN
3639	!
3640	!-- Horizontally aligned default, natural and urban surfaces
3641	CALL calc_albedo( surf_lsm_h )
3642	CALL calc_albedo( surf_usm_h )
3643	!
3644	!-- Vertically aligned default, natural and urban surfaces
3645	DO l = 0, 3
3646	CALL calc_albedo( surf_lsm_v(l) )
3647	CALL calc_albedo( surf_usm_v(l) )
3648	ENDDO
3649	ENDIF
3650	#endif
3651
3652	!
3653	!-- Prepare input data for RRTMG
3654
3655	!
3656	!-- In case of large scale forcing with surface data, calculate new pressure
3657	!-- profile. nzt_rad might be modified by these calls and all required arrays
3658	!-- will then be re-allocated
3659	IF ( large_scale_forcing .AND. lsf_surf ) THEN
3660	CALL read_sounding_data
3661	CALL read_trace_gas_data
3662	ENDIF
3663
3664
3665	IF ( average_radiation ) THEN
3666	!
3667	!-- Determine minimum topography top index.
3668	k_topo_l = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
3669	#if defined( __parallel )
3670	CALL MPI_ALLREDUCE( k_topo_l, k_topo, 1, MPI_INTEGER, MPI_MIN, &
3671	comm2d, ierr)
3672	#else
3673	k_topo = k_topo_l
3674	#endif
3675
3676	rrtm_asdir(1) = albedo_urb
3677	rrtm_asdif(1) = albedo_urb
3678	rrtm_aldir(1) = albedo_urb
3679	rrtm_aldif(1) = albedo_urb
3680
3681	rrtm_emis = emissivity_urb
3682	!
3683	!-- Calculate mean pt profile.
3684	CALL calc_mean_profile( pt, 4 )
3685	pt_av = hom(:, 1, 4, 0)
3686
3687	IF ( humidity ) THEN
3688	CALL calc_mean_profile( q, 41 )
3689	q_av = hom(:, 1, 41, 0)
3690	ENDIF
3691	!
3692	!-- Prepare profiles of temperature and H2O volume mixing ratio
3693	rrtm_tlev(0,k_topo+1) = t_rad_urb
3694
3695	IF ( bulk_cloud_model ) THEN
3696
3697	CALL calc_mean_profile( ql, 54 )
3698	! average ql is now in hom(:, 1, 54, 0)
3699	ql_av = hom(:, 1, 54, 0)
3700
3701	DO k = nzb+1, nzt+1
3702	rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp &
3703	)*.286_wp + lv_d_cp ql_av(k)
3704	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q_av(k) - ql_av(k))
3705	ENDDO
3706	ELSE
3707	DO k = nzb+1, nzt+1
3708	rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp &
3709	)**.286_wp
3710	ENDDO
3711
3712	IF ( humidity ) THEN
3713	DO k = nzb+1, nzt+1
3714	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q_av(k)
3715	ENDDO
3716	ELSE
3717	rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp
3718	ENDIF
3719	ENDIF
3720
3721	!
3722	!-- Avoid temperature/humidity jumps at the top of the PALM domain by
3723	!-- linear interpolation from nzt+2 to nzt+7. Jumps are induced by
3724	!-- discrepancies between the values in the domain and those above that
3725	!-- are prescribed in RRTMG
3726	DO k = nzt+2, nzt+7
3727	rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) &
3728	+ ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) &
3729	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) &
3730	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
3731
3732	rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) &
3733	+ ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )&
3734	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )&
3735	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
3736
3737	ENDDO
3738
3739	!-- Linear interpolate to zw grid. Loop reaches one level further up
3740	!-- due to the staggered grid in RRTMG
3741	DO k = k_topo+2, nzt+8
3742	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - &
3743	rrtm_tlay(0,k-1)) &
3744	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
3745	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
3746	ENDDO
3747	!
3748	!-- Calculate liquid water path and cloud fraction for each column.
3749	!-- Note that LWP is required in g/m2 instead of kg/kg m.
3750	rrtm_cldfr = 0.0_wp
3751	rrtm_reliq = 0.0_wp
3752	rrtm_cliqwp = 0.0_wp
3753	rrtm_icld = 0
3754
3755	IF ( bulk_cloud_model ) THEN
3756	DO k = nzb+1, nzt+1
3757	rrtm_cliqwp(0,k) = ql_av(k) * 1000._wp * &
3758	(rrtm_plev(0,k) - rrtm_plev(0,k+1)) &
3759	* 100._wp / g
3760
3761	IF ( rrtm_cliqwp(0,k) > 0._wp ) THEN
3762	rrtm_cldfr(0,k) = 1._wp
3763	IF ( rrtm_icld == 0 ) rrtm_icld = 1
3764
3765	!
3766	!-- Calculate cloud droplet effective radius
3767	rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql_av(k) &
3768	* rho_surface &
3769	/ ( 4.0_wp * pi * nc_const * rho_l ) &
3770	)**0.33333333333333_wp &
3771	* EXP( LOG( sigma_gc )**2 )
3772	!
3773	!-- Limit effective radius
3774	IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN
3775	rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp)
3776	rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp)
3777	ENDIF
3778	ENDIF
3779	ENDDO
3780	ENDIF
3781
3782	!
3783	!-- Set surface temperature
3784	rrtm_tsfc = t_rad_urb
3785
3786	IF ( lw_radiation ) THEN
3787	!
3788	!-- Due to technical reasons, copy optical depth to dummy arguments
3789	!-- which are allocated on the exact size as the rrtmg_lw is called.
3790	!-- As one dimesion is allocated with zero size, compiler complains
3791	!-- that rank of the array does not match that of the
3792	!-- assumed-shaped arguments in the RRTMG library. In order to
3793	!-- avoid this, write to dummy arguments and give pass the entire
3794	!-- dummy array. Seems to be the only existing work-around.
3795	ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) )
3796	ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) )
3797
3798	rrtm_lw_taucld_dum = &
3799	rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1)
3800	rrtm_lw_tauaer_dum = &
3801	rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1)
3802
3803	CALL rrtmg_lw( 1, &
3804	nzt_rad-k_topo, &
3805	rrtm_icld, &
3806	rrtm_idrv, &
3807	rrtm_play(:,k_topo+1:), &
3808	rrtm_plev(:,k_topo+1:), &
3809	rrtm_tlay(:,k_topo+1:), &
3810	rrtm_tlev(:,k_topo+1:), &
3811	rrtm_tsfc, &
3812	rrtm_h2ovmr(:,k_topo+1:), &
3813	rrtm_o3vmr(:,k_topo+1:), &
3814	rrtm_co2vmr(:,k_topo+1:), &
3815	rrtm_ch4vmr(:,k_topo+1:), &
3816	rrtm_n2ovmr(:,k_topo+1:), &
3817	rrtm_o2vmr(:,k_topo+1:), &
3818	rrtm_cfc11vmr(:,k_topo+1:), &
3819	rrtm_cfc12vmr(:,k_topo+1:), &
3820	rrtm_cfc22vmr(:,k_topo+1:), &
3821	rrtm_ccl4vmr(:,k_topo+1:), &
3822	rrtm_emis, &
3823	rrtm_inflglw, &
3824	rrtm_iceflglw, &
3825	rrtm_liqflglw, &
3826	rrtm_cldfr(:,k_topo+1:), &
3827	rrtm_lw_taucld_dum, &
3828	rrtm_cicewp(:,k_topo+1:), &
3829	rrtm_cliqwp(:,k_topo+1:), &
3830	rrtm_reice(:,k_topo+1:), &
3831	rrtm_reliq(:,k_topo+1:), &
3832	rrtm_lw_tauaer_dum, &
3833	rrtm_lwuflx(:,k_topo:), &
3834	rrtm_lwdflx(:,k_topo:), &
3835	rrtm_lwhr(:,k_topo+1:), &
3836	rrtm_lwuflxc(:,k_topo:), &
3837	rrtm_lwdflxc(:,k_topo:), &
3838	rrtm_lwhrc(:,k_topo+1:), &
3839	rrtm_lwuflx_dt(:,k_topo:), &
3840	rrtm_lwuflxc_dt(:,k_topo:) )
3841
3842	DEALLOCATE ( rrtm_lw_taucld_dum )
3843	DEALLOCATE ( rrtm_lw_tauaer_dum )
3844	!
3845	!-- Save fluxes
3846	DO k = nzb, nzt+1
3847	rad_lw_in(k,:,:) = rrtm_lwdflx(0,k)
3848	rad_lw_out(k,:,:) = rrtm_lwuflx(0,k)
3849	ENDDO
3850	rad_lw_in_diff(:,:) = rad_lw_in(k_topo,:,:)
3851	!
3852	!-- Save heating rates (convert from K/d to K/h).
3853	!-- Further, even though an aggregated radiation is computed, map
3854	!-- signle-column profiles on top of any topography, in order to
3855	!-- obtain correct near surface radiation heating/cooling rates.
3856	DO i = nxl, nxr
3857	DO j = nys, nyn
3858	k_topo_l = topo_top_ind(j,i,0)
3859	DO k = k_topo_l+1, nzt+1
3860	rad_lw_hr(k,j,i) = rrtm_lwhr(0,k-k_topo_l) * d_hours_day
3861	rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k-k_topo_l) * d_hours_day
3862	ENDDO
3863	ENDDO
3864	ENDDO
3865
3866	ENDIF
3867
3868	IF ( sw_radiation .AND. sun_up ) THEN
3869	!
3870	!-- Due to technical reasons, copy optical depths and other
3871	!-- to dummy arguments which are allocated on the exact size as the
3872	!-- rrtmg_sw is called.
3873	!-- As one dimesion is allocated with zero size, compiler complains
3874	!-- that rank of the array does not match that of the
3875	!-- assumed-shaped arguments in the RRTMG library. In order to
3876	!-- avoid this, write to dummy arguments and give pass the entire
3877	!-- dummy array. Seems to be the only existing work-around.
3878	ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3879	ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3880	ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3881	ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3882	ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
3883	ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
3884	ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
3885	ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) )
3886
3887	rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3888	rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3889	rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3890	rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3891	rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
3892	rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
3893	rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
3894	rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1)
3895
3896	CALL rrtmg_sw( 1, &
3897	nzt_rad-k_topo, &
3898	rrtm_icld, &
3899	rrtm_iaer, &
3900	rrtm_play(:,k_topo+1:nzt_rad+1), &
3901	rrtm_plev(:,k_topo+1:nzt_rad+2), &
3902	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
3903	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
3904	rrtm_tsfc, &
3905	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
3906	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
3907	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
3908	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
3909	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
3910	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
3911	rrtm_asdir, &
3912	rrtm_asdif, &
3913	rrtm_aldir, &
3914	rrtm_aldif, &
3915	zenith, &
3916	0.0_wp, &
3917	day_of_year, &
3918	solar_constant, &
3919	rrtm_inflgsw, &
3920	rrtm_iceflgsw, &
3921	rrtm_liqflgsw, &
3922	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
3923	rrtm_sw_taucld_dum, &
3924	rrtm_sw_ssacld_dum, &
3925	rrtm_sw_asmcld_dum, &
3926	rrtm_sw_fsfcld_dum, &
3927	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
3928	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
3929	rrtm_reice(:,k_topo+1:nzt_rad+1), &
3930	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
3931	rrtm_sw_tauaer_dum, &
3932	rrtm_sw_ssaaer_dum, &
3933	rrtm_sw_asmaer_dum, &
3934	rrtm_sw_ecaer_dum, &
3935	rrtm_swuflx(:,k_topo:nzt_rad+1), &
3936	rrtm_swdflx(:,k_topo:nzt_rad+1), &
3937	rrtm_swhr(:,k_topo+1:nzt_rad+1), &
3938	rrtm_swuflxc(:,k_topo:nzt_rad+1), &
3939	rrtm_swdflxc(:,k_topo:nzt_rad+1), &
3940	rrtm_swhrc(:,k_topo+1:nzt_rad+1), &
3941	rrtm_dirdflux(:,k_topo:nzt_rad+1), &
3942	rrtm_difdflux(:,k_topo:nzt_rad+1) )
3943
3944	DEALLOCATE( rrtm_sw_taucld_dum )
3945	DEALLOCATE( rrtm_sw_ssacld_dum )
3946	DEALLOCATE( rrtm_sw_asmcld_dum )
3947	DEALLOCATE( rrtm_sw_fsfcld_dum )
3948	DEALLOCATE( rrtm_sw_tauaer_dum )
3949	DEALLOCATE( rrtm_sw_ssaaer_dum )
3950	DEALLOCATE( rrtm_sw_asmaer_dum )
3951	DEALLOCATE( rrtm_sw_ecaer_dum )
3952
3953	!
3954	!-- Save radiation fluxes for the entire depth of the model domain
3955	DO k = nzb, nzt+1
3956	rad_sw_in(k,:,:) = rrtm_swdflx(0,k)
3957	rad_sw_out(k,:,:) = rrtm_swuflx(0,k)
3958	ENDDO
3959	!-- Save direct and diffuse SW radiation at the surface (required by RTM)
3960	rad_sw_in_dir(:,:) = rrtm_dirdflux(0,k_topo)
3961	rad_sw_in_diff(:,:) = rrtm_difdflux(0,k_topo)
3962
3963	!
3964	!-- Save heating rates (convert from K/d to K/s)
3965	DO k = nzb+1, nzt+1
3966	rad_sw_hr(k,:,:) = rrtm_swhr(0,k) * d_hours_day
3967	rad_sw_cs_hr(k,:,:) = rrtm_swhrc(0,k) * d_hours_day
3968	ENDDO
3969	!
3970	!-- Solar radiation is zero during night
3971	ELSE
3972	rad_sw_in = 0.0_wp
3973	rad_sw_out = 0.0_wp
3974	rad_sw_in_dir(:,:) = 0.0_wp
3975	rad_sw_in_diff(:,:) = 0.0_wp
3976	ENDIF
3977	!
3978	!-- RRTMG is called for each (j,i) grid point separately, starting at the
3979	!-- highest topography level. Here no RTM is used since average_radiation is false
3980	ELSE
3981	!
3982	!-- Loop over all grid points
3983	DO i = nxl, nxr
3984	DO j = nys, nyn
3985
3986	!
3987	!-- Prepare profiles of temperature and H2O volume mixing ratio
3988	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
3989	rrtm_tlev(0,nzb+1) = surf_lsm_h%pt_surface(m) * exner(nzb)
3990	ENDDO
3991	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
3992	rrtm_tlev(0,nzb+1) = surf_usm_h%pt_surface(m) * exner(nzb)
3993	ENDDO
3994
3995
3996	IF ( bulk_cloud_model ) THEN
3997	DO k = nzb+1, nzt+1
3998	rrtm_tlay(0,k) = pt(k,j,i) * exner(k) &
3999	+ lv_d_cp * ql(k,j,i)
4000	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q(k,j,i) - ql(k,j,i))
4001	ENDDO
4002	ELSEIF ( cloud_droplets ) THEN
4003	DO k = nzb+1, nzt+1
4004	rrtm_tlay(0,k) = pt(k,j,i) * exner(k) &
4005	+ lv_d_cp * ql(k,j,i)
4006	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i)
4007	ENDDO
4008	ELSE
4009	DO k = nzb+1, nzt+1
4010	rrtm_tlay(0,k) = pt(k,j,i) * exner(k)
4011	ENDDO
4012
4013	IF ( humidity ) THEN
4014	DO k = nzb+1, nzt+1
4015	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i)
4016	ENDDO
4017	ELSE
4018	rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp
4019	ENDIF
4020	ENDIF
4021
4022	!
4023	!-- Avoid temperature/humidity jumps at the top of the LES domain by
4024	!-- linear interpolation from nzt+2 to nzt+7
4025	DO k = nzt+2, nzt+7
4026	rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) &
4027	+ ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) &
4028	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) &
4029	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
4030
4031	rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) &
4032	+ ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )&
4033	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )&
4034	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
4035
4036	ENDDO
4037
4038	!-- Linear interpolate to zw grid
4039	DO k = nzb+2, nzt+8
4040	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - &
4041	rrtm_tlay(0,k-1)) &
4042	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
4043	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
4044	ENDDO
4045
4046
4047	!
4048	!-- Calculate liquid water path and cloud fraction for each column.
4049	!-- Note that LWP is required in g/m2 instead of kg/kg m.
4050	rrtm_cldfr = 0.0_wp
4051	rrtm_reliq = 0.0_wp
4052	rrtm_cliqwp = 0.0_wp
4053	rrtm_icld = 0
4054
4055	IF ( bulk_cloud_model .OR. cloud_droplets ) THEN
4056	DO k = nzb+1, nzt+1
4057	rrtm_cliqwp(0,k) = ql(k,j,i) * 1000.0_wp * &
4058	(rrtm_plev(0,k) - rrtm_plev(0,k+1)) &
4059	* 100.0_wp / g
4060
4061	IF ( rrtm_cliqwp(0,k) > 0.0_wp ) THEN
4062	rrtm_cldfr(0,k) = 1.0_wp
4063	IF ( rrtm_icld == 0 ) rrtm_icld = 1
4064
4065	!
4066	!-- Calculate cloud droplet effective radius
4067	IF ( bulk_cloud_model ) THEN
4068	!
4069	!-- Calculete effective droplet radius. In case of using
4070	!-- cloud_scheme = 'morrison' and a non reasonable number
4071	!-- of cloud droplets the inital aerosol number
4072	!-- concentration is considered.
4073	IF ( microphysics_morrison ) THEN
4074	IF ( nc(k,j,i) > 1.0E-20_wp ) THEN
4075	nc_rad = nc(k,j,i)
4076	ELSE
4077	nc_rad = na_init
4078	ENDIF
4079	ELSE
4080	nc_rad = nc_const
4081	ENDIF
4082
4083	rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql(k,j,i) &
4084	* rho_surface &
4085	/ ( 4.0_wp * pi * nc_rad * rho_l ) &
4086	)**0.33333333333333_wp &
4087	* EXP( LOG( sigma_gc )**2 )
4088
4089	ELSEIF ( cloud_droplets ) THEN
4090	number_of_particles = prt_count(k,j,i)
4091
4092	IF (number_of_particles <= 0) CYCLE
4093	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
4094	s_r2 = 0.0_wp
4095	s_r3 = 0.0_wp
4096
4097	DO n = 1, number_of_particles
4098	IF ( particles(n)%particle_mask ) THEN
4099	s_r2 = s_r2 + particles(n)%radius*2 &
4100	particles(n)%weight_factor
4101	s_r3 = s_r3 + particles(n)%radius*3 &
4102	particles(n)%weight_factor
4103	ENDIF
4104	ENDDO
4105
4106	IF ( s_r2 > 0.0_wp ) rrtm_reliq(0,k) = s_r3 / s_r2
4107
4108	ENDIF
4109
4110	!
4111	!-- Limit effective radius
4112	IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN
4113	rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp)
4114	rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp)
4115	ENDIF
4116	ENDIF
4117	ENDDO
4118	ENDIF
4119
4120	!
4121	!-- Write surface emissivity and surface temperature at current
4122	!-- surface element on RRTMG-shaped array.
4123	!-- Please note, as RRTMG is a single column model, surface attributes
4124	!-- are only obtained from horizontally aligned surfaces (for
4125	!-- simplicity). Taking surface attributes from horizontal and
4126	!-- vertical walls would lead to multiple solutions.
4127	!-- Moreover, for natural- and urban-type surfaces, several surface
4128	!-- classes can exist at a surface element next to each other.
4129	!-- To obtain bulk parameters, apply a weighted average for these
4130	!-- surfaces.
4131	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
4132	rrtm_emis = surf_lsm_h%frac(ind_veg_wall,m) * &
4133	surf_lsm_h%emissivity(ind_veg_wall,m) + &
4134	surf_lsm_h%frac(ind_pav_green,m) * &
4135	surf_lsm_h%emissivity(ind_pav_green,m) + &
4136	surf_lsm_h%frac(ind_wat_win,m) * &
4137	surf_lsm_h%emissivity(ind_wat_win,m)
4138	rrtm_tsfc = surf_lsm_h%pt_surface(m) * exner(nzb)
4139	ENDDO
4140	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
4141	rrtm_emis = surf_usm_h%frac(ind_veg_wall,m) * &
4142	surf_usm_h%emissivity(ind_veg_wall,m) + &
4143	surf_usm_h%frac(ind_pav_green,m) * &
4144	surf_usm_h%emissivity(ind_pav_green,m) + &
4145	surf_usm_h%frac(ind_wat_win,m) * &
4146	surf_usm_h%emissivity(ind_wat_win,m)
4147	rrtm_tsfc = surf_usm_h%pt_surface(m) * exner(nzb)
4148	ENDDO
4149	!
4150	!-- Obtain topography top index (lower bound of RRTMG)
4151	k_topo = topo_top_ind(j,i,0)
4152
4153	IF ( lw_radiation ) THEN
4154	!
4155	!-- Due to technical reasons, copy optical depth to dummy arguments
4156	!-- which are allocated on the exact size as the rrtmg_lw is called.
4157	!-- As one dimesion is allocated with zero size, compiler complains
4158	!-- that rank of the array does not match that of the
4159	!-- assumed-shaped arguments in the RRTMG library. In order to
4160	!-- avoid this, write to dummy arguments and give pass the entire
4161	!-- dummy array. Seems to be the only existing work-around.
4162	ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) )
4163	ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) )
4164
4165	rrtm_lw_taucld_dum = &
4166	rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1)
4167	rrtm_lw_tauaer_dum = &
4168	rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1)
4169
4170	CALL rrtmg_lw( 1, &
4171	nzt_rad-k_topo, &
4172	rrtm_icld, &
4173	rrtm_idrv, &
4174	rrtm_play(:,k_topo+1:nzt_rad+1), &
4175	rrtm_plev(:,k_topo+1:nzt_rad+2), &
4176	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
4177	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
4178	rrtm_tsfc, &
4179	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
4180	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
4181	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
4182	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
4183	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
4184	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
4185	rrtm_cfc11vmr(:,k_topo+1:nzt_rad+1), &
4186	rrtm_cfc12vmr(:,k_topo+1:nzt_rad+1), &
4187	rrtm_cfc22vmr(:,k_topo+1:nzt_rad+1), &
4188	rrtm_ccl4vmr(:,k_topo+1:nzt_rad+1), &
4189	rrtm_emis, &
4190	rrtm_inflglw, &
4191	rrtm_iceflglw, &
4192	rrtm_liqflglw, &
4193	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
4194	rrtm_lw_taucld_dum, &
4195	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
4196	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
4197	rrtm_reice(:,k_topo+1:nzt_rad+1), &
4198	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
4199	rrtm_lw_tauaer_dum, &
4200	rrtm_lwuflx(:,k_topo:nzt_rad+1), &
4201	rrtm_lwdflx(:,k_topo:nzt_rad+1), &
4202	rrtm_lwhr(:,k_topo+1:nzt_rad+1), &
4203	rrtm_lwuflxc(:,k_topo:nzt_rad+1), &
4204	rrtm_lwdflxc(:,k_topo:nzt_rad+1), &
4205	rrtm_lwhrc(:,k_topo+1:nzt_rad+1), &
4206	rrtm_lwuflx_dt(:,k_topo:nzt_rad+1), &
4207	rrtm_lwuflxc_dt(:,k_topo:nzt_rad+1) )
4208
4209	DEALLOCATE ( rrtm_lw_taucld_dum )
4210	DEALLOCATE ( rrtm_lw_tauaer_dum )
4211	!
4212	!-- Save fluxes
4213	DO k = k_topo, nzt+1
4214	rad_lw_in(k,j,i) = rrtm_lwdflx(0,k)
4215	rad_lw_out(k,j,i) = rrtm_lwuflx(0,k)
4216	ENDDO
4217
4218	!
4219	!-- Save heating rates (convert from K/d to K/h)
4220	DO k = k_topo+1, nzt+1
4221	rad_lw_hr(k,j,i) = rrtm_lwhr(0,k-k_topo) * d_hours_day
4222	rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k-k_topo) * d_hours_day
4223	ENDDO
4224
4225	!
4226	!-- Save surface radiative fluxes and change in LW heating rate
4227	!-- onto respective surface elements
4228	!-- Horizontal surfaces
4229	DO m = surf_lsm_h%start_index(j,i), &
4230	surf_lsm_h%end_index(j,i)
4231	surf_lsm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo)
4232	surf_lsm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo)
4233	surf_lsm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo)
4234	ENDDO
4235	DO m = surf_usm_h%start_index(j,i), &
4236	surf_usm_h%end_index(j,i)
4237	surf_usm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo)
4238	surf_usm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo)
4239	surf_usm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo)
4240	ENDDO
4241	!
4242	!-- Vertical surfaces. Fluxes are obtain at vertical level of the
4243	!-- respective surface element
4244	DO l = 0, 3
4245	DO m = surf_lsm_v(l)%start_index(j,i), &
4246	surf_lsm_v(l)%end_index(j,i)
4247	k = surf_lsm_v(l)%k(m)
4248	surf_lsm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k)
4249	surf_lsm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k)
4250	surf_lsm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
4251	ENDDO
4252	DO m = surf_usm_v(l)%start_index(j,i), &
4253	surf_usm_v(l)%end_index(j,i)
4254	k = surf_usm_v(l)%k(m)
4255	surf_usm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k)
4256	surf_usm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k)
4257	surf_usm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
4258	ENDDO
4259	ENDDO
4260
4261	ENDIF
4262
4263	IF ( sw_radiation .AND. sun_up ) THEN
4264	!
4265	!-- Get albedo for direct/diffusive long/shortwave radiation at
4266	!-- current (y,x)-location from surface variables.
4267	!-- Only obtain it from horizontal surfaces, as RRTMG is a single
4268	!-- column model
4269	!-- (Please note, only one loop will entered, controlled by
4270	!-- start-end index.)
4271	DO m = surf_lsm_h%start_index(j,i), &
4272	surf_lsm_h%end_index(j,i)
4273	rrtm_asdir(1) = SUM( surf_lsm_h%frac(:,m) * &
4274	surf_lsm_h%rrtm_asdir(:,m) )
4275	rrtm_asdif(1) = SUM( surf_lsm_h%frac(:,m) * &
4276	surf_lsm_h%rrtm_asdif(:,m) )
4277	rrtm_aldir(1) = SUM( surf_lsm_h%frac(:,m) * &
4278	surf_lsm_h%rrtm_aldir(:,m) )
4279	rrtm_aldif(1) = SUM( surf_lsm_h%frac(:,m) * &
4280	surf_lsm_h%rrtm_aldif(:,m) )
4281	ENDDO
4282	DO m = surf_usm_h%start_index(j,i), &
4283	surf_usm_h%end_index(j,i)
4284	rrtm_asdir(1) = SUM( surf_usm_h%frac(:,m) * &
4285	surf_usm_h%rrtm_asdir(:,m) )
4286	rrtm_asdif(1) = SUM( surf_usm_h%frac(:,m) * &
4287	surf_usm_h%rrtm_asdif(:,m) )
4288	rrtm_aldir(1) = SUM( surf_usm_h%frac(:,m) * &
4289	surf_usm_h%rrtm_aldir(:,m) )
4290	rrtm_aldif(1) = SUM( surf_usm_h%frac(:,m) * &
4291	surf_usm_h%rrtm_aldif(:,m) )
4292	ENDDO
4293	!
4294	!-- Due to technical reasons, copy optical depths and other
4295	!-- to dummy arguments which are allocated on the exact size as the
4296	!-- rrtmg_sw is called.
4297	!-- As one dimesion is allocated with zero size, compiler complains
4298	!-- that rank of the array does not match that of the
4299	!-- assumed-shaped arguments in the RRTMG library. In order to
4300	!-- avoid this, write to dummy arguments and give pass the entire
4301	!-- dummy array. Seems to be the only existing work-around.
4302	ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4303	ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4304	ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4305	ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4306	ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4307	ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4308	ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4309	ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) )
4310
4311	rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4312	rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4313	rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4314	rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4315	rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4316	rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4317	rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4318	rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1)
4319
4320	CALL rrtmg_sw( 1, &
4321	nzt_rad-k_topo, &
4322	rrtm_icld, &
4323	rrtm_iaer, &
4324	rrtm_play(:,k_topo+1:nzt_rad+1), &
4325	rrtm_plev(:,k_topo+1:nzt_rad+2), &
4326	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
4327	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
4328	rrtm_tsfc, &
4329	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
4330	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
4331	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
4332	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
4333	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
4334	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
4335	rrtm_asdir, &
4336	rrtm_asdif, &
4337	rrtm_aldir, &
4338	rrtm_aldif, &
4339	zenith, &
4340	0.0_wp, &
4341	day_of_year, &
4342	solar_constant, &
4343	rrtm_inflgsw, &
4344	rrtm_iceflgsw, &
4345	rrtm_liqflgsw, &
4346	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
4347	rrtm_sw_taucld_dum, &
4348	rrtm_sw_ssacld_dum, &
4349	rrtm_sw_asmcld_dum, &
4350	rrtm_sw_fsfcld_dum, &
4351	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
4352	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
4353	rrtm_reice(:,k_topo+1:nzt_rad+1), &
4354	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
4355	rrtm_sw_tauaer_dum, &
4356	rrtm_sw_ssaaer_dum, &
4357	rrtm_sw_asmaer_dum, &
4358	rrtm_sw_ecaer_dum, &
4359	rrtm_swuflx(:,k_topo:nzt_rad+1), &
4360	rrtm_swdflx(:,k_topo:nzt_rad+1), &
4361	rrtm_swhr(:,k_topo+1:nzt_rad+1), &
4362	rrtm_swuflxc(:,k_topo:nzt_rad+1), &
4363	rrtm_swdflxc(:,k_topo:nzt_rad+1), &
4364	rrtm_swhrc(:,k_topo+1:nzt_rad+1), &
4365	rrtm_dirdflux(:,k_topo:nzt_rad+1), &
4366	rrtm_difdflux(:,k_topo:nzt_rad+1) )
4367
4368	DEALLOCATE( rrtm_sw_taucld_dum )
4369	DEALLOCATE( rrtm_sw_ssacld_dum )
4370	DEALLOCATE( rrtm_sw_asmcld_dum )
4371	DEALLOCATE( rrtm_sw_fsfcld_dum )
4372	DEALLOCATE( rrtm_sw_tauaer_dum )
4373	DEALLOCATE( rrtm_sw_ssaaer_dum )
4374	DEALLOCATE( rrtm_sw_asmaer_dum )
4375	DEALLOCATE( rrtm_sw_ecaer_dum )
4376	!
4377	!-- Save fluxes
4378	DO k = nzb, nzt+1
4379	rad_sw_in(k,j,i) = rrtm_swdflx(0,k)
4380	rad_sw_out(k,j,i) = rrtm_swuflx(0,k)
4381	ENDDO
4382	!
4383	!-- Save heating rates (convert from K/d to K/s)
4384	DO k = nzb+1, nzt+1
4385	rad_sw_hr(k,j,i) = rrtm_swhr(0,k) * d_hours_day
4386	rad_sw_cs_hr(k,j,i) = rrtm_swhrc(0,k) * d_hours_day
4387	ENDDO
4388
4389	!
4390	!-- Save surface radiative fluxes onto respective surface elements
4391	!-- Horizontal surfaces
4392	DO m = surf_lsm_h%start_index(j,i), &
4393	surf_lsm_h%end_index(j,i)
4394	surf_lsm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo)
4395	surf_lsm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo)
4396	ENDDO
4397	DO m = surf_usm_h%start_index(j,i), &
4398	surf_usm_h%end_index(j,i)
4399	surf_usm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo)
4400	surf_usm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo)
4401	ENDDO
4402	!
4403	!-- Vertical surfaces. Fluxes are obtain at respective vertical
4404	!-- level of the surface element
4405	DO l = 0, 3
4406	DO m = surf_lsm_v(l)%start_index(j,i), &
4407	surf_lsm_v(l)%end_index(j,i)
4408	k = surf_lsm_v(l)%k(m)
4409	surf_lsm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k)
4410	surf_lsm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
4411	ENDDO
4412	DO m = surf_usm_v(l)%start_index(j,i), &
4413	surf_usm_v(l)%end_index(j,i)
4414	k = surf_usm_v(l)%k(m)
4415	surf_usm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k)
4416	surf_usm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
4417	ENDDO
4418	ENDDO
4419	!
4420	!-- Solar radiation is zero during night
4421	ELSE
4422	rad_sw_in = 0.0_wp
4423	rad_sw_out = 0.0_wp
4424	!-- !!!!!!!! ATTENSION !!!!!!!!!!!!!!!
4425	!-- Surface radiative fluxes should be also set to zero here
4426	!-- Save surface radiative fluxes onto respective surface elements
4427	!-- Horizontal surfaces
4428	DO m = surf_lsm_h%start_index(j,i), &
4429	surf_lsm_h%end_index(j,i)
4430	surf_lsm_h%rad_sw_in(m) = 0.0_wp
4431	surf_lsm_h%rad_sw_out(m) = 0.0_wp
4432	ENDDO
4433	DO m = surf_usm_h%start_index(j,i), &
4434	surf_usm_h%end_index(j,i)
4435	surf_usm_h%rad_sw_in(m) = 0.0_wp
4436	surf_usm_h%rad_sw_out(m) = 0.0_wp
4437	ENDDO
4438	!
4439	!-- Vertical surfaces. Fluxes are obtain at respective vertical
4440	!-- level of the surface element
4441	DO l = 0, 3
4442	DO m = surf_lsm_v(l)%start_index(j,i), &
4443	surf_lsm_v(l)%end_index(j,i)
4444	k = surf_lsm_v(l)%k(m)
4445	surf_lsm_v(l)%rad_sw_in(m) = 0.0_wp
4446	surf_lsm_v(l)%rad_sw_out(m) = 0.0_wp
4447	ENDDO
4448	DO m = surf_usm_v(l)%start_index(j,i), &
4449	surf_usm_v(l)%end_index(j,i)
4450	k = surf_usm_v(l)%k(m)
4451	surf_usm_v(l)%rad_sw_in(m) = 0.0_wp
4452	surf_usm_v(l)%rad_sw_out(m) = 0.0_wp
4453	ENDDO
4454	ENDDO
4455	ENDIF
4456
4457	ENDDO
4458	ENDDO
4459
4460	ENDIF
4461	!
4462	!-- Finally, calculate surface net radiation for surface elements.
4463	IF ( .NOT. radiation_interactions ) THEN
4464	!-- First, for horizontal surfaces
4465	DO m = 1, surf_lsm_h%ns
4466	surf_lsm_h%rad_net(m) = surf_lsm_h%rad_sw_in(m) &
4467	- surf_lsm_h%rad_sw_out(m) &
4468	+ surf_lsm_h%rad_lw_in(m) &
4469	- surf_lsm_h%rad_lw_out(m)
4470	ENDDO
4471	DO m = 1, surf_usm_h%ns
4472	surf_usm_h%rad_net(m) = surf_usm_h%rad_sw_in(m) &
4473	- surf_usm_h%rad_sw_out(m) &
4474	+ surf_usm_h%rad_lw_in(m) &
4475	- surf_usm_h%rad_lw_out(m)
4476	ENDDO
4477	!
4478	!-- Vertical surfaces.
4479	!-- Todo: weight with azimuth and zenith angle according to their orientation!
4480	DO l = 0, 3
4481	DO m = 1, surf_lsm_v(l)%ns
4482	surf_lsm_v(l)%rad_net(m) = surf_lsm_v(l)%rad_sw_in(m) &
4483	- surf_lsm_v(l)%rad_sw_out(m) &
4484	+ surf_lsm_v(l)%rad_lw_in(m) &
4485	- surf_lsm_v(l)%rad_lw_out(m)
4486	ENDDO
4487	DO m = 1, surf_usm_v(l)%ns
4488	surf_usm_v(l)%rad_net(m) = surf_usm_v(l)%rad_sw_in(m) &
4489	- surf_usm_v(l)%rad_sw_out(m) &
4490	+ surf_usm_v(l)%rad_lw_in(m) &
4491	- surf_usm_v(l)%rad_lw_out(m)
4492	ENDDO
4493	ENDDO
4494	ENDIF
4495
4496
4497	CALL exchange_horiz( rad_lw_in, nbgp )
4498	CALL exchange_horiz( rad_lw_out, nbgp )
4499	CALL exchange_horiz( rad_lw_hr, nbgp )
4500	CALL exchange_horiz( rad_lw_cs_hr, nbgp )
4501
4502	CALL exchange_horiz( rad_sw_in, nbgp )
4503	CALL exchange_horiz( rad_sw_out, nbgp )
4504	CALL exchange_horiz( rad_sw_hr, nbgp )
4505	CALL exchange_horiz( rad_sw_cs_hr, nbgp )
4506
4507	#endif
4508
4509	END SUBROUTINE radiation_rrtmg
4510
4511
4512	!------------------------------------------------------------------------------!
4513	! Description:
4514	! ------------
4515	!> Calculate the cosine of the zenith angle (variable is called zenith)
4516	!------------------------------------------------------------------------------!
4517	SUBROUTINE calc_zenith
4518
4519	IMPLICIT NONE
4520
4521	REAL(wp) :: declination, & !< solar declination angle
4522	hour_angle !< solar hour angle
4523	!
4524	!-- Calculate current day and time based on the initial values and simulation
4525	!-- time
4526	CALL calc_date_and_time
4527
4528	!
4529	!-- Calculate solar declination and hour angle
4530	declination = ASIN( decl_1 * SIN(decl_2 * REAL(day_of_year, KIND=wp) - decl_3) )
4531	hour_angle = 2.0_wp * pi * (time_utc / 86400.0_wp) + lon - pi
4532
4533	!
4534	!-- Calculate cosine of solar zenith angle
4535	cos_zenith = SIN(lat) * SIN(declination) + COS(lat) * COS(declination) &
4536	* COS(hour_angle)
4537	cos_zenith = MAX(0.0_wp,cos_zenith)
4538
4539	!
4540	!-- Calculate solar directional vector
4541	IF ( sun_direction ) THEN
4542
4543	!
4544	!-- Direction in longitudes equals to sin(solar_azimuth) * sin(zenith)
4545	sun_dir_lon = -SIN(hour_angle) * COS(declination)
4546
4547	!
4548	!-- Direction in latitues equals to cos(solar_azimuth) * sin(zenith)
4549	sun_dir_lat = SIN(declination) * COS(lat) - COS(hour_angle) &
4550	* COS(declination) * SIN(lat)
4551	ENDIF
4552
4553	!
4554	!-- Check if the sun is up (otheriwse shortwave calculations can be skipped)
4555	IF ( cos_zenith > 0.0_wp ) THEN
4556	sun_up = .TRUE.
4557	ELSE
4558	sun_up = .FALSE.
4559	END IF
4560
4561	END SUBROUTINE calc_zenith
4562
4563	#if defined ( __rrtmg ) && defined ( __netcdf )
4564	!------------------------------------------------------------------------------!
4565	! Description:
4566	! ------------
4567	!> Calculates surface albedo components based on Briegleb (1992) and
4568	!> Briegleb et al. (1986)
4569	!------------------------------------------------------------------------------!
4570	SUBROUTINE calc_albedo( surf )
4571
4572	IMPLICIT NONE
4573
4574	INTEGER(iwp) :: ind_type !< running index surface tiles
4575	INTEGER(iwp) :: m !< running index surface elements
4576
4577	TYPE(surf_type) :: surf !< treated surfaces
4578
4579	IF ( sun_up .AND. .NOT. average_radiation ) THEN
4580
4581	DO m = 1, surf%ns
4582	!
4583	!-- Loop over surface elements
4584	DO ind_type = 0, SIZE( surf%albedo_type, 1 ) - 1
4585
4586	!
4587	!-- Ocean
4588	IF ( surf%albedo_type(ind_type,m) == 1 ) THEN
4589	surf%rrtm_aldir(ind_type,m) = 0.026_wp / &
4590	( cos_zenith**1.7_wp + 0.065_wp )&
4591	+ 0.15_wp * ( cos_zenith - 0.1_wp ) &
4592	* ( cos_zenith - 0.5_wp ) &
4593	* ( cos_zenith - 1.0_wp )
4594	surf%rrtm_asdir(ind_type,m) = surf%rrtm_aldir(ind_type,m)
4595	!
4596	!-- Snow
4597	ELSEIF ( surf%albedo_type(ind_type,m) == 16 ) THEN
4598	IF ( cos_zenith < 0.5_wp ) THEN
4599	surf%rrtm_aldir(ind_type,m) = &
4600	0.5_wp * ( 1.0_wp - surf%aldif(ind_type,m) ) &
4601	* ( 3.0_wp / ( 1.0_wp + 4.0_wp &
4602	* cos_zenith ) ) - 1.0_wp
4603	surf%rrtm_asdir(ind_type,m) = &
4604	0.5_wp * ( 1.0_wp - surf%asdif(ind_type,m) ) &
4605	* ( 3.0_wp / ( 1.0_wp + 4.0_wp &
4606	* cos_zenith ) ) - 1.0_wp
4607
4608	surf%rrtm_aldir(ind_type,m) = &
4609	MIN(0.98_wp, surf%rrtm_aldir(ind_type,m))
4610	surf%rrtm_asdir(ind_type,m) = &
4611	MIN(0.98_wp, surf%rrtm_asdir(ind_type,m))
4612	ELSE
4613	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4614	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4615	ENDIF
4616	!
4617	!-- Sea ice
4618	ELSEIF ( surf%albedo_type(ind_type,m) == 15 ) THEN
4619	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4620	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4621
4622	!
4623	!-- Asphalt
4624	ELSEIF ( surf%albedo_type(ind_type,m) == 17 ) THEN
4625	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4626	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4627
4628
4629	!
4630	!-- Bare soil
4631	ELSEIF ( surf%albedo_type(ind_type,m) == 18 ) THEN
4632	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4633	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4634
4635	!
4636	!-- Land surfaces
4637	ELSE
4638	SELECT CASE ( surf%albedo_type(ind_type,m) )
4639
4640	!
4641	!-- Surface types with strong zenith dependence
4642	CASE ( 1, 2, 3, 4, 11, 12, 13 )
4643	surf%rrtm_aldir(ind_type,m) = &
4644	surf%aldif(ind_type,m) * 1.4_wp / &
4645	( 1.0_wp + 0.8_wp * cos_zenith )
4646	surf%rrtm_asdir(ind_type,m) = &
4647	surf%asdif(ind_type,m) * 1.4_wp / &
4648	( 1.0_wp + 0.8_wp * cos_zenith )
4649	!
4650	!-- Surface types with weak zenith dependence
4651	CASE ( 5, 6, 7, 8, 9, 10, 14 )
4652	surf%rrtm_aldir(ind_type,m) = &
4653	surf%aldif(ind_type,m) * 1.1_wp / &
4654	( 1.0_wp + 0.2_wp * cos_zenith )
4655	surf%rrtm_asdir(ind_type,m) = &
4656	surf%asdif(ind_type,m) * 1.1_wp / &
4657	( 1.0_wp + 0.2_wp * cos_zenith )
4658
4659	CASE DEFAULT
4660
4661	END SELECT
4662	ENDIF
4663	!
4664	!-- Diffusive albedo is taken from Table 2
4665	surf%rrtm_aldif(ind_type,m) = surf%aldif(ind_type,m)
4666	surf%rrtm_asdif(ind_type,m) = surf%asdif(ind_type,m)
4667	ENDDO
4668	ENDDO
4669	!
4670	!-- Set albedo in case of average radiation
4671	ELSEIF ( sun_up .AND. average_radiation ) THEN
4672	surf%rrtm_asdir = albedo_urb
4673	surf%rrtm_asdif = albedo_urb
4674	surf%rrtm_aldir = albedo_urb
4675	surf%rrtm_aldif = albedo_urb
4676	!
4677	!-- Darkness
4678	ELSE
4679	surf%rrtm_aldir = 0.0_wp
4680	surf%rrtm_asdir = 0.0_wp
4681	surf%rrtm_aldif = 0.0_wp
4682	surf%rrtm_asdif = 0.0_wp
4683	ENDIF
4684
4685	END SUBROUTINE calc_albedo
4686
4687	!------------------------------------------------------------------------------!
4688	! Description:
4689	! ------------
4690	!> Read sounding data (pressure and temperature) from RADIATION_DATA.
4691	!------------------------------------------------------------------------------!
4692	SUBROUTINE read_sounding_data
4693
4694	IMPLICIT NONE
4695
4696	INTEGER(iwp) :: id, & !< NetCDF id of input file
4697	id_dim_zrad, & !< pressure level id in the NetCDF file
4698	id_var, & !< NetCDF variable id
4699	k, & !< loop index
4700	nz_snd, & !< number of vertical levels in the sounding data
4701	nz_snd_start, & !< start vertical index for sounding data to be used
4702	nz_snd_end !< end vertical index for souding data to be used
4703
4704	REAL(wp) :: t_surface !< actual surface temperature
4705
4706	REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd_tmp, & !< temporary hydrostatic pressure profile (sounding)
4707	t_snd_tmp !< temporary temperature profile (sounding)
4708
4709	!
4710	!-- In case of updates, deallocate arrays first (sufficient to check one
4711	!-- array as the others are automatically allocated). This is required
4712	!-- because nzt_rad might change during the update
4713	IF ( ALLOCATED ( hyp_snd ) ) THEN
4714	DEALLOCATE( hyp_snd )
4715	DEALLOCATE( t_snd )
4716	DEALLOCATE ( rrtm_play )
4717	DEALLOCATE ( rrtm_plev )
4718	DEALLOCATE ( rrtm_tlay )
4719	DEALLOCATE ( rrtm_tlev )
4720
4721	DEALLOCATE ( rrtm_cicewp )
4722	DEALLOCATE ( rrtm_cldfr )
4723	DEALLOCATE ( rrtm_cliqwp )
4724	DEALLOCATE ( rrtm_reice )
4725	DEALLOCATE ( rrtm_reliq )
4726	DEALLOCATE ( rrtm_lw_taucld )
4727	DEALLOCATE ( rrtm_lw_tauaer )
4728
4729	DEALLOCATE ( rrtm_lwdflx )
4730	DEALLOCATE ( rrtm_lwdflxc )
4731	DEALLOCATE ( rrtm_lwuflx )
4732	DEALLOCATE ( rrtm_lwuflxc )
4733	DEALLOCATE ( rrtm_lwuflx_dt )
4734	DEALLOCATE ( rrtm_lwuflxc_dt )
4735	DEALLOCATE ( rrtm_lwhr )
4736	DEALLOCATE ( rrtm_lwhrc )
4737
4738	DEALLOCATE ( rrtm_sw_taucld )
4739	DEALLOCATE ( rrtm_sw_ssacld )
4740	DEALLOCATE ( rrtm_sw_asmcld )
4741	DEALLOCATE ( rrtm_sw_fsfcld )
4742	DEALLOCATE ( rrtm_sw_tauaer )
4743	DEALLOCATE ( rrtm_sw_ssaaer )
4744	DEALLOCATE ( rrtm_sw_asmaer )
4745	DEALLOCATE ( rrtm_sw_ecaer )
4746
4747	DEALLOCATE ( rrtm_swdflx )
4748	DEALLOCATE ( rrtm_swdflxc )
4749	DEALLOCATE ( rrtm_swuflx )
4750	DEALLOCATE ( rrtm_swuflxc )
4751	DEALLOCATE ( rrtm_swhr )
4752	DEALLOCATE ( rrtm_swhrc )
4753	DEALLOCATE ( rrtm_dirdflux )
4754	DEALLOCATE ( rrtm_difdflux )
4755
4756	ENDIF
4757
4758	!
4759	!-- Open file for reading
4760	nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id )
4761	CALL netcdf_handle_error_rad( 'read_sounding_data', 549 )
4762
4763	!
4764	!-- Inquire dimension of z axis and save in nz_snd
4765	nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim_zrad )
4766	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim_zrad, len = nz_snd )
4767	CALL netcdf_handle_error_rad( 'read_sounding_data', 551 )
4768
4769	!
4770	! !-- Allocate temporary array for storing pressure data
4771	ALLOCATE( hyp_snd_tmp(1:nz_snd) )
4772	hyp_snd_tmp = 0.0_wp
4773
4774
4775	!-- Read pressure from file
4776	nc_stat = NF90_INQ_VARID( id, "Pressure", id_var )
4777	nc_stat = NF90_GET_VAR( id, id_var, hyp_snd_tmp(:), start = (/1/), &
4778	count = (/nz_snd/) )
4779	CALL netcdf_handle_error_rad( 'read_sounding_data', 552 )
4780
4781	!
4782	!-- Allocate temporary array for storing temperature data
4783	ALLOCATE( t_snd_tmp(1:nz_snd) )
4784	t_snd_tmp = 0.0_wp
4785
4786	!
4787	!-- Read temperature from file
4788	nc_stat = NF90_INQ_VARID( id, "ReferenceTemperature", id_var )
4789	nc_stat = NF90_GET_VAR( id, id_var, t_snd_tmp(:), start = (/1/), &
4790	count = (/nz_snd/) )
4791	CALL netcdf_handle_error_rad( 'read_sounding_data', 553 )
4792
4793	!
4794	!-- Calculate start of sounding data
4795	nz_snd_start = nz_snd + 1
4796	nz_snd_end = nz_snd + 1
4797
4798	!
4799	!-- Start filling vertical dimension at 10hPa above the model domain (hyp is
4800	!-- in Pa, hyp_snd in hPa).
4801	DO k = 1, nz_snd
4802	IF ( hyp_snd_tmp(k) < ( hyp(nzt+1) - 1000.0_wp) * 0.01_wp ) THEN
4803	nz_snd_start = k
4804	EXIT
4805	END IF
4806	END DO
4807
4808	IF ( nz_snd_start <= nz_snd ) THEN
4809	nz_snd_end = nz_snd
4810	END IF
4811
4812
4813	!
4814	!-- Calculate of total grid points for RRTMG calculations
4815	nzt_rad = nzt + nz_snd_end - nz_snd_start + 1
4816
4817	!
4818	!-- Save data above LES domain in hyp_snd, t_snd
4819	ALLOCATE( hyp_snd(nzb+1:nzt_rad) )
4820	ALLOCATE( t_snd(nzb+1:nzt_rad) )
4821	hyp_snd = 0.0_wp
4822	t_snd = 0.0_wp
4823
4824	hyp_snd(nzt+2:nzt_rad) = hyp_snd_tmp(nz_snd_start+1:nz_snd_end)
4825	t_snd(nzt+2:nzt_rad) = t_snd_tmp(nz_snd_start+1:nz_snd_end)
4826
4827	nc_stat = NF90_CLOSE( id )
4828
4829	!
4830	!-- Calculate pressure levels on zu and zw grid. Sounding data is added at
4831	!-- top of the LES domain. This routine does not consider horizontal or
4832	!-- vertical variability of pressure and temperature
4833	ALLOCATE ( rrtm_play(0:0,nzb+1:nzt_rad+1) )
4834	ALLOCATE ( rrtm_plev(0:0,nzb+1:nzt_rad+2) )
4835
4836	t_surface = pt_surface * exner(nzb)
4837	DO k = nzb+1, nzt+1
4838	rrtm_play(0,k) = hyp(k) * 0.01_wp
4839	rrtm_plev(0,k) = barometric_formula(zw(k-1), &
4840	pt_surface * exner(nzb), &
4841	surface_pressure )
4842	ENDDO
4843
4844	DO k = nzt+2, nzt_rad
4845	rrtm_play(0,k) = hyp_snd(k)
4846	rrtm_plev(0,k) = 0.5_wp * ( rrtm_play(0,k) + rrtm_play(0,k-1) )
4847	ENDDO
4848	rrtm_plev(0,nzt_rad+1) = MAX( 0.5 * hyp_snd(nzt_rad), &
4849	1.5 * hyp_snd(nzt_rad) &
4850	- 0.5 * hyp_snd(nzt_rad-1) )
4851	rrtm_plev(0,nzt_rad+2) = MIN( 1.0E-4_wp, &
4852	0.25_wp * rrtm_plev(0,nzt_rad+1) )
4853
4854	rrtm_play(0,nzt_rad+1) = 0.5 * rrtm_plev(0,nzt_rad+1)
4855
4856	!
4857	!-- Calculate temperature/humidity levels at top of the LES domain.
4858	!-- Currently, the temperature is taken from sounding data (might lead to a
4859	!-- temperature jump at interface. To do: Humidity is currently not
4860	!-- calculated above the LES domain.
4861	ALLOCATE ( rrtm_tlay(0:0,nzb+1:nzt_rad+1) )
4862	ALLOCATE ( rrtm_tlev(0:0,nzb+1:nzt_rad+2) )
4863
4864	DO k = nzt+8, nzt_rad
4865	rrtm_tlay(0,k) = t_snd(k)
4866	ENDDO
4867	rrtm_tlay(0,nzt_rad+1) = 2.0_wp * rrtm_tlay(0,nzt_rad) &
4868	- rrtm_tlay(0,nzt_rad-1)
4869	DO k = nzt+9, nzt_rad+1
4870	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) &
4871	- rrtm_tlay(0,k-1)) &
4872	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
4873	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
4874	ENDDO
4875
4876	rrtm_tlev(0,nzt_rad+2) = 2.0_wp * rrtm_tlay(0,nzt_rad+1) &
4877	- rrtm_tlev(0,nzt_rad)
4878	!
4879	!-- Allocate remaining RRTMG arrays
4880	ALLOCATE ( rrtm_cicewp(0:0,nzb+1:nzt_rad+1) )
4881	ALLOCATE ( rrtm_cldfr(0:0,nzb+1:nzt_rad+1) )
4882	ALLOCATE ( rrtm_cliqwp(0:0,nzb+1:nzt_rad+1) )
4883	ALLOCATE ( rrtm_reice(0:0,nzb+1:nzt_rad+1) )
4884	ALLOCATE ( rrtm_reliq(0:0,nzb+1:nzt_rad+1) )
4885	ALLOCATE ( rrtm_lw_taucld(1:nbndlw+1,0:0,nzb+1:nzt_rad+1) )
4886	ALLOCATE ( rrtm_lw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndlw+1) )
4887	ALLOCATE ( rrtm_sw_taucld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4888	ALLOCATE ( rrtm_sw_ssacld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4889	ALLOCATE ( rrtm_sw_asmcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4890	ALLOCATE ( rrtm_sw_fsfcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4891	ALLOCATE ( rrtm_sw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
4892	ALLOCATE ( rrtm_sw_ssaaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
4893	ALLOCATE ( rrtm_sw_asmaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
4894	ALLOCATE ( rrtm_sw_ecaer(0:0,nzb+1:nzt_rad+1,1:naerec+1) )
4895
4896	!
4897	!-- The ice phase is currently not considered in PALM
4898	rrtm_cicewp = 0.0_wp
4899	rrtm_reice = 0.0_wp
4900
4901	!
4902	!-- Set other parameters (move to NAMELIST parameters in the future)
4903	rrtm_lw_tauaer = 0.0_wp
4904	rrtm_lw_taucld = 0.0_wp
4905	rrtm_sw_taucld = 0.0_wp
4906	rrtm_sw_ssacld = 0.0_wp
4907	rrtm_sw_asmcld = 0.0_wp
4908	rrtm_sw_fsfcld = 0.0_wp
4909	rrtm_sw_tauaer = 0.0_wp
4910	rrtm_sw_ssaaer = 0.0_wp
4911	rrtm_sw_asmaer = 0.0_wp
4912	rrtm_sw_ecaer = 0.0_wp
4913
4914
4915	ALLOCATE ( rrtm_swdflx(0:0,nzb:nzt_rad+1) )
4916	ALLOCATE ( rrtm_swuflx(0:0,nzb:nzt_rad+1) )
4917	ALLOCATE ( rrtm_swhr(0:0,nzb+1:nzt_rad+1) )
4918	ALLOCATE ( rrtm_swuflxc(0:0,nzb:nzt_rad+1) )
4919	ALLOCATE ( rrtm_swdflxc(0:0,nzb:nzt_rad+1) )
4920	ALLOCATE ( rrtm_swhrc(0:0,nzb+1:nzt_rad+1) )
4921	ALLOCATE ( rrtm_dirdflux(0:0,nzb:nzt_rad+1) )
4922	ALLOCATE ( rrtm_difdflux(0:0,nzb:nzt_rad+1) )
4923
4924	rrtm_swdflx = 0.0_wp
4925	rrtm_swuflx = 0.0_wp
4926	rrtm_swhr = 0.0_wp
4927	rrtm_swuflxc = 0.0_wp
4928	rrtm_swdflxc = 0.0_wp
4929	rrtm_swhrc = 0.0_wp
4930	rrtm_dirdflux = 0.0_wp
4931	rrtm_difdflux = 0.0_wp
4932
4933	ALLOCATE ( rrtm_lwdflx(0:0,nzb:nzt_rad+1) )
4934	ALLOCATE ( rrtm_lwuflx(0:0,nzb:nzt_rad+1) )
4935	ALLOCATE ( rrtm_lwhr(0:0,nzb+1:nzt_rad+1) )
4936	ALLOCATE ( rrtm_lwuflxc(0:0,nzb:nzt_rad+1) )
4937	ALLOCATE ( rrtm_lwdflxc(0:0,nzb:nzt_rad+1) )
4938	ALLOCATE ( rrtm_lwhrc(0:0,nzb+1:nzt_rad+1) )
4939
4940	rrtm_lwdflx = 0.0_wp
4941	rrtm_lwuflx = 0.0_wp
4942	rrtm_lwhr = 0.0_wp
4943	rrtm_lwuflxc = 0.0_wp
4944	rrtm_lwdflxc = 0.0_wp
4945	rrtm_lwhrc = 0.0_wp
4946
4947	ALLOCATE ( rrtm_lwuflx_dt(0:0,nzb:nzt_rad+1) )
4948	ALLOCATE ( rrtm_lwuflxc_dt(0:0,nzb:nzt_rad+1) )
4949
4950	rrtm_lwuflx_dt = 0.0_wp
4951	rrtm_lwuflxc_dt = 0.0_wp
4952
4953	END SUBROUTINE read_sounding_data
4954
4955
4956	!------------------------------------------------------------------------------!
4957	! Description:
4958	! ------------
4959	!> Read trace gas data from file and convert into trace gas paths / volume
4960	!> mixing ratios. If a user-defined input file is provided it needs to follow
4961	!> the convections used in RRTMG (see respective netCDF files shipped with
4962	!> RRTMG)
4963	!------------------------------------------------------------------------------!
4964	SUBROUTINE read_trace_gas_data
4965
4966	USE rrsw_ncpar
4967
4968	IMPLICIT NONE
4969
4970	INTEGER(iwp), PARAMETER :: num_trace_gases = 10 !< number of trace gases (absorbers)
4971
4972	CHARACTER(LEN=5), DIMENSION(num_trace_gases), PARAMETER :: & !< trace gas names
4973	trace_names = (/'O3 ', 'CO2 ', 'CH4 ', 'N2O ', 'O2 ', &
4974	'CFC11', 'CFC12', 'CFC22', 'CCL4 ', 'H2O '/)
4975
4976	INTEGER(iwp) :: id, & !< NetCDF id
4977	k, & !< loop index
4978	m, & !< loop index
4979	n, & !< loop index
4980	nabs, & !< number of absorbers
4981	np, & !< number of pressure levels
4982	id_abs, & !< NetCDF id of the respective absorber
4983	id_dim, & !< NetCDF id of asborber's dimension
4984	id_var !< NetCDf id ot the absorber
4985
4986	REAL(wp) :: p_mls_l, & !< pressure lower limit for interpolation
4987	p_mls_u, & !< pressure upper limit for interpolation
4988	p_wgt_l, & !< pressure weight lower limit for interpolation
4989	p_wgt_u, & !< pressure weight upper limit for interpolation
4990	p_mls_m !< mean pressure between upper and lower limits
4991
4992
4993	REAL(wp), DIMENSION(:), ALLOCATABLE :: p_mls, & !< pressure levels for the absorbers
4994	rrtm_play_tmp, & !< temporary array for pressure zu-levels
4995	rrtm_plev_tmp, & !< temporary array for pressure zw-levels
4996	trace_path_tmp !< temporary array for storing trace gas path data
4997
4998	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: trace_mls, & !< array for storing the absorber amounts
4999	trace_mls_path, & !< array for storing trace gas path data
5000	trace_mls_tmp !< temporary array for storing trace gas data
5001
5002
5003	!
5004	!-- In case of updates, deallocate arrays first (sufficient to check one
5005	!-- array as the others are automatically allocated)
5006	IF ( ALLOCATED ( rrtm_o3vmr ) ) THEN
5007	DEALLOCATE ( rrtm_o3vmr )
5008	DEALLOCATE ( rrtm_co2vmr )
5009	DEALLOCATE ( rrtm_ch4vmr )
5010	DEALLOCATE ( rrtm_n2ovmr )
5011	DEALLOCATE ( rrtm_o2vmr )
5012	DEALLOCATE ( rrtm_cfc11vmr )
5013	DEALLOCATE ( rrtm_cfc12vmr )
5014	DEALLOCATE ( rrtm_cfc22vmr )
5015	DEALLOCATE ( rrtm_ccl4vmr )
5016	DEALLOCATE ( rrtm_h2ovmr )
5017	ENDIF
5018
5019	!
5020	!-- Allocate trace gas profiles
5021	ALLOCATE ( rrtm_o3vmr(0:0,1:nzt_rad+1) )
5022	ALLOCATE ( rrtm_co2vmr(0:0,1:nzt_rad+1) )
5023	ALLOCATE ( rrtm_ch4vmr(0:0,1:nzt_rad+1) )
5024	ALLOCATE ( rrtm_n2ovmr(0:0,1:nzt_rad+1) )
5025	ALLOCATE ( rrtm_o2vmr(0:0,1:nzt_rad+1) )
5026	ALLOCATE ( rrtm_cfc11vmr(0:0,1:nzt_rad+1) )
5027	ALLOCATE ( rrtm_cfc12vmr(0:0,1:nzt_rad+1) )
5028	ALLOCATE ( rrtm_cfc22vmr(0:0,1:nzt_rad+1) )
5029	ALLOCATE ( rrtm_ccl4vmr(0:0,1:nzt_rad+1) )
5030	ALLOCATE ( rrtm_h2ovmr(0:0,1:nzt_rad+1) )
5031
5032	!
5033	!-- Open file for reading
5034	nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id )
5035	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 549 )
5036	!
5037	!-- Inquire dimension ids and dimensions
5038	nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim )
5039	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5040	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = np)
5041	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5042
5043	nc_stat = NF90_INQ_DIMID( id, "Absorber", id_dim )
5044	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5045	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = nabs )
5046	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5047
5048
5049	!
5050	!-- Allocate pressure, and trace gas arrays
5051	ALLOCATE( p_mls(1:np) )
5052	ALLOCATE( trace_mls(1:num_trace_gases,1:np) )
5053	ALLOCATE( trace_mls_tmp(1:nabs,1:np) )
5054
5055
5056	nc_stat = NF90_INQ_VARID( id, "Pressure", id_var )
5057	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5058	nc_stat = NF90_GET_VAR( id, id_var, p_mls )
5059	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5060
5061	nc_stat = NF90_INQ_VARID( id, "AbsorberAmountMLS", id_var )
5062	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5063	nc_stat = NF90_GET_VAR( id, id_var, trace_mls_tmp )
5064	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5065
5066
5067	!
5068	!-- Write absorber amounts (mls) to trace_mls
5069	DO n = 1, num_trace_gases
5070	CALL getAbsorberIndex( TRIM( trace_names(n) ), id_abs )
5071
5072	trace_mls(n,1:np) = trace_mls_tmp(id_abs,1:np)
5073
5074	!
5075	!-- Replace missing values by zero
5076	WHERE ( trace_mls(n,:) > 2.0_wp )
5077	trace_mls(n,:) = 0.0_wp
5078	END WHERE
5079	END DO
5080
5081	DEALLOCATE ( trace_mls_tmp )
5082
5083	nc_stat = NF90_CLOSE( id )
5084	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 551 )
5085
5086	!
5087	!-- Add extra pressure level for calculations of the trace gas paths
5088	ALLOCATE ( rrtm_play_tmp(1:nzt_rad+1) )
5089	ALLOCATE ( rrtm_plev_tmp(1:nzt_rad+2) )
5090
5091	rrtm_play_tmp(1:nzt_rad) = rrtm_play(0,1:nzt_rad)
5092	rrtm_plev_tmp(1:nzt_rad+1) = rrtm_plev(0,1:nzt_rad+1)
5093	rrtm_play_tmp(nzt_rad+1) = rrtm_plev(0,nzt_rad+1) * 0.5_wp
5094	rrtm_plev_tmp(nzt_rad+2) = MIN( 1.0E-4_wp, 0.25_wp &
5095	* rrtm_plev(0,nzt_rad+1) )
5096
5097	!
5098	!-- Calculate trace gas path (zero at surface) with interpolation to the
5099	!-- sounding levels
5100	ALLOCATE ( trace_mls_path(1:nzt_rad+2,1:num_trace_gases) )
5101
5102	trace_mls_path(nzb+1,:) = 0.0_wp
5103
5104	DO k = nzb+2, nzt_rad+2
5105	DO m = 1, num_trace_gases
5106	trace_mls_path(k,m) = trace_mls_path(k-1,m)
5107
5108	!
5109	!-- When the pressure level is higher than the trace gas pressure
5110	!-- level, assume that
5111	IF ( rrtm_plev_tmp(k-1) > p_mls(1) ) THEN
5112
5113	trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,1) &
5114	* ( rrtm_plev_tmp(k-1) &
5115	- MAX( p_mls(1), rrtm_plev_tmp(k) ) &
5116	) / g
5117	ENDIF
5118
5119	!
5120	!-- Integrate for each sounding level from the contributing p_mls
5121	!-- levels
5122	DO n = 2, np
5123	!
5124	!-- Limit p_mls so that it is within the model level
5125	p_mls_u = MIN( rrtm_plev_tmp(k-1), &
5126	MAX( rrtm_plev_tmp(k), p_mls(n) ) )
5127	p_mls_l = MIN( rrtm_plev_tmp(k-1), &
5128	MAX( rrtm_plev_tmp(k), p_mls(n-1) ) )
5129
5130	IF ( p_mls_l > p_mls_u ) THEN
5131
5132	!
5133	!-- Calculate weights for interpolation
5134	p_mls_m = 0.5_wp * (p_mls_l + p_mls_u)
5135	p_wgt_u = (p_mls(n-1) - p_mls_m) / (p_mls(n-1) - p_mls(n))
5136	p_wgt_l = (p_mls_m - p_mls(n)) / (p_mls(n-1) - p_mls(n))
5137
5138	!
5139	!-- Add level to trace gas path
5140	trace_mls_path(k,m) = trace_mls_path(k,m) &
5141	+ ( p_wgt_u * trace_mls(m,n) &
5142	+ p_wgt_l * trace_mls(m,n-1) ) &
5143	* (p_mls_l - p_mls_u) / g
5144	ENDIF
5145	ENDDO
5146
5147	IF ( rrtm_plev_tmp(k) < p_mls(np) ) THEN
5148	trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,np) &
5149	* ( MIN( rrtm_plev_tmp(k-1), p_mls(np) ) &
5150	- rrtm_plev_tmp(k) &
5151	) / g
5152	ENDIF
5153	ENDDO
5154	ENDDO
5155
5156
5157	!
5158	!-- Prepare trace gas path profiles
5159	ALLOCATE ( trace_path_tmp(1:nzt_rad+1) )
5160
5161	DO m = 1, num_trace_gases
5162
5163	trace_path_tmp(1:nzt_rad+1) = ( trace_mls_path(2:nzt_rad+2,m) &
5164	- trace_mls_path(1:nzt_rad+1,m) ) * g &
5165	/ ( rrtm_plev_tmp(1:nzt_rad+1) &
5166	- rrtm_plev_tmp(2:nzt_rad+2) )
5167
5168	!
5169	!-- Save trace gas paths to the respective arrays
5170	SELECT CASE ( TRIM( trace_names(m) ) )
5171
5172	CASE ( 'O3' )
5173
5174	rrtm_o3vmr(0,:) = trace_path_tmp(:)
5175
5176	CASE ( 'CO2' )
5177
5178	rrtm_co2vmr(0,:) = trace_path_tmp(:)
5179
5180	CASE ( 'CH4' )
5181
5182	rrtm_ch4vmr(0,:) = trace_path_tmp(:)
5183
5184	CASE ( 'N2O' )
5185
5186	rrtm_n2ovmr(0,:) = trace_path_tmp(:)
5187
5188	CASE ( 'O2' )
5189
5190	rrtm_o2vmr(0,:) = trace_path_tmp(:)
5191
5192	CASE ( 'CFC11' )
5193
5194	rrtm_cfc11vmr(0,:) = trace_path_tmp(:)
5195
5196	CASE ( 'CFC12' )
5197
5198	rrtm_cfc12vmr(0,:) = trace_path_tmp(:)
5199
5200	CASE ( 'CFC22' )
5201
5202	rrtm_cfc22vmr(0,:) = trace_path_tmp(:)
5203
5204	CASE ( 'CCL4' )
5205
5206	rrtm_ccl4vmr(0,:) = trace_path_tmp(:)
5207
5208	CASE ( 'H2O' )
5209
5210	rrtm_h2ovmr(0,:) = trace_path_tmp(:)
5211
5212	CASE DEFAULT
5213
5214	END SELECT
5215
5216	ENDDO
5217
5218	DEALLOCATE ( trace_path_tmp )
5219	DEALLOCATE ( trace_mls_path )
5220	DEALLOCATE ( rrtm_play_tmp )
5221	DEALLOCATE ( rrtm_plev_tmp )
5222	DEALLOCATE ( trace_mls )
5223	DEALLOCATE ( p_mls )
5224
5225	END SUBROUTINE read_trace_gas_data
5226
5227
5228	SUBROUTINE netcdf_handle_error_rad( routine_name, errno )
5229
5230	USE control_parameters, &
5231	ONLY: message_string
5232
5233	USE NETCDF
5234
5235	USE pegrid
5236
5237	IMPLICIT NONE
5238
5239	CHARACTER(LEN=6) :: message_identifier
5240	CHARACTER(LEN=*) :: routine_name
5241
5242	INTEGER(iwp) :: errno
5243
5244	IF ( nc_stat /= NF90_NOERR ) THEN
5245
5246	WRITE( message_identifier, '(''NC'',I4.4)' ) errno
5247	message_string = TRIM( NF90_STRERROR( nc_stat ) )
5248
5249	CALL message( routine_name, message_identifier, 2, 2, 0, 6, 1 )
5250
5251	ENDIF
5252
5253	END SUBROUTINE netcdf_handle_error_rad
5254	#endif
5255
5256
5257	!------------------------------------------------------------------------------!
5258	! Description:
5259	! ------------
5260	!> Calculate temperature tendency due to radiative cooling/heating.
5261	!> Cache-optimized version.
5262	!------------------------------------------------------------------------------!
5263	#if defined( __rrtmg )
5264	SUBROUTINE radiation_tendency_ij ( i, j, tend )
5265
5266	IMPLICIT NONE
5267
5268	INTEGER(iwp) :: i, j, k !< loop indices
5269
5270	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term
5271
5272	IF ( radiation_scheme == 'rrtmg' ) THEN
5273	!
5274	!-- Calculate tendency based on heating rate
5275	DO k = nzb+1, nzt+1
5276	tend(k,j,i) = tend(k,j,i) + (rad_lw_hr(k,j,i) + rad_sw_hr(k,j,i)) &
5277	* d_exner(k) * d_seconds_hour
5278	ENDDO
5279
5280	ENDIF
5281
5282	END SUBROUTINE radiation_tendency_ij
5283	#endif
5284
5285
5286	!------------------------------------------------------------------------------!
5287	! Description:
5288	! ------------
5289	!> Calculate temperature tendency due to radiative cooling/heating.
5290	!> Vector-optimized version
5291	!------------------------------------------------------------------------------!
5292	#if defined( __rrtmg )
5293	SUBROUTINE radiation_tendency ( tend )
5294
5295	USE indices, &
5296	ONLY: nxl, nxr, nyn, nys
5297
5298	IMPLICIT NONE
5299
5300	INTEGER(iwp) :: i, j, k !< loop indices
5301
5302	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term
5303
5304	IF ( radiation_scheme == 'rrtmg' ) THEN
5305	!
5306	!-- Calculate tendency based on heating rate
5307	DO i = nxl, nxr
5308	DO j = nys, nyn
5309	DO k = nzb+1, nzt+1
5310	tend(k,j,i) = tend(k,j,i) + ( rad_lw_hr(k,j,i) &
5311	+ rad_sw_hr(k,j,i) ) * d_exner(k) &
5312	* d_seconds_hour
5313	ENDDO
5314	ENDDO
5315	ENDDO
5316	ENDIF
5317
5318	END SUBROUTINE radiation_tendency
5319	#endif
5320
5321	!------------------------------------------------------------------------------!
5322	! Description:
5323	! ------------
5324	!> This subroutine calculates interaction of the solar radiation
5325	!> with urban and land surfaces and updates all surface heatfluxes.
5326	!> It calculates also the required parameters for RRTMG lower BC.
5327	!>
5328	!> For more info. see Resler et al. 2017
5329	!>
5330	!> The new version 2.0 was radically rewriten, the discretization scheme
5331	!> has been changed. This new version significantly improves effectivity
5332	!> of the paralelization and the scalability of the model.
5333	!------------------------------------------------------------------------------!
5334
5335	SUBROUTINE radiation_interaction
5336
5337	IMPLICIT NONE
5338
5339	INTEGER(iwp) :: i, j, k, kk, d, refstep, m, mm, l, ll
5340	INTEGER(iwp) :: isurf, isurfsrc, isvf, icsf, ipcgb
5341	INTEGER(iwp) :: imrt, imrtf
5342	INTEGER(iwp) :: isd !< solar direction number
5343	INTEGER(iwp) :: pc_box_dimshift !< transform for best accuracy
5344	INTEGER(iwp), DIMENSION(0:3) :: reorder = (/ 1, 0, 3, 2 /)
5345
5346	REAL(wp), DIMENSION(3,3) :: mrot !< grid rotation matrix (zyx)
5347	REAL(wp), DIMENSION(3,0:nsurf_type):: vnorm !< face direction normal vectors (zyx)
5348	REAL(wp), DIMENSION(3) :: sunorig !< grid rotated solar direction unit vector (zyx)
5349	REAL(wp), DIMENSION(3) :: sunorig_grid !< grid squashed solar direction unit vector (zyx)
5350	REAL(wp), DIMENSION(0:nsurf_type) :: costheta !< direct irradiance factor of solar angle
5351	REAL(wp), DIMENSION(nz_urban_b:nz_urban_t) :: pchf_prep !< precalculated factor for canopy temperature tendency
5352	REAL(wp), PARAMETER :: alpha = 0._wp !< grid rotation (TODO: synchronize with rotation_angle
5353	!< from netcdf_data_input_mod)
5354	REAL(wp) :: pc_box_area, pc_abs_frac, pc_abs_eff
5355	REAL(wp) :: asrc !< area of source face
5356	REAL(wp) :: pcrad !< irradiance from plant canopy
5357	REAL(wp) :: pabsswl = 0.0_wp !< total absorbed SW radiation energy in local processor (W)
5358	REAL(wp) :: pabssw = 0.0_wp !< total absorbed SW radiation energy in all processors (W)
5359	REAL(wp) :: pabslwl = 0.0_wp !< total absorbed LW radiation energy in local processor (W)
5360	REAL(wp) :: pabslw = 0.0_wp !< total absorbed LW radiation energy in all processors (W)
5361	REAL(wp) :: pemitlwl = 0.0_wp !< total emitted LW radiation energy in all processors (W)
5362	REAL(wp) :: pemitlw = 0.0_wp !< total emitted LW radiation energy in all processors (W)
5363	REAL(wp) :: pinswl = 0.0_wp !< total received SW radiation energy in local processor (W)
5364	REAL(wp) :: pinsw = 0.0_wp !< total received SW radiation energy in all processor (W)
5365	REAL(wp) :: pinlwl = 0.0_wp !< total received LW radiation energy in local processor (W)
5366	REAL(wp) :: pinlw = 0.0_wp !< total received LW radiation energy in all processor (W)
5367	REAL(wp) :: emiss_sum_surfl !< sum of emissisivity of surfaces in local processor
5368	REAL(wp) :: emiss_sum_surf !< sum of emissisivity of surfaces in all processor
5369	REAL(wp) :: area_surfl !< total area of surfaces in local processor
5370	REAL(wp) :: area_surf !< total area of surfaces in all processor
5371	REAL(wp) :: area_hor !< total horizontal area of domain in all processor
5372	#if defined( __parallel )
5373	REAL(wp), DIMENSION(1:7) :: combine_allreduce !< dummy array used to combine several MPI_ALLREDUCE calls
5374	REAL(wp), DIMENSION(1:7) :: combine_allreduce_l !< dummy array used to combine several MPI_ALLREDUCE calls
5375	#endif
5376
5377	IF ( debug_output_timestep ) CALL debug_message( 'radiation_interaction', 'start' )
5378
5379	IF ( plant_canopy ) THEN
5380	pchf_prep(:) = r_d * exner(nz_urban_b:nz_urban_t) &
5381	/ (c_p * hyp(nz_urban_b:nz_urban_t) * dxdydz(1)) !< equals to 1 / (rho * c_p * Vbox * T)
5382	ENDIF
5383
5384	sun_direction = .TRUE.
5385	CALL calc_zenith !< required also for diffusion radiation
5386
5387	!-- prepare rotated normal vectors and irradiance factor
5388	vnorm(1,:) = kdir(:)
5389	vnorm(2,:) = jdir(:)
5390	vnorm(3,:) = idir(:)
5391	mrot(1, :) = (/ 1._wp, 0._wp, 0._wp /)
5392	mrot(2, :) = (/ 0._wp, COS(alpha), SIN(alpha) /)
5393	mrot(3, :) = (/ 0._wp, -SIN(alpha), COS(alpha) /)
5394	sunorig = (/ cos_zenith, sun_dir_lat, sun_dir_lon /)
5395	sunorig = MATMUL(mrot, sunorig)
5396	DO d = 0, nsurf_type
5397	costheta(d) = DOT_PRODUCT(sunorig, vnorm(:,d))
5398	ENDDO
5399
5400	IF ( cos_zenith > 0 ) THEN
5401	!-- now we will "squash" the sunorig vector by grid box size in
5402	!-- each dimension, so that this new direction vector will allow us
5403	!-- to traverse the ray path within grid coordinates directly
5404	sunorig_grid = (/ sunorig(1)/dz(1), sunorig(2)/dy, sunorig(3)/dx /)
5405	!-- sunorig_grid = sunorig_grid / norm2(sunorig_grid)
5406	sunorig_grid = sunorig_grid / SQRT(SUM(sunorig_grid**2))
5407
5408	IF ( npcbl > 0 ) THEN
5409	!-- precompute effective box depth with prototype Leaf Area Density
5410	pc_box_dimshift = MAXLOC(ABS(sunorig), 1) - 1
5411	CALL box_absorb(CSHIFT((/dz(1),dy,dx/), pc_box_dimshift), &
5412	60, prototype_lad, &
5413	CSHIFT(ABS(sunorig), pc_box_dimshift), &
5414	pc_box_area, pc_abs_frac)
5415	pc_box_area = pc_box_area * ABS(sunorig(pc_box_dimshift+1) &
5416	/ sunorig(1))
5417	pc_abs_eff = LOG(1._wp - pc_abs_frac) / prototype_lad
5418	ENDIF
5419	ENDIF
5420	!
5421	!-- Split downwelling shortwave radiation into a diffuse and a direct part.
5422	!-- Note, if radiation scheme is RRTMG or diffuse radiation is externally
5423	!-- prescribed, this is not required.
5424	IF ( radiation_scheme /= 'rrtmg' .AND. &
5425	.NOT. rad_sw_in_dif_f%from_file ) CALL calc_diffusion_radiation
5426
5427	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5428	!-- First pass: direct + diffuse irradiance + thermal
5429	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5430	surfinswdir = 0._wp !nsurfl
5431	surfins = 0._wp !nsurfl
5432	surfinl = 0._wp !nsurfl
5433	surfoutsl(:) = 0.0_wp !start-end
5434	surfoutll(:) = 0.0_wp !start-end
5435	IF ( nmrtbl > 0 ) THEN
5436	mrtinsw(:) = 0._wp
5437	mrtinlw(:) = 0._wp
5438	ENDIF
5439	surfinlg(:) = 0._wp !global
5440
5441
5442	!-- Set up thermal radiation from surfaces
5443	!-- emiss_surf is defined only for surfaces for which energy balance is calculated
5444	!-- Workaround: reorder surface data type back on 1D array including all surfaces,
5445	!-- which implies to reorder horizontal and vertical surfaces
5446	!
5447	!-- Horizontal walls
5448	mm = 1
5449	DO i = nxl, nxr
5450	DO j = nys, nyn
5451	!-- urban
5452	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
5453	surfoutll(mm) = SUM ( surf_usm_h%frac(:,m) * &
5454	surf_usm_h%emissivity(:,m) ) &
5455	* sigma_sb &
5456	* surf_usm_h%pt_surface(m)**4
5457	albedo_surf(mm) = SUM ( surf_usm_h%frac(:,m) * &
5458	surf_usm_h%albedo(:,m) )
5459	emiss_surf(mm) = SUM ( surf_usm_h%frac(:,m) * &
5460	surf_usm_h%emissivity(:,m) )
5461	mm = mm + 1
5462	ENDDO
5463	!-- land
5464	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
5465	surfoutll(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5466	surf_lsm_h%emissivity(:,m) ) &
5467	* sigma_sb &
5468	* surf_lsm_h%pt_surface(m)**4
5469	albedo_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5470	surf_lsm_h%albedo(:,m) )
5471	emiss_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5472	surf_lsm_h%emissivity(:,m) )
5473	mm = mm + 1
5474	ENDDO
5475	ENDDO
5476	ENDDO
5477	!
5478	!-- Vertical walls
5479	DO i = nxl, nxr
5480	DO j = nys, nyn
5481	DO ll = 0, 3
5482	l = reorder(ll)
5483	!-- urban
5484	DO m = surf_usm_v(l)%start_index(j,i), &
5485	surf_usm_v(l)%end_index(j,i)
5486	surfoutll(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5487	surf_usm_v(l)%emissivity(:,m) ) &
5488	* sigma_sb &
5489	* surf_usm_v(l)%pt_surface(m)**4
5490	albedo_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5491	surf_usm_v(l)%albedo(:,m) )
5492	emiss_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5493	surf_usm_v(l)%emissivity(:,m) )
5494	mm = mm + 1
5495	ENDDO
5496	!-- land
5497	DO m = surf_lsm_v(l)%start_index(j,i), &
5498	surf_lsm_v(l)%end_index(j,i)
5499	surfoutll(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5500	surf_lsm_v(l)%emissivity(:,m) ) &
5501	* sigma_sb &
5502	* surf_lsm_v(l)%pt_surface(m)**4
5503	albedo_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5504	surf_lsm_v(l)%albedo(:,m) )
5505	emiss_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5506	surf_lsm_v(l)%emissivity(:,m) )
5507	mm = mm + 1
5508	ENDDO
5509	ENDDO
5510	ENDDO
5511	ENDDO
5512
5513	#if defined( __parallel )
5514	!-- might be optimized and gather only values relevant for current processor
5515	CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, &
5516	surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) !nsurf global
5517	IF ( ierr /= 0 ) THEN
5518	WRITE(9,*) 'Error MPI_AllGatherv1:', ierr, SIZE(surfoutll), nsurfl, &
5519	SIZE(surfoutl), nsurfs, surfstart
5520	FLUSH(9)
5521	ENDIF
5522	#else
5523	surfoutl(:) = surfoutll(:) !nsurf global
5524	#endif
5525
5526	IF ( surface_reflections) THEN
5527	DO isvf = 1, nsvfl
5528	isurf = svfsurf(1, isvf)
5529	k = surfl(iz, isurf)
5530	j = surfl(iy, isurf)
5531	i = surfl(ix, isurf)
5532	isurfsrc = svfsurf(2, isvf)
5533	!
5534	!-- For surface-to-surface factors we calculate thermal radiation in 1st pass
5535	IF ( plant_lw_interact ) THEN
5536	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc)
5537	ELSE
5538	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)
5539	ENDIF
5540	ENDDO
5541	ENDIF
5542	!
5543	!-- diffuse radiation using sky view factor
5544	DO isurf = 1, nsurfl
5545	j = surfl(iy, isurf)
5546	i = surfl(ix, isurf)
5547	surfinswdif(isurf) = rad_sw_in_diff(j,i) * skyvft(isurf)
5548	IF ( plant_lw_interact ) THEN
5549	surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvft(isurf)
5550	ELSE
5551	surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvf(isurf)
5552	ENDIF
5553	ENDDO
5554	!
5555	!-- MRT diffuse irradiance
5556	DO imrt = 1, nmrtbl
5557	j = mrtbl(iy, imrt)
5558	i = mrtbl(ix, imrt)
5559	mrtinsw(imrt) = mrtskyt(imrt) * rad_sw_in_diff(j,i)
5560	mrtinlw(imrt) = mrtsky(imrt) * rad_lw_in_diff(j,i)
5561	ENDDO
5562
5563	!-- direct radiation
5564	IF ( cos_zenith > 0 ) THEN
5565	!--Identify solar direction vector (discretized number) 1)
5566	!--
5567	j = FLOOR(ACOS(cos_zenith) / pi * raytrace_discrete_elevs)
5568	i = MODULO(NINT(ATAN2(sun_dir_lon, sun_dir_lat) &
5569	/ (2._wppi) raytrace_discrete_azims-.5_wp, iwp), &
5570	raytrace_discrete_azims)
5571	isd = dsidir_rev(j, i)
5572	!-- TODO: check if isd = -1 to report that this solar position is not precalculated
5573	DO isurf = 1, nsurfl
5574	j = surfl(iy, isurf)
5575	i = surfl(ix, isurf)
5576	surfinswdir(isurf) = rad_sw_in_dir(j,i) * &
5577	costheta(surfl(id, isurf)) * dsitrans(isurf, isd) / cos_zenith
5578	ENDDO
5579	!
5580	!-- MRT direct irradiance
5581	DO imrt = 1, nmrtbl
5582	j = mrtbl(iy, imrt)
5583	i = mrtbl(ix, imrt)
5584	mrtinsw(imrt) = mrtinsw(imrt) + mrtdsit(imrt, isd) * rad_sw_in_dir(j,i) &
5585	/ cos_zenith / 4._wp ! normal to sphere
5586	ENDDO
5587	ENDIF
5588	!
5589	!-- MRT first pass thermal
5590	DO imrtf = 1, nmrtf
5591	imrt = mrtfsurf(1, imrtf)
5592	isurfsrc = mrtfsurf(2, imrtf)
5593	mrtinlw(imrt) = mrtinlw(imrt) + mrtf(imrtf) * surfoutl(isurfsrc)
5594	ENDDO
5595	!
5596	!-- Absorption in each local plant canopy grid box from the first atmospheric
5597	!-- pass of radiation
5598	IF ( npcbl > 0 ) THEN
5599
5600	pcbinswdir(:) = 0._wp
5601	pcbinswdif(:) = 0._wp
5602	pcbinlw(:) = 0._wp
5603
5604	DO icsf = 1, ncsfl
5605	ipcgb = csfsurf(1, icsf)
5606	i = pcbl(ix,ipcgb)
5607	j = pcbl(iy,ipcgb)
5608	k = pcbl(iz,ipcgb)
5609	isurfsrc = csfsurf(2, icsf)
5610
5611	IF ( isurfsrc == -1 ) THEN
5612	!
5613	!-- Diffuse radiation from sky
5614	pcbinswdif(ipcgb) = csf(1,icsf) * rad_sw_in_diff(j,i)
5615	!
5616	!-- Absorbed diffuse LW radiation from sky minus emitted to sky
5617	IF ( plant_lw_interact ) THEN
5618	pcbinlw(ipcgb) = csf(1,icsf) &
5619	* (rad_lw_in_diff(j, i) &
5620	- sigma_sb * (pt(k,j,i)exner(k))*4)
5621	ENDIF
5622	!
5623	!-- Direct solar radiation
5624	IF ( cos_zenith > 0 ) THEN
5625	!-- Estimate directed box absorption
5626	pc_abs_frac = 1._wp - exp(pc_abs_eff * lad_s(k,j,i))
5627	!
5628	!-- isd has already been established, see 1)
5629	pcbinswdir(ipcgb) = rad_sw_in_dir(j, i) * pc_box_area &
5630	* pc_abs_frac * dsitransc(ipcgb, isd)
5631	ENDIF
5632	ELSE
5633	IF ( plant_lw_interact ) THEN
5634	!
5635	!-- Thermal emission from plan canopy towards respective face
5636	pcrad = sigma_sb * (pt(k,j,i) * exner(k))*4 csf(1,icsf)
5637	surfinlg(isurfsrc) = surfinlg(isurfsrc) + pcrad
5638	!
5639	!-- Remove the flux above + absorb LW from first pass from surfaces
5640	asrc = facearea(surf(id, isurfsrc))
5641	pcbinlw(ipcgb) = pcbinlw(ipcgb) &
5642	+ (csf(1,icsf) * surfoutl(isurfsrc) & ! Absorb from first pass surf emit
5643	- pcrad) & ! Remove emitted heatflux
5644	* asrc
5645	ENDIF
5646	ENDIF
5647	ENDDO
5648
5649	pcbinsw(:) = pcbinswdir(:) + pcbinswdif(:)
5650	ENDIF
5651
5652	IF ( plant_lw_interact ) THEN
5653	!
5654	!-- Exchange incoming lw radiation from plant canopy
5655	#if defined( __parallel )
5656	CALL MPI_Allreduce(MPI_IN_PLACE, surfinlg, nsurf, MPI_REAL, MPI_SUM, comm2d, ierr)
5657	IF ( ierr /= 0 ) THEN
5658	WRITE (9,*) 'Error MPI_Allreduce:', ierr
5659	FLUSH(9)
5660	ENDIF
5661	surfinl(:) = surfinl(:) + surfinlg(surfstart(myid)+1:surfstart(myid+1))
5662	#else
5663	surfinl(:) = surfinl(:) + surfinlg(:)
5664	#endif
5665	ENDIF
5666
5667	surfins = surfinswdir + surfinswdif
5668	surfinl = surfinl + surfinlwdif
5669	surfinsw = surfins
5670	surfinlw = surfinl
5671	surfoutsw = 0.0_wp
5672	surfoutlw = surfoutll
5673	surfemitlwl = surfoutll
5674
5675	IF ( .NOT. surface_reflections ) THEN
5676	!
5677	!-- Set nrefsteps to 0 to disable reflections
5678	nrefsteps = 0
5679	surfoutsl = albedo_surf * surfins
5680	surfoutll = (1._wp - emiss_surf) * surfinl
5681	surfoutsw = surfoutsw + surfoutsl
5682	surfoutlw = surfoutlw + surfoutll
5683	ENDIF
5684
5685	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5686	!-- Next passes - reflections
5687	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5688	DO refstep = 1, nrefsteps
5689
5690	surfoutsl = albedo_surf * surfins
5691	!
5692	!-- for non-transparent surfaces, longwave albedo is 1 - emissivity
5693	surfoutll = (1._wp - emiss_surf) * surfinl
5694
5695	#if defined( __parallel )
5696	CALL MPI_AllGatherv(surfoutsl, nsurfl, MPI_REAL, &
5697	surfouts, nsurfs, surfstart, MPI_REAL, comm2d, ierr)
5698	IF ( ierr /= 0 ) THEN
5699	WRITE(9,*) 'Error MPI_AllGatherv2:', ierr, SIZE(surfoutsl), nsurfl, &
5700	SIZE(surfouts), nsurfs, surfstart
5701	FLUSH(9)
5702	ENDIF
5703
5704	CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, &
5705	surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr)
5706	IF ( ierr /= 0 ) THEN
5707	WRITE(9,*) 'Error MPI_AllGatherv3:', ierr, SIZE(surfoutll), nsurfl, &
5708	SIZE(surfoutl), nsurfs, surfstart
5709	FLUSH(9)
5710	ENDIF
5711
5712	#else
5713	surfouts = surfoutsl
5714	surfoutl = surfoutll
5715	#endif
5716	!
5717	!-- Reset for the input from next reflective pass
5718	surfins = 0._wp
5719	surfinl = 0._wp
5720	!
5721	!-- Reflected radiation
5722	DO isvf = 1, nsvfl
5723	isurf = svfsurf(1, isvf)
5724	isurfsrc = svfsurf(2, isvf)
5725	surfins(isurf) = surfins(isurf) + svf(1,isvf) * svf(2,isvf) * surfouts(isurfsrc)
5726	IF ( plant_lw_interact ) THEN
5727	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc)
5728	ELSE
5729	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)
5730	ENDIF
5731	ENDDO
5732	!
5733	!-- NOTE: PC absorbtion and MRT from reflected can both be done at once
5734	!-- after all reflections if we do one more MPI_ALLGATHERV on surfout.
5735	!-- Advantage: less local computation. Disadvantage: one more collective
5736	!-- MPI call.
5737	!
5738	!-- Radiation absorbed by plant canopy
5739	DO icsf = 1, ncsfl
5740	ipcgb = csfsurf(1, icsf)
5741	isurfsrc = csfsurf(2, icsf)
5742	IF ( isurfsrc == -1 ) CYCLE ! sky->face only in 1st pass, not here
5743	!
5744	!-- Calculate source surface area. If the `surf' array is removed
5745	!-- before timestepping starts (future version), then asrc must be
5746	!-- stored within `csf'
5747	asrc = facearea(surf(id, isurfsrc))
5748	pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * surfouts(isurfsrc) * asrc
5749	IF ( plant_lw_interact ) THEN
5750	pcbinlw(ipcgb) = pcbinlw(ipcgb) + csf(1,icsf) * surfoutl(isurfsrc) * asrc
5751	ENDIF
5752	ENDDO
5753	!
5754	!-- MRT reflected
5755	DO imrtf = 1, nmrtf
5756	imrt = mrtfsurf(1, imrtf)
5757	isurfsrc = mrtfsurf(2, imrtf)
5758	mrtinsw(imrt) = mrtinsw(imrt) + mrtft(imrtf) * surfouts(isurfsrc)
5759	mrtinlw(imrt) = mrtinlw(imrt) + mrtf(imrtf) * surfoutl(isurfsrc)
5760	ENDDO
5761
5762	surfinsw = surfinsw + surfins
5763	surfinlw = surfinlw + surfinl
5764	surfoutsw = surfoutsw + surfoutsl
5765	surfoutlw = surfoutlw + surfoutll
5766
5767	ENDDO ! refstep
5768
5769	!-- push heat flux absorbed by plant canopy to respective 3D arrays
5770	IF ( npcbl > 0 ) THEN
5771	pc_heating_rate(:,:,:) = 0.0_wp
5772	DO ipcgb = 1, npcbl
5773	j = pcbl(iy, ipcgb)
5774	i = pcbl(ix, ipcgb)
5775	k = pcbl(iz, ipcgb)
5776	!
5777	!-- Following expression equals former kk = k - nzb_s_inner(j,i)
5778	kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat
5779	pc_heating_rate(kk, j, i) = (pcbinsw(ipcgb) + pcbinlw(ipcgb)) &
5780	* pchf_prep(k) * pt(k, j, i) !-- = dT/dt
5781	ENDDO
5782
5783	IF ( humidity .AND. plant_canopy_transpiration ) THEN
5784	!-- Calculation of plant canopy transpiration rate and correspondidng latent heat rate
5785	pc_transpiration_rate(:,:,:) = 0.0_wp
5786	pc_latent_rate(:,:,:) = 0.0_wp
5787	DO ipcgb = 1, npcbl
5788	i = pcbl(ix, ipcgb)
5789	j = pcbl(iy, ipcgb)
5790	k = pcbl(iz, ipcgb)
5791	kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat
5792	CALL pcm_calc_transpiration_rate( i, j, k, kk, pcbinsw(ipcgb), pcbinlw(ipcgb), &
5793	pc_transpiration_rate(kk,j,i), pc_latent_rate(kk,j,i) )
5794	ENDDO
5795	ENDIF
5796	ENDIF
5797	!
5798	!-- Calculate black body MRT (after all reflections)
5799	IF ( nmrtbl > 0 ) THEN
5800	IF ( mrt_include_sw ) THEN
5801	mrt(:) = ((mrtinsw(:) + mrtinlw(:)) / sigma_sb) ** .25_wp
5802	ELSE
5803	mrt(:) = (mrtinlw(:) / sigma_sb) ** .25_wp
5804	ENDIF
5805	ENDIF
5806	!
5807	!-- Transfer radiation arrays required for energy balance to the respective data types
5808	DO i = 1, nsurfl
5809	m = surfl(im,i)
5810	!
5811	!-- (1) Urban surfaces
5812	!-- upward-facing
5813	IF ( surfl(1,i) == iup_u ) THEN
5814	surf_usm_h%rad_sw_in(m) = surfinsw(i)
5815	surf_usm_h%rad_sw_out(m) = surfoutsw(i)
5816	surf_usm_h%rad_sw_dir(m) = surfinswdir(i)
5817	surf_usm_h%rad_sw_dif(m) = surfinswdif(i)
5818	surf_usm_h%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5819	surfinswdif(i)
5820	surf_usm_h%rad_sw_res(m) = surfins(i)
5821	surf_usm_h%rad_lw_in(m) = surfinlw(i)
5822	surf_usm_h%rad_lw_out(m) = surfoutlw(i)
5823	surf_usm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5824	surfinlw(i) - surfoutlw(i)
5825	surf_usm_h%rad_net_l(m) = surf_usm_h%rad_net(m)
5826	surf_usm_h%rad_lw_dif(m) = surfinlwdif(i)
5827	surf_usm_h%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5828	surf_usm_h%rad_lw_res(m) = surfinl(i)
5829	!
5830	!-- northward-facding
5831	ELSEIF ( surfl(1,i) == inorth_u ) THEN
5832	surf_usm_v(0)%rad_sw_in(m) = surfinsw(i)
5833	surf_usm_v(0)%rad_sw_out(m) = surfoutsw(i)
5834	surf_usm_v(0)%rad_sw_dir(m) = surfinswdir(i)
5835	surf_usm_v(0)%rad_sw_dif(m) = surfinswdif(i)
5836	surf_usm_v(0)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5837	surfinswdif(i)
5838	surf_usm_v(0)%rad_sw_res(m) = surfins(i)
5839	surf_usm_v(0)%rad_lw_in(m) = surfinlw(i)
5840	surf_usm_v(0)%rad_lw_out(m) = surfoutlw(i)
5841	surf_usm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5842	surfinlw(i) - surfoutlw(i)
5843	surf_usm_v(0)%rad_net_l(m) = surf_usm_v(0)%rad_net(m)
5844	surf_usm_v(0)%rad_lw_dif(m) = surfinlwdif(i)
5845	surf_usm_v(0)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5846	surf_usm_v(0)%rad_lw_res(m) = surfinl(i)
5847	!
5848	!-- southward-facding
5849	ELSEIF ( surfl(1,i) == isouth_u ) THEN
5850	surf_usm_v(1)%rad_sw_in(m) = surfinsw(i)
5851	surf_usm_v(1)%rad_sw_out(m) = surfoutsw(i)
5852	surf_usm_v(1)%rad_sw_dir(m) = surfinswdir(i)
5853	surf_usm_v(1)%rad_sw_dif(m) = surfinswdif(i)
5854	surf_usm_v(1)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5855	surfinswdif(i)
5856	surf_usm_v(1)%rad_sw_res(m) = surfins(i)
5857	surf_usm_v(1)%rad_lw_in(m) = surfinlw(i)
5858	surf_usm_v(1)%rad_lw_out(m) = surfoutlw(i)
5859	surf_usm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5860	surfinlw(i) - surfoutlw(i)
5861	surf_usm_v(1)%rad_net_l(m) = surf_usm_v(1)%rad_net(m)
5862	surf_usm_v(1)%rad_lw_dif(m) = surfinlwdif(i)
5863	surf_usm_v(1)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5864	surf_usm_v(1)%rad_lw_res(m) = surfinl(i)
5865	!
5866	!-- eastward-facing
5867	ELSEIF ( surfl(1,i) == ieast_u ) THEN
5868	surf_usm_v(2)%rad_sw_in(m) = surfinsw(i)
5869	surf_usm_v(2)%rad_sw_out(m) = surfoutsw(i)
5870	surf_usm_v(2)%rad_sw_dir(m) = surfinswdir(i)
5871	surf_usm_v(2)%rad_sw_dif(m) = surfinswdif(i)
5872	surf_usm_v(2)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5873	surfinswdif(i)
5874	surf_usm_v(2)%rad_sw_res(m) = surfins(i)
5875	surf_usm_v(2)%rad_lw_in(m) = surfinlw(i)
5876	surf_usm_v(2)%rad_lw_out(m) = surfoutlw(i)
5877	surf_usm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5878	surfinlw(i) - surfoutlw(i)
5879	surf_usm_v(2)%rad_net_l(m) = surf_usm_v(2)%rad_net(m)
5880	surf_usm_v(2)%rad_lw_dif(m) = surfinlwdif(i)
5881	surf_usm_v(2)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5882	surf_usm_v(2)%rad_lw_res(m) = surfinl(i)
5883	!
5884	!-- westward-facding
5885	ELSEIF ( surfl(1,i) == iwest_u ) THEN
5886	surf_usm_v(3)%rad_sw_in(m) = surfinsw(i)
5887	surf_usm_v(3)%rad_sw_out(m) = surfoutsw(i)
5888	surf_usm_v(3)%rad_sw_dir(m) = surfinswdir(i)
5889	surf_usm_v(3)%rad_sw_dif(m) = surfinswdif(i)
5890	surf_usm_v(3)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5891	surfinswdif(i)
5892	surf_usm_v(3)%rad_sw_res(m) = surfins(i)
5893	surf_usm_v(3)%rad_lw_in(m) = surfinlw(i)
5894	surf_usm_v(3)%rad_lw_out(m) = surfoutlw(i)
5895	surf_usm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5896	surfinlw(i) - surfoutlw(i)
5897	surf_usm_v(3)%rad_net_l(m) = surf_usm_v(3)%rad_net(m)
5898	surf_usm_v(3)%rad_lw_dif(m) = surfinlwdif(i)
5899	surf_usm_v(3)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5900	surf_usm_v(3)%rad_lw_res(m) = surfinl(i)
5901	!
5902	!-- (2) land surfaces
5903	!-- upward-facing
5904	ELSEIF ( surfl(1,i) == iup_l ) THEN
5905	surf_lsm_h%rad_sw_in(m) = surfinsw(i)
5906	surf_lsm_h%rad_sw_out(m) = surfoutsw(i)
5907	surf_lsm_h%rad_sw_dir(m) = surfinswdir(i)
5908	surf_lsm_h%rad_sw_dif(m) = surfinswdif(i)
5909	surf_lsm_h%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5910	surfinswdif(i)
5911	surf_lsm_h%rad_sw_res(m) = surfins(i)
5912	surf_lsm_h%rad_lw_in(m) = surfinlw(i)
5913	surf_lsm_h%rad_lw_out(m) = surfoutlw(i)
5914	surf_lsm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5915	surfinlw(i) - surfoutlw(i)
5916	surf_lsm_h%rad_lw_dif(m) = surfinlwdif(i)
5917	surf_lsm_h%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5918	surf_lsm_h%rad_lw_res(m) = surfinl(i)
5919	!
5920	!-- northward-facding
5921	ELSEIF ( surfl(1,i) == inorth_l ) THEN
5922	surf_lsm_v(0)%rad_sw_in(m) = surfinsw(i)
5923	surf_lsm_v(0)%rad_sw_out(m) = surfoutsw(i)
5924	surf_lsm_v(0)%rad_sw_dir(m) = surfinswdir(i)
5925	surf_lsm_v(0)%rad_sw_dif(m) = surfinswdif(i)
5926	surf_lsm_v(0)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5927	surfinswdif(i)
5928	surf_lsm_v(0)%rad_sw_res(m) = surfins(i)
5929	surf_lsm_v(0)%rad_lw_in(m) = surfinlw(i)
5930	surf_lsm_v(0)%rad_lw_out(m) = surfoutlw(i)
5931	surf_lsm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5932	surfinlw(i) - surfoutlw(i)
5933	surf_lsm_v(0)%rad_lw_dif(m) = surfinlwdif(i)
5934	surf_lsm_v(0)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5935	surf_lsm_v(0)%rad_lw_res(m) = surfinl(i)
5936	!
5937	!-- southward-facding
5938	ELSEIF ( surfl(1,i) == isouth_l ) THEN
5939	surf_lsm_v(1)%rad_sw_in(m) = surfinsw(i)
5940	surf_lsm_v(1)%rad_sw_out(m) = surfoutsw(i)
5941	surf_lsm_v(1)%rad_sw_dir(m) = surfinswdir(i)
5942	surf_lsm_v(1)%rad_sw_dif(m) = surfinswdif(i)
5943	surf_lsm_v(1)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5944	surfinswdif(i)
5945	surf_lsm_v(1)%rad_sw_res(m) = surfins(i)
5946	surf_lsm_v(1)%rad_lw_in(m) = surfinlw(i)
5947	surf_lsm_v(1)%rad_lw_out(m) = surfoutlw(i)
5948	surf_lsm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5949	surfinlw(i) - surfoutlw(i)
5950	surf_lsm_v(1)%rad_lw_dif(m) = surfinlwdif(i)
5951	surf_lsm_v(1)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5952	surf_lsm_v(1)%rad_lw_res(m) = surfinl(i)
5953	!
5954	!-- eastward-facing
5955	ELSEIF ( surfl(1,i) == ieast_l ) THEN
5956	surf_lsm_v(2)%rad_sw_in(m) = surfinsw(i)
5957	surf_lsm_v(2)%rad_sw_out(m) = surfoutsw(i)
5958	surf_lsm_v(2)%rad_sw_dir(m) = surfinswdir(i)
5959	surf_lsm_v(2)%rad_sw_dif(m) = surfinswdif(i)
5960	surf_lsm_v(2)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5961	surfinswdif(i)
5962	surf_lsm_v(2)%rad_sw_res(m) = surfins(i)
5963	surf_lsm_v(2)%rad_lw_in(m) = surfinlw(i)
5964	surf_lsm_v(2)%rad_lw_out(m) = surfoutlw(i)
5965	surf_lsm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5966	surfinlw(i) - surfoutlw(i)
5967	surf_lsm_v(2)%rad_lw_dif(m) = surfinlwdif(i)
5968	surf_lsm_v(2)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5969	surf_lsm_v(2)%rad_lw_res(m) = surfinl(i)
5970	!
5971	!-- westward-facing
5972	ELSEIF ( surfl(1,i) == iwest_l ) THEN
5973	surf_lsm_v(3)%rad_sw_in(m) = surfinsw(i)
5974	surf_lsm_v(3)%rad_sw_out(m) = surfoutsw(i)
5975	surf_lsm_v(3)%rad_sw_dir(m) = surfinswdir(i)
5976	surf_lsm_v(3)%rad_sw_dif(m) = surfinswdif(i)
5977	surf_lsm_v(3)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - &
5978	surfinswdif(i)
5979	surf_lsm_v(3)%rad_sw_res(m) = surfins(i)
5980	surf_lsm_v(3)%rad_lw_in(m) = surfinlw(i)
5981	surf_lsm_v(3)%rad_lw_out(m) = surfoutlw(i)
5982	surf_lsm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5983	surfinlw(i) - surfoutlw(i)
5984	surf_lsm_v(3)%rad_lw_dif(m) = surfinlwdif(i)
5985	surf_lsm_v(3)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
5986	surf_lsm_v(3)%rad_lw_res(m) = surfinl(i)
5987	ENDIF
5988
5989	ENDDO
5990
5991	DO m = 1, surf_usm_h%ns
5992	surf_usm_h%surfhf(m) = surf_usm_h%rad_sw_in(m) + &
5993	surf_usm_h%rad_lw_in(m) - &
5994	surf_usm_h%rad_sw_out(m) - &
5995	surf_usm_h%rad_lw_out(m)
5996	ENDDO
5997	DO m = 1, surf_lsm_h%ns
5998	surf_lsm_h%surfhf(m) = surf_lsm_h%rad_sw_in(m) + &
5999	surf_lsm_h%rad_lw_in(m) - &
6000	surf_lsm_h%rad_sw_out(m) - &
6001	surf_lsm_h%rad_lw_out(m)
6002	ENDDO
6003
6004	DO l = 0, 3
6005	!-- urban
6006	DO m = 1, surf_usm_v(l)%ns
6007	surf_usm_v(l)%surfhf(m) = surf_usm_v(l)%rad_sw_in(m) + &
6008	surf_usm_v(l)%rad_lw_in(m) - &
6009	surf_usm_v(l)%rad_sw_out(m) - &
6010	surf_usm_v(l)%rad_lw_out(m)
6011	ENDDO
6012	!-- land
6013	DO m = 1, surf_lsm_v(l)%ns
6014	surf_lsm_v(l)%surfhf(m) = surf_lsm_v(l)%rad_sw_in(m) + &
6015	surf_lsm_v(l)%rad_lw_in(m) - &
6016	surf_lsm_v(l)%rad_sw_out(m) - &
6017	surf_lsm_v(l)%rad_lw_out(m)
6018
6019	ENDDO
6020	ENDDO
6021	!
6022	!-- Calculate the average temperature, albedo, and emissivity for urban/land
6023	!-- domain when using average_radiation in the respective radiation model
6024
6025	!-- calculate horizontal area
6026	! !!! ATTENTION!!! uniform grid is assumed here
6027	area_hor = (nx+1) * (ny+1) * dx * dy
6028	!
6029	!-- absorbed/received SW & LW and emitted LW energy of all physical
6030	!-- surfaces (land and urban) in local processor
6031	pinswl = 0._wp
6032	pinlwl = 0._wp
6033	pabsswl = 0._wp
6034	pabslwl = 0._wp
6035	pemitlwl = 0._wp
6036	emiss_sum_surfl = 0._wp
6037	area_surfl = 0._wp
6038	DO i = 1, nsurfl
6039	d = surfl(id, i)
6040	!-- received SW & LW
6041	pinswl = pinswl + (surfinswdir(i) + surfinswdif(i)) * facearea(d)
6042	pinlwl = pinlwl + surfinlwdif(i) * facearea(d)
6043	!-- absorbed SW & LW
6044	pabsswl = pabsswl + (1._wp - albedo_surf(i)) * &
6045	surfinsw(i) * facearea(d)
6046	pabslwl = pabslwl + emiss_surf(i) * surfinlw(i) * facearea(d)
6047	!-- emitted LW
6048	pemitlwl = pemitlwl + surfemitlwl(i) * facearea(d)
6049	!-- emissivity and area sum
6050	emiss_sum_surfl = emiss_sum_surfl + emiss_surf(i) * facearea(d)
6051	area_surfl = area_surfl + facearea(d)
6052	END DO
6053	!
6054	!-- add the absorbed SW energy by plant canopy
6055	IF ( npcbl > 0 ) THEN
6056	pabsswl = pabsswl + SUM(pcbinsw)
6057	pabslwl = pabslwl + SUM(pcbinlw)
6058	pinswl = pinswl + SUM(pcbinswdir) + SUM(pcbinswdif)
6059	ENDIF
6060	!
6061	!-- gather all rad flux energy in all processors. In order to reduce
6062	!-- the number of MPI calls (to reduce latencies), combine the required
6063	!-- quantities in one array, sum it up, and subsequently re-distribute
6064	!-- back to the respective quantities.
6065	#if defined( __parallel )
6066	combine_allreduce_l(1) = pinswl
6067	combine_allreduce_l(2) = pinlwl
6068	combine_allreduce_l(3) = pabsswl
6069	combine_allreduce_l(4) = pabslwl
6070	combine_allreduce_l(5) = pemitlwl
6071	combine_allreduce_l(6) = emiss_sum_surfl
6072	combine_allreduce_l(7) = area_surfl
6073
6074	CALL MPI_ALLREDUCE( combine_allreduce_l, &
6075	combine_allreduce, &
6076	SIZE( combine_allreduce ), &
6077	MPI_REAL, &
6078	MPI_SUM, &
6079	comm2d, &
6080	ierr )
6081
6082	pinsw = combine_allreduce(1)
6083	pinlw = combine_allreduce(2)
6084	pabssw = combine_allreduce(3)
6085	pabslw = combine_allreduce(4)
6086	pemitlw = combine_allreduce(5)
6087	emiss_sum_surf = combine_allreduce(6)
6088	area_surf = combine_allreduce(7)
6089	#else
6090	pinsw = pinswl
6091	pinlw = pinlwl
6092	pabssw = pabsswl
6093	pabslw = pabslwl
6094	pemitlw = pemitlwl
6095	emiss_sum_surf = emiss_sum_surfl
6096	area_surf = area_surfl
6097	#endif
6098
6099	!-- (1) albedo
6100	IF ( pinsw /= 0.0_wp ) albedo_urb = ( pinsw - pabssw ) / pinsw
6101	!-- (2) average emmsivity
6102	IF ( area_surf /= 0.0_wp ) emissivity_urb = emiss_sum_surf / area_surf
6103	!
6104	!-- Temporally comment out calculation of effective radiative temperature.
6105	!-- See below for more explanation.
6106	!-- (3) temperature
6107	!-- first we calculate an effective horizontal area to account for
6108	!-- the effect of vertical surfaces (which contributes to LW emission)
6109	!-- We simply use the ratio of the total LW to the incoming LW flux
6110	area_hor = pinlw / rad_lw_in_diff(nyn,nxl)
6111	t_rad_urb = ( ( pemitlw - pabslw + emissivity_urb * pinlw ) / &
6112	(emissivity_urb * sigma_sb * area_hor) )**0.25_wp
6113
6114	IF ( debug_output_timestep ) CALL debug_message( 'radiation_interaction', 'end' )
6115
6116
6117	CONTAINS
6118
6119	!------------------------------------------------------------------------------!
6120	!> Calculates radiation absorbed by box with given size and LAD.
6121	!>
6122	!> Simulates resol**2 rays (by equally spacing a bounding horizontal square
6123	!> conatining all possible rays that would cross the box) and calculates
6124	!> average transparency per ray. Returns fraction of absorbed radiation flux
6125	!> and area for which this fraction is effective.
6126	!------------------------------------------------------------------------------!
6127	PURE SUBROUTINE box_absorb(boxsize, resol, dens, uvec, area, absorb)
6128	IMPLICIT NONE
6129
6130	REAL(wp), DIMENSION(3), INTENT(in) :: &
6131	boxsize, & !< z, y, x size of box in m
6132	uvec !< z, y, x unit vector of incoming flux
6133	INTEGER(iwp), INTENT(in) :: &
6134	resol !< No. of rays in x and y dimensions
6135	REAL(wp), INTENT(in) :: &
6136	dens !< box density (e.g. Leaf Area Density)
6137	REAL(wp), INTENT(out) :: &
6138	area, & !< horizontal area for flux absorbtion
6139	absorb !< fraction of absorbed flux
6140	REAL(wp) :: &
6141	xshift, yshift, &
6142	xmin, xmax, ymin, ymax, &
6143	xorig, yorig, &
6144	dx1, dy1, dz1, dx2, dy2, dz2, &
6145	crdist, &
6146	transp
6147	INTEGER(iwp) :: &
6148	i, j
6149
6150	xshift = uvec(3) / uvec(1) * boxsize(1)
6151	xmin = min(0._wp, -xshift)
6152	xmax = boxsize(3) + max(0._wp, -xshift)
6153	yshift = uvec(2) / uvec(1) * boxsize(1)
6154	ymin = min(0._wp, -yshift)
6155	ymax = boxsize(2) + max(0._wp, -yshift)
6156
6157	transp = 0._wp
6158	DO i = 1, resol
6159	xorig = xmin + (xmax-xmin) * (i-.5_wp) / resol
6160	DO j = 1, resol
6161	yorig = ymin + (ymax-ymin) * (j-.5_wp) / resol
6162
6163	dz1 = 0._wp
6164	dz2 = boxsize(1)/uvec(1)
6165
6166	IF ( uvec(2) > 0._wp ) THEN
6167	dy1 = -yorig / uvec(2) !< crossing with y=0
6168	dy2 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2)
6169	ELSE !uvec(2)==0
6170	dy1 = -huge(1._wp)
6171	dy2 = huge(1._wp)
6172	ENDIF
6173
6174	IF ( uvec(3) > 0._wp ) THEN
6175	dx1 = -xorig / uvec(3) !< crossing with x=0
6176	dx2 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3)
6177	ELSE !uvec(3)==0
6178	dx1 = -huge(1._wp)
6179	dx2 = huge(1._wp)
6180	ENDIF
6181
6182	crdist = max(0._wp, (min(dz2, dy2, dx2) - max(dz1, dy1, dx1)))
6183	transp = transp + exp(-ext_coef * dens * crdist)
6184	ENDDO
6185	ENDDO
6186	transp = transp / resol**2
6187	area = (boxsize(3)+xshift)*(boxsize(2)+yshift)
6188	absorb = 1._wp - transp
6189
6190	END SUBROUTINE box_absorb
6191
6192	!------------------------------------------------------------------------------!
6193	! Description:
6194	! ------------
6195	!> This subroutine splits direct and diffusion dw radiation
6196	!> It sould not be called in case the radiation model already does it
6197	!> It follows Boland, Ridley & Brown (2008)
6198	!------------------------------------------------------------------------------!
6199	SUBROUTINE calc_diffusion_radiation
6200
6201	INTEGER(iwp) :: i !< grid index x-direction
6202	INTEGER(iwp) :: j !< grid index y-direction
6203
6204	REAL(wp) :: year_angle !< angle
6205	REAL(wp) :: etr !< extraterestrial radiation
6206	REAL(wp) :: corrected_solarUp !< corrected solar up radiation
6207	REAL(wp) :: horizontalETR !< horizontal extraterestrial radiation
6208	REAL(wp) :: clearnessIndex !< clearness index
6209	REAL(wp) :: diff_frac !< diffusion fraction of the radiation
6210
6211	REAL(wp), PARAMETER :: lowest_solarUp = 0.1_wp !< limit the sun elevation to protect stability of the calculation
6212	!
6213	!-- Calculate current day and time based on the initial values and simulation time
6214	year_angle = ( (day_of_year_init * 86400) + time_utc_init &
6215	+ time_since_reference_point ) * d_seconds_year &
6216	* 2.0_wp * pi
6217
6218	etr = solar_constant * (1.00011_wp + &
6219	0.034221_wp * cos(year_angle) + &
6220	0.001280_wp * sin(year_angle) + &
6221	0.000719_wp * cos(2.0_wp * year_angle) + &
6222	0.000077_wp * sin(2.0_wp * year_angle))
6223	!
6224	!--
6225	!-- Under a very low angle, we keep extraterestrial radiation at
6226	!-- the last small value, therefore the clearness index will be pushed
6227	!-- towards 0 while keeping full continuity.
6228	IF ( cos_zenith <= lowest_solarUp ) THEN
6229	corrected_solarUp = lowest_solarUp
6230	ELSE
6231	corrected_solarUp = cos_zenith
6232	ENDIF
6233
6234	horizontalETR = etr * corrected_solarUp
6235
6236	DO i = nxl, nxr
6237	DO j = nys, nyn
6238	clearnessIndex = rad_sw_in(0,j,i) / horizontalETR
6239	diff_frac = 1.0_wp / (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex))
6240	rad_sw_in_diff(j,i) = rad_sw_in(0,j,i) * diff_frac
6241	rad_sw_in_dir(j,i) = rad_sw_in(0,j,i) * (1.0_wp - diff_frac)
6242	rad_lw_in_diff(j,i) = rad_lw_in(0,j,i)
6243	ENDDO
6244	ENDDO
6245
6246	END SUBROUTINE calc_diffusion_radiation
6247
6248	END SUBROUTINE radiation_interaction
6249
6250	!------------------------------------------------------------------------------!
6251	! Description:
6252	! ------------
6253	!> This subroutine initializes structures needed for radiative transfer
6254	!> model. This model calculates transformation processes of the
6255	!> radiation inside urban and land canopy layer. The module includes also
6256	!> the interaction of the radiation with the resolved plant canopy.
6257	!>
6258	!> For more info. see Resler et al. 2017
6259	!>
6260	!> The new version 2.0 was radically rewriten, the discretization scheme
6261	!> has been changed. This new version significantly improves effectivity
6262	!> of the paralelization and the scalability of the model.
6263	!>
6264	!------------------------------------------------------------------------------!
6265	SUBROUTINE radiation_interaction_init
6266
6267	USE control_parameters, &
6268	ONLY: dz_stretch_level_start
6269
6270	USE plant_canopy_model_mod, &
6271	ONLY: lad_s
6272
6273	IMPLICIT NONE
6274
6275	INTEGER(iwp) :: i, j, k, l, m, d
6276	INTEGER(iwp) :: k_topo !< vertical index indicating topography top for given (j,i)
6277	INTEGER(iwp) :: nzptl, nzubl, nzutl, isurf, ipcgb, imrt
6278	REAL(wp) :: mrl
6279	#if defined( __parallel )
6280	INTEGER(iwp), DIMENSION(:), POINTER, SAVE :: gridsurf_rma !< fortran pointer, but lower bounds are 1
6281	TYPE(c_ptr) :: gridsurf_rma_p !< allocated c pointer
6282	INTEGER(iwp) :: minfo !< MPI RMA window info handle
6283	#endif
6284
6285	!
6286	!-- precalculate face areas for different face directions using normal vector
6287	DO d = 0, nsurf_type
6288	facearea(d) = 1._wp
6289	IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx
6290	IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy
6291	IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz(1)
6292	ENDDO
6293	!
6294	!-- Find nz_urban_b, nz_urban_t, nz_urban via wall_flag_0 array (nzb_s_inner will be
6295	!-- removed later). The following contruct finds the lowest / largest index
6296	!-- for any upward-facing wall (see bit 12).
6297	nzubl = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
6298	nzutl = MAXVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
6299
6300	nzubl = MAX( nzubl, nzb )
6301
6302	IF ( plant_canopy ) THEN
6303	!-- allocate needed arrays
6304	ALLOCATE( pct(nys:nyn,nxl:nxr) )
6305	ALLOCATE( pch(nys:nyn,nxl:nxr) )
6306
6307	!-- calculate plant canopy height
6308	npcbl = 0
6309	pct = 0
6310	pch = 0
6311	DO i = nxl, nxr
6312	DO j = nys, nyn
6313	!
6314	!-- Find topography top index
6315	k_topo = topo_top_ind(j,i,0)
6316
6317	DO k = nzt+1, 0, -1
6318	IF ( lad_s(k,j,i) /= 0.0_wp ) THEN
6319	!-- we are at the top of the pcs
6320	pct(j,i) = k + k_topo
6321	pch(j,i) = k
6322	npcbl = npcbl + pch(j,i)
6323	EXIT
6324	ENDIF
6325	ENDDO
6326	ENDDO
6327	ENDDO
6328
6329	nzutl = MAX( nzutl, MAXVAL( pct ) )
6330	nzptl = MAXVAL( pct )
6331
6332	prototype_lad = MAXVAL( lad_s ) * .9_wp !< better be *1.0 if lad is either 0 or maxval(lad) everywhere
6333	IF ( prototype_lad <= 0._wp ) prototype_lad = .3_wp
6334	!WRITE(message_string, '(a,f6.3)') 'Precomputing effective box optical ' &
6335	! // 'depth using prototype leaf area density = ', prototype_lad
6336	!CALL message('radiation_interaction_init', 'PA0520', 0, 0, -1, 6, 0)
6337	ENDIF
6338
6339	nzutl = MIN( nzutl + nzut_free, nzt )
6340
6341	#if defined( __parallel )
6342	CALL MPI_AllReduce(nzubl, nz_urban_b, 1, MPI_INTEGER, MPI_MIN, comm2d, ierr )
6343	IF ( ierr /= 0 ) THEN
6344	WRITE(9,*) 'Error MPI_AllReduce11:', ierr, nzubl, nz_urban_b
6345	FLUSH(9)
6346	ENDIF
6347	CALL MPI_AllReduce(nzutl, nz_urban_t, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr )
6348	IF ( ierr /= 0 ) THEN
6349	WRITE(9,*) 'Error MPI_AllReduce12:', ierr, nzutl, nz_urban_t
6350	FLUSH(9)
6351	ENDIF
6352	CALL MPI_AllReduce(nzptl, nz_plant_t, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr )
6353	IF ( ierr /= 0 ) THEN
6354	WRITE(9,*) 'Error MPI_AllReduce13:', ierr, nzptl, nz_plant_t
6355	FLUSH(9)
6356	ENDIF
6357	#else
6358	nz_urban_b = nzubl
6359	nz_urban_t = nzutl
6360	nz_plant_t = nzptl
6361	#endif
6362	!
6363	!-- Stretching (non-uniform grid spacing) is not considered in the radiation
6364	!-- model. Therefore, vertical stretching has to be applied above the area
6365	!-- where the parts of the radiation model which assume constant grid spacing
6366	!-- are active. ABS (...) is required because the default value of
6367	!-- dz_stretch_level_start is -9999999.9_wp (negative).
6368	IF ( ABS( dz_stretch_level_start(1) ) <= zw(nz_urban_t) ) THEN
6369	WRITE( message_string, * ) 'The lowest level where vertical ', &
6370	'stretching is applied have to be ', &
6371	'greater than ', zw(nz_urban_t)
6372	CALL message( 'radiation_interaction_init', 'PA0496', 1, 2, 0, 6, 0 )
6373	ENDIF
6374	!
6375	!-- global number of urban and plant layers
6376	nz_urban = nz_urban_t - nz_urban_b + 1
6377	nz_plant = nz_plant_t - nz_urban_b + 1
6378	!
6379	!-- check max_raytracing_dist relative to urban surface layer height
6380	mrl = 2.0_wp * nz_urban * dz(1)
6381	!-- set max_raytracing_dist to double the urban surface layer height, if not set
6382	IF ( max_raytracing_dist == -999.0_wp ) THEN
6383	max_raytracing_dist = mrl
6384	ENDIF
6385	!-- check if max_raytracing_dist set too low (here we only warn the user. Other
6386	! option is to correct the value again to double the urban surface layer height)
6387	IF ( max_raytracing_dist < mrl ) THEN
6388	WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist is set less than ' // &
6389	'double the urban surface layer height, i.e. ', mrl
6390	CALL message('radiation_interaction_init', 'PA0521', 0, 0, 0, 6, 0 )
6391	ENDIF
6392	! IF ( max_raytracing_dist <= mrl ) THEN
6393	! IF ( max_raytracing_dist /= -999.0_wp ) THEN
6394	! !-- max_raytracing_dist too low
6395	! WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist too low, ' &
6396	! // 'override to value ', mrl
6397	! CALL message('radiation_interaction_init', 'PA0521', 0, 0, -1, 6, 0)
6398	! ENDIF
6399	! max_raytracing_dist = mrl
6400	! ENDIF
6401	!
6402	!-- allocate urban surfaces grid
6403	!-- calc number of surfaces in local proc
6404	IF ( debug_output ) CALL debug_message( 'calculation of indices for surfaces', 'info' )
6405
6406	nsurfl = 0
6407	!
6408	!-- Number of horizontal surfaces including land- and roof surfaces in both USM and LSM. Note that
6409	!-- All horizontal surface elements are already counted in surface_mod.
6410	startland = 1
6411	nsurfl = surf_usm_h%ns + surf_lsm_h%ns
6412	endland = nsurfl
6413	nlands = endland - startland + 1
6414
6415	!
6416	!-- Number of vertical surfaces in both USM and LSM. Note that all vertical surface elements are
6417	!-- already counted in surface_mod.
6418	startwall = nsurfl+1
6419	DO i = 0,3
6420	nsurfl = nsurfl + surf_usm_v(i)%ns + surf_lsm_v(i)%ns
6421	ENDDO
6422	endwall = nsurfl
6423	nwalls = endwall - startwall + 1
6424	dirstart = (/ startland, startwall, startwall, startwall, startwall /)
6425	dirend = (/ endland, endwall, endwall, endwall, endwall /)
6426
6427	!-- fill gridpcbl and pcbl
6428	IF ( npcbl > 0 ) THEN
6429	ALLOCATE( pcbl(iz:ix, 1:npcbl) )
6430	ALLOCATE( gridpcbl(nz_urban_b:nz_plant_t,nys:nyn,nxl:nxr) )
6431	pcbl = -1
6432	gridpcbl(:,:,:) = 0
6433	ipcgb = 0
6434	DO i = nxl, nxr
6435	DO j = nys, nyn
6436	!
6437	!-- Find topography top index
6438	k_topo = topo_top_ind(j,i,0)
6439
6440	DO k = k_topo + 1, pct(j,i)
6441	ipcgb = ipcgb + 1
6442	gridpcbl(k,j,i) = ipcgb
6443	pcbl(:,ipcgb) = (/ k, j, i /)
6444	ENDDO
6445	ENDDO
6446	ENDDO
6447	ALLOCATE( pcbinsw( 1:npcbl ) )
6448	ALLOCATE( pcbinswdir( 1:npcbl ) )
6449	ALLOCATE( pcbinswdif( 1:npcbl ) )
6450	ALLOCATE( pcbinlw( 1:npcbl ) )
6451	ENDIF
6452
6453	!
6454	!-- Fill surfl (the ordering of local surfaces given by the following
6455	!-- cycles must not be altered, certain file input routines may depend
6456	!-- on it).
6457	!
6458	!-- We allocate the array as linear and then use a two-dimensional pointer
6459	!-- into it, because some MPI implementations crash with 2D-allocated arrays.
6460	ALLOCATE(surfl_linear(nidx_surf*nsurfl))
6461	surfl(1:nidx_surf,1:nsurfl) => surfl_linear(1:nidx_surf*nsurfl)
6462	isurf = 0
6463	IF ( rad_angular_discretization ) THEN
6464	!
6465	!-- Allocate and fill the reverse indexing array gridsurf
6466	#if defined( __parallel )
6467	!
6468	!-- raytrace_mpi_rma is asserted
6469
6470	CALL MPI_Info_create(minfo, ierr)
6471	IF ( ierr /= 0 ) THEN
6472	WRITE(9,*) 'Error MPI_Info_create1:', ierr
6473	FLUSH(9)
6474	ENDIF
6475	CALL MPI_Info_set(minfo, 'accumulate_ordering', 'none', ierr)
6476	IF ( ierr /= 0 ) THEN
6477	WRITE(9,*) 'Error MPI_Info_set1:', ierr
6478	FLUSH(9)
6479	ENDIF
6480	CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr)
6481	IF ( ierr /= 0 ) THEN
6482	WRITE(9,*) 'Error MPI_Info_set2:', ierr
6483	FLUSH(9)
6484	ENDIF
6485	CALL MPI_Info_set(minfo, 'same_size', 'true', ierr)
6486	IF ( ierr /= 0 ) THEN
6487	WRITE(9,*) 'Error MPI_Info_set3:', ierr
6488	FLUSH(9)
6489	ENDIF
6490	CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr)
6491	IF ( ierr /= 0 ) THEN
6492	WRITE(9,*) 'Error MPI_Info_set4:', ierr
6493	FLUSH(9)
6494	ENDIF
6495
6496	CALL MPI_Win_allocate(INT(STORAGE_SIZE(1_iwp)/8nsurf_type_unz_urbannnynnx, &
6497	kind=MPI_ADDRESS_KIND), STORAGE_SIZE(1_iwp)/8, &
6498	minfo, comm2d, gridsurf_rma_p, win_gridsurf, ierr)
6499	IF ( ierr /= 0 ) THEN
6500	WRITE(9,*) 'Error MPI_Win_allocate1:', ierr, &
6501	INT(STORAGE_SIZE(1_iwp)/8nsurf_type_unz_urbannnynnx,kind=MPI_ADDRESS_KIND), &
6502	STORAGE_SIZE(1_iwp)/8, win_gridsurf
6503	FLUSH(9)
6504	ENDIF
6505
6506	CALL MPI_Info_free(minfo, ierr)
6507	IF ( ierr /= 0 ) THEN
6508	WRITE(9,*) 'Error MPI_Info_free1:', ierr
6509	FLUSH(9)
6510	ENDIF
6511
6512	!
6513	!-- On Intel compilers, calling c_f_pointer to transform a C pointer
6514	!-- directly to a multi-dimensional Fotran pointer leads to strange
6515	!-- errors on dimension boundaries. However, transforming to a 1D
6516	!-- pointer and then redirecting a multidimensional pointer to it works
6517	!-- fine.
6518	CALL c_f_pointer(gridsurf_rma_p, gridsurf_rma, (/ nsurf_type_unz_urbannny*nnx /))
6519	gridsurf(0:nsurf_type_u-1, nz_urban_b:nz_urban_t, nys:nyn, nxl:nxr) => &
6520	gridsurf_rma(1:nsurf_type_unz_urbannny*nnx)
6521	#else
6522	ALLOCATE(gridsurf(0:nsurf_type_u-1,nz_urban_b:nz_urban_t,nys:nyn,nxl:nxr) )
6523	#endif
6524	gridsurf(:,:,:,:) = -999
6525	ENDIF
6526
6527	!-- add horizontal surface elements (land and urban surfaces)
6528	!-- TODO: add urban overhanging surfaces (idown_u)
6529	DO i = nxl, nxr
6530	DO j = nys, nyn
6531	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
6532	k = surf_usm_h%k(m)
6533	isurf = isurf + 1
6534	surfl(:,isurf) = (/iup_u,k,j,i,m/)
6535	IF ( rad_angular_discretization ) THEN
6536	gridsurf(iup_u,k,j,i) = isurf
6537	ENDIF
6538	ENDDO
6539
6540	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
6541	k = surf_lsm_h%k(m)
6542	isurf = isurf + 1
6543	surfl(:,isurf) = (/iup_l,k,j,i,m/)
6544	IF ( rad_angular_discretization ) THEN
6545	gridsurf(iup_u,k,j,i) = isurf
6546	ENDIF
6547	ENDDO
6548
6549	ENDDO
6550	ENDDO
6551
6552	!-- add vertical surface elements (land and urban surfaces)
6553	!-- TODO: remove the hard coding of l = 0 to l = idirection
6554	DO i = nxl, nxr
6555	DO j = nys, nyn
6556	l = 0
6557	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6558	k = surf_usm_v(l)%k(m)
6559	isurf = isurf + 1
6560	surfl(:,isurf) = (/inorth_u,k,j,i,m/)
6561	IF ( rad_angular_discretization ) THEN
6562	gridsurf(inorth_u,k,j,i) = isurf
6563	ENDIF
6564	ENDDO
6565	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6566	k = surf_lsm_v(l)%k(m)
6567	isurf = isurf + 1
6568	surfl(:,isurf) = (/inorth_l,k,j,i,m/)
6569	IF ( rad_angular_discretization ) THEN
6570	gridsurf(inorth_u,k,j,i) = isurf
6571	ENDIF
6572	ENDDO
6573
6574	l = 1
6575	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6576	k = surf_usm_v(l)%k(m)
6577	isurf = isurf + 1
6578	surfl(:,isurf) = (/isouth_u,k,j,i,m/)
6579	IF ( rad_angular_discretization ) THEN
6580	gridsurf(isouth_u,k,j,i) = isurf
6581	ENDIF
6582	ENDDO
6583	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6584	k = surf_lsm_v(l)%k(m)
6585	isurf = isurf + 1
6586	surfl(:,isurf) = (/isouth_l,k,j,i,m/)
6587	IF ( rad_angular_discretization ) THEN
6588	gridsurf(isouth_u,k,j,i) = isurf
6589	ENDIF
6590	ENDDO
6591
6592	l = 2
6593	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6594	k = surf_usm_v(l)%k(m)
6595	isurf = isurf + 1
6596	surfl(:,isurf) = (/ieast_u,k,j,i,m/)
6597	IF ( rad_angular_discretization ) THEN
6598	gridsurf(ieast_u,k,j,i) = isurf
6599	ENDIF
6600	ENDDO
6601	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6602	k = surf_lsm_v(l)%k(m)
6603	isurf = isurf + 1
6604	surfl(:,isurf) = (/ieast_l,k,j,i,m/)
6605	IF ( rad_angular_discretization ) THEN
6606	gridsurf(ieast_u,k,j,i) = isurf
6607	ENDIF
6608	ENDDO
6609
6610	l = 3
6611	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6612	k = surf_usm_v(l)%k(m)
6613	isurf = isurf + 1
6614	surfl(:,isurf) = (/iwest_u,k,j,i,m/)
6615	IF ( rad_angular_discretization ) THEN
6616	gridsurf(iwest_u,k,j,i) = isurf
6617	ENDIF
6618	ENDDO
6619	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6620	k = surf_lsm_v(l)%k(m)
6621	isurf = isurf + 1
6622	surfl(:,isurf) = (/iwest_l,k,j,i,m/)
6623	IF ( rad_angular_discretization ) THEN
6624	gridsurf(iwest_u,k,j,i) = isurf
6625	ENDIF
6626	ENDDO
6627	ENDDO
6628	ENDDO
6629	!
6630	!-- Add local MRT boxes for specified number of levels
6631	nmrtbl = 0
6632	IF ( mrt_nlevels > 0 ) THEN
6633	DO i = nxl, nxr
6634	DO j = nys, nyn
6635	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
6636	!
6637	!-- Skip roof if requested
6638	IF ( mrt_skip_roof .AND. surf_usm_h%isroof_surf(m) ) CYCLE
6639	!
6640	!-- Cycle over specified no of levels
6641	nmrtbl = nmrtbl + mrt_nlevels
6642	ENDDO
6643	!
6644	!-- Dtto for LSM
6645	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
6646	nmrtbl = nmrtbl + mrt_nlevels
6647	ENDDO
6648	ENDDO
6649	ENDDO
6650
6651	ALLOCATE( mrtbl(iz:ix,nmrtbl), mrtsky(nmrtbl), mrtskyt(nmrtbl), &
6652	mrtinsw(nmrtbl), mrtinlw(nmrtbl), mrt(nmrtbl) )
6653
6654	imrt = 0
6655	DO i = nxl, nxr
6656	DO j = nys, nyn
6657	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
6658	!
6659	!-- Skip roof if requested
6660	IF ( mrt_skip_roof .AND. surf_usm_h%isroof_surf(m) ) CYCLE
6661	!
6662	!-- Cycle over specified no of levels
6663	l = surf_usm_h%k(m)
6664	DO k = l, l + mrt_nlevels - 1
6665	imrt = imrt + 1
6666	mrtbl(:,imrt) = (/k,j,i/)
6667	ENDDO
6668	ENDDO
6669	!
6670	!-- Dtto for LSM
6671	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
6672	l = surf_lsm_h%k(m)
6673	DO k = l, l + mrt_nlevels - 1
6674	imrt = imrt + 1
6675	mrtbl(:,imrt) = (/k,j,i/)
6676	ENDDO
6677	ENDDO
6678	ENDDO
6679	ENDDO
6680	ENDIF
6681
6682	!
6683	!-- broadband albedo of the land, roof and wall surface
6684	!-- for domain border and sky set artifically to 1.0
6685	!-- what allows us to calculate heat flux leaving over
6686	!-- side and top borders of the domain
6687	ALLOCATE ( albedo_surf(nsurfl) )
6688	albedo_surf = 1.0_wp
6689	!
6690	!-- Also allocate further array for emissivity with identical order of
6691	!-- surface elements as radiation arrays.
6692	ALLOCATE ( emiss_surf(nsurfl) )
6693
6694
6695	!
6696	!-- global array surf of indices of surfaces and displacement index array surfstart
6697	ALLOCATE(nsurfs(0:numprocs-1))
6698
6699	#if defined( __parallel )
6700	CALL MPI_Allgather(nsurfl,1,MPI_INTEGER,nsurfs,1,MPI_INTEGER,comm2d,ierr)
6701	IF ( ierr /= 0 ) THEN
6702	WRITE(9,*) 'Error MPI_AllGather1:', ierr, nsurfl, nsurfs
6703	FLUSH(9)
6704	ENDIF
6705
6706	#else
6707	nsurfs(0) = nsurfl
6708	#endif
6709	ALLOCATE(surfstart(0:numprocs))
6710	k = 0
6711	DO i=0,numprocs-1
6712	surfstart(i) = k
6713	k = k+nsurfs(i)
6714	ENDDO
6715	surfstart(numprocs) = k
6716	nsurf = k
6717	!
6718	!-- We allocate the array as linear and then use a two-dimensional pointer
6719	!-- into it, because some MPI implementations crash with 2D-allocated arrays.
6720	ALLOCATE(surf_linear(nidx_surf*nsurf))
6721	surf(1:nidx_surf,1:nsurf) => surf_linear(1:nidx_surf*nsurf)
6722
6723	#if defined( __parallel )
6724	CALL MPI_AllGatherv(surfl_linear, nsurfl*nidx_surf, MPI_INTEGER, &
6725	surf_linear, nsurfs*nidx_surf, &
6726	surfstart(0:numprocs-1)*nidx_surf, MPI_INTEGER, &
6727	comm2d, ierr)
6728	IF ( ierr /= 0 ) THEN
6729	WRITE(9,*) 'Error MPI_AllGatherv4:', ierr, SIZE(surfl_linear), &
6730	nsurflnidx_surf, SIZE(surf_linear), nsurfsnidx_surf, &
6731	surfstart(0:numprocs-1)*nidx_surf
6732	FLUSH(9)
6733	ENDIF
6734	#else
6735	surf = surfl
6736	#endif
6737
6738	!--
6739	!-- allocation of the arrays for direct and diffusion radiation
6740	IF ( debug_output ) CALL debug_message( 'allocation of radiation arrays', 'info' )
6741	!-- rad_sw_in, rad_lw_in are computed in radiation model,
6742	!-- splitting of direct and diffusion part is done
6743	!-- in calc_diffusion_radiation for now
6744
6745	ALLOCATE( rad_sw_in_dir(nysg:nyng,nxlg:nxrg) )
6746	ALLOCATE( rad_sw_in_diff(nysg:nyng,nxlg:nxrg) )
6747	ALLOCATE( rad_lw_in_diff(nysg:nyng,nxlg:nxrg) )
6748	rad_sw_in_dir = 0.0_wp
6749	rad_sw_in_diff = 0.0_wp
6750	rad_lw_in_diff = 0.0_wp
6751
6752	!-- allocate radiation arrays
6753	ALLOCATE( surfins(nsurfl) )
6754	ALLOCATE( surfinl(nsurfl) )
6755	ALLOCATE( surfinsw(nsurfl) )
6756	ALLOCATE( surfinlw(nsurfl) )
6757	ALLOCATE( surfinswdir(nsurfl) )
6758	ALLOCATE( surfinswdif(nsurfl) )
6759	ALLOCATE( surfinlwdif(nsurfl) )
6760	ALLOCATE( surfoutsl(nsurfl) )
6761	ALLOCATE( surfoutll(nsurfl) )
6762	ALLOCATE( surfoutsw(nsurfl) )
6763	ALLOCATE( surfoutlw(nsurfl) )
6764	ALLOCATE( surfouts(nsurf) )
6765	ALLOCATE( surfoutl(nsurf) )
6766	ALLOCATE( surfinlg(nsurf) )
6767	ALLOCATE( skyvf(nsurfl) )
6768	ALLOCATE( skyvft(nsurfl) )
6769	ALLOCATE( surfemitlwl(nsurfl) )
6770
6771	!
6772	!-- In case of average_radiation, aggregated surface albedo and emissivity,
6773	!-- also set initial value for t_rad_urb.
6774	!-- For now set an arbitrary initial value.
6775	IF ( average_radiation ) THEN
6776	albedo_urb = 0.1_wp
6777	emissivity_urb = 0.9_wp
6778	t_rad_urb = pt_surface
6779	ENDIF
6780
6781	END SUBROUTINE radiation_interaction_init
6782
6783	!------------------------------------------------------------------------------!
6784	! Description:
6785	! ------------
6786	!> Calculates shape view factors (SVF), plant sink canopy factors (PCSF),
6787	!> sky-view factors, discretized path for direct solar radiation, MRT factors
6788	!> and other preprocessed data needed for radiation_interaction.
6789	!------------------------------------------------------------------------------!
6790	SUBROUTINE radiation_calc_svf
6791
6792	IMPLICIT NONE
6793
6794	INTEGER(iwp) :: i, j, k, d, ip, jp
6795	INTEGER(iwp) :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrt, imrtf, ipcgb
6796	INTEGER(iwp) :: sd, td
6797	INTEGER(iwp) :: iaz, izn !< azimuth, zenith counters
6798	INTEGER(iwp) :: naz, nzn !< azimuth, zenith num of steps
6799	REAL(wp) :: az0, zn0 !< starting azimuth/zenith
6800	REAL(wp) :: azs, zns !< azimuth/zenith cycle step
6801	REAL(wp) :: az1, az2 !< relative azimuth of section borders
6802	REAL(wp) :: azmid !< ray (center) azimuth
6803	REAL(wp) :: yxlen !< \|yxdir\|
6804	REAL(wp), DIMENSION(2) :: yxdir !< y,x unit vector of ray direction (in grid units)
6805	REAL(wp), DIMENSION(:), ALLOCATABLE :: zdirs !< directions in z (tangent of elevation)
6806	REAL(wp), DIMENSION(:), ALLOCATABLE :: zcent !< zenith angle centers
6807	REAL(wp), DIMENSION(:), ALLOCATABLE :: zbdry !< zenith angle boundaries
6808	REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac !< view factor fractions for individual rays
6809	REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac0 !< dtto (original values)
6810	REAL(wp), DIMENSION(:), ALLOCATABLE :: ztransp !< array of transparency in z steps
6811	INTEGER(iwp) :: lowest_free_ray !< index into zdirs
6812	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: itarget !< face indices of detected obstacles
6813	INTEGER(iwp) :: itarg0, itarg1
6814
6815	INTEGER(iwp) :: udim
6816	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: nzterrl_l
6817	INTEGER(iwp), DIMENSION(:,:), POINTER :: nzterrl
6818	REAL(wp), DIMENSION(:), ALLOCATABLE,TARGET:: csflt_l, pcsflt_l
6819	REAL(wp), DIMENSION(:,:), POINTER :: csflt, pcsflt
6820	INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: kcsflt_l,kpcsflt_l
6821	INTEGER(iwp), DIMENSION(:,:), POINTER :: kcsflt,kpcsflt
6822	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: icsflt,dcsflt,ipcsflt,dpcsflt
6823	REAL(wp), DIMENSION(3) :: uv
6824	LOGICAL :: visible
6825	REAL(wp), DIMENSION(3) :: sa, ta !< real coordinates z,y,x of source and target
6826	REAL(wp) :: difvf !< differential view factor
6827	REAL(wp) :: transparency, rirrf, sqdist, svfsum
6828	INTEGER(iwp) :: isurflt, isurfs, isurflt_prev
6829	INTEGER(idp) :: ray_skip_maxdist, ray_skip_minval !< skipped raytracing counts
6830	INTEGER(iwp) :: max_track_len !< maximum 2d track length
6831	INTEGER(iwp) :: minfo
6832	REAL(wp), DIMENSION(:), POINTER, SAVE :: lad_s_rma !< fortran 1D pointer
6833	TYPE(c_ptr) :: lad_s_rma_p !< allocated c pointer
6834	#if defined( __parallel )
6835	INTEGER(kind=MPI_ADDRESS_KIND) :: size_lad_rma
6836	#endif
6837	!
6838	INTEGER(iwp), DIMENSION(0:svfnorm_report_num) :: svfnorm_counts
6839
6840
6841	!-- calculation of the SVF
6842	CALL location_message( 'calculating view factors for radiation interaction', 'start' )
6843
6844	!-- initialize variables and temporary arrays for calculation of svf and csf
6845	nsvfl = 0
6846	ncsfl = 0
6847	nsvfla = gasize
6848	msvf = 1
6849	ALLOCATE( asvf1(nsvfla) )
6850	asvf => asvf1
6851	IF ( plant_canopy ) THEN
6852	ncsfla = gasize
6853	mcsf = 1
6854	ALLOCATE( acsf1(ncsfla) )
6855	acsf => acsf1
6856	ENDIF
6857	nmrtf = 0
6858	IF ( mrt_nlevels > 0 ) THEN
6859	nmrtfa = gasize
6860	mmrtf = 1
6861	ALLOCATE ( amrtf1(nmrtfa) )
6862	amrtf => amrtf1
6863	ENDIF
6864	ray_skip_maxdist = 0
6865	ray_skip_minval = 0
6866
6867	!-- initialize temporary terrain and plant canopy height arrays (global 2D array!)
6868	ALLOCATE( nzterr(0:(nx+1)*(ny+1)-1) )
6869	#if defined( __parallel )
6870	!ALLOCATE( nzterrl(nys:nyn,nxl:nxr) )
6871	ALLOCATE( nzterrl_l((nyn-nys+1)*(nxr-nxl+1)) )
6872	nzterrl(nys:nyn,nxl:nxr) => nzterrl_l(1:(nyn-nys+1)*(nxr-nxl+1))
6873	nzterrl = topo_top_ind(nys:nyn,nxl:nxr,0)
6874	CALL MPI_AllGather( nzterrl_l, nnx*nny, MPI_INTEGER, &
6875	nzterr, nnx*nny, MPI_INTEGER, comm2d, ierr )
6876	IF ( ierr /= 0 ) THEN
6877	WRITE(9,) 'Error MPI_AllGather1:', ierr, SIZE(nzterrl_l), nnxnny, &
6878	SIZE(nzterr), nnx*nny
6879	FLUSH(9)
6880	ENDIF
6881	DEALLOCATE(nzterrl_l)
6882	#else
6883	nzterr = RESHAPE( topo_top_ind(nys:nyn,nxl:nxr,0), (/(nx+1)*(ny+1)/) )
6884	#endif
6885	IF ( plant_canopy ) THEN
6886	ALLOCATE( plantt(0:(nx+1)*(ny+1)-1) )
6887	maxboxesg = nx + ny + nz_plant + 1
6888	max_track_len = nx + ny + 1
6889	!-- temporary arrays storing values for csf calculation during raytracing
6890	ALLOCATE( boxes(3, maxboxesg) )
6891	ALLOCATE( crlens(maxboxesg) )
6892
6893	#if defined( __parallel )
6894	CALL MPI_AllGather( pct, nnx*nny, MPI_INTEGER, &
6895	plantt, nnx*nny, MPI_INTEGER, comm2d, ierr )
6896	IF ( ierr /= 0 ) THEN
6897	WRITE(9,) 'Error MPI_AllGather2:', ierr, SIZE(pct), nnxnny, &
6898	SIZE(plantt), nnx*nny
6899	FLUSH(9)
6900	ENDIF
6901
6902	!-- temporary arrays storing values for csf calculation during raytracing
6903	ALLOCATE( lad_ip(maxboxesg) )
6904	ALLOCATE( lad_disp(maxboxesg) )
6905
6906	IF ( raytrace_mpi_rma ) THEN
6907	ALLOCATE( lad_s_ray(maxboxesg) )
6908
6909	! set conditions for RMA communication
6910	CALL MPI_Info_create(minfo, ierr)
6911	IF ( ierr /= 0 ) THEN
6912	WRITE(9,*) 'Error MPI_Info_create2:', ierr
6913	FLUSH(9)
6914	ENDIF
6915	CALL MPI_Info_set(minfo, 'accumulate_ordering', 'none', ierr)
6916	IF ( ierr /= 0 ) THEN
6917	WRITE(9,*) 'Error MPI_Info_set5:', ierr
6918	FLUSH(9)
6919	ENDIF
6920	CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr)
6921	IF ( ierr /= 0 ) THEN
6922	WRITE(9,*) 'Error MPI_Info_set6:', ierr
6923	FLUSH(9)
6924	ENDIF
6925	CALL MPI_Info_set(minfo, 'same_size', 'true', ierr)
6926	IF ( ierr /= 0 ) THEN
6927	WRITE(9,*) 'Error MPI_Info_set7:', ierr
6928	FLUSH(9)
6929	ENDIF
6930	CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr)
6931	IF ( ierr /= 0 ) THEN
6932	WRITE(9,*) 'Error MPI_Info_set8:', ierr
6933	FLUSH(9)
6934	ENDIF
6935
6936	!-- Allocate and initialize the MPI RMA window
6937	!-- must be in accordance with allocation of lad_s in plant_canopy_model
6938	!-- optimization of memory should be done
6939	!-- Argument X of function STORAGE_SIZE(X) needs arbitrary REAL(wp) value, set to 1.0_wp for now
6940	size_lad_rma = STORAGE_SIZE(1.0_wp)/8nnxnny*nz_plant
6941	CALL MPI_Win_allocate(size_lad_rma, STORAGE_SIZE(1.0_wp)/8, minfo, comm2d, &
6942	lad_s_rma_p, win_lad, ierr)
6943	IF ( ierr /= 0 ) THEN
6944	WRITE(9,*) 'Error MPI_Win_allocate2:', ierr, size_lad_rma, &
6945	STORAGE_SIZE(1.0_wp)/8, win_lad
6946	FLUSH(9)
6947	ENDIF
6948	CALL c_f_pointer(lad_s_rma_p, lad_s_rma, (/ nz_plantnnynnx /))
6949	sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr) => lad_s_rma(1:nz_plantnnynnx)
6950	ELSE
6951	ALLOCATE(sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr))
6952	ENDIF
6953	#else
6954	plantt = RESHAPE( pct(nys:nyn,nxl:nxr), (/(nx+1)*(ny+1)/) )
6955	ALLOCATE(sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr))
6956	#endif
6957	plantt_max = MAXVAL(plantt)
6958	ALLOCATE( rt2_track(2, max_track_len), rt2_track_lad(nz_urban_b:plantt_max, max_track_len), &
6959	rt2_track_dist(0:max_track_len), rt2_dist(plantt_max-nz_urban_b+2) )
6960
6961	sub_lad(:,:,:) = 0._wp
6962	DO i = nxl, nxr
6963	DO j = nys, nyn
6964	k = topo_top_ind(j,i,0)
6965
6966	sub_lad(k:nz_plant_t, j, i) = lad_s(0:nz_plant_t-k, j, i)
6967	ENDDO
6968	ENDDO
6969
6970	#if defined( __parallel )
6971	IF ( raytrace_mpi_rma ) THEN
6972	CALL MPI_Info_free(minfo, ierr)
6973	IF ( ierr /= 0 ) THEN
6974	WRITE(9,*) 'Error MPI_Info_free2:', ierr
6975	FLUSH(9)
6976	ENDIF
6977	CALL MPI_Win_lock_all(0, win_lad, ierr)
6978	IF ( ierr /= 0 ) THEN
6979	WRITE(9,*) 'Error MPI_Win_lock_all1:', ierr, win_lad
6980	FLUSH(9)
6981	ENDIF
6982
6983	ELSE
6984	ALLOCATE( sub_lad_g(0:(nx+1)(ny+1)nz_plant-1) )
6985	CALL MPI_AllGather( sub_lad, nnxnnynz_plant, MPI_REAL, &
6986	sub_lad_g, nnxnnynz_plant, MPI_REAL, comm2d, ierr )
6987	IF ( ierr /= 0 ) THEN
6988	WRITE(9,*) 'Error MPI_AllGather3:', ierr, SIZE(sub_lad), &
6989	nnxnnynz_plant, SIZE(sub_lad_g), nnxnnynz_plant
6990	FLUSH(9)
6991	ENDIF
6992	ENDIF
6993	#endif
6994	ENDIF
6995
6996	!-- prepare the MPI_Win for collecting the surface indices
6997	!-- from the reverse index arrays gridsurf from processors of target surfaces
6998	#if defined( __parallel )
6999	IF ( rad_angular_discretization ) THEN
7000	!
7001	!-- raytrace_mpi_rma is asserted
7002	CALL MPI_Win_lock_all(0, win_gridsurf, ierr)
7003	IF ( ierr /= 0 ) THEN
7004	WRITE(9,*) 'Error MPI_Win_lock_all2:', ierr, win_gridsurf
7005	FLUSH(9)
7006	ENDIF
7007	ENDIF
7008	#endif
7009
7010
7011	!--Directions opposite to face normals are not even calculated,
7012	!--they must be preset to 0
7013	!--
7014	dsitrans(:,:) = 0._wp
7015
7016	DO isurflt = 1, nsurfl
7017	!-- determine face centers
7018	td = surfl(id, isurflt)
7019	ta = (/ REAL(surfl(iz, isurflt), wp) - 0.5_wp * kdir(td), &
7020	REAL(surfl(iy, isurflt), wp) - 0.5_wp * jdir(td), &
7021	REAL(surfl(ix, isurflt), wp) - 0.5_wp * idir(td) /)
7022
7023	!--Calculate sky view factor and raytrace DSI paths
7024	skyvf(isurflt) = 0._wp
7025	skyvft(isurflt) = 0._wp
7026
7027	!--Select a proper half-sphere for 2D raytracing
7028	SELECT CASE ( td )
7029	CASE ( iup_u, iup_l )
7030	az0 = 0._wp
7031	naz = raytrace_discrete_azims
7032	azs = 2._wp * pi / REAL(naz, wp)
7033	zn0 = 0._wp
7034	nzn = raytrace_discrete_elevs / 2
7035	zns = pi / 2._wp / REAL(nzn, wp)
7036	CASE ( isouth_u, isouth_l )
7037	az0 = pi / 2._wp
7038	naz = raytrace_discrete_azims / 2
7039	azs = pi / REAL(naz, wp)
7040	zn0 = 0._wp
7041	nzn = raytrace_discrete_elevs
7042	zns = pi / REAL(nzn, wp)
7043	CASE ( inorth_u, inorth_l )
7044	az0 = - pi / 2._wp
7045	naz = raytrace_discrete_azims / 2
7046	azs = pi / REAL(naz, wp)
7047	zn0 = 0._wp
7048	nzn = raytrace_discrete_elevs
7049	zns = pi / REAL(nzn, wp)
7050	CASE ( iwest_u, iwest_l )
7051	az0 = pi
7052	naz = raytrace_discrete_azims / 2
7053	azs = pi / REAL(naz, wp)
7054	zn0 = 0._wp
7055	nzn = raytrace_discrete_elevs
7056	zns = pi / REAL(nzn, wp)
7057	CASE ( ieast_u, ieast_l )
7058	az0 = 0._wp
7059	naz = raytrace_discrete_azims / 2
7060	azs = pi / REAL(naz, wp)
7061	zn0 = 0._wp
7062	nzn = raytrace_discrete_elevs
7063	zns = pi / REAL(nzn, wp)
7064	CASE DEFAULT
7065	WRITE(message_string, *) 'ERROR: the surface type ', td, &
7066	' is not supported for calculating',&
7067	' SVF'
7068	CALL message( 'radiation_calc_svf', 'PA0488', 1, 2, 0, 6, 0 )
7069	END SELECT
7070
7071	ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), &
7072	ztransp(1:nznnaz), itarget(1:nznnaz) ) !FIXME allocate itarget only
7073	!in case of rad_angular_discretization
7074
7075	itarg0 = 1
7076	itarg1 = nzn
7077	zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7078	zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/)
7079	IF ( td == iup_u .OR. td == iup_l ) THEN
7080	vffrac(1:nzn) = (COS(2 * zbdry(0:nzn-1)) - COS(2 * zbdry(1:nzn))) / 2._wp / REAL(naz, wp)
7081	!
7082	!-- For horizontal target, vf fractions are constant per azimuth
7083	DO iaz = 1, naz-1
7084	vffrac(iaznzn+1:(iaz+1)nzn) = vffrac(1:nzn)
7085	ENDDO
7086	!-- sum of whole vffrac equals 1, verified
7087	ENDIF
7088	!
7089	!-- Calculate sky-view factor and direct solar visibility using 2D raytracing
7090	DO iaz = 1, naz
7091	azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7092	IF ( td /= iup_u .AND. td /= iup_l ) THEN
7093	az2 = REAL(iaz, wp) * azs - pi/2._wp
7094	az1 = az2 - azs
7095	!TODO precalculate after 1st line
7096	vffrac(itarg0:itarg1) = (SIN(az2) - SIN(az1)) &
7097	* (zbdry(1:nzn) - zbdry(0:nzn-1) &
7098	+ SIN(zbdry(0:nzn-1))*COS(zbdry(0:nzn-1)) &
7099	- SIN(zbdry(1:nzn))*COS(zbdry(1:nzn))) &
7100	/ (2._wp * pi)
7101	!-- sum of whole vffrac equals 1, verified
7102	ENDIF
7103	yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7104	yxlen = SQRT(SUM(yxdir(:)**2))
7105	zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7106	yxdir(:) = yxdir(:) / yxlen
7107
7108	CALL raytrace_2d(ta, yxdir, nzn, zdirs, &
7109	surfstart(myid) + isurflt, facearea(td), &
7110	vffrac(itarg0:itarg1), .TRUE., .TRUE., &
7111	.FALSE., lowest_free_ray, &
7112	ztransp(itarg0:itarg1), &
7113	itarget(itarg0:itarg1))
7114
7115	skyvf(isurflt) = skyvf(isurflt) + &
7116	SUM(vffrac(itarg0:itarg0+lowest_free_ray-1))
7117	skyvft(isurflt) = skyvft(isurflt) + &
7118	SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) &
7119	* vffrac(itarg0:itarg0+lowest_free_ray-1))
7120
7121	!-- Save direct solar transparency
7122	j = MODULO(NINT(azmid/ &
7123	(2._wppi)raytrace_discrete_azims-.5_wp, iwp), &
7124	raytrace_discrete_azims)
7125
7126	DO k = 1, raytrace_discrete_elevs/2
7127	i = dsidir_rev(k-1, j)
7128	IF ( i /= -1 .AND. k <= lowest_free_ray ) &
7129	dsitrans(isurflt, i) = ztransp(itarg0+k-1)
7130	ENDDO
7131
7132	!
7133	!-- Advance itarget indices
7134	itarg0 = itarg1 + 1
7135	itarg1 = itarg1 + nzn
7136	ENDDO
7137
7138	IF ( rad_angular_discretization ) THEN
7139	!-- sort itarget by face id
7140	CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz)
7141	!
7142	!-- For aggregation, we need fractions multiplied by transmissivities
7143	ztransp(:) = vffrac(:) * ztransp(:)
7144	!
7145	!-- find the first valid position
7146	itarg0 = 1
7147	DO WHILE ( itarg0 <= nzn*naz )
7148	IF ( itarget(itarg0) /= -1 ) EXIT
7149	itarg0 = itarg0 + 1
7150	ENDDO
7151
7152	DO i = itarg0, nzn*naz
7153	!
7154	!-- For duplicate values, only sum up vf fraction value
7155	IF ( i < nzn*naz ) THEN
7156	IF ( itarget(i+1) == itarget(i) ) THEN
7157	vffrac(i+1) = vffrac(i+1) + vffrac(i)
7158	ztransp(i+1) = ztransp(i+1) + ztransp(i)
7159	CYCLE
7160	ENDIF
7161	ENDIF
7162	!
7163	!-- write to the svf array
7164	nsvfl = nsvfl + 1
7165	!-- check dimmension of asvf array and enlarge it if needed
7166	IF ( nsvfla < nsvfl ) THEN
7167	k = CEILING(REAL(nsvfla, kind=wp) * grow_factor)
7168	IF ( msvf == 0 ) THEN
7169	msvf = 1
7170	ALLOCATE( asvf1(k) )
7171	asvf => asvf1
7172	asvf1(1:nsvfla) = asvf2
7173	DEALLOCATE( asvf2 )
7174	ELSE
7175	msvf = 0
7176	ALLOCATE( asvf2(k) )
7177	asvf => asvf2
7178	asvf2(1:nsvfla) = asvf1
7179	DEALLOCATE( asvf1 )
7180	ENDIF
7181
7182	IF ( debug_output ) THEN
7183	WRITE( debug_string, '(A,3I12)' ) 'Grow asvf:', nsvfl, nsvfla, k
7184	CALL debug_message( debug_string, 'info' )
7185	ENDIF
7186
7187	nsvfla = k
7188	ENDIF
7189	!-- write svf values into the array
7190	asvf(nsvfl)%isurflt = isurflt
7191	asvf(nsvfl)%isurfs = itarget(i)
7192	asvf(nsvfl)%rsvf = vffrac(i)
7193	asvf(nsvfl)%rtransp = ztransp(i) / vffrac(i)
7194	END DO
7195
7196	ENDIF ! rad_angular_discretization
7197
7198	DEALLOCATE ( zdirs, zcent, zbdry, vffrac, ztransp, itarget ) !FIXME itarget shall be allocated only
7199	!in case of rad_angular_discretization
7200	!
7201	!-- Following calculations only required for surface_reflections
7202	IF ( surface_reflections .AND. .NOT. rad_angular_discretization ) THEN
7203
7204	DO isurfs = 1, nsurf
7205	IF ( .NOT. surface_facing(surfl(ix, isurflt), surfl(iy, isurflt), &
7206	surfl(iz, isurflt), surfl(id, isurflt), &
7207	surf(ix, isurfs), surf(iy, isurfs), &
7208	surf(iz, isurfs), surf(id, isurfs)) ) THEN
7209	CYCLE
7210	ENDIF
7211
7212	sd = surf(id, isurfs)
7213	sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd), &
7214	REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd), &
7215	REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd) /)
7216
7217	!-- unit vector source -> target
7218	uv = (/ (ta(1)-sa(1))dz(1), (ta(2)-sa(2))dy, (ta(3)-sa(3))*dx /)
7219	sqdist = SUM(uv(:)**2)
7220	uv = uv / SQRT(sqdist)
7221
7222	!-- reject raytracing above max distance
7223	IF ( SQRT(sqdist) > max_raytracing_dist ) THEN
7224	ray_skip_maxdist = ray_skip_maxdist + 1
7225	CYCLE
7226	ENDIF
7227
7228	difvf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) & ! cosine of source normal and direction
7229	* dot_product((/ kdir(td), jdir(td), idir(td) /), -uv) & ! cosine of target normal and reverse direction
7230	/ (pi * sqdist) ! square of distance between centers
7231	!
7232	!-- irradiance factor (our unshaded shape view factor) = view factor per differential target area * source area
7233	rirrf = difvf * facearea(sd)
7234
7235	!-- reject raytracing for potentially too small view factor values
7236	IF ( rirrf < min_irrf_value ) THEN
7237	ray_skip_minval = ray_skip_minval + 1
7238	CYCLE
7239	ENDIF
7240
7241	!-- raytrace + process plant canopy sinks within
7242	CALL raytrace(sa, ta, isurfs, difvf, facearea(td), .TRUE., &
7243	visible, transparency)
7244
7245	IF ( .NOT. visible ) CYCLE
7246	! rsvf = rirrf * transparency
7247
7248	!-- write to the svf array
7249	nsvfl = nsvfl + 1
7250	!-- check dimmension of asvf array and enlarge it if needed
7251	IF ( nsvfla < nsvfl ) THEN
7252	k = CEILING(REAL(nsvfla, kind=wp) * grow_factor)
7253	IF ( msvf == 0 ) THEN
7254	msvf = 1
7255	ALLOCATE( asvf1(k) )
7256	asvf => asvf1
7257	asvf1(1:nsvfla) = asvf2
7258	DEALLOCATE( asvf2 )
7259	ELSE
7260	msvf = 0
7261	ALLOCATE( asvf2(k) )
7262	asvf => asvf2
7263	asvf2(1:nsvfla) = asvf1
7264	DEALLOCATE( asvf1 )
7265	ENDIF
7266
7267	IF ( debug_output ) THEN
7268	WRITE( debug_string, '(A,3I12)' ) 'Grow asvf:', nsvfl, nsvfla, k
7269	CALL debug_message( debug_string, 'info' )
7270	ENDIF
7271
7272	nsvfla = k
7273	ENDIF
7274	!-- write svf values into the array
7275	asvf(nsvfl)%isurflt = isurflt
7276	asvf(nsvfl)%isurfs = isurfs
7277	asvf(nsvfl)%rsvf = rirrf !we postopne multiplication by transparency
7278	asvf(nsvfl)%rtransp = transparency !a.k.a. Direct Irradiance Factor
7279	ENDDO
7280	ENDIF
7281	ENDDO
7282
7283	!--
7284	!-- Raytrace to canopy boxes to fill dsitransc TODO optimize
7285	dsitransc(:,:) = 0._wp
7286	az0 = 0._wp
7287	naz = raytrace_discrete_azims
7288	azs = 2._wp * pi / REAL(naz, wp)
7289	zn0 = 0._wp
7290	nzn = raytrace_discrete_elevs / 2
7291	zns = pi / 2._wp / REAL(nzn, wp)
7292	ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), vffrac(1:nzn), ztransp(1:nzn), &
7293	itarget(1:nzn) )
7294	zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7295	vffrac(:) = 0._wp
7296
7297	DO ipcgb = 1, npcbl
7298	ta = (/ REAL(pcbl(iz, ipcgb), wp), &
7299	REAL(pcbl(iy, ipcgb), wp), &
7300	REAL(pcbl(ix, ipcgb), wp) /)
7301	!-- Calculate direct solar visibility using 2D raytracing
7302	DO iaz = 1, naz
7303	azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7304	yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7305	yxlen = SQRT(SUM(yxdir(:)**2))
7306	zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7307	yxdir(:) = yxdir(:) / yxlen
7308	CALL raytrace_2d(ta, yxdir, nzn, zdirs, &
7309	-999, -999._wp, vffrac, .FALSE., .FALSE., .TRUE., &
7310	lowest_free_ray, ztransp, itarget)
7311
7312	!-- Save direct solar transparency
7313	j = MODULO(NINT(azmid/ &
7314	(2._wppi)raytrace_discrete_azims-.5_wp, iwp), &
7315	raytrace_discrete_azims)
7316	DO k = 1, raytrace_discrete_elevs/2
7317	i = dsidir_rev(k-1, j)
7318	IF ( i /= -1 .AND. k <= lowest_free_ray ) &
7319	dsitransc(ipcgb, i) = ztransp(k)
7320	ENDDO
7321	ENDDO
7322	ENDDO
7323	DEALLOCATE ( zdirs, zcent, vffrac, ztransp, itarget )
7324	!--
7325	!-- Raytrace to MRT boxes
7326	IF ( nmrtbl > 0 ) THEN
7327	mrtdsit(:,:) = 0._wp
7328	mrtsky(:) = 0._wp
7329	mrtskyt(:) = 0._wp
7330	az0 = 0._wp
7331	naz = raytrace_discrete_azims
7332	azs = 2._wp * pi / REAL(naz, wp)
7333	zn0 = 0._wp
7334	nzn = raytrace_discrete_elevs
7335	zns = pi / REAL(nzn, wp)
7336	ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), vffrac0(1:nzn), &
7337	ztransp(1:nznnaz), itarget(1:nznnaz) ) !FIXME allocate itarget only
7338	!in case of rad_angular_discretization
7339
7340	zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7341	zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/)
7342	vffrac0(:) = (COS(zbdry(0:nzn-1)) - COS(zbdry(1:nzn))) / 2._wp / REAL(naz, wp)
7343	!
7344	!--Modify direction weights to simulate human body (lower weight for top-down)
7345	IF ( mrt_geom_human ) THEN
7346	vffrac0(:) = vffrac0(:) * MAX(0._wp, SIN(zcent(:))0.88_wp + COS(zcent(:))0.12_wp)
7347	vffrac0(:) = vffrac0(:) / (SUM(vffrac0) * REAL(naz, wp))
7348	ENDIF
7349
7350	DO imrt = 1, nmrtbl
7351	ta = (/ REAL(mrtbl(iz, imrt), wp), &
7352	REAL(mrtbl(iy, imrt), wp), &
7353	REAL(mrtbl(ix, imrt), wp) /)
7354	!
7355	!-- vf fractions are constant per azimuth
7356	DO iaz = 0, naz-1
7357	vffrac(iaznzn+1:(iaz+1)nzn) = vffrac0(:)
7358	ENDDO
7359	!-- sum of whole vffrac equals 1, verified
7360	itarg0 = 1
7361	itarg1 = nzn
7362	!
7363	!-- Calculate sky-view factor and direct solar visibility using 2D raytracing
7364	DO iaz = 1, naz
7365	azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7366	yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7367	yxlen = SQRT(SUM(yxdir(:)**2))
7368	zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7369	yxdir(:) = yxdir(:) / yxlen
7370
7371	CALL raytrace_2d(ta, yxdir, nzn, zdirs, &
7372	-999, -999._wp, vffrac(itarg0:itarg1), .TRUE., &
7373	.FALSE., .TRUE., lowest_free_ray, &
7374	ztransp(itarg0:itarg1), &
7375	itarget(itarg0:itarg1))
7376
7377	!-- Sky view factors for MRT
7378	mrtsky(imrt) = mrtsky(imrt) + &
7379	SUM(vffrac(itarg0:itarg0+lowest_free_ray-1))
7380	mrtskyt(imrt) = mrtskyt(imrt) + &
7381	SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) &
7382	* vffrac(itarg0:itarg0+lowest_free_ray-1))
7383	!-- Direct solar transparency for MRT
7384	j = MODULO(NINT(azmid/ &
7385	(2._wppi)raytrace_discrete_azims-.5_wp, iwp), &
7386	raytrace_discrete_azims)
7387	DO k = 1, raytrace_discrete_elevs/2
7388	i = dsidir_rev(k-1, j)
7389	IF ( i /= -1 .AND. k <= lowest_free_ray ) &
7390	mrtdsit(imrt, i) = ztransp(itarg0+k-1)
7391	ENDDO
7392	!
7393	!-- Advance itarget indices
7394	itarg0 = itarg1 + 1
7395	itarg1 = itarg1 + nzn
7396	ENDDO
7397
7398	!-- sort itarget by face id
7399	CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz)
7400	!
7401	!-- find the first valid position
7402	itarg0 = 1
7403	DO WHILE ( itarg0 <= nzn*naz )
7404	IF ( itarget(itarg0) /= -1 ) EXIT
7405	itarg0 = itarg0 + 1
7406	ENDDO
7407
7408	DO i = itarg0, nzn*naz
7409	!
7410	!-- For duplicate values, only sum up vf fraction value
7411	IF ( i < nzn*naz ) THEN
7412	IF ( itarget(i+1) == itarget(i) ) THEN
7413	vffrac(i+1) = vffrac(i+1) + vffrac(i)
7414	CYCLE
7415	ENDIF
7416	ENDIF
7417	!
7418	!-- write to the mrtf array
7419	nmrtf = nmrtf + 1
7420	!-- check dimmension of mrtf array and enlarge it if needed
7421	IF ( nmrtfa < nmrtf ) THEN
7422	k = CEILING(REAL(nmrtfa, kind=wp) * grow_factor)
7423	IF ( mmrtf == 0 ) THEN
7424	mmrtf = 1
7425	ALLOCATE( amrtf1(k) )
7426	amrtf => amrtf1
7427	amrtf1(1:nmrtfa) = amrtf2
7428	DEALLOCATE( amrtf2 )
7429	ELSE
7430	mmrtf = 0
7431	ALLOCATE( amrtf2(k) )
7432	amrtf => amrtf2
7433	amrtf2(1:nmrtfa) = amrtf1
7434	DEALLOCATE( amrtf1 )
7435	ENDIF
7436
7437	IF ( debug_output ) THEN
7438	WRITE( debug_string, '(A,3I12)' ) 'Grow amrtf:', nmrtf, nmrtfa, k
7439	CALL debug_message( debug_string, 'info' )
7440	ENDIF
7441
7442	nmrtfa = k
7443	ENDIF
7444	!-- write mrtf values into the array
7445	amrtf(nmrtf)%isurflt = imrt
7446	amrtf(nmrtf)%isurfs = itarget(i)
7447	amrtf(nmrtf)%rsvf = vffrac(i)
7448	amrtf(nmrtf)%rtransp = ztransp(i)
7449	ENDDO ! itarg
7450
7451	ENDDO ! imrt
7452	DEALLOCATE ( zdirs, zcent, zbdry, vffrac, vffrac0, ztransp, itarget )
7453	!
7454	!-- Move MRT factors to final arrays
7455	ALLOCATE ( mrtf(nmrtf), mrtft(nmrtf), mrtfsurf(2,nmrtf) )
7456	DO imrtf = 1, nmrtf
7457	mrtf(imrtf) = amrtf(imrtf)%rsvf
7458	mrtft(imrtf) = amrtf(imrtf)%rsvf * amrtf(imrtf)%rtransp
7459	mrtfsurf(:,imrtf) = (/amrtf(imrtf)%isurflt, amrtf(imrtf)%isurfs /)
7460	ENDDO
7461	IF ( ALLOCATED(amrtf1) ) DEALLOCATE( amrtf1 )
7462	IF ( ALLOCATED(amrtf2) ) DEALLOCATE( amrtf2 )
7463	ENDIF ! nmrtbl > 0
7464
7465	IF ( rad_angular_discretization ) THEN
7466	#if defined( __parallel )
7467	!-- finalize MPI_RMA communication established to get global index of the surface from grid indices
7468	!-- flush all MPI window pending requests
7469	CALL MPI_Win_flush_all(win_gridsurf, ierr)
7470	IF ( ierr /= 0 ) THEN
7471	WRITE(9,*) 'Error MPI_Win_flush_all1:', ierr, win_gridsurf
7472	FLUSH(9)
7473	ENDIF
7474	!-- unlock MPI window
7475	CALL MPI_Win_unlock_all(win_gridsurf, ierr)
7476	IF ( ierr /= 0 ) THEN
7477	WRITE(9,*) 'Error MPI_Win_unlock_all1:', ierr, win_gridsurf
7478	FLUSH(9)
7479	ENDIF
7480	!-- free MPI window
7481	CALL MPI_Win_free(win_gridsurf, ierr)
7482	IF ( ierr /= 0 ) THEN
7483	WRITE(9,*) 'Error MPI_Win_free1:', ierr, win_gridsurf
7484	FLUSH(9)
7485	ENDIF
7486	#else
7487	DEALLOCATE ( gridsurf )
7488	#endif
7489	ENDIF
7490
7491	IF ( debug_output ) CALL debug_message( 'waiting for completion of SVF and CSF calculation in all processes', 'info' )
7492
7493	!-- deallocate temporary global arrays
7494	DEALLOCATE(nzterr)
7495
7496	IF ( plant_canopy ) THEN
7497	!-- finalize mpi_rma communication and deallocate temporary arrays
7498	#if defined( __parallel )
7499	IF ( raytrace_mpi_rma ) THEN
7500	CALL MPI_Win_flush_all(win_lad, ierr)
7501	IF ( ierr /= 0 ) THEN
7502	WRITE(9,*) 'Error MPI_Win_flush_all2:', ierr, win_lad
7503	FLUSH(9)
7504	ENDIF
7505	!-- unlock MPI window
7506	CALL MPI_Win_unlock_all(win_lad, ierr)
7507	IF ( ierr /= 0 ) THEN
7508	WRITE(9,*) 'Error MPI_Win_unlock_all2:', ierr, win_lad
7509	FLUSH(9)
7510	ENDIF
7511	!-- free MPI window
7512	CALL MPI_Win_free(win_lad, ierr)
7513	IF ( ierr /= 0 ) THEN
7514	WRITE(9,*) 'Error MPI_Win_free2:', ierr, win_lad
7515	FLUSH(9)
7516	ENDIF
7517	!-- deallocate temporary arrays storing values for csf calculation during raytracing
7518	DEALLOCATE( lad_s_ray )
7519	!-- sub_lad is the pointer to lad_s_rma in case of raytrace_mpi_rma
7520	!-- and must not be deallocated here
7521	ELSE
7522	DEALLOCATE(sub_lad)
7523	DEALLOCATE(sub_lad_g)
7524	ENDIF
7525	#else
7526	DEALLOCATE(sub_lad)
7527	#endif
7528	DEALLOCATE( boxes )
7529	DEALLOCATE( crlens )
7530	DEALLOCATE( plantt )
7531	DEALLOCATE( rt2_track, rt2_track_lad, rt2_track_dist, rt2_dist )
7532	ENDIF
7533
7534	IF ( debug_output ) CALL debug_message( 'calculation of the complete SVF array', 'info' )
7535
7536	IF ( rad_angular_discretization ) THEN
7537	IF ( debug_output ) CALL debug_message( 'Load svf from the structure array to plain arrays', 'info' )
7538	ALLOCATE( svf(ndsvf,nsvfl) )
7539	ALLOCATE( svfsurf(idsvf,nsvfl) )
7540
7541	DO isvf = 1, nsvfl
7542	svf(:, isvf) = (/ asvf(isvf)%rsvf, asvf(isvf)%rtransp /)
7543	svfsurf(:, isvf) = (/ asvf(isvf)%isurflt, asvf(isvf)%isurfs /)
7544	ENDDO
7545	ELSE
7546	IF ( debug_output ) CALL debug_message( 'Start SVF sort', 'info' )
7547	!-- sort svf ( a version of quicksort )
7548	CALL quicksort_svf(asvf,1,nsvfl)
7549
7550	!< load svf from the structure array to plain arrays
7551	IF ( debug_output ) CALL debug_message( 'Load svf from the structure array to plain arrays', 'info' )
7552	ALLOCATE( svf(ndsvf,nsvfl) )
7553	ALLOCATE( svfsurf(idsvf,nsvfl) )
7554	svfnorm_counts(:) = 0._wp
7555	isurflt_prev = -1
7556	ksvf = 1
7557	svfsum = 0._wp
7558	DO isvf = 1, nsvfl
7559	!-- normalize svf per target face
7560	IF ( asvf(ksvf)%isurflt /= isurflt_prev ) THEN
7561	IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN
7562	!< update histogram of logged svf normalization values
7563	i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev)))
7564	svfnorm_counts(i) = svfnorm_counts(i) + 1
7565
7566	svf(1, isvf_surflt:isvf-1) = svf(1, isvf_surflt:isvf-1) / svfsum * (1._wp-skyvf(isurflt_prev))
7567	ENDIF
7568	isurflt_prev = asvf(ksvf)%isurflt
7569	isvf_surflt = isvf
7570	svfsum = asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp
7571	ELSE
7572	svfsum = svfsum + asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp
7573	ENDIF
7574
7575	svf(:, isvf) = (/ asvf(ksvf)%rsvf, asvf(ksvf)%rtransp /)
7576	svfsurf(:, isvf) = (/ asvf(ksvf)%isurflt, asvf(ksvf)%isurfs /)
7577
7578	!-- next element
7579	ksvf = ksvf + 1
7580	ENDDO
7581
7582	IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN
7583	i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev)))
7584	svfnorm_counts(i) = svfnorm_counts(i) + 1
7585
7586	svf(1, isvf_surflt:nsvfl) = svf(1, isvf_surflt:nsvfl) / svfsum * (1._wp-skyvf(isurflt_prev))
7587	ENDIF
7588	WRITE(9, *) 'SVF normalization histogram:', svfnorm_counts, &
7589	'on thresholds:', svfnorm_report_thresh(1:svfnorm_report_num), '(val < thresh <= val)'
7590	!TODO we should be able to deallocate skyvf, from now on we only need skyvft
7591	ENDIF ! rad_angular_discretization
7592
7593	!-- deallocate temporary asvf array
7594	!-- DEALLOCATE(asvf) - ifort has a problem with deallocation of allocatable target
7595	!-- via pointing pointer - we need to test original targets
7596	IF ( ALLOCATED(asvf1) ) THEN
7597	DEALLOCATE(asvf1)
7598	ENDIF
7599	IF ( ALLOCATED(asvf2) ) THEN
7600	DEALLOCATE(asvf2)
7601	ENDIF
7602
7603	npcsfl = 0
7604	IF ( plant_canopy ) THEN
7605
7606	IF ( debug_output ) CALL debug_message( 'Calculation of the complete CSF array', 'info' )
7607	!-- sort and merge csf for the last time, keeping the array size to minimum
7608	CALL merge_and_grow_csf(-1)
7609
7610	!-- aggregate csb among processors
7611	!-- allocate necessary arrays
7612	udim = max(ncsfl,1)
7613	ALLOCATE( csflt_l(ndcsf*udim) )
7614	csflt(1:ndcsf,1:udim) => csflt_l(1:ndcsf*udim)
7615	ALLOCATE( kcsflt_l(kdcsf*udim) )
7616	kcsflt(1:kdcsf,1:udim) => kcsflt_l(1:kdcsf*udim)
7617	ALLOCATE( icsflt(0:numprocs-1) )
7618	ALLOCATE( dcsflt(0:numprocs-1) )
7619	ALLOCATE( ipcsflt(0:numprocs-1) )
7620	ALLOCATE( dpcsflt(0:numprocs-1) )
7621
7622	!-- fill out arrays of csf values and
7623	!-- arrays of number of elements and displacements
7624	!-- for particular precessors
7625	icsflt = 0
7626	dcsflt = 0
7627	ip = -1
7628	j = -1
7629	d = 0
7630	DO kcsf = 1, ncsfl
7631	j = j+1
7632	IF ( acsf(kcsf)%ip /= ip ) THEN
7633	!-- new block of the processor
7634	!-- number of elements of previous block
7635	IF ( ip>=0) icsflt(ip) = j
7636	d = d+j
7637	!-- blank blocks
7638	DO jp = ip+1, acsf(kcsf)%ip-1
7639	!-- number of elements is zero, displacement is equal to previous
7640	icsflt(jp) = 0
7641	dcsflt(jp) = d
7642	ENDDO
7643	!-- the actual block
7644	ip = acsf(kcsf)%ip
7645	dcsflt(ip) = d
7646	j = 0
7647	ENDIF
7648	csflt(1,kcsf) = acsf(kcsf)%rcvf
7649	!-- fill out integer values of itz,ity,itx,isurfs
7650	kcsflt(1,kcsf) = acsf(kcsf)%itz
7651	kcsflt(2,kcsf) = acsf(kcsf)%ity
7652	kcsflt(3,kcsf) = acsf(kcsf)%itx
7653	kcsflt(4,kcsf) = acsf(kcsf)%isurfs
7654	ENDDO
7655	!-- last blank blocks at the end of array
7656	j = j+1
7657	IF ( ip>=0 ) icsflt(ip) = j
7658	d = d+j
7659	DO jp = ip+1, numprocs-1
7660	!-- number of elements is zero, displacement is equal to previous
7661	icsflt(jp) = 0
7662	dcsflt(jp) = d
7663	ENDDO
7664
7665	!-- deallocate temporary acsf array
7666	!-- DEALLOCATE(acsf) - ifort has a problem with deallocation of allocatable target
7667	!-- via pointing pointer - we need to test original targets
7668	IF ( ALLOCATED(acsf1) ) THEN
7669	DEALLOCATE(acsf1)
7670	ENDIF
7671	IF ( ALLOCATED(acsf2) ) THEN
7672	DEALLOCATE(acsf2)
7673	ENDIF
7674
7675	#if defined( __parallel )
7676	!-- scatter and gather the number of elements to and from all processor
7677	!-- and calculate displacements
7678	IF ( debug_output ) CALL debug_message( 'Scatter and gather the number of elements to and from all processor', 'info' )
7679
7680	CALL MPI_AlltoAll(icsflt,1,MPI_INTEGER,ipcsflt,1,MPI_INTEGER,comm2d, ierr)
7681
7682	IF ( ierr /= 0 ) THEN
7683	WRITE(9,*) 'Error MPI_AlltoAll1:', ierr, SIZE(icsflt), SIZE(ipcsflt)
7684	FLUSH(9)
7685	ENDIF
7686
7687	npcsfl = SUM(ipcsflt)
7688	d = 0
7689	DO i = 0, numprocs-1
7690	dpcsflt(i) = d
7691	d = d + ipcsflt(i)
7692	ENDDO
7693
7694	!-- exchange csf fields between processors
7695	IF ( debug_output ) CALL debug_message( 'Exchange csf fields between processors', 'info' )
7696	udim = max(npcsfl,1)
7697	ALLOCATE( pcsflt_l(ndcsf*udim) )
7698	pcsflt(1:ndcsf,1:udim) => pcsflt_l(1:ndcsf*udim)
7699	ALLOCATE( kpcsflt_l(kdcsf*udim) )
7700	kpcsflt(1:kdcsf,1:udim) => kpcsflt_l(1:kdcsf*udim)
7701	CALL MPI_AlltoAllv(csflt_l, ndcsficsflt, ndcsfdcsflt, MPI_REAL, &
7702	pcsflt_l, ndcsfipcsflt, ndcsfdpcsflt, MPI_REAL, comm2d, ierr)
7703	IF ( ierr /= 0 ) THEN
7704	WRITE(9,) 'Error MPI_AlltoAllv1:', ierr, SIZE(ipcsflt), ndcsficsflt, &
7705	ndcsfdcsflt, SIZE(pcsflt_l),ndcsfipcsflt, ndcsf*dpcsflt
7706	FLUSH(9)
7707	ENDIF
7708
7709	CALL MPI_AlltoAllv(kcsflt_l, kdcsficsflt, kdcsfdcsflt, MPI_INTEGER, &
7710	kpcsflt_l, kdcsfipcsflt, kdcsfdpcsflt, MPI_INTEGER, comm2d, ierr)
7711	IF ( ierr /= 0 ) THEN
7712	WRITE(9,) 'Error MPI_AlltoAllv2:', ierr, SIZE(kcsflt_l),kdcsficsflt, &
7713	kdcsfdcsflt, SIZE(kpcsflt_l), kdcsfipcsflt, kdcsf*dpcsflt
7714	FLUSH(9)
7715	ENDIF
7716
7717	#else
7718	npcsfl = ncsfl
7719	ALLOCATE( pcsflt(ndcsf,max(npcsfl,ndcsf)) )
7720	ALLOCATE( kpcsflt(kdcsf,max(npcsfl,kdcsf)) )
7721	pcsflt = csflt
7722	kpcsflt = kcsflt
7723	#endif
7724
7725	!-- deallocate temporary arrays
7726	DEALLOCATE( csflt_l )
7727	DEALLOCATE( kcsflt_l )
7728	DEALLOCATE( icsflt )
7729	DEALLOCATE( dcsflt )
7730	DEALLOCATE( ipcsflt )
7731	DEALLOCATE( dpcsflt )
7732
7733	!-- sort csf ( a version of quicksort )
7734	IF ( debug_output ) CALL debug_message( 'Sort csf', 'info' )
7735	CALL quicksort_csf2(kpcsflt, pcsflt, 1, npcsfl)
7736
7737	!-- aggregate canopy sink factor records with identical box & source
7738	!-- againg across all values from all processors
7739	IF ( debug_output ) CALL debug_message( 'Aggregate canopy sink factor records with identical box', 'info' )
7740
7741	IF ( npcsfl > 0 ) THEN
7742	icsf = 1 !< reading index
7743	kcsf = 1 !< writing index
7744	DO WHILE (icsf < npcsfl)
7745	!-- here kpcsf(kcsf) already has values from kpcsf(icsf)
7746	IF ( kpcsflt(3,icsf) == kpcsflt(3,icsf+1) .AND. &
7747	kpcsflt(2,icsf) == kpcsflt(2,icsf+1) .AND. &
7748	kpcsflt(1,icsf) == kpcsflt(1,icsf+1) .AND. &
7749	kpcsflt(4,icsf) == kpcsflt(4,icsf+1) ) THEN
7750
7751	pcsflt(1,kcsf) = pcsflt(1,kcsf) + pcsflt(1,icsf+1)
7752
7753	!-- advance reading index, keep writing index
7754	icsf = icsf + 1
7755	ELSE
7756	!-- not identical, just advance and copy
7757	icsf = icsf + 1
7758	kcsf = kcsf + 1
7759	kpcsflt(:,kcsf) = kpcsflt(:,icsf)
7760	pcsflt(:,kcsf) = pcsflt(:,icsf)
7761	ENDIF
7762	ENDDO
7763	!-- last written item is now also the last item in valid part of array
7764	npcsfl = kcsf
7765	ENDIF
7766
7767	ncsfl = npcsfl
7768	IF ( ncsfl > 0 ) THEN
7769	ALLOCATE( csf(ndcsf,ncsfl) )
7770	ALLOCATE( csfsurf(idcsf,ncsfl) )
7771	DO icsf = 1, ncsfl
7772	csf(:,icsf) = pcsflt(:,icsf)
7773	csfsurf(1,icsf) = gridpcbl(kpcsflt(1,icsf),kpcsflt(2,icsf),kpcsflt(3,icsf))
7774	csfsurf(2,icsf) = kpcsflt(4,icsf)
7775	ENDDO
7776	ENDIF
7777
7778	!-- deallocation of temporary arrays
7779	IF ( npcbl > 0 ) DEALLOCATE( gridpcbl )
7780	DEALLOCATE( pcsflt_l )
7781	DEALLOCATE( kpcsflt_l )
7782	IF ( debug_output ) CALL debug_message( 'End of aggregate csf', 'info' )
7783
7784	ENDIF
7785
7786	#if defined( __parallel )
7787	CALL MPI_BARRIER( comm2d, ierr )
7788	#endif
7789	CALL location_message( 'calculating view factors for radiation interaction', 'finished' )
7790
7791	RETURN !todo: remove
7792
7793	! WRITE( message_string, * ) &
7794	! 'I/O error when processing shape view factors / ', &
7795	! 'plant canopy sink factors / direct irradiance factors.'
7796	! CALL message( 'init_urban_surface', 'PA0502', 2, 2, 0, 6, 0 )
7797
7798	END SUBROUTINE radiation_calc_svf
7799
7800
7801	!------------------------------------------------------------------------------!
7802	! Description:
7803	! ------------
7804	!> Raytracing for detecting obstacles and calculating compound canopy sink
7805	!> factors. (A simple obstacle detection would only need to process faces in
7806	!> 3 dimensions without any ordering.)
7807	!> Assumtions:
7808	!> -----------
7809	!> 1. The ray always originates from a face midpoint (only one coordinate equals
7810	!> *.5, i.e. wall) and doesn't travel parallel to the surface (that would mean
7811	!> shape factor=0). Therefore, the ray may never travel exactly along a face
7812	!> or an edge.
7813	!> 2. From grid bottom to urban surface top the grid has to be equidistant
7814	!> within each of the dimensions, including vertical (but the resolution
7815	!> doesn't need to be the same in all three dimensions).
7816	!------------------------------------------------------------------------------!
7817	SUBROUTINE raytrace(src, targ, isrc, difvf, atarg, create_csf, visible, transparency)
7818	IMPLICIT NONE
7819
7820	REAL(wp), DIMENSION(3), INTENT(in) :: src, targ !< real coordinates z,y,x
7821	INTEGER(iwp), INTENT(in) :: isrc !< index of source face for csf
7822	REAL(wp), INTENT(in) :: difvf !< differential view factor for csf
7823	REAL(wp), INTENT(in) :: atarg !< target surface area for csf
7824	LOGICAL, INTENT(in) :: create_csf !< whether to generate new CSFs during raytracing
7825	LOGICAL, INTENT(out) :: visible
7826	REAL(wp), INTENT(out) :: transparency !< along whole path
7827	INTEGER(iwp) :: i, k, d
7828	INTEGER(iwp) :: seldim !< dimension to be incremented
7829	INTEGER(iwp) :: ncsb !< no of written plant canopy sinkboxes
7830	INTEGER(iwp) :: maxboxes !< max no of gridboxes visited
7831	REAL(wp) :: distance !< euclidean along path
7832	REAL(wp) :: crlen !< length of gridbox crossing
7833	REAL(wp) :: lastdist !< beginning of current crossing
7834	REAL(wp) :: nextdist !< end of current crossing
7835	REAL(wp) :: realdist !< distance in meters per unit distance
7836	REAL(wp) :: crmid !< midpoint of crossing
7837	REAL(wp) :: cursink !< sink factor for current canopy box
7838	REAL(wp), DIMENSION(3) :: delta !< path vector
7839	REAL(wp), DIMENSION(3) :: uvect !< unit vector
7840	REAL(wp), DIMENSION(3) :: dimnextdist !< distance for each dimension increments
7841	INTEGER(iwp), DIMENSION(3) :: box !< gridbox being crossed
7842	INTEGER(iwp), DIMENSION(3) :: dimnext !< next dimension increments along path
7843	INTEGER(iwp), DIMENSION(3) :: dimdelta !< dimension direction = +- 1
7844	INTEGER(iwp) :: px, py !< number of processors in x and y dir before
7845	!< the processor in the question
7846	INTEGER(iwp) :: ip !< number of processor where gridbox reside
7847	INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array
7848
7849	REAL(wp) :: eps = 1E-10_wp !< epsilon for value comparison
7850	REAL(wp) :: lad_s_target !< recieved lad_s of particular grid box
7851
7852	!
7853	!-- Maximum number of gridboxes visited equals to maximum number of boundaries crossed in each dimension plus one. That's also
7854	!-- the maximum number of plant canopy boxes written. We grow the acsf array accordingly using exponential factor.
7855	maxboxes = SUM(ABS(NINT(targ, iwp) - NINT(src, iwp))) + 1
7856	IF ( plant_canopy .AND. ncsfl + maxboxes > ncsfla ) THEN
7857	!-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1)
7858	!-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) &
7859	!-- / log(grow_factor)), kind=wp))
7860	!-- or use this code to simply always keep some extra space after growing
7861	k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor)
7862
7863	CALL merge_and_grow_csf(k)
7864	ENDIF
7865
7866	transparency = 1._wp
7867	ncsb = 0
7868
7869	delta(:) = targ(:) - src(:)
7870	distance = SQRT(SUM(delta(:)**2))
7871	IF ( distance == 0._wp ) THEN
7872	visible = .TRUE.
7873	RETURN
7874	ENDIF
7875	uvect(:) = delta(:) / distance
7876	realdist = SQRT(SUM( (uvect(:)(/dz(1),dy,dx/))*2 ))
7877
7878	lastdist = 0._wp
7879
7880	!-- Since all face coordinates have values *.5 and we'd like to use
7881	!-- integers, all these have .5 added
7882	DO d = 1, 3
7883	IF ( uvect(d) == 0._wp ) THEN
7884	dimnext(d) = 999999999
7885	dimdelta(d) = 999999999
7886	dimnextdist(d) = 1.0E20_wp
7887	ELSE IF ( uvect(d) > 0._wp ) THEN
7888	dimnext(d) = CEILING(src(d) + .5_wp)
7889	dimdelta(d) = 1
7890	dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d)
7891	ELSE
7892	dimnext(d) = FLOOR(src(d) + .5_wp)
7893	dimdelta(d) = -1
7894	dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d)
7895	ENDIF
7896	ENDDO
7897
7898	DO
7899	!-- along what dimension will the next wall crossing be?
7900	seldim = minloc(dimnextdist, 1)
7901	nextdist = dimnextdist(seldim)
7902	IF ( nextdist > distance ) nextdist = distance
7903
7904	crlen = nextdist - lastdist
7905	IF ( crlen > .001_wp ) THEN
7906	crmid = (lastdist + nextdist) * .5_wp
7907	box = NINT(src(:) + uvect(:) * crmid, iwp)
7908
7909	!-- calculate index of the grid with global indices (box(2),box(3))
7910	!-- in the array nzterr and plantt and id of the coresponding processor
7911	px = box(3)/nnx
7912	py = box(2)/nny
7913	ip = px*pdims(2)+py
7914	ig = ipnnxnny + (box(3)-pxnnx)nny + box(2)-py*nny
7915	IF ( box(1) <= nzterr(ig) ) THEN
7916	visible = .FALSE.
7917	RETURN
7918	ENDIF
7919
7920	IF ( plant_canopy ) THEN
7921	IF ( box(1) <= plantt(ig) ) THEN
7922	ncsb = ncsb + 1
7923	boxes(:,ncsb) = box
7924	crlens(ncsb) = crlen
7925	#if defined( __parallel )
7926	lad_ip(ncsb) = ip
7927	lad_disp(ncsb) = (box(3)-pxnnx)(nnynz_plant) + (box(2)-pynny)*nz_plant + box(1)-nz_urban_b
7928	#endif
7929	ENDIF
7930	ENDIF
7931	ENDIF
7932
7933	IF ( ABS(distance - nextdist) < eps ) EXIT
7934	lastdist = nextdist
7935	dimnext(seldim) = dimnext(seldim) + dimdelta(seldim)
7936	dimnextdist(seldim) = (dimnext(seldim) - .5_wp - src(seldim)) / uvect(seldim)
7937	ENDDO
7938
7939	IF ( plant_canopy ) THEN
7940	#if defined( __parallel )
7941	IF ( raytrace_mpi_rma ) THEN
7942	!-- send requests for lad_s to appropriate processor
7943	CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'start' )
7944	DO i = 1, ncsb
7945	CALL MPI_Get(lad_s_ray(i), 1, MPI_REAL, lad_ip(i), lad_disp(i), &
7946	1, MPI_REAL, win_lad, ierr)
7947	IF ( ierr /= 0 ) THEN
7948	WRITE(9,*) 'Error MPI_Get1:', ierr, lad_s_ray(i), &
7949	lad_ip(i), lad_disp(i), win_lad
7950	FLUSH(9)
7951	ENDIF
7952	ENDDO
7953
7954	!-- wait for all pending local requests complete
7955	CALL MPI_Win_flush_local_all(win_lad, ierr)
7956	IF ( ierr /= 0 ) THEN
7957	WRITE(9,*) 'Error MPI_Win_flush_local_all1:', ierr, win_lad
7958	FLUSH(9)
7959	ENDIF
7960	CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'stop' )
7961
7962	ENDIF
7963	#endif
7964
7965	!-- calculate csf and transparency
7966	DO i = 1, ncsb
7967	#if defined( __parallel )
7968	IF ( raytrace_mpi_rma ) THEN
7969	lad_s_target = lad_s_ray(i)
7970	ELSE
7971	lad_s_target = sub_lad_g(lad_ip(i)nnxnny*nz_plant + lad_disp(i))
7972	ENDIF
7973	#else
7974	lad_s_target = sub_lad(boxes(1,i),boxes(2,i),boxes(3,i))
7975	#endif
7976	cursink = 1._wp - exp(-ext_coef * lad_s_target * crlens(i)*realdist)
7977
7978	IF ( create_csf ) THEN
7979	!-- write svf values into the array
7980	ncsfl = ncsfl + 1
7981	acsf(ncsfl)%ip = lad_ip(i)
7982	acsf(ncsfl)%itx = boxes(3,i)
7983	acsf(ncsfl)%ity = boxes(2,i)
7984	acsf(ncsfl)%itz = boxes(1,i)
7985	acsf(ncsfl)%isurfs = isrc
7986	acsf(ncsfl)%rcvf = cursinktransparencydifvf*atarg
7987	ENDIF !< create_csf
7988
7989	transparency = transparency * (1._wp - cursink)
7990
7991	ENDDO
7992	ENDIF
7993
7994	visible = .TRUE.
7995
7996	END SUBROUTINE raytrace
7997
7998
7999	!------------------------------------------------------------------------------!
8000	! Description:
8001	! ------------
8002	!> A new, more efficient version of ray tracing algorithm that processes a whole
8003	!> arc instead of a single ray.
8004	!>
8005	!> In all comments, horizon means tangent of horizon angle, i.e.
8006	!> vertical_delta / horizontal_distance
8007	!------------------------------------------------------------------------------!
8008	SUBROUTINE raytrace_2d(origin, yxdir, nrays, zdirs, iorig, aorig, vffrac, &
8009	calc_svf, create_csf, skip_1st_pcb, &
8010	lowest_free_ray, transparency, itarget)
8011	IMPLICIT NONE
8012
8013	REAL(wp), DIMENSION(3), INTENT(IN) :: origin !< z,y,x coordinates of ray origin
8014	REAL(wp), DIMENSION(2), INTENT(IN) :: yxdir !< y,x unit vector of ray direction (in grid units)
8015	INTEGER(iwp) :: nrays !< number of rays (z directions) to raytrace
8016	REAL(wp), DIMENSION(nrays), INTENT(IN) :: zdirs !< list of z directions to raytrace (z/hdist, grid, zenith->nadir)
8017	INTEGER(iwp), INTENT(in) :: iorig !< index of origin face for csf
8018	REAL(wp), INTENT(in) :: aorig !< origin face area for csf
8019	REAL(wp), DIMENSION(nrays), INTENT(in) :: vffrac !< view factor fractions of each ray for csf
8020	LOGICAL, INTENT(in) :: calc_svf !< whether to calculate SFV (identify obstacle surfaces)
8021	LOGICAL, INTENT(in) :: create_csf !< whether to create canopy sink factors
8022	LOGICAL, INTENT(in) :: skip_1st_pcb !< whether to skip first plant canopy box during raytracing
8023	INTEGER(iwp), INTENT(out) :: lowest_free_ray !< index into zdirs
8024	REAL(wp), DIMENSION(nrays), INTENT(OUT) :: transparency !< transparencies of zdirs paths
8025	INTEGER(iwp), DIMENSION(nrays), INTENT(OUT) :: itarget !< global indices of target faces for zdirs
8026
8027	INTEGER(iwp), DIMENSION(nrays) :: target_procs
8028	REAL(wp) :: horizon !< highest horizon found after raytracing (z/hdist)
8029	INTEGER(iwp) :: i, k, l, d
8030	INTEGER(iwp) :: seldim !< dimension to be incremented
8031	REAL(wp), DIMENSION(2) :: yxorigin !< horizontal copy of origin (y,x)
8032	REAL(wp) :: distance !< euclidean along path
8033	REAL(wp) :: lastdist !< beginning of current crossing
8034	REAL(wp) :: nextdist !< end of current crossing
8035	REAL(wp) :: crmid !< midpoint of crossing
8036	REAL(wp) :: horz_entry !< horizon at entry to column
8037	REAL(wp) :: horz_exit !< horizon at exit from column
8038	REAL(wp) :: bdydim !< boundary for current dimension
8039	REAL(wp), DIMENSION(2) :: crossdist !< distances to boundary for dimensions
8040	REAL(wp), DIMENSION(2) :: dimnextdist !< distance for each dimension increments
8041	INTEGER(iwp), DIMENSION(2) :: column !< grid column being crossed
8042	INTEGER(iwp), DIMENSION(2) :: dimnext !< next dimension increments along path
8043	INTEGER(iwp), DIMENSION(2) :: dimdelta !< dimension direction = +- 1
8044	INTEGER(iwp) :: px, py !< number of processors in x and y dir before
8045	!< the processor in the question
8046	INTEGER(iwp) :: ip !< number of processor where gridbox reside
8047	INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array
8048	INTEGER(iwp) :: wcount !< RMA window item count
8049	INTEGER(iwp) :: maxboxes !< max no of CSF created
8050	INTEGER(iwp) :: nly !< maximum plant canopy height
8051	INTEGER(iwp) :: ntrack
8052
8053	INTEGER(iwp) :: zb0
8054	INTEGER(iwp) :: zb1
8055	INTEGER(iwp) :: nz
8056	INTEGER(iwp) :: iz
8057	INTEGER(iwp) :: zsgn
8058	INTEGER(iwp) :: lowest_lad !< lowest column cell for which we need LAD
8059	INTEGER(iwp) :: lastdir !< wall direction before hitting this column
8060	INTEGER(iwp), DIMENSION(2) :: lastcolumn
8061
8062	#if defined( __parallel )
8063	INTEGER(MPI_ADDRESS_KIND) :: wdisp !< RMA window displacement
8064	#endif
8065
8066	REAL(wp) :: eps = 1E-10_wp !< epsilon for value comparison
8067	REAL(wp) :: zbottom, ztop !< urban surface boundary in real numbers
8068	REAL(wp) :: zorig !< z coordinate of ray column entry
8069	REAL(wp) :: zexit !< z coordinate of ray column exit
8070	REAL(wp) :: qdist !< ratio of real distance to z coord difference
8071	REAL(wp) :: dxxyy !< square of real horizontal distance
8072	REAL(wp) :: curtrans !< transparency of current PC box crossing
8073
8074
8075
8076	yxorigin(:) = origin(2:3)
8077	transparency(:) = 1._wp !-- Pre-set the all rays to transparent before reducing
8078	horizon = -HUGE(1._wp)
8079	lowest_free_ray = nrays
8080	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8081	ALLOCATE(target_surfl(nrays))
8082	target_surfl(:) = -1
8083	lastdir = -999
8084	lastcolumn(:) = -999
8085	ENDIF
8086
8087	!-- Determine distance to boundary (in 2D xy)
8088	IF ( yxdir(1) > 0._wp ) THEN
8089	bdydim = ny + .5_wp !< north global boundary
8090	crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1)
8091	ELSEIF ( yxdir(1) == 0._wp ) THEN
8092	crossdist(1) = HUGE(1._wp)
8093	ELSE
8094	bdydim = -.5_wp !< south global boundary
8095	crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1)
8096	ENDIF
8097
8098	IF ( yxdir(2) > 0._wp ) THEN
8099	bdydim = nx + .5_wp !< east global boundary
8100	crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2)
8101	ELSEIF ( yxdir(2) == 0._wp ) THEN
8102	crossdist(2) = HUGE(1._wp)
8103	ELSE
8104	bdydim = -.5_wp !< west global boundary
8105	crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2)
8106	ENDIF
8107	distance = minval(crossdist, 1)
8108
8109	IF ( plant_canopy ) THEN
8110	rt2_track_dist(0) = 0._wp
8111	rt2_track_lad(:,:) = 0._wp
8112	nly = plantt_max - nz_urban_b + 1
8113	ENDIF
8114
8115	lastdist = 0._wp
8116
8117	!-- Since all face coordinates have values *.5 and we'd like to use
8118	!-- integers, all these have .5 added
8119	DO d = 1, 2
8120	IF ( yxdir(d) == 0._wp ) THEN
8121	dimnext(d) = HUGE(1_iwp)
8122	dimdelta(d) = HUGE(1_iwp)
8123	dimnextdist(d) = HUGE(1._wp)
8124	ELSE IF ( yxdir(d) > 0._wp ) THEN
8125	dimnext(d) = FLOOR(yxorigin(d) + .5_wp) + 1
8126	dimdelta(d) = 1
8127	dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d)
8128	ELSE
8129	dimnext(d) = CEILING(yxorigin(d) + .5_wp) - 1
8130	dimdelta(d) = -1
8131	dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d)
8132	ENDIF
8133	ENDDO
8134
8135	ntrack = 0
8136	DO
8137	!-- along what dimension will the next wall crossing be?
8138	seldim = minloc(dimnextdist, 1)
8139	nextdist = dimnextdist(seldim)
8140	IF ( nextdist > distance ) nextdist = distance
8141
8142	IF ( nextdist > lastdist ) THEN
8143	ntrack = ntrack + 1
8144	crmid = (lastdist + nextdist) * .5_wp
8145	column = NINT(yxorigin(:) + yxdir(:) * crmid, iwp)
8146
8147	!-- calculate index of the grid with global indices (column(1),column(2))
8148	!-- in the array nzterr and plantt and id of the coresponding processor
8149	px = column(2)/nnx
8150	py = column(1)/nny
8151	ip = px*pdims(2)+py
8152	ig = ipnnxnny + (column(2)-pxnnx)nny + column(1)-py*nny
8153
8154	IF ( lastdist == 0._wp ) THEN
8155	horz_entry = -HUGE(1._wp)
8156	ELSE
8157	horz_entry = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / lastdist
8158	ENDIF
8159	horz_exit = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / nextdist
8160
8161	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8162	!
8163	!-- Identify vertical obstacles hit by rays in current column
8164	DO WHILE ( lowest_free_ray > 0 )
8165	IF ( zdirs(lowest_free_ray) > horz_entry ) EXIT
8166	!
8167	!-- This may only happen after 1st column, so lastdir and lastcolumn are valid
8168	CALL request_itarget(lastdir, &
8169	CEILING(-0.5_wp + origin(1) + zdirs(lowest_free_ray)*lastdist), &
8170	lastcolumn(1), lastcolumn(2), &
8171	target_surfl(lowest_free_ray), target_procs(lowest_free_ray))
8172	lowest_free_ray = lowest_free_ray - 1
8173	ENDDO
8174	!
8175	!-- Identify horizontal obstacles hit by rays in current column
8176	DO WHILE ( lowest_free_ray > 0 )
8177	IF ( zdirs(lowest_free_ray) > horz_exit ) EXIT
8178	CALL request_itarget(iup_u, nzterr(ig)+1, column(1), column(2), &
8179	target_surfl(lowest_free_ray), &
8180	target_procs(lowest_free_ray))
8181	lowest_free_ray = lowest_free_ray - 1
8182	ENDDO
8183	ENDIF
8184
8185	horizon = MAX(horizon, horz_entry, horz_exit)
8186
8187	IF ( plant_canopy ) THEN
8188	rt2_track(:, ntrack) = column(:)
8189	rt2_track_dist(ntrack) = nextdist
8190	ENDIF
8191	ENDIF
8192
8193	IF ( nextdist + eps >= distance ) EXIT
8194
8195	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8196	!
8197	!-- Save wall direction of coming building column (= this air column)
8198	IF ( seldim == 1 ) THEN
8199	IF ( dimdelta(seldim) == 1 ) THEN
8200	lastdir = isouth_u
8201	ELSE
8202	lastdir = inorth_u
8203	ENDIF
8204	ELSE
8205	IF ( dimdelta(seldim) == 1 ) THEN
8206	lastdir = iwest_u
8207	ELSE
8208	lastdir = ieast_u
8209	ENDIF
8210	ENDIF
8211	lastcolumn = column
8212	ENDIF
8213	lastdist = nextdist
8214	dimnext(seldim) = dimnext(seldim) + dimdelta(seldim)
8215	dimnextdist(seldim) = (dimnext(seldim) - .5_wp - yxorigin(seldim)) / yxdir(seldim)
8216	ENDDO
8217
8218	IF ( plant_canopy ) THEN
8219	!-- Request LAD WHERE applicable
8220	!--
8221	#if defined( __parallel )
8222	IF ( raytrace_mpi_rma ) THEN
8223	!-- send requests for lad_s to appropriate processor
8224	!CALL cpu_log( log_point_s(77), 'usm_init_rma', 'start' )
8225	DO i = 1, ntrack
8226	px = rt2_track(2,i)/nnx
8227	py = rt2_track(1,i)/nny
8228	ip = px*pdims(2)+py
8229	ig = ipnnxnny + (rt2_track(2,i)-pxnnx)nny + rt2_track(1,i)-py*nny
8230
8231	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8232	!
8233	!-- For fixed view resolution, we need plant canopy even for rays
8234	!-- to opposing surfaces
8235	lowest_lad = nzterr(ig) + 1
8236	ELSE
8237	!
8238	!-- We only need LAD for rays directed above horizon (to sky)
8239	lowest_lad = CEILING( -0.5_wp + origin(1) + &
8240	MIN( horizon * rt2_track_dist(i-1), & ! entry
8241	horizon * rt2_track_dist(i) ) ) ! exit
8242	ENDIF
8243	!
8244	!-- Skip asking for LAD where all plant canopy is under requested level
8245	IF ( plantt(ig) < lowest_lad ) CYCLE
8246
8247	wdisp = (rt2_track(2,i)-pxnnx)(nnynz_plant) + (rt2_track(1,i)-pynny)*nz_plant + lowest_lad-nz_urban_b
8248	wcount = plantt(ig)-lowest_lad+1
8249	! TODO send request ASAP - even during raytracing
8250	CALL MPI_Get(rt2_track_lad(lowest_lad:plantt(ig), i), wcount, MPI_REAL, ip, &
8251	wdisp, wcount, MPI_REAL, win_lad, ierr)
8252	IF ( ierr /= 0 ) THEN
8253	WRITE(9,*) 'Error MPI_Get2:', ierr, rt2_track_lad(lowest_lad:plantt(ig), i), &
8254	wcount, ip, wdisp, win_lad
8255	FLUSH(9)
8256	ENDIF
8257	ENDDO
8258
8259	!-- wait for all pending local requests complete
8260	! TODO WAIT selectively for each column later when needed
8261	CALL MPI_Win_flush_local_all(win_lad, ierr)
8262	IF ( ierr /= 0 ) THEN
8263	WRITE(9,*) 'Error MPI_Win_flush_local_all2:', ierr, win_lad
8264	FLUSH(9)
8265	ENDIF
8266	!CALL cpu_log( log_point_s(77), 'usm_init_rma', 'stop' )
8267
8268	ELSE ! raytrace_mpi_rma = .F.
8269	DO i = 1, ntrack
8270	px = rt2_track(2,i)/nnx
8271	py = rt2_track(1,i)/nny
8272	ip = px*pdims(2)+py
8273	ig = ipnnxnnynz_plant + (rt2_track(2,i)-pxnnx)(nnynz_plant) + (rt2_track(1,i)-pynny)nz_plant
8274	rt2_track_lad(nz_urban_b:plantt_max, i) = sub_lad_g(ig:ig+nly-1)
8275	ENDDO
8276	ENDIF
8277	#else
8278	DO i = 1, ntrack
8279	rt2_track_lad(nz_urban_b:plantt_max, i) = sub_lad(rt2_track(1,i), rt2_track(2,i), nz_urban_b:plantt_max)
8280	ENDDO
8281	#endif
8282	ENDIF ! plant_canopy
8283
8284	IF ( rad_angular_discretization .AND. calc_svf ) THEN
8285	#if defined( __parallel )
8286	!-- wait for all gridsurf requests to complete
8287	CALL MPI_Win_flush_local_all(win_gridsurf, ierr)
8288	IF ( ierr /= 0 ) THEN
8289	WRITE(9,*) 'Error MPI_Win_flush_local_all3:', ierr, win_gridsurf
8290	FLUSH(9)
8291	ENDIF
8292	#endif
8293	!
8294	!-- recalculate local surf indices into global ones
8295	DO i = 1, nrays
8296	IF ( target_surfl(i) == -1 ) THEN
8297	itarget(i) = -1
8298	ELSE
8299	itarget(i) = target_surfl(i) + surfstart(target_procs(i))
8300	ENDIF
8301	ENDDO
8302
8303	DEALLOCATE( target_surfl )
8304
8305	ELSE
8306	itarget(:) = -1
8307	ENDIF ! rad_angular_discretization
8308
8309	IF ( plant_canopy ) THEN
8310	!-- Skip the PCB around origin if requested (for MRT, the PCB might not be there)
8311	!--
8312	IF ( skip_1st_pcb .AND. NINT(origin(1)) <= plantt_max ) THEN
8313	rt2_track_lad(NINT(origin(1), iwp), 1) = 0._wp
8314	ENDIF
8315
8316	!-- Assert that we have space allocated for CSFs
8317	!--
8318	maxboxes = (ntrack + MAX(CEILING(origin(1)-.5_wp) - nz_urban_b, &
8319	nz_urban_t - CEILING(origin(1)-.5_wp))) * nrays
8320	IF ( ncsfl + maxboxes > ncsfla ) THEN
8321	!-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1)
8322	!-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) &
8323	!-- / log(grow_factor)), kind=wp))
8324	!-- or use this code to simply always keep some extra space after growing
8325	k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor)
8326	CALL merge_and_grow_csf(k)
8327	ENDIF
8328
8329	!-- Calculate transparencies and store new CSFs
8330	!--
8331	zbottom = REAL(nz_urban_b, wp) - .5_wp
8332	ztop = REAL(plantt_max, wp) + .5_wp
8333
8334	!-- Reverse direction of radiation (face->sky), only when calc_svf
8335	!--
8336	IF ( calc_svf ) THEN
8337	DO i = 1, ntrack ! for each column
8338	dxxyy = ((dyyxdir(1))2 + (dxyxdir(2))*2) (rt2_track_dist(i)-rt2_track_dist(i-1))**2
8339	px = rt2_track(2,i)/nnx
8340	py = rt2_track(1,i)/nny
8341	ip = px*pdims(2)+py
8342
8343	DO k = 1, nrays ! for each ray
8344	!
8345	!-- NOTE 6778:
8346	!-- With traditional svf discretization, CSFs under the horizon
8347	!-- (i.e. for surface to surface radiation) are created in
8348	!-- raytrace(). With rad_angular_discretization, we must create
8349	!-- CSFs under horizon only for one direction, otherwise we would
8350	!-- have duplicate amount of energy. Although we could choose
8351	!-- either of the two directions (they differ only by
8352	!-- discretization error with no bias), we choose the the backward
8353	!-- direction, because it tends to cumulate high canopy sink
8354	!-- factors closer to raytrace origin, i.e. it should potentially
8355	!-- cause less moiree.
8356	IF ( .NOT. rad_angular_discretization ) THEN
8357	IF ( zdirs(k) <= horizon ) CYCLE
8358	ENDIF
8359
8360	zorig = origin(1) + zdirs(k) * rt2_track_dist(i-1)
8361	IF ( zorig <= zbottom .OR. zorig >= ztop ) CYCLE
8362
8363	zsgn = INT(SIGN(1._wp, zdirs(k)), iwp)
8364	rt2_dist(1) = 0._wp
8365	IF ( zdirs(k) == 0._wp ) THEN ! ray is exactly horizontal
8366	nz = 2
8367	rt2_dist(nz) = SQRT(dxxyy)
8368	iz = CEILING(-.5_wp + zorig, iwp)
8369	ELSE
8370	zexit = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop)
8371
8372	zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! because it must be greater than orig
8373	zb1 = CEILING(zexit * zsgn - .5_wp) - 1 ! because it must be smaller than exit
8374	nz = MAX(zb1 - zb0 + 3, 2)
8375	rt2_dist(nz) = SQRT(((zexit-zorig)dz(1))*2 + dxxyy)
8376	qdist = rt2_dist(nz) / (zexit-zorig)
8377	rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/)
8378	iz = zb0 * zsgn
8379	ENDIF
8380
8381	DO l = 2, nz
8382	IF ( rt2_track_lad(iz, i) > 0._wp ) THEN
8383	curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1)))
8384
8385	IF ( create_csf ) THEN
8386	ncsfl = ncsfl + 1
8387	acsf(ncsfl)%ip = ip
8388	acsf(ncsfl)%itx = rt2_track(2,i)
8389	acsf(ncsfl)%ity = rt2_track(1,i)
8390	acsf(ncsfl)%itz = iz
8391	acsf(ncsfl)%isurfs = iorig
8392	acsf(ncsfl)%rcvf = (1._wp - curtrans)transparency(k)vffrac(k)
8393	ENDIF
8394
8395	transparency(k) = transparency(k) * curtrans
8396	ENDIF
8397	iz = iz + zsgn
8398	ENDDO ! l = 1, nz - 1
8399	ENDDO ! k = 1, nrays
8400	ENDDO ! i = 1, ntrack
8401
8402	transparency(1:lowest_free_ray) = 1._wp !-- Reset rays above horizon to transparent (see NOTE 6778)
8403	ENDIF
8404
8405	!-- Forward direction of radiation (sky->face), always
8406	!--
8407	DO i = ntrack, 1, -1 ! for each column backwards
8408	dxxyy = ((dyyxdir(1))2 + (dxyxdir(2))*2) (rt2_track_dist(i)-rt2_track_dist(i-1))**2
8409	px = rt2_track(2,i)/nnx
8410	py = rt2_track(1,i)/nny
8411	ip = px*pdims(2)+py
8412
8413	DO k = 1, nrays ! for each ray
8414	!
8415	!-- See NOTE 6778 above
8416	IF ( zdirs(k) <= horizon ) CYCLE
8417
8418	zexit = origin(1) + zdirs(k) * rt2_track_dist(i-1)
8419	IF ( zexit <= zbottom .OR. zexit >= ztop ) CYCLE
8420
8421	zsgn = -INT(SIGN(1._wp, zdirs(k)), iwp)
8422	rt2_dist(1) = 0._wp
8423	IF ( zdirs(k) == 0._wp ) THEN ! ray is exactly horizontal
8424	nz = 2
8425	rt2_dist(nz) = SQRT(dxxyy)
8426	iz = NINT(zexit, iwp)
8427	ELSE
8428	zorig = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop)
8429
8430	zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! because it must be greater than orig
8431	zb1 = CEILING(zexit * zsgn - .5_wp) - 1 ! because it must be smaller than exit
8432	nz = MAX(zb1 - zb0 + 3, 2)
8433	rt2_dist(nz) = SQRT(((zexit-zorig)dz(1))*2 + dxxyy)
8434	qdist = rt2_dist(nz) / (zexit-zorig)
8435	rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/)
8436	iz = zb0 * zsgn
8437	ENDIF
8438
8439	DO l = 2, nz
8440	IF ( rt2_track_lad(iz, i) > 0._wp ) THEN
8441	curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1)))
8442
8443	IF ( create_csf ) THEN
8444	ncsfl = ncsfl + 1
8445	acsf(ncsfl)%ip = ip
8446	acsf(ncsfl)%itx = rt2_track(2,i)
8447	acsf(ncsfl)%ity = rt2_track(1,i)
8448	acsf(ncsfl)%itz = iz
8449	IF ( itarget(k) /= -1 ) STOP 1 !FIXME remove after test
8450	acsf(ncsfl)%isurfs = -1
8451	acsf(ncsfl)%rcvf = (1._wp - curtrans)transparency(k)aorig*vffrac(k)
8452	ENDIF ! create_csf
8453
8454	transparency(k) = transparency(k) * curtrans
8455	ENDIF
8456	iz = iz + zsgn
8457	ENDDO ! l = 1, nz - 1
8458	ENDDO ! k = 1, nrays
8459	ENDDO ! i = 1, ntrack
8460	ENDIF ! plant_canopy
8461
8462	IF ( .NOT. (rad_angular_discretization .AND. calc_svf) ) THEN
8463	!
8464	!-- Just update lowest_free_ray according to horizon
8465	DO WHILE ( lowest_free_ray > 0 )
8466	IF ( zdirs(lowest_free_ray) > horizon ) EXIT
8467	lowest_free_ray = lowest_free_ray - 1
8468	ENDDO
8469	ENDIF
8470
8471	CONTAINS
8472
8473	SUBROUTINE request_itarget( d, z, y, x, isurfl, iproc )
8474
8475	INTEGER(iwp), INTENT(in) :: d, z, y, x
8476	INTEGER(iwp), TARGET, INTENT(out) :: isurfl
8477	INTEGER(iwp), INTENT(out) :: iproc
8478	#if defined( __parallel )
8479	#else
8480	INTEGER(iwp) :: target_displ !< index of the grid in the local gridsurf array
8481	#endif
8482	INTEGER(iwp) :: px, py !< number of processors in x and y direction
8483	!< before the processor in the question
8484	#if defined( __parallel )
8485	INTEGER(KIND=MPI_ADDRESS_KIND) :: target_displ !< index of the grid in the local gridsurf array
8486
8487	!
8488	!-- Calculate target processor and index in the remote local target gridsurf array
8489	px = x / nnx
8490	py = y / nny
8491	iproc = px * pdims(2) + py
8492	target_displ = ((x-pxnnx) nny + y - pynny ) nz_urban * nsurf_type_u +&
8493	( z-nz_urban_b ) * nsurf_type_u + d
8494	!
8495	!-- Send MPI_Get request to obtain index target_surfl(i)
8496	CALL MPI_GET( isurfl, 1, MPI_INTEGER, iproc, target_displ, &
8497	1, MPI_INTEGER, win_gridsurf, ierr)
8498	IF ( ierr /= 0 ) THEN
8499	WRITE( 9,* ) 'Error MPI_Get3:', ierr, isurfl, iproc, target_displ, &
8500	win_gridsurf
8501	FLUSH( 9 )
8502	ENDIF
8503	#else
8504	!-- set index target_surfl(i)
8505	isurfl = gridsurf(d,z,y,x)
8506	#endif
8507
8508	END SUBROUTINE request_itarget
8509
8510	END SUBROUTINE raytrace_2d
8511
8512
8513	!------------------------------------------------------------------------------!
8514	!
8515	! Description:
8516	! ------------
8517	!> Calculates apparent solar positions for all timesteps and stores discretized
8518	!> positions.
8519	!------------------------------------------------------------------------------!
8520	SUBROUTINE radiation_presimulate_solar_pos
8521
8522	IMPLICIT NONE
8523
8524	INTEGER(iwp) :: it, i, j
8525	INTEGER(iwp) :: day_of_month_prev,month_of_year_prev
8526	REAL(wp) :: tsrp_prev
8527	REAL(wp) :: simulated_time_prev
8528	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir_tmp !< dsidir_tmp[:,i] = unit vector of i-th
8529	!< appreant solar direction
8530
8531	ALLOCATE ( dsidir_rev(0:raytrace_discrete_elevs/2-1, &
8532	0:raytrace_discrete_azims-1) )
8533	dsidir_rev(:,:) = -1
8534	ALLOCATE ( dsidir_tmp(3, &
8535	raytrace_discrete_elevs/2*raytrace_discrete_azims) )
8536	ndsidir = 0
8537
8538	!
8539	!-- We will artificialy update time_since_reference_point and return to
8540	!-- true value later
8541	tsrp_prev = time_since_reference_point
8542	simulated_time_prev = simulated_time
8543	day_of_month_prev = day_of_month
8544	month_of_year_prev = month_of_year
8545	sun_direction = .TRUE.
8546
8547	!
8548	!-- initialize the simulated_time
8549	simulated_time = 0._wp
8550	!
8551	!-- Process spinup time if configured
8552	IF ( spinup_time > 0._wp ) THEN
8553	DO it = 0, CEILING(spinup_time / dt_spinup)
8554	time_since_reference_point = -spinup_time + REAL(it, wp) * dt_spinup
8555	simulated_time = simulated_time + dt_spinup
8556	CALL simulate_pos
8557	ENDDO
8558	ENDIF
8559	!
8560	!-- Process simulation time
8561	DO it = 0, CEILING(( end_time - spinup_time ) / dt_radiation)
8562	time_since_reference_point = REAL(it, wp) * dt_radiation
8563	simulated_time = simulated_time + dt_radiation
8564	CALL simulate_pos
8565	ENDDO
8566	!
8567	!-- Return date and time to its original values
8568	time_since_reference_point = tsrp_prev
8569	simulated_time = simulated_time_prev
8570	day_of_month = day_of_month_prev
8571	month_of_year = month_of_year_prev
8572	CALL init_date_and_time
8573
8574	!-- Allocate global vars which depend on ndsidir
8575	ALLOCATE ( dsidir ( 3, ndsidir ) )
8576	dsidir(:,:) = dsidir_tmp(:, 1:ndsidir)
8577	DEALLOCATE ( dsidir_tmp )
8578
8579	ALLOCATE ( dsitrans(nsurfl, ndsidir) )
8580	ALLOCATE ( dsitransc(npcbl, ndsidir) )
8581	IF ( nmrtbl > 0 ) ALLOCATE ( mrtdsit(nmrtbl, ndsidir) )
8582
8583	WRITE ( message_string, * ) 'Precalculated', ndsidir, ' solar positions', &
8584	' from', it, ' timesteps.'
8585	CALL message( 'radiation_presimulate_solar_pos', 'UI0013', 0, 0, 0, 6, 0 )
8586
8587	CONTAINS
8588
8589	!------------------------------------------------------------------------!
8590	! Description:
8591	! ------------
8592	!> Simuates a single position
8593	!------------------------------------------------------------------------!
8594	SUBROUTINE simulate_pos
8595	IMPLICIT NONE
8596	!
8597	!-- Update apparent solar position based on modified t_s_r_p
8598	CALL calc_zenith
8599	IF ( cos_zenith > 0 ) THEN
8600	!--
8601	!-- Identify solar direction vector (discretized number) 1)
8602	i = MODULO(NINT(ATAN2(sun_dir_lon, sun_dir_lat) &
8603	/ (2._wppi) raytrace_discrete_azims-.5_wp, iwp), &
8604	raytrace_discrete_azims)
8605	j = FLOOR(ACOS(cos_zenith) / pi * raytrace_discrete_elevs)
8606	IF ( dsidir_rev(j, i) == -1 ) THEN
8607	ndsidir = ndsidir + 1
8608	dsidir_tmp(:, ndsidir) = &
8609	(/ COS((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs), &
8610	SIN((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs) &
8611	* COS((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims), &
8612	SIN((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs) &
8613	* SIN((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims) /)
8614	dsidir_rev(j, i) = ndsidir
8615	ENDIF
8616	ENDIF
8617	END SUBROUTINE simulate_pos
8618
8619	END SUBROUTINE radiation_presimulate_solar_pos
8620
8621
8622
8623	!------------------------------------------------------------------------------!
8624	! Description:
8625	! ------------
8626	!> Determines whether two faces are oriented towards each other. Since the
8627	!> surfaces follow the gird box surfaces, it checks first whether the two surfaces
8628	!> are directed in the same direction, then it checks if the two surfaces are
8629	!> located in confronted direction but facing away from each other, e.g. <--\| \|-->
8630	!------------------------------------------------------------------------------!
8631	PURE LOGICAL FUNCTION surface_facing(x, y, z, d, x2, y2, z2, d2)
8632	IMPLICIT NONE
8633	INTEGER(iwp), INTENT(in) :: x, y, z, d, x2, y2, z2, d2
8634
8635	surface_facing = .FALSE.
8636
8637	!-- first check: are the two surfaces directed in the same direction
8638	IF ( (d==iup_u .OR. d==iup_l ) &
8639	.AND. (d2==iup_u .OR. d2==iup_l) ) RETURN
8640	IF ( (d==isouth_u .OR. d==isouth_l ) &
8641	.AND. (d2==isouth_u .OR. d2==isouth_l) ) RETURN
8642	IF ( (d==inorth_u .OR. d==inorth_l ) &
8643	.AND. (d2==inorth_u .OR. d2==inorth_l) ) RETURN
8644	IF ( (d==iwest_u .OR. d==iwest_l ) &
8645	.AND. (d2==iwest_u .OR. d2==iwest_l ) ) RETURN
8646	IF ( (d==ieast_u .OR. d==ieast_l ) &
8647	.AND. (d2==ieast_u .OR. d2==ieast_l ) ) RETURN
8648
8649	!-- second check: are surfaces facing away from each other
8650	SELECT CASE (d)
8651	CASE (iup_u, iup_l) !< upward facing surfaces
8652	IF ( z2 < z ) RETURN
8653	CASE (isouth_u, isouth_l) !< southward facing surfaces
8654	IF ( y2 > y ) RETURN
8655	CASE (inorth_u, inorth_l) !< northward facing surfaces
8656	IF ( y2 < y ) RETURN
8657	CASE (iwest_u, iwest_l) !< westward facing surfaces
8658	IF ( x2 > x ) RETURN
8659	CASE (ieast_u, ieast_l) !< eastward facing surfaces
8660	IF ( x2 < x ) RETURN
8661	END SELECT
8662
8663	SELECT CASE (d2)
8664	CASE (iup_u) !< ground, roof
8665	IF ( z < z2 ) RETURN
8666	CASE (isouth_u, isouth_l) !< south facing
8667	IF ( y > y2 ) RETURN
8668	CASE (inorth_u, inorth_l) !< north facing
8669	IF ( y < y2 ) RETURN
8670	CASE (iwest_u, iwest_l) !< west facing
8671	IF ( x > x2 ) RETURN
8672	CASE (ieast_u, ieast_l) !< east facing
8673	IF ( x < x2 ) RETURN
8674	CASE (-1)
8675	CONTINUE
8676	END SELECT
8677
8678	surface_facing = .TRUE.
8679
8680	END FUNCTION surface_facing
8681
8682
8683	!------------------------------------------------------------------------------!
8684	!
8685	! Description:
8686	! ------------
8687	!> Reads svf, svfsurf, csf, csfsurf and mrt factors data from saved file
8688	!> SVF means sky view factors and CSF means canopy sink factors
8689	!------------------------------------------------------------------------------!
8690	SUBROUTINE radiation_read_svf
8691
8692	IMPLICIT NONE
8693
8694	CHARACTER(rad_version_len) :: rad_version_field
8695
8696	INTEGER(iwp) :: i
8697	INTEGER(iwp) :: ndsidir_from_file = 0
8698	INTEGER(iwp) :: npcbl_from_file = 0
8699	INTEGER(iwp) :: nsurfl_from_file = 0
8700	INTEGER(iwp) :: nmrtbl_from_file = 0
8701
8702
8703	CALL location_message( 'reading view factors for radiation interaction', 'start' )
8704
8705	DO i = 0, io_blocks-1
8706	IF ( i == io_group ) THEN
8707
8708	!
8709	!-- numprocs_previous_run is only known in case of reading restart
8710	!-- data. If a new initial run which reads svf data is started the
8711	!-- following query will be skipped
8712	IF ( initializing_actions == 'read_restart_data' ) THEN
8713
8714	IF ( numprocs_previous_run /= numprocs ) THEN
8715	WRITE( message_string, * ) 'A different number of ', &
8716	'processors between the run ', &
8717	'that has written the svf data ',&
8718	'and the one that will read it ',&
8719	'is not allowed'
8720	CALL message( 'check_open', 'PA0491', 1, 2, 0, 6, 0 )
8721	ENDIF
8722
8723	ENDIF
8724
8725	!
8726	!-- Open binary file
8727	CALL check_open( 88 )
8728
8729	!
8730	!-- read and check version
8731	READ ( 88 ) rad_version_field
8732	IF ( TRIM(rad_version_field) /= TRIM(rad_version) ) THEN
8733	WRITE( message_string, * ) 'Version of binary SVF file "', &
8734	TRIM(rad_version_field), '" does not match ', &
8735	'the version of model "', TRIM(rad_version), '"'
8736	CALL message( 'radiation_read_svf', 'PA0482', 1, 2, 0, 6, 0 )
8737	ENDIF
8738
8739	!
8740	!-- read nsvfl, ncsfl, nsurfl, nmrtf
8741	READ ( 88 ) nsvfl, ncsfl, nsurfl_from_file, npcbl_from_file, &
8742	ndsidir_from_file, nmrtbl_from_file, nmrtf
8743
8744	IF ( nsvfl < 0 .OR. ncsfl < 0 ) THEN
8745	WRITE( message_string, * ) 'Wrong number of SVF or CSF'
8746	CALL message( 'radiation_read_svf', 'PA0483', 1, 2, 0, 6, 0 )
8747	ELSE
8748	WRITE(debug_string,*) 'Number of SVF, CSF, and nsurfl ', &
8749	'to read', nsvfl, ncsfl, &
8750	nsurfl_from_file
8751	IF ( debug_output ) CALL debug_message( debug_string, 'info' )
8752	ENDIF
8753
8754	IF ( nsurfl_from_file /= nsurfl ) THEN
8755	WRITE( message_string, * ) 'nsurfl from SVF file does not ', &
8756	'match calculated nsurfl from ', &
8757	'radiation_interaction_init'
8758	CALL message( 'radiation_read_svf', 'PA0490', 1, 2, 0, 6, 0 )
8759	ENDIF
8760
8761	IF ( npcbl_from_file /= npcbl ) THEN
8762	WRITE( message_string, * ) 'npcbl from SVF file does not ', &
8763	'match calculated npcbl from ', &
8764	'radiation_interaction_init'
8765	CALL message( 'radiation_read_svf', 'PA0493', 1, 2, 0, 6, 0 )
8766	ENDIF
8767
8768	IF ( ndsidir_from_file /= ndsidir ) THEN
8769	WRITE( message_string, * ) 'ndsidir from SVF file does not ', &
8770	'match calculated ndsidir from ', &
8771	'radiation_presimulate_solar_pos'
8772	CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 )
8773	ENDIF
8774	IF ( nmrtbl_from_file /= nmrtbl ) THEN
8775	WRITE( message_string, * ) 'nmrtbl from SVF file does not ', &
8776	'match calculated nmrtbl from ', &
8777	'radiation_interaction_init'
8778	CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 )
8779	ELSE
8780	WRITE(debug_string,*) 'Number of nmrtf to read ', nmrtf
8781	IF ( debug_output ) CALL debug_message( debug_string, 'info' )
8782	ENDIF
8783
8784	!
8785	!-- Arrays skyvf, skyvft, dsitrans and dsitransc are allready
8786	!-- allocated in radiation_interaction_init and
8787	!-- radiation_presimulate_solar_pos
8788	IF ( nsurfl > 0 ) THEN
8789	READ(88) skyvf
8790	READ(88) skyvft
8791	READ(88) dsitrans
8792	ENDIF
8793
8794	IF ( plant_canopy .AND. npcbl > 0 ) THEN
8795	READ ( 88 ) dsitransc
8796	ENDIF
8797
8798	!
8799	!-- The allocation of svf, svfsurf, csf, csfsurf, mrtf, mrtft, and
8800	!-- mrtfsurf happens in routine radiation_calc_svf which is not
8801	!-- called if the program enters radiation_read_svf. Therefore
8802	!-- these arrays has to allocate in the following
8803	IF ( nsvfl > 0 ) THEN
8804	ALLOCATE( svf(ndsvf,nsvfl) )
8805	ALLOCATE( svfsurf(idsvf,nsvfl) )
8806	READ(88) svf
8807	READ(88) svfsurf
8808	ENDIF
8809
8810	IF ( plant_canopy .AND. ncsfl > 0 ) THEN
8811	ALLOCATE( csf(ndcsf,ncsfl) )
8812	ALLOCATE( csfsurf(idcsf,ncsfl) )
8813	READ(88) csf
8814	READ(88) csfsurf
8815	ENDIF
8816
8817	IF ( nmrtbl > 0 ) THEN
8818	READ(88) mrtsky
8819	READ(88) mrtskyt
8820	READ(88) mrtdsit
8821	ENDIF
8822
8823	IF ( nmrtf > 0 ) THEN
8824	ALLOCATE ( mrtf(nmrtf) )
8825	ALLOCATE ( mrtft(nmrtf) )
8826	ALLOCATE ( mrtfsurf(2,nmrtf) )
8827	READ(88) mrtf
8828	READ(88) mrtft
8829	READ(88) mrtfsurf
8830	ENDIF
8831
8832	!
8833	!-- Close binary file
8834	CALL close_file( 88 )
8835
8836	ENDIF
8837	#if defined( __parallel )
8838	CALL MPI_BARRIER( comm2d, ierr )
8839	#endif
8840	ENDDO
8841
8842	CALL location_message( 'reading view factors for radiation interaction', 'finished' )
8843
8844
8845	END SUBROUTINE radiation_read_svf
8846
8847
8848	!------------------------------------------------------------------------------!
8849	!
8850	! Description:
8851	! ------------
8852	!> Subroutine stores svf, svfsurf, csf, csfsurf and mrt data to a file.
8853	!------------------------------------------------------------------------------!
8854	SUBROUTINE radiation_write_svf
8855
8856	IMPLICIT NONE
8857
8858	INTEGER(iwp) :: i
8859
8860
8861	CALL location_message( 'writing view factors for radiation interaction', 'start' )
8862
8863	DO i = 0, io_blocks-1
8864	IF ( i == io_group ) THEN
8865	!
8866	!-- Open binary file
8867	CALL check_open( 89 )
8868
8869	WRITE ( 89 ) rad_version
8870	WRITE ( 89 ) nsvfl, ncsfl, nsurfl, npcbl, ndsidir, nmrtbl, nmrtf
8871	IF ( nsurfl > 0 ) THEN
8872	WRITE ( 89 ) skyvf
8873	WRITE ( 89 ) skyvft
8874	WRITE ( 89 ) dsitrans
8875	ENDIF
8876	IF ( npcbl > 0 ) THEN
8877	WRITE ( 89 ) dsitransc
8878	ENDIF
8879	IF ( nsvfl > 0 ) THEN
8880	WRITE ( 89 ) svf
8881	WRITE ( 89 ) svfsurf
8882	ENDIF
8883	IF ( plant_canopy .AND. ncsfl > 0 ) THEN
8884	WRITE ( 89 ) csf
8885	WRITE ( 89 ) csfsurf
8886	ENDIF
8887	IF ( nmrtbl > 0 ) THEN
8888	WRITE ( 89 ) mrtsky
8889	WRITE ( 89 ) mrtskyt
8890	WRITE ( 89 ) mrtdsit
8891	ENDIF
8892	IF ( nmrtf > 0 ) THEN
8893	WRITE ( 89 ) mrtf
8894	WRITE ( 89 ) mrtft
8895	WRITE ( 89 ) mrtfsurf
8896	ENDIF
8897	!
8898	!-- Close binary file
8899	CALL close_file( 89 )
8900
8901	ENDIF
8902	#if defined( __parallel )
8903	CALL MPI_BARRIER( comm2d, ierr )
8904	#endif
8905	ENDDO
8906
8907	CALL location_message( 'writing view factors for radiation interaction', 'finished' )
8908
8909
8910	END SUBROUTINE radiation_write_svf
8911
8912
8913	!------------------------------------------------------------------------------!
8914	!
8915	! Description:
8916	! ------------
8917	!> Block of auxiliary subroutines:
8918	!> 1. quicksort and corresponding comparison
8919	!> 2. merge_and_grow_csf for implementation of "dynamical growing"
8920	!> array for csf
8921	!------------------------------------------------------------------------------!
8922	!-- quicksort.f --f90--
8923	!-- Author: t-nissie, adaptation J.Resler
8924	!-- License: GPLv3
8925	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
8926	RECURSIVE SUBROUTINE quicksort_itarget(itarget, vffrac, ztransp, first, last)
8927	IMPLICIT NONE
8928	INTEGER(iwp), DIMENSION(:), INTENT(INOUT) :: itarget
8929	REAL(wp), DIMENSION(:), INTENT(INOUT) :: vffrac, ztransp
8930	INTEGER(iwp), INTENT(IN) :: first, last
8931	INTEGER(iwp) :: x, t
8932	INTEGER(iwp) :: i, j
8933	REAL(wp) :: tr
8934
8935	IF ( first>=last ) RETURN
8936	x = itarget((first+last)/2)
8937	i = first
8938	j = last
8939	DO
8940	DO WHILE ( itarget(i) < x )
8941	i=i+1
8942	ENDDO
8943	DO WHILE ( x < itarget(j) )
8944	j=j-1
8945	ENDDO
8946	IF ( i >= j ) EXIT
8947	t = itarget(i); itarget(i) = itarget(j); itarget(j) = t
8948	tr = vffrac(i); vffrac(i) = vffrac(j); vffrac(j) = tr
8949	tr = ztransp(i); ztransp(i) = ztransp(j); ztransp(j) = tr
8950	i=i+1
8951	j=j-1
8952	ENDDO
8953	IF ( first < i-1 ) CALL quicksort_itarget(itarget, vffrac, ztransp, first, i-1)
8954	IF ( j+1 < last ) CALL quicksort_itarget(itarget, vffrac, ztransp, j+1, last)
8955	END SUBROUTINE quicksort_itarget
8956
8957	PURE FUNCTION svf_lt(svf1,svf2) result (res)
8958	TYPE (t_svf), INTENT(in) :: svf1,svf2
8959	LOGICAL :: res
8960	IF ( svf1%isurflt < svf2%isurflt .OR. &
8961	(svf1%isurflt == svf2%isurflt .AND. svf1%isurfs < svf2%isurfs) ) THEN
8962	res = .TRUE.
8963	ELSE
8964	res = .FALSE.
8965	ENDIF
8966	END FUNCTION svf_lt
8967
8968
8969	!-- quicksort.f --f90--
8970	!-- Author: t-nissie, adaptation J.Resler
8971	!-- License: GPLv3
8972	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
8973	RECURSIVE SUBROUTINE quicksort_svf(svfl, first, last)
8974	IMPLICIT NONE
8975	TYPE(t_svf), DIMENSION(:), INTENT(INOUT) :: svfl
8976	INTEGER(iwp), INTENT(IN) :: first, last
8977	TYPE(t_svf) :: x, t
8978	INTEGER(iwp) :: i, j
8979
8980	IF ( first>=last ) RETURN
8981	x = svfl( (first+last) / 2 )
8982	i = first
8983	j = last
8984	DO
8985	DO while ( svf_lt(svfl(i),x) )
8986	i=i+1
8987	ENDDO
8988	DO while ( svf_lt(x,svfl(j)) )
8989	j=j-1
8990	ENDDO
8991	IF ( i >= j ) EXIT
8992	t = svfl(i); svfl(i) = svfl(j); svfl(j) = t
8993	i=i+1
8994	j=j-1
8995	ENDDO
8996	IF ( first < i-1 ) CALL quicksort_svf(svfl, first, i-1)
8997	IF ( j+1 < last ) CALL quicksort_svf(svfl, j+1, last)
8998	END SUBROUTINE quicksort_svf
8999
9000	PURE FUNCTION csf_lt(csf1,csf2) result (res)
9001	TYPE (t_csf), INTENT(in) :: csf1,csf2
9002	LOGICAL :: res
9003	IF ( csf1%ip < csf2%ip .OR. &
9004	(csf1%ip == csf2%ip .AND. csf1%itx < csf2%itx) .OR. &
9005	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity < csf2%ity) .OR. &
9006	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. &
9007	csf1%itz < csf2%itz) .OR. &
9008	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. &
9009	csf1%itz == csf2%itz .AND. csf1%isurfs < csf2%isurfs) ) THEN
9010	res = .TRUE.
9011	ELSE
9012	res = .FALSE.
9013	ENDIF
9014	END FUNCTION csf_lt
9015
9016
9017	!-- quicksort.f --f90--
9018	!-- Author: t-nissie, adaptation J.Resler
9019	!-- License: GPLv3
9020	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9021	RECURSIVE SUBROUTINE quicksort_csf(csfl, first, last)
9022	IMPLICIT NONE
9023	TYPE(t_csf), DIMENSION(:), INTENT(INOUT) :: csfl
9024	INTEGER(iwp), INTENT(IN) :: first, last
9025	TYPE(t_csf) :: x, t
9026	INTEGER(iwp) :: i, j
9027
9028	IF ( first>=last ) RETURN
9029	x = csfl( (first+last)/2 )
9030	i = first
9031	j = last
9032	DO
9033	DO while ( csf_lt(csfl(i),x) )
9034	i=i+1
9035	ENDDO
9036	DO while ( csf_lt(x,csfl(j)) )
9037	j=j-1
9038	ENDDO
9039	IF ( i >= j ) EXIT
9040	t = csfl(i); csfl(i) = csfl(j); csfl(j) = t
9041	i=i+1
9042	j=j-1
9043	ENDDO
9044	IF ( first < i-1 ) CALL quicksort_csf(csfl, first, i-1)
9045	IF ( j+1 < last ) CALL quicksort_csf(csfl, j+1, last)
9046	END SUBROUTINE quicksort_csf
9047
9048
9049	!------------------------------------------------------------------------------!
9050	!
9051	! Description:
9052	! ------------
9053	!> Grows the CSF array exponentially after it is full. During that, the ray
9054	!> canopy sink factors with common source face and target plant canopy grid
9055	!> cell are merged together so that the size doesn't grow out of control.
9056	!------------------------------------------------------------------------------!
9057	SUBROUTINE merge_and_grow_csf(newsize)
9058	INTEGER(iwp), INTENT(in) :: newsize !< new array size after grow, must be >= ncsfl
9059	!< or -1 to shrink to minimum
9060	INTEGER(iwp) :: iread, iwrite
9061	TYPE(t_csf), DIMENSION(:), POINTER :: acsfnew
9062
9063
9064	IF ( newsize == -1 ) THEN
9065	!-- merge in-place
9066	acsfnew => acsf
9067	ELSE
9068	!-- allocate new array
9069	IF ( mcsf == 0 ) THEN
9070	ALLOCATE( acsf1(newsize) )
9071	acsfnew => acsf1
9072	ELSE
9073	ALLOCATE( acsf2(newsize) )
9074	acsfnew => acsf2
9075	ENDIF
9076	ENDIF
9077
9078	IF ( ncsfl >= 1 ) THEN
9079	!-- sort csf in place (quicksort)
9080	CALL quicksort_csf(acsf,1,ncsfl)
9081
9082	!-- while moving to a new array, aggregate canopy sink factor records with identical box & source
9083	acsfnew(1) = acsf(1)
9084	iwrite = 1
9085	DO iread = 2, ncsfl
9086	!-- here acsf(kcsf) already has values from acsf(icsf)
9087	IF ( acsfnew(iwrite)%itx == acsf(iread)%itx &
9088	.AND. acsfnew(iwrite)%ity == acsf(iread)%ity &
9089	.AND. acsfnew(iwrite)%itz == acsf(iread)%itz &
9090	.AND. acsfnew(iwrite)%isurfs == acsf(iread)%isurfs ) THEN
9091
9092	acsfnew(iwrite)%rcvf = acsfnew(iwrite)%rcvf + acsf(iread)%rcvf
9093	!-- advance reading index, keep writing index
9094	ELSE
9095	!-- not identical, just advance and copy
9096	iwrite = iwrite + 1
9097	acsfnew(iwrite) = acsf(iread)
9098	ENDIF
9099	ENDDO
9100	ncsfl = iwrite
9101	ENDIF
9102
9103	IF ( newsize == -1 ) THEN
9104	!-- allocate new array and copy shrinked data
9105	IF ( mcsf == 0 ) THEN
9106	ALLOCATE( acsf1(ncsfl) )
9107	acsf1(1:ncsfl) = acsf2(1:ncsfl)
9108	ELSE
9109	ALLOCATE( acsf2(ncsfl) )
9110	acsf2(1:ncsfl) = acsf1(1:ncsfl)
9111	ENDIF
9112	ENDIF
9113
9114	!-- deallocate old array
9115	IF ( mcsf == 0 ) THEN
9116	mcsf = 1
9117	acsf => acsf1
9118	DEALLOCATE( acsf2 )
9119	ELSE
9120	mcsf = 0
9121	acsf => acsf2
9122	DEALLOCATE( acsf1 )
9123	ENDIF
9124	ncsfla = newsize
9125
9126	IF ( debug_output ) THEN
9127	WRITE( debug_string, '(A,2I12)' ) 'Grow acsf2:', ncsfl, ncsfla
9128	CALL debug_message( debug_string, 'info' )
9129	ENDIF
9130
9131	END SUBROUTINE merge_and_grow_csf
9132
9133
9134	!-- quicksort.f --f90--
9135	!-- Author: t-nissie, adaptation J.Resler
9136	!-- License: GPLv3
9137	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9138	RECURSIVE SUBROUTINE quicksort_csf2(kpcsflt, pcsflt, first, last)
9139	IMPLICIT NONE
9140	INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT) :: kpcsflt
9141	REAL(wp), DIMENSION(:,:), INTENT(INOUT) :: pcsflt
9142	INTEGER(iwp), INTENT(IN) :: first, last
9143	REAL(wp), DIMENSION(ndcsf) :: t2
9144	INTEGER(iwp), DIMENSION(kdcsf) :: x, t1
9145	INTEGER(iwp) :: i, j
9146
9147	IF ( first>=last ) RETURN
9148	x = kpcsflt(:, (first+last)/2 )
9149	i = first
9150	j = last
9151	DO
9152	DO while ( csf_lt2(kpcsflt(:,i),x) )
9153	i=i+1
9154	ENDDO
9155	DO while ( csf_lt2(x,kpcsflt(:,j)) )
9156	j=j-1
9157	ENDDO
9158	IF ( i >= j ) EXIT
9159	t1 = kpcsflt(:,i); kpcsflt(:,i) = kpcsflt(:,j); kpcsflt(:,j) = t1
9160	t2 = pcsflt(:,i); pcsflt(:,i) = pcsflt(:,j); pcsflt(:,j) = t2
9161	i=i+1
9162	j=j-1
9163	ENDDO
9164	IF ( first < i-1 ) CALL quicksort_csf2(kpcsflt, pcsflt, first, i-1)
9165	IF ( j+1 < last ) CALL quicksort_csf2(kpcsflt, pcsflt, j+1, last)
9166	END SUBROUTINE quicksort_csf2
9167
9168
9169	PURE FUNCTION csf_lt2(item1, item2) result(res)
9170	INTEGER(iwp), DIMENSION(kdcsf), INTENT(in) :: item1, item2
9171	LOGICAL :: res
9172	res = ( (item1(3) < item2(3)) &
9173	.OR. (item1(3) == item2(3) .AND. item1(2) < item2(2)) &
9174	.OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) < item2(1)) &
9175	.OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) == item2(1) &
9176	.AND. item1(4) < item2(4)) )
9177	END FUNCTION csf_lt2
9178
9179	PURE FUNCTION searchsorted(athresh, val) result(ind)
9180	REAL(wp), DIMENSION(:), INTENT(IN) :: athresh
9181	REAL(wp), INTENT(IN) :: val
9182	INTEGER(iwp) :: ind
9183	INTEGER(iwp) :: i
9184
9185	DO i = LBOUND(athresh, 1), UBOUND(athresh, 1)
9186	IF ( val < athresh(i) ) THEN
9187	ind = i - 1
9188	RETURN
9189	ENDIF
9190	ENDDO
9191	ind = UBOUND(athresh, 1)
9192	END FUNCTION searchsorted
9193
9194
9195	!------------------------------------------------------------------------------!
9196	!
9197	! Description:
9198	! ------------
9199	!> Subroutine for averaging 3D data
9200	!------------------------------------------------------------------------------!
9201	SUBROUTINE radiation_3d_data_averaging( mode, variable )
9202
9203
9204	USE control_parameters
9205
9206	USE indices
9207
9208	USE kinds
9209
9210	IMPLICIT NONE
9211
9212	CHARACTER (LEN=*) :: mode !<
9213	CHARACTER (LEN=*) :: variable !<
9214
9215	LOGICAL :: match_lsm !< flag indicating natural-type surface
9216	LOGICAL :: match_usm !< flag indicating urban-type surface
9217
9218	INTEGER(iwp) :: i !<
9219	INTEGER(iwp) :: j !<
9220	INTEGER(iwp) :: k !<
9221	INTEGER(iwp) :: l, m !< index of current surface element
9222
9223	INTEGER(iwp) :: ids, idsint_u, idsint_l, isurf
9224	CHARACTER(LEN=varnamelength) :: var
9225
9226	!-- find the real name of the variable
9227	ids = -1
9228	l = -1
9229	var = TRIM(variable)
9230	DO i = 0, nd-1
9231	k = len(TRIM(var))
9232	j = len(TRIM(dirname(i)))
9233	IF ( k-j+1 >= 1_iwp ) THEN
9234	IF ( TRIM(var(k-j+1:k)) == TRIM(dirname(i)) ) THEN
9235	ids = i
9236	idsint_u = dirint_u(ids)
9237	idsint_l = dirint_l(ids)
9238	var = var(:k-j)
9239	EXIT
9240	ENDIF
9241	ENDIF
9242	ENDDO
9243	IF ( ids == -1 ) THEN
9244	var = TRIM(variable)
9245	ENDIF
9246
9247	IF ( mode == 'allocate' ) THEN
9248
9249	SELECT CASE ( TRIM( var ) )
9250	!-- block of large scale (e.g. RRTMG) radiation output variables
9251	CASE ( 'rad_net*' )
9252	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
9253	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
9254	ENDIF
9255	rad_net_av = 0.0_wp
9256
9257	CASE ( 'rad_lw_in*' )
9258	IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
9259	ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
9260	ENDIF
9261	rad_lw_in_xy_av = 0.0_wp
9262
9263	CASE ( 'rad_lw_out*' )
9264	IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
9265	ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
9266	ENDIF
9267	rad_lw_out_xy_av = 0.0_wp
9268
9269	CASE ( 'rad_sw_in*' )
9270	IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
9271	ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
9272	ENDIF
9273	rad_sw_in_xy_av = 0.0_wp
9274
9275	CASE ( 'rad_sw_out*' )
9276	IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
9277	ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
9278	ENDIF
9279	rad_sw_out_xy_av = 0.0_wp
9280
9281	CASE ( 'rad_lw_in' )
9282	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
9283	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9284	ENDIF
9285	rad_lw_in_av = 0.0_wp
9286
9287	CASE ( 'rad_lw_out' )
9288	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
9289	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9290	ENDIF
9291	rad_lw_out_av = 0.0_wp
9292
9293	CASE ( 'rad_lw_cs_hr' )
9294	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
9295	ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9296	ENDIF
9297	rad_lw_cs_hr_av = 0.0_wp
9298
9299	CASE ( 'rad_lw_hr' )
9300	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
9301	ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9302	ENDIF
9303	rad_lw_hr_av = 0.0_wp
9304
9305	CASE ( 'rad_sw_in' )
9306	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
9307	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9308	ENDIF
9309	rad_sw_in_av = 0.0_wp
9310
9311	CASE ( 'rad_sw_out' )
9312	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
9313	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9314	ENDIF
9315	rad_sw_out_av = 0.0_wp
9316
9317	CASE ( 'rad_sw_cs_hr' )
9318	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
9319	ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9320	ENDIF
9321	rad_sw_cs_hr_av = 0.0_wp
9322
9323	CASE ( 'rad_sw_hr' )
9324	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
9325	ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9326	ENDIF
9327	rad_sw_hr_av = 0.0_wp
9328
9329	!-- block of RTM output variables
9330	CASE ( 'rtm_rad_net' )
9331	!-- array of complete radiation balance
9332	IF ( .NOT. ALLOCATED(surfradnet_av) ) THEN
9333	ALLOCATE( surfradnet_av(nsurfl) )
9334	surfradnet_av = 0.0_wp
9335	ENDIF
9336
9337	CASE ( 'rtm_rad_insw' )
9338	!-- array of sw radiation falling to surface after i-th reflection
9339	IF ( .NOT. ALLOCATED(surfinsw_av) ) THEN
9340	ALLOCATE( surfinsw_av(nsurfl) )
9341	surfinsw_av = 0.0_wp
9342	ENDIF
9343
9344	CASE ( 'rtm_rad_inlw' )
9345	!-- array of lw radiation falling to surface after i-th reflection
9346	IF ( .NOT. ALLOCATED(surfinlw_av) ) THEN
9347	ALLOCATE( surfinlw_av(nsurfl) )
9348	surfinlw_av = 0.0_wp
9349	ENDIF
9350
9351	CASE ( 'rtm_rad_inswdir' )
9352	!-- array of direct sw radiation falling to surface from sun
9353	IF ( .NOT. ALLOCATED(surfinswdir_av) ) THEN
9354	ALLOCATE( surfinswdir_av(nsurfl) )
9355	surfinswdir_av = 0.0_wp
9356	ENDIF
9357
9358	CASE ( 'rtm_rad_inswdif' )
9359	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
9360	IF ( .NOT. ALLOCATED(surfinswdif_av) ) THEN
9361	ALLOCATE( surfinswdif_av(nsurfl) )
9362	surfinswdif_av = 0.0_wp
9363	ENDIF
9364
9365	CASE ( 'rtm_rad_inswref' )
9366	!-- array of sw radiation falling to surface from reflections
9367	IF ( .NOT. ALLOCATED(surfinswref_av) ) THEN
9368	ALLOCATE( surfinswref_av(nsurfl) )
9369	surfinswref_av = 0.0_wp
9370	ENDIF
9371
9372	CASE ( 'rtm_rad_inlwdif' )
9373	!-- array of sw radiation falling to surface after i-th reflection
9374	IF ( .NOT. ALLOCATED(surfinlwdif_av) ) THEN
9375	ALLOCATE( surfinlwdif_av(nsurfl) )
9376	surfinlwdif_av = 0.0_wp
9377	ENDIF
9378
9379	CASE ( 'rtm_rad_inlwref' )
9380	!-- array of lw radiation falling to surface from reflections
9381	IF ( .NOT. ALLOCATED(surfinlwref_av) ) THEN
9382	ALLOCATE( surfinlwref_av(nsurfl) )
9383	surfinlwref_av = 0.0_wp
9384	ENDIF
9385
9386	CASE ( 'rtm_rad_outsw' )
9387	!-- array of sw radiation emitted from surface after i-th reflection
9388	IF ( .NOT. ALLOCATED(surfoutsw_av) ) THEN
9389	ALLOCATE( surfoutsw_av(nsurfl) )
9390	surfoutsw_av = 0.0_wp
9391	ENDIF
9392
9393	CASE ( 'rtm_rad_outlw' )
9394	!-- array of lw radiation emitted from surface after i-th reflection
9395	IF ( .NOT. ALLOCATED(surfoutlw_av) ) THEN
9396	ALLOCATE( surfoutlw_av(nsurfl) )
9397	surfoutlw_av = 0.0_wp
9398	ENDIF
9399	CASE ( 'rtm_rad_ressw' )
9400	!-- array of residua of sw radiation absorbed in surface after last reflection
9401	IF ( .NOT. ALLOCATED(surfins_av) ) THEN
9402	ALLOCATE( surfins_av(nsurfl) )
9403	surfins_av = 0.0_wp
9404	ENDIF
9405
9406	CASE ( 'rtm_rad_reslw' )
9407	!-- array of residua of lw radiation absorbed in surface after last reflection
9408	IF ( .NOT. ALLOCATED(surfinl_av) ) THEN
9409	ALLOCATE( surfinl_av(nsurfl) )
9410	surfinl_av = 0.0_wp
9411	ENDIF
9412
9413	CASE ( 'rtm_rad_pc_inlw' )
9414	!-- array of of lw radiation absorbed in plant canopy
9415	IF ( .NOT. ALLOCATED(pcbinlw_av) ) THEN
9416	ALLOCATE( pcbinlw_av(1:npcbl) )
9417	pcbinlw_av = 0.0_wp
9418	ENDIF
9419
9420	CASE ( 'rtm_rad_pc_insw' )
9421	!-- array of of sw radiation absorbed in plant canopy
9422	IF ( .NOT. ALLOCATED(pcbinsw_av) ) THEN
9423	ALLOCATE( pcbinsw_av(1:npcbl) )
9424	pcbinsw_av = 0.0_wp
9425	ENDIF
9426
9427	CASE ( 'rtm_rad_pc_inswdir' )
9428	!-- array of of direct sw radiation absorbed in plant canopy
9429	IF ( .NOT. ALLOCATED(pcbinswdir_av) ) THEN
9430	ALLOCATE( pcbinswdir_av(1:npcbl) )
9431	pcbinswdir_av = 0.0_wp
9432	ENDIF
9433
9434	CASE ( 'rtm_rad_pc_inswdif' )
9435	!-- array of of diffuse sw radiation absorbed in plant canopy
9436	IF ( .NOT. ALLOCATED(pcbinswdif_av) ) THEN
9437	ALLOCATE( pcbinswdif_av(1:npcbl) )
9438	pcbinswdif_av = 0.0_wp
9439	ENDIF
9440
9441	CASE ( 'rtm_rad_pc_inswref' )
9442	!-- array of of reflected sw radiation absorbed in plant canopy
9443	IF ( .NOT. ALLOCATED(pcbinswref_av) ) THEN
9444	ALLOCATE( pcbinswref_av(1:npcbl) )
9445	pcbinswref_av = 0.0_wp
9446	ENDIF
9447
9448	CASE ( 'rtm_mrt_sw' )
9449	IF ( .NOT. ALLOCATED( mrtinsw_av ) ) THEN
9450	ALLOCATE( mrtinsw_av(nmrtbl) )
9451	ENDIF
9452	mrtinsw_av = 0.0_wp
9453
9454	CASE ( 'rtm_mrt_lw' )
9455	IF ( .NOT. ALLOCATED( mrtinlw_av ) ) THEN
9456	ALLOCATE( mrtinlw_av(nmrtbl) )
9457	ENDIF
9458	mrtinlw_av = 0.0_wp
9459
9460	CASE ( 'rtm_mrt' )
9461	IF ( .NOT. ALLOCATED( mrt_av ) ) THEN
9462	ALLOCATE( mrt_av(nmrtbl) )
9463	ENDIF
9464	mrt_av = 0.0_wp
9465
9466	CASE DEFAULT
9467	CONTINUE
9468
9469	END SELECT
9470
9471	ELSEIF ( mode == 'sum' ) THEN
9472
9473	SELECT CASE ( TRIM( var ) )
9474	!-- block of large scale (e.g. RRTMG) radiation output variables
9475	CASE ( 'rad_net*' )
9476	IF ( ALLOCATED( rad_net_av ) ) THEN
9477	DO i = nxl, nxr
9478	DO j = nys, nyn
9479	match_lsm = surf_lsm_h%start_index(j,i) <= &
9480	surf_lsm_h%end_index(j,i)
9481	match_usm = surf_usm_h%start_index(j,i) <= &
9482	surf_usm_h%end_index(j,i)
9483
9484	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9485	m = surf_lsm_h%end_index(j,i)
9486	rad_net_av(j,i) = rad_net_av(j,i) + &
9487	surf_lsm_h%rad_net(m)
9488	ELSEIF ( match_usm ) THEN
9489	m = surf_usm_h%end_index(j,i)
9490	rad_net_av(j,i) = rad_net_av(j,i) + &
9491	surf_usm_h%rad_net(m)
9492	ENDIF
9493	ENDDO
9494	ENDDO
9495	ENDIF
9496
9497	CASE ( 'rad_lw_in*' )
9498	IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
9499	DO i = nxl, nxr
9500	DO j = nys, nyn
9501	match_lsm = surf_lsm_h%start_index(j,i) <= &
9502	surf_lsm_h%end_index(j,i)
9503	match_usm = surf_usm_h%start_index(j,i) <= &
9504	surf_usm_h%end_index(j,i)
9505
9506	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9507	m = surf_lsm_h%end_index(j,i)
9508	rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) + &
9509	surf_lsm_h%rad_lw_in(m)
9510	ELSEIF ( match_usm ) THEN
9511	m = surf_usm_h%end_index(j,i)
9512	rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) + &
9513	surf_usm_h%rad_lw_in(m)
9514	ENDIF
9515	ENDDO
9516	ENDDO
9517	ENDIF
9518
9519	CASE ( 'rad_lw_out*' )
9520	IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
9521	DO i = nxl, nxr
9522	DO j = nys, nyn
9523	match_lsm = surf_lsm_h%start_index(j,i) <= &
9524	surf_lsm_h%end_index(j,i)
9525	match_usm = surf_usm_h%start_index(j,i) <= &
9526	surf_usm_h%end_index(j,i)
9527
9528	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9529	m = surf_lsm_h%end_index(j,i)
9530	rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) + &
9531	surf_lsm_h%rad_lw_out(m)
9532	ELSEIF ( match_usm ) THEN
9533	m = surf_usm_h%end_index(j,i)
9534	rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) + &
9535	surf_usm_h%rad_lw_out(m)
9536	ENDIF
9537	ENDDO
9538	ENDDO
9539	ENDIF
9540
9541	CASE ( 'rad_sw_in*' )
9542	IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
9543	DO i = nxl, nxr
9544	DO j = nys, nyn
9545	match_lsm = surf_lsm_h%start_index(j,i) <= &
9546	surf_lsm_h%end_index(j,i)
9547	match_usm = surf_usm_h%start_index(j,i) <= &
9548	surf_usm_h%end_index(j,i)
9549
9550	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9551	m = surf_lsm_h%end_index(j,i)
9552	rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) + &
9553	surf_lsm_h%rad_sw_in(m)
9554	ELSEIF ( match_usm ) THEN
9555	m = surf_usm_h%end_index(j,i)
9556	rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) + &
9557	surf_usm_h%rad_sw_in(m)
9558	ENDIF
9559	ENDDO
9560	ENDDO
9561	ENDIF
9562
9563	CASE ( 'rad_sw_out*' )
9564	IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
9565	DO i = nxl, nxr
9566	DO j = nys, nyn
9567	match_lsm = surf_lsm_h%start_index(j,i) <= &
9568	surf_lsm_h%end_index(j,i)
9569	match_usm = surf_usm_h%start_index(j,i) <= &
9570	surf_usm_h%end_index(j,i)
9571
9572	IF ( match_lsm .AND. .NOT. match_usm ) THEN
9573	m = surf_lsm_h%end_index(j,i)
9574	rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) + &
9575	surf_lsm_h%rad_sw_out(m)
9576	ELSEIF ( match_usm ) THEN
9577	m = surf_usm_h%end_index(j,i)
9578	rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) + &
9579	surf_usm_h%rad_sw_out(m)
9580	ENDIF
9581	ENDDO
9582	ENDDO
9583	ENDIF
9584
9585	CASE ( 'rad_lw_in' )
9586	IF ( ALLOCATED( rad_lw_in_av ) ) THEN
9587	DO i = nxlg, nxrg
9588	DO j = nysg, nyng
9589	DO k = nzb, nzt+1
9590	rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) &
9591	+ rad_lw_in(k,j,i)
9592	ENDDO
9593	ENDDO
9594	ENDDO
9595	ENDIF
9596
9597	CASE ( 'rad_lw_out' )
9598	IF ( ALLOCATED( rad_lw_out_av ) ) THEN
9599	DO i = nxlg, nxrg
9600	DO j = nysg, nyng
9601	DO k = nzb, nzt+1
9602	rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) &
9603	+ rad_lw_out(k,j,i)
9604	ENDDO
9605	ENDDO
9606	ENDDO
9607	ENDIF
9608
9609	CASE ( 'rad_lw_cs_hr' )
9610	IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN
9611	DO i = nxlg, nxrg
9612	DO j = nysg, nyng
9613	DO k = nzb, nzt+1
9614	rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) &
9615	+ rad_lw_cs_hr(k,j,i)
9616	ENDDO
9617	ENDDO
9618	ENDDO
9619	ENDIF
9620
9621	CASE ( 'rad_lw_hr' )
9622	IF ( ALLOCATED( rad_lw_hr_av ) ) THEN
9623	DO i = nxlg, nxrg
9624	DO j = nysg, nyng
9625	DO k = nzb, nzt+1
9626	rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) &
9627	+ rad_lw_hr(k,j,i)
9628	ENDDO
9629	ENDDO
9630	ENDDO
9631	ENDIF
9632
9633	CASE ( 'rad_sw_in' )
9634	IF ( ALLOCATED( rad_sw_in_av ) ) THEN
9635	DO i = nxlg, nxrg
9636	DO j = nysg, nyng
9637	DO k = nzb, nzt+1
9638	rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) &
9639	+ rad_sw_in(k,j,i)
9640	ENDDO
9641	ENDDO
9642	ENDDO
9643	ENDIF
9644
9645	CASE ( 'rad_sw_out' )
9646	IF ( ALLOCATED( rad_sw_out_av ) ) THEN
9647	DO i = nxlg, nxrg
9648	DO j = nysg, nyng
9649	DO k = nzb, nzt+1
9650	rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) &
9651	+ rad_sw_out(k,j,i)
9652	ENDDO
9653	ENDDO
9654	ENDDO
9655	ENDIF
9656
9657	CASE ( 'rad_sw_cs_hr' )
9658	IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN
9659	DO i = nxlg, nxrg
9660	DO j = nysg, nyng
9661	DO k = nzb, nzt+1
9662	rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) &
9663	+ rad_sw_cs_hr(k,j,i)
9664	ENDDO
9665	ENDDO
9666	ENDDO
9667	ENDIF
9668
9669	CASE ( 'rad_sw_hr' )
9670	IF ( ALLOCATED( rad_sw_hr_av ) ) THEN
9671	DO i = nxlg, nxrg
9672	DO j = nysg, nyng
9673	DO k = nzb, nzt+1
9674	rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) &
9675	+ rad_sw_hr(k,j,i)
9676	ENDDO
9677	ENDDO
9678	ENDDO
9679	ENDIF
9680
9681	!-- block of RTM output variables
9682	CASE ( 'rtm_rad_net' )
9683	!-- array of complete radiation balance
9684	DO isurf = dirstart(ids), dirend(ids)
9685	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9686	surfradnet_av(isurf) = surfinsw(isurf) - surfoutsw(isurf) + surfinlw(isurf) - surfoutlw(isurf)
9687	ENDIF
9688	ENDDO
9689
9690	CASE ( 'rtm_rad_insw' )
9691	!-- array of sw radiation falling to surface after i-th reflection
9692	DO isurf = dirstart(ids), dirend(ids)
9693	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9694	surfinsw_av(isurf) = surfinsw_av(isurf) + surfinsw(isurf)
9695	ENDIF
9696	ENDDO
9697
9698	CASE ( 'rtm_rad_inlw' )
9699	!-- array of lw radiation falling to surface after i-th reflection
9700	DO isurf = dirstart(ids), dirend(ids)
9701	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9702	surfinlw_av(isurf) = surfinlw_av(isurf) + surfinlw(isurf)
9703	ENDIF
9704	ENDDO
9705
9706	CASE ( 'rtm_rad_inswdir' )
9707	!-- array of direct sw radiation falling to surface from sun
9708	DO isurf = dirstart(ids), dirend(ids)
9709	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9710	surfinswdir_av(isurf) = surfinswdir_av(isurf) + surfinswdir(isurf)
9711	ENDIF
9712	ENDDO
9713
9714	CASE ( 'rtm_rad_inswdif' )
9715	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
9716	DO isurf = dirstart(ids), dirend(ids)
9717	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9718	surfinswdif_av(isurf) = surfinswdif_av(isurf) + surfinswdif(isurf)
9719	ENDIF
9720	ENDDO
9721
9722	CASE ( 'rtm_rad_inswref' )
9723	!-- array of sw radiation falling to surface from reflections
9724	DO isurf = dirstart(ids), dirend(ids)
9725	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9726	surfinswref_av(isurf) = surfinswref_av(isurf) + surfinsw(isurf) - &
9727	surfinswdir(isurf) - surfinswdif(isurf)
9728	ENDIF
9729	ENDDO
9730
9731
9732	CASE ( 'rtm_rad_inlwdif' )
9733	!-- array of sw radiation falling to 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	surfinlwdif_av(isurf) = surfinlwdif_av(isurf) + surfinlwdif(isurf)
9737	ENDIF
9738	ENDDO
9739	!
9740	CASE ( 'rtm_rad_inlwref' )
9741	!-- array of lw radiation falling to surface from reflections
9742	DO isurf = dirstart(ids), dirend(ids)
9743	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9744	surfinlwref_av(isurf) = surfinlwref_av(isurf) + &
9745	surfinlw(isurf) - surfinlwdif(isurf)
9746	ENDIF
9747	ENDDO
9748
9749	CASE ( 'rtm_rad_outsw' )
9750	!-- array of sw radiation emitted from surface after i-th reflection
9751	DO isurf = dirstart(ids), dirend(ids)
9752	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9753	surfoutsw_av(isurf) = surfoutsw_av(isurf) + surfoutsw(isurf)
9754	ENDIF
9755	ENDDO
9756
9757	CASE ( 'rtm_rad_outlw' )
9758	!-- array of lw radiation emitted from surface after i-th reflection
9759	DO isurf = dirstart(ids), dirend(ids)
9760	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9761	surfoutlw_av(isurf) = surfoutlw_av(isurf) + surfoutlw(isurf)
9762	ENDIF
9763	ENDDO
9764
9765	CASE ( 'rtm_rad_ressw' )
9766	!-- array of residua of sw radiation absorbed in surface after last reflection
9767	DO isurf = dirstart(ids), dirend(ids)
9768	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9769	surfins_av(isurf) = surfins_av(isurf) + surfins(isurf)
9770	ENDIF
9771	ENDDO
9772
9773	CASE ( 'rtm_rad_reslw' )
9774	!-- array of residua of lw radiation absorbed in surface after last reflection
9775	DO isurf = dirstart(ids), dirend(ids)
9776	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9777	surfinl_av(isurf) = surfinl_av(isurf) + surfinl(isurf)
9778	ENDIF
9779	ENDDO
9780
9781	CASE ( 'rtm_rad_pc_inlw' )
9782	DO l = 1, npcbl
9783	pcbinlw_av(l) = pcbinlw_av(l) + pcbinlw(l)
9784	ENDDO
9785
9786	CASE ( 'rtm_rad_pc_insw' )
9787	DO l = 1, npcbl
9788	pcbinsw_av(l) = pcbinsw_av(l) + pcbinsw(l)
9789	ENDDO
9790
9791	CASE ( 'rtm_rad_pc_inswdir' )
9792	DO l = 1, npcbl
9793	pcbinswdir_av(l) = pcbinswdir_av(l) + pcbinswdir(l)
9794	ENDDO
9795
9796	CASE ( 'rtm_rad_pc_inswdif' )
9797	DO l = 1, npcbl
9798	pcbinswdif_av(l) = pcbinswdif_av(l) + pcbinswdif(l)
9799	ENDDO
9800
9801	CASE ( 'rtm_rad_pc_inswref' )
9802	DO l = 1, npcbl
9803	pcbinswref_av(l) = pcbinswref_av(l) + pcbinsw(l) - pcbinswdir(l) - pcbinswdif(l)
9804	ENDDO
9805
9806	CASE ( 'rad_mrt_sw' )
9807	IF ( ALLOCATED( mrtinsw_av ) ) THEN
9808	mrtinsw_av(:) = mrtinsw_av(:) + mrtinsw(:)
9809	ENDIF
9810
9811	CASE ( 'rad_mrt_lw' )
9812	IF ( ALLOCATED( mrtinlw_av ) ) THEN
9813	mrtinlw_av(:) = mrtinlw_av(:) + mrtinlw(:)
9814	ENDIF
9815
9816	CASE ( 'rad_mrt' )
9817	IF ( ALLOCATED( mrt_av ) ) THEN
9818	mrt_av(:) = mrt_av(:) + mrt(:)
9819	ENDIF
9820
9821	CASE DEFAULT
9822	CONTINUE
9823
9824	END SELECT
9825
9826	ELSEIF ( mode == 'average' ) THEN
9827
9828	SELECT CASE ( TRIM( var ) )
9829	!-- block of large scale (e.g. RRTMG) radiation output variables
9830	CASE ( 'rad_net*' )
9831	IF ( ALLOCATED( rad_net_av ) ) THEN
9832	DO i = nxlg, nxrg
9833	DO j = nysg, nyng
9834	rad_net_av(j,i) = rad_net_av(j,i) &
9835	/ REAL( average_count_3d, KIND=wp )
9836	ENDDO
9837	ENDDO
9838	ENDIF
9839
9840	CASE ( 'rad_lw_in*' )
9841	IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
9842	DO i = nxlg, nxrg
9843	DO j = nysg, nyng
9844	rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) &
9845	/ REAL( average_count_3d, KIND=wp )
9846	ENDDO
9847	ENDDO
9848	ENDIF
9849
9850	CASE ( 'rad_lw_out*' )
9851	IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
9852	DO i = nxlg, nxrg
9853	DO j = nysg, nyng
9854	rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) &
9855	/ REAL( average_count_3d, KIND=wp )
9856	ENDDO
9857	ENDDO
9858	ENDIF
9859
9860	CASE ( 'rad_sw_in*' )
9861	IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
9862	DO i = nxlg, nxrg
9863	DO j = nysg, nyng
9864	rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) &
9865	/ REAL( average_count_3d, KIND=wp )
9866	ENDDO
9867	ENDDO
9868	ENDIF
9869
9870	CASE ( 'rad_sw_out*' )
9871	IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
9872	DO i = nxlg, nxrg
9873	DO j = nysg, nyng
9874	rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) &
9875	/ REAL( average_count_3d, KIND=wp )
9876	ENDDO
9877	ENDDO
9878	ENDIF
9879
9880	CASE ( 'rad_lw_in' )
9881	IF ( ALLOCATED( rad_lw_in_av ) ) THEN
9882	DO i = nxlg, nxrg
9883	DO j = nysg, nyng
9884	DO k = nzb, nzt+1
9885	rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) &
9886	/ REAL( average_count_3d, KIND=wp )
9887	ENDDO
9888	ENDDO
9889	ENDDO
9890	ENDIF
9891
9892	CASE ( 'rad_lw_out' )
9893	IF ( ALLOCATED( rad_lw_out_av ) ) THEN
9894	DO i = nxlg, nxrg
9895	DO j = nysg, nyng
9896	DO k = nzb, nzt+1
9897	rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) &
9898	/ REAL( average_count_3d, KIND=wp )
9899	ENDDO
9900	ENDDO
9901	ENDDO
9902	ENDIF
9903
9904	CASE ( 'rad_lw_cs_hr' )
9905	IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN
9906	DO i = nxlg, nxrg
9907	DO j = nysg, nyng
9908	DO k = nzb, nzt+1
9909	rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) &
9910	/ REAL( average_count_3d, KIND=wp )
9911	ENDDO
9912	ENDDO
9913	ENDDO
9914	ENDIF
9915
9916	CASE ( 'rad_lw_hr' )
9917	IF ( ALLOCATED( rad_lw_hr_av ) ) THEN
9918	DO i = nxlg, nxrg
9919	DO j = nysg, nyng
9920	DO k = nzb, nzt+1
9921	rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) &
9922	/ REAL( average_count_3d, KIND=wp )
9923	ENDDO
9924	ENDDO
9925	ENDDO
9926	ENDIF
9927
9928	CASE ( 'rad_sw_in' )
9929	IF ( ALLOCATED( rad_sw_in_av ) ) THEN
9930	DO i = nxlg, nxrg
9931	DO j = nysg, nyng
9932	DO k = nzb, nzt+1
9933	rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) &
9934	/ REAL( average_count_3d, KIND=wp )
9935	ENDDO
9936	ENDDO
9937	ENDDO
9938	ENDIF
9939
9940	CASE ( 'rad_sw_out' )
9941	IF ( ALLOCATED( rad_sw_out_av ) ) THEN
9942	DO i = nxlg, nxrg
9943	DO j = nysg, nyng
9944	DO k = nzb, nzt+1
9945	rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) &
9946	/ REAL( average_count_3d, KIND=wp )
9947	ENDDO
9948	ENDDO
9949	ENDDO
9950	ENDIF
9951
9952	CASE ( 'rad_sw_cs_hr' )
9953	IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN
9954	DO i = nxlg, nxrg
9955	DO j = nysg, nyng
9956	DO k = nzb, nzt+1
9957	rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) &
9958	/ REAL( average_count_3d, KIND=wp )
9959	ENDDO
9960	ENDDO
9961	ENDDO
9962	ENDIF
9963
9964	CASE ( 'rad_sw_hr' )
9965	IF ( ALLOCATED( rad_sw_hr_av ) ) THEN
9966	DO i = nxlg, nxrg
9967	DO j = nysg, nyng
9968	DO k = nzb, nzt+1
9969	rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) &
9970	/ REAL( average_count_3d, KIND=wp )
9971	ENDDO
9972	ENDDO
9973	ENDDO
9974	ENDIF
9975
9976	!-- block of RTM output variables
9977	CASE ( 'rtm_rad_net' )
9978	!-- array of complete radiation balance
9979	DO isurf = dirstart(ids), dirend(ids)
9980	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9981	surfradnet_av(isurf) = surfinsw_av(isurf) / REAL( average_count_3d, kind=wp )
9982	ENDIF
9983	ENDDO
9984
9985	CASE ( 'rtm_rad_insw' )
9986	!-- array of sw radiation falling to surface after i-th reflection
9987	DO isurf = dirstart(ids), dirend(ids)
9988	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9989	surfinsw_av(isurf) = surfinsw_av(isurf) / REAL( average_count_3d, kind=wp )
9990	ENDIF
9991	ENDDO
9992
9993	CASE ( 'rtm_rad_inlw' )
9994	!-- array of lw radiation falling to surface after i-th reflection
9995	DO isurf = dirstart(ids), dirend(ids)
9996	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
9997	surfinlw_av(isurf) = surfinlw_av(isurf) / REAL( average_count_3d, kind=wp )
9998	ENDIF
9999	ENDDO
10000
10001	CASE ( 'rtm_rad_inswdir' )
10002	!-- array of direct sw radiation falling to surface from sun
10003	DO isurf = dirstart(ids), dirend(ids)
10004	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10005	surfinswdir_av(isurf) = surfinswdir_av(isurf) / REAL( average_count_3d, kind=wp )
10006	ENDIF
10007	ENDDO
10008
10009	CASE ( 'rtm_rad_inswdif' )
10010	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
10011	DO isurf = dirstart(ids), dirend(ids)
10012	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10013	surfinswdif_av(isurf) = surfinswdif_av(isurf) / REAL( average_count_3d, kind=wp )
10014	ENDIF
10015	ENDDO
10016
10017	CASE ( 'rtm_rad_inswref' )
10018	!-- array of sw radiation falling to surface from reflections
10019	DO isurf = dirstart(ids), dirend(ids)
10020	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10021	surfinswref_av(isurf) = surfinswref_av(isurf) / REAL( average_count_3d, kind=wp )
10022	ENDIF
10023	ENDDO
10024
10025	CASE ( 'rtm_rad_inlwdif' )
10026	!-- array of sw radiation falling to surface after i-th reflection
10027	DO isurf = dirstart(ids), dirend(ids)
10028	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10029	surfinlwdif_av(isurf) = surfinlwdif_av(isurf) / REAL( average_count_3d, kind=wp )
10030	ENDIF
10031	ENDDO
10032
10033	CASE ( 'rtm_rad_inlwref' )
10034	!-- array of lw radiation falling to surface from reflections
10035	DO isurf = dirstart(ids), dirend(ids)
10036	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10037	surfinlwref_av(isurf) = surfinlwref_av(isurf) / REAL( average_count_3d, kind=wp )
10038	ENDIF
10039	ENDDO
10040
10041	CASE ( 'rtm_rad_outsw' )
10042	!-- array of sw radiation emitted from surface after i-th reflection
10043	DO isurf = dirstart(ids), dirend(ids)
10044	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10045	surfoutsw_av(isurf) = surfoutsw_av(isurf) / REAL( average_count_3d, kind=wp )
10046	ENDIF
10047	ENDDO
10048
10049	CASE ( 'rtm_rad_outlw' )
10050	!-- array of lw radiation emitted from surface after i-th reflection
10051	DO isurf = dirstart(ids), dirend(ids)
10052	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10053	surfoutlw_av(isurf) = surfoutlw_av(isurf) / REAL( average_count_3d, kind=wp )
10054	ENDIF
10055	ENDDO
10056
10057	CASE ( 'rtm_rad_ressw' )
10058	!-- array of residua of sw radiation absorbed in surface after last reflection
10059	DO isurf = dirstart(ids), dirend(ids)
10060	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10061	surfins_av(isurf) = surfins_av(isurf) / REAL( average_count_3d, kind=wp )
10062	ENDIF
10063	ENDDO
10064
10065	CASE ( 'rtm_rad_reslw' )
10066	!-- array of residua of lw radiation absorbed in surface after last reflection
10067	DO isurf = dirstart(ids), dirend(ids)
10068	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10069	surfinl_av(isurf) = surfinl_av(isurf) / REAL( average_count_3d, kind=wp )
10070	ENDIF
10071	ENDDO
10072
10073	CASE ( 'rtm_rad_pc_inlw' )
10074	DO l = 1, npcbl
10075	pcbinlw_av(:) = pcbinlw_av(:) / REAL( average_count_3d, kind=wp )
10076	ENDDO
10077
10078	CASE ( 'rtm_rad_pc_insw' )
10079	DO l = 1, npcbl
10080	pcbinsw_av(:) = pcbinsw_av(:) / REAL( average_count_3d, kind=wp )
10081	ENDDO
10082
10083	CASE ( 'rtm_rad_pc_inswdir' )
10084	DO l = 1, npcbl
10085	pcbinswdir_av(:) = pcbinswdir_av(:) / REAL( average_count_3d, kind=wp )
10086	ENDDO
10087
10088	CASE ( 'rtm_rad_pc_inswdif' )
10089	DO l = 1, npcbl
10090	pcbinswdif_av(:) = pcbinswdif_av(:) / REAL( average_count_3d, kind=wp )
10091	ENDDO
10092
10093	CASE ( 'rtm_rad_pc_inswref' )
10094	DO l = 1, npcbl
10095	pcbinswref_av(:) = pcbinswref_av(:) / REAL( average_count_3d, kind=wp )
10096	ENDDO
10097
10098	CASE ( 'rad_mrt_lw' )
10099	IF ( ALLOCATED( mrtinlw_av ) ) THEN
10100	mrtinlw_av(:) = mrtinlw_av(:) / REAL( average_count_3d, KIND=wp )
10101	ENDIF
10102
10103	CASE ( 'rad_mrt' )
10104	IF ( ALLOCATED( mrt_av ) ) THEN
10105	mrt_av(:) = mrt_av(:) / REAL( average_count_3d, KIND=wp )
10106	ENDIF
10107
10108	END SELECT
10109
10110	ENDIF
10111
10112	END SUBROUTINE radiation_3d_data_averaging
10113
10114
10115	!------------------------------------------------------------------------------!
10116	!
10117	! Description:
10118	! ------------
10119	!> Subroutine defining appropriate grid for netcdf variables.
10120	!> It is called out from subroutine netcdf.
10121	!------------------------------------------------------------------------------!
10122	SUBROUTINE radiation_define_netcdf_grid( variable, found, grid_x, grid_y, grid_z )
10123
10124	IMPLICIT NONE
10125
10126	CHARACTER (LEN=*), INTENT(IN) :: variable !<
10127	LOGICAL, INTENT(OUT) :: found !<
10128	CHARACTER (LEN=*), INTENT(OUT) :: grid_x !<
10129	CHARACTER (LEN=*), INTENT(OUT) :: grid_y !<
10130	CHARACTER (LEN=*), INTENT(OUT) :: grid_z !<
10131
10132	CHARACTER (len=varnamelength) :: var
10133
10134	found = .TRUE.
10135
10136	!
10137	!-- Check for the grid
10138	var = TRIM(variable)
10139	!-- RTM directional variables
10140	IF ( var(1:12) == 'rtm_rad_net_' .OR. var(1:13) == 'rtm_rad_insw_' .OR. &
10141	var(1:13) == 'rtm_rad_inlw_' .OR. var(1:16) == 'rtm_rad_inswdir_' .OR. &
10142	var(1:16) == 'rtm_rad_inswdif_' .OR. var(1:16) == 'rtm_rad_inswref_' .OR. &
10143	var(1:16) == 'rtm_rad_inlwdif_' .OR. var(1:16) == 'rtm_rad_inlwref_' .OR. &
10144	var(1:14) == 'rtm_rad_outsw_' .OR. var(1:14) == 'rtm_rad_outlw_' .OR. &
10145	var(1:14) == 'rtm_rad_ressw_' .OR. var(1:14) == 'rtm_rad_reslw_' .OR. &
10146	var == 'rtm_rad_pc_inlw' .OR. &
10147	var == 'rtm_rad_pc_insw' .OR. var == 'rtm_rad_pc_inswdir' .OR. &
10148	var == 'rtm_rad_pc_inswdif' .OR. var == 'rtm_rad_pc_inswref' .OR. &
10149	var(1:7) == 'rtm_svf' .OR. var(1:7) == 'rtm_dif' .OR. &
10150	var(1:9) == 'rtm_skyvf' .OR. var(1:10) == 'rtm_skyvft' .OR. &
10151	var(1:12) == 'rtm_surfalb_' .OR. var(1:13) == 'rtm_surfemis_' .OR. &
10152	var == 'rtm_mrt' .OR. var == 'rtm_mrt_sw' .OR. var == 'rtm_mrt_lw' ) THEN
10153
10154	found = .TRUE.
10155	grid_x = 'x'
10156	grid_y = 'y'
10157	grid_z = 'zu'
10158	ELSE
10159
10160	SELECT CASE ( TRIM( var ) )
10161
10162	CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_sw_cs_hr', 'rad_sw_hr', &
10163	'rad_lw_cs_hr_xy', 'rad_lw_hr_xy', 'rad_sw_cs_hr_xy', &
10164	'rad_sw_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_hr_xz', &
10165	'rad_sw_cs_hr_xz', 'rad_sw_hr_xz', 'rad_lw_cs_hr_yz', &
10166	'rad_lw_hr_yz', 'rad_sw_cs_hr_yz', 'rad_sw_hr_yz', &
10167	'rad_mrt', 'rad_mrt_sw', 'rad_mrt_lw' )
10168	grid_x = 'x'
10169	grid_y = 'y'
10170	grid_z = 'zu'
10171
10172	CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out', &
10173	'rad_lw_in_xy', 'rad_lw_out_xy', 'rad_sw_in_xy','rad_sw_out_xy', &
10174	'rad_lw_in_xz', 'rad_lw_out_xz', 'rad_sw_in_xz','rad_sw_out_xz', &
10175	'rad_lw_in_yz', 'rad_lw_out_yz', 'rad_sw_in_yz','rad_sw_out_yz' )
10176	grid_x = 'x'
10177	grid_y = 'y'
10178	grid_z = 'zw'
10179
10180
10181	CASE DEFAULT
10182	found = .FALSE.
10183	grid_x = 'none'
10184	grid_y = 'none'
10185	grid_z = 'none'
10186
10187	END SELECT
10188	ENDIF
10189
10190	END SUBROUTINE radiation_define_netcdf_grid
10191
10192	!------------------------------------------------------------------------------!
10193	!
10194	! Description:
10195	! ------------
10196	!> Subroutine defining 2D output variables
10197	!------------------------------------------------------------------------------!
10198	SUBROUTINE radiation_data_output_2d( av, variable, found, grid, mode, &
10199	local_pf, two_d, nzb_do, nzt_do )
10200
10201	USE indices
10202
10203	USE kinds
10204
10205
10206	IMPLICIT NONE
10207
10208	CHARACTER (LEN=*) :: grid !<
10209	CHARACTER (LEN=*) :: mode !<
10210	CHARACTER (LEN=*) :: variable !<
10211
10212	INTEGER(iwp) :: av !<
10213	INTEGER(iwp) :: i !<
10214	INTEGER(iwp) :: j !<
10215	INTEGER(iwp) :: k !<
10216	INTEGER(iwp) :: m !< index of surface element at grid point (j,i)
10217	INTEGER(iwp) :: nzb_do !<
10218	INTEGER(iwp) :: nzt_do !<
10219
10220	LOGICAL :: found !<
10221	LOGICAL :: two_d !< flag parameter that indicates 2D variables (horizontal cross sections)
10222
10223	REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute
10224
10225	REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !<
10226
10227	found = .TRUE.
10228
10229	SELECT CASE ( TRIM( variable ) )
10230
10231	CASE ( 'rad_net*_xy' ) ! 2d-array
10232	IF ( av == 0 ) THEN
10233	DO i = nxl, nxr
10234	DO j = nys, nyn
10235	!
10236	!-- Obtain rad_net from its respective surface type
10237	!-- Natural-type surfaces
10238	DO m = surf_lsm_h%start_index(j,i), &
10239	surf_lsm_h%end_index(j,i)
10240	local_pf(i,j,nzb+1) = surf_lsm_h%rad_net(m)
10241	ENDDO
10242	!
10243	!-- Urban-type surfaces
10244	DO m = surf_usm_h%start_index(j,i), &
10245	surf_usm_h%end_index(j,i)
10246	local_pf(i,j,nzb+1) = surf_usm_h%rad_net(m)
10247	ENDDO
10248	ENDDO
10249	ENDDO
10250	ELSE
10251	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
10252	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
10253	rad_net_av = REAL( fill_value, KIND = wp )
10254	ENDIF
10255	DO i = nxl, nxr
10256	DO j = nys, nyn
10257	local_pf(i,j,nzb+1) = rad_net_av(j,i)
10258	ENDDO
10259	ENDDO
10260	ENDIF
10261	two_d = .TRUE.
10262	grid = 'zu1'
10263
10264	CASE ( 'rad_lw_in*_xy' ) ! 2d-array
10265	IF ( av == 0 ) THEN
10266	DO i = nxl, nxr
10267	DO j = nys, nyn
10268	!
10269	!-- Obtain rad_net from its respective surface type
10270	!-- Natural-type surfaces
10271	DO m = surf_lsm_h%start_index(j,i), &
10272	surf_lsm_h%end_index(j,i)
10273	local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_in(m)
10274	ENDDO
10275	!
10276	!-- Urban-type surfaces
10277	DO m = surf_usm_h%start_index(j,i), &
10278	surf_usm_h%end_index(j,i)
10279	local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_in(m)
10280	ENDDO
10281	ENDDO
10282	ENDDO
10283	ELSE
10284	IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
10285	ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
10286	rad_lw_in_xy_av = REAL( fill_value, KIND = wp )
10287	ENDIF
10288	DO i = nxl, nxr
10289	DO j = nys, nyn
10290	local_pf(i,j,nzb+1) = rad_lw_in_xy_av(j,i)
10291	ENDDO
10292	ENDDO
10293	ENDIF
10294	two_d = .TRUE.
10295	grid = 'zu1'
10296
10297	CASE ( 'rad_lw_out*_xy' ) ! 2d-array
10298	IF ( av == 0 ) THEN
10299	DO i = nxl, nxr
10300	DO j = nys, nyn
10301	!
10302	!-- Obtain rad_net from its respective surface type
10303	!-- Natural-type surfaces
10304	DO m = surf_lsm_h%start_index(j,i), &
10305	surf_lsm_h%end_index(j,i)
10306	local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_out(m)
10307	ENDDO
10308	!
10309	!-- Urban-type surfaces
10310	DO m = surf_usm_h%start_index(j,i), &
10311	surf_usm_h%end_index(j,i)
10312	local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_out(m)
10313	ENDDO
10314	ENDDO
10315	ENDDO
10316	ELSE
10317	IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
10318	ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
10319	rad_lw_out_xy_av = REAL( fill_value, KIND = wp )
10320	ENDIF
10321	DO i = nxl, nxr
10322	DO j = nys, nyn
10323	local_pf(i,j,nzb+1) = rad_lw_out_xy_av(j,i)
10324	ENDDO
10325	ENDDO
10326	ENDIF
10327	two_d = .TRUE.
10328	grid = 'zu1'
10329
10330	CASE ( 'rad_sw_in*_xy' ) ! 2d-array
10331	IF ( av == 0 ) THEN
10332	DO i = nxl, nxr
10333	DO j = nys, nyn
10334	!
10335	!-- Obtain rad_net from its respective surface type
10336	!-- Natural-type surfaces
10337	DO m = surf_lsm_h%start_index(j,i), &
10338	surf_lsm_h%end_index(j,i)
10339	local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_in(m)
10340	ENDDO
10341	!
10342	!-- Urban-type surfaces
10343	DO m = surf_usm_h%start_index(j,i), &
10344	surf_usm_h%end_index(j,i)
10345	local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_in(m)
10346	ENDDO
10347	ENDDO
10348	ENDDO
10349	ELSE
10350	IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
10351	ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
10352	rad_sw_in_xy_av = REAL( fill_value, KIND = wp )
10353	ENDIF
10354	DO i = nxl, nxr
10355	DO j = nys, nyn
10356	local_pf(i,j,nzb+1) = rad_sw_in_xy_av(j,i)
10357	ENDDO
10358	ENDDO
10359	ENDIF
10360	two_d = .TRUE.
10361	grid = 'zu1'
10362
10363	CASE ( 'rad_sw_out*_xy' ) ! 2d-array
10364	IF ( av == 0 ) THEN
10365	DO i = nxl, nxr
10366	DO j = nys, nyn
10367	!
10368	!-- Obtain rad_net from its respective surface type
10369	!-- Natural-type surfaces
10370	DO m = surf_lsm_h%start_index(j,i), &
10371	surf_lsm_h%end_index(j,i)
10372	local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_out(m)
10373	ENDDO
10374	!
10375	!-- Urban-type surfaces
10376	DO m = surf_usm_h%start_index(j,i), &
10377	surf_usm_h%end_index(j,i)
10378	local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_out(m)
10379	ENDDO
10380	ENDDO
10381	ENDDO
10382	ELSE
10383	IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
10384	ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
10385	rad_sw_out_xy_av = REAL( fill_value, KIND = wp )
10386	ENDIF
10387	DO i = nxl, nxr
10388	DO j = nys, nyn
10389	local_pf(i,j,nzb+1) = rad_sw_out_xy_av(j,i)
10390	ENDDO
10391	ENDDO
10392	ENDIF
10393	two_d = .TRUE.
10394	grid = 'zu1'
10395
10396	CASE ( 'rad_lw_in_xy', 'rad_lw_in_xz', 'rad_lw_in_yz' )
10397	IF ( av == 0 ) THEN
10398	DO i = nxl, nxr
10399	DO j = nys, nyn
10400	DO k = nzb_do, nzt_do
10401	local_pf(i,j,k) = rad_lw_in(k,j,i)
10402	ENDDO
10403	ENDDO
10404	ENDDO
10405	ELSE
10406	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
10407	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10408	rad_lw_in_av = REAL( fill_value, KIND = wp )
10409	ENDIF
10410	DO i = nxl, nxr
10411	DO j = nys, nyn
10412	DO k = nzb_do, nzt_do
10413	local_pf(i,j,k) = rad_lw_in_av(k,j,i)
10414	ENDDO
10415	ENDDO
10416	ENDDO
10417	ENDIF
10418	IF ( mode == 'xy' ) grid = 'zu'
10419
10420	CASE ( 'rad_lw_out_xy', 'rad_lw_out_xz', 'rad_lw_out_yz' )
10421	IF ( av == 0 ) THEN
10422	DO i = nxl, nxr
10423	DO j = nys, nyn
10424	DO k = nzb_do, nzt_do
10425	local_pf(i,j,k) = rad_lw_out(k,j,i)
10426	ENDDO
10427	ENDDO
10428	ENDDO
10429	ELSE
10430	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
10431	ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10432	rad_lw_out_av = REAL( fill_value, KIND = wp )
10433	ENDIF
10434	DO i = nxl, nxr
10435	DO j = nys, nyn
10436	DO k = nzb_do, nzt_do
10437	local_pf(i,j,k) = rad_lw_out_av(k,j,i)
10438	ENDDO
10439	ENDDO
10440	ENDDO
10441	ENDIF
10442	IF ( mode == 'xy' ) grid = 'zu'
10443
10444	CASE ( 'rad_lw_cs_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_cs_hr_yz' )
10445	IF ( av == 0 ) THEN
10446	DO i = nxl, nxr
10447	DO j = nys, nyn
10448	DO k = nzb_do, nzt_do
10449	local_pf(i,j,k) = rad_lw_cs_hr(k,j,i)
10450	ENDDO
10451	ENDDO
10452	ENDDO
10453	ELSE
10454	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
10455	ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10456	rad_lw_cs_hr_av = REAL( fill_value, KIND = wp )
10457	ENDIF
10458	DO i = nxl, nxr
10459	DO j = nys, nyn
10460	DO k = nzb_do, nzt_do
10461	local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i)
10462	ENDDO
10463	ENDDO
10464	ENDDO
10465	ENDIF
10466	IF ( mode == 'xy' ) grid = 'zw'
10467
10468	CASE ( 'rad_lw_hr_xy', 'rad_lw_hr_xz', 'rad_lw_hr_yz' )
10469	IF ( av == 0 ) THEN
10470	DO i = nxl, nxr
10471	DO j = nys, nyn
10472	DO k = nzb_do, nzt_do
10473	local_pf(i,j,k) = rad_lw_hr(k,j,i)
10474	ENDDO
10475	ENDDO
10476	ENDDO
10477	ELSE
10478	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
10479	ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10480	rad_lw_hr_av= REAL( fill_value, KIND = wp )
10481	ENDIF
10482	DO i = nxl, nxr
10483	DO j = nys, nyn
10484	DO k = nzb_do, nzt_do
10485	local_pf(i,j,k) = rad_lw_hr_av(k,j,i)
10486	ENDDO
10487	ENDDO
10488	ENDDO
10489	ENDIF
10490	IF ( mode == 'xy' ) grid = 'zw'
10491
10492	CASE ( 'rad_sw_in_xy', 'rad_sw_in_xz', 'rad_sw_in_yz' )
10493	IF ( av == 0 ) THEN
10494	DO i = nxl, nxr
10495	DO j = nys, nyn
10496	DO k = nzb_do, nzt_do
10497	local_pf(i,j,k) = rad_sw_in(k,j,i)
10498	ENDDO
10499	ENDDO
10500	ENDDO
10501	ELSE
10502	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
10503	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10504	rad_sw_in_av = REAL( fill_value, KIND = wp )
10505	ENDIF
10506	DO i = nxl, nxr
10507	DO j = nys, nyn
10508	DO k = nzb_do, nzt_do
10509	local_pf(i,j,k) = rad_sw_in_av(k,j,i)
10510	ENDDO
10511	ENDDO
10512	ENDDO
10513	ENDIF
10514	IF ( mode == 'xy' ) grid = 'zu'
10515
10516	CASE ( 'rad_sw_out_xy', 'rad_sw_out_xz', 'rad_sw_out_yz' )
10517	IF ( av == 0 ) THEN
10518	DO i = nxl, nxr
10519	DO j = nys, nyn
10520	DO k = nzb_do, nzt_do
10521	local_pf(i,j,k) = rad_sw_out(k,j,i)
10522	ENDDO
10523	ENDDO
10524	ENDDO
10525	ELSE
10526	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
10527	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10528	rad_sw_out_av = REAL( fill_value, KIND = wp )
10529	ENDIF
10530	DO i = nxl, nxr
10531	DO j = nys, nyn
10532	DO k = nzb, nzt+1
10533	local_pf(i,j,k) = rad_sw_out_av(k,j,i)
10534	ENDDO
10535	ENDDO
10536	ENDDO
10537	ENDIF
10538	IF ( mode == 'xy' ) grid = 'zu'
10539
10540	CASE ( 'rad_sw_cs_hr_xy', 'rad_sw_cs_hr_xz', 'rad_sw_cs_hr_yz' )
10541	IF ( av == 0 ) THEN
10542	DO i = nxl, nxr
10543	DO j = nys, nyn
10544	DO k = nzb_do, nzt_do
10545	local_pf(i,j,k) = rad_sw_cs_hr(k,j,i)
10546	ENDDO
10547	ENDDO
10548	ENDDO
10549	ELSE
10550	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
10551	ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10552	rad_sw_cs_hr_av = REAL( fill_value, KIND = wp )
10553	ENDIF
10554	DO i = nxl, nxr
10555	DO j = nys, nyn
10556	DO k = nzb_do, nzt_do
10557	local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i)
10558	ENDDO
10559	ENDDO
10560	ENDDO
10561	ENDIF
10562	IF ( mode == 'xy' ) grid = 'zw'
10563
10564	CASE ( 'rad_sw_hr_xy', 'rad_sw_hr_xz', 'rad_sw_hr_yz' )
10565	IF ( av == 0 ) THEN
10566	DO i = nxl, nxr
10567	DO j = nys, nyn
10568	DO k = nzb_do, nzt_do
10569	local_pf(i,j,k) = rad_sw_hr(k,j,i)
10570	ENDDO
10571	ENDDO
10572	ENDDO
10573	ELSE
10574	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
10575	ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10576	rad_sw_hr_av = REAL( fill_value, KIND = wp )
10577	ENDIF
10578	DO i = nxl, nxr
10579	DO j = nys, nyn
10580	DO k = nzb_do, nzt_do
10581	local_pf(i,j,k) = rad_sw_hr_av(k,j,i)
10582	ENDDO
10583	ENDDO
10584	ENDDO
10585	ENDIF
10586	IF ( mode == 'xy' ) grid = 'zw'
10587
10588	CASE DEFAULT
10589	found = .FALSE.
10590	grid = 'none'
10591
10592	END SELECT
10593
10594	END SUBROUTINE radiation_data_output_2d
10595
10596
10597	!------------------------------------------------------------------------------!
10598	!
10599	! Description:
10600	! ------------
10601	!> Subroutine defining 3D output variables
10602	!------------------------------------------------------------------------------!
10603	SUBROUTINE radiation_data_output_3d( av, variable, found, local_pf, nzb_do, nzt_do )
10604
10605
10606	USE indices
10607
10608	USE kinds
10609
10610
10611	IMPLICIT NONE
10612
10613	CHARACTER (LEN=*) :: variable !<
10614
10615	INTEGER(iwp) :: av !<
10616	INTEGER(iwp) :: i, j, k, l !<
10617	INTEGER(iwp) :: nzb_do !<
10618	INTEGER(iwp) :: nzt_do !<
10619
10620	LOGICAL :: found !<
10621
10622	REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute
10623
10624	REAL(sp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !<
10625
10626	CHARACTER (len=varnamelength) :: var, surfid
10627	INTEGER(iwp) :: ids,idsint_u,idsint_l,isurf,isvf,isurfs,isurflt,ipcgb
10628	INTEGER(iwp) :: is, js, ks, istat
10629
10630	found = .TRUE.
10631	var = TRIM(variable)
10632
10633	!-- check if variable belongs to radiation related variables (starts with rad or rtm)
10634	IF ( len(var) < 3_iwp ) THEN
10635	found = .FALSE.
10636	RETURN
10637	ENDIF
10638
10639	IF ( var(1:3) /= 'rad' .AND. var(1:3) /= 'rtm' ) THEN
10640	found = .FALSE.
10641	RETURN
10642	ENDIF
10643
10644	ids = -1
10645	DO i = 0, nd-1
10646	k = len(TRIM(var))
10647	j = len(TRIM(dirname(i)))
10648	IF ( k-j+1 >= 1_iwp ) THEN
10649	IF ( TRIM(var(k-j+1:k)) == TRIM(dirname(i)) ) THEN
10650	ids = i
10651	idsint_u = dirint_u(ids)
10652	idsint_l = dirint_l(ids)
10653	var = var(:k-j)
10654	EXIT
10655	ENDIF
10656	ENDIF
10657	ENDDO
10658	IF ( ids == -1 ) THEN
10659	var = TRIM(variable)
10660	ENDIF
10661
10662	IF ( (var(1:8) == 'rtm_svf_' .OR. var(1:8) == 'rtm_dif_') .AND. len(TRIM(var)) >= 13 ) THEN
10663	!-- svf values to particular surface
10664	surfid = var(9:)
10665	i = index(surfid,'_')
10666	j = index(surfid(i+1:),'_')
10667	READ(surfid(1:i-1),*, iostat=istat ) is
10668	IF ( istat == 0 ) THEN
10669	READ(surfid(i+1:i+j-1),*, iostat=istat ) js
10670	ENDIF
10671	IF ( istat == 0 ) THEN
10672	READ(surfid(i+j+1:),*, iostat=istat ) ks
10673	ENDIF
10674	IF ( istat == 0 ) THEN
10675	var = var(1:7)
10676	ENDIF
10677	ENDIF
10678
10679	local_pf = fill_value
10680
10681	SELECT CASE ( TRIM( var ) )
10682	!-- block of large scale radiation model (e.g. RRTMG) output variables
10683	CASE ( 'rad_sw_in' )
10684	IF ( av == 0 ) THEN
10685	DO i = nxl, nxr
10686	DO j = nys, nyn
10687	DO k = nzb_do, nzt_do
10688	local_pf(i,j,k) = rad_sw_in(k,j,i)
10689	ENDDO
10690	ENDDO
10691	ENDDO
10692	ELSE
10693	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
10694	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10695	rad_sw_in_av = REAL( fill_value, KIND = wp )
10696	ENDIF
10697	DO i = nxl, nxr
10698	DO j = nys, nyn
10699	DO k = nzb_do, nzt_do
10700	local_pf(i,j,k) = rad_sw_in_av(k,j,i)
10701	ENDDO
10702	ENDDO
10703	ENDDO
10704	ENDIF
10705
10706	CASE ( 'rad_sw_out' )
10707	IF ( av == 0 ) THEN
10708	DO i = nxl, nxr
10709	DO j = nys, nyn
10710	DO k = nzb_do, nzt_do
10711	local_pf(i,j,k) = rad_sw_out(k,j,i)
10712	ENDDO
10713	ENDDO
10714	ENDDO
10715	ELSE
10716	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
10717	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10718	rad_sw_out_av = REAL( fill_value, KIND = wp )
10719	ENDIF
10720	DO i = nxl, nxr
10721	DO j = nys, nyn
10722	DO k = nzb_do, nzt_do
10723	local_pf(i,j,k) = rad_sw_out_av(k,j,i)
10724	ENDDO
10725	ENDDO
10726	ENDDO
10727	ENDIF
10728
10729	CASE ( 'rad_sw_cs_hr' )
10730	IF ( av == 0 ) THEN
10731	DO i = nxl, nxr
10732	DO j = nys, nyn
10733	DO k = nzb_do, nzt_do
10734	local_pf(i,j,k) = rad_sw_cs_hr(k,j,i)
10735	ENDDO
10736	ENDDO
10737	ENDDO
10738	ELSE
10739	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
10740	ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10741	rad_sw_cs_hr_av = REAL( fill_value, KIND = wp )
10742	ENDIF
10743	DO i = nxl, nxr
10744	DO j = nys, nyn
10745	DO k = nzb_do, nzt_do
10746	local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i)
10747	ENDDO
10748	ENDDO
10749	ENDDO
10750	ENDIF
10751
10752	CASE ( 'rad_sw_hr' )
10753	IF ( av == 0 ) THEN
10754	DO i = nxl, nxr
10755	DO j = nys, nyn
10756	DO k = nzb_do, nzt_do
10757	local_pf(i,j,k) = rad_sw_hr(k,j,i)
10758	ENDDO
10759	ENDDO
10760	ENDDO
10761	ELSE
10762	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
10763	ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10764	rad_sw_hr_av = REAL( fill_value, KIND = wp )
10765	ENDIF
10766	DO i = nxl, nxr
10767	DO j = nys, nyn
10768	DO k = nzb_do, nzt_do
10769	local_pf(i,j,k) = rad_sw_hr_av(k,j,i)
10770	ENDDO
10771	ENDDO
10772	ENDDO
10773	ENDIF
10774
10775	CASE ( 'rad_lw_in' )
10776	IF ( av == 0 ) THEN
10777	DO i = nxl, nxr
10778	DO j = nys, nyn
10779	DO k = nzb_do, nzt_do
10780	local_pf(i,j,k) = rad_lw_in(k,j,i)
10781	ENDDO
10782	ENDDO
10783	ENDDO
10784	ELSE
10785	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
10786	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10787	rad_lw_in_av = REAL( fill_value, KIND = wp )
10788	ENDIF
10789	DO i = nxl, nxr
10790	DO j = nys, nyn
10791	DO k = nzb_do, nzt_do
10792	local_pf(i,j,k) = rad_lw_in_av(k,j,i)
10793	ENDDO
10794	ENDDO
10795	ENDDO
10796	ENDIF
10797
10798	CASE ( 'rad_lw_out' )
10799	IF ( av == 0 ) THEN
10800	DO i = nxl, nxr
10801	DO j = nys, nyn
10802	DO k = nzb_do, nzt_do
10803	local_pf(i,j,k) = rad_lw_out(k,j,i)
10804	ENDDO
10805	ENDDO
10806	ENDDO
10807	ELSE
10808	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
10809	ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10810	rad_lw_out_av = REAL( fill_value, KIND = wp )
10811	ENDIF
10812	DO i = nxl, nxr
10813	DO j = nys, nyn
10814	DO k = nzb_do, nzt_do
10815	local_pf(i,j,k) = rad_lw_out_av(k,j,i)
10816	ENDDO
10817	ENDDO
10818	ENDDO
10819	ENDIF
10820
10821	CASE ( 'rad_lw_cs_hr' )
10822	IF ( av == 0 ) THEN
10823	DO i = nxl, nxr
10824	DO j = nys, nyn
10825	DO k = nzb_do, nzt_do
10826	local_pf(i,j,k) = rad_lw_cs_hr(k,j,i)
10827	ENDDO
10828	ENDDO
10829	ENDDO
10830	ELSE
10831	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
10832	ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10833	rad_lw_cs_hr_av = REAL( fill_value, KIND = wp )
10834	ENDIF
10835	DO i = nxl, nxr
10836	DO j = nys, nyn
10837	DO k = nzb_do, nzt_do
10838	local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i)
10839	ENDDO
10840	ENDDO
10841	ENDDO
10842	ENDIF
10843
10844	CASE ( 'rad_lw_hr' )
10845	IF ( av == 0 ) THEN
10846	DO i = nxl, nxr
10847	DO j = nys, nyn
10848	DO k = nzb_do, nzt_do
10849	local_pf(i,j,k) = rad_lw_hr(k,j,i)
10850	ENDDO
10851	ENDDO
10852	ENDDO
10853	ELSE
10854	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
10855	ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10856	rad_lw_hr_av = REAL( fill_value, KIND = wp )
10857	ENDIF
10858	DO i = nxl, nxr
10859	DO j = nys, nyn
10860	DO k = nzb_do, nzt_do
10861	local_pf(i,j,k) = rad_lw_hr_av(k,j,i)
10862	ENDDO
10863	ENDDO
10864	ENDDO
10865	ENDIF
10866
10867	CASE ( 'rtm_rad_net' )
10868	!-- array of complete radiation balance
10869	DO isurf = dirstart(ids), dirend(ids)
10870	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10871	IF ( av == 0 ) THEN
10872	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = &
10873	surfinsw(isurf) - surfoutsw(isurf) + surfinlw(isurf) - surfoutlw(isurf)
10874	ELSE
10875	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfradnet_av(isurf)
10876	ENDIF
10877	ENDIF
10878	ENDDO
10879
10880	CASE ( 'rtm_rad_insw' )
10881	!-- array of sw radiation falling to surface after i-th reflection
10882	DO isurf = dirstart(ids), dirend(ids)
10883	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10884	IF ( av == 0 ) THEN
10885	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinsw(isurf)
10886	ELSE
10887	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinsw_av(isurf)
10888	ENDIF
10889	ENDIF
10890	ENDDO
10891
10892	CASE ( 'rtm_rad_inlw' )
10893	!-- array of lw radiation falling to surface after i-th reflection
10894	DO isurf = dirstart(ids), dirend(ids)
10895	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10896	IF ( av == 0 ) THEN
10897	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw(isurf)
10898	ELSE
10899	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw_av(isurf)
10900	ENDIF
10901	ENDIF
10902	ENDDO
10903
10904	CASE ( 'rtm_rad_inswdir' )
10905	!-- array of direct sw radiation falling to surface from sun
10906	DO isurf = dirstart(ids), dirend(ids)
10907	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10908	IF ( av == 0 ) THEN
10909	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdir(isurf)
10910	ELSE
10911	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdir_av(isurf)
10912	ENDIF
10913	ENDIF
10914	ENDDO
10915
10916	CASE ( 'rtm_rad_inswdif' )
10917	!-- array of difusion sw radiation falling to surface from sky and borders of the domain
10918	DO isurf = dirstart(ids), dirend(ids)
10919	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10920	IF ( av == 0 ) THEN
10921	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdif(isurf)
10922	ELSE
10923	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdif_av(isurf)
10924	ENDIF
10925	ENDIF
10926	ENDDO
10927
10928	CASE ( 'rtm_rad_inswref' )
10929	!-- array of sw radiation falling to surface from reflections
10930	DO isurf = dirstart(ids), dirend(ids)
10931	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10932	IF ( av == 0 ) THEN
10933	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = &
10934	surfinsw(isurf) - surfinswdir(isurf) - surfinswdif(isurf)
10935	ELSE
10936	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswref_av(isurf)
10937	ENDIF
10938	ENDIF
10939	ENDDO
10940
10941	CASE ( 'rtm_rad_inlwdif' )
10942	!-- array of difusion lw radiation falling to surface from sky and borders of the domain
10943	DO isurf = dirstart(ids), dirend(ids)
10944	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10945	IF ( av == 0 ) THEN
10946	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwdif(isurf)
10947	ELSE
10948	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwdif_av(isurf)
10949	ENDIF
10950	ENDIF
10951	ENDDO
10952
10953	CASE ( 'rtm_rad_inlwref' )
10954	!-- array of lw radiation falling to surface from reflections
10955	DO isurf = dirstart(ids), dirend(ids)
10956	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10957	IF ( av == 0 ) THEN
10958	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw(isurf) - surfinlwdif(isurf)
10959	ELSE
10960	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwref_av(isurf)
10961	ENDIF
10962	ENDIF
10963	ENDDO
10964
10965	CASE ( 'rtm_rad_outsw' )
10966	!-- array of sw radiation emitted from surface after i-th reflection
10967	DO isurf = dirstart(ids), dirend(ids)
10968	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10969	IF ( av == 0 ) THEN
10970	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutsw(isurf)
10971	ELSE
10972	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutsw_av(isurf)
10973	ENDIF
10974	ENDIF
10975	ENDDO
10976
10977	CASE ( 'rtm_rad_outlw' )
10978	!-- array of lw radiation emitted from surface after i-th reflection
10979	DO isurf = dirstart(ids), dirend(ids)
10980	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10981	IF ( av == 0 ) THEN
10982	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutlw(isurf)
10983	ELSE
10984	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutlw_av(isurf)
10985	ENDIF
10986	ENDIF
10987	ENDDO
10988
10989	CASE ( 'rtm_rad_ressw' )
10990	!-- average of array of residua of sw radiation absorbed in surface after last reflection
10991	DO isurf = dirstart(ids), dirend(ids)
10992	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
10993	IF ( av == 0 ) THEN
10994	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfins(isurf)
10995	ELSE
10996	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfins_av(isurf)
10997	ENDIF
10998	ENDIF
10999	ENDDO
11000
11001	CASE ( 'rtm_rad_reslw' )
11002	!-- average of array of residua of lw radiation absorbed in surface after last reflection
11003	DO isurf = dirstart(ids), dirend(ids)
11004	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11005	IF ( av == 0 ) THEN
11006	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinl(isurf)
11007	ELSE
11008	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinl_av(isurf)
11009	ENDIF
11010	ENDIF
11011	ENDDO
11012
11013	CASE ( 'rtm_rad_pc_inlw' )
11014	!-- array of lw radiation absorbed by plant canopy
11015	DO ipcgb = 1, npcbl
11016	IF ( av == 0 ) THEN
11017	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinlw(ipcgb)
11018	ELSE
11019	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinlw_av(ipcgb)
11020	ENDIF
11021	ENDDO
11022
11023	CASE ( 'rtm_rad_pc_insw' )
11024	!-- array of sw radiation absorbed by plant canopy
11025	DO ipcgb = 1, npcbl
11026	IF ( av == 0 ) THEN
11027	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinsw(ipcgb)
11028	ELSE
11029	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinsw_av(ipcgb)
11030	ENDIF
11031	ENDDO
11032
11033	CASE ( 'rtm_rad_pc_inswdir' )
11034	!-- array of direct sw radiation absorbed by plant canopy
11035	DO ipcgb = 1, npcbl
11036	IF ( av == 0 ) THEN
11037	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdir(ipcgb)
11038	ELSE
11039	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdir_av(ipcgb)
11040	ENDIF
11041	ENDDO
11042
11043	CASE ( 'rtm_rad_pc_inswdif' )
11044	!-- array of diffuse sw radiation absorbed by plant canopy
11045	DO ipcgb = 1, npcbl
11046	IF ( av == 0 ) THEN
11047	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdif(ipcgb)
11048	ELSE
11049	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdif_av(ipcgb)
11050	ENDIF
11051	ENDDO
11052
11053	CASE ( 'rtm_rad_pc_inswref' )
11054	!-- array of reflected sw radiation absorbed by plant canopy
11055	DO ipcgb = 1, npcbl
11056	IF ( av == 0 ) THEN
11057	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = &
11058	pcbinsw(ipcgb) - pcbinswdir(ipcgb) - pcbinswdif(ipcgb)
11059	ELSE
11060	local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswref_av(ipcgb)
11061	ENDIF
11062	ENDDO
11063
11064	CASE ( 'rtm_mrt_sw' )
11065	local_pf = REAL( fill_value, KIND = wp )
11066	IF ( av == 0 ) THEN
11067	DO l = 1, nmrtbl
11068	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinsw(l)
11069	ENDDO
11070	ELSE
11071	IF ( ALLOCATED( mrtinsw_av ) ) THEN
11072	DO l = 1, nmrtbl
11073	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinsw_av(l)
11074	ENDDO
11075	ENDIF
11076	ENDIF
11077
11078	CASE ( 'rtm_mrt_lw' )
11079	local_pf = REAL( fill_value, KIND = wp )
11080	IF ( av == 0 ) THEN
11081	DO l = 1, nmrtbl
11082	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinlw(l)
11083	ENDDO
11084	ELSE
11085	IF ( ALLOCATED( mrtinlw_av ) ) THEN
11086	DO l = 1, nmrtbl
11087	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinlw_av(l)
11088	ENDDO
11089	ENDIF
11090	ENDIF
11091
11092	CASE ( 'rtm_mrt' )
11093	local_pf = REAL( fill_value, KIND = wp )
11094	IF ( av == 0 ) THEN
11095	DO l = 1, nmrtbl
11096	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrt(l)
11097	ENDDO
11098	ELSE
11099	IF ( ALLOCATED( mrt_av ) ) THEN
11100	DO l = 1, nmrtbl
11101	local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrt_av(l)
11102	ENDDO
11103	ENDIF
11104	ENDIF
11105	!
11106	!-- block of RTM output variables
11107	!-- variables are intended mainly for debugging and detailed analyse purposes
11108	CASE ( 'rtm_skyvf' )
11109	!
11110	!-- sky view factor
11111	DO isurf = dirstart(ids), dirend(ids)
11112	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11113	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = skyvf(isurf)
11114	ENDIF
11115	ENDDO
11116
11117	CASE ( 'rtm_skyvft' )
11118	!
11119	!-- sky view factor
11120	DO isurf = dirstart(ids), dirend(ids)
11121	IF ( surfl(id,isurf) == ids ) THEN
11122	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = skyvft(isurf)
11123	ENDIF
11124	ENDDO
11125
11126	CASE ( 'rtm_svf', 'rtm_dif' )
11127	!
11128	!-- shape view factors or iradiance factors to selected surface
11129	IF ( TRIM(var)=='rtm_svf' ) THEN
11130	k = 1
11131	ELSE
11132	k = 2
11133	ENDIF
11134	DO isvf = 1, nsvfl
11135	isurflt = svfsurf(1, isvf)
11136	isurfs = svfsurf(2, isvf)
11137
11138	IF ( surf(ix,isurfs) == is .AND. surf(iy,isurfs) == js .AND. surf(iz,isurfs) == ks .AND. &
11139	(surf(id,isurfs) == idsint_u .OR. surfl(id,isurfs) == idsint_l ) ) THEN
11140	!
11141	!-- correct source surface
11142	local_pf(surfl(ix,isurflt),surfl(iy,isurflt),surfl(iz,isurflt)) = svf(k,isvf)
11143	ENDIF
11144	ENDDO
11145
11146	CASE ( 'rtm_surfalb' )
11147	!
11148	!-- surface albedo
11149	DO isurf = dirstart(ids), dirend(ids)
11150	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11151	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = albedo_surf(isurf)
11152	ENDIF
11153	ENDDO
11154
11155	CASE ( 'rtm_surfemis' )
11156	!
11157	!-- surface emissivity, weighted average
11158	DO isurf = dirstart(ids), dirend(ids)
11159	IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN
11160	local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = emiss_surf(isurf)
11161	ENDIF
11162	ENDDO
11163
11164	CASE DEFAULT
11165	found = .FALSE.
11166
11167	END SELECT
11168
11169
11170	END SUBROUTINE radiation_data_output_3d
11171
11172	!------------------------------------------------------------------------------!
11173	!
11174	! Description:
11175	! ------------
11176	!> Subroutine defining masked data output
11177	!------------------------------------------------------------------------------!
11178	SUBROUTINE radiation_data_output_mask( av, variable, found, local_pf, mid )
11179
11180	USE control_parameters
11181
11182	USE indices
11183
11184	USE kinds
11185
11186
11187	IMPLICIT NONE
11188
11189	CHARACTER (LEN=*) :: variable !<
11190
11191	CHARACTER(LEN=5) :: grid !< flag to distinquish between staggered grids
11192
11193	INTEGER(iwp) :: av !<
11194	INTEGER(iwp) :: i !<
11195	INTEGER(iwp) :: j !<
11196	INTEGER(iwp) :: k !<
11197	INTEGER(iwp) :: mid !< masked output running index
11198	INTEGER(iwp) :: topo_top_index !< k index of highest horizontal surface
11199
11200	LOGICAL :: found !< true if output array was found
11201	LOGICAL :: resorted !< true if array is resorted
11202
11203
11204	REAL(wp), &
11205	DIMENSION(mask_size_l(mid,1),mask_size_l(mid,2),mask_size_l(mid,3)) :: &
11206	local_pf !<
11207
11208	REAL(wp), DIMENSION(:,:,:), POINTER :: to_be_resorted !< points to array which needs to be resorted for output
11209
11210
11211	found = .TRUE.
11212	grid = 's'
11213	resorted = .FALSE.
11214
11215	SELECT CASE ( TRIM( variable ) )
11216
11217
11218	CASE ( 'rad_lw_in' )
11219	IF ( av == 0 ) THEN
11220	to_be_resorted => rad_lw_in
11221	ELSE
11222	to_be_resorted => rad_lw_in_av
11223	ENDIF
11224
11225	CASE ( 'rad_lw_out' )
11226	IF ( av == 0 ) THEN
11227	to_be_resorted => rad_lw_out
11228	ELSE
11229	to_be_resorted => rad_lw_out_av
11230	ENDIF
11231
11232	CASE ( 'rad_lw_cs_hr' )
11233	IF ( av == 0 ) THEN
11234	to_be_resorted => rad_lw_cs_hr
11235	ELSE
11236	to_be_resorted => rad_lw_cs_hr_av
11237	ENDIF
11238
11239	CASE ( 'rad_lw_hr' )
11240	IF ( av == 0 ) THEN
11241	to_be_resorted => rad_lw_hr
11242	ELSE
11243	to_be_resorted => rad_lw_hr_av
11244	ENDIF
11245
11246	CASE ( 'rad_sw_in' )
11247	IF ( av == 0 ) THEN
11248	to_be_resorted => rad_sw_in
11249	ELSE
11250	to_be_resorted => rad_sw_in_av
11251	ENDIF
11252
11253	CASE ( 'rad_sw_out' )
11254	IF ( av == 0 ) THEN
11255	to_be_resorted => rad_sw_out
11256	ELSE
11257	to_be_resorted => rad_sw_out_av
11258	ENDIF
11259
11260	CASE ( 'rad_sw_cs_hr' )
11261	IF ( av == 0 ) THEN
11262	to_be_resorted => rad_sw_cs_hr
11263	ELSE
11264	to_be_resorted => rad_sw_cs_hr_av
11265	ENDIF
11266
11267	CASE ( 'rad_sw_hr' )
11268	IF ( av == 0 ) THEN
11269	to_be_resorted => rad_sw_hr
11270	ELSE
11271	to_be_resorted => rad_sw_hr_av
11272	ENDIF
11273
11274	CASE DEFAULT
11275	found = .FALSE.
11276
11277	END SELECT
11278
11279	!
11280	!-- Resort the array to be output, if not done above
11281	IF ( found .AND. .NOT. resorted ) THEN
11282	IF ( .NOT. mask_surface(mid) ) THEN
11283	!
11284	!-- Default masked output
11285	DO i = 1, mask_size_l(mid,1)
11286	DO j = 1, mask_size_l(mid,2)
11287	DO k = 1, mask_size_l(mid,3)
11288	local_pf(i,j,k) = to_be_resorted(mask_k(mid,k), &
11289	mask_j(mid,j),mask_i(mid,i))
11290	ENDDO
11291	ENDDO
11292	ENDDO
11293
11294	ELSE
11295	!
11296	!-- Terrain-following masked output
11297	DO i = 1, mask_size_l(mid,1)
11298	DO j = 1, mask_size_l(mid,2)
11299	!
11300	!-- Get k index of highest horizontal surface
11301	topo_top_index = topo_top_ind(mask_j(mid,j), &
11302	mask_i(mid,i), &
11303	0 )
11304	!
11305	!-- Save output array
11306	DO k = 1, mask_size_l(mid,3)
11307	local_pf(i,j,k) = to_be_resorted( &
11308	MIN( topo_top_index+mask_k(mid,k), &
11309	nzt+1 ), &
11310	mask_j(mid,j), &
11311	mask_i(mid,i) )
11312	ENDDO
11313	ENDDO
11314	ENDDO
11315
11316	ENDIF
11317	ENDIF
11318
11319
11320
11321	END SUBROUTINE radiation_data_output_mask
11322
11323
11324	!------------------------------------------------------------------------------!
11325	! Description:
11326	! ------------
11327	!> Subroutine writes local (subdomain) restart data
11328	!------------------------------------------------------------------------------!
11329	SUBROUTINE radiation_wrd_local
11330
11331
11332	IMPLICIT NONE
11333
11334
11335	IF ( ALLOCATED( rad_net_av ) ) THEN
11336	CALL wrd_write_string( 'rad_net_av' )
11337	WRITE ( 14 ) rad_net_av
11338	ENDIF
11339
11340	IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
11341	CALL wrd_write_string( 'rad_lw_in_xy_av' )
11342	WRITE ( 14 ) rad_lw_in_xy_av
11343	ENDIF
11344
11345	IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
11346	CALL wrd_write_string( 'rad_lw_out_xy_av' )
11347	WRITE ( 14 ) rad_lw_out_xy_av
11348	ENDIF
11349
11350	IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
11351	CALL wrd_write_string( 'rad_sw_in_xy_av' )
11352	WRITE ( 14 ) rad_sw_in_xy_av
11353	ENDIF
11354
11355	IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
11356	CALL wrd_write_string( 'rad_sw_out_xy_av' )
11357	WRITE ( 14 ) rad_sw_out_xy_av
11358	ENDIF
11359
11360	IF ( ALLOCATED( rad_lw_in ) ) THEN
11361	CALL wrd_write_string( 'rad_lw_in' )
11362	WRITE ( 14 ) rad_lw_in
11363	ENDIF
11364
11365	IF ( ALLOCATED( rad_lw_in_av ) ) THEN
11366	CALL wrd_write_string( 'rad_lw_in_av' )
11367	WRITE ( 14 ) rad_lw_in_av
11368	ENDIF
11369
11370	IF ( ALLOCATED( rad_lw_out ) ) THEN
11371	CALL wrd_write_string( 'rad_lw_out' )
11372	WRITE ( 14 ) rad_lw_out
11373	ENDIF
11374
11375	IF ( ALLOCATED( rad_lw_out_av) ) THEN
11376	CALL wrd_write_string( 'rad_lw_out_av' )
11377	WRITE ( 14 ) rad_lw_out_av
11378	ENDIF
11379
11380	IF ( ALLOCATED( rad_lw_cs_hr) ) THEN
11381	CALL wrd_write_string( 'rad_lw_cs_hr' )
11382	WRITE ( 14 ) rad_lw_cs_hr
11383	ENDIF
11384
11385	IF ( ALLOCATED( rad_lw_cs_hr_av) ) THEN
11386	CALL wrd_write_string( 'rad_lw_cs_hr_av' )
11387	WRITE ( 14 ) rad_lw_cs_hr_av
11388	ENDIF
11389
11390	IF ( ALLOCATED( rad_lw_hr) ) THEN
11391	CALL wrd_write_string( 'rad_lw_hr' )
11392	WRITE ( 14 ) rad_lw_hr
11393	ENDIF
11394
11395	IF ( ALLOCATED( rad_lw_hr_av) ) THEN
11396	CALL wrd_write_string( 'rad_lw_hr_av' )
11397	WRITE ( 14 ) rad_lw_hr_av
11398	ENDIF
11399
11400	IF ( ALLOCATED( rad_sw_in) ) THEN
11401	CALL wrd_write_string( 'rad_sw_in' )
11402	WRITE ( 14 ) rad_sw_in
11403	ENDIF
11404
11405	IF ( ALLOCATED( rad_sw_in_av) ) THEN
11406	CALL wrd_write_string( 'rad_sw_in_av' )
11407	WRITE ( 14 ) rad_sw_in_av
11408	ENDIF
11409
11410	IF ( ALLOCATED( rad_sw_out) ) THEN
11411	CALL wrd_write_string( 'rad_sw_out' )
11412	WRITE ( 14 ) rad_sw_out
11413	ENDIF
11414
11415	IF ( ALLOCATED( rad_sw_out_av) ) THEN
11416	CALL wrd_write_string( 'rad_sw_out_av' )
11417	WRITE ( 14 ) rad_sw_out_av
11418	ENDIF
11419
11420	IF ( ALLOCATED( rad_sw_cs_hr) ) THEN
11421	CALL wrd_write_string( 'rad_sw_cs_hr' )
11422	WRITE ( 14 ) rad_sw_cs_hr
11423	ENDIF
11424
11425	IF ( ALLOCATED( rad_sw_cs_hr_av) ) THEN
11426	CALL wrd_write_string( 'rad_sw_cs_hr_av' )
11427	WRITE ( 14 ) rad_sw_cs_hr_av
11428	ENDIF
11429
11430	IF ( ALLOCATED( rad_sw_hr) ) THEN
11431	CALL wrd_write_string( 'rad_sw_hr' )
11432	WRITE ( 14 ) rad_sw_hr
11433	ENDIF
11434
11435	IF ( ALLOCATED( rad_sw_hr_av) ) THEN
11436	CALL wrd_write_string( 'rad_sw_hr_av' )
11437	WRITE ( 14 ) rad_sw_hr_av
11438	ENDIF
11439
11440
11441	END SUBROUTINE radiation_wrd_local
11442
11443	!------------------------------------------------------------------------------!
11444	! Description:
11445	! ------------
11446	!> Subroutine reads local (subdomain) restart data
11447	!------------------------------------------------------------------------------!
11448	SUBROUTINE radiation_rrd_local( k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, &
11449	nxr_on_file, nynf, nync, nyn_on_file, nysf, &
11450	nysc, nys_on_file, tmp_2d, tmp_3d, found )
11451
11452
11453	USE control_parameters
11454
11455	USE indices
11456
11457	USE kinds
11458
11459	USE pegrid
11460
11461
11462	IMPLICIT NONE
11463
11464	INTEGER(iwp) :: k !<
11465	INTEGER(iwp) :: nxlc !<
11466	INTEGER(iwp) :: nxlf !<
11467	INTEGER(iwp) :: nxl_on_file !<
11468	INTEGER(iwp) :: nxrc !<
11469	INTEGER(iwp) :: nxrf !<
11470	INTEGER(iwp) :: nxr_on_file !<
11471	INTEGER(iwp) :: nync !<
11472	INTEGER(iwp) :: nynf !<
11473	INTEGER(iwp) :: nyn_on_file !<
11474	INTEGER(iwp) :: nysc !<
11475	INTEGER(iwp) :: nysf !<
11476	INTEGER(iwp) :: nys_on_file !<
11477
11478	LOGICAL, INTENT(OUT) :: found
11479
11480	REAL(wp), DIMENSION(nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_2d !<
11481
11482	REAL(wp), DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d !<
11483
11484	REAL(wp), DIMENSION(0:0,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d2 !<
11485
11486
11487	found = .TRUE.
11488
11489
11490	SELECT CASE ( restart_string(1:length) )
11491
11492	CASE ( 'rad_net_av' )
11493	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
11494	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
11495	ENDIF
11496	IF ( k == 1 ) READ ( 13 ) tmp_2d
11497	rad_net_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11498	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11499
11500	CASE ( 'rad_lw_in_xy_av' )
11501	IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
11502	ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
11503	ENDIF
11504	IF ( k == 1 ) READ ( 13 ) tmp_2d
11505	rad_lw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11506	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11507
11508	CASE ( 'rad_lw_out_xy_av' )
11509	IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
11510	ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
11511	ENDIF
11512	IF ( k == 1 ) READ ( 13 ) tmp_2d
11513	rad_lw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11514	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11515
11516	CASE ( 'rad_sw_in_xy_av' )
11517	IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
11518	ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
11519	ENDIF
11520	IF ( k == 1 ) READ ( 13 ) tmp_2d
11521	rad_sw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11522	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11523
11524	CASE ( 'rad_sw_out_xy_av' )
11525	IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
11526	ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
11527	ENDIF
11528	IF ( k == 1 ) READ ( 13 ) tmp_2d
11529	rad_sw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11530	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11531
11532	CASE ( 'rad_lw_in' )
11533	IF ( .NOT. ALLOCATED( rad_lw_in ) ) THEN
11534	IF ( radiation_scheme == 'clear-sky' .OR. &
11535	radiation_scheme == 'constant' .OR. &
11536	radiation_scheme == 'external' ) THEN
11537	ALLOCATE( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) )
11538	ELSE
11539	ALLOCATE( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11540	ENDIF
11541	ENDIF
11542	IF ( k == 1 ) THEN
11543	IF ( radiation_scheme == 'clear-sky' .OR. &
11544	radiation_scheme == 'constant' .OR. &
11545	radiation_scheme == 'external' ) THEN
11546	READ ( 13 ) tmp_3d2
11547	rad_lw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11548	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11549	ELSE
11550	READ ( 13 ) tmp_3d
11551	rad_lw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11552	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11553	ENDIF
11554	ENDIF
11555
11556	CASE ( 'rad_lw_in_av' )
11557	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
11558	IF ( radiation_scheme == 'clear-sky' .OR. &
11559	radiation_scheme == 'constant' .OR. &
11560	radiation_scheme == 'external' ) THEN
11561	ALLOCATE( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
11562	ELSE
11563	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11564	ENDIF
11565	ENDIF
11566	IF ( k == 1 ) THEN
11567	IF ( radiation_scheme == 'clear-sky' .OR. &
11568	radiation_scheme == 'constant' .OR. &
11569	radiation_scheme == 'external' ) THEN
11570	READ ( 13 ) tmp_3d2
11571	rad_lw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&
11572	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11573	ELSE
11574	READ ( 13 ) tmp_3d
11575	rad_lw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11576	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11577	ENDIF
11578	ENDIF
11579
11580	CASE ( 'rad_lw_out' )
11581	IF ( .NOT. ALLOCATED( rad_lw_out ) ) THEN
11582	IF ( radiation_scheme == 'clear-sky' .OR. &
11583	radiation_scheme == 'constant' .OR. &
11584	radiation_scheme == 'external' ) THEN
11585	ALLOCATE( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) )
11586	ELSE
11587	ALLOCATE( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11588	ENDIF
11589	ENDIF
11590	IF ( k == 1 ) THEN
11591	IF ( radiation_scheme == 'clear-sky' .OR. &
11592	radiation_scheme == 'constant' .OR. &
11593	radiation_scheme == 'external' ) THEN
11594	READ ( 13 ) tmp_3d2
11595	rad_lw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11596	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11597	ELSE
11598	READ ( 13 ) tmp_3d
11599	rad_lw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11600	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11601	ENDIF
11602	ENDIF
11603
11604	CASE ( 'rad_lw_out_av' )
11605	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
11606	IF ( radiation_scheme == 'clear-sky' .OR. &
11607	radiation_scheme == 'constant' .OR. &
11608	radiation_scheme == 'external' ) THEN
11609	ALLOCATE( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
11610	ELSE
11611	ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11612	ENDIF
11613	ENDIF
11614	IF ( k == 1 ) THEN
11615	IF ( radiation_scheme == 'clear-sky' .OR. &
11616	radiation_scheme == 'constant' .OR. &
11617	radiation_scheme == 'external' ) THEN
11618	READ ( 13 ) tmp_3d2
11619	rad_lw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) &
11620	= tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11621	ELSE
11622	READ ( 13 ) tmp_3d
11623	rad_lw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11624	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11625	ENDIF
11626	ENDIF
11627
11628	CASE ( 'rad_lw_cs_hr' )
11629	IF ( .NOT. ALLOCATED( rad_lw_cs_hr ) ) THEN
11630	ALLOCATE( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11631	ENDIF
11632	IF ( k == 1 ) READ ( 13 ) tmp_3d
11633	rad_lw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11634	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11635
11636	CASE ( 'rad_lw_cs_hr_av' )
11637	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
11638	ALLOCATE( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11639	ENDIF
11640	IF ( k == 1 ) READ ( 13 ) tmp_3d
11641	rad_lw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11642	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11643
11644	CASE ( 'rad_lw_hr' )
11645	IF ( .NOT. ALLOCATED( rad_lw_hr ) ) THEN
11646	ALLOCATE( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11647	ENDIF
11648	IF ( k == 1 ) READ ( 13 ) tmp_3d
11649	rad_lw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11650	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11651
11652	CASE ( 'rad_lw_hr_av' )
11653	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
11654	ALLOCATE( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11655	ENDIF
11656	IF ( k == 1 ) READ ( 13 ) tmp_3d
11657	rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11658	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11659
11660	CASE ( 'rad_sw_in' )
11661	IF ( .NOT. ALLOCATED( rad_sw_in ) ) THEN
11662	IF ( radiation_scheme == 'clear-sky' .OR. &
11663	radiation_scheme == 'constant' .OR. &
11664	radiation_scheme == 'external' ) THEN
11665	ALLOCATE( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) )
11666	ELSE
11667	ALLOCATE( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11668	ENDIF
11669	ENDIF
11670	IF ( k == 1 ) THEN
11671	IF ( radiation_scheme == 'clear-sky' .OR. &
11672	radiation_scheme == 'constant' .OR. &
11673	radiation_scheme == 'external' ) THEN
11674	READ ( 13 ) tmp_3d2
11675	rad_sw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11676	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11677	ELSE
11678	READ ( 13 ) tmp_3d
11679	rad_sw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11680	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11681	ENDIF
11682	ENDIF
11683
11684	CASE ( 'rad_sw_in_av' )
11685	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
11686	IF ( radiation_scheme == 'clear-sky' .OR. &
11687	radiation_scheme == 'constant' .OR. &
11688	radiation_scheme == 'external' ) THEN
11689	ALLOCATE( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
11690	ELSE
11691	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11692	ENDIF
11693	ENDIF
11694	IF ( k == 1 ) THEN
11695	IF ( radiation_scheme == 'clear-sky' .OR. &
11696	radiation_scheme == 'constant' .OR. &
11697	radiation_scheme == 'external' ) THEN
11698	READ ( 13 ) tmp_3d2
11699	rad_sw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&
11700	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11701	ELSE
11702	READ ( 13 ) tmp_3d
11703	rad_sw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11704	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11705	ENDIF
11706	ENDIF
11707
11708	CASE ( 'rad_sw_out' )
11709	IF ( .NOT. ALLOCATED( rad_sw_out ) ) THEN
11710	IF ( radiation_scheme == 'clear-sky' .OR. &
11711	radiation_scheme == 'constant' .OR. &
11712	radiation_scheme == 'external' ) THEN
11713	ALLOCATE( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) )
11714	ELSE
11715	ALLOCATE( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11716	ENDIF
11717	ENDIF
11718	IF ( k == 1 ) THEN
11719	IF ( radiation_scheme == 'clear-sky' .OR. &
11720	radiation_scheme == 'constant' .OR. &
11721	radiation_scheme == 'external' ) THEN
11722	READ ( 13 ) tmp_3d2
11723	rad_sw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11724	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11725	ELSE
11726	READ ( 13 ) tmp_3d
11727	rad_sw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11728	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11729	ENDIF
11730	ENDIF
11731
11732	CASE ( 'rad_sw_out_av' )
11733	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
11734	IF ( radiation_scheme == 'clear-sky' .OR. &
11735	radiation_scheme == 'constant' .OR. &
11736	radiation_scheme == 'external' ) THEN
11737	ALLOCATE( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
11738	ELSE
11739	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11740	ENDIF
11741	ENDIF
11742	IF ( k == 1 ) THEN
11743	IF ( radiation_scheme == 'clear-sky' .OR. &
11744	radiation_scheme == 'constant' .OR. &
11745	radiation_scheme == 'external' ) THEN
11746	READ ( 13 ) tmp_3d2
11747	rad_sw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) &
11748	= tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11749	ELSE
11750	READ ( 13 ) tmp_3d
11751	rad_sw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11752	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11753	ENDIF
11754	ENDIF
11755
11756	CASE ( 'rad_sw_cs_hr' )
11757	IF ( .NOT. ALLOCATED( rad_sw_cs_hr ) ) THEN
11758	ALLOCATE( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11759	ENDIF
11760	IF ( k == 1 ) READ ( 13 ) tmp_3d
11761	rad_sw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11762	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11763
11764	CASE ( 'rad_sw_cs_hr_av' )
11765	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
11766	ALLOCATE( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11767	ENDIF
11768	IF ( k == 1 ) READ ( 13 ) tmp_3d
11769	rad_sw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11770	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11771
11772	CASE ( 'rad_sw_hr' )
11773	IF ( .NOT. ALLOCATED( rad_sw_hr ) ) THEN
11774	ALLOCATE( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11775	ENDIF
11776	IF ( k == 1 ) READ ( 13 ) tmp_3d
11777	rad_sw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11778	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11779
11780	CASE ( 'rad_sw_hr_av' )
11781	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
11782	ALLOCATE( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11783	ENDIF
11784	IF ( k == 1 ) READ ( 13 ) tmp_3d
11785	rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11786	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11787
11788	CASE DEFAULT
11789
11790	found = .FALSE.
11791
11792	END SELECT
11793
11794	END SUBROUTINE radiation_rrd_local
11795
11796
11797	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 @ 4190

Download in other formats: