Home

Context Navigation

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

Last change on this file since 2894 was 2894, checked in by Giersch, 7 years ago
Reading/Writing? data in case of restart runs revised
Property svn:keywords set to `Id`
File size: 373.0 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 1997-2018 Leibniz Universitaet Hannover
18	!------------------------------------------------------------------------------!
19	!
20	! Current revisions:
21	! -----------------
22	!
23	!
24	! Former revisions:
25	! -----------------
26	! $Id: radiation_model_mod.f90 2894 2018-03-15 09:17:58Z Giersch $
27	! Calculations of the index range of the subdomain on file which overlaps with
28	! the current subdomain are already done in read_restart_data_mod
29	! radiation_read_restart_data was renamed to radiation_rrd_local and
30	! radiation_last_actions was renamed to radiation_wrd_local, variable named
31	! found has been introduced for checking if restart data was found, reading
32	! of restart strings has been moved completely to read_restart_data_mod,
33	! radiation_rrd_local is already inside the overlap loop programmed in
34	! read_restart_data_mod, the marker * end rad * is not necessary anymore,
35	! strings and their respective lengths are written out and read now in case of
36	! restart runs to get rid of prescribed character lengths (Giersch)
37	!
38	! 2809 2018-02-15 09:55:58Z suehring
39	! Bugfix for gfortran: Replace the function C_SIZEOF with STORAGE_SIZE
40	!
41	! 2753 2018-01-16 14:16:49Z suehring
42	! Tile approach for spectral albedo implemented.
43	!
44	! 2746 2018-01-15 12:06:04Z suehring
45	! Move flag plant canopy to modules
46	!
47	! 2724 2018-01-05 12:12:38Z maronga
48	! Set default of average_radiation to .FALSE.
49	!
50	! 2723 2018-01-05 09:27:03Z maronga
51	! Bugfix in calculation of rad_lw_out (clear-sky). First grid level was used
52	! instead of the surface value
53	!
54	! 2718 2018-01-02 08:49:38Z maronga
55	! Corrected "Former revisions" section
56	!
57	! 2707 2017-12-18 18:34:46Z suehring
58	! Changes from last commit documented
59	!
60	! 2706 2017-12-18 18:33:49Z suehring
61	! Bugfix, in average radiation case calculate exner function before using it.
62	!
63	! 2701 2017-12-15 15:40:50Z suehring
64	! Changes from last commit documented
65	!
66	! 2698 2017-12-14 18:46:24Z suehring
67	! Bugfix in get_topography_top_index
68	!
69	! 2696 2017-12-14 17:12:51Z kanani
70	! - Change in file header (GPL part)
71	! - Improved reading/writing of SVF from/to file (BM)
72	! - Bugfixes concerning RRTMG as well as average_radiation options (M. Salim)
73	! - Revised initialization of surface albedo and some minor bugfixes (MS)
74	! - Update net radiation after running radiation interaction routine (MS)
75	! - Revisions from M Salim included
76	! - Adjustment to topography and surface structure (MS)
77	! - Initialization of albedo and surface emissivity via input file (MS)
78	! - albedo_pars extended (MS)
79	!
80	! 2604 2017-11-06 13:29:00Z schwenkel
81	! bugfix for calculation of effective radius using morrison microphysics
82	!
83	! 2601 2017-11-02 16:22:46Z scharf
84	! added emissivity to namelist
85	!
86	! 2575 2017-10-24 09:57:58Z maronga
87	! Bugfix: calculation of shortwave and longwave albedos for RRTMG swapped
88	!
89	! 2547 2017-10-16 12:41:56Z schwenkel
90	! extended by cloud_droplets option, minor bugfix and correct calculation of
91	! cloud droplet number concentration
92	!
93	! 2544 2017-10-13 18:09:32Z maronga
94	! Moved date and time quantitis to separate module date_and_time_mod
95	!
96	! 2512 2017-10-04 08:26:59Z raasch
97	! upper bounds of cross section and 3d output changed from nx+1,ny+1 to nx,ny
98	! no output of ghost layer data
99	!
100	! 2504 2017-09-27 10:36:13Z maronga
101	! Updates pavement types and albedo parameters
102	!
103	! 2328 2017-08-03 12:34:22Z maronga
104	! Emissivity can now be set individually for each pixel.
105	! Albedo type can be inferred from land surface model.
106	! Added default albedo type for bare soil
107	!
108	! 2318 2017-07-20 17:27:44Z suehring
109	! Get topography top index via Function call
110	!
111	! 2317 2017-07-20 17:27:19Z suehring
112	! Improved syntax layout
113	!
114	! 2298 2017-06-29 09:28:18Z raasch
115	! type of write_binary changed from CHARACTER to LOGICAL
116	!
117	! 2296 2017-06-28 07:53:56Z maronga
118	! Added output of rad_sw_out for radiation_scheme = 'constant'
119	!
120	! 2270 2017-06-09 12:18:47Z maronga
121	! Numbering changed (2 timeseries removed)
122	!
123	! 2249 2017-06-06 13:58:01Z sward
124	! Allow for RRTMG runs without humidity/cloud physics
125	!
126	! 2248 2017-06-06 13:52:54Z sward
127	! Error no changed
128	!
129	! 2233 2017-05-30 18:08:54Z suehring
130	!
131	! 2232 2017-05-30 17:47:52Z suehring
132	! Adjustments to new topography concept
133	! Bugfix in read restart
134	!
135	! 2200 2017-04-11 11:37:51Z suehring
136	! Bugfix in call of exchange_horiz_2d and read restart data
137	!
138	! 2163 2017-03-01 13:23:15Z schwenkel
139	! Bugfix in radiation_check_data_output
140	!
141	! 2157 2017-02-22 15:10:35Z suehring
142	! Bugfix in read_restart data
143	!
144	! 2011 2016-09-19 17:29:57Z kanani
145	! Removed CALL of auxiliary SUBROUTINE get_usm_info,
146	! flag urban_surface is now defined in module control_parameters.
147	!
148	! 2007 2016-08-24 15:47:17Z kanani
149	! Added calculation of solar directional vector for new urban surface
150	! model,
151	! accounted for urban_surface model in radiation_check_parameters,
152	! correction of comments for zenith angle.
153	!
154	! 2000 2016-08-20 18:09:15Z knoop
155	! Forced header and separation lines into 80 columns
156	!
157	! 1976 2016-07-27 13:28:04Z maronga
158	! Output of 2D/3D/masked data is now directly done within this module. The
159	! radiation schemes have been simplified for better usability so that
160	! rad_lw_in, rad_lw_out, rad_sw_in, and rad_sw_out are available independent of
161	! the radiation code used.
162	!
163	! 1856 2016-04-13 12:56:17Z maronga
164	! Bugfix: allocation of rad_lw_out for radiation_scheme = 'clear-sky'
165	!
166	! 1853 2016-04-11 09:00:35Z maronga
167	! Added routine for radiation_scheme = constant.
168	!
169	! 1849 2016-04-08 11:33:18Z hoffmann
170	! Adapted for modularization of microphysics
171	!
172	! 1826 2016-04-07 12:01:39Z maronga
173	! Further modularization.
174	!
175	! 1788 2016-03-10 11:01:04Z maronga
176	! Added new albedo class for pavements / roads.
177	!
178	! 1783 2016-03-06 18:36:17Z raasch
179	! palm-netcdf-module removed in order to avoid a circular module dependency,
180	! netcdf-variables moved to netcdf-module, new routine netcdf_handle_error_rad
181	! added
182	!
183	! 1757 2016-02-22 15:49:32Z maronga
184	! Added parameter unscheduled_radiation_calls. Bugfix: interpolation of sounding
185	! profiles for pressure and temperature above the LES domain.
186	!
187	! 1709 2015-11-04 14:47:01Z maronga
188	! Bugfix: set initial value for rrtm_lwuflx_dt to zero, small formatting
189	! corrections
190	!
191	! 1701 2015-11-02 07:43:04Z maronga
192	! Bugfixes: wrong index for output of timeseries, setting of nz_snd_end
193	!
194	! 1691 2015-10-26 16:17:44Z maronga
195	! Added option for spin-up runs without radiation (skip_time_do_radiation). Bugfix
196	! in calculation of pressure profiles. Bugfix in calculation of trace gas profiles.
197	! Added output of radiative heating rates.
198	!
199	! 1682 2015-10-07 23:56:08Z knoop
200	! Code annotations made doxygen readable
201	!
202	! 1606 2015-06-29 10:43:37Z maronga
203	! Added preprocessor directive __netcdf to allow for compiling without netCDF.
204	! Note, however, that RRTMG cannot be used without netCDF.
205	!
206	! 1590 2015-05-08 13:56:27Z maronga
207	! Bugfix: definition of character strings requires same length for all elements
208	!
209	! 1587 2015-05-04 14:19:01Z maronga
210	! Added albedo class for snow
211	!
212	! 1585 2015-04-30 07:05:52Z maronga
213	! Added support for RRTMG
214	!
215	! 1571 2015-03-12 16:12:49Z maronga
216	! Added missing KIND attribute. Removed upper-case variable names
217	!
218	! 1551 2015-03-03 14:18:16Z maronga
219	! Added support for data output. Various variables have been renamed. Added
220	! interface for different radiation schemes (currently: clear-sky, constant, and
221	! RRTM (not yet implemented).
222	!
223	! 1496 2014-12-02 17:25:50Z maronga
224	! Initial revision
225	!
226	!
227	! Description:
228	! ------------
229	!> Radiation models and interfaces
230	!> @todo move variable definitions used in radiation_init only to the subroutine
231	!> as they are no longer required after initialization.
232	!> @todo Output of full column vertical profiles used in RRTMG
233	!> @todo Output of other rrtm arrays (such as volume mixing ratios)
234	!> @todo Adapt for use with topography
235	!> @todo Optimize radiation_tendency routines
236	!>
237	!> @note Many variables have a leading dummy dimension (0:0) in order to
238	!> match the assume-size shape expected by the RRTMG model.
239	!------------------------------------------------------------------------------!
240	MODULE radiation_model_mod
241
242	USE arrays_3d, &
243	ONLY: dzw, hyp, nc, pt, q, ql, zu, zw
244
245	USE calc_mean_profile_mod, &
246	ONLY: calc_mean_profile
247
248	USE cloud_parameters, &
249	ONLY: cp, l_d_cp, r_d, rho_l
250
251	USE constants, &
252	ONLY: pi
253
254	USE control_parameters, &
255	ONLY: cloud_droplets, cloud_physics, coupling_char, dz, g, &
256	initializing_actions, io_blocks, io_group, &
257	latitude, longitude, large_scale_forcing, lsf_surf, &
258	message_string, microphysics_morrison, plant_canopy, pt_surface,&
259	rho_surface, surface_pressure, time_since_reference_point
260
261	USE cpulog, &
262	ONLY: cpu_log, log_point, log_point_s
263
264	USE grid_variables, &
265	ONLY: ddx, ddy, dx, dy
266
267	USE date_and_time_mod, &
268	ONLY: calc_date_and_time, d_hours_day, d_seconds_hour, day_of_year, &
269	time_utc
270
271	USE indices, &
272	ONLY: nnx, nny, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, &
273	nzb, nzt
274
275	USE, INTRINSIC :: iso_c_binding
276
277	USE kinds
278
279	USE microphysics_mod, &
280	ONLY: na_init, nc_const, sigma_gc
281
282	#if defined ( __netcdf )
283	USE NETCDF
284	#endif
285
286	USE netcdf_data_input_mod, &
287	ONLY: albedo_type_f, albedo_pars_f, building_type_f, pavement_type_f, &
288	vegetation_type_f, water_type_f
289
290	USE plant_canopy_model_mod, &
291	ONLY: pc_heating_rate, lad_s, usm_lad_rma
292
293	USE pegrid
294
295	#if defined ( __rrtmg )
296	USE parrrsw, &
297	ONLY: naerec, nbndsw
298
299	USE parrrtm, &
300	ONLY: nbndlw
301
302	USE rrtmg_lw_init, &
303	ONLY: rrtmg_lw_ini
304
305	USE rrtmg_sw_init, &
306	ONLY: rrtmg_sw_ini
307
308	USE rrtmg_lw_rad, &
309	ONLY: rrtmg_lw
310
311	USE rrtmg_sw_rad, &
312	ONLY: rrtmg_sw
313	#endif
314	USE statistics, &
315	ONLY: hom
316
317	USE surface_mod, &
318	ONLY: get_topography_top_index, get_topography_top_index_ji, &
319	surf_def_h, surf_def_v, surf_lsm_h, &
320	surf_lsm_v, surf_type, surf_usm_h, surf_usm_v
321
322	IMPLICIT NONE
323
324	CHARACTER(10) :: radiation_scheme = 'clear-sky' ! 'constant', 'clear-sky', or 'rrtmg'
325
326	!
327	!-- Predefined Land surface classes (albedo_type) after Briegleb (1992)
328	CHARACTER(37), DIMENSION(0:33), PARAMETER :: albedo_type_name = (/ &
329	'user defined ', & ! 0
330	'ocean ', & ! 1
331	'mixed farming, tall grassland ', & ! 2
332	'tall/medium grassland ', & ! 3
333	'evergreen shrubland ', & ! 4
334	'short grassland/meadow/shrubland ', & ! 5
335	'evergreen needleleaf forest ', & ! 6
336	'mixed deciduous evergreen forest ', & ! 7
337	'deciduous forest ', & ! 8
338	'tropical evergreen broadleaved forest', & ! 9
339	'medium/tall grassland/woodland ', & ! 10
340	'desert, sandy ', & ! 11
341	'desert, rocky ', & ! 12
342	'tundra ', & ! 13
343	'land ice ', & ! 14
344	'sea ice ', & ! 15
345	'snow ', & ! 16
346	'bare soil ', & ! 17
347	'asphalt/concrete mix ', & ! 18
348	'asphalt (asphalt concrete) ', & ! 19
349	'concrete (Portland concrete) ', & ! 20
350	'sett ', & ! 21
351	'paving stones ', & ! 22
352	'cobblestone ', & ! 23
353	'metal ', & ! 24
354	'wood ', & ! 25
355	'gravel ', & ! 26
356	'fine gravel ', & ! 27
357	'pebblestone ', & ! 28
358	'woodchips ', & ! 29
359	'tartan (sports) ', & ! 30
360	'artifical turf (sports) ', & ! 31
361	'clay (sports) ', & ! 32
362	'building (dummy) ' & ! 33
363	/)
364
365	INTEGER(iwp) :: albedo_type = 9999999, & !< Albedo surface type
366	dots_rad = 0 !< starting index for timeseries output
367
368	LOGICAL :: unscheduled_radiation_calls = .TRUE., & !< flag parameter indicating whether additional calls of the radiation code are allowed
369	constant_albedo = .FALSE., & !< flag parameter indicating whether the albedo may change depending on zenith
370	force_radiation_call = .FALSE., & !< flag parameter for unscheduled radiation calls
371	lw_radiation = .TRUE., & !< flag parameter indicating whether longwave radiation shall be calculated
372	radiation = .FALSE., & !< flag parameter indicating whether the radiation model is used
373	sun_up = .TRUE., & !< flag parameter indicating whether the sun is up or down
374	sw_radiation = .TRUE., & !< flag parameter indicating whether shortwave radiation shall be calculated
375	sun_direction = .FALSE., & !< flag parameter indicating whether solar direction shall be calculated
376	average_radiation = .FALSE., & !< flag to set the calculation of radiation averaging for the domain
377	atm_surfaces = .FALSE., & !< flag parameter indicating wheather surfaces of atmospheric cells will be considered in calculating SVF
378	radiation_interactions = .TRUE., & !< flag to control if radiation interactions via sky-view factors shall be considered
379	surf_reflections = .TRUE. !< flag to switch the calculation of radiation interaction between surfaces.
380	!< When it switched off, only the effect of buildings and trees shadow will
381	!< will be considered. However fewer SVFs are expected.
382
383
384	REAL(wp), PARAMETER :: sigma_sb = 5.67037321E-8_wp, & !< Stefan-Boltzmann constant
385	solar_constant = 1368.0_wp !< solar constant at top of atmosphere
386
387	REAL(wp) :: albedo = 9999999.9_wp, & !< NAMELIST alpha
388	albedo_lw_dif = 9999999.9_wp, & !< NAMELIST aldif
389	albedo_lw_dir = 9999999.9_wp, & !< NAMELIST aldir
390	albedo_sw_dif = 9999999.9_wp, & !< NAMELIST asdif
391	albedo_sw_dir = 9999999.9_wp, & !< NAMELIST asdir
392	decl_1, & !< declination coef. 1
393	decl_2, & !< declination coef. 2
394	decl_3, & !< declination coef. 3
395	dt_radiation = 0.0_wp, & !< radiation model timestep
396	emissivity = 9999999.9_wp, & !< NAMELIST surface emissivity
397	lon = 0.0_wp, & !< longitude in radians
398	lat = 0.0_wp, & !< latitude in radians
399	net_radiation = 0.0_wp, & !< net radiation at surface
400	skip_time_do_radiation = 0.0_wp, & !< Radiation model is not called before this time
401	sky_trans, & !< sky transmissivity
402	time_radiation = 0.0_wp !< time since last call of radiation code
403
404
405	REAL(wp), DIMENSION(0:0) :: zenith, & !< cosine of solar zenith angle
406	sun_dir_lat, & !< solar directional vector in latitudes
407	sun_dir_lon !< solar directional vector in longitudes
408
409	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_net_av !< average of rad_net
410	!
411	!-- Land surface albedos for solar zenith angle of 60Â° after Briegleb (1992)
412	!-- (shortwave, longwave, broadband): sw, lw, bb,
413	REAL(wp), DIMENSION(0:2,1:33), PARAMETER :: albedo_pars = RESHAPE( (/&
414	0.06_wp, 0.06_wp, 0.06_wp, & ! 1
415	0.09_wp, 0.28_wp, 0.19_wp, & ! 2
416	0.11_wp, 0.33_wp, 0.23_wp, & ! 3
417	0.11_wp, 0.33_wp, 0.23_wp, & ! 4
418	0.14_wp, 0.34_wp, 0.25_wp, & ! 5
419	0.06_wp, 0.22_wp, 0.14_wp, & ! 6
420	0.06_wp, 0.27_wp, 0.17_wp, & ! 7
421	0.06_wp, 0.31_wp, 0.19_wp, & ! 8
422	0.06_wp, 0.22_wp, 0.14_wp, & ! 9
423	0.06_wp, 0.28_wp, 0.18_wp, & ! 10
424	0.35_wp, 0.51_wp, 0.43_wp, & ! 11
425	0.24_wp, 0.40_wp, 0.32_wp, & ! 12
426	0.10_wp, 0.27_wp, 0.19_wp, & ! 13
427	0.90_wp, 0.65_wp, 0.77_wp, & ! 14
428	0.90_wp, 0.65_wp, 0.77_wp, & ! 15
429	0.95_wp, 0.70_wp, 0.82_wp, & ! 16
430	0.08_wp, 0.08_wp, 0.08_wp, & ! 17
431	0.17_wp, 0.17_wp, 0.17_wp, & ! 18
432	0.17_wp, 0.17_wp, 0.17_wp, & ! 19
433	0.17_wp, 0.17_wp, 0.17_wp, & ! 20
434	0.17_wp, 0.17_wp, 0.17_wp, & ! 21
435	0.17_wp, 0.17_wp, 0.17_wp, & ! 22
436	0.17_wp, 0.17_wp, 0.17_wp, & ! 23
437	0.17_wp, 0.17_wp, 0.17_wp, & ! 24
438	0.17_wp, 0.17_wp, 0.17_wp, & ! 25
439	0.17_wp, 0.17_wp, 0.17_wp, & ! 26
440	0.17_wp, 0.17_wp, 0.17_wp, & ! 27
441	0.17_wp, 0.17_wp, 0.17_wp, & ! 28
442	0.17_wp, 0.17_wp, 0.17_wp, & ! 29
443	0.17_wp, 0.17_wp, 0.17_wp, & ! 30
444	0.17_wp, 0.17_wp, 0.17_wp, & ! 31
445	0.17_wp, 0.17_wp, 0.17_wp, & ! 32
446	0.17_wp, 0.17_wp, 0.17_wp & ! 33
447	/), (/ 3, 33 /) )
448
449	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: &
450	rad_lw_cs_hr, & !< longwave clear sky radiation heating rate (K/s)
451	rad_lw_cs_hr_av, & !< average of rad_lw_cs_hr
452	rad_lw_hr, & !< longwave radiation heating rate (K/s)
453	rad_lw_hr_av, & !< average of rad_sw_hr
454	rad_lw_in, & !< incoming longwave radiation (W/m2)
455	rad_lw_in_av, & !< average of rad_lw_in
456	rad_lw_out, & !< outgoing longwave radiation (W/m2)
457	rad_lw_out_av, & !< average of rad_lw_out
458	rad_sw_cs_hr, & !< shortwave clear sky radiation heating rate (K/s)
459	rad_sw_cs_hr_av, & !< average of rad_sw_cs_hr
460	rad_sw_hr, & !< shortwave radiation heating rate (K/s)
461	rad_sw_hr_av, & !< average of rad_sw_hr
462	rad_sw_in, & !< incoming shortwave radiation (W/m2)
463	rad_sw_in_av, & !< average of rad_sw_in
464	rad_sw_out, & !< outgoing shortwave radiation (W/m2)
465	rad_sw_out_av !< average of rad_sw_out
466
467
468	!
469	!-- Variables and parameters used in RRTMG only
470	#if defined ( __rrtmg )
471	CHARACTER(LEN=12) :: rrtm_input_file = "RAD_SND_DATA" !< name of the NetCDF input file (sounding data)
472
473
474	!
475	!-- Flag parameters for RRTMGS (should not be changed)
476	INTEGER(iwp), PARAMETER :: rrtm_idrv = 1, & !< flag for longwave upward flux calculation option (0,1)
477	rrtm_inflglw = 2, & !< flag for lw cloud optical properties (0,1,2)
478	rrtm_iceflglw = 0, & !< flag for lw ice particle specifications (0,1,2,3)
479	rrtm_liqflglw = 1, & !< flag for lw liquid droplet specifications
480	rrtm_inflgsw = 2, & !< flag for sw cloud optical properties (0,1,2)
481	rrtm_iceflgsw = 0, & !< flag for sw ice particle specifications (0,1,2,3)
482	rrtm_liqflgsw = 1 !< flag for sw liquid droplet specifications
483
484	!
485	!-- The following variables should be only changed with care, as this will
486	!-- require further setting of some variables, which is currently not
487	!-- implemented (aerosols, ice phase).
488	INTEGER(iwp) :: nzt_rad, & !< upper vertical limit for radiation calculations
489	rrtm_icld = 0, & !< cloud flag (0: clear sky column, 1: cloudy column)
490	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)
491
492	INTEGER(iwp) :: nc_stat !< local variable for storin the result of netCDF calls for error message handling
493
494	LOGICAL :: snd_exists = .FALSE. !< flag parameter to check whether a user-defined input files exists
495
496	REAL(wp), PARAMETER :: mol_mass_air_d_wv = 1.607793_wp !< molecular weight dry air / water vapor
497
498	REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd, & !< hypostatic pressure from sounding data (hPa)
499	q_snd, & !< specific humidity from sounding data (kg/kg) - dummy at the moment
500	rrtm_tsfc, & !< dummy array for storing surface temperature
501	t_snd !< actual temperature from sounding data (hPa)
502
503	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rrtm_ccl4vmr, & !< CCL4 volume mixing ratio (g/mol)
504	rrtm_cfc11vmr, & !< CFC11 volume mixing ratio (g/mol)
505	rrtm_cfc12vmr, & !< CFC12 volume mixing ratio (g/mol)
506	rrtm_cfc22vmr, & !< CFC22 volume mixing ratio (g/mol)
507	rrtm_ch4vmr, & !< CH4 volume mixing ratio
508	rrtm_cicewp, & !< in-cloud ice water path (g/mÂ²)
509	rrtm_cldfr, & !< cloud fraction (0,1)
510	rrtm_cliqwp, & !< in-cloud liquid water path (g/mÂ²)
511	rrtm_co2vmr, & !< CO2 volume mixing ratio (g/mol)
512	rrtm_emis, & !< surface emissivity (0-1)
513	rrtm_h2ovmr, & !< H2O volume mixing ratio
514	rrtm_n2ovmr, & !< N2O volume mixing ratio
515	rrtm_o2vmr, & !< O2 volume mixing ratio
516	rrtm_o3vmr, & !< O3 volume mixing ratio
517	rrtm_play, & !< pressure layers (hPa, zu-grid)
518	rrtm_plev, & !< pressure layers (hPa, zw-grid)
519	rrtm_reice, & !< cloud ice effective radius (microns)
520	rrtm_reliq, & !< cloud water drop effective radius (microns)
521	rrtm_tlay, & !< actual temperature (K, zu-grid)
522	rrtm_tlev, & !< actual temperature (K, zw-grid)
523	rrtm_lwdflx, & !< RRTM output of incoming longwave radiation flux (W/m2)
524	rrtm_lwdflxc, & !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)
525	rrtm_lwuflx, & !< RRTM output of outgoing longwave radiation flux (W/m2)
526	rrtm_lwuflxc, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)
527	rrtm_lwuflx_dt, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)
528	rrtm_lwuflxc_dt,& !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)
529	rrtm_lwhr, & !< RRTM output of longwave radiation heating rate (K/d)
530	rrtm_lwhrc, & !< RRTM output of incoming longwave clear sky radiation heating rate (K/d)
531	rrtm_swdflx, & !< RRTM output of incoming shortwave radiation flux (W/m2)
532	rrtm_swdflxc, & !< RRTM output of outgoing clear sky shortwave radiation flux (W/m2)
533	rrtm_swuflx, & !< RRTM output of outgoing shortwave radiation flux (W/m2)
534	rrtm_swuflxc, & !< RRTM output of incoming clear sky shortwave radiation flux (W/m2)
535	rrtm_swhr, & !< RRTM output of shortwave radiation heating rate (K/d)
536	rrtm_swhrc !< RRTM output of incoming shortwave clear sky radiation heating rate (K/d)
537
538
539	REAL(wp), DIMENSION(1) :: rrtm_aldif, & !< surface albedo for longwave diffuse radiation
540	rrtm_aldir, & !< surface albedo for longwave direct radiation
541	rrtm_asdif, & !< surface albedo for shortwave diffuse radiation
542	rrtm_asdir !< surface albedo for shortwave direct radiation
543
544	!
545	!-- Definition of arrays that are currently not used for calling RRTMG (due to setting of flag parameters)
546	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rad_lw_cs_in, & !< incoming clear sky longwave radiation (W/m2) (not used)
547	rad_lw_cs_out, & !< outgoing clear sky longwave radiation (W/m2) (not used)
548	rad_sw_cs_in, & !< incoming clear sky shortwave radiation (W/m2) (not used)
549	rad_sw_cs_out, & !< outgoing clear sky shortwave radiation (W/m2) (not used)
550	rrtm_lw_tauaer, & !< lw aerosol optical depth
551	rrtm_lw_taucld, & !< lw in-cloud optical depth
552	rrtm_sw_taucld, & !< sw in-cloud optical depth
553	rrtm_sw_ssacld, & !< sw in-cloud single scattering albedo
554	rrtm_sw_asmcld, & !< sw in-cloud asymmetry parameter
555	rrtm_sw_fsfcld, & !< sw in-cloud forward scattering fraction
556	rrtm_sw_tauaer, & !< sw aerosol optical depth
557	rrtm_sw_ssaaer, & !< sw aerosol single scattering albedo
558	rrtm_sw_asmaer, & !< sw aerosol asymmetry parameter
559	rrtm_sw_ecaer !< sw aerosol optical detph at 0.55 microns (rrtm_iaer = 6 only)
560
561	#endif
562	!
563	!-- Parameters of urban and land surface models
564	INTEGER(iwp) :: nzu !< number of layers of urban surface (will be calculated)
565	INTEGER(iwp) :: nzub,nzut !< bottom and top layer of urban surface (will be calculated)
566	!-- parameters of urban and land surface models
567	INTEGER(iwp), PARAMETER :: nzut_free = 3 !< number of free layers above top of of topography
568	INTEGER(iwp), PARAMETER :: ndsvf = 2 !< number of dimensions of real values in SVF
569	INTEGER(iwp), PARAMETER :: idsvf = 2 !< number of dimensions of integer values in SVF
570	INTEGER(iwp), PARAMETER :: ndcsf = 2 !< number of dimensions of real values in CSF
571	INTEGER(iwp), PARAMETER :: idcsf = 2 !< number of dimensions of integer values in CSF
572	INTEGER(iwp), PARAMETER :: kdcsf = 4 !< number of dimensions of integer values in CSF calculation array
573	INTEGER(iwp), PARAMETER :: id = 1 !< position of d-index in surfl and surf
574	INTEGER(iwp), PARAMETER :: iz = 2 !< position of k-index in surfl and surf
575	INTEGER(iwp), PARAMETER :: iy = 3 !< position of j-index in surfl and surf
576	INTEGER(iwp), PARAMETER :: ix = 4 !< position of i-index in surfl and surf
577
578	INTEGER(iwp), PARAMETER :: nsurf_type = 21 !< number of surf types incl. phys.(land+urban) & (atm.,sky,boundary) surfaces - 1
579
580	INTEGER(iwp), PARAMETER :: iup_u = 0 !< 0 - index of urban ubward surface (ground or roof)
581	INTEGER(iwp), PARAMETER :: idown_u = 1 !< 1 - index of urban downward surface (overhanging)
582	INTEGER(iwp), PARAMETER :: inorth_u = 2 !< 2 - index of urban northward facing wall
583	INTEGER(iwp), PARAMETER :: isouth_u = 3 !< 3 - index of urban southward facing wall
584	INTEGER(iwp), PARAMETER :: ieast_u = 4 !< 4 - index of urban eastward facing wall
585	INTEGER(iwp), PARAMETER :: iwest_u = 5 !< 5 - index of urban westward facing wall
586
587	INTEGER(iwp), PARAMETER :: iup_l = 6 !< 6 - index of land ubward surface (ground or roof)
588	INTEGER(iwp), PARAMETER :: inorth_l = 7 !< 7 - index of land northward facing wall
589	INTEGER(iwp), PARAMETER :: isouth_l = 8 !< 8 - index of land southward facing wall
590	INTEGER(iwp), PARAMETER :: ieast_l = 9 !< 9 - index of land eastward facing wall
591	INTEGER(iwp), PARAMETER :: iwest_l = 10 !< 10- index of land westward facing wall
592
593	INTEGER(iwp), PARAMETER :: iup_a = 11 !< 11- index of atm. cell ubward virtual surface
594	INTEGER(iwp), PARAMETER :: idown_a = 12 !< 12- index of atm. cell downward virtual surface
595	INTEGER(iwp), PARAMETER :: inorth_a = 13 !< 13- index of atm. cell northward facing virtual surface
596	INTEGER(iwp), PARAMETER :: isouth_a = 14 !< 14- index of atm. cell southward facing virtual surface
597	INTEGER(iwp), PARAMETER :: ieast_a = 15 !< 15- index of atm. cell eastward facing virtual surface
598	INTEGER(iwp), PARAMETER :: iwest_a = 16 !< 16- index of atm. cell westward facing virtual surface
599
600	INTEGER(iwp), PARAMETER :: isky = 17 !< 17 - index of top border of the urban surface layer ("urban sky")
601	INTEGER(iwp), PARAMETER :: inorth_b = 18 !< 18 - index of free north border of the domain (south facing)
602	INTEGER(iwp), PARAMETER :: isouth_b = 19 !< 19 - index of north south border of the domain (north facing)
603	INTEGER(iwp), PARAMETER :: ieast_b = 20 !< 20 - index of east border of the domain (west facing)
604	INTEGER(iwp), PARAMETER :: iwest_b = 21 !< 21 - index of wast border of the domain (east facing)
605
606	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: idir = (/0, 0,0, 0,1,-1,0,0, 0,1,-1,0, 0,0, 0,1,-1, 0, 0,0,-1,1/) !< surface normal direction x indices
607	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: jdir = (/0, 0,1,-1,0, 0,0,1,-1,0, 0,0, 0,1,-1,0, 0, 0,-1,1, 0,0/) !< surface normal direction y indices
608	INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: kdir = (/1,-1,0, 0,0, 0,1,0, 0,0, 0,1,-1,0, 0,0, 0,-1, 0,0, 0,0/) !< surface normal direction z indices
609	!< parameter but set in the code
610
611
612	!-- indices and sizes of urban and land surface models
613	INTEGER(iwp) :: nskys !< number of sky surfaces in local processor
614	INTEGER(iwp) :: startland !< start index of block of land and roof surfaces!-- block variables needed for calculation of the plant canopy model inside the urban surface model
615	INTEGER(iwp) :: endland !< end index of block of land and roof surfaces INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pct !< top layer of the plant canopy
616	INTEGER(iwp) :: nlands !< number of land and roof surfaces in local processor INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pch !< heights of the plant canopy
617	INTEGER(iwp) :: startwall !< start index of block of wall surfaces INTEGER(iwp) :: npcbl !< number of the plant canopy gridboxes in local processor
618	INTEGER(iwp) :: endwall !< end index of block of wall surfaces INTEGER(wp), DIMENSION(:,:), ALLOCATABLE :: pcbl !< k,j,i coordinates of l-th local plant canopy box pcbl[:,l] = [k, j,
619	INTEGER(iwp) :: nwalls !< number of wall surfaces in local processor REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw !< array of absorbed sw radiation for local plant canopy box
620	INTEGER(iwp) :: nborder !< number of border surfaces in local processor REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw !< array of absorbed lw radiation for local plant canopy box
621
622
623	!-- indices and sizes of urban and land surface models
624	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: surfl !< coordinates of i-th local surface in local grid - surfl[:,k] = [d, z, y, x]
625	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: surf !< coordinates of i-th surface in grid - surf[:,k] = [d, z, y, x]
626	INTEGER(iwp) :: nsurfl !< number of all surfaces in local processor
627	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nsurfs !< array of number of all surfaces in individual processors
628	INTEGER(iwp) :: startsky !< start index of block of sky
629	INTEGER(iwp) :: endsky !< end index of block of sky
630	INTEGER(iwp) :: startenergy !< start index of block of real surfaces (land, walls and roofs)
631	INTEGER(iwp) :: endenergy !< end index of block of real surfaces (land, walls and roofs)
632	INTEGER(iwp) :: nenergy !< number of real surfaces in local processor
633	INTEGER(iwp) :: nsurf !< global number of surfaces in index array of surfaces (nsurf = proc nsurfs)
634	INTEGER(iwp) :: startborder !< start index of block of border
635	INTEGER(iwp) :: endborder !< end index of block of border
636	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: surfstart !< starts of blocks of surfaces for individual processors in array surf
637	!< respective block for particular processor is surfstart[iproc]+1 : surfstart[iproc+1]
638
639	!-- block variables needed for calculation of the plant canopy model inside the urban surface model
640	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pct !< top layer of the plant canopy
641	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pch !< heights of the plant canopy
642	INTEGER(iwp) :: npcbl !< number of the plant canopy gridboxes in local processor
643	INTEGER(wp), DIMENSION(:,:), ALLOCATABLE :: pcbl !< k,j,i coordinates of l-th local plant canopy box pcbl[:,l] = [k, j, i]
644	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw !< array of absorbed sw radiation for local plant canopy box
645	REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw !< array of absorbed lw radiation for local plant canopy box
646
647	!-- configuration parameters (they can be setup in PALM config)
648	LOGICAL :: split_diffusion_radiation = .TRUE. !< split direct and diffusion dw radiation
649	!< (.F. in case the radiation model already does it)
650	LOGICAL :: energy_balance_surf_h = .TRUE. !< flag parameter indicating wheather the energy balance is calculated for horizontal surfaces
651	LOGICAL :: energy_balance_surf_v = .TRUE. !< flag parameter indicating wheather the energy balance is calculated for vertical surfaces
652	LOGICAL :: read_svf_on_init = .FALSE. !< flag parameter indicating wheather SVFs will be read from a file at initialization
653	LOGICAL :: write_svf_on_init = .FALSE. !< flag parameter indicating wheather SVFs will be written out to a file
654	LOGICAL :: mrt_factors = .FALSE. !< whether to generate MRT factor files during init
655	INTEGER(iwp) :: nrefsteps = 0 !< number of reflection steps to perform
656	REAL(wp), PARAMETER :: ext_coef = 0.6_wp !< extinction coefficient (a.k.a. alpha)
657	INTEGER(iwp), PARAMETER :: svf_code_len = 15 !< length of code for verification of the end of svf file
658	CHARACTER(svf_code_len), PARAMETER :: svf_code = '* end svf *' !< code for verification of the end of svf file
659	INTEGER(iwp), PARAMETER :: usm_version_len = 10 !< length of identification string of usm version
660	CHARACTER(usm_version_len), PARAMETER :: usm_version = 'USM v. 1.0' !< identification of version of binary svf and restart files
661
662	!-- radiation related arrays to be used in radiation_interaction routine
663	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_dir !< direct sw radiation
664	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_diff !< diffusion sw radiation
665	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_diff !< diffusion lw radiation
666
667	!-- parameters required for RRTMG lower boundary condition
668	REAL(wp) :: albedo_urb !< albedo value retuned to RRTMG boundary cond.
669	REAL(wp) :: emissivity_urb !< emissivity value retuned to RRTMG boundary cond.
670	REAL(wp) :: t_rad_urb !< temperature value retuned to RRTMG boundary cond.
671
672	!-- type for calculation of svf
673	TYPE t_svf
674	INTEGER(iwp) :: isurflt !<
675	INTEGER(iwp) :: isurfs !<
676	REAL(wp) :: rsvf !<
677	REAL(wp) :: rtransp !<
678	END TYPE
679
680	!-- type for calculation of csf
681	TYPE t_csf
682	INTEGER(iwp) :: ip !<
683	INTEGER(iwp) :: itx !<
684	INTEGER(iwp) :: ity !<
685	INTEGER(iwp) :: itz !<
686	INTEGER(iwp) :: isurfs !<
687	REAL(wp) :: rsvf !<
688	REAL(wp) :: rtransp !<
689	END TYPE
690
691	!-- arrays storing the values of USM
692	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: svfsurf !< svfsurf[:,isvf] = index of source and target surface for svf[isvf]
693	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: svf !< array of shape view factors+direct irradiation factors for local surfaces
694	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins !< array of sw radiation falling to local surface after i-th reflection
695	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl !< array of lw radiation for local surface after i-th reflection
696
697	!< Inward radiation is also valid for virtual surfaces (radiation leaving domain)
698	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw !< array of sw radiation falling to local surface including radiation from reflections
699	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw !< array of lw radiation falling to local surface including radiation from reflections
700	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir !< array of direct sw radiation falling to local surface
701	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif !< array of diffuse sw radiation from sky and model boundary falling to local surface
702	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif !< array of diffuse lw radiation from sky and model boundary falling to local surface
703
704	!< Outward radiation is only valid for nonvirtual surfaces
705	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsl !< array of reflected sw radiation for local surface in i-th reflection
706	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutll !< array of reflected + emitted lw radiation for local surface in i-th reflection
707	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfouts !< array of reflected sw radiation for all surfaces in i-th reflection
708	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutl !< array of reflected + emitted lw radiation for all surfaces in i-th reflection
709	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw !< array of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection
710	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw !< array of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection
711	REAL(wp), DIMENSION(:), ALLOCATABLE :: surfhf !< array of total radiation flux incoming to minus outgoing from local surface
712	REAL(wp), DIMENSION(:), ALLOCATABLE :: rad_net_l !< local copy of rad_net (net radiation at surface)
713
714	!-- block variables needed for calculation of the plant canopy model inside the urban surface model
715	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: csfsurf !< csfsurf[:,icsf] = index of target surface and csf grid index for csf[icsf]
716	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csf !< array of plant canopy sink fators + direct irradiation factors (transparency)
717	REAL(wp), DIMENSION(:,:,:), POINTER :: usm_lad !< subset of lad_s within urban surface, transformed to plain Z coordinate
718	REAL(wp), DIMENSION(:), POINTER :: usm_lad_g !< usm_lad globalized (used to avoid MPI RMA calls in raytracing)
719	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nzterr, plantt !< temporary global arrays for raytracing
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(:), ALLOCATABLE, TARGET :: asvf1, asvf2 !< realizations of svf array
725	TYPE(t_csf), DIMENSION(:), ALLOCATABLE, TARGET :: acsf1, acsf2 !< realizations of csf array
726	INTEGER(iwp) :: nsvfla !< dimmension of array allocated for storage of svf in local processor
727	INTEGER(iwp) :: ncsfla !< dimmension of array allocated for storage of csf in local processor
728	INTEGER(iwp) :: msvf, mcsf !< mod for swapping the growing array
729	INTEGER(iwp), PARAMETER :: gasize = 10000 !< initial size of growing arrays
730	REAL(wp) :: dist_max_svf = -9999.0 !< maximum distance to calculate the minimum svf to be considered. It is
731	!< used to avoid very small SVFs resulting from too far surfaces with mutual visibility
732	INTEGER(iwp) :: nsvfl !< number of svf for local processor
733	INTEGER(iwp) :: ncsfl !< no. of csf in local processor
734	!< needed only during calc_svf but must be here because it is
735	!< shared between subroutines usm_calc_svf and usm_raytrace
736	INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: gridpcbl !< index of local pcb[k,j,i]
737
738	!-- temporary arrays for calculation of csf in raytracing
739	INTEGER(iwp) :: maxboxesg !< max number of boxes ray can cross in the domain
740	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: boxes !< coordinates of gridboxes being crossed by ray
741	REAL(wp), DIMENSION(:), ALLOCATABLE :: crlens !< array of crossing lengths of ray for particular grid boxes
742	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: lad_ip !< array of numbers of process where lad is stored
743	#if defined( __parallel )
744	INTEGER(kind=MPI_ADDRESS_KIND), &
745	DIMENSION(:), ALLOCATABLE :: lad_disp !< array of displaycements of lad in local array of proc lad_ip
746	#endif
747	REAL(wp), DIMENSION(:), ALLOCATABLE :: lad_s_ray !< array of received lad_s for appropriate gridboxes crossed by ray
748
749
750	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
751	!-- Energy balance variables
752	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
753	!-- parameters of the land, roof and wall surfaces
754	REAL(wp), DIMENSION(:), ALLOCATABLE :: albedo_surf !< albedo of the surface
755	REAL(wp), DIMENSION(:), ALLOCATABLE :: emiss_surf !< emissivity of the wall surface
756
757
758	INTERFACE radiation_check_data_output
759	MODULE PROCEDURE radiation_check_data_output
760	END INTERFACE radiation_check_data_output
761
762	INTERFACE radiation_check_data_output_pr
763	MODULE PROCEDURE radiation_check_data_output_pr
764	END INTERFACE radiation_check_data_output_pr
765
766	INTERFACE radiation_check_parameters
767	MODULE PROCEDURE radiation_check_parameters
768	END INTERFACE radiation_check_parameters
769
770	INTERFACE radiation_clearsky
771	MODULE PROCEDURE radiation_clearsky
772	END INTERFACE radiation_clearsky
773
774	INTERFACE radiation_constant
775	MODULE PROCEDURE radiation_constant
776	END INTERFACE radiation_constant
777
778	INTERFACE radiation_control
779	MODULE PROCEDURE radiation_control
780	END INTERFACE radiation_control
781
782	INTERFACE radiation_3d_data_averaging
783	MODULE PROCEDURE radiation_3d_data_averaging
784	END INTERFACE radiation_3d_data_averaging
785
786	INTERFACE radiation_data_output_2d
787	MODULE PROCEDURE radiation_data_output_2d
788	END INTERFACE radiation_data_output_2d
789
790	INTERFACE radiation_data_output_3d
791	MODULE PROCEDURE radiation_data_output_3d
792	END INTERFACE radiation_data_output_3d
793
794	INTERFACE radiation_data_output_mask
795	MODULE PROCEDURE radiation_data_output_mask
796	END INTERFACE radiation_data_output_mask
797
798	INTERFACE radiation_define_netcdf_grid
799	MODULE PROCEDURE radiation_define_netcdf_grid
800	END INTERFACE radiation_define_netcdf_grid
801
802	INTERFACE radiation_header
803	MODULE PROCEDURE radiation_header
804	END INTERFACE radiation_header
805
806	INTERFACE radiation_init
807	MODULE PROCEDURE radiation_init
808	END INTERFACE radiation_init
809
810	INTERFACE radiation_parin
811	MODULE PROCEDURE radiation_parin
812	END INTERFACE radiation_parin
813
814	INTERFACE radiation_rrtmg
815	MODULE PROCEDURE radiation_rrtmg
816	END INTERFACE radiation_rrtmg
817
818	INTERFACE radiation_tendency
819	MODULE PROCEDURE radiation_tendency
820	MODULE PROCEDURE radiation_tendency_ij
821	END INTERFACE radiation_tendency
822
823	INTERFACE radiation_rrd_local
824	MODULE PROCEDURE radiation_rrd_local
825	END INTERFACE radiation_rrd_local
826
827	INTERFACE radiation_wrd_local
828	MODULE PROCEDURE radiation_wrd_local
829	END INTERFACE radiation_wrd_local
830
831	INTERFACE radiation_interaction
832	MODULE PROCEDURE radiation_interaction
833	END INTERFACE radiation_interaction
834
835	INTERFACE radiation_interaction_init
836	MODULE PROCEDURE radiation_interaction_init
837	END INTERFACE radiation_interaction_init
838
839	INTERFACE radiation_radflux_gridbox
840	MODULE PROCEDURE radiation_radflux_gridbox
841	END INTERFACE radiation_radflux_gridbox
842
843	INTERFACE radiation_calc_svf
844	MODULE PROCEDURE radiation_calc_svf
845	END INTERFACE radiation_calc_svf
846
847	INTERFACE radiation_write_svf
848	MODULE PROCEDURE radiation_write_svf
849	END INTERFACE radiation_write_svf
850
851	INTERFACE radiation_read_svf
852	MODULE PROCEDURE radiation_read_svf
853	END INTERFACE radiation_read_svf
854
855
856	SAVE
857
858	PRIVATE
859
860	!
861	!-- Public functions / NEEDS SORTING
862	PUBLIC radiation_check_data_output, radiation_check_data_output_pr, &
863	radiation_check_parameters, radiation_control, &
864	radiation_header, radiation_init, radiation_parin, &
865	radiation_3d_data_averaging, radiation_tendency, &
866	radiation_data_output_2d, radiation_data_output_3d, &
867	radiation_define_netcdf_grid, radiation_wrd_local, &
868	radiation_rrd_local, radiation_data_output_mask, &
869	radiation_radflux_gridbox, radiation_calc_svf, radiation_write_svf, &
870	radiation_interaction, radiation_interaction_init, &
871	radiation_read_svf
872
873
874
875	!
876	!-- Public variables and constants / NEEDS SORTING
877	PUBLIC albedo, albedo_type, decl_1, decl_2, decl_3, dots_rad, dt_radiation,&
878	emissivity, force_radiation_call, &
879	lat, lon, rad_net_av, radiation, radiation_scheme, rad_lw_in, &
880	rad_lw_in_av, rad_lw_out, rad_lw_out_av, &
881	rad_lw_cs_hr, rad_lw_cs_hr_av, rad_lw_hr, rad_lw_hr_av, rad_sw_in, &
882	rad_sw_in_av, rad_sw_out, rad_sw_out_av, rad_sw_cs_hr, &
883	rad_sw_cs_hr_av, rad_sw_hr, rad_sw_hr_av, sigma_sb, solar_constant, &
884	skip_time_do_radiation, time_radiation, unscheduled_radiation_calls,&
885	zenith, calc_zenith, sun_direction, sun_dir_lat, sun_dir_lon, &
886	split_diffusion_radiation, &
887	energy_balance_surf_h, energy_balance_surf_v, write_svf_on_init, &
888	read_svf_on_init, nrefsteps, mrt_factors, dist_max_svf, nsvfl, svf, &
889	svfsurf, surfinsw, surfinlw, surfins, surfinl, surfinswdir, &
890	surfinswdif, surfoutsw, surfoutlw, surfinlwdif, rad_sw_in_dir, &
891	rad_sw_in_diff, rad_lw_in_diff, surfouts, surfoutl, surfoutsl, &
892	surfoutll, idir, jdir, kdir, id, iz, iy, ix, isky, nenergy, nsurfs, &
893	surfstart, surf, surfl, nsurfl, pcbinsw, pcbinlw, pcbl, npcbl, &
894	startenergy, endenergy, iup_u, inorth_u, isouth_u, ieast_u, iwest_u,&
895	iup_l, inorth_l, isouth_l, ieast_l, iwest_l, startsky, endsky, &
896	startborder, endborder, nsurf_type, nzub, nzut, inorth_b,idown_a, &
897	isouth_b, ieast_b, iwest_b, nzu, pch, nsurf, iup_a, inorth_a, &
898	isouth_a, ieast_a, iwest_a, idsvf, ndsvf, idcsf, ndcsf, kdcsf, pct, &
899	radiation_interactions, startwall, startland, endland, endwall
900
901
902
903	#if defined ( __rrtmg )
904	PUBLIC rrtm_aldif, rrtm_aldir, rrtm_asdif, rrtm_asdir
905	#endif
906
907	CONTAINS
908
909
910	!------------------------------------------------------------------------------!
911	! Description:
912	! ------------
913	!> This subroutine controls the calls of the radiation schemes
914	!------------------------------------------------------------------------------!
915	SUBROUTINE radiation_control
916
917
918	IMPLICIT NONE
919
920
921	SELECT CASE ( TRIM( radiation_scheme ) )
922
923	CASE ( 'constant' )
924	CALL radiation_constant
925
926	CASE ( 'clear-sky' )
927	CALL radiation_clearsky
928
929	CASE ( 'rrtmg' )
930	CALL radiation_rrtmg
931
932	CASE DEFAULT
933
934	END SELECT
935
936
937	END SUBROUTINE radiation_control
938
939	!------------------------------------------------------------------------------!
940	! Description:
941	! ------------
942	!> Check data output for radiation model
943	!------------------------------------------------------------------------------!
944	SUBROUTINE radiation_check_data_output( var, unit, i, ilen, k )
945
946
947	USE control_parameters, &
948	ONLY: data_output, message_string
949
950	IMPLICIT NONE
951
952	CHARACTER (LEN=*) :: unit !<
953	CHARACTER (LEN=*) :: var !<
954
955	INTEGER(iwp) :: i
956	INTEGER(iwp) :: ilen
957	INTEGER(iwp) :: k
958
959	SELECT CASE ( TRIM( var ) )
960
961	CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_sw_cs_hr', 'rad_sw_hr' )
962	IF ( .NOT. radiation .OR. radiation_scheme /= 'rrtmg' ) THEN
963	message_string = '"output of "' // TRIM( var ) // '" requi' // &
964	'res radiation = .TRUE. and ' // &
965	'radiation_scheme = "rrtmg"'
966	CALL message( 'check_parameters', 'PA0406', 1, 2, 0, 6, 0 )
967	ENDIF
968	unit = 'K/h'
969
970	CASE ( 'rad_net', 'rrtm_aldif', 'rrtm_aldir', 'rrtm_asdif', &
971	'rrtm_asdir*' )
972	IF ( k == 0 .OR. data_output(i)(ilen-2:ilen) /= '_xy' ) THEN
973	message_string = 'illegal value for data_output: "' // &
974	TRIM( var ) // '" & only 2d-horizontal ' // &
975	'cross sections are allowed for this value'
976	CALL message( 'check_parameters', 'PA0111', 1, 2, 0, 6, 0 )
977	ENDIF
978	IF ( .NOT. radiation .OR. radiation_scheme /= "rrtmg" ) THEN
979	IF ( TRIM( var ) == 'rrtm_aldif*' .OR. &
980	TRIM( var ) == 'rrtm_aldir*' .OR. &
981	TRIM( var ) == 'rrtm_asdif*' .OR. &
982	TRIM( var ) == 'rrtm_asdir*' ) &
983	THEN
984	message_string = 'output of "' // TRIM( var ) // '" require'&
985	// 's radiation = .TRUE. and radiation_sch'&
986	// 'eme = "rrtmg"'
987	CALL message( 'check_parameters', 'PA0409', 1, 2, 0, 6, 0 )
988	ENDIF
989	ENDIF
990
991	IF ( TRIM( var ) == 'rad_net*' ) unit = 'W/m2'
992	IF ( TRIM( var ) == 'rrtm_aldif*' ) unit = ''
993	IF ( TRIM( var ) == 'rrtm_aldir*' ) unit = ''
994	IF ( TRIM( var ) == 'rrtm_asdif*' ) unit = ''
995	IF ( TRIM( var ) == 'rrtm_asdir*' ) unit = ''
996
997	CASE DEFAULT
998	unit = 'illegal'
999
1000	END SELECT
1001
1002
1003	END SUBROUTINE radiation_check_data_output
1004
1005	!------------------------------------------------------------------------------!
1006	! Description:
1007	! ------------
1008	!> Check data output of profiles for radiation model
1009	!------------------------------------------------------------------------------!
1010	SUBROUTINE radiation_check_data_output_pr( variable, var_count, unit, &
1011	dopr_unit )
1012
1013	USE arrays_3d, &
1014	ONLY: zu
1015
1016	USE control_parameters, &
1017	ONLY: data_output_pr, message_string
1018
1019	USE indices
1020
1021	USE profil_parameter
1022
1023	USE statistics
1024
1025	IMPLICIT NONE
1026
1027	CHARACTER (LEN=*) :: unit !<
1028	CHARACTER (LEN=*) :: variable !<
1029	CHARACTER (LEN=*) :: dopr_unit !< local value of dopr_unit
1030
1031	INTEGER(iwp) :: user_pr_index !<
1032	INTEGER(iwp) :: var_count !<
1033
1034	SELECT CASE ( TRIM( variable ) )
1035
1036	CASE ( 'rad_net' )
1037	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )&
1038	THEN
1039	message_string = 'data_output_pr = ' // &
1040	TRIM( data_output_pr(var_count) ) // ' is' // &
1041	'not available for radiation = .FALSE. or ' //&
1042	'radiation_scheme = "constant"'
1043	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1044	ELSE
1045	dopr_index(var_count) = 99
1046	dopr_unit = 'W/m2'
1047	hom(:,2,99,:) = SPREAD( zw, 2, statistic_regions+1 )
1048	unit = dopr_unit
1049	ENDIF
1050
1051	CASE ( 'rad_lw_in' )
1052	IF ( ( .NOT. radiation) .OR. radiation_scheme == 'constant' ) &
1053	THEN
1054	message_string = 'data_output_pr = ' // &
1055	TRIM( data_output_pr(var_count) ) // ' is' // &
1056	'not available for radiation = .FALSE. or ' //&
1057	'radiation_scheme = "constant"'
1058	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1059	ELSE
1060	dopr_index(var_count) = 100
1061	dopr_unit = 'W/m2'
1062	hom(:,2,100,:) = SPREAD( zw, 2, statistic_regions+1 )
1063	unit = dopr_unit
1064	ENDIF
1065
1066	CASE ( 'rad_lw_out' )
1067	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) &
1068	THEN
1069	message_string = 'data_output_pr = ' // &
1070	TRIM( data_output_pr(var_count) ) // ' is' // &
1071	'not available for radiation = .FALSE. or ' //&
1072	'radiation_scheme = "constant"'
1073	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1074	ELSE
1075	dopr_index(var_count) = 101
1076	dopr_unit = 'W/m2'
1077	hom(:,2,101,:) = SPREAD( zw, 2, statistic_regions+1 )
1078	unit = dopr_unit
1079	ENDIF
1080
1081	CASE ( 'rad_sw_in' )
1082	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) &
1083	THEN
1084	message_string = 'data_output_pr = ' // &
1085	TRIM( data_output_pr(var_count) ) // ' is' // &
1086	'not available for radiation = .FALSE. or ' //&
1087	'radiation_scheme = "constant"'
1088	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1089	ELSE
1090	dopr_index(var_count) = 102
1091	dopr_unit = 'W/m2'
1092	hom(:,2,102,:) = SPREAD( zw, 2, statistic_regions+1 )
1093	unit = dopr_unit
1094	ENDIF
1095
1096	CASE ( 'rad_sw_out')
1097	IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )&
1098	THEN
1099	message_string = 'data_output_pr = ' // &
1100	TRIM( data_output_pr(var_count) ) // ' is' // &
1101	'not available for radiation = .FALSE. or ' //&
1102	'radiation_scheme = "constant"'
1103	CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1104	ELSE
1105	dopr_index(var_count) = 103
1106	dopr_unit = 'W/m2'
1107	hom(:,2,103,:) = SPREAD( zw, 2, statistic_regions+1 )
1108	unit = dopr_unit
1109	ENDIF
1110
1111	CASE ( 'rad_lw_cs_hr' )
1112	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1113	THEN
1114	message_string = 'data_output_pr = ' // &
1115	TRIM( data_output_pr(var_count) ) // ' is' // &
1116	'not available for radiation = .FALSE. or ' //&
1117	'radiation_scheme /= "rrtmg"'
1118	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1119	ELSE
1120	dopr_index(var_count) = 104
1121	dopr_unit = 'K/h'
1122	hom(:,2,104,:) = SPREAD( zu, 2, statistic_regions+1 )
1123	unit = dopr_unit
1124	ENDIF
1125
1126	CASE ( 'rad_lw_hr' )
1127	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1128	THEN
1129	message_string = 'data_output_pr = ' // &
1130	TRIM( data_output_pr(var_count) ) // ' is' // &
1131	'not available for radiation = .FALSE. or ' //&
1132	'radiation_scheme /= "rrtmg"'
1133	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1134	ELSE
1135	dopr_index(var_count) = 105
1136	dopr_unit = 'K/h'
1137	hom(:,2,105,:) = SPREAD( zu, 2, statistic_regions+1 )
1138	unit = dopr_unit
1139	ENDIF
1140
1141	CASE ( 'rad_sw_cs_hr' )
1142	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1143	THEN
1144	message_string = 'data_output_pr = ' // &
1145	TRIM( data_output_pr(var_count) ) // ' is' // &
1146	'not available for radiation = .FALSE. or ' //&
1147	'radiation_scheme /= "rrtmg"'
1148	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1149	ELSE
1150	dopr_index(var_count) = 106
1151	dopr_unit = 'K/h'
1152	hom(:,2,106,:) = SPREAD( zu, 2, statistic_regions+1 )
1153	unit = dopr_unit
1154	ENDIF
1155
1156	CASE ( 'rad_sw_hr' )
1157	IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) &
1158	THEN
1159	message_string = 'data_output_pr = ' // &
1160	TRIM( data_output_pr(var_count) ) // ' is' // &
1161	'not available for radiation = .FALSE. or ' //&
1162	'radiation_scheme /= "rrtmg"'
1163	CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1164	ELSE
1165	dopr_index(var_count) = 107
1166	dopr_unit = 'K/h'
1167	hom(:,2,107,:) = SPREAD( zu, 2, statistic_regions+1 )
1168	unit = dopr_unit
1169	ENDIF
1170
1171
1172	CASE DEFAULT
1173	unit = 'illegal'
1174
1175	END SELECT
1176
1177
1178	END SUBROUTINE radiation_check_data_output_pr
1179
1180
1181	!------------------------------------------------------------------------------!
1182	! Description:
1183	! ------------
1184	!> Check parameters routine for radiation model
1185	!------------------------------------------------------------------------------!
1186	SUBROUTINE radiation_check_parameters
1187
1188	USE control_parameters, &
1189	ONLY: message_string, topography, urban_surface
1190
1191	USE netcdf_data_input_mod, &
1192	ONLY: input_pids_static
1193
1194	IMPLICIT NONE
1195
1196
1197	IF ( radiation_scheme /= 'constant' .AND. &
1198	radiation_scheme /= 'clear-sky' .AND. &
1199	radiation_scheme /= 'rrtmg' ) THEN
1200	message_string = 'unknown radiation_scheme = '// &
1201	TRIM( radiation_scheme )
1202	CALL message( 'check_parameters', 'PA0405', 1, 2, 0, 6, 0 )
1203	ELSEIF ( radiation_scheme == 'rrtmg' ) THEN
1204	#if ! defined ( __rrtmg )
1205	message_string = 'radiation_scheme = "rrtmg" requires ' // &
1206	'compilation of PALM with pre-processor ' // &
1207	'directive -D__rrtmg'
1208	CALL message( 'check_parameters', 'PA0407', 1, 2, 0, 6, 0 )
1209	#endif
1210	#if defined ( __rrtmg ) && ! defined( __netcdf )
1211	message_string = 'radiation_scheme = "rrtmg" requires ' // &
1212	'the use of NetCDF (preprocessor directive ' // &
1213	'-D__netcdf'
1214	CALL message( 'check_parameters', 'PA0412', 1, 2, 0, 6, 0 )
1215	#endif
1216
1217	ENDIF
1218	!
1219	!-- Checks performed only if data is given via namelist only.
1220	IF ( .NOT. input_pids_static ) THEN
1221	IF ( albedo_type == 0 .AND. albedo == 9999999.9_wp .AND. &
1222	radiation_scheme == 'clear-sky') THEN
1223	message_string = 'radiation_scheme = "clear-sky" in combination' //&
1224	'with albedo_type = 0 requires setting of albedo'//&
1225	' /= 9999999.9'
1226	CALL message( 'check_parameters', 'PA0410', 1, 2, 0, 6, 0 )
1227	ENDIF
1228
1229	IF ( albedo_type == 0 .AND. radiation_scheme == 'rrtmg' .AND. &
1230	( albedo_lw_dif == 9999999.9_wp .OR. albedo_lw_dir == 9999999.9_wp&
1231	.OR. albedo_sw_dif == 9999999.9_wp .OR. albedo_sw_dir == 9999999.9_wp&
1232	) ) THEN
1233	message_string = 'radiation_scheme = "rrtmg" in combination' // &
1234	'with albedo_type = 0 requires setting of ' // &
1235	'albedo_lw_dif /= 9999999.9' // &
1236	'albedo_lw_dir /= 9999999.9' // &
1237	'albedo_sw_dif /= 9999999.9 and' // &
1238	'albedo_sw_dir /= 9999999.9'
1239	CALL message( 'check_parameters', 'PA0411', 1, 2, 0, 6, 0 )
1240	ENDIF
1241	ENDIF
1242
1243	!
1244	!-- Radiation interactions
1245	IF ( urban_surface .AND. .NOT. radiation_interactions ) THEN
1246	message_string = 'radiation_interactions = .T. is required '// &
1247	'when using the urban surface model'
1248	CALL message( 'check_parameters', 'PA0999', 1, 2, 0, 6, 0 )
1249	ENDIF
1250
1251
1252	END SUBROUTINE radiation_check_parameters
1253
1254
1255	!------------------------------------------------------------------------------!
1256	! Description:
1257	! ------------
1258	!> Initialization of the radiation model
1259	!------------------------------------------------------------------------------!
1260	SUBROUTINE radiation_init
1261
1262	IMPLICIT NONE
1263
1264	INTEGER(iwp) :: i !< running index x-direction
1265	INTEGER(iwp) :: ind_type !< running index for subgrid-surface tiles
1266	INTEGER(iwp) :: ioff !< offset in x between surface element reference grid point in atmosphere and actual surface
1267	INTEGER(iwp) :: j !< running index y-direction
1268	INTEGER(iwp) :: joff !< offset in y between surface element reference grid point in atmosphere and actual surface
1269	INTEGER(iwp) :: l !< running index for orientation of vertical surfaces
1270	INTEGER(iwp) :: m !< running index for surface elements
1271
1272	!
1273	!-- Allocate array for storing the surface net radiation
1274	IF ( .NOT. ALLOCATED ( surf_def_h(0)%rad_net ) .AND. &
1275	surf_def_h(0)%ns > 0 ) THEN
1276	ALLOCATE( surf_def_h(0)%rad_net(1:surf_def_h(0)%ns) )
1277	surf_def_h(0)%rad_net = 0.0_wp
1278	ENDIF
1279	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_net ) .AND. &
1280	surf_lsm_h%ns > 0 ) THEN
1281	ALLOCATE( surf_lsm_h%rad_net(1:surf_lsm_h%ns) )
1282	surf_lsm_h%rad_net = 0.0_wp
1283	ENDIF
1284	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_net ) .AND. &
1285	surf_usm_h%ns > 0 ) THEN
1286	ALLOCATE( surf_usm_h%rad_net(1:surf_usm_h%ns) )
1287	surf_usm_h%rad_net = 0.0_wp
1288	ENDIF
1289	DO l = 0, 3
1290	IF ( .NOT. ALLOCATED ( surf_def_v(l)%rad_net ) .AND. &
1291	surf_def_v(l)%ns > 0 ) THEN
1292	ALLOCATE( surf_def_v(l)%rad_net(1:surf_def_v(l)%ns) )
1293	surf_def_v(l)%rad_net = 0.0_wp
1294	ENDIF
1295	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_net ) .AND. &
1296	surf_lsm_v(l)%ns > 0 ) THEN
1297	ALLOCATE( surf_lsm_v(l)%rad_net(1:surf_lsm_v(l)%ns) )
1298	surf_lsm_v(l)%rad_net = 0.0_wp
1299	ENDIF
1300	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_net ) .AND. &
1301	surf_usm_v(l)%ns > 0 ) THEN
1302	ALLOCATE( surf_usm_v(l)%rad_net(1:surf_usm_v(l)%ns) )
1303	surf_usm_v(l)%rad_net = 0.0_wp
1304	ENDIF
1305	ENDDO
1306
1307
1308	!
1309	!-- Allocate array for storing the surface longwave (out) radiation change
1310	IF ( .NOT. ALLOCATED ( surf_def_h(0)%rad_lw_out_change_0 ) .AND. &
1311	surf_def_h(0)%ns > 0 ) THEN
1312	ALLOCATE( surf_def_h(0)%rad_lw_out_change_0(1:surf_def_h(0)%ns) )
1313	surf_def_h(0)%rad_lw_out_change_0 = 0.0_wp
1314	ENDIF
1315	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_lw_out_change_0 ) .AND. &
1316	surf_lsm_h%ns > 0 ) THEN
1317	ALLOCATE( surf_lsm_h%rad_lw_out_change_0(1:surf_lsm_h%ns) )
1318	surf_lsm_h%rad_lw_out_change_0 = 0.0_wp
1319	ENDIF
1320	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_lw_out_change_0 ) .AND. &
1321	surf_usm_h%ns > 0 ) THEN
1322	ALLOCATE( surf_usm_h%rad_lw_out_change_0(1:surf_usm_h%ns) )
1323	surf_usm_h%rad_lw_out_change_0 = 0.0_wp
1324	ENDIF
1325	DO l = 0, 3
1326	IF ( .NOT. ALLOCATED ( surf_def_v(l)%rad_lw_out_change_0 ) .AND. &
1327	surf_def_v(l)%ns > 0 ) THEN
1328	ALLOCATE( surf_def_v(l)%rad_lw_out_change_0(1:surf_def_v(l)%ns) )
1329	surf_def_v(l)%rad_lw_out_change_0 = 0.0_wp
1330	ENDIF
1331	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_lw_out_change_0 ) .AND. &
1332	surf_lsm_v(l)%ns > 0 ) THEN
1333	ALLOCATE( surf_lsm_v(l)%rad_lw_out_change_0(1:surf_lsm_v(l)%ns) )
1334	surf_lsm_v(l)%rad_lw_out_change_0 = 0.0_wp
1335	ENDIF
1336	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_lw_out_change_0 ) .AND. &
1337	surf_usm_v(l)%ns > 0 ) THEN
1338	ALLOCATE( surf_usm_v(l)%rad_lw_out_change_0(1:surf_usm_v(l)%ns) )
1339	surf_usm_v(l)%rad_lw_out_change_0 = 0.0_wp
1340	ENDIF
1341	ENDDO
1342
1343	!
1344	!-- Allocate surface arrays for incoming/outgoing short/longwave radiation
1345	IF ( .NOT. ALLOCATED ( surf_def_h(0)%rad_sw_in ) .AND. &
1346	surf_def_h(0)%ns > 0 ) THEN
1347	ALLOCATE( surf_def_h(0)%rad_sw_in(1:surf_def_h(0)%ns) )
1348	ALLOCATE( surf_def_h(0)%rad_sw_out(1:surf_def_h(0)%ns) )
1349	ALLOCATE( surf_def_h(0)%rad_lw_in(1:surf_def_h(0)%ns) )
1350	ALLOCATE( surf_def_h(0)%rad_lw_out(1:surf_def_h(0)%ns) )
1351	surf_def_h(0)%rad_sw_in = 0.0_wp
1352	surf_def_h(0)%rad_sw_out = 0.0_wp
1353	surf_def_h(0)%rad_lw_in = 0.0_wp
1354	surf_def_h(0)%rad_lw_out = 0.0_wp
1355	ENDIF
1356	IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_sw_in ) .AND. &
1357	surf_lsm_h%ns > 0 ) THEN
1358	ALLOCATE( surf_lsm_h%rad_sw_in(1:surf_lsm_h%ns) )
1359	ALLOCATE( surf_lsm_h%rad_sw_out(1:surf_lsm_h%ns) )
1360	ALLOCATE( surf_lsm_h%rad_lw_in(1:surf_lsm_h%ns) )
1361	ALLOCATE( surf_lsm_h%rad_lw_out(1:surf_lsm_h%ns) )
1362	surf_lsm_h%rad_sw_in = 0.0_wp
1363	surf_lsm_h%rad_sw_out = 0.0_wp
1364	surf_lsm_h%rad_lw_in = 0.0_wp
1365	surf_lsm_h%rad_lw_out = 0.0_wp
1366	ENDIF
1367	IF ( .NOT. ALLOCATED ( surf_usm_h%rad_sw_in ) .AND. &
1368	surf_usm_h%ns > 0 ) THEN
1369	ALLOCATE( surf_usm_h%rad_sw_in(1:surf_usm_h%ns) )
1370	ALLOCATE( surf_usm_h%rad_sw_out(1:surf_usm_h%ns) )
1371	ALLOCATE( surf_usm_h%rad_lw_in(1:surf_usm_h%ns) )
1372	ALLOCATE( surf_usm_h%rad_lw_out(1:surf_usm_h%ns) )
1373	surf_usm_h%rad_sw_in = 0.0_wp
1374	surf_usm_h%rad_sw_out = 0.0_wp
1375	surf_usm_h%rad_lw_in = 0.0_wp
1376	surf_usm_h%rad_lw_out = 0.0_wp
1377	ENDIF
1378	DO l = 0, 3
1379	IF ( .NOT. ALLOCATED ( surf_def_v(l)%rad_sw_in ) .AND. &
1380	surf_def_v(l)%ns > 0 ) THEN
1381	ALLOCATE( surf_def_v(l)%rad_sw_in(1:surf_def_v(l)%ns) )
1382	ALLOCATE( surf_def_v(l)%rad_sw_out(1:surf_def_v(l)%ns) )
1383	ALLOCATE( surf_def_v(l)%rad_lw_in(1:surf_def_v(l)%ns) )
1384	ALLOCATE( surf_def_v(l)%rad_lw_out(1:surf_def_v(l)%ns) )
1385	surf_def_v(l)%rad_sw_in = 0.0_wp
1386	surf_def_v(l)%rad_sw_out = 0.0_wp
1387	surf_def_v(l)%rad_lw_in = 0.0_wp
1388	surf_def_v(l)%rad_lw_out = 0.0_wp
1389	ENDIF
1390	IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_sw_in ) .AND. &
1391	surf_lsm_v(l)%ns > 0 ) THEN
1392	ALLOCATE( surf_lsm_v(l)%rad_sw_in(1:surf_lsm_v(l)%ns) )
1393	ALLOCATE( surf_lsm_v(l)%rad_sw_out(1:surf_lsm_v(l)%ns) )
1394	ALLOCATE( surf_lsm_v(l)%rad_lw_in(1:surf_lsm_v(l)%ns) )
1395	ALLOCATE( surf_lsm_v(l)%rad_lw_out(1:surf_lsm_v(l)%ns) )
1396	surf_lsm_v(l)%rad_sw_in = 0.0_wp
1397	surf_lsm_v(l)%rad_sw_out = 0.0_wp
1398	surf_lsm_v(l)%rad_lw_in = 0.0_wp
1399	surf_lsm_v(l)%rad_lw_out = 0.0_wp
1400	ENDIF
1401	IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_sw_in ) .AND. &
1402	surf_usm_v(l)%ns > 0 ) THEN
1403	ALLOCATE( surf_usm_v(l)%rad_sw_in(1:surf_usm_v(l)%ns) )
1404	ALLOCATE( surf_usm_v(l)%rad_sw_out(1:surf_usm_v(l)%ns) )
1405	ALLOCATE( surf_usm_v(l)%rad_lw_in(1:surf_usm_v(l)%ns) )
1406	ALLOCATE( surf_usm_v(l)%rad_lw_out(1:surf_usm_v(l)%ns) )
1407	surf_usm_v(l)%rad_sw_in = 0.0_wp
1408	surf_usm_v(l)%rad_sw_out = 0.0_wp
1409	surf_usm_v(l)%rad_lw_in = 0.0_wp
1410	surf_usm_v(l)%rad_lw_out = 0.0_wp
1411	ENDIF
1412	ENDDO
1413	!
1414	!-- If necessary, allocate surface attribute albedo_type.
1415	!-- Only for default-surfaces, In case urban- or land-surface scheme is
1416	!-- utilized, this has been already allocated. For default surfaces,
1417	!-- no tile approach between different surface fractions is considered,
1418	!-- so first dimension is allocated with zero.
1419	!-- Initialize them with namelist parameter.
1420	ALLOCATE ( surf_def_h(0)%albedo_type(0:0,1:surf_def_h(0)%ns) )
1421	surf_def_h(0)%albedo_type = albedo_type
1422
1423	DO l = 0, 3
1424	ALLOCATE ( surf_def_v(l)%albedo_type(0:0,1:surf_def_v(l)%ns) )
1425	surf_def_v(l)%albedo_type = albedo_type
1426	ENDDO
1427	!
1428	!-- If available, overwrite albedo_type by values read from file.
1429	!-- Again, only required for default-type surfaces.
1430	IF ( albedo_type_f%from_file ) THEN
1431	DO i = nxl, nxr
1432	DO j = nys, nyn
1433	IF ( albedo_type_f%var(j,i) /= albedo_type_f%fill ) THEN
1434
1435	DO m = surf_def_h(0)%start_index(j,i), &
1436	surf_def_h(0)%end_index(j,i)
1437	surf_def_h(0)%albedo_type(0,m) = albedo_type_f%var(j,i)
1438	ENDDO
1439	DO l = 0, 3
1440	ioff = surf_def_v(l)%ioff
1441	joff = surf_def_v(l)%joff
1442	DO m = surf_def_v(l)%start_index(j,i), &
1443	surf_def_v(l)%end_index(j,i)
1444	surf_def_v(l)%albedo_type(0,m) = &
1445	albedo_type_f%var(j+joff,i+ioff)
1446	ENDDO
1447	ENDDO
1448	ENDIF
1449	ENDDO
1450	ENDDO
1451	ENDIF
1452
1453	!
1454	!-- If necessary, allocate surface attribute emissivity.
1455	!-- Only for default-type surfaces. In case urband- or
1456	!-- land-surface scheme is utilized, this has been already allocated.
1457	!-- Initialize them with namelist parameter.
1458	ALLOCATE ( surf_def_h(0)%emissivity(0:0,1:surf_def_h(0)%ns) )
1459	surf_def_h(0)%emissivity = emissivity
1460
1461	DO l = 0, 3
1462	ALLOCATE ( surf_def_v(l)%emissivity(0:0,1:surf_def_v(l)%ns) )
1463	ENDDO
1464
1465	!
1466	!-- Fix net radiation in case of radiation_scheme = 'constant'
1467	IF ( radiation_scheme == 'constant' ) THEN
1468	IF ( ALLOCATED( surf_def_h(0)%rad_net ) ) &
1469	surf_def_h(0)%rad_net = net_radiation
1470	IF ( ALLOCATED( surf_lsm_h%rad_net ) ) &
1471	surf_lsm_h%rad_net = net_radiation
1472	IF ( ALLOCATED( surf_usm_h%rad_net ) ) &
1473	surf_usm_h%rad_net = net_radiation
1474	!
1475	!-- Todo: weight with inclination angle
1476	DO l = 0, 3
1477	IF ( ALLOCATED( surf_def_v(l)%rad_net ) ) &
1478	surf_def_v(l)%rad_net = net_radiation
1479	IF ( ALLOCATED( surf_lsm_v(l)%rad_net ) ) &
1480	surf_lsm_v(l)%rad_net = net_radiation
1481	IF ( ALLOCATED( surf_usm_v(l)%rad_net ) ) &
1482	surf_usm_v(l)%rad_net = net_radiation
1483	ENDDO
1484	! radiation = .FALSE.
1485	!
1486	!-- Calculate orbital constants
1487	ELSE
1488	decl_1 = SIN(23.45_wp * pi / 180.0_wp)
1489	decl_2 = 2.0_wp * pi / 365.0_wp
1490	decl_3 = decl_2 * 81.0_wp
1491	lat = latitude * pi / 180.0_wp
1492	lon = longitude * pi / 180.0_wp
1493	ENDIF
1494
1495	IF ( radiation_scheme == 'clear-sky' .OR. &
1496	radiation_scheme == 'constant') THEN
1497	!
1498	!-- Allocate average arrays for incoming/outgoing short/longwave radiation
1499	IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN
1500	ALLOCATE ( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
1501	ENDIF
1502	IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN
1503	ALLOCATE ( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
1504	ENDIF
1505
1506	IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN
1507	ALLOCATE ( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
1508	ENDIF
1509	IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN
1510	ALLOCATE ( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
1511	ENDIF
1512	!
1513	!-- Allocate arrays for broadband albedo, and level 1 initialization
1514	!-- via namelist paramter.
1515	IF ( .NOT. ALLOCATED(surf_def_h(0)%albedo) ) &
1516	ALLOCATE( surf_def_h(0)%albedo(0:0,1:surf_def_h(0)%ns) )
1517	IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) &
1518	ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) )
1519	IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) &
1520	ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) )
1521
1522	surf_def_h(0)%albedo = albedo
1523	surf_lsm_h%albedo = albedo
1524	surf_usm_h%albedo = albedo
1525	DO l = 0, 3
1526	IF ( .NOT. ALLOCATED( surf_def_v(l)%albedo ) ) &
1527	ALLOCATE( surf_def_v(l)%albedo(0:0,1:surf_def_v(l)%ns) )
1528	IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) &
1529	ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) )
1530	IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) &
1531	ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) )
1532
1533	surf_def_v(l)%albedo = albedo
1534	surf_lsm_v(l)%albedo = albedo
1535	surf_usm_v(l)%albedo = albedo
1536	ENDDO
1537	!
1538	!-- Level 2 initialization of broadband albedo via given albedo_type.
1539	!-- Only if albedo_type is non-zero
1540	DO m = 1, surf_def_h(0)%ns
1541	IF ( surf_def_h(0)%albedo_type(0,m) /= 0 ) &
1542	surf_def_h(0)%albedo(0,m) = &
1543	albedo_pars(2,surf_def_h(0)%albedo_type(0,m))
1544	ENDDO
1545	DO m = 1, surf_lsm_h%ns
1546	IF ( surf_lsm_h%albedo_type(0,m) /= 0 ) &
1547	surf_lsm_h%albedo(0,m) = &
1548	albedo_pars(2,surf_lsm_h%albedo_type(0,m))
1549	IF ( surf_lsm_h%albedo_type(1,m) /= 0 ) &
1550	surf_lsm_h%albedo(1,m) = &
1551	albedo_pars(2,surf_lsm_h%albedo_type(1,m))
1552	IF ( surf_lsm_h%albedo_type(2,m) /= 0 ) &
1553	surf_lsm_h%albedo(2,m) = &
1554	albedo_pars(2,surf_lsm_h%albedo_type(2,m))
1555	ENDDO
1556	DO m = 1, surf_usm_h%ns
1557	IF ( surf_usm_h%albedo_type(0,m) /= 0 ) &
1558	surf_usm_h%albedo(0,m) = &
1559	albedo_pars(2,surf_usm_h%albedo_type(0,m))
1560	IF ( surf_usm_h%albedo_type(1,m) /= 0 ) &
1561	surf_usm_h%albedo(1,m) = &
1562	albedo_pars(2,surf_usm_h%albedo_type(1,m))
1563	IF ( surf_usm_h%albedo_type(2,m) /= 0 ) &
1564	surf_usm_h%albedo(2,m) = &
1565	albedo_pars(2,surf_usm_h%albedo_type(2,m))
1566	ENDDO
1567
1568	DO l = 0, 3
1569	DO m = 1, surf_def_v(l)%ns
1570	IF ( surf_def_v(l)%albedo_type(0,m) /= 0 ) &
1571	surf_def_v(l)%albedo(0,m) = &
1572	albedo_pars(2,surf_def_v(l)%albedo_type(0,m))
1573	ENDDO
1574	DO m = 1, surf_lsm_v(l)%ns
1575	IF ( surf_lsm_v(l)%albedo_type(0,m) /= 0 ) &
1576	surf_lsm_v(l)%albedo(0,m) = &
1577	albedo_pars(2,surf_lsm_v(l)%albedo_type(0,m))
1578	IF ( surf_lsm_v(l)%albedo_type(1,m) /= 0 ) &
1579	surf_lsm_v(l)%albedo(1,m) = &
1580	albedo_pars(2,surf_lsm_v(l)%albedo_type(1,m))
1581	IF ( surf_lsm_v(l)%albedo_type(2,m) /= 0 ) &
1582	surf_lsm_v(l)%albedo(2,m) = &
1583	albedo_pars(2,surf_lsm_v(l)%albedo_type(2,m))
1584	ENDDO
1585	DO m = 1, surf_usm_v(l)%ns
1586	IF ( surf_usm_v(l)%albedo_type(0,m) /= 0 ) &
1587	surf_usm_v(l)%albedo(0,m) = &
1588	albedo_pars(2,surf_usm_v(l)%albedo_type(0,m))
1589	IF ( surf_usm_v(l)%albedo_type(1,m) /= 0 ) &
1590	surf_usm_v(l)%albedo(1,m) = &
1591	albedo_pars(2,surf_usm_v(l)%albedo_type(1,m))
1592	IF ( surf_usm_v(l)%albedo_type(2,m) /= 0 ) &
1593	surf_usm_v(l)%albedo(2,m) = &
1594	albedo_pars(2,surf_usm_v(l)%albedo_type(2,m))
1595	ENDDO
1596	ENDDO
1597
1598	!
1599	!-- Level 3 initialization at grid points where albedo type is zero.
1600	!-- This case, albedo is taken from file. In case of constant radiation
1601	!-- or clear sky, only broadband albedo is given.
1602	IF ( albedo_pars_f%from_file ) THEN
1603	!
1604	!-- Horizontal surfaces
1605	DO m = 1, surf_def_h(0)%ns
1606	i = surf_def_h(0)%i(m)
1607	j = surf_def_h(0)%j(m)
1608	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill .AND. &
1609	surf_def_h(0)%albedo_type(0,m) == 0 ) THEN
1610	surf_def_h(0)%albedo(0,m) = albedo_pars_f%pars_xy(0,j,i)
1611	ENDIF
1612	ENDDO
1613	DO m = 1, surf_lsm_h%ns
1614	i = surf_lsm_h%i(m)
1615	j = surf_lsm_h%j(m)
1616	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1617	IF ( surf_lsm_h%albedo_type(0,m) == 0 ) &
1618	surf_lsm_h%albedo(0,m) = albedo_pars_f%pars_xy(0,j,i)
1619	IF ( surf_lsm_h%albedo_type(1,m) == 0 ) &
1620	surf_lsm_h%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i)
1621	IF ( surf_lsm_h%albedo_type(2,m) == 0 ) &
1622	surf_lsm_h%albedo(2,m) = albedo_pars_f%pars_xy(0,j,i)
1623	ENDIF
1624	ENDDO
1625	DO m = 1, surf_usm_h%ns
1626	i = surf_usm_h%i(m)
1627	j = surf_usm_h%j(m)
1628	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1629	IF ( surf_usm_h%albedo_type(0,m) == 0 ) &
1630	surf_usm_h%albedo(0,m) = albedo_pars_f%pars_xy(0,j,i)
1631	IF ( surf_usm_h%albedo_type(1,m) == 0 ) &
1632	surf_usm_h%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i)
1633	IF ( surf_usm_h%albedo_type(2,m) == 0 ) &
1634	surf_usm_h%albedo(2,m) = albedo_pars_f%pars_xy(0,j,i)
1635	ENDIF
1636	ENDDO
1637	!
1638	!-- Vertical surfaces
1639	DO l = 0, 3
1640
1641	ioff = surf_def_v(l)%ioff
1642	joff = surf_def_v(l)%joff
1643	DO m = 1, surf_def_v(l)%ns
1644	i = surf_def_v(l)%i(m) + ioff
1645	j = surf_def_v(l)%j(m) + joff
1646	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill .AND. &
1647	surf_def_v(l)%albedo_type(0,m) == 0 ) THEN
1648	surf_def_v(l)%albedo(0,m) = albedo_pars_f%pars_xy(0,j,i)
1649	ENDIF
1650	ENDDO
1651
1652	ioff = surf_lsm_v(l)%ioff
1653	joff = surf_lsm_v(l)%joff
1654	DO m = 1, surf_lsm_v(l)%ns
1655	i = surf_lsm_v(l)%i(m) + ioff
1656	j = surf_lsm_v(l)%j(m) + joff
1657	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1658	IF ( surf_lsm_v(l)%albedo_type(0,m) == 0 ) &
1659	surf_lsm_v(l)%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i)
1660	IF ( surf_lsm_v(l)%albedo_type(1,m) == 0 ) &
1661	surf_lsm_v(l)%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i)
1662	IF ( surf_lsm_v(l)%albedo_type(2,m) == 0 ) &
1663	surf_lsm_v(l)%albedo(2,m) = albedo_pars_f%pars_xy(0,j,i)
1664	ENDIF
1665	ENDDO
1666
1667	ioff = surf_usm_v(l)%ioff
1668	joff = surf_usm_v(l)%joff
1669	DO m = 1, surf_usm_h%ns
1670	i = surf_usm_h%i(m) + joff
1671	j = surf_usm_h%j(m) + joff
1672	IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN
1673	IF ( surf_usm_v(l)%albedo_type(0,m) == 0 ) &
1674	surf_usm_v(l)%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i)
1675	IF ( surf_usm_v(l)%albedo_type(1,m) == 0 ) &
1676	surf_usm_v(l)%albedo(1,m) = albedo_pars_f%pars_xy(0,j,i)
1677	IF ( surf_usm_v(l)%albedo_type(2,m) == 0 ) &
1678	surf_lsm_v(l)%albedo(2,m) = albedo_pars_f%pars_xy(0,j,i)
1679	ENDIF
1680	ENDDO
1681	ENDDO
1682
1683	ENDIF
1684	!
1685	!-- Initialization actions for RRTMG
1686	ELSEIF ( radiation_scheme == 'rrtmg' ) THEN
1687	#if defined ( __rrtmg )
1688	!
1689	!-- Allocate albedos for short/longwave radiation, horizontal surfaces
1690	!-- for wall/green/window (USM) or vegetation/pavement/water surfaces
1691	!-- (LSM). Please note, for default-type surfaces no tile approach is
1692	!-- applied.
1693	ALLOCATE ( surf_def_h(0)%aldif(0:0,1:surf_def_h(0)%ns) )
1694	ALLOCATE ( surf_def_h(0)%aldir(0:0,1:surf_def_h(0)%ns) )
1695	ALLOCATE ( surf_def_h(0)%asdif(0:0,1:surf_def_h(0)%ns) )
1696	ALLOCATE ( surf_def_h(0)%asdir(0:0,1:surf_def_h(0)%ns) )
1697	ALLOCATE ( surf_def_h(0)%rrtm_aldif(0:0,1:surf_def_h(0)%ns) )
1698	ALLOCATE ( surf_def_h(0)%rrtm_aldir(0:0,1:surf_def_h(0)%ns) )
1699	ALLOCATE ( surf_def_h(0)%rrtm_asdif(0:0,1:surf_def_h(0)%ns) )
1700	ALLOCATE ( surf_def_h(0)%rrtm_asdir(0:0,1:surf_def_h(0)%ns) )
1701
1702	ALLOCATE ( surf_lsm_h%aldif(0:2,1:surf_lsm_h%ns) )
1703	ALLOCATE ( surf_lsm_h%aldir(0:2,1:surf_lsm_h%ns) )
1704	ALLOCATE ( surf_lsm_h%asdif(0:2,1:surf_lsm_h%ns) )
1705	ALLOCATE ( surf_lsm_h%asdir(0:2,1:surf_lsm_h%ns) )
1706	ALLOCATE ( surf_lsm_h%rrtm_aldif(0:2,1:surf_lsm_h%ns) )
1707	ALLOCATE ( surf_lsm_h%rrtm_aldir(0:2,1:surf_lsm_h%ns) )
1708	ALLOCATE ( surf_lsm_h%rrtm_asdif(0:2,1:surf_lsm_h%ns) )
1709	ALLOCATE ( surf_lsm_h%rrtm_asdir(0:2,1:surf_lsm_h%ns) )
1710
1711	ALLOCATE ( surf_usm_h%aldif(0:2,1:surf_usm_h%ns) )
1712	ALLOCATE ( surf_usm_h%aldir(0:2,1:surf_usm_h%ns) )
1713	ALLOCATE ( surf_usm_h%asdif(0:2,1:surf_usm_h%ns) )
1714	ALLOCATE ( surf_usm_h%asdir(0:2,1:surf_usm_h%ns) )
1715	ALLOCATE ( surf_usm_h%rrtm_aldif(0:2,1:surf_usm_h%ns) )
1716	ALLOCATE ( surf_usm_h%rrtm_aldir(0:2,1:surf_usm_h%ns) )
1717	ALLOCATE ( surf_usm_h%rrtm_asdif(0:2,1:surf_usm_h%ns) )
1718	ALLOCATE ( surf_usm_h%rrtm_asdir(0:2,1:surf_usm_h%ns) )
1719
1720	!
1721	!-- Allocate broadband albedo (temporary for the current radiation
1722	!-- implementations)
1723	IF ( .NOT. ALLOCATED(surf_def_h(0)%albedo) ) &
1724	ALLOCATE( surf_def_h(0)%albedo(0:0,1:surf_def_h(0)%ns) )
1725	IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) &
1726	ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns) )
1727	IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) &
1728	ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns) )
1729
1730	!
1731	!-- Allocate albedos for short/longwave radiation, vertical surfaces
1732	DO l = 0, 3
1733	ALLOCATE ( surf_def_v(l)%aldif(0:0,1:surf_def_v(l)%ns) )
1734	ALLOCATE ( surf_def_v(l)%aldir(0:0,1:surf_def_v(l)%ns) )
1735	ALLOCATE ( surf_def_v(l)%asdif(0:0,1:surf_def_v(l)%ns) )
1736	ALLOCATE ( surf_def_v(l)%asdir(0:0,1:surf_def_v(l)%ns) )
1737
1738	ALLOCATE ( surf_def_v(l)%rrtm_aldif(0:0,1:surf_def_v(l)%ns) )
1739	ALLOCATE ( surf_def_v(l)%rrtm_aldir(0:0,1:surf_def_v(l)%ns) )
1740	ALLOCATE ( surf_def_v(l)%rrtm_asdif(0:0,1:surf_def_v(l)%ns) )
1741	ALLOCATE ( surf_def_v(l)%rrtm_asdir(0:0,1:surf_def_v(l)%ns) )
1742
1743	ALLOCATE ( surf_lsm_v(l)%aldif(0:2,1:surf_lsm_v(l)%ns) )
1744	ALLOCATE ( surf_lsm_v(l)%aldir(0:2,1:surf_lsm_v(l)%ns) )
1745	ALLOCATE ( surf_lsm_v(l)%asdif(0:2,1:surf_lsm_v(l)%ns) )
1746	ALLOCATE ( surf_lsm_v(l)%asdir(0:2,1:surf_lsm_v(l)%ns) )
1747
1748	ALLOCATE ( surf_lsm_v(l)%rrtm_aldif(0:2,1:surf_lsm_v(l)%ns) )
1749	ALLOCATE ( surf_lsm_v(l)%rrtm_aldir(0:2,1:surf_lsm_v(l)%ns) )
1750	ALLOCATE ( surf_lsm_v(l)%rrtm_asdif(0:2,1:surf_lsm_v(l)%ns) )
1751	ALLOCATE ( surf_lsm_v(l)%rrtm_asdir(0:2,1:surf_lsm_v(l)%ns) )
1752
1753	ALLOCATE ( surf_usm_v(l)%aldif(0:2,1:surf_usm_v(l)%ns) )
1754	ALLOCATE ( surf_usm_v(l)%aldir(0:2,1:surf_usm_v(l)%ns) )
1755	ALLOCATE ( surf_usm_v(l)%asdif(0:2,1:surf_usm_v(l)%ns) )
1756	ALLOCATE ( surf_usm_v(l)%asdir(0:2,1:surf_usm_v(l)%ns) )
1757
1758	ALLOCATE ( surf_usm_v(l)%rrtm_aldif(0:2,1:surf_usm_v(l)%ns) )
1759	ALLOCATE ( surf_usm_v(l)%rrtm_aldir(0:2,1:surf_usm_v(l)%ns) )
1760	ALLOCATE ( surf_usm_v(l)%rrtm_asdif(0:2,1:surf_usm_v(l)%ns) )
1761	ALLOCATE ( surf_usm_v(l)%rrtm_asdir(0:2,1:surf_usm_v(l)%ns) )
1762	!
1763	!-- Allocate broadband albedo (temporary for the current radiation
1764	!-- implementations)
1765	IF ( .NOT. ALLOCATED( surf_def_v(l)%albedo ) ) &
1766	ALLOCATE( surf_def_v(l)%albedo(0:0,1:surf_def_v(l)%ns) )
1767	IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) &
1768	ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) )
1769	IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) &
1770	ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) )
1771
1772	ENDDO
1773	!
1774	!-- Level 1 initialization of spectral albedos via namelist
1775	!-- paramters. Please note, this case all surface tiles are initialized
1776	!-- the same.
1777	IF ( surf_def_h(0)%ns > 0 ) THEN
1778	surf_def_h(0)%aldif = albedo_lw_dif
1779	surf_def_h(0)%aldir = albedo_lw_dir
1780	surf_def_h(0)%asdif = albedo_sw_dif
1781	surf_def_h(0)%asdir = albedo_sw_dir
1782	surf_def_h(0)%albedo = albedo_sw_dif
1783	ENDIF
1784	IF ( surf_lsm_h%ns > 0 ) THEN
1785	surf_lsm_h%aldif = albedo_lw_dif
1786	surf_lsm_h%aldir = albedo_lw_dir
1787	surf_lsm_h%asdif = albedo_sw_dif
1788	surf_lsm_h%asdir = albedo_sw_dir
1789	surf_lsm_h%albedo = albedo_sw_dif
1790	ENDIF
1791	IF ( surf_usm_h%ns > 0 ) THEN
1792	surf_usm_h%aldif = albedo_lw_dif
1793	surf_usm_h%aldir = albedo_lw_dir
1794	surf_usm_h%asdif = albedo_sw_dif
1795	surf_usm_h%asdir = albedo_sw_dir
1796	surf_usm_h%albedo = albedo_sw_dif
1797	ENDIF
1798
1799	DO l = 0, 3
1800	IF ( surf_def_v(l)%ns > 0 ) THEN
1801	surf_def_v(l)%aldif = albedo_lw_dif
1802	surf_def_v(l)%aldir = albedo_lw_dir
1803	surf_def_v(l)%asdif = albedo_sw_dif
1804	surf_def_v(l)%asdir = albedo_sw_dir
1805	surf_def_v(l)%albedo = albedo_sw_dif
1806	ENDIF
1807
1808	IF ( surf_lsm_v(l)%ns > 0 ) THEN
1809	surf_lsm_v(l)%aldif = albedo_lw_dif
1810	surf_lsm_v(l)%aldir = albedo_lw_dir
1811	surf_lsm_v(l)%asdif = albedo_sw_dif
1812	surf_lsm_v(l)%asdir = albedo_sw_dir
1813	surf_lsm_v(l)%albedo = albedo_sw_dif
1814	ENDIF
1815
1816	IF ( surf_usm_v(l)%ns > 0 ) THEN
1817	surf_usm_v(l)%aldif = albedo_lw_dif
1818	surf_usm_v(l)%aldir = albedo_lw_dir
1819	surf_usm_v(l)%asdif = albedo_sw_dif
1820	surf_usm_v(l)%asdir = albedo_sw_dir
1821	surf_usm_v(l)%albedo = albedo_sw_dif
1822	ENDIF
1823	ENDDO
1824
1825	!
1826	!-- Level 2 initialization of spectral albedos via albedo_type.
1827	!-- Please note, for natural- and urban-type surfaces, a tile approach
1828	!-- is applied so that the resulting albedo is calculated via the weighted
1829	!-- average of respective surface fractions.
1830	DO m = 1, surf_def_h(0)%ns
1831	IF ( surf_def_h(0)%albedo_type(0,m) /= 0 ) THEN
1832	surf_def_h(0)%aldif(0,m) = &
1833	albedo_pars(0,surf_def_h(0)%albedo_type(0,m))
1834	surf_def_h(0)%asdif(0,m) = &
1835	albedo_pars(1,surf_def_h(0)%albedo_type(0,m))
1836	surf_def_h(0)%aldir(0,m) = &
1837	albedo_pars(0,surf_def_h(0)%albedo_type(0,m))
1838	surf_def_h(0)%asdir(0,m) = &
1839	albedo_pars(1,surf_def_h(0)%albedo_type(0,m))
1840	surf_def_h(0)%albedo(0,m) = &
1841	albedo_pars(2,surf_def_h(0)%albedo_type(0,m))
1842	ENDIF
1843	ENDDO
1844
1845	DO m = 1, surf_lsm_h%ns
1846	!
1847	!-- Spectral albedos for vegetation/pavement/water surfaces
1848	DO ind_type = 0, 2
1849	IF ( surf_lsm_h%albedo_type(ind_type,m) /= 0 ) THEN
1850	surf_lsm_h%aldif(ind_type,m) = &
1851	albedo_pars(0,surf_lsm_h%albedo_type(ind_type,m))
1852	surf_lsm_h%asdif(ind_type,m) = &
1853	albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m))
1854	surf_lsm_h%aldir(ind_type,m) = &
1855	albedo_pars(0,surf_lsm_h%albedo_type(ind_type,m))
1856	surf_lsm_h%asdir(ind_type,m) = &
1857	albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m))
1858	surf_lsm_h%albedo(ind_type,m) = &
1859	albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m))
1860	ENDIF
1861	ENDDO
1862
1863	ENDDO
1864
1865	DO m = 1, surf_usm_h%ns
1866	!
1867	!-- Spectral albedos for wall/green/window surfaces
1868	DO ind_type = 0, 2
1869	IF ( surf_usm_h%albedo_type(ind_type,m) /= 0 ) THEN
1870	surf_usm_h%aldif(ind_type,m) = &
1871	albedo_pars(0,surf_usm_h%albedo_type(ind_type,m))
1872	surf_usm_h%asdif(ind_type,m) = &
1873	albedo_pars(1,surf_usm_h%albedo_type(ind_type,m))
1874	surf_usm_h%aldir(ind_type,m) = &
1875	albedo_pars(0,surf_usm_h%albedo_type(ind_type,m))
1876	surf_usm_h%asdir(ind_type,m) = &
1877	albedo_pars(1,surf_usm_h%albedo_type(ind_type,m))
1878	surf_usm_h%albedo(ind_type,m) = &
1879	albedo_pars(2,surf_usm_h%albedo_type(ind_type,m))
1880	ENDIF
1881	ENDDO
1882
1883	ENDDO
1884
1885	DO l = 0, 3
1886
1887	DO m = 1, surf_def_v(l)%ns
1888	IF ( surf_def_v(l)%albedo_type(0,m) /= 0 ) THEN
1889	surf_def_v(l)%aldif(0,m) = &
1890	albedo_pars(0,surf_def_v(l)%albedo_type(0,m))
1891	surf_def_v(l)%asdif(0,m) = &
1892	albedo_pars(1,surf_def_v(l)%albedo_type(0,m))
1893	surf_def_v(l)%aldir(0,m) = &
1894	albedo_pars(0,surf_def_v(l)%albedo_type(0,m))
1895	surf_def_v(l)%asdir(0,m) = &
1896	albedo_pars(1,surf_def_v(l)%albedo_type(0,m))
1897	surf_def_v(l)%albedo(0,m) = &
1898	albedo_pars(2,surf_def_v(l)%albedo_type(0,m))
1899	ENDIF
1900	ENDDO
1901
1902	DO m = 1, surf_lsm_v(l)%ns
1903	!
1904	!-- Spectral albedos for vegetation/pavement/water surfaces
1905	DO ind_type = 0, 2
1906	IF ( surf_lsm_v(l)%albedo_type(ind_type,m) /= 0 ) THEN
1907	surf_lsm_v(l)%aldif(ind_type,m) = &
1908	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_type,m))
1909	surf_lsm_v(l)%asdif(ind_type,m) = &
1910	albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m))
1911	surf_lsm_v(l)%aldir(ind_type,m) = &
1912	albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_type,m))
1913	surf_lsm_v(l)%asdir(ind_type,m) = &
1914	albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m))
1915	surf_lsm_v(l)%albedo(ind_type,m) = &
1916	albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m))
1917	ENDIF
1918	ENDDO
1919	ENDDO
1920
1921	DO m = 1, surf_usm_v(l)%ns
1922	!
1923	!-- Spectral albedos for wall/green/window surfaces
1924	DO ind_type = 0, 2
1925	IF ( surf_usm_v(l)%albedo_type(ind_type,m) /= 0 ) THEN
1926	surf_usm_v(l)%aldif(ind_type,m) = &
1927	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_type,m))
1928	surf_usm_v(l)%asdif(ind_type,m) = &
1929	albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m))
1930	surf_usm_v(l)%aldir(ind_type,m) = &
1931	albedo_pars(0,surf_usm_v(l)%albedo_type(ind_type,m))
1932	surf_usm_v(l)%asdir(ind_type,m) = &
1933	albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m))
1934	surf_usm_v(l)%albedo(ind_type,m) = &
1935	albedo_pars(2,surf_usm_v(l)%albedo_type(ind_type,m))
1936	ENDIF
1937	ENDDO
1938
1939	ENDDO
1940	ENDDO
1941	!
1942	!-- Level 3 initialization at grid points where albedo type is zero.
1943	!-- This case, spectral albedos are taken from file if available
1944	IF ( albedo_pars_f%from_file ) THEN
1945	!
1946	!-- Horizontal
1947	DO m = 1, surf_def_h(0)%ns
1948	i = surf_def_h(0)%i(m)
1949	j = surf_def_h(0)%j(m)
1950	IF ( surf_def_h(0)%albedo_type(0,m) == 0 ) THEN
1951
1952	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) &
1953	surf_def_h(0)%albedo(0,m) = albedo_pars_f%pars_xy(1,j,i)
1954	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) &
1955	surf_def_h(0)%aldir(0,m) = albedo_pars_f%pars_xy(1,j,i)
1956	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) &
1957	surf_def_h(0)%aldif(0,m) = albedo_pars_f%pars_xy(2,j,i)
1958	IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill ) &
1959	surf_def_h(0)%asdir(0,m) = albedo_pars_f%pars_xy(3,j,i)
1960	IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill ) &
1961	surf_def_h(0)%asdif(0,m) = albedo_pars_f%pars_xy(4,j,i)
1962	ENDIF
1963	ENDDO
1964
1965	DO m = 1, surf_lsm_h%ns
1966	i = surf_lsm_h%i(m)
1967	j = surf_lsm_h%j(m)
1968	!
1969	!-- Spectral albedos for vegetation/pavement/water surfaces
1970	DO ind_type = 0, 2
1971	IF ( surf_lsm_h%albedo_type(ind_type,m) == 0 ) THEN
1972	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )&
1973	surf_lsm_h%albedo(ind_type,m) = &
1974	albedo_pars_f%pars_xy(1,j,i)
1975	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )&
1976	surf_lsm_h%aldir(ind_type,m) = &
1977	albedo_pars_f%pars_xy(1,j,i)
1978	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill )&
1979	surf_lsm_h%aldif(ind_type,m) = &
1980	albedo_pars_f%pars_xy(2,j,i)
1981	IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill )&
1982	surf_lsm_h%asdir(ind_type,m) = &
1983	albedo_pars_f%pars_xy(3,j,i)
1984	IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill )&
1985	surf_lsm_h%asdif(ind_type,m) = &
1986	albedo_pars_f%pars_xy(4,j,i)
1987	ENDIF
1988	ENDDO
1989	ENDDO
1990
1991	DO m = 1, surf_usm_h%ns
1992	i = surf_usm_h%i(m)
1993	j = surf_usm_h%j(m)
1994	!
1995	!-- Spectral albedos for wall/green/window surfaces
1996	DO ind_type = 0, 2
1997	IF ( surf_usm_h%albedo_type(ind_type,m) == 0 ) THEN
1998	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )&
1999	surf_usm_h%albedo(ind_type,m) = &
2000	albedo_pars_f%pars_xy(1,j,i)
2001	IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )&
2002	surf_usm_h%aldir(ind_type,m) = &
2003	albedo_pars_f%pars_xy(1,j,i)
2004	IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill )&
2005	surf_usm_h%aldif(ind_type,m) = &
2006	albedo_pars_f%pars_xy(2,j,i)
2007	IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill )&
2008	surf_usm_h%asdir(ind_type,m) = &
2009	albedo_pars_f%pars_xy(3,j,i)
2010	IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill )&
2011	surf_usm_h%asdif(ind_type,m) = &
2012	albedo_pars_f%pars_xy(4,j,i)
2013	ENDIF
2014	ENDDO
2015
2016	ENDDO
2017	!
2018	!-- Vertical
2019	DO l = 0, 3
2020	ioff = surf_def_v(l)%ioff
2021	joff = surf_def_v(l)%joff
2022
2023	DO m = 1, surf_def_v(l)%ns
2024
2025	i = surf_def_v(l)%i(m)
2026	j = surf_def_v(l)%j(m)
2027
2028	IF ( surf_def_v(l)%albedo_type(0,m) == 0 ) THEN
2029
2030	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2031	albedo_pars_f%fill ) &
2032	surf_def_v(l)%albedo(0,m) = &
2033	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2034	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2035	albedo_pars_f%fill ) &
2036	surf_def_v(l)%aldir(0,m) = &
2037	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2038	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2039	albedo_pars_f%fill ) &
2040	surf_def_v(l)%aldif(0,m) = &
2041	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2042	IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= &
2043	albedo_pars_f%fill ) &
2044	surf_def_v(l)%asdir(0,m) = &
2045	albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2046	IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= &
2047	albedo_pars_f%fill ) &
2048	surf_def_v(l)%asdif(0,m) = &
2049	albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2050	ENDIF
2051	ENDDO
2052
2053	ioff = surf_lsm_v(l)%ioff
2054	joff = surf_lsm_v(l)%joff
2055
2056	DO m = 1, surf_lsm_v(l)%ns
2057	i = surf_lsm_v(l)%i(m)
2058	j = surf_lsm_v(l)%j(m)
2059	!
2060	!-- Spectral albedos for vegetation/pavement/water surfaces
2061	DO ind_type = 0, 2
2062	IF ( surf_lsm_v(l)%albedo_type(ind_type,m) == 0 ) THEN
2063	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2064	albedo_pars_f%fill ) &
2065	surf_lsm_v(l)%albedo(ind_type,m) = &
2066	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2067	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2068	albedo_pars_f%fill ) &
2069	surf_lsm_v(l)%aldir(ind_type,m) = &
2070	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2071	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2072	albedo_pars_f%fill ) &
2073	surf_lsm_v(l)%aldif(ind_type,m) = &
2074	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2075	IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= &
2076	albedo_pars_f%fill ) &
2077	surf_lsm_v(l)%asdir(ind_type,m) = &
2078	albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2079	IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= &
2080	albedo_pars_f%fill ) &
2081	surf_lsm_v(l)%asdif(ind_type,m) = &
2082	albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2083	ENDIF
2084	ENDDO
2085	ENDDO
2086
2087	ioff = surf_usm_v(l)%ioff
2088	joff = surf_usm_v(l)%joff
2089
2090	DO m = 1, surf_usm_v(l)%ns
2091	i = surf_usm_v(l)%i(m)
2092	j = surf_usm_v(l)%j(m)
2093	!
2094	!-- Spectral albedos for wall/green/window surfaces
2095	DO ind_type = 0, 2
2096	IF ( surf_usm_v(l)%albedo_type(ind_type,m) == 0 ) THEN
2097	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2098	albedo_pars_f%fill ) &
2099	surf_usm_v(l)%albedo(ind_type,m) = &
2100	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2101	IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= &
2102	albedo_pars_f%fill ) &
2103	surf_usm_v(l)%aldir(ind_type,m) = &
2104	albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2105	IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= &
2106	albedo_pars_f%fill ) &
2107	surf_usm_v(l)%aldif(ind_type,m) = &
2108	albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2109	IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= &
2110	albedo_pars_f%fill ) &
2111	surf_usm_v(l)%asdir(ind_type,m) = &
2112	albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2113	IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= &
2114	albedo_pars_f%fill ) &
2115	surf_usm_v(l)%asdif(ind_type,m) = &
2116	albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2117	ENDIF
2118	ENDDO
2119
2120	ENDDO
2121	ENDDO
2122
2123	ENDIF
2124
2125	!
2126	!-- Calculate initial values of current (cosine of) the zenith angle and
2127	!-- whether the sun is up
2128	CALL calc_zenith
2129	!
2130	!-- Calculate initial surface albedo for different surfaces
2131	IF ( .NOT. constant_albedo ) THEN
2132	!
2133	!-- Horizontally aligned default, natural and urban surfaces
2134	CALL calc_albedo( surf_def_h(0) )
2135	CALL calc_albedo( surf_lsm_h )
2136	CALL calc_albedo( surf_usm_h )
2137	!
2138	!-- Vertically aligned default, natural and urban surfaces
2139	DO l = 0, 3
2140	CALL calc_albedo( surf_def_v(l) )
2141	CALL calc_albedo( surf_lsm_v(l) )
2142	CALL calc_albedo( surf_usm_v(l) )
2143	ENDDO
2144	ELSE
2145	!
2146	!-- Initialize sun-inclination independent spectral albedos
2147	!-- Horizontal surfaces
2148	IF ( surf_def_h(0)%ns > 0 ) THEN
2149	surf_def_h(0)%rrtm_aldir = surf_def_h(0)%aldir
2150	surf_def_h(0)%rrtm_asdir = surf_def_h(0)%asdir
2151	surf_def_h(0)%rrtm_aldif = surf_def_h(0)%aldif
2152	surf_def_h(0)%rrtm_asdif = surf_def_h(0)%asdif
2153	ENDIF
2154	IF ( surf_lsm_h%ns > 0 ) THEN
2155	surf_lsm_h%rrtm_aldir = surf_lsm_h%aldir
2156	surf_lsm_h%rrtm_asdir = surf_lsm_h%asdir
2157	surf_lsm_h%rrtm_aldif = surf_lsm_h%aldif
2158	surf_lsm_h%rrtm_asdif = surf_lsm_h%asdif
2159	ENDIF
2160	IF ( surf_usm_h%ns > 0 ) THEN
2161	surf_usm_h%rrtm_aldir = surf_usm_h%aldir
2162	surf_usm_h%rrtm_asdir = surf_usm_h%asdir
2163	surf_usm_h%rrtm_aldif = surf_usm_h%aldif
2164	surf_usm_h%rrtm_asdif = surf_usm_h%asdif
2165	ENDIF
2166	!
2167	!-- Vertical surfaces
2168	DO l = 0, 3
2169	IF ( surf_def_h(0)%ns > 0 ) THEN
2170	surf_def_v(l)%rrtm_aldir = surf_def_v(l)%aldir
2171	surf_def_v(l)%rrtm_asdir = surf_def_v(l)%asdir
2172	surf_def_v(l)%rrtm_aldif = surf_def_v(l)%aldif
2173	surf_def_v(l)%rrtm_asdif = surf_def_v(l)%asdif
2174	ENDIF
2175	IF ( surf_lsm_v(l)%ns > 0 ) THEN
2176	surf_lsm_v(l)%rrtm_aldir = surf_lsm_v(l)%aldir
2177	surf_lsm_v(l)%rrtm_asdir = surf_lsm_v(l)%asdir
2178	surf_lsm_v(l)%rrtm_aldif = surf_lsm_v(l)%aldif
2179	surf_lsm_v(l)%rrtm_asdif = surf_lsm_v(l)%asdif
2180	ENDIF
2181	IF ( surf_usm_v(l)%ns > 0 ) THEN
2182	surf_usm_v(l)%rrtm_aldir = surf_usm_v(l)%aldir
2183	surf_usm_v(l)%rrtm_asdir = surf_usm_v(l)%asdir
2184	surf_usm_v(l)%rrtm_aldif = surf_usm_v(l)%aldif
2185	surf_usm_v(l)%rrtm_asdif = surf_usm_v(l)%asdif
2186	ENDIF
2187	ENDDO
2188
2189	ENDIF
2190
2191	!
2192	!-- Allocate 3d arrays of radiative fluxes and heating rates
2193	IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN
2194	ALLOCATE ( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2195	rad_sw_in = 0.0_wp
2196	ENDIF
2197
2198	IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN
2199	ALLOCATE ( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2200	ENDIF
2201
2202	IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN
2203	ALLOCATE ( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2204	rad_sw_out = 0.0_wp
2205	ENDIF
2206
2207	IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN
2208	ALLOCATE ( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2209	ENDIF
2210
2211	IF ( .NOT. ALLOCATED ( rad_sw_hr ) ) THEN
2212	ALLOCATE ( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2213	rad_sw_hr = 0.0_wp
2214	ENDIF
2215
2216	IF ( .NOT. ALLOCATED ( rad_sw_hr_av ) ) THEN
2217	ALLOCATE ( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2218	rad_sw_hr_av = 0.0_wp
2219	ENDIF
2220
2221	IF ( .NOT. ALLOCATED ( rad_sw_cs_hr ) ) THEN
2222	ALLOCATE ( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2223	rad_sw_cs_hr = 0.0_wp
2224	ENDIF
2225
2226	IF ( .NOT. ALLOCATED ( rad_sw_cs_hr_av ) ) THEN
2227	ALLOCATE ( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2228	rad_sw_cs_hr_av = 0.0_wp
2229	ENDIF
2230
2231	IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN
2232	ALLOCATE ( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2233	rad_lw_in = 0.0_wp
2234	ENDIF
2235
2236	IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN
2237	ALLOCATE ( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2238	ENDIF
2239
2240	IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN
2241	ALLOCATE ( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2242	rad_lw_out = 0.0_wp
2243	ENDIF
2244
2245	IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN
2246	ALLOCATE ( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2247	ENDIF
2248
2249	IF ( .NOT. ALLOCATED ( rad_lw_hr ) ) THEN
2250	ALLOCATE ( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2251	rad_lw_hr = 0.0_wp
2252	ENDIF
2253
2254	IF ( .NOT. ALLOCATED ( rad_lw_hr_av ) ) THEN
2255	ALLOCATE ( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2256	rad_lw_hr_av = 0.0_wp
2257	ENDIF
2258
2259	IF ( .NOT. ALLOCATED ( rad_lw_cs_hr ) ) THEN
2260	ALLOCATE ( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2261	rad_lw_cs_hr = 0.0_wp
2262	ENDIF
2263
2264	IF ( .NOT. ALLOCATED ( rad_lw_cs_hr_av ) ) THEN
2265	ALLOCATE ( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2266	rad_lw_cs_hr_av = 0.0_wp
2267	ENDIF
2268
2269	ALLOCATE ( rad_sw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2270	ALLOCATE ( rad_sw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2271	rad_sw_cs_in = 0.0_wp
2272	rad_sw_cs_out = 0.0_wp
2273
2274	ALLOCATE ( rad_lw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2275	ALLOCATE ( rad_lw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2276	rad_lw_cs_in = 0.0_wp
2277	rad_lw_cs_out = 0.0_wp
2278
2279	!
2280	!-- Allocate 1-element array for surface temperature
2281	!-- (RRTMG anticipates an array as passed argument).
2282	ALLOCATE ( rrtm_tsfc(1) )
2283	!
2284	!-- Allocate surface emissivity.
2285	!-- Values will be given directly before calling rrtm_lw.
2286	ALLOCATE ( rrtm_emis(0:0,1:nbndlw+1) )
2287
2288	!
2289	!-- Initialize RRTMG
2290	IF ( lw_radiation ) CALL rrtmg_lw_ini ( cp )
2291	IF ( sw_radiation ) CALL rrtmg_sw_ini ( cp )
2292
2293	!
2294	!-- Set input files for RRTMG
2295	INQUIRE(FILE="RAD_SND_DATA", EXIST=snd_exists)
2296	IF ( .NOT. snd_exists ) THEN
2297	rrtm_input_file = "rrtmg_lw.nc"
2298	ENDIF
2299
2300	!
2301	!-- Read vertical layers for RRTMG from sounding data
2302	!-- The routine provides nzt_rad, hyp_snd(1:nzt_rad),
2303	!-- t_snd(nzt+2:nzt_rad), rrtm_play(1:nzt_rad), rrtm_plev(1_nzt_rad+1),
2304	!-- rrtm_tlay(nzt+2:nzt_rad), rrtm_tlev(nzt+2:nzt_rad+1)
2305	CALL read_sounding_data
2306
2307	!
2308	!-- Read trace gas profiles from file. This routine provides
2309	!-- the rrtm_ arrays (1:nzt_rad+1)
2310	CALL read_trace_gas_data
2311	#endif
2312	ENDIF
2313
2314	!
2315	!-- Perform user actions if required
2316	CALL user_init_radiation
2317
2318	!
2319	!-- Calculate radiative fluxes at model start
2320	IF ( TRIM( initializing_actions ) /= 'read_restart_data' ) THEN
2321
2322	SELECT CASE ( radiation_scheme )
2323	CASE ( 'rrtmg' )
2324	CALL radiation_rrtmg
2325	CASE ( 'clear-sky' )
2326	CALL radiation_clearsky
2327	CASE ( 'constant' )
2328	CALL radiation_constant
2329	CASE DEFAULT
2330	END SELECT
2331
2332	ENDIF
2333
2334	RETURN
2335
2336	END SUBROUTINE radiation_init
2337
2338
2339	!------------------------------------------------------------------------------!
2340	! Description:
2341	! ------------
2342	!> A simple clear sky radiation model
2343	!------------------------------------------------------------------------------!
2344	SUBROUTINE radiation_clearsky
2345
2346
2347	IMPLICIT NONE
2348
2349	INTEGER(iwp) :: l !< running index for surface orientation
2350
2351	REAL(wp) :: exn !< Exner functions at surface
2352	REAL(wp) :: exn1 !< Exner functions at first grid level or at urban layer top
2353	REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top
2354	REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain
2355	REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top
2356	REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain
2357
2358	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
2359
2360	!
2361	!-- Calculate current zenith angle
2362	CALL calc_zenith
2363
2364	!
2365	!-- Calculate sky transmissivity
2366	sky_trans = 0.6_wp + 0.2_wp * zenith(0)
2367	!
2368	!-- Calculate value of the Exner function at model surface
2369	exn = (surface_pressure / 1000.0_wp )**0.286_wp
2370	!
2371	!-- In case averaged radiation is used, calculate mean temperature and
2372	!-- liquid water mixing ratio at the urban-layer top.
2373	IF ( average_radiation ) THEN
2374	pt1 = 0.0_wp
2375	IF ( cloud_physics ) ql1 = 0.0_wp
2376
2377	pt1_l = SUM( pt(nzut,nys:nyn,nxl:nxr) )
2378	IF ( cloud_physics ) ql1_l = SUM( ql(nzut,nys:nyn,nxl:nxr) )
2379
2380	#if defined( __parallel )
2381	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
2382	CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
2383	IF ( cloud_physics ) &
2384	CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
2385	#else
2386	pt1 = pt1_l
2387	IF ( cloud_physics ) ql1 = ql1_l
2388	#endif
2389
2390	exn1 = ( hyp(nzut) / 100000.0_wp )**0.286_wp
2391	IF ( cloud_physics ) pt1 = pt1 + l_d_cp / exn1 * ql1
2392	!
2393	!-- Finally, divide by number of grid points
2394	pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp )
2395	ENDIF
2396	!
2397	!-- Call clear-sky calculation for each surface orientation.
2398	!-- First, horizontal surfaces
2399	surf => surf_def_h(0)
2400	CALL radiation_clearsky_surf
2401	surf => surf_lsm_h
2402	CALL radiation_clearsky_surf
2403	surf => surf_usm_h
2404	CALL radiation_clearsky_surf
2405	!
2406	!-- Vertical surfaces
2407	DO l = 0, 3
2408	surf => surf_def_v(l)
2409	CALL radiation_clearsky_surf
2410	surf => surf_lsm_v(l)
2411	CALL radiation_clearsky_surf
2412	surf => surf_usm_v(l)
2413	CALL radiation_clearsky_surf
2414	ENDDO
2415
2416	CONTAINS
2417
2418	SUBROUTINE radiation_clearsky_surf
2419
2420	IMPLICIT NONE
2421
2422	INTEGER(iwp) :: i !< index x-direction
2423	INTEGER(iwp) :: j !< index y-direction
2424	INTEGER(iwp) :: k !< index z-direction
2425	INTEGER(iwp) :: m !< running index for surface elements
2426
2427	IF ( surf%ns < 1 ) RETURN
2428
2429	!
2430	!-- Calculate radiation fluxes and net radiation (rad_net) assuming
2431	!-- homogeneous urban radiation conditions.
2432	IF ( average_radiation ) THEN
2433
2434	k = nzut
2435
2436	exn1 = ( hyp(k+1) / 100000.0_wp )**0.286_wp
2437
2438	surf%rad_sw_in = solar_constant * sky_trans * zenith(0)
2439	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
2440
2441	surf%rad_lw_in = 0.8_wp * sigma_sb * (pt1 * exn1)**4
2442
2443	surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 &
2444	+ (1.0_wp - emissivity_urb) * surf%rad_lw_in
2445
2446	surf%rad_net = surf%rad_sw_in - surf%rad_sw_out &
2447	+ surf%rad_lw_in - surf%rad_lw_out
2448
2449	surf%rad_lw_out_change_0 = 3.0_wp * emissivity_urb * sigma_sb &
2450	* (t_rad_urb)**3
2451
2452	!
2453	!-- Calculate radiation fluxes and net radiation (rad_net) for each surface
2454	!-- element.
2455	ELSE
2456
2457	DO m = 1, surf%ns
2458	i = surf%i(m)
2459	j = surf%j(m)
2460	k = surf%k(m)
2461
2462	exn1 = (hyp(k) / 100000.0_wp )**0.286_wp
2463
2464	surf%rad_sw_in(m) = solar_constant * sky_trans * zenith(0)
2465	!
2466	!-- Weighted average according to surface fraction.
2467	!-- In case no surface fraction is given ( default-type )
2468	!-- no weighted averaging is performed ( only one surface type per
2469	!-- surface element ).
2470	!-- ATTENTION: when radiation interactions are switched on the
2471	!-- calculated fluxes below are not actually used as they are
2472	!-- overwritten in radiation_interaction.
2473	IF ( ALLOCATED( surf%frac ) ) THEN
2474
2475	surf%rad_sw_out(m) = ( surf%frac(0,m) * surf%albedo(0,m) &
2476	+ surf%frac(1,m) * surf%albedo(1,m) &
2477	+ surf%frac(2,m) * surf%albedo(2,m) ) &
2478	* surf%rad_sw_in(m)
2479
2480	surf%rad_lw_out(m) = ( surf%frac(0,m) * surf%emissivity(0,m)&
2481	+ surf%frac(1,m) * surf%emissivity(1,m)&
2482	+ surf%frac(2,m) * surf%emissivity(2,m)&
2483	) &
2484	* sigma_sb &
2485	* ( surf%pt_surface(m) * exn )**4
2486
2487	surf%rad_lw_out_change_0(m) = &
2488	( surf%frac(0,m) * surf%emissivity(0,m) &
2489	+ surf%frac(1,m) * surf%emissivity(1,m) &
2490	+ surf%frac(2,m) * surf%emissivity(2,m) &
2491	) * 3.0_wp * sigma_sb &
2492	* ( surf%pt_surface(m) * exn )** 3
2493
2494	ELSE
2495
2496	surf%rad_sw_out(m) = surf%albedo(0,m) * surf%rad_sw_in(m)
2497
2498	surf%rad_lw_out(m) = surf%emissivity(0,m) &
2499	* sigma_sb &
2500	* ( surf%pt_surface(m) * exn )**4
2501
2502	surf%rad_lw_out_change_0(m) = surf%emissivity(0,m) &
2503	* 3.0_wp * sigma_sb &
2504	* ( surf%pt_surface(m) * exn )** 3
2505
2506	ENDIF
2507
2508	IF ( cloud_physics ) THEN
2509	pt1 = pt(k,j,i) + l_d_cp / exn1 * ql(k,j,i)
2510	surf%rad_lw_in(m) = 0.8_wp * sigma_sb * (pt1 * exn1)**4
2511	ELSE
2512	surf%rad_lw_in(m) = 0.8_wp * sigma_sb * (pt(k,j,i) * exn1)**4
2513	ENDIF
2514
2515	surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) &
2516	+ surf%rad_lw_in(m) - surf%rad_lw_out(m)
2517
2518	ENDDO
2519
2520	ENDIF
2521
2522	END SUBROUTINE radiation_clearsky_surf
2523
2524	END SUBROUTINE radiation_clearsky
2525
2526
2527	!------------------------------------------------------------------------------!
2528	! Description:
2529	! ------------
2530	!> This scheme keeps the prescribed net radiation constant during the run
2531	!------------------------------------------------------------------------------!
2532	SUBROUTINE radiation_constant
2533
2534
2535	IMPLICIT NONE
2536
2537	INTEGER(iwp) :: l !< running index for surface orientation
2538
2539	REAL(wp) :: exn !< Exner functions at surface
2540	REAL(wp) :: exn1 !< Exner functions at first grid level
2541	REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top
2542	REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain
2543	REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top
2544	REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain
2545
2546	TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine
2547
2548	!
2549	!-- Calculate value of the Exner function
2550	exn = (surface_pressure / 1000.0_wp )**0.286_wp
2551	!
2552	!-- In case averaged radiation is used, calculate mean temperature and
2553	!-- liquid water mixing ratio at the urban-layer top.
2554	IF ( average_radiation ) THEN
2555	pt1 = 0.0_wp
2556	IF ( cloud_physics ) ql1 = 0.0_wp
2557
2558	pt1_l = SUM( pt(nzut,nys:nyn,nxl:nxr) )
2559	IF ( cloud_physics ) ql1_l = SUM( ql(nzut,nys:nyn,nxl:nxr) )
2560
2561	#if defined( __parallel )
2562	IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr )
2563	CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
2564	IF ( cloud_physics ) &
2565	CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
2566	#else
2567	pt1 = pt1_l
2568	IF ( cloud_physics ) ql1 = ql1_l
2569	#endif
2570	IF ( cloud_physics ) pt1 = pt1 + l_d_cp / exn1 * ql1
2571	!
2572	!-- Finally, divide by number of grid points
2573	pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp )
2574	ENDIF
2575
2576	!
2577	!-- First, horizontal surfaces
2578	surf => surf_def_h(0)
2579	CALL radiation_constant_surf
2580	surf => surf_lsm_h
2581	CALL radiation_constant_surf
2582	surf => surf_usm_h
2583	CALL radiation_constant_surf
2584	!
2585	!-- Vertical surfaces
2586	DO l = 0, 3
2587	surf => surf_def_v(l)
2588	CALL radiation_constant_surf
2589	surf => surf_lsm_v(l)
2590	CALL radiation_constant_surf
2591	surf => surf_usm_v(l)
2592	CALL radiation_constant_surf
2593	ENDDO
2594
2595	CONTAINS
2596
2597	SUBROUTINE radiation_constant_surf
2598
2599	IMPLICIT NONE
2600
2601	INTEGER(iwp) :: i !< index x-direction
2602	INTEGER(iwp) :: ioff !< offset between surface element and adjacent grid point along x
2603	INTEGER(iwp) :: j !< index y-direction
2604	INTEGER(iwp) :: joff !< offset between surface element and adjacent grid point along y
2605	INTEGER(iwp) :: k !< index z-direction
2606	INTEGER(iwp) :: koff !< offset between surface element and adjacent grid point along z
2607	INTEGER(iwp) :: m !< running index for surface elements
2608
2609	IF ( surf%ns < 1 ) RETURN
2610
2611	!-- Calculate homogenoeus urban radiation fluxes
2612	IF ( average_radiation ) THEN
2613
2614	! set height above canopy
2615	k = nzut
2616
2617	surf%rad_net = net_radiation
2618	! MS: Wyh k + 1 ?
2619	exn1 = (hyp(k+1) / 100000.0_wp )**0.286_wp
2620
2621	surf%rad_lw_in = 0.8_wp * sigma_sb * (pt1 * exn1)**4
2622
2623	surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 &
2624	+ ( 10.0_wp - emissivity_urb ) & ! shouldn't be this a bulk value -- emissivity_urb?
2625	* surf%rad_lw_in
2626
2627	surf%rad_lw_out_change_0 = 3.0_wp * emissivity_urb * sigma_sb &
2628	* t_rad_urb**3
2629
2630	surf%rad_sw_in = ( surf%rad_net - surf%rad_lw_in &
2631	+ surf%rad_lw_out ) &
2632	/ ( 1.0_wp - albedo_urb )
2633
2634	surf%rad_sw_out = albedo_urb * surf%rad_sw_in
2635
2636	!
2637	!-- Calculate radiation fluxes for each surface element
2638	ELSE
2639	!
2640	!-- Determine index offset between surface element and adjacent
2641	!-- atmospheric grid point
2642	ioff = surf%ioff
2643	joff = surf%joff
2644	koff = surf%koff
2645
2646	!
2647	!-- Prescribe net radiation and estimate the remaining radiative fluxes
2648	DO m = 1, surf%ns
2649	i = surf%i(m)
2650	j = surf%j(m)
2651	k = surf%k(m)
2652
2653	surf%rad_net(m) = net_radiation
2654
2655	exn1 = (hyp(k) / 100000.0_wp )**0.286_wp
2656
2657	IF ( cloud_physics ) THEN
2658	pt1 = pt(k,j,i) + l_d_cp / exn1 * ql(k,j,i)
2659	surf%rad_lw_in(m) = 0.8_wp * sigma_sb * (pt1 * exn1)**4
2660	ELSE
2661	surf%rad_lw_in(m) = 0.8_wp * sigma_sb * &
2662	( pt(k,j,i) * exn1 )**4
2663	ENDIF
2664
2665	!
2666	!-- Weighted average according to surface fraction.
2667	!-- In case no surface fraction is given ( default-type )
2668	!-- no weighted averaging is performed ( only one surface type per
2669	!-- surface element ).
2670	IF ( ALLOCATED( surf%frac ) ) THEN
2671
2672	surf%rad_lw_out(m) = ( surf%frac(0,m) * surf%emissivity(0,m)&
2673	+ surf%frac(1,m) * surf%emissivity(1,m)&
2674	+ surf%frac(2,m) * surf%emissivity(2,m)&
2675	) &
2676	* sigma_sb &
2677	* ( surf%pt_surface(m) * exn )**4
2678
2679	surf%rad_sw_in(m) = ( surf%rad_net(m) - surf%rad_lw_in(m) &
2680	+ surf%rad_lw_out(m) ) &
2681	/ ( 1.0_wp - &
2682	( surf%frac(0,m) * surf%albedo(0,m) +&
2683	surf%frac(1,m) * surf%albedo(1,m) +&
2684	surf%frac(1,m) * surf%albedo(1,m) )&
2685	)
2686
2687	surf%rad_sw_out(m) = ( surf%frac(0,m) * surf%albedo(0,m) &
2688	+ surf%frac(1,m) * surf%albedo(1,m) &
2689	+ surf%frac(2,m) * surf%albedo(2,m) ) &
2690	* surf%rad_sw_in(m)
2691
2692	ELSE
2693	surf%rad_lw_out(m) = surf%emissivity(0,m) &
2694	* sigma_sb &
2695	* ( surf%pt_surface(m) * exn )**4
2696
2697	surf%rad_sw_in(m) = ( surf%rad_net(m) - surf%rad_lw_in(m) &
2698	+ surf%rad_lw_out(m) ) &
2699	/ ( 1.0_wp - &
2700	( surf%frac(0,m) * surf%albedo(0,m) )&
2701	)
2702
2703	surf%rad_sw_out(m) = ( surf%frac(0,m) * surf%albedo(0,m) ) &
2704	* surf%rad_sw_in(m)
2705	ENDIF
2706
2707	ENDDO
2708
2709	ENDIF
2710
2711	END SUBROUTINE radiation_constant_surf
2712
2713
2714	END SUBROUTINE radiation_constant
2715
2716	!------------------------------------------------------------------------------!
2717	! Description:
2718	! ------------
2719	!> Header output for radiation model
2720	!------------------------------------------------------------------------------!
2721	SUBROUTINE radiation_header ( io )
2722
2723
2724	IMPLICIT NONE
2725
2726	INTEGER(iwp), INTENT(IN) :: io !< Unit of the output file
2727
2728
2729
2730	!
2731	!-- Write radiation model header
2732	WRITE( io, 3 )
2733
2734	IF ( radiation_scheme == "constant" ) THEN
2735	WRITE( io, 4 ) net_radiation
2736	ELSEIF ( radiation_scheme == "clear-sky" ) THEN
2737	WRITE( io, 5 )
2738	ELSEIF ( radiation_scheme == "rrtmg" ) THEN
2739	WRITE( io, 6 )
2740	IF ( .NOT. lw_radiation ) WRITE( io, 10 )
2741	IF ( .NOT. sw_radiation ) WRITE( io, 11 )
2742	ENDIF
2743
2744	IF ( albedo_type_f%from_file .OR. vegetation_type_f%from_file .OR. &
2745	pavement_type_f%from_file .OR. water_type_f%from_file .OR. &
2746	building_type_f%from_file ) THEN
2747	WRITE( io, 13 )
2748	ELSE
2749	IF ( albedo_type == 0 ) THEN
2750	WRITE( io, 7 ) albedo
2751	ELSE
2752	WRITE( io, 8 ) TRIM( albedo_type_name(albedo_type) )
2753	ENDIF
2754	ENDIF
2755	IF ( constant_albedo ) THEN
2756	WRITE( io, 9 )
2757	ENDIF
2758
2759	WRITE( io, 12 ) dt_radiation
2760
2761
2762	3 FORMAT (//' Radiation model information:'/ &
2763	' ----------------------------'/)
2764	4 FORMAT (' --> Using constant net radiation: net_radiation = ', F6.2, &
2765	// 'W/m**2')
2766	5 FORMAT (' --> Simple radiation scheme for clear sky is used (no clouds,',&
2767	' default)')
2768	6 FORMAT (' --> RRTMG scheme is used')
2769	7 FORMAT (/' User-specific surface albedo: albedo =', F6.3)
2770	8 FORMAT (/' Albedo is set for land surface type: ', A)
2771	9 FORMAT (/' --> Albedo is fixed during the run')
2772	10 FORMAT (/' --> Longwave radiation is disabled')
2773	11 FORMAT (/' --> Shortwave radiation is disabled.')
2774	12 FORMAT (' Timestep: dt_radiation = ', F6.2, ' s')
2775	13 FORMAT (/' Albedo is set individually for each xy-location, according ' &
2776	'to given surface type.')
2777
2778
2779	END SUBROUTINE radiation_header
2780
2781
2782	!------------------------------------------------------------------------------!
2783	! Description:
2784	! ------------
2785	!> Parin for &radiation_par for radiation model
2786	!------------------------------------------------------------------------------!
2787	SUBROUTINE radiation_parin
2788
2789
2790	IMPLICIT NONE
2791
2792	CHARACTER (LEN=80) :: line !< dummy string that contains the current line of the parameter file
2793
2794	NAMELIST /radiation_par/ albedo, albedo_type, albedo_lw_dir, &
2795	albedo_lw_dif, albedo_sw_dir, albedo_sw_dif, &
2796	constant_albedo, dt_radiation, emissivity, &
2797	lw_radiation, net_radiation, &
2798	radiation_scheme, skip_time_do_radiation, &
2799	sw_radiation, unscheduled_radiation_calls, &
2800	split_diffusion_radiation, &
2801	energy_balance_surf_h, &
2802	energy_balance_surf_v, &
2803	read_svf_on_init, &
2804	nrefsteps, &
2805	write_svf_on_init, &
2806	mrt_factors, &
2807	dist_max_svf, &
2808	average_radiation, &
2809	radiation_interactions, atm_surfaces, &
2810	surf_reflections
2811
2812	line = ' '
2813
2814	!
2815	!-- Try to find radiation model package
2816	REWIND ( 11 )
2817	line = ' '
2818	DO WHILE ( INDEX( line, '&radiation_par' ) == 0 )
2819	READ ( 11, '(A)', END=10 ) line
2820	ENDDO
2821	BACKSPACE ( 11 )
2822
2823	!
2824	!-- Read user-defined namelist
2825	READ ( 11, radiation_par )
2826
2827	!
2828	!-- Set flag that indicates that the radiation model is switched on
2829	radiation = .TRUE.
2830
2831	10 CONTINUE
2832
2833
2834	END SUBROUTINE radiation_parin
2835
2836
2837	!------------------------------------------------------------------------------!
2838	! Description:
2839	! ------------
2840	!> Implementation of the RRTMG radiation_scheme
2841	!------------------------------------------------------------------------------!
2842	SUBROUTINE radiation_rrtmg
2843
2844	USE indices, &
2845	ONLY: nbgp
2846
2847	USE particle_attributes, &
2848	ONLY: grid_particles, number_of_particles, particles, &
2849	particle_advection_start, prt_count
2850
2851	IMPLICIT NONE
2852
2853	#if defined ( __rrtmg )
2854
2855	INTEGER(iwp) :: i, j, k, l, m, n !< loop indices
2856	INTEGER(iwp) :: k_topo !< topography top index
2857
2858	REAL(wp) :: nc_rad, & !< number concentration of cloud droplets
2859	s_r2, & !< weighted sum over all droplets with r^2
2860	s_r3 !< weighted sum over all droplets with r^3
2861
2862	REAL(wp), DIMENSION(0:nzt+1) :: pt_av, q_av, ql_av
2863	!
2864	!-- Just dummy arguments
2865	REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rrtm_lw_taucld_dum, &
2866	rrtm_lw_tauaer_dum, &
2867	rrtm_sw_taucld_dum, &
2868	rrtm_sw_ssacld_dum, &
2869	rrtm_sw_asmcld_dum, &
2870	rrtm_sw_fsfcld_dum, &
2871	rrtm_sw_tauaer_dum, &
2872	rrtm_sw_ssaaer_dum, &
2873	rrtm_sw_asmaer_dum, &
2874	rrtm_sw_ecaer_dum
2875
2876	!
2877	!-- Calculate current (cosine of) zenith angle and whether the sun is up
2878	CALL calc_zenith
2879	!
2880	!-- Calculate surface albedo. In case average radiation is applied,
2881	!-- this is not required.
2882	IF ( .NOT. constant_albedo ) THEN
2883	!
2884	!-- Horizontally aligned default, natural and urban surfaces
2885	CALL calc_albedo( surf_def_h(0) )
2886	CALL calc_albedo( surf_lsm_h )
2887	CALL calc_albedo( surf_usm_h )
2888	!
2889	!-- Vertically aligned default, natural and urban surfaces
2890	DO l = 0, 3
2891	CALL calc_albedo( surf_def_v(l) )
2892	CALL calc_albedo( surf_lsm_v(l) )
2893	CALL calc_albedo( surf_usm_v(l) )
2894	ENDDO
2895	ENDIF
2896
2897	!
2898	!-- Prepare input data for RRTMG
2899
2900	!
2901	!-- In case of large scale forcing with surface data, calculate new pressure
2902	!-- profile. nzt_rad might be modified by these calls and all required arrays
2903	!-- will then be re-allocated
2904	IF ( large_scale_forcing .AND. lsf_surf ) THEN
2905	CALL read_sounding_data
2906	CALL read_trace_gas_data
2907	ENDIF
2908
2909
2910	IF ( average_radiation ) THEN
2911
2912	rrtm_asdir(1) = albedo_urb
2913	rrtm_asdif(1) = albedo_urb
2914	rrtm_aldir(1) = albedo_urb
2915	rrtm_aldif(1) = albedo_urb
2916
2917	rrtm_emis = emissivity_urb
2918	!
2919	!-- Calculate mean pt profile. Actually, only one height level is required.
2920	CALL calc_mean_profile( pt, 4 )
2921	pt_av = hom(:, 1, 4, 0)
2922
2923	!
2924	!-- Prepare profiles of temperature and H2O volume mixing ratio
2925	rrtm_tlev(0,nzb+1) = t_rad_urb
2926
2927	IF ( cloud_physics ) THEN
2928	CALL calc_mean_profile( q, 41 )
2929	! average q is now in hom(:, 1, 41, 0)
2930	q_av = hom(:, 1, 41, 0)
2931	CALL calc_mean_profile( ql, 54 )
2932	! average ql is now in hom(:, 1, 54, 0)
2933	ql_av = hom(:, 1, 54, 0)
2934
2935	DO k = nzb+1, nzt+1
2936	rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp &
2937	)*.286_wp + l_d_cp ql_av(k)
2938	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q_av(k) - ql_av(k))
2939	ENDDO
2940	ELSE
2941	DO k = nzb+1, nzt+1
2942	rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp &
2943	)**.286_wp
2944	rrtm_h2ovmr(0,k) = 0._wp
2945	ENDDO
2946	ENDIF
2947
2948	!
2949	!-- Avoid temperature/humidity jumps at the top of the LES domain by
2950	!-- linear interpolation from nzt+2 to nzt+7
2951	DO k = nzt+2, nzt+7
2952	rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) &
2953	+ ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) &
2954	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) &
2955	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
2956
2957	rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) &
2958	+ ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )&
2959	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )&
2960	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
2961
2962	ENDDO
2963
2964	!-- Linear interpolate to zw grid
2965	DO k = nzb+2, nzt+8
2966	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - &
2967	rrtm_tlay(0,k-1)) &
2968	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
2969	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
2970	ENDDO
2971
2972
2973	!
2974	!-- Calculate liquid water path and cloud fraction for each column.
2975	!-- Note that LWP is required in g/mÂ² instead of kg/kg m.
2976	rrtm_cldfr = 0.0_wp
2977	rrtm_reliq = 0.0_wp
2978	rrtm_cliqwp = 0.0_wp
2979	rrtm_icld = 0
2980
2981	IF ( cloud_physics ) THEN
2982	DO k = nzb+1, nzt+1
2983	rrtm_cliqwp(0,k) = ql_av(k) * 1000._wp * &
2984	(rrtm_plev(0,k) - rrtm_plev(0,k+1)) &
2985	* 100._wp / g
2986
2987	IF ( rrtm_cliqwp(0,k) > 0._wp ) THEN
2988	rrtm_cldfr(0,k) = 1._wp
2989	IF ( rrtm_icld == 0 ) rrtm_icld = 1
2990
2991	!
2992	!-- Calculate cloud droplet effective radius
2993	IF ( cloud_physics ) THEN
2994	rrtm_reliq(0,k) = 1.0E6_wp * ( 3._wp * ql_av(k) &
2995	* rho_surface &
2996	/ ( 4._wp * pi * nc_const * rho_l )&
2997	)**.33333333333333_wp &
2998	* EXP( LOG( sigma_gc )**2 )
2999
3000	ENDIF
3001
3002	!
3003	!-- Limit effective radius
3004	IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN
3005	rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp)
3006	rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp)
3007	ENDIF
3008	ENDIF
3009	ENDDO
3010	ENDIF
3011
3012	!
3013	!-- Set surface temperature
3014	rrtm_tsfc = t_rad_urb
3015
3016	IF ( lw_radiation ) THEN
3017	CALL rrtmg_lw( 1, nzt_rad , rrtm_icld , rrtm_idrv ,&
3018	rrtm_play , rrtm_plev , rrtm_tlay , rrtm_tlev ,&
3019	rrtm_tsfc , rrtm_h2ovmr , rrtm_o3vmr , rrtm_co2vmr ,&
3020	rrtm_ch4vmr , rrtm_n2ovmr , rrtm_o2vmr , rrtm_cfc11vmr ,&
3021	rrtm_cfc12vmr , rrtm_cfc22vmr, rrtm_ccl4vmr , rrtm_emis ,&
3022	rrtm_inflglw , rrtm_iceflglw, rrtm_liqflglw, rrtm_cldfr ,&
3023	rrtm_lw_taucld , rrtm_cicewp , rrtm_cliqwp , rrtm_reice ,&
3024	rrtm_reliq , rrtm_lw_tauaer, &
3025	rrtm_lwuflx , rrtm_lwdflx , rrtm_lwhr , &
3026	rrtm_lwuflxc , rrtm_lwdflxc , rrtm_lwhrc , &
3027	rrtm_lwuflx_dt , rrtm_lwuflxc_dt )
3028
3029	!
3030	!-- Save fluxes
3031	DO k = nzb, nzt+1
3032	rad_lw_in(k,:,:) = rrtm_lwdflx(0,k)
3033	rad_lw_out(k,:,:) = rrtm_lwuflx(0,k)
3034	ENDDO
3035
3036	!
3037	!-- Save heating rates (convert from K/d to K/h)
3038	DO k = nzb+1, nzt+1
3039	rad_lw_hr(k,:,:) = rrtm_lwhr(0,k) * d_hours_day
3040	rad_lw_cs_hr(k,:,:) = rrtm_lwhrc(0,k) * d_hours_day
3041	ENDDO
3042
3043	!
3044	!-- Save surface radiative fluxes and change in LW heating rate
3045	!-- onto respective surface elements
3046	!-- Horizontal surfaces
3047	IF ( surf_def_h(0)%ns > 0 ) THEN
3048	surf_def_h(0)%rad_lw_in = rrtm_lwdflx(0,nzb)
3049	surf_def_h(0)%rad_lw_out = rrtm_lwuflx(0,nzb)
3050	surf_def_h(0)%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb)
3051	ENDIF
3052	IF ( surf_lsm_h%ns > 0 ) THEN
3053	surf_lsm_h%rad_lw_in = rrtm_lwdflx(0,nzb)
3054	surf_lsm_h%rad_lw_out = rrtm_lwuflx(0,nzb)
3055	surf_lsm_h%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb)
3056	ENDIF
3057	IF ( surf_usm_h%ns > 0 ) THEN
3058	surf_usm_h%rad_lw_in = rrtm_lwdflx(0,nzb)
3059	surf_usm_h%rad_lw_out = rrtm_lwuflx(0,nzb)
3060	surf_usm_h%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb)
3061	ENDIF
3062	!
3063	!-- Vertical surfaces.
3064	DO l = 0, 3
3065	IF ( surf_def_v(l)%ns > 0 ) THEN
3066	surf_def_v(l)%rad_lw_in = rrtm_lwdflx(0,nzb)
3067	surf_def_v(l)%rad_lw_out = rrtm_lwuflx(0,nzb)
3068	surf_def_v(l)%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb)
3069	ENDIF
3070	IF ( surf_lsm_v(l)%ns > 0 ) THEN
3071	surf_lsm_v(l)%rad_lw_in = rrtm_lwdflx(0,nzb)
3072	surf_lsm_v(l)%rad_lw_out = rrtm_lwuflx(0,nzb)
3073	surf_lsm_v(l)%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb)
3074	ENDIF
3075	IF ( surf_usm_v(l)%ns > 0 ) THEN
3076	surf_usm_v(l)%rad_lw_in = rrtm_lwdflx(0,nzb)
3077	surf_usm_v(l)%rad_lw_out = rrtm_lwuflx(0,nzb)
3078	surf_usm_v(l)%rad_lw_out_change_0 = rrtm_lwuflx_dt(0,nzb)
3079	ENDIF
3080	ENDDO
3081
3082	ENDIF
3083
3084	IF ( sw_radiation .AND. sun_up ) THEN
3085	CALL rrtmg_sw( 1, nzt_rad , rrtm_icld , rrtm_iaer ,&
3086	rrtm_play , rrtm_plev , rrtm_tlay , rrtm_tlev ,&
3087	rrtm_tsfc , rrtm_h2ovmr , rrtm_o3vmr , rrtm_co2vmr ,&
3088	rrtm_ch4vmr , rrtm_n2ovmr , rrtm_o2vmr , rrtm_asdir ,&
3089	rrtm_asdif , rrtm_aldir , rrtm_aldif , zenith, &
3090	0.0_wp , day_of_year , solar_constant, rrtm_inflgsw,&
3091	rrtm_iceflgsw , rrtm_liqflgsw, rrtm_cldfr , rrtm_sw_taucld ,&
3092	rrtm_sw_ssacld , rrtm_sw_asmcld, rrtm_sw_fsfcld, rrtm_cicewp ,&
3093	rrtm_cliqwp , rrtm_reice , rrtm_reliq , rrtm_sw_tauaer ,&
3094	rrtm_sw_ssaaer , rrtm_sw_asmaer , rrtm_sw_ecaer , &
3095	rrtm_swuflx , rrtm_swdflx , rrtm_swhr , &
3096	rrtm_swuflxc , rrtm_swdflxc , rrtm_swhrc )
3097
3098	!
3099	!-- Save fluxes
3100	DO k = nzb, nzt+1
3101	rad_sw_in(k,:,:) = rrtm_swdflx(0,k)
3102	rad_sw_out(k,:,:) = rrtm_swuflx(0,k)
3103	ENDDO
3104
3105	!
3106	!-- Save heating rates (convert from K/d to K/s)
3107	DO k = nzb+1, nzt+1
3108	rad_sw_hr(k,:,:) = rrtm_swhr(0,k) * d_hours_day
3109	rad_sw_cs_hr(k,:,:) = rrtm_swhrc(0,k) * d_hours_day
3110	ENDDO
3111
3112	!
3113	!-- Save surface radiative fluxes onto respective surface elements
3114	!-- Horizontal surfaces
3115	IF ( surf_def_h(0)%ns > 0 ) THEN
3116	surf_def_h(0)%rad_lw_in = rrtm_swdflx(0,nzb)
3117	surf_def_h(0)%rad_lw_out = rrtm_swuflx(0,nzb)
3118	ENDIF
3119	IF ( surf_lsm_h%ns > 0 ) THEN
3120	surf_lsm_h%rad_sw_in = rrtm_swdflx(0,nzb)
3121	surf_lsm_h%rad_sw_out = rrtm_swuflx(0,nzb)
3122	ENDIF
3123	IF ( surf_usm_h%ns > 0 ) THEN
3124	surf_usm_h%rad_sw_in = rrtm_swdflx(0,nzb)
3125	surf_usm_h%rad_sw_out = rrtm_swuflx(0,nzb)
3126	ENDIF
3127	!
3128	!-- Vertical surfaces. Fluxes are obtain at respective vertical
3129	!-- level of the surface element
3130	DO l = 0, 3
3131	IF ( surf_def_v(l)%ns > 0 ) THEN
3132	surf_def_v(l)%rad_sw_in = rrtm_swdflx(0,nzb)
3133	surf_def_v(l)%rad_sw_out = rrtm_swuflx(0,nzb)
3134	ENDIF
3135	IF ( surf_lsm_v(l)%ns > 0 ) THEN
3136	surf_lsm_v(l)%rad_sw_in = rrtm_swdflx(0,nzb)
3137	surf_lsm_v(l)%rad_sw_out = rrtm_swuflx(0,nzb)
3138	ENDIF
3139	IF ( surf_usm_v(l)%ns > 0 ) THEN
3140	surf_usm_v(l)%rad_sw_in = rrtm_swdflx(0,nzb)
3141	surf_usm_v(l)%rad_sw_out = rrtm_swuflx(0,nzb)
3142	ENDIF
3143	ENDDO
3144
3145	ENDIF
3146	!
3147	!-- RRTMG is called for each (j,i) grid point separately, starting at the
3148	!-- highest topography level
3149	ELSE
3150	!
3151	!-- Loop over all grid points
3152	DO i = nxl, nxr
3153	DO j = nys, nyn
3154
3155	!
3156	!-- Prepare profiles of temperature and H2O volume mixing ratio
3157	rrtm_tlev(0,nzb+1) = pt(nzb,j,i) * ( surface_pressure &
3158	/ 1000.0_wp )**0.286_wp
3159
3160
3161	IF ( cloud_physics ) THEN
3162	DO k = nzb+1, nzt+1
3163	rrtm_tlay(0,k) = pt(k,j,i) * ( (hyp(k) ) / 100000.0_wp &
3164	)*0.286_wp + l_d_cp ql(k,j,i)
3165	rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q(k,j,i) - ql(k,j,i))
3166	ENDDO
3167	ELSE
3168	DO k = nzb+1, nzt+1
3169	rrtm_tlay(0,k) = pt(k,j,i) * ( (hyp(k) ) / 100000.0_wp &
3170	)**0.286_wp
3171	rrtm_h2ovmr(0,k) = 0.0_wp
3172	ENDDO
3173	ENDIF
3174
3175	!
3176	!-- Avoid temperature/humidity jumps at the top of the LES domain by
3177	!-- linear interpolation from nzt+2 to nzt+7
3178	DO k = nzt+2, nzt+7
3179	rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) &
3180	+ ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) &
3181	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) &
3182	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
3183
3184	rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) &
3185	+ ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )&
3186	/ ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )&
3187	* ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
3188
3189	ENDDO
3190
3191	!-- Linear interpolate to zw grid
3192	DO k = nzb+2, nzt+8
3193	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - &
3194	rrtm_tlay(0,k-1)) &
3195	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
3196	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
3197	ENDDO
3198
3199
3200	!
3201	!-- Calculate liquid water path and cloud fraction for each column.
3202	!-- Note that LWP is required in g/mÂ² instead of kg/kg m.
3203	rrtm_cldfr = 0.0_wp
3204	rrtm_reliq = 0.0_wp
3205	rrtm_cliqwp = 0.0_wp
3206	rrtm_icld = 0
3207
3208	IF ( cloud_physics .OR. cloud_droplets ) THEN
3209	DO k = nzb+1, nzt+1
3210	rrtm_cliqwp(0,k) = ql(k,j,i) * 1000.0_wp * &
3211	(rrtm_plev(0,k) - rrtm_plev(0,k+1)) &
3212	* 100.0_wp / g
3213
3214	IF ( rrtm_cliqwp(0,k) > 0.0_wp ) THEN
3215	rrtm_cldfr(0,k) = 1.0_wp
3216	IF ( rrtm_icld == 0 ) rrtm_icld = 1
3217
3218	!
3219	!-- Calculate cloud droplet effective radius
3220	IF ( cloud_physics ) THEN
3221	!
3222	!-- Calculete effective droplet radius. In case of using
3223	!-- cloud_scheme = 'morrison' and a non reasonable number
3224	!-- of cloud droplets the inital aerosol number
3225	!-- concentration is considered.
3226	IF ( microphysics_morrison ) THEN
3227	IF ( nc(k,j,i) > 1.0E-20_wp ) THEN
3228	nc_rad = nc(k,j,i)
3229	ELSE
3230	nc_rad = na_init
3231	ENDIF
3232	ELSE
3233	nc_rad = nc_const
3234	ENDIF
3235
3236	rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql(k,j,i) &
3237	* rho_surface &
3238	/ ( 4.0_wp * pi * nc_rad * rho_l ) &
3239	)**0.33333333333333_wp &
3240	* EXP( LOG( sigma_gc )**2 )
3241
3242	ELSEIF ( cloud_droplets ) THEN
3243	number_of_particles = prt_count(k,j,i)
3244
3245	IF (number_of_particles <= 0) CYCLE
3246	particles => grid_particles(k,j,i)%particles(1:number_of_particles)
3247	s_r2 = 0.0_wp
3248	s_r3 = 0.0_wp
3249
3250	DO n = 1, number_of_particles
3251	IF ( particles(n)%particle_mask ) THEN
3252	s_r2 = s_r2 + particles(n)%radius*2 &
3253	particles(n)%weight_factor
3254	s_r3 = s_r3 + particles(n)%radius*3 &
3255	particles(n)%weight_factor
3256	ENDIF
3257	ENDDO
3258
3259	IF ( s_r2 > 0.0_wp ) rrtm_reliq(0,k) = s_r3 / s_r2
3260
3261	ENDIF
3262
3263	!
3264	!-- Limit effective radius
3265	IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN
3266	rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp)
3267	rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp)
3268	ENDIF
3269	ENDIF
3270	ENDDO
3271	ENDIF
3272
3273	!
3274	!-- Write surface emissivity and surface temperature at current
3275	!-- surface element on RRTMG-shaped array.
3276	!-- Please note, as RRTMG is a single column model, surface attributes
3277	!-- are only obtained from horizontally aligned surfaces (for
3278	!-- simplicity). Taking surface attributes from horizontal and
3279	!-- vertical walls would lead to multiple solutions.
3280	!-- Moreover, for natural- and urban-type surfaces, several surface
3281	!-- classes can exist at a surface element next to each other.
3282	!-- To obtain bulk parameters, apply a weighted average for these
3283	!-- surfaces.
3284	DO m = surf_def_h(0)%start_index(j,i), surf_def_h(0)%end_index(j,i)
3285	rrtm_emis = surf_def_h(0)%emissivity(0,m)
3286	rrtm_tsfc = pt(surf_def_h(0)%k(m)+surf_def_h(0)%koff,j,i) * &
3287	(surface_pressure / 1000.0_wp )**0.286_wp
3288	ENDDO
3289	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
3290	rrtm_emis = surf_lsm_h%frac(0,m) * surf_lsm_h%emissivity(0,m) +&
3291	surf_lsm_h%frac(1,m) * surf_lsm_h%emissivity(1,m) +&
3292	surf_lsm_h%frac(2,m) * surf_lsm_h%emissivity(2,m)
3293	rrtm_tsfc = pt(surf_lsm_h%k(m)+surf_lsm_h%koff,j,i) * &
3294	(surface_pressure / 1000.0_wp )**0.286_wp
3295	ENDDO
3296	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
3297	rrtm_emis = surf_usm_h%frac(0,m) * surf_usm_h%emissivity(0,m) +&
3298	surf_usm_h%frac(1,m) * surf_usm_h%emissivity(1,m) +&
3299	surf_usm_h%frac(2,m) * surf_usm_h%emissivity(2,m)
3300	rrtm_tsfc = pt(surf_usm_h%k(m)+surf_usm_h%koff,j,i) * &
3301	(surface_pressure / 1000.0_wp )**0.286_wp
3302	ENDDO
3303	!
3304	!-- Obtain topography top index (lower bound of RRTMG)
3305	k_topo = get_topography_top_index_ji( j, i, 's' )
3306
3307	IF ( lw_radiation ) THEN
3308	!
3309	!-- Due to technical reasons, copy optical depth to dummy arguments
3310	!-- which are allocated on the exact size as the rrtmg_lw is called.
3311	!-- As one dimesion is allocated with zero size, compiler complains
3312	!-- that rank of the array does not match that of the
3313	!-- assumed-shaped arguments in the RRTMG library. In order to
3314	!-- avoid this, write to dummy arguments and give pass the entire
3315	!-- dummy array. Seems to be the only existing work-around.
3316	ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) )
3317	ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) )
3318
3319	rrtm_lw_taucld_dum = &
3320	rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1)
3321	rrtm_lw_tauaer_dum = &
3322	rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1)
3323
3324	CALL rrtmg_lw( 1, &
3325	nzt_rad-k_topo, &
3326	rrtm_icld, &
3327	rrtm_idrv, &
3328	rrtm_play(:,k_topo+1:nzt_rad+1), &
3329	rrtm_plev(:,k_topo+1:nzt_rad+2), &
3330	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
3331	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
3332	rrtm_tsfc, &
3333	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
3334	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
3335	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
3336	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
3337	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
3338	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
3339	rrtm_cfc11vmr(:,k_topo+1:nzt_rad+1), &
3340	rrtm_cfc12vmr(:,k_topo+1:nzt_rad+1), &
3341	rrtm_cfc22vmr(:,k_topo+1:nzt_rad+1), &
3342	rrtm_ccl4vmr(:,k_topo+1:nzt_rad+1), &
3343	rrtm_emis, &
3344	rrtm_inflglw, &
3345	rrtm_iceflglw, &
3346	rrtm_liqflglw, &
3347	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
3348	rrtm_lw_taucld_dum, &
3349	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
3350	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
3351	rrtm_reice(:,k_topo+1:nzt_rad+1), &
3352	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
3353	rrtm_lw_tauaer_dum, &
3354	rrtm_lwuflx(:,k_topo:nzt_rad+1), &
3355	rrtm_lwdflx(:,k_topo:nzt_rad+1), &
3356	rrtm_lwhr(:,k_topo+1:nzt_rad+1), &
3357	rrtm_lwuflxc(:,k_topo:nzt_rad+1), &
3358	rrtm_lwdflxc(:,k_topo:nzt_rad+1), &
3359	rrtm_lwhrc(:,k_topo+1:nzt_rad+1), &
3360	rrtm_lwuflx_dt(:,k_topo:nzt_rad+1), &
3361	rrtm_lwuflxc_dt(:,k_topo:nzt_rad+1) )
3362
3363	DEALLOCATE ( rrtm_lw_taucld_dum )
3364	DEALLOCATE ( rrtm_lw_tauaer_dum )
3365	!
3366	!-- Save fluxes
3367	DO k = k_topo, nzt+1
3368	rad_lw_in(k,j,i) = rrtm_lwdflx(0,k)
3369	rad_lw_out(k,j,i) = rrtm_lwuflx(0,k)
3370	ENDDO
3371
3372	!
3373	!-- Save heating rates (convert from K/d to K/h)
3374	DO k = k_topo+1, nzt+1
3375	rad_lw_hr(k,j,i) = rrtm_lwhr(0,k) * d_hours_day
3376	rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k) * d_hours_day
3377	ENDDO
3378
3379	!
3380	!-- Save surface radiative fluxes and change in LW heating rate
3381	!-- onto respective surface elements
3382	!-- Horizontal surfaces
3383	DO m = surf_def_h(0)%start_index(j,i), &
3384	surf_def_h(0)%end_index(j,i)
3385	surf_def_h(0)%rad_lw_in(m) = rrtm_lwdflx(0,k_topo)
3386	surf_def_h(0)%rad_lw_out(m) = rrtm_lwuflx(0,k_topo)
3387	surf_def_h(0)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo)
3388	ENDDO
3389	DO m = surf_lsm_h%start_index(j,i), &
3390	surf_lsm_h%end_index(j,i)
3391	surf_lsm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo)
3392	surf_lsm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo)
3393	surf_lsm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo)
3394	ENDDO
3395	DO m = surf_usm_h%start_index(j,i), &
3396	surf_usm_h%end_index(j,i)
3397	surf_usm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo)
3398	surf_usm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo)
3399	surf_usm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo)
3400	ENDDO
3401	!
3402	!-- Vertical surfaces. Fluxes are obtain at vertical level of the
3403	!-- respective surface element
3404	DO l = 0, 3
3405	DO m = surf_def_v(l)%start_index(j,i), &
3406	surf_def_v(l)%end_index(j,i)
3407	k = surf_def_v(l)%k(m)
3408	surf_def_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k)
3409	surf_def_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k)
3410	surf_def_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
3411	ENDDO
3412	DO m = surf_lsm_v(l)%start_index(j,i), &
3413	surf_lsm_v(l)%end_index(j,i)
3414	k = surf_lsm_v(l)%k(m)
3415	surf_lsm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k)
3416	surf_lsm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k)
3417	surf_lsm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
3418	ENDDO
3419	DO m = surf_usm_v(l)%start_index(j,i), &
3420	surf_usm_v(l)%end_index(j,i)
3421	k = surf_usm_v(l)%k(m)
3422	surf_usm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k)
3423	surf_usm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k)
3424	surf_usm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
3425	ENDDO
3426	ENDDO
3427
3428	ENDIF
3429
3430	IF ( sw_radiation .AND. sun_up ) THEN
3431	!
3432	!-- Get albedo for direct/diffusive long/shortwave radiation at
3433	!-- current (y,x)-location from surface variables.
3434	!-- Only obtain it from horizontal surfaces, as RRTMG is a single
3435	!-- column model
3436	!-- (Please note, only one loop will entered, controlled by
3437	!-- start-end index.)
3438	DO m = surf_def_h(0)%start_index(j,i), &
3439	surf_def_h(0)%end_index(j,i)
3440	rrtm_asdir(1) = surf_def_h(0)%rrtm_asdir(0,m)
3441	rrtm_asdif(1) = surf_def_h(0)%rrtm_asdif(0,m)
3442	rrtm_aldir(1) = surf_def_h(0)%rrtm_aldir(0,m)
3443	rrtm_aldif(1) = surf_def_h(0)%rrtm_aldif(0,m)
3444	ENDDO
3445	DO m = surf_lsm_h%start_index(j,i), &
3446	surf_lsm_h%end_index(j,i)
3447	rrtm_asdir(1) = SUM( surf_lsm_h%frac(:,m) * &
3448	surf_lsm_h%rrtm_asdir(:,m) )
3449	rrtm_asdif(1) = SUM( surf_lsm_h%frac(:,m) * &
3450	surf_lsm_h%rrtm_asdif(:,m) )
3451	rrtm_aldir(1) = SUM( surf_lsm_h%frac(:,m) * &
3452	surf_lsm_h%rrtm_aldir(:,m) )
3453	rrtm_aldif(1) = SUM( surf_lsm_h%frac(:,m) * &
3454	surf_lsm_h%rrtm_aldif(:,m) )
3455	ENDDO
3456	DO m = surf_usm_h%start_index(j,i), &
3457	surf_usm_h%end_index(j,i)
3458	rrtm_asdir(1) = SUM( surf_usm_h%frac(:,m) * &
3459	surf_usm_h%rrtm_asdir(:,m) )
3460	rrtm_asdif(1) = SUM( surf_usm_h%frac(:,m) * &
3461	surf_usm_h%rrtm_asdif(:,m) )
3462	rrtm_aldir(1) = SUM( surf_usm_h%frac(:,m) * &
3463	surf_usm_h%rrtm_aldir(:,m) )
3464	rrtm_aldif(1) = SUM( surf_usm_h%frac(:,m) * &
3465	surf_usm_h%rrtm_aldif(:,m) )
3466	ENDDO
3467	!
3468	!-- Due to technical reasons, copy optical depths and other
3469	!-- to dummy arguments which are allocated on the exact size as the
3470	!-- rrtmg_sw is called.
3471	!-- As one dimesion is allocated with zero size, compiler complains
3472	!-- that rank of the array does not match that of the
3473	!-- assumed-shaped arguments in the RRTMG library. In order to
3474	!-- avoid this, write to dummy arguments and give pass the entire
3475	!-- dummy array. Seems to be the only existing work-around.
3476	ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3477	ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3478	ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3479	ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3480	ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
3481	ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
3482	ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
3483	ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) )
3484
3485	rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3486	rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3487	rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3488	rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3489	rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
3490	rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
3491	rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
3492	rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1)
3493
3494	CALL rrtmg_sw( 1, &
3495	nzt_rad-k_topo, &
3496	rrtm_icld, &
3497	rrtm_iaer, &
3498	rrtm_play(:,k_topo+1:nzt_rad+1), &
3499	rrtm_plev(:,k_topo+1:nzt_rad+2), &
3500	rrtm_tlay(:,k_topo+1:nzt_rad+1), &
3501	rrtm_tlev(:,k_topo+1:nzt_rad+2), &
3502	rrtm_tsfc, &
3503	rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), &
3504	rrtm_o3vmr(:,k_topo+1:nzt_rad+1), &
3505	rrtm_co2vmr(:,k_topo+1:nzt_rad+1), &
3506	rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), &
3507	rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), &
3508	rrtm_o2vmr(:,k_topo+1:nzt_rad+1), &
3509	rrtm_asdir, &
3510	rrtm_asdif, &
3511	rrtm_aldir, &
3512	rrtm_aldif, &
3513	zenith, &
3514	0.0_wp, &
3515	day_of_year, &
3516	solar_constant, &
3517	rrtm_inflgsw, &
3518	rrtm_iceflgsw, &
3519	rrtm_liqflgsw, &
3520	rrtm_cldfr(:,k_topo+1:nzt_rad+1), &
3521	rrtm_sw_taucld_dum, &
3522	rrtm_sw_ssacld_dum, &
3523	rrtm_sw_asmcld_dum, &
3524	rrtm_sw_fsfcld_dum, &
3525	rrtm_cicewp(:,k_topo+1:nzt_rad+1), &
3526	rrtm_cliqwp(:,k_topo+1:nzt_rad+1), &
3527	rrtm_reice(:,k_topo+1:nzt_rad+1), &
3528	rrtm_reliq(:,k_topo+1:nzt_rad+1), &
3529	rrtm_sw_tauaer_dum, &
3530	rrtm_sw_ssaaer_dum, &
3531	rrtm_sw_asmaer_dum, &
3532	rrtm_sw_ecaer_dum, &
3533	rrtm_swuflx(:,k_topo:nzt_rad+1), &
3534	rrtm_swdflx(:,k_topo:nzt_rad+1), &
3535	rrtm_swhr(:,k_topo+1:nzt_rad+1), &
3536	rrtm_swuflxc(:,k_topo:nzt_rad+1), &
3537	rrtm_swdflxc(:,k_topo:nzt_rad+1), &
3538	rrtm_swhrc(:,k_topo+1:nzt_rad+1) )
3539
3540	DEALLOCATE( rrtm_sw_taucld_dum )
3541	DEALLOCATE( rrtm_sw_ssacld_dum )
3542	DEALLOCATE( rrtm_sw_asmcld_dum )
3543	DEALLOCATE( rrtm_sw_fsfcld_dum )
3544	DEALLOCATE( rrtm_sw_tauaer_dum )
3545	DEALLOCATE( rrtm_sw_ssaaer_dum )
3546	DEALLOCATE( rrtm_sw_asmaer_dum )
3547	DEALLOCATE( rrtm_sw_ecaer_dum )
3548	!
3549	!-- Save fluxes
3550	DO k = nzb, nzt+1
3551	rad_sw_in(k,j,i) = rrtm_swdflx(0,k)
3552	rad_sw_out(k,j,i) = rrtm_swuflx(0,k)
3553	ENDDO
3554	!
3555	!-- Save heating rates (convert from K/d to K/s)
3556	DO k = nzb+1, nzt+1
3557	rad_sw_hr(k,j,i) = rrtm_swhr(0,k) * d_hours_day
3558	rad_sw_cs_hr(k,j,i) = rrtm_swhrc(0,k) * d_hours_day
3559	ENDDO
3560
3561	!
3562	!-- Save surface radiative fluxes onto respective surface elements
3563	!-- Horizontal surfaces
3564	DO m = surf_def_h(0)%start_index(j,i), &
3565	surf_def_h(0)%end_index(j,i)
3566	surf_def_h(0)%rad_sw_in(m) = rrtm_swdflx(0,k_topo)
3567	surf_def_h(0)%rad_sw_out(m) = rrtm_swuflx(0,k_topo)
3568	ENDDO
3569	DO m = surf_lsm_h%start_index(j,i), &
3570	surf_lsm_h%end_index(j,i)
3571	surf_lsm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo)
3572	surf_lsm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo)
3573	ENDDO
3574	DO m = surf_usm_h%start_index(j,i), &
3575	surf_usm_h%end_index(j,i)
3576	surf_usm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo)
3577	surf_usm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo)
3578	ENDDO
3579	!
3580	!-- Vertical surfaces. Fluxes are obtain at respective vertical
3581	!-- level of the surface element
3582	DO l = 0, 3
3583	DO m = surf_def_v(l)%start_index(j,i), &
3584	surf_def_v(l)%end_index(j,i)
3585	k = surf_def_v(l)%k(m)
3586	surf_def_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k)
3587	surf_def_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
3588	ENDDO
3589	DO m = surf_lsm_v(l)%start_index(j,i), &
3590	surf_lsm_v(l)%end_index(j,i)
3591	k = surf_lsm_v(l)%k(m)
3592	surf_lsm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k)
3593	surf_lsm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
3594	ENDDO
3595	DO m = surf_usm_v(l)%start_index(j,i), &
3596	surf_usm_v(l)%end_index(j,i)
3597	k = surf_usm_v(l)%k(m)
3598	surf_usm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k)
3599	surf_usm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
3600	ENDDO
3601	ENDDO
3602
3603	ENDIF
3604
3605	ENDDO
3606	ENDDO
3607
3608	ENDIF
3609	!
3610	!-- Finally, calculate surface net radiation for surface elements.
3611	!-- First, for horizontal surfaces
3612	DO m = 1, surf_def_h(0)%ns
3613	surf_def_h(0)%rad_net(m) = surf_def_h(0)%rad_sw_in(m) &
3614	- surf_def_h(0)%rad_sw_out(m) &
3615	+ surf_def_h(0)%rad_lw_in(m) &
3616	- surf_def_h(0)%rad_lw_out(m)
3617	ENDDO
3618	DO m = 1, surf_lsm_h%ns
3619	surf_lsm_h%rad_net(m) = surf_lsm_h%rad_sw_in(m) &
3620	- surf_lsm_h%rad_sw_out(m) &
3621	+ surf_lsm_h%rad_lw_in(m) &
3622	- surf_lsm_h%rad_lw_out(m)
3623	ENDDO
3624	DO m = 1, surf_usm_h%ns
3625	surf_usm_h%rad_net(m) = surf_usm_h%rad_sw_in(m) &
3626	- surf_usm_h%rad_sw_out(m) &
3627	+ surf_usm_h%rad_lw_in(m) &
3628	- surf_usm_h%rad_lw_out(m)
3629	ENDDO
3630	!
3631	!-- Vertical surfaces.
3632	!-- Todo: weight with azimuth and zenith angle according to their orientation!
3633	DO l = 0, 3
3634	DO m = 1, surf_def_v(l)%ns
3635	surf_def_v(l)%rad_net(m) = surf_def_v(l)%rad_sw_in(m) &
3636	- surf_def_v(l)%rad_sw_out(m) &
3637	+ surf_def_v(l)%rad_lw_in(m) &
3638	- surf_def_v(l)%rad_lw_out(m)
3639	ENDDO
3640	DO m = 1, surf_lsm_v(l)%ns
3641	surf_lsm_v(l)%rad_net(m) = surf_lsm_v(l)%rad_sw_in(m) &
3642	- surf_lsm_v(l)%rad_sw_out(m) &
3643	+ surf_lsm_v(l)%rad_lw_in(m) &
3644	- surf_lsm_v(l)%rad_lw_out(m)
3645	ENDDO
3646	DO m = 1, surf_usm_v(l)%ns
3647	surf_usm_v(l)%rad_net(m) = surf_usm_v(l)%rad_sw_in(m) &
3648	- surf_usm_v(l)%rad_sw_out(m) &
3649	+ surf_usm_v(l)%rad_lw_in(m) &
3650	- surf_usm_v(l)%rad_lw_out(m)
3651	ENDDO
3652	ENDDO
3653
3654
3655	CALL exchange_horiz( rad_lw_in, nbgp )
3656	CALL exchange_horiz( rad_lw_out, nbgp )
3657	CALL exchange_horiz( rad_lw_hr, nbgp )
3658	CALL exchange_horiz( rad_lw_cs_hr, nbgp )
3659
3660	CALL exchange_horiz( rad_sw_in, nbgp )
3661	CALL exchange_horiz( rad_sw_out, nbgp )
3662	CALL exchange_horiz( rad_sw_hr, nbgp )
3663	CALL exchange_horiz( rad_sw_cs_hr, nbgp )
3664
3665	#endif
3666
3667	END SUBROUTINE radiation_rrtmg
3668
3669
3670	!------------------------------------------------------------------------------!
3671	! Description:
3672	! ------------
3673	!> Calculate the cosine of the zenith angle (variable is called zenith)
3674	!------------------------------------------------------------------------------!
3675	SUBROUTINE calc_zenith
3676
3677	IMPLICIT NONE
3678
3679	REAL(wp) :: declination, & !< solar declination angle
3680	hour_angle !< solar hour angle
3681	!
3682	!-- Calculate current day and time based on the initial values and simulation
3683	!-- time
3684	CALL calc_date_and_time
3685
3686	!
3687	!-- Calculate solar declination and hour angle
3688	declination = ASIN( decl_1 * SIN(decl_2 * REAL(day_of_year, KIND=wp) - decl_3) )
3689	hour_angle = 2.0_wp * pi * (time_utc / 86400.0_wp) + lon - pi
3690
3691	!
3692	!-- Calculate cosine of solar zenith angle
3693	zenith(0) = SIN(lat) * SIN(declination) + COS(lat) * COS(declination) &
3694	* COS(hour_angle)
3695	zenith(0) = MAX(0.0_wp,zenith(0))
3696
3697	!
3698	!-- Calculate solar directional vector
3699	IF ( sun_direction ) THEN
3700
3701	!
3702	!-- Direction in longitudes equals to sin(solar_azimuth) * sin(zenith)
3703	sun_dir_lon(0) = -SIN(hour_angle) * COS(declination)
3704
3705	!
3706	!-- Direction in latitues equals to cos(solar_azimuth) * sin(zenith)
3707	sun_dir_lat(0) = SIN(declination) * COS(lat) - COS(hour_angle) &
3708	* COS(declination) * SIN(lat)
3709	ENDIF
3710
3711	!
3712	!-- Check if the sun is up (otheriwse shortwave calculations can be skipped)
3713	IF ( zenith(0) > 0.0_wp ) THEN
3714	sun_up = .TRUE.
3715	ELSE
3716	sun_up = .FALSE.
3717	END IF
3718
3719	END SUBROUTINE calc_zenith
3720
3721	#if defined ( __rrtmg ) && defined ( __netcdf )
3722	!------------------------------------------------------------------------------!
3723	! Description:
3724	! ------------
3725	!> Calculates surface albedo components based on Briegleb (1992) and
3726	!> Briegleb et al. (1986)
3727	!------------------------------------------------------------------------------!
3728	SUBROUTINE calc_albedo( surf )
3729
3730	IMPLICIT NONE
3731
3732	INTEGER(iwp) :: ind_type !< running index surface tiles
3733	INTEGER(iwp) :: m !< running index surface elements
3734
3735	TYPE(surf_type) :: surf !< treated surfaces
3736
3737	IF ( sun_up .AND. .NOT. average_radiation ) THEN
3738
3739	DO m = 1, surf%ns
3740	!
3741	!-- Loop over surface elements
3742	DO ind_type = 0, SIZE( surf%albedo_type, 1 ) - 1
3743
3744	!
3745	!-- Ocean
3746	IF ( surf%albedo_type(ind_type,m) == 1 ) THEN
3747	surf%rrtm_aldir(ind_type,m) = 0.026_wp / &
3748	( zenith(0)**1.7_wp + 0.065_wp )&
3749	+ 0.15_wp * ( zenith(0) - 0.1_wp ) &
3750	* ( zenith(0) - 0.5_wp ) &
3751	* ( zenith(0) - 1.0_wp )
3752	surf%rrtm_asdir(ind_type,m) = surf%rrtm_aldir(ind_type,m)
3753	!
3754	!-- Snow
3755	ELSEIF ( surf%albedo_type(ind_type,m) == 16 ) THEN
3756	IF ( zenith(0) < 0.5_wp ) THEN
3757	surf%rrtm_aldir(ind_type,m) = &
3758	0.5_wp * ( 1.0_wp - surf%aldif(ind_type,m) ) &
3759	* ( 3.0_wp / ( 1.0_wp + 4.0_wp &
3760	* zenith(0) ) ) - 1.0_wp
3761	surf%rrtm_asdir(ind_type,m) = &
3762	0.5_wp * ( 1.0_wp - surf%asdif(ind_type,m) ) &
3763	* ( 3.0_wp / ( 1.0_wp + 4.0_wp &
3764	* zenith(0) ) ) - 1.0_wp
3765
3766	surf%rrtm_aldir(ind_type,m) = &
3767	MIN(0.98_wp, surf%rrtm_aldir(ind_type,m))
3768	surf%rrtm_asdir(ind_type,m) = &
3769	MIN(0.98_wp, surf%rrtm_asdir(ind_type,m))
3770	ELSE
3771	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
3772	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
3773	ENDIF
3774	!
3775	!-- Sea ice
3776	ELSEIF ( surf%albedo_type(ind_type,m) == 15 ) THEN
3777	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
3778	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
3779
3780	!
3781	!-- Asphalt
3782	ELSEIF ( surf%albedo_type(ind_type,m) == 17 ) THEN
3783	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
3784	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
3785
3786
3787	!
3788	!-- Bare soil
3789	ELSEIF ( surf%albedo_type(ind_type,m) == 18 ) THEN
3790	surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
3791	surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
3792
3793	!
3794	!-- Land surfaces
3795	ELSE
3796	SELECT CASE ( surf%albedo_type(ind_type,m) )
3797
3798	!
3799	!-- Surface types with strong zenith dependence
3800	CASE ( 1, 2, 3, 4, 11, 12, 13 )
3801	surf%rrtm_aldir(ind_type,m) = &
3802	surf%aldif(ind_type,m) * 1.4_wp / &
3803	( 1.0_wp + 0.8_wp * zenith(0) )
3804	surf%rrtm_asdir(ind_type,m) = &
3805	surf%asdif(ind_type,m) * 1.4_wp / &
3806	( 1.0_wp + 0.8_wp * zenith(0) )
3807	!
3808	!-- Surface types with weak zenith dependence
3809	CASE ( 5, 6, 7, 8, 9, 10, 14 )
3810	surf%rrtm_aldir(ind_type,m) = &
3811	surf%aldif(ind_type,m) * 1.1_wp / &
3812	( 1.0_wp + 0.2_wp * zenith(0) )
3813	surf%rrtm_asdir(ind_type,m) = &
3814	surf%asdif(ind_type,m) * 1.1_wp / &
3815	( 1.0_wp + 0.2_wp * zenith(0) )
3816
3817	CASE DEFAULT
3818
3819	END SELECT
3820	ENDIF
3821	!
3822	!-- Diffusive albedo is taken from Table 2
3823	surf%rrtm_aldif(ind_type,m) = surf%aldif(ind_type,m)
3824	surf%rrtm_asdif(ind_type,m) = surf%asdif(ind_type,m)
3825	ENDDO
3826	ENDDO
3827	!
3828	!-- Set albedo in case of average radiation
3829	ELSEIF ( sun_up .AND. average_radiation ) THEN
3830	surf%rrtm_asdir = albedo_urb
3831	surf%rrtm_asdif = albedo_urb
3832	surf%rrtm_aldir = albedo_urb
3833	surf%rrtm_aldif = albedo_urb
3834	!
3835	!-- Darkness
3836	ELSE
3837	surf%rrtm_aldir = 0.0_wp
3838	surf%rrtm_asdir = 0.0_wp
3839	surf%rrtm_aldif = 0.0_wp
3840	surf%rrtm_asdif = 0.0_wp
3841	ENDIF
3842
3843	END SUBROUTINE calc_albedo
3844
3845	!------------------------------------------------------------------------------!
3846	! Description:
3847	! ------------
3848	!> Read sounding data (pressure and temperature) from RADIATION_DATA.
3849	!------------------------------------------------------------------------------!
3850	SUBROUTINE read_sounding_data
3851
3852	IMPLICIT NONE
3853
3854	INTEGER(iwp) :: id, & !< NetCDF id of input file
3855	id_dim_zrad, & !< pressure level id in the NetCDF file
3856	id_var, & !< NetCDF variable id
3857	k, & !< loop index
3858	nz_snd, & !< number of vertical levels in the sounding data
3859	nz_snd_start, & !< start vertical index for sounding data to be used
3860	nz_snd_end !< end vertical index for souding data to be used
3861
3862	REAL(wp) :: t_surface !< actual surface temperature
3863
3864	REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd_tmp, & !< temporary hydrostatic pressure profile (sounding)
3865	t_snd_tmp !< temporary temperature profile (sounding)
3866
3867	!
3868	!-- In case of updates, deallocate arrays first (sufficient to check one
3869	!-- array as the others are automatically allocated). This is required
3870	!-- because nzt_rad might change during the update
3871	IF ( ALLOCATED ( hyp_snd ) ) THEN
3872	DEALLOCATE( hyp_snd )
3873	DEALLOCATE( t_snd )
3874	DEALLOCATE( q_snd )
3875	DEALLOCATE ( rrtm_play )
3876	DEALLOCATE ( rrtm_plev )
3877	DEALLOCATE ( rrtm_tlay )
3878	DEALLOCATE ( rrtm_tlev )
3879
3880	DEALLOCATE ( rrtm_h2ovmr )
3881	DEALLOCATE ( rrtm_cicewp )
3882	DEALLOCATE ( rrtm_cldfr )
3883	DEALLOCATE ( rrtm_cliqwp )
3884	DEALLOCATE ( rrtm_reice )
3885	DEALLOCATE ( rrtm_reliq )
3886	DEALLOCATE ( rrtm_lw_taucld )
3887	DEALLOCATE ( rrtm_lw_tauaer )
3888
3889	DEALLOCATE ( rrtm_lwdflx )
3890	DEALLOCATE ( rrtm_lwdflxc )
3891	DEALLOCATE ( rrtm_lwuflx )
3892	DEALLOCATE ( rrtm_lwuflxc )
3893	DEALLOCATE ( rrtm_lwuflx_dt )
3894	DEALLOCATE ( rrtm_lwuflxc_dt )
3895	DEALLOCATE ( rrtm_lwhr )
3896	DEALLOCATE ( rrtm_lwhrc )
3897
3898	DEALLOCATE ( rrtm_sw_taucld )
3899	DEALLOCATE ( rrtm_sw_ssacld )
3900	DEALLOCATE ( rrtm_sw_asmcld )
3901	DEALLOCATE ( rrtm_sw_fsfcld )
3902	DEALLOCATE ( rrtm_sw_tauaer )
3903	DEALLOCATE ( rrtm_sw_ssaaer )
3904	DEALLOCATE ( rrtm_sw_asmaer )
3905	DEALLOCATE ( rrtm_sw_ecaer )
3906
3907	DEALLOCATE ( rrtm_swdflx )
3908	DEALLOCATE ( rrtm_swdflxc )
3909	DEALLOCATE ( rrtm_swuflx )
3910	DEALLOCATE ( rrtm_swuflxc )
3911	DEALLOCATE ( rrtm_swhr )
3912	DEALLOCATE ( rrtm_swhrc )
3913
3914	ENDIF
3915
3916	!
3917	!-- Open file for reading
3918	nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id )
3919	CALL netcdf_handle_error_rad( 'read_sounding_data', 549 )
3920
3921	!
3922	!-- Inquire dimension of z axis and save in nz_snd
3923	nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim_zrad )
3924	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim_zrad, len = nz_snd )
3925	CALL netcdf_handle_error_rad( 'read_sounding_data', 551 )
3926
3927	!
3928	! !-- Allocate temporary array for storing pressure data
3929	ALLOCATE( hyp_snd_tmp(1:nz_snd) )
3930	hyp_snd_tmp = 0.0_wp
3931
3932
3933	!-- Read pressure from file
3934	nc_stat = NF90_INQ_VARID( id, "Pressure", id_var )
3935	nc_stat = NF90_GET_VAR( id, id_var, hyp_snd_tmp(:), start = (/1/), &
3936	count = (/nz_snd/) )
3937	CALL netcdf_handle_error_rad( 'read_sounding_data', 552 )
3938
3939	!
3940	!-- Allocate temporary array for storing temperature data
3941	ALLOCATE( t_snd_tmp(1:nz_snd) )
3942	t_snd_tmp = 0.0_wp
3943
3944	!
3945	!-- Read temperature from file
3946	nc_stat = NF90_INQ_VARID( id, "ReferenceTemperature", id_var )
3947	nc_stat = NF90_GET_VAR( id, id_var, t_snd_tmp(:), start = (/1/), &
3948	count = (/nz_snd/) )
3949	CALL netcdf_handle_error_rad( 'read_sounding_data', 553 )
3950
3951	!
3952	!-- Calculate start of sounding data
3953	nz_snd_start = nz_snd + 1
3954	nz_snd_end = nz_snd + 1
3955
3956	!
3957	!-- Start filling vertical dimension at 10hPa above the model domain (hyp is
3958	!-- in Pa, hyp_snd in hPa).
3959	DO k = 1, nz_snd
3960	IF ( hyp_snd_tmp(k) < ( hyp(nzt+1) - 1000.0_wp) * 0.01_wp ) THEN
3961	nz_snd_start = k
3962	EXIT
3963	END IF
3964	END DO
3965
3966	IF ( nz_snd_start <= nz_snd ) THEN
3967	nz_snd_end = nz_snd
3968	END IF
3969
3970
3971	!
3972	!-- Calculate of total grid points for RRTMG calculations
3973	nzt_rad = nzt + nz_snd_end - nz_snd_start + 1
3974
3975	!
3976	!-- Save data above LES domain in hyp_snd, t_snd and q_snd
3977	!-- Note: q_snd_tmp is not calculated at the moment (dry residual atmosphere)
3978	ALLOCATE( hyp_snd(nzb+1:nzt_rad) )
3979	ALLOCATE( t_snd(nzb+1:nzt_rad) )
3980	ALLOCATE( q_snd(nzb+1:nzt_rad) )
3981	hyp_snd = 0.0_wp
3982	t_snd = 0.0_wp
3983	q_snd = 0.0_wp
3984
3985	hyp_snd(nzt+2:nzt_rad) = hyp_snd_tmp(nz_snd_start+1:nz_snd_end)
3986	t_snd(nzt+2:nzt_rad) = t_snd_tmp(nz_snd_start+1:nz_snd_end)
3987
3988	nc_stat = NF90_CLOSE( id )
3989
3990	!
3991	!-- Calculate pressure levels on zu and zw grid. Sounding data is added at
3992	!-- top of the LES domain. This routine does not consider horizontal or
3993	!-- vertical variability of pressure and temperature
3994	ALLOCATE ( rrtm_play(0:0,nzb+1:nzt_rad+1) )
3995	ALLOCATE ( rrtm_plev(0:0,nzb+1:nzt_rad+2) )
3996
3997	t_surface = pt_surface * ( surface_pressure / 1000.0_wp )**0.286_wp
3998	DO k = nzb+1, nzt+1
3999	rrtm_play(0,k) = hyp(k) * 0.01_wp
4000	rrtm_plev(0,k) = surface_pressure * ( (t_surface - g/cp * zw(k-1)) / &
4001	t_surface )**(1.0_wp/0.286_wp)
4002	ENDDO
4003
4004	DO k = nzt+2, nzt_rad
4005	rrtm_play(0,k) = hyp_snd(k)
4006	rrtm_plev(0,k) = 0.5_wp * ( rrtm_play(0,k) + rrtm_play(0,k-1) )
4007	ENDDO
4008	rrtm_plev(0,nzt_rad+1) = MAX( 0.5 * hyp_snd(nzt_rad), &
4009	1.5 * hyp_snd(nzt_rad) &
4010	- 0.5 * hyp_snd(nzt_rad-1) )
4011	rrtm_plev(0,nzt_rad+2) = MIN( 1.0E-4_wp, &
4012	0.25_wp * rrtm_plev(0,nzt_rad+1) )
4013
4014	rrtm_play(0,nzt_rad+1) = 0.5 * rrtm_plev(0,nzt_rad+1)
4015
4016	!
4017	!-- Calculate temperature/humidity levels at top of the LES domain.
4018	!-- Currently, the temperature is taken from sounding data (might lead to a
4019	!-- temperature jump at interface. To do: Humidity is currently not
4020	!-- calculated above the LES domain.
4021	ALLOCATE ( rrtm_tlay(0:0,nzb+1:nzt_rad+1) )
4022	ALLOCATE ( rrtm_tlev(0:0,nzb+1:nzt_rad+2) )
4023	ALLOCATE ( rrtm_h2ovmr(0:0,nzb+1:nzt_rad+1) )
4024
4025	DO k = nzt+8, nzt_rad
4026	rrtm_tlay(0,k) = t_snd(k)
4027	rrtm_h2ovmr(0,k) = q_snd(k)
4028	ENDDO
4029	rrtm_tlay(0,nzt_rad+1) = 2.0_wp * rrtm_tlay(0,nzt_rad) &
4030	- rrtm_tlay(0,nzt_rad-1)
4031	DO k = nzt+9, nzt_rad+1
4032	rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) &
4033	- rrtm_tlay(0,k-1)) &
4034	/ ( rrtm_play(0,k) - rrtm_play(0,k-1) ) &
4035	* ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
4036	ENDDO
4037	rrtm_h2ovmr(0,nzt_rad+1) = rrtm_h2ovmr(0,nzt_rad)
4038
4039	rrtm_tlev(0,nzt_rad+2) = 2.0_wp * rrtm_tlay(0,nzt_rad+1) &
4040	- rrtm_tlev(0,nzt_rad)
4041	!
4042	!-- Allocate remaining RRTMG arrays
4043	ALLOCATE ( rrtm_cicewp(0:0,nzb+1:nzt_rad+1) )
4044	ALLOCATE ( rrtm_cldfr(0:0,nzb+1:nzt_rad+1) )
4045	ALLOCATE ( rrtm_cliqwp(0:0,nzb+1:nzt_rad+1) )
4046	ALLOCATE ( rrtm_reice(0:0,nzb+1:nzt_rad+1) )
4047	ALLOCATE ( rrtm_reliq(0:0,nzb+1:nzt_rad+1) )
4048	ALLOCATE ( rrtm_lw_taucld(1:nbndlw+1,0:0,nzb+1:nzt_rad+1) )
4049	ALLOCATE ( rrtm_lw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndlw+1) )
4050	ALLOCATE ( rrtm_sw_taucld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4051	ALLOCATE ( rrtm_sw_ssacld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4052	ALLOCATE ( rrtm_sw_asmcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4053	ALLOCATE ( rrtm_sw_fsfcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4054	ALLOCATE ( rrtm_sw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
4055	ALLOCATE ( rrtm_sw_ssaaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
4056	ALLOCATE ( rrtm_sw_asmaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
4057	ALLOCATE ( rrtm_sw_ecaer(0:0,nzb+1:nzt_rad+1,1:naerec+1) )
4058
4059	!
4060	!-- The ice phase is currently not considered in PALM
4061	rrtm_cicewp = 0.0_wp
4062	rrtm_reice = 0.0_wp
4063
4064	!
4065	!-- Set other parameters (move to NAMELIST parameters in the future)
4066	rrtm_lw_tauaer = 0.0_wp
4067	rrtm_lw_taucld = 0.0_wp
4068	rrtm_sw_taucld = 0.0_wp
4069	rrtm_sw_ssacld = 0.0_wp
4070	rrtm_sw_asmcld = 0.0_wp
4071	rrtm_sw_fsfcld = 0.0_wp
4072	rrtm_sw_tauaer = 0.0_wp
4073	rrtm_sw_ssaaer = 0.0_wp
4074	rrtm_sw_asmaer = 0.0_wp
4075	rrtm_sw_ecaer = 0.0_wp
4076
4077
4078	ALLOCATE ( rrtm_swdflx(0:0,nzb:nzt_rad+1) )
4079	ALLOCATE ( rrtm_swuflx(0:0,nzb:nzt_rad+1) )
4080	ALLOCATE ( rrtm_swhr(0:0,nzb+1:nzt_rad+1) )
4081	ALLOCATE ( rrtm_swuflxc(0:0,nzb:nzt_rad+1) )
4082	ALLOCATE ( rrtm_swdflxc(0:0,nzb:nzt_rad+1) )
4083	ALLOCATE ( rrtm_swhrc(0:0,nzb+1:nzt_rad+1) )
4084
4085	rrtm_swdflx = 0.0_wp
4086	rrtm_swuflx = 0.0_wp
4087	rrtm_swhr = 0.0_wp
4088	rrtm_swuflxc = 0.0_wp
4089	rrtm_swdflxc = 0.0_wp
4090	rrtm_swhrc = 0.0_wp
4091
4092	ALLOCATE ( rrtm_lwdflx(0:0,nzb:nzt_rad+1) )
4093	ALLOCATE ( rrtm_lwuflx(0:0,nzb:nzt_rad+1) )
4094	ALLOCATE ( rrtm_lwhr(0:0,nzb+1:nzt_rad+1) )
4095	ALLOCATE ( rrtm_lwuflxc(0:0,nzb:nzt_rad+1) )
4096	ALLOCATE ( rrtm_lwdflxc(0:0,nzb:nzt_rad+1) )
4097	ALLOCATE ( rrtm_lwhrc(0:0,nzb+1:nzt_rad+1) )
4098
4099	rrtm_lwdflx = 0.0_wp
4100	rrtm_lwuflx = 0.0_wp
4101	rrtm_lwhr = 0.0_wp
4102	rrtm_lwuflxc = 0.0_wp
4103	rrtm_lwdflxc = 0.0_wp
4104	rrtm_lwhrc = 0.0_wp
4105
4106	ALLOCATE ( rrtm_lwuflx_dt(0:0,nzb:nzt_rad+1) )
4107	ALLOCATE ( rrtm_lwuflxc_dt(0:0,nzb:nzt_rad+1) )
4108
4109	rrtm_lwuflx_dt = 0.0_wp
4110	rrtm_lwuflxc_dt = 0.0_wp
4111
4112	END SUBROUTINE read_sounding_data
4113
4114
4115	!------------------------------------------------------------------------------!
4116	! Description:
4117	! ------------
4118	!> Read trace gas data from file
4119	!------------------------------------------------------------------------------!
4120	SUBROUTINE read_trace_gas_data
4121
4122	USE rrsw_ncpar
4123
4124	IMPLICIT NONE
4125
4126	INTEGER(iwp), PARAMETER :: num_trace_gases = 9 !< number of trace gases (absorbers)
4127
4128	CHARACTER(LEN=5), DIMENSION(num_trace_gases), PARAMETER :: & !< trace gas names
4129	trace_names = (/'O3 ', 'CO2 ', 'CH4 ', 'N2O ', 'O2 ', &
4130	'CFC11', 'CFC12', 'CFC22', 'CCL4 '/)
4131
4132	INTEGER(iwp) :: id, & !< NetCDF id
4133	k, & !< loop index
4134	m, & !< loop index
4135	n, & !< loop index
4136	nabs, & !< number of absorbers
4137	np, & !< number of pressure levels
4138	id_abs, & !< NetCDF id of the respective absorber
4139	id_dim, & !< NetCDF id of asborber's dimension
4140	id_var !< NetCDf id ot the absorber
4141
4142	REAL(wp) :: p_mls_l, p_mls_u, p_wgt_l, p_wgt_u, p_mls_m
4143
4144
4145	REAL(wp), DIMENSION(:), ALLOCATABLE :: p_mls, & !< pressure levels for the absorbers
4146	rrtm_play_tmp, & !< temporary array for pressure zu-levels
4147	rrtm_plev_tmp, & !< temporary array for pressure zw-levels
4148	trace_path_tmp !< temporary array for storing trace gas path data
4149
4150	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: trace_mls, & !< array for storing the absorber amounts
4151	trace_mls_path, & !< array for storing trace gas path data
4152	trace_mls_tmp !< temporary array for storing trace gas data
4153
4154
4155	!
4156	!-- In case of updates, deallocate arrays first (sufficient to check one
4157	!-- array as the others are automatically allocated)
4158	IF ( ALLOCATED ( rrtm_o3vmr ) ) THEN
4159	DEALLOCATE ( rrtm_o3vmr )
4160	DEALLOCATE ( rrtm_co2vmr )
4161	DEALLOCATE ( rrtm_ch4vmr )
4162	DEALLOCATE ( rrtm_n2ovmr )
4163	DEALLOCATE ( rrtm_o2vmr )
4164	DEALLOCATE ( rrtm_cfc11vmr )
4165	DEALLOCATE ( rrtm_cfc12vmr )
4166	DEALLOCATE ( rrtm_cfc22vmr )
4167	DEALLOCATE ( rrtm_ccl4vmr )
4168	ENDIF
4169
4170	!
4171	!-- Allocate trace gas profiles
4172	ALLOCATE ( rrtm_o3vmr(0:0,1:nzt_rad+1) )
4173	ALLOCATE ( rrtm_co2vmr(0:0,1:nzt_rad+1) )
4174	ALLOCATE ( rrtm_ch4vmr(0:0,1:nzt_rad+1) )
4175	ALLOCATE ( rrtm_n2ovmr(0:0,1:nzt_rad+1) )
4176	ALLOCATE ( rrtm_o2vmr(0:0,1:nzt_rad+1) )
4177	ALLOCATE ( rrtm_cfc11vmr(0:0,1:nzt_rad+1) )
4178	ALLOCATE ( rrtm_cfc12vmr(0:0,1:nzt_rad+1) )
4179	ALLOCATE ( rrtm_cfc22vmr(0:0,1:nzt_rad+1) )
4180	ALLOCATE ( rrtm_ccl4vmr(0:0,1:nzt_rad+1) )
4181
4182	!
4183	!-- Open file for reading
4184	nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id )
4185	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 549 )
4186	!
4187	!-- Inquire dimension ids and dimensions
4188	nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim )
4189	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
4190	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = np)
4191	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
4192
4193	nc_stat = NF90_INQ_DIMID( id, "Absorber", id_dim )
4194	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
4195	nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = nabs )
4196	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
4197
4198
4199	!
4200	!-- Allocate pressure, and trace gas arrays
4201	ALLOCATE( p_mls(1:np) )
4202	ALLOCATE( trace_mls(1:num_trace_gases,1:np) )
4203	ALLOCATE( trace_mls_tmp(1:nabs,1:np) )
4204
4205
4206	nc_stat = NF90_INQ_VARID( id, "Pressure", id_var )
4207	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
4208	nc_stat = NF90_GET_VAR( id, id_var, p_mls )
4209	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
4210
4211	nc_stat = NF90_INQ_VARID( id, "AbsorberAmountMLS", id_var )
4212	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
4213	nc_stat = NF90_GET_VAR( id, id_var, trace_mls_tmp )
4214	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
4215
4216
4217	!
4218	!-- Write absorber amounts (mls) to trace_mls
4219	DO n = 1, num_trace_gases
4220	CALL getAbsorberIndex( TRIM( trace_names(n) ), id_abs )
4221
4222	trace_mls(n,1:np) = trace_mls_tmp(id_abs,1:np)
4223
4224	!
4225	!-- Replace missing values by zero
4226	WHERE ( trace_mls(n,:) > 2.0_wp )
4227	trace_mls(n,:) = 0.0_wp
4228	END WHERE
4229	END DO
4230
4231	DEALLOCATE ( trace_mls_tmp )
4232
4233	nc_stat = NF90_CLOSE( id )
4234	CALL netcdf_handle_error_rad( 'read_trace_gas_data', 551 )
4235
4236	!
4237	!-- Add extra pressure level for calculations of the trace gas paths
4238	ALLOCATE ( rrtm_play_tmp(1:nzt_rad+1) )
4239	ALLOCATE ( rrtm_plev_tmp(1:nzt_rad+2) )
4240
4241	rrtm_play_tmp(1:nzt_rad) = rrtm_play(0,1:nzt_rad)
4242	rrtm_plev_tmp(1:nzt_rad+1) = rrtm_plev(0,1:nzt_rad+1)
4243	rrtm_play_tmp(nzt_rad+1) = rrtm_plev(0,nzt_rad+1) * 0.5_wp
4244	rrtm_plev_tmp(nzt_rad+2) = MIN( 1.0E-4_wp, 0.25_wp &
4245	* rrtm_plev(0,nzt_rad+1) )
4246
4247	!
4248	!-- Calculate trace gas path (zero at surface) with interpolation to the
4249	!-- sounding levels
4250	ALLOCATE ( trace_mls_path(1:nzt_rad+2,1:num_trace_gases) )
4251
4252	trace_mls_path(nzb+1,:) = 0.0_wp
4253
4254	DO k = nzb+2, nzt_rad+2
4255	DO m = 1, num_trace_gases
4256	trace_mls_path(k,m) = trace_mls_path(k-1,m)
4257
4258	!
4259	!-- When the pressure level is higher than the trace gas pressure
4260	!-- level, assume that
4261	IF ( rrtm_plev_tmp(k-1) > p_mls(1) ) THEN
4262
4263	trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,1) &
4264	* ( rrtm_plev_tmp(k-1) &
4265	- MAX( p_mls(1), rrtm_plev_tmp(k) ) &
4266	) / g
4267	ENDIF
4268
4269	!
4270	!-- Integrate for each sounding level from the contributing p_mls
4271	!-- levels
4272	DO n = 2, np
4273	!
4274	!-- Limit p_mls so that it is within the model level
4275	p_mls_u = MIN( rrtm_plev_tmp(k-1), &
4276	MAX( rrtm_plev_tmp(k), p_mls(n) ) )
4277	p_mls_l = MIN( rrtm_plev_tmp(k-1), &
4278	MAX( rrtm_plev_tmp(k), p_mls(n-1) ) )
4279
4280	IF ( p_mls_l > p_mls_u ) THEN
4281
4282	!
4283	!-- Calculate weights for interpolation
4284	p_mls_m = 0.5_wp * (p_mls_l + p_mls_u)
4285	p_wgt_u = (p_mls(n-1) - p_mls_m) / (p_mls(n-1) - p_mls(n))
4286	p_wgt_l = (p_mls_m - p_mls(n)) / (p_mls(n-1) - p_mls(n))
4287
4288	!
4289	!-- Add level to trace gas path
4290	trace_mls_path(k,m) = trace_mls_path(k,m) &
4291	+ ( p_wgt_u * trace_mls(m,n) &
4292	+ p_wgt_l * trace_mls(m,n-1) ) &
4293	* (p_mls_l - p_mls_u) / g
4294	ENDIF
4295	ENDDO
4296
4297	IF ( rrtm_plev_tmp(k) < p_mls(np) ) THEN
4298	trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,np) &
4299	* ( MIN( rrtm_plev_tmp(k-1), p_mls(np) ) &
4300	- rrtm_plev_tmp(k) &
4301	) / g
4302	ENDIF
4303	ENDDO
4304	ENDDO
4305
4306
4307	!
4308	!-- Prepare trace gas path profiles
4309	ALLOCATE ( trace_path_tmp(1:nzt_rad+1) )
4310
4311	DO m = 1, num_trace_gases
4312
4313	trace_path_tmp(1:nzt_rad+1) = ( trace_mls_path(2:nzt_rad+2,m) &
4314	- trace_mls_path(1:nzt_rad+1,m) ) * g &
4315	/ ( rrtm_plev_tmp(1:nzt_rad+1) &
4316	- rrtm_plev_tmp(2:nzt_rad+2) )
4317
4318	!
4319	!-- Save trace gas paths to the respective arrays
4320	SELECT CASE ( TRIM( trace_names(m) ) )
4321
4322	CASE ( 'O3' )
4323
4324	rrtm_o3vmr(0,:) = trace_path_tmp(:)
4325
4326	CASE ( 'CO2' )
4327
4328	rrtm_co2vmr(0,:) = trace_path_tmp(:)
4329
4330	CASE ( 'CH4' )
4331
4332	rrtm_ch4vmr(0,:) = trace_path_tmp(:)
4333
4334	CASE ( 'N2O' )
4335
4336	rrtm_n2ovmr(0,:) = trace_path_tmp(:)
4337
4338	CASE ( 'O2' )
4339
4340	rrtm_o2vmr(0,:) = trace_path_tmp(:)
4341
4342	CASE ( 'CFC11' )
4343
4344	rrtm_cfc11vmr(0,:) = trace_path_tmp(:)
4345
4346	CASE ( 'CFC12' )
4347
4348	rrtm_cfc12vmr(0,:) = trace_path_tmp(:)
4349
4350	CASE ( 'CFC22' )
4351
4352	rrtm_cfc22vmr(0,:) = trace_path_tmp(:)
4353
4354	CASE ( 'CCL4' )
4355
4356	rrtm_ccl4vmr(0,:) = trace_path_tmp(:)
4357
4358	CASE DEFAULT
4359
4360	END SELECT
4361
4362	ENDDO
4363
4364	DEALLOCATE ( trace_path_tmp )
4365	DEALLOCATE ( trace_mls_path )
4366	DEALLOCATE ( rrtm_play_tmp )
4367	DEALLOCATE ( rrtm_plev_tmp )
4368	DEALLOCATE ( trace_mls )
4369	DEALLOCATE ( p_mls )
4370
4371	END SUBROUTINE read_trace_gas_data
4372
4373
4374	SUBROUTINE netcdf_handle_error_rad( routine_name, errno )
4375
4376	USE control_parameters, &
4377	ONLY: message_string
4378
4379	USE NETCDF
4380
4381	USE pegrid
4382
4383	IMPLICIT NONE
4384
4385	CHARACTER(LEN=6) :: message_identifier
4386	CHARACTER(LEN=*) :: routine_name
4387
4388	INTEGER(iwp) :: errno
4389
4390	IF ( nc_stat /= NF90_NOERR ) THEN
4391
4392	WRITE( message_identifier, '(''NC'',I4.4)' ) errno
4393	message_string = TRIM( NF90_STRERROR( nc_stat ) )
4394
4395	CALL message( routine_name, message_identifier, 2, 2, 0, 6, 1 )
4396
4397	ENDIF
4398
4399	END SUBROUTINE netcdf_handle_error_rad
4400	#endif
4401
4402
4403	!------------------------------------------------------------------------------!
4404	! Description:
4405	! ------------
4406	!> Calculate temperature tendency due to radiative cooling/heating.
4407	!> Cache-optimized version.
4408	!------------------------------------------------------------------------------!
4409	SUBROUTINE radiation_tendency_ij ( i, j, tend )
4410
4411	USE cloud_parameters, &
4412	ONLY: pt_d_t
4413
4414	IMPLICIT NONE
4415
4416	INTEGER(iwp) :: i, j, k !< loop indices
4417
4418	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term
4419
4420	IF ( radiation_scheme == 'rrtmg' ) THEN
4421	#if defined ( __rrtmg )
4422	!
4423	!-- Calculate tendency based on heating rate
4424	DO k = nzb+1, nzt+1
4425	tend(k,j,i) = tend(k,j,i) + (rad_lw_hr(k,j,i) + rad_sw_hr(k,j,i)) &
4426	* pt_d_t(k) * d_seconds_hour
4427	ENDDO
4428	#endif
4429	ENDIF
4430
4431	END SUBROUTINE radiation_tendency_ij
4432
4433
4434	!------------------------------------------------------------------------------!
4435	! Description:
4436	! ------------
4437	!> Calculate temperature tendency due to radiative cooling/heating.
4438	!> Vector-optimized version
4439	!------------------------------------------------------------------------------!
4440	SUBROUTINE radiation_tendency ( tend )
4441
4442	USE cloud_parameters, &
4443	ONLY: pt_d_t
4444
4445	USE indices, &
4446	ONLY: nxl, nxr, nyn, nys
4447
4448	IMPLICIT NONE
4449
4450	INTEGER(iwp) :: i, j, k !< loop indices
4451
4452	REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term
4453
4454	IF ( radiation_scheme == 'rrtmg' ) THEN
4455	#if defined ( __rrtmg )
4456	!
4457	!-- Calculate tendency based on heating rate
4458	DO i = nxl, nxr
4459	DO j = nys, nyn
4460	DO k = nzb+1, nzt+1
4461	tend(k,j,i) = tend(k,j,i) + ( rad_lw_hr(k,j,i) &
4462	+ rad_sw_hr(k,j,i) ) * pt_d_t(k) &
4463	* d_seconds_hour
4464	ENDDO
4465	ENDDO
4466	ENDDO
4467	#endif
4468	ENDIF
4469
4470
4471	END SUBROUTINE radiation_tendency
4472
4473
4474	!------------------------------------------------------------------------------!
4475	! Description:
4476	! ------------
4477	!> This subroutine calculates interaction of the solar radiation
4478	!> with urban and land surfaces and updates all surface heatfluxes, including
4479	!> the vertual atmospheric cell faces. It calculates also the required parameters
4480	!> for RRTMG lower BC.
4481	!>
4482	!> For more info. see Resler et al. 2017
4483	!>
4484	!------------------------------------------------------------------------------!
4485	SUBROUTINE radiation_interaction_init
4486
4487	USE netcdf_data_input_mod, &
4488	ONLY: leaf_area_density_f
4489
4490	USE plant_canopy_model_mod, &
4491	ONLY: pch_index, pc_heating_rate, lad_s, prototype_lad, usm_lad_rma
4492
4493	IMPLICIT NONE
4494
4495	INTEGER(iwp) :: i, j, k, d, l, ir, jr, ids, m
4496	INTEGER(iwp) :: k_topo !< vertical index indicating topography top for given (j,i)
4497	INTEGER(iwp) :: k_topo2 !< vertical index indicating topography top for given (j,i)
4498	INTEGER(iwp) :: nzubl, nzutl, isurf, ipcgb
4499	INTEGER(iwp) :: procid
4500
4501	INTEGER(iwp), DIMENSION(1:4,inorth_b:iwest_b) :: ijdb !< start and end of the local domain border coordinates (set in code)
4502	LOGICAL, DIMENSION(inorth_b:iwest_b) :: isborder !< is PE on the border of the domain in four corresponding directions
4503
4504	!
4505	!-- Find nzub, nzut, nzu via wall_flag_0 array (nzb_s_inner will be
4506	!-- removed later). The following contruct finds the lowest / largest index
4507	!-- for any upward-facing wall (see bit 12).
4508	nzubl = MINVAL( get_topography_top_index( 's' ) )
4509	nzutl = MAXVAL( get_topography_top_index( 's' ) )
4510
4511	nzubl = MAX( nzubl, nzb )
4512
4513	IF ( plant_canopy ) THEN
4514	!-- allocate needed arrays
4515	ALLOCATE( pct(nys:nyn,nxl:nxr) )
4516	ALLOCATE( pch(nys:nyn,nxl:nxr) )
4517
4518	!-- calculate plant canopy height
4519	npcbl = 0
4520	pct = 0
4521	pch = 0
4522	DO i = nxl, nxr
4523	DO j = nys, nyn
4524	!
4525	!-- Find topography top index
4526	k_topo = get_topography_top_index_ji( j, i, 's' )
4527
4528	DO k = nzt+1, 0, -1
4529	IF ( lad_s(k,j,i) /= 0.0_wp ) THEN
4530	!-- we are at the top of the pcs
4531	pct(j,i) = k + k_topo
4532	pch(j,i) = k
4533	npcbl = npcbl + pch(j,i)
4534	EXIT
4535	ENDIF
4536	ENDDO
4537	ENDDO
4538	ENDDO
4539
4540	nzutl = MAX( nzutl, MAXVAL( pct ) )
4541	!-- code of plant canopy model uses parameter pch_index
4542	!-- we need to setup it here to right value
4543	!-- (pch_index, lad_s and other arrays in PCM are defined flat)
4544	pch_index = MERGE( leaf_area_density_f%nz - 1, MAXVAL( pch ), &
4545	leaf_area_density_f%from_file )
4546
4547	prototype_lad = MAXVAL( lad_s ) * .9_wp !< better be *1.0 if lad is either 0 or maxval(lad) everywhere
4548	IF ( prototype_lad <= 0._wp ) prototype_lad = .3_wp
4549	!WRITE(message_string, '(a,f6.3)') 'Precomputing effective box optical ' &
4550	! // 'depth using prototype leaf area density = ', prototype_lad
4551	!CALL message('usm_init_urban_surface', 'PA0520', 0, 0, -1, 6, 0)
4552	ENDIF
4553
4554	nzutl = MIN( nzutl + nzut_free, nzt )
4555
4556	#if defined( __parallel )
4557	CALL MPI_AllReduce(nzubl, nzub, 1, MPI_INTEGER, MPI_MIN, comm2d, ierr )
4558	CALL MPI_AllReduce(nzutl, nzut, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr )
4559	#else
4560	nzub = nzubl
4561	nzut = nzutl
4562	#endif
4563	!
4564	!-- global number of urban layers
4565	nzu = nzut - nzub + 1
4566	!
4567	!-- allocate urban surfaces grid
4568	!-- calc number of surfaces in local proc
4569	CALL location_message( ' calculation of indices for surfaces', .TRUE. )
4570	nsurfl = 0
4571	!
4572	!-- Number of horizontal surfaces including land- and roof surfaces in both USM and LSM. Note that
4573	!-- All horizontal surface elements are already counted in surface_mod.
4574	startland = 1
4575	nsurfl = surf_usm_h%ns + surf_lsm_h%ns
4576	endland = nsurfl
4577	nlands = endland - startland + 1
4578
4579	!
4580	!-- Number of vertical surfaces in both USM and LSM. Note that all vertical surface elements are
4581	!-- already counted in surface_mod.
4582	startwall = nsurfl+1
4583	DO i = 0,3
4584	nsurfl = nsurfl + surf_usm_v(i)%ns + surf_lsm_v(i)%ns
4585	ENDDO
4586	endwall = nsurfl
4587	nwalls = endwall - startwall + 1
4588
4589	!-- range of energy balance surfaces ! will be treated separately by surf_usm_h and surf_usm_v
4590	!-- Do we really need usm_energy_balance_land??!!
4591	!-- !!! Attention: if usm_energy_balance_land = false then only vertical surfaces will be considered here
4592	nenergy = 0
4593	IF ( energy_balance_surf_h ) THEN
4594	startenergy = startland
4595	nenergy = nenergy + nlands
4596	ELSE
4597	startenergy = startwall
4598	ENDIF
4599	IF ( energy_balance_surf_v ) THEN
4600	endenergy = endwall
4601	nenergy = nenergy + nwalls
4602	ELSE
4603	endenergy = endland
4604	ENDIF
4605
4606	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4607	!-- block of virtual surfaces
4608	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4609	!-- calculate sky surfaces ! not used so far!
4610	startsky = nsurfl+1
4611	nsurfl = nsurfl+(nxr-nxl+1)*(nyn-nys+1)
4612	endsky = nsurfl
4613	nskys = endsky-startsky+1
4614
4615	!-- border flags
4616	#if defined( __parallel )
4617	isborder = (/ north_border_pe, south_border_pe, right_border_pe, left_border_pe /)
4618	#else
4619	isborder = (/.TRUE.,.TRUE.,.TRUE.,.TRUE./)
4620	#endif
4621	!-- fill array of the limits of the local domain borders
4622	ijdb = RESHAPE( (/ nxl,nxr,nyn,nyn,nxl,nxr,nys,nys,nxr,nxr,nys,nyn,nxl,nxl,nys,nyn /), (/4, 4/) )
4623	!-- calulation of the free borders of the domain
4624	startborder = nsurfl + 1
4625	DO ids = inorth_b,iwest_b
4626	IF ( isborder(ids) ) THEN
4627	!-- free border of the domain in direction ids
4628	DO i = ijdb(1,ids), ijdb(2,ids)
4629	DO j = ijdb(3,ids), ijdb(4,ids)
4630
4631	k_topo = get_topography_top_index_ji( j, i, 's' )
4632	k_topo2 = get_topography_top_index_ji( j-jdir(ids), i-idir(ids), 's' )
4633
4634
4635	k = nzut - MAX( k_topo, k_topo2 )
4636	nsurfl = nsurfl + k
4637	ENDDO
4638	ENDDO
4639	ENDIF
4640	ENDDO
4641	endborder = nsurfl
4642	nborder = endborder - startborder + 1
4643
4644	!-- calulation of the atmospheric virtual surfaces
4645	!-- each atmospheric cell has 6 faces
4646	IF ( atm_surfaces ) THEN
4647	DO i = nxl, nxr
4648	DO j = nys, nyn
4649	!-- Find topography top index
4650	k_topo = get_topography_top_index_ji( j, i, 's' )
4651	k = nzut - k_topo
4652	nsurfl = nsurfl + 6 * k
4653	ENDDO
4654	ENDDO
4655	!-- exclude the local physical surfaces
4656	nsurfl = nsurfl - nlands - nwalls
4657	!-- exclude the local virtual surfaces
4658	nsurfl = nsurfl - nskys - nborder
4659	ENDIF
4660
4661	!-- fill gridpcbl and pcbl
4662	IF ( plant_canopy ) THEN
4663	ALLOCATE( pcbl(iz:ix, 1:npcbl) )
4664	ALLOCATE( gridpcbl(nzub:nzut,nys:nyn,nxl:nxr) )
4665	gridpcbl(:,:,:) = 0
4666	ipcgb = 0
4667	DO i = nxl, nxr
4668	DO j = nys, nyn
4669	!
4670	!-- Find topography top index
4671	k_topo = get_topography_top_index_ji( j, i, 's' )
4672
4673	DO k = k_topo + 1, pct(j,i)
4674	ipcgb = ipcgb + 1
4675	gridpcbl(k,j,i) = ipcgb
4676	pcbl(:,ipcgb) = (/ k, j, i /)
4677	ENDDO
4678	ENDDO
4679	ENDDO
4680
4681	ALLOCATE( pcbinsw( 1:npcbl ) )
4682	ALLOCATE( pcbinlw( 1:npcbl ) )
4683	ENDIF
4684
4685	!-- fill surfl
4686	ALLOCATE(surfl(5,nsurfl)) ! is it mecessary to allocate it with (5,nsurfl)?
4687	isurf = 0
4688
4689	!-- add horizontal surface elements (land and urban surfaces)
4690	!-- TODO: add urban overhanging surfaces (idown_u)
4691	DO i = nxl, nxr
4692	DO j = nys, nyn
4693	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
4694	k = surf_usm_h%k(m)
4695
4696	isurf = isurf + 1
4697	surfl(:,isurf) = (/iup_u,k,j,i,m/)
4698	ENDDO
4699
4700	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
4701	k = surf_lsm_h%k(m)
4702
4703	isurf = isurf + 1
4704	surfl(:,isurf) = (/iup_l,k,j,i,m/)
4705	ENDDO
4706
4707	ENDDO
4708	ENDDO
4709
4710	!-- add vertical surface elements (land and urban surfaces)
4711	!-- TODO: remove the hard coding of l = 0 to l = idirection
4712	DO i = nxl, nxr
4713	DO j = nys, nyn
4714	l = 0
4715	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
4716	k = surf_usm_v(l)%k(m)
4717
4718	isurf = isurf + 1
4719	surfl(:,isurf) = (/inorth_u,k,j,i,m/)
4720	ENDDO
4721	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
4722	k = surf_lsm_v(l)%k(m)
4723
4724	isurf = isurf + 1
4725	surfl(:,isurf) = (/inorth_l,k,j,i,m/)
4726	ENDDO
4727
4728	l = 1
4729	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
4730	k = surf_usm_v(l)%k(m)
4731
4732	isurf = isurf + 1
4733	surfl(:,isurf) = (/isouth_u,k,j,i,m/)
4734	ENDDO
4735	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
4736	k = surf_lsm_v(l)%k(m)
4737
4738	isurf = isurf + 1
4739	surfl(:,isurf) = (/isouth_l,k,j,i,m/)
4740	ENDDO
4741
4742	l = 2
4743	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
4744	k = surf_usm_v(l)%k(m)
4745
4746	isurf = isurf + 1
4747	surfl(:,isurf) = (/ieast_u,k,j,i,m/)
4748	ENDDO
4749	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
4750	k = surf_lsm_v(l)%k(m)
4751
4752	isurf = isurf + 1
4753	surfl(:,isurf) = (/ieast_l,k,j,i,m/)
4754	ENDDO
4755
4756	l = 3
4757	DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
4758	k = surf_usm_v(l)%k(m)
4759
4760	isurf = isurf + 1
4761	surfl(:,isurf) = (/iwest_u,k,j,i,m/)
4762	ENDDO
4763	DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
4764	k = surf_lsm_v(l)%k(m)
4765
4766	isurf = isurf + 1
4767	surfl(:,isurf) = (/iwest_l,k,j,i,m/)
4768	ENDDO
4769	ENDDO
4770	ENDDO
4771
4772	!-- add sky
4773	DO i = nxl, nxr
4774	DO j = nys, nyn
4775	isurf = isurf + 1
4776	k = nzut
4777	surfl(:,isurf) = (/isky,k,j,i,-1/)
4778	ENDDO
4779	ENDDO
4780
4781	!-- calulation of the free borders of the domain
4782	DO ids = inorth_b,iwest_b
4783	IF ( isborder(ids) ) THEN
4784	!-- free border of the domain in direction ids
4785	DO i = ijdb(1,ids), ijdb(2,ids)
4786	DO j = ijdb(3,ids), ijdb(4,ids)
4787	k_topo = get_topography_top_index_ji( j, i, 's' )
4788	k_topo2 = get_topography_top_index_ji( j-jdir(ids), i-idir(ids), 's' )
4789
4790	DO k = MAX(k_topo,k_topo2)+1, nzut
4791	isurf = isurf + 1
4792	surfl(:,isurf) = (/ids,k,j,i,-1/)
4793	ENDDO
4794	ENDDO
4795	ENDDO
4796	ENDIF
4797	ENDDO
4798
4799	!-- adding the atmospheric virtual surfaces
4800	IF ( atm_surfaces ) THEN
4801	!-- TODO: use flags to identfy atmospheric cells and its coresponding surfaces
4802	!-- add horizontal surface
4803	DO i = nxl, nxr
4804	DO j = nys, nyn
4805	k_topo = get_topography_top_index_ji( j, i, 's' )
4806
4807	!-- add upward surface
4808	DO k = (k_topo+1), nzut-1
4809	isurf = isurf + 1
4810	surfl(:,isurf) = (/iup_a,k+1,j,i,-1/)
4811	ENDDO
4812
4813	!-- add downward surface
4814	DO k = (k_topo+1), nzut-1
4815	isurf = isurf + 1
4816	surfl(:,isurf) = (/idown_a,k,j,i,-1/)
4817	ENDDO
4818	ENDDO
4819	ENDDO
4820
4821	!-- add vertical surfaces
4822	DO i = nxl, nxr
4823	DO j = nys, nyn
4824	k_topo = get_topography_top_index_ji( j, i, 's' )
4825	!-- north
4826	IF ( j /= ny ) THEN
4827	ids = inorth_a
4828	jr = min(max(j-jdir(ids),0),ny)
4829	ir = min(max(i-idir(ids),0),nx)
4830	k_topo2 = get_topography_top_index_ji( jr, ir, 's' )
4831	DO k = MAX(k_topo,k_topo2)+1, nzut
4832	isurf = isurf + 1
4833	surfl(:,isurf) = (/inorth_a,k,j,i,-1/)
4834	ENDDO
4835	END IF
4836	!-- south
4837	IF ( j /= 0 ) THEN
4838	ids = isouth_a
4839	jr = min(max(j-jdir(ids),0),ny)
4840	ir = min(max(i-idir(ids),0),nx)
4841	k_topo2 = get_topography_top_index_ji( jr, ir, 's' )
4842
4843	DO k = MAX(k_topo,k_topo2)+1, nzut
4844	isurf = isurf + 1
4845	surfl(:,isurf) = (/isouth_a,k,j,i,-1/)
4846	ENDDO
4847	END IF
4848	!-- east
4849	IF ( i /= nx ) THEN
4850	ids = ieast_a
4851	jr = min(max(j-jdir(ids),0),ny)
4852	ir = min(max(i-idir(ids),0),nx)
4853	k_topo2 = get_topography_top_index_ji( jr, ir, 's' )
4854
4855	DO k = MAX(k_topo,k_topo2)+1, nzut
4856	isurf = isurf + 1
4857	surfl(:,isurf) = (/ieast_a,k,j,i,-1/)
4858	ENDDO
4859	END IF
4860	!-- west
4861	IF ( i /= 0 ) THEN
4862	ids = iwest_a
4863	jr = min(max(j-jdir(ids),0),ny)
4864	ir = min(max(i-idir(ids),0),nx)
4865	k_topo2 = get_topography_top_index_ji( jr, ir, 's' )
4866
4867	DO k = MAX(k_topo,k_topo2)+1, nzut
4868	isurf = isurf + 1
4869	surfl(:,isurf) = (/iwest_a,k,j,i,-1/)
4870	ENDDO
4871	END IF
4872	ENDDO
4873	ENDDO
4874
4875	ENDIF
4876
4877	!
4878	!-- broadband albedo of the land, roof and wall surface
4879	!-- for domain border and sky set artifically to 1.0
4880	!-- what allows us to calculate heat flux leaving over
4881	!-- side and top borders of the domain
4882	ALLOCATE ( albedo_surf(nsurfl) )
4883	albedo_surf = 1.0_wp
4884	!
4885	!-- Also allocate further array for emissivity with identical order of
4886	!-- surface elements as radiation arrays.
4887	!-- MS: Why startenergy:endenergy and albedo surf from 1:nsurfl ?
4888	ALLOCATE ( emiss_surf(startenergy:endenergy) )
4889
4890
4891	!
4892	!-- global array surf of indices of surfaces and displacement index array surfstart
4893	ALLOCATE(nsurfs(0:numprocs-1))
4894
4895	#if defined( __parallel )
4896	CALL MPI_Allgather(nsurfl,1,MPI_INTEGER,nsurfs,1,MPI_INTEGER,comm2d,ierr)
4897	#else
4898	nsurfs(0) = nsurfl
4899	#endif
4900	ALLOCATE(surfstart(0:numprocs))
4901	k = 0
4902	DO i=0,numprocs-1
4903	surfstart(i) = k
4904	k = k+nsurfs(i)
4905	ENDDO
4906	surfstart(numprocs) = k
4907	nsurf = k
4908	ALLOCATE(surf(5,nsurf))
4909
4910	#if defined( __parallel )
4911	CALL MPI_AllGatherv(surfl, nsurfl5, MPI_INTEGER, surf, nsurfs5, surfstart*5, MPI_INTEGER, comm2d, ierr)
4912	#else
4913	surf = surfl
4914	#endif
4915
4916	!--
4917	!-- allocation of the arrays for direct and diffusion radiation
4918	CALL location_message( ' allocation of radiation arrays', .TRUE. )
4919	!-- rad_sw_in, rad_lw_in are computed in radiation model,
4920	!-- splitting of direct and diffusion part is done
4921	!-- in usm_calc_diffusion_radiation for now
4922
4923	ALLOCATE( rad_sw_in_dir(nysg:nyng,nxlg:nxrg) )
4924	ALLOCATE( rad_sw_in_diff(nysg:nyng,nxlg:nxrg) )
4925	ALLOCATE( rad_lw_in_diff(nysg:nyng,nxlg:nxrg) )
4926	rad_sw_in_dir = 0.0_wp
4927	rad_sw_in_diff = 0.0_wp
4928	rad_lw_in_diff = 0.0_wp
4929
4930	!-- allocate radiation arrays
4931	ALLOCATE( surfins(nsurfl) )
4932	ALLOCATE( surfinl(nsurfl) )
4933	ALLOCATE( surfinsw(nsurfl) )
4934	ALLOCATE( surfinlw(nsurfl) )
4935	ALLOCATE( surfinswdir(nsurfl) )
4936	ALLOCATE( surfinswdif(nsurfl) )
4937	ALLOCATE( surfinlwdif(nsurfl) )
4938	ALLOCATE( surfoutsl(startenergy:endenergy) )
4939	ALLOCATE( surfoutll(startenergy:endenergy) )
4940	ALLOCATE( surfoutsw(startenergy:endenergy) )
4941	ALLOCATE( surfoutlw(startenergy:endenergy) )
4942	ALLOCATE( surfouts(nsurf) ) !TODO: global surfaces without virtual
4943	ALLOCATE( surfoutl(nsurf) ) !TODO: global surfaces without virtual
4944
4945	!
4946	!-- @Mohamed
4947	!-- In case of average_radiation, aggregated surface albedo and emissivity,
4948	!-- also set initial value of t_rad_urb.
4949	!-- For the moment set an arbitrary initial value.
4950	IF ( average_radiation ) THEN
4951	albedo_urb = 0.5_wp
4952	emissivity_urb = 0.5_wp
4953	t_rad_urb = pt_surface
4954	ENDIF
4955
4956	END SUBROUTINE radiation_interaction_init
4957	!------------------------------------------------------------------------------!
4958	! Description:
4959	! ------------
4960	!> This subroutine calculates interaction of the solar radiation
4961	!> with urban and land surfaces and updates all surface heatfluxes, including
4962	!> the vertual atmospheric cell faces. It calculates also the required parameters
4963	!> for RRTMG lower BC.
4964	!>
4965	!> For more info. see Resler et al. 2017
4966	!>
4967	!------------------------------------------------------------------------------!
4968	SUBROUTINE radiation_interaction
4969
4970
4971	USE control_parameters
4972
4973	USE plant_canopy_model_mod, &
4974	ONLY: prototype_lad
4975
4976	IMPLICIT NONE
4977
4978	INTEGER(iwp) :: i, j, k, kk, is, js, d, ku, refstep, m, mm, l, ll
4979	INTEGER(iwp) :: ii, jj !< running indices
4980	INTEGER(iwp) :: nzubl, nzutl, isurf, isurfsrc, isurf1, isvf, icsf, ipcgb
4981	INTEGER(iwp), DIMENSION(4) :: bdycross
4982	REAL(wp), DIMENSION(3,3) :: mrot !< grid rotation matrix (xyz)
4983	REAL(wp), DIMENSION(3,0:nsurf_type) :: vnorm !< face direction normal vectors (xyz)
4984	REAL(wp), DIMENSION(3) :: sunorig !< grid rotated solar direction unit vector (xyz)
4985	REAL(wp), DIMENSION(3) :: sunorig_grid !< grid squashed solar direction unit vector (zyx)
4986	REAL(wp), DIMENSION(0:nsurf_type) :: costheta !< direct irradiance factor of solar angle
4987	REAL(wp), DIMENSION(nzub:nzut) :: pchf_prep !< precalculated factor for canopy temp tendency
4988	REAL(wp), PARAMETER :: alpha = 0._wp !< grid rotation (TODO: add to namelist or remove)
4989	REAL(wp) :: rx, ry, rz
4990	REAL(wp) :: pc_box_area, pc_abs_frac, pc_abs_eff
4991	INTEGER(iwp) :: pc_box_dimshift !< transform for best accuracy
4992	INTEGER(iwp), DIMENSION(0:3) :: reorder = (/ 1, 0, 3, 2 /)
4993	REAL(wp), DIMENSION(0:nsurf_type) :: facearea
4994	REAL(wp) :: pabsswl = 0.0_wp !< total absorbed SW radiation energy in local processor (W)
4995	REAL(wp) :: pabssw = 0.0_wp !< total absorbed SW radiation energy in all processors (W)
4996	REAL(wp) :: pabslwl = 0.0_wp !< total absorbed LW radiation energy in local processor (W)
4997	REAL(wp) :: pabslw = 0.0_wp !< total absorbed LW radiation energy in all processors (W)
4998	REAL(wp) :: pemitlwl = 0.0_wp !< total emitted LW radiation energy in all processors (W)
4999	REAL(wp) :: pemitlw = 0.0_wp !< total emitted LW radiation energy in all processors (W)
5000	REAL(wp) :: pinswl = 0.0_wp !< total received SW radiation energy in local processor (W)
5001	REAL(wp) :: pinsw = 0.0_wp !< total received SW radiation energy in all processor (W)
5002	REAL(wp) :: pinlwl = 0.0_wp !< total received LW radiation energy in local processor (W)
5003	REAL(wp) :: pinlw = 0.0_wp !< total received LW radiation energy in all processor (W)
5004	REAL(wp) :: emiss_sum_surfl !< sum of emissisivity of surfaces in local processor
5005	REAL(wp) :: emiss_sum_surf !< sum of emissisivity of surfaces in all processor
5006	REAL(wp) :: area_surfl !< total area of surfaces in local processor
5007	REAL(wp) :: area_surf !< total area of surfaces in all processor
5008
5009	IF ( plant_canopy ) THEN
5010	pchf_prep(:) = r_d * (hyp(nzub:nzut) / 100000.0_wp)**0.286_wp &
5011	/ (cp * hyp(nzub:nzut) * dxdydz) !< equals to 1 / (rho * c_p * Vbox * T)
5012	ENDIF
5013
5014	sun_direction = .TRUE.
5015	CALL calc_zenith !< required also for diffusion radiation
5016
5017	!-- prepare rotated normal vectors and irradiance factor
5018	vnorm(1,:) = idir(:)
5019	vnorm(2,:) = jdir(:)
5020	vnorm(3,:) = kdir(:)
5021	mrot(1, :) = (/ cos(alpha), -sin(alpha), 0._wp /)
5022	mrot(2, :) = (/ sin(alpha), cos(alpha), 0._wp /)
5023	mrot(3, :) = (/ 0._wp, 0._wp, 1._wp /)
5024	sunorig = (/ sun_dir_lon, sun_dir_lat, zenith(0) /)
5025	sunorig = matmul(mrot, sunorig)
5026	DO d = 0, nsurf_type
5027	costheta(d) = dot_product(sunorig, vnorm(:,d))
5028	ENDDO
5029
5030	IF ( zenith(0) > 0 ) THEN
5031	!-- now we will "squash" the sunorig vector by grid box size in
5032	!-- each dimension, so that this new direction vector will allow us
5033	!-- to traverse the ray path within grid coordinates directly
5034	sunorig_grid = (/ sunorig(3)/dz, sunorig(2)/dy, sunorig(1)/dx /)
5035	!-- sunorig_grid = sunorig_grid / norm2(sunorig_grid)
5036	sunorig_grid = sunorig_grid / SQRT(SUM(sunorig_grid**2))
5037
5038	IF ( plant_canopy ) THEN
5039	!-- precompute effective box depth with prototype Leaf Area Density
5040	pc_box_dimshift = maxloc(sunorig, 1) - 1
5041	CALL box_absorb(cshift((/dx,dy,dz/), pc_box_dimshift), &
5042	60, prototype_lad, &
5043	cshift(sunorig, pc_box_dimshift), &
5044	pc_box_area, pc_abs_frac)
5045	pc_box_area = pc_box_area * sunorig(pc_box_dimshift+1) / sunorig(3)
5046	pc_abs_eff = log(1._wp - pc_abs_frac) / prototype_lad
5047	ENDIF
5048	ENDIF
5049
5050	!-- split diffusion and direct part of the solar downward radiation
5051	!-- comming from radiation model and store it in 2D arrays
5052	!-- rad_sw_in_diff, rad_sw_in_dir and rad_lw_in_diff
5053	IF ( split_diffusion_radiation ) THEN
5054	CALL calc_diffusion_radiation
5055	ELSE
5056	DO i = nxl, nxr
5057	DO j = nys, nyn
5058	DO m = surf_def_h(0)%start_index(j,i), &
5059	surf_def_h(0)%end_index(j,i)
5060	rad_sw_in_diff(j,i) = 0.0_wp
5061	rad_sw_in_dir(j,i) = surf_def_h(0)%rad_sw_in(m)
5062	rad_lw_in_diff(j,i) = surf_def_h(0)%rad_lw_in(m)
5063	ENDDO
5064	DO m = surf_lsm_h%start_index(j,i), &
5065	surf_lsm_h%end_index(j,i)
5066	rad_sw_in_diff(j,i) = 0.0_wp
5067	rad_sw_in_dir(j,i) = surf_lsm_h%rad_sw_in(m)
5068	rad_lw_in_diff(j,i) = surf_lsm_h%rad_lw_in(m)
5069	ENDDO
5070	DO m = surf_usm_h%start_index(j,i), &
5071	surf_usm_h%end_index(j,i)
5072	rad_sw_in_diff(j,i) = 0.0_wp
5073	rad_sw_in_dir(j,i) = surf_usm_h%rad_sw_in(m)
5074	rad_lw_in_diff(j,i) = surf_usm_h%rad_lw_in(m)
5075	ENDDO
5076	ENDDO
5077	ENDDO
5078	ENDIF
5079
5080	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5081	!-- First pass: direct + diffuse irradiance
5082	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5083	surfinswdir = 0._wp !nsurfl
5084	surfinswdif = 0._wp !nsurfl
5085	surfinlwdif = 0._wp !nsurfl
5086	surfins = 0._wp !nsurfl
5087	surfinl = 0._wp !nsurfl
5088	surfoutsl(:) = 0.0_wp !start-end
5089	surfoutll(:) = 0.0_wp !start-end
5090
5091	!-- Set up thermal radiation from surfaces
5092	!-- emiss_surf is defined only for surfaces for which energy balance is calculated
5093	!-- Workaround: reorder surface data type back on 1D array including all surfaces,
5094	!-- which implies to reorder horizontal and vertical surfaces
5095	!
5096	!-- Horizontal walls
5097	mm = 1
5098	DO i = nxl, nxr
5099	DO j = nys, nyn
5100	!-- urban
5101	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
5102	surfoutll(mm) = SUM ( surf_usm_h%frac(:,m) * &
5103	surf_usm_h%emissivity(:,m) ) &
5104	* sigma_sb &
5105	* surf_usm_h%pt_surface(m)**4
5106	albedo_surf(mm) = SUM ( surf_usm_h%frac(:,m) * &
5107	surf_usm_h%albedo(:,m) )
5108	emiss_surf(mm) = SUM ( surf_usm_h%frac(:,m) * &
5109	surf_usm_h%emissivity(:,m) )
5110	mm = mm + 1
5111	ENDDO
5112	!-- land
5113	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
5114	surfoutll(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5115	surf_lsm_h%emissivity(:,m) ) &
5116	* sigma_sb &
5117	* surf_lsm_h%pt_surface(m)**4
5118	albedo_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5119	surf_lsm_h%albedo(:,m) )
5120	emiss_surf(mm) = SUM ( surf_lsm_h%frac(:,m) * &
5121	surf_lsm_h%emissivity(:,m) )
5122	mm = mm + 1
5123	ENDDO
5124	ENDDO
5125	ENDDO
5126	!
5127	!-- Vertical walls
5128	DO i = nxl, nxr
5129	DO j = nys, nyn
5130	DO ll = 0, 3
5131	l = reorder(ll)
5132	!-- urban
5133	DO m = surf_usm_v(l)%start_index(j,i), &
5134	surf_usm_v(l)%end_index(j,i)
5135	surfoutll(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5136	surf_usm_v(l)%emissivity(:,m) ) &
5137	* sigma_sb &
5138	* surf_usm_v(l)%pt_surface(m)**4
5139	albedo_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5140	surf_usm_v(l)%albedo(:,m) )
5141	emiss_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) * &
5142	surf_usm_v(l)%emissivity(:,m) )
5143	mm = mm + 1
5144	ENDDO
5145	!-- land
5146	DO m = surf_lsm_v(l)%start_index(j,i), &
5147	surf_lsm_v(l)%end_index(j,i)
5148	surfoutll(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5149	surf_lsm_v(l)%emissivity(:,m) ) &
5150	* sigma_sb &
5151	* surf_lsm_v(l)%pt_surface(m)**4
5152	albedo_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5153	surf_lsm_v(l)%albedo(:,m) )
5154	emiss_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) * &
5155	surf_lsm_v(l)%emissivity(:,m) )
5156	mm = mm + 1
5157	ENDDO
5158	ENDDO
5159	ENDDO
5160	ENDDO
5161
5162	#if defined( __parallel )
5163	!-- might be optimized and gather only values relevant for current processor
5164
5165	CALL MPI_AllGatherv(surfoutll, nenergy, MPI_REAL, &
5166	surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) !nsurf global
5167	#else
5168	surfoutl(:) = surfoutll(:) !nsurf global
5169	#endif
5170
5171	isurf1 = -1 !< previous processed surface
5172	DO isvf = 1, nsvfl
5173	isurf = svfsurf(1, isvf)
5174	k = surfl(iz, isurf)
5175	j = surfl(iy, isurf)
5176	i = surfl(ix, isurf)
5177	isurfsrc = svfsurf(2, isvf)
5178	IF ( zenith(0) > 0 .AND. isurf /= isurf1 ) THEN
5179	!-- locate the virtual surface where the direct solar ray crosses domain boundary
5180	!-- (once per target surface)
5181	d = surfl(id, isurf)
5182	rz = REAL(k, wp) - 0.5_wp * kdir(d)
5183	ry = REAL(j, wp) - 0.5_wp * jdir(d)
5184	rx = REAL(i, wp) - 0.5_wp * idir(d)
5185
5186	CALL find_boundary_face( (/ rz, ry, rx /), sunorig_grid, bdycross)
5187
5188	isurf1 = isurf
5189	ENDIF
5190
5191	IF ( surf(id, isurfsrc) >= isky ) THEN
5192	!-- diffuse rad from boundary surfaces. Since it is a simply
5193	!-- calculated value, it is not assigned to surfref(s/l),
5194	!-- instead it is used directly here
5195	!-- we consider the radiation from the radiation model falling on surface
5196	!-- as the radiation falling on the top of urban layer into the place of the source surface
5197	!-- we consider it as a very reasonable simplification which allow as avoid
5198	!-- necessity of other global range arrays and some all to all mpi communication
5199	surfinswdif(isurf) = surfinswdif(isurf) + rad_sw_in_diff(j,i) * svf(1,isvf) * svf(2,isvf)
5200	!< canopy shading is applied only to shortwave
5201	surfinlwdif(isurf) = surfinlwdif(isurf) + rad_lw_in_diff(j,i) * svf(1,isvf)
5202	ELSE
5203	!-- for surface-to-surface factors we calculate thermal radiation in 1st pass
5204	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)
5205	ENDIF
5206
5207	IF ( zenith(0) > 0 .AND. all( surf(1:4,isurfsrc) == bdycross ) ) THEN
5208	!-- found svf between model boundary and the face => face isn't shaded
5209	surfinswdir(isurf) = rad_sw_in_dir(j,i) &
5210	* costheta(surfl(id, isurf)) * svf(2,isvf) / zenith(0)
5211
5212	ENDIF
5213	ENDDO
5214
5215	IF ( plant_canopy ) THEN
5216
5217	pcbinsw(:) = 0._wp
5218	pcbinlw(:) = 0._wp !< will stay always 0 since we don't absorb lw anymore
5219	!
5220	!-- pcsf first pass
5221	isurf1 = -1 !< previous processed pcgb
5222	DO icsf = 1, ncsfl
5223	ipcgb = csfsurf(1, icsf)
5224	i = pcbl(ix,ipcgb)
5225	j = pcbl(iy,ipcgb)
5226	k = pcbl(iz,ipcgb)
5227	isurfsrc = csfsurf(2, icsf)
5228
5229	IF ( zenith(0) > 0 .AND. ipcgb /= isurf1 ) THEN
5230	!-- locate the virtual surface where the direct solar ray crosses domain boundary
5231	!-- (once per target PC gridbox)
5232	rz = REAL(k, wp)
5233	ry = REAL(j, wp)
5234	rx = REAL(i, wp)
5235	CALL find_boundary_face( (/ rz, ry, rx /), &
5236	sunorig_grid, bdycross)
5237
5238	isurf1 = ipcgb
5239	ENDIF
5240
5241	IF ( surf(id, isurfsrc) >= isky ) THEN
5242	!-- Diffuse rad from boundary surfaces. See comments for svf above.
5243	pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * csf(2,icsf) * rad_sw_in_diff(j,i)
5244	!-- canopy shading is applied only to shortwave, therefore no absorbtion for lw
5245	!-- pcbinlw(ipcgb) = pcbinlw(ipcgb) + svf(1,isvf) * rad_lw_in_diff(j,i)
5246	!ELSE
5247	!-- Thermal radiation in 1st pass
5248	!-- pcbinlw(ipcgb) = pcbinlw(ipcgb) + svf(1,isvf) * surfoutl(isurfsrc)
5249	ENDIF
5250
5251	IF ( zenith(0) > 0 .AND. ALL( surf(1:4,isurfsrc) == bdycross ) ) THEN
5252	!-- found svf between model boundary and the pcgb => pcgb isn't shaded
5253	pc_abs_frac = 1._wp - EXP(pc_abs_eff * lad_s(k,j,i))
5254	pcbinsw(ipcgb) = pcbinsw(ipcgb) &
5255	+ rad_sw_in_dir(j, i) * pc_box_area * csf(2,icsf) * pc_abs_frac
5256	ENDIF
5257	ENDDO
5258	ENDIF
5259
5260	surfins(startenergy:endenergy) = surfinswdir(startenergy:endenergy) + surfinswdif(startenergy:endenergy)
5261	surfinl(startenergy:endenergy) = surfinl(startenergy:endenergy) + surfinlwdif(startenergy:endenergy)
5262	surfinsw(:) = surfins(:)
5263	surfinlw(:) = surfinl(:)
5264	surfoutsw(:) = 0.0_wp
5265	surfoutlw(:) = surfoutll(:)
5266	! surfhf(startenergy:endenergy) = surfinsw(startenergy:endenergy) + surfinlw(startenergy:endenergy) &
5267	! - surfoutsw(startenergy:endenergy) - surfoutlw(startenergy:endenergy)
5268
5269	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5270	!-- Next passes - reflections
5271	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5272	DO refstep = 1, nrefsteps
5273
5274	surfoutsl(startenergy:endenergy) = albedo_surf(startenergy:endenergy) * surfins(startenergy:endenergy)
5275	!-- for non-transparent surfaces, longwave albedo is 1 - emissivity
5276	surfoutll(startenergy:endenergy) = (1._wp - emiss_surf(startenergy:endenergy)) * surfinl(startenergy:endenergy)
5277
5278	#if defined( __parallel )
5279	CALL MPI_AllGatherv(surfoutsl, nsurfl, MPI_REAL, &
5280	surfouts, nsurfs, surfstart, MPI_REAL, comm2d, ierr)
5281	CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, &
5282	surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr)
5283	#else
5284	surfouts(:) = surfoutsl(:)
5285	surfoutl(:) = surfoutll(:)
5286	#endif
5287
5288	!-- reset for next pass input
5289	surfins(:) = 0._wp
5290	surfinl(:) = 0._wp
5291
5292	!-- reflected radiation
5293	DO isvf = 1, nsvfl
5294	isurf = svfsurf(1, isvf)
5295	isurfsrc = svfsurf(2, isvf)
5296
5297	!-- TODO: to remove if, use start+end for isvf
5298	IF ( surf(id, isurfsrc) < isky ) THEN
5299	surfins(isurf) = surfins(isurf) + svf(1,isvf) * svf(2,isvf) * surfouts(isurfsrc)
5300	surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)
5301	ENDIF
5302	ENDDO
5303
5304	!-- radiation absorbed by plant canopy
5305	DO icsf = 1, ncsfl
5306	ipcgb = csfsurf(1, icsf)
5307	isurfsrc = csfsurf(2, icsf)
5308
5309	IF ( surf(id, isurfsrc) < isky ) THEN
5310	pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * csf(2,icsf) * surfouts(isurfsrc)
5311	!-- pcbinlw(ipcgb) = pcbinlw(ipcgb) + csf(1,icsf) * surfoutl(isurfsrc)
5312	ENDIF
5313	ENDDO
5314
5315	surfinsw(:) = surfinsw(:) + surfins(:)
5316	surfinlw(:) = surfinlw(:) + surfinl(:)
5317	surfoutsw(startenergy:endenergy) = surfoutsw(startenergy:endenergy) + surfoutsl(startenergy:endenergy)
5318	surfoutlw(startenergy:endenergy) = surfoutlw(startenergy:endenergy) + surfoutll(startenergy:endenergy)
5319	! surfhf(startenergy:endenergy) = surfinsw(startenergy:endenergy) + surfinlw(startenergy:endenergy) &
5320	! - surfoutsw(startenergy:endenergy) - surfoutlw(startenergy:endenergy)
5321
5322	ENDDO
5323
5324	!-- push heat flux absorbed by plant canopy to respective 3D arrays
5325	IF ( plant_canopy ) THEN
5326	pc_heating_rate(:,:,:) = 0._wp
5327	DO ipcgb = 1, npcbl
5328	j = pcbl(iy, ipcgb)
5329	i = pcbl(ix, ipcgb)
5330	k = pcbl(iz, ipcgb)
5331	!
5332	!-- Following expression equals former kk = k - nzb_s_inner(j,i)
5333	kk = k - get_topography_top_index_ji( j, i, 's' ) !- lad arrays are defined flat
5334	pc_heating_rate(kk, j, i) = (pcbinsw(ipcgb) + pcbinlw(ipcgb)) &
5335	* pchf_prep(k) * pt(k, j, i) !-- = dT/dt
5336	ENDDO
5337	ENDIF
5338	!
5339	!-- Transfer radiation arrays required for energy balance to the respective data types
5340	DO i = startenergy, endenergy
5341	m = surfl(5,i)
5342	!
5343	!-- (1) Urban surfaces
5344	!-- upward-facing
5345	IF ( surfl(1,i) == iup_u ) THEN
5346	surf_usm_h%rad_sw_in(m) = surfinsw(i)
5347	surf_usm_h%rad_sw_out(m) = surfoutsw(i)
5348	surf_usm_h%rad_lw_in(m) = surfinlw(i)
5349	surf_usm_h%rad_lw_out(m) = surfoutlw(i)
5350	surf_usm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5351	surfinlw(i) - surfoutlw(i)
5352	!
5353	!-- northward-facding
5354	ELSEIF ( surfl(1,i) == inorth_u ) THEN
5355	surf_usm_v(0)%rad_sw_in(m) = surfinsw(i)
5356	surf_usm_v(0)%rad_sw_out(m) = surfoutsw(i)
5357	surf_usm_v(0)%rad_lw_in(m) = surfinlw(i)
5358	surf_usm_v(0)%rad_lw_out(m) = surfoutlw(i)
5359	surf_usm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5360	surfinlw(i) - surfoutlw(i)
5361	!
5362	!-- southward-facding
5363	ELSEIF ( surfl(1,i) == isouth_u ) THEN
5364	surf_usm_v(1)%rad_sw_in(m) = surfinsw(i)
5365	surf_usm_v(1)%rad_sw_out(m) = surfoutsw(i)
5366	surf_usm_v(1)%rad_lw_in(m) = surfinlw(i)
5367	surf_usm_v(1)%rad_lw_out(m) = surfoutlw(i)
5368	surf_usm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5369	surfinlw(i) - surfoutlw(i)
5370	!
5371	!-- eastward-facing
5372	ELSEIF ( surfl(1,i) == ieast_u ) THEN
5373	surf_usm_v(2)%rad_sw_in(m) = surfinsw(i)
5374	surf_usm_v(2)%rad_sw_out(m) = surfoutsw(i)
5375	surf_usm_v(2)%rad_lw_in(m) = surfinlw(i)
5376	surf_usm_v(2)%rad_lw_out(m) = surfoutlw(i)
5377	surf_usm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5378	surfinlw(i) - surfoutlw(i)
5379	!
5380	!-- westward-facding
5381	ELSEIF ( surfl(1,i) == iwest_u ) THEN
5382	surf_usm_v(3)%rad_sw_in(m) = surfinsw(i)
5383	surf_usm_v(3)%rad_sw_out(m) = surfoutsw(i)
5384	surf_usm_v(3)%rad_lw_in(m) = surfinlw(i)
5385	surf_usm_v(3)%rad_lw_out(m) = surfoutlw(i)
5386	surf_usm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5387	surfinlw(i) - surfoutlw(i)
5388	!
5389	!-- (2) land surfaces
5390	!-- upward-facing
5391	ELSEIF ( surfl(1,i) == iup_l ) THEN
5392	surf_lsm_h%rad_sw_in(m) = surfinsw(i)
5393	surf_lsm_h%rad_sw_out(m) = surfoutsw(i)
5394	surf_lsm_h%rad_lw_in(m) = surfinlw(i)
5395	surf_lsm_h%rad_lw_out(m) = surfoutlw(i)
5396	surf_lsm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5397	surfinlw(i) - surfoutlw(i)
5398	!
5399	!-- northward-facding
5400	ELSEIF ( surfl(1,i) == inorth_l ) THEN
5401	surf_lsm_v(0)%rad_sw_in(m) = surfinsw(i)
5402	surf_lsm_v(0)%rad_sw_out(m) = surfoutsw(i)
5403	surf_lsm_v(0)%rad_lw_in(m) = surfinlw(i)
5404	surf_lsm_v(0)%rad_lw_out(m) = surfoutlw(i)
5405	surf_lsm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5406	surfinlw(i) - surfoutlw(i)
5407	!
5408	!-- southward-facding
5409	ELSEIF ( surfl(1,i) == isouth_l ) THEN
5410	surf_lsm_v(1)%rad_sw_in(m) = surfinsw(i)
5411	surf_lsm_v(1)%rad_sw_out(m) = surfoutsw(i)
5412	surf_lsm_v(1)%rad_lw_in(m) = surfinlw(i)
5413	surf_lsm_v(1)%rad_lw_out(m) = surfoutlw(i)
5414	surf_lsm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5415	surfinlw(i) - surfoutlw(i)
5416	!
5417	!-- eastward-facing
5418	ELSEIF ( surfl(1,i) == ieast_l ) THEN
5419	surf_lsm_v(2)%rad_sw_in(m) = surfinsw(i)
5420	surf_lsm_v(2)%rad_sw_out(m) = surfoutsw(i)
5421	surf_lsm_v(2)%rad_lw_in(m) = surfinlw(i)
5422	surf_lsm_v(2)%rad_lw_out(m) = surfoutlw(i)
5423	surf_lsm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5424	surfinlw(i) - surfoutlw(i)
5425	!
5426	!-- westward-facing
5427	ELSEIF ( surfl(1,i) == iwest_l ) THEN
5428	surf_lsm_v(3)%rad_sw_in(m) = surfinsw(i)
5429	surf_lsm_v(3)%rad_sw_out(m) = surfoutsw(i)
5430	surf_lsm_v(3)%rad_lw_in(m) = surfinlw(i)
5431	surf_lsm_v(3)%rad_lw_out(m) = surfoutlw(i)
5432	surf_lsm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + &
5433	surfinlw(i) - surfoutlw(i)
5434	ENDIF
5435
5436	ENDDO
5437
5438	DO m = 1, surf_usm_h%ns
5439	surf_usm_h%surfhf(m) = surf_usm_h%rad_sw_in(m) + &
5440	surf_usm_h%rad_lw_in(m) - &
5441	surf_usm_h%rad_sw_out(m) - &
5442	surf_usm_h%rad_lw_out(m)
5443	ENDDO
5444	DO m = 1, surf_lsm_h%ns
5445	surf_lsm_h%surfhf(m) = surf_lsm_h%rad_sw_in(m) + &
5446	surf_lsm_h%rad_lw_in(m) - &
5447	surf_lsm_h%rad_sw_out(m) - &
5448	surf_lsm_h%rad_lw_out(m)
5449	ENDDO
5450
5451	DO l = 0, 3
5452	!-- urban
5453	DO m = 1, surf_usm_v(l)%ns
5454	surf_usm_v(l)%surfhf(m) = surf_usm_v(l)%rad_sw_in(m) + &
5455	surf_usm_v(l)%rad_lw_in(m) - &
5456	surf_usm_v(l)%rad_sw_out(m) - &
5457	surf_usm_v(l)%rad_lw_out(m)
5458	ENDDO
5459	!-- land
5460	DO m = 1, surf_lsm_v(l)%ns
5461	surf_lsm_v(l)%surfhf(m) = surf_lsm_v(l)%rad_sw_in(m) + &
5462	surf_lsm_v(l)%rad_lw_in(m) - &
5463	surf_lsm_v(l)%rad_sw_out(m) - &
5464	surf_lsm_v(l)%rad_lw_out(m)
5465
5466	ENDDO
5467	ENDDO
5468	!
5469	!-- Calculate the average temperature, albedo, and emissivity for urban/land domain
5470	!-- in case of using average_radiation in the respective radiation model
5471	IF ( average_radiation ) THEN
5472
5473	!--
5474	!-- precalculate face areas for different face directions using normal vector
5475	!-- TODO: make facearea a globale variable because it is used in more than one subroutine
5476	DO d = 0, nsurf_type
5477	facearea(d) = 1._wp
5478	IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx
5479	IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy
5480	IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz
5481	ENDDO
5482	!
5483	!-- total absorbed SW & LW and emitted LW energy by all physical surfaces (land and urban) in local processor
5484	pabsswl = 0._wp
5485	pabslwl = 0._wp
5486	pemitlwl = 0._wp
5487	emiss_sum_surfl = 0._wp
5488	area_surfl = 0._wp
5489	DO i = startenergy, endenergy
5490	d = surfl(id, i)
5491	pabsswl = pabsswl + (1._wp - albedo_surf(i)) * surfinsw(i) * facearea(d)
5492	pabslwl = pabslwl + emiss_surf(i) * surfinlw(i) * facearea(d)
5493	pemitlwl = pemitlwl + surfoutlw(i) * facearea(d)
5494	emiss_sum_surfl = emiss_sum_surfl + emiss_surf(i) * facearea(d)
5495	area_surfl = area_surfl + facearea(d)
5496	END DO
5497	!
5498	!-- add the absorbed SW energy by plant canopy
5499	IF ( plant_canopy ) THEN
5500	pabsswl = pabsswl + SUM(pcbinsw)
5501	pabslwl = pabslwl + SUM(pcbinlw)
5502	ENDIF
5503	!
5504	!-- gather all absorbed SW energy in all processors
5505	#if defined( __parallel )
5506	CALL MPI_ALLREDUCE( pabsswl, pabssw, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
5507	CALL MPI_ALLREDUCE( pabslwl, pabslw, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
5508	CALL MPI_ALLREDUCE( pemitlwl, pemitlw, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
5509	CALL MPI_ALLREDUCE( emiss_sum_surfl, emiss_sum_surf, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
5510	CALL MPI_ALLREDUCE( area_surfl, area_surf, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
5511	#else
5512	pabssw = pabsswl
5513	pabslwl = pabslw
5514	pemitlwl = pemitlw
5515	emiss_sum_surf = emiss_sum_surfl
5516	area_surf = area_surfl
5517	#endif
5518	!
5519	!-- total received SW energy in local processor !!!!!! cos??!!!!
5520	pinswl = 0._wp
5521	pinlwl = 0._wp
5522	!-- sky
5523	DO i = startsky, endsky
5524	d = surfl(id, i)
5525	ii = surfl(ix, i)
5526	jj = surfl(iy, i)
5527	pinswl = pinswl + (rad_sw_in_dir(jj,ii) + rad_sw_in_diff(jj,ii)) * facearea(d)
5528	pinlwl = pinlwl + rad_lw_in_diff(jj,ii) * facearea(d)
5529	ENDDO
5530	!-- boundary
5531	DO i = startborder, endborder
5532	d = surfl(id, i)
5533	ii = surfl(ix, i)
5534	jj = surfl(iy, i)
5535	pinswl = pinswl + (rad_sw_in_dir(jj,ii) + rad_sw_in_diff(jj,ii)) * facearea(d)
5536	pinlwl = pinlwl + rad_lw_in_diff(jj,ii) * facearea(d)
5537	ENDDO
5538	!-- gather all received SW energy in all processors
5539	#if defined( __parallel )
5540	CALL MPI_ALLREDUCE( pinswl, pinsw, 1, MPI_REAL, MPI_SUM, comm2d, ierr)
5541	CALL MPI_ALLREDUCE( pinlwl, pinlw, 1, MPI_REAL, MPI_SUM, comm2d, ierr)
5542	#else
5543	pinsw = pinswl
5544	pinlw = pinlwl
5545	#endif
5546	!-- (1) albedo
5547	IF ( pinsw /= 0.0_wp ) albedo_urb = 1._wp - pabssw / pinsw
5548
5549	!-- (2) average emmsivity
5550	emissivity_urb = emiss_sum_surf / area_surf
5551
5552	!-- (3) temerature
5553	t_rad_urb = ((pemitlw - pabslw + emissivity_urbpinlw)/(emissivity_urbsigma_sbarea_surf))*0.25_wp
5554
5555	ENDIF
5556
5557	!-- return surface radiation to horizontal surfaces
5558	!-- to rad_sw_in, rad_lw_in and rad_net for outputs
5559	!!!!!!!!!!
5560	!-- we need the original radiation on urban top layer
5561	!-- for calculation of MRT so we can't do adjustment here for now
5562	!!!!!!!!!!
5563	!!!DO isurf = 1, nsurfl
5564	!!! i = surfl(ix,isurf)
5565	!!! j = surfl(iy,isurf)
5566	!!! k = surfl(iz,isurf)
5567	!!! d = surfl(id,isurf)
5568	!!! IF ( d==iroof ) THEN
5569	!!! rad_sw_in(:,j,i) = surfinsw(isurf)
5570	!!! rad_lw_in(:,j,i) = surfinlw(isurf)
5571	!!! rad_net(j,i) = rad_sw_in(k,j,i) - rad_sw_out(k,j,i) + rad_lw_in(k,j,i) - rad_lw_out(k,j,i)
5572	!!! ENDIF
5573	!!!ENDDO
5574
5575	CONTAINS
5576
5577	!------------------------------------------------------------------------------!
5578	! Description:
5579	! ------------
5580	!> This subroutine splits direct and diffusion dw radiation
5581	!> It sould not be called in case the radiation model already does it
5582	!> It follows <CITATION>
5583	!------------------------------------------------------------------------------!
5584	SUBROUTINE calc_diffusion_radiation
5585
5586	USE date_and_time_mod, &
5587	ONLY: day_of_year_init, time_utc_init
5588
5589	REAL(wp), PARAMETER :: sol_const = 1367.0_wp !< solar conbstant
5590	REAL(wp), PARAMETER :: lowest_solarUp = 0.1_wp !< limit the sun elevation to protect stability of the calculation
5591	INTEGER(iwp) :: i, j
5592	REAL(wp), PARAMETER :: year_seconds = 86400._wp * 365._wp
5593	REAL(wp) :: year_angle !< angle
5594	REAL(wp) :: etr !< extraterestrial radiation
5595	REAL(wp) :: corrected_solarUp !< corrected solar up radiation
5596	REAL(wp) :: horizontalETR !< horizontal extraterestrial radiation
5597	REAL(wp) :: clearnessIndex !< clearness index
5598	REAL(wp) :: diff_frac !< diffusion fraction of the radiation
5599
5600
5601	!-- Calculate current day and time based on the initial values and simulation time
5602	year_angle = ((day_of_year_init*86400) &
5603	+ time_utc_init+time_since_reference_point) &
5604	/ year_seconds * 2.0_wp * pi
5605
5606	etr = sol_const * (1.00011_wp + &
5607	0.034221_wp * cos(year_angle) + &
5608	0.001280_wp * sin(year_angle) + &
5609	0.000719_wp * cos(2.0_wp * year_angle) + &
5610	0.000077_wp * sin(2.0_wp * year_angle))
5611
5612	!--
5613	!-- Under a very low angle, we keep extraterestrial radiation at
5614	!-- the last small value, therefore the clearness index will be pushed
5615	!-- towards 0 while keeping full continuity.
5616	!--
5617	IF ( zenith(0) <= lowest_solarUp ) THEN
5618	corrected_solarUp = lowest_solarUp
5619	ELSE
5620	corrected_solarUp = zenith(0)
5621	ENDIF
5622
5623	horizontalETR = etr * corrected_solarUp
5624
5625	DO i = nxl, nxr
5626	DO j = nys, nyn
5627
5628	DO m = surf_def_h(0)%start_index(j,i), &
5629	surf_def_h(0)%end_index(j,i)
5630	clearnessIndex = surf_def_h(0)%rad_sw_in(m) / horizontalETR
5631	diff_frac = 1.0_wp / &
5632	(1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex))
5633	rad_sw_in_diff(j,i) = surf_def_h(0)%rad_sw_in(m) * diff_frac
5634	rad_sw_in_dir(j,i) = surf_def_h(0)%rad_sw_in(m) * &
5635	(1.0_wp - diff_frac)
5636	rad_lw_in_diff(j,i) = surf_def_h(0)%rad_lw_in(m)
5637	ENDDO
5638	DO m = surf_lsm_h%start_index(j,i), &
5639	surf_lsm_h%end_index(j,i)
5640	clearnessIndex = surf_lsm_h%rad_sw_in(m) / horizontalETR
5641	diff_frac = 1.0_wp / &
5642	(1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex))
5643	rad_sw_in_diff(j,i) = surf_lsm_h%rad_sw_in(m) * diff_frac
5644	rad_sw_in_dir(j,i) = surf_lsm_h%rad_sw_in(m) * &
5645	(1.0_wp - diff_frac)
5646	rad_lw_in_diff(j,i) = surf_lsm_h%rad_lw_in(m)
5647	ENDDO
5648	DO m = surf_usm_h%start_index(j,i), &
5649	surf_usm_h%end_index(j,i)
5650	clearnessIndex = surf_usm_h%rad_sw_in(m) / horizontalETR
5651	diff_frac = 1.0_wp / &
5652	(1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex))
5653	rad_sw_in_diff(j,i) = surf_usm_h%rad_sw_in(m) * diff_frac
5654	rad_sw_in_dir(j,i) = surf_usm_h%rad_sw_in(m) * &
5655	(1.0_wp - diff_frac)
5656	rad_lw_in_diff(j,i) = surf_usm_h%rad_lw_in(m)
5657	ENDDO
5658	ENDDO
5659	ENDDO
5660
5661	END SUBROUTINE calc_diffusion_radiation
5662
5663	!------------------------------------------------------------------------------!
5664	!> Finds first model boundary crossed by a ray
5665	!------------------------------------------------------------------------------!
5666	PURE SUBROUTINE find_boundary_face(origin, uvect, bdycross)
5667
5668	IMPLICIT NONE
5669
5670	INTEGER(iwp) :: d !<
5671	INTEGER(iwp) :: seldim !< found fist crossing index
5672
5673	INTEGER(iwp), DIMENSION(3) :: bdyd !< boundary direction
5674	INTEGER(iwp), DIMENSION(4), INTENT(out) :: bdycross !< found boundary crossing (d, z, y, x)
5675
5676	REAL(wp) :: bdydim !<
5677	REAL(wp) :: dist !<
5678
5679	REAL(wp), DIMENSION(3) :: crossdist !< crossing distance
5680	REAL(wp), DIMENSION(3), INTENT(in) :: origin !< ray origin
5681	REAL(wp), DIMENSION(3), INTENT(in) :: uvect !< ray unit vector
5682
5683
5684	bdydim = nzut + .5_wp !< top boundary
5685	bdyd(1) = isky
5686	crossdist(1) = ( bdydim - origin(1) ) / uvect(1) !< subroutine called only when uvect(1)>0
5687
5688	IF ( uvect(2) == 0._wp ) THEN
5689	crossdist(2) = huge(1._wp)
5690	ELSE
5691	IF ( uvect(2) >= 0._wp ) THEN
5692	bdydim = ny + .5_wp !< north global boundary
5693	bdyd(2) = inorth_b
5694	ELSE
5695	bdydim = -.5_wp !< south global boundary
5696	bdyd(2) = isouth_b
5697	ENDIF
5698	crossdist(2) = ( bdydim - origin(2) ) / uvect(2)
5699	ENDIF
5700
5701	IF ( uvect(3) == 0._wp ) THEN
5702	crossdist(3) = huge(1._wp)
5703	ELSE
5704	IF ( uvect(3) >= 0._wp ) THEN
5705	bdydim = nx + .5_wp !< east global boundary
5706	bdyd(3) = ieast_b
5707	ELSE
5708	bdydim = -.5_wp !< west global boundary
5709	bdyd(3) = iwest_b
5710	ENDIF
5711	crossdist(3) = ( bdydim - origin(3) ) / uvect(3)
5712	ENDIF
5713
5714	seldim = minloc(crossdist, 1)
5715	dist = crossdist(seldim)
5716	d = bdyd(seldim)
5717
5718	bdycross(1) = d
5719	bdycross(2:4) = NINT( origin(:) + uvect(:) * dist &
5720	+ .5_wp * (/ kdir(d), jdir(d), idir(d) /) )
5721
5722	END SUBROUTINE find_boundary_face
5723	!------------------------------------------------------------------------------!
5724	!> Calculates radiation absorbed by box with given size and LAD.
5725	!>
5726	!> Simulates resol**2 rays (by equally spacing a bounding horizontal square
5727	!> conatining all possible rays that would cross the box) and calculates
5728	!> average transparency per ray. Returns fraction of absorbed radiation flux
5729	!> and area for which this fraction is effective.
5730	!------------------------------------------------------------------------------!
5731	PURE SUBROUTINE box_absorb(boxsize, resol, dens, uvec, area, absorb)
5732	IMPLICIT NONE
5733
5734	REAL(wp), DIMENSION(3), INTENT(in) :: &
5735	boxsize, & !< z, y, x size of box in m
5736	uvec !< z, y, x unit vector of incoming flux
5737	INTEGER(iwp), INTENT(in) :: &
5738	resol !< No. of rays in x and y dimensions
5739	REAL(wp), INTENT(in) :: &
5740	dens !< box density (e.g. Leaf Area Density)
5741	REAL(wp), INTENT(out) :: &
5742	area, & !< horizontal area for flux absorbtion
5743	absorb !< fraction of absorbed flux
5744	REAL(wp) :: &
5745	xshift, yshift, &
5746	xmin, xmax, ymin, ymax, &
5747	xorig, yorig, &
5748	dx1, dy1, dz1, dx2, dy2, dz2, &
5749	crdist, &
5750	transp
5751	INTEGER(iwp) :: &
5752	i, j
5753
5754	xshift = uvec(3) / uvec(1) * boxsize(1)
5755	xmin = min(0._wp, -xshift)
5756	xmax = boxsize(3) + max(0._wp, -xshift)
5757	yshift = uvec(2) / uvec(1) * boxsize(1)
5758	ymin = min(0._wp, -yshift)
5759	ymax = boxsize(2) + max(0._wp, -yshift)
5760
5761	transp = 0._wp
5762	DO i = 1, resol
5763	xorig = xmin + (xmax-xmin) * (i-.5_wp) / resol
5764	DO j = 1, resol
5765	yorig = ymin + (ymax-ymin) * (j-.5_wp) / resol
5766
5767	dz1 = 0._wp
5768	dz2 = boxsize(1)/uvec(1)
5769
5770	IF ( uvec(2) > 0._wp ) THEN
5771	dy1 = -yorig / uvec(2) !< crossing with y=0
5772	dy2 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2)
5773	ELSE IF ( uvec(2) < 0._wp ) THEN
5774	dy1 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2)
5775	dy2 = -yorig / uvec(2) !< crossing with y=0
5776	ELSE !uvec(2)==0
5777	dy1 = -huge(1._wp)
5778	dy2 = huge(1._wp)
5779	ENDIF
5780
5781	IF ( uvec(3) > 0._wp ) THEN
5782	dx1 = -xorig / uvec(3) !< crossing with x=0
5783	dx2 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3)
5784	ELSE IF ( uvec(3) < 0._wp ) THEN
5785	dx1 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3)
5786	dx2 = -xorig / uvec(3) !< crossing with x=0
5787	ELSE !uvec(1)==0
5788	dx1 = -huge(1._wp)
5789	dx2 = huge(1._wp)
5790	ENDIF
5791
5792	crdist = max(0._wp, (min(dz2, dy2, dx2) - max(dz1, dy1, dx1)))
5793	transp = transp + exp(-ext_coef * dens * crdist)
5794	ENDDO
5795	ENDDO
5796	transp = transp / resol**2
5797	area = (boxsize(3)+xshift)*(boxsize(2)+yshift)
5798	absorb = 1._wp - transp
5799
5800	END SUBROUTINE box_absorb
5801
5802
5803	END SUBROUTINE radiation_interaction
5804
5805
5806	!------------------------------------------------------------------------------!
5807	! Description:
5808	! ------------
5809	!> Calculates shape view factors SVF and plant sink canopy factors PSCF
5810	!> !!!!!DESCRIPTION!!!!!!!!!!
5811	!------------------------------------------------------------------------------!
5812	SUBROUTINE radiation_calc_svf
5813
5814	IMPLICIT NONE
5815
5816	INTEGER(iwp) :: i, j, k, l, d, ip, jp
5817	INTEGER(iwp) :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrtt, imrtf
5818	INTEGER(iwp) :: sd, td, ioln, iproc
5819	REAL(wp), DIMENSION(0:nsurf_type) :: facearea
5820	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: nzterrl, planthl
5821	REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csflt, pcsflt
5822	INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: kcsflt,kpcsflt
5823	INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: icsflt,dcsflt,ipcsflt,dpcsflt
5824	REAL(wp), DIMENSION(3) :: uv
5825	LOGICAL :: visible
5826	REAL(wp), DIMENSION(3) :: sa, ta !< real coordinates z,y,x of source and target
5827	REAL(wp) :: transparency, rirrf, sqdist, svfsum
5828	INTEGER(iwp) :: isurflt, isurfs, isurflt_prev
5829	INTEGER(iwp) :: itx, ity, itz
5830	CHARACTER(len=7) :: pid_char = ''
5831	INTEGER(iwp) :: win_lad, minfo
5832	REAL(wp), DIMENSION(:,:,:), POINTER :: lad_s_rma !< fortran pointer, but lower bounds are 1
5833	TYPE(c_ptr) :: lad_s_rma_p !< allocated c pointer
5834	#if defined( __parallel )
5835	INTEGER(kind=MPI_ADDRESS_KIND) :: size_lad_rma
5836	#endif
5837	REAL(wp), DIMENSION(0:nsurf_type) :: svf_threshold !< threshold to ignore very small svf between far surfaces
5838
5839	!
5840	!-- calculation of the SVF
5841	CALL location_message( ' calculation of SVF and CSF', .TRUE. )
5842	CALL cpu_log( log_point_s(79), 'radiation_calc_svf', 'start' )
5843	!
5844	!-- precalculate face areas for different face directions using normal vector
5845	DO d = 0, nsurf_type
5846	facearea(d) = 1._wp
5847	IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx
5848	IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy
5849	IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz
5850	ENDDO
5851
5852	!-- calculate the svf threshold
5853	svf_threshold = 0._wp
5854	IF ( dist_max_svf > 0._wp ) THEN
5855	DO d = 0, nsurf_type
5856	sqdist = dist_max_svf * dist_max_svf
5857	svf_threshold(d) = 1._wp / (pi * sqdist) * facearea(d)
5858	ENDDO
5859	ENDIF
5860
5861	!-- initialize variables and temporary arrays for calculation of svf and csf
5862	nsvfl = 0
5863	ncsfl = 0
5864	nsvfla = gasize
5865	msvf = 1
5866	ALLOCATE( asvf1(nsvfla) )
5867	asvf => asvf1
5868	IF ( plant_canopy ) THEN
5869	ncsfla = gasize
5870	mcsf = 1
5871	ALLOCATE( acsf1(ncsfla) )
5872	acsf => acsf1
5873	ENDIF
5874
5875	!-- initialize temporary terrain and plant canopy height arrays (global 2D array!)
5876	ALLOCATE( nzterr(0:(nx+1)*(ny+1)-1) )
5877	#if defined( __parallel )
5878	ALLOCATE( nzterrl(nys:nyn,nxl:nxr) )
5879	nzterrl = get_topography_top_index( 's' )
5880	CALL MPI_AllGather( nzterrl, nnx*nny, MPI_INTEGER, &
5881	nzterr, nnx*nny, MPI_INTEGER, comm2d, ierr )
5882	DEALLOCATE(nzterrl)
5883	#else
5884	nzterr = RESHAPE( get_topography_top_index( 's' ), (/(nx+1)*(ny+1)/) )
5885	#endif
5886	IF ( plant_canopy ) THEN
5887	ALLOCATE( plantt(0:(nx+1)*(ny+1)-1) )
5888	maxboxesg = nx + ny + nzu + 1
5889	!-- temporary arrays storing values for csf calculation during raytracing
5890	ALLOCATE( boxes(3, maxboxesg) )
5891	ALLOCATE( crlens(maxboxesg) )
5892
5893	#if defined( __parallel )
5894	ALLOCATE( planthl(nys:nyn,nxl:nxr) )
5895	planthl = pch(nys:nyn,nxl:nxr)
5896
5897	CALL MPI_AllGather( planthl, nnx*nny, MPI_INTEGER, &
5898	plantt, nnx*nny, MPI_INTEGER, comm2d, ierr )
5899	DEALLOCATE( planthl )
5900
5901	!-- temporary arrays storing values for csf calculation during raytracing
5902	ALLOCATE( lad_ip(maxboxesg) )
5903	ALLOCATE( lad_disp(maxboxesg) )
5904
5905	IF ( usm_lad_rma ) THEN
5906	ALLOCATE( lad_s_ray(maxboxesg) )
5907
5908	! set conditions for RMA communication
5909	CALL MPI_Info_create(minfo, ierr)
5910	CALL MPI_Info_set(minfo, 'accumulate_ordering', '', ierr)
5911	CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr)
5912	CALL MPI_Info_set(minfo, 'same_size', 'true', ierr)
5913	CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr)
5914
5915	!-- Allocate and initialize the MPI RMA window
5916	!-- must be in accordance with allocation of lad_s in plant_canopy_model
5917	!-- optimization of memory should be done
5918	!-- Argument X of function STORAGE_SIZE(X) needs arbitrary REAL(wp) value, set to 1.0_wp for now
5919	size_lad_rma = STORAGE_SIZE(1.0_wp)/8nnxnny*nzu
5920	CALL MPI_Win_allocate(size_lad_rma, STORAGE_SIZE(1.0_wp)/8, minfo, comm2d, &
5921	lad_s_rma_p, win_lad, ierr)
5922	CALL c_f_pointer(lad_s_rma_p, lad_s_rma, (/ nzu, nny, nnx /))
5923	usm_lad(nzub:, nys:, nxl:) => lad_s_rma(:,:,:)
5924	ELSE
5925	ALLOCATE(usm_lad(nzub:nzut, nys:nyn, nxl:nxr))
5926	ENDIF
5927	#else
5928	plantt = RESHAPE( pct(nys:nyn,nxl:nxr), (/(nx+1)*(ny+1)/) )
5929	ALLOCATE(usm_lad(nzub:nzut, nys:nyn, nxl:nxr))
5930	#endif
5931	usm_lad(:,:,:) = 0._wp
5932	DO i = nxl, nxr
5933	DO j = nys, nyn
5934	k = get_topography_top_index_ji( j, i, 's' )
5935
5936	usm_lad(k:nzut, j, i) = lad_s(0:nzut-k, j, i)
5937	ENDDO
5938	ENDDO
5939
5940	#if defined( __parallel )
5941	IF ( usm_lad_rma ) THEN
5942	CALL MPI_Info_free(minfo, ierr)
5943	CALL MPI_Win_lock_all(0, win_lad, ierr)
5944	ELSE
5945	ALLOCATE( usm_lad_g(0:(nx+1)(ny+1)nzu-1) )
5946	CALL MPI_AllGather( usm_lad, nnxnnynzu, MPI_REAL, &
5947	usm_lad_g, nnxnnynzu, MPI_REAL, comm2d, ierr )
5948	ENDIF
5949	#endif
5950	ENDIF
5951
5952	IF ( mrt_factors ) THEN
5953	OPEN(153, file='MRT_TARGETS', access='SEQUENTIAL', &
5954	action='READ', status='OLD', form='FORMATTED', err=524)
5955	OPEN(154, file='MRT_FACTORS'//myid_char, access='DIRECT', recl=(54+28), &
5956	action='WRITE', status='REPLACE', form='UNFORMATTED', err=525)
5957	imrtf = 1
5958	DO
5959	READ(153, *, end=526, err=524) imrtt, i, j, k
5960	IF ( i < nxl .OR. i > nxr &
5961	.OR. j < nys .OR. j > nyn ) CYCLE
5962	ta = (/ REAL(k), REAL(j), REAL(i) /)
5963
5964	DO isurfs = 1, nsurf
5965	IF ( .NOT. surface_facing(i, j, k, -1, &
5966	surf(ix, isurfs), surf(iy, isurfs), &
5967	surf(iz, isurfs), surf(id, isurfs)) ) THEN
5968	CYCLE
5969	ENDIF
5970
5971	sd = surf(id, isurfs)
5972	sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd), &
5973	REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd), &
5974	REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd) /)
5975
5976	!-- unit vector source -> target
5977	uv = (/ (ta(1)-sa(1))dz, (ta(2)-sa(2))dy, (ta(3)-sa(3))*dx /)
5978	sqdist = SUM(uv(:)**2)
5979	uv = uv / SQRT(sqdist)
5980
5981	!-- irradiance factor - see svf. Here we consider that target face is always normal,
5982	!-- i.e. the second dot product equals 1
5983	rirrf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) &
5984	/ (pi * sqdist) * facearea(sd)
5985
5986	!-- raytrace while not creating any canopy sink factors
5987	CALL raytrace(sa, ta, isurfs, rirrf, 1._wp, .FALSE., &
5988	visible, transparency, win_lad)
5989	IF ( .NOT. visible ) CYCLE
5990
5991	!rsvf = rirrf * transparency
5992	WRITE(154, rec=imrtf, err=525) INT(imrtt, kind=4), &
5993	INT(surf(id, isurfs), kind=4), &
5994	INT(surf(iz, isurfs), kind=4), &
5995	INT(surf(iy, isurfs), kind=4), &
5996	INT(surf(ix, isurfs), kind=4), &
5997	REAL(rirrf, kind=8), REAL(transparency, kind=8)
5998	imrtf = imrtf + 1
5999
6000	ENDDO !< isurfs
6001	ENDDO !< MRT_TARGETS record
6002
6003	524 message_string = 'error reading file MRT_TARGETS'
6004	CALL message( 'radiation_calc_svf', 'PA0524', 1, 2, 0, 6, 0 )
6005
6006	525 message_string = 'error writing file MRT_FACTORS'//myid_char
6007	CALL message( 'radiation_calc_svf', 'PA0525', 1, 2, 0, 6, 0 )
6008
6009	526 CLOSE(153)
6010	CLOSE(154)
6011	ENDIF !< mrt_factors
6012
6013
6014	DO isurflt = 1, nsurfl
6015	!-- determine face centers
6016	td = surfl(id, isurflt)
6017	IF ( td >= isky .AND. .NOT. plant_canopy ) CYCLE
6018	ta = (/ REAL(surfl(iz, isurflt), wp) - 0.5_wp * kdir(td), &
6019	REAL(surfl(iy, isurflt), wp) - 0.5_wp * jdir(td), &
6020	REAL(surfl(ix, isurflt), wp) - 0.5_wp * idir(td) /)
6021	DO isurfs = 1, nsurf
6022	!-- cycle for atmospheric surfaces since they are not source surfaces
6023	sd = surf(id, isurfs)
6024	IF ( sd > iwest_l .AND. sd < isky ) CYCLE
6025	!-- if reflections between target surfaces (urban and land) are neglected (surf_reflection set to
6026	!-- FALSE) cycle. This will reduce the number of SVFs and keep SVFs between only ertual surfaces to
6027	!-- physical surfaces
6028	IF ( .NOT. surf_reflections .AND. sd < isky ) CYCLE
6029	!-- cycle if the target and the source surfaces are not facing each other
6030	IF ( .NOT. surface_facing(surfl(ix, isurflt), surfl(iy, isurflt), &
6031	surfl(iz, isurflt), surfl(id, isurflt), &
6032	surf(ix, isurfs), surf(iy, isurfs), &
6033	surf(iz, isurfs), surf(id, isurfs)) ) THEN
6034	CYCLE
6035	ENDIF
6036
6037	sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd), &
6038	REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd), &
6039	REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd) /)
6040
6041	!-- unit vector source -> target
6042	uv = (/ (ta(1)-sa(1))dz, (ta(2)-sa(2))dy, (ta(3)-sa(3))*dx /)
6043	sqdist = SUM(uv(:)**2)
6044	uv = uv / SQRT(sqdist)
6045
6046	!-- irradiance factor (our unshaded shape view factor) = view factor per differential target area * source area
6047	rirrf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) & ! cosine of source normal and direction
6048	* dot_product((/ kdir(td), jdir(td), idir(td) /), -uv) & ! cosine of target normal and reverse direction
6049	/ (pi * sqdist) & ! square of distance between centers
6050	* facearea(sd)
6051
6052	!-- skip svf less than svf_threshold
6053	IF ( rirrf < svf_threshold(sd) .AND. sd < isky ) CYCLE
6054
6055	!-- raytrace + process plant canopy sinks within
6056	CALL raytrace(sa, ta, isurfs, rirrf, facearea(td), .TRUE., &
6057	visible, transparency, win_lad)
6058
6059	IF ( .NOT. visible ) CYCLE
6060	IF ( td >= isky ) CYCLE !< we calculated these only for raytracing
6061	!< to find plant canopy sinks, we don't need svf for them
6062
6063	!-- write to the svf array
6064	nsvfl = nsvfl + 1
6065	!-- check dimmension of asvf array and enlarge it if needed
6066	IF ( nsvfla < nsvfl ) THEN
6067	k = nsvfla * 2
6068	IF ( msvf == 0 ) THEN
6069	msvf = 1
6070	ALLOCATE( asvf1(k) )
6071	asvf => asvf1
6072	asvf1(1:nsvfla) = asvf2
6073	DEALLOCATE( asvf2 )
6074	ELSE
6075	msvf = 0
6076	ALLOCATE( asvf2(k) )
6077	asvf => asvf2
6078	asvf2(1:nsvfla) = asvf1
6079	DEALLOCATE( asvf1 )
6080	ENDIF
6081	nsvfla = k
6082	ENDIF
6083	!-- write svf values into the array
6084	asvf(nsvfl)%isurflt = isurflt
6085	asvf(nsvfl)%isurfs = isurfs
6086	asvf(nsvfl)%rsvf = rirrf !we postopne multiplication by transparency
6087	asvf(nsvfl)%rtransp = transparency !a.k.a. Direct Irradiance Factor
6088	ENDDO
6089	ENDDO
6090
6091	CALL location_message( ' waiting for completion of SVF and CSF calculation in all processes', .TRUE. )
6092	!-- deallocate temporary global arrays
6093	DEALLOCATE(nzterr)
6094
6095	IF ( plant_canopy ) THEN
6096	!-- finalize mpi_rma communication and deallocate temporary arrays
6097	#if defined( __parallel )
6098	IF ( usm_lad_rma ) THEN
6099	CALL MPI_Win_flush_all(win_lad, ierr)
6100	!-- unlock MPI window
6101	CALL MPI_Win_unlock_all(win_lad, ierr)
6102	!-- free MPI window
6103	CALL MPI_Win_free(win_lad, ierr)
6104
6105	!-- deallocate temporary arrays storing values for csf calculation during raytracing
6106	DEALLOCATE( lad_s_ray )
6107	!-- usm_lad is the pointer to lad_s_rma in case of usm_lad_rma
6108	!-- and must not be deallocated here
6109	ELSE
6110	DEALLOCATE(usm_lad)
6111	DEALLOCATE(usm_lad_g)
6112	ENDIF
6113	#else
6114	DEALLOCATE(usm_lad)
6115	#endif
6116	DEALLOCATE( boxes )
6117	DEALLOCATE( crlens )
6118	DEALLOCATE( plantt )
6119	ENDIF
6120
6121	CALL location_message( ' calculation of the complete SVF array', .TRUE. )
6122
6123	!-- sort svf ( a version of quicksort )
6124	CALL quicksort_svf(asvf,1,nsvfl)
6125
6126	ALLOCATE( svf(ndsvf,nsvfl) )
6127	ALLOCATE( svfsurf(idsvf,nsvfl) )
6128
6129	!< load svf from the structure array to plain arrays
6130	isurflt_prev = -1
6131	ksvf = 1
6132	svfsum = 0._wp
6133	DO isvf = 1, nsvfl
6134	!-- normalize svf per target face
6135	IF ( asvf(ksvf)%isurflt /= isurflt_prev ) THEN
6136	IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN
6137	!-- TODO detect and log when normalization differs too much from 1
6138	svf(1, isvf_surflt:isvf-1) = svf(1, isvf_surflt:isvf-1) / svfsum
6139	ENDIF
6140	isurflt_prev = asvf(ksvf)%isurflt
6141	isvf_surflt = isvf
6142	svfsum = asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp
6143	ELSE
6144	svfsum = svfsum + asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp
6145	ENDIF
6146
6147	svf(:, isvf) = (/ asvf(ksvf)%rsvf, asvf(ksvf)%rtransp /)
6148	svfsurf(:, isvf) = (/ asvf(ksvf)%isurflt, asvf(ksvf)%isurfs /)
6149
6150	!-- next element
6151	ksvf = ksvf + 1
6152	ENDDO
6153
6154	IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN
6155	!-- TODO detect and log when normalization differs too much from 1
6156	svf(1, isvf_surflt:nsvfl) = svf(1, isvf_surflt:nsvfl) / svfsum
6157	ENDIF
6158
6159	!-- deallocate temporary asvf array
6160	!-- DEALLOCATE(asvf) - ifort has a problem with deallocation of allocatable target
6161	!-- via pointing pointer - we need to test original targets
6162	IF ( ALLOCATED(asvf1) ) THEN
6163	DEALLOCATE(asvf1)
6164	ENDIF
6165	IF ( ALLOCATED(asvf2) ) THEN
6166	DEALLOCATE(asvf2)
6167	ENDIF
6168
6169	npcsfl = 0
6170	IF ( plant_canopy ) THEN
6171
6172	CALL location_message( ' calculation of the complete CSF array', .TRUE. )
6173
6174	!-- sort and merge csf for the last time, keeping the array size to minimum
6175	CALL merge_and_grow_csf(-1)
6176
6177	!-- aggregate csb among processors
6178	!-- allocate necessary arrays
6179	ALLOCATE( csflt(ndcsf,max(ncsfl,ndcsf)) )
6180	ALLOCATE( kcsflt(kdcsf,max(ncsfl,kdcsf)) )
6181	ALLOCATE( icsflt(0:numprocs-1) )
6182	ALLOCATE( dcsflt(0:numprocs-1) )
6183	ALLOCATE( ipcsflt(0:numprocs-1) )
6184	ALLOCATE( dpcsflt(0:numprocs-1) )
6185
6186	!-- fill out arrays of csf values and
6187	!-- arrays of number of elements and displacements
6188	!-- for particular precessors
6189	icsflt = 0
6190	dcsflt = 0
6191	ip = -1
6192	j = -1
6193	d = 0
6194	DO kcsf = 1, ncsfl
6195	j = j+1
6196	IF ( acsf(kcsf)%ip /= ip ) THEN
6197	!-- new block of the processor
6198	!-- number of elements of previous block
6199	IF ( ip>=0) icsflt(ip) = j
6200	d = d+j
6201	!-- blank blocks
6202	DO jp = ip+1, acsf(kcsf)%ip-1
6203	!-- number of elements is zero, displacement is equal to previous
6204	icsflt(jp) = 0
6205	dcsflt(jp) = d
6206	ENDDO
6207	!-- the actual block
6208	ip = acsf(kcsf)%ip
6209	dcsflt(ip) = d
6210	j = 0
6211	ENDIF
6212	!-- fill out real values of rsvf, rtransp
6213	csflt(1,kcsf) = acsf(kcsf)%rsvf
6214	csflt(2,kcsf) = acsf(kcsf)%rtransp
6215	!-- fill out integer values of itz,ity,itx,isurfs
6216	kcsflt(1,kcsf) = acsf(kcsf)%itz
6217	kcsflt(2,kcsf) = acsf(kcsf)%ity
6218	kcsflt(3,kcsf) = acsf(kcsf)%itx
6219	kcsflt(4,kcsf) = acsf(kcsf)%isurfs
6220	ENDDO
6221	!-- last blank blocks at the end of array
6222	j = j+1
6223	IF ( ip>=0 ) icsflt(ip) = j
6224	d = d+j
6225	DO jp = ip+1, numprocs-1
6226	!-- number of elements is zero, displacement is equal to previous
6227	icsflt(jp) = 0
6228	dcsflt(jp) = d
6229	ENDDO
6230
6231	!-- deallocate temporary acsf array
6232	!-- DEALLOCATE(acsf) - ifort has a problem with deallocation of allocatable target
6233	!-- via pointing pointer - we need to test original targets
6234	IF ( ALLOCATED(acsf1) ) THEN
6235	DEALLOCATE(acsf1)
6236	ENDIF
6237	IF ( ALLOCATED(acsf2) ) THEN
6238	DEALLOCATE(acsf2)
6239	ENDIF
6240
6241	#if defined( __parallel )
6242	!-- scatter and gather the number of elements to and from all processor
6243	!-- and calculate displacements
6244	CALL MPI_AlltoAll(icsflt,1,MPI_INTEGER,ipcsflt,1,MPI_INTEGER,comm2d, ierr)
6245
6246	npcsfl = SUM(ipcsflt)
6247	d = 0
6248	DO i = 0, numprocs-1
6249	dpcsflt(i) = d
6250	d = d + ipcsflt(i)
6251	ENDDO
6252
6253	!-- exchange csf fields between processors
6254	ALLOCATE( pcsflt(ndcsf,max(npcsfl,ndcsf)) )
6255	ALLOCATE( kpcsflt(kdcsf,max(npcsfl,kdcsf)) )
6256	CALL MPI_AlltoAllv(csflt, ndcsficsflt, ndcsfdcsflt, MPI_REAL, &
6257	pcsflt, ndcsfipcsflt, ndcsfdpcsflt, MPI_REAL, comm2d, ierr)
6258	CALL MPI_AlltoAllv(kcsflt, kdcsficsflt, kdcsfdcsflt, MPI_INTEGER, &
6259	kpcsflt, kdcsfipcsflt, kdcsfdpcsflt, MPI_INTEGER, comm2d, ierr)
6260
6261	#else
6262	npcsfl = ncsfl
6263	ALLOCATE( pcsflt(ndcsf,max(npcsfl,ndcsf)) )
6264	ALLOCATE( kpcsflt(kdcsf,max(npcsfl,kdcsf)) )
6265	pcsflt = csflt
6266	kpcsflt = kcsflt
6267	#endif
6268
6269	!-- deallocate temporary arrays
6270	DEALLOCATE( csflt )
6271	DEALLOCATE( kcsflt )
6272	DEALLOCATE( icsflt )
6273	DEALLOCATE( dcsflt )
6274	DEALLOCATE( ipcsflt )
6275	DEALLOCATE( dpcsflt )
6276
6277	!-- sort csf ( a version of quicksort )
6278	CALL quicksort_csf2(kpcsflt, pcsflt, 1, npcsfl)
6279
6280	!-- aggregate canopy sink factor records with identical box & source
6281	!-- againg across all values from all processors
6282	IF ( npcsfl > 0 ) THEN
6283	icsf = 1 !< reading index
6284	kcsf = 1 !< writing index
6285	DO while (icsf < npcsfl)
6286	!-- here kpcsf(kcsf) already has values from kpcsf(icsf)
6287	IF ( kpcsflt(3,icsf) == kpcsflt(3,icsf+1) .AND. &
6288	kpcsflt(2,icsf) == kpcsflt(2,icsf+1) .AND. &
6289	kpcsflt(1,icsf) == kpcsflt(1,icsf+1) .AND. &
6290	kpcsflt(4,icsf) == kpcsflt(4,icsf+1) ) THEN
6291	!-- We could simply take either first or second rtransp, both are valid. As a very simple heuristic about which ray
6292	!-- probably passes nearer the center of the target box, we choose DIF from the entry with greater CSF, since that
6293	!-- might mean that the traced beam passes longer through the canopy box.
6294	IF ( pcsflt(1,kcsf) < pcsflt(1,icsf+1) ) THEN
6295	pcsflt(2,kcsf) = pcsflt(2,icsf+1)
6296	ENDIF
6297	pcsflt(1,kcsf) = pcsflt(1,kcsf) + pcsflt(1,icsf+1)
6298
6299	!-- advance reading index, keep writing index
6300	icsf = icsf + 1
6301	ELSE
6302	!-- not identical, just advance and copy
6303	icsf = icsf + 1
6304	kcsf = kcsf + 1
6305	kpcsflt(:,kcsf) = kpcsflt(:,icsf)
6306	pcsflt(:,kcsf) = pcsflt(:,icsf)
6307	ENDIF
6308	ENDDO
6309	!-- last written item is now also the last item in valid part of array
6310	npcsfl = kcsf
6311	ENDIF
6312
6313	ncsfl = npcsfl
6314	IF ( ncsfl > 0 ) THEN
6315	ALLOCATE( csf(ndcsf,ncsfl) )
6316	ALLOCATE( csfsurf(idcsf,ncsfl) )
6317	DO icsf = 1, ncsfl
6318	csf(:,icsf) = pcsflt(:,icsf)
6319	csfsurf(1,icsf) = gridpcbl(kpcsflt(1,icsf),kpcsflt(2,icsf),kpcsflt(3,icsf))
6320	csfsurf(2,icsf) = kpcsflt(4,icsf)
6321	ENDDO
6322	ENDIF
6323
6324	!-- deallocation of temporary arrays
6325	DEALLOCATE( pcsflt )
6326	DEALLOCATE( kpcsflt )
6327	IF ( ALLOCATED( gridpcbl ) ) DEALLOCATE( gridpcbl )
6328
6329	ENDIF
6330
6331	RETURN
6332
6333	301 WRITE( message_string, * ) &
6334	'I/O error when processing shape view factors / ', &
6335	'plant canopy sink factors / direct irradiance factors.'
6336	CALL message( 'init_urban_surface', 'PA0502', 2, 2, 0, 6, 0 )
6337
6338	CALL cpu_log( log_point_s(79), 'radiation_calc_svf', 'stop' )
6339
6340
6341	END SUBROUTINE radiation_calc_svf
6342
6343
6344	!------------------------------------------------------------------------------!
6345	! Description:
6346	! ------------
6347	!> Raytracing for detecting obstacles and calculating compound canopy sink
6348	!> factors. (A simple obstacle detection would only need to process faces in
6349	!> 3 dimensions without any ordering.)
6350	!> Assumtions:
6351	!> -----------
6352	!> 1. The ray always originates from a face midpoint (only one coordinate equals
6353	!> *.5, i.e. wall) and doesn't travel parallel to the surface (that would mean
6354	!> shape factor=0). Therefore, the ray may never travel exactly along a face
6355	!> or an edge.
6356	!> 2. From grid bottom to urban surface top the grid has to be equidistant
6357	!> within each of the dimensions, including vertical (but the resolution
6358	!> doesn't need to be the same in all three dimensions).
6359	!------------------------------------------------------------------------------!
6360	SUBROUTINE raytrace(src, targ, isrc, rirrf, atarg, create_csf, visible, transparency, win_lad)
6361	IMPLICIT NONE
6362
6363	REAL(wp), DIMENSION(3), INTENT(in) :: src, targ !< real coordinates z,y,x
6364	INTEGER(iwp), INTENT(in) :: isrc !< index of source face for csf
6365	REAL(wp), INTENT(in) :: rirrf !< irradiance factor for csf
6366	REAL(wp), INTENT(in) :: atarg !< target surface area for csf
6367	LOGICAL, INTENT(in) :: create_csf !< whether to generate new CSFs during raytracing
6368	LOGICAL, INTENT(out) :: visible
6369	REAL(wp), INTENT(out) :: transparency !< along whole path
6370	INTEGER(iwp), INTENT(in) :: win_lad
6371	INTEGER(iwp) :: i, j, k, d
6372	INTEGER(iwp) :: seldim !< dimension to be incremented
6373	INTEGER(iwp) :: ncsb !< no of written plant canopy sinkboxes
6374	INTEGER(iwp) :: maxboxes !< max no of gridboxes visited
6375	REAL(wp) :: distance !< euclidean along path
6376	REAL(wp) :: crlen !< length of gridbox crossing
6377	REAL(wp) :: lastdist !< beginning of current crossing
6378	REAL(wp) :: nextdist !< end of current crossing
6379	REAL(wp) :: realdist !< distance in meters per unit distance
6380	REAL(wp) :: crmid !< midpoint of crossing
6381	REAL(wp) :: cursink !< sink factor for current canopy box
6382	REAL(wp), DIMENSION(3) :: delta !< path vector
6383	REAL(wp), DIMENSION(3) :: uvect !< unit vector
6384	REAL(wp), DIMENSION(3) :: dimnextdist !< distance for each dimension increments
6385	INTEGER(iwp), DIMENSION(3) :: box !< gridbox being crossed
6386	INTEGER(iwp), DIMENSION(3) :: dimnext !< next dimension increments along path
6387	INTEGER(iwp), DIMENSION(3) :: dimdelta !< dimension direction = +- 1
6388	INTEGER(iwp) :: px, py !< number of processors in x and y dir before
6389	!< the processor in the question
6390	INTEGER(iwp) :: ip !< number of processor where gridbox reside
6391	INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array
6392	REAL(wp) :: lad_s_target !< recieved lad_s of particular grid box
6393	REAL(wp), PARAMETER :: grow_factor = 1.5_wp !< factor of expansion of grow arrays
6394
6395	!
6396	!-- Maximum number of gridboxes visited equals to maximum number of boundaries crossed in each dimension plus one. That's also
6397	!-- the maximum number of plant canopy boxes written. We grow the acsf array accordingly using exponential factor.
6398	maxboxes = SUM(ABS(NINT(targ) - NINT(src))) + 1
6399	IF ( plant_canopy .AND. ncsfl + maxboxes > ncsfla ) THEN
6400	!-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1)
6401	!-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) &
6402	!-- / log(grow_factor)), kind=wp))
6403	!-- or use this code to simply always keep some extra space after growing
6404	k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor)
6405
6406	CALL merge_and_grow_csf(k)
6407	ENDIF
6408
6409	transparency = 1._wp
6410	ncsb = 0
6411
6412	delta(:) = targ(:) - src(:)
6413	distance = SQRT(SUM(delta(:)**2))
6414	IF ( distance == 0._wp ) THEN
6415	visible = .TRUE.
6416	RETURN
6417	ENDIF
6418	uvect(:) = delta(:) / distance
6419	realdist = SQRT(SUM( (uvect(:)(/dz,dy,dx/))*2 ))
6420
6421	lastdist = 0._wp
6422
6423	!-- Since all face coordinates have values *.5 and we'd like to use
6424	!-- integers, all these have .5 added
6425	DO d = 1, 3
6426	IF ( uvect(d) == 0._wp ) THEN
6427	dimnext(d) = 999999999
6428	dimdelta(d) = 999999999
6429	dimnextdist(d) = 1.0E20_wp
6430	ELSE IF ( uvect(d) > 0._wp ) THEN
6431	dimnext(d) = CEILING(src(d) + .5_wp)
6432	dimdelta(d) = 1
6433	dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d)
6434	ELSE
6435	dimnext(d) = FLOOR(src(d) + .5_wp)
6436	dimdelta(d) = -1
6437	dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d)
6438	ENDIF
6439	ENDDO
6440
6441	DO
6442	!-- along what dimension will the next wall crossing be?
6443	seldim = minloc(dimnextdist, 1)
6444	nextdist = dimnextdist(seldim)
6445	IF ( nextdist > distance ) nextdist = distance
6446
6447	crlen = nextdist - lastdist
6448	IF ( crlen > .001_wp ) THEN
6449	crmid = (lastdist + nextdist) * .5_wp
6450	box = NINT(src(:) + uvect(:) * crmid)
6451
6452	!-- calculate index of the grid with global indices (box(2),box(3))
6453	!-- in the array nzterr and plantt and id of the coresponding processor
6454	px = box(3)/nnx
6455	py = box(2)/nny
6456	ip = px*pdims(2)+py
6457	ig = ipnnxnny + (box(3)-pxnnx)nny + box(2)-py*nny
6458	IF ( box(1) <= nzterr(ig) ) THEN
6459	visible = .FALSE.
6460	RETURN
6461	ENDIF
6462
6463	IF ( plant_canopy ) THEN
6464	IF ( box(1) <= plantt(ig) ) THEN
6465	ncsb = ncsb + 1
6466	boxes(:,ncsb) = box
6467	crlens(ncsb) = crlen
6468	#if defined( __parallel )
6469	lad_ip(ncsb) = ip
6470	lad_disp(ncsb) = (box(3)-pxnnx)(nnynzu) + (box(2)-pynny)*nzu + box(1)-nzub
6471	#endif
6472	ENDIF
6473	ENDIF
6474	ENDIF
6475
6476	IF ( nextdist >= distance ) EXIT
6477	lastdist = nextdist
6478	dimnext(seldim) = dimnext(seldim) + dimdelta(seldim)
6479	dimnextdist(seldim) = (dimnext(seldim) - .5_wp - src(seldim)) / uvect(seldim)
6480	ENDDO
6481
6482	IF ( plant_canopy ) THEN
6483	#if defined( __parallel )
6484	IF ( usm_lad_rma ) THEN
6485	!-- send requests for lad_s to appropriate processor
6486	CALL cpu_log( log_point_s(77), 'usm_init_rma', 'start' )
6487	DO i = 1, ncsb
6488	CALL MPI_Get(lad_s_ray(i), 1, MPI_REAL, lad_ip(i), lad_disp(i), &
6489	1, MPI_REAL, win_lad, ierr)
6490	IF ( ierr /= 0 ) THEN
6491	WRITE(message_string, *) 'MPI error ', ierr, ' at MPI_Get'
6492	CALL message( 'raytrace', 'PA0519', 1, 2, 0, 6, 0 )
6493	ENDIF
6494	ENDDO
6495
6496	!-- wait for all pending local requests complete
6497	CALL MPI_Win_flush_local_all(win_lad, ierr)
6498	IF ( ierr /= 0 ) THEN
6499	WRITE(message_string, *) 'MPI error ', ierr, ' at MPI_Win_flush_local_all'
6500	CALL message( 'raytrace', 'PA0519', 1, 2, 0, 6, 0 )
6501	ENDIF
6502	CALL cpu_log( log_point_s(77), 'usm_init_rma', 'stop' )
6503
6504	ENDIF
6505	#endif
6506
6507	!-- calculate csf and transparency
6508	DO i = 1, ncsb
6509	#if defined( __parallel )
6510	IF ( usm_lad_rma ) THEN
6511	lad_s_target = lad_s_ray(i)
6512	ELSE
6513	lad_s_target = usm_lad_g(lad_ip(i)nnxnny*nzu + lad_disp(i))
6514	ENDIF
6515	#else
6516	lad_s_target = usm_lad(boxes(1,i),boxes(2,i),boxes(3,i))
6517	#endif
6518	cursink = 1._wp - exp(-ext_coef * lad_s_target * crlens(i)*realdist)
6519
6520	IF ( create_csf ) THEN
6521	!-- write svf values into the array
6522	ncsfl = ncsfl + 1
6523	acsf(ncsfl)%ip = lad_ip(i)
6524	acsf(ncsfl)%itx = boxes(3,i)
6525	acsf(ncsfl)%ity = boxes(2,i)
6526	acsf(ncsfl)%itz = boxes(1,i)
6527	acsf(ncsfl)%isurfs = isrc
6528	acsf(ncsfl)%rsvf = REAL(cursinkrirrfatarg, wp) !-- we postpone multiplication by transparency
6529	acsf(ncsfl)%rtransp = REAL(transparency, wp)
6530	ENDIF !< create_csf
6531
6532	transparency = transparency * (1._wp - cursink)
6533
6534	ENDDO
6535	ENDIF
6536
6537	visible = .TRUE.
6538
6539	END SUBROUTINE raytrace
6540
6541
6542	!------------------------------------------------------------------------------!
6543	! Description:
6544	! ------------
6545	!> Determines whether two faces are oriented towards each other. Since the
6546	!> surfaces follow the gird box surfaces, it checks first whether the two surfaces
6547	!> are directed in the same direction, then it checks if the two surfaces are
6548	!> located in confronted direction but facing away from each other, e.g. <--\| \|-->
6549	!------------------------------------------------------------------------------!
6550	PURE LOGICAL FUNCTION surface_facing(x, y, z, d, x2, y2, z2, d2)
6551	IMPLICIT NONE
6552	INTEGER(iwp), INTENT(in) :: x, y, z, d, x2, y2, z2, d2
6553
6554	surface_facing = .FALSE.
6555
6556	!-- first check: are the two surfaces directed in the same direction
6557	IF ( (d==iup_u .OR. d==iup_l .OR. d==iup_a ) &
6558	.AND. (d2==iup_u .OR. d2==iup_l) ) RETURN
6559	IF ( (d==isky .OR. d==idown_a) .AND. d2==isky ) RETURN
6560	IF ( (d==isouth_u .OR. d==isouth_l .OR. d==isouth_a .OR. d==inorth_b ) &
6561	.AND. (d2==isouth_u .OR. d2==isouth_l .OR. d2==inorth_b) ) RETURN
6562	IF ( (d==inorth_u .OR. d==inorth_l .OR. d==inorth_a .OR. d==isouth_b ) &
6563	.AND. (d2==inorth_u .OR. d2==inorth_l .OR. d2==isouth_b) ) RETURN
6564	IF ( (d==iwest_u .OR. d==iwest_l .OR. d==iwest_a .OR. d==ieast_b ) &
6565	.AND. (d2==iwest_u .OR. d2==iwest_l .OR. d2==ieast_b ) ) RETURN
6566	IF ( (d==ieast_u .OR. d==ieast_l .OR. d==ieast_a .OR. d==iwest_b ) &
6567	.AND. (d2==ieast_u .OR. d2==ieast_l .OR. d2==iwest_b ) ) RETURN
6568
6569	!-- second check: are surfaces facing away from each other
6570	SELECT CASE (d)
6571	CASE (iup_u, iup_l, iup_a) !< upward facing surfaces
6572	IF ( z2 < z ) RETURN
6573	CASE (isky, idown_a) !< downward facing surfaces
6574	IF ( z2 > z ) RETURN
6575	CASE (isouth_u, isouth_l, isouth_a, inorth_b) !< southward facing surfaces
6576	IF ( y2 > y ) RETURN
6577	CASE (inorth_u, inorth_l, inorth_a, isouth_b) !< northward facing surfaces
6578	IF ( y2 < y ) RETURN
6579	CASE (iwest_u, iwest_l, iwest_a, ieast_b) !< westward facing surfaces
6580	IF ( x2 > x ) RETURN
6581	CASE (ieast_u, ieast_l, ieast_a, iwest_b) !< eastward facing surfaces
6582	IF ( x2 < x ) RETURN
6583	END SELECT
6584
6585	SELECT CASE (d2)
6586	CASE (iup_u) !< ground, roof
6587	IF ( z < z2 ) RETURN
6588	CASE (isky) !< sky
6589	IF ( z > z2 ) RETURN
6590	CASE (isouth_u, isouth_l, inorth_b) !< south facing
6591	IF ( y > y2 ) RETURN
6592	CASE (inorth_u, inorth_l, isouth_b) !< north facing
6593	IF ( y < y2 ) RETURN
6594	CASE (iwest_u, iwest_l, ieast_b) !< west facing
6595	IF ( x > x2 ) RETURN
6596	CASE (ieast_u, ieast_l, iwest_b) !< east facing
6597	IF ( x < x2 ) RETURN
6598	CASE (-1)
6599	CONTINUE
6600	END SELECT
6601
6602	surface_facing = .TRUE.
6603
6604	END FUNCTION surface_facing
6605
6606	!------------------------------------------------------------------------------!
6607	!
6608	! Description:
6609	! ------------
6610	!> Soubroutine reads svf and svfsurf data from saved file
6611	!------------------------------------------------------------------------------!
6612	SUBROUTINE radiation_read_svf
6613
6614	IMPLICIT NONE
6615	INTEGER(iwp) :: fsvf = 89
6616	INTEGER(iwp) :: i
6617	CHARACTER(usm_version_len) :: usm_version_field
6618	CHARACTER(svf_code_len) :: svf_code_field
6619
6620	DO i = 0, io_blocks-1
6621	IF ( i == io_group ) THEN
6622	OPEN ( fsvf, FILE='SVFIN'//TRIM(coupling_char)//'/'//myid_char,&
6623	form='unformatted', status='old' )
6624
6625	!-- read and check version
6626	READ ( fsvf ) usm_version_field
6627	IF ( TRIM(usm_version_field) /= TRIM(usm_version) ) THEN
6628	WRITE( message_string, * ) 'Version of binary SVF file "', &
6629	TRIM(usm_version_field), '" does not match ', &
6630	'the version of model "', TRIM(usm_version), '"'
6631	CALL message( 'radiation_read_svf', 'UI0012', 1, 2, 0, 6, 0 )
6632	ENDIF
6633
6634	!-- read nsvfl, ncsfl
6635	READ ( fsvf ) nsvfl, ncsfl
6636	IF ( nsvfl <= 0 .OR. ncsfl < 0 ) THEN
6637	WRITE( message_string, * ) 'Wrong number of SVF or CSF'
6638	CALL message( 'radiation_read_svf', 'UI0012', 1, 2, 0, 6, 0 )
6639	ELSE
6640	WRITE(message_string,*) ' Number of SVF and CSF to read', nsvfl, ncsfl
6641	CALL location_message( message_string, .TRUE. )
6642	ENDIF
6643
6644	ALLOCATE(svf(ndsvf,nsvfl))
6645	ALLOCATE(svfsurf(idsvf,nsvfl))
6646	READ(fsvf) svf
6647	READ(fsvf) svfsurf
6648	IF ( plant_canopy ) THEN
6649	ALLOCATE(csf(ndcsf,ncsfl))
6650	ALLOCATE(csfsurf(idcsf,ncsfl))
6651	READ(fsvf) csf
6652	READ(fsvf) csfsurf
6653	ENDIF
6654	READ ( fsvf ) svf_code_field
6655
6656	IF ( TRIM(svf_code_field) /= TRIM(svf_code) ) THEN
6657	WRITE( message_string, * ) 'Wrong structure of binary svf file'
6658	CALL message( 'radiation_read_svf', 'UI0012', 1, 2, 0, 6, 0 )
6659	ENDIF
6660
6661	CLOSE (fsvf)
6662
6663	ENDIF
6664	#if defined( __parallel )
6665	CALL MPI_BARRIER( comm2d, ierr )
6666	#endif
6667	ENDDO
6668
6669	END SUBROUTINE radiation_read_svf
6670
6671
6672	!------------------------------------------------------------------------------!
6673	!
6674	! Description:
6675	! ------------
6676	!> Subroutine stores svf, svfsurf, csf and csfsurf data to a file.
6677	!------------------------------------------------------------------------------!
6678	SUBROUTINE radiation_write_svf
6679
6680	IMPLICIT NONE
6681	INTEGER(iwp) :: fsvf = 89
6682	INTEGER(iwp) :: i
6683
6684	DO i = 0, io_blocks-1
6685	IF ( i == io_group ) THEN
6686	OPEN ( fsvf, FILE='SVFOUT'//TRIM( coupling_char )//'/'//myid_char, &
6687	form='unformatted', status='new' )
6688
6689	WRITE ( fsvf ) usm_version
6690	WRITE ( fsvf ) nsvfl, ncsfl
6691	WRITE ( fsvf ) svf
6692	WRITE ( fsvf ) svfsurf
6693	IF ( plant_canopy ) THEN
6694	WRITE ( fsvf ) csf
6695	WRITE ( fsvf ) csfsurf
6696	ENDIF
6697	WRITE ( fsvf ) TRIM(svf_code)
6698
6699	CLOSE (fsvf)
6700	#if defined( __parallel )
6701	CALL MPI_BARRIER( comm2d, ierr )
6702	#endif
6703	ENDIF
6704	ENDDO
6705
6706	END SUBROUTINE radiation_write_svf
6707
6708
6709
6710	!------------------------------------------------------------------------------!
6711	! Description:
6712	! ------------
6713	!
6714	!> radiation_radflux_gridbox subroutine gives the sw and lw radiation fluxes at the
6715	!> faces of a gridbox defined at i,j,k and located in the urban layer.
6716	!> The total sw and the diffuse sw radiation as well as the lw radiation fluxes at
6717	!> the gridbox 6 faces are stored in sw_gridbox, swd_gridbox, and lw_gridbox arrays,
6718	!> respectively, in the following order:
6719	!> up_face, down_face, north_face, south_face, east_face, west_face
6720	!>
6721	!> The subroutine reports also how successful was the search process via the parameter
6722	!> i_feedback as follow:
6723	!> - i_feedback = 1 : successful
6724	!> - i_feedback = -1 : unsuccessful; the requisted point is outside the urban domain
6725	!> - i_feedback = 0 : uncomplete; some gridbox faces fluxes are missing
6726	!>
6727	!>
6728	!> It is called outside from usm_urban_surface_mod whenever the radiation fluxes
6729	!> are needed.
6730	!>
6731	!> TODO:
6732	!> - Compare performance when using some combination of the Fortran intrinsic
6733	!> functions, e.g. MINLOC, MAXLOC, ALL, ANY and COUNT functions, which search
6734	!> surfl array for elements meeting user-specified criterion, i.e. i,j,k
6735	!> - Report non-found or incomplete radiation fluxes arrays , if any, at the
6736	!> gridbox faces in an error message form
6737	!>
6738	!------------------------------------------------------------------------------!
6739	SUBROUTINE radiation_radflux_gridbox(i,j,k,sw_gridbox,swd_gridbox,lw_gridbox,i_feedback)
6740
6741	IMPLICIT NONE
6742
6743	INTEGER(iwp), INTENT(in) :: i,j,k !< gridbox indices at which fluxes are required
6744	INTEGER(iwp) :: ii,jj,kk,d !< surface indices and type
6745	INTEGER(iwp) :: l !< surface id
6746	REAL(wp) , DIMENSION(1:6), INTENT(out) :: sw_gridbox,lw_gridbox !< total sw and lw radiation fluxes of 6 faces of a gridbox, w/m2
6747	REAL(wp) , DIMENSION(1:6), INTENT(out) :: swd_gridbox !< diffuse sw radiation from sky and model boundary of 6 faces of a gridbox, w/m2
6748	INTEGER(iwp), INTENT(out) :: i_feedback !< feedback to report how the search was successful
6749
6750
6751	!-- initialize variables
6752	i_feedback = -999999
6753	sw_gridbox = -999999.9_wp
6754	lw_gridbox = -999999.9_wp
6755	swd_gridbox = -999999.9_wp
6756
6757	!-- check the requisted grid indices
6758	IF ( k < nzb .OR. k > nzut .OR. &
6759	j < nysg .OR. j > nyng .OR. &
6760	i < nxlg .OR. i > nxrg &
6761	) THEN
6762	i_feedback = -1
6763	RETURN
6764	ENDIF
6765
6766	!-- search for the required grid and formulate the fluxes at the 6 gridbox faces
6767	DO l = 1, nsurfl
6768	ii = surfl(ix,l)
6769	jj = surfl(iy,l)
6770	kk = surfl(iz,l)
6771
6772	IF ( ii == i .AND. jj == j .AND. kk == k ) THEN
6773	d = surfl(id,l)
6774
6775	SELECT CASE ( d )
6776
6777	CASE (iup_u,iup_l,iup_a) !- gridbox up_facing face
6778	sw_gridbox(1) = surfinsw(l)
6779	lw_gridbox(1) = surfinlw(l)
6780	swd_gridbox(1) = surfinswdif(l)
6781
6782	CASE (isky,idown_a) !- gridbox down_facing face
6783	sw_gridbox(2) = surfinsw(l)
6784	lw_gridbox(2) = surfinlw(l)
6785	swd_gridbox(2) = surfinswdif(l)
6786
6787	CASE (inorth_u,inorth_l,inorth_a,isouth_b) !- gridbox north_facing face
6788	sw_gridbox(3) = surfinsw(l)
6789	lw_gridbox(3) = surfinlw(l)
6790	swd_gridbox(3) = surfinswdif(l)
6791
6792	CASE (isouth_u,isouth_l,isouth_a,inorth_b) !- gridbox south_facing face
6793	sw_gridbox(4) = surfinsw(l)
6794	lw_gridbox(4) = surfinlw(l)
6795	swd_gridbox(4) = surfinswdif(l)
6796
6797	CASE (ieast_u,ieast_l,ieast_a,iwest_b) !- gridbox east_facing face
6798	sw_gridbox(5) = surfinsw(l)
6799	lw_gridbox(5) = surfinlw(l)
6800	swd_gridbox(5) = surfinswdif(l)
6801
6802	CASE (iwest_u,iwest_l,iwest_a,ieast_b) !- gridbox west_facing face
6803	sw_gridbox(6) = surfinsw(l)
6804	lw_gridbox(6) = surfinlw(l)
6805	swd_gridbox(6) = surfinswdif(l)
6806
6807	END SELECT
6808
6809	ENDIF
6810
6811	IF ( ALL( sw_gridbox(:) /= -999999.9_wp ) ) EXIT
6812	ENDDO
6813
6814	!-- check the completeness of the fluxes at all gidbox faces
6815	!-- TODO: report non-found or incomplete rad fluxes arrays in an error message form
6816	IF ( ANY( sw_gridbox(:) <= -999999.9_wp ) .OR. &
6817	ANY( swd_gridbox(:) <= -999999.9_wp ) .OR. &
6818	ANY( lw_gridbox(:) <= -999999.9_wp ) ) THEN
6819	i_feedback = 0
6820	ELSE
6821	i_feedback = 1
6822	ENDIF
6823
6824	RETURN
6825
6826	END SUBROUTINE radiation_radflux_gridbox
6827
6828
6829	!------------------------------------------------------------------------------!
6830	!
6831	! Description:
6832	! ------------
6833	!> Block of auxiliary subroutines:
6834	!> 1. quicksort and corresponding comparison
6835	!> 2. merge_and_grow_csf for implementation of "dynamical growing"
6836	!> array for csf
6837	!------------------------------------------------------------------------------!
6838	PURE FUNCTION svf_lt(svf1,svf2) result (res)
6839	TYPE (t_svf), INTENT(in) :: svf1,svf2
6840	LOGICAL :: res
6841	IF ( svf1%isurflt < svf2%isurflt .OR. &
6842	(svf1%isurflt == svf2%isurflt .AND. svf1%isurfs < svf2%isurfs) ) THEN
6843	res = .TRUE.
6844	ELSE
6845	res = .FALSE.
6846	ENDIF
6847	END FUNCTION svf_lt
6848
6849
6850	!-- quicksort.f --f90--
6851	!-- Author: t-nissie, adaptation J.Resler
6852	!-- License: GPLv3
6853	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
6854	RECURSIVE SUBROUTINE quicksort_svf(svfl, first, last)
6855	IMPLICIT NONE
6856	TYPE(t_svf), DIMENSION(:), INTENT(INOUT) :: svfl
6857	INTEGER(iwp), INTENT(IN) :: first, last
6858	TYPE(t_svf) :: x, t
6859	INTEGER(iwp) :: i, j
6860
6861	IF ( first>=last ) RETURN
6862	x = svfl( (first+last) / 2 )
6863	i = first
6864	j = last
6865	DO
6866	DO while ( svf_lt(svfl(i),x) )
6867	i=i+1
6868	ENDDO
6869	DO while ( svf_lt(x,svfl(j)) )
6870	j=j-1
6871	ENDDO
6872	IF ( i >= j ) EXIT
6873	t = svfl(i); svfl(i) = svfl(j); svfl(j) = t
6874	i=i+1
6875	j=j-1
6876	ENDDO
6877	IF ( first < i-1 ) CALL quicksort_svf(svfl, first, i-1)
6878	IF ( j+1 < last ) CALL quicksort_svf(svfl, j+1, last)
6879	END SUBROUTINE quicksort_svf
6880
6881
6882	PURE FUNCTION csf_lt(csf1,csf2) result (res)
6883	TYPE (t_csf), INTENT(in) :: csf1,csf2
6884	LOGICAL :: res
6885	IF ( csf1%ip < csf2%ip .OR. &
6886	(csf1%ip == csf2%ip .AND. csf1%itx < csf2%itx) .OR. &
6887	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity < csf2%ity) .OR. &
6888	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. &
6889	csf1%itz < csf2%itz) .OR. &
6890	(csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. &
6891	csf1%itz == csf2%itz .AND. csf1%isurfs < csf2%isurfs) ) THEN
6892	res = .TRUE.
6893	ELSE
6894	res = .FALSE.
6895	ENDIF
6896	END FUNCTION csf_lt
6897
6898
6899	!-- quicksort.f --f90--
6900	!-- Author: t-nissie, adaptation J.Resler
6901	!-- License: GPLv3
6902	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
6903	RECURSIVE SUBROUTINE quicksort_csf(csfl, first, last)
6904	IMPLICIT NONE
6905	TYPE(t_csf), DIMENSION(:), INTENT(INOUT) :: csfl
6906	INTEGER(iwp), INTENT(IN) :: first, last
6907	TYPE(t_csf) :: x, t
6908	INTEGER(iwp) :: i, j
6909
6910	IF ( first>=last ) RETURN
6911	x = csfl( (first+last)/2 )
6912	i = first
6913	j = last
6914	DO
6915	DO while ( csf_lt(csfl(i),x) )
6916	i=i+1
6917	ENDDO
6918	DO while ( csf_lt(x,csfl(j)) )
6919	j=j-1
6920	ENDDO
6921	IF ( i >= j ) EXIT
6922	t = csfl(i); csfl(i) = csfl(j); csfl(j) = t
6923	i=i+1
6924	j=j-1
6925	ENDDO
6926	IF ( first < i-1 ) CALL quicksort_csf(csfl, first, i-1)
6927	IF ( j+1 < last ) CALL quicksort_csf(csfl, j+1, last)
6928	END SUBROUTINE quicksort_csf
6929
6930
6931	SUBROUTINE merge_and_grow_csf(newsize)
6932	INTEGER(iwp), INTENT(in) :: newsize !< new array size after grow, must be >= ncsfl
6933	!< or -1 to shrink to minimum
6934	INTEGER(iwp) :: iread, iwrite
6935	TYPE(t_csf), DIMENSION(:), POINTER :: acsfnew
6936
6937	IF ( newsize == -1 ) THEN
6938	!-- merge in-place
6939	acsfnew => acsf
6940	ELSE
6941	!-- allocate new array
6942	IF ( mcsf == 0 ) THEN
6943	ALLOCATE( acsf1(newsize) )
6944	acsfnew => acsf1
6945	ELSE
6946	ALLOCATE( acsf2(newsize) )
6947	acsfnew => acsf2
6948	ENDIF
6949	ENDIF
6950
6951	IF ( ncsfl >= 1 ) THEN
6952	!-- sort csf in place (quicksort)
6953	CALL quicksort_csf(acsf,1,ncsfl)
6954
6955	!-- while moving to a new array, aggregate canopy sink factor records with identical box & source
6956	acsfnew(1) = acsf(1)
6957	iwrite = 1
6958	DO iread = 2, ncsfl
6959	!-- here acsf(kcsf) already has values from acsf(icsf)
6960	IF ( acsfnew(iwrite)%itx == acsf(iread)%itx &
6961	.AND. acsfnew(iwrite)%ity == acsf(iread)%ity &
6962	.AND. acsfnew(iwrite)%itz == acsf(iread)%itz &
6963	.AND. acsfnew(iwrite)%isurfs == acsf(iread)%isurfs ) THEN
6964	!-- We could simply take either first or second rtransp, both are valid. As a very simple heuristic about which ray
6965	!-- probably passes nearer the center of the target box, we choose DIF from the entry with greater CSF, since that
6966	!-- might mean that the traced beam passes longer through the canopy box.
6967	IF ( acsfnew(iwrite)%rsvf < acsf(iread)%rsvf ) THEN
6968	acsfnew(iwrite)%rtransp = acsf(iread)%rtransp
6969	ENDIF
6970	acsfnew(iwrite)%rsvf = acsfnew(iwrite)%rsvf + acsf(iread)%rsvf
6971	!-- advance reading index, keep writing index
6972	ELSE
6973	!-- not identical, just advance and copy
6974	iwrite = iwrite + 1
6975	acsfnew(iwrite) = acsf(iread)
6976	ENDIF
6977	ENDDO
6978	ncsfl = iwrite
6979	ENDIF
6980
6981	IF ( newsize == -1 ) THEN
6982	!-- allocate new array and copy shrinked data
6983	IF ( mcsf == 0 ) THEN
6984	ALLOCATE( acsf1(ncsfl) )
6985	acsf1(1:ncsfl) = acsf2(1:ncsfl)
6986	ELSE
6987	ALLOCATE( acsf2(ncsfl) )
6988	acsf2(1:ncsfl) = acsf1(1:ncsfl)
6989	ENDIF
6990	ENDIF
6991
6992	!-- deallocate old array
6993	IF ( mcsf == 0 ) THEN
6994	mcsf = 1
6995	acsf => acsf1
6996	DEALLOCATE( acsf2 )
6997	ELSE
6998	mcsf = 0
6999	acsf => acsf2
7000	DEALLOCATE( acsf1 )
7001	ENDIF
7002	ncsfla = newsize
7003	END SUBROUTINE merge_and_grow_csf
7004
7005
7006	!-- quicksort.f --f90--
7007	!-- Author: t-nissie, adaptation J.Resler
7008	!-- License: GPLv3
7009	!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
7010	RECURSIVE SUBROUTINE quicksort_csf2(kpcsflt, pcsflt, first, last)
7011	IMPLICIT NONE
7012	INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT) :: kpcsflt
7013	REAL(wp), DIMENSION(:,:), INTENT(INOUT) :: pcsflt
7014	INTEGER(iwp), INTENT(IN) :: first, last
7015	REAL(wp), DIMENSION(ndcsf) :: t2
7016	INTEGER(iwp), DIMENSION(kdcsf) :: x, t1
7017	INTEGER(iwp) :: i, j
7018
7019	IF ( first>=last ) RETURN
7020	x = kpcsflt(:, (first+last)/2 )
7021	i = first
7022	j = last
7023	DO
7024	DO while ( csf_lt2(kpcsflt(:,i),x) )
7025	i=i+1
7026	ENDDO
7027	DO while ( csf_lt2(x,kpcsflt(:,j)) )
7028	j=j-1
7029	ENDDO
7030	IF ( i >= j ) EXIT
7031	t1 = kpcsflt(:,i); kpcsflt(:,i) = kpcsflt(:,j); kpcsflt(:,j) = t1
7032	t2 = pcsflt(:,i); pcsflt(:,i) = pcsflt(:,j); pcsflt(:,j) = t2
7033	i=i+1
7034	j=j-1
7035	ENDDO
7036	IF ( first < i-1 ) CALL quicksort_csf2(kpcsflt, pcsflt, first, i-1)
7037	IF ( j+1 < last ) CALL quicksort_csf2(kpcsflt, pcsflt, j+1, last)
7038	END SUBROUTINE quicksort_csf2
7039
7040
7041	PURE FUNCTION csf_lt2(item1, item2) result(res)
7042	INTEGER(iwp), DIMENSION(kdcsf), INTENT(in) :: item1, item2
7043	LOGICAL :: res
7044	res = ( (item1(3) < item2(3)) &
7045	.OR. (item1(3) == item2(3) .AND. item1(2) < item2(2)) &
7046	.OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) < item2(1)) &
7047	.OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) == item2(1) &
7048	.AND. item1(4) < item2(4)) )
7049	END FUNCTION csf_lt2
7050
7051	!------------------------------------------------------------------------------!
7052	!
7053	! Description:
7054	! ------------
7055	!> Subroutine for averaging 3D data
7056	!------------------------------------------------------------------------------!
7057	SUBROUTINE radiation_3d_data_averaging( mode, variable )
7058
7059
7060	USE control_parameters
7061
7062	USE indices
7063
7064	USE kinds
7065
7066	IMPLICIT NONE
7067
7068	CHARACTER (LEN=*) :: mode !<
7069	CHARACTER (LEN=*) :: variable !<
7070
7071	INTEGER(iwp) :: i !<
7072	INTEGER(iwp) :: j !<
7073	INTEGER(iwp) :: k !<
7074	INTEGER(iwp) :: m !< index of current surface element
7075
7076	IF ( mode == 'allocate' ) THEN
7077
7078	SELECT CASE ( TRIM( variable ) )
7079
7080	CASE ( 'rad_net*' )
7081	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
7082	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
7083	ENDIF
7084	rad_net_av = 0.0_wp
7085
7086	CASE ( 'rad_lw_in' )
7087	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
7088	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
7089	ENDIF
7090	rad_lw_in_av = 0.0_wp
7091
7092	CASE ( 'rad_lw_out' )
7093	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
7094	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
7095	ENDIF
7096	rad_lw_out_av = 0.0_wp
7097
7098	CASE ( 'rad_lw_cs_hr' )
7099	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
7100	ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
7101	ENDIF
7102	rad_lw_cs_hr_av = 0.0_wp
7103
7104	CASE ( 'rad_lw_hr' )
7105	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
7106	ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
7107	ENDIF
7108	rad_lw_hr_av = 0.0_wp
7109
7110	CASE ( 'rad_sw_in' )
7111	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
7112	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
7113	ENDIF
7114	rad_sw_in_av = 0.0_wp
7115
7116	CASE ( 'rad_sw_out' )
7117	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
7118	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
7119	ENDIF
7120	rad_sw_out_av = 0.0_wp
7121
7122	CASE ( 'rad_sw_cs_hr' )
7123	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
7124	ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
7125	ENDIF
7126	rad_sw_cs_hr_av = 0.0_wp
7127
7128	CASE ( 'rad_sw_hr' )
7129	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
7130	ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
7131	ENDIF
7132	rad_sw_hr_av = 0.0_wp
7133
7134	CASE DEFAULT
7135	CONTINUE
7136
7137	END SELECT
7138
7139	ELSEIF ( mode == 'sum' ) THEN
7140
7141	SELECT CASE ( TRIM( variable ) )
7142
7143	CASE ( 'rad_net*' )
7144	DO i = nxl, nxr
7145	DO j = nys, nyn
7146	DO m = surf_def_h(0)%start_index(j,i), &
7147	surf_def_h(0)%end_index(j,i)
7148	rad_net_av(j,i) = rad_net_av(j,i) + surf_def_h(0)%rad_net(m)
7149	ENDDO
7150	DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
7151	rad_net_av(j,i) = rad_net_av(j,i) + surf_lsm_h%rad_net(m)
7152	ENDDO
7153	DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
7154	rad_net_av(j,i) = rad_net_av(j,i) + surf_usm_h%rad_net(m)
7155	ENDDO
7156	ENDDO
7157	ENDDO
7158
7159	CASE ( 'rad_lw_in' )
7160	DO i = nxlg, nxrg
7161	DO j = nysg, nyng
7162	DO k = nzb, nzt+1
7163	rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) + rad_lw_in(k,j,i)
7164	ENDDO
7165	ENDDO
7166	ENDDO
7167
7168	CASE ( 'rad_lw_out' )
7169	DO i = nxlg, nxrg
7170	DO j = nysg, nyng
7171	DO k = nzb, nzt+1
7172	rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) &
7173	+ rad_lw_out(k,j,i)
7174	ENDDO
7175	ENDDO
7176	ENDDO
7177
7178	CASE ( 'rad_lw_cs_hr' )
7179	DO i = nxlg, nxrg
7180	DO j = nysg, nyng
7181	DO k = nzb, nzt+1
7182	rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) &
7183	+ rad_lw_cs_hr(k,j,i)
7184	ENDDO
7185	ENDDO
7186	ENDDO
7187
7188	CASE ( 'rad_lw_hr' )
7189	DO i = nxlg, nxrg
7190	DO j = nysg, nyng
7191	DO k = nzb, nzt+1
7192	rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) &
7193	+ rad_lw_hr(k,j,i)
7194	ENDDO
7195	ENDDO
7196	ENDDO
7197
7198	CASE ( 'rad_sw_in' )
7199	DO i = nxlg, nxrg
7200	DO j = nysg, nyng
7201	DO k = nzb, nzt+1
7202	rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) &
7203	+ rad_sw_in(k,j,i)
7204	ENDDO
7205	ENDDO
7206	ENDDO
7207
7208	CASE ( 'rad_sw_out' )
7209	DO i = nxlg, nxrg
7210	DO j = nysg, nyng
7211	DO k = nzb, nzt+1
7212	rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) &
7213	+ rad_sw_out(k,j,i)
7214	ENDDO
7215	ENDDO
7216	ENDDO
7217
7218	CASE ( 'rad_sw_cs_hr' )
7219	DO i = nxlg, nxrg
7220	DO j = nysg, nyng
7221	DO k = nzb, nzt+1
7222	rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) &
7223	+ rad_sw_cs_hr(k,j,i)
7224	ENDDO
7225	ENDDO
7226	ENDDO
7227
7228	CASE ( 'rad_sw_hr' )
7229	DO i = nxlg, nxrg
7230	DO j = nysg, nyng
7231	DO k = nzb, nzt+1
7232	rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) &
7233	+ rad_sw_hr(k,j,i)
7234	ENDDO
7235	ENDDO
7236	ENDDO
7237
7238	CASE DEFAULT
7239	CONTINUE
7240
7241	END SELECT
7242
7243	ELSEIF ( mode == 'average' ) THEN
7244
7245	SELECT CASE ( TRIM( variable ) )
7246
7247	CASE ( 'rad_net*' )
7248	DO i = nxlg, nxrg
7249	DO j = nysg, nyng
7250	rad_net_av(j,i) = rad_net_av(j,i) / REAL( average_count_3d, &
7251	KIND=wp )
7252	ENDDO
7253	ENDDO
7254
7255	CASE ( 'rad_lw_in' )
7256	DO i = nxlg, nxrg
7257	DO j = nysg, nyng
7258	DO k = nzb, nzt+1
7259	rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) &
7260	/ REAL( average_count_3d, KIND=wp )
7261	ENDDO
7262	ENDDO
7263	ENDDO
7264
7265	CASE ( 'rad_lw_out' )
7266	DO i = nxlg, nxrg
7267	DO j = nysg, nyng
7268	DO k = nzb, nzt+1
7269	rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) &
7270	/ REAL( average_count_3d, KIND=wp )
7271	ENDDO
7272	ENDDO
7273	ENDDO
7274
7275	CASE ( 'rad_lw_cs_hr' )
7276	DO i = nxlg, nxrg
7277	DO j = nysg, nyng
7278	DO k = nzb, nzt+1
7279	rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) &
7280	/ REAL( average_count_3d, KIND=wp )
7281	ENDDO
7282	ENDDO
7283	ENDDO
7284
7285	CASE ( 'rad_lw_hr' )
7286	DO i = nxlg, nxrg
7287	DO j = nysg, nyng
7288	DO k = nzb, nzt+1
7289	rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) &
7290	/ REAL( average_count_3d, KIND=wp )
7291	ENDDO
7292	ENDDO
7293	ENDDO
7294
7295	CASE ( 'rad_sw_in' )
7296	DO i = nxlg, nxrg
7297	DO j = nysg, nyng
7298	DO k = nzb, nzt+1
7299	rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) &
7300	/ REAL( average_count_3d, KIND=wp )
7301	ENDDO
7302	ENDDO
7303	ENDDO
7304
7305	CASE ( 'rad_sw_out' )
7306	DO i = nxlg, nxrg
7307	DO j = nysg, nyng
7308	DO k = nzb, nzt+1
7309	rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) &
7310	/ REAL( average_count_3d, KIND=wp )
7311	ENDDO
7312	ENDDO
7313	ENDDO
7314
7315	CASE ( 'rad_sw_cs_hr' )
7316	DO i = nxlg, nxrg
7317	DO j = nysg, nyng
7318	DO k = nzb, nzt+1
7319	rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) &
7320	/ REAL( average_count_3d, KIND=wp )
7321	ENDDO
7322	ENDDO
7323	ENDDO
7324
7325	CASE ( 'rad_sw_hr' )
7326	DO i = nxlg, nxrg
7327	DO j = nysg, nyng
7328	DO k = nzb, nzt+1
7329	rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) &
7330	/ REAL( average_count_3d, KIND=wp )
7331	ENDDO
7332	ENDDO
7333	ENDDO
7334
7335	END SELECT
7336
7337	ENDIF
7338
7339	END SUBROUTINE radiation_3d_data_averaging
7340
7341
7342	!------------------------------------------------------------------------------!
7343	!
7344	! Description:
7345	! ------------
7346	!> Subroutine defining appropriate grid for netcdf variables.
7347	!> It is called out from subroutine netcdf.
7348	!------------------------------------------------------------------------------!
7349	SUBROUTINE radiation_define_netcdf_grid( var, found, grid_x, grid_y, grid_z )
7350
7351	IMPLICIT NONE
7352
7353	CHARACTER (LEN=*), INTENT(IN) :: var !<
7354	LOGICAL, INTENT(OUT) :: found !<
7355	CHARACTER (LEN=*), INTENT(OUT) :: grid_x !<
7356	CHARACTER (LEN=*), INTENT(OUT) :: grid_y !<
7357	CHARACTER (LEN=*), INTENT(OUT) :: grid_z !<
7358
7359	found = .TRUE.
7360
7361
7362	!
7363	!-- Check for the grid
7364	SELECT CASE ( TRIM( var ) )
7365
7366	CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_sw_cs_hr', 'rad_sw_hr', &
7367	'rad_lw_cs_hr_xy', 'rad_lw_hr_xy', 'rad_sw_cs_hr_xy', &
7368	'rad_sw_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_hr_xz', &
7369	'rad_sw_cs_hr_xz', 'rad_sw_hr_xz', 'rad_lw_cs_hr_yz', &
7370	'rad_lw_hr_yz', 'rad_sw_cs_hr_yz', 'rad_sw_hr_yz' )
7371	grid_x = 'x'
7372	grid_y = 'y'
7373	grid_z = 'zu'
7374
7375	CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out', &
7376	'rad_lw_in_xy', 'rad_lw_out_xy', 'rad_sw_in_xy','rad_sw_out_xy', &
7377	'rad_lw_in_xz', 'rad_lw_out_xz', 'rad_sw_in_xz','rad_sw_out_xz', &
7378	'rad_lw_in_yz', 'rad_lw_out_yz', 'rad_sw_in_yz','rad_sw_out_yz' )
7379	grid_x = 'x'
7380	grid_y = 'y'
7381	grid_z = 'zw'
7382
7383
7384	CASE DEFAULT
7385	found = .FALSE.
7386	grid_x = 'none'
7387	grid_y = 'none'
7388	grid_z = 'none'
7389
7390	END SELECT
7391
7392	END SUBROUTINE radiation_define_netcdf_grid
7393
7394	!------------------------------------------------------------------------------!
7395	!
7396	! Description:
7397	! ------------
7398	!> Subroutine defining 3D output variables
7399	!------------------------------------------------------------------------------!
7400	SUBROUTINE radiation_data_output_2d( av, variable, found, grid, mode, &
7401	local_pf, two_d )
7402
7403	USE indices
7404
7405	USE kinds
7406
7407
7408	IMPLICIT NONE
7409
7410	CHARACTER (LEN=*) :: grid !<
7411	CHARACTER (LEN=*) :: mode !<
7412	CHARACTER (LEN=*) :: variable !<
7413
7414	INTEGER(iwp) :: av !<
7415	INTEGER(iwp) :: i !<
7416	INTEGER(iwp) :: j !<
7417	INTEGER(iwp) :: k !<
7418	INTEGER(iwp) :: m !< index of surface element at grid point (j,i)
7419
7420	LOGICAL :: found !<
7421	LOGICAL :: two_d !< flag parameter that indicates 2D variables (horizontal cross sections)
7422
7423	REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb:nzt+1) :: local_pf !<
7424
7425	found = .TRUE.
7426
7427	SELECT CASE ( TRIM( variable ) )
7428
7429	CASE ( 'rad_net*_xy' ) ! 2d-array
7430	IF ( av == 0 ) THEN
7431	DO i = nxl, nxr
7432	DO j = nys, nyn
7433	!
7434	!-- Obtain rad_net from its respective surface type
7435	!-- Default-type surfaces
7436	DO m = surf_def_h(0)%start_index(j,i), &
7437	surf_def_h(0)%end_index(j,i)
7438	local_pf(i,j,nzb+1) = surf_def_h(0)%rad_net(m)
7439	ENDDO
7440	!
7441	!-- Natural-type surfaces
7442	DO m = surf_lsm_h%start_index(j,i), &
7443	surf_lsm_h%end_index(j,i)
7444	local_pf(i,j,nzb+1) = surf_lsm_h%rad_net(m)
7445	ENDDO
7446	!
7447	!-- Urban-type surfaces
7448	DO m = surf_usm_h%start_index(j,i), &
7449	surf_usm_h%end_index(j,i)
7450	local_pf(i,j,nzb+1) = surf_usm_h%rad_net(m)
7451	ENDDO
7452	ENDDO
7453	ENDDO
7454	ELSE
7455	DO i = nxl, nxr
7456	DO j = nys, nyn
7457	local_pf(i,j,nzb+1) = rad_net_av(j,i)
7458	ENDDO
7459	ENDDO
7460	ENDIF
7461	two_d = .TRUE.
7462	grid = 'zu1'
7463
7464
7465	CASE ( 'rad_lw_in_xy', 'rad_lw_in_xz', 'rad_lw_in_yz' )
7466	IF ( av == 0 ) THEN
7467	DO i = nxl, nxr
7468	DO j = nys, nyn
7469	DO k = nzb, nzt+1
7470	local_pf(i,j,k) = rad_lw_in(k,j,i)
7471	ENDDO
7472	ENDDO
7473	ENDDO
7474	ELSE
7475	DO i = nxl, nxr
7476	DO j = nys, nyn
7477	DO k = nzb, nzt+1
7478	local_pf(i,j,k) = rad_lw_in_av(k,j,i)
7479	ENDDO
7480	ENDDO
7481	ENDDO
7482	ENDIF
7483	IF ( mode == 'xy' ) grid = 'zu'
7484
7485	CASE ( 'rad_lw_out_xy', 'rad_lw_out_xz', 'rad_lw_out_yz' )
7486	IF ( av == 0 ) THEN
7487	DO i = nxl, nxr
7488	DO j = nys, nyn
7489	DO k = nzb, nzt+1
7490	local_pf(i,j,k) = rad_lw_out(k,j,i)
7491	ENDDO
7492	ENDDO
7493	ENDDO
7494	ELSE
7495	DO i = nxl, nxr
7496	DO j = nys, nyn
7497	DO k = nzb, nzt+1
7498	local_pf(i,j,k) = rad_lw_out_av(k,j,i)
7499	ENDDO
7500	ENDDO
7501	ENDDO
7502	ENDIF
7503	IF ( mode == 'xy' ) grid = 'zu'
7504
7505	CASE ( 'rad_lw_cs_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_cs_hr_yz' )
7506	IF ( av == 0 ) THEN
7507	DO i = nxl, nxr
7508	DO j = nys, nyn
7509	DO k = nzb, nzt+1
7510	local_pf(i,j,k) = rad_lw_cs_hr(k,j,i)
7511	ENDDO
7512	ENDDO
7513	ENDDO
7514	ELSE
7515	DO i = nxl, nxr
7516	DO j = nys, nyn
7517	DO k = nzb, nzt+1
7518	local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i)
7519	ENDDO
7520	ENDDO
7521	ENDDO
7522	ENDIF
7523	IF ( mode == 'xy' ) grid = 'zw'
7524
7525	CASE ( 'rad_lw_hr_xy', 'rad_lw_hr_xz', 'rad_lw_hr_yz' )
7526	IF ( av == 0 ) THEN
7527	DO i = nxl, nxr
7528	DO j = nys, nyn
7529	DO k = nzb, nzt+1
7530	local_pf(i,j,k) = rad_lw_hr(k,j,i)
7531	ENDDO
7532	ENDDO
7533	ENDDO
7534	ELSE
7535	DO i = nxl, nxr
7536	DO j = nys, nyn
7537	DO k = nzb, nzt+1
7538	local_pf(i,j,k) = rad_lw_hr_av(k,j,i)
7539	ENDDO
7540	ENDDO
7541	ENDDO
7542	ENDIF
7543	IF ( mode == 'xy' ) grid = 'zw'
7544
7545	CASE ( 'rad_sw_in_xy', 'rad_sw_in_xz', 'rad_sw_in_yz' )
7546	IF ( av == 0 ) THEN
7547	DO i = nxl, nxr
7548	DO j = nys, nyn
7549	DO k = nzb, nzt+1
7550	local_pf(i,j,k) = rad_sw_in(k,j,i)
7551	ENDDO
7552	ENDDO
7553	ENDDO
7554	ELSE
7555	DO i = nxl, nxr
7556	DO j = nys, nyn
7557	DO k = nzb, nzt+1
7558	local_pf(i,j,k) = rad_sw_in_av(k,j,i)
7559	ENDDO
7560	ENDDO
7561	ENDDO
7562	ENDIF
7563	IF ( mode == 'xy' ) grid = 'zu'
7564
7565	CASE ( 'rad_sw_out_xy', 'rad_sw_out_xz', 'rad_sw_out_yz' )
7566	IF ( av == 0 ) THEN
7567	DO i = nxl, nxr
7568	DO j = nys, nyn
7569	DO k = nzb, nzt+1
7570	local_pf(i,j,k) = rad_sw_out(k,j,i)
7571	ENDDO
7572	ENDDO
7573	ENDDO
7574	ELSE
7575	DO i = nxl, nxr
7576	DO j = nys, nyn
7577	DO k = nzb, nzt+1
7578	local_pf(i,j,k) = rad_sw_out_av(k,j,i)
7579	ENDDO
7580	ENDDO
7581	ENDDO
7582	ENDIF
7583	IF ( mode == 'xy' ) grid = 'zu'
7584
7585	CASE ( 'rad_sw_cs_hr_xy', 'rad_sw_cs_hr_xz', 'rad_sw_cs_hr_yz' )
7586	IF ( av == 0 ) THEN
7587	DO i = nxl, nxr
7588	DO j = nys, nyn
7589	DO k = nzb, nzt+1
7590	local_pf(i,j,k) = rad_sw_cs_hr(k,j,i)
7591	ENDDO
7592	ENDDO
7593	ENDDO
7594	ELSE
7595	DO i = nxl, nxr
7596	DO j = nys, nyn
7597	DO k = nzb, nzt+1
7598	local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i)
7599	ENDDO
7600	ENDDO
7601	ENDDO
7602	ENDIF
7603	IF ( mode == 'xy' ) grid = 'zw'
7604
7605	CASE ( 'rad_sw_hr_xy', 'rad_sw_hr_xz', 'rad_sw_hr_yz' )
7606	IF ( av == 0 ) THEN
7607	DO i = nxl, nxr
7608	DO j = nys, nyn
7609	DO k = nzb, nzt+1
7610	local_pf(i,j,k) = rad_sw_hr(k,j,i)
7611	ENDDO
7612	ENDDO
7613	ENDDO
7614	ELSE
7615	DO i = nxl, nxr
7616	DO j = nys, nyn
7617	DO k = nzb, nzt+1
7618	local_pf(i,j,k) = rad_sw_hr_av(k,j,i)
7619	ENDDO
7620	ENDDO
7621	ENDDO
7622	ENDIF
7623	IF ( mode == 'xy' ) grid = 'zw'
7624
7625	CASE DEFAULT
7626	found = .FALSE.
7627	grid = 'none'
7628
7629	END SELECT
7630
7631	END SUBROUTINE radiation_data_output_2d
7632
7633
7634	!------------------------------------------------------------------------------!
7635	!
7636	! Description:
7637	! ------------
7638	!> Subroutine defining 3D output variables
7639	!------------------------------------------------------------------------------!
7640	SUBROUTINE radiation_data_output_3d( av, variable, found, local_pf )
7641
7642
7643	USE indices
7644
7645	USE kinds
7646
7647
7648	IMPLICIT NONE
7649
7650	CHARACTER (LEN=*) :: variable !<
7651
7652	INTEGER(iwp) :: av !<
7653	INTEGER(iwp) :: i !<
7654	INTEGER(iwp) :: j !<
7655	INTEGER(iwp) :: k !<
7656
7657	LOGICAL :: found !<
7658
7659	REAL(sp), DIMENSION(nxl:nxr,nys:nyn,nzb:nzt+1) :: local_pf !<
7660
7661
7662	found = .TRUE.
7663
7664
7665	SELECT CASE ( TRIM( variable ) )
7666
7667	CASE ( 'rad_sw_in' )
7668	IF ( av == 0 ) THEN
7669	DO i = nxl, nxr
7670	DO j = nys, nyn
7671	DO k = nzb, nzt+1
7672	local_pf(i,j,k) = rad_sw_in(k,j,i)
7673	ENDDO
7674	ENDDO
7675	ENDDO
7676	ELSE
7677	DO i = nxl, nxr
7678	DO j = nys, nyn
7679	DO k = nzb, nzt+1
7680	local_pf(i,j,k) = rad_sw_in_av(k,j,i)
7681	ENDDO
7682	ENDDO
7683	ENDDO
7684	ENDIF
7685
7686	CASE ( 'rad_sw_out' )
7687	IF ( av == 0 ) THEN
7688	DO i = nxl, nxr
7689	DO j = nys, nyn
7690	DO k = nzb, nzt+1
7691	local_pf(i,j,k) = rad_sw_out(k,j,i)
7692	ENDDO
7693	ENDDO
7694	ENDDO
7695	ELSE
7696	DO i = nxl, nxr
7697	DO j = nys, nyn
7698	DO k = nzb, nzt+1
7699	local_pf(i,j,k) = rad_sw_out_av(k,j,i)
7700	ENDDO
7701	ENDDO
7702	ENDDO
7703	ENDIF
7704
7705	CASE ( 'rad_sw_cs_hr' )
7706	IF ( av == 0 ) THEN
7707	DO i = nxl, nxr
7708	DO j = nys, nyn
7709	DO k = nzb, nzt+1
7710	local_pf(i,j,k) = rad_sw_cs_hr(k,j,i)
7711	ENDDO
7712	ENDDO
7713	ENDDO
7714	ELSE
7715	DO i = nxl, nxr
7716	DO j = nys, nyn
7717	DO k = nzb, nzt+1
7718	local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i)
7719	ENDDO
7720	ENDDO
7721	ENDDO
7722	ENDIF
7723
7724	CASE ( 'rad_sw_hr' )
7725	IF ( av == 0 ) THEN
7726	DO i = nxl, nxr
7727	DO j = nys, nyn
7728	DO k = nzb, nzt+1
7729	local_pf(i,j,k) = rad_sw_hr(k,j,i)
7730	ENDDO
7731	ENDDO
7732	ENDDO
7733	ELSE
7734	DO i = nxl, nxr
7735	DO j = nys, nyn
7736	DO k = nzb, nzt+1
7737	local_pf(i,j,k) = rad_sw_hr_av(k,j,i)
7738	ENDDO
7739	ENDDO
7740	ENDDO
7741	ENDIF
7742
7743	CASE ( 'rad_lw_in' )
7744	IF ( av == 0 ) THEN
7745	DO i = nxl, nxr
7746	DO j = nys, nyn
7747	DO k = nzb, nzt+1
7748	local_pf(i,j,k) = rad_lw_in(k,j,i)
7749	ENDDO
7750	ENDDO
7751	ENDDO
7752	ELSE
7753	DO i = nxl, nxr
7754	DO j = nys, nyn
7755	DO k = nzb, nzt+1
7756	local_pf(i,j,k) = rad_lw_in_av(k,j,i)
7757	ENDDO
7758	ENDDO
7759	ENDDO
7760	ENDIF
7761
7762	CASE ( 'rad_lw_out' )
7763	IF ( av == 0 ) THEN
7764	DO i = nxl, nxr
7765	DO j = nys, nyn
7766	DO k = nzb, nzt+1
7767	local_pf(i,j,k) = rad_lw_out(k,j,i)
7768	ENDDO
7769	ENDDO
7770	ENDDO
7771	ELSE
7772	DO i = nxl, nxr
7773	DO j = nys, nyn
7774	DO k = nzb, nzt+1
7775	local_pf(i,j,k) = rad_lw_out_av(k,j,i)
7776	ENDDO
7777	ENDDO
7778	ENDDO
7779	ENDIF
7780
7781	CASE ( 'rad_lw_cs_hr' )
7782	IF ( av == 0 ) THEN
7783	DO i = nxl, nxr
7784	DO j = nys, nyn
7785	DO k = nzb, nzt+1
7786	local_pf(i,j,k) = rad_lw_cs_hr(k,j,i)
7787	ENDDO
7788	ENDDO
7789	ENDDO
7790	ELSE
7791	DO i = nxl, nxr
7792	DO j = nys, nyn
7793	DO k = nzb, nzt+1
7794	local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i)
7795	ENDDO
7796	ENDDO
7797	ENDDO
7798	ENDIF
7799
7800	CASE ( 'rad_lw_hr' )
7801	IF ( av == 0 ) THEN
7802	DO i = nxl, nxr
7803	DO j = nys, nyn
7804	DO k = nzb, nzt+1
7805	local_pf(i,j,k) = rad_lw_hr(k,j,i)
7806	ENDDO
7807	ENDDO
7808	ENDDO
7809	ELSE
7810	DO i = nxl, nxr
7811	DO j = nys, nyn
7812	DO k = nzb, nzt+1
7813	local_pf(i,j,k) = rad_lw_hr_av(k,j,i)
7814	ENDDO
7815	ENDDO
7816	ENDDO
7817	ENDIF
7818
7819	CASE DEFAULT
7820	found = .FALSE.
7821
7822	END SELECT
7823
7824
7825	END SUBROUTINE radiation_data_output_3d
7826
7827	!------------------------------------------------------------------------------!
7828	!
7829	! Description:
7830	! ------------
7831	!> Subroutine defining masked data output
7832	!------------------------------------------------------------------------------!
7833	SUBROUTINE radiation_data_output_mask( av, variable, found, local_pf )
7834
7835	USE control_parameters
7836
7837	USE indices
7838
7839	USE kinds
7840
7841
7842	IMPLICIT NONE
7843
7844	CHARACTER (LEN=*) :: variable !<
7845
7846	INTEGER(iwp) :: av !<
7847	INTEGER(iwp) :: i !<
7848	INTEGER(iwp) :: j !<
7849	INTEGER(iwp) :: k !<
7850
7851	LOGICAL :: found !<
7852
7853	REAL(wp), &
7854	DIMENSION(mask_size_l(mid,1),mask_size_l(mid,2),mask_size_l(mid,3)) :: &
7855	local_pf !<
7856
7857
7858	found = .TRUE.
7859
7860	SELECT CASE ( TRIM( variable ) )
7861
7862
7863	CASE ( 'rad_lw_in' )
7864	IF ( av == 0 ) THEN
7865	DO i = 1, mask_size_l(mid,1)
7866	DO j = 1, mask_size_l(mid,2)
7867	DO k = 1, mask_size_l(mid,3)
7868	local_pf(i,j,k) = rad_lw_in(mask_k(mid,k), &
7869	mask_j(mid,j),mask_i(mid,i))
7870	ENDDO
7871	ENDDO
7872	ENDDO
7873	ELSE
7874	DO i = 1, mask_size_l(mid,1)
7875	DO j = 1, mask_size_l(mid,2)
7876	DO k = 1, mask_size_l(mid,3)
7877	local_pf(i,j,k) = rad_lw_in_av(mask_k(mid,k), &
7878	mask_j(mid,j),mask_i(mid,i))
7879	ENDDO
7880	ENDDO
7881	ENDDO
7882	ENDIF
7883
7884	CASE ( 'rad_lw_out' )
7885	IF ( av == 0 ) THEN
7886	DO i = 1, mask_size_l(mid,1)
7887	DO j = 1, mask_size_l(mid,2)
7888	DO k = 1, mask_size_l(mid,3)
7889	local_pf(i,j,k) = rad_lw_out(mask_k(mid,k), &
7890	mask_j(mid,j),mask_i(mid,i))
7891	ENDDO
7892	ENDDO
7893	ENDDO
7894	ELSE
7895	DO i = 1, mask_size_l(mid,1)
7896	DO j = 1, mask_size_l(mid,2)
7897	DO k = 1, mask_size_l(mid,3)
7898	local_pf(i,j,k) = rad_lw_out_av(mask_k(mid,k), &
7899	mask_j(mid,j),mask_i(mid,i))
7900	ENDDO
7901	ENDDO
7902	ENDDO
7903	ENDIF
7904
7905	CASE ( 'rad_lw_cs_hr' )
7906	IF ( av == 0 ) THEN
7907	DO i = 1, mask_size_l(mid,1)
7908	DO j = 1, mask_size_l(mid,2)
7909	DO k = 1, mask_size_l(mid,3)
7910	local_pf(i,j,k) = rad_lw_cs_hr(mask_k(mid,k), &
7911	mask_j(mid,j),mask_i(mid,i))
7912	ENDDO
7913	ENDDO
7914	ENDDO
7915	ELSE
7916	DO i = 1, mask_size_l(mid,1)
7917	DO j = 1, mask_size_l(mid,2)
7918	DO k = 1, mask_size_l(mid,3)
7919	local_pf(i,j,k) = rad_lw_cs_hr_av(mask_k(mid,k), &
7920	mask_j(mid,j),mask_i(mid,i))
7921	ENDDO
7922	ENDDO
7923	ENDDO
7924	ENDIF
7925
7926	CASE ( 'rad_lw_hr' )
7927	IF ( av == 0 ) THEN
7928	DO i = 1, mask_size_l(mid,1)
7929	DO j = 1, mask_size_l(mid,2)
7930	DO k = 1, mask_size_l(mid,3)
7931	local_pf(i,j,k) = rad_lw_hr(mask_k(mid,k), &
7932	mask_j(mid,j),mask_i(mid,i))
7933	ENDDO
7934	ENDDO
7935	ENDDO
7936	ELSE
7937	DO i = 1, mask_size_l(mid,1)
7938	DO j = 1, mask_size_l(mid,2)
7939	DO k = 1, mask_size_l(mid,3)
7940	local_pf(i,j,k) = rad_lw_hr_av(mask_k(mid,k), &
7941	mask_j(mid,j),mask_i(mid,i))
7942	ENDDO
7943	ENDDO
7944	ENDDO
7945	ENDIF
7946
7947	CASE ( 'rad_sw_in' )
7948	IF ( av == 0 ) THEN
7949	DO i = 1, mask_size_l(mid,1)
7950	DO j = 1, mask_size_l(mid,2)
7951	DO k = 1, mask_size_l(mid,3)
7952	local_pf(i,j,k) = rad_sw_in(mask_k(mid,k), &
7953	mask_j(mid,j),mask_i(mid,i))
7954	ENDDO
7955	ENDDO
7956	ENDDO
7957	ELSE
7958	DO i = 1, mask_size_l(mid,1)
7959	DO j = 1, mask_size_l(mid,2)
7960	DO k = 1, mask_size_l(mid,3)
7961	local_pf(i,j,k) = rad_sw_in_av(mask_k(mid,k), &
7962	mask_j(mid,j),mask_i(mid,i))
7963	ENDDO
7964	ENDDO
7965	ENDDO
7966	ENDIF
7967
7968	CASE ( 'rad_sw_out' )
7969	IF ( av == 0 ) THEN
7970	DO i = 1, mask_size_l(mid,1)
7971	DO j = 1, mask_size_l(mid,2)
7972	DO k = 1, mask_size_l(mid,3)
7973	local_pf(i,j,k) = rad_sw_out(mask_k(mid,k), &
7974	mask_j(mid,j),mask_i(mid,i))
7975	ENDDO
7976	ENDDO
7977	ENDDO
7978	ELSE
7979	DO i = 1, mask_size_l(mid,1)
7980	DO j = 1, mask_size_l(mid,2)
7981	DO k = 1, mask_size_l(mid,3)
7982	local_pf(i,j,k) = rad_sw_out_av(mask_k(mid,k), &
7983	mask_j(mid,j),mask_i(mid,i))
7984	ENDDO
7985	ENDDO
7986	ENDDO
7987	ENDIF
7988
7989	CASE ( 'rad_sw_cs_hr' )
7990	IF ( av == 0 ) THEN
7991	DO i = 1, mask_size_l(mid,1)
7992	DO j = 1, mask_size_l(mid,2)
7993	DO k = 1, mask_size_l(mid,3)
7994	local_pf(i,j,k) = rad_sw_cs_hr(mask_k(mid,k), &
7995	mask_j(mid,j),mask_i(mid,i))
7996	ENDDO
7997	ENDDO
7998	ENDDO
7999	ELSE
8000	DO i = 1, mask_size_l(mid,1)
8001	DO j = 1, mask_size_l(mid,2)
8002	DO k = 1, mask_size_l(mid,3)
8003	local_pf(i,j,k) = rad_sw_cs_hr_av(mask_k(mid,k), &
8004	mask_j(mid,j),mask_i(mid,i))
8005	ENDDO
8006	ENDDO
8007	ENDDO
8008	ENDIF
8009
8010	CASE ( 'rad_sw_hr' )
8011	IF ( av == 0 ) THEN
8012	DO i = 1, mask_size_l(mid,1)
8013	DO j = 1, mask_size_l(mid,2)
8014	DO k = 1, mask_size_l(mid,3)
8015	local_pf(i,j,k) = rad_sw_hr(mask_k(mid,k), &
8016	mask_j(mid,j),mask_i(mid,i))
8017	ENDDO
8018	ENDDO
8019	ENDDO
8020	ELSE
8021	DO i = 1, mask_size_l(mid,1)
8022	DO j = 1, mask_size_l(mid,2)
8023	DO k = 1, mask_size_l(mid,3)
8024	local_pf(i,j,k) = rad_sw_hr_av(mask_k(mid,k), &
8025	mask_j(mid,j),mask_i(mid,i))
8026	ENDDO
8027	ENDDO
8028	ENDDO
8029	ENDIF
8030
8031	CASE DEFAULT
8032	found = .FALSE.
8033
8034	END SELECT
8035
8036
8037	END SUBROUTINE radiation_data_output_mask
8038
8039
8040	!------------------------------------------------------------------------------!
8041	!
8042	! Description:
8043	! ------------
8044	!> Subroutine writes the respective restart data
8045	!------------------------------------------------------------------------------!
8046	SUBROUTINE radiation_wrd_local
8047
8048
8049	IMPLICIT NONE
8050
8051
8052	IF ( ALLOCATED( rad_net_av ) ) THEN
8053	CALL wrd_write_string( 'rad_net_av' )
8054	WRITE ( 14 ) rad_net_av
8055	ENDIF
8056
8057	IF ( ALLOCATED( rad_lw_in ) ) THEN
8058	CALL wrd_write_string( 'rad_lw_in' )
8059	WRITE ( 14 ) rad_lw_in
8060	ENDIF
8061
8062	IF ( ALLOCATED( rad_lw_in_av ) ) THEN
8063	CALL wrd_write_string( 'rad_lw_in_av' )
8064	WRITE ( 14 ) rad_lw_in_av
8065	ENDIF
8066
8067	IF ( ALLOCATED( rad_lw_out ) ) THEN
8068	CALL wrd_write_string( 'rad_lw_out' )
8069	WRITE ( 14 ) rad_lw_out
8070	ENDIF
8071
8072	IF ( ALLOCATED( rad_lw_out_av) ) THEN
8073	CALL wrd_write_string( 'rad_lw_out_av' )
8074	WRITE ( 14 ) rad_lw_out_av
8075	ENDIF
8076
8077	IF ( ALLOCATED( rad_lw_cs_hr) ) THEN
8078	CALL wrd_write_string( 'rad_lw_cs_hr' )
8079	WRITE ( 14 ) rad_lw_cs_hr
8080	ENDIF
8081
8082	IF ( ALLOCATED( rad_lw_cs_hr_av) ) THEN
8083	CALL wrd_write_string( 'rad_lw_cs_hr_av' )
8084	WRITE ( 14 ) rad_lw_cs_hr_av
8085	ENDIF
8086
8087	IF ( ALLOCATED( rad_lw_hr) ) THEN
8088	CALL wrd_write_string( 'rad_lw_hr' )
8089	WRITE ( 14 ) rad_lw_hr
8090	ENDIF
8091
8092	IF ( ALLOCATED( rad_lw_hr_av) ) THEN
8093	CALL wrd_write_string( 'rad_lw_hr_av' )
8094	WRITE ( 14 ) rad_lw_hr_av
8095	ENDIF
8096
8097	IF ( ALLOCATED( rad_sw_in) ) THEN
8098	CALL wrd_write_string( 'rad_sw_in' )
8099	WRITE ( 14 ) rad_sw_in
8100	ENDIF
8101
8102	IF ( ALLOCATED( rad_sw_in_av) ) THEN
8103	CALL wrd_write_string( 'rad_sw_in_av' )
8104	WRITE ( 14 ) rad_sw_in_av
8105	ENDIF
8106
8107	IF ( ALLOCATED( rad_sw_out) ) THEN
8108	CALL wrd_write_string( 'rad_sw_out' )
8109	WRITE ( 14 ) rad_sw_out
8110	ENDIF
8111
8112	IF ( ALLOCATED( rad_sw_out_av) ) THEN
8113	CALL wrd_write_string( 'rad_sw_out_av' )
8114	WRITE ( 14 ) rad_sw_out_av
8115	ENDIF
8116
8117	IF ( ALLOCATED( rad_sw_cs_hr) ) THEN
8118	CALL wrd_write_string( 'rad_sw_cs_hr' )
8119	WRITE ( 14 ) rad_sw_cs_hr
8120	ENDIF
8121
8122	IF ( ALLOCATED( rad_sw_cs_hr_av) ) THEN
8123	CALL wrd_write_string( 'rad_sw_cs_hr_av' )
8124	WRITE ( 14 ) rad_sw_cs_hr_av
8125	ENDIF
8126
8127	IF ( ALLOCATED( rad_sw_hr) ) THEN
8128	CALL wrd_write_string( 'rad_sw_hr' )
8129	WRITE ( 14 ) rad_sw_hr
8130	ENDIF
8131
8132	IF ( ALLOCATED( rad_sw_hr_av) ) THEN
8133	CALL wrd_write_string( 'rad_sw_hr_av' )
8134	WRITE ( 14 ) rad_sw_hr_av
8135	ENDIF
8136
8137
8138	END SUBROUTINE radiation_wrd_local
8139
8140
8141	SUBROUTINE radiation_rrd_local( i, k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, &
8142	nxr_on_file, nynf, nync, nyn_on_file, nysf, &
8143	nysc, nys_on_file, tmp_2d, tmp_3d, found )
8144
8145
8146	USE control_parameters
8147
8148	USE indices
8149
8150	USE kinds
8151
8152	USE pegrid
8153
8154
8155	IMPLICIT NONE
8156
8157	INTEGER(iwp) :: i !<
8158	INTEGER(iwp) :: k !<
8159	INTEGER(iwp) :: nxlc !<
8160	INTEGER(iwp) :: nxlf !<
8161	INTEGER(iwp) :: nxl_on_file !<
8162	INTEGER(iwp) :: nxrc !<
8163	INTEGER(iwp) :: nxrf !<
8164	INTEGER(iwp) :: nxr_on_file !<
8165	INTEGER(iwp) :: nync !<
8166	INTEGER(iwp) :: nynf !<
8167	INTEGER(iwp) :: nyn_on_file !<
8168	INTEGER(iwp) :: nysc !<
8169	INTEGER(iwp) :: nysf !<
8170	INTEGER(iwp) :: nys_on_file !<
8171
8172	LOGICAL, INTENT(OUT) :: found
8173
8174	REAL(wp), DIMENSION(nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_2d !<
8175
8176	REAL(wp), DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d !<
8177
8178	REAL(wp), DIMENSION(0:0,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d2 !<
8179
8180
8181	found = .TRUE.
8182
8183
8184	SELECT CASE ( restart_string(1:length) )
8185
8186	CASE ( 'rad_net_av' )
8187	IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
8188	ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
8189	ENDIF
8190	IF ( k == 1 ) READ ( 13 ) tmp_2d
8191	rad_net_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8192	tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8193	CASE ( 'rad_lw_in' )
8194	IF ( .NOT. ALLOCATED( rad_lw_in ) ) THEN
8195	IF ( radiation_scheme == 'clear-sky' .OR. &
8196	radiation_scheme == 'constant') THEN
8197	ALLOCATE( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) )
8198	ELSE
8199	ALLOCATE( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8200	ENDIF
8201	ENDIF
8202	IF ( k == 1 ) THEN
8203	IF ( radiation_scheme == 'clear-sky' .OR. &
8204	radiation_scheme == 'constant') THEN
8205	READ ( 13 ) tmp_3d2
8206	rad_lw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8207	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8208	ELSE
8209	READ ( 13 ) tmp_3d
8210	rad_lw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8211	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8212	ENDIF
8213	ENDIF
8214
8215	CASE ( 'rad_lw_in_av' )
8216	IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
8217	IF ( radiation_scheme == 'clear-sky' .OR. &
8218	radiation_scheme == 'constant') THEN
8219	ALLOCATE( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
8220	ELSE
8221	ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8222	ENDIF
8223	ENDIF
8224	IF ( k == 1 ) THEN
8225	IF ( radiation_scheme == 'clear-sky' .OR. &
8226	radiation_scheme == 'constant') THEN
8227	READ ( 13 ) tmp_3d2
8228	rad_lw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&
8229	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8230	ELSE
8231	READ ( 13 ) tmp_3d
8232	rad_lw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8233	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8234	ENDIF
8235	ENDIF
8236
8237	CASE ( 'rad_lw_out' )
8238	IF ( .NOT. ALLOCATED( rad_lw_out ) ) THEN
8239	IF ( radiation_scheme == 'clear-sky' .OR. &
8240	radiation_scheme == 'constant') THEN
8241	ALLOCATE( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) )
8242	ELSE
8243	ALLOCATE( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8244	ENDIF
8245	ENDIF
8246	IF ( k == 1 ) THEN
8247	IF ( radiation_scheme == 'clear-sky' .OR. &
8248	radiation_scheme == 'constant') THEN
8249	READ ( 13 ) tmp_3d2
8250	rad_lw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8251	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8252	ELSE
8253	READ ( 13 ) tmp_3d
8254	rad_lw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8255	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8256	ENDIF
8257	ENDIF
8258
8259	CASE ( 'rad_lw_out_av' )
8260	IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
8261	IF ( radiation_scheme == 'clear-sky' .OR. &
8262	radiation_scheme == 'constant') THEN
8263	ALLOCATE( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
8264	ELSE
8265	ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8266	ENDIF
8267	ENDIF
8268	IF ( k == 1 ) THEN
8269	IF ( radiation_scheme == 'clear-sky' .OR. &
8270	radiation_scheme == 'constant') THEN
8271	READ ( 13 ) tmp_3d2
8272	rad_lw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) &
8273	= tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8274	ELSE
8275	READ ( 13 ) tmp_3d
8276	rad_lw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8277	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8278	ENDIF
8279	ENDIF
8280
8281	CASE ( 'rad_lw_cs_hr' )
8282	IF ( .NOT. ALLOCATED( rad_lw_cs_hr ) ) THEN
8283	ALLOCATE( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8284	ENDIF
8285	IF ( k == 1 ) READ ( 13 ) tmp_3d
8286	rad_lw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8287	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8288
8289	CASE ( 'rad_lw_cs_hr_av' )
8290	IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
8291	ALLOCATE( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8292	ENDIF
8293	IF ( k == 1 ) READ ( 13 ) tmp_3d
8294	rad_lw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8295	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8296
8297	CASE ( 'rad_lw_hr' )
8298	IF ( .NOT. ALLOCATED( rad_lw_hr ) ) THEN
8299	ALLOCATE( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8300	ENDIF
8301	IF ( k == 1 ) READ ( 13 ) tmp_3d
8302	rad_lw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8303	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8304
8305	CASE ( 'rad_lw_hr_av' )
8306	IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
8307	ALLOCATE( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8308	ENDIF
8309	IF ( k == 1 ) READ ( 13 ) tmp_3d
8310	rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8311	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8312
8313	CASE ( 'rad_sw_in' )
8314	IF ( .NOT. ALLOCATED( rad_sw_in ) ) THEN
8315	IF ( radiation_scheme == 'clear-sky' .OR. &
8316	radiation_scheme == 'constant') THEN
8317	ALLOCATE( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) )
8318	ELSE
8319	ALLOCATE( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8320	ENDIF
8321	ENDIF
8322	IF ( k == 1 ) THEN
8323	IF ( radiation_scheme == 'clear-sky' .OR. &
8324	radiation_scheme == 'constant') THEN
8325	READ ( 13 ) tmp_3d2
8326	rad_sw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8327	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8328	ELSE
8329	READ ( 13 ) tmp_3d
8330	rad_sw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8331	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8332	ENDIF
8333	ENDIF
8334
8335	CASE ( 'rad_sw_in_av' )
8336	IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
8337	IF ( radiation_scheme == 'clear-sky' .OR. &
8338	radiation_scheme == 'constant') THEN
8339	ALLOCATE( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
8340	ELSE
8341	ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8342	ENDIF
8343	ENDIF
8344	IF ( k == 1 ) THEN
8345	IF ( radiation_scheme == 'clear-sky' .OR. &
8346	radiation_scheme == 'constant') THEN
8347	READ ( 13 ) tmp_3d2
8348	rad_sw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&
8349	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8350	ELSE
8351	READ ( 13 ) tmp_3d
8352	rad_sw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8353	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8354	ENDIF
8355	ENDIF
8356
8357	CASE ( 'rad_sw_out' )
8358	IF ( .NOT. ALLOCATED( rad_sw_out ) ) THEN
8359	IF ( radiation_scheme == 'clear-sky' .OR. &
8360	radiation_scheme == 'constant') THEN
8361	ALLOCATE( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) )
8362	ELSE
8363	ALLOCATE( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8364	ENDIF
8365	ENDIF
8366	IF ( k == 1 ) THEN
8367	IF ( radiation_scheme == 'clear-sky' .OR. &
8368	radiation_scheme == 'constant') THEN
8369	READ ( 13 ) tmp_3d2
8370	rad_sw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8371	tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8372	ELSE
8373	READ ( 13 ) tmp_3d
8374	rad_sw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8375	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8376	ENDIF
8377	ENDIF
8378
8379	CASE ( 'rad_sw_out_av' )
8380	IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
8381	IF ( radiation_scheme == 'clear-sky' .OR. &
8382	radiation_scheme == 'constant') THEN
8383	ALLOCATE( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
8384	ELSE
8385	ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8386	ENDIF
8387	ENDIF
8388	IF ( k == 1 ) THEN
8389	IF ( radiation_scheme == 'clear-sky' .OR. &
8390	radiation_scheme == 'constant') THEN
8391	READ ( 13 ) tmp_3d2
8392	rad_sw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) &
8393	= tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8394	ELSE
8395	READ ( 13 ) tmp_3d
8396	rad_sw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8397	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8398	ENDIF
8399	ENDIF
8400
8401	CASE ( 'rad_sw_cs_hr' )
8402	IF ( .NOT. ALLOCATED( rad_sw_cs_hr ) ) THEN
8403	ALLOCATE( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8404	ENDIF
8405	IF ( k == 1 ) READ ( 13 ) tmp_3d
8406	rad_sw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8407	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8408
8409	CASE ( 'rad_sw_cs_hr_av' )
8410	IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
8411	ALLOCATE( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8412	ENDIF
8413	IF ( k == 1 ) READ ( 13 ) tmp_3d
8414	rad_sw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8415	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8416
8417	CASE ( 'rad_sw_hr' )
8418	IF ( .NOT. ALLOCATED( rad_sw_hr ) ) THEN
8419	ALLOCATE( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8420	ENDIF
8421	IF ( k == 1 ) READ ( 13 ) tmp_3d
8422	rad_sw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8423	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8424
8425	CASE ( 'rad_sw_hr_av' )
8426	IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
8427	ALLOCATE( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8428	ENDIF
8429	IF ( k == 1 ) READ ( 13 ) tmp_3d
8430	rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
8431	tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
8432
8433	CASE DEFAULT
8434
8435	found = .FALSE.
8436
8437	END SELECT
8438
8439
8440	END SUBROUTINE radiation_rrd_local
8441
8442
8443	END MODULE radiation_model_mod

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

Download in other formats:

| Impressum | ©Leibniz Universität Hannover |