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

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

Bugfix in raytracing - add an epsilon value to overcome precision-related errors.

  • Property svn:keywords set to Id
  • Property svn:mergeinfo set to (toggle deleted branches)
    /palm/branches/chemistry/SOURCE/radiation_model_mod.f902047-3190,​3218-3297
    /palm/branches/forwind/SOURCE/radiation_model_mod.f901564-1913
    /palm/branches/palm4u/SOURCE/radiation_model_mod.f902540-2692
    /palm/branches/radiation/SOURCE/radiation_model_mod.f902081-3493
    /palm/branches/rans/SOURCE/radiation_model_mod.f902078-3128
    /palm/branches/resler/SOURCE/radiation_model_mod.f902023-3336
    /palm/branches/salsa/SOURCE/radiation_model_mod.f902503-3460
File size: 449.7 KB
Line 
1!> @file radiation_model_mod.f90
2!------------------------------------------------------------------------------!
3! This file is part of the PALM model system.
4!
5! PALM is free software: you can redistribute it and/or modify it under the
6! terms of the GNU General Public License as published by the Free Software
7! Foundation, either version 3 of the License, or (at your option) any later
8! version.
9!
10! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13!
14! You should have received a copy of the GNU General Public License along with
15! PALM. If not, see <http://www.gnu.org/licenses/>.
16!
17! Copyright 2015-2018 Institute of Computer Science of the
18!                     Czech Academy of Sciences, Prague
19! Copyright 2015-2018 Czech Technical University in Prague
20! Copyright 1997-2018 Leibniz Universitaet Hannover
21!------------------------------------------------------------------------------!
22!
23! Current revisions:
24! ------------------
25!
26!
27! Former revisions:
28! -----------------
29! $Id: radiation_model_mod.f90 3528 2018-11-15 19:07:11Z gronemeier $
30! Add an epsilon value to compare values in if statement to fix possible
31! precsion related errors in raytrace routines.
32!
33! 3524 2018-11-14 13:36:44Z raasch
34! missing cpp-directives added
35!
36! 3495 2018-11-06 15:22:17Z kanani
37! Resort control_parameters ONLY list,
38! From branch radiation@3491 moh.hefny:
39! bugfix in calculating the apparent solar positions by updating
40! the simulated time so that the actual time is correct.
41!
42! 3464 2018-10-30 18:08:55Z kanani
43! From branch resler@3462, pavelkrc:
44! add MRT shaping function for human
45!
46! 3449 2018-10-29 19:36:56Z suehring
47! New RTM version 3.0: (Pavel Krc, Jaroslav Resler, ICS, Prague)
48!   - Interaction of plant canopy with LW radiation
49!   - Transpiration from resolved plant canopy dependent on radiation
50!     called from RTM
51!
52!
53! 3435 2018-10-26 18:25:44Z gronemeier
54! - workaround: return unit=illegal in check_data_output for certain variables
55!   when check called from init_masks
56! - Use pointer in masked output to reduce code redundancies
57! - Add terrain-following masked output
58!
59! 3424 2018-10-25 07:29:10Z gronemeier
60! bugfix: add rad_lw_in, rad_lw_out, rad_sw_out to radiation_check_data_output
61!
62! 3378 2018-10-19 12:34:59Z kanani
63! merge from radiation branch (r3362) into trunk
64! (moh.hefny):
65! - removed read/write_svf_on_init and read_dist_max_svf (not used anymore)
66! - bugfix nzut > nzpt in calculating maxboxes
67!
68! 3372 2018-10-18 14:03:19Z raasch
69! bugfix: kind type of 2nd argument of mpi_win_allocate changed, misplaced
70!         __parallel directive
71!
72! 3351 2018-10-15 18:40:42Z suehring
73! Do not overwrite values of spectral and broadband albedo during initialization
74! if they are already initialized in the urban-surface model via ASCII input.
75!
76! 3337 2018-10-12 15:17:09Z kanani
77! - New RTM version 2.9: (Pavel Krc, Jaroslav Resler, ICS, Prague)
78!   added calculation of the MRT inside the RTM module
79!   MRT fluxes are consequently used in the new biometeorology module
80!   for calculation of biological indices (MRT, PET)
81!   Fixes of v. 2.5 and SVN trunk:
82!    - proper initialization of rad_net_l
83!    - make arrays nsurfs and surfstart TARGET to prevent some MPI problems
84!    - initialization of arrays used in MPI one-sided operation as 1-D arrays
85!      to prevent problems with some MPI/compiler combinations
86!    - fix indexing of target displacement in subroutine request_itarget to
87!      consider nzub
88!    - fix LAD dimmension range in PCB calculation
89!    - check ierr in all MPI calls
90!    - use proper per-gridbox sky and diffuse irradiance
91!    - fix shading for reflected irradiance
92!    - clear away the residuals of "atmospheric surfaces" implementation
93!    - fix rounding bug in raytrace_2d introduced in SVN trunk
94! - New RTM version 2.5: (Pavel Krc, Jaroslav Resler, ICS, Prague)
95!   can use angular discretization for all SVF
96!   (i.e. reflected and emitted radiation in addition to direct and diffuse),
97!   allowing for much better scaling wih high resoltion and/or complex terrain
98! - Unite array grow factors
99! - Fix slightly shifted terrain height in raytrace_2d
100! - Use more efficient MPI_Win_allocate for reverse gridsurf index
101! - Fix random MPI RMA bugs on Intel compilers
102! - Fix approx. double plant canopy sink values for reflected radiation
103! - Fix mostly missing plant canopy sinks for direct radiation
104! - Fix discretization errors for plant canopy sink in diffuse radiation
105! - Fix rounding errors in raytrace_2d
106!
107! 3274 2018-09-24 15:42:55Z knoop
108! Modularization of all bulk cloud physics code components
109!
110! 3272 2018-09-24 10:16:32Z suehring
111! - split direct and diffusion shortwave radiation using RRTMG rather than using
112!   calc_diffusion_radiation, in case of RRTMG
113! - removed the namelist variable split_diffusion_radiation. Now splitting depends
114!   on the choise of radiation radiation scheme
115! - removed calculating the rdiation flux for surfaces at the radiation scheme
116!   in case of using RTM since it will be calculated anyway in the radiation
117!   interaction routine.
118! - set SW radiation flux for surfaces to zero at night in case of no RTM is used
119! - precalculate the unit vector yxdir of ray direction to avoid the temporarly
120!   array allocation during the subroutine call
121! - fixed a bug in calculating the max number of boxes ray can cross in the domain
122!
123! 3264 2018-09-20 13:54:11Z moh.hefny
124! Bugfix in raytrace_2d calls
125!
126! 3248 2018-09-14 09:42:06Z sward
127! Minor formating changes
128!
129! 3246 2018-09-13 15:14:50Z sward
130! Added error handling for input namelist via parin_fail_message
131!
132! 3241 2018-09-12 15:02:00Z raasch
133! unused variables removed or commented
134!
135! 3233 2018-09-07 13:21:24Z schwenkel
136! Adapted for the use of cloud_droplets
137!
138! 3230 2018-09-05 09:29:05Z schwenkel
139! Bugfix in radiation_constant_surf: changed (10.0 - emissivity_urb) to
140! (1.0 - emissivity_urb)
141!
142! 3226 2018-08-31 12:27:09Z suehring
143! Bugfixes in calculation of sky-view factors and canopy-sink factors.
144!
145! 3186 2018-07-30 17:07:14Z suehring
146! Remove print statement
147!
148! 3180 2018-07-27 11:00:56Z suehring
149! Revise concept for calculation of effective radiative temperature and mapping
150! of radiative heating
151!
152! 3175 2018-07-26 14:07:38Z suehring
153! Bugfix for commit 3172
154!
155! 3173 2018-07-26 12:55:23Z suehring
156! Revise output of surface radiation quantities in case of overhanging
157! structures
158!
159! 3172 2018-07-26 12:06:06Z suehring
160! Bugfixes:
161!  - temporal work-around for calculation of effective radiative surface
162!    temperature
163!  - prevent positive solar radiation during nighttime
164!
165! 3170 2018-07-25 15:19:37Z suehring
166! Bugfix, map signle-column radiation forcing profiles on top of any topography
167!
168! 3156 2018-07-19 16:30:54Z knoop
169! Bugfix: replaced usage of the pt array with the surf%pt_surface array
170!
171! 3137 2018-07-17 06:44:21Z maronga
172! String length for trace_names fixed
173!
174! 3127 2018-07-15 08:01:25Z maronga
175! A few pavement parameters updated.
176!
177! 3123 2018-07-12 16:21:53Z suehring
178! Correct working precision for INTEGER number
179!
180! 3122 2018-07-11 21:46:41Z maronga
181! Bugfix: maximum distance for raytracing was set to  -999 m by default,
182! effectively switching off all surface reflections when max_raytracing_dist
183! was not explicitly set in namelist
184!
185! 3117 2018-07-11 09:59:11Z maronga
186! Bugfix: water vapor was not transfered to RRTMG when bulk_cloud_model = .F.
187! Bugfix: changed the calculation of RRTMG boundary conditions (Mohamed Salim)
188! Bugfix: dry residual atmosphere is replaced by standard RRTMG atmosphere
189!
190! 3116 2018-07-10 14:31:58Z suehring
191! Output of long/shortwave radiation at surface
192!
193! 3107 2018-07-06 15:55:51Z suehring
194! Bugfix, missing index for dz
195!
196! 3066 2018-06-12 08:55:55Z Giersch
197! Error message revised
198!
199! 3065 2018-06-12 07:03:02Z Giersch
200! dz was replaced by dz(1), error message concerning vertical stretching was
201! added 
202!
203! 3049 2018-05-29 13:52:36Z Giersch
204! Error messages revised
205!
206! 3045 2018-05-28 07:55:41Z Giersch
207! Error message revised
208!
209! 3026 2018-05-22 10:30:53Z schwenkel
210! Changed the name specific humidity to mixing ratio, since we are computing
211! mixing ratios.
212!
213! 3016 2018-05-09 10:53:37Z Giersch
214! Revised structure of reading svf data according to PALM coding standard:
215! svf_code_field/len and fsvf removed, error messages PA0493 and PA0494 added,
216! allocation status of output arrays checked.
217!
218! 3014 2018-05-09 08:42:38Z maronga
219! Introduced plant canopy height similar to urban canopy height to limit
220! the memory requirement to allocate lad.
221! Deactivated automatic setting of minimum raytracing distance.
222!
223! 3004 2018-04-27 12:33:25Z Giersch
224! Further allocation checks implemented (averaged data will be assigned to fill
225! values if no allocation happened so far)
226!
227! 2995 2018-04-19 12:13:16Z Giersch
228! IF-statement in radiation_init removed so that the calculation of radiative
229! fluxes at model start is done in any case, bugfix in
230! radiation_presimulate_solar_pos (end_time is the sum of end_time and the
231! spinup_time specified in the p3d_file ), list of variables/fields that have
232! to be written out or read in case of restarts has been extended
233!
234! 2977 2018-04-17 10:27:57Z kanani
235! Implement changes from branch radiation (r2948-2971) with minor modifications,
236! plus some formatting.
237! (moh.hefny):
238! - replaced plant_canopy by npcbl to check tree existence to avoid weird
239!   allocation of related arrays (after domain decomposition some domains
240!   contains no trees although plant_canopy (global parameter) is still TRUE).
241! - added a namelist parameter to force RTM settings
242! - enabled the option to switch radiation reflections off
243! - renamed surf_reflections to surface_reflections
244! - removed average_radiation flag from the namelist (now it is implicitly set
245!   in init_3d_model according to RTM)
246! - edited read and write sky view factors and CSF routines to account for
247!   the sub-domains which may not contain any of them
248!
249! 2967 2018-04-13 11:22:08Z raasch
250! bugfix: missing parallel cpp-directives added
251!
252! 2964 2018-04-12 16:04:03Z Giersch
253! Error message PA0491 has been introduced which could be previously found in
254! check_open. The variable numprocs_previous_run is only known in case of
255! initializing_actions == read_restart_data
256!
257! 2963 2018-04-12 14:47:44Z suehring
258! - Introduce index for vegetation/wall, pavement/green-wall and water/window
259!   surfaces, for clearer access of surface fraction, albedo, emissivity, etc. .
260! - Minor bugfix in initialization of albedo for window surfaces
261!
262! 2944 2018-04-03 16:20:18Z suehring
263! Fixed bad commit
264!
265! 2943 2018-04-03 16:17:10Z suehring
266! No read of nsurfl from SVF file since it is calculated in
267! radiation_interaction_init,
268! allocation of arrays in radiation_read_svf only if not yet allocated,
269! update of 2920 revision comment.
270!
271! 2932 2018-03-26 09:39:22Z maronga
272! renamed radiation_par to radiation_parameters
273!
274! 2930 2018-03-23 16:30:46Z suehring
275! Remove default surfaces from radiation model, does not make much sense to
276! apply radiation model without energy-balance solvers; Further, add check for
277! this.
278!
279! 2920 2018-03-22 11:22:01Z kanani
280! - Bugfix: Initialize pcbl array (=-1)
281! RTM version 2.0 (Jaroslav Resler, Pavel Krc, Mohamed Salim):
282! - new major version of radiation interactions
283! - substantially enhanced performance and scalability
284! - processing of direct and diffuse solar radiation separated from reflected
285!   radiation, removed virtual surfaces
286! - new type of sky discretization by azimuth and elevation angles
287! - diffuse radiation processed cumulatively using sky view factor
288! - used precalculated apparent solar positions for direct irradiance
289! - added new 2D raytracing process for processing whole vertical column at once
290!   to increase memory efficiency and decrease number of MPI RMA operations
291! - enabled limiting the number of view factors between surfaces by the distance
292!   and value
293! - fixing issues induced by transferring radiation interactions from
294!   urban_surface_mod to radiation_mod
295! - bugfixes and other minor enhancements
296!
297! 2906 2018-03-19 08:56:40Z Giersch
298! NAMELIST paramter read/write_svf_on_init have been removed, functions
299! check_open and close_file are used now for opening/closing files related to
300! svf data, adjusted unit number and error numbers
301!
302! 2894 2018-03-15 09:17:58Z Giersch
303! Calculations of the index range of the subdomain on file which overlaps with
304! the current subdomain are already done in read_restart_data_mod
305! radiation_read_restart_data was renamed to radiation_rrd_local and
306! radiation_last_actions was renamed to radiation_wrd_local, variable named
307! found has been introduced for checking if restart data was found, reading
308! of restart strings has been moved completely to read_restart_data_mod,
309! radiation_rrd_local is already inside the overlap loop programmed in
310! read_restart_data_mod, the marker *** end rad *** is not necessary anymore,
311! strings and their respective lengths are written out and read now in case of
312! restart runs to get rid of prescribed character lengths (Giersch)
313!
314! 2809 2018-02-15 09:55:58Z suehring
315! Bugfix for gfortran: Replace the function C_SIZEOF with STORAGE_SIZE
316!
317! 2753 2018-01-16 14:16:49Z suehring
318! Tile approach for spectral albedo implemented.
319!
320! 2746 2018-01-15 12:06:04Z suehring
321! Move flag plant canopy to modules
322!
323! 2724 2018-01-05 12:12:38Z maronga
324! Set default of average_radiation to .FALSE.
325!
326! 2723 2018-01-05 09:27:03Z maronga
327! Bugfix in calculation of rad_lw_out (clear-sky). First grid level was used
328! instead of the surface value
329!
330! 2718 2018-01-02 08:49:38Z maronga
331! Corrected "Former revisions" section
332!
333! 2707 2017-12-18 18:34:46Z suehring
334! Changes from last commit documented
335!
336! 2706 2017-12-18 18:33:49Z suehring
337! Bugfix, in average radiation case calculate exner function before using it.
338!
339! 2701 2017-12-15 15:40:50Z suehring
340! Changes from last commit documented
341!
342! 2698 2017-12-14 18:46:24Z suehring
343! Bugfix in get_topography_top_index
344!
345! 2696 2017-12-14 17:12:51Z kanani
346! - Change in file header (GPL part)
347! - Improved reading/writing of SVF from/to file (BM)
348! - Bugfixes concerning RRTMG as well as average_radiation options (M. Salim)
349! - Revised initialization of surface albedo and some minor bugfixes (MS)
350! - Update net radiation after running radiation interaction routine (MS)
351! - Revisions from M Salim included
352! - Adjustment to topography and surface structure (MS)
353! - Initialization of albedo and surface emissivity via input file (MS)
354! - albedo_pars extended (MS)
355!
356! 2604 2017-11-06 13:29:00Z schwenkel
357! bugfix for calculation of effective radius using morrison microphysics
358!
359! 2601 2017-11-02 16:22:46Z scharf
360! added emissivity to namelist
361!
362! 2575 2017-10-24 09:57:58Z maronga
363! Bugfix: calculation of shortwave and longwave albedos for RRTMG swapped
364!
365! 2547 2017-10-16 12:41:56Z schwenkel
366! extended by cloud_droplets option, minor bugfix and correct calculation of
367! cloud droplet number concentration
368!
369! 2544 2017-10-13 18:09:32Z maronga
370! Moved date and time quantitis to separate module date_and_time_mod
371!
372! 2512 2017-10-04 08:26:59Z raasch
373! upper bounds of cross section and 3d output changed from nx+1,ny+1 to nx,ny
374! no output of ghost layer data
375!
376! 2504 2017-09-27 10:36:13Z maronga
377! Updates pavement types and albedo parameters
378!
379! 2328 2017-08-03 12:34:22Z maronga
380! Emissivity can now be set individually for each pixel.
381! Albedo type can be inferred from land surface model.
382! Added default albedo type for bare soil
383!
384! 2318 2017-07-20 17:27:44Z suehring
385! Get topography top index via Function call
386!
387! 2317 2017-07-20 17:27:19Z suehring
388! Improved syntax layout
389!
390! 2298 2017-06-29 09:28:18Z raasch
391! type of write_binary changed from CHARACTER to LOGICAL
392!
393! 2296 2017-06-28 07:53:56Z maronga
394! Added output of rad_sw_out for radiation_scheme = 'constant'
395!
396! 2270 2017-06-09 12:18:47Z maronga
397! Numbering changed (2 timeseries removed)
398!
399! 2249 2017-06-06 13:58:01Z sward
400! Allow for RRTMG runs without humidity/cloud physics
401!
402! 2248 2017-06-06 13:52:54Z sward
403! Error no changed
404!
405! 2233 2017-05-30 18:08:54Z suehring
406!
407! 2232 2017-05-30 17:47:52Z suehring
408! Adjustments to new topography concept
409! Bugfix in read restart
410!
411! 2200 2017-04-11 11:37:51Z suehring
412! Bugfix in call of exchange_horiz_2d and read restart data
413!
414! 2163 2017-03-01 13:23:15Z schwenkel
415! Bugfix in radiation_check_data_output
416!
417! 2157 2017-02-22 15:10:35Z suehring
418! Bugfix in read_restart data
419!
420! 2011 2016-09-19 17:29:57Z kanani
421! Removed CALL of auxiliary SUBROUTINE get_usm_info,
422! flag urban_surface is now defined in module control_parameters.
423!
424! 2007 2016-08-24 15:47:17Z kanani
425! Added calculation of solar directional vector for new urban surface
426! model,
427! accounted for urban_surface model in radiation_check_parameters,
428! correction of comments for zenith angle.
429!
430! 2000 2016-08-20 18:09:15Z knoop
431! Forced header and separation lines into 80 columns
432!
433! 1976 2016-07-27 13:28:04Z maronga
434! Output of 2D/3D/masked data is now directly done within this module. The
435! radiation schemes have been simplified for better usability so that
436! rad_lw_in, rad_lw_out, rad_sw_in, and rad_sw_out are available independent of
437! the radiation code used.
438!
439! 1856 2016-04-13 12:56:17Z maronga
440! Bugfix: allocation of rad_lw_out for radiation_scheme = 'clear-sky'
441!
442! 1853 2016-04-11 09:00:35Z maronga
443! Added routine for radiation_scheme = constant.
444
445! 1849 2016-04-08 11:33:18Z hoffmann
446! Adapted for modularization of microphysics
447!
448! 1826 2016-04-07 12:01:39Z maronga
449! Further modularization.
450!
451! 1788 2016-03-10 11:01:04Z maronga
452! Added new albedo class for pavements / roads.
453!
454! 1783 2016-03-06 18:36:17Z raasch
455! palm-netcdf-module removed in order to avoid a circular module dependency,
456! netcdf-variables moved to netcdf-module, new routine netcdf_handle_error_rad
457! added
458!
459! 1757 2016-02-22 15:49:32Z maronga
460! Added parameter unscheduled_radiation_calls. Bugfix: interpolation of sounding
461! profiles for pressure and temperature above the LES domain.
462!
463! 1709 2015-11-04 14:47:01Z maronga
464! Bugfix: set initial value for rrtm_lwuflx_dt to zero, small formatting
465! corrections
466!
467! 1701 2015-11-02 07:43:04Z maronga
468! Bugfixes: wrong index for output of timeseries, setting of nz_snd_end
469!
470! 1691 2015-10-26 16:17:44Z maronga
471! Added option for spin-up runs without radiation (skip_time_do_radiation). Bugfix
472! in calculation of pressure profiles. Bugfix in calculation of trace gas profiles.
473! Added output of radiative heating rates.
474!
475! 1682 2015-10-07 23:56:08Z knoop
476! Code annotations made doxygen readable
477!
478! 1606 2015-06-29 10:43:37Z maronga
479! Added preprocessor directive __netcdf to allow for compiling without netCDF.
480! Note, however, that RRTMG cannot be used without netCDF.
481!
482! 1590 2015-05-08 13:56:27Z maronga
483! Bugfix: definition of character strings requires same length for all elements
484!
485! 1587 2015-05-04 14:19:01Z maronga
486! Added albedo class for snow
487!
488! 1585 2015-04-30 07:05:52Z maronga
489! Added support for RRTMG
490!
491! 1571 2015-03-12 16:12:49Z maronga
492! Added missing KIND attribute. Removed upper-case variable names
493!
494! 1551 2015-03-03 14:18:16Z maronga
495! Added support for data output. Various variables have been renamed. Added
496! interface for different radiation schemes (currently: clear-sky, constant, and
497! RRTM (not yet implemented).
498!
499! 1496 2014-12-02 17:25:50Z maronga
500! Initial revision
501!
502!
503! Description:
504! ------------
505!> Radiation models and interfaces
506!> @todo Replace dz(1) appropriatly to account for grid stretching
507!> @todo move variable definitions used in radiation_init only to the subroutine
508!>       as they are no longer required after initialization.
509!> @todo Output of full column vertical profiles used in RRTMG
510!> @todo Output of other rrtm arrays (such as volume mixing ratios)
511!> @todo Check for mis-used NINT() calls in raytrace_2d
512!>       RESULT: Original was correct (carefully verified formula), the change
513!>               to INT broke raytracing      -- P. Krc
514!> @todo Optimize radiation_tendency routines
515!>
516!> @note Many variables have a leading dummy dimension (0:0) in order to
517!>       match the assume-size shape expected by the RRTMG model.
518!------------------------------------------------------------------------------!
519 MODULE radiation_model_mod
520 
521    USE arrays_3d,                                                             &
522        ONLY:  dzw, hyp, nc, pt, p, q, ql, u, v, w, zu, zw, exner, d_exner
523
524    USE basic_constants_and_equations_mod,                                     &
525        ONLY:  c_p, g, lv_d_cp, l_v, pi, r_d, rho_l, solar_constant,      &
526               barometric_formula
527
528    USE calc_mean_profile_mod,                                                 &
529        ONLY:  calc_mean_profile
530
531    USE control_parameters,                                                    &
532        ONLY:  cloud_droplets, coupling_char, dz, dt_spinup, end_time,         &
533               humidity,                                                       &
534               initializing_actions, io_blocks, io_group,                      &
535               land_surface, large_scale_forcing,                              &
536               latitude, longitude, lsf_surf,                                  &
537               message_string, plant_canopy, pt_surface,                       &
538               rho_surface, simulated_time, spinup_time, surface_pressure,     &
539               time_since_reference_point, urban_surface
540
541    USE cpulog,                                                                &
542        ONLY:  cpu_log, log_point, log_point_s
543
544    USE grid_variables,                                                        &
545         ONLY:  ddx, ddy, dx, dy 
546
547    USE date_and_time_mod,                                                     &
548        ONLY:  calc_date_and_time, d_hours_day, d_seconds_hour, day_of_year,   &
549               d_seconds_year, day_of_year_init, time_utc_init, time_utc
550
551    USE indices,                                                               &
552        ONLY:  nnx, nny, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg,   &
553               nzb, nzt
554
555    USE, INTRINSIC :: iso_c_binding
556
557    USE kinds
558
559    USE bulk_cloud_model_mod,                                                  &
560        ONLY:  bulk_cloud_model, microphysics_morrison, na_init, nc_const, sigma_gc
561
562#if defined ( __netcdf )
563    USE NETCDF
564#endif
565
566    USE netcdf_data_input_mod,                                                 &
567        ONLY:  albedo_type_f, albedo_pars_f, building_type_f, pavement_type_f, &
568               vegetation_type_f, water_type_f
569
570    USE plant_canopy_model_mod,                                                &
571        ONLY:  lad_s, pc_heating_rate, pc_transpiration_rate, pc_latent_rate,  &
572               plant_canopy_transpiration, pcm_calc_transpiration_rate
573
574    USE pegrid
575
576#if defined ( __rrtmg )
577    USE parrrsw,                                                               &
578        ONLY:  naerec, nbndsw
579
580    USE parrrtm,                                                               &
581        ONLY:  nbndlw
582
583    USE rrtmg_lw_init,                                                         &
584        ONLY:  rrtmg_lw_ini
585
586    USE rrtmg_sw_init,                                                         &
587        ONLY:  rrtmg_sw_ini
588
589    USE rrtmg_lw_rad,                                                          &
590        ONLY:  rrtmg_lw
591
592    USE rrtmg_sw_rad,                                                          &
593        ONLY:  rrtmg_sw
594#endif
595    USE statistics,                                                            &
596        ONLY:  hom
597
598    USE surface_mod,                                                           &
599        ONLY:  get_topography_top_index, get_topography_top_index_ji,          &
600               ind_pav_green, ind_veg_wall, ind_wat_win,                       &
601               surf_lsm_h, surf_lsm_v, surf_type, surf_usm_h, surf_usm_v
602
603    IMPLICIT NONE
604
605    CHARACTER(10) :: radiation_scheme = 'clear-sky' ! 'constant', 'clear-sky', or 'rrtmg'
606
607!
608!-- Predefined Land surface classes (albedo_type) after Briegleb (1992)
609    CHARACTER(37), DIMENSION(0:33), PARAMETER :: albedo_type_name = (/      &
610                                   'user defined                         ', & !  0
611                                   'ocean                                ', & !  1
612                                   'mixed farming, tall grassland        ', & !  2
613                                   'tall/medium grassland                ', & !  3
614                                   'evergreen shrubland                  ', & !  4
615                                   'short grassland/meadow/shrubland     ', & !  5
616                                   'evergreen needleleaf forest          ', & !  6
617                                   'mixed deciduous evergreen forest     ', & !  7
618                                   'deciduous forest                     ', & !  8
619                                   'tropical evergreen broadleaved forest', & !  9
620                                   'medium/tall grassland/woodland       ', & ! 10
621                                   'desert, sandy                        ', & ! 11
622                                   'desert, rocky                        ', & ! 12
623                                   'tundra                               ', & ! 13
624                                   'land ice                             ', & ! 14
625                                   'sea ice                              ', & ! 15
626                                   'snow                                 ', & ! 16
627                                   'bare soil                            ', & ! 17
628                                   'asphalt/concrete mix                 ', & ! 18
629                                   'asphalt (asphalt concrete)           ', & ! 19
630                                   'concrete (Portland concrete)         ', & ! 20
631                                   'sett                                 ', & ! 21
632                                   'paving stones                        ', & ! 22
633                                   'cobblestone                          ', & ! 23
634                                   'metal                                ', & ! 24
635                                   'wood                                 ', & ! 25
636                                   'gravel                               ', & ! 26
637                                   'fine gravel                          ', & ! 27
638                                   'pebblestone                          ', & ! 28
639                                   'woodchips                            ', & ! 29
640                                   'tartan (sports)                      ', & ! 30
641                                   'artifical turf (sports)              ', & ! 31
642                                   'clay (sports)                        ', & ! 32
643                                   'building (dummy)                     '  & ! 33
644                                                         /)
645
646    REAL(wp), PARAMETER :: sigma_sb       = 5.67037321E-8_wp !< Stefan-Boltzmann constant
647
648    INTEGER(iwp) :: albedo_type  = 9999999, & !< Albedo surface type
649                    dots_rad     = 0          !< starting index for timeseries output
650
651    LOGICAL ::  unscheduled_radiation_calls = .TRUE., & !< flag parameter indicating whether additional calls of the radiation code are allowed
652                constant_albedo = .FALSE.,            & !< flag parameter indicating whether the albedo may change depending on zenith
653                force_radiation_call = .FALSE.,       & !< flag parameter for unscheduled radiation calls
654                lw_radiation = .TRUE.,                & !< flag parameter indicating whether longwave radiation shall be calculated
655                radiation = .FALSE.,                  & !< flag parameter indicating whether the radiation model is used
656                sun_up    = .TRUE.,                   & !< flag parameter indicating whether the sun is up or down
657                sw_radiation = .TRUE.,                & !< flag parameter indicating whether shortwave radiation shall be calculated
658                sun_direction = .FALSE.,              & !< flag parameter indicating whether solar direction shall be calculated
659                average_radiation = .FALSE.,          & !< flag to set the calculation of radiation averaging for the domain
660                radiation_interactions = .FALSE.,     & !< flag to activiate RTM (TRUE only if vertical urban/land surface and trees exist)
661                surface_reflections = .TRUE.,         & !< flag to switch the calculation of radiation interaction between surfaces.
662                                                        !< When it switched off, only the effect of buildings and trees shadow
663                                                        !< will be considered. However fewer SVFs are expected.
664                radiation_interactions_on = .TRUE.      !< namelist flag to force RTM activiation regardless to vertical urban/land surface and trees
665
666    REAL(wp) :: albedo = 9999999.9_wp,           & !< NAMELIST alpha
667                albedo_lw_dif = 9999999.9_wp,    & !< NAMELIST aldif
668                albedo_lw_dir = 9999999.9_wp,    & !< NAMELIST aldir
669                albedo_sw_dif = 9999999.9_wp,    & !< NAMELIST asdif
670                albedo_sw_dir = 9999999.9_wp,    & !< NAMELIST asdir
671                decl_1,                          & !< declination coef. 1
672                decl_2,                          & !< declination coef. 2
673                decl_3,                          & !< declination coef. 3
674                dt_radiation = 0.0_wp,           & !< radiation model timestep
675                emissivity = 9999999.9_wp,       & !< NAMELIST surface emissivity
676                lon = 0.0_wp,                    & !< longitude in radians
677                lat = 0.0_wp,                    & !< latitude in radians
678                net_radiation = 0.0_wp,          & !< net radiation at surface
679                skip_time_do_radiation = 0.0_wp, & !< Radiation model is not called before this time
680                sky_trans,                       & !< sky transmissivity
681                time_radiation = 0.0_wp            !< time since last call of radiation code
682
683
684    REAL(wp), DIMENSION(0:0) ::  zenith,         & !< cosine of solar zenith angle
685                                 sun_dir_lat,    & !< solar directional vector in latitudes
686                                 sun_dir_lon       !< solar directional vector in longitudes
687
688    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  rad_net_av       !< average of net radiation (rad_net) at surface
689    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  rad_lw_in_xy_av  !< average of incoming longwave radiation at surface
690    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  rad_lw_out_xy_av !< average of outgoing longwave radiation at surface
691    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  rad_sw_in_xy_av  !< average of incoming shortwave radiation at surface
692    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  rad_sw_out_xy_av !< average of outgoing shortwave radiation at surface
693!
694!-- Land surface albedos for solar zenith angle of 60° after Briegleb (1992)     
695!-- (shortwave, longwave, broadband):   sw,      lw,      bb,
696    REAL(wp), DIMENSION(0:2,1:33), PARAMETER :: albedo_pars = RESHAPE( (/& 
697                                   0.06_wp, 0.06_wp, 0.06_wp,            & !  1
698                                   0.09_wp, 0.28_wp, 0.19_wp,            & !  2
699                                   0.11_wp, 0.33_wp, 0.23_wp,            & !  3
700                                   0.11_wp, 0.33_wp, 0.23_wp,            & !  4
701                                   0.14_wp, 0.34_wp, 0.25_wp,            & !  5
702                                   0.06_wp, 0.22_wp, 0.14_wp,            & !  6
703                                   0.06_wp, 0.27_wp, 0.17_wp,            & !  7
704                                   0.06_wp, 0.31_wp, 0.19_wp,            & !  8
705                                   0.06_wp, 0.22_wp, 0.14_wp,            & !  9
706                                   0.06_wp, 0.28_wp, 0.18_wp,            & ! 10
707                                   0.35_wp, 0.51_wp, 0.43_wp,            & ! 11
708                                   0.24_wp, 0.40_wp, 0.32_wp,            & ! 12
709                                   0.10_wp, 0.27_wp, 0.19_wp,            & ! 13
710                                   0.90_wp, 0.65_wp, 0.77_wp,            & ! 14
711                                   0.90_wp, 0.65_wp, 0.77_wp,            & ! 15
712                                   0.95_wp, 0.70_wp, 0.82_wp,            & ! 16
713                                   0.08_wp, 0.08_wp, 0.08_wp,            & ! 17
714                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 18
715                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 19
716                                   0.30_wp, 0.30_wp, 0.30_wp,            & ! 20
717                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 21
718                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 22
719                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 23
720                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 24
721                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 25
722                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 26
723                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 27
724                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 28
725                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 29
726                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 30
727                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 31
728                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 32
729                                   0.17_wp, 0.17_wp, 0.17_wp             & ! 33
730                                 /), (/ 3, 33 /) )
731
732    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: &
733                        rad_lw_cs_hr,                  & !< longwave clear sky radiation heating rate (K/s)
734                        rad_lw_cs_hr_av,               & !< average of rad_lw_cs_hr
735                        rad_lw_hr,                     & !< longwave radiation heating rate (K/s)
736                        rad_lw_hr_av,                  & !< average of rad_sw_hr
737                        rad_lw_in,                     & !< incoming longwave radiation (W/m2)
738                        rad_lw_in_av,                  & !< average of rad_lw_in
739                        rad_lw_out,                    & !< outgoing longwave radiation (W/m2)
740                        rad_lw_out_av,                 & !< average of rad_lw_out
741                        rad_sw_cs_hr,                  & !< shortwave clear sky radiation heating rate (K/s)
742                        rad_sw_cs_hr_av,               & !< average of rad_sw_cs_hr
743                        rad_sw_hr,                     & !< shortwave radiation heating rate (K/s)
744                        rad_sw_hr_av,                  & !< average of rad_sw_hr
745                        rad_sw_in,                     & !< incoming shortwave radiation (W/m2)
746                        rad_sw_in_av,                  & !< average of rad_sw_in
747                        rad_sw_out,                    & !< outgoing shortwave radiation (W/m2)
748                        rad_sw_out_av                    !< average of rad_sw_out
749
750
751!
752!-- Variables and parameters used in RRTMG only
753#if defined ( __rrtmg )
754    CHARACTER(LEN=12) :: rrtm_input_file = "RAD_SND_DATA" !< name of the NetCDF input file (sounding data)
755
756
757!
758!-- Flag parameters for RRTMGS (should not be changed)
759    INTEGER(iwp), PARAMETER :: rrtm_idrv     = 1, & !< flag for longwave upward flux calculation option (0,1)
760                               rrtm_inflglw  = 2, & !< flag for lw cloud optical properties (0,1,2)
761                               rrtm_iceflglw = 0, & !< flag for lw ice particle specifications (0,1,2,3)
762                               rrtm_liqflglw = 1, & !< flag for lw liquid droplet specifications
763                               rrtm_inflgsw  = 2, & !< flag for sw cloud optical properties (0,1,2)
764                               rrtm_iceflgsw = 0, & !< flag for sw ice particle specifications (0,1,2,3)
765                               rrtm_liqflgsw = 1    !< flag for sw liquid droplet specifications
766
767!
768!-- The following variables should be only changed with care, as this will
769!-- require further setting of some variables, which is currently not
770!-- implemented (aerosols, ice phase).
771    INTEGER(iwp) :: nzt_rad,           & !< upper vertical limit for radiation calculations
772                    rrtm_icld = 0,     & !< cloud flag (0: clear sky column, 1: cloudy column)
773                    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)
774
775    INTEGER(iwp) :: nc_stat !< local variable for storin the result of netCDF calls for error message handling
776
777    LOGICAL :: snd_exists = .FALSE.      !< flag parameter to check whether a user-defined input files exists
778
779    REAL(wp), PARAMETER :: mol_mass_air_d_wv = 1.607793_wp !< molecular weight dry air / water vapor
780
781    REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd,     & !< hypostatic pressure from sounding data (hPa)
782                                           rrtm_tsfc,   & !< dummy array for storing surface temperature
783                                           t_snd          !< actual temperature from sounding data (hPa)
784
785    REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rrtm_ccl4vmr,   & !< CCL4 volume mixing ratio (g/mol)
786                                             rrtm_cfc11vmr,  & !< CFC11 volume mixing ratio (g/mol)
787                                             rrtm_cfc12vmr,  & !< CFC12 volume mixing ratio (g/mol)
788                                             rrtm_cfc22vmr,  & !< CFC22 volume mixing ratio (g/mol)
789                                             rrtm_ch4vmr,    & !< CH4 volume mixing ratio
790                                             rrtm_cicewp,    & !< in-cloud ice water path (g/m²)
791                                             rrtm_cldfr,     & !< cloud fraction (0,1)
792                                             rrtm_cliqwp,    & !< in-cloud liquid water path (g/m²)
793                                             rrtm_co2vmr,    & !< CO2 volume mixing ratio (g/mol)
794                                             rrtm_emis,      & !< surface emissivity (0-1) 
795                                             rrtm_h2ovmr,    & !< H2O volume mixing ratio
796                                             rrtm_n2ovmr,    & !< N2O volume mixing ratio
797                                             rrtm_o2vmr,     & !< O2 volume mixing ratio
798                                             rrtm_o3vmr,     & !< O3 volume mixing ratio
799                                             rrtm_play,      & !< pressure layers (hPa, zu-grid)
800                                             rrtm_plev,      & !< pressure layers (hPa, zw-grid)
801                                             rrtm_reice,     & !< cloud ice effective radius (microns)
802                                             rrtm_reliq,     & !< cloud water drop effective radius (microns)
803                                             rrtm_tlay,      & !< actual temperature (K, zu-grid)
804                                             rrtm_tlev,      & !< actual temperature (K, zw-grid)
805                                             rrtm_lwdflx,    & !< RRTM output of incoming longwave radiation flux (W/m2)
806                                             rrtm_lwdflxc,   & !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)
807                                             rrtm_lwuflx,    & !< RRTM output of outgoing longwave radiation flux (W/m2)
808                                             rrtm_lwuflxc,   & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)
809                                             rrtm_lwuflx_dt, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)
810                                             rrtm_lwuflxc_dt,& !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)
811                                             rrtm_lwhr,      & !< RRTM output of longwave radiation heating rate (K/d)
812                                             rrtm_lwhrc,     & !< RRTM output of incoming longwave clear sky radiation heating rate (K/d)
813                                             rrtm_swdflx,    & !< RRTM output of incoming shortwave radiation flux (W/m2)
814                                             rrtm_swdflxc,   & !< RRTM output of outgoing clear sky shortwave radiation flux (W/m2)
815                                             rrtm_swuflx,    & !< RRTM output of outgoing shortwave radiation flux (W/m2)
816                                             rrtm_swuflxc,   & !< RRTM output of incoming clear sky shortwave radiation flux (W/m2)
817                                             rrtm_swhr,      & !< RRTM output of shortwave radiation heating rate (K/d)
818                                             rrtm_swhrc,     & !< RRTM output of incoming shortwave clear sky radiation heating rate (K/d)
819                                             rrtm_dirdflux,  & !< RRTM output of incoming direct shortwave (W/m2)
820                                             rrtm_difdflux     !< RRTM output of incoming diffuse shortwave (W/m2)
821
822    REAL(wp), DIMENSION(1) ::                rrtm_aldif,     & !< surface albedo for longwave diffuse radiation
823                                             rrtm_aldir,     & !< surface albedo for longwave direct radiation
824                                             rrtm_asdif,     & !< surface albedo for shortwave diffuse radiation
825                                             rrtm_asdir        !< surface albedo for shortwave direct radiation
826
827!
828!-- Definition of arrays that are currently not used for calling RRTMG (due to setting of flag parameters)
829    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  rad_lw_cs_in,   & !< incoming clear sky longwave radiation (W/m2) (not used)
830                                                rad_lw_cs_out,  & !< outgoing clear sky longwave radiation (W/m2) (not used)
831                                                rad_sw_cs_in,   & !< incoming clear sky shortwave radiation (W/m2) (not used)
832                                                rad_sw_cs_out,  & !< outgoing clear sky shortwave radiation (W/m2) (not used)
833                                                rrtm_lw_tauaer, & !< lw aerosol optical depth
834                                                rrtm_lw_taucld, & !< lw in-cloud optical depth
835                                                rrtm_sw_taucld, & !< sw in-cloud optical depth
836                                                rrtm_sw_ssacld, & !< sw in-cloud single scattering albedo
837                                                rrtm_sw_asmcld, & !< sw in-cloud asymmetry parameter
838                                                rrtm_sw_fsfcld, & !< sw in-cloud forward scattering fraction
839                                                rrtm_sw_tauaer, & !< sw aerosol optical depth
840                                                rrtm_sw_ssaaer, & !< sw aerosol single scattering albedo
841                                                rrtm_sw_asmaer, & !< sw aerosol asymmetry parameter
842                                                rrtm_sw_ecaer     !< sw aerosol optical detph at 0.55 microns (rrtm_iaer = 6 only)
843
844#endif
845!
846!-- Parameters of urban and land surface models
847    INTEGER(iwp)                                   ::  nzu                                !< number of layers of urban surface (will be calculated)
848    INTEGER(iwp)                                   ::  nzp                                !< number of layers of plant canopy (will be calculated)
849    INTEGER(iwp)                                   ::  nzub,nzut                          !< bottom and top layer of urban surface (will be calculated)
850    INTEGER(iwp)                                   ::  nzpt                               !< top layer of plant canopy (will be calculated)
851!-- parameters of urban and land surface models
852    INTEGER(iwp), PARAMETER                        ::  nzut_free = 3                      !< number of free layers above top of of topography
853    INTEGER(iwp), PARAMETER                        ::  ndsvf = 2                          !< number of dimensions of real values in SVF
854    INTEGER(iwp), PARAMETER                        ::  idsvf = 2                          !< number of dimensions of integer values in SVF
855    INTEGER(iwp), PARAMETER                        ::  ndcsf = 1                          !< number of dimensions of real values in CSF
856    INTEGER(iwp), PARAMETER                        ::  idcsf = 2                          !< number of dimensions of integer values in CSF
857    INTEGER(iwp), PARAMETER                        ::  kdcsf = 4                          !< number of dimensions of integer values in CSF calculation array
858    INTEGER(iwp), PARAMETER                        ::  id = 1                             !< position of d-index in surfl and surf
859    INTEGER(iwp), PARAMETER                        ::  iz = 2                             !< position of k-index in surfl and surf
860    INTEGER(iwp), PARAMETER                        ::  iy = 3                             !< position of j-index in surfl and surf
861    INTEGER(iwp), PARAMETER                        ::  ix = 4                             !< position of i-index in surfl and surf
862
863    INTEGER(iwp), PARAMETER                        ::  nsurf_type = 10                    !< number of surf types incl. phys.(land+urban) & (atm.,sky,boundary) surfaces - 1
864
865    INTEGER(iwp), PARAMETER                        ::  iup_u    = 0                       !< 0 - index of urban upward surface (ground or roof)
866    INTEGER(iwp), PARAMETER                        ::  idown_u  = 1                       !< 1 - index of urban downward surface (overhanging)
867    INTEGER(iwp), PARAMETER                        ::  inorth_u = 2                       !< 2 - index of urban northward facing wall
868    INTEGER(iwp), PARAMETER                        ::  isouth_u = 3                       !< 3 - index of urban southward facing wall
869    INTEGER(iwp), PARAMETER                        ::  ieast_u  = 4                       !< 4 - index of urban eastward facing wall
870    INTEGER(iwp), PARAMETER                        ::  iwest_u  = 5                       !< 5 - index of urban westward facing wall
871
872    INTEGER(iwp), PARAMETER                        ::  iup_l    = 6                       !< 6 - index of land upward surface (ground or roof)
873    INTEGER(iwp), PARAMETER                        ::  inorth_l = 7                       !< 7 - index of land northward facing wall
874    INTEGER(iwp), PARAMETER                        ::  isouth_l = 8                       !< 8 - index of land southward facing wall
875    INTEGER(iwp), PARAMETER                        ::  ieast_l  = 9                       !< 9 - index of land eastward facing wall
876    INTEGER(iwp), PARAMETER                        ::  iwest_l  = 10                      !< 10- index of land westward facing wall
877
878    INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER ::  idir = (/0, 0,0, 0,1,-1,0,0, 0,1,-1/)   !< surface normal direction x indices
879    INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER ::  jdir = (/0, 0,1,-1,0, 0,0,1,-1,0, 0/)   !< surface normal direction y indices
880    INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER ::  kdir = (/1,-1,0, 0,0, 0,1,0, 0,0, 0/)   !< surface normal direction z indices
881    REAL(wp),     DIMENSION(0:nsurf_type)          :: facearea                            !< area of single face in respective
882                                                                                          !< direction (will be calc'd)
883
884
885!-- indices and sizes of urban and land surface models
886    INTEGER(iwp)                                   ::  startland        !< start index of block of land and roof surfaces
887    INTEGER(iwp)                                   ::  endland          !< end index of block of land and roof surfaces
888    INTEGER(iwp)                                   ::  nlands           !< number of land and roof surfaces in local processor
889    INTEGER(iwp)                                   ::  startwall        !< start index of block of wall surfaces
890    INTEGER(iwp)                                   ::  endwall          !< end index of block of wall surfaces
891    INTEGER(iwp)                                   ::  nwalls           !< number of wall surfaces in local processor
892
893!-- indices and sizes of urban and land surface models
894    INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET ::  surfl_l          !< coordinates of i-th local surface in local grid - surfl[:,k] = [d, z, y, x]
895    INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET ::  surf_l           !< coordinates of i-th surface in grid - surf[:,k] = [d, z, y, x]
896    INTEGER(iwp), DIMENSION(:,:), POINTER          ::  surfl            !< coordinates of i-th local surface in local grid - surfl[:,k] = [d, z, y, x]
897    INTEGER(iwp), DIMENSION(:,:), POINTER          ::  surf             !< coordinates of i-th surface in grid - surf[:,k] = [d, z, y, x]
898    INTEGER(iwp)                                   ::  nsurfl           !< number of all surfaces in local processor
899    INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET ::  nsurfs           !< array of number of all surfaces in individual processors
900    INTEGER(iwp)                                   ::  nsurf            !< global number of surfaces in index array of surfaces (nsurf = proc nsurfs)
901    INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET ::  surfstart        !< starts of blocks of surfaces for individual processors in array surf (indexed from 1)
902                                                                        !< respective block for particular processor is surfstart[iproc+1]+1 : surfstart[iproc+1]+nsurfs[iproc+1]
903
904!-- block variables needed for calculation of the plant canopy model inside the urban surface model
905    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  pct              !< top layer of the plant canopy
906    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  pch              !< heights of the plant canopy
907    INTEGER(iwp)                                   ::  npcbl = 0        !< number of the plant canopy gridboxes in local processor
908    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  pcbl             !< k,j,i coordinates of l-th local plant canopy box pcbl[:,l] = [k, j, i]
909    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  pcbinsw          !< array of absorbed sw radiation for local plant canopy box
910    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  pcbinswdir       !< array of absorbed direct sw radiation for local plant canopy box
911    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  pcbinswdif       !< array of absorbed diffusion sw radiation for local plant canopy box
912    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  pcbinlw          !< array of absorbed lw radiation for local plant canopy box
913
914!-- configuration parameters (they can be setup in PALM config)
915    LOGICAL                                        ::  raytrace_mpi_rma = .TRUE.          !< use MPI RMA to access LAD and gridsurf from remote processes during raytracing
916    LOGICAL                                        ::  rad_angular_discretization = .TRUE.!< whether to use fixed resolution discretization of view factors for
917                                                                                          !< reflected radiation (as opposed to all mutually visible pairs)
918    LOGICAL                                        ::  plant_lw_interact = .TRUE.         !< whether plant canopy interacts with LW radiation (in addition to SW)
919    INTEGER(iwp)                                   ::  mrt_nlevels = 0                    !< number of vertical boxes above surface for which to calculate MRT
920    LOGICAL                                        ::  mrt_skip_roof = .TRUE.             !< do not calculate MRT above roof surfaces
921    LOGICAL                                        ::  mrt_include_sw = .TRUE.            !< should MRT calculation include SW radiation as well?
922    LOGICAL                                        ::  mrt_geom_human = .TRUE.            !< MRT direction weights simulate human body instead of a sphere
923    INTEGER(iwp)                                   ::  nrefsteps = 3                      !< number of reflection steps to perform
924    REAL(wp), PARAMETER                            ::  ext_coef = 0.6_wp                  !< extinction coefficient (a.k.a. alpha)
925    INTEGER(iwp), PARAMETER                        ::  rad_version_len = 10               !< length of identification string of rad version
926    CHARACTER(rad_version_len), PARAMETER          ::  rad_version = 'RAD v. 3.0'         !< identification of version of binary svf and restart files
927    INTEGER(iwp)                                   ::  raytrace_discrete_elevs = 40       !< number of discretization steps for elevation (nadir to zenith)
928    INTEGER(iwp)                                   ::  raytrace_discrete_azims = 80       !< number of discretization steps for azimuth (out of 360 degrees)
929    REAL(wp)                                       ::  max_raytracing_dist = -999.0_wp    !< maximum distance for raytracing (in metres)
930    REAL(wp)                                       ::  min_irrf_value = 1e-6_wp           !< minimum potential irradiance factor value for raytracing
931    REAL(wp), DIMENSION(1:30)                      ::  svfnorm_report_thresh = 1e21_wp    !< thresholds of SVF normalization values to report
932    INTEGER(iwp)                                   ::  svfnorm_report_num                 !< number of SVF normalization thresholds to report
933
934!-- radiation related arrays to be used in radiation_interaction routine
935    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  rad_sw_in_dir    !< direct sw radiation
936    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  rad_sw_in_diff   !< diffusion sw radiation
937    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  rad_lw_in_diff   !< diffusion lw radiation
938
939!-- parameters required for RRTMG lower boundary condition
940    REAL(wp)                   :: albedo_urb      !< albedo value retuned to RRTMG boundary cond.
941    REAL(wp)                   :: emissivity_urb  !< emissivity value retuned to RRTMG boundary cond.
942    REAL(wp)                   :: t_rad_urb       !< temperature value retuned to RRTMG boundary cond.
943
944!-- type for calculation of svf
945    TYPE t_svf
946        INTEGER(iwp)                               :: isurflt           !<
947        INTEGER(iwp)                               :: isurfs            !<
948        REAL(wp)                                   :: rsvf              !<
949        REAL(wp)                                   :: rtransp           !<
950    END TYPE
951
952!-- type for calculation of csf
953    TYPE t_csf
954        INTEGER(iwp)                               :: ip                !<
955        INTEGER(iwp)                               :: itx               !<
956        INTEGER(iwp)                               :: ity               !<
957        INTEGER(iwp)                               :: itz               !<
958        INTEGER(iwp)                               :: isurfs            !< Idx of source face / -1 for sky
959        REAL(wp)                                   :: rcvf              !< Canopy view factor for faces /
960                                                                        !< canopy sink factor for sky (-1)
961    END TYPE
962
963!-- arrays storing the values of USM
964    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  svfsurf          !< svfsurf[:,isvf] = index of target and source surface for svf[isvf]
965    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  svf              !< array of shape view factors+direct irradiation factors for local surfaces
966    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfins          !< array of sw radiation falling to local surface after i-th reflection
967    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinl          !< array of lw radiation for local surface after i-th reflection
968
969    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  skyvf            !< array of sky view factor for each local surface
970    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  skyvft           !< array of sky view factor including transparency for each local surface
971    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  dsitrans         !< dsidir[isvfl,i] = path transmittance of i-th
972                                                                        !< direction of direct solar irradiance per target surface
973    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  dsitransc        !< dtto per plant canopy box
974    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  dsidir           !< dsidir[:,i] = unit vector of i-th
975                                                                        !< direction of direct solar irradiance
976    INTEGER(iwp)                                   ::  ndsidir          !< number of apparent solar directions used
977    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  dsidir_rev       !< dsidir_rev[ielev,iazim] = i for dsidir or -1 if not present
978
979    INTEGER(iwp)                                   ::  nmrtbl           !< No. of local grid boxes for which MRT is calculated
980    INTEGER(iwp)                                   ::  nmrtf            !< number of MRT factors for local processor
981    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  mrtbl            !< coordinates of i-th local MRT box - surfl[:,i] = [z, y, x]
982    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  mrtfsurf         !< mrtfsurf[:,imrtf] = index of target MRT box and source surface for mrtf[imrtf]
983    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrtf             !< array of MRT factors for each local MRT box
984    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrtft            !< array of MRT factors including transparency for each local MRT box
985    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrtsky           !< array of sky view factor for each local MRT box
986    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrtskyt          !< array of sky view factor including transparency for each local MRT box
987    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  mrtdsit          !< array of direct solar transparencies for each local MRT box
988    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrtinsw          !< mean SW radiant flux for each MRT box
989    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrtinlw          !< mean LW radiant flux for each MRT box
990    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrt              !< mean radiant temperature for each MRT box
991    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrtinsw_av       !< time average mean SW radiant flux for each MRT box
992    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrtinlw_av       !< time average mean LW radiant flux for each MRT box
993    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrt_av           !< time average mean radiant temperature for each MRT box
994
995    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinsw         !< array of sw radiation falling to local surface including radiation from reflections
996    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinlw         !< array of lw radiation falling to local surface including radiation from reflections
997    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinswdir      !< array of direct sw radiation falling to local surface
998    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinswdif      !< array of diffuse sw radiation from sky and model boundary falling to local surface
999    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinlwdif      !< array of diffuse lw radiation from sky and model boundary falling to local surface
1000   
1001                                                                        !< Outward radiation is only valid for nonvirtual surfaces
1002    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfoutsl        !< array of reflected sw radiation for local surface in i-th reflection
1003    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfoutll        !< array of reflected + emitted lw radiation for local surface in i-th reflection
1004    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfouts         !< array of reflected sw radiation for all surfaces in i-th reflection
1005    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfoutl         !< array of reflected + emitted lw radiation for all surfaces in i-th reflection
1006    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinlg         !< global array of incoming lw radiation from plant canopy
1007    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfoutsw        !< array of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection
1008    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfoutlw        !< array of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection
1009    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfemitlwl      !< array of emitted lw radiation for local surface used to calculate effective surface temperature for radiation model
1010
1011!-- block variables needed for calculation of the plant canopy model inside the urban surface model
1012    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  csfsurf          !< csfsurf[:,icsf] = index of target surface and csf grid index for csf[icsf]
1013    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  csf              !< array of plant canopy sink fators + direct irradiation factors (transparency)
1014    REAL(wp), DIMENSION(:,:,:), POINTER            ::  sub_lad          !< subset of lad_s within urban surface, transformed to plain Z coordinate
1015    REAL(wp), DIMENSION(:), POINTER                ::  sub_lad_g        !< sub_lad globalized (used to avoid MPI RMA calls in raytracing)
1016    REAL(wp)                                       ::  prototype_lad    !< prototype leaf area density for computing effective optical depth
1017    INTEGER(iwp), DIMENSION(:), ALLOCATABLE        ::  nzterr, plantt   !< temporary global arrays for raytracing
1018    INTEGER(iwp)                                   ::  plantt_max
1019
1020!-- arrays and variables for calculation of svf and csf
1021    TYPE(t_svf), DIMENSION(:), POINTER             ::  asvf             !< pointer to growing svc array
1022    TYPE(t_csf), DIMENSION(:), POINTER             ::  acsf             !< pointer to growing csf array
1023    TYPE(t_svf), DIMENSION(:), POINTER             ::  amrtf            !< pointer to growing mrtf array
1024    TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET ::  asvf1, asvf2     !< realizations of svf array
1025    TYPE(t_csf), DIMENSION(:), ALLOCATABLE, TARGET ::  acsf1, acsf2     !< realizations of csf array
1026    TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET ::  amrtf1, amrtf2   !< realizations of mftf array
1027    INTEGER(iwp)                                   ::  nsvfla           !< dimmension of array allocated for storage of svf in local processor
1028    INTEGER(iwp)                                   ::  ncsfla           !< dimmension of array allocated for storage of csf in local processor
1029    INTEGER(iwp)                                   ::  nmrtfa           !< dimmension of array allocated for storage of mrt
1030    INTEGER(iwp)                                   ::  msvf, mcsf, mmrtf!< mod for swapping the growing array
1031    INTEGER(iwp), PARAMETER                        ::  gasize = 100000  !< initial size of growing arrays
1032    REAL(wp), PARAMETER                            ::  grow_factor = 1.4_wp !< growth factor of growing arrays
1033    INTEGER(iwp)                                   ::  nsvfl            !< number of svf for local processor
1034    INTEGER(iwp)                                   ::  ncsfl            !< no. of csf in local processor
1035                                                                        !< needed only during calc_svf but must be here because it is
1036                                                                        !< shared between subroutines calc_svf and raytrace
1037    INTEGER(iwp), DIMENSION(:,:,:,:), POINTER      ::  gridsurf         !< reverse index of local surfl[d,k,j,i] (for case rad_angular_discretization)
1038    INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE    ::  gridpcbl         !< reverse index of local pcbl[k,j,i]
1039    INTEGER(iwp), PARAMETER                        ::  nsurf_type_u = 6 !< number of urban surf types (used in gridsurf)
1040
1041!-- temporary arrays for calculation of csf in raytracing
1042    INTEGER(iwp)                                   ::  maxboxesg        !< max number of boxes ray can cross in the domain
1043    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  boxes            !< coordinates of gridboxes being crossed by ray
1044    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  crlens           !< array of crossing lengths of ray for particular grid boxes
1045    INTEGER(iwp), DIMENSION(:), ALLOCATABLE        ::  lad_ip           !< array of numbers of process where lad is stored
1046#if defined( __parallel )
1047    INTEGER(kind=MPI_ADDRESS_KIND), &
1048                  DIMENSION(:), ALLOCATABLE        ::  lad_disp         !< array of displaycements of lad in local array of proc lad_ip
1049    INTEGER(iwp)                                   ::  win_lad          !< MPI RMA window for leaf area density
1050    INTEGER(iwp)                                   ::  win_gridsurf     !< MPI RMA window for reverse grid surface index
1051#endif
1052    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  lad_s_ray        !< array of received lad_s for appropriate gridboxes crossed by ray
1053    INTEGER(iwp), DIMENSION(:), ALLOCATABLE        ::  target_surfl
1054    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  rt2_track
1055    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  rt2_track_lad
1056    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  rt2_track_dist
1057    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  rt2_dist
1058
1059
1060
1061!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1062!-- Energy balance variables
1063!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
1064!-- parameters of the land, roof and wall surfaces
1065    REAL(wp), DIMENSION(:), ALLOCATABLE            :: albedo_surf        !< albedo of the surface
1066    REAL(wp), DIMENSION(:), ALLOCATABLE            :: emiss_surf         !< emissivity of the wall surface
1067
1068
1069    INTERFACE radiation_check_data_output
1070       MODULE PROCEDURE radiation_check_data_output
1071    END INTERFACE radiation_check_data_output
1072
1073    INTERFACE radiation_check_data_output_pr
1074       MODULE PROCEDURE radiation_check_data_output_pr
1075    END INTERFACE radiation_check_data_output_pr
1076 
1077    INTERFACE radiation_check_parameters
1078       MODULE PROCEDURE radiation_check_parameters
1079    END INTERFACE radiation_check_parameters
1080 
1081    INTERFACE radiation_clearsky
1082       MODULE PROCEDURE radiation_clearsky
1083    END INTERFACE radiation_clearsky
1084 
1085    INTERFACE radiation_constant
1086       MODULE PROCEDURE radiation_constant
1087    END INTERFACE radiation_constant
1088 
1089    INTERFACE radiation_control
1090       MODULE PROCEDURE radiation_control
1091    END INTERFACE radiation_control
1092
1093    INTERFACE radiation_3d_data_averaging
1094       MODULE PROCEDURE radiation_3d_data_averaging
1095    END INTERFACE radiation_3d_data_averaging
1096
1097    INTERFACE radiation_data_output_2d
1098       MODULE PROCEDURE radiation_data_output_2d
1099    END INTERFACE radiation_data_output_2d
1100
1101    INTERFACE radiation_data_output_3d
1102       MODULE PROCEDURE radiation_data_output_3d
1103    END INTERFACE radiation_data_output_3d
1104
1105    INTERFACE radiation_data_output_mask
1106       MODULE PROCEDURE radiation_data_output_mask
1107    END INTERFACE radiation_data_output_mask
1108
1109    INTERFACE radiation_define_netcdf_grid
1110       MODULE PROCEDURE radiation_define_netcdf_grid
1111    END INTERFACE radiation_define_netcdf_grid
1112
1113    INTERFACE radiation_header
1114       MODULE PROCEDURE radiation_header
1115    END INTERFACE radiation_header 
1116 
1117    INTERFACE radiation_init
1118       MODULE PROCEDURE radiation_init
1119    END INTERFACE radiation_init
1120
1121    INTERFACE radiation_parin
1122       MODULE PROCEDURE radiation_parin
1123    END INTERFACE radiation_parin
1124   
1125    INTERFACE radiation_rrtmg
1126       MODULE PROCEDURE radiation_rrtmg
1127    END INTERFACE radiation_rrtmg
1128
1129    INTERFACE radiation_tendency
1130       MODULE PROCEDURE radiation_tendency
1131       MODULE PROCEDURE radiation_tendency_ij
1132    END INTERFACE radiation_tendency
1133
1134    INTERFACE radiation_rrd_local
1135       MODULE PROCEDURE radiation_rrd_local
1136    END INTERFACE radiation_rrd_local
1137
1138    INTERFACE radiation_wrd_local
1139       MODULE PROCEDURE radiation_wrd_local
1140    END INTERFACE radiation_wrd_local
1141
1142    INTERFACE radiation_interaction
1143       MODULE PROCEDURE radiation_interaction
1144    END INTERFACE radiation_interaction
1145
1146    INTERFACE radiation_interaction_init
1147       MODULE PROCEDURE radiation_interaction_init
1148    END INTERFACE radiation_interaction_init
1149 
1150    INTERFACE radiation_presimulate_solar_pos
1151       MODULE PROCEDURE radiation_presimulate_solar_pos
1152    END INTERFACE radiation_presimulate_solar_pos
1153
1154    INTERFACE radiation_radflux_gridbox
1155       MODULE PROCEDURE radiation_radflux_gridbox
1156    END INTERFACE radiation_radflux_gridbox
1157
1158    INTERFACE radiation_calc_svf
1159       MODULE PROCEDURE radiation_calc_svf
1160    END INTERFACE radiation_calc_svf
1161
1162    INTERFACE radiation_write_svf
1163       MODULE PROCEDURE radiation_write_svf
1164    END INTERFACE radiation_write_svf
1165
1166    INTERFACE radiation_read_svf
1167       MODULE PROCEDURE radiation_read_svf
1168    END INTERFACE radiation_read_svf
1169
1170
1171    SAVE
1172
1173    PRIVATE
1174
1175!
1176!-- Public functions / NEEDS SORTING
1177    PUBLIC radiation_check_data_output, radiation_check_data_output_pr,        &
1178           radiation_check_parameters, radiation_control,                      &
1179           radiation_header, radiation_init, radiation_parin,                  &
1180           radiation_3d_data_averaging, radiation_tendency,                    &
1181           radiation_data_output_2d, radiation_data_output_3d,                 &
1182           radiation_define_netcdf_grid, radiation_wrd_local,                  &
1183           radiation_rrd_local, radiation_data_output_mask,                    &
1184           radiation_radflux_gridbox, radiation_calc_svf, radiation_write_svf, &
1185           radiation_interaction, radiation_interaction_init,                  &
1186           radiation_read_svf, radiation_presimulate_solar_pos
1187           
1188
1189   
1190!
1191!-- Public variables and constants / NEEDS SORTING
1192    PUBLIC albedo, albedo_type, decl_1, decl_2, decl_3, dots_rad, dt_radiation,&
1193           emissivity, force_radiation_call, lat, lon, mrt_geom_human,         &
1194           mrt_include_sw, mrt_nlevels, mrtbl, mrtinsw, mrtinlw, nmrtbl,       &
1195           rad_net_av, radiation, radiation_scheme, rad_lw_in,                 &
1196           rad_lw_in_av, rad_lw_out, rad_lw_out_av,                            &
1197           rad_lw_cs_hr, rad_lw_cs_hr_av, rad_lw_hr, rad_lw_hr_av, rad_sw_in,  &
1198           rad_sw_in_av, rad_sw_out, rad_sw_out_av, rad_sw_cs_hr,              &
1199           rad_sw_cs_hr_av, rad_sw_hr, rad_sw_hr_av, sigma_sb, solar_constant, &
1200           skip_time_do_radiation, time_radiation, unscheduled_radiation_calls,&
1201           zenith, calc_zenith, sun_direction, sun_dir_lat, sun_dir_lon,       &
1202           nrefsteps, nsvfl, svf,                                              &
1203           svfsurf, surfinsw, surfinlw, surfins, surfinl, surfinswdir,         &
1204           surfinswdif, surfoutsw, surfoutlw, surfinlwdif, rad_sw_in_dir,      &
1205           rad_sw_in_diff, rad_lw_in_diff, surfouts, surfoutl, surfoutsl,      &
1206           surfoutll, idir, jdir, kdir, id, iz, iy, ix,                        &
1207           surf, surfl, nsurfl, pcbinswdir, pcbinswdif, pcbinsw, pcbinlw,      &
1208           iup_u, inorth_u, isouth_u, ieast_u, iwest_u,                        &
1209           iup_l, inorth_l, isouth_l, ieast_l, iwest_l,                        &
1210           nsurf_type, nzub, nzut, nzu, pch, nsurf,                            &
1211           idsvf, ndsvf, idcsf, ndcsf, kdcsf, pct,                             &
1212           radiation_interactions, startwall, startland, endland, endwall,     &
1213           skyvf, skyvft, radiation_interactions_on, average_radiation, npcbl, &
1214           pcbl
1215
1216#if defined ( __rrtmg )
1217    PUBLIC rrtm_aldif, rrtm_aldir, rrtm_asdif, rrtm_asdir
1218#endif
1219
1220 CONTAINS
1221
1222
1223!------------------------------------------------------------------------------!
1224! Description:
1225! ------------
1226!> This subroutine controls the calls of the radiation schemes
1227!------------------------------------------------------------------------------!
1228    SUBROUTINE radiation_control
1229 
1230 
1231       IMPLICIT NONE
1232
1233
1234       SELECT CASE ( TRIM( radiation_scheme ) )
1235
1236          CASE ( 'constant' )
1237             CALL radiation_constant
1238         
1239          CASE ( 'clear-sky' ) 
1240             CALL radiation_clearsky
1241       
1242          CASE ( 'rrtmg' )
1243             CALL radiation_rrtmg
1244
1245          CASE DEFAULT
1246
1247       END SELECT
1248
1249
1250    END SUBROUTINE radiation_control
1251
1252!------------------------------------------------------------------------------!
1253! Description:
1254! ------------
1255!> Check data output for radiation model
1256!------------------------------------------------------------------------------!
1257    SUBROUTINE radiation_check_data_output( var, unit, i, ilen, k )
1258 
1259 
1260       USE control_parameters,                                                 &
1261           ONLY: data_output, message_string
1262
1263       IMPLICIT NONE
1264
1265       CHARACTER (LEN=*) ::  unit     !<
1266       CHARACTER (LEN=*) ::  var      !<
1267
1268       INTEGER(iwp) :: i
1269       INTEGER(iwp) :: ilen
1270       INTEGER(iwp) :: k
1271
1272       SELECT CASE ( TRIM( var ) )
1273
1274          CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_lw_in', 'rad_lw_out', &
1275                 'rad_sw_cs_hr', 'rad_sw_hr', 'rad_sw_in', 'rad_sw_out'  )
1276             IF (  .NOT.  radiation  .OR.  radiation_scheme /= 'rrtmg' )  THEN
1277                message_string = '"output of "' // TRIM( var ) // '" requi' // &
1278                                 'res radiation = .TRUE. and ' //              &
1279                                 'radiation_scheme = "rrtmg"'
1280                CALL message( 'check_parameters', 'PA0406', 1, 2, 0, 6, 0 )
1281             ENDIF
1282             unit = 'K/h'     
1283
1284          CASE ( 'rad_net*', 'rrtm_aldif*', 'rrtm_aldir*', 'rrtm_asdif*',      &
1285                 'rrtm_asdir*', 'rad_lw_in*', 'rad_lw_out*', 'rad_sw_in*',     &
1286                 'rad_sw_out*')
1287             IF ( i == 0 .AND. ilen == 0 .AND. k == 0)  THEN
1288                ! Workaround for masked output (calls with i=ilen=k=0)
1289                unit = 'illegal'
1290                RETURN
1291             ENDIF
1292             IF ( k == 0  .OR.  data_output(i)(ilen-2:ilen) /= '_xy' )  THEN
1293                message_string = 'illegal value for data_output: "' //         &
1294                                 TRIM( var ) // '" & only 2d-horizontal ' //   &
1295                                 'cross sections are allowed for this value'
1296                CALL message( 'check_parameters', 'PA0111', 1, 2, 0, 6, 0 )
1297             ENDIF
1298             IF (  .NOT.  radiation  .OR.  radiation_scheme /= "rrtmg" )  THEN
1299                IF ( TRIM( var ) == 'rrtm_aldif*'  .OR.                        &
1300                     TRIM( var ) == 'rrtm_aldir*'  .OR.                        &
1301                     TRIM( var ) == 'rrtm_asdif*'  .OR.                        &
1302                     TRIM( var ) == 'rrtm_asdir*'      )                       &
1303                THEN
1304                   message_string = 'output of "' // TRIM( var ) // '" require'&
1305                                    // 's radiation = .TRUE. and radiation_sch'&
1306                                    // 'eme = "rrtmg"'
1307                   CALL message( 'check_parameters', 'PA0409', 1, 2, 0, 6, 0 )
1308                ENDIF
1309             ENDIF
1310
1311             IF ( TRIM( var ) == 'rad_net*'      ) unit = 'W/m2'   
1312             IF ( TRIM( var ) == 'rad_lw_in*'    ) unit = 'W/m2'
1313             IF ( TRIM( var ) == 'rad_lw_out*'   ) unit = 'W/m2'
1314             IF ( TRIM( var ) == 'rad_sw_in*'    ) unit = 'W/m2'
1315             IF ( TRIM( var ) == 'rad_sw_out*'   ) unit = 'W/m2'
1316             IF ( TRIM( var ) == 'rad_sw_in'     ) unit = 'W/m2'
1317             IF ( TRIM( var ) == 'rrtm_aldif*'   ) unit = ''   
1318             IF ( TRIM( var ) == 'rrtm_aldir*'   ) unit = '' 
1319             IF ( TRIM( var ) == 'rrtm_asdif*'   ) unit = '' 
1320             IF ( TRIM( var ) == 'rrtm_asdir*'   ) unit = '' 
1321
1322          CASE ( 'rad_mrt', 'rad_mrt_sw', 'rad_mrt_lw'  )
1323
1324             IF ( i == 0 .AND. ilen == 0 .AND. k == 0)  THEN
1325                ! Workaround for masked output (calls with i=ilen=k=0)
1326                unit = 'illegal'
1327                RETURN
1328             ENDIF
1329
1330             IF ( .NOT.  radiation ) THEN
1331                message_string = 'output of "' // TRIM( var ) // '" require'&
1332                                 // 's radiation = .TRUE.'
1333                CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1334             ENDIF
1335             IF ( mrt_nlevels == 0 ) THEN
1336                message_string = 'output of "' // TRIM( var ) // '" require'&
1337                                 // 's mrt_nlevels > 0'
1338                CALL message( 'check_parameters', 'PA0510', 1, 2, 0, 6, 0 )
1339             ENDIF
1340             IF ( TRIM( var ) == 'rad_mrt_sw'  .AND.  .NOT. mrt_include_sw ) THEN
1341                message_string = 'output of "' // TRIM( var ) // '" require'&
1342                                 // 's rad_mrt_sw = .TRUE.'
1343                CALL message( 'check_parameters', 'PA0511', 1, 2, 0, 6, 0 )
1344             ENDIF
1345             IF ( TRIM( var ) == 'rad_mrt' ) THEN
1346                unit = 'K'
1347             ELSE
1348                unit = 'W m-2'
1349             ENDIF
1350
1351          CASE DEFAULT
1352             unit = 'illegal'
1353
1354       END SELECT
1355
1356
1357    END SUBROUTINE radiation_check_data_output
1358
1359!------------------------------------------------------------------------------!
1360! Description:
1361! ------------
1362!> Check data output of profiles for radiation model
1363!------------------------------------------------------------------------------! 
1364    SUBROUTINE radiation_check_data_output_pr( variable, var_count, unit,      &
1365               dopr_unit )
1366 
1367       USE arrays_3d,                                                          &
1368           ONLY: zu
1369
1370       USE control_parameters,                                                 &
1371           ONLY: data_output_pr, message_string
1372
1373       USE indices
1374
1375       USE profil_parameter
1376
1377       USE statistics
1378
1379       IMPLICIT NONE
1380   
1381       CHARACTER (LEN=*) ::  unit      !<
1382       CHARACTER (LEN=*) ::  variable  !<
1383       CHARACTER (LEN=*) ::  dopr_unit !< local value of dopr_unit
1384 
1385       INTEGER(iwp) ::  var_count     !<
1386
1387       SELECT CASE ( TRIM( variable ) )
1388       
1389         CASE ( 'rad_net' )
1390             IF ( (  .NOT.  radiation )  .OR.  radiation_scheme == 'constant' )&
1391             THEN
1392                message_string = 'data_output_pr = ' //                        &
1393                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1394                                 'not available for radiation = .FALSE. or ' //&
1395                                 'radiation_scheme = "constant"'
1396                CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1397             ELSE
1398                dopr_index(var_count) = 99
1399                dopr_unit  = 'W/m2'
1400                hom(:,2,99,:)  = SPREAD( zw, 2, statistic_regions+1 )
1401                unit = dopr_unit
1402             ENDIF
1403
1404          CASE ( 'rad_lw_in' )
1405             IF ( (  .NOT.  radiation)  .OR.  radiation_scheme == 'constant' ) &
1406             THEN
1407                message_string = 'data_output_pr = ' //                        &
1408                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1409                                 'not available for radiation = .FALSE. or ' //&
1410                                 'radiation_scheme = "constant"'
1411                CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1412             ELSE
1413                dopr_index(var_count) = 100
1414                dopr_unit  = 'W/m2'
1415                hom(:,2,100,:)  = SPREAD( zw, 2, statistic_regions+1 )
1416                unit = dopr_unit 
1417             ENDIF
1418
1419          CASE ( 'rad_lw_out' )
1420             IF ( (  .NOT. radiation )  .OR.  radiation_scheme == 'constant' ) &
1421             THEN
1422                message_string = 'data_output_pr = ' //                        &
1423                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1424                                 'not available for radiation = .FALSE. or ' //&
1425                                 'radiation_scheme = "constant"'
1426                CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1427             ELSE
1428                dopr_index(var_count) = 101
1429                dopr_unit  = 'W/m2'
1430                hom(:,2,101,:)  = SPREAD( zw, 2, statistic_regions+1 )
1431                unit = dopr_unit   
1432             ENDIF
1433
1434          CASE ( 'rad_sw_in' )
1435             IF ( (  .NOT. radiation )  .OR.  radiation_scheme == 'constant' ) &
1436             THEN
1437                message_string = 'data_output_pr = ' //                        &
1438                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1439                                 'not available for radiation = .FALSE. or ' //&
1440                                 'radiation_scheme = "constant"'
1441                CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1442             ELSE
1443                dopr_index(var_count) = 102
1444                dopr_unit  = 'W/m2'
1445                hom(:,2,102,:)  = SPREAD( zw, 2, statistic_regions+1 )
1446                unit = dopr_unit
1447             ENDIF
1448
1449          CASE ( 'rad_sw_out')
1450             IF ( (  .NOT.  radiation )  .OR.  radiation_scheme == 'constant' )&
1451             THEN
1452                message_string = 'data_output_pr = ' //                        &
1453                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1454                                 'not available for radiation = .FALSE. or ' //&
1455                                 'radiation_scheme = "constant"'
1456                CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1457             ELSE
1458                dopr_index(var_count) = 103
1459                dopr_unit  = 'W/m2'
1460                hom(:,2,103,:)  = SPREAD( zw, 2, statistic_regions+1 )
1461                unit = dopr_unit
1462             ENDIF
1463
1464          CASE ( 'rad_lw_cs_hr' )
1465             IF ( (  .NOT.  radiation )  .OR.  radiation_scheme /= 'rrtmg' )   &
1466             THEN
1467                message_string = 'data_output_pr = ' //                        &
1468                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1469                                 'not available for radiation = .FALSE. or ' //&
1470                                 'radiation_scheme /= "rrtmg"'
1471                CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1472             ELSE
1473                dopr_index(var_count) = 104
1474                dopr_unit  = 'K/h'
1475                hom(:,2,104,:)  = SPREAD( zu, 2, statistic_regions+1 )
1476                unit = dopr_unit
1477             ENDIF
1478
1479          CASE ( 'rad_lw_hr' )
1480             IF ( (  .NOT.  radiation )  .OR.  radiation_scheme /= 'rrtmg' )   &
1481             THEN
1482                message_string = 'data_output_pr = ' //                        &
1483                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1484                                 'not available for radiation = .FALSE. or ' //&
1485                                 'radiation_scheme /= "rrtmg"'
1486                CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1487             ELSE
1488                dopr_index(var_count) = 105
1489                dopr_unit  = 'K/h'
1490                hom(:,2,105,:)  = SPREAD( zu, 2, statistic_regions+1 )
1491                unit = dopr_unit
1492             ENDIF
1493
1494          CASE ( 'rad_sw_cs_hr' )
1495             IF ( (  .NOT.  radiation )  .OR.  radiation_scheme /= 'rrtmg' )   &
1496             THEN
1497                message_string = 'data_output_pr = ' //                        &
1498                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1499                                 'not available for radiation = .FALSE. or ' //&
1500                                 'radiation_scheme /= "rrtmg"'
1501                CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1502             ELSE
1503                dopr_index(var_count) = 106
1504                dopr_unit  = 'K/h'
1505                hom(:,2,106,:)  = SPREAD( zu, 2, statistic_regions+1 )
1506                unit = dopr_unit
1507             ENDIF
1508
1509          CASE ( 'rad_sw_hr' )
1510             IF ( (  .NOT.  radiation )  .OR.  radiation_scheme /= 'rrtmg' )   &
1511             THEN
1512                message_string = 'data_output_pr = ' //                        &
1513                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1514                                 'not available for radiation = .FALSE. or ' //&
1515                                 'radiation_scheme /= "rrtmg"'
1516                CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1517             ELSE
1518                dopr_index(var_count) = 107
1519                dopr_unit  = 'K/h'
1520                hom(:,2,107,:)  = SPREAD( zu, 2, statistic_regions+1 )
1521                unit = dopr_unit
1522             ENDIF
1523
1524
1525          CASE DEFAULT
1526             unit = 'illegal'
1527
1528       END SELECT
1529
1530
1531    END SUBROUTINE radiation_check_data_output_pr
1532 
1533 
1534!------------------------------------------------------------------------------!
1535! Description:
1536! ------------
1537!> Check parameters routine for radiation model
1538!------------------------------------------------------------------------------!
1539    SUBROUTINE radiation_check_parameters
1540
1541       USE control_parameters,                                                 &
1542           ONLY: land_surface, message_string, urban_surface
1543
1544       USE netcdf_data_input_mod,                                              &
1545           ONLY:  input_pids_static                 
1546   
1547       IMPLICIT NONE
1548       
1549!
1550!--    In case no urban-surface or land-surface model is applied, usage of
1551!--    a radiation model make no sense.         
1552       IF ( .NOT. land_surface  .AND.  .NOT. urban_surface )  THEN
1553          message_string = 'Usage of radiation module is only allowed if ' //  &
1554                           'land-surface and/or urban-surface model is applied.'
1555          CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 )
1556       ENDIF
1557
1558       IF ( radiation_scheme /= 'constant'   .AND.                             &
1559            radiation_scheme /= 'clear-sky'  .AND.                             &
1560            radiation_scheme /= 'rrtmg' )  THEN
1561          message_string = 'unknown radiation_scheme = '//                     &
1562                           TRIM( radiation_scheme )
1563          CALL message( 'check_parameters', 'PA0405', 1, 2, 0, 6, 0 )
1564       ELSEIF ( radiation_scheme == 'rrtmg' )  THEN
1565#if ! defined ( __rrtmg )
1566          message_string = 'radiation_scheme = "rrtmg" requires ' //           & 
1567                           'compilation of PALM with pre-processor ' //        &
1568                           'directive -D__rrtmg'
1569          CALL message( 'check_parameters', 'PA0407', 1, 2, 0, 6, 0 )
1570#endif
1571#if defined ( __rrtmg ) && ! defined( __netcdf )
1572          message_string = 'radiation_scheme = "rrtmg" requires ' //           & 
1573                           'the use of NetCDF (preprocessor directive ' //     &
1574                           '-D__netcdf'
1575          CALL message( 'check_parameters', 'PA0412', 1, 2, 0, 6, 0 )
1576#endif
1577
1578       ENDIF
1579!
1580!--    Checks performed only if data is given via namelist only.
1581       IF ( .NOT. input_pids_static )  THEN
1582          IF ( albedo_type == 0  .AND.  albedo == 9999999.9_wp  .AND.          &
1583               radiation_scheme == 'clear-sky')  THEN
1584             message_string = 'radiation_scheme = "clear-sky" in combination'//& 
1585                              'with albedo_type = 0 requires setting of'//     &
1586                              'albedo /= 9999999.9'
1587             CALL message( 'check_parameters', 'PA0410', 1, 2, 0, 6, 0 )
1588          ENDIF
1589
1590          IF ( albedo_type == 0  .AND.  radiation_scheme == 'rrtmg'  .AND.     &
1591             ( albedo_lw_dif == 9999999.9_wp .OR. albedo_lw_dir == 9999999.9_wp&
1592          .OR. albedo_sw_dif == 9999999.9_wp .OR. albedo_sw_dir == 9999999.9_wp& 
1593             ) ) THEN
1594             message_string = 'radiation_scheme = "rrtmg" in combination' //   & 
1595                              'with albedo_type = 0 requires setting of ' //   &
1596                              'albedo_lw_dif /= 9999999.9' //                  &
1597                              'albedo_lw_dir /= 9999999.9' //                  &
1598                              'albedo_sw_dif /= 9999999.9 and' //              &
1599                              'albedo_sw_dir /= 9999999.9'
1600             CALL message( 'check_parameters', 'PA0411', 1, 2, 0, 6, 0 )
1601          ENDIF
1602       ENDIF
1603!
1604!--    Parallel rad_angular_discretization without raytrace_mpi_rma is not implemented
1605#if defined( __parallel )     
1606       IF ( rad_angular_discretization  .AND.  .NOT. raytrace_mpi_rma )  THEN
1607          message_string = 'rad_angular_discretization can only be used ' //  &
1608                           'together with raytrace_mpi_rma or when ' //  &
1609                           'no parallelization is applied.'
1610          CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 )
1611       ENDIF
1612#endif
1613
1614       IF ( cloud_droplets  .AND.   radiation_scheme == 'rrtmg'  .AND.         &
1615            average_radiation ) THEN
1616          message_string = 'average_radiation = .T. with radiation_scheme'//   & 
1617                           '= "rrtmg" in combination cloud_droplets = .T.'//   &
1618                           'is not implementd'
1619          CALL message( 'check_parameters', 'PA0560', 1, 2, 0, 6, 0 )
1620       ENDIF
1621
1622!
1623!--    Incialize svf normalization reporting histogram
1624       svfnorm_report_num = 1
1625       DO WHILE ( svfnorm_report_thresh(svfnorm_report_num) < 1e20_wp          &
1626                   .AND. svfnorm_report_num <= 30 )
1627          svfnorm_report_num = svfnorm_report_num + 1
1628       ENDDO
1629       svfnorm_report_num = svfnorm_report_num - 1
1630
1631
1632 
1633    END SUBROUTINE radiation_check_parameters 
1634 
1635 
1636!------------------------------------------------------------------------------!
1637! Description:
1638! ------------
1639!> Initialization of the radiation model
1640!------------------------------------------------------------------------------!
1641    SUBROUTINE radiation_init
1642   
1643       IMPLICIT NONE
1644
1645       INTEGER(iwp) ::  i         !< running index x-direction
1646       INTEGER(iwp) ::  ioff      !< offset in x between surface element reference grid point in atmosphere and actual surface
1647       INTEGER(iwp) ::  j         !< running index y-direction
1648       INTEGER(iwp) ::  joff      !< offset in y between surface element reference grid point in atmosphere and actual surface
1649       INTEGER(iwp) ::  l         !< running index for orientation of vertical surfaces
1650       INTEGER(iwp) ::  m         !< running index for surface elements
1651#if defined( __rrtmg )
1652       INTEGER(iwp) ::  ind_type  !< running index for subgrid-surface tiles
1653#endif
1654
1655!
1656!--    Allocate array for storing the surface net radiation
1657       IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_net )  .AND.                      &
1658                  surf_lsm_h%ns > 0  )   THEN
1659          ALLOCATE( surf_lsm_h%rad_net(1:surf_lsm_h%ns) )
1660          surf_lsm_h%rad_net = 0.0_wp 
1661       ENDIF
1662       IF ( .NOT. ALLOCATED ( surf_usm_h%rad_net )  .AND.                      &
1663                  surf_usm_h%ns > 0  )  THEN
1664          ALLOCATE( surf_usm_h%rad_net(1:surf_usm_h%ns) )
1665          surf_usm_h%rad_net = 0.0_wp 
1666       ENDIF
1667       DO  l = 0, 3
1668          IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_net )  .AND.                &
1669                     surf_lsm_v(l)%ns > 0  )  THEN
1670             ALLOCATE( surf_lsm_v(l)%rad_net(1:surf_lsm_v(l)%ns) )
1671             surf_lsm_v(l)%rad_net = 0.0_wp 
1672          ENDIF
1673          IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_net )  .AND.                &
1674                     surf_usm_v(l)%ns > 0  )  THEN
1675             ALLOCATE( surf_usm_v(l)%rad_net(1:surf_usm_v(l)%ns) )
1676             surf_usm_v(l)%rad_net = 0.0_wp 
1677          ENDIF
1678       ENDDO
1679
1680
1681!
1682!--    Allocate array for storing the surface longwave (out) radiation change
1683       IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_lw_out_change_0 )  .AND.          &
1684                  surf_lsm_h%ns > 0  )   THEN
1685          ALLOCATE( surf_lsm_h%rad_lw_out_change_0(1:surf_lsm_h%ns) )
1686          surf_lsm_h%rad_lw_out_change_0 = 0.0_wp 
1687       ENDIF
1688       IF ( .NOT. ALLOCATED ( surf_usm_h%rad_lw_out_change_0 )  .AND.          &
1689                  surf_usm_h%ns > 0  )  THEN
1690          ALLOCATE( surf_usm_h%rad_lw_out_change_0(1:surf_usm_h%ns) )
1691          surf_usm_h%rad_lw_out_change_0 = 0.0_wp 
1692       ENDIF
1693       DO  l = 0, 3
1694          IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_lw_out_change_0 )  .AND.    &
1695                     surf_lsm_v(l)%ns > 0  )  THEN
1696             ALLOCATE( surf_lsm_v(l)%rad_lw_out_change_0(1:surf_lsm_v(l)%ns) )
1697             surf_lsm_v(l)%rad_lw_out_change_0 = 0.0_wp 
1698          ENDIF
1699          IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_lw_out_change_0 )  .AND.    &
1700                     surf_usm_v(l)%ns > 0  )  THEN
1701             ALLOCATE( surf_usm_v(l)%rad_lw_out_change_0(1:surf_usm_v(l)%ns) )
1702             surf_usm_v(l)%rad_lw_out_change_0 = 0.0_wp 
1703          ENDIF
1704       ENDDO
1705
1706!
1707!--    Allocate surface arrays for incoming/outgoing short/longwave radiation
1708       IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_sw_in )  .AND.                    &
1709                  surf_lsm_h%ns > 0  )   THEN
1710          ALLOCATE( surf_lsm_h%rad_sw_in(1:surf_lsm_h%ns)  )
1711          ALLOCATE( surf_lsm_h%rad_sw_out(1:surf_lsm_h%ns) )
1712          ALLOCATE( surf_lsm_h%rad_lw_in(1:surf_lsm_h%ns)  )
1713          ALLOCATE( surf_lsm_h%rad_lw_out(1:surf_lsm_h%ns) )
1714          surf_lsm_h%rad_sw_in  = 0.0_wp 
1715          surf_lsm_h%rad_sw_out = 0.0_wp 
1716          surf_lsm_h%rad_lw_in  = 0.0_wp 
1717          surf_lsm_h%rad_lw_out = 0.0_wp 
1718       ENDIF
1719       IF ( .NOT. ALLOCATED ( surf_usm_h%rad_sw_in )  .AND.                    &
1720                  surf_usm_h%ns > 0  )  THEN
1721          ALLOCATE( surf_usm_h%rad_sw_in(1:surf_usm_h%ns)  )
1722          ALLOCATE( surf_usm_h%rad_sw_out(1:surf_usm_h%ns) )
1723          ALLOCATE( surf_usm_h%rad_lw_in(1:surf_usm_h%ns)  )
1724          ALLOCATE( surf_usm_h%rad_lw_out(1:surf_usm_h%ns) )
1725          surf_usm_h%rad_sw_in  = 0.0_wp 
1726          surf_usm_h%rad_sw_out = 0.0_wp 
1727          surf_usm_h%rad_lw_in  = 0.0_wp 
1728          surf_usm_h%rad_lw_out = 0.0_wp 
1729       ENDIF
1730       DO  l = 0, 3
1731          IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_sw_in )  .AND.              &
1732                     surf_lsm_v(l)%ns > 0  )  THEN
1733             ALLOCATE( surf_lsm_v(l)%rad_sw_in(1:surf_lsm_v(l)%ns)  )
1734             ALLOCATE( surf_lsm_v(l)%rad_sw_out(1:surf_lsm_v(l)%ns) )
1735             ALLOCATE( surf_lsm_v(l)%rad_lw_in(1:surf_lsm_v(l)%ns)  )
1736             ALLOCATE( surf_lsm_v(l)%rad_lw_out(1:surf_lsm_v(l)%ns) )
1737             surf_lsm_v(l)%rad_sw_in  = 0.0_wp 
1738             surf_lsm_v(l)%rad_sw_out = 0.0_wp 
1739             surf_lsm_v(l)%rad_lw_in  = 0.0_wp 
1740             surf_lsm_v(l)%rad_lw_out = 0.0_wp 
1741          ENDIF
1742          IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_sw_in )  .AND.              &
1743                     surf_usm_v(l)%ns > 0  )  THEN
1744             ALLOCATE( surf_usm_v(l)%rad_sw_in(1:surf_usm_v(l)%ns)  )
1745             ALLOCATE( surf_usm_v(l)%rad_sw_out(1:surf_usm_v(l)%ns) )
1746             ALLOCATE( surf_usm_v(l)%rad_lw_in(1:surf_usm_v(l)%ns)  )
1747             ALLOCATE( surf_usm_v(l)%rad_lw_out(1:surf_usm_v(l)%ns) )
1748             surf_usm_v(l)%rad_sw_in  = 0.0_wp 
1749             surf_usm_v(l)%rad_sw_out = 0.0_wp 
1750             surf_usm_v(l)%rad_lw_in  = 0.0_wp 
1751             surf_usm_v(l)%rad_lw_out = 0.0_wp 
1752          ENDIF
1753       ENDDO
1754!
1755!--    Fix net radiation in case of radiation_scheme = 'constant'
1756       IF ( radiation_scheme == 'constant' )  THEN
1757          IF ( ALLOCATED( surf_lsm_h%rad_net ) )                               &
1758             surf_lsm_h%rad_net    = net_radiation
1759          IF ( ALLOCATED( surf_usm_h%rad_net ) )                               &
1760             surf_usm_h%rad_net    = net_radiation
1761!
1762!--       Todo: weight with inclination angle
1763          DO  l = 0, 3
1764             IF ( ALLOCATED( surf_lsm_v(l)%rad_net ) )                         &
1765                surf_lsm_v(l)%rad_net = net_radiation
1766             IF ( ALLOCATED( surf_usm_v(l)%rad_net ) )                         &
1767                surf_usm_v(l)%rad_net = net_radiation
1768          ENDDO
1769!          radiation = .FALSE.
1770!
1771!--    Calculate orbital constants
1772       ELSE
1773          decl_1 = SIN(23.45_wp * pi / 180.0_wp)
1774          decl_2 = 2.0_wp * pi / 365.0_wp
1775          decl_3 = decl_2 * 81.0_wp
1776          lat    = latitude * pi / 180.0_wp
1777          lon    = longitude * pi / 180.0_wp
1778       ENDIF
1779
1780       IF ( radiation_scheme == 'clear-sky'  .OR.                              &
1781            radiation_scheme == 'constant')  THEN
1782
1783
1784!
1785!--       Allocate arrays for incoming/outgoing short/longwave radiation
1786          IF ( .NOT. ALLOCATED ( rad_sw_in ) )  THEN
1787             ALLOCATE ( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) )
1788          ENDIF
1789          IF ( .NOT. ALLOCATED ( rad_sw_out ) )  THEN
1790             ALLOCATE ( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) )
1791          ENDIF
1792
1793          IF ( .NOT. ALLOCATED ( rad_lw_in ) )  THEN
1794             ALLOCATE ( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) )
1795          ENDIF
1796          IF ( .NOT. ALLOCATED ( rad_lw_out ) )  THEN
1797             ALLOCATE ( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) )
1798          ENDIF
1799
1800!
1801!--       Allocate average arrays for incoming/outgoing short/longwave radiation
1802          IF ( .NOT. ALLOCATED ( rad_sw_in_av ) )  THEN
1803             ALLOCATE ( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
1804          ENDIF
1805          IF ( .NOT. ALLOCATED ( rad_sw_out_av ) )  THEN
1806             ALLOCATE ( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
1807          ENDIF
1808
1809          IF ( .NOT. ALLOCATED ( rad_lw_in_av ) )  THEN
1810             ALLOCATE ( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
1811          ENDIF
1812          IF ( .NOT. ALLOCATED ( rad_lw_out_av ) )  THEN
1813             ALLOCATE ( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
1814          ENDIF
1815!
1816!--       Allocate arrays for broadband albedo, and level 1 initialization
1817!--       via namelist paramter, unless not already allocated.
1818          IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) )  THEN
1819             ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns)     )
1820             surf_lsm_h%albedo    = albedo
1821          ENDIF
1822          IF ( .NOT. ALLOCATED(surf_usm_h%albedo) )  THEN
1823             ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns)     )
1824             surf_usm_h%albedo    = albedo
1825          ENDIF
1826
1827          DO  l = 0, 3
1828             IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) )  THEN
1829                ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) )
1830                surf_lsm_v(l)%albedo = albedo
1831             ENDIF
1832             IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) )  THEN
1833                ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) )
1834                surf_usm_v(l)%albedo = albedo
1835             ENDIF
1836          ENDDO
1837!
1838!--       Level 2 initialization of broadband albedo via given albedo_type.
1839!--       Only if albedo_type is non-zero. In case of urban surface and
1840!--       input data is read from ASCII file, albedo_type will be zero, so that
1841!--       albedo won't be overwritten.
1842          DO  m = 1, surf_lsm_h%ns
1843             IF ( surf_lsm_h%albedo_type(ind_veg_wall,m) /= 0 )                &
1844                surf_lsm_h%albedo(ind_veg_wall,m) =                            &
1845                           albedo_pars(2,surf_lsm_h%albedo_type(ind_veg_wall,m))
1846             IF ( surf_lsm_h%albedo_type(ind_pav_green,m) /= 0 )               &
1847                surf_lsm_h%albedo(ind_pav_green,m) =                           &
1848                           albedo_pars(2,surf_lsm_h%albedo_type(ind_pav_green,m))
1849             IF ( surf_lsm_h%albedo_type(ind_wat_win,m) /= 0 )                 &
1850                surf_lsm_h%albedo(ind_wat_win,m) =                             &
1851                           albedo_pars(2,surf_lsm_h%albedo_type(ind_wat_win,m))
1852          ENDDO
1853          DO  m = 1, surf_usm_h%ns
1854             IF ( surf_usm_h%albedo_type(ind_veg_wall,m) /= 0 )                &
1855                surf_usm_h%albedo(ind_veg_wall,m) =                            &
1856                           albedo_pars(2,surf_usm_h%albedo_type(ind_veg_wall,m))
1857             IF ( surf_usm_h%albedo_type(ind_pav_green,m) /= 0 )               &
1858                surf_usm_h%albedo(ind_pav_green,m) =                           &
1859                           albedo_pars(2,surf_usm_h%albedo_type(ind_pav_green,m))
1860             IF ( surf_usm_h%albedo_type(ind_wat_win,m) /= 0 )                 &
1861                surf_usm_h%albedo(ind_wat_win,m) =                             &
1862                           albedo_pars(2,surf_usm_h%albedo_type(ind_wat_win,m))
1863          ENDDO
1864
1865          DO  l = 0, 3
1866             DO  m = 1, surf_lsm_v(l)%ns
1867                IF ( surf_lsm_v(l)%albedo_type(ind_veg_wall,m) /= 0 )          &
1868                   surf_lsm_v(l)%albedo(ind_veg_wall,m) =                      &
1869                        albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_veg_wall,m))
1870                IF ( surf_lsm_v(l)%albedo_type(ind_pav_green,m) /= 0 )         &
1871                   surf_lsm_v(l)%albedo(ind_pav_green,m) =                     &
1872                        albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_pav_green,m))
1873                IF ( surf_lsm_v(l)%albedo_type(ind_wat_win,m) /= 0 )           &
1874                   surf_lsm_v(l)%albedo(ind_wat_win,m) =                       &
1875                        albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_wat_win,m))
1876             ENDDO
1877             DO  m = 1, surf_usm_v(l)%ns
1878                IF ( surf_usm_v(l)%albedo_type(ind_veg_wall,m) /= 0 )          &
1879                   surf_usm_v(l)%albedo(ind_veg_wall,m) =                      &
1880                        albedo_pars(2,surf_usm_v(l)%albedo_type(ind_veg_wall,m))
1881                IF ( surf_usm_v(l)%albedo_type(ind_pav_green,m) /= 0 )         &
1882                   surf_usm_v(l)%albedo(ind_pav_green,m) =                     &
1883                        albedo_pars(2,surf_usm_v(l)%albedo_type(ind_pav_green,m))
1884                IF ( surf_usm_v(l)%albedo_type(ind_wat_win,m) /= 0 )           &
1885                   surf_usm_v(l)%albedo(ind_wat_win,m) =                       &
1886                        albedo_pars(2,surf_usm_v(l)%albedo_type(ind_wat_win,m))
1887             ENDDO
1888          ENDDO
1889
1890!
1891!--       Level 3 initialization at grid points where albedo type is zero.
1892!--       This case, albedo is taken from file. In case of constant radiation
1893!--       or clear sky, only broadband albedo is given.
1894          IF ( albedo_pars_f%from_file )  THEN
1895!
1896!--          Horizontal surfaces
1897             DO  m = 1, surf_lsm_h%ns
1898                i = surf_lsm_h%i(m)
1899                j = surf_lsm_h%j(m)
1900                IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )  THEN
1901                   IF ( surf_lsm_h%albedo_type(ind_veg_wall,m) == 0 )          &
1902                      surf_lsm_h%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1903                   IF ( surf_lsm_h%albedo_type(ind_pav_green,m) == 0 )         &
1904                      surf_lsm_h%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1905                   IF ( surf_lsm_h%albedo_type(ind_wat_win,m) == 0 )           &
1906                      surf_lsm_h%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1907                ENDIF
1908             ENDDO
1909             DO  m = 1, surf_usm_h%ns
1910                i = surf_usm_h%i(m)
1911                j = surf_usm_h%j(m)
1912                IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )  THEN
1913                   IF ( surf_usm_h%albedo_type(ind_veg_wall,m) == 0 )          &
1914                      surf_usm_h%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1915                   IF ( surf_usm_h%albedo_type(ind_pav_green,m) == 0 )         &
1916                      surf_usm_h%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1917                   IF ( surf_usm_h%albedo_type(ind_wat_win,m) == 0 )           &
1918                      surf_usm_h%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1919                ENDIF
1920             ENDDO 
1921!
1922!--          Vertical surfaces           
1923             DO  l = 0, 3
1924
1925                ioff = surf_lsm_v(l)%ioff
1926                joff = surf_lsm_v(l)%joff
1927                DO  m = 1, surf_lsm_v(l)%ns
1928                   i = surf_lsm_v(l)%i(m) + ioff
1929                   j = surf_lsm_v(l)%j(m) + joff
1930                   IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )  THEN
1931                      IF ( surf_lsm_v(l)%albedo_type(ind_veg_wall,m) == 0 )    &
1932                         surf_lsm_v(l)%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1933                      IF ( surf_lsm_v(l)%albedo_type(ind_pav_green,m) == 0 )   &
1934                         surf_lsm_v(l)%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1935                      IF ( surf_lsm_v(l)%albedo_type(ind_wat_win,m) == 0 )     &
1936                         surf_lsm_v(l)%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1937                   ENDIF
1938                ENDDO
1939
1940                ioff = surf_usm_v(l)%ioff
1941                joff = surf_usm_v(l)%joff
1942                DO  m = 1, surf_usm_h%ns
1943                   i = surf_usm_h%i(m) + joff
1944                   j = surf_usm_h%j(m) + joff
1945                   IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )  THEN
1946                      IF ( surf_usm_v(l)%albedo_type(ind_veg_wall,m) == 0 )    &
1947                         surf_usm_v(l)%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1948                      IF ( surf_usm_v(l)%albedo_type(ind_pav_green,m) == 0 )   &
1949                         surf_usm_v(l)%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1950                      IF ( surf_usm_v(l)%albedo_type(ind_wat_win,m) == 0 )     &
1951                         surf_lsm_v(l)%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1952                   ENDIF
1953                ENDDO
1954             ENDDO
1955
1956          ENDIF 
1957!
1958!--    Initialization actions for RRTMG
1959       ELSEIF ( radiation_scheme == 'rrtmg' )  THEN
1960#if defined ( __rrtmg )
1961!
1962!--       Allocate albedos for short/longwave radiation, horizontal surfaces
1963!--       for wall/green/window (USM) or vegetation/pavement/water surfaces
1964!--       (LSM).
1965          ALLOCATE ( surf_lsm_h%aldif(0:2,1:surf_lsm_h%ns)       )
1966          ALLOCATE ( surf_lsm_h%aldir(0:2,1:surf_lsm_h%ns)       )
1967          ALLOCATE ( surf_lsm_h%asdif(0:2,1:surf_lsm_h%ns)       )
1968          ALLOCATE ( surf_lsm_h%asdir(0:2,1:surf_lsm_h%ns)       )
1969          ALLOCATE ( surf_lsm_h%rrtm_aldif(0:2,1:surf_lsm_h%ns)  )
1970          ALLOCATE ( surf_lsm_h%rrtm_aldir(0:2,1:surf_lsm_h%ns)  )
1971          ALLOCATE ( surf_lsm_h%rrtm_asdif(0:2,1:surf_lsm_h%ns)  )
1972          ALLOCATE ( surf_lsm_h%rrtm_asdir(0:2,1:surf_lsm_h%ns)  )
1973
1974          ALLOCATE ( surf_usm_h%aldif(0:2,1:surf_usm_h%ns)       )
1975          ALLOCATE ( surf_usm_h%aldir(0:2,1:surf_usm_h%ns)       )
1976          ALLOCATE ( surf_usm_h%asdif(0:2,1:surf_usm_h%ns)       )
1977          ALLOCATE ( surf_usm_h%asdir(0:2,1:surf_usm_h%ns)       )
1978          ALLOCATE ( surf_usm_h%rrtm_aldif(0:2,1:surf_usm_h%ns)  )
1979          ALLOCATE ( surf_usm_h%rrtm_aldir(0:2,1:surf_usm_h%ns)  )
1980          ALLOCATE ( surf_usm_h%rrtm_asdif(0:2,1:surf_usm_h%ns)  )
1981          ALLOCATE ( surf_usm_h%rrtm_asdir(0:2,1:surf_usm_h%ns)  )
1982
1983!
1984!--       Allocate broadband albedo (temporary for the current radiation
1985!--       implementations)
1986          IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) )                            &
1987             ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns)     )
1988          IF ( .NOT. ALLOCATED(surf_usm_h%albedo) )                            &
1989             ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns)     )
1990
1991!
1992!--       Allocate albedos for short/longwave radiation, vertical surfaces
1993          DO  l = 0, 3
1994
1995             ALLOCATE ( surf_lsm_v(l)%aldif(0:2,1:surf_lsm_v(l)%ns)      )
1996             ALLOCATE ( surf_lsm_v(l)%aldir(0:2,1:surf_lsm_v(l)%ns)      )
1997             ALLOCATE ( surf_lsm_v(l)%asdif(0:2,1:surf_lsm_v(l)%ns)      )
1998             ALLOCATE ( surf_lsm_v(l)%asdir(0:2,1:surf_lsm_v(l)%ns)      )
1999
2000             ALLOCATE ( surf_lsm_v(l)%rrtm_aldif(0:2,1:surf_lsm_v(l)%ns) )
2001             ALLOCATE ( surf_lsm_v(l)%rrtm_aldir(0:2,1:surf_lsm_v(l)%ns) )
2002             ALLOCATE ( surf_lsm_v(l)%rrtm_asdif(0:2,1:surf_lsm_v(l)%ns) )
2003             ALLOCATE ( surf_lsm_v(l)%rrtm_asdir(0:2,1:surf_lsm_v(l)%ns) )
2004
2005             ALLOCATE ( surf_usm_v(l)%aldif(0:2,1:surf_usm_v(l)%ns)      )
2006             ALLOCATE ( surf_usm_v(l)%aldir(0:2,1:surf_usm_v(l)%ns)      )
2007             ALLOCATE ( surf_usm_v(l)%asdif(0:2,1:surf_usm_v(l)%ns)      )
2008             ALLOCATE ( surf_usm_v(l)%asdir(0:2,1:surf_usm_v(l)%ns)      )
2009
2010             ALLOCATE ( surf_usm_v(l)%rrtm_aldif(0:2,1:surf_usm_v(l)%ns) )
2011             ALLOCATE ( surf_usm_v(l)%rrtm_aldir(0:2,1:surf_usm_v(l)%ns) )
2012             ALLOCATE ( surf_usm_v(l)%rrtm_asdif(0:2,1:surf_usm_v(l)%ns) )
2013             ALLOCATE ( surf_usm_v(l)%rrtm_asdir(0:2,1:surf_usm_v(l)%ns) )
2014!
2015!--          Allocate broadband albedo (temporary for the current radiation
2016!--          implementations)
2017             IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) )                    &
2018                ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) )
2019             IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) )                    &
2020                ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) )
2021
2022          ENDDO
2023!
2024!--       Level 1 initialization of spectral albedos via namelist
2025!--       paramters. Please note, this case all surface tiles are initialized
2026!--       the same.
2027          IF ( surf_lsm_h%ns > 0 )  THEN
2028             surf_lsm_h%aldif  = albedo_lw_dif
2029             surf_lsm_h%aldir  = albedo_lw_dir
2030             surf_lsm_h%asdif  = albedo_sw_dif
2031             surf_lsm_h%asdir  = albedo_sw_dir
2032             surf_lsm_h%albedo = albedo_sw_dif
2033          ENDIF
2034          IF ( surf_usm_h%ns > 0 )  THEN
2035             IF ( surf_usm_h%albedo_from_ascii )  THEN
2036                surf_usm_h%aldif  = surf_usm_h%albedo
2037                surf_usm_h%aldir  = surf_usm_h%albedo
2038                surf_usm_h%asdif  = surf_usm_h%albedo
2039                surf_usm_h%asdir  = surf_usm_h%albedo
2040             ELSE
2041                surf_usm_h%aldif  = albedo_lw_dif
2042                surf_usm_h%aldir  = albedo_lw_dir
2043                surf_usm_h%asdif  = albedo_sw_dif
2044                surf_usm_h%asdir  = albedo_sw_dir
2045                surf_usm_h%albedo = albedo_sw_dif
2046             ENDIF
2047          ENDIF
2048
2049          DO  l = 0, 3
2050
2051             IF ( surf_lsm_v(l)%ns > 0 )  THEN
2052                surf_lsm_v(l)%aldif  = albedo_lw_dif
2053                surf_lsm_v(l)%aldir  = albedo_lw_dir
2054                surf_lsm_v(l)%asdif  = albedo_sw_dif
2055                surf_lsm_v(l)%asdir  = albedo_sw_dir
2056                surf_lsm_v(l)%albedo = albedo_sw_dif
2057             ENDIF
2058
2059             IF ( surf_usm_v(l)%ns > 0 )  THEN
2060                IF ( surf_usm_v(l)%albedo_from_ascii )  THEN
2061                   surf_usm_v(l)%aldif  = surf_usm_v(l)%albedo
2062                   surf_usm_v(l)%aldir  = surf_usm_v(l)%albedo
2063                   surf_usm_v(l)%asdif  = surf_usm_v(l)%albedo
2064                   surf_usm_v(l)%asdir  = surf_usm_v(l)%albedo
2065                ELSE
2066                   surf_usm_v(l)%aldif  = albedo_lw_dif
2067                   surf_usm_v(l)%aldir  = albedo_lw_dir
2068                   surf_usm_v(l)%asdif  = albedo_sw_dif
2069                   surf_usm_v(l)%asdir  = albedo_sw_dir
2070                ENDIF
2071             ENDIF
2072          ENDDO
2073
2074!
2075!--       Level 2 initialization of spectral albedos via albedo_type.
2076!--       Please note, for natural- and urban-type surfaces, a tile approach
2077!--       is applied so that the resulting albedo is calculated via the weighted
2078!--       average of respective surface fractions.
2079          DO  m = 1, surf_lsm_h%ns
2080!
2081!--          Spectral albedos for vegetation/pavement/water surfaces
2082             DO  ind_type = 0, 2
2083                IF ( surf_lsm_h%albedo_type(ind_type,m) /= 0 )  THEN
2084                   surf_lsm_h%aldif(ind_type,m) =                              &
2085                               albedo_pars(0,surf_lsm_h%albedo_type(ind_type,m))
2086                   surf_lsm_h%asdif(ind_type,m) =                              &
2087                               albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m))
2088                   surf_lsm_h%aldir(ind_type,m) =                              &
2089                               albedo_pars(0,surf_lsm_h%albedo_type(ind_type,m))
2090                   surf_lsm_h%asdir(ind_type,m) =                              &
2091                               albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m))
2092                   surf_lsm_h%albedo(ind_type,m) =                             &
2093                               albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m))
2094                ENDIF
2095             ENDDO
2096
2097          ENDDO
2098!
2099!--       For urban surface only if albedo has not been already initialized
2100!--       in the urban-surface model via the ASCII file.
2101          IF ( .NOT. surf_usm_h%albedo_from_ascii )  THEN
2102             DO  m = 1, surf_usm_h%ns
2103!
2104!--             Spectral albedos for wall/green/window surfaces
2105                DO  ind_type = 0, 2
2106                   IF ( surf_usm_h%albedo_type(ind_type,m) /= 0 )  THEN
2107                      surf_usm_h%aldif(ind_type,m) =                           &
2108                               albedo_pars(0,surf_usm_h%albedo_type(ind_type,m))
2109                      surf_usm_h%asdif(ind_type,m) =                           &
2110                               albedo_pars(1,surf_usm_h%albedo_type(ind_type,m))
2111                      surf_usm_h%aldir(ind_type,m) =                           &
2112                               albedo_pars(0,surf_usm_h%albedo_type(ind_type,m))
2113                      surf_usm_h%asdir(ind_type,m) =                           &
2114                               albedo_pars(1,surf_usm_h%albedo_type(ind_type,m))
2115                      surf_usm_h%albedo(ind_type,m) =                          &
2116                               albedo_pars(2,surf_usm_h%albedo_type(ind_type,m))
2117                   ENDIF
2118                ENDDO
2119
2120             ENDDO
2121          ENDIF
2122
2123          DO l = 0, 3
2124
2125             DO  m = 1, surf_lsm_v(l)%ns
2126!
2127!--             Spectral albedos for vegetation/pavement/water surfaces
2128                DO  ind_type = 0, 2
2129                   IF ( surf_lsm_v(l)%albedo_type(ind_type,m) /= 0 )  THEN
2130                      surf_lsm_v(l)%aldif(ind_type,m) =                        &
2131                            albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_type,m))
2132                      surf_lsm_v(l)%asdif(ind_type,m) =                        &
2133                            albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m))
2134                      surf_lsm_v(l)%aldir(ind_type,m) =                        &
2135                            albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_type,m))
2136                      surf_lsm_v(l)%asdir(ind_type,m) =                        &
2137                            albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m))
2138                      surf_lsm_v(l)%albedo(ind_type,m) =                       &
2139                            albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m))
2140                   ENDIF
2141                ENDDO
2142             ENDDO
2143!
2144!--          For urban surface only if albedo has not been already initialized
2145!--          in the urban-surface model via the ASCII file.
2146             IF ( .NOT. surf_usm_v(l)%albedo_from_ascii )  THEN
2147                DO  m = 1, surf_usm_v(l)%ns
2148!
2149!--                Spectral albedos for wall/green/window surfaces
2150                   DO  ind_type = 0, 2
2151                      IF ( surf_usm_v(l)%albedo_type(ind_type,m) /= 0 )  THEN
2152                         surf_usm_v(l)%aldif(ind_type,m) =                     &
2153                            albedo_pars(0,surf_usm_v(l)%albedo_type(ind_type,m))
2154                         surf_usm_v(l)%asdif(ind_type,m) =                     &
2155                            albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m))
2156                         surf_usm_v(l)%aldir(ind_type,m) =                     &
2157                            albedo_pars(0,surf_usm_v(l)%albedo_type(ind_type,m))
2158                         surf_usm_v(l)%asdir(ind_type,m) =                     &
2159                            albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m))
2160                         surf_usm_v(l)%albedo(ind_type,m) =                    &
2161                            albedo_pars(2,surf_usm_v(l)%albedo_type(ind_type,m))
2162                      ENDIF
2163                   ENDDO
2164
2165                ENDDO
2166             ENDIF
2167          ENDDO
2168!
2169!--       Level 3 initialization at grid points where albedo type is zero.
2170!--       This case, spectral albedos are taken from file if available
2171          IF ( albedo_pars_f%from_file )  THEN
2172!
2173!--          Horizontal
2174             DO  m = 1, surf_lsm_h%ns
2175                i = surf_lsm_h%i(m)
2176                j = surf_lsm_h%j(m)
2177!
2178!--             Spectral albedos for vegetation/pavement/water surfaces
2179                DO  ind_type = 0, 2
2180                   IF ( surf_lsm_h%albedo_type(ind_type,m) == 0 )  THEN
2181                      IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )&
2182                         surf_lsm_h%albedo(ind_type,m) =                       &
2183                                                albedo_pars_f%pars_xy(1,j,i)
2184                      IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )&
2185                         surf_lsm_h%aldir(ind_type,m) =                        &
2186                                                albedo_pars_f%pars_xy(1,j,i)
2187                      IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill )&
2188                         surf_lsm_h%aldif(ind_type,m) =                        &
2189                                                albedo_pars_f%pars_xy(2,j,i)
2190                      IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill )&
2191                         surf_lsm_h%asdir(ind_type,m) =                        &
2192                                                albedo_pars_f%pars_xy(3,j,i)
2193                      IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill )&
2194                         surf_lsm_h%asdif(ind_type,m) =                        &
2195                                                albedo_pars_f%pars_xy(4,j,i)
2196                   ENDIF
2197                ENDDO
2198             ENDDO
2199!
2200!--          For urban surface only if albedo has not been already initialized
2201!--          in the urban-surface model via the ASCII file.
2202             IF ( .NOT. surf_usm_h%albedo_from_ascii )  THEN
2203                DO  m = 1, surf_usm_h%ns
2204                   i = surf_usm_h%i(m)
2205                   j = surf_usm_h%j(m)
2206!
2207!--                Spectral albedos for wall/green/window surfaces
2208                   DO  ind_type = 0, 2
2209                      IF ( surf_usm_h%albedo_type(ind_type,m) == 0 )  THEN
2210                         IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )&
2211                            surf_usm_h%albedo(ind_type,m) =                       &
2212                                                albedo_pars_f%pars_xy(1,j,i)
2213                         IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )&
2214                            surf_usm_h%aldir(ind_type,m) =                        &
2215                                                albedo_pars_f%pars_xy(1,j,i)
2216                         IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill )&
2217                            surf_usm_h%aldif(ind_type,m) =                        &
2218                                                albedo_pars_f%pars_xy(2,j,i)
2219                         IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill )&
2220                            surf_usm_h%asdir(ind_type,m) =                        &
2221                                                albedo_pars_f%pars_xy(3,j,i)
2222                         IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill )&
2223                            surf_usm_h%asdif(ind_type,m) =                        &
2224                                                albedo_pars_f%pars_xy(4,j,i)
2225                      ENDIF
2226                   ENDDO
2227
2228                ENDDO
2229             ENDIF
2230!
2231!--          Vertical
2232             DO  l = 0, 3
2233                ioff = surf_lsm_v(l)%ioff
2234                joff = surf_lsm_v(l)%joff
2235
2236                DO  m = 1, surf_lsm_v(l)%ns
2237                   i = surf_lsm_v(l)%i(m)
2238                   j = surf_lsm_v(l)%j(m)
2239!
2240!--                Spectral albedos for vegetation/pavement/water surfaces
2241                   DO  ind_type = 0, 2
2242                      IF ( surf_lsm_v(l)%albedo_type(ind_type,m) == 0 )  THEN
2243                         IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /=        &
2244                              albedo_pars_f%fill )                             &
2245                            surf_lsm_v(l)%albedo(ind_type,m) =                 &
2246                                          albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2247                         IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /=        &
2248                              albedo_pars_f%fill )                             &
2249                            surf_lsm_v(l)%aldir(ind_type,m) =                  &
2250                                          albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2251                         IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /=        &
2252                              albedo_pars_f%fill )                             &
2253                            surf_lsm_v(l)%aldif(ind_type,m) =                  &
2254                                          albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2255                         IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /=        &
2256                              albedo_pars_f%fill )                             &
2257                            surf_lsm_v(l)%asdir(ind_type,m) =                  &
2258                                          albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2259                         IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /=        &
2260                              albedo_pars_f%fill )                             &
2261                            surf_lsm_v(l)%asdif(ind_type,m) =                  &
2262                                          albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2263                      ENDIF
2264                   ENDDO
2265                ENDDO
2266!
2267!--             For urban surface only if albedo has not been already initialized
2268!--             in the urban-surface model via the ASCII file.
2269                IF ( .NOT. surf_usm_v(l)%albedo_from_ascii )  THEN
2270                   ioff = surf_usm_v(l)%ioff
2271                   joff = surf_usm_v(l)%joff
2272
2273                   DO  m = 1, surf_usm_v(l)%ns
2274                      i = surf_usm_v(l)%i(m)
2275                      j = surf_usm_v(l)%j(m)
2276!
2277!--                   Spectral albedos for wall/green/window surfaces
2278                      DO  ind_type = 0, 2
2279                         IF ( surf_usm_v(l)%albedo_type(ind_type,m) == 0 )  THEN
2280                            IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /=        &
2281                                 albedo_pars_f%fill )                             &
2282                               surf_usm_v(l)%albedo(ind_type,m) =                 &
2283                                             albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2284                            IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /=        &
2285                                 albedo_pars_f%fill )                             &
2286                               surf_usm_v(l)%aldir(ind_type,m) =                  &
2287                                             albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2288                            IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /=        &
2289                                 albedo_pars_f%fill )                             &
2290                               surf_usm_v(l)%aldif(ind_type,m) =                  &
2291                                             albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2292                            IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /=        &
2293                                 albedo_pars_f%fill )                             &
2294                               surf_usm_v(l)%asdir(ind_type,m) =                  &
2295                                             albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2296                            IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /=        &
2297                                 albedo_pars_f%fill )                             &
2298                               surf_usm_v(l)%asdif(ind_type,m) =                  &
2299                                             albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2300                         ENDIF
2301                      ENDDO
2302
2303                   ENDDO
2304                ENDIF
2305             ENDDO
2306
2307          ENDIF
2308
2309!
2310!--       Calculate initial values of current (cosine of) the zenith angle and
2311!--       whether the sun is up
2312          CALL calc_zenith     
2313!
2314!--       Calculate initial surface albedo for different surfaces
2315          IF ( .NOT. constant_albedo )  THEN
2316#if defined( __netcdf )
2317!
2318!--          Horizontally aligned natural and urban surfaces
2319             CALL calc_albedo( surf_lsm_h    )
2320             CALL calc_albedo( surf_usm_h    )
2321!
2322!--          Vertically aligned natural and urban surfaces
2323             DO  l = 0, 3
2324                CALL calc_albedo( surf_lsm_v(l) )
2325                CALL calc_albedo( surf_usm_v(l) )
2326             ENDDO
2327#endif
2328          ELSE
2329!
2330!--          Initialize sun-inclination independent spectral albedos
2331!--          Horizontal surfaces
2332             IF ( surf_lsm_h%ns > 0 )  THEN
2333                surf_lsm_h%rrtm_aldir = surf_lsm_h%aldir
2334                surf_lsm_h%rrtm_asdir = surf_lsm_h%asdir
2335                surf_lsm_h%rrtm_aldif = surf_lsm_h%aldif
2336                surf_lsm_h%rrtm_asdif = surf_lsm_h%asdif
2337             ENDIF
2338             IF ( surf_usm_h%ns > 0 )  THEN
2339                surf_usm_h%rrtm_aldir = surf_usm_h%aldir
2340                surf_usm_h%rrtm_asdir = surf_usm_h%asdir
2341                surf_usm_h%rrtm_aldif = surf_usm_h%aldif
2342                surf_usm_h%rrtm_asdif = surf_usm_h%asdif
2343             ENDIF
2344!
2345!--          Vertical surfaces
2346             DO  l = 0, 3
2347                IF ( surf_lsm_v(l)%ns > 0 )  THEN
2348                   surf_lsm_v(l)%rrtm_aldir = surf_lsm_v(l)%aldir
2349                   surf_lsm_v(l)%rrtm_asdir = surf_lsm_v(l)%asdir
2350                   surf_lsm_v(l)%rrtm_aldif = surf_lsm_v(l)%aldif
2351                   surf_lsm_v(l)%rrtm_asdif = surf_lsm_v(l)%asdif
2352                ENDIF
2353                IF ( surf_usm_v(l)%ns > 0 )  THEN
2354                   surf_usm_v(l)%rrtm_aldir = surf_usm_v(l)%aldir
2355                   surf_usm_v(l)%rrtm_asdir = surf_usm_v(l)%asdir
2356                   surf_usm_v(l)%rrtm_aldif = surf_usm_v(l)%aldif
2357                   surf_usm_v(l)%rrtm_asdif = surf_usm_v(l)%asdif
2358                ENDIF
2359             ENDDO
2360
2361          ENDIF
2362
2363!
2364!--       Allocate 3d arrays of radiative fluxes and heating rates
2365          IF ( .NOT. ALLOCATED ( rad_sw_in ) )  THEN
2366             ALLOCATE ( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2367             rad_sw_in = 0.0_wp
2368          ENDIF
2369
2370          IF ( .NOT. ALLOCATED ( rad_sw_in_av ) )  THEN
2371             ALLOCATE ( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2372          ENDIF
2373
2374          IF ( .NOT. ALLOCATED ( rad_sw_out ) )  THEN
2375             ALLOCATE ( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2376             rad_sw_out = 0.0_wp
2377          ENDIF
2378
2379          IF ( .NOT. ALLOCATED ( rad_sw_out_av ) )  THEN
2380             ALLOCATE ( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2381          ENDIF
2382
2383          IF ( .NOT. ALLOCATED ( rad_sw_hr ) )  THEN
2384             ALLOCATE ( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2385             rad_sw_hr = 0.0_wp
2386          ENDIF
2387
2388          IF ( .NOT. ALLOCATED ( rad_sw_hr_av ) )  THEN
2389             ALLOCATE ( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2390             rad_sw_hr_av = 0.0_wp
2391          ENDIF
2392
2393          IF ( .NOT. ALLOCATED ( rad_sw_cs_hr ) )  THEN
2394             ALLOCATE ( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2395             rad_sw_cs_hr = 0.0_wp
2396          ENDIF
2397
2398          IF ( .NOT. ALLOCATED ( rad_sw_cs_hr_av ) )  THEN
2399             ALLOCATE ( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2400             rad_sw_cs_hr_av = 0.0_wp
2401          ENDIF
2402
2403          IF ( .NOT. ALLOCATED ( rad_lw_in ) )  THEN
2404             ALLOCATE ( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2405             rad_lw_in     = 0.0_wp
2406          ENDIF
2407
2408          IF ( .NOT. ALLOCATED ( rad_lw_in_av ) )  THEN
2409             ALLOCATE ( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2410          ENDIF
2411
2412          IF ( .NOT. ALLOCATED ( rad_lw_out ) )  THEN
2413             ALLOCATE ( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2414            rad_lw_out    = 0.0_wp
2415          ENDIF
2416
2417          IF ( .NOT. ALLOCATED ( rad_lw_out_av ) )  THEN
2418             ALLOCATE ( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2419          ENDIF
2420
2421          IF ( .NOT. ALLOCATED ( rad_lw_hr ) )  THEN
2422             ALLOCATE ( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2423             rad_lw_hr = 0.0_wp
2424          ENDIF
2425
2426          IF ( .NOT. ALLOCATED ( rad_lw_hr_av ) )  THEN
2427             ALLOCATE ( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2428             rad_lw_hr_av = 0.0_wp
2429          ENDIF
2430
2431          IF ( .NOT. ALLOCATED ( rad_lw_cs_hr ) )  THEN
2432             ALLOCATE ( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2433             rad_lw_cs_hr = 0.0_wp
2434          ENDIF
2435
2436          IF ( .NOT. ALLOCATED ( rad_lw_cs_hr_av ) )  THEN
2437             ALLOCATE ( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2438             rad_lw_cs_hr_av = 0.0_wp
2439          ENDIF
2440
2441          ALLOCATE ( rad_sw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2442          ALLOCATE ( rad_sw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2443          rad_sw_cs_in  = 0.0_wp
2444          rad_sw_cs_out = 0.0_wp
2445
2446          ALLOCATE ( rad_lw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2447          ALLOCATE ( rad_lw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2448          rad_lw_cs_in  = 0.0_wp
2449          rad_lw_cs_out = 0.0_wp
2450
2451!
2452!--       Allocate 1-element array for surface temperature
2453!--       (RRTMG anticipates an array as passed argument).
2454          ALLOCATE ( rrtm_tsfc(1) )
2455!
2456!--       Allocate surface emissivity.
2457!--       Values will be given directly before calling rrtm_lw.
2458          ALLOCATE ( rrtm_emis(0:0,1:nbndlw+1) )
2459
2460!
2461!--       Initialize RRTMG
2462          IF ( lw_radiation )  CALL rrtmg_lw_ini ( c_p )
2463          IF ( sw_radiation )  CALL rrtmg_sw_ini ( c_p )
2464
2465!
2466!--       Set input files for RRTMG
2467          INQUIRE(FILE="RAD_SND_DATA", EXIST=snd_exists) 
2468          IF ( .NOT. snd_exists )  THEN
2469             rrtm_input_file = "rrtmg_lw.nc"
2470          ENDIF
2471
2472!
2473!--       Read vertical layers for RRTMG from sounding data
2474!--       The routine provides nzt_rad, hyp_snd(1:nzt_rad),
2475!--       t_snd(nzt+2:nzt_rad), rrtm_play(1:nzt_rad), rrtm_plev(1_nzt_rad+1),
2476!--       rrtm_tlay(nzt+2:nzt_rad), rrtm_tlev(nzt+2:nzt_rad+1)
2477          CALL read_sounding_data
2478
2479!
2480!--       Read trace gas profiles from file. This routine provides
2481!--       the rrtm_ arrays (1:nzt_rad+1)
2482          CALL read_trace_gas_data
2483#endif
2484       ENDIF
2485
2486!
2487!--    Perform user actions if required
2488       CALL user_init_radiation
2489
2490!
2491!--    Calculate radiative fluxes at model start
2492       SELECT CASE ( TRIM( radiation_scheme ) )
2493
2494          CASE ( 'rrtmg' )
2495             CALL radiation_rrtmg
2496
2497          CASE ( 'clear-sky' )
2498             CALL radiation_clearsky
2499
2500          CASE ( 'constant' )
2501             CALL radiation_constant
2502
2503          CASE DEFAULT
2504
2505       END SELECT
2506
2507       RETURN
2508
2509    END SUBROUTINE radiation_init
2510
2511
2512!------------------------------------------------------------------------------!
2513! Description:
2514! ------------
2515!> A simple clear sky radiation model
2516!------------------------------------------------------------------------------!
2517    SUBROUTINE radiation_clearsky
2518
2519
2520       IMPLICIT NONE
2521
2522       INTEGER(iwp) ::  l         !< running index for surface orientation
2523       REAL(wp)     ::  pt1       !< potential temperature at first grid level or mean value at urban layer top
2524       REAL(wp)     ::  pt1_l     !< potential temperature at first grid level or mean value at urban layer top at local subdomain
2525       REAL(wp)     ::  ql1       !< liquid water mixing ratio at first grid level or mean value at urban layer top
2526       REAL(wp)     ::  ql1_l     !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain
2527
2528       TYPE(surf_type), POINTER ::  surf !< pointer on respective surface type, used to generalize routine   
2529
2530!
2531!--    Calculate current zenith angle
2532       CALL calc_zenith
2533
2534!
2535!--    Calculate sky transmissivity
2536       sky_trans = 0.6_wp + 0.2_wp * zenith(0)
2537
2538!
2539!--    Calculate value of the Exner function at model surface
2540!
2541!--    In case averaged radiation is used, calculate mean temperature and
2542!--    liquid water mixing ratio at the urban-layer top.
2543       IF ( average_radiation ) THEN
2544          pt1   = 0.0_wp
2545          IF ( bulk_cloud_model  .OR.  cloud_droplets )  ql1   = 0.0_wp
2546
2547          pt1_l = SUM( pt(nzut,nys:nyn,nxl:nxr) )
2548          IF ( bulk_cloud_model  .OR.  cloud_droplets  )  ql1_l = SUM( ql(nzut,nys:nyn,nxl:nxr) )
2549
2550#if defined( __parallel )     
2551          IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
2552          CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
2553          IF ( ierr /= 0 ) THEN
2554              WRITE(9,*) 'Error MPI_AllReduce1:', ierr, pt1_l, pt1
2555              FLUSH(9)
2556          ENDIF
2557
2558          IF ( bulk_cloud_model  .OR.  cloud_droplets ) THEN
2559              CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
2560              IF ( ierr /= 0 ) THEN
2561                  WRITE(9,*) 'Error MPI_AllReduce2:', ierr, ql1_l, ql1
2562                  FLUSH(9)
2563              ENDIF
2564          ENDIF
2565#else
2566          pt1 = pt1_l 
2567          IF ( bulk_cloud_model  .OR.  cloud_droplets )  ql1 = ql1_l
2568#endif
2569
2570          IF ( bulk_cloud_model  .OR.  cloud_droplets  )  pt1 = pt1 + lv_d_cp / exner(nzut) * ql1
2571!
2572!--       Finally, divide by number of grid points
2573          pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp )
2574       ENDIF
2575!
2576!--    Call clear-sky calculation for each surface orientation.
2577!--    First, horizontal surfaces
2578       surf => surf_lsm_h
2579       CALL radiation_clearsky_surf
2580       surf => surf_usm_h
2581       CALL radiation_clearsky_surf
2582!
2583!--    Vertical surfaces
2584       DO  l = 0, 3
2585          surf => surf_lsm_v(l)
2586          CALL radiation_clearsky_surf
2587          surf => surf_usm_v(l)
2588          CALL radiation_clearsky_surf
2589       ENDDO
2590
2591       CONTAINS
2592
2593          SUBROUTINE radiation_clearsky_surf
2594
2595             IMPLICIT NONE
2596
2597             INTEGER(iwp) ::  i         !< index x-direction
2598             INTEGER(iwp) ::  j         !< index y-direction
2599             INTEGER(iwp) ::  k         !< index z-direction
2600             INTEGER(iwp) ::  m         !< running index for surface elements
2601
2602             IF ( surf%ns < 1 )  RETURN
2603
2604!
2605!--          Calculate radiation fluxes and net radiation (rad_net) assuming
2606!--          homogeneous urban radiation conditions.
2607             IF ( average_radiation ) THEN       
2608
2609                k = nzut
2610
2611                surf%rad_sw_in  = solar_constant * sky_trans * zenith(0)
2612                surf%rad_sw_out = albedo_urb * surf%rad_sw_in
2613               
2614                surf%rad_lw_in  = 0.8_wp * sigma_sb * (pt1 * exner(k+1))**4
2615
2616                surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4   &
2617                                    + (1.0_wp - emissivity_urb) * surf%rad_lw_in
2618
2619                surf%rad_net = surf%rad_sw_in - surf%rad_sw_out                &
2620                             + surf%rad_lw_in - surf%rad_lw_out
2621
2622                surf%rad_lw_out_change_0 = 3.0_wp * emissivity_urb * sigma_sb  &
2623                                           * (t_rad_urb)**3
2624
2625!
2626!--          Calculate radiation fluxes and net radiation (rad_net) for each surface
2627!--          element.
2628             ELSE
2629
2630                DO  m = 1, surf%ns
2631                   i = surf%i(m)
2632                   j = surf%j(m)
2633                   k = surf%k(m)
2634
2635                   surf%rad_sw_in(m) = solar_constant * sky_trans * zenith(0)
2636
2637!
2638!--                Weighted average according to surface fraction.
2639!--                ATTENTION: when radiation interactions are switched on the
2640!--                calculated fluxes below are not actually used as they are
2641!--                overwritten in radiation_interaction.
2642                   surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m)  *         &
2643                                          surf%albedo(ind_veg_wall,m)          &
2644                                        + surf%frac(ind_pav_green,m) *         &
2645                                          surf%albedo(ind_pav_green,m)         &
2646                                        + surf%frac(ind_wat_win,m)   *         &
2647                                          surf%albedo(ind_wat_win,m) )         &
2648                                        * surf%rad_sw_in(m)
2649
2650                   surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m)  *         &
2651                                          surf%emissivity(ind_veg_wall,m)      &
2652                                        + surf%frac(ind_pav_green,m) *         &
2653                                          surf%emissivity(ind_pav_green,m)     &
2654                                        + surf%frac(ind_wat_win,m)   *         &
2655                                          surf%emissivity(ind_wat_win,m)       &
2656                                        )                                      &
2657                                        * sigma_sb                             &
2658                                        * ( surf%pt_surface(m) * exner(nzb) )**4
2659
2660                   surf%rad_lw_out_change_0(m) =                               &
2661                                      ( surf%frac(ind_veg_wall,m)  *           &
2662                                        surf%emissivity(ind_veg_wall,m)        &
2663                                      + surf%frac(ind_pav_green,m) *           &
2664                                        surf%emissivity(ind_pav_green,m)       &
2665                                      + surf%frac(ind_wat_win,m)   *           &
2666                                        surf%emissivity(ind_wat_win,m)         &
2667                                      ) * 3.0_wp * sigma_sb                    &
2668                                      * ( surf%pt_surface(m) * exner(nzb) )** 3
2669
2670
2671                   IF ( bulk_cloud_model  .OR.  cloud_droplets  )  THEN
2672                      pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i)
2673                      surf%rad_lw_in(m)  = 0.8_wp * sigma_sb * (pt1 * exner(k))**4
2674                   ELSE
2675                      surf%rad_lw_in(m)  = 0.8_wp * sigma_sb * (pt(k,j,i) * exner(k))**4
2676                   ENDIF
2677
2678                   surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m)    &
2679                                   + surf%rad_lw_in(m) - surf%rad_lw_out(m)
2680
2681                ENDDO
2682
2683             ENDIF
2684
2685!
2686!--          Fill out values in radiation arrays
2687             DO  m = 1, surf%ns
2688                i = surf%i(m)
2689                j = surf%j(m)
2690                rad_sw_in(0,j,i) = surf%rad_sw_in(m)
2691                rad_sw_out(0,j,i) = surf%rad_sw_out(m)
2692                rad_lw_in(0,j,i) = surf%rad_lw_in(m)
2693                rad_lw_out(0,j,i) = surf%rad_lw_out(m)
2694             ENDDO
2695 
2696          END SUBROUTINE radiation_clearsky_surf
2697
2698    END SUBROUTINE radiation_clearsky
2699
2700
2701!------------------------------------------------------------------------------!
2702! Description:
2703! ------------
2704!> This scheme keeps the prescribed net radiation constant during the run
2705!------------------------------------------------------------------------------!
2706    SUBROUTINE radiation_constant
2707
2708
2709       IMPLICIT NONE
2710
2711       INTEGER(iwp) ::  l         !< running index for surface orientation
2712
2713       REAL(wp)     ::  pt1       !< potential temperature at first grid level or mean value at urban layer top
2714       REAL(wp)     ::  pt1_l     !< potential temperature at first grid level or mean value at urban layer top at local subdomain
2715       REAL(wp)     ::  ql1       !< liquid water mixing ratio at first grid level or mean value at urban layer top
2716       REAL(wp)     ::  ql1_l     !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain
2717
2718       TYPE(surf_type), POINTER ::  surf !< pointer on respective surface type, used to generalize routine
2719
2720!
2721!--    In case averaged radiation is used, calculate mean temperature and
2722!--    liquid water mixing ratio at the urban-layer top.
2723       IF ( average_radiation ) THEN   
2724          pt1   = 0.0_wp
2725          IF ( bulk_cloud_model  .OR.  cloud_droplets )  ql1   = 0.0_wp
2726
2727          pt1_l = SUM( pt(nzut,nys:nyn,nxl:nxr) )
2728          IF ( bulk_cloud_model  .OR.  cloud_droplets )  ql1_l = SUM( ql(nzut,nys:nyn,nxl:nxr) )
2729
2730#if defined( __parallel )     
2731          IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
2732          CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
2733          IF ( ierr /= 0 ) THEN
2734              WRITE(9,*) 'Error MPI_AllReduce3:', ierr, pt1_l, pt1
2735              FLUSH(9)
2736          ENDIF
2737          IF ( bulk_cloud_model  .OR.  cloud_droplets )  THEN
2738             CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
2739             IF ( ierr /= 0 ) THEN
2740                 WRITE(9,*) 'Error MPI_AllReduce4:', ierr, ql1_l, ql1
2741                 FLUSH(9)
2742             ENDIF
2743          ENDIF
2744#else
2745          pt1 = pt1_l
2746          IF ( bulk_cloud_model  .OR.  cloud_droplets )  ql1 = ql1_l
2747#endif
2748          IF ( bulk_cloud_model  .OR.  cloud_droplets )  pt1 = pt1 + lv_d_cp / exner(nzut+1) * ql1
2749!
2750!--       Finally, divide by number of grid points
2751          pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp )
2752       ENDIF
2753
2754!
2755!--    First, horizontal surfaces
2756       surf => surf_lsm_h
2757       CALL radiation_constant_surf
2758       surf => surf_usm_h
2759       CALL radiation_constant_surf
2760!
2761!--    Vertical surfaces
2762       DO  l = 0, 3
2763          surf => surf_lsm_v(l)
2764          CALL radiation_constant_surf
2765          surf => surf_usm_v(l)
2766          CALL radiation_constant_surf
2767       ENDDO
2768
2769       CONTAINS
2770
2771          SUBROUTINE radiation_constant_surf
2772
2773             IMPLICIT NONE
2774
2775             INTEGER(iwp) ::  i         !< index x-direction
2776             INTEGER(iwp) ::  ioff      !< offset between surface element and adjacent grid point along x
2777             INTEGER(iwp) ::  j         !< index y-direction
2778             INTEGER(iwp) ::  joff      !< offset between surface element and adjacent grid point along y
2779             INTEGER(iwp) ::  k         !< index z-direction
2780             INTEGER(iwp) ::  koff      !< offset between surface element and adjacent grid point along z
2781             INTEGER(iwp) ::  m         !< running index for surface elements
2782
2783             IF ( surf%ns < 1 )  RETURN
2784
2785!--          Calculate homogenoeus urban radiation fluxes
2786             IF ( average_radiation ) THEN
2787
2788                surf%rad_net = net_radiation
2789
2790                surf%rad_lw_in  = 0.8_wp * sigma_sb * (pt1 * exner(nzut+1))**4
2791
2792                surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4   &
2793                                    + ( 1.0_wp - emissivity_urb )             & ! shouldn't be this a bulk value -- emissivity_urb?
2794                                    * surf%rad_lw_in
2795
2796                surf%rad_lw_out_change_0 = 3.0_wp * emissivity_urb * sigma_sb  &
2797                                           * t_rad_urb**3
2798
2799                surf%rad_sw_in = ( surf%rad_net - surf%rad_lw_in               &
2800                                     + surf%rad_lw_out )                       &
2801                                     / ( 1.0_wp - albedo_urb )
2802
2803                surf%rad_sw_out =  albedo_urb * surf%rad_sw_in
2804
2805!
2806!--          Calculate radiation fluxes for each surface element
2807             ELSE
2808!
2809!--             Determine index offset between surface element and adjacent
2810!--             atmospheric grid point
2811                ioff = surf%ioff
2812                joff = surf%joff
2813                koff = surf%koff
2814
2815!
2816!--             Prescribe net radiation and estimate the remaining radiative fluxes
2817                DO  m = 1, surf%ns
2818                   i = surf%i(m)
2819                   j = surf%j(m)
2820                   k = surf%k(m)
2821
2822                   surf%rad_net(m) = net_radiation
2823
2824                   IF ( bulk_cloud_model  .OR.  cloud_droplets )  THEN
2825                      pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i)
2826                      surf%rad_lw_in(m)  = 0.8_wp * sigma_sb * (pt1 * exner(k))**4
2827                   ELSE
2828                      surf%rad_lw_in(m)  = 0.8_wp * sigma_sb *                 &
2829                                             ( pt(k,j,i) * exner(k) )**4
2830                   ENDIF
2831
2832!
2833!--                Weighted average according to surface fraction.
2834                   surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m)  *         &
2835                                          surf%emissivity(ind_veg_wall,m)      &
2836                                        + surf%frac(ind_pav_green,m) *         &
2837                                          surf%emissivity(ind_pav_green,m)     &
2838                                        + surf%frac(ind_wat_win,m)   *         &
2839                                          surf%emissivity(ind_wat_win,m)       &
2840                                        )                                      &
2841                                      * sigma_sb                               &
2842                                      * ( surf%pt_surface(m) * exner(nzb) )**4
2843
2844                   surf%rad_sw_in(m) = ( surf%rad_net(m) - surf%rad_lw_in(m)   &
2845                                       + surf%rad_lw_out(m) )                  &
2846                                       / ( 1.0_wp -                            &
2847                                          ( surf%frac(ind_veg_wall,m)  *       &
2848                                            surf%albedo(ind_veg_wall,m)        &
2849                                         +  surf%frac(ind_pav_green,m) *       &
2850                                            surf%albedo(ind_pav_green,m)       &
2851                                         +  surf%frac(ind_wat_win,m)   *       &
2852                                            surf%albedo(ind_wat_win,m) )       &
2853                                         )
2854
2855                   surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m)  *         &
2856                                          surf%albedo(ind_veg_wall,m)          &
2857                                        + surf%frac(ind_pav_green,m) *         &
2858                                          surf%albedo(ind_pav_green,m)         &
2859                                        + surf%frac(ind_wat_win,m)   *         &
2860                                          surf%albedo(ind_wat_win,m) )         &
2861                                      * surf%rad_sw_in(m)
2862
2863                ENDDO
2864
2865             ENDIF
2866
2867!
2868!--          Fill out values in radiation arrays
2869             DO  m = 1, surf%ns
2870                i = surf%i(m)
2871                j = surf%j(m)
2872                rad_sw_in(0,j,i) = surf%rad_sw_in(m)
2873                rad_sw_out(0,j,i) = surf%rad_sw_out(m)
2874                rad_lw_in(0,j,i) = surf%rad_lw_in(m)
2875                rad_lw_out(0,j,i) = surf%rad_lw_out(m)
2876             ENDDO
2877
2878          END SUBROUTINE radiation_constant_surf
2879         
2880
2881    END SUBROUTINE radiation_constant
2882
2883!------------------------------------------------------------------------------!
2884! Description:
2885! ------------
2886!> Header output for radiation model
2887!------------------------------------------------------------------------------!
2888    SUBROUTINE radiation_header ( io )
2889
2890
2891       IMPLICIT NONE
2892 
2893       INTEGER(iwp), INTENT(IN) ::  io            !< Unit of the output file
2894   
2895
2896       
2897!
2898!--    Write radiation model header
2899       WRITE( io, 3 )
2900
2901       IF ( radiation_scheme == "constant" )  THEN
2902          WRITE( io, 4 ) net_radiation
2903       ELSEIF ( radiation_scheme == "clear-sky" )  THEN
2904          WRITE( io, 5 )
2905       ELSEIF ( radiation_scheme == "rrtmg" )  THEN
2906          WRITE( io, 6 )
2907          IF ( .NOT. lw_radiation )  WRITE( io, 10 )
2908          IF ( .NOT. sw_radiation )  WRITE( io, 11 )
2909       ENDIF
2910
2911       IF ( albedo_type_f%from_file  .OR.  vegetation_type_f%from_file  .OR.   &
2912            pavement_type_f%from_file  .OR.  water_type_f%from_file  .OR.      &
2913            building_type_f%from_file )  THEN
2914             WRITE( io, 13 )
2915       ELSE 
2916          IF ( albedo_type == 0 )  THEN
2917             WRITE( io, 7 ) albedo
2918          ELSE
2919             WRITE( io, 8 ) TRIM( albedo_type_name(albedo_type) )
2920          ENDIF
2921       ENDIF
2922       IF ( constant_albedo )  THEN
2923          WRITE( io, 9 )
2924       ENDIF
2925       
2926       WRITE( io, 12 ) dt_radiation
2927 
2928
2929 3 FORMAT (//' Radiation model information:'/                                  &
2930              ' ----------------------------'/)
2931 4 FORMAT ('    --> Using constant net radiation: net_radiation = ', F6.2,     &
2932           // 'W/m**2')
2933 5 FORMAT ('    --> Simple radiation scheme for clear sky is used (no clouds,',&
2934                   ' default)')
2935 6 FORMAT ('    --> RRTMG scheme is used')
2936 7 FORMAT (/'    User-specific surface albedo: albedo =', F6.3)
2937 8 FORMAT (/'    Albedo is set for land surface type: ', A)
2938 9 FORMAT (/'    --> Albedo is fixed during the run')
293910 FORMAT (/'    --> Longwave radiation is disabled')
294011 FORMAT (/'    --> Shortwave radiation is disabled.')
294112 FORMAT  ('    Timestep: dt_radiation = ', F6.2, '  s')
294213 FORMAT (/'    Albedo is set individually for each xy-location, according ', &
2943                 'to given surface type.')
2944
2945
2946    END SUBROUTINE radiation_header
2947   
2948
2949!------------------------------------------------------------------------------!
2950! Description:
2951! ------------
2952!> Parin for &radiation_parameters for radiation model
2953!------------------------------------------------------------------------------!
2954    SUBROUTINE radiation_parin
2955
2956
2957       IMPLICIT NONE
2958
2959       CHARACTER (LEN=80) ::  line  !< dummy string that contains the current line of the parameter file
2960       
2961       NAMELIST /radiation_par/   albedo, albedo_lw_dif, albedo_lw_dir,         &
2962                                  albedo_sw_dif, albedo_sw_dir, albedo_type,    &
2963                                  constant_albedo, dt_radiation, emissivity,    &
2964                                  lw_radiation, max_raytracing_dist,            &
2965                                  min_irrf_value, mrt_geom_human,               &
2966                                  mrt_include_sw, mrt_nlevels,                  &
2967                                  mrt_skip_roof, net_radiation, nrefsteps,      &
2968                                  plant_lw_interact, rad_angular_discretization,&
2969                                  radiation_interactions_on, radiation_scheme,  &
2970                                  raytrace_discrete_azims,                      &
2971                                  raytrace_discrete_elevs, raytrace_mpi_rma,    &
2972                                  skip_time_do_radiation, surface_reflections,  &
2973                                  svfnorm_report_thresh, sw_radiation,          &
2974                                  unscheduled_radiation_calls
2975
2976   
2977       NAMELIST /radiation_parameters/ albedo, albedo_lw_dif, albedo_lw_dir,    &
2978                                  albedo_sw_dif, albedo_sw_dir, albedo_type,    &
2979                                  constant_albedo, dt_radiation, emissivity,    &
2980                                  lw_radiation, max_raytracing_dist,            &
2981                                  min_irrf_value, mrt_geom_human,               &
2982                                  mrt_include_sw, mrt_nlevels,                  &
2983                                  mrt_skip_roof, net_radiation, nrefsteps,      &
2984                                  plant_lw_interact, rad_angular_discretization,&
2985                                  radiation_interactions_on, radiation_scheme,  &
2986                                  raytrace_discrete_azims,                      &
2987                                  raytrace_discrete_elevs, raytrace_mpi_rma,    &
2988                                  skip_time_do_radiation, surface_reflections,  &
2989                                  svfnorm_report_thresh, sw_radiation,          &
2990                                  unscheduled_radiation_calls
2991   
2992       line = ' '
2993       
2994!
2995!--    Try to find radiation model namelist
2996       REWIND ( 11 )
2997       line = ' '
2998       DO WHILE ( INDEX( line, '&radiation_parameters' ) == 0 )
2999          READ ( 11, '(A)', END=12 )  line
3000       ENDDO
3001       BACKSPACE ( 11 )
3002
3003!
3004!--    Read user-defined namelist
3005       READ ( 11, radiation_parameters, ERR = 10 )
3006
3007!
3008!--    Set flag that indicates that the radiation model is switched on
3009       radiation = .TRUE.
3010
3011       GOTO 14
3012
3013 10    BACKSPACE( 11 )
3014       READ( 11 , '(A)') line
3015       CALL parin_fail_message( 'radiation_parameters', line )
3016!
3017!--    Try to find old namelist
3018 12    REWIND ( 11 )
3019       line = ' '
3020       DO WHILE ( INDEX( line, '&radiation_par' ) == 0 )
3021          READ ( 11, '(A)', END=14 )  line
3022       ENDDO
3023       BACKSPACE ( 11 )
3024
3025!
3026!--    Read user-defined namelist
3027       READ ( 11, radiation_par, ERR = 13, END = 14 )
3028
3029       message_string = 'namelist radiation_par is deprecated and will be ' // &
3030                     'removed in near future. Please use namelist ' //         &
3031                     'radiation_parameters instead'
3032       CALL message( 'radiation_parin', 'PA0487', 0, 1, 0, 6, 0 )
3033
3034!
3035!--    Set flag that indicates that the radiation model is switched on
3036       radiation = .TRUE.
3037
3038       IF ( .NOT.  radiation_interactions_on  .AND.  surface_reflections )  THEN
3039          message_string = 'surface_reflections is allowed only when '      // &
3040               'radiation_interactions_on is set to TRUE'
3041          CALL message( 'radiation_parin', 'PA0293',1, 2, 0, 6, 0 )
3042       ENDIF
3043
3044       GOTO 14
3045
3046 13    BACKSPACE( 11 )
3047       READ( 11 , '(A)') line
3048       CALL parin_fail_message( 'radiation_par', line )
3049
3050 14    CONTINUE
3051       
3052    END SUBROUTINE radiation_parin
3053
3054
3055!------------------------------------------------------------------------------!
3056! Description:
3057! ------------
3058!> Implementation of the RRTMG radiation_scheme
3059!------------------------------------------------------------------------------!
3060    SUBROUTINE radiation_rrtmg
3061
3062#if defined ( __rrtmg )
3063       USE indices,                                                            &
3064           ONLY:  nbgp
3065
3066       USE particle_attributes,                                                &
3067           ONLY:  grid_particles, number_of_particles, particles,              &
3068                  particle_advection_start, prt_count
3069
3070       IMPLICIT NONE
3071
3072
3073       INTEGER(iwp) ::  i, j, k, l, m, n !< loop indices
3074       INTEGER(iwp) ::  k_topo     !< topography top index
3075
3076       REAL(wp)     ::  nc_rad, &    !< number concentration of cloud droplets
3077                        s_r2,   &    !< weighted sum over all droplets with r^2
3078                        s_r3         !< weighted sum over all droplets with r^3
3079
3080       REAL(wp), DIMENSION(0:nzt+1) :: pt_av, q_av, ql_av
3081!
3082!--    Just dummy arguments
3083       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rrtm_lw_taucld_dum,          &
3084                                                  rrtm_lw_tauaer_dum,          &
3085                                                  rrtm_sw_taucld_dum,          &
3086                                                  rrtm_sw_ssacld_dum,          &
3087                                                  rrtm_sw_asmcld_dum,          &
3088                                                  rrtm_sw_fsfcld_dum,          &
3089                                                  rrtm_sw_tauaer_dum,          &
3090                                                  rrtm_sw_ssaaer_dum,          &
3091                                                  rrtm_sw_asmaer_dum,          &
3092                                                  rrtm_sw_ecaer_dum
3093
3094!
3095!--    Calculate current (cosine of) zenith angle and whether the sun is up
3096       CALL calc_zenith     
3097!
3098!--    Calculate surface albedo. In case average radiation is applied,
3099!--    this is not required.
3100#if defined( __netcdf )
3101       IF ( .NOT. constant_albedo )  THEN
3102!
3103!--       Horizontally aligned default, natural and urban surfaces
3104          CALL calc_albedo( surf_lsm_h    )
3105          CALL calc_albedo( surf_usm_h    )
3106!
3107!--       Vertically aligned default, natural and urban surfaces
3108          DO  l = 0, 3
3109             CALL calc_albedo( surf_lsm_v(l) )
3110             CALL calc_albedo( surf_usm_v(l) )
3111          ENDDO
3112       ENDIF
3113#endif
3114
3115!
3116!--    Prepare input data for RRTMG
3117
3118!
3119!--    In case of large scale forcing with surface data, calculate new pressure
3120!--    profile. nzt_rad might be modified by these calls and all required arrays
3121!--    will then be re-allocated
3122       IF ( large_scale_forcing  .AND.  lsf_surf )  THEN
3123          CALL read_sounding_data
3124          CALL read_trace_gas_data
3125       ENDIF
3126
3127
3128       IF ( average_radiation ) THEN
3129
3130          rrtm_asdir(1)  = albedo_urb
3131          rrtm_asdif(1)  = albedo_urb
3132          rrtm_aldir(1)  = albedo_urb
3133          rrtm_aldif(1)  = albedo_urb
3134
3135          rrtm_emis = emissivity_urb
3136!
3137!--       Calculate mean pt profile. Actually, only one height level is required.
3138          CALL calc_mean_profile( pt, 4 )
3139          pt_av = hom(:, 1, 4, 0)
3140         
3141          IF ( humidity )  THEN
3142             CALL calc_mean_profile( q, 41 )
3143             q_av  = hom(:, 1, 41, 0)
3144          ENDIF
3145!
3146!--       Prepare profiles of temperature and H2O volume mixing ratio
3147          rrtm_tlev(0,nzb+1) = t_rad_urb
3148
3149          IF ( bulk_cloud_model )  THEN
3150
3151             CALL calc_mean_profile( ql, 54 )
3152             ! average ql is now in hom(:, 1, 54, 0)
3153             ql_av = hom(:, 1, 54, 0)
3154             
3155             DO k = nzb+1, nzt+1
3156                rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp       &
3157                                 )**.286_wp + lv_d_cp * ql_av(k)
3158                rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q_av(k) - ql_av(k))
3159             ENDDO
3160          ELSE
3161             DO k = nzb+1, nzt+1
3162                rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp       &
3163                                 )**.286_wp
3164             ENDDO
3165
3166             IF ( humidity )  THEN
3167                DO k = nzb+1, nzt+1
3168                   rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q_av(k)
3169                ENDDO
3170             ELSE
3171                rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp
3172             ENDIF
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 ( bulk_cloud_model )  THEN
3209             DO k = nzb+1, nzt+1
3210                rrtm_cliqwp(0,k) =  ql_av(k) * 1000._wp *                   &
3211                                    (rrtm_plev(0,k) - rrtm_plev(0,k+1))     &
3212                                    * 100._wp / g 
3213
3214                IF ( rrtm_cliqwp(0,k) > 0._wp )  THEN
3215                   rrtm_cldfr(0,k) = 1._wp
3216                   IF ( rrtm_icld == 0 )  rrtm_icld = 1
3217
3218!
3219!--                Calculate cloud droplet effective radius
3220                   rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql_av(k)         &
3221                                     * rho_surface                          &
3222                                     / ( 4.0_wp * pi * nc_const * rho_l )   &
3223                                     )**0.33333333333333_wp                 &
3224                                     * EXP( LOG( sigma_gc )**2 )
3225!
3226!--                Limit effective radius
3227                   IF ( rrtm_reliq(0,k) > 0.0_wp )  THEN
3228                      rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp)
3229                      rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp)
3230                   ENDIF
3231                ENDIF
3232             ENDDO
3233          ENDIF
3234
3235!
3236!--       Set surface temperature
3237          rrtm_tsfc = t_rad_urb
3238         
3239          IF ( lw_radiation )  THEN       
3240         
3241             CALL rrtmg_lw( 1, nzt_rad      , rrtm_icld    , rrtm_idrv      ,&
3242             rrtm_play       , rrtm_plev    , rrtm_tlay    , rrtm_tlev      ,&
3243             rrtm_tsfc       , rrtm_h2ovmr  , rrtm_o3vmr   , rrtm_co2vmr    ,&
3244             rrtm_ch4vmr     , rrtm_n2ovmr  , rrtm_o2vmr   , rrtm_cfc11vmr  ,&
3245             rrtm_cfc12vmr   , rrtm_cfc22vmr, rrtm_ccl4vmr , rrtm_emis      ,&
3246             rrtm_inflglw    , rrtm_iceflglw, rrtm_liqflglw, rrtm_cldfr     ,&
3247             rrtm_lw_taucld  , rrtm_cicewp  , rrtm_cliqwp  , rrtm_reice     ,& 
3248             rrtm_reliq      , rrtm_lw_tauaer,                               &
3249             rrtm_lwuflx     , rrtm_lwdflx  , rrtm_lwhr  ,                   &
3250             rrtm_lwuflxc    , rrtm_lwdflxc , rrtm_lwhrc ,                   &
3251             rrtm_lwuflx_dt  ,  rrtm_lwuflxc_dt )
3252
3253!
3254!--          Save fluxes
3255             DO k = nzb, nzt+1
3256                rad_lw_in(k,:,:)  = rrtm_lwdflx(0,k)
3257                rad_lw_out(k,:,:) = rrtm_lwuflx(0,k)
3258             ENDDO
3259             rad_lw_in_diff(:,:) = rad_lw_in(0,:,:)
3260!
3261!--          Save heating rates (convert from K/d to K/h).
3262!--          Further, even though an aggregated radiation is computed, map
3263!--          signle-column profiles on top of any topography, in order to
3264!--          obtain correct near surface radiation heating/cooling rates.
3265             DO  i = nxl, nxr
3266                DO  j = nys, nyn
3267                   k_topo = get_topography_top_index_ji( j, i, 's' )
3268                   DO k = k_topo+1, nzt+1
3269                      rad_lw_hr(k,j,i)     = rrtm_lwhr(0,k-k_topo)  * d_hours_day
3270                      rad_lw_cs_hr(k,j,i)  = rrtm_lwhrc(0,k-k_topo) * d_hours_day
3271                   ENDDO
3272                ENDDO
3273             ENDDO
3274
3275          ENDIF
3276
3277          IF ( sw_radiation .AND. sun_up )  THEN
3278             CALL rrtmg_sw( 1, nzt_rad      , rrtm_icld     , rrtm_iaer      ,&
3279             rrtm_play      , rrtm_plev     , rrtm_tlay     , rrtm_tlev      ,&
3280             rrtm_tsfc      , rrtm_h2ovmr   , rrtm_o3vmr    , rrtm_co2vmr    ,&
3281             rrtm_ch4vmr    , rrtm_n2ovmr   , rrtm_o2vmr    , rrtm_asdir     ,&
3282             rrtm_asdif     , rrtm_aldir    , rrtm_aldif    , zenith         ,&
3283             0.0_wp         , day_of_year   , solar_constant, rrtm_inflgsw   ,&
3284             rrtm_iceflgsw  , rrtm_liqflgsw , rrtm_cldfr    , rrtm_sw_taucld ,&
3285             rrtm_sw_ssacld , rrtm_sw_asmcld, rrtm_sw_fsfcld, rrtm_cicewp    ,&
3286             rrtm_cliqwp    , rrtm_reice    , rrtm_reliq    , rrtm_sw_tauaer ,&
3287             rrtm_sw_ssaaer , rrtm_sw_asmaer, rrtm_sw_ecaer , rrtm_swuflx    ,&
3288             rrtm_swdflx    , rrtm_swhr     , rrtm_swuflxc  , rrtm_swdflxc   ,&
3289             rrtm_swhrc     , rrtm_dirdflux , rrtm_difdflux )
3290 
3291!
3292!--          Save fluxes:
3293!--          - whole domain
3294             DO k = nzb, nzt+1
3295                rad_sw_in(k,:,:)  = rrtm_swdflx(0,k)
3296                rad_sw_out(k,:,:) = rrtm_swuflx(0,k)
3297             ENDDO
3298!--          - direct and diffuse SW at urban-surface-layer (required by RTM)
3299             rad_sw_in_dir(:,:) = rrtm_dirdflux(0,nzb)
3300             rad_sw_in_diff(:,:) = rrtm_difdflux(0,nzb)
3301
3302!
3303!--          Save heating rates (convert from K/d to K/s)
3304             DO k = nzb+1, nzt+1
3305                rad_sw_hr(k,:,:)     = rrtm_swhr(0,k)  * d_hours_day
3306                rad_sw_cs_hr(k,:,:)  = rrtm_swhrc(0,k) * d_hours_day
3307             ENDDO
3308!
3309!--       Solar radiation is zero during night
3310          ELSE
3311             rad_sw_in  = 0.0_wp
3312             rad_sw_out = 0.0_wp
3313             rad_sw_in_dir(:,:) = 0.0_wp
3314             rad_sw_in_diff(:,:) = 0.0_wp
3315          ENDIF
3316!
3317!--    RRTMG is called for each (j,i) grid point separately, starting at the
3318!--    highest topography level. Here no RTM is used since average_radiation is false
3319       ELSE
3320!
3321!--       Loop over all grid points
3322          DO i = nxl, nxr
3323             DO j = nys, nyn
3324
3325!
3326!--             Prepare profiles of temperature and H2O volume mixing ratio
3327                DO  m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
3328                   rrtm_tlev(0,nzb+1) = surf_lsm_h%pt_surface(m) * exner(nzb)
3329                ENDDO
3330                DO  m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
3331                   rrtm_tlev(0,nzb+1) = surf_usm_h%pt_surface(m) * exner(nzb)
3332                ENDDO
3333
3334
3335                IF ( bulk_cloud_model )  THEN
3336                   DO k = nzb+1, nzt+1
3337                      rrtm_tlay(0,k) = pt(k,j,i) * exner(k)                    &
3338                                        + lv_d_cp * ql(k,j,i)
3339                      rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q(k,j,i) - ql(k,j,i))
3340                   ENDDO
3341                ELSEIF ( cloud_droplets )  THEN
3342                   DO k = nzb+1, nzt+1
3343                      rrtm_tlay(0,k) = pt(k,j,i) * exner(k)                     &
3344                                        + lv_d_cp * ql(k,j,i)
3345                      rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i) 
3346                   ENDDO
3347                ELSE
3348                   DO k = nzb+1, nzt+1
3349                      rrtm_tlay(0,k) = pt(k,j,i) * exner(k)
3350                   ENDDO
3351
3352                   IF ( humidity )  THEN
3353                      DO k = nzb+1, nzt+1
3354                         rrtm_h2ovmr(0,k) =  mol_mass_air_d_wv * q(k,j,i)
3355                      ENDDO   
3356                   ELSE
3357                      rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp
3358                   ENDIF
3359                ENDIF
3360
3361!
3362!--             Avoid temperature/humidity jumps at the top of the LES domain by
3363!--             linear interpolation from nzt+2 to nzt+7
3364                DO k = nzt+2, nzt+7
3365                   rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1)                         &
3366                                 + ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) &
3367                                 / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) &
3368                                 * ( rrtm_play(0,k)     - rrtm_play(0,nzt+1) )
3369
3370                   rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1)                     &
3371                              + ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )&
3372                              / ( rrtm_play(0,nzt+8)   - rrtm_play(0,nzt+1)   )&
3373                              * ( rrtm_play(0,k)       - rrtm_play(0,nzt+1) )
3374
3375                ENDDO
3376
3377!--             Linear interpolate to zw grid
3378                DO k = nzb+2, nzt+8
3379                   rrtm_tlev(0,k)   = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) -     &
3380                                      rrtm_tlay(0,k-1))                        &
3381                                      / ( rrtm_play(0,k) - rrtm_play(0,k-1) )  &
3382                                      * ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
3383                ENDDO
3384
3385
3386!
3387!--             Calculate liquid water path and cloud fraction for each column.
3388!--             Note that LWP is required in g/m² instead of kg/kg m.
3389                rrtm_cldfr  = 0.0_wp
3390                rrtm_reliq  = 0.0_wp
3391                rrtm_cliqwp = 0.0_wp
3392                rrtm_icld   = 0
3393
3394                IF ( bulk_cloud_model  .OR.  cloud_droplets )  THEN
3395                   DO k = nzb+1, nzt+1
3396                      rrtm_cliqwp(0,k) =  ql(k,j,i) * 1000.0_wp *              &
3397                                          (rrtm_plev(0,k) - rrtm_plev(0,k+1))  &
3398                                          * 100.0_wp / g 
3399
3400                      IF ( rrtm_cliqwp(0,k) > 0.0_wp )  THEN
3401                         rrtm_cldfr(0,k) = 1.0_wp
3402                         IF ( rrtm_icld == 0 )  rrtm_icld = 1
3403
3404!
3405!--                      Calculate cloud droplet effective radius
3406                         IF ( bulk_cloud_model )  THEN
3407!
3408!--                         Calculete effective droplet radius. In case of using
3409!--                         cloud_scheme = 'morrison' and a non reasonable number
3410!--                         of cloud droplets the inital aerosol number 
3411!--                         concentration is considered.
3412                            IF ( microphysics_morrison )  THEN
3413                               IF ( nc(k,j,i) > 1.0E-20_wp )  THEN
3414                                  nc_rad = nc(k,j,i)
3415                               ELSE
3416                                  nc_rad = na_init
3417                               ENDIF
3418                            ELSE
3419                               nc_rad = nc_const
3420                            ENDIF 
3421
3422                            rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql(k,j,i)     &
3423                                              * rho_surface                       &
3424                                              / ( 4.0_wp * pi * nc_rad * rho_l )  &
3425                                              )**0.33333333333333_wp              &
3426                                              * EXP( LOG( sigma_gc )**2 )
3427
3428                         ELSEIF ( cloud_droplets )  THEN
3429                            number_of_particles = prt_count(k,j,i)
3430
3431                            IF (number_of_particles <= 0)  CYCLE
3432                            particles => grid_particles(k,j,i)%particles(1:number_of_particles)
3433                            s_r2 = 0.0_wp
3434                            s_r3 = 0.0_wp
3435
3436                            DO  n = 1, number_of_particles
3437                               IF ( particles(n)%particle_mask )  THEN
3438                                  s_r2 = s_r2 + particles(n)%radius**2 *       &
3439                                         particles(n)%weight_factor
3440                                  s_r3 = s_r3 + particles(n)%radius**3 *       &
3441                                         particles(n)%weight_factor
3442                               ENDIF
3443                            ENDDO
3444
3445                            IF ( s_r2 > 0.0_wp )  rrtm_reliq(0,k) = s_r3 / s_r2
3446
3447                         ENDIF
3448
3449!
3450!--                      Limit effective radius
3451                         IF ( rrtm_reliq(0,k) > 0.0_wp )  THEN
3452                            rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp)
3453                            rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp)
3454                        ENDIF
3455                      ENDIF
3456                   ENDDO
3457                ENDIF
3458
3459!
3460!--             Write surface emissivity and surface temperature at current
3461!--             surface element on RRTMG-shaped array.
3462!--             Please note, as RRTMG is a single column model, surface attributes
3463!--             are only obtained from horizontally aligned surfaces (for
3464!--             simplicity). Taking surface attributes from horizontal and
3465!--             vertical walls would lead to multiple solutions. 
3466!--             Moreover, for natural- and urban-type surfaces, several surface
3467!--             classes can exist at a surface element next to each other.
3468!--             To obtain bulk parameters, apply a weighted average for these
3469!--             surfaces.
3470                DO  m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
3471                   rrtm_emis = surf_lsm_h%frac(ind_veg_wall,m)  *              &
3472                               surf_lsm_h%emissivity(ind_veg_wall,m)  +        &
3473                               surf_lsm_h%frac(ind_pav_green,m) *              &
3474                               surf_lsm_h%emissivity(ind_pav_green,m) +        & 
3475                               surf_lsm_h%frac(ind_wat_win,m)   *              &
3476                               surf_lsm_h%emissivity(ind_wat_win,m)
3477                   rrtm_tsfc = surf_lsm_h%pt_surface(m) * exner(nzb)
3478                ENDDO             
3479                DO  m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
3480                   rrtm_emis = surf_usm_h%frac(ind_veg_wall,m)  *              &
3481                               surf_usm_h%emissivity(ind_veg_wall,m)  +        &
3482                               surf_usm_h%frac(ind_pav_green,m) *              &
3483                               surf_usm_h%emissivity(ind_pav_green,m) +        & 
3484                               surf_usm_h%frac(ind_wat_win,m)   *              &
3485                               surf_usm_h%emissivity(ind_wat_win,m)
3486                   rrtm_tsfc = surf_usm_h%pt_surface(m) * exner(nzb)
3487                ENDDO
3488!
3489!--             Obtain topography top index (lower bound of RRTMG)
3490                k_topo = get_topography_top_index_ji( j, i, 's' )
3491
3492                IF ( lw_radiation )  THEN
3493!
3494!--                Due to technical reasons, copy optical depth to dummy arguments
3495!--                which are allocated on the exact size as the rrtmg_lw is called.
3496!--                As one dimesion is allocated with zero size, compiler complains
3497!--                that rank of the array does not match that of the
3498!--                assumed-shaped arguments in the RRTMG library. In order to
3499!--                avoid this, write to dummy arguments and give pass the entire
3500!--                dummy array. Seems to be the only existing work-around. 
3501                   ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) )
3502                   ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) )
3503
3504                   rrtm_lw_taucld_dum =                                        &
3505                               rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1)
3506                   rrtm_lw_tauaer_dum =                                        &
3507                               rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1)
3508
3509                   CALL rrtmg_lw( 1,                                           &                                       
3510                                  nzt_rad-k_topo,                              &
3511                                  rrtm_icld,                                   &
3512                                  rrtm_idrv,                                   &
3513                                  rrtm_play(:,k_topo+1:nzt_rad+1),             &
3514                                  rrtm_plev(:,k_topo+1:nzt_rad+2),             &
3515                                  rrtm_tlay(:,k_topo+1:nzt_rad+1),             &
3516                                  rrtm_tlev(:,k_topo+1:nzt_rad+2),             &
3517                                  rrtm_tsfc,                                   &
3518                                  rrtm_h2ovmr(:,k_topo+1:nzt_rad+1),           &
3519                                  rrtm_o3vmr(:,k_topo+1:nzt_rad+1),            &
3520                                  rrtm_co2vmr(:,k_topo+1:nzt_rad+1),           &
3521                                  rrtm_ch4vmr(:,k_topo+1:nzt_rad+1),           &
3522                                  rrtm_n2ovmr(:,k_topo+1:nzt_rad+1),           &
3523                                  rrtm_o2vmr(:,k_topo+1:nzt_rad+1),            &
3524                                  rrtm_cfc11vmr(:,k_topo+1:nzt_rad+1),         &
3525                                  rrtm_cfc12vmr(:,k_topo+1:nzt_rad+1),         &
3526                                  rrtm_cfc22vmr(:,k_topo+1:nzt_rad+1),         &
3527                                  rrtm_ccl4vmr(:,k_topo+1:nzt_rad+1),          &
3528                                  rrtm_emis,                                   &
3529                                  rrtm_inflglw,                                &
3530                                  rrtm_iceflglw,                               &
3531                                  rrtm_liqflglw,                               &
3532                                  rrtm_cldfr(:,k_topo+1:nzt_rad+1),            &
3533                                  rrtm_lw_taucld_dum,                          &
3534                                  rrtm_cicewp(:,k_topo+1:nzt_rad+1),           &
3535                                  rrtm_cliqwp(:,k_topo+1:nzt_rad+1),           &
3536                                  rrtm_reice(:,k_topo+1:nzt_rad+1),            & 
3537                                  rrtm_reliq(:,k_topo+1:nzt_rad+1),            &
3538                                  rrtm_lw_tauaer_dum,                          &
3539                                  rrtm_lwuflx(:,k_topo:nzt_rad+1),             &
3540                                  rrtm_lwdflx(:,k_topo:nzt_rad+1),             &
3541                                  rrtm_lwhr(:,k_topo+1:nzt_rad+1),             &
3542                                  rrtm_lwuflxc(:,k_topo:nzt_rad+1),            &
3543                                  rrtm_lwdflxc(:,k_topo:nzt_rad+1),            &
3544                                  rrtm_lwhrc(:,k_topo+1:nzt_rad+1),            &
3545                                  rrtm_lwuflx_dt(:,k_topo:nzt_rad+1),          &
3546                                  rrtm_lwuflxc_dt(:,k_topo:nzt_rad+1) )
3547
3548                   DEALLOCATE ( rrtm_lw_taucld_dum )
3549                   DEALLOCATE ( rrtm_lw_tauaer_dum )
3550!
3551!--                Save fluxes
3552                   DO k = k_topo, nzt+1
3553                      rad_lw_in(k,j,i)  = rrtm_lwdflx(0,k)
3554                      rad_lw_out(k,j,i) = rrtm_lwuflx(0,k)
3555                   ENDDO
3556
3557!
3558!--                Save heating rates (convert from K/d to K/h)
3559                   DO k = k_topo+1, nzt+1
3560                      rad_lw_hr(k,j,i)     = rrtm_lwhr(0,k-k_topo)  * d_hours_day
3561                      rad_lw_cs_hr(k,j,i)  = rrtm_lwhrc(0,k-k_topo) * d_hours_day
3562                   ENDDO
3563
3564!
3565!--                Save surface radiative fluxes and change in LW heating rate
3566!--                onto respective surface elements
3567!--                Horizontal surfaces
3568                   DO  m = surf_lsm_h%start_index(j,i),                        &
3569                           surf_lsm_h%end_index(j,i)
3570                      surf_lsm_h%rad_lw_in(m)           = rrtm_lwdflx(0,k_topo)
3571                      surf_lsm_h%rad_lw_out(m)          = rrtm_lwuflx(0,k_topo)
3572                      surf_lsm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(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_lw_in(m)           = rrtm_lwdflx(0,k_topo)
3577                      surf_usm_h%rad_lw_out(m)          = rrtm_lwuflx(0,k_topo)
3578                      surf_usm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo)
3579                   ENDDO 
3580!
3581!--                Vertical surfaces. Fluxes are obtain at vertical level of the
3582!--                respective surface element
3583                   DO  l = 0, 3
3584                      DO  m = surf_lsm_v(l)%start_index(j,i),                  &
3585                              surf_lsm_v(l)%end_index(j,i)
3586                         k                                    = surf_lsm_v(l)%k(m)
3587                         surf_lsm_v(l)%rad_lw_in(m)           = rrtm_lwdflx(0,k)
3588                         surf_lsm_v(l)%rad_lw_out(m)          = rrtm_lwuflx(0,k)
3589                         surf_lsm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
3590                      ENDDO             
3591                      DO  m = surf_usm_v(l)%start_index(j,i),                  &
3592                              surf_usm_v(l)%end_index(j,i)
3593                         k                                    = surf_usm_v(l)%k(m)
3594                         surf_usm_v(l)%rad_lw_in(m)           = rrtm_lwdflx(0,k)
3595                         surf_usm_v(l)%rad_lw_out(m)          = rrtm_lwuflx(0,k)
3596                         surf_usm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
3597                      ENDDO 
3598                   ENDDO
3599
3600                ENDIF
3601
3602                IF ( sw_radiation .AND. sun_up )  THEN
3603!
3604!--                Get albedo for direct/diffusive long/shortwave radiation at
3605!--                current (y,x)-location from surface variables.
3606!--                Only obtain it from horizontal surfaces, as RRTMG is a single
3607!--                column model
3608!--                (Please note, only one loop will entered, controlled by
3609!--                start-end index.)
3610                   DO  m = surf_lsm_h%start_index(j,i),                        &
3611                           surf_lsm_h%end_index(j,i)
3612                      rrtm_asdir(1)  = SUM( surf_lsm_h%frac(:,m) *             &
3613                                            surf_lsm_h%rrtm_asdir(:,m) )
3614                      rrtm_asdif(1)  = SUM( surf_lsm_h%frac(:,m) *             &
3615                                            surf_lsm_h%rrtm_asdif(:,m) )
3616                      rrtm_aldir(1)  = SUM( surf_lsm_h%frac(:,m) *             &
3617                                            surf_lsm_h%rrtm_aldir(:,m) )
3618                      rrtm_aldif(1)  = SUM( surf_lsm_h%frac(:,m) *             &
3619                                            surf_lsm_h%rrtm_aldif(:,m) )
3620                   ENDDO             
3621                   DO  m = surf_usm_h%start_index(j,i),                        &
3622                           surf_usm_h%end_index(j,i)
3623                      rrtm_asdir(1)  = SUM( surf_usm_h%frac(:,m) *             &
3624                                            surf_usm_h%rrtm_asdir(:,m) )
3625                      rrtm_asdif(1)  = SUM( surf_usm_h%frac(:,m) *             &
3626                                            surf_usm_h%rrtm_asdif(:,m) )
3627                      rrtm_aldir(1)  = SUM( surf_usm_h%frac(:,m) *             &
3628                                            surf_usm_h%rrtm_aldir(:,m) )
3629                      rrtm_aldif(1)  = SUM( surf_usm_h%frac(:,m) *             &
3630                                            surf_usm_h%rrtm_aldif(:,m) )
3631                   ENDDO
3632!
3633!--                Due to technical reasons, copy optical depths and other
3634!--                to dummy arguments which are allocated on the exact size as the
3635!--                rrtmg_sw is called.
3636!--                As one dimesion is allocated with zero size, compiler complains
3637!--                that rank of the array does not match that of the
3638!--                assumed-shaped arguments in the RRTMG library. In order to
3639!--                avoid this, write to dummy arguments and give pass the entire
3640!--                dummy array. Seems to be the only existing work-around. 
3641                   ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3642                   ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3643                   ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3644                   ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
3645                   ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
3646                   ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
3647                   ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
3648                   ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1)  )
3649     
3650                   rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3651                   rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3652                   rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3653                   rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
3654                   rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
3655                   rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
3656                   rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
3657                   rrtm_sw_ecaer_dum  = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1)
3658
3659                   CALL rrtmg_sw( 1,                                           &
3660                                  nzt_rad-k_topo,                              &
3661                                  rrtm_icld,                                   &
3662                                  rrtm_iaer,                                   &
3663                                  rrtm_play(:,k_topo+1:nzt_rad+1),             &
3664                                  rrtm_plev(:,k_topo+1:nzt_rad+2),             &
3665                                  rrtm_tlay(:,k_topo+1:nzt_rad+1),             &
3666                                  rrtm_tlev(:,k_topo+1:nzt_rad+2),             &
3667                                  rrtm_tsfc,                                   &
3668                                  rrtm_h2ovmr(:,k_topo+1:nzt_rad+1),           &                               
3669                                  rrtm_o3vmr(:,k_topo+1:nzt_rad+1),            &       
3670                                  rrtm_co2vmr(:,k_topo+1:nzt_rad+1),           &
3671                                  rrtm_ch4vmr(:,k_topo+1:nzt_rad+1),           &
3672                                  rrtm_n2ovmr(:,k_topo+1:nzt_rad+1),           &
3673                                  rrtm_o2vmr(:,k_topo+1:nzt_rad+1),            &
3674                                  rrtm_asdir,                                  & 
3675                                  rrtm_asdif,                                  &
3676                                  rrtm_aldir,                                  &
3677                                  rrtm_aldif,                                  &
3678                                  zenith,                                      &
3679                                  0.0_wp,                                      &
3680                                  day_of_year,                                 &
3681                                  solar_constant,                              &
3682                                  rrtm_inflgsw,                                &
3683                                  rrtm_iceflgsw,                               &
3684                                  rrtm_liqflgsw,                               &
3685                                  rrtm_cldfr(:,k_topo+1:nzt_rad+1),            &
3686                                  rrtm_sw_taucld_dum,                          &
3687                                  rrtm_sw_ssacld_dum,                          &
3688                                  rrtm_sw_asmcld_dum,                          &
3689                                  rrtm_sw_fsfcld_dum,                          &
3690                                  rrtm_cicewp(:,k_topo+1:nzt_rad+1),           &
3691                                  rrtm_cliqwp(:,k_topo+1:nzt_rad+1),           &
3692                                  rrtm_reice(:,k_topo+1:nzt_rad+1),            &
3693                                  rrtm_reliq(:,k_topo+1:nzt_rad+1),            &
3694                                  rrtm_sw_tauaer_dum,                          &
3695                                  rrtm_sw_ssaaer_dum,                          &
3696                                  rrtm_sw_asmaer_dum,                          &
3697                                  rrtm_sw_ecaer_dum,                           &
3698                                  rrtm_swuflx(:,k_topo:nzt_rad+1),             & 
3699                                  rrtm_swdflx(:,k_topo:nzt_rad+1),             & 
3700                                  rrtm_swhr(:,k_topo+1:nzt_rad+1),             & 
3701                                  rrtm_swuflxc(:,k_topo:nzt_rad+1),            & 
3702                                  rrtm_swdflxc(:,k_topo:nzt_rad+1),            &
3703                                  rrtm_swhrc(:,k_topo+1:nzt_rad+1),            &
3704                                  rrtm_dirdflux(:,k_topo:nzt_rad+1),           &
3705                                  rrtm_difdflux(:,k_topo:nzt_rad+1) )
3706
3707                   DEALLOCATE( rrtm_sw_taucld_dum )
3708                   DEALLOCATE( rrtm_sw_ssacld_dum )
3709                   DEALLOCATE( rrtm_sw_asmcld_dum )
3710                   DEALLOCATE( rrtm_sw_fsfcld_dum )
3711                   DEALLOCATE( rrtm_sw_tauaer_dum )
3712                   DEALLOCATE( rrtm_sw_ssaaer_dum )
3713                   DEALLOCATE( rrtm_sw_asmaer_dum )
3714                   DEALLOCATE( rrtm_sw_ecaer_dum )
3715!
3716!--                Save fluxes
3717                   DO k = nzb, nzt+1
3718                      rad_sw_in(k,j,i)  = rrtm_swdflx(0,k)
3719                      rad_sw_out(k,j,i) = rrtm_swuflx(0,k)
3720                   ENDDO
3721!
3722!--                Save heating rates (convert from K/d to K/s)
3723                   DO k = nzb+1, nzt+1
3724                      rad_sw_hr(k,j,i)     = rrtm_swhr(0,k)  * d_hours_day
3725                      rad_sw_cs_hr(k,j,i)  = rrtm_swhrc(0,k) * d_hours_day
3726                   ENDDO
3727
3728!
3729!--                Save surface radiative fluxes onto respective surface elements
3730!--                Horizontal surfaces
3731                   DO  m = surf_lsm_h%start_index(j,i),                        &
3732                           surf_lsm_h%end_index(j,i)
3733                      surf_lsm_h%rad_sw_in(m)     = rrtm_swdflx(0,k_topo)
3734                      surf_lsm_h%rad_sw_out(m)    = rrtm_swuflx(0,k_topo)
3735                   ENDDO             
3736                   DO  m = surf_usm_h%start_index(j,i),                        &
3737                           surf_usm_h%end_index(j,i)
3738                      surf_usm_h%rad_sw_in(m)     = rrtm_swdflx(0,k_topo)
3739                      surf_usm_h%rad_sw_out(m)    = rrtm_swuflx(0,k_topo)
3740                   ENDDO 
3741!
3742!--                Vertical surfaces. Fluxes are obtain at respective vertical
3743!--                level of the surface element
3744                   DO  l = 0, 3
3745                      DO  m = surf_lsm_v(l)%start_index(j,i),                  &
3746                              surf_lsm_v(l)%end_index(j,i)
3747                         k                           = surf_lsm_v(l)%k(m)
3748                         surf_lsm_v(l)%rad_sw_in(m)  = rrtm_swdflx(0,k)
3749                         surf_lsm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
3750                      ENDDO             
3751                      DO  m = surf_usm_v(l)%start_index(j,i),                  &
3752                              surf_usm_v(l)%end_index(j,i)
3753                         k                           = surf_usm_v(l)%k(m)
3754                         surf_usm_v(l)%rad_sw_in(m)  = rrtm_swdflx(0,k)
3755                         surf_usm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
3756                      ENDDO 
3757                   ENDDO
3758!
3759!--             Solar radiation is zero during night
3760                ELSE
3761                   rad_sw_in  = 0.0_wp
3762                   rad_sw_out = 0.0_wp
3763!--             !!!!!!!! ATTENSION !!!!!!!!!!!!!!!
3764!--             Surface radiative fluxes should be also set to zero here                 
3765!--                Save surface radiative fluxes onto respective surface elements
3766!--                Horizontal surfaces
3767                   DO  m = surf_lsm_h%start_index(j,i),                        &
3768                           surf_lsm_h%end_index(j,i)
3769                      surf_lsm_h%rad_sw_in(m)     = 0.0_wp
3770                      surf_lsm_h%rad_sw_out(m)    = 0.0_wp
3771                   ENDDO             
3772                   DO  m = surf_usm_h%start_index(j,i),                        &
3773                           surf_usm_h%end_index(j,i)
3774                      surf_usm_h%rad_sw_in(m)     = 0.0_wp
3775                      surf_usm_h%rad_sw_out(m)    = 0.0_wp
3776                   ENDDO 
3777!
3778!--                Vertical surfaces. Fluxes are obtain at respective vertical
3779!--                level of the surface element
3780                   DO  l = 0, 3
3781                      DO  m = surf_lsm_v(l)%start_index(j,i),                  &
3782                              surf_lsm_v(l)%end_index(j,i)
3783                         k                           = surf_lsm_v(l)%k(m)
3784                         surf_lsm_v(l)%rad_sw_in(m)  = 0.0_wp
3785                         surf_lsm_v(l)%rad_sw_out(m) = 0.0_wp
3786                      ENDDO             
3787                      DO  m = surf_usm_v(l)%start_index(j,i),                  &
3788                              surf_usm_v(l)%end_index(j,i)
3789                         k                           = surf_usm_v(l)%k(m)
3790                         surf_usm_v(l)%rad_sw_in(m)  = 0.0_wp
3791                         surf_usm_v(l)%rad_sw_out(m) = 0.0_wp
3792                      ENDDO 
3793                   ENDDO
3794                ENDIF
3795
3796             ENDDO
3797          ENDDO
3798
3799       ENDIF
3800!
3801!--    Finally, calculate surface net radiation for surface elements.
3802       IF (  .NOT.  radiation_interactions  ) THEN
3803!--       First, for horizontal surfaces   
3804          DO  m = 1, surf_lsm_h%ns
3805             surf_lsm_h%rad_net(m) = surf_lsm_h%rad_sw_in(m)                   &
3806                                   - surf_lsm_h%rad_sw_out(m)                  &
3807                                   + surf_lsm_h%rad_lw_in(m)                   &
3808                                   - surf_lsm_h%rad_lw_out(m)
3809          ENDDO
3810          DO  m = 1, surf_usm_h%ns
3811             surf_usm_h%rad_net(m) = surf_usm_h%rad_sw_in(m)                   &
3812                                   - surf_usm_h%rad_sw_out(m)                  &
3813                                   + surf_usm_h%rad_lw_in(m)                   &
3814                                   - surf_usm_h%rad_lw_out(m)
3815          ENDDO
3816!
3817!--       Vertical surfaces.
3818!--       Todo: weight with azimuth and zenith angle according to their orientation!
3819          DO  l = 0, 3     
3820             DO  m = 1, surf_lsm_v(l)%ns
3821                surf_lsm_v(l)%rad_net(m) = surf_lsm_v(l)%rad_sw_in(m)          &
3822                                         - surf_lsm_v(l)%rad_sw_out(m)         &
3823                                         + surf_lsm_v(l)%rad_lw_in(m)          &
3824                                         - surf_lsm_v(l)%rad_lw_out(m)
3825             ENDDO
3826             DO  m = 1, surf_usm_v(l)%ns
3827                surf_usm_v(l)%rad_net(m) = surf_usm_v(l)%rad_sw_in(m)          &
3828                                         - surf_usm_v(l)%rad_sw_out(m)         &
3829                                         + surf_usm_v(l)%rad_lw_in(m)          &
3830                                         - surf_usm_v(l)%rad_lw_out(m)
3831             ENDDO
3832          ENDDO
3833       ENDIF
3834
3835
3836       CALL exchange_horiz( rad_lw_in,  nbgp )
3837       CALL exchange_horiz( rad_lw_out, nbgp )
3838       CALL exchange_horiz( rad_lw_hr,    nbgp )
3839       CALL exchange_horiz( rad_lw_cs_hr, nbgp )
3840
3841       CALL exchange_horiz( rad_sw_in,  nbgp )
3842       CALL exchange_horiz( rad_sw_out, nbgp ) 
3843       CALL exchange_horiz( rad_sw_hr,    nbgp )
3844       CALL exchange_horiz( rad_sw_cs_hr, nbgp )
3845
3846#endif
3847
3848    END SUBROUTINE radiation_rrtmg
3849
3850
3851!------------------------------------------------------------------------------!
3852! Description:
3853! ------------
3854!> Calculate the cosine of the zenith angle (variable is called zenith)
3855!------------------------------------------------------------------------------!
3856    SUBROUTINE calc_zenith
3857
3858       IMPLICIT NONE
3859
3860       REAL(wp) ::  declination,  & !< solar declination angle
3861                    hour_angle      !< solar hour angle
3862!
3863!--    Calculate current day and time based on the initial values and simulation
3864!--    time
3865       CALL calc_date_and_time
3866
3867!
3868!--    Calculate solar declination and hour angle   
3869       declination = ASIN( decl_1 * SIN(decl_2 * REAL(day_of_year, KIND=wp) - decl_3) )
3870       hour_angle  = 2.0_wp * pi * (time_utc / 86400.0_wp) + lon - pi
3871
3872!
3873!--    Calculate cosine of solar zenith angle
3874       zenith(0) = SIN(lat) * SIN(declination) + COS(lat) * COS(declination)   &
3875                                            * COS(hour_angle)
3876       zenith(0) = MAX(0.0_wp,zenith(0))
3877
3878!
3879!--    Calculate solar directional vector
3880       IF ( sun_direction )  THEN
3881
3882!
3883!--       Direction in longitudes equals to sin(solar_azimuth) * sin(zenith)
3884          sun_dir_lon(0) = -SIN(hour_angle) * COS(declination)
3885
3886!
3887!--       Direction in latitues equals to cos(solar_azimuth) * sin(zenith)
3888          sun_dir_lat(0) = SIN(declination) * COS(lat) - COS(hour_angle) &
3889                              * COS(declination) * SIN(lat)
3890       ENDIF
3891
3892!
3893!--    Check if the sun is up (otheriwse shortwave calculations can be skipped)
3894       IF ( zenith(0) > 0.0_wp )  THEN
3895          sun_up = .TRUE.
3896       ELSE
3897          sun_up = .FALSE.
3898       END IF
3899
3900    END SUBROUTINE calc_zenith
3901
3902#if defined ( __rrtmg ) && defined ( __netcdf )
3903!------------------------------------------------------------------------------!
3904! Description:
3905! ------------
3906!> Calculates surface albedo components based on Briegleb (1992) and
3907!> Briegleb et al. (1986)
3908!------------------------------------------------------------------------------!
3909    SUBROUTINE calc_albedo( surf )
3910
3911        IMPLICIT NONE
3912
3913        INTEGER(iwp)    ::  ind_type !< running index surface tiles
3914        INTEGER(iwp)    ::  m        !< running index surface elements
3915
3916        TYPE(surf_type) ::  surf !< treated surfaces
3917
3918        IF ( sun_up  .AND.  .NOT. average_radiation )  THEN
3919
3920           DO  m = 1, surf%ns
3921!
3922!--           Loop over surface elements
3923              DO  ind_type = 0, SIZE( surf%albedo_type, 1 ) - 1
3924           
3925!
3926!--              Ocean
3927                 IF ( surf%albedo_type(ind_type,m) == 1 )  THEN
3928                    surf%rrtm_aldir(ind_type,m) = 0.026_wp /                    &
3929                                                ( zenith(0)**1.7_wp + 0.065_wp )&
3930                                     + 0.15_wp * ( zenith(0) - 0.1_wp )         &
3931                                               * ( zenith(0) - 0.5_wp )         &
3932                                               * ( zenith(0) - 1.0_wp )
3933                    surf%rrtm_asdir(ind_type,m) = surf%rrtm_aldir(ind_type,m)
3934!
3935!--              Snow
3936                 ELSEIF ( surf%albedo_type(ind_type,m) == 16 )  THEN
3937                    IF ( zenith(0) < 0.5_wp )  THEN
3938                       surf%rrtm_aldir(ind_type,m) =                           &
3939                                 0.5_wp * ( 1.0_wp - surf%aldif(ind_type,m) )  &
3940                                        * ( 3.0_wp / ( 1.0_wp + 4.0_wp         &
3941                                        * zenith(0) ) ) - 1.0_wp
3942                       surf%rrtm_asdir(ind_type,m) =                           &
3943                                 0.5_wp * ( 1.0_wp - surf%asdif(ind_type,m) )  &
3944                                        * ( 3.0_wp / ( 1.0_wp + 4.0_wp         &
3945                                        * zenith(0) ) ) - 1.0_wp
3946
3947                       surf%rrtm_aldir(ind_type,m) =                           &
3948                                       MIN(0.98_wp, surf%rrtm_aldir(ind_type,m))
3949                       surf%rrtm_asdir(ind_type,m) =                           &
3950                                       MIN(0.98_wp, surf%rrtm_asdir(ind_type,m))
3951                    ELSE
3952                       surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
3953                       surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
3954                    ENDIF
3955!
3956!--              Sea ice
3957                 ELSEIF ( surf%albedo_type(ind_type,m) == 15 )  THEN
3958                    surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
3959                    surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
3960
3961!
3962!--              Asphalt
3963                 ELSEIF ( surf%albedo_type(ind_type,m) == 17 )  THEN
3964                    surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
3965                    surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
3966
3967
3968!
3969!--              Bare soil
3970                 ELSEIF ( surf%albedo_type(ind_type,m) == 18 )  THEN
3971                    surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
3972                    surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
3973
3974!
3975!--              Land surfaces
3976                 ELSE
3977                    SELECT CASE ( surf%albedo_type(ind_type,m) )
3978
3979!
3980!--                    Surface types with strong zenith dependence
3981                       CASE ( 1, 2, 3, 4, 11, 12, 13 )
3982                          surf%rrtm_aldir(ind_type,m) =                        &
3983                                surf%aldif(ind_type,m) * 1.4_wp /              &
3984                                           ( 1.0_wp + 0.8_wp * zenith(0) )
3985                          surf%rrtm_asdir(ind_type,m) =                        &
3986                                surf%asdif(ind_type,m) * 1.4_wp /              &
3987                                           ( 1.0_wp + 0.8_wp * zenith(0) )
3988!
3989!--                    Surface types with weak zenith dependence
3990                       CASE ( 5, 6, 7, 8, 9, 10, 14 )
3991                          surf%rrtm_aldir(ind_type,m) =                        &
3992                                surf%aldif(ind_type,m) * 1.1_wp /              &
3993                                           ( 1.0_wp + 0.2_wp * zenith(0) )
3994                          surf%rrtm_asdir(ind_type,m) =                        &
3995                                surf%asdif(ind_type,m) * 1.1_wp /              &
3996                                           ( 1.0_wp + 0.2_wp * zenith(0) )
3997
3998                       CASE DEFAULT
3999
4000                    END SELECT
4001                 ENDIF
4002!
4003!--              Diffusive albedo is taken from Table 2
4004                 surf%rrtm_aldif(ind_type,m) = surf%aldif(ind_type,m)
4005                 surf%rrtm_asdif(ind_type,m) = surf%asdif(ind_type,m)
4006              ENDDO
4007           ENDDO
4008!
4009!--     Set albedo in case of average radiation
4010        ELSEIF ( sun_up  .AND.  average_radiation )  THEN
4011           surf%rrtm_asdir = albedo_urb
4012           surf%rrtm_asdif = albedo_urb
4013           surf%rrtm_aldir = albedo_urb
4014           surf%rrtm_aldif = albedo_urb 
4015!
4016!--     Darkness
4017        ELSE
4018           surf%rrtm_aldir = 0.0_wp
4019           surf%rrtm_asdir = 0.0_wp
4020           surf%rrtm_aldif = 0.0_wp
4021           surf%rrtm_asdif = 0.0_wp
4022        ENDIF
4023
4024    END SUBROUTINE calc_albedo
4025
4026!------------------------------------------------------------------------------!
4027! Description:
4028! ------------
4029!> Read sounding data (pressure and temperature) from RADIATION_DATA.
4030!------------------------------------------------------------------------------!
4031    SUBROUTINE read_sounding_data
4032
4033       IMPLICIT NONE
4034
4035       INTEGER(iwp) :: id,           & !< NetCDF id of input file
4036                       id_dim_zrad,  & !< pressure level id in the NetCDF file
4037                       id_var,       & !< NetCDF variable id
4038                       k,            & !< loop index
4039                       nz_snd,       & !< number of vertical levels in the sounding data
4040                       nz_snd_start, & !< start vertical index for sounding data to be used
4041                       nz_snd_end      !< end vertical index for souding data to be used
4042
4043       REAL(wp) :: t_surface           !< actual surface temperature
4044
4045       REAL(wp), DIMENSION(:), ALLOCATABLE ::  hyp_snd_tmp, & !< temporary hydrostatic pressure profile (sounding)
4046                                               t_snd_tmp      !< temporary temperature profile (sounding)
4047
4048!
4049!--    In case of updates, deallocate arrays first (sufficient to check one
4050!--    array as the others are automatically allocated). This is required
4051!--    because nzt_rad might change during the update
4052       IF ( ALLOCATED ( hyp_snd ) )  THEN
4053          DEALLOCATE( hyp_snd )
4054          DEALLOCATE( t_snd )
4055          DEALLOCATE ( rrtm_play )
4056          DEALLOCATE ( rrtm_plev )
4057          DEALLOCATE ( rrtm_tlay )
4058          DEALLOCATE ( rrtm_tlev )
4059
4060          DEALLOCATE ( rrtm_cicewp )
4061          DEALLOCATE ( rrtm_cldfr )
4062          DEALLOCATE ( rrtm_cliqwp )
4063          DEALLOCATE ( rrtm_reice )
4064          DEALLOCATE ( rrtm_reliq )
4065          DEALLOCATE ( rrtm_lw_taucld )
4066          DEALLOCATE ( rrtm_lw_tauaer )
4067
4068          DEALLOCATE ( rrtm_lwdflx  )
4069          DEALLOCATE ( rrtm_lwdflxc )
4070          DEALLOCATE ( rrtm_lwuflx  )
4071          DEALLOCATE ( rrtm_lwuflxc )
4072          DEALLOCATE ( rrtm_lwuflx_dt )
4073          DEALLOCATE ( rrtm_lwuflxc_dt )
4074          DEALLOCATE ( rrtm_lwhr  )
4075          DEALLOCATE ( rrtm_lwhrc )
4076
4077          DEALLOCATE ( rrtm_sw_taucld )
4078          DEALLOCATE ( rrtm_sw_ssacld )
4079          DEALLOCATE ( rrtm_sw_asmcld )
4080          DEALLOCATE ( rrtm_sw_fsfcld )
4081          DEALLOCATE ( rrtm_sw_tauaer )
4082          DEALLOCATE ( rrtm_sw_ssaaer )
4083          DEALLOCATE ( rrtm_sw_asmaer ) 
4084          DEALLOCATE ( rrtm_sw_ecaer )   
4085 
4086          DEALLOCATE ( rrtm_swdflx  )
4087          DEALLOCATE ( rrtm_swdflxc )
4088          DEALLOCATE ( rrtm_swuflx  )
4089          DEALLOCATE ( rrtm_swuflxc )
4090          DEALLOCATE ( rrtm_swhr  )
4091          DEALLOCATE ( rrtm_swhrc )
4092          DEALLOCATE ( rrtm_dirdflux )
4093          DEALLOCATE ( rrtm_difdflux )
4094
4095       ENDIF
4096
4097!
4098!--    Open file for reading
4099       nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id )
4100       CALL netcdf_handle_error_rad( 'read_sounding_data', 549 )
4101
4102!
4103!--    Inquire dimension of z axis and save in nz_snd
4104       nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim_zrad )
4105       nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim_zrad, len = nz_snd )
4106       CALL netcdf_handle_error_rad( 'read_sounding_data', 551 )
4107
4108!
4109! !--    Allocate temporary array for storing pressure data
4110       ALLOCATE( hyp_snd_tmp(1:nz_snd) )
4111       hyp_snd_tmp = 0.0_wp
4112
4113
4114!--    Read pressure from file
4115       nc_stat = NF90_INQ_VARID( id, "Pressure", id_var )
4116       nc_stat = NF90_GET_VAR( id, id_var, hyp_snd_tmp(:), start = (/1/),      &
4117                               count = (/nz_snd/) )
4118       CALL netcdf_handle_error_rad( 'read_sounding_data', 552 )
4119
4120!
4121!--    Allocate temporary array for storing temperature data
4122       ALLOCATE( t_snd_tmp(1:nz_snd) )
4123       t_snd_tmp = 0.0_wp
4124
4125!
4126!--    Read temperature from file
4127       nc_stat = NF90_INQ_VARID( id, "ReferenceTemperature", id_var )
4128       nc_stat = NF90_GET_VAR( id, id_var, t_snd_tmp(:), start = (/1/),        &
4129                               count = (/nz_snd/) )
4130       CALL netcdf_handle_error_rad( 'read_sounding_data', 553 )
4131
4132!
4133!--    Calculate start of sounding data
4134       nz_snd_start = nz_snd + 1
4135       nz_snd_end   = nz_snd + 1
4136
4137!
4138!--    Start filling vertical dimension at 10hPa above the model domain (hyp is
4139!--    in Pa, hyp_snd in hPa).
4140       DO  k = 1, nz_snd
4141          IF ( hyp_snd_tmp(k) < ( hyp(nzt+1) - 1000.0_wp) * 0.01_wp )  THEN
4142             nz_snd_start = k
4143             EXIT
4144          END IF
4145       END DO
4146
4147       IF ( nz_snd_start <= nz_snd )  THEN
4148          nz_snd_end = nz_snd
4149       END IF
4150
4151
4152!
4153!--    Calculate of total grid points for RRTMG calculations
4154       nzt_rad = nzt + nz_snd_end - nz_snd_start + 1
4155
4156!
4157!--    Save data above LES domain in hyp_snd, t_snd
4158       ALLOCATE( hyp_snd(nzb+1:nzt_rad) )
4159       ALLOCATE( t_snd(nzb+1:nzt_rad)   )
4160       hyp_snd = 0.0_wp
4161       t_snd = 0.0_wp
4162
4163       hyp_snd(nzt+2:nzt_rad) = hyp_snd_tmp(nz_snd_start+1:nz_snd_end)
4164       t_snd(nzt+2:nzt_rad)   = t_snd_tmp(nz_snd_start+1:nz_snd_end)
4165
4166       nc_stat = NF90_CLOSE( id )
4167
4168!
4169!--    Calculate pressure levels on zu and zw grid. Sounding data is added at
4170!--    top of the LES domain. This routine does not consider horizontal or
4171!--    vertical variability of pressure and temperature
4172       ALLOCATE ( rrtm_play(0:0,nzb+1:nzt_rad+1)   )
4173       ALLOCATE ( rrtm_plev(0:0,nzb+1:nzt_rad+2)   )
4174
4175       t_surface = pt_surface * exner(nzb)
4176       DO k = nzb+1, nzt+1
4177          rrtm_play(0,k) = hyp(k) * 0.01_wp
4178          rrtm_plev(0,k) = barometric_formula(zw(k-1),                         &
4179                              pt_surface * exner(nzb), &
4180                              surface_pressure )
4181       ENDDO
4182
4183       DO k = nzt+2, nzt_rad
4184          rrtm_play(0,k) = hyp_snd(k)
4185          rrtm_plev(0,k) = 0.5_wp * ( rrtm_play(0,k) + rrtm_play(0,k-1) )
4186       ENDDO
4187       rrtm_plev(0,nzt_rad+1) = MAX( 0.5 * hyp_snd(nzt_rad),                   &
4188                                   1.5 * hyp_snd(nzt_rad)                      &
4189                                 - 0.5 * hyp_snd(nzt_rad-1) )
4190       rrtm_plev(0,nzt_rad+2)  = MIN( 1.0E-4_wp,                               &
4191                                      0.25_wp * rrtm_plev(0,nzt_rad+1) )
4192
4193       rrtm_play(0,nzt_rad+1) = 0.5 * rrtm_plev(0,nzt_rad+1)
4194
4195!
4196!--    Calculate temperature/humidity levels at top of the LES domain.
4197!--    Currently, the temperature is taken from sounding data (might lead to a
4198!--    temperature jump at interface. To do: Humidity is currently not
4199!--    calculated above the LES domain.
4200       ALLOCATE ( rrtm_tlay(0:0,nzb+1:nzt_rad+1)   )
4201       ALLOCATE ( rrtm_tlev(0:0,nzb+1:nzt_rad+2)   )
4202
4203       DO k = nzt+8, nzt_rad
4204          rrtm_tlay(0,k)   = t_snd(k)
4205       ENDDO
4206       rrtm_tlay(0,nzt_rad+1) = 2.0_wp * rrtm_tlay(0,nzt_rad)                  &
4207                                - rrtm_tlay(0,nzt_rad-1)
4208       DO k = nzt+9, nzt_rad+1
4209          rrtm_tlev(0,k)   = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k)                &
4210                             - rrtm_tlay(0,k-1))                               &
4211                             / ( rrtm_play(0,k) - rrtm_play(0,k-1) )           &
4212                             * ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
4213       ENDDO
4214
4215       rrtm_tlev(0,nzt_rad+2)   = 2.0_wp * rrtm_tlay(0,nzt_rad+1)              &
4216                                  - rrtm_tlev(0,nzt_rad)
4217!
4218!--    Allocate remaining RRTMG arrays
4219       ALLOCATE ( rrtm_cicewp(0:0,nzb+1:nzt_rad+1) )
4220       ALLOCATE ( rrtm_cldfr(0:0,nzb+1:nzt_rad+1) )
4221       ALLOCATE ( rrtm_cliqwp(0:0,nzb+1:nzt_rad+1) )
4222       ALLOCATE ( rrtm_reice(0:0,nzb+1:nzt_rad+1) )
4223       ALLOCATE ( rrtm_reliq(0:0,nzb+1:nzt_rad+1) )
4224       ALLOCATE ( rrtm_lw_taucld(1:nbndlw+1,0:0,nzb+1:nzt_rad+1) )
4225       ALLOCATE ( rrtm_lw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndlw+1) )
4226       ALLOCATE ( rrtm_sw_taucld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4227       ALLOCATE ( rrtm_sw_ssacld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4228       ALLOCATE ( rrtm_sw_asmcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4229       ALLOCATE ( rrtm_sw_fsfcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
4230       ALLOCATE ( rrtm_sw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
4231       ALLOCATE ( rrtm_sw_ssaaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
4232       ALLOCATE ( rrtm_sw_asmaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) ) 
4233       ALLOCATE ( rrtm_sw_ecaer(0:0,nzb+1:nzt_rad+1,1:naerec+1) )   
4234
4235!
4236!--    The ice phase is currently not considered in PALM
4237       rrtm_cicewp = 0.0_wp
4238       rrtm_reice  = 0.0_wp
4239
4240!
4241!--    Set other parameters (move to NAMELIST parameters in the future)
4242       rrtm_lw_tauaer = 0.0_wp
4243       rrtm_lw_taucld = 0.0_wp
4244       rrtm_sw_taucld = 0.0_wp
4245       rrtm_sw_ssacld = 0.0_wp
4246       rrtm_sw_asmcld = 0.0_wp
4247       rrtm_sw_fsfcld = 0.0_wp
4248       rrtm_sw_tauaer = 0.0_wp
4249       rrtm_sw_ssaaer = 0.0_wp
4250       rrtm_sw_asmaer = 0.0_wp
4251       rrtm_sw_ecaer  = 0.0_wp
4252
4253
4254       ALLOCATE ( rrtm_swdflx(0:0,nzb:nzt_rad+1)  )
4255       ALLOCATE ( rrtm_swuflx(0:0,nzb:nzt_rad+1)  )
4256       ALLOCATE ( rrtm_swhr(0:0,nzb+1:nzt_rad+1)  )
4257       ALLOCATE ( rrtm_swuflxc(0:0,nzb:nzt_rad+1) )
4258       ALLOCATE ( rrtm_swdflxc(0:0,nzb:nzt_rad+1) )
4259       ALLOCATE ( rrtm_swhrc(0:0,nzb+1:nzt_rad+1) )
4260       ALLOCATE ( rrtm_dirdflux(0:0,nzb:nzt_rad+1) )
4261       ALLOCATE ( rrtm_difdflux(0:0,nzb:nzt_rad+1) )
4262
4263       rrtm_swdflx  = 0.0_wp
4264       rrtm_swuflx  = 0.0_wp
4265       rrtm_swhr    = 0.0_wp 
4266       rrtm_swuflxc = 0.0_wp
4267       rrtm_swdflxc = 0.0_wp
4268       rrtm_swhrc   = 0.0_wp
4269       rrtm_dirdflux = 0.0_wp
4270       rrtm_difdflux = 0.0_wp
4271
4272       ALLOCATE ( rrtm_lwdflx(0:0,nzb:nzt_rad+1)  )
4273       ALLOCATE ( rrtm_lwuflx(0:0,nzb:nzt_rad+1)  )
4274       ALLOCATE ( rrtm_lwhr(0:0,nzb+1:nzt_rad+1)  )
4275       ALLOCATE ( rrtm_lwuflxc(0:0,nzb:nzt_rad+1) )
4276       ALLOCATE ( rrtm_lwdflxc(0:0,nzb:nzt_rad+1) )
4277       ALLOCATE ( rrtm_lwhrc(0:0,nzb+1:nzt_rad+1) )
4278
4279       rrtm_lwdflx  = 0.0_wp
4280       rrtm_lwuflx  = 0.0_wp
4281       rrtm_lwhr    = 0.0_wp 
4282       rrtm_lwuflxc = 0.0_wp
4283       rrtm_lwdflxc = 0.0_wp
4284       rrtm_lwhrc   = 0.0_wp
4285
4286       ALLOCATE ( rrtm_lwuflx_dt(0:0,nzb:nzt_rad+1) )
4287       ALLOCATE ( rrtm_lwuflxc_dt(0:0,nzb:nzt_rad+1) )
4288
4289       rrtm_lwuflx_dt = 0.0_wp
4290       rrtm_lwuflxc_dt = 0.0_wp
4291
4292    END SUBROUTINE read_sounding_data
4293
4294
4295!------------------------------------------------------------------------------!
4296! Description:
4297! ------------
4298!> Read trace gas data from file
4299!------------------------------------------------------------------------------!
4300    SUBROUTINE read_trace_gas_data
4301
4302       USE rrsw_ncpar
4303
4304       IMPLICIT NONE
4305
4306       INTEGER(iwp), PARAMETER :: num_trace_gases = 10 !< number of trace gases (absorbers)
4307
4308       CHARACTER(LEN=5), DIMENSION(num_trace_gases), PARAMETER ::              & !< trace gas names
4309           trace_names = (/'O3   ', 'CO2  ', 'CH4  ', 'N2O  ', 'O2   ',        &
4310                           'CFC11', 'CFC12', 'CFC22', 'CCL4 ', 'H2O  '/)
4311
4312       INTEGER(iwp) :: id,     & !< NetCDF id
4313                       k,      & !< loop index
4314                       m,      & !< loop index
4315                       n,      & !< loop index
4316                       nabs,   & !< number of absorbers
4317                       np,     & !< number of pressure levels
4318                       id_abs, & !< NetCDF id of the respective absorber
4319                       id_dim, & !< NetCDF id of asborber's dimension
4320                       id_var    !< NetCDf id ot the absorber
4321
4322       REAL(wp) :: p_mls_l, p_mls_u, p_wgt_l, p_wgt_u, p_mls_m
4323
4324
4325       REAL(wp), DIMENSION(:), ALLOCATABLE   ::  p_mls,          & !< pressure levels for the absorbers
4326                                                 rrtm_play_tmp,  & !< temporary array for pressure zu-levels
4327                                                 rrtm_plev_tmp,  & !< temporary array for pressure zw-levels
4328                                                 trace_path_tmp    !< temporary array for storing trace gas path data
4329
4330       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  trace_mls,      & !< array for storing the absorber amounts
4331                                                 trace_mls_path, & !< array for storing trace gas path data
4332                                                 trace_mls_tmp     !< temporary array for storing trace gas data
4333
4334
4335!
4336!--    In case of updates, deallocate arrays first (sufficient to check one
4337!--    array as the others are automatically allocated)
4338       IF ( ALLOCATED ( rrtm_o3vmr ) )  THEN
4339          DEALLOCATE ( rrtm_o3vmr  )
4340          DEALLOCATE ( rrtm_co2vmr )
4341          DEALLOCATE ( rrtm_ch4vmr )
4342          DEALLOCATE ( rrtm_n2ovmr )
4343          DEALLOCATE ( rrtm_o2vmr  )
4344          DEALLOCATE ( rrtm_cfc11vmr )
4345          DEALLOCATE ( rrtm_cfc12vmr )
4346          DEALLOCATE ( rrtm_cfc22vmr )
4347          DEALLOCATE ( rrtm_ccl4vmr  )
4348          DEALLOCATE ( rrtm_h2ovmr  )     
4349       ENDIF
4350
4351!
4352!--    Allocate trace gas profiles
4353       ALLOCATE ( rrtm_o3vmr(0:0,1:nzt_rad+1)  )
4354       ALLOCATE ( rrtm_co2vmr(0:0,1:nzt_rad+1) )
4355       ALLOCATE ( rrtm_ch4vmr(0:0,1:nzt_rad+1) )
4356       ALLOCATE ( rrtm_n2ovmr(0:0,1:nzt_rad+1) )
4357       ALLOCATE ( rrtm_o2vmr(0:0,1:nzt_rad+1)  )
4358       ALLOCATE ( rrtm_cfc11vmr(0:0,1:nzt_rad+1) )
4359       ALLOCATE ( rrtm_cfc12vmr(0:0,1:nzt_rad+1) )
4360       ALLOCATE ( rrtm_cfc22vmr(0:0,1:nzt_rad+1) )
4361       ALLOCATE ( rrtm_ccl4vmr(0:0,1:nzt_rad+1)  )
4362       ALLOCATE ( rrtm_h2ovmr(0:0,1:nzt_rad+1)  )
4363
4364!
4365!--    Open file for reading
4366       nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id )
4367       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 549 )
4368!
4369!--    Inquire dimension ids and dimensions
4370       nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim )
4371       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
4372       nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = np) 
4373       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
4374
4375       nc_stat = NF90_INQ_DIMID( id, "Absorber", id_dim )
4376       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
4377       nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = nabs ) 
4378       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
4379   
4380
4381!
4382!--    Allocate pressure, and trace gas arrays     
4383       ALLOCATE( p_mls(1:np) )
4384       ALLOCATE( trace_mls(1:num_trace_gases,1:np) ) 
4385       ALLOCATE( trace_mls_tmp(1:nabs,1:np) ) 
4386
4387
4388       nc_stat = NF90_INQ_VARID( id, "Pressure", id_var )
4389       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
4390       nc_stat = NF90_GET_VAR( id, id_var, p_mls )
4391       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
4392
4393       nc_stat = NF90_INQ_VARID( id, "AbsorberAmountMLS", id_var )
4394       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
4395       nc_stat = NF90_GET_VAR( id, id_var, trace_mls_tmp )
4396       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
4397
4398
4399!
4400!--    Write absorber amounts (mls) to trace_mls
4401       DO n = 1, num_trace_gases
4402          CALL getAbsorberIndex( TRIM( trace_names(n) ), id_abs )
4403
4404          trace_mls(n,1:np) = trace_mls_tmp(id_abs,1:np)
4405
4406!
4407!--       Replace missing values by zero
4408          WHERE ( trace_mls(n,:) > 2.0_wp ) 
4409             trace_mls(n,:) = 0.0_wp
4410          END WHERE
4411       END DO
4412
4413       DEALLOCATE ( trace_mls_tmp )
4414
4415       nc_stat = NF90_CLOSE( id )
4416       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 551 )
4417
4418!
4419!--    Add extra pressure level for calculations of the trace gas paths
4420       ALLOCATE ( rrtm_play_tmp(1:nzt_rad+1) )
4421       ALLOCATE ( rrtm_plev_tmp(1:nzt_rad+2) )
4422
4423       rrtm_play_tmp(1:nzt_rad)   = rrtm_play(0,1:nzt_rad) 
4424       rrtm_plev_tmp(1:nzt_rad+1) = rrtm_plev(0,1:nzt_rad+1)
4425       rrtm_play_tmp(nzt_rad+1)   = rrtm_plev(0,nzt_rad+1) * 0.5_wp
4426       rrtm_plev_tmp(nzt_rad+2)   = MIN( 1.0E-4_wp, 0.25_wp                    &
4427                                         * rrtm_plev(0,nzt_rad+1) )
4428 
4429!
4430!--    Calculate trace gas path (zero at surface) with interpolation to the
4431!--    sounding levels
4432       ALLOCATE ( trace_mls_path(1:nzt_rad+2,1:num_trace_gases) )
4433
4434       trace_mls_path(nzb+1,:) = 0.0_wp
4435       
4436       DO k = nzb+2, nzt_rad+2
4437          DO m = 1, num_trace_gases
4438             trace_mls_path(k,m) = trace_mls_path(k-1,m)
4439
4440!
4441!--          When the pressure level is higher than the trace gas pressure
4442!--          level, assume that
4443             IF ( rrtm_plev_tmp(k-1) > p_mls(1) )  THEN             
4444               
4445                trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,1)     &
4446                                      * ( rrtm_plev_tmp(k-1)                   &
4447                                          - MAX( p_mls(1), rrtm_plev_tmp(k) )  &
4448                                        ) / g
4449             ENDIF
4450
4451!
4452!--          Integrate for each sounding level from the contributing p_mls
4453!--          levels
4454             DO n = 2, np
4455!
4456!--             Limit p_mls so that it is within the model level
4457                p_mls_u = MIN( rrtm_plev_tmp(k-1),                             &
4458                          MAX( rrtm_plev_tmp(k), p_mls(n) ) )
4459                p_mls_l = MIN( rrtm_plev_tmp(k-1),                             &
4460                          MAX( rrtm_plev_tmp(k), p_mls(n-1) ) )
4461
4462                IF ( p_mls_l > p_mls_u )  THEN
4463
4464!
4465!--                Calculate weights for interpolation
4466                   p_mls_m = 0.5_wp * (p_mls_l + p_mls_u)
4467                   p_wgt_u = (p_mls(n-1) - p_mls_m) / (p_mls(n-1) - p_mls(n))
4468                   p_wgt_l = (p_mls_m - p_mls(n))   / (p_mls(n-1) - p_mls(n))
4469
4470!
4471!--                Add level to trace gas path
4472                   trace_mls_path(k,m) = trace_mls_path(k,m)                   &
4473                                         +  ( p_wgt_u * trace_mls(m,n)         &
4474                                            + p_wgt_l * trace_mls(m,n-1) )     &
4475                                         * (p_mls_l - p_mls_u) / g
4476                ENDIF
4477             ENDDO
4478
4479             IF ( rrtm_plev_tmp(k) < p_mls(np) )  THEN
4480                trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,np)    &
4481                                      * ( MIN( rrtm_plev_tmp(k-1), p_mls(np) ) &
4482                                          - rrtm_plev_tmp(k)                   &
4483                                        ) / g 
4484             ENDIF 
4485          ENDDO
4486       ENDDO
4487
4488
4489!
4490!--    Prepare trace gas path profiles
4491       ALLOCATE ( trace_path_tmp(1:nzt_rad+1) )
4492
4493       DO m = 1, num_trace_gases
4494
4495          trace_path_tmp(1:nzt_rad+1) = ( trace_mls_path(2:nzt_rad+2,m)        &
4496                                       - trace_mls_path(1:nzt_rad+1,m) ) * g   &
4497                                       / ( rrtm_plev_tmp(1:nzt_rad+1)          &
4498                                       - rrtm_plev_tmp(2:nzt_rad+2) )
4499
4500!
4501!--       Save trace gas paths to the respective arrays
4502          SELECT CASE ( TRIM( trace_names(m) ) )
4503
4504             CASE ( 'O3' )
4505
4506                rrtm_o3vmr(0,:) = trace_path_tmp(:)
4507
4508             CASE ( 'CO2' )
4509
4510                rrtm_co2vmr(0,:) = trace_path_tmp(:)
4511
4512             CASE ( 'CH4' )
4513
4514                rrtm_ch4vmr(0,:) = trace_path_tmp(:)
4515
4516             CASE ( 'N2O' )
4517
4518                rrtm_n2ovmr(0,:) = trace_path_tmp(:)
4519
4520             CASE ( 'O2' )
4521
4522                rrtm_o2vmr(0,:) = trace_path_tmp(:)
4523
4524             CASE ( 'CFC11' )
4525
4526                rrtm_cfc11vmr(0,:) = trace_path_tmp(:)
4527
4528             CASE ( 'CFC12' )
4529
4530                rrtm_cfc12vmr(0,:) = trace_path_tmp(:)
4531
4532             CASE ( 'CFC22' )
4533
4534                rrtm_cfc22vmr(0,:) = trace_path_tmp(:)
4535
4536             CASE ( 'CCL4' )
4537
4538                rrtm_ccl4vmr(0,:) = trace_path_tmp(:)
4539
4540             CASE ( 'H2O' )
4541
4542                rrtm_h2ovmr(0,:) = trace_path_tmp(:)
4543               
4544             CASE DEFAULT
4545
4546          END SELECT
4547
4548       ENDDO
4549
4550       DEALLOCATE ( trace_path_tmp )
4551       DEALLOCATE ( trace_mls_path )
4552       DEALLOCATE ( rrtm_play_tmp )
4553       DEALLOCATE ( rrtm_plev_tmp )
4554       DEALLOCATE ( trace_mls )
4555       DEALLOCATE ( p_mls )
4556
4557    END SUBROUTINE read_trace_gas_data
4558
4559
4560    SUBROUTINE netcdf_handle_error_rad( routine_name, errno )
4561
4562       USE control_parameters,                                                 &
4563           ONLY:  message_string
4564
4565       USE NETCDF
4566
4567       USE pegrid
4568
4569       IMPLICIT NONE
4570
4571       CHARACTER(LEN=6) ::  message_identifier
4572       CHARACTER(LEN=*) ::  routine_name
4573
4574       INTEGER(iwp) ::  errno
4575
4576       IF ( nc_stat /= NF90_NOERR )  THEN
4577
4578          WRITE( message_identifier, '(''NC'',I4.4)' )  errno
4579          message_string = TRIM( NF90_STRERROR( nc_stat ) )
4580
4581          CALL message( routine_name, message_identifier, 2, 2, 0, 6, 1 )
4582
4583       ENDIF
4584
4585    END SUBROUTINE netcdf_handle_error_rad
4586#endif
4587
4588
4589!------------------------------------------------------------------------------!
4590! Description:
4591! ------------
4592!> Calculate temperature tendency due to radiative cooling/heating.
4593!> Cache-optimized version.
4594!------------------------------------------------------------------------------!
4595 SUBROUTINE radiation_tendency_ij ( i, j, tend )
4596
4597    IMPLICIT NONE
4598
4599    INTEGER(iwp) :: i, j, k !< loop indices
4600
4601    REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term
4602
4603    IF ( radiation_scheme == 'rrtmg' )  THEN
4604#if defined  ( __rrtmg )
4605!
4606!--    Calculate tendency based on heating rate
4607       DO k = nzb+1, nzt+1
4608          tend(k,j,i) = tend(k,j,i) + (rad_lw_hr(k,j,i) + rad_sw_hr(k,j,i))    &
4609                                         * d_exner(k) * d_seconds_hour
4610       ENDDO
4611#endif
4612    ENDIF
4613
4614    END SUBROUTINE radiation_tendency_ij
4615
4616
4617!------------------------------------------------------------------------------!
4618! Description:
4619! ------------
4620!> Calculate temperature tendency due to radiative cooling/heating.
4621!> Vector-optimized version
4622!------------------------------------------------------------------------------!
4623 SUBROUTINE radiation_tendency ( tend )
4624
4625    USE indices,                                                               &
4626        ONLY:  nxl, nxr, nyn, nys
4627
4628    IMPLICIT NONE
4629
4630    INTEGER(iwp) :: i, j, k !< loop indices
4631
4632    REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term
4633
4634    IF ( radiation_scheme == 'rrtmg' )  THEN
4635#if defined  ( __rrtmg )
4636!
4637!--    Calculate tendency based on heating rate
4638       DO  i = nxl, nxr
4639          DO  j = nys, nyn
4640             DO k = nzb+1, nzt+1
4641                tend(k,j,i) = tend(k,j,i) + ( rad_lw_hr(k,j,i)                 &
4642                                          +  rad_sw_hr(k,j,i) ) * d_exner(k)   &
4643                                          * d_seconds_hour
4644             ENDDO
4645          ENDDO
4646       ENDDO
4647#endif
4648    ENDIF
4649
4650
4651 END SUBROUTINE radiation_tendency
4652
4653!------------------------------------------------------------------------------!
4654! Description:
4655! ------------
4656!> This subroutine calculates interaction of the solar radiation
4657!> with urban and land surfaces and updates all surface heatfluxes.
4658!> It calculates also the required parameters for RRTMG lower BC.
4659!>
4660!> For more info. see Resler et al. 2017
4661!>
4662!> The new version 2.0 was radically rewriten, the discretization scheme
4663!> has been changed. This new version significantly improves effectivity
4664!> of the paralelization and the scalability of the model.
4665!------------------------------------------------------------------------------!
4666
4667 SUBROUTINE radiation_interaction
4668
4669     IMPLICIT NONE
4670
4671     INTEGER(iwp)                      :: i, j, k, kk, is, js, d, ku, refstep, m, mm, l, ll
4672     INTEGER(iwp)                      :: isurf, isurfsrc, isvf, icsf, ipcgb
4673     INTEGER(iwp)                      :: imrt, imrtf
4674     INTEGER(iwp)                      :: isd                !< solar direction number
4675     INTEGER(iwp)                      :: pc_box_dimshift    !< transform for best accuracy
4676     INTEGER(iwp), DIMENSION(0:3)      :: reorder = (/ 1, 0, 3, 2 /)
4677     
4678     REAL(wp), DIMENSION(3,3)          :: mrot               !< grid rotation matrix (zyx)
4679     REAL(wp), DIMENSION(3,0:nsurf_type):: vnorm             !< face direction normal vectors (zyx)
4680     REAL(wp), DIMENSION(3)            :: sunorig            !< grid rotated solar direction unit vector (zyx)
4681     REAL(wp), DIMENSION(3)            :: sunorig_grid       !< grid squashed solar direction unit vector (zyx)
4682     REAL(wp), DIMENSION(0:nsurf_type) :: costheta           !< direct irradiance factor of solar angle
4683     REAL(wp), DIMENSION(nzub:nzut)    :: pchf_prep          !< precalculated factor for canopy temperature tendency
4684     REAL(wp), PARAMETER               :: alpha = 0._wp      !< grid rotation (TODO: add to namelist or remove)
4685     REAL(wp)                          :: pc_box_area, pc_abs_frac, pc_abs_eff
4686     REAL(wp)                          :: asrc               !< area of source face
4687     REAL(wp)                          :: pcrad              !< irradiance from plant canopy
4688     REAL(wp)                          :: pabsswl  = 0.0_wp  !< total absorbed SW radiation energy in local processor (W)
4689     REAL(wp)                          :: pabssw   = 0.0_wp  !< total absorbed SW radiation energy in all processors (W)
4690     REAL(wp)                          :: pabslwl  = 0.0_wp  !< total absorbed LW radiation energy in local processor (W)
4691     REAL(wp)                          :: pabslw   = 0.0_wp  !< total absorbed LW radiation energy in all processors (W)
4692     REAL(wp)                          :: pemitlwl = 0.0_wp  !< total emitted LW radiation energy in all processors (W)
4693     REAL(wp)                          :: pemitlw  = 0.0_wp  !< total emitted LW radiation energy in all processors (W)
4694     REAL(wp)                          :: pinswl   = 0.0_wp  !< total received SW radiation energy in local processor (W)
4695     REAL(wp)                          :: pinsw    = 0.0_wp  !< total received SW radiation energy in all processor (W)
4696     REAL(wp)                          :: pinlwl   = 0.0_wp  !< total received LW radiation energy in local processor (W)
4697     REAL(wp)                          :: pinlw    = 0.0_wp  !< total received LW radiation energy in all processor (W)
4698     REAL(wp)                          :: emiss_sum_surfl    !< sum of emissisivity of surfaces in local processor
4699     REAL(wp)                          :: emiss_sum_surf     !< sum of emissisivity of surfaces in all processor
4700     REAL(wp)                          :: area_surfl         !< total area of surfaces in local processor
4701     REAL(wp)                          :: area_surf          !< total area of surfaces in all processor
4702     REAL(wp)                          :: area_hor           !< total horizontal area of domain in all processor
4703
4704#if ! defined( __nopointer )
4705     IF ( plant_canopy )  THEN
4706         pchf_prep(:) = r_d * exner(nzub:nzut)                                 &
4707                     / (c_p * hyp(nzub:nzut) * dx*dy*dz(1)) !< equals to 1 / (rho * c_p * Vbox * T)
4708     ENDIF
4709#endif
4710     sun_direction = .TRUE.
4711     CALL calc_zenith  !< required also for diffusion radiation
4712
4713!--     prepare rotated normal vectors and irradiance factor
4714     vnorm(1,:) = kdir(:)
4715     vnorm(2,:) = jdir(:)
4716     vnorm(3,:) = idir(:)
4717     mrot(1, :) = (/ 1._wp,  0._wp,      0._wp      /)
4718     mrot(2, :) = (/ 0._wp,  COS(alpha), SIN(alpha) /)
4719     mrot(3, :) = (/ 0._wp, -SIN(alpha), COS(alpha) /)
4720     sunorig = (/ zenith(0), sun_dir_lat, sun_dir_lon /)
4721     sunorig = MATMUL(mrot, sunorig)
4722     DO d = 0, nsurf_type
4723         costheta(d) = DOT_PRODUCT(sunorig, vnorm(:,d))
4724     ENDDO
4725
4726     IF ( zenith(0) > 0 )  THEN
4727!--      now we will "squash" the sunorig vector by grid box size in
4728!--      each dimension, so that this new direction vector will allow us
4729!--      to traverse the ray path within grid coordinates directly
4730         sunorig_grid = (/ sunorig(1)/dz(1), sunorig(2)/dy, sunorig(3)/dx /)
4731!--      sunorig_grid = sunorig_grid / norm2(sunorig_grid)
4732         sunorig_grid = sunorig_grid / SQRT(SUM(sunorig_grid**2))
4733
4734         IF ( npcbl > 0 )  THEN
4735!--         precompute effective box depth with prototype Leaf Area Density
4736            pc_box_dimshift = MAXLOC(ABS(sunorig), 1) - 1
4737            CALL box_absorb(CSHIFT((/dz(1),dy,dx/), pc_box_dimshift),       &
4738                                60, prototype_lad,                          &
4739                                CSHIFT(ABS(sunorig), pc_box_dimshift),      &
4740                                pc_box_area, pc_abs_frac)
4741            pc_box_area = pc_box_area * ABS(sunorig(pc_box_dimshift+1)      &
4742                          / sunorig(1))
4743            pc_abs_eff = LOG(1._wp - pc_abs_frac) / prototype_lad
4744         ENDIF
4745     ENDIF
4746
4747!--  if radiation scheme is not RRTMG, split diffusion and direct part of the solar downward radiation
4748!--  comming from radiation model and store it in 2D arrays
4749     IF (  radiation_scheme /= 'rrtmg'  )  CALL calc_diffusion_radiation
4750
4751!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4752!--     First pass: direct + diffuse irradiance + thermal
4753!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4754     surfinswdir   = 0._wp !nsurfl
4755     surfins       = 0._wp !nsurfl
4756     surfinl       = 0._wp !nsurfl
4757     surfoutsl(:)  = 0.0_wp !start-end
4758     surfoutll(:)  = 0.0_wp !start-end
4759     IF ( nmrtbl > 0 )  THEN
4760        mrtinsw(:) = 0._wp
4761        mrtinlw(:) = 0._wp
4762     ENDIF
4763     surfinlg(:)  = 0._wp !global
4764
4765
4766!--  Set up thermal radiation from surfaces
4767!--  emiss_surf is defined only for surfaces for which energy balance is calculated
4768!--  Workaround: reorder surface data type back on 1D array including all surfaces,
4769!--  which implies to reorder horizontal and vertical surfaces
4770!
4771!--  Horizontal walls
4772     mm = 1
4773     DO  i = nxl, nxr
4774        DO  j = nys, nyn
4775!--           urban
4776           DO  m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
4777              surfoutll(mm) = SUM ( surf_usm_h%frac(:,m) *                  &
4778                                    surf_usm_h%emissivity(:,m) )            &
4779                                  * sigma_sb                                &
4780                                  * surf_usm_h%pt_surface(m)**4
4781              albedo_surf(mm) = SUM ( surf_usm_h%frac(:,m) *                &
4782                                      surf_usm_h%albedo(:,m) )
4783              emiss_surf(mm)  = SUM ( surf_usm_h%frac(:,m) *                &
4784                                      surf_usm_h%emissivity(:,m) )
4785              mm = mm + 1
4786           ENDDO
4787!--           land
4788           DO  m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
4789              surfoutll(mm) = SUM ( surf_lsm_h%frac(:,m) *                  &
4790                                    surf_lsm_h%emissivity(:,m) )            &
4791                                  * sigma_sb                                &
4792                                  * surf_lsm_h%pt_surface(m)**4
4793              albedo_surf(mm) = SUM ( surf_lsm_h%frac(:,m) *                &
4794                                      surf_lsm_h%albedo(:,m) )
4795              emiss_surf(mm)  = SUM ( surf_lsm_h%frac(:,m) *                &
4796                                      surf_lsm_h%emissivity(:,m) )
4797              mm = mm + 1
4798           ENDDO
4799        ENDDO
4800     ENDDO
4801!
4802!--     Vertical walls
4803     DO  i = nxl, nxr
4804        DO  j = nys, nyn
4805           DO  ll = 0, 3
4806              l = reorder(ll)
4807!--              urban
4808              DO  m = surf_usm_v(l)%start_index(j,i),                       &
4809                      surf_usm_v(l)%end_index(j,i)
4810                 surfoutll(mm) = SUM ( surf_usm_v(l)%frac(:,m) *            &
4811                                       surf_usm_v(l)%emissivity(:,m) )      &
4812                                  * sigma_sb                                &
4813                                  * surf_usm_v(l)%pt_surface(m)**4
4814                 albedo_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) *          &
4815                                         surf_usm_v(l)%albedo(:,m) )
4816                 emiss_surf(mm)  = SUM ( surf_usm_v(l)%frac(:,m) *          &
4817                                         surf_usm_v(l)%emissivity(:,m) )
4818                 mm = mm + 1
4819              ENDDO
4820!--              land
4821              DO  m = surf_lsm_v(l)%start_index(j,i),                       &
4822                      surf_lsm_v(l)%end_index(j,i)
4823                 surfoutll(mm) = SUM ( surf_lsm_v(l)%frac(:,m) *            &
4824                                       surf_lsm_v(l)%emissivity(:,m) )      &
4825                                  * sigma_sb                                &
4826                                  * surf_lsm_v(l)%pt_surface(m)**4
4827                 albedo_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) *          &
4828                                         surf_lsm_v(l)%albedo(:,m) )
4829                 emiss_surf(mm)  = SUM ( surf_lsm_v(l)%frac(:,m) *          &
4830                                         surf_lsm_v(l)%emissivity(:,m) )
4831                 mm = mm + 1
4832              ENDDO
4833           ENDDO
4834        ENDDO
4835     ENDDO
4836
4837#if defined( __parallel )
4838!--     might be optimized and gather only values relevant for current processor
4839     CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, &
4840                         surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) !nsurf global
4841     IF ( ierr /= 0 ) THEN
4842         WRITE(9,*) 'Error MPI_AllGatherv1:', ierr, SIZE(surfoutll), nsurfl, &
4843                     SIZE(surfoutl), nsurfs, surfstart
4844         FLUSH(9)
4845     ENDIF
4846#else
4847     surfoutl(:) = surfoutll(:) !nsurf global
4848#endif
4849
4850     IF ( surface_reflections)  THEN
4851        DO  isvf = 1, nsvfl
4852           isurf = svfsurf(1, isvf)
4853           k     = surfl(iz, isurf)
4854           j     = surfl(iy, isurf)
4855           i     = surfl(ix, isurf)
4856           isurfsrc = svfsurf(2, isvf)
4857!
4858!--        For surface-to-surface factors we calculate thermal radiation in 1st pass
4859           IF ( plant_lw_interact )  THEN
4860              surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc)
4861           ELSE
4862              surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)
4863           ENDIF
4864        ENDDO
4865     ENDIF
4866!
4867!--  diffuse radiation using sky view factor
4868     DO isurf = 1, nsurfl
4869        j = surfl(iy, isurf)
4870        i = surfl(ix, isurf)
4871        surfinswdif(isurf) = rad_sw_in_diff(j,i) * skyvft(isurf)
4872        IF ( plant_lw_interact )  THEN
4873           surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvft(isurf)
4874        ELSE
4875           surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvf(isurf)
4876        ENDIF
4877     ENDDO
4878!
4879!--  MRT diffuse irradiance
4880     DO  imrt = 1, nmrtbl
4881        j = mrtbl(iy, imrt)
4882        i = mrtbl(ix, imrt)
4883        mrtinsw(imrt) = mrtskyt(imrt) * rad_sw_in_diff(j,i)
4884        mrtinlw(imrt) = mrtsky(imrt) * rad_lw_in_diff(j,i)
4885     ENDDO
4886
4887     !-- direct radiation
4888     IF ( zenith(0) > 0 )  THEN
4889        !--Identify solar direction vector (discretized number) 1)
4890        !--
4891        j = FLOOR(ACOS(zenith(0)) / pi * raytrace_discrete_elevs)
4892        i = MODULO(NINT(ATAN2(sun_dir_lon(0), sun_dir_lat(0))               &
4893                        / (2._wp*pi) * raytrace_discrete_azims-.5_wp, iwp), &
4894                   raytrace_discrete_azims)
4895        isd = dsidir_rev(j, i)
4896!-- TODO: check if isd = -1 to report that this solar position is not precalculated
4897        DO isurf = 1, nsurfl
4898           j = surfl(iy, isurf)
4899           i = surfl(ix, isurf)
4900           surfinswdir(isurf) = rad_sw_in_dir(j,i) *                        &
4901                costheta(surfl(id, isurf)) * dsitrans(isurf, isd) / zenith(0)
4902        ENDDO
4903!
4904!--     MRT direct irradiance
4905        DO  imrt = 1, nmrtbl
4906           j = mrtbl(iy, imrt)
4907           i = mrtbl(ix, imrt)
4908           mrtinsw(imrt) = mrtinsw(imrt) + mrtdsit(imrt, isd) * rad_sw_in_dir(j,i) &
4909                                     / zenith(0) / 4._wp ! normal to sphere
4910        ENDDO
4911     ENDIF
4912!
4913!--  MRT first pass thermal
4914     DO  imrtf = 1, nmrtf
4915        imrt = mrtfsurf(1, imrtf)
4916        isurfsrc = mrtfsurf(2, imrtf)
4917        mrtinlw(imrt) = mrtinlw(imrt) + mrtf(imrtf) * surfoutl(isurfsrc)
4918     ENDDO
4919
4920     IF ( npcbl > 0 )  THEN
4921
4922         pcbinswdir(:) = 0._wp
4923         pcbinswdif(:) = 0._wp
4924         pcbinlw(:) = 0._wp
4925!
4926!--      pcsf first pass
4927         DO icsf = 1, ncsfl
4928             ipcgb = csfsurf(1, icsf)
4929             i = pcbl(ix,ipcgb)
4930             j = pcbl(iy,ipcgb)
4931             k = pcbl(iz,ipcgb)
4932             isurfsrc = csfsurf(2, icsf)
4933
4934             IF ( isurfsrc == -1 )  THEN
4935!
4936!--             Diffuse rad from sky.
4937                pcbinswdif(ipcgb) = csf(1,icsf) * rad_sw_in_diff(j,i)
4938!
4939!--             Absorbed diffuse LW from sky minus emitted to sky
4940                IF ( plant_lw_interact )  THEN
4941                   pcbinlw(ipcgb) = csf(1,icsf)                                  &
4942                                       * (rad_lw_in_diff(j, i)                   &
4943                                          - sigma_sb * (pt(k,j,i)*exner(k))**4)
4944                ENDIF
4945!
4946!--             Direct rad
4947                IF ( zenith(0) > 0 )  THEN
4948!--                Estimate directed box absorption
4949                   pc_abs_frac = 1._wp - exp(pc_abs_eff * lad_s(k,j,i))
4950!
4951!--                isd has already been established, see 1)
4952                   pcbinswdir(ipcgb) = rad_sw_in_dir(j, i) * pc_box_area &
4953                                       * pc_abs_frac * dsitransc(ipcgb, isd)
4954                ENDIF
4955             ELSE
4956                IF ( plant_lw_interact )  THEN
4957!
4958!--                Thermal emission from plan canopy towards respective face
4959                   pcrad = sigma_sb * (pt(k,j,i) * exner(k))**4 * csf(1,icsf)
4960                   surfinlg(isurfsrc) = surfinlg(isurfsrc) + pcrad
4961!
4962!--                Remove the flux above + absorb LW from first pass from surfaces
4963                   asrc = facearea(surf(id, isurfsrc))
4964                   pcbinlw(ipcgb) = pcbinlw(ipcgb)                      &
4965                                    + (csf(1,icsf) * surfoutl(isurfsrc) & ! Absorb from first pass surf emit
4966                                       - pcrad)                         & ! Remove emitted heatflux
4967                                    * asrc
4968                ENDIF
4969             ENDIF
4970         ENDDO
4971
4972         pcbinsw(:) = pcbinswdir(:) + pcbinswdif(:)
4973     ENDIF
4974
4975     IF ( plant_lw_interact )  THEN
4976!
4977!--     Exchange incoming lw radiation from plant canopy
4978#if defined( __parallel )
4979        CALL MPI_Allreduce(MPI_IN_PLACE, surfinlg, nsurf, MPI_REAL, MPI_SUM, comm2d, ierr)
4980        IF ( ierr /= 0 )  THEN
4981           WRITE (9,*) 'Error MPI_Allreduce:', ierr
4982           FLUSH(9)
4983        ENDIF
4984        surfinl(:) = surfinl(:) + surfinlg(surfstart(myid)+1:surfstart(myid+1))
4985#else
4986        surfinl(:) = surfinl(:) + surfinlg(:)
4987#endif
4988     ENDIF
4989
4990     surfins = surfinswdir + surfinswdif
4991     surfinl = surfinl + surfinlwdif
4992     surfinsw = surfins
4993     surfinlw = surfinl
4994     surfoutsw = 0.0_wp
4995     surfoutlw = surfoutll
4996     surfemitlwl = surfoutll
4997
4998     IF ( .NOT.  surface_reflections )  THEN
4999!
5000!--     Set nrefsteps to 0 to disable reflections       
5001        nrefsteps = 0
5002        surfoutsl = albedo_surf * surfins
5003        surfoutll = (1._wp - emiss_surf) * surfinl
5004        surfoutsw = surfoutsw + surfoutsl
5005        surfoutlw = surfoutlw + surfoutll
5006     ENDIF
5007
5008!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5009!--     Next passes - reflections
5010!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5011     DO refstep = 1, nrefsteps
5012
5013         surfoutsl = albedo_surf * surfins
5014!--         for non-transparent surfaces, longwave albedo is 1 - emissivity
5015         surfoutll = (1._wp - emiss_surf) * surfinl
5016
5017#if defined( __parallel )
5018         CALL MPI_AllGatherv(surfoutsl, nsurfl, MPI_REAL, &
5019             surfouts, nsurfs, surfstart, MPI_REAL, comm2d, ierr)
5020         IF ( ierr /= 0 ) THEN
5021             WRITE(9,*) 'Error MPI_AllGatherv2:', ierr, SIZE(surfoutsl), nsurfl, &
5022                        SIZE(surfouts), nsurfs, surfstart
5023             FLUSH(9)
5024         ENDIF
5025
5026         CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, &
5027             surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr)
5028         IF ( ierr /= 0 ) THEN
5029             WRITE(9,*) 'Error MPI_AllGatherv3:', ierr, SIZE(surfoutll), nsurfl, &
5030                        SIZE(surfoutl), nsurfs, surfstart
5031             FLUSH(9)
5032         ENDIF
5033
5034#else
5035         surfouts = surfoutsl
5036         surfoutl = surfoutll
5037#endif
5038
5039!--         reset for next pass input
5040         surfins = 0._wp
5041         surfinl = 0._wp
5042
5043!--         reflected radiation
5044         DO isvf = 1, nsvfl
5045             isurf = svfsurf(1, isvf)
5046             isurfsrc = svfsurf(2, isvf)
5047             surfins(isurf) = surfins(isurf) + svf(1,isvf) * svf(2,isvf) * surfouts(isurfsrc)
5048             IF ( plant_lw_interact )  THEN
5049                surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc)
5050             ELSE
5051                surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)
5052             ENDIF
5053         ENDDO
5054!
5055!--      NOTE: PC absorbtion and MRT from reflected can both be done at once
5056!--      after all reflections if we do one more MPI_ALLGATHERV on surfout.
5057!--      Advantage: less local computation. Disadvantage: one more collective
5058!--      MPI call.
5059!
5060!--      Radiation absorbed by plant canopy
5061         DO  icsf = 1, ncsfl
5062             ipcgb = csfsurf(1, icsf)
5063             isurfsrc = csfsurf(2, icsf)
5064             IF ( isurfsrc == -1 )  CYCLE ! sky->face only in 1st pass, not here
5065!
5066!--          Calculate source surface area. If the `surf' array is removed
5067!--          before timestepping starts (future version), then asrc must be
5068!--          stored within `csf'
5069             asrc = facearea(surf(id, isurfsrc))
5070             pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * surfouts(isurfsrc) * asrc
5071             IF ( plant_lw_interact )  THEN
5072                pcbinlw(ipcgb) = pcbinlw(ipcgb) + csf(1,icsf) * surfoutl(isurfsrc) * asrc
5073             ENDIF
5074         ENDDO
5075!
5076!--      MRT reflected
5077         DO  imrtf = 1, nmrtf
5078            imrt = mrtfsurf(1, imrtf)
5079            isurfsrc = mrtfsurf(2, imrtf)
5080            mrtinsw(imrt) = mrtinsw(imrt) + mrtft(imrtf) * surfouts(isurfsrc)
5081            mrtinlw(imrt) = mrtinlw(imrt) + mrtf(imrtf) * surfoutl(isurfsrc)
5082         ENDDO
5083
5084         surfinsw = surfinsw  + surfins
5085         surfinlw = surfinlw  + surfinl
5086         surfoutsw = surfoutsw + surfoutsl
5087         surfoutlw = surfoutlw + surfoutll
5088
5089     ENDDO ! refstep
5090
5091!--  push heat flux absorbed by plant canopy to respective 3D arrays
5092     IF ( npcbl > 0 )  THEN
5093         pc_heating_rate(:,:,:) = 0.0_wp
5094         DO ipcgb = 1, npcbl
5095             j = pcbl(iy, ipcgb)
5096             i = pcbl(ix, ipcgb)
5097             k = pcbl(iz, ipcgb)
5098!
5099!--          Following expression equals former kk = k - nzb_s_inner(j,i)
5100             kk = k - get_topography_top_index_ji( j, i, 's' )  !- lad arrays are defined flat
5101             pc_heating_rate(kk, j, i) = (pcbinsw(ipcgb) + pcbinlw(ipcgb)) &
5102                 * pchf_prep(k) * pt(k, j, i) !-- = dT/dt
5103         ENDDO
5104
5105         IF ( humidity .AND. plant_canopy_transpiration ) THEN
5106!--          Calculation of plant canopy transpiration rate and correspondidng latent heat rate
5107             pc_transpiration_rate(:,:,:) = 0.0_wp
5108             pc_latent_rate(:,:,:) = 0.0_wp
5109             DO ipcgb = 1, npcbl
5110                 i = pcbl(ix, ipcgb)
5111                 j = pcbl(iy, ipcgb)
5112                 k = pcbl(iz, ipcgb)
5113                 kk = k - get_topography_top_index_ji( j, i, 's' )  !- lad arrays are defined flat
5114                 CALL pcm_calc_transpiration_rate( i, j, k, kk, pcbinsw(ipcgb), pcbinlw(ipcgb), &
5115                                                   pc_transpiration_rate(kk,j,i), pc_latent_rate(kk,j,i) )
5116              ENDDO
5117         ENDIF
5118     ENDIF
5119!
5120!--  Calculate black body MRT (after all reflections)
5121     IF ( nmrtbl > 0 )  THEN
5122        IF ( mrt_include_sw )  THEN
5123           mrt(:) = ((mrtinsw(:) + mrtinlw(:)) / sigma_sb) ** .25_wp
5124        ELSE
5125           mrt(:) = (mrtinlw(:) / sigma_sb) ** .25_wp
5126        ENDIF
5127     ENDIF
5128!
5129!--     Transfer radiation arrays required for energy balance to the respective data types
5130     DO  i = 1, nsurfl
5131        m  = surfl(5,i)
5132!
5133!--     (1) Urban surfaces
5134!--     upward-facing
5135        IF ( surfl(1,i) == iup_u )  THEN
5136           surf_usm_h%rad_sw_in(m)  = surfinsw(i)
5137           surf_usm_h%rad_sw_out(m) = surfoutsw(i)
5138           surf_usm_h%rad_lw_in(m)  = surfinlw(i)
5139           surf_usm_h%rad_lw_out(m) = surfoutlw(i)
5140           surf_usm_h%rad_net(m)    = surfinsw(i) - surfoutsw(i) +          &
5141                                      surfinlw(i) - surfoutlw(i)
5142           surf_usm_h%rad_net_l(m)  = surf_usm_h%rad_net(m)
5143!
5144!--     northward-facding
5145        ELSEIF ( surfl(1,i) == inorth_u )  THEN
5146           surf_usm_v(0)%rad_sw_in(m)  = surfinsw(i)
5147           surf_usm_v(0)%rad_sw_out(m) = surfoutsw(i)
5148           surf_usm_v(0)%rad_lw_in(m)  = surfinlw(i)
5149           surf_usm_v(0)%rad_lw_out(m) = surfoutlw(i)
5150           surf_usm_v(0)%rad_net(m)    = surfinsw(i) - surfoutsw(i) +       &
5151                                         surfinlw(i) - surfoutlw(i)
5152           surf_usm_v(0)%rad_net_l(m)  = surf_usm_v(0)%rad_net(m)
5153!
5154!--     southward-facding
5155        ELSEIF ( surfl(1,i) == isouth_u )  THEN
5156           surf_usm_v(1)%rad_sw_in(m)  = surfinsw(i)
5157           surf_usm_v(1)%rad_sw_out(m) = surfoutsw(i)
5158           surf_usm_v(1)%rad_lw_in(m)  = surfinlw(i)
5159           surf_usm_v(1)%rad_lw_out(m) = surfoutlw(i)
5160           surf_usm_v(1)%rad_net(m)    = surfinsw(i) - surfoutsw(i) +       &
5161                                         surfinlw(i) - surfoutlw(i)
5162           surf_usm_v(1)%rad_net_l(m)  = surf_usm_v(1)%rad_net(m)
5163!
5164!--     eastward-facing
5165        ELSEIF ( surfl(1,i) == ieast_u )  THEN
5166           surf_usm_v(2)%rad_sw_in(m)  = surfinsw(i)
5167           surf_usm_v(2)%rad_sw_out(m) = surfoutsw(i)
5168           surf_usm_v(2)%rad_lw_in(m)  = surfinlw(i)
5169           surf_usm_v(2)%rad_lw_out(m) = surfoutlw(i)
5170           surf_usm_v(2)%rad_net(m)    = surfinsw(i) - surfoutsw(i) +       &
5171                                         surfinlw(i) - surfoutlw(i)
5172           surf_usm_v(2)%rad_net_l(m)  = surf_usm_v(2)%rad_net(m)
5173!
5174!--     westward-facding
5175        ELSEIF ( surfl(1,i) == iwest_u )  THEN
5176           surf_usm_v(3)%rad_sw_in(m)  = surfinsw(i)
5177           surf_usm_v(3)%rad_sw_out(m) = surfoutsw(i)
5178           surf_usm_v(3)%rad_lw_in(m)  = surfinlw(i)
5179           surf_usm_v(3)%rad_lw_out(m) = surfoutlw(i)
5180           surf_usm_v(3)%rad_net(m)    = surfinsw(i) - surfoutsw(i) +       &
5181                                         surfinlw(i) - surfoutlw(i)
5182           surf_usm_v(3)%rad_net_l(m)  = surf_usm_v(3)%rad_net(m)
5183!
5184!--     (2) land surfaces
5185!--     upward-facing
5186        ELSEIF ( surfl(1,i) == iup_l )  THEN
5187           surf_lsm_h%rad_sw_in(m)  = surfinsw(i)
5188           surf_lsm_h%rad_sw_out(m) = surfoutsw(i)
5189           surf_lsm_h%rad_lw_in(m)  = surfinlw(i)
5190           surf_lsm_h%rad_lw_out(m) = surfoutlw(i)
5191           surf_lsm_h%rad_net(m)    = surfinsw(i) - surfoutsw(i) +          &
5192                                      surfinlw(i) - surfoutlw(i)
5193!
5194!--     northward-facding
5195        ELSEIF ( surfl(1,i) == inorth_l )  THEN
5196           surf_lsm_v(0)%rad_sw_in(m)  = surfinsw(i)
5197           surf_lsm_v(0)%rad_sw_out(m) = surfoutsw(i)
5198           surf_lsm_v(0)%rad_lw_in(m)  = surfinlw(i)
5199           surf_lsm_v(0)%rad_lw_out(m) = surfoutlw(i)
5200           surf_lsm_v(0)%rad_net(m)    = surfinsw(i) - surfoutsw(i) +       &
5201                                         surfinlw(i) - surfoutlw(i)
5202!
5203!--     southward-facding
5204        ELSEIF ( surfl(1,i) == isouth_l )  THEN
5205           surf_lsm_v(1)%rad_sw_in(m)  = surfinsw(i)
5206           surf_lsm_v(1)%rad_sw_out(m) = surfoutsw(i)
5207           surf_lsm_v(1)%rad_lw_in(m)  = surfinlw(i)
5208           surf_lsm_v(1)%rad_lw_out(m) = surfoutlw(i)
5209           surf_lsm_v(1)%rad_net(m)    = surfinsw(i) - surfoutsw(i) +       &
5210                                         surfinlw(i) - surfoutlw(i)
5211!
5212!--     eastward-facing
5213        ELSEIF ( surfl(1,i) == ieast_l )  THEN
5214           surf_lsm_v(2)%rad_sw_in(m)  = surfinsw(i)
5215           surf_lsm_v(2)%rad_sw_out(m) = surfoutsw(i)
5216           surf_lsm_v(2)%rad_lw_in(m)  = surfinlw(i)
5217           surf_lsm_v(2)%rad_lw_out(m) = surfoutlw(i)
5218           surf_lsm_v(2)%rad_net(m)    = surfinsw(i) - surfoutsw(i) +       &
5219                                         surfinlw(i) - surfoutlw(i)
5220!
5221!--     westward-facing
5222        ELSEIF ( surfl(1,i) == iwest_l )  THEN
5223           surf_lsm_v(3)%rad_sw_in(m)  = surfinsw(i)
5224           surf_lsm_v(3)%rad_sw_out(m) = surfoutsw(i)
5225           surf_lsm_v(3)%rad_lw_in(m)  = surfinlw(i)
5226           surf_lsm_v(3)%rad_lw_out(m) = surfoutlw(i)
5227           surf_lsm_v(3)%rad_net(m)    = surfinsw(i) - surfoutsw(i) +       &
5228                                         surfinlw(i) - surfoutlw(i)
5229        ENDIF
5230
5231     ENDDO
5232
5233     DO  m = 1, surf_usm_h%ns
5234        surf_usm_h%surfhf(m) = surf_usm_h%rad_sw_in(m)  +                   &
5235                               surf_usm_h%rad_lw_in(m)  -                   &
5236                               surf_usm_h%rad_sw_out(m) -                   &
5237                               surf_usm_h%rad_lw_out(m)
5238     ENDDO
5239     DO  m = 1, surf_lsm_h%ns
5240        surf_lsm_h%surfhf(m) = surf_lsm_h%rad_sw_in(m)  +                   &
5241                               surf_lsm_h%rad_lw_in(m)  -                   &
5242                               surf_lsm_h%rad_sw_out(m) -                   &
5243                               surf_lsm_h%rad_lw_out(m)
5244     ENDDO
5245
5246     DO  l = 0, 3
5247!--     urban
5248        DO  m = 1, surf_usm_v(l)%ns
5249           surf_usm_v(l)%surfhf(m) = surf_usm_v(l)%rad_sw_in(m)  +          &
5250                                     surf_usm_v(l)%rad_lw_in(m)  -          &
5251                                     surf_usm_v(l)%rad_sw_out(m) -          &
5252                                     surf_usm_v(l)%rad_lw_out(m)
5253        ENDDO
5254!--     land
5255        DO  m = 1, surf_lsm_v(l)%ns
5256           surf_lsm_v(l)%surfhf(m) = surf_lsm_v(l)%rad_sw_in(m)  +          &
5257                                     surf_lsm_v(l)%rad_lw_in(m)  -          &
5258                                     surf_lsm_v(l)%rad_sw_out(m) -          &
5259                                     surf_lsm_v(l)%rad_lw_out(m)
5260
5261        ENDDO
5262     ENDDO
5263!
5264!--  Calculate the average temperature, albedo, and emissivity for urban/land
5265!--  domain when using average_radiation in the respective radiation model
5266
5267!--  calculate horizontal area
5268! !!! ATTENTION!!! uniform grid is assumed here
5269     area_hor = (nx+1) * (ny+1) * dx * dy
5270!
5271!--  absorbed/received SW & LW and emitted LW energy of all physical
5272!--  surfaces (land and urban) in local processor
5273     pinswl = 0._wp
5274     pinlwl = 0._wp
5275     pabsswl = 0._wp
5276     pabslwl = 0._wp
5277     pemitlwl = 0._wp
5278     emiss_sum_surfl = 0._wp
5279     area_surfl = 0._wp
5280     DO  i = 1, nsurfl
5281        d = surfl(id, i)
5282!--  received SW & LW
5283        pinswl = pinswl + (surfinswdir(i) + surfinswdif(i)) * facearea(d)
5284        pinlwl = pinlwl + surfinlwdif(i) * facearea(d)
5285!--   absorbed SW & LW
5286        pabsswl = pabsswl + (1._wp - albedo_surf(i)) *                   &
5287                                                surfinsw(i) * facearea(d)
5288        pabslwl = pabslwl + emiss_surf(i) * surfinlw(i) * facearea(d)
5289!--   emitted LW
5290        pemitlwl = pemitlwl + surfemitlwl(i) * facearea(d)
5291!--   emissivity and area sum
5292        emiss_sum_surfl = emiss_sum_surfl + emiss_surf(i) * facearea(d)
5293        area_surfl = area_surfl + facearea(d)
5294     END DO
5295!
5296!--  add the absorbed SW energy by plant canopy
5297     IF ( npcbl > 0 )  THEN
5298        pabsswl = pabsswl + SUM(pcbinsw)
5299        pabslwl = pabslwl + SUM(pcbinlw)
5300        pinswl = pinswl + SUM(pcbinswdir) + SUM(pcbinswdif)
5301     ENDIF
5302!
5303!--  gather all rad flux energy in all processors
5304#if defined( __parallel )
5305     CALL MPI_ALLREDUCE( pinswl, pinsw, 1, MPI_REAL, MPI_SUM, comm2d, ierr)
5306     IF ( ierr /= 0 ) THEN
5307         WRITE(9,*) 'Error MPI_AllReduce5:', ierr, pinswl, pinsw
5308         FLUSH(9)
5309     ENDIF
5310     CALL MPI_ALLREDUCE( pinlwl, pinlw, 1, MPI_REAL, MPI_SUM, comm2d, ierr)
5311     IF ( ierr /= 0 ) THEN
5312         WRITE(9,*) 'Error MPI_AllReduce6:', ierr, pinlwl, pinlw
5313         FLUSH(9)
5314     ENDIF
5315     CALL MPI_ALLREDUCE( pabsswl, pabssw, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
5316     IF ( ierr /= 0 ) THEN
5317         WRITE(9,*) 'Error MPI_AllReduce7:', ierr, pabsswl, pabssw
5318         FLUSH(9)
5319     ENDIF
5320     CALL MPI_ALLREDUCE( pabslwl, pabslw, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
5321     IF ( ierr /= 0 ) THEN
5322         WRITE(9,*) 'Error MPI_AllReduce8:', ierr, pabslwl, pabslw
5323         FLUSH(9)
5324     ENDIF
5325     CALL MPI_ALLREDUCE( pemitlwl, pemitlw, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
5326     IF ( ierr /= 0 ) THEN
5327         WRITE(9,*) 'Error MPI_AllReduce8:', ierr, pemitlwl, pemitlw
5328         FLUSH(9)
5329     ENDIF
5330     CALL MPI_ALLREDUCE( emiss_sum_surfl, emiss_sum_surf, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
5331     IF ( ierr /= 0 ) THEN
5332         WRITE(9,*) 'Error MPI_AllReduce9:', ierr, emiss_sum_surfl, emiss_sum_surf
5333         FLUSH(9)
5334     ENDIF
5335     CALL MPI_ALLREDUCE( area_surfl, area_surf, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
5336     IF ( ierr /= 0 ) THEN
5337         WRITE(9,*) 'Error MPI_AllReduce10:', ierr, area_surfl, area_surf
5338         FLUSH(9)
5339     ENDIF
5340#else
5341     pinsw = pinswl
5342     pinlw = pinlwl
5343     pabssw = pabsswl
5344     pabslw = pabslwl
5345     pemitlw = pemitlwl
5346     emiss_sum_surf = emiss_sum_surfl
5347     area_surf = area_surfl
5348#endif
5349
5350!--  (1) albedo
5351     IF ( pinsw /= 0.0_wp )  &
5352          albedo_urb = (pinsw - pabssw) / pinsw
5353!--  (2) average emmsivity
5354     IF ( area_surf /= 0.0_wp ) &
5355          emissivity_urb = emiss_sum_surf / area_surf
5356!
5357!--  Temporally comment out calculation of effective radiative temperature.
5358!--  See below for more explanation.
5359!--  (3) temperature
5360!--   first we calculate an effective horizontal area to account for
5361!--   the effect of vertical surfaces (which contributes to LW emission)
5362!--   We simply use the ratio of the total LW to the incoming LW flux
5363      area_hor = pinlw/rad_lw_in_diff(nyn,nxl)
5364      t_rad_urb = ( (pemitlw - pabslw + emissivity_urb*pinlw) / &
5365           (emissivity_urb*sigma_sb * area_hor) )**0.25_wp
5366
5367    CONTAINS
5368
5369!------------------------------------------------------------------------------!
5370!> Calculates radiation absorbed by box with given size and LAD.
5371!>
5372!> Simulates resol**2 rays (by equally spacing a bounding horizontal square
5373!> conatining all possible rays that would cross the box) and calculates
5374!> average transparency per ray. Returns fraction of absorbed radiation flux
5375!> and area for which this fraction is effective.
5376!------------------------------------------------------------------------------!
5377    PURE SUBROUTINE box_absorb(boxsize, resol, dens, uvec, area, absorb)
5378       IMPLICIT NONE
5379
5380       REAL(wp), DIMENSION(3), INTENT(in) :: &
5381            boxsize, &      !< z, y, x size of box in m
5382            uvec            !< z, y, x unit vector of incoming flux
5383       INTEGER(iwp), INTENT(in) :: &
5384            resol           !< No. of rays in x and y dimensions
5385       REAL(wp), INTENT(in) :: &
5386            dens            !< box density (e.g. Leaf Area Density)
5387       REAL(wp), INTENT(out) :: &
5388            area, &         !< horizontal area for flux absorbtion
5389            absorb          !< fraction of absorbed flux
5390       REAL(wp) :: &
5391            xshift, yshift, &
5392            xmin, xmax, ymin, ymax, &
5393            xorig, yorig, &
5394            dx1, dy1, dz1, dx2, dy2, dz2, &
5395            crdist, &
5396            transp
5397       INTEGER(iwp) :: &
5398            i, j
5399
5400       xshift = uvec(3) / uvec(1) * boxsize(1)
5401       xmin = min(0._wp, -xshift)
5402       xmax = boxsize(3) + max(0._wp, -xshift)
5403       yshift = uvec(2) / uvec(1) * boxsize(1)
5404       ymin = min(0._wp, -yshift)
5405       ymax = boxsize(2) + max(0._wp, -yshift)
5406
5407       transp = 0._wp
5408       DO i = 1, resol
5409          xorig = xmin + (xmax-xmin) * (i-.5_wp) / resol
5410          DO j = 1, resol
5411             yorig = ymin + (ymax-ymin) * (j-.5_wp) / resol
5412
5413             dz1 = 0._wp
5414             dz2 = boxsize(1)/uvec(1)
5415
5416             IF ( uvec(2) > 0._wp )  THEN
5417                dy1 = -yorig             / uvec(2) !< crossing with y=0
5418                dy2 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2)
5419             ELSE !uvec(2)==0
5420                dy1 = -huge(1._wp)
5421                dy2 = huge(1._wp)
5422             ENDIF
5423
5424             IF ( uvec(3) > 0._wp )  THEN
5425                dx1 = -xorig             / uvec(3) !< crossing with x=0
5426                dx2 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3)
5427             ELSE !uvec(3)==0
5428                dx1 = -huge(1._wp)
5429                dx2 = huge(1._wp)
5430             ENDIF
5431
5432             crdist = max(0._wp, (min(dz2, dy2, dx2) - max(dz1, dy1, dx1)))
5433             transp = transp + exp(-ext_coef * dens * crdist)
5434          ENDDO
5435       ENDDO
5436       transp = transp / resol**2
5437       area = (boxsize(3)+xshift)*(boxsize(2)+yshift)
5438       absorb = 1._wp - transp
5439
5440    END SUBROUTINE box_absorb
5441
5442!------------------------------------------------------------------------------!
5443! Description:
5444! ------------
5445!> This subroutine splits direct and diffusion dw radiation
5446!> It sould not be called in case the radiation model already does it
5447!> It follows <CITATION>
5448!------------------------------------------------------------------------------!
5449    SUBROUTINE calc_diffusion_radiation 
5450   
5451        REAL(wp), PARAMETER                          :: lowest_solarUp = 0.1_wp  !< limit the sun elevation to protect stability of the calculation
5452        INTEGER(iwp)                                 :: i, j
5453        REAL(wp)                                     ::  year_angle              !< angle
5454        REAL(wp)                                     ::  etr                     !< extraterestrial radiation
5455        REAL(wp)                                     ::  corrected_solarUp       !< corrected solar up radiation
5456        REAL(wp)                                     ::  horizontalETR           !< horizontal extraterestrial radiation
5457        REAL(wp)                                     ::  clearnessIndex          !< clearness index
5458        REAL(wp)                                     ::  diff_frac               !< diffusion fraction of the radiation
5459
5460       
5461!--     Calculate current day and time based on the initial values and simulation time
5462        year_angle = ( (day_of_year_init * 86400) + time_utc_init              &
5463                        + time_since_reference_point )  * d_seconds_year       &
5464                        * 2.0_wp * pi
5465       
5466        etr = solar_constant * (1.00011_wp +                                   &
5467                          0.034221_wp * cos(year_angle) +                      &
5468                          0.001280_wp * sin(year_angle) +                      &
5469                          0.000719_wp * cos(2.0_wp * year_angle) +             &
5470                          0.000077_wp * sin(2.0_wp * year_angle))
5471       
5472!--   
5473!--     Under a very low angle, we keep extraterestrial radiation at
5474!--     the last small value, therefore the clearness index will be pushed
5475!--     towards 0 while keeping full continuity.
5476!--   
5477        IF ( zenith(0) <= lowest_solarUp )  THEN
5478            corrected_solarUp = lowest_solarUp
5479        ELSE
5480            corrected_solarUp = zenith(0)
5481        ENDIF
5482       
5483        horizontalETR = etr * corrected_solarUp
5484       
5485        DO i = nxl, nxr
5486            DO j = nys, nyn
5487                clearnessIndex = rad_sw_in(0,j,i) / horizontalETR
5488                diff_frac = 1.0_wp / (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex))
5489                rad_sw_in_diff(j,i) = rad_sw_in(0,j,i) * diff_frac
5490                rad_sw_in_dir(j,i)  = rad_sw_in(0,j,i) * (1.0_wp - diff_frac)
5491                rad_lw_in_diff(j,i) = rad_lw_in(0,j,i)
5492            ENDDO
5493        ENDDO
5494       
5495    END SUBROUTINE calc_diffusion_radiation
5496
5497
5498 END SUBROUTINE radiation_interaction
5499   
5500!------------------------------------------------------------------------------!
5501! Description:
5502! ------------
5503!> This subroutine initializes structures needed for radiative transfer
5504!> model. This model calculates transformation processes of the
5505!> radiation inside urban and land canopy layer. The module includes also
5506!> the interaction of the radiation with the resolved plant canopy.
5507!>
5508!> For more info. see Resler et al. 2017
5509!>
5510!> The new version 2.0 was radically rewriten, the discretization scheme
5511!> has been changed. This new version significantly improves effectivity
5512!> of the paralelization and the scalability of the model.
5513!>
5514!------------------------------------------------------------------------------!
5515    SUBROUTINE radiation_interaction_init
5516
5517       USE control_parameters,                                                 &
5518           ONLY:  dz_stretch_level_start
5519           
5520       USE netcdf_data_input_mod,                                              &
5521           ONLY:  leaf_area_density_f
5522
5523       USE plant_canopy_model_mod,                                             &
5524           ONLY:  pch_index, lad_s
5525
5526       IMPLICIT NONE
5527
5528       INTEGER(iwp) :: i, j, k, l, m, d
5529       INTEGER(iwp) :: k_topo     !< vertical index indicating topography top for given (j,i)
5530       INTEGER(iwp) :: nzptl, nzubl, nzutl, isurf, ipcgb, imrt
5531       REAL(wp)     :: mrl
5532#if defined( __parallel )
5533       INTEGER(iwp), DIMENSION(:), POINTER       ::  gridsurf_rma   !< fortran pointer, but lower bounds are 1
5534       TYPE(c_ptr)                               ::  gridsurf_rma_p !< allocated c pointer
5535       INTEGER(iwp)                              ::  minfo          !< MPI RMA window info handle
5536#endif
5537
5538!
5539!--     precalculate face areas for different face directions using normal vector
5540        DO d = 0, nsurf_type
5541            facearea(d) = 1._wp
5542            IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx
5543            IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy
5544            IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz(1)
5545        ENDDO
5546!
5547!--    Find nzub, nzut, nzu via wall_flag_0 array (nzb_s_inner will be
5548!--    removed later). The following contruct finds the lowest / largest index
5549!--    for any upward-facing wall (see bit 12).
5550       nzubl = MINVAL( get_topography_top_index( 's' ) )
5551       nzutl = MAXVAL( get_topography_top_index( 's' ) )
5552
5553       nzubl = MAX( nzubl, nzb )
5554
5555       IF ( plant_canopy )  THEN
5556!--        allocate needed arrays
5557           ALLOCATE( pct(nys:nyn,nxl:nxr) )
5558           ALLOCATE( pch(nys:nyn,nxl:nxr) )
5559
5560!--        calculate plant canopy height
5561           npcbl = 0
5562           pct   = 0
5563           pch   = 0
5564           DO i = nxl, nxr
5565               DO j = nys, nyn
5566!
5567!--                Find topography top index
5568                   k_topo = get_topography_top_index_ji( j, i, 's' )
5569
5570                   DO k = nzt+1, 0, -1
5571                       IF ( lad_s(k,j,i) /= 0.0_wp )  THEN
5572!--                        we are at the top of the pcs
5573                           pct(j,i) = k + k_topo
5574                           pch(j,i) = k
5575                           npcbl = npcbl + pch(j,i)
5576                           EXIT
5577                       ENDIF
5578                   ENDDO
5579               ENDDO
5580           ENDDO
5581
5582           nzutl = MAX( nzutl, MAXVAL( pct ) )
5583           nzptl = MAXVAL( pct )
5584!--        code of plant canopy model uses parameter pch_index
5585!--        we need to setup it here to right value
5586!--        (pch_index, lad_s and other arrays in PCM are defined flat)
5587           pch_index = MERGE( leaf_area_density_f%nz - 1, MAXVAL( pch ),       &
5588                              leaf_area_density_f%from_file )
5589
5590           prototype_lad = MAXVAL( lad_s ) * .9_wp  !< better be *1.0 if lad is either 0 or maxval(lad) everywhere
5591           IF ( prototype_lad <= 0._wp ) prototype_lad = .3_wp
5592           !WRITE(message_string, '(a,f6.3)') 'Precomputing effective box optical ' &
5593           !    // 'depth using prototype leaf area density = ', prototype_lad
5594           !CALL message('usm_init_urban_surface', 'PA0520', 0, 0, -1, 6, 0)
5595       ENDIF
5596
5597       nzutl = MIN( nzutl + nzut_free, nzt )
5598
5599#if defined( __parallel )
5600       CALL MPI_AllReduce(nzubl, nzub, 1, MPI_INTEGER, MPI_MIN, comm2d, ierr )
5601       IF ( ierr /= 0 ) THEN
5602           WRITE(9,*) 'Error MPI_AllReduce11:', ierr, nzubl, nzub
5603           FLUSH(9)
5604       ENDIF
5605       CALL MPI_AllReduce(nzutl, nzut, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr )
5606       IF ( ierr /= 0 ) THEN
5607           WRITE(9,*) 'Error MPI_AllReduce12:', ierr, nzutl, nzut
5608           FLUSH(9)
5609       ENDIF
5610       CALL MPI_AllReduce(nzptl, nzpt, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr )
5611       IF ( ierr /= 0 ) THEN
5612           WRITE(9,*) 'Error MPI_AllReduce13:', ierr, nzptl, nzpt
5613           FLUSH(9)
5614       ENDIF
5615#else
5616       nzub = nzubl
5617       nzut = nzutl
5618       nzpt = nzptl
5619#endif
5620!
5621!--    Stretching (non-uniform grid spacing) is not considered in the radiation
5622!--    model. Therefore, vertical stretching has to be applied above the area
5623!--    where the parts of the radiation model which assume constant grid spacing
5624!--    are active. ABS (...) is required because the default value of
5625!--    dz_stretch_level_start is -9999999.9_wp (negative).
5626       IF ( ABS( dz_stretch_level_start(1) ) <= zw(nzut) ) THEN
5627          WRITE( message_string, * ) 'The lowest level where vertical ',       &
5628                                     'stretching is applied have to be ',      &
5629                                     'greater than ', zw(nzut)
5630          CALL message( 'radiation_interaction_init', 'PA0496', 1, 2, 0, 6, 0 )
5631       ENDIF 
5632!
5633!--    global number of urban and plant layers
5634       nzu = nzut - nzub + 1
5635       nzp = nzpt - nzub + 1
5636!
5637!--    check max_raytracing_dist relative to urban surface layer height
5638       mrl = 2.0_wp * nzu * dz(1)
5639!--    set max_raytracing_dist to double the urban surface layer height, if not set
5640       IF ( max_raytracing_dist == -999.0_wp ) THEN
5641          max_raytracing_dist = mrl
5642       ENDIF
5643!--    check if max_raytracing_dist set too low (here we only warn the user. Other
5644!      option is to correct the value again to double the urban surface layer height)
5645       IF ( max_raytracing_dist  <  mrl ) THEN
5646          WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist is set less than ', &
5647               'double the urban surface layer height, i.e. ', mrl
5648          CALL message('radiation_interaction_init', 'PA0521', 0, 0, -1, 6, 0)
5649       ENDIF
5650!        IF ( max_raytracing_dist <= mrl ) THEN
5651!           IF ( max_raytracing_dist /= -999.0_wp ) THEN
5652! !--          max_raytracing_dist too low
5653!              WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist too low, ' &
5654!                    // 'override to value ', mrl
5655!              CALL message('radiation_interaction_init', 'PA0521', 0, 0, -1, 6, 0)
5656!           ENDIF
5657!           max_raytracing_dist = mrl
5658!        ENDIF
5659!
5660!--    allocate urban surfaces grid
5661!--    calc number of surfaces in local proc
5662       CALL location_message( '    calculation of indices for surfaces', .TRUE. )
5663       nsurfl = 0
5664!
5665!--    Number of horizontal surfaces including land- and roof surfaces in both USM and LSM. Note that
5666!--    All horizontal surface elements are already counted in surface_mod.
5667       startland = 1
5668       nsurfl    = surf_usm_h%ns + surf_lsm_h%ns
5669       endland   = nsurfl
5670       nlands    = endland - startland + 1
5671
5672!
5673!--    Number of vertical surfaces in both USM and LSM. Note that all vertical surface elements are
5674!--    already counted in surface_mod.
5675       startwall = nsurfl+1
5676       DO  i = 0,3
5677          nsurfl = nsurfl + surf_usm_v(i)%ns + surf_lsm_v(i)%ns
5678       ENDDO
5679       endwall = nsurfl
5680       nwalls  = endwall - startwall + 1
5681
5682!--    fill gridpcbl and pcbl
5683       IF ( npcbl > 0 )  THEN
5684           ALLOCATE( pcbl(iz:ix, 1:npcbl) )
5685           ALLOCATE( gridpcbl(nzub:nzpt,nys:nyn,nxl:nxr) )
5686           pcbl = -1
5687           gridpcbl(:,:,:) = 0
5688           ipcgb = 0
5689           DO i = nxl, nxr
5690               DO j = nys, nyn
5691!
5692!--                Find topography top index
5693                   k_topo = get_topography_top_index_ji( j, i, 's' )
5694
5695                   DO k = k_topo + 1, pct(j,i)
5696                       ipcgb = ipcgb + 1
5697                       gridpcbl(k,j,i) = ipcgb
5698                       pcbl(:,ipcgb) = (/ k, j, i /)
5699                   ENDDO
5700               ENDDO
5701           ENDDO
5702           ALLOCATE( pcbinsw( 1:npcbl ) )
5703           ALLOCATE( pcbinswdir( 1:npcbl ) )
5704           ALLOCATE( pcbinswdif( 1:npcbl ) )
5705           ALLOCATE( pcbinlw( 1:npcbl ) )
5706       ENDIF
5707
5708!--    fill surfl (the ordering of local surfaces given by the following
5709!--    cycles must not be altered, certain file input routines may depend
5710!--    on it)
5711       ALLOCATE(surfl_l(5*nsurfl))  ! is it necessary to allocate it with (5,nsurfl)?
5712       surfl(1:5,1:nsurfl) => surfl_l(1:5*nsurfl)
5713       isurf = 0
5714       IF ( rad_angular_discretization )  THEN
5715!
5716!--       Allocate and fill the reverse indexing array gridsurf
5717#if defined( __parallel )
5718!
5719!--       raytrace_mpi_rma is asserted
5720
5721          CALL MPI_Info_create(minfo, ierr)
5722          IF ( ierr /= 0 ) THEN
5723              WRITE(9,*) 'Error MPI_Info_create1:', ierr
5724              FLUSH(9)
5725          ENDIF
5726          CALL MPI_Info_set(minfo, 'accumulate_ordering', '', ierr)
5727          IF ( ierr /= 0 ) THEN
5728              WRITE(9,*) 'Error MPI_Info_set1:', ierr
5729              FLUSH(9)
5730          ENDIF
5731          CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr)
5732          IF ( ierr /= 0 ) THEN
5733              WRITE(9,*) 'Error MPI_Info_set2:', ierr
5734              FLUSH(9)
5735          ENDIF
5736          CALL MPI_Info_set(minfo, 'same_size', 'true', ierr)
5737          IF ( ierr /= 0 ) THEN
5738              WRITE(9,*) 'Error MPI_Info_set3:', ierr
5739              FLUSH(9)
5740          ENDIF
5741          CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr)
5742          IF ( ierr /= 0 ) THEN
5743              WRITE(9,*) 'Error MPI_Info_set4:', ierr
5744              FLUSH(9)
5745          ENDIF
5746
5747          CALL MPI_Win_allocate(INT(STORAGE_SIZE(1_iwp)/8*nsurf_type_u*nzu*nny*nnx, &
5748                                    kind=MPI_ADDRESS_KIND), STORAGE_SIZE(1_iwp)/8,  &
5749                                minfo, comm2d, gridsurf_rma_p, win_gridsurf, ierr)
5750          IF ( ierr /= 0 ) THEN
5751              WRITE(9,*) 'Error MPI_Win_allocate1:', ierr, &
5752                 INT(STORAGE_SIZE(1_iwp)/8*nsurf_type_u*nzu*nny*nnx,kind=MPI_ADDRESS_KIND), &
5753                 STORAGE_SIZE(1_iwp)/8, win_gridsurf
5754              FLUSH(9)
5755          ENDIF
5756
5757          CALL MPI_Info_free(minfo, ierr)
5758          IF ( ierr /= 0 ) THEN
5759              WRITE(9,*) 'Error MPI_Info_free1:', ierr
5760              FLUSH(9)
5761          ENDIF
5762
5763!
5764!--       On Intel compilers, calling c_f_pointer to transform a C pointer
5765!--       directly to a multi-dimensional Fotran pointer leads to strange
5766!--       errors on dimension boundaries. However, transforming to a 1D
5767!--       pointer and then redirecting a multidimensional pointer to it works
5768!--       fine.
5769          CALL c_f_pointer(gridsurf_rma_p, gridsurf_rma, (/ nsurf_type_u*nzu*nny*nnx /))
5770          gridsurf(0:nsurf_type_u-1, nzub:nzut, nys:nyn, nxl:nxr) =>                &
5771                     gridsurf_rma(1:nsurf_type_u*nzu*nny*nnx)
5772#else
5773          ALLOCATE(gridsurf(0:nsurf_type_u-1,nzub:nzut,nys:nyn,nxl:nxr) )
5774#endif
5775          gridsurf(:,:,:,:) = -999
5776       ENDIF
5777
5778!--    add horizontal surface elements (land and urban surfaces)
5779!--    TODO: add urban overhanging surfaces (idown_u)
5780       DO i = nxl, nxr
5781           DO j = nys, nyn
5782              DO  m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
5783                 k = surf_usm_h%k(m)
5784                 isurf = isurf + 1
5785                 surfl(:,isurf) = (/iup_u,k,j,i,m/)
5786                 IF ( rad_angular_discretization ) THEN
5787                    gridsurf(iup_u,k,j,i) = isurf
5788                 ENDIF
5789              ENDDO
5790
5791              DO  m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
5792                 k = surf_lsm_h%k(m)
5793                 isurf = isurf + 1
5794                 surfl(:,isurf) = (/iup_l,k,j,i,m/)
5795                 IF ( rad_angular_discretization ) THEN
5796                    gridsurf(iup_u,k,j,i) = isurf
5797                 ENDIF
5798              ENDDO
5799
5800           ENDDO
5801       ENDDO
5802
5803!--    add vertical surface elements (land and urban surfaces)
5804!--    TODO: remove the hard coding of l = 0 to l = idirection
5805       DO i = nxl, nxr
5806           DO j = nys, nyn
5807              l = 0
5808              DO  m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
5809                 k = surf_usm_v(l)%k(m)
5810                 isurf = isurf + 1
5811                 surfl(:,isurf) = (/inorth_u,k,j,i,m/)
5812                 IF ( rad_angular_discretization ) THEN
5813                    gridsurf(inorth_u,k,j,i) = isurf
5814                 ENDIF
5815              ENDDO
5816              DO  m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
5817                 k = surf_lsm_v(l)%k(m)
5818                 isurf = isurf + 1
5819                 surfl(:,isurf) = (/inorth_l,k,j,i,m/)
5820                 IF ( rad_angular_discretization ) THEN
5821                    gridsurf(inorth_u,k,j,i) = isurf
5822                 ENDIF
5823              ENDDO
5824
5825              l = 1
5826              DO  m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
5827                 k = surf_usm_v(l)%k(m)
5828                 isurf = isurf + 1
5829                 surfl(:,isurf) = (/isouth_u,k,j,i,m/)
5830                 IF ( rad_angular_discretization ) THEN
5831                    gridsurf(isouth_u,k,j,i) = isurf
5832                 ENDIF
5833              ENDDO
5834              DO  m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
5835                 k = surf_lsm_v(l)%k(m)
5836                 isurf = isurf + 1
5837                 surfl(:,isurf) = (/isouth_l,k,j,i,m/)
5838                 IF ( rad_angular_discretization ) THEN
5839                    gridsurf(isouth_u,k,j,i) = isurf
5840                 ENDIF
5841              ENDDO
5842
5843              l = 2
5844              DO  m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
5845                 k = surf_usm_v(l)%k(m)
5846                 isurf = isurf + 1
5847                 surfl(:,isurf) = (/ieast_u,k,j,i,m/)
5848                 IF ( rad_angular_discretization ) THEN
5849                    gridsurf(ieast_u,k,j,i) = isurf
5850                 ENDIF
5851              ENDDO
5852              DO  m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
5853                 k = surf_lsm_v(l)%k(m)
5854                 isurf = isurf + 1
5855                 surfl(:,isurf) = (/ieast_l,k,j,i,m/)
5856                 IF ( rad_angular_discretization ) THEN
5857                    gridsurf(ieast_u,k,j,i) = isurf
5858                 ENDIF
5859              ENDDO
5860
5861              l = 3
5862              DO  m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
5863                 k = surf_usm_v(l)%k(m)
5864                 isurf = isurf + 1
5865                 surfl(:,isurf) = (/iwest_u,k,j,i,m/)
5866                 IF ( rad_angular_discretization ) THEN
5867                    gridsurf(iwest_u,k,j,i) = isurf
5868                 ENDIF
5869              ENDDO
5870              DO  m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
5871                 k = surf_lsm_v(l)%k(m)
5872                 isurf = isurf + 1
5873                 surfl(:,isurf) = (/iwest_l,k,j,i,m/)
5874                 IF ( rad_angular_discretization ) THEN
5875                    gridsurf(iwest_u,k,j,i) = isurf
5876                 ENDIF
5877              ENDDO
5878           ENDDO
5879       ENDDO
5880!
5881!--    Add local MRT boxes for specified number of levels
5882       nmrtbl = 0
5883       IF ( mrt_nlevels > 0 )  THEN
5884          DO  i = nxl, nxr
5885             DO  j = nys, nyn
5886                DO  m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
5887!
5888!--                Skip roof if requested
5889                   IF ( mrt_skip_roof  .AND.  surf_usm_h%isroof_surf(m) )  CYCLE
5890!
5891!--                Cycle over specified no of levels
5892                   nmrtbl = nmrtbl + mrt_nlevels
5893                ENDDO
5894!
5895!--             Dtto for LSM
5896                DO  m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
5897                   nmrtbl = nmrtbl + mrt_nlevels
5898                ENDDO
5899             ENDDO
5900          ENDDO
5901
5902          ALLOCATE( mrtbl(iz:ix,nmrtbl), mrtsky(nmrtbl), mrtskyt(nmrtbl), &
5903                    mrtinsw(nmrtbl), mrtinlw(nmrtbl), mrt(nmrtbl) )
5904
5905          imrt = 0
5906          DO  i = nxl, nxr
5907             DO  j = nys, nyn
5908                DO  m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
5909!
5910!--                Skip roof if requested
5911                   IF ( mrt_skip_roof  .AND.  surf_usm_h%isroof_surf(m) )  CYCLE
5912!
5913!--                Cycle over specified no of levels
5914                   l = surf_usm_h%k(m)
5915                   DO  k = l, l + mrt_nlevels - 1
5916                      imrt = imrt + 1
5917                      mrtbl(:,imrt) = (/k,j,i/)
5918                   ENDDO
5919                ENDDO
5920!
5921!--             Dtto for LSM
5922                DO  m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
5923                   l = surf_lsm_h%k(m)
5924                   DO  k = l, l + mrt_nlevels - 1
5925                      imrt = imrt + 1
5926                      mrtbl(:,imrt) = (/k,j,i/)
5927                   ENDDO
5928                ENDDO
5929             ENDDO
5930          ENDDO
5931       ENDIF
5932
5933!
5934!--    broadband albedo of the land, roof and wall surface
5935!--    for domain border and sky set artifically to 1.0
5936!--    what allows us to calculate heat flux leaving over
5937!--    side and top borders of the domain
5938       ALLOCATE ( albedo_surf(nsurfl) )
5939       albedo_surf = 1.0_wp
5940!
5941!--    Also allocate further array for emissivity with identical order of
5942!--    surface elements as radiation arrays.
5943       ALLOCATE ( emiss_surf(nsurfl)  )
5944
5945
5946!
5947!--    global array surf of indices of surfaces and displacement index array surfstart
5948       ALLOCATE(nsurfs(0:numprocs-1))
5949
5950#if defined( __parallel )
5951       CALL MPI_Allgather(nsurfl,1,MPI_INTEGER,nsurfs,1,MPI_INTEGER,comm2d,ierr)
5952       IF ( ierr /= 0 ) THEN
5953         WRITE(9,*) 'Error MPI_AllGather1:', ierr, nsurfl, nsurfs
5954         FLUSH(9)
5955     ENDIF
5956
5957#else
5958       nsurfs(0) = nsurfl
5959#endif
5960       ALLOCATE(surfstart(0:numprocs))
5961       k = 0
5962       DO i=0,numprocs-1
5963           surfstart(i) = k
5964           k = k+nsurfs(i)
5965       ENDDO
5966       surfstart(numprocs) = k
5967       nsurf = k
5968       ALLOCATE(surf_l(5*nsurf))
5969       surf(1:5,1:nsurf) => surf_l(1:5*nsurf)
5970
5971#if defined( __parallel )
5972       CALL MPI_AllGatherv(surfl_l, nsurfl*5, MPI_INTEGER, surf_l, nsurfs*5, &
5973           surfstart(0:numprocs-1)*5, MPI_INTEGER, comm2d, ierr)
5974       IF ( ierr /= 0 ) THEN
5975           WRITE(9,*) 'Error MPI_AllGatherv4:', ierr, SIZE(surfl_l), nsurfl*5, &
5976                      SIZE(surf_l), nsurfs*5, surfstart(0:numprocs-1)*5
5977           FLUSH(9)
5978       ENDIF
5979#else
5980       surf = surfl
5981#endif
5982
5983!--
5984!--    allocation of the arrays for direct and diffusion radiation
5985       CALL location_message( '    allocation of radiation arrays', .TRUE. )
5986!--    rad_sw_in, rad_lw_in are computed in radiation model,
5987!--    splitting of direct and diffusion part is done
5988!--    in calc_diffusion_radiation for now
5989
5990       ALLOCATE( rad_sw_in_dir(nysg:nyng,nxlg:nxrg) )
5991       ALLOCATE( rad_sw_in_diff(nysg:nyng,nxlg:nxrg) )
5992       ALLOCATE( rad_lw_in_diff(nysg:nyng,nxlg:nxrg) )
5993       rad_sw_in_dir  = 0.0_wp
5994       rad_sw_in_diff = 0.0_wp
5995       rad_lw_in_diff = 0.0_wp
5996
5997!--    allocate radiation arrays
5998       ALLOCATE( surfins(nsurfl) )
5999       ALLOCATE( surfinl(nsurfl) )
6000       ALLOCATE( surfinsw(nsurfl) )
6001       ALLOCATE( surfinlw(nsurfl) )
6002       ALLOCATE( surfinswdir(nsurfl) )
6003       ALLOCATE( surfinswdif(nsurfl) )
6004       ALLOCATE( surfinlwdif(nsurfl) )
6005       ALLOCATE( surfoutsl(nsurfl) )
6006       ALLOCATE( surfoutll(nsurfl) )
6007       ALLOCATE( surfoutsw(nsurfl) )
6008       ALLOCATE( surfoutlw(nsurfl) )
6009       ALLOCATE( surfouts(nsurf) )
6010       ALLOCATE( surfoutl(nsurf) )
6011       ALLOCATE( surfinlg(nsurf) )
6012       ALLOCATE( skyvf(nsurfl) )
6013       ALLOCATE( skyvft(nsurfl) )
6014       ALLOCATE( surfemitlwl(nsurfl) )
6015
6016!
6017!--    In case of average_radiation, aggregated surface albedo and emissivity,
6018!--    also set initial value for t_rad_urb.
6019!--    For now set an arbitrary initial value.
6020       IF ( average_radiation )  THEN
6021          albedo_urb = 0.1_wp
6022          emissivity_urb = 0.9_wp
6023          t_rad_urb = pt_surface
6024       ENDIF
6025
6026    END SUBROUTINE radiation_interaction_init
6027
6028!------------------------------------------------------------------------------!
6029! Description:
6030! ------------
6031!> Calculates shape view factors (SVF), plant sink canopy factors (PCSF),
6032!> sky-view factors, discretized path for direct solar radiation, MRT factors
6033!> and other preprocessed data needed for radiation_interaction.
6034!------------------------------------------------------------------------------!
6035    SUBROUTINE radiation_calc_svf
6036   
6037        IMPLICIT NONE
6038       
6039        INTEGER(iwp)                                  :: i, j, k, d, ip, jp
6040        INTEGER(iwp)                                  :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrt, imrtf, ipcgb
6041        INTEGER(iwp)                                  :: sd, td
6042        INTEGER(iwp)                                  :: iaz, izn      !< azimuth, zenith counters
6043        INTEGER(iwp)                                  :: naz, nzn      !< azimuth, zenith num of steps
6044        REAL(wp)                                      :: az0, zn0      !< starting azimuth/zenith
6045        REAL(wp)                                      :: azs, zns      !< azimuth/zenith cycle step
6046        REAL(wp)                                      :: az1, az2      !< relative azimuth of section borders
6047        REAL(wp)                                      :: azmid         !< ray (center) azimuth
6048        REAL(wp)                                      :: yxlen         !< |yxdir|
6049        REAL(wp), DIMENSION(2)                        :: yxdir         !< y,x *unit* vector of ray direction (in grid units)
6050        REAL(wp), DIMENSION(:), ALLOCATABLE           :: zdirs         !< directions in z (tangent of elevation)
6051        REAL(wp), DIMENSION(:), ALLOCATABLE           :: zcent         !< zenith angle centers
6052        REAL(wp), DIMENSION(:), ALLOCATABLE           :: zbdry         !< zenith angle boundaries
6053        REAL(wp), DIMENSION(:), ALLOCATABLE           :: vffrac        !< view factor fractions for individual rays
6054        REAL(wp), DIMENSION(:), ALLOCATABLE           :: vffrac0       !< dtto (original values)
6055        REAL(wp), DIMENSION(:), ALLOCATABLE           :: ztransp       !< array of transparency in z steps
6056        INTEGER(iwp)                                  :: lowest_free_ray !< index into zdirs
6057        INTEGER(iwp), DIMENSION(:), ALLOCATABLE       :: itarget       !< face indices of detected obstacles
6058        INTEGER(iwp)                                  :: itarg0, itarg1
6059
6060        INTEGER(iwp)                                  :: udim
6061        INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: nzterrl_l
6062        INTEGER(iwp), DIMENSION(:,:), POINTER         :: nzterrl
6063        REAL(wp),     DIMENSION(:), ALLOCATABLE,TARGET:: csflt_l, pcsflt_l
6064        REAL(wp),     DIMENSION(:,:), POINTER         :: csflt, pcsflt
6065        INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: kcsflt_l,kpcsflt_l
6066        INTEGER(iwp), DIMENSION(:,:), POINTER         :: kcsflt,kpcsflt
6067        INTEGER(iwp), DIMENSION(:), ALLOCATABLE       :: icsflt,dcsflt,ipcsflt,dpcsflt
6068        REAL(wp), DIMENSION(3)                        :: uv
6069        LOGICAL                                       :: visible
6070        REAL(wp), DIMENSION(3)                        :: sa, ta          !< real coordinates z,y,x of source and target
6071        REAL(wp)                                      :: difvf           !< differential view factor
6072        REAL(wp)                                      :: transparency, rirrf, sqdist, svfsum
6073        INTEGER(iwp)                                  :: isurflt, isurfs, isurflt_prev
6074        INTEGER(idp)                                  :: ray_skip_maxdist, ray_skip_minval !< skipped raytracing counts
6075        INTEGER(iwp)                                  :: max_track_len !< maximum 2d track length
6076        INTEGER(iwp)                                  :: minfo
6077        REAL(wp), DIMENSION(:), POINTER               :: lad_s_rma       !< fortran 1D pointer
6078        TYPE(c_ptr)                                   :: lad_s_rma_p     !< allocated c pointer
6079#if defined( __parallel )
6080        INTEGER(kind=MPI_ADDRESS_KIND)                :: size_lad_rma
6081#endif
6082!   
6083        INTEGER(iwp), DIMENSION(0:svfnorm_report_num) :: svfnorm_counts
6084        CHARACTER(200)                                :: msg
6085
6086!--     calculation of the SVF
6087        CALL location_message( '    calculation of SVF and CSF', .TRUE. )
6088        CALL radiation_write_debug_log('Start calculation of SVF and CSF')
6089
6090!--     initialize variables and temporary arrays for calculation of svf and csf
6091        nsvfl  = 0
6092        ncsfl  = 0
6093        nsvfla = gasize
6094        msvf   = 1
6095        ALLOCATE( asvf1(nsvfla) )
6096        asvf => asvf1
6097        IF ( plant_canopy )  THEN
6098            ncsfla = gasize
6099            mcsf   = 1
6100            ALLOCATE( acsf1(ncsfla) )
6101            acsf => acsf1
6102        ENDIF
6103        nmrtf = 0
6104        IF ( mrt_nlevels > 0 )  THEN
6105           nmrtfa = gasize
6106           mmrtf = 1
6107           ALLOCATE ( amrtf1(nmrtfa) )
6108           amrtf => amrtf1
6109        ENDIF
6110        ray_skip_maxdist = 0
6111        ray_skip_minval = 0
6112       
6113!--     initialize temporary terrain and plant canopy height arrays (global 2D array!)
6114        ALLOCATE( nzterr(0:(nx+1)*(ny+1)-1) )
6115#if defined( __parallel )
6116        !ALLOCATE( nzterrl(nys:nyn,nxl:nxr) )
6117        ALLOCATE( nzterrl_l((nyn-nys+1)*(nxr-nxl+1)) )
6118        nzterrl(nys:nyn,nxl:nxr) => nzterrl_l(1:(nyn-nys+1)*(nxr-nxl+1))
6119        nzterrl = get_topography_top_index( 's' )
6120        CALL MPI_AllGather( nzterrl_l, nnx*nny, MPI_INTEGER, &
6121                            nzterr, nnx*nny, MPI_INTEGER, comm2d, ierr )
6122        IF ( ierr /= 0 ) THEN
6123            WRITE(9,*) 'Error MPI_AllGather1:', ierr, SIZE(nzterrl_l), nnx*nny, &
6124                       SIZE(nzterr), nnx*nny
6125            FLUSH(9)
6126        ENDIF
6127        DEALLOCATE(nzterrl_l)
6128#else
6129        nzterr = RESHAPE( get_topography_top_index( 's' ), (/(nx+1)*(ny+1)/) )
6130#endif
6131        IF ( plant_canopy )  THEN
6132            ALLOCATE( plantt(0:(nx+1)*(ny+1)-1) )
6133            maxboxesg = nx + ny + nzp + 1
6134            max_track_len = nx + ny + 1
6135!--         temporary arrays storing values for csf calculation during raytracing
6136            ALLOCATE( boxes(3, maxboxesg) )
6137            ALLOCATE( crlens(maxboxesg) )
6138
6139#if defined( __parallel )
6140            CALL MPI_AllGather( pct, nnx*nny, MPI_INTEGER, &
6141                                plantt, nnx*nny, MPI_INTEGER, comm2d, ierr )
6142            IF ( ierr /= 0 ) THEN
6143                WRITE(9,*) 'Error MPI_AllGather2:', ierr, SIZE(pct), nnx*nny, &
6144                           SIZE(plantt), nnx*nny
6145                FLUSH(9)
6146            ENDIF
6147
6148!--         temporary arrays storing values for csf calculation during raytracing
6149            ALLOCATE( lad_ip(maxboxesg) )
6150            ALLOCATE( lad_disp(maxboxesg) )
6151
6152            IF ( raytrace_mpi_rma )  THEN
6153                ALLOCATE( lad_s_ray(maxboxesg) )
6154               
6155                ! set conditions for RMA communication
6156                CALL MPI_Info_create(minfo, ierr)
6157                IF ( ierr /= 0 ) THEN
6158                    WRITE(9,*) 'Error MPI_Info_create2:', ierr
6159                    FLUSH(9)
6160                ENDIF
6161                CALL MPI_Info_set(minfo, 'accumulate_ordering', '', ierr)
6162                IF ( ierr /= 0 ) THEN
6163                    WRITE(9,*) 'Error MPI_Info_set5:', ierr
6164                    FLUSH(9)
6165                ENDIF
6166                CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr)
6167                IF ( ierr /= 0 ) THEN
6168                    WRITE(9,*) 'Error MPI_Info_set6:', ierr
6169                    FLUSH(9)
6170                ENDIF
6171                CALL MPI_Info_set(minfo, 'same_size', 'true', ierr)
6172                IF ( ierr /= 0 ) THEN
6173                    WRITE(9,*) 'Error MPI_Info_set7:', ierr
6174                    FLUSH(9)
6175                ENDIF
6176                CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr)
6177                IF ( ierr /= 0 ) THEN
6178                    WRITE(9,*) 'Error MPI_Info_set8:', ierr
6179                    FLUSH(9)
6180                ENDIF
6181
6182!--             Allocate and initialize the MPI RMA window
6183!--             must be in accordance with allocation of lad_s in plant_canopy_model
6184!--             optimization of memory should be done
6185!--             Argument X of function STORAGE_SIZE(X) needs arbitrary REAL(wp) value, set to 1.0_wp for now
6186                size_lad_rma = STORAGE_SIZE(1.0_wp)/8*nnx*nny*nzp
6187                CALL MPI_Win_allocate(size_lad_rma, STORAGE_SIZE(1.0_wp)/8, minfo, comm2d, &
6188                                        lad_s_rma_p, win_lad, ierr)
6189                IF ( ierr /= 0 ) THEN
6190                    WRITE(9,*) 'Error MPI_Win_allocate2:', ierr, size_lad_rma, &
6191                                STORAGE_SIZE(1.0_wp)/8, win_lad
6192                    FLUSH(9)
6193                ENDIF
6194                CALL c_f_pointer(lad_s_rma_p, lad_s_rma, (/ nzp*nny*nnx /))
6195                sub_lad(nzub:nzpt, nys:nyn, nxl:nxr) => lad_s_rma(1:nzp*nny*nnx)
6196            ELSE
6197                ALLOCATE(sub_lad(nzub:nzpt, nys:nyn, nxl:nxr))
6198            ENDIF
6199#else
6200            plantt = RESHAPE( pct(nys:nyn,nxl:nxr), (/(nx+1)*(ny+1)/) )
6201            ALLOCATE(sub_lad(nzub:nzpt, nys:nyn, nxl:nxr))
6202#endif
6203            plantt_max = MAXVAL(plantt)
6204            ALLOCATE( rt2_track(2, max_track_len), rt2_track_lad(nzub:plantt_max, max_track_len), &
6205                      rt2_track_dist(0:max_track_len), rt2_dist(plantt_max-nzub+2) )
6206
6207            sub_lad(:,:,:) = 0._wp
6208            DO i = nxl, nxr
6209                DO j = nys, nyn
6210                    k = get_topography_top_index_ji( j, i, 's' )
6211
6212                    sub_lad(k:nzpt, j, i) = lad_s(0:nzpt-k, j, i)
6213                ENDDO
6214            ENDDO
6215
6216#if defined( __parallel )
6217            IF ( raytrace_mpi_rma )  THEN
6218                CALL MPI_Info_free(minfo, ierr)
6219                IF ( ierr /= 0 ) THEN
6220                    WRITE(9,*) 'Error MPI_Info_free2:', ierr
6221                    FLUSH(9)
6222                ENDIF
6223                CALL MPI_Win_lock_all(0, win_lad, ierr)
6224                IF ( ierr /= 0 ) THEN
6225                    WRITE(9,*) 'Error MPI_Win_lock_all1:', ierr, win_lad
6226                    FLUSH(9)
6227                ENDIF
6228               
6229            ELSE
6230                ALLOCATE( sub_lad_g(0:(nx+1)*(ny+1)*nzp-1) )
6231                CALL MPI_AllGather( sub_lad, nnx*nny*nzp, MPI_REAL, &
6232                                    sub_lad_g, nnx*nny*nzp, MPI_REAL, comm2d, ierr )
6233                IF ( ierr /= 0 ) THEN
6234                    WRITE(9,*) 'Error MPI_AllGather3:', ierr, SIZE(sub_lad), &
6235                                nnx*nny*nzp, SIZE(sub_lad_g), nnx*nny*nzp
6236                    FLUSH(9)
6237                ENDIF
6238            ENDIF
6239#endif
6240        ENDIF
6241
6242!--     prepare the MPI_Win for collecting the surface indices
6243!--     from the reverse index arrays gridsurf from processors of target surfaces
6244#if defined( __parallel )
6245        IF ( rad_angular_discretization )  THEN
6246!
6247!--         raytrace_mpi_rma is asserted
6248            CALL MPI_Win_lock_all(0, win_gridsurf, ierr)
6249            IF ( ierr /= 0 ) THEN
6250                WRITE(9,*) 'Error MPI_Win_lock_all2:', ierr, win_gridsurf
6251                FLUSH(9)
6252            ENDIF
6253        ENDIF
6254#endif
6255
6256
6257        !--Directions opposite to face normals are not even calculated,
6258        !--they must be preset to 0
6259        !--
6260        dsitrans(:,:) = 0._wp
6261       
6262        DO isurflt = 1, nsurfl
6263!--         determine face centers
6264            td = surfl(id, isurflt)
6265            ta = (/ REAL(surfl(iz, isurflt), wp) - 0.5_wp * kdir(td),  &
6266                      REAL(surfl(iy, isurflt), wp) - 0.5_wp * jdir(td),  &
6267                      REAL(surfl(ix, isurflt), wp) - 0.5_wp * idir(td)  /)
6268
6269            !--Calculate sky view factor and raytrace DSI paths
6270            skyvf(isurflt) = 0._wp
6271            skyvft(isurflt) = 0._wp
6272
6273            !--Select a proper half-sphere for 2D raytracing
6274            SELECT CASE ( td )
6275               CASE ( iup_u, iup_l )
6276                  az0 = 0._wp
6277                  naz = raytrace_discrete_azims
6278                  azs = 2._wp * pi / REAL(naz, wp)
6279                  zn0 = 0._wp
6280                  nzn = raytrace_discrete_elevs / 2
6281                  zns = pi / 2._wp / REAL(nzn, wp)
6282               CASE ( isouth_u, isouth_l )
6283                  az0 = pi / 2._wp
6284                  naz = raytrace_discrete_azims / 2
6285                  azs = pi / REAL(naz, wp)
6286                  zn0 = 0._wp
6287                  nzn = raytrace_discrete_elevs
6288                  zns = pi / REAL(nzn, wp)
6289               CASE ( inorth_u, inorth_l )
6290                  az0 = - pi / 2._wp
6291                  naz = raytrace_discrete_azims / 2
6292                  azs = pi / REAL(naz, wp)
6293                  zn0 = 0._wp
6294                  nzn = raytrace_discrete_elevs
6295                  zns = pi / REAL(nzn, wp)
6296               CASE ( iwest_u, iwest_l )
6297                  az0 = pi
6298                  naz = raytrace_discrete_azims / 2
6299                  azs = pi / REAL(naz, wp)
6300                  zn0 = 0._wp
6301                  nzn = raytrace_discrete_elevs
6302                  zns = pi / REAL(nzn, wp)
6303               CASE ( ieast_u, ieast_l )
6304                  az0 = 0._wp
6305                  naz = raytrace_discrete_azims / 2
6306                  azs = pi / REAL(naz, wp)
6307                  zn0 = 0._wp
6308                  nzn = raytrace_discrete_elevs
6309                  zns = pi / REAL(nzn, wp)
6310               CASE DEFAULT
6311                  WRITE(message_string, *) 'ERROR: the surface type ', td,     &
6312                                           ' is not supported for calculating',&
6313                                           ' SVF'
6314                  CALL message( 'radiation_calc_svf', 'PA0488', 1, 2, 0, 6, 0 )
6315            END SELECT
6316
6317            ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), &
6318                       ztransp(1:nzn*naz), itarget(1:nzn*naz) )   !FIXME allocate itarget only
6319                                                                  !in case of rad_angular_discretization
6320
6321            itarg0 = 1
6322            itarg1 = nzn
6323            zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
6324            zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/)
6325            IF ( td == iup_u  .OR.  td == iup_l )  THEN
6326               vffrac(1:nzn) = (COS(2 * zbdry(0:nzn-1)) - COS(2 * zbdry(1:nzn))) / 2._wp / REAL(naz, wp)
6327!
6328!--            For horizontal target, vf fractions are constant per azimuth
6329               DO iaz = 1, naz-1
6330                  vffrac(iaz*nzn+1:(iaz+1)*nzn) = vffrac(1:nzn)
6331               ENDDO
6332!--            sum of whole vffrac equals 1, verified
6333            ENDIF
6334!
6335!--         Calculate sky-view factor and direct solar visibility using 2D raytracing
6336            DO iaz = 1, naz
6337               azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
6338               IF ( td /= iup_u  .AND.  td /= iup_l )  THEN
6339                  az2 = REAL(iaz, wp) * azs - pi/2._wp
6340                  az1 = az2 - azs
6341                  !TODO precalculate after 1st line
6342                  vffrac(itarg0:itarg1) = (SIN(az2) - SIN(az1))               &
6343                              * (zbdry(1:nzn) - zbdry(0:nzn-1)                &
6344                                 + SIN(zbdry(0:nzn-1))*COS(zbdry(0:nzn-1))    &
6345                                 - SIN(zbdry(1:nzn))*COS(zbdry(1:nzn)))       &
6346                              / (2._wp * pi)
6347!--               sum of whole vffrac equals 1, verified
6348               ENDIF
6349               yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
6350               yxlen = SQRT(SUM(yxdir(:)**2))
6351               zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
6352               yxdir(:) = yxdir(:) / yxlen
6353
6354               CALL raytrace_2d(ta, yxdir, nzn, zdirs,                        &
6355                                    surfstart(myid) + isurflt, facearea(td),  &
6356                                    vffrac(itarg0:itarg1), .TRUE., .TRUE.,    &
6357                                    .FALSE., lowest_free_ray,                 &
6358                                    ztransp(itarg0:itarg1),                   &
6359                                    itarget(itarg0:itarg1))
6360
6361               skyvf(isurflt) = skyvf(isurflt) + &
6362                                SUM(vffrac(itarg0:itarg0+lowest_free_ray-1))
6363               skyvft(isurflt) = skyvft(isurflt) + &
6364                                 SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) &
6365                                             * vffrac(itarg0:itarg0+lowest_free_ray-1))
6366 
6367!--            Save direct solar transparency
6368               j = MODULO(NINT(azmid/                                          &
6369                               (2._wp*pi)*raytrace_discrete_azims-.5_wp, iwp), &
6370                          raytrace_discrete_azims)
6371
6372               DO k = 1, raytrace_discrete_elevs/2
6373                  i = dsidir_rev(k-1, j)
6374                  IF ( i /= -1  .AND.  k <= lowest_free_ray )  &
6375                     dsitrans(isurflt, i) = ztransp(itarg0+k-1)
6376               ENDDO
6377
6378!
6379!--            Advance itarget indices
6380               itarg0 = itarg1 + 1
6381               itarg1 = itarg1 + nzn
6382            ENDDO
6383
6384            IF ( rad_angular_discretization )  THEN
6385!--            sort itarget by face id
6386               CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz)
6387!
6388!--            find the first valid position
6389               itarg0 = 1
6390               DO WHILE ( itarg0 <= nzn*naz )
6391                  IF ( itarget(itarg0) /= -1 )  EXIT
6392                  itarg0 = itarg0 + 1
6393               ENDDO
6394
6395               DO  i = itarg0, nzn*naz
6396!
6397!--               For duplicate values, only sum up vf fraction value
6398                  IF ( i < nzn*naz )  THEN
6399                     IF ( itarget(i+1) == itarget(i) )  THEN
6400                        vffrac(i+1) = vffrac(i+1) + vffrac(i)
6401                        CYCLE
6402                     ENDIF
6403                  ENDIF
6404!
6405!--               write to the svf array
6406                  nsvfl = nsvfl + 1
6407!--               check dimmension of asvf array and enlarge it if needed
6408                  IF ( nsvfla < nsvfl )  THEN
6409                     k = CEILING(REAL(nsvfla, kind=wp) * grow_factor)
6410                     IF ( msvf == 0 )  THEN
6411                        msvf = 1
6412                        ALLOCATE( asvf1(k) )
6413                        asvf => asvf1
6414                        asvf1(1:nsvfla) = asvf2
6415                        DEALLOCATE( asvf2 )
6416                     ELSE
6417                        msvf = 0
6418                        ALLOCATE( asvf2(k) )
6419                        asvf => asvf2
6420                        asvf2(1:nsvfla) = asvf1
6421                        DEALLOCATE( asvf1 )
6422                     ENDIF
6423
6424                     WRITE (msg,'(A,3I12)') 'Grow asvf:',nsvfl,nsvfla,k
6425                     CALL radiation_write_debug_log( msg )
6426                     
6427                     nsvfla = k
6428                  ENDIF
6429!--               write svf values into the array
6430                  asvf(nsvfl)%isurflt = isurflt
6431                  asvf(nsvfl)%isurfs = itarget(i)
6432                  asvf(nsvfl)%rsvf = vffrac(i)
6433                  asvf(nsvfl)%rtransp = ztransp(i)
6434               END DO
6435
6436            ENDIF ! rad_angular_discretization
6437
6438            DEALLOCATE ( zdirs, zcent, zbdry, vffrac, ztransp, itarget ) !FIXME itarget shall be allocated only
6439                                                                  !in case of rad_angular_discretization
6440!
6441!--         Following calculations only required for surface_reflections
6442            IF ( surface_reflections  .AND.  .NOT. rad_angular_discretization )  THEN
6443
6444               DO  isurfs = 1, nsurf
6445                  IF ( .NOT.  surface_facing(surfl(ix, isurflt), surfl(iy, isurflt), &
6446                     surfl(iz, isurflt), surfl(id, isurflt), &
6447                     surf(ix, isurfs), surf(iy, isurfs), &
6448                     surf(iz, isurfs), surf(id, isurfs)) )  THEN
6449                     CYCLE
6450                  ENDIF
6451                 
6452                  sd = surf(id, isurfs)
6453                  sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd),  &
6454                          REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd),  &
6455                          REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd)  /)
6456
6457!--               unit vector source -> target
6458                  uv = (/ (ta(1)-sa(1))*dz(1), (ta(2)-sa(2))*dy, (ta(3)-sa(3))*dx /)
6459                  sqdist = SUM(uv(:)**2)
6460                  uv = uv / SQRT(sqdist)
6461
6462!--               reject raytracing above max distance
6463                  IF ( SQRT(sqdist) > max_raytracing_dist ) THEN
6464                     ray_skip_maxdist = ray_skip_maxdist + 1
6465                     CYCLE
6466                  ENDIF
6467                 
6468                  difvf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) & ! cosine of source normal and direction
6469                      * dot_product((/ kdir(td), jdir(td), idir(td) /), -uv) &  ! cosine of target normal and reverse direction
6470                      / (pi * sqdist) ! square of distance between centers
6471!
6472!--               irradiance factor (our unshaded shape view factor) = view factor per differential target area * source area
6473                  rirrf = difvf * facearea(sd)
6474
6475!--               reject raytracing for potentially too small view factor values
6476                  IF ( rirrf < min_irrf_value ) THEN
6477                      ray_skip_minval = ray_skip_minval + 1
6478                      CYCLE
6479                  ENDIF
6480
6481!--               raytrace + process plant canopy sinks within
6482                  CALL raytrace(sa, ta, isurfs, difvf, facearea(td), .TRUE., &
6483                                visible, transparency)
6484
6485                  IF ( .NOT.  visible ) CYCLE
6486                 ! rsvf = rirrf * transparency
6487
6488!--               write to the svf array
6489                  nsvfl = nsvfl + 1
6490!--               check dimmension of asvf array and enlarge it if needed
6491                  IF ( nsvfla < nsvfl )  THEN
6492                     k = CEILING(REAL(nsvfla, kind=wp) * grow_factor)
6493                     IF ( msvf == 0 )  THEN
6494                        msvf = 1
6495                        ALLOCATE( asvf1(k) )
6496                        asvf => asvf1
6497                        asvf1(1:nsvfla) = asvf2
6498                        DEALLOCATE( asvf2 )
6499                     ELSE
6500                        msvf = 0
6501                        ALLOCATE( asvf2(k) )
6502                        asvf => asvf2
6503                        asvf2(1:nsvfla) = asvf1
6504                        DEALLOCATE( asvf1 )
6505                     ENDIF
6506
6507                     WRITE(msg,'(A,3I12)') 'Grow asvf:',nsvfl,nsvfla,k
6508                     CALL radiation_write_debug_log( msg )
6509                     
6510                     nsvfla = k
6511                  ENDIF
6512!--               write svf values into the array
6513                  asvf(nsvfl)%isurflt = isurflt
6514                  asvf(nsvfl)%isurfs = isurfs
6515                  asvf(nsvfl)%rsvf = rirrf !we postopne multiplication by transparency
6516                  asvf(nsvfl)%rtransp = transparency !a.k.a. Direct Irradiance Factor
6517               ENDDO
6518            ENDIF
6519        ENDDO
6520
6521!--
6522!--     Raytrace to canopy boxes to fill dsitransc TODO optimize
6523        dsitransc(:,:) = 0._wp
6524        az0 = 0._wp
6525        naz = raytrace_discrete_azims
6526        azs = 2._wp * pi / REAL(naz, wp)
6527        zn0 = 0._wp
6528        nzn = raytrace_discrete_elevs / 2
6529        zns = pi / 2._wp / REAL(nzn, wp)
6530        ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), vffrac(1:nzn), ztransp(1:nzn), &
6531               itarget(1:nzn) )
6532        zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
6533        vffrac(:) = 0._wp
6534
6535        DO  ipcgb = 1, npcbl
6536           ta = (/ REAL(pcbl(iz, ipcgb), wp),  &
6537                   REAL(pcbl(iy, ipcgb), wp),  &
6538                   REAL(pcbl(ix, ipcgb), wp) /)
6539!--        Calculate direct solar visibility using 2D raytracing
6540           DO  iaz = 1, naz
6541              azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
6542              yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
6543              yxlen = SQRT(SUM(yxdir(:)**2))
6544              zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
6545              yxdir(:) = yxdir(:) / yxlen
6546              CALL raytrace_2d(ta, yxdir, nzn, zdirs,                                &
6547                                   -999, -999._wp, vffrac, .FALSE., .FALSE., .TRUE., &
6548                                   lowest_free_ray, ztransp, itarget)
6549
6550!--           Save direct solar transparency
6551              j = MODULO(NINT(azmid/                                         &
6552                             (2._wp*pi)*raytrace_discrete_azims-.5_wp, iwp), &
6553                         raytrace_discrete_azims)
6554              DO  k = 1, raytrace_discrete_elevs/2
6555                 i = dsidir_rev(k-1, j)
6556                 IF ( i /= -1  .AND.  k <= lowest_free_ray ) &
6557                    dsitransc(ipcgb, i) = ztransp(k)
6558              ENDDO
6559           ENDDO
6560        ENDDO
6561        DEALLOCATE ( zdirs, zcent, vffrac, ztransp, itarget )
6562!--
6563!--     Raytrace to MRT boxes
6564        IF ( nmrtbl > 0 )  THEN
6565           mrtdsit(:,:) = 0._wp
6566           mrtsky(:) = 0._wp
6567           mrtskyt(:) = 0._wp
6568           az0 = 0._wp
6569           naz = raytrace_discrete_azims
6570           azs = 2._wp * pi / REAL(naz, wp)
6571           zn0 = 0._wp
6572           nzn = raytrace_discrete_elevs
6573           zns = pi / REAL(nzn, wp)
6574           ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), vffrac0(1:nzn), &
6575                      ztransp(1:nzn*naz), itarget(1:nzn*naz) )   !FIXME allocate itarget only
6576                                                                 !in case of rad_angular_discretization
6577
6578           zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
6579           zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/)
6580           vffrac0(:) = (COS(zbdry(0:nzn-1)) - COS(zbdry(1:nzn))) / 2._wp / REAL(naz, wp)
6581           !
6582           !--Modify direction weights to simulate human body (lower weight for top-down)
6583           IF ( mrt_geom_human )  THEN
6584              vffrac0(:) = vffrac0(:) * MAX(0._wp, SIN(zcent(:))*0.88_wp + COS(zcent(:))*0.12_wp)
6585              vffrac0(:) = vffrac0(:) / (SUM(vffrac0) * REAL(naz, wp))
6586           ENDIF
6587
6588           DO  imrt = 1, nmrtbl
6589              ta = (/ REAL(mrtbl(iz, imrt), wp),  &
6590                      REAL(mrtbl(iy, imrt), wp),  &
6591                      REAL(mrtbl(ix, imrt), wp) /)
6592!
6593!--           vf fractions are constant per azimuth
6594              DO iaz = 0, naz-1
6595                 vffrac(iaz*nzn+1:(iaz+1)*nzn) = vffrac0(:)
6596              ENDDO
6597!--           sum of whole vffrac equals 1, verified
6598              itarg0 = 1
6599              itarg1 = nzn
6600!
6601!--           Calculate sky-view factor and direct solar visibility using 2D raytracing
6602              DO  iaz = 1, naz
6603                 azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
6604                 yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
6605                 yxlen = SQRT(SUM(yxdir(:)**2))
6606                 zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
6607                 yxdir(:) = yxdir(:) / yxlen
6608
6609                 CALL raytrace_2d(ta, yxdir, nzn, zdirs,                         &
6610                                  -999, -999._wp, vffrac(itarg0:itarg1), .TRUE., &
6611                                  .FALSE., .TRUE., lowest_free_ray,              &
6612                                  ztransp(itarg0:itarg1),                        &
6613                                  itarget(itarg0:itarg1))
6614
6615!--              Sky view factors for MRT
6616                 mrtsky(imrt) = mrtsky(imrt) + &
6617                                  SUM(vffrac(itarg0:itarg0+lowest_free_ray-1))
6618                 mrtskyt(imrt) = mrtskyt(imrt) + &
6619                                   SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) &
6620                                               * vffrac(itarg0:itarg0+lowest_free_ray-1))
6621!--              Direct solar transparency for MRT
6622                 j = MODULO(NINT(azmid/                                         &
6623                                (2._wp*pi)*raytrace_discrete_azims-.5_wp, iwp), &
6624                            raytrace_discrete_azims)
6625                 DO  k = 1, raytrace_discrete_elevs/2
6626                    i = dsidir_rev(k-1, j)
6627                    IF ( i /= -1  .AND.  k <= lowest_free_ray ) &
6628                       mrtdsit(imrt, i) = ztransp(itarg0+k-1)
6629                 ENDDO
6630!
6631!--              Advance itarget indices
6632                 itarg0 = itarg1 + 1
6633                 itarg1 = itarg1 + nzn
6634              ENDDO
6635
6636!--           sort itarget by face id
6637              CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz)
6638!
6639!--           find the first valid position
6640              itarg0 = 1
6641              DO WHILE ( itarg0 <= nzn*naz )
6642                 IF ( itarget(itarg0) /= -1 )  EXIT
6643                 itarg0 = itarg0 + 1
6644              ENDDO
6645
6646              DO  i = itarg0, nzn*naz
6647!
6648!--              For duplicate values, only sum up vf fraction value
6649                 IF ( i < nzn*naz )  THEN
6650                    IF ( itarget(i+1) == itarget(i) )  THEN
6651                       vffrac(i+1) = vffrac(i+1) + vffrac(i)
6652                       CYCLE
6653                    ENDIF
6654                 ENDIF
6655!
6656!--              write to the mrtf array
6657                 nmrtf = nmrtf + 1
6658!--              check dimmension of mrtf array and enlarge it if needed
6659                 IF ( nmrtfa < nmrtf )  THEN
6660                    k = CEILING(REAL(nmrtfa, kind=wp) * grow_factor)
6661                    IF ( mmrtf == 0 )  THEN
6662                       mmrtf = 1
6663                       ALLOCATE( amrtf1(k) )
6664                       amrtf => amrtf1
6665                       amrtf1(1:nmrtfa) = amrtf2
6666                       DEALLOCATE( amrtf2 )
6667                    ELSE
6668                       mmrtf = 0
6669                       ALLOCATE( amrtf2(k) )
6670                       amrtf => amrtf2
6671                       amrtf2(1:nmrtfa) = amrtf1
6672                       DEALLOCATE( amrtf1 )
6673                    ENDIF
6674
6675                    WRITE (msg,'(A,3I12)') 'Grow amrtf:', nmrtf, nmrtfa, k
6676                    CALL radiation_write_debug_log( msg )
6677
6678                    nmrtfa = k
6679                 ENDIF
6680!--              write mrtf values into the array
6681                 amrtf(nmrtf)%isurflt = imrt
6682                 amrtf(nmrtf)%isurfs = itarget(i)
6683                 amrtf(nmrtf)%rsvf = vffrac(i)
6684                 amrtf(nmrtf)%rtransp = ztransp(i)
6685              ENDDO ! itarg
6686
6687           ENDDO ! imrt
6688           DEALLOCATE ( zdirs, zcent, zbdry, vffrac, vffrac0, ztransp, itarget )
6689!
6690!--        Move MRT factors to final arrays
6691           ALLOCATE ( mrtf(nmrtf), mrtft(nmrtf), mrtfsurf(2,nmrtf) )
6692           DO  imrtf = 1, nmrtf
6693              mrtf(imrtf) = amrtf(imrtf)%rsvf
6694              mrtft(imrtf) = amrtf(imrtf)%rsvf * amrtf(imrtf)%rtransp
6695              mrtfsurf(:,imrtf) = (/amrtf(imrtf)%isurflt, amrtf(imrtf)%isurfs /)
6696           ENDDO
6697           IF ( ALLOCATED(amrtf1) )  DEALLOCATE( amrtf1 )
6698           IF ( ALLOCATED(amrtf2) )  DEALLOCATE( amrtf2 )
6699        ENDIF ! nmrtbl > 0
6700
6701        IF ( rad_angular_discretization )  THEN
6702#if defined( __parallel )
6703!--        finalize MPI_RMA communication established to get global index of the surface from grid indices
6704!--        flush all MPI window pending requests
6705           CALL MPI_Win_flush_all(win_gridsurf, ierr)
6706           IF ( ierr /= 0 ) THEN
6707               WRITE(9,*) 'Error MPI_Win_flush_all1:', ierr, win_gridsurf
6708               FLUSH(9)
6709           ENDIF
6710!--        unlock MPI window
6711           CALL MPI_Win_unlock_all(win_gridsurf, ierr)
6712           IF ( ierr /= 0 ) THEN
6713               WRITE(9,*) 'Error MPI_Win_unlock_all1:', ierr, win_gridsurf
6714               FLUSH(9)
6715           ENDIF
6716!--        free MPI window
6717           CALL MPI_Win_free(win_gridsurf, ierr)
6718           IF ( ierr /= 0 ) THEN
6719               WRITE(9,*) 'Error MPI_Win_free1:', ierr, win_gridsurf
6720               FLUSH(9)
6721           ENDIF
6722#else
6723           DEALLOCATE ( gridsurf )
6724#endif
6725        ENDIF
6726
6727        CALL radiation_write_debug_log( 'End of calculation SVF' )
6728        WRITE(msg, *) 'Raytracing skipped for maximum distance of ', &
6729           max_raytracing_dist, ' m on ', ray_skip_maxdist, ' pairs.'
6730        CALL radiation_write_debug_log( msg )
6731        WRITE(msg, *) 'Raytracing skipped for minimum potential value of ', &
6732           min_irrf_value , ' on ', ray_skip_minval, ' pairs.'
6733        CALL radiation_write_debug_log( msg )
6734
6735        CALL location_message( '    waiting for completion of SVF and CSF calculation in all processes', .TRUE. )
6736!--     deallocate temporary global arrays
6737        DEALLOCATE(nzterr)
6738       
6739        IF ( plant_canopy )  THEN
6740!--         finalize mpi_rma communication and deallocate temporary arrays
6741#if defined( __parallel )
6742            IF ( raytrace_mpi_rma )  THEN
6743                CALL MPI_Win_flush_all(win_lad, ierr)
6744                IF ( ierr /= 0 ) THEN
6745                    WRITE(9,*) 'Error MPI_Win_flush_all2:', ierr, win_lad
6746                    FLUSH(9)
6747                ENDIF
6748!--             unlock MPI window
6749                CALL MPI_Win_unlock_all(win_lad, ierr)
6750                IF ( ierr /= 0 ) THEN
6751                    WRITE(9,*) 'Error MPI_Win_unlock_all2:', ierr, win_lad
6752                    FLUSH(9)
6753                ENDIF
6754!--             free MPI window
6755                CALL MPI_Win_free(win_lad, ierr)
6756                IF ( ierr /= 0 ) THEN
6757                    WRITE(9,*) 'Error MPI_Win_free2:', ierr, win_lad
6758                    FLUSH(9)
6759                ENDIF
6760!--             deallocate temporary arrays storing values for csf calculation during raytracing
6761                DEALLOCATE( lad_s_ray )
6762!--             sub_lad is the pointer to lad_s_rma in case of raytrace_mpi_rma
6763!--             and must not be deallocated here
6764            ELSE
6765                DEALLOCATE(sub_lad)
6766                DEALLOCATE(sub_lad_g)
6767            ENDIF
6768#else
6769            DEALLOCATE(sub_lad)
6770#endif
6771            DEALLOCATE( boxes )
6772            DEALLOCATE( crlens )
6773            DEALLOCATE( plantt )
6774            DEALLOCATE( rt2_track, rt2_track_lad, rt2_track_dist, rt2_dist )
6775        ENDIF
6776
6777        CALL location_message( '    calculation of the complete SVF array', .TRUE. )
6778
6779        IF ( rad_angular_discretization )  THEN
6780           CALL radiation_write_debug_log( 'Load svf from the structure array to plain arrays' )
6781           ALLOCATE( svf(ndsvf,nsvfl) )
6782           ALLOCATE( svfsurf(idsvf,nsvfl) )
6783
6784           DO isvf = 1, nsvfl
6785               svf(:, isvf) = (/ asvf(isvf)%rsvf, asvf(isvf)%rtransp /)
6786               svfsurf(:, isvf) = (/ asvf(isvf)%isurflt, asvf(isvf)%isurfs /)
6787           ENDDO
6788        ELSE
6789           CALL radiation_write_debug_log( 'Start SVF sort' )
6790!--        sort svf ( a version of quicksort )
6791           CALL quicksort_svf(asvf,1,nsvfl)
6792
6793           !< load svf from the structure array to plain arrays
6794           CALL radiation_write_debug_log( 'Load svf from the structure array to plain arrays' )
6795           ALLOCATE( svf(ndsvf,nsvfl) )
6796           ALLOCATE( svfsurf(idsvf,nsvfl) )
6797           svfnorm_counts(:) = 0._wp
6798           isurflt_prev = -1
6799           ksvf = 1
6800           svfsum = 0._wp
6801           DO isvf = 1, nsvfl
6802!--            normalize svf per target face
6803               IF ( asvf(ksvf)%isurflt /= isurflt_prev )  THEN
6804                   IF ( isurflt_prev /= -1  .AND.  svfsum /= 0._wp )  THEN
6805                       !< update histogram of logged svf normalization values
6806                       i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev)))
6807                       svfnorm_counts(i) = svfnorm_counts(i) + 1
6808
6809                       svf(1, isvf_surflt:isvf-1) = svf(1, isvf_surflt:isvf-1) / svfsum * (1._wp-skyvf(isurflt_prev))
6810                   ENDIF
6811                   isurflt_prev = asvf(ksvf)%isurflt
6812                   isvf_surflt = isvf
6813                   svfsum = asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp
6814               ELSE
6815                   svfsum = svfsum + asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp
6816               ENDIF
6817
6818               svf(:, isvf) = (/ asvf(ksvf)%rsvf, asvf(ksvf)%rtransp /)
6819               svfsurf(:, isvf) = (/ asvf(ksvf)%isurflt, asvf(ksvf)%isurfs /)
6820
6821!--            next element
6822               ksvf = ksvf + 1
6823           ENDDO
6824
6825           IF ( isurflt_prev /= -1  .AND.  svfsum /= 0._wp )  THEN
6826               i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev)))
6827               svfnorm_counts(i) = svfnorm_counts(i) + 1
6828
6829               svf(1, isvf_surflt:nsvfl) = svf(1, isvf_surflt:nsvfl) / svfsum * (1._wp-skyvf(isurflt_prev))
6830           ENDIF
6831           WRITE(9, *) 'SVF normalization histogram:', svfnorm_counts,  &
6832                       'on thresholds:', svfnorm_report_thresh(1:svfnorm_report_num), '(val < thresh <= val)'
6833           !TODO we should be able to deallocate skyvf, from now on we only need skyvft
6834        ENDIF ! rad_angular_discretization
6835
6836!--     deallocate temporary asvf array
6837!--     DEALLOCATE(asvf) - ifort has a problem with deallocation of allocatable target
6838!--     via pointing pointer - we need to test original targets
6839        IF ( ALLOCATED(asvf1) )  THEN
6840            DEALLOCATE(asvf1)
6841        ENDIF
6842        IF ( ALLOCATED(asvf2) )  THEN
6843            DEALLOCATE(asvf2)
6844        ENDIF
6845
6846        npcsfl = 0
6847        IF ( plant_canopy )  THEN
6848
6849            CALL location_message( '    calculation of the complete CSF array', .TRUE. )
6850            CALL radiation_write_debug_log( 'Calculation of the complete CSF array' )
6851!--         sort and merge csf for the last time, keeping the array size to minimum
6852            CALL merge_and_grow_csf(-1)
6853           
6854!--         aggregate csb among processors
6855!--         allocate necessary arrays
6856            udim = max(ncsfl,1)
6857            ALLOCATE( csflt_l(ndcsf*udim) )
6858            csflt(1:ndcsf,1:udim) => csflt_l(1:ndcsf*udim)
6859            ALLOCATE( kcsflt_l(kdcsf*udim) )
6860            kcsflt(1:kdcsf,1:udim) => kcsflt_l(1:kdcsf*udim)
6861            ALLOCATE( icsflt(0:numprocs-1) )
6862            ALLOCATE( dcsflt(0:numprocs-1) )
6863            ALLOCATE( ipcsflt(0:numprocs-1) )
6864            ALLOCATE( dpcsflt(0:numprocs-1) )
6865           
6866!--         fill out arrays of csf values and
6867!--         arrays of number of elements and displacements
6868!--         for particular precessors
6869            icsflt = 0
6870            dcsflt = 0
6871            ip = -1
6872            j = -1
6873            d = 0
6874            DO kcsf = 1, ncsfl
6875                j = j+1
6876                IF ( acsf(kcsf)%ip /= ip )  THEN
6877!--                 new block of the processor
6878!--                 number of elements of previous block
6879                    IF ( ip>=0) icsflt(ip) = j
6880                    d = d+j
6881!--                 blank blocks
6882                    DO jp = ip+1, acsf(kcsf)%ip-1
6883!--                     number of elements is zero, displacement is equal to previous
6884                        icsflt(jp) = 0
6885                        dcsflt(jp) = d
6886                    ENDDO
6887!--                 the actual block
6888                    ip = acsf(kcsf)%ip
6889                    dcsflt(ip) = d
6890                    j = 0
6891                ENDIF
6892                csflt(1,kcsf) = acsf(kcsf)%rcvf
6893!--             fill out integer values of itz,ity,itx,isurfs
6894                kcsflt(1,kcsf) = acsf(kcsf)%itz
6895                kcsflt(2,kcsf) = acsf(kcsf)%ity
6896                kcsflt(3,kcsf) = acsf(kcsf)%itx
6897                kcsflt(4,kcsf) = acsf(kcsf)%isurfs
6898            ENDDO
6899!--         last blank blocks at the end of array
6900            j = j+1
6901            IF ( ip>=0 ) icsflt(ip) = j
6902            d = d+j
6903            DO jp = ip+1, numprocs-1
6904!--             number of elements is zero, displacement is equal to previous
6905                icsflt(jp) = 0
6906                dcsflt(jp) = d
6907            ENDDO
6908           
6909!--         deallocate temporary acsf array
6910!--         DEALLOCATE(acsf) - ifort has a problem with deallocation of allocatable target
6911!--         via pointing pointer - we need to test original targets
6912            IF ( ALLOCATED(acsf1) )  THEN
6913                DEALLOCATE(acsf1)
6914            ENDIF
6915            IF ( ALLOCATED(acsf2) )  THEN
6916                DEALLOCATE(acsf2)
6917            ENDIF
6918                   
6919#if defined( __parallel )
6920!--         scatter and gather the number of elements to and from all processor
6921!--         and calculate displacements
6922            CALL radiation_write_debug_log( 'Scatter and gather the number of elements to and from all processor' )
6923            CALL MPI_AlltoAll(icsflt,1,MPI_INTEGER,ipcsflt,1,MPI_INTEGER,comm2d, ierr)
6924            IF ( ierr /= 0 ) THEN
6925                WRITE(9,*) 'Error MPI_AlltoAll1:', ierr, SIZE(icsflt), SIZE(ipcsflt)
6926                FLUSH(9)
6927            ENDIF
6928
6929            npcsfl = SUM(ipcsflt)
6930            d = 0
6931            DO i = 0, numprocs-1
6932                dpcsflt(i) = d
6933                d = d + ipcsflt(i)
6934            ENDDO
6935
6936!--         exchange csf fields between processors
6937            CALL radiation_write_debug_log( 'Exchange csf fields between processors' )
6938            udim = max(npcsfl,1)
6939            ALLOCATE( pcsflt_l(ndcsf*udim) )
6940            pcsflt(1:ndcsf,1:udim) => pcsflt_l(1:ndcsf*udim)
6941            ALLOCATE( kpcsflt_l(kdcsf*udim) )
6942            kpcsflt(1:kdcsf,1:udim) => kpcsflt_l(1:kdcsf*udim)
6943            CALL MPI_AlltoAllv(csflt_l, ndcsf*icsflt, ndcsf*dcsflt, MPI_REAL, &
6944                pcsflt_l, ndcsf*ipcsflt, ndcsf*dpcsflt, MPI_REAL, comm2d, ierr)
6945            IF ( ierr /= 0 ) THEN
6946                WRITE(9,*) 'Error MPI_AlltoAllv1:', ierr, SIZE(ipcsflt), ndcsf*icsflt, &
6947                            ndcsf*dcsflt, SIZE(pcsflt_l),ndcsf*ipcsflt, ndcsf*dpcsflt
6948                FLUSH(9)
6949            ENDIF
6950
6951            CALL MPI_AlltoAllv(kcsflt_l, kdcsf*icsflt, kdcsf*dcsflt, MPI_INTEGER, &
6952                kpcsflt_l, kdcsf*ipcsflt, kdcsf*dpcsflt, MPI_INTEGER, comm2d, ierr)
6953            IF ( ierr /= 0 ) THEN
6954                WRITE(9,*) 'Error MPI_AlltoAllv2:', ierr, SIZE(kcsflt_l),kdcsf*icsflt, &
6955                           kdcsf*dcsflt, SIZE(kpcsflt_l), kdcsf*ipcsflt, kdcsf*dpcsflt
6956                FLUSH(9)
6957            ENDIF
6958           
6959#else
6960            npcsfl = ncsfl
6961            ALLOCATE( pcsflt(ndcsf,max(npcsfl,ndcsf)) )
6962            ALLOCATE( kpcsflt(kdcsf,max(npcsfl,kdcsf)) )
6963            pcsflt = csflt
6964            kpcsflt = kcsflt
6965#endif
6966
6967!--         deallocate temporary arrays
6968            DEALLOCATE( csflt_l )
6969            DEALLOCATE( kcsflt_l )
6970            DEALLOCATE( icsflt )
6971            DEALLOCATE( dcsflt )
6972            DEALLOCATE( ipcsflt )
6973            DEALLOCATE( dpcsflt )
6974
6975!--         sort csf ( a version of quicksort )
6976            CALL radiation_write_debug_log( 'Sort csf' )
6977            CALL quicksort_csf2(kpcsflt, pcsflt, 1, npcsfl)
6978
6979!--         aggregate canopy sink factor records with identical box & source
6980!--         againg across all values from all processors
6981            CALL radiation_write_debug_log( 'Aggregate canopy sink factor records with identical box' )
6982
6983            IF ( npcsfl > 0 )  THEN
6984                icsf = 1 !< reading index
6985                kcsf = 1 !< writing index
6986                DO while (icsf < npcsfl)
6987!--                 here kpcsf(kcsf) already has values from kpcsf(icsf)
6988                    IF ( kpcsflt(3,icsf) == kpcsflt(3,icsf+1)  .AND.  &
6989                         kpcsflt(2,icsf) == kpcsflt(2,icsf+1)  .AND.  &
6990                         kpcsflt(1,icsf) == kpcsflt(1,icsf+1)  .AND.  &
6991                         kpcsflt(4,icsf) == kpcsflt(4,icsf+1) )  THEN
6992
6993                        pcsflt(1,kcsf) = pcsflt(1,kcsf) + pcsflt(1,icsf+1)
6994
6995!--                     advance reading index, keep writing index
6996                        icsf = icsf + 1
6997                    ELSE
6998!--                     not identical, just advance and copy
6999                        icsf = icsf + 1
7000                        kcsf = kcsf + 1
7001                        kpcsflt(:,kcsf) = kpcsflt(:,icsf)
7002                        pcsflt(:,kcsf) = pcsflt(:,icsf)
7003                    ENDIF
7004                ENDDO
7005!--             last written item is now also the last item in valid part of array
7006                npcsfl = kcsf
7007            ENDIF
7008
7009            ncsfl = npcsfl
7010            IF ( ncsfl > 0 )  THEN
7011                ALLOCATE( csf(ndcsf,ncsfl) )
7012                ALLOCATE( csfsurf(idcsf,ncsfl) )
7013                DO icsf = 1, ncsfl
7014                    csf(:,icsf) = pcsflt(:,icsf)
7015                    csfsurf(1,icsf) =  gridpcbl(kpcsflt(1,icsf),kpcsflt(2,icsf),kpcsflt(3,icsf))
7016                    csfsurf(2,icsf) =  kpcsflt(4,icsf)
7017                ENDDO
7018            ENDIF
7019           
7020!--         deallocation of temporary arrays
7021            IF ( npcbl > 0 )  DEALLOCATE( gridpcbl )
7022            DEALLOCATE( pcsflt_l )
7023            DEALLOCATE( kpcsflt_l )
7024            CALL radiation_write_debug_log( 'End of aggregate csf' )
7025           
7026        ENDIF
7027
7028#if defined( __parallel )
7029        CALL MPI_BARRIER( comm2d, ierr )
7030#endif
7031        CALL radiation_write_debug_log( 'End of radiation_calc_svf (after mpi_barrier)' )
7032
7033        RETURN
7034       
7035!        WRITE( message_string, * )  &
7036!            'I/O error when processing shape view factors / ',  &
7037!            'plant canopy sink factors / direct irradiance factors.'
7038!        CALL message( 'init_urban_surface', 'PA0502', 2, 2, 0, 6, 0 )
7039       
7040    END SUBROUTINE radiation_calc_svf
7041
7042   
7043!------------------------------------------------------------------------------!
7044! Description:
7045! ------------
7046!> Raytracing for detecting obstacles and calculating compound canopy sink
7047!> factors. (A simple obstacle detection would only need to process faces in
7048!> 3 dimensions without any ordering.)
7049!> Assumtions:
7050!> -----------
7051!> 1. The ray always originates from a face midpoint (only one coordinate equals
7052!>    *.5, i.e. wall) and doesn't travel parallel to the surface (that would mean
7053!>    shape factor=0). Therefore, the ray may never travel exactly along a face
7054!>    or an edge.
7055!> 2. From grid bottom to urban surface top the grid has to be *equidistant*
7056!>    within each of the dimensions, including vertical (but the resolution
7057!>    doesn't need to be the same in all three dimensions).
7058!------------------------------------------------------------------------------!
7059    SUBROUTINE raytrace(src, targ, isrc, difvf, atarg, create_csf, visible, transparency)
7060        IMPLICIT NONE
7061
7062        REAL(wp), DIMENSION(3), INTENT(in)     :: src, targ    !< real coordinates z,y,x
7063        INTEGER(iwp), INTENT(in)               :: isrc         !< index of source face for csf
7064        REAL(wp), INTENT(in)                   :: difvf        !< differential view factor for csf
7065        REAL(wp), INTENT(in)                   :: atarg        !< target surface area for csf
7066        LOGICAL, INTENT(in)                    :: create_csf   !< whether to generate new CSFs during raytracing
7067        LOGICAL, INTENT(out)                   :: visible
7068        REAL(wp), INTENT(out)                  :: transparency !< along whole path
7069        INTEGER(iwp)                           :: i, k, d
7070        INTEGER(iwp)                           :: seldim       !< dimension to be incremented
7071        INTEGER(iwp)                           :: ncsb         !< no of written plant canopy sinkboxes
7072        INTEGER(iwp)                           :: maxboxes     !< max no of gridboxes visited
7073        REAL(wp)                               :: distance     !< euclidean along path
7074        REAL(wp)                               :: crlen        !< length of gridbox crossing
7075        REAL(wp)                               :: lastdist     !< beginning of current crossing
7076        REAL(wp)                               :: nextdist     !< end of current crossing
7077        REAL(wp)                               :: realdist     !< distance in meters per unit distance
7078        REAL(wp)                               :: crmid        !< midpoint of crossing
7079        REAL(wp)                               :: cursink      !< sink factor for current canopy box
7080        REAL(wp), DIMENSION(3)                 :: delta        !< path vector
7081        REAL(wp), DIMENSION(3)                 :: uvect        !< unit vector
7082        REAL(wp), DIMENSION(3)                 :: dimnextdist  !< distance for each dimension increments
7083        INTEGER(iwp), DIMENSION(3)             :: box          !< gridbox being crossed
7084        INTEGER(iwp), DIMENSION(3)             :: dimnext      !< next dimension increments along path
7085        INTEGER(iwp), DIMENSION(3)             :: dimdelta     !< dimension direction = +- 1
7086        INTEGER(iwp)                           :: px, py       !< number of processors in x and y dir before
7087                                                               !< the processor in the question
7088        INTEGER(iwp)                           :: ip           !< number of processor where gridbox reside
7089        INTEGER(iwp)                           :: ig           !< 1D index of gridbox in global 2D array
7090       
7091        REAL(wp)                               :: eps = 1E-10_wp !< epsilon for value comparison
7092        REAL(wp)                               :: lad_s_target   !< recieved lad_s of particular grid box
7093
7094!
7095!--     Maximum number of gridboxes visited equals to maximum number of boundaries crossed in each dimension plus one. That's also
7096!--     the maximum number of plant canopy boxes written. We grow the acsf array accordingly using exponential factor.
7097        maxboxes = SUM(ABS(NINT(targ, iwp) - NINT(src, iwp))) + 1
7098        IF ( plant_canopy  .AND.  ncsfl + maxboxes > ncsfla )  THEN
7099!--         use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1)
7100!--         k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) &
7101!--                                                / log(grow_factor)), kind=wp))
7102!--         or use this code to simply always keep some extra space after growing
7103            k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor)
7104
7105            CALL merge_and_grow_csf(k)
7106        ENDIF
7107       
7108        transparency = 1._wp
7109        ncsb = 0
7110
7111        delta(:) = targ(:) - src(:)
7112        distance = SQRT(SUM(delta(:)**2))
7113        IF ( distance == 0._wp )  THEN
7114            visible = .TRUE.
7115            RETURN
7116        ENDIF
7117        uvect(:) = delta(:) / distance
7118        realdist = SQRT(SUM( (uvect(:)*(/dz(1),dy,dx/))**2 ))
7119
7120        lastdist = 0._wp
7121
7122!--     Since all face coordinates have values *.5 and we'd like to use
7123!--     integers, all these have .5 added
7124        DO d = 1, 3
7125            IF ( uvect(d) == 0._wp )  THEN
7126                dimnext(d) = 999999999
7127                dimdelta(d) = 999999999
7128                dimnextdist(d) = 1.0E20_wp
7129            ELSE IF ( uvect(d) > 0._wp )  THEN
7130                dimnext(d) = CEILING(src(d) + .5_wp)
7131                dimdelta(d) = 1
7132                dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d)
7133            ELSE
7134                dimnext(d) = FLOOR(src(d) + .5_wp)
7135                dimdelta(d) = -1
7136                dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d)
7137            ENDIF
7138        ENDDO
7139
7140        DO
7141!--         along what dimension will the next wall crossing be?
7142            seldim = minloc(dimnextdist, 1)
7143            nextdist = dimnextdist(seldim)
7144            IF ( nextdist > distance ) nextdist = distance
7145
7146            crlen = nextdist - lastdist
7147            IF ( crlen > .001_wp )  THEN
7148                crmid = (lastdist + nextdist) * .5_wp
7149                box = NINT(src(:) + uvect(:) * crmid, iwp)
7150
7151!--             calculate index of the grid with global indices (box(2),box(3))
7152!--             in the array nzterr and plantt and id of the coresponding processor
7153                px = box(3)/nnx
7154                py = box(2)/nny
7155                ip = px*pdims(2)+py
7156                ig = ip*nnx*nny + (box(3)-px*nnx)*nny + box(2)-py*nny
7157                IF ( box(1) <= nzterr(ig) )  THEN
7158                    visible = .FALSE.
7159                    RETURN
7160                ENDIF
7161
7162                IF ( plant_canopy )  THEN
7163                    IF ( box(1) <= plantt(ig) )  THEN
7164                        ncsb = ncsb + 1
7165                        boxes(:,ncsb) = box
7166                        crlens(ncsb) = crlen
7167#if defined( __parallel )
7168                        lad_ip(ncsb) = ip
7169                        lad_disp(ncsb) = (box(3)-px*nnx)*(nny*nzp) + (box(2)-py*nny)*nzp + box(1)-nzub
7170#endif
7171                    ENDIF
7172                ENDIF
7173            ENDIF
7174
7175            IF ( ABS(distance - nextdist) < eps )  EXIT
7176            lastdist = nextdist
7177            dimnext(seldim) = dimnext(seldim) + dimdelta(seldim)
7178            dimnextdist(seldim) = (dimnext(seldim) - .5_wp - src(seldim)) / uvect(seldim)
7179        ENDDO
7180       
7181        IF ( plant_canopy )  THEN
7182#if defined( __parallel )
7183            IF ( raytrace_mpi_rma )  THEN
7184!--             send requests for lad_s to appropriate processor
7185                CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'start' )
7186                DO i = 1, ncsb
7187                    CALL MPI_Get(lad_s_ray(i), 1, MPI_REAL, lad_ip(i), lad_disp(i), &
7188                                 1, MPI_REAL, win_lad, ierr)
7189                    IF ( ierr /= 0 )  THEN
7190                        WRITE(9,*) 'Error MPI_Get1:', ierr, lad_s_ray(i), &
7191                                   lad_ip(i), lad_disp(i), win_lad
7192                        FLUSH(9)
7193                    ENDIF
7194                ENDDO
7195               
7196!--             wait for all pending local requests complete
7197                CALL MPI_Win_flush_local_all(win_lad, ierr)
7198                IF ( ierr /= 0 )  THEN
7199                    WRITE(9,*) 'Error MPI_Win_flush_local_all1:', ierr, win_lad
7200                    FLUSH(9)
7201                ENDIF
7202                CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'stop' )
7203               
7204            ENDIF
7205#endif
7206
7207!--         calculate csf and transparency
7208            DO i = 1, ncsb
7209#if defined( __parallel )
7210                IF ( raytrace_mpi_rma )  THEN
7211                    lad_s_target = lad_s_ray(i)
7212                ELSE
7213                    lad_s_target = sub_lad_g(lad_ip(i)*nnx*nny*nzp + lad_disp(i))
7214                ENDIF
7215#else
7216                lad_s_target = sub_lad(boxes(1,i),boxes(2,i),boxes(3,i))
7217#endif
7218                cursink = 1._wp - exp(-ext_coef * lad_s_target * crlens(i)*realdist)
7219
7220                IF ( create_csf )  THEN
7221!--                 write svf values into the array
7222                    ncsfl = ncsfl + 1
7223                    acsf(ncsfl)%ip = lad_ip(i)
7224                    acsf(ncsfl)%itx = boxes(3,i)
7225                    acsf(ncsfl)%ity = boxes(2,i)
7226                    acsf(ncsfl)%itz = boxes(1,i)
7227                    acsf(ncsfl)%isurfs = isrc
7228                    acsf(ncsfl)%rcvf = cursink*transparency*difvf*atarg
7229                ENDIF  !< create_csf
7230
7231                transparency = transparency * (1._wp - cursink)
7232               
7233            ENDDO
7234        ENDIF
7235       
7236        visible = .TRUE.
7237
7238    END SUBROUTINE raytrace
7239   
7240 
7241!------------------------------------------------------------------------------!
7242! Description:
7243! ------------
7244!> A new, more efficient version of ray tracing algorithm that processes a whole
7245!> arc instead of a single ray.
7246!>
7247!> In all comments, horizon means tangent of horizon angle, i.e.
7248!> vertical_delta / horizontal_distance
7249!------------------------------------------------------------------------------!
7250   SUBROUTINE raytrace_2d(origin, yxdir, nrays, zdirs, iorig, aorig, vffrac,  &
7251                              calc_svf, create_csf, skip_1st_pcb,             &
7252                              lowest_free_ray, transparency, itarget)
7253      IMPLICIT NONE
7254
7255      REAL(wp), DIMENSION(3), INTENT(IN)     ::  origin        !< z,y,x coordinates of ray origin
7256      REAL(wp), DIMENSION(2), INTENT(IN)     ::  yxdir         !< y,x *unit* vector of ray direction (in grid units)
7257      INTEGER(iwp)                           ::  nrays         !< number of rays (z directions) to raytrace
7258      REAL(wp), DIMENSION(nrays), INTENT(IN) ::  zdirs         !< list of z directions to raytrace (z/hdist, grid, zenith->nadir)
7259      INTEGER(iwp), INTENT(in)               ::  iorig         !< index of origin face for csf
7260      REAL(wp), INTENT(in)                   ::  aorig         !< origin face area for csf
7261      REAL(wp), DIMENSION(nrays), INTENT(in) ::  vffrac        !< view factor fractions of each ray for csf
7262      LOGICAL, INTENT(in)                    ::  calc_svf      !< whether to calculate SFV (identify obstacle surfaces)
7263      LOGICAL, INTENT(in)                    ::  create_csf    !< whether to create canopy sink factors
7264      LOGICAL, INTENT(in)                    ::  skip_1st_pcb  !< whether to skip first plant canopy box during raytracing
7265      INTEGER(iwp), INTENT(out)              ::  lowest_free_ray !< index into zdirs
7266      REAL(wp), DIMENSION(nrays), INTENT(OUT) ::  transparency !< transparencies of zdirs paths
7267      INTEGER(iwp), DIMENSION(nrays), INTENT(OUT) ::  itarget  !< global indices of target faces for zdirs
7268
7269      INTEGER(iwp), DIMENSION(nrays)         ::  target_procs
7270      REAL(wp)                               ::  horizon       !< highest horizon found after raytracing (z/hdist)
7271      INTEGER(iwp)                           ::  i, k, l, d
7272      INTEGER(iwp)                           ::  seldim       !< dimension to be incremented
7273      REAL(wp), DIMENSION(2)                 ::  yxorigin     !< horizontal copy of origin (y,x)
7274      REAL(wp)                               ::  distance     !< euclidean along path
7275      REAL(wp)                               ::  lastdist     !< beginning of current crossing
7276      REAL(wp)                               ::  nextdist     !< end of current crossing
7277      REAL(wp)                               ::  crmid        !< midpoint of crossing
7278      REAL(wp)                               ::  horz_entry   !< horizon at entry to column
7279      REAL(wp)                               ::  horz_exit    !< horizon at exit from column
7280      REAL(wp)                               ::  bdydim       !< boundary for current dimension
7281      REAL(wp), DIMENSION(2)                 ::  crossdist    !< distances to boundary for dimensions
7282      REAL(wp), DIMENSION(2)                 ::  dimnextdist  !< distance for each dimension increments
7283      INTEGER(iwp), DIMENSION(2)             ::  column       !< grid column being crossed
7284      INTEGER(iwp), DIMENSION(2)             ::  dimnext      !< next dimension increments along path
7285      INTEGER(iwp), DIMENSION(2)             ::  dimdelta     !< dimension direction = +- 1
7286      INTEGER(iwp)                           ::  px, py       !< number of processors in x and y dir before
7287                                                              !< the processor in the question
7288      INTEGER(iwp)                           ::  ip           !< number of processor where gridbox reside
7289      INTEGER(iwp)                           ::  ig           !< 1D index of gridbox in global 2D array
7290      INTEGER(iwp)                           ::  wcount       !< RMA window item count
7291      INTEGER(iwp)                           ::  maxboxes     !< max no of CSF created
7292      INTEGER(iwp)                           ::  nly          !< maximum  plant canopy height
7293      INTEGER(iwp)                           ::  ntrack
7294     
7295      INTEGER(iwp)                           ::  zb0
7296      INTEGER(iwp)                           ::  zb1
7297      INTEGER(iwp)                           ::  nz
7298      INTEGER(iwp)                           ::  iz
7299      INTEGER(iwp)                           ::  zsgn
7300      INTEGER(iwp)                           ::  lowest_lad   !< lowest column cell for which we need LAD
7301      INTEGER(iwp)                           ::  lastdir      !< wall direction before hitting this column
7302      INTEGER(iwp), DIMENSION(2)             ::  lastcolumn
7303
7304#if defined( __parallel )
7305      INTEGER(MPI_ADDRESS_KIND)              ::  wdisp        !< RMA window displacement
7306#endif
7307     
7308      REAL(wp)                               ::  eps = 1E-10_wp !< epsilon for value comparison
7309      REAL(wp)                               ::  zbottom, ztop !< urban surface boundary in real numbers
7310      REAL(wp)                               ::  zorig         !< z coordinate of ray column entry
7311      REAL(wp)                               ::  zexit         !< z coordinate of ray column exit
7312      REAL(wp)                               ::  qdist         !< ratio of real distance to z coord difference
7313      REAL(wp)                               ::  dxxyy         !< square of real horizontal distance
7314      REAL(wp)                               ::  curtrans      !< transparency of current PC box crossing
7315     
7316
7317     
7318      yxorigin(:) = origin(2:3)
7319      transparency(:) = 1._wp !-- Pre-set the all rays to transparent before reducing
7320      horizon = -HUGE(1._wp)
7321      lowest_free_ray = nrays
7322      IF ( rad_angular_discretization  .AND.  calc_svf )  THEN
7323         ALLOCATE(target_surfl(nrays))
7324         target_surfl(:) = -1
7325         lastdir = -999
7326         lastcolumn(:) = -999
7327      ENDIF
7328
7329!--   Determine distance to boundary (in 2D xy)
7330      IF ( yxdir(1) > 0._wp )  THEN
7331         bdydim = ny + .5_wp !< north global boundary
7332         crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1)
7333      ELSEIF ( yxdir(1) == 0._wp )  THEN
7334         crossdist(1) = HUGE(1._wp)
7335      ELSE
7336          bdydim = -.5_wp !< south global boundary
7337          crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1)
7338      ENDIF
7339
7340      IF ( yxdir(2) >= 0._wp )  THEN
7341          bdydim = nx + .5_wp !< east global boundary
7342          crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2)
7343      ELSEIF ( yxdir(2) == 0._wp )  THEN
7344         crossdist(2) = HUGE(1._wp)
7345      ELSE
7346          bdydim = -.5_wp !< west global boundary
7347          crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2)
7348      ENDIF
7349      distance = minval(crossdist, 1)
7350
7351      IF ( plant_canopy )  THEN
7352         rt2_track_dist(0) = 0._wp
7353         rt2_track_lad(:,:) = 0._wp
7354         nly = plantt_max - nzub + 1
7355      ENDIF
7356
7357      lastdist = 0._wp
7358
7359!--   Since all face coordinates have values *.5 and we'd like to use
7360!--   integers, all these have .5 added
7361      DO  d = 1, 2
7362          IF ( yxdir(d) == 0._wp )  THEN
7363              dimnext(d) = HUGE(1_iwp)
7364              dimdelta(d) = HUGE(1_iwp)
7365              dimnextdist(d) = HUGE(1._wp)
7366          ELSE IF ( yxdir(d) > 0._wp )  THEN
7367              dimnext(d) = FLOOR(yxorigin(d) + .5_wp) + 1
7368              dimdelta(d) = 1
7369              dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d)
7370          ELSE
7371              dimnext(d) = CEILING(yxorigin(d) + .5_wp) - 1
7372              dimdelta(d) = -1
7373              dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d)
7374          ENDIF
7375      ENDDO
7376
7377      ntrack = 0
7378      DO
7379!--      along what dimension will the next wall crossing be?
7380         seldim = minloc(dimnextdist, 1)
7381         nextdist = dimnextdist(seldim)
7382         IF ( nextdist > distance )  nextdist = distance
7383
7384         IF ( nextdist > lastdist )  THEN
7385            ntrack = ntrack + 1
7386            crmid = (lastdist + nextdist) * .5_wp
7387            column = NINT(yxorigin(:) + yxdir(:) * crmid, iwp)
7388
7389!--         calculate index of the grid with global indices (column(1),column(2))
7390!--         in the array nzterr and plantt and id of the coresponding processor
7391            px = column(2)/nnx
7392            py = column(1)/nny
7393            ip = px*pdims(2)+py
7394            ig = ip*nnx*nny + (column(2)-px*nnx)*nny + column(1)-py*nny
7395
7396            IF ( lastdist == 0._wp )  THEN
7397               horz_entry = -HUGE(1._wp)
7398            ELSE
7399               horz_entry = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / lastdist
7400            ENDIF
7401            horz_exit = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / nextdist
7402
7403            IF ( rad_angular_discretization  .AND.  calc_svf )  THEN
7404!
7405!--            Identify vertical obstacles hit by rays in current column
7406               DO WHILE ( lowest_free_ray > 0 )
7407                  IF ( zdirs(lowest_free_ray) > horz_entry )  EXIT
7408!
7409!--               This may only happen after 1st column, so lastdir and lastcolumn are valid
7410                  CALL request_itarget(lastdir,                                         &
7411                        CEILING(-0.5_wp + origin(1) + zdirs(lowest_free_ray)*lastdist), &
7412                        lastcolumn(1), lastcolumn(2),                                   &
7413                        target_surfl(lowest_free_ray), target_procs(lowest_free_ray))
7414                  lowest_free_ray = lowest_free_ray - 1
7415               ENDDO
7416!
7417!--            Identify horizontal obstacles hit by rays in current column
7418               DO WHILE ( lowest_free_ray > 0 )
7419                  IF ( zdirs(lowest_free_ray) > horz_exit )  EXIT
7420                  CALL request_itarget(iup_u, nzterr(ig)+1, column(1), column(2), &
7421                                       target_surfl(lowest_free_ray),           &
7422                                       target_procs(lowest_free_ray))
7423                  lowest_free_ray = lowest_free_ray - 1
7424               ENDDO
7425            ENDIF
7426
7427            horizon = MAX(horizon, horz_entry, horz_exit)
7428
7429            IF ( plant_canopy )  THEN
7430               rt2_track(:, ntrack) = column(:)
7431               rt2_track_dist(ntrack) = nextdist
7432            ENDIF
7433         ENDIF
7434
7435         IF ( ABS(distance - nextdist) < eps )  EXIT
7436
7437         IF ( rad_angular_discretization  .AND.  calc_svf )  THEN
7438!
7439!--         Save wall direction of coming building column (= this air column)
7440            IF ( seldim == 1 )  THEN
7441               IF ( dimdelta(seldim) == 1 )  THEN
7442                  lastdir = isouth_u
7443               ELSE
7444                  lastdir = inorth_u
7445               ENDIF
7446            ELSE
7447               IF ( dimdelta(seldim) == 1 )  THEN
7448                  lastdir = iwest_u
7449               ELSE
7450                  lastdir = ieast_u
7451               ENDIF
7452            ENDIF
7453            lastcolumn = column
7454         ENDIF
7455         lastdist = nextdist
7456         dimnext(seldim) = dimnext(seldim) + dimdelta(seldim)
7457         dimnextdist(seldim) = (dimnext(seldim) - .5_wp - yxorigin(seldim)) / yxdir(seldim)
7458      ENDDO
7459
7460      IF ( plant_canopy )  THEN
7461!--      Request LAD WHERE applicable
7462!--     
7463#if defined( __parallel )
7464         IF ( raytrace_mpi_rma )  THEN
7465!--         send requests for lad_s to appropriate processor
7466            !CALL cpu_log( log_point_s(77), 'usm_init_rma', 'start' )
7467            DO  i = 1, ntrack
7468               px = rt2_track(2,i)/nnx
7469               py = rt2_track(1,i)/nny
7470               ip = px*pdims(2)+py
7471               ig = ip*nnx*nny + (rt2_track(2,i)-px*nnx)*nny + rt2_track(1,i)-py*nny
7472
7473               IF ( rad_angular_discretization  .AND.  calc_svf )  THEN
7474!
7475!--               For fixed view resolution, we need plant canopy even for rays
7476!--               to opposing surfaces
7477                  lowest_lad = nzterr(ig) + 1
7478               ELSE
7479!
7480!--               We only need LAD for rays directed above horizon (to sky)
7481                  lowest_lad = CEILING( -0.5_wp + origin(1) +            &
7482                                    MIN( horizon * rt2_track_dist(i-1),  & ! entry
7483                                         horizon * rt2_track_dist(i)   ) ) ! exit
7484               ENDIF
7485!
7486!--            Skip asking for LAD where all plant canopy is under requested level
7487               IF ( plantt(ig) < lowest_lad )  CYCLE
7488
7489               wdisp = (rt2_track(2,i)-px*nnx)*(nny*nzp) + (rt2_track(1,i)-py*nny)*nzp + lowest_lad-nzub
7490               wcount = plantt(ig)-lowest_lad+1
7491               ! TODO send request ASAP - even during raytracing
7492               CALL MPI_Get(rt2_track_lad(lowest_lad:plantt(ig), i), wcount, MPI_REAL, ip,    &
7493                            wdisp, wcount, MPI_REAL, win_lad, ierr)
7494               IF ( ierr /= 0 )  THEN
7495                  WRITE(9,*) 'Error MPI_Get2:', ierr, rt2_track_lad(lowest_lad:plantt(ig), i), &
7496                             wcount, ip, wdisp, win_lad
7497                  FLUSH(9)
7498               ENDIF
7499            ENDDO
7500
7501!--         wait for all pending local requests complete
7502            ! TODO WAIT selectively for each column later when needed
7503            CALL MPI_Win_flush_local_all(win_lad, ierr)
7504            IF ( ierr /= 0 )  THEN
7505               WRITE(9,*) 'Error MPI_Win_flush_local_all2:', ierr, win_lad
7506               FLUSH(9)
7507            ENDIF
7508            !CALL cpu_log( log_point_s(77), 'usm_init_rma', 'stop' )
7509
7510         ELSE ! raytrace_mpi_rma = .F.
7511            DO  i = 1, ntrack
7512               px = rt2_track(2,i)/nnx
7513               py = rt2_track(1,i)/nny
7514               ip = px*pdims(2)+py
7515               ig = ip*nnx*nny*nzp + (rt2_track(2,i)-px*nnx)*(nny*nzp) + (rt2_track(1,i)-py*nny)*nzp
7516               rt2_track_lad(nzub:plantt_max, i) = sub_lad_g(ig:ig+nly-1)
7517            ENDDO
7518         ENDIF
7519#else
7520         DO  i = 1, ntrack
7521            rt2_track_lad(nzub:plantt_max, i) = sub_lad(rt2_track(1,i), rt2_track(2,i), nzub:plantt_max)
7522         ENDDO
7523#endif
7524      ENDIF ! plant_canopy
7525
7526      IF ( rad_angular_discretization  .AND.  calc_svf )  THEN
7527#if defined( __parallel )
7528!--      wait for all gridsurf requests to complete
7529         CALL MPI_Win_flush_local_all(win_gridsurf, ierr)
7530         IF ( ierr /= 0 )  THEN
7531            WRITE(9,*) 'Error MPI_Win_flush_local_all3:', ierr, win_gridsurf
7532            FLUSH(9)
7533         ENDIF
7534#endif
7535!
7536!--      recalculate local surf indices into global ones
7537         DO i = 1, nrays
7538            IF ( target_surfl(i) == -1 )  THEN
7539               itarget(i) = -1
7540            ELSE
7541               itarget(i) = target_surfl(i) + surfstart(target_procs(i))
7542            ENDIF
7543         ENDDO
7544         
7545         DEALLOCATE( target_surfl )
7546         
7547      ELSE
7548         itarget(:) = -1
7549      ENDIF ! rad_angular_discretization
7550
7551      IF ( plant_canopy )  THEN
7552!--      Skip the PCB around origin if requested (for MRT, the PCB might not be there)
7553!--     
7554         IF ( skip_1st_pcb  .AND.  NINT(origin(1)) <= plantt_max )  THEN
7555            rt2_track_lad(NINT(origin(1), iwp), 1) = 0._wp
7556         ENDIF
7557
7558!--      Assert that we have space allocated for CSFs
7559!--     
7560         maxboxes = (ntrack + MAX(CEILING(origin(1)-.5_wp) - nzub,          &
7561                                  nzut - CEILING(origin(1)-.5_wp))) * nrays
7562         IF ( ncsfl + maxboxes > ncsfla )  THEN
7563!--         use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1)
7564!--         k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) &
7565!--                                                / log(grow_factor)), kind=wp))
7566!--         or use this code to simply always keep some extra space after growing
7567            k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor)
7568            CALL merge_and_grow_csf(k)
7569         ENDIF
7570
7571!--      Calculate transparencies and store new CSFs
7572!--     
7573         zbottom = REAL(nzub, wp) - .5_wp
7574         ztop = REAL(plantt_max, wp) + .5_wp
7575
7576!--      Reverse direction of radiation (face->sky), only when calc_svf
7577!--     
7578         IF ( calc_svf )  THEN
7579            DO  i = 1, ntrack ! for each column
7580               dxxyy = ((dy*yxdir(1))**2 + (dx*yxdir(2))**2) * (rt2_track_dist(i)-rt2_track_dist(i-1))**2
7581               px = rt2_track(2,i)/nnx
7582               py = rt2_track(1,i)/nny
7583               ip = px*pdims(2)+py
7584
7585               DO  k = 1, nrays ! for each ray
7586!
7587!--               NOTE 6778:
7588!--               With traditional svf discretization, CSFs under the horizon
7589!--               (i.e. for surface to surface radiation)  are created in
7590!--               raytrace(). With rad_angular_discretization, we must create
7591!--               CSFs under horizon only for one direction, otherwise we would
7592!--               have duplicate amount of energy. Although we could choose
7593!--               either of the two directions (they differ only by
7594!--               discretization error with no bias), we choose the the backward
7595!--               direction, because it tends to cumulate high canopy sink
7596!--               factors closer to raytrace origin, i.e. it should potentially
7597!--               cause less moiree.
7598                  IF ( .NOT. rad_angular_discretization )  THEN
7599                     IF ( zdirs(k) <= horizon )  CYCLE
7600                  ENDIF
7601
7602                  zorig = origin(1) + zdirs(k) * rt2_track_dist(i-1)
7603                  IF ( zorig <= zbottom  .OR.  zorig >= ztop )  CYCLE
7604
7605                  zsgn = INT(SIGN(1._wp, zdirs(k)), iwp)
7606                  rt2_dist(1) = 0._wp
7607                  IF ( zdirs(k) == 0._wp )  THEN ! ray is exactly horizontal
7608                     nz = 2
7609                     rt2_dist(nz) = SQRT(dxxyy)
7610                     iz = CEILING(-.5_wp + zorig, iwp)
7611                  ELSE
7612                     zexit = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop)
7613
7614                     zb0 = FLOOR(  zorig * zsgn - .5_wp) + 1  ! because it must be greater than orig
7615                     zb1 = CEILING(zexit * zsgn - .5_wp) - 1  ! because it must be smaller than exit
7616                     nz = MAX(zb1 - zb0 + 3, 2)
7617                     rt2_dist(nz) = SQRT(((zexit-zorig)*dz(1))**2 + dxxyy)
7618                     qdist = rt2_dist(nz) / (zexit-zorig)
7619                     rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/)
7620                     iz = zb0 * zsgn
7621                  ENDIF
7622
7623                  DO  l = 2, nz
7624                     IF ( rt2_track_lad(iz, i) > 0._wp )  THEN
7625                        curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1)))
7626
7627                        IF ( create_csf )  THEN
7628                           ncsfl = ncsfl + 1
7629                           acsf(ncsfl)%ip = ip
7630                           acsf(ncsfl)%itx = rt2_track(2,i)
7631                           acsf(ncsfl)%ity = rt2_track(1,i)
7632                           acsf(ncsfl)%itz = iz
7633                           acsf(ncsfl)%isurfs = iorig
7634                           acsf(ncsfl)%rcvf = (1._wp - curtrans)*transparency(k)*vffrac(k)
7635                        ENDIF
7636
7637                        transparency(k) = transparency(k) * curtrans
7638                     ENDIF
7639                     iz = iz + zsgn
7640                  ENDDO ! l = 1, nz - 1
7641               ENDDO ! k = 1, nrays
7642            ENDDO ! i = 1, ntrack
7643
7644            transparency(1:lowest_free_ray) = 1._wp !-- Reset rays above horizon to transparent (see NOTE 6778)
7645         ENDIF
7646
7647!--      Forward direction of radiation (sky->face), always
7648!--     
7649         DO  i = ntrack, 1, -1 ! for each column backwards
7650            dxxyy = ((dy*yxdir(1))**2 + (dx*yxdir(2))**2) * (rt2_track_dist(i)-rt2_track_dist(i-1))**2
7651            px = rt2_track(2,i)/nnx
7652            py = rt2_track(1,i)/nny
7653            ip = px*pdims(2)+py
7654
7655            DO  k = 1, nrays ! for each ray
7656!
7657!--            See NOTE 6778 above
7658               IF ( zdirs(k) <= horizon )  CYCLE
7659
7660               zexit = origin(1) + zdirs(k) * rt2_track_dist(i-1)
7661               IF ( zexit <= zbottom  .OR.  zexit >= ztop )  CYCLE
7662
7663               zsgn = -INT(SIGN(1._wp, zdirs(k)), iwp)
7664               rt2_dist(1) = 0._wp
7665               IF ( zdirs(k) == 0._wp )  THEN ! ray is exactly horizontal
7666                  nz = 2
7667                  rt2_dist(nz) = SQRT(dxxyy)
7668                  iz = NINT(zexit, iwp)
7669               ELSE
7670                  zorig = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop)
7671
7672                  zb0 = FLOOR(  zorig * zsgn - .5_wp) + 1  ! because it must be greater than orig
7673                  zb1 = CEILING(zexit * zsgn - .5_wp) - 1  ! because it must be smaller than exit
7674                  nz = MAX(zb1 - zb0 + 3, 2)
7675                  rt2_dist(nz) = SQRT(((zexit-zorig)*dz(1))**2 + dxxyy)
7676                  qdist = rt2_dist(nz) / (zexit-zorig)
7677                  rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/)
7678                  iz = zb0 * zsgn
7679               ENDIF
7680
7681               DO  l = 2, nz
7682                  IF ( rt2_track_lad(iz, i) > 0._wp )  THEN
7683                     curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1)))
7684
7685                     IF ( create_csf )  THEN
7686                        ncsfl = ncsfl + 1
7687                        acsf(ncsfl)%ip = ip
7688                        acsf(ncsfl)%itx = rt2_track(2,i)
7689                        acsf(ncsfl)%ity = rt2_track(1,i)
7690                        acsf(ncsfl)%itz = iz
7691                        IF ( itarget(k) /= -1 )  ERROR STOP !FIXME remove after test
7692                        acsf(ncsfl)%isurfs = -1
7693                        acsf(ncsfl)%rcvf = (1._wp - curtrans)*transparency(k)*aorig*vffrac(k)
7694                     ENDIF  ! create_csf
7695
7696                     transparency(k) = transparency(k) * curtrans
7697                  ENDIF
7698                  iz = iz + zsgn
7699               ENDDO ! l = 1, nz - 1
7700            ENDDO ! k = 1, nrays
7701         ENDDO ! i = 1, ntrack
7702      ENDIF ! plant_canopy
7703
7704      IF ( .NOT. (rad_angular_discretization  .AND.  calc_svf) )  THEN
7705!
7706!--      Just update lowest_free_ray according to horizon
7707         DO WHILE ( lowest_free_ray > 0 )
7708            IF ( zdirs(lowest_free_ray) > horizon )  EXIT
7709            lowest_free_ray = lowest_free_ray - 1
7710         ENDDO
7711      ENDIF
7712
7713   CONTAINS
7714
7715      SUBROUTINE request_itarget( d, z, y, x, isurfl, iproc )
7716
7717         INTEGER(iwp), INTENT(in)            ::  d, z, y, x
7718         INTEGER(iwp), TARGET, INTENT(out)   ::  isurfl
7719         INTEGER(iwp), INTENT(out)           ::  iproc
7720#if defined( __parallel )
7721#else
7722         INTEGER(iwp)                        ::  target_displ  !< index of the grid in the local gridsurf array
7723#endif
7724         INTEGER(iwp)                        ::  px, py        !< number of processors in x and y direction
7725                                                               !< before the processor in the question
7726#if defined( __parallel )
7727         INTEGER(KIND=MPI_ADDRESS_KIND)      ::  target_displ  !< index of the grid in the local gridsurf array
7728
7729!
7730!--      Calculate target processor and index in the remote local target gridsurf array
7731         px = x / nnx
7732         py = y / nny
7733         iproc = px * pdims(2) + py
7734         target_displ = ((x-px*nnx) * nny + y - py*nny ) * nzu * nsurf_type_u +&
7735                        ( z-nzub ) * nsurf_type_u + d
7736!
7737!--      Send MPI_Get request to obtain index target_surfl(i)
7738         CALL MPI_GET( isurfl, 1, MPI_INTEGER, iproc, target_displ,            &
7739                       1, MPI_INTEGER, win_gridsurf, ierr)
7740         IF ( ierr /= 0 )  THEN
7741            WRITE( 9,* ) 'Error MPI_Get3:', ierr, isurfl, iproc, target_displ, &
7742                         win_gridsurf
7743            FLUSH( 9 )
7744         ENDIF
7745#else
7746!--      set index target_surfl(i)
7747         isurfl = gridsurf(d,z,y,x)
7748#endif
7749
7750      END SUBROUTINE request_itarget
7751
7752   END SUBROUTINE raytrace_2d
7753 
7754
7755!------------------------------------------------------------------------------!
7756!
7757! Description:
7758! ------------
7759!> Calculates apparent solar positions for all timesteps and stores discretized
7760!> positions.
7761!------------------------------------------------------------------------------!
7762   SUBROUTINE radiation_presimulate_solar_pos
7763      IMPLICIT NONE
7764
7765      INTEGER(iwp)                              ::  it, i, j
7766      REAL(wp)                                  ::  tsrp_prev
7767      REAL(wp)                                  ::  simulated_time_prev
7768      REAL(wp), DIMENSION(:,:), ALLOCATABLE     ::  dsidir_tmp       !< dsidir_tmp[:,i] = unit vector of i-th
7769                                                                     !< appreant solar direction
7770
7771      ALLOCATE ( dsidir_rev(0:raytrace_discrete_elevs/2-1,                 &
7772                            0:raytrace_discrete_azims-1) )
7773      dsidir_rev(:,:) = -1
7774      ALLOCATE ( dsidir_tmp(3,                                             &
7775                     raytrace_discrete_elevs/2*raytrace_discrete_azims) )
7776      ndsidir = 0
7777
7778!
7779!--   We will artificialy update time_since_reference_point and return to
7780!--   true value later
7781      tsrp_prev = time_since_reference_point
7782      simulated_time_prev = simulated_time
7783      sun_direction = .TRUE.
7784
7785!
7786!--   Process spinup time if configured
7787      IF ( spinup_time > 0._wp )  THEN
7788         DO  it = 0, CEILING(spinup_time / dt_spinup)
7789            time_since_reference_point = -spinup_time + REAL(it, wp) * dt_spinup
7790            simulated_time = simulated_time + dt_spinup
7791            CALL simulate_pos
7792         ENDDO
7793      ENDIF
7794!
7795!--   Process simulation time
7796      DO  it = 0, CEILING(( end_time - spinup_time ) / dt_radiation)
7797         time_since_reference_point = REAL(it, wp) * dt_radiation
7798         simulated_time = simulated_time + dt_spinup
7799         CALL simulate_pos
7800      ENDDO
7801
7802      time_since_reference_point = tsrp_prev
7803      simulated_time = simulated_time_prev
7804
7805!--   Allocate global vars which depend on ndsidir
7806      ALLOCATE ( dsidir ( 3, ndsidir ) )
7807      dsidir(:,:) = dsidir_tmp(:, 1:ndsidir)
7808      DEALLOCATE ( dsidir_tmp )
7809
7810      ALLOCATE ( dsitrans(nsurfl, ndsidir) )
7811      ALLOCATE ( dsitransc(npcbl, ndsidir) )
7812      IF ( nmrtbl > 0 )  ALLOCATE ( mrtdsit(nmrtbl, ndsidir) )
7813
7814      WRITE ( message_string, * ) 'Precalculated', ndsidir, ' solar positions', &
7815                                  'from', it, ' timesteps.'
7816      CALL message( 'radiation_presimulate_solar_pos', 'UI0013', 0, 0, 0, 6, 0 )
7817
7818      CONTAINS
7819
7820      !------------------------------------------------------------------------!
7821      ! Description:
7822      ! ------------
7823      !> Simuates a single position
7824      !------------------------------------------------------------------------!
7825      SUBROUTINE simulate_pos
7826         IMPLICIT NONE
7827!
7828!--      Update apparent solar position based on modified t_s_r_p
7829         CALL calc_zenith
7830         IF ( zenith(0) > 0 )  THEN
7831!--         
7832!--         Identify solar direction vector (discretized number) 1)
7833            i = MODULO(NINT(ATAN2(sun_dir_lon(0), sun_dir_lat(0))               &
7834                            / (2._wp*pi) * raytrace_discrete_azims-.5_wp, iwp), &
7835                       raytrace_discrete_azims)
7836            j = FLOOR(ACOS(zenith(0)) / pi * raytrace_discrete_elevs)
7837            IF ( dsidir_rev(j, i) == -1 )  THEN
7838               ndsidir = ndsidir + 1
7839               dsidir_tmp(:, ndsidir) =                                              &
7840                     (/ COS((REAL(j,wp)+.5_wp) * pi      / raytrace_discrete_elevs), &
7841                        SIN((REAL(j,wp)+.5_wp) * pi      / raytrace_discrete_elevs)  &
7842                      * COS((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims), &
7843                        SIN((REAL(j,wp)+.5_wp) * pi      / raytrace_discrete_elevs)  &
7844                      * SIN((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims) /)
7845               dsidir_rev(j, i) = ndsidir
7846            ENDIF
7847         ENDIF
7848      END SUBROUTINE simulate_pos
7849
7850   END SUBROUTINE radiation_presimulate_solar_pos
7851
7852
7853
7854!------------------------------------------------------------------------------!
7855! Description:
7856! ------------
7857!> Determines whether two faces are oriented towards each other. Since the
7858!> surfaces follow the gird box surfaces, it checks first whether the two surfaces
7859!> are directed in the same direction, then it checks if the two surfaces are
7860!> located in confronted direction but facing away from each other, e.g. <--| |-->
7861!------------------------------------------------------------------------------!
7862    PURE LOGICAL FUNCTION surface_facing(x, y, z, d, x2, y2, z2, d2)
7863        IMPLICIT NONE
7864        INTEGER(iwp),   INTENT(in)  :: x, y, z, d, x2, y2, z2, d2
7865     
7866        surface_facing = .FALSE.
7867
7868!-- first check: are the two surfaces directed in the same direction
7869        IF ( (d==iup_u  .OR.  d==iup_l )                             &
7870             .AND. (d2==iup_u  .OR. d2==iup_l) ) RETURN
7871        IF ( (d==isouth_u  .OR.  d==isouth_l ) &
7872             .AND.  (d2==isouth_u  .OR.  d2==isouth_l) ) RETURN
7873        IF ( (d==inorth_u  .OR.  d==inorth_l ) &
7874             .AND.  (d2==inorth_u  .OR.  d2==inorth_l) ) RETURN
7875        IF ( (d==iwest_u  .OR.  d==iwest_l )     &
7876             .AND.  (d2==iwest_u  .OR.  d2==iwest_l ) ) RETURN
7877        IF ( (d==ieast_u  .OR.  d==ieast_l )     &
7878             .AND.  (d2==ieast_u  .OR.  d2==ieast_l ) ) RETURN
7879
7880!-- second check: are surfaces facing away from each other
7881        SELECT CASE (d)
7882            CASE (iup_u, iup_l)                     !< upward facing surfaces
7883                IF ( z2 < z ) RETURN
7884            CASE (isouth_u, isouth_l)               !< southward facing surfaces
7885                IF ( y2 > y ) RETURN
7886            CASE (inorth_u, inorth_l)               !< northward facing surfaces
7887                IF ( y2 < y ) RETURN
7888            CASE (iwest_u, iwest_l)                 !< westward facing surfaces
7889                IF ( x2 > x ) RETURN
7890            CASE (ieast_u, ieast_l)                 !< eastward facing surfaces
7891                IF ( x2 < x ) RETURN
7892        END SELECT
7893
7894        SELECT CASE (d2)
7895            CASE (iup_u)                            !< ground, roof
7896                IF ( z < z2 ) RETURN
7897            CASE (isouth_u, isouth_l)               !< south facing
7898                IF ( y > y2 ) RETURN
7899            CASE (inorth_u, inorth_l)               !< north facing
7900                IF ( y < y2 ) RETURN
7901            CASE (iwest_u, iwest_l)                 !< west facing
7902                IF ( x > x2 ) RETURN
7903            CASE (ieast_u, ieast_l)                 !< east facing
7904                IF ( x < x2 ) RETURN
7905            CASE (-1)
7906                CONTINUE
7907        END SELECT
7908
7909        surface_facing = .TRUE.
7910       
7911    END FUNCTION surface_facing
7912
7913
7914!------------------------------------------------------------------------------!
7915!
7916! Description:
7917! ------------
7918!> Soubroutine reads svf and svfsurf data from saved file
7919!> SVF means sky view factors and CSF means canopy sink factors
7920!------------------------------------------------------------------------------!
7921    SUBROUTINE radiation_read_svf
7922
7923       IMPLICIT NONE
7924       
7925       CHARACTER(rad_version_len)   :: rad_version_field
7926       
7927       INTEGER(iwp)                 :: i
7928       INTEGER(iwp)                 :: ndsidir_from_file = 0
7929       INTEGER(iwp)                 :: npcbl_from_file = 0
7930       INTEGER(iwp)                 :: nsurfl_from_file = 0
7931       
7932       DO  i = 0, io_blocks-1
7933          IF ( i == io_group )  THEN
7934
7935!
7936!--          numprocs_previous_run is only known in case of reading restart
7937!--          data. If a new initial run which reads svf data is started the
7938!--          following query will be skipped
7939             IF ( initializing_actions == 'read_restart_data' ) THEN
7940
7941                IF ( numprocs_previous_run /= numprocs ) THEN
7942                   WRITE( message_string, * ) 'A different number of ',        &
7943                                              'processors between the run ',   &
7944                                              'that has written the svf data ',&
7945                                              'and the one that will read it ',&
7946                                              'is not allowed' 
7947                   CALL message( 'check_open', 'PA0491', 1, 2, 0, 6, 0 )
7948                ENDIF
7949
7950             ENDIF
7951             
7952!
7953!--          Open binary file
7954             CALL check_open( 88 )
7955
7956!
7957!--          read and check version
7958             READ ( 88 ) rad_version_field
7959             IF ( TRIM(rad_version_field) /= TRIM(rad_version) )  THEN
7960                 WRITE( message_string, * ) 'Version of binary SVF file "',    &
7961                             TRIM(rad_version_field), '" does not match ',     &
7962                             'the version of model "', TRIM(rad_version), '"'
7963                 CALL message( 'radiation_read_svf', 'PA0482', 1, 2, 0, 6, 0 )
7964             ENDIF
7965             
7966!
7967!--          read nsvfl, ncsfl, nsurfl
7968             READ ( 88 ) nsvfl, ncsfl, nsurfl_from_file, npcbl_from_file,      &
7969                         ndsidir_from_file
7970             
7971             IF ( nsvfl < 0  .OR.  ncsfl < 0 )  THEN
7972                 WRITE( message_string, * ) 'Wrong number of SVF or CSF'
7973                 CALL message( 'radiation_read_svf', 'PA0483', 1, 2, 0, 6, 0 )
7974             ELSE
7975                 WRITE(message_string,*) '    Number of SVF, CSF, and nsurfl ',&
7976                                         'to read', nsvfl, ncsfl,              &
7977                                         nsurfl_from_file
7978                 CALL location_message( message_string, .TRUE. )
7979             ENDIF
7980             
7981             IF ( nsurfl_from_file /= nsurfl )  THEN
7982                 WRITE( message_string, * ) 'nsurfl from SVF file does not ',  &
7983                                            'match calculated nsurfl from ',   &
7984                                            'radiation_interaction_init'
7985                 CALL message( 'radiation_read_svf', 'PA0490', 1, 2, 0, 6, 0 )
7986             ENDIF
7987             
7988             IF ( npcbl_from_file /= npcbl )  THEN
7989                 WRITE( message_string, * ) 'npcbl from SVF file does not ',   &
7990                                            'match calculated npcbl from ',    &
7991                                            'radiation_interaction_init'
7992                 CALL message( 'radiation_read_svf', 'PA0493', 1, 2, 0, 6, 0 )
7993             ENDIF
7994             
7995             IF ( ndsidir_from_file /= ndsidir )  THEN
7996                 WRITE( message_string, * ) 'ndsidir from SVF file does not ', &
7997                                            'match calculated ndsidir from ',  &
7998                                            'radiation_presimulate_solar_pos'
7999                 CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 )
8000             ENDIF
8001             
8002!
8003!--          Arrays skyvf, skyvft, dsitrans and dsitransc are allready
8004!--          allocated in radiation_interaction_init and
8005!--          radiation_presimulate_solar_pos
8006             IF ( nsurfl > 0 )  THEN
8007                READ(88) skyvf
8008                READ(88) skyvft
8009                READ(88) dsitrans 
8010             ENDIF
8011             
8012             IF ( plant_canopy  .AND.  npcbl > 0 ) THEN
8013                READ ( 88 )  dsitransc
8014             ENDIF
8015             
8016!
8017!--          The allocation of svf, svfsurf, csf and csfsurf happens in routine
8018!--          radiation_calc_svf which is not called if the program enters
8019!--          radiation_read_svf. Therefore these arrays has to allocate in the
8020!--          following
8021             IF ( nsvfl > 0 )  THEN
8022                ALLOCATE( svf(ndsvf,nsvfl) )
8023                ALLOCATE( svfsurf(idsvf,nsvfl) )
8024                READ(88) svf
8025                READ(88) svfsurf
8026             ENDIF
8027
8028             IF ( plant_canopy  .AND.  ncsfl > 0 )  THEN
8029                ALLOCATE( csf(ndcsf,ncsfl) )
8030                ALLOCATE( csfsurf(idcsf,ncsfl) )
8031                READ(88) csf
8032                READ(88) csfsurf
8033             ENDIF
8034             
8035!
8036!--          Close binary file                 
8037             CALL close_file( 88 )
8038               
8039          ENDIF
8040#if defined( __parallel )
8041          CALL MPI_BARRIER( comm2d, ierr )
8042#endif
8043       ENDDO
8044
8045    END SUBROUTINE radiation_read_svf
8046
8047
8048!------------------------------------------------------------------------------!
8049!
8050! Description:
8051! ------------
8052!> Subroutine stores svf, svfsurf, csf and csfsurf data to a file.
8053!------------------------------------------------------------------------------!
8054    SUBROUTINE radiation_write_svf
8055
8056       IMPLICIT NONE
8057       
8058       INTEGER(iwp)        :: i
8059
8060       DO  i = 0, io_blocks-1
8061          IF ( i == io_group )  THEN
8062!
8063!--          Open binary file
8064             CALL check_open( 89 )
8065
8066             WRITE ( 89 )  rad_version
8067             WRITE ( 89 )  nsvfl, ncsfl, nsurfl, npcbl, ndsidir
8068             IF ( nsurfl > 0 ) THEN
8069                WRITE ( 89 )  skyvf
8070                WRITE ( 89 )  skyvft
8071                WRITE ( 89 )  dsitrans
8072             ENDIF
8073             IF ( npcbl > 0 ) THEN
8074                WRITE ( 89 )  dsitransc
8075             ENDIF
8076             IF ( nsvfl > 0 ) THEN
8077                WRITE ( 89 )  svf
8078                WRITE ( 89 )  svfsurf
8079             ENDIF
8080             IF ( plant_canopy  .AND.  ncsfl > 0 )  THEN
8081                 WRITE ( 89 )  csf
8082                 WRITE ( 89 )  csfsurf
8083             ENDIF
8084
8085!
8086!--          Close binary file                 
8087             CALL close_file( 89 )
8088
8089          ENDIF
8090#if defined( __parallel )
8091          CALL MPI_BARRIER( comm2d, ierr )
8092#endif
8093       ENDDO
8094    END SUBROUTINE radiation_write_svf
8095
8096!------------------------------------------------------------------------------!
8097!
8098! Description:
8099! ------------
8100!> Block of auxiliary subroutines:
8101!> 1. quicksort and corresponding comparison
8102!> 2. merge_and_grow_csf for implementation of "dynamical growing"
8103!>    array for csf
8104!------------------------------------------------------------------------------!
8105!-- quicksort.f -*-f90-*-
8106!-- Author: t-nissie, adaptation J.Resler
8107!-- License: GPLv3
8108!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
8109    RECURSIVE SUBROUTINE quicksort_itarget(itarget, vffrac, ztransp, first, last)
8110        IMPLICIT NONE
8111        INTEGER(iwp), DIMENSION(:), INTENT(INOUT)   :: itarget
8112        REAL(wp), DIMENSION(:), INTENT(INOUT)       :: vffrac, ztransp
8113        INTEGER(iwp), INTENT(IN)                    :: first, last
8114        INTEGER(iwp)                                :: x, t
8115        INTEGER(iwp)                                :: i, j
8116        REAL(wp)                                    :: tr
8117
8118        IF ( first>=last ) RETURN
8119        x = itarget((first+last)/2)
8120        i = first
8121        j = last
8122        DO
8123            DO WHILE ( itarget(i) < x )
8124               i=i+1
8125            ENDDO
8126            DO WHILE ( x < itarget(j) )
8127                j=j-1
8128            ENDDO
8129            IF ( i >= j ) EXIT
8130            t = itarget(i);  itarget(i) = itarget(j);  itarget(j) = t
8131            tr = vffrac(i);  vffrac(i) = vffrac(j);  vffrac(j) = tr
8132            tr = ztransp(i);  ztransp(i) = ztransp(j);  ztransp(j) = tr
8133            i=i+1
8134            j=j-1
8135        ENDDO
8136        IF ( first < i-1 ) CALL quicksort_itarget(itarget, vffrac, ztransp, first, i-1)
8137        IF ( j+1 < last )  CALL quicksort_itarget(itarget, vffrac, ztransp, j+1, last)
8138    END SUBROUTINE quicksort_itarget
8139
8140    PURE FUNCTION svf_lt(svf1,svf2) result (res)
8141      TYPE (t_svf), INTENT(in) :: svf1,svf2
8142      LOGICAL                  :: res
8143      IF ( svf1%isurflt < svf2%isurflt  .OR.    &
8144          (svf1%isurflt == svf2%isurflt  .AND.  svf1%isurfs < svf2%isurfs) )  THEN
8145          res = .TRUE.
8146      ELSE
8147          res = .FALSE.
8148      ENDIF
8149    END FUNCTION svf_lt
8150
8151
8152!-- quicksort.f -*-f90-*-
8153!-- Author: t-nissie, adaptation J.Resler
8154!-- License: GPLv3
8155!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
8156    RECURSIVE SUBROUTINE quicksort_svf(svfl, first, last)
8157        IMPLICIT NONE
8158        TYPE(t_svf), DIMENSION(:), INTENT(INOUT)  :: svfl
8159        INTEGER(iwp), INTENT(IN)                  :: first, last
8160        TYPE(t_svf)                               :: x, t
8161        INTEGER(iwp)                              :: i, j
8162
8163        IF ( first>=last ) RETURN
8164        x = svfl( (first+last) / 2 )
8165        i = first
8166        j = last
8167        DO
8168            DO while ( svf_lt(svfl(i),x) )
8169               i=i+1
8170            ENDDO
8171            DO while ( svf_lt(x,svfl(j)) )
8172                j=j-1
8173            ENDDO
8174            IF ( i >= j ) EXIT
8175            t = svfl(i);  svfl(i) = svfl(j);  svfl(j) = t
8176            i=i+1
8177            j=j-1
8178        ENDDO
8179        IF ( first < i-1 ) CALL quicksort_svf(svfl, first, i-1)
8180        IF ( j+1 < last )  CALL quicksort_svf(svfl, j+1, last)
8181    END SUBROUTINE quicksort_svf
8182
8183    PURE FUNCTION csf_lt(csf1,csf2) result (res)
8184      TYPE (t_csf), INTENT(in) :: csf1,csf2
8185      LOGICAL                  :: res
8186      IF ( csf1%ip < csf2%ip  .OR.    &
8187           (csf1%ip == csf2%ip  .AND.  csf1%itx < csf2%itx)  .OR.  &
8188           (csf1%ip == csf2%ip  .AND.  csf1%itx == csf2%itx  .AND.  csf1%ity < csf2%ity)  .OR.  &
8189           (csf1%ip == csf2%ip  .AND.  csf1%itx == csf2%itx  .AND.  csf1%ity == csf2%ity  .AND.   &
8190            csf1%itz < csf2%itz)  .OR.  &
8191           (csf1%ip == csf2%ip  .AND.  csf1%itx == csf2%itx  .AND.  csf1%ity == csf2%ity  .AND.   &
8192            csf1%itz == csf2%itz  .AND.  csf1%isurfs < csf2%isurfs) )  THEN
8193          res = .TRUE.
8194      ELSE
8195          res = .FALSE.
8196      ENDIF
8197    END FUNCTION csf_lt
8198
8199
8200!-- quicksort.f -*-f90-*-
8201!-- Author: t-nissie, adaptation J.Resler
8202!-- License: GPLv3
8203!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
8204    RECURSIVE SUBROUTINE quicksort_csf(csfl, first, last)
8205        IMPLICIT NONE
8206        TYPE(t_csf), DIMENSION(:), INTENT(INOUT)  :: csfl
8207        INTEGER(iwp), INTENT(IN)                  :: first, last
8208        TYPE(t_csf)                               :: x, t
8209        INTEGER(iwp)                              :: i, j
8210
8211        IF ( first>=last ) RETURN
8212        x = csfl( (first+last)/2 )
8213        i = first
8214        j = last
8215        DO
8216            DO while ( csf_lt(csfl(i),x) )
8217                i=i+1
8218            ENDDO
8219            DO while ( csf_lt(x,csfl(j)) )
8220                j=j-1
8221            ENDDO
8222            IF ( i >= j ) EXIT
8223            t = csfl(i);  csfl(i) = csfl(j);  csfl(j) = t
8224            i=i+1
8225            j=j-1
8226        ENDDO
8227        IF ( first < i-1 ) CALL quicksort_csf(csfl, first, i-1)
8228        IF ( j+1 < last )  CALL quicksort_csf(csfl, j+1, last)
8229    END SUBROUTINE quicksort_csf
8230
8231   
8232    SUBROUTINE merge_and_grow_csf(newsize)
8233        INTEGER(iwp), INTENT(in)                :: newsize  !< new array size after grow, must be >= ncsfl
8234                                                            !< or -1 to shrink to minimum
8235        INTEGER(iwp)                            :: iread, iwrite
8236        TYPE(t_csf), DIMENSION(:), POINTER      :: acsfnew
8237        CHARACTER(100)                          :: msg
8238
8239        IF ( newsize == -1 )  THEN
8240!--         merge in-place
8241            acsfnew => acsf
8242        ELSE
8243!--         allocate new array
8244            IF ( mcsf == 0 )  THEN
8245                ALLOCATE( acsf1(newsize) )
8246                acsfnew => acsf1
8247            ELSE
8248                ALLOCATE( acsf2(newsize) )
8249                acsfnew => acsf2
8250            ENDIF
8251        ENDIF
8252
8253        IF ( ncsfl >= 1 )  THEN
8254!--         sort csf in place (quicksort)
8255            CALL quicksort_csf(acsf,1,ncsfl)
8256
8257!--         while moving to a new array, aggregate canopy sink factor records with identical box & source
8258            acsfnew(1) = acsf(1)
8259            iwrite = 1
8260            DO iread = 2, ncsfl
8261!--             here acsf(kcsf) already has values from acsf(icsf)
8262                IF ( acsfnew(iwrite)%itx == acsf(iread)%itx &
8263                         .AND.  acsfnew(iwrite)%ity == acsf(iread)%ity &
8264                         .AND.  acsfnew(iwrite)%itz == acsf(iread)%itz &
8265                         .AND.  acsfnew(iwrite)%isurfs == acsf(iread)%isurfs )  THEN
8266
8267                    acsfnew(iwrite)%rcvf = acsfnew(iwrite)%rcvf + acsf(iread)%rcvf
8268!--                 advance reading index, keep writing index
8269                ELSE
8270!--                 not identical, just advance and copy
8271                    iwrite = iwrite + 1
8272                    acsfnew(iwrite) = acsf(iread)
8273                ENDIF
8274            ENDDO
8275            ncsfl = iwrite
8276        ENDIF
8277
8278        IF ( newsize == -1 )  THEN
8279!--         allocate new array and copy shrinked data
8280            IF ( mcsf == 0 )  THEN
8281                ALLOCATE( acsf1(ncsfl) )
8282                acsf1(1:ncsfl) = acsf2(1:ncsfl)
8283            ELSE
8284                ALLOCATE( acsf2(ncsfl) )
8285                acsf2(1:ncsfl) = acsf1(1:ncsfl)
8286            ENDIF
8287        ENDIF
8288
8289!--     deallocate old array
8290        IF ( mcsf == 0 )  THEN
8291            mcsf = 1
8292            acsf => acsf1
8293            DEALLOCATE( acsf2 )
8294        ELSE
8295            mcsf = 0
8296            acsf => acsf2
8297            DEALLOCATE( acsf1 )
8298        ENDIF
8299        ncsfla = newsize
8300
8301        WRITE(msg,'(A,2I12)') 'Grow acsf2:',ncsfl,ncsfla
8302        CALL radiation_write_debug_log( msg )
8303
8304    END SUBROUTINE merge_and_grow_csf
8305
8306   
8307!-- quicksort.f -*-f90-*-
8308!-- Author: t-nissie, adaptation J.Resler
8309!-- License: GPLv3
8310!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
8311    RECURSIVE SUBROUTINE quicksort_csf2(kpcsflt, pcsflt, first, last)
8312        IMPLICIT NONE
8313        INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT)  :: kpcsflt
8314        REAL(wp), DIMENSION(:,:), INTENT(INOUT)      :: pcsflt
8315        INTEGER(iwp), INTENT(IN)                     :: first, last
8316        REAL(wp), DIMENSION(ndcsf)                   :: t2
8317        INTEGER(iwp), DIMENSION(kdcsf)               :: x, t1
8318        INTEGER(iwp)                                 :: i, j
8319
8320        IF ( first>=last ) RETURN
8321        x = kpcsflt(:, (first+last)/2 )
8322        i = first
8323        j = last
8324        DO
8325            DO while ( csf_lt2(kpcsflt(:,i),x) )
8326                i=i+1
8327            ENDDO
8328            DO while ( csf_lt2(x,kpcsflt(:,j)) )
8329                j=j-1
8330            ENDDO
8331            IF ( i >= j ) EXIT
8332            t1 = kpcsflt(:,i);  kpcsflt(:,i) = kpcsflt(:,j);  kpcsflt(:,j) = t1
8333            t2 = pcsflt(:,i);  pcsflt(:,i) = pcsflt(:,j);  pcsflt(:,j) = t2
8334            i=i+1
8335            j=j-1
8336        ENDDO
8337        IF ( first < i-1 ) CALL quicksort_csf2(kpcsflt, pcsflt, first, i-1)
8338        IF ( j+1 < last )  CALL quicksort_csf2(kpcsflt, pcsflt, j+1, last)
8339    END SUBROUTINE quicksort_csf2
8340   
8341
8342    PURE FUNCTION csf_lt2(item1, item2) result(res)
8343        INTEGER(iwp), DIMENSION(kdcsf), INTENT(in)  :: item1, item2
8344        LOGICAL                                     :: res
8345        res = ( (item1(3) < item2(3))                                                        &
8346             .OR.  (item1(3) == item2(3)  .AND.  item1(2) < item2(2))                            &
8347             .OR.  (item1(3) == item2(3)  .AND.  item1(2) == item2(2)  .AND.  item1(1) < item2(1)) &
8348             .OR.  (item1(3) == item2(3)  .AND.  item1(2) == item2(2)  .AND.  item1(1) == item2(1) &
8349                 .AND.  item1(4) < item2(4)) )
8350    END FUNCTION csf_lt2
8351
8352    PURE FUNCTION searchsorted(athresh, val) result(ind)
8353        REAL(wp), DIMENSION(:), INTENT(IN)  :: athresh
8354        REAL(wp), INTENT(IN)                :: val
8355        INTEGER(iwp)                        :: ind
8356        INTEGER(iwp)                        :: i
8357
8358        DO i = LBOUND(athresh, 1), UBOUND(athresh, 1)
8359            IF ( val < athresh(i) ) THEN
8360                ind = i - 1
8361                RETURN
8362            ENDIF
8363        ENDDO
8364        ind = UBOUND(athresh, 1)
8365    END FUNCTION searchsorted
8366
8367!------------------------------------------------------------------------------!
8368! Description:
8369! ------------
8370!
8371!> radiation_radflux_gridbox subroutine gives the sw and lw radiation fluxes at the
8372!> faces of a gridbox defined at i,j,k and located in the urban layer.
8373!> The total sw and the diffuse sw radiation as well as the lw radiation fluxes at
8374!> the gridbox 6 faces are stored in sw_gridbox, swd_gridbox, and lw_gridbox arrays,
8375!> respectively, in the following order:
8376!>  up_face, down_face, north_face, south_face, east_face, west_face
8377!>
8378!> The subroutine reports also how successful was the search process via the parameter
8379!> i_feedback as follow:
8380!> - i_feedback =  1 : successful
8381!> - i_feedback = -1 : unsuccessful; the requisted point is outside the urban domain
8382!> - i_feedback =  0 : uncomplete; some gridbox faces fluxes are missing
8383!>
8384!>
8385!> It is called outside from usm_urban_surface_mod whenever the radiation fluxes
8386!> are needed.
8387!>
8388!> This routine is not used so far. However, it may serve as an interface for radiation
8389!> fluxes of urban and land surfaces
8390!>
8391!> TODO:
8392!>    - Compare performance when using some combination of the Fortran intrinsic
8393!>      functions, e.g. MINLOC, MAXLOC, ALL, ANY and COUNT functions, which search
8394!>      surfl array for elements meeting user-specified criterion, i.e. i,j,k
8395!>    - Report non-found or incomplete radiation fluxes arrays , if any, at the
8396!>      gridbox faces in an error message form
8397!>
8398!------------------------------------------------------------------------------!
8399    SUBROUTINE radiation_radflux_gridbox(i,j,k,sw_gridbox,swd_gridbox,lw_gridbox,i_feedback)
8400       
8401        IMPLICIT NONE
8402
8403        INTEGER(iwp),                 INTENT(in)  :: i,j,k                 !< gridbox indices at which fluxes are required
8404        INTEGER(iwp)                              :: ii,jj,kk,d            !< surface indices and type
8405        INTEGER(iwp)                              :: l                     !< surface id
8406        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
8407        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
8408        INTEGER(iwp),                 INTENT(out) :: i_feedback            !< feedback to report how the search was successful
8409
8410
8411!-- initialize variables
8412        i_feedback  = -999999
8413        sw_gridbox  = -999999.9_wp
8414        lw_gridbox  = -999999.9_wp
8415        swd_gridbox = -999999.9_wp
8416       
8417!-- check the requisted grid indices
8418        IF ( k < nzb   .OR.  k > nzut  .OR.   &
8419             j < nysg  .OR.  j > nyng  .OR.   &
8420             i < nxlg  .OR.  i > nxrg         &
8421             ) THEN
8422           i_feedback = -1
8423           RETURN
8424        ENDIF
8425
8426!-- search for the required grid and formulate the fluxes at the 6 gridbox faces
8427        DO l = 1, nsurfl
8428            ii = surfl(ix,l)
8429            jj = surfl(iy,l)
8430            kk = surfl(iz,l)
8431
8432            IF ( ii == i  .AND.  jj == j  .AND.  kk == k ) THEN
8433               d = surfl(id,l)
8434
8435               SELECT CASE ( d )
8436
8437               CASE (iup_u,iup_l)                          !- gridbox up_facing face
8438                  sw_gridbox(1) = surfinsw(l)
8439                  lw_gridbox(1) = surfinlw(l)
8440                  swd_gridbox(1) = surfinswdif(l)
8441
8442               CASE (inorth_u,inorth_l)                    !- gridbox north_facing face
8443                  sw_gridbox(3) = surfinsw(l)
8444                  lw_gridbox(3) = surfinlw(l)
8445                  swd_gridbox(3) = surfinswdif(l)
8446
8447               CASE (isouth_u,isouth_l)                    !- gridbox south_facing face
8448                  sw_gridbox(4) = surfinsw(l)
8449                  lw_gridbox(4) = surfinlw(l)
8450                  swd_gridbox(4) = surfinswdif(l)
8451
8452               CASE (ieast_u,ieast_l)                      !- gridbox east_facing face
8453                  sw_gridbox(5) = surfinsw(l)
8454                  lw_gridbox(5) = surfinlw(l)
8455                  swd_gridbox(5) = surfinswdif(l)
8456
8457               CASE (iwest_u,iwest_l)                      !- gridbox west_facing face
8458                  sw_gridbox(6) = surfinsw(l)
8459                  lw_gridbox(6) = surfinlw(l)
8460                  swd_gridbox(6) = surfinswdif(l)
8461
8462               END SELECT
8463
8464            ENDIF
8465
8466        IF ( ALL( sw_gridbox(:)  /= -999999.9_wp )  ) EXIT
8467        ENDDO
8468
8469!-- check the completeness of the fluxes at all gidbox faces       
8470!-- TODO: report non-found or incomplete rad fluxes arrays in an error message form
8471        IF ( ANY( sw_gridbox(:)  <= -999999.9_wp )  .OR.   &
8472             ANY( swd_gridbox(:) <= -999999.9_wp )  .OR.   &
8473             ANY( lw_gridbox(:)  <= -999999.9_wp ) ) THEN
8474           i_feedback = 0
8475        ELSE
8476           i_feedback = 1
8477        ENDIF
8478       
8479        RETURN
8480       
8481    END SUBROUTINE radiation_radflux_gridbox
8482
8483!------------------------------------------------------------------------------!
8484!
8485! Description:
8486! ------------
8487!> Subroutine for averaging 3D data
8488!------------------------------------------------------------------------------!
8489SUBROUTINE radiation_3d_data_averaging( mode, variable )
8490 
8491
8492    USE control_parameters
8493
8494    USE indices
8495
8496    USE kinds
8497
8498    IMPLICIT NONE
8499
8500    CHARACTER (LEN=*) ::  mode    !<
8501    CHARACTER (LEN=*) :: variable !<
8502
8503    LOGICAL      ::  match_lsm !< flag indicating natural-type surface
8504    LOGICAL      ::  match_usm !< flag indicating urban-type surface
8505   
8506    INTEGER(iwp) ::  i !<
8507    INTEGER(iwp) ::  j !<
8508    INTEGER(iwp) ::  k !<
8509    INTEGER(iwp) ::  l, m !< index of current surface element
8510
8511    IF ( mode == 'allocate' )  THEN
8512
8513       SELECT CASE ( TRIM( variable ) )
8514
8515             CASE ( 'rad_net*' )
8516                IF ( .NOT. ALLOCATED( rad_net_av ) )  THEN
8517                   ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
8518                ENDIF
8519                rad_net_av = 0.0_wp
8520             
8521             CASE ( 'rad_lw_in*' )
8522                IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) )  THEN
8523                   ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
8524                ENDIF
8525                rad_lw_in_xy_av = 0.0_wp
8526               
8527             CASE ( 'rad_lw_out*' )
8528                IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) )  THEN
8529                   ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
8530                ENDIF
8531                rad_lw_out_xy_av = 0.0_wp
8532               
8533             CASE ( 'rad_sw_in*' )
8534                IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) )  THEN
8535                   ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
8536                ENDIF
8537                rad_sw_in_xy_av = 0.0_wp
8538               
8539             CASE ( 'rad_sw_out*' )
8540                IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) )  THEN
8541                   ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
8542                ENDIF
8543                rad_sw_out_xy_av = 0.0_wp               
8544
8545             CASE ( 'rad_lw_in' )
8546                IF ( .NOT. ALLOCATED( rad_lw_in_av ) )  THEN
8547                   ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8548                ENDIF
8549                rad_lw_in_av = 0.0_wp
8550
8551             CASE ( 'rad_lw_out' )
8552                IF ( .NOT. ALLOCATED( rad_lw_out_av ) )  THEN
8553                   ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8554                ENDIF
8555                rad_lw_out_av = 0.0_wp
8556
8557             CASE ( 'rad_lw_cs_hr' )
8558                IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) )  THEN
8559                   ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
8560                ENDIF
8561                rad_lw_cs_hr_av = 0.0_wp
8562
8563             CASE ( 'rad_lw_hr' )
8564                IF ( .NOT. ALLOCATED( rad_lw_hr_av ) )  THEN
8565                   ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
8566                ENDIF
8567                rad_lw_hr_av = 0.0_wp
8568
8569             CASE ( 'rad_sw_in' )
8570                IF ( .NOT. ALLOCATED( rad_sw_in_av ) )  THEN
8571                   ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8572                ENDIF
8573                rad_sw_in_av = 0.0_wp
8574
8575             CASE ( 'rad_sw_out' )
8576                IF ( .NOT. ALLOCATED( rad_sw_out_av ) )  THEN
8577                   ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
8578                ENDIF
8579                rad_sw_out_av = 0.0_wp
8580
8581             CASE ( 'rad_sw_cs_hr' )
8582                IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) )  THEN
8583                   ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
8584                ENDIF
8585                rad_sw_cs_hr_av = 0.0_wp
8586
8587             CASE ( 'rad_sw_hr' )
8588                IF ( .NOT. ALLOCATED( rad_sw_hr_av ) )  THEN
8589                   ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
8590                ENDIF
8591                rad_sw_hr_av = 0.0_wp
8592
8593             CASE ( 'rad_mrt_sw' )
8594                IF ( .NOT. ALLOCATED( mrtinsw_av ) )  THEN
8595                   ALLOCATE( mrtinsw_av(nmrtbl) )
8596                ENDIF
8597                mrtinsw_av = 0.0_wp
8598
8599             CASE ( 'rad_mrt_lw' )
8600                IF ( .NOT. ALLOCATED( mrtinlw_av ) )  THEN
8601                   ALLOCATE( mrtinlw_av(nmrtbl) )
8602                ENDIF
8603                mrtinlw_av = 0.0_wp
8604
8605             CASE ( 'rad_mrt' )
8606                IF ( .NOT. ALLOCATED( mrt_av ) )  THEN
8607                   ALLOCATE( mrt_av(nmrtbl) )
8608                ENDIF
8609                mrt_av = 0.0_wp
8610
8611          CASE DEFAULT
8612             CONTINUE
8613
8614       END SELECT
8615
8616    ELSEIF ( mode == 'sum' )  THEN
8617
8618       SELECT CASE ( TRIM( variable ) )
8619
8620          CASE ( 'rad_net*' )
8621             IF ( ALLOCATED( rad_net_av ) ) THEN
8622                DO  i = nxl, nxr
8623                   DO  j = nys, nyn
8624                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
8625                                  surf_lsm_h%end_index(j,i)
8626                      match_usm = surf_usm_h%start_index(j,i) <=               &
8627                                  surf_usm_h%end_index(j,i)
8628
8629                     IF ( match_lsm  .AND.  .NOT. match_usm )  THEN
8630                         m = surf_lsm_h%end_index(j,i)
8631                         rad_net_av(j,i) = rad_net_av(j,i) +                   &
8632                                         surf_lsm_h%rad_net(m)
8633                      ELSEIF ( match_usm )  THEN
8634                         m = surf_usm_h%end_index(j,i)
8635                         rad_net_av(j,i) = rad_net_av(j,i) +                   &
8636                                         surf_usm_h%rad_net(m)
8637                      ENDIF
8638                   ENDDO
8639                ENDDO
8640             ENDIF
8641
8642          CASE ( 'rad_lw_in*' )
8643             IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
8644                DO  i = nxl, nxr
8645                   DO  j = nys, nyn
8646                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
8647                                  surf_lsm_h%end_index(j,i)
8648                      match_usm = surf_usm_h%start_index(j,i) <=               &
8649                                  surf_usm_h%end_index(j,i)
8650
8651                      IF ( match_lsm  .AND.  .NOT. match_usm )  THEN
8652                         m = surf_lsm_h%end_index(j,i)
8653                         rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) +         &
8654                                         surf_lsm_h%rad_lw_in(m)
8655                      ELSEIF ( match_usm )  THEN
8656                         m = surf_usm_h%end_index(j,i)
8657                         rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) +         &
8658                                         surf_usm_h%rad_lw_in(m)
8659                      ENDIF
8660                   ENDDO
8661                ENDDO
8662             ENDIF
8663             
8664          CASE ( 'rad_lw_out*' )
8665             IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
8666                DO  i = nxl, nxr
8667                   DO  j = nys, nyn
8668                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
8669                                  surf_lsm_h%end_index(j,i)
8670                      match_usm = surf_usm_h%start_index(j,i) <=               &
8671                                  surf_usm_h%end_index(j,i)
8672
8673                      IF ( match_lsm  .AND.  .NOT. match_usm )  THEN
8674                         m = surf_lsm_h%end_index(j,i)
8675                         rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) +       &
8676                                                 surf_lsm_h%rad_lw_out(m)
8677                      ELSEIF ( match_usm )  THEN
8678                         m = surf_usm_h%end_index(j,i)
8679                         rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) +       &
8680                                                 surf_usm_h%rad_lw_out(m)
8681                      ENDIF
8682                   ENDDO
8683                ENDDO
8684             ENDIF
8685             
8686          CASE ( 'rad_sw_in*' )
8687             IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
8688                DO  i = nxl, nxr
8689                   DO  j = nys, nyn
8690                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
8691                                  surf_lsm_h%end_index(j,i)
8692                      match_usm = surf_usm_h%start_index(j,i) <=               &
8693                                  surf_usm_h%end_index(j,i)
8694
8695                      IF ( match_lsm  .AND.  .NOT. match_usm )  THEN
8696                         m = surf_lsm_h%end_index(j,i)
8697                         rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) +         &
8698                                                surf_lsm_h%rad_sw_in(m)
8699                      ELSEIF ( match_usm )  THEN
8700                         m = surf_usm_h%end_index(j,i)
8701                         rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) +         &
8702                                                surf_usm_h%rad_sw_in(m)
8703                      ENDIF
8704                   ENDDO
8705                ENDDO
8706             ENDIF
8707             
8708          CASE ( 'rad_sw_out*' )
8709             IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
8710                DO  i = nxl, nxr
8711                   DO  j = nys, nyn
8712                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
8713                                  surf_lsm_h%end_index(j,i)
8714                      match_usm = surf_usm_h%start_index(j,i) <=               &
8715                                  surf_usm_h%end_index(j,i)
8716
8717                      IF ( match_lsm  .AND.  .NOT. match_usm )  THEN
8718                         m = surf_lsm_h%end_index(j,i)
8719                         rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) +       &
8720                                                 surf_lsm_h%rad_sw_out(m)
8721                      ELSEIF ( match_usm )  THEN
8722                         m = surf_usm_h%end_index(j,i)
8723                         rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) +       &
8724                                                 surf_usm_h%rad_sw_out(m)
8725                      ENDIF
8726                   ENDDO
8727                ENDDO
8728             ENDIF
8729             
8730          CASE ( 'rad_lw_in' )
8731             IF ( ALLOCATED( rad_lw_in_av ) ) THEN
8732                DO  i = nxlg, nxrg
8733                   DO  j = nysg, nyng
8734                      DO  k = nzb, nzt+1
8735                         rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i)             &
8736                                               + rad_lw_in(k,j,i)
8737                      ENDDO
8738                   ENDDO
8739                ENDDO
8740             ENDIF
8741
8742          CASE ( 'rad_lw_out' )
8743             IF ( ALLOCATED( rad_lw_out_av ) ) THEN
8744                DO  i = nxlg, nxrg
8745                   DO  j = nysg, nyng
8746                      DO  k = nzb, nzt+1
8747                         rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i)           &
8748                                                + rad_lw_out(k,j,i)
8749                      ENDDO
8750                   ENDDO
8751                ENDDO
8752             ENDIF
8753
8754          CASE ( 'rad_lw_cs_hr' )
8755             IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN
8756                DO  i = nxlg, nxrg
8757                   DO  j = nysg, nyng
8758                      DO  k = nzb, nzt+1
8759                         rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i)       &
8760                                                  + rad_lw_cs_hr(k,j,i)
8761                      ENDDO
8762                   ENDDO
8763                ENDDO
8764             ENDIF
8765
8766          CASE ( 'rad_lw_hr' )
8767             IF ( ALLOCATED( rad_lw_hr_av ) ) THEN
8768                DO  i = nxlg, nxrg
8769                   DO  j = nysg, nyng
8770                      DO  k = nzb, nzt+1
8771                         rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i)             &
8772                                               + rad_lw_hr(k,j,i)
8773                      ENDDO
8774                   ENDDO
8775                ENDDO
8776             ENDIF
8777
8778          CASE ( 'rad_sw_in' )
8779             IF ( ALLOCATED( rad_sw_in_av ) ) THEN
8780                DO  i = nxlg, nxrg
8781                   DO  j = nysg, nyng
8782                      DO  k = nzb, nzt+1
8783                         rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i)             &
8784                                               + rad_sw_in(k,j,i)
8785                      ENDDO
8786                   ENDDO
8787                ENDDO
8788             ENDIF
8789
8790          CASE ( 'rad_sw_out' )
8791             IF ( ALLOCATED( rad_sw_out_av ) ) THEN
8792                DO  i = nxlg, nxrg
8793                   DO  j = nysg, nyng
8794                      DO  k = nzb, nzt+1
8795                         rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i)           &
8796                                                + rad_sw_out(k,j,i)
8797                      ENDDO
8798                   ENDDO
8799                ENDDO
8800             ENDIF
8801
8802          CASE ( 'rad_sw_cs_hr' )
8803             IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN
8804                DO  i = nxlg, nxrg
8805                   DO  j = nysg, nyng
8806                      DO  k = nzb, nzt+1
8807                         rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i)       &
8808                                                  + rad_sw_cs_hr(k,j,i)
8809                      ENDDO
8810                   ENDDO
8811                ENDDO
8812             ENDIF
8813
8814          CASE ( 'rad_sw_hr' )
8815             IF ( ALLOCATED( rad_sw_hr_av ) ) THEN
8816                DO  i = nxlg, nxrg
8817                   DO  j = nysg, nyng
8818                      DO  k = nzb, nzt+1
8819                         rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i)             &
8820                                               + rad_sw_hr(k,j,i)
8821                      ENDDO
8822                   ENDDO
8823                ENDDO
8824             ENDIF
8825
8826          CASE ( 'rad_mrt_sw' )
8827             IF ( ALLOCATED( mrtinsw_av ) )  THEN
8828                mrtinsw_av(:) = mrtinsw_av(:) + mrtinsw(:)
8829             ENDIF
8830
8831          CASE ( 'rad_mrt_lw' )
8832             IF ( ALLOCATED( mrtinlw_av ) )  THEN
8833                mrtinlw_av(:) = mrtinlw_av(:) + mrtinlw(:)
8834             ENDIF
8835
8836          CASE ( 'rad_mrt' )
8837             IF ( ALLOCATED( mrt_av ) )  THEN
8838                mrt_av(:) = mrt_av(:) + mrt(:)
8839             ENDIF
8840
8841          CASE DEFAULT
8842             CONTINUE
8843
8844       END SELECT
8845
8846    ELSEIF ( mode == 'average' )  THEN
8847
8848       SELECT CASE ( TRIM( variable ) )
8849
8850          CASE ( 'rad_net*' )
8851             IF ( ALLOCATED( rad_net_av ) ) THEN
8852                DO  i = nxlg, nxrg
8853                   DO  j = nysg, nyng
8854                      rad_net_av(j,i) = rad_net_av(j,i)                        &
8855                                        / REAL( average_count_3d, KIND=wp )
8856                   ENDDO
8857                ENDDO
8858             ENDIF
8859             
8860          CASE ( 'rad_lw_in*' )
8861             IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
8862                DO  i = nxlg, nxrg
8863                   DO  j = nysg, nyng
8864                      rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i)              &
8865                                        / REAL( average_count_3d, KIND=wp )
8866                   ENDDO
8867                ENDDO
8868             ENDIF
8869             
8870          CASE ( 'rad_lw_out*' )
8871             IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
8872                DO  i = nxlg, nxrg
8873                   DO  j = nysg, nyng
8874                      rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i)            &
8875                                        / REAL( average_count_3d, KIND=wp )
8876                   ENDDO
8877                ENDDO
8878             ENDIF
8879             
8880          CASE ( 'rad_sw_in*' )
8881             IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
8882                DO  i = nxlg, nxrg
8883                   DO  j = nysg, nyng
8884                      rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i)              &
8885                                        / REAL( average_count_3d, KIND=wp )
8886                   ENDDO
8887                ENDDO
8888             ENDIF
8889             
8890          CASE ( 'rad_sw_out*' )
8891             IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
8892                DO  i = nxlg, nxrg
8893                   DO  j = nysg, nyng
8894                      rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i)             &
8895                                        / REAL( average_count_3d, KIND=wp )
8896                   ENDDO
8897                ENDDO
8898             ENDIF
8899
8900          CASE ( 'rad_lw_in' )
8901             IF ( ALLOCATED( rad_lw_in_av ) ) THEN
8902                DO  i = nxlg, nxrg
8903                   DO  j = nysg, nyng
8904                      DO  k = nzb, nzt+1
8905                         rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i)             &
8906                                               / REAL( average_count_3d, KIND=wp )
8907                      ENDDO
8908                   ENDDO
8909                ENDDO
8910             ENDIF
8911
8912          CASE ( 'rad_lw_out' )
8913             IF ( ALLOCATED( rad_lw_out_av ) ) THEN
8914                DO  i = nxlg, nxrg
8915                   DO  j = nysg, nyng
8916                      DO  k = nzb, nzt+1
8917                         rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i)           &
8918                                                / REAL( average_count_3d, KIND=wp )
8919                      ENDDO
8920                   ENDDO
8921                ENDDO
8922             ENDIF
8923
8924          CASE ( 'rad_lw_cs_hr' )
8925             IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN
8926                DO  i = nxlg, nxrg
8927                   DO  j = nysg, nyng
8928                      DO  k = nzb, nzt+1
8929                         rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i)       &
8930                                                / REAL( average_count_3d, KIND=wp )
8931                      ENDDO
8932                   ENDDO
8933                ENDDO
8934             ENDIF
8935
8936          CASE ( 'rad_lw_hr' )
8937             IF ( ALLOCATED( rad_lw_hr_av ) ) THEN
8938                DO  i = nxlg, nxrg
8939                   DO  j = nysg, nyng
8940                      DO  k = nzb, nzt+1
8941                         rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i)             &
8942                                               / REAL( average_count_3d, KIND=wp )
8943                      ENDDO
8944                   ENDDO
8945                ENDDO
8946             ENDIF
8947
8948          CASE ( 'rad_sw_in' )
8949             IF ( ALLOCATED( rad_sw_in_av ) ) THEN
8950                DO  i = nxlg, nxrg
8951                   DO  j = nysg, nyng
8952                      DO  k = nzb, nzt+1
8953                         rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i)             &
8954                                               / REAL( average_count_3d, KIND=wp )
8955                      ENDDO
8956                   ENDDO
8957                ENDDO
8958             ENDIF
8959
8960          CASE ( 'rad_sw_out' )
8961             IF ( ALLOCATED( rad_sw_out_av ) ) THEN
8962                DO  i = nxlg, nxrg
8963                   DO  j = nysg, nyng
8964                      DO  k = nzb, nzt+1
8965                         rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i)           &
8966                                                / REAL( average_count_3d, KIND=wp )
8967                      ENDDO
8968                   ENDDO
8969                ENDDO
8970             ENDIF
8971
8972          CASE ( 'rad_sw_cs_hr' )
8973             IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN
8974                DO  i = nxlg, nxrg
8975                   DO  j = nysg, nyng
8976                      DO  k = nzb, nzt+1
8977                         rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i)       &
8978                                                / REAL( average_count_3d, KIND=wp )
8979                      ENDDO
8980                   ENDDO
8981                ENDDO
8982             ENDIF
8983
8984          CASE ( 'rad_sw_hr' )
8985             IF ( ALLOCATED( rad_sw_hr_av ) ) THEN
8986                DO  i = nxlg, nxrg
8987                   DO  j = nysg, nyng
8988                      DO  k = nzb, nzt+1
8989                         rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i)             &
8990                                               / REAL( average_count_3d, KIND=wp )
8991                      ENDDO
8992                   ENDDO
8993                ENDDO
8994             ENDIF
8995
8996          CASE ( 'rad_mrt_sw' )
8997             IF ( ALLOCATED( mrtinsw_av ) )  THEN
8998                mrtinsw_av(:) = mrtinsw_av(:)  / REAL( average_count_3d, KIND=wp )
8999             ENDIF
9000
9001          CASE ( 'rad_mrt_lw' )
9002             IF ( ALLOCATED( mrtinlw_av ) )  THEN
9003                mrtinlw_av(:) = mrtinlw_av(:) / REAL( average_count_3d, KIND=wp )
9004             ENDIF
9005
9006          CASE ( 'rad_mrt' )
9007             IF ( ALLOCATED( mrt_av ) )  THEN
9008                mrt_av(:) = mrt_av(:) / REAL( average_count_3d, KIND=wp )
9009             ENDIF
9010
9011       END SELECT
9012
9013    ENDIF
9014
9015END SUBROUTINE radiation_3d_data_averaging
9016
9017
9018!------------------------------------------------------------------------------!
9019!
9020! Description:
9021! ------------
9022!> Subroutine defining appropriate grid for netcdf variables.
9023!> It is called out from subroutine netcdf.
9024!------------------------------------------------------------------------------!
9025SUBROUTINE radiation_define_netcdf_grid( var, found, grid_x, grid_y, grid_z )
9026   
9027    IMPLICIT NONE
9028
9029    CHARACTER (LEN=*), INTENT(IN)  ::  var         !<
9030    LOGICAL, INTENT(OUT)           ::  found       !<
9031    CHARACTER (LEN=*), INTENT(OUT) ::  grid_x      !<
9032    CHARACTER (LEN=*), INTENT(OUT) ::  grid_y      !<
9033    CHARACTER (LEN=*), INTENT(OUT) ::  grid_z      !<
9034
9035    found  = .TRUE.
9036
9037!
9038!-- Check for the grid
9039    SELECT CASE ( TRIM( var ) )
9040
9041       CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_sw_cs_hr', 'rad_sw_hr',        &
9042              'rad_lw_cs_hr_xy', 'rad_lw_hr_xy', 'rad_sw_cs_hr_xy',            &
9043              'rad_sw_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_hr_xz',               &
9044              'rad_sw_cs_hr_xz', 'rad_sw_hr_xz', 'rad_lw_cs_hr_yz',            &
9045              'rad_lw_hr_yz', 'rad_sw_cs_hr_yz', 'rad_sw_hr_yz',               &
9046              'rad_mrt', 'rad_mrt_sw', 'rad_mrt_lw' )
9047          grid_x = 'x'
9048          grid_y = 'y'
9049          grid_z = 'zu'
9050
9051       CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out',            &
9052              'rad_lw_in_xy', 'rad_lw_out_xy', 'rad_sw_in_xy','rad_sw_out_xy', &
9053              'rad_lw_in_xz', 'rad_lw_out_xz', 'rad_sw_in_xz','rad_sw_out_xz', &
9054              'rad_lw_in_yz', 'rad_lw_out_yz', 'rad_sw_in_yz','rad_sw_out_yz' )
9055          grid_x = 'x'
9056          grid_y = 'y'
9057          grid_z = 'zw'
9058
9059
9060       CASE DEFAULT
9061          found  = .FALSE.
9062          grid_x = 'none'
9063          grid_y = 'none'
9064          grid_z = 'none'
9065
9066        END SELECT
9067
9068    END SUBROUTINE radiation_define_netcdf_grid
9069
9070!------------------------------------------------------------------------------!
9071!
9072! Description:
9073! ------------
9074!> Subroutine defining 2D output variables
9075!------------------------------------------------------------------------------!
9076 SUBROUTINE radiation_data_output_2d( av, variable, found, grid, mode,         &
9077                                      local_pf, two_d, nzb_do, nzt_do )
9078 
9079    USE indices
9080
9081    USE kinds
9082
9083
9084    IMPLICIT NONE
9085
9086    CHARACTER (LEN=*) ::  grid     !<
9087    CHARACTER (LEN=*) ::  mode     !<
9088    CHARACTER (LEN=*) ::  variable !<
9089
9090    INTEGER(iwp) ::  av !<
9091    INTEGER(iwp) ::  i  !<
9092    INTEGER(iwp) ::  j  !<
9093    INTEGER(iwp) ::  k  !<
9094    INTEGER(iwp) ::  m  !< index of surface element at grid point (j,i)
9095    INTEGER(iwp) ::  nzb_do   !<
9096    INTEGER(iwp) ::  nzt_do   !<
9097
9098    LOGICAL      ::  found !<
9099    LOGICAL      ::  two_d !< flag parameter that indicates 2D variables (horizontal cross sections)
9100
9101    REAL(wp) ::  fill_value = -999.0_wp    !< value for the _FillValue attribute
9102
9103    REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) ::  local_pf !<
9104
9105    found = .TRUE.
9106
9107    SELECT CASE ( TRIM( variable ) )
9108
9109       CASE ( 'rad_net*_xy' )        ! 2d-array
9110          IF ( av == 0 ) THEN
9111             DO  i = nxl, nxr
9112                DO  j = nys, nyn
9113!
9114!--                Obtain rad_net from its respective surface type
9115!--                Natural-type surfaces
9116                   DO  m = surf_lsm_h%start_index(j,i),                        &
9117                           surf_lsm_h%end_index(j,i) 
9118                      local_pf(i,j,nzb+1) = surf_lsm_h%rad_net(m)
9119                   ENDDO
9120!
9121!--                Urban-type surfaces
9122                   DO  m = surf_usm_h%start_index(j,i),                        &
9123                           surf_usm_h%end_index(j,i) 
9124                      local_pf(i,j,nzb+1) = surf_usm_h%rad_net(m)
9125                   ENDDO
9126                ENDDO
9127             ENDDO
9128          ELSE
9129             IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
9130                ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
9131                rad_net_av = REAL( fill_value, KIND = wp )
9132             ENDIF
9133             DO  i = nxl, nxr
9134                DO  j = nys, nyn 
9135                   local_pf(i,j,nzb+1) = rad_net_av(j,i)
9136                ENDDO
9137             ENDDO
9138          ENDIF
9139          two_d = .TRUE.
9140          grid = 'zu1'
9141         
9142       CASE ( 'rad_lw_in*_xy' )        ! 2d-array
9143          IF ( av == 0 ) THEN
9144             DO  i = nxl, nxr
9145                DO  j = nys, nyn
9146!
9147!--                Obtain rad_net from its respective surface type
9148!--                Natural-type surfaces
9149                   DO  m = surf_lsm_h%start_index(j,i),                        &
9150                           surf_lsm_h%end_index(j,i) 
9151                      local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_in(m)
9152                   ENDDO
9153!
9154!--                Urban-type surfaces
9155                   DO  m = surf_usm_h%start_index(j,i),                        &
9156                           surf_usm_h%end_index(j,i) 
9157                      local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_in(m)
9158                   ENDDO
9159                ENDDO
9160             ENDDO
9161          ELSE
9162             IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
9163                ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
9164                rad_lw_in_xy_av = REAL( fill_value, KIND = wp )
9165             ENDIF
9166             DO  i = nxl, nxr
9167                DO  j = nys, nyn 
9168                   local_pf(i,j,nzb+1) = rad_lw_in_xy_av(j,i)
9169                ENDDO
9170             ENDDO
9171          ENDIF
9172          two_d = .TRUE.
9173          grid = 'zu1'
9174         
9175       CASE ( 'rad_lw_out*_xy' )        ! 2d-array
9176          IF ( av == 0 ) THEN
9177             DO  i = nxl, nxr
9178                DO  j = nys, nyn
9179!
9180!--                Obtain rad_net from its respective surface type
9181!--                Natural-type surfaces
9182                   DO  m = surf_lsm_h%start_index(j,i),                        &
9183                           surf_lsm_h%end_index(j,i) 
9184                      local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_out(m)
9185                   ENDDO
9186!
9187!--                Urban-type surfaces
9188                   DO  m = surf_usm_h%start_index(j,i),                        &
9189                           surf_usm_h%end_index(j,i) 
9190                      local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_out(m)
9191                   ENDDO
9192                ENDDO
9193             ENDDO
9194          ELSE
9195             IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
9196                ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
9197                rad_lw_out_xy_av = REAL( fill_value, KIND = wp )
9198             ENDIF
9199             DO  i = nxl, nxr
9200                DO  j = nys, nyn 
9201                   local_pf(i,j,nzb+1) = rad_lw_out_xy_av(j,i)
9202                ENDDO
9203             ENDDO
9204          ENDIF
9205          two_d = .TRUE.
9206          grid = 'zu1'
9207         
9208       CASE ( 'rad_sw_in*_xy' )        ! 2d-array
9209          IF ( av == 0 ) THEN
9210             DO  i = nxl, nxr
9211                DO  j = nys, nyn
9212!
9213!--                Obtain rad_net from its respective surface type
9214!--                Natural-type surfaces
9215                   DO  m = surf_lsm_h%start_index(j,i),                        &
9216                           surf_lsm_h%end_index(j,i) 
9217                      local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_in(m)
9218                   ENDDO
9219!
9220!--                Urban-type surfaces
9221                   DO  m = surf_usm_h%start_index(j,i),                        &
9222                           surf_usm_h%end_index(j,i) 
9223                      local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_in(m)
9224                   ENDDO
9225                ENDDO
9226             ENDDO
9227          ELSE
9228             IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
9229                ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
9230                rad_sw_in_xy_av = REAL( fill_value, KIND = wp )
9231             ENDIF
9232             DO  i = nxl, nxr
9233                DO  j = nys, nyn 
9234                   local_pf(i,j,nzb+1) = rad_sw_in_xy_av(j,i)
9235                ENDDO
9236             ENDDO
9237          ENDIF
9238          two_d = .TRUE.
9239          grid = 'zu1'
9240         
9241       CASE ( 'rad_sw_out*_xy' )        ! 2d-array
9242          IF ( av == 0 ) THEN
9243             DO  i = nxl, nxr
9244                DO  j = nys, nyn
9245!
9246!--                Obtain rad_net from its respective surface type
9247!--                Natural-type surfaces
9248                   DO  m = surf_lsm_h%start_index(j,i),                        &
9249                           surf_lsm_h%end_index(j,i) 
9250                      local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_out(m)
9251                   ENDDO
9252!
9253!--                Urban-type surfaces
9254                   DO  m = surf_usm_h%start_index(j,i),                        &
9255                           surf_usm_h%end_index(j,i) 
9256                      local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_out(m)
9257                   ENDDO
9258                ENDDO
9259             ENDDO
9260          ELSE
9261             IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
9262                ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
9263                rad_sw_out_xy_av = REAL( fill_value, KIND = wp )
9264             ENDIF
9265             DO  i = nxl, nxr
9266                DO  j = nys, nyn 
9267                   local_pf(i,j,nzb+1) = rad_sw_out_xy_av(j,i)
9268                ENDDO
9269             ENDDO
9270          ENDIF
9271          two_d = .TRUE.
9272          grid = 'zu1'         
9273         
9274       CASE ( 'rad_lw_in_xy', 'rad_lw_in_xz', 'rad_lw_in_yz' )
9275          IF ( av == 0 ) THEN
9276             DO  i = nxl, nxr
9277                DO  j = nys, nyn
9278                   DO  k = nzb_do, nzt_do
9279                      local_pf(i,j,k) = rad_lw_in(k,j,i)
9280                   ENDDO
9281                ENDDO
9282             ENDDO
9283          ELSE
9284            IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
9285               ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9286               rad_lw_in_av = REAL( fill_value, KIND = wp )
9287            ENDIF
9288             DO  i = nxl, nxr
9289                DO  j = nys, nyn 
9290                   DO  k = nzb_do, nzt_do
9291                      local_pf(i,j,k) = rad_lw_in_av(k,j,i)
9292                   ENDDO
9293                ENDDO
9294             ENDDO
9295          ENDIF
9296          IF ( mode == 'xy' )  grid = 'zu'
9297
9298       CASE ( 'rad_lw_out_xy', 'rad_lw_out_xz', 'rad_lw_out_yz' )
9299          IF ( av == 0 ) THEN
9300             DO  i = nxl, nxr
9301                DO  j = nys, nyn
9302                   DO  k = nzb_do, nzt_do
9303                      local_pf(i,j,k) = rad_lw_out(k,j,i)
9304                   ENDDO
9305                ENDDO
9306             ENDDO
9307          ELSE
9308            IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
9309               ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9310               rad_lw_out_av = REAL( fill_value, KIND = wp )
9311            ENDIF
9312             DO  i = nxl, nxr
9313                DO  j = nys, nyn 
9314                   DO  k = nzb_do, nzt_do
9315                      local_pf(i,j,k) = rad_lw_out_av(k,j,i)
9316                   ENDDO
9317                ENDDO
9318             ENDDO
9319          ENDIF   
9320          IF ( mode == 'xy' )  grid = 'zu'
9321
9322       CASE ( 'rad_lw_cs_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_cs_hr_yz' )
9323          IF ( av == 0 ) THEN
9324             DO  i = nxl, nxr
9325                DO  j = nys, nyn
9326                   DO  k = nzb_do, nzt_do
9327                      local_pf(i,j,k) = rad_lw_cs_hr(k,j,i)
9328                   ENDDO
9329                ENDDO
9330             ENDDO
9331          ELSE
9332            IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
9333               ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9334               rad_lw_cs_hr_av = REAL( fill_value, KIND = wp )
9335            ENDIF
9336             DO  i = nxl, nxr
9337                DO  j = nys, nyn 
9338                   DO  k = nzb_do, nzt_do
9339                      local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i)
9340                   ENDDO
9341                ENDDO
9342             ENDDO
9343          ENDIF
9344          IF ( mode == 'xy' )  grid = 'zw'
9345
9346       CASE ( 'rad_lw_hr_xy', 'rad_lw_hr_xz', 'rad_lw_hr_yz' )
9347          IF ( av == 0 ) THEN
9348             DO  i = nxl, nxr
9349                DO  j = nys, nyn
9350                   DO  k = nzb_do, nzt_do
9351                      local_pf(i,j,k) = rad_lw_hr(k,j,i)
9352                   ENDDO
9353                ENDDO
9354             ENDDO
9355          ELSE
9356            IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
9357               ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9358               rad_lw_hr_av= REAL( fill_value, KIND = wp )
9359            ENDIF
9360             DO  i = nxl, nxr
9361                DO  j = nys, nyn 
9362                   DO  k = nzb_do, nzt_do
9363                      local_pf(i,j,k) = rad_lw_hr_av(k,j,i)
9364                   ENDDO
9365                ENDDO
9366             ENDDO
9367          ENDIF
9368          IF ( mode == 'xy' )  grid = 'zw'
9369
9370       CASE ( 'rad_sw_in_xy', 'rad_sw_in_xz', 'rad_sw_in_yz' )
9371          IF ( av == 0 ) THEN
9372             DO  i = nxl, nxr
9373                DO  j = nys, nyn
9374                   DO  k = nzb_do, nzt_do
9375                      local_pf(i,j,k) = rad_sw_in(k,j,i)
9376                   ENDDO
9377                ENDDO
9378             ENDDO
9379          ELSE
9380            IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
9381               ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9382               rad_sw_in_av = REAL( fill_value, KIND = wp )
9383            ENDIF
9384             DO  i = nxl, nxr
9385                DO  j = nys, nyn 
9386                   DO  k = nzb_do, nzt_do
9387                      local_pf(i,j,k) = rad_sw_in_av(k,j,i)
9388                   ENDDO
9389                ENDDO
9390             ENDDO
9391          ENDIF
9392          IF ( mode == 'xy' )  grid = 'zu'
9393
9394       CASE ( 'rad_sw_out_xy', 'rad_sw_out_xz', 'rad_sw_out_yz' )
9395          IF ( av == 0 ) THEN
9396             DO  i = nxl, nxr
9397                DO  j = nys, nyn
9398                   DO  k = nzb_do, nzt_do
9399                      local_pf(i,j,k) = rad_sw_out(k,j,i)
9400                   ENDDO
9401                ENDDO
9402             ENDDO
9403          ELSE
9404            IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
9405               ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9406               rad_sw_out_av = REAL( fill_value, KIND = wp )
9407            ENDIF
9408             DO  i = nxl, nxr
9409                DO  j = nys, nyn 
9410                   DO  k = nzb, nzt+1
9411                      local_pf(i,j,k) = rad_sw_out_av(k,j,i)
9412                   ENDDO
9413                ENDDO
9414             ENDDO
9415          ENDIF
9416          IF ( mode == 'xy' )  grid = 'zu'
9417
9418       CASE ( 'rad_sw_cs_hr_xy', 'rad_sw_cs_hr_xz', 'rad_sw_cs_hr_yz' )
9419          IF ( av == 0 ) THEN
9420             DO  i = nxl, nxr
9421                DO  j = nys, nyn
9422                   DO  k = nzb_do, nzt_do
9423                      local_pf(i,j,k) = rad_sw_cs_hr(k,j,i)
9424                   ENDDO
9425                ENDDO
9426             ENDDO
9427          ELSE
9428            IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
9429               ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9430               rad_sw_cs_hr_av = REAL( fill_value, KIND = wp )
9431            ENDIF
9432             DO  i = nxl, nxr
9433                DO  j = nys, nyn 
9434                   DO  k = nzb_do, nzt_do
9435                      local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i)
9436                   ENDDO
9437                ENDDO
9438             ENDDO
9439          ENDIF
9440          IF ( mode == 'xy' )  grid = 'zw'
9441
9442       CASE ( 'rad_sw_hr_xy', 'rad_sw_hr_xz', 'rad_sw_hr_yz' )
9443          IF ( av == 0 ) THEN
9444             DO  i = nxl, nxr
9445                DO  j = nys, nyn
9446                   DO  k = nzb_do, nzt_do
9447                      local_pf(i,j,k) = rad_sw_hr(k,j,i)
9448                   ENDDO
9449                ENDDO
9450             ENDDO
9451          ELSE
9452            IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
9453               ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9454               rad_sw_hr_av = REAL( fill_value, KIND = wp )
9455            ENDIF
9456             DO  i = nxl, nxr
9457                DO  j = nys, nyn 
9458                   DO  k = nzb_do, nzt_do
9459                      local_pf(i,j,k) = rad_sw_hr_av(k,j,i)
9460                   ENDDO
9461                ENDDO
9462             ENDDO
9463          ENDIF
9464          IF ( mode == 'xy' )  grid = 'zw'
9465
9466       CASE DEFAULT
9467          found = .FALSE.
9468          grid  = 'none'
9469
9470    END SELECT
9471 
9472 END SUBROUTINE radiation_data_output_2d
9473
9474
9475!------------------------------------------------------------------------------!
9476!
9477! Description:
9478! ------------
9479!> Subroutine defining 3D output variables
9480!------------------------------------------------------------------------------!
9481 SUBROUTINE radiation_data_output_3d( av, variable, found, local_pf, nzb_do, nzt_do )
9482 
9483
9484    USE indices
9485
9486    USE kinds
9487
9488
9489    IMPLICIT NONE
9490
9491    CHARACTER (LEN=*) ::  variable !<
9492
9493    INTEGER(iwp) ::  av          !<
9494    INTEGER(iwp) ::  i, j, k, l  !<
9495    INTEGER(iwp) ::  nzb_do      !<
9496    INTEGER(iwp) ::  nzt_do      !<
9497
9498    LOGICAL      ::  found       !<
9499
9500    REAL(wp)     ::  fill_value = -999.0_wp    !< value for the _FillValue attribute
9501
9502    REAL(sp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) ::  local_pf !<
9503
9504    found = .TRUE.
9505
9506
9507    SELECT CASE ( TRIM( variable ) )
9508
9509      CASE ( 'rad_sw_in' )
9510         IF ( av == 0 )  THEN
9511            DO  i = nxl, nxr
9512               DO  j = nys, nyn
9513                  DO  k = nzb_do, nzt_do
9514                     local_pf(i,j,k) = rad_sw_in(k,j,i)
9515                  ENDDO
9516               ENDDO
9517            ENDDO
9518         ELSE
9519            IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
9520               ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9521               rad_sw_in_av = REAL( fill_value, KIND = wp )
9522            ENDIF
9523            DO  i = nxl, nxr
9524               DO  j = nys, nyn
9525                  DO  k = nzb_do, nzt_do
9526                     local_pf(i,j,k) = rad_sw_in_av(k,j,i)
9527                  ENDDO
9528               ENDDO
9529            ENDDO
9530         ENDIF
9531
9532      CASE ( 'rad_sw_out' )
9533         IF ( av == 0 )  THEN
9534            DO  i = nxl, nxr
9535               DO  j = nys, nyn
9536                  DO  k = nzb_do, nzt_do
9537                     local_pf(i,j,k) = rad_sw_out(k,j,i)
9538                  ENDDO
9539               ENDDO
9540            ENDDO
9541         ELSE
9542            IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
9543               ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9544               rad_sw_out_av = REAL( fill_value, KIND = wp )
9545            ENDIF
9546            DO  i = nxl, nxr
9547               DO  j = nys, nyn
9548                  DO  k = nzb_do, nzt_do
9549                     local_pf(i,j,k) = rad_sw_out_av(k,j,i)
9550                  ENDDO
9551               ENDDO
9552            ENDDO
9553         ENDIF
9554
9555      CASE ( 'rad_sw_cs_hr' )
9556         IF ( av == 0 )  THEN
9557            DO  i = nxl, nxr
9558               DO  j = nys, nyn
9559                  DO  k = nzb_do, nzt_do
9560                     local_pf(i,j,k) = rad_sw_cs_hr(k,j,i)
9561                  ENDDO
9562               ENDDO
9563            ENDDO
9564         ELSE
9565            IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
9566               ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9567               rad_sw_cs_hr_av = REAL( fill_value, KIND = wp )
9568            ENDIF
9569            DO  i = nxl, nxr
9570               DO  j = nys, nyn
9571                  DO  k = nzb_do, nzt_do
9572                     local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i)
9573                  ENDDO
9574               ENDDO
9575            ENDDO
9576         ENDIF
9577
9578      CASE ( 'rad_sw_hr' )
9579         IF ( av == 0 )  THEN
9580            DO  i = nxl, nxr
9581               DO  j = nys, nyn
9582                  DO  k = nzb_do, nzt_do
9583                     local_pf(i,j,k) = rad_sw_hr(k,j,i)
9584                  ENDDO
9585               ENDDO
9586            ENDDO
9587         ELSE
9588            IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
9589               ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9590               rad_sw_hr_av = REAL( fill_value, KIND = wp )
9591            ENDIF
9592            DO  i = nxl, nxr
9593               DO  j = nys, nyn
9594                  DO  k = nzb_do, nzt_do
9595                     local_pf(i,j,k) = rad_sw_hr_av(k,j,i)
9596                  ENDDO
9597               ENDDO
9598            ENDDO
9599         ENDIF
9600
9601      CASE ( 'rad_lw_in' )
9602         IF ( av == 0 )  THEN
9603            DO  i = nxl, nxr
9604               DO  j = nys, nyn
9605                  DO  k = nzb_do, nzt_do
9606                     local_pf(i,j,k) = rad_lw_in(k,j,i)
9607                  ENDDO
9608               ENDDO
9609            ENDDO
9610         ELSE
9611            IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
9612               ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9613               rad_lw_in_av = REAL( fill_value, KIND = wp )
9614            ENDIF
9615            DO  i = nxl, nxr
9616               DO  j = nys, nyn
9617                  DO  k = nzb_do, nzt_do
9618                     local_pf(i,j,k) = rad_lw_in_av(k,j,i)
9619                  ENDDO
9620               ENDDO
9621            ENDDO
9622         ENDIF
9623
9624      CASE ( 'rad_lw_out' )
9625         IF ( av == 0 )  THEN
9626            DO  i = nxl, nxr
9627               DO  j = nys, nyn
9628                  DO  k = nzb_do, nzt_do
9629                     local_pf(i,j,k) = rad_lw_out(k,j,i)
9630                  ENDDO
9631               ENDDO
9632            ENDDO
9633         ELSE
9634            IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
9635               ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9636               rad_lw_out_av = REAL( fill_value, KIND = wp )
9637            ENDIF
9638            DO  i = nxl, nxr
9639               DO  j = nys, nyn
9640                  DO  k = nzb_do, nzt_do
9641                     local_pf(i,j,k) = rad_lw_out_av(k,j,i)
9642                  ENDDO
9643               ENDDO
9644            ENDDO
9645         ENDIF
9646
9647      CASE ( 'rad_lw_cs_hr' )
9648         IF ( av == 0 )  THEN
9649            DO  i = nxl, nxr
9650               DO  j = nys, nyn
9651                  DO  k = nzb_do, nzt_do
9652                     local_pf(i,j,k) = rad_lw_cs_hr(k,j,i)
9653                  ENDDO
9654               ENDDO
9655            ENDDO
9656         ELSE
9657            IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
9658               ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9659               rad_lw_cs_hr_av = REAL( fill_value, KIND = wp )
9660            ENDIF
9661            DO  i = nxl, nxr
9662               DO  j = nys, nyn
9663                  DO  k = nzb_do, nzt_do
9664                     local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i)
9665                  ENDDO
9666               ENDDO
9667            ENDDO
9668         ENDIF
9669
9670      CASE ( 'rad_lw_hr' )
9671         IF ( av == 0 )  THEN
9672            DO  i = nxl, nxr
9673               DO  j = nys, nyn
9674                  DO  k = nzb_do, nzt_do
9675                     local_pf(i,j,k) = rad_lw_hr(k,j,i)
9676                  ENDDO
9677               ENDDO
9678            ENDDO
9679         ELSE
9680            IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
9681               ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9682              rad_lw_hr_av = REAL( fill_value, KIND = wp )
9683            ENDIF
9684            DO  i = nxl, nxr
9685               DO  j = nys, nyn
9686                  DO  k = nzb_do, nzt_do
9687                     local_pf(i,j,k) = rad_lw_hr_av(k,j,i)
9688                  ENDDO
9689               ENDDO
9690            ENDDO
9691         ENDIF
9692
9693      CASE ( 'rad_mrt_sw' )
9694         local_pf = REAL( fill_value, KIND = wp )
9695         IF ( av == 0 )  THEN
9696            DO  l = 1, nmrtbl
9697               i = mrtbl(ix,l)
9698               j = mrtbl(iy,l)
9699               k = mrtbl(iz,l)
9700               local_pf(i,j,k) = mrtinsw(l)
9701            ENDDO
9702         ELSE
9703            IF ( ALLOCATED( mrtinsw_av ) ) THEN
9704               DO  l = 1, nmrtbl
9705                  i = mrtbl(ix,l)
9706                  j = mrtbl(iy,l)
9707                  k = mrtbl(iz,l)
9708                  local_pf(i,j,k) = mrtinsw_av(l)
9709               ENDDO
9710            ENDIF
9711         ENDIF
9712
9713      CASE ( 'rad_mrt_lw' )
9714         local_pf = REAL( fill_value, KIND = wp )
9715         IF ( av == 0 )  THEN
9716            DO  l = 1, nmrtbl
9717               i = mrtbl(ix,l)
9718               j = mrtbl(iy,l)
9719               k = mrtbl(iz,l)
9720               local_pf(i,j,k) = mrtinlw(l)
9721            ENDDO
9722         ELSE
9723            IF ( ALLOCATED( mrtinlw_av ) ) THEN
9724               DO  l = 1, nmrtbl
9725                  i = mrtbl(ix,l)
9726                  j = mrtbl(iy,l)
9727                  k = mrtbl(iz,l)
9728                  local_pf(i,j,k) = mrtinlw_av(l)
9729               ENDDO
9730            ENDIF
9731         ENDIF
9732
9733      CASE ( 'rad_mrt' )
9734         local_pf = REAL( fill_value, KIND = wp )
9735         IF ( av == 0 )  THEN
9736            DO  l = 1, nmrtbl
9737               i = mrtbl(ix,l)
9738               j = mrtbl(iy,l)
9739               k = mrtbl(iz,l)
9740               local_pf(i,j,k) = mrt(l)
9741            ENDDO
9742         ELSE
9743            IF ( ALLOCATED( mrt_av ) ) THEN
9744               DO  l = 1, nmrtbl
9745                  i = mrtbl(ix,l)
9746                  j = mrtbl(iy,l)
9747                  k = mrtbl(iz,l)
9748                  local_pf(i,j,k) = mrt_av(l)
9749               ENDDO
9750            ENDIF
9751         ENDIF
9752
9753       CASE DEFAULT
9754          found = .FALSE.
9755
9756    END SELECT
9757
9758
9759 END SUBROUTINE radiation_data_output_3d
9760
9761!------------------------------------------------------------------------------!
9762!
9763! Description:
9764! ------------
9765!> Subroutine defining masked data output
9766!------------------------------------------------------------------------------!
9767 SUBROUTINE radiation_data_output_mask( av, variable, found, local_pf )
9768 
9769    USE control_parameters
9770       
9771    USE indices
9772   
9773    USE kinds
9774   
9775
9776    IMPLICIT NONE
9777
9778    CHARACTER (LEN=*) ::  variable   !<
9779
9780    CHARACTER(LEN=5) ::  grid        !< flag to distinquish between staggered grids
9781
9782    INTEGER(iwp) ::  av              !<
9783    INTEGER(iwp) ::  i               !<
9784    INTEGER(iwp) ::  j               !<
9785    INTEGER(iwp) ::  k               !<
9786    INTEGER(iwp) ::  topo_top_ind    !< k index of highest horizontal surface
9787
9788    LOGICAL ::  found                !< true if output array was found
9789    LOGICAL ::  resorted             !< true if array is resorted
9790
9791
9792    REAL(wp),                                                                  &
9793       DIMENSION(mask_size_l(mid,1),mask_size_l(mid,2),mask_size_l(mid,3)) ::  &
9794          local_pf   !<
9795
9796    REAL(wp), DIMENSION(:,:,:), POINTER ::  to_be_resorted  !< points to array which needs to be resorted for output
9797
9798
9799    found    = .TRUE.
9800    grid     = 's'
9801    resorted = .FALSE.
9802
9803    SELECT CASE ( TRIM( variable ) )
9804
9805
9806       CASE ( 'rad_lw_in' )
9807          IF ( av == 0 )  THEN
9808             to_be_resorted => rad_lw_in
9809          ELSE
9810             to_be_resorted => rad_lw_in_av
9811          ENDIF
9812
9813       CASE ( 'rad_lw_out' )
9814          IF ( av == 0 )  THEN
9815             to_be_resorted => rad_lw_out
9816          ELSE
9817             to_be_resorted => rad_lw_out_av
9818          ENDIF
9819
9820       CASE ( 'rad_lw_cs_hr' )
9821          IF ( av == 0 )  THEN
9822             to_be_resorted => rad_lw_cs_hr
9823          ELSE
9824             to_be_resorted => rad_lw_cs_hr_av
9825          ENDIF
9826
9827       CASE ( 'rad_lw_hr' )
9828          IF ( av == 0 )  THEN
9829             to_be_resorted => rad_lw_hr
9830          ELSE
9831             to_be_resorted => rad_lw_hr_av
9832          ENDIF
9833
9834       CASE ( 'rad_sw_in' )
9835          IF ( av == 0 )  THEN
9836             to_be_resorted => rad_sw_in
9837          ELSE
9838             to_be_resorted => rad_sw_in_av
9839          ENDIF
9840
9841       CASE ( 'rad_sw_out' )
9842          IF ( av == 0 )  THEN
9843             to_be_resorted => rad_sw_out
9844          ELSE
9845             to_be_resorted => rad_sw_out_av
9846          ENDIF
9847
9848       CASE ( 'rad_sw_cs_hr' )
9849          IF ( av == 0 )  THEN
9850             to_be_resorted => rad_sw_cs_hr
9851          ELSE
9852             to_be_resorted => rad_sw_cs_hr_av
9853          ENDIF
9854
9855       CASE ( 'rad_sw_hr' )
9856          IF ( av == 0 )  THEN
9857             to_be_resorted => rad_sw_hr
9858          ELSE
9859             to_be_resorted => rad_sw_hr_av
9860          ENDIF
9861
9862       CASE DEFAULT
9863          found = .FALSE.
9864
9865    END SELECT
9866
9867!
9868!-- Resort the array to be output, if not done above
9869    IF ( .NOT. resorted )  THEN
9870       IF ( .NOT. mask_surface(mid) )  THEN
9871!
9872!--       Default masked output
9873          DO  i = 1, mask_size_l(mid,1)
9874             DO  j = 1, mask_size_l(mid,2)
9875                DO  k = 1, mask_size_l(mid,3)
9876                   local_pf(i,j,k) =  to_be_resorted(mask_k(mid,k), &
9877                                      mask_j(mid,j),mask_i(mid,i))
9878                ENDDO
9879             ENDDO
9880          ENDDO
9881
9882       ELSE
9883!
9884!--       Terrain-following masked output
9885          DO  i = 1, mask_size_l(mid,1)
9886             DO  j = 1, mask_size_l(mid,2)
9887!
9888!--             Get k index of highest horizontal surface
9889                topo_top_ind = get_topography_top_index_ji( mask_j(mid,j), &
9890                                                            mask_i(mid,i), &
9891                                                            grid )
9892!
9893!--             Save output array
9894                DO  k = 1, mask_size_l(mid,3)
9895                   local_pf(i,j,k) = to_be_resorted(                       &
9896                                          MIN( topo_top_ind+mask_k(mid,k), &
9897                                               nzt+1 ),                    &
9898                                          mask_j(mid,j),                   &
9899                                          mask_i(mid,i)                     )
9900                ENDDO
9901             ENDDO
9902          ENDDO
9903
9904       ENDIF
9905    ENDIF
9906
9907
9908
9909 END SUBROUTINE radiation_data_output_mask
9910
9911
9912!------------------------------------------------------------------------------!
9913! Description:
9914! ------------
9915!> Subroutine writes local (subdomain) restart data
9916!------------------------------------------------------------------------------!
9917 SUBROUTINE radiation_wrd_local
9918
9919
9920    IMPLICIT NONE
9921
9922
9923    IF ( ALLOCATED( rad_net_av ) )  THEN
9924       CALL wrd_write_string( 'rad_net_av' )
9925       WRITE ( 14 )  rad_net_av
9926    ENDIF
9927   
9928    IF ( ALLOCATED( rad_lw_in_xy_av ) )  THEN
9929       CALL wrd_write_string( 'rad_lw_in_xy_av' )
9930       WRITE ( 14 )  rad_lw_in_xy_av
9931    ENDIF
9932   
9933    IF ( ALLOCATED( rad_lw_out_xy_av ) )  THEN
9934       CALL wrd_write_string( 'rad_lw_out_xy_av' )
9935       WRITE ( 14 )  rad_lw_out_xy_av
9936    ENDIF
9937   
9938    IF ( ALLOCATED( rad_sw_in_xy_av ) )  THEN
9939       CALL wrd_write_string( 'rad_sw_in_xy_av' )
9940       WRITE ( 14 )  rad_sw_in_xy_av
9941    ENDIF
9942   
9943    IF ( ALLOCATED( rad_sw_out_xy_av ) )  THEN
9944       CALL wrd_write_string( 'rad_sw_out_xy_av' )
9945       WRITE ( 14 )  rad_sw_out_xy_av
9946    ENDIF
9947
9948    IF ( ALLOCATED( rad_lw_in ) )  THEN
9949       CALL wrd_write_string( 'rad_lw_in' )
9950       WRITE ( 14 )  rad_lw_in
9951    ENDIF
9952
9953    IF ( ALLOCATED( rad_lw_in_av ) )  THEN
9954       CALL wrd_write_string( 'rad_lw_in_av' )
9955       WRITE ( 14 )  rad_lw_in_av
9956    ENDIF
9957
9958    IF ( ALLOCATED( rad_lw_out ) )  THEN
9959       CALL wrd_write_string( 'rad_lw_out' )
9960       WRITE ( 14 )  rad_lw_out
9961    ENDIF
9962
9963    IF ( ALLOCATED( rad_lw_out_av) )  THEN
9964       CALL wrd_write_string( 'rad_lw_out_av' )
9965       WRITE ( 14 )  rad_lw_out_av
9966    ENDIF
9967
9968    IF ( ALLOCATED( rad_lw_cs_hr) )  THEN
9969       CALL wrd_write_string( 'rad_lw_cs_hr' )
9970       WRITE ( 14 )  rad_lw_cs_hr
9971    ENDIF
9972
9973    IF ( ALLOCATED( rad_lw_cs_hr_av) )  THEN
9974       CALL wrd_write_string( 'rad_lw_cs_hr_av' )
9975       WRITE ( 14 )  rad_lw_cs_hr_av
9976    ENDIF
9977
9978    IF ( ALLOCATED( rad_lw_hr) )  THEN
9979       CALL wrd_write_string( 'rad_lw_hr' )
9980       WRITE ( 14 )  rad_lw_hr
9981    ENDIF
9982
9983    IF ( ALLOCATED( rad_lw_hr_av) )  THEN
9984       CALL wrd_write_string( 'rad_lw_hr_av' )
9985       WRITE ( 14 )  rad_lw_hr_av
9986    ENDIF
9987
9988    IF ( ALLOCATED( rad_sw_in) )  THEN
9989       CALL wrd_write_string( 'rad_sw_in' )
9990       WRITE ( 14 )  rad_sw_in
9991    ENDIF
9992
9993    IF ( ALLOCATED( rad_sw_in_av) )  THEN
9994       CALL wrd_write_string( 'rad_sw_in_av' )
9995       WRITE ( 14 )  rad_sw_in_av
9996    ENDIF
9997
9998    IF ( ALLOCATED( rad_sw_out) )  THEN
9999       CALL wrd_write_string( 'rad_sw_out' )
10000       WRITE ( 14 )  rad_sw_out
10001    ENDIF
10002
10003    IF ( ALLOCATED( rad_sw_out_av) )  THEN
10004       CALL wrd_write_string( 'rad_sw_out_av' )
10005       WRITE ( 14 )  rad_sw_out_av
10006    ENDIF
10007
10008    IF ( ALLOCATED( rad_sw_cs_hr) )  THEN
10009       CALL wrd_write_string( 'rad_sw_cs_hr' )
10010       WRITE ( 14 )  rad_sw_cs_hr
10011    ENDIF
10012
10013    IF ( ALLOCATED( rad_sw_cs_hr_av) )  THEN
10014       CALL wrd_write_string( 'rad_sw_cs_hr_av' )
10015       WRITE ( 14 )  rad_sw_cs_hr_av
10016    ENDIF
10017
10018    IF ( ALLOCATED( rad_sw_hr) )  THEN
10019       CALL wrd_write_string( 'rad_sw_hr' )
10020       WRITE ( 14 )  rad_sw_hr
10021    ENDIF
10022
10023    IF ( ALLOCATED( rad_sw_hr_av) )  THEN
10024       CALL wrd_write_string( 'rad_sw_hr_av' )
10025       WRITE ( 14 )  rad_sw_hr_av
10026    ENDIF
10027
10028
10029 END SUBROUTINE radiation_wrd_local
10030
10031!------------------------------------------------------------------------------!
10032! Description:
10033! ------------
10034!> Subroutine reads local (subdomain) restart data
10035!------------------------------------------------------------------------------!
10036 SUBROUTINE radiation_rrd_local( i, k, nxlf, nxlc, nxl_on_file, nxrf, nxrc,    &
10037                                nxr_on_file, nynf, nync, nyn_on_file, nysf,    &
10038                                nysc, nys_on_file, tmp_2d, tmp_3d, found )
10039 
10040
10041    USE control_parameters
10042       
10043    USE indices
10044   
10045    USE kinds
10046   
10047    USE pegrid
10048
10049
10050    IMPLICIT NONE
10051
10052    INTEGER(iwp) ::  i               !<
10053    INTEGER(iwp) ::  k               !<
10054    INTEGER(iwp) ::  nxlc            !<
10055    INTEGER(iwp) ::  nxlf            !<
10056    INTEGER(iwp) ::  nxl_on_file     !<
10057    INTEGER(iwp) ::  nxrc            !<
10058    INTEGER(iwp) ::  nxrf            !<
10059    INTEGER(iwp) ::  nxr_on_file     !<
10060    INTEGER(iwp) ::  nync            !<
10061    INTEGER(iwp) ::  nynf            !<
10062    INTEGER(iwp) ::  nyn_on_file     !<
10063    INTEGER(iwp) ::  nysc            !<
10064    INTEGER(iwp) ::  nysf            !<
10065    INTEGER(iwp) ::  nys_on_file     !<
10066
10067    LOGICAL, INTENT(OUT)  :: found
10068
10069    REAL(wp), DIMENSION(nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_2d   !<
10070
10071    REAL(wp), DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d   !<
10072
10073    REAL(wp), DIMENSION(0:0,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d2   !<
10074
10075
10076    found = .TRUE.
10077
10078
10079    SELECT CASE ( restart_string(1:length) )
10080
10081       CASE ( 'rad_net_av' )
10082          IF ( .NOT. ALLOCATED( rad_net_av ) )  THEN
10083             ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
10084          ENDIF 
10085          IF ( k == 1 )  READ ( 13 )  tmp_2d
10086          rad_net_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp)  =           &
10087                        tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10088                       
10089       CASE ( 'rad_lw_in_xy_av' )
10090          IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) )  THEN
10091             ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
10092          ENDIF 
10093          IF ( k == 1 )  READ ( 13 )  tmp_2d
10094          rad_lw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp)  =      &
10095                        tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10096                       
10097       CASE ( 'rad_lw_out_xy_av' )
10098          IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) )  THEN
10099             ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
10100          ENDIF 
10101          IF ( k == 1 )  READ ( 13 )  tmp_2d
10102          rad_lw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp)  =     &
10103                        tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10104                       
10105       CASE ( 'rad_sw_in_xy_av' )
10106          IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) )  THEN
10107             ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
10108          ENDIF 
10109          IF ( k == 1 )  READ ( 13 )  tmp_2d
10110          rad_sw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp)  =      &
10111                        tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10112                       
10113       CASE ( 'rad_sw_out_xy_av' )
10114          IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) )  THEN
10115             ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
10116          ENDIF 
10117          IF ( k == 1 )  READ ( 13 )  tmp_2d
10118          rad_sw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp)  =     &
10119                        tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10120                       
10121       CASE ( 'rad_lw_in' )
10122          IF ( .NOT. ALLOCATED( rad_lw_in ) )  THEN
10123             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
10124                  radiation_scheme == 'constant')  THEN
10125                ALLOCATE( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) )
10126             ELSE
10127                ALLOCATE( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10128             ENDIF
10129          ENDIF 
10130          IF ( k == 1 )  THEN
10131             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
10132                  radiation_scheme == 'constant')  THEN
10133                READ ( 13 )  tmp_3d2
10134                rad_lw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =   &
10135                   tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10136             ELSE
10137                READ ( 13 )  tmp_3d
10138                rad_lw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =     &
10139                    tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10140             ENDIF
10141          ENDIF
10142
10143       CASE ( 'rad_lw_in_av' )
10144          IF ( .NOT. ALLOCATED( rad_lw_in_av ) )  THEN
10145             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
10146                  radiation_scheme == 'constant')  THEN
10147                ALLOCATE( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
10148             ELSE
10149                ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10150             ENDIF
10151          ENDIF 
10152          IF ( k == 1 )  THEN
10153             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
10154                  radiation_scheme == 'constant')  THEN
10155                READ ( 13 )  tmp_3d2
10156                rad_lw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&
10157                    tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10158             ELSE
10159                READ ( 13 )  tmp_3d
10160                rad_lw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =  &
10161                    tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10162             ENDIF
10163          ENDIF
10164
10165       CASE ( 'rad_lw_out' )
10166          IF ( .NOT. ALLOCATED( rad_lw_out ) )  THEN
10167             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
10168                  radiation_scheme == 'constant')  THEN
10169                ALLOCATE( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) )
10170             ELSE
10171                ALLOCATE( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10172             ENDIF
10173          ENDIF 
10174          IF ( k == 1 )  THEN
10175             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
10176                  radiation_scheme == 'constant')  THEN
10177                READ ( 13 )  tmp_3d2
10178                rad_lw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =  &
10179                    tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10180             ELSE
10181                READ ( 13 )  tmp_3d
10182                rad_lw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =    &
10183                    tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10184             ENDIF
10185          ENDIF
10186
10187       CASE ( 'rad_lw_out_av' )
10188          IF ( .NOT. ALLOCATED( rad_lw_out_av ) )  THEN
10189             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
10190                  radiation_scheme == 'constant')  THEN
10191                ALLOCATE( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
10192             ELSE
10193                ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10194             ENDIF
10195          ENDIF 
10196          IF ( k == 1 )  THEN
10197             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
10198                  radiation_scheme == 'constant')  THEN
10199                READ ( 13 )  tmp_3d2
10200                rad_lw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) &
10201                   = tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10202             ELSE
10203                READ ( 13 )  tmp_3d
10204                rad_lw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
10205                    tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10206             ENDIF
10207          ENDIF
10208
10209       CASE ( 'rad_lw_cs_hr' )
10210          IF ( .NOT. ALLOCATED( rad_lw_cs_hr ) )  THEN
10211             ALLOCATE( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10212          ENDIF
10213          IF ( k == 1 )  READ ( 13 )  tmp_3d
10214          rad_lw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =        &
10215                  tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10216
10217       CASE ( 'rad_lw_cs_hr_av' )
10218          IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) )  THEN
10219             ALLOCATE( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10220          ENDIF
10221          IF ( k == 1 )  READ ( 13 )  tmp_3d
10222          rad_lw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =     &
10223                  tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10224
10225       CASE ( 'rad_lw_hr' )
10226          IF ( .NOT. ALLOCATED( rad_lw_hr ) )  THEN
10227             ALLOCATE( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10228          ENDIF
10229          IF ( k == 1 )  READ ( 13 )  tmp_3d
10230          rad_lw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =           &
10231                  tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10232
10233       CASE ( 'rad_lw_hr_av' )
10234          IF ( .NOT. ALLOCATED( rad_lw_hr_av ) )  THEN
10235             ALLOCATE( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10236          ENDIF
10237          IF ( k == 1 )  READ ( 13 )  tmp_3d
10238          rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =        &
10239                  tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10240
10241       CASE ( 'rad_sw_in' )
10242          IF ( .NOT. ALLOCATED( rad_sw_in ) )  THEN
10243             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
10244                  radiation_scheme == 'constant')  THEN
10245                ALLOCATE( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) )
10246             ELSE
10247                ALLOCATE( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10248             ENDIF
10249          ENDIF 
10250          IF ( k == 1 )  THEN
10251             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
10252                  radiation_scheme == 'constant')  THEN
10253                READ ( 13 )  tmp_3d2
10254                rad_sw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =   &
10255                    tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10256             ELSE
10257                READ ( 13 )  tmp_3d
10258                rad_sw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =     &
10259                    tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10260             ENDIF
10261          ENDIF
10262
10263       CASE ( 'rad_sw_in_av' )
10264          IF ( .NOT. ALLOCATED( rad_sw_in_av ) )  THEN
10265             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
10266                  radiation_scheme == 'constant')  THEN
10267                ALLOCATE( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
10268             ELSE
10269                ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10270             ENDIF
10271          ENDIF 
10272          IF ( k == 1 )  THEN
10273             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
10274                  radiation_scheme == 'constant')  THEN
10275                READ ( 13 )  tmp_3d2
10276                rad_sw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&
10277                    tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10278             ELSE
10279                READ ( 13 )  tmp_3d
10280                rad_sw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =  &
10281                    tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10282             ENDIF
10283          ENDIF
10284
10285       CASE ( 'rad_sw_out' )
10286          IF ( .NOT. ALLOCATED( rad_sw_out ) )  THEN
10287             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
10288                  radiation_scheme == 'constant')  THEN
10289                ALLOCATE( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) )
10290             ELSE
10291                ALLOCATE( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10292             ENDIF
10293          ENDIF 
10294          IF ( k == 1 )  THEN
10295             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
10296                  radiation_scheme == 'constant')  THEN
10297                READ ( 13 )  tmp_3d2
10298                rad_sw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =  &
10299                    tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10300             ELSE
10301                READ ( 13 )  tmp_3d
10302                rad_sw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =    &
10303                    tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10304             ENDIF
10305          ENDIF
10306
10307       CASE ( 'rad_sw_out_av' )
10308          IF ( .NOT. ALLOCATED( rad_sw_out_av ) )  THEN
10309             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
10310                  radiation_scheme == 'constant')  THEN
10311                ALLOCATE( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
10312             ELSE
10313                ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10314             ENDIF
10315          ENDIF 
10316          IF ( k == 1 )  THEN
10317             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
10318                  radiation_scheme == 'constant')  THEN
10319                READ ( 13 )  tmp_3d2
10320                rad_sw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) &
10321                   = tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10322             ELSE
10323                READ ( 13 )  tmp_3d
10324                rad_sw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
10325                    tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10326             ENDIF
10327          ENDIF
10328
10329       CASE ( 'rad_sw_cs_hr' )
10330          IF ( .NOT. ALLOCATED( rad_sw_cs_hr ) )  THEN
10331             ALLOCATE( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10332          ENDIF
10333          IF ( k == 1 )  READ ( 13 )  tmp_3d
10334          rad_sw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =        &
10335                  tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10336
10337       CASE ( 'rad_sw_cs_hr_av' )
10338          IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) )  THEN
10339             ALLOCATE( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10340          ENDIF
10341          IF ( k == 1 )  READ ( 13 )  tmp_3d
10342          rad_sw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =     &
10343                  tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10344
10345       CASE ( 'rad_sw_hr' )
10346          IF ( .NOT. ALLOCATED( rad_sw_hr ) )  THEN
10347             ALLOCATE( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10348          ENDIF
10349          IF ( k == 1 )  READ ( 13 )  tmp_3d
10350          rad_sw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =           &
10351                  tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10352
10353       CASE ( 'rad_sw_hr_av' )
10354          IF ( .NOT. ALLOCATED( rad_sw_hr_av ) )  THEN
10355             ALLOCATE( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10356          ENDIF
10357          IF ( k == 1 )  READ ( 13 )  tmp_3d
10358          rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =        &
10359                  tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
10360
10361       CASE DEFAULT
10362
10363          found = .FALSE.
10364
10365    END SELECT
10366
10367 END SUBROUTINE radiation_rrd_local
10368
10369!------------------------------------------------------------------------------!
10370! Description:
10371! ------------
10372!> Subroutine writes debug information
10373!------------------------------------------------------------------------------!
10374 SUBROUTINE radiation_write_debug_log ( message )
10375    !> it writes debug log with time stamp
10376    CHARACTER(*)  :: message
10377    CHARACTER(15) :: dtc
10378    CHARACTER(8)  :: date
10379    CHARACTER(10) :: time
10380    CHARACTER(5)  :: zone
10381    CALL date_and_time(date, time, zone)
10382    dtc = date(7:8)//','//time(1:2)//':'//time(3:4)//':'//time(5:10)
10383    WRITE(9,'(2A)') dtc, TRIM(message)
10384    FLUSH(9)
10385 END SUBROUTINE radiation_write_debug_log
10386
10387 END MODULE radiation_model_mod
Note: See TracBrowser for help on using the repository browser.