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

Last change on this file since 4245 was 4245, checked in by pavelkrc, 6 years ago

Merge branch resler into trunk

  • 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/mosaik_M2/radiation_model_mod.f902360-3471
    /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-4244
    /palm/branches/salsa/SOURCE/radiation_model_mod.f902503-3460
    /palm/branches/fricke/SOURCE/radiation_model_mod.f90942-977
    /palm/branches/hoffmann/SOURCE/radiation_model_mod.f90989-1052
    /palm/branches/letzel/masked_output/SOURCE/radiation_model_mod.f90296-409
    /palm/branches/suehring/radiation_model_mod.f90423-666
File size: 545.4 KB
Line 
1!> @file radiation_model_mod.f90
2!------------------------------------------------------------------------------!
3! This file is part of the PALM model system.
4!
5! PALM is free software: you can redistribute it and/or modify it under the
6! terms of the GNU General Public License as published by the Free Software
7! Foundation, either version 3 of the License, or (at your option) any later
8! version.
9!
10! PALM is distributed in the hope that it will be useful, but WITHOUT ANY
11! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
12! A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
13!
14! You should have received a copy of the GNU General Public License along with
15! PALM. If not, see <http://www.gnu.org/licenses/>.
16!
17! Copyright 2015-2019 Institute of Computer Science of the
18!                     Czech Academy of Sciences, Prague
19! Copyright 2015-2019 Czech Technical University in Prague
20! Copyright 1997-2019 Leibniz Universitaet Hannover
21!------------------------------------------------------------------------------!
22!
23! Current revisions:
24! ------------------
25!
26!
27! Former revisions:
28! -----------------
29! $Id: radiation_model_mod.f90 4245 2019-09-30 08:40:37Z pavelkrc $
30! Initialize explicit per-surface albedos from building_surface_pars
31!
32! 4238 2019-09-25 16:06:01Z suehring
33! Modify check in order to avoid equality comparisons of floating points
34!
35! 4227 2019-09-10 18:04:34Z gronemeier
36! implement new palm_date_time_mod
37!
38! 4226 2019-09-10 17:03:24Z suehring
39! - Netcdf input routine for dimension length renamed
40! - Define time variable for external radiation input relative to time_utc_init
41!
42! 4210 2019-09-02 13:07:09Z suehring
43! - Revise steering of splitting diffuse and direct radiation
44! - Bugfixes in checks
45! - Optimize mapping of radiation components onto 2D arrays, avoid unnecessary
46!   operations
47!
48! 4208 2019-09-02 09:01:07Z suehring
49! Bugfix in accessing albedo_pars in the clear-sky branch
50! (merge from branch resler)
51!
52! 4198 2019-08-29 15:17:48Z gronemeier
53! Prohibit execution of radiation model if rotation_angle is not zero
54!
55! 4197 2019-08-29 14:33:32Z suehring
56! Revise steering of surface albedo initialization when albedo_pars is provided
57!
58! 4190 2019-08-27 15:42:37Z suehring
59! Implement external radiation forcing also for level-of-detail = 2
60! (horizontally 2D radiation)
61!
62! 4188 2019-08-26 14:15:47Z suehring
63! Minor adjustment in error message
64!
65! 4187 2019-08-26 12:43:15Z suehring
66! - Take external radiation from root domain dynamic input if not provided for
67!   each nested domain
68! - Combine MPI_ALLREDUCE calls to reduce mpi overhead
69!
70! 4182 2019-08-22 15:20:23Z scharf
71! Corrected "Former revisions" section
72!
73! 4179 2019-08-21 11:16:12Z suehring
74! Remove debug prints
75!
76! 4178 2019-08-21 11:13:06Z suehring
77! External radiation forcing implemented.
78!
79! 4168 2019-08-16 13:50:17Z suehring
80! Replace function get_topography_top_index by topo_top_ind
81!
82! 4157 2019-08-14 09:19:12Z suehring
83! Give informative message on raytracing distance only by core zero
84!
85! 4148 2019-08-08 11:26:00Z suehring
86! Comments added
87!
88! 4134 2019-08-02 18:39:57Z suehring
89! Bugfix in formatted write statement
90!
91! 4127 2019-07-30 14:47:10Z suehring
92! Remove unused pch_index (merge from branch resler)
93!
94! 4089 2019-07-11 14:30:27Z suehring
95! - Correct level 2 initialization of spectral albedos in rrtmg branch, long- and
96!   shortwave albedos were mixed-up.
97! - Change order of albedo_pars so that it is now consistent with the defined
98!   order of albedo_pars in PIDS
99!
100! 4069 2019-07-01 14:05:51Z Giersch
101! Masked output running index mid has been introduced as a local variable to
102! avoid runtime error (Loop variable has been modified) in time_integration
103!
104! 4067 2019-07-01 13:29:25Z suehring
105! Bugfix, pass dummy string to MPI_INFO_SET (J. Resler)
106!
107! 4039 2019-06-18 10:32:41Z suehring
108! Bugfix for masked data output
109!
110! 4008 2019-05-30 09:50:11Z moh.hefny
111! Bugfix in check variable when a variable's string is less than 3
112! characters is processed. All variables now are checked if they
113! belong to radiation
114!
115! 3992 2019-05-22 16:49:38Z suehring
116! Bugfix in rrtmg radiation branch in a nested run when the lowest prognistic
117! grid points in a child domain are all inside topography
118!
119! 3987 2019-05-22 09:52:13Z kanani
120! Introduce alternative switch for debug output during timestepping
121!
122! 3943 2019-05-02 09:50:41Z maronga
123! Missing blank characteer added.
124!
125! 3900 2019-04-16 15:17:43Z suehring
126! Fixed initialization problem
127!
128! 3885 2019-04-11 11:29:34Z kanani
129! Changes related to global restructuring of location messages and introduction
130! of additional debug messages
131!
132! 3881 2019-04-10 09:31:22Z suehring
133! Output of albedo and emissivity moved from USM, bugfixes in initialization
134! of albedo
135!
136! 3861 2019-04-04 06:27:41Z maronga
137! Bugfix: factor of 4.0 required instead of 3.0 in calculation of rad_lw_out_change_0
138!
139! 3859 2019-04-03 20:30:31Z maronga
140! Added some descriptions
141!
142! 3847 2019-04-01 14:51:44Z suehring
143! Implement check for dt_radiation (must be > 0)
144!
145! 3846 2019-04-01 13:55:30Z suehring
146! unused variable removed
147!
148! 3814 2019-03-26 08:40:31Z pavelkrc
149! Change zenith(0:0) and others to scalar.
150! Code review.
151! Rename exported nzu, nzp and related variables due to name conflict
152!
153! 3771 2019-02-28 12:19:33Z raasch
154! rrtmg preprocessor for directives moved/added, save attribute added to temporary
155! pointers to avoid compiler warnings about outlived pointer targets,
156! statement added to avoid compiler warning about unused variable
157!
158! 3769 2019-02-28 10:16:49Z moh.hefny
159! removed unused variables and subroutine radiation_radflux_gridbox
160!
161! 3767 2019-02-27 08:18:02Z raasch
162! unused variable for file index removed from rrd-subroutines parameter list
163!
164! 3760 2019-02-21 18:47:35Z moh.hefny
165! Bugfix: initialized simulated_time before calculating solar position
166! to enable restart option with reading in SVF from file(s).
167!
168! 3754 2019-02-19 17:02:26Z kanani
169! (resler, pavelkrc)
170! Bugfixes: add further required MRT factors to read/write_svf,
171! fix for aggregating view factors to eliminate local noise in reflected
172! irradiance at mutually close surfaces (corners, presence of trees) in the
173! angular discretization scheme.
174!
175! 3752 2019-02-19 09:37:22Z resler
176! added read/write number of MRT factors to the respective routines
177!
178! 3705 2019-01-29 19:56:39Z suehring
179! Make variables that are sampled in virtual measurement module public
180!
181! 3704 2019-01-29 19:51:41Z suehring
182! Some interface calls moved to module_interface + cleanup
183!
184! 3667 2019-01-10 14:26:24Z schwenkel
185! Modified check for rrtmg input files
186!
187! 3655 2019-01-07 16:51:22Z knoop
188! nopointer option removed
189!
190! 1496 2014-12-02 17:25:50Z maronga
191! Initial revision
192!
193!
194! Description:
195! ------------
196!> Radiation models and interfaces
197!> @todo Replace dz(1) appropriatly to account for grid stretching
198!> @todo move variable definitions used in radiation_init only to the subroutine
199!>       as they are no longer required after initialization.
200!> @todo Output of full column vertical profiles used in RRTMG
201!> @todo Output of other rrtm arrays (such as volume mixing ratios)
202!> @todo Check for mis-used NINT() calls in raytrace_2d
203!>       RESULT: Original was correct (carefully verified formula), the change
204!>               to INT broke raytracing      -- P. Krc
205!> @todo Optimize radiation_tendency routines
206!> @todo Consider rotated model domains (rotation_angle/=0.0)
207!>
208!> @note Many variables have a leading dummy dimension (0:0) in order to
209!>       match the assume-size shape expected by the RRTMG model.
210!------------------------------------------------------------------------------!
211 MODULE radiation_model_mod
212 
213    USE arrays_3d,                                                             &
214        ONLY:  dzw, hyp, nc, pt, p, q, ql, u, v, w, zu, zw, exner, d_exner
215
216    USE basic_constants_and_equations_mod,                                     &
217        ONLY:  c_p, g, lv_d_cp, l_v, pi, r_d, rho_l, solar_constant, sigma_sb, &
218               barometric_formula
219
220    USE calc_mean_profile_mod,                                                 &
221        ONLY:  calc_mean_profile
222
223    USE control_parameters,                                                    &
224        ONLY:  cloud_droplets, coupling_char,                                  &
225               debug_output, debug_output_timestep, debug_string,              &
226               dt_3d,                                                          &
227               dz, dt_spinup, end_time,                                        &
228               humidity,                                                       &
229               initializing_actions, io_blocks, io_group,                      &
230               land_surface, large_scale_forcing,                              &
231               latitude, longitude, lsf_surf,                                  &
232               message_string, plant_canopy, pt_surface,                       &
233               rho_surface, simulated_time, spinup_time, surface_pressure,     &
234               read_svf, write_svf,                                            &
235               time_since_reference_point, urban_surface, varnamelength
236
237    USE cpulog,                                                                &
238        ONLY:  cpu_log, log_point, log_point_s
239
240    USE grid_variables,                                                        &
241         ONLY:  ddx, ddy, dx, dy 
242
243    USE indices,                                                               &
244        ONLY:  nnx, nny, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg,   &
245               nzb, nzt, topo_top_ind
246
247    USE, INTRINSIC :: iso_c_binding
248
249    USE kinds
250
251    USE bulk_cloud_model_mod,                                                  &
252        ONLY:  bulk_cloud_model, microphysics_morrison, na_init, nc_const, sigma_gc
253
254#if defined ( __netcdf )
255    USE NETCDF
256#endif
257
258    USE netcdf_data_input_mod,                                                 &
259        ONLY:  albedo_type_f,                                                  &
260               albedo_pars_f,                                                  &
261               building_type_f,                                                &
262               building_surface_pars_f,                                        &
263               pavement_type_f,                                                &
264               vegetation_type_f,                                              &
265               water_type_f,                                                   &
266               char_fill,                                                      &
267               char_lod,                                                       &
268               check_existence,                                                &
269               close_input_file,                                               &
270               get_attribute,                                                  &
271               get_dimension_length,                                           &
272               get_variable,                                                   &
273               inquire_num_variables,                                          &
274               inquire_variable_names,                                         &
275               input_file_dynamic,                                             &
276               input_pids_dynamic,                                             &
277               num_var_pids,                                                   &
278               pids_id,                                                        &
279               open_read_file,                                                 &
280               real_1d_3d,                                                     &
281               vars_pids
282
283    USE palm_date_time_mod,                                                    &
284        ONLY:  date_time_str_len, get_date_time,                               &
285               hours_per_day, seconds_per_hour
286
287    USE plant_canopy_model_mod,                                                &
288        ONLY:  lad_s, pc_heating_rate, pc_transpiration_rate, pc_latent_rate,  &
289               plant_canopy_transpiration, pcm_calc_transpiration_rate
290
291    USE pegrid
292
293#if defined ( __rrtmg )
294    USE parrrsw,                                                               &
295        ONLY:  naerec, nbndsw
296
297    USE parrrtm,                                                               &
298        ONLY:  nbndlw
299
300    USE rrtmg_lw_init,                                                         &
301        ONLY:  rrtmg_lw_ini
302
303    USE rrtmg_sw_init,                                                         &
304        ONLY:  rrtmg_sw_ini
305
306    USE rrtmg_lw_rad,                                                          &
307        ONLY:  rrtmg_lw
308
309    USE rrtmg_sw_rad,                                                          &
310        ONLY:  rrtmg_sw
311#endif
312    USE statistics,                                                            &
313        ONLY:  hom
314
315    USE surface_mod,                                                           &
316        ONLY:  ind_pav_green, ind_veg_wall, ind_wat_win,                       &
317               surf_lsm_h, surf_lsm_v, surf_type, surf_usm_h, surf_usm_v,      &
318               vertical_surfaces_exist
319
320    IMPLICIT NONE
321
322    CHARACTER(10) :: radiation_scheme = 'clear-sky' ! 'constant', 'clear-sky', or 'rrtmg'
323
324!
325!-- Predefined Land surface classes (albedo_type) after Briegleb (1992)
326    CHARACTER(37), DIMENSION(0:33), PARAMETER :: albedo_type_name = (/      &
327                                   'user defined                         ', & !  0
328                                   'ocean                                ', & !  1
329                                   'mixed farming, tall grassland        ', & !  2
330                                   'tall/medium grassland                ', & !  3
331                                   'evergreen shrubland                  ', & !  4
332                                   'short grassland/meadow/shrubland     ', & !  5
333                                   'evergreen needleleaf forest          ', & !  6
334                                   'mixed deciduous evergreen forest     ', & !  7
335                                   'deciduous forest                     ', & !  8
336                                   'tropical evergreen broadleaved forest', & !  9
337                                   'medium/tall grassland/woodland       ', & ! 10
338                                   'desert, sandy                        ', & ! 11
339                                   'desert, rocky                        ', & ! 12
340                                   'tundra                               ', & ! 13
341                                   'land ice                             ', & ! 14
342                                   'sea ice                              ', & ! 15
343                                   'snow                                 ', & ! 16
344                                   'bare soil                            ', & ! 17
345                                   'asphalt/concrete mix                 ', & ! 18
346                                   'asphalt (asphalt concrete)           ', & ! 19
347                                   'concrete (Portland concrete)         ', & ! 20
348                                   'sett                                 ', & ! 21
349                                   'paving stones                        ', & ! 22
350                                   'cobblestone                          ', & ! 23
351                                   'metal                                ', & ! 24
352                                   'wood                                 ', & ! 25
353                                   'gravel                               ', & ! 26
354                                   'fine gravel                          ', & ! 27
355                                   'pebblestone                          ', & ! 28
356                                   'woodchips                            ', & ! 29
357                                   'tartan (sports)                      ', & ! 30
358                                   'artifical turf (sports)              ', & ! 31
359                                   'clay (sports)                        ', & ! 32
360                                   'building (dummy)                     '  & ! 33
361                                                         /)
362!
363!-- Indices of radiation-related input attributes in building_surface_pars
364!-- (other are in urban_surface_mod)
365    INTEGER(iwp) ::  ind_s_alb_b_wall                = 19 !< index for Broadband albedo of wall fraction
366    INTEGER(iwp) ::  ind_s_alb_l_wall                = 20 !< index for Longwave albedo of wall fraction
367    INTEGER(iwp) ::  ind_s_alb_s_wall                = 21 !< index for Shortwave albedo of wall fraction
368    INTEGER(iwp) ::  ind_s_alb_b_win                 = 22 !< index for Broadband albedo of window fraction
369    INTEGER(iwp) ::  ind_s_alb_l_win                 = 23 !< index for Longwave albedo of window fraction
370    INTEGER(iwp) ::  ind_s_alb_s_win                 = 24 !< index for Shortwave albedo of window fraction
371    INTEGER(iwp) ::  ind_s_alb_b_green               = 24 !< index for Broadband albedo of green fraction
372    INTEGER(iwp) ::  ind_s_alb_l_green               = 25 !< index for Longwave albedo of green fraction
373    INTEGER(iwp) ::  ind_s_alb_s_green               = 26 !< index for Shortwave albedo of green fraction
374
375    INTEGER(iwp) :: albedo_type  = 9999999_iwp, &     !< Albedo surface type
376                    dots_rad     = 0_iwp              !< starting index for timeseries output
377
378    LOGICAL ::  unscheduled_radiation_calls = .TRUE., & !< flag parameter indicating whether additional calls of the radiation code are allowed
379                constant_albedo = .FALSE.,            & !< flag parameter indicating whether the albedo may change depending on zenith
380                force_radiation_call = .FALSE.,       & !< flag parameter for unscheduled radiation calls
381                lw_radiation = .TRUE.,                & !< flag parameter indicating whether longwave radiation shall be calculated
382                radiation = .FALSE.,                  & !< flag parameter indicating whether the radiation model is used
383                sun_up    = .TRUE.,                   & !< flag parameter indicating whether the sun is up or down
384                sw_radiation = .TRUE.,                & !< flag parameter indicating whether shortwave radiation shall be calculated
385                sun_direction = .FALSE.,              & !< flag parameter indicating whether solar direction shall be calculated
386                average_radiation = .FALSE.,          & !< flag to set the calculation of radiation averaging for the domain
387                radiation_interactions = .FALSE.,     & !< flag to activiate RTM (TRUE only if vertical urban/land surface and trees exist)
388                surface_reflections = .TRUE.,         & !< flag to switch the calculation of radiation interaction between surfaces.
389                                                        !< When it switched off, only the effect of buildings and trees shadow
390                                                        !< will be considered. However fewer SVFs are expected.
391                radiation_interactions_on = .TRUE.      !< namelist flag to force RTM activiation regardless to vertical urban/land surface and trees
392
393    REAL(wp) :: albedo = 9999999.9_wp,           & !< NAMELIST alpha
394                albedo_lw_dif = 9999999.9_wp,    & !< NAMELIST aldif
395                albedo_lw_dir = 9999999.9_wp,    & !< NAMELIST aldir
396                albedo_sw_dif = 9999999.9_wp,    & !< NAMELIST asdif
397                albedo_sw_dir = 9999999.9_wp,    & !< NAMELIST asdir
398                decl_1,                          & !< declination coef. 1
399                decl_2,                          & !< declination coef. 2
400                decl_3,                          & !< declination coef. 3
401                dt_radiation = 0.0_wp,           & !< radiation model timestep
402                emissivity = 9999999.9_wp,       & !< NAMELIST surface emissivity
403                lon = 0.0_wp,                    & !< longitude in radians
404                lat = 0.0_wp,                    & !< latitude in radians
405                net_radiation = 0.0_wp,          & !< net radiation at surface
406                skip_time_do_radiation = 0.0_wp, & !< Radiation model is not called before this time
407                sky_trans,                       & !< sky transmissivity
408                time_radiation = 0.0_wp            !< time since last call of radiation code
409
410    INTEGER(iwp) ::  day_of_year   !< day of the current year
411
412    REAL(wp) ::  cos_zenith        !< cosine of solar zenith angle, also z-coordinate of solar unit vector
413    REAL(wp) ::  d_hours_day       !< 1 / hours-per-day
414    REAL(wp) ::  d_seconds_hour    !< 1 / seconds-per-hour
415    REAL(wp) ::  second_of_day     !< second of the current day
416    REAL(wp) ::  sun_dir_lat       !< y-coordinate of solar unit vector
417    REAL(wp) ::  sun_dir_lon       !< x-coordinate of solar unit vector
418
419    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  rad_net_av       !< average of net radiation (rad_net) at surface
420    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  rad_lw_in_xy_av  !< average of incoming longwave radiation at surface
421    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  rad_lw_out_xy_av !< average of outgoing longwave radiation at surface
422    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  rad_sw_in_xy_av  !< average of incoming shortwave radiation at surface
423    REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  rad_sw_out_xy_av !< average of outgoing shortwave radiation at surface
424
425    REAL(wp), PARAMETER :: emissivity_atm_clsky = 0.8_wp       !< emissivity of the clear-sky atmosphere
426!
427!-- Land surface albedos for solar zenith angle of 60degree after Briegleb (1992)     
428!-- (broadband, longwave, shortwave ):   bb,      lw,      sw,
429    REAL(wp), DIMENSION(0:2,1:33), PARAMETER :: albedo_pars = RESHAPE( (/& 
430                                   0.06_wp, 0.06_wp, 0.06_wp,            & !  1
431                                   0.19_wp, 0.28_wp, 0.09_wp,            & !  2
432                                   0.23_wp, 0.33_wp, 0.11_wp,            & !  3
433                                   0.23_wp, 0.33_wp, 0.11_wp,            & !  4
434                                   0.25_wp, 0.34_wp, 0.14_wp,            & !  5
435                                   0.14_wp, 0.22_wp, 0.06_wp,            & !  6
436                                   0.17_wp, 0.27_wp, 0.06_wp,            & !  7
437                                   0.19_wp, 0.31_wp, 0.06_wp,            & !  8
438                                   0.14_wp, 0.22_wp, 0.06_wp,            & !  9
439                                   0.18_wp, 0.28_wp, 0.06_wp,            & ! 10
440                                   0.43_wp, 0.51_wp, 0.35_wp,            & ! 11
441                                   0.32_wp, 0.40_wp, 0.24_wp,            & ! 12
442                                   0.19_wp, 0.27_wp, 0.10_wp,            & ! 13
443                                   0.77_wp, 0.65_wp, 0.90_wp,            & ! 14
444                                   0.77_wp, 0.65_wp, 0.90_wp,            & ! 15
445                                   0.82_wp, 0.70_wp, 0.95_wp,            & ! 16
446                                   0.08_wp, 0.08_wp, 0.08_wp,            & ! 17
447                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 18
448                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 19
449                                   0.30_wp, 0.30_wp, 0.30_wp,            & ! 20
450                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 21
451                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 22
452                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 23
453                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 24
454                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 25
455                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 26
456                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 27
457                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 28
458                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 29
459                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 30
460                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 31
461                                   0.17_wp, 0.17_wp, 0.17_wp,            & ! 32
462                                   0.17_wp, 0.17_wp, 0.17_wp             & ! 33
463                                 /), (/ 3, 33 /) )
464
465    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: &
466                        rad_lw_cs_hr,                  & !< longwave clear sky radiation heating rate (K/s)
467                        rad_lw_cs_hr_av,               & !< average of rad_lw_cs_hr
468                        rad_lw_hr,                     & !< longwave radiation heating rate (K/s)
469                        rad_lw_hr_av,                  & !< average of rad_sw_hr
470                        rad_lw_in,                     & !< incoming longwave radiation (W/m2)
471                        rad_lw_in_av,                  & !< average of rad_lw_in
472                        rad_lw_out,                    & !< outgoing longwave radiation (W/m2)
473                        rad_lw_out_av,                 & !< average of rad_lw_out
474                        rad_sw_cs_hr,                  & !< shortwave clear sky radiation heating rate (K/s)
475                        rad_sw_cs_hr_av,               & !< average of rad_sw_cs_hr
476                        rad_sw_hr,                     & !< shortwave radiation heating rate (K/s)
477                        rad_sw_hr_av,                  & !< average of rad_sw_hr
478                        rad_sw_in,                     & !< incoming shortwave radiation (W/m2)
479                        rad_sw_in_av,                  & !< average of rad_sw_in
480                        rad_sw_out,                    & !< outgoing shortwave radiation (W/m2)
481                        rad_sw_out_av                    !< average of rad_sw_out
482
483
484!
485!-- Variables and parameters used in RRTMG only
486#if defined ( __rrtmg )
487    CHARACTER(LEN=12) :: rrtm_input_file = "RAD_SND_DATA" !< name of the NetCDF input file (sounding data)
488
489
490!
491!-- Flag parameters to be passed to RRTMG (should not be changed until ice phase in clouds is allowed)
492    INTEGER(iwp), PARAMETER :: rrtm_idrv     = 1, & !< flag for longwave upward flux calculation option (0,1)
493                               rrtm_inflglw  = 2, & !< flag for lw cloud optical properties (0,1,2)
494                               rrtm_iceflglw = 0, & !< flag for lw ice particle specifications (0,1,2,3)
495                               rrtm_liqflglw = 1, & !< flag for lw liquid droplet specifications
496                               rrtm_inflgsw  = 2, & !< flag for sw cloud optical properties (0,1,2)
497                               rrtm_iceflgsw = 0, & !< flag for sw ice particle specifications (0,1,2,3)
498                               rrtm_liqflgsw = 1    !< flag for sw liquid droplet specifications
499
500!
501!-- The following variables should be only changed with care, as this will
502!-- require further setting of some variables, which is currently not
503!-- implemented (aerosols, ice phase).
504    INTEGER(iwp) :: nzt_rad,           & !< upper vertical limit for radiation calculations
505                    rrtm_icld = 0,     & !< cloud flag (0: clear sky column, 1: cloudy column)
506                    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)
507
508    INTEGER(iwp) :: nc_stat !< local variable for storin the result of netCDF calls for error message handling
509
510    LOGICAL :: snd_exists = .FALSE.      !< flag parameter to check whether a user-defined input files exists
511    LOGICAL :: sw_exists = .FALSE.       !< flag parameter to check whether that required rrtmg sw file exists
512    LOGICAL :: lw_exists = .FALSE.       !< flag parameter to check whether that required rrtmg lw file exists
513
514
515    REAL(wp), PARAMETER :: mol_mass_air_d_wv = 1.607793_wp !< molecular weight dry air / water vapor
516
517    REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd,     & !< hypostatic pressure from sounding data (hPa)
518                                           rrtm_tsfc,   & !< dummy array for storing surface temperature
519                                           t_snd          !< actual temperature from sounding data (hPa)
520
521    REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rrtm_ccl4vmr,   & !< CCL4 volume mixing ratio (g/mol)
522                                             rrtm_cfc11vmr,  & !< CFC11 volume mixing ratio (g/mol)
523                                             rrtm_cfc12vmr,  & !< CFC12 volume mixing ratio (g/mol)
524                                             rrtm_cfc22vmr,  & !< CFC22 volume mixing ratio (g/mol)
525                                             rrtm_ch4vmr,    & !< CH4 volume mixing ratio
526                                             rrtm_cicewp,    & !< in-cloud ice water path (g/m2)
527                                             rrtm_cldfr,     & !< cloud fraction (0,1)
528                                             rrtm_cliqwp,    & !< in-cloud liquid water path (g/m2)
529                                             rrtm_co2vmr,    & !< CO2 volume mixing ratio (g/mol)
530                                             rrtm_emis,      & !< surface emissivity (0-1) 
531                                             rrtm_h2ovmr,    & !< H2O volume mixing ratio
532                                             rrtm_n2ovmr,    & !< N2O volume mixing ratio
533                                             rrtm_o2vmr,     & !< O2 volume mixing ratio
534                                             rrtm_o3vmr,     & !< O3 volume mixing ratio
535                                             rrtm_play,      & !< pressure layers (hPa, zu-grid)
536                                             rrtm_plev,      & !< pressure layers (hPa, zw-grid)
537                                             rrtm_reice,     & !< cloud ice effective radius (microns)
538                                             rrtm_reliq,     & !< cloud water drop effective radius (microns)
539                                             rrtm_tlay,      & !< actual temperature (K, zu-grid)
540                                             rrtm_tlev,      & !< actual temperature (K, zw-grid)
541                                             rrtm_lwdflx,    & !< RRTM output of incoming longwave radiation flux (W/m2)
542                                             rrtm_lwdflxc,   & !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)
543                                             rrtm_lwuflx,    & !< RRTM output of outgoing longwave radiation flux (W/m2)
544                                             rrtm_lwuflxc,   & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)
545                                             rrtm_lwuflx_dt, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)
546                                             rrtm_lwuflxc_dt,& !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)
547                                             rrtm_lwhr,      & !< RRTM output of longwave radiation heating rate (K/d)
548                                             rrtm_lwhrc,     & !< RRTM output of incoming longwave clear sky radiation heating rate (K/d)
549                                             rrtm_swdflx,    & !< RRTM output of incoming shortwave radiation flux (W/m2)
550                                             rrtm_swdflxc,   & !< RRTM output of outgoing clear sky shortwave radiation flux (W/m2)
551                                             rrtm_swuflx,    & !< RRTM output of outgoing shortwave radiation flux (W/m2)
552                                             rrtm_swuflxc,   & !< RRTM output of incoming clear sky shortwave radiation flux (W/m2)
553                                             rrtm_swhr,      & !< RRTM output of shortwave radiation heating rate (K/d)
554                                             rrtm_swhrc,     & !< RRTM output of incoming shortwave clear sky radiation heating rate (K/d)
555                                             rrtm_dirdflux,  & !< RRTM output of incoming direct shortwave (W/m2)
556                                             rrtm_difdflux     !< RRTM output of incoming diffuse shortwave (W/m2)
557
558    REAL(wp), DIMENSION(1) ::                rrtm_aldif,     & !< surface albedo for longwave diffuse radiation
559                                             rrtm_aldir,     & !< surface albedo for longwave direct radiation
560                                             rrtm_asdif,     & !< surface albedo for shortwave diffuse radiation
561                                             rrtm_asdir        !< surface albedo for shortwave direct radiation
562
563!
564!-- Definition of arrays that are currently not used for calling RRTMG (due to setting of flag parameters)
565    REAL(wp), DIMENSION(:,:,:), ALLOCATABLE ::  rad_lw_cs_in,   & !< incoming clear sky longwave radiation (W/m2) (not used)
566                                                rad_lw_cs_out,  & !< outgoing clear sky longwave radiation (W/m2) (not used)
567                                                rad_sw_cs_in,   & !< incoming clear sky shortwave radiation (W/m2) (not used)
568                                                rad_sw_cs_out,  & !< outgoing clear sky shortwave radiation (W/m2) (not used)
569                                                rrtm_lw_tauaer, & !< lw aerosol optical depth
570                                                rrtm_lw_taucld, & !< lw in-cloud optical depth
571                                                rrtm_sw_taucld, & !< sw in-cloud optical depth
572                                                rrtm_sw_ssacld, & !< sw in-cloud single scattering albedo
573                                                rrtm_sw_asmcld, & !< sw in-cloud asymmetry parameter
574                                                rrtm_sw_fsfcld, & !< sw in-cloud forward scattering fraction
575                                                rrtm_sw_tauaer, & !< sw aerosol optical depth
576                                                rrtm_sw_ssaaer, & !< sw aerosol single scattering albedo
577                                                rrtm_sw_asmaer, & !< sw aerosol asymmetry parameter
578                                                rrtm_sw_ecaer     !< sw aerosol optical detph at 0.55 microns (rrtm_iaer = 6 only)
579
580#endif
581!
582!-- Parameters of urban and land surface models
583    INTEGER(iwp)                                   ::  nz_urban                           !< number of layers of urban surface (will be calculated)
584    INTEGER(iwp)                                   ::  nz_plant                           !< number of layers of plant canopy (will be calculated)
585    INTEGER(iwp)                                   ::  nz_urban_b                         !< bottom layer of urban surface (will be calculated)
586    INTEGER(iwp)                                   ::  nz_urban_t                         !< top layer of urban surface (will be calculated)
587    INTEGER(iwp)                                   ::  nz_plant_t                         !< top layer of plant canopy (will be calculated)
588!-- parameters of urban and land surface models
589    INTEGER(iwp), PARAMETER                        ::  nzut_free = 3                      !< number of free layers above top of of topography
590    INTEGER(iwp), PARAMETER                        ::  ndsvf = 2                          !< number of dimensions of real values in SVF
591    INTEGER(iwp), PARAMETER                        ::  idsvf = 2                          !< number of dimensions of integer values in SVF
592    INTEGER(iwp), PARAMETER                        ::  ndcsf = 1                          !< number of dimensions of real values in CSF
593    INTEGER(iwp), PARAMETER                        ::  idcsf = 2                          !< number of dimensions of integer values in CSF
594    INTEGER(iwp), PARAMETER                        ::  kdcsf = 4                          !< number of dimensions of integer values in CSF calculation array
595    INTEGER(iwp), PARAMETER                        ::  id = 1                             !< position of d-index in surfl and surf
596    INTEGER(iwp), PARAMETER                        ::  iz = 2                             !< position of k-index in surfl and surf
597    INTEGER(iwp), PARAMETER                        ::  iy = 3                             !< position of j-index in surfl and surf
598    INTEGER(iwp), PARAMETER                        ::  ix = 4                             !< position of i-index in surfl and surf
599    INTEGER(iwp), PARAMETER                        ::  im = 5                             !< position of surface m-index in surfl and surf
600    INTEGER(iwp), PARAMETER                        ::  nidx_surf = 5                      !< number of indices in surfl and surf
601
602    INTEGER(iwp), PARAMETER                        ::  nsurf_type = 10                    !< number of surf types incl. phys.(land+urban) & (atm.,sky,boundary) surfaces - 1
603
604    INTEGER(iwp), PARAMETER                        ::  iup_u    = 0                       !< 0 - index of urban upward surface (ground or roof)
605    INTEGER(iwp), PARAMETER                        ::  idown_u  = 1                       !< 1 - index of urban downward surface (overhanging)
606    INTEGER(iwp), PARAMETER                        ::  inorth_u = 2                       !< 2 - index of urban northward facing wall
607    INTEGER(iwp), PARAMETER                        ::  isouth_u = 3                       !< 3 - index of urban southward facing wall
608    INTEGER(iwp), PARAMETER                        ::  ieast_u  = 4                       !< 4 - index of urban eastward facing wall
609    INTEGER(iwp), PARAMETER                        ::  iwest_u  = 5                       !< 5 - index of urban westward facing wall
610
611    INTEGER(iwp), PARAMETER                        ::  iup_l    = 6                       !< 6 - index of land upward surface (ground or roof)
612    INTEGER(iwp), PARAMETER                        ::  inorth_l = 7                       !< 7 - index of land northward facing wall
613    INTEGER(iwp), PARAMETER                        ::  isouth_l = 8                       !< 8 - index of land southward facing wall
614    INTEGER(iwp), PARAMETER                        ::  ieast_l  = 9                       !< 9 - index of land eastward facing wall
615    INTEGER(iwp), PARAMETER                        ::  iwest_l  = 10                      !< 10- index of land westward facing wall
616
617    INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER ::  idir = (/0, 0,0, 0,1,-1,0,0, 0,1,-1/)   !< surface normal direction x indices
618    INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER ::  jdir = (/0, 0,1,-1,0, 0,0,1,-1,0, 0/)   !< surface normal direction y indices
619    INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER ::  kdir = (/1,-1,0, 0,0, 0,1,0, 0,0, 0/)   !< surface normal direction z indices
620    REAL(wp),     DIMENSION(0:nsurf_type)          :: facearea                            !< area of single face in respective
621                                                                                          !< direction (will be calc'd)
622
623
624!-- indices and sizes of urban and land surface models
625    INTEGER(iwp)                                   ::  startland        !< start index of block of land and roof surfaces
626    INTEGER(iwp)                                   ::  endland          !< end index of block of land and roof surfaces
627    INTEGER(iwp)                                   ::  nlands           !< number of land and roof surfaces in local processor
628    INTEGER(iwp)                                   ::  startwall        !< start index of block of wall surfaces
629    INTEGER(iwp)                                   ::  endwall          !< end index of block of wall surfaces
630    INTEGER(iwp)                                   ::  nwalls           !< number of wall surfaces in local processor
631
632!-- indices needed for RTM netcdf output subroutines
633    INTEGER(iwp), PARAMETER                        :: nd = 5
634    CHARACTER(LEN=6), DIMENSION(0:nd-1), PARAMETER :: dirname = (/ '_roof ', '_south', '_north', '_west ', '_east ' /)
635    INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER     :: dirint_u = (/ iup_u, isouth_u, inorth_u, iwest_u, ieast_u /)
636    INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER     :: dirint_l = (/ iup_l, isouth_l, inorth_l, iwest_l, ieast_l /)
637    INTEGER(iwp), DIMENSION(0:nd-1)                :: dirstart
638    INTEGER(iwp), DIMENSION(0:nd-1)                :: dirend
639
640!-- indices and sizes of urban and land surface models
641    INTEGER(iwp), DIMENSION(:,:), POINTER          ::  surfl            !< coordinates of i-th local surface in local grid - surfl[:,k] = [d, z, y, x, m]
642    INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET ::  surfl_linear     !< dtto (linearly allocated array)
643    INTEGER(iwp), DIMENSION(:,:), POINTER          ::  surf             !< coordinates of i-th surface in grid - surf[:,k] = [d, z, y, x, m]
644    INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET ::  surf_linear      !< dtto (linearly allocated array)
645    INTEGER(iwp)                                   ::  nsurfl           !< number of all surfaces in local processor
646    INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET ::  nsurfs           !< array of number of all surfaces in individual processors
647    INTEGER(iwp)                                   ::  nsurf            !< global number of surfaces in index array of surfaces (nsurf = proc nsurfs)
648    INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET ::  surfstart        !< starts of blocks of surfaces for individual processors in array surf (indexed from 1)
649                                                                        !< respective block for particular processor is surfstart[iproc+1]+1 : surfstart[iproc+1]+nsurfs[iproc+1]
650
651!-- block variables needed for calculation of the plant canopy model inside the urban surface model
652    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  pct              !< top layer of the plant canopy
653    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  pch              !< heights of the plant canopy
654    INTEGER(iwp)                                   ::  npcbl = 0        !< number of the plant canopy gridboxes in local processor
655    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  pcbl             !< k,j,i coordinates of l-th local plant canopy box pcbl[:,l] = [k, j, i]
656    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  pcbinsw          !< array of absorbed sw radiation for local plant canopy box
657    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  pcbinswdir       !< array of absorbed direct sw radiation for local plant canopy box
658    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  pcbinswdif       !< array of absorbed diffusion sw radiation for local plant canopy box
659    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  pcbinlw          !< array of absorbed lw radiation for local plant canopy box
660
661!-- configuration parameters (they can be setup in PALM config)
662    LOGICAL                                        ::  raytrace_mpi_rma = .TRUE.          !< use MPI RMA to access LAD and gridsurf from remote processes during raytracing
663    LOGICAL                                        ::  rad_angular_discretization = .TRUE.!< whether to use fixed resolution discretization of view factors for
664                                                                                          !< reflected radiation (as opposed to all mutually visible pairs)
665    LOGICAL                                        ::  plant_lw_interact = .TRUE.         !< whether plant canopy interacts with LW radiation (in addition to SW)
666    INTEGER(iwp)                                   ::  mrt_nlevels = 0                    !< number of vertical boxes above surface for which to calculate MRT
667    LOGICAL                                        ::  mrt_skip_roof = .TRUE.             !< do not calculate MRT above roof surfaces
668    LOGICAL                                        ::  mrt_include_sw = .TRUE.            !< should MRT calculation include SW radiation as well?
669    LOGICAL                                        ::  mrt_geom_human = .TRUE.            !< MRT direction weights simulate human body instead of a sphere
670    INTEGER(iwp)                                   ::  nrefsteps = 3                      !< number of reflection steps to perform
671    REAL(wp), PARAMETER                            ::  ext_coef = 0.6_wp                  !< extinction coefficient (a.k.a. alpha)
672    INTEGER(iwp), PARAMETER                        ::  rad_version_len = 10               !< length of identification string of rad version
673    CHARACTER(rad_version_len), PARAMETER          ::  rad_version = 'RAD v. 3.0'         !< identification of version of binary svf and restart files
674    INTEGER(iwp)                                   ::  raytrace_discrete_elevs = 40       !< number of discretization steps for elevation (nadir to zenith)
675    INTEGER(iwp)                                   ::  raytrace_discrete_azims = 80       !< number of discretization steps for azimuth (out of 360 degrees)
676    REAL(wp)                                       ::  max_raytracing_dist = -999.0_wp    !< maximum distance for raytracing (in metres)
677    REAL(wp)                                       ::  min_irrf_value = 1e-6_wp           !< minimum potential irradiance factor value for raytracing
678    REAL(wp), DIMENSION(1:30)                      ::  svfnorm_report_thresh = 1e21_wp    !< thresholds of SVF normalization values to report
679    INTEGER(iwp)                                   ::  svfnorm_report_num                 !< number of SVF normalization thresholds to report
680
681!-- radiation related arrays to be used in radiation_interaction routine
682    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  rad_sw_in_dir    !< direct sw radiation
683    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  rad_sw_in_diff   !< diffusion sw radiation
684    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  rad_lw_in_diff   !< diffusion lw radiation
685
686!-- parameters required for RRTMG lower boundary condition
687    REAL(wp)                   :: albedo_urb      !< albedo value retuned to RRTMG boundary cond.
688    REAL(wp)                   :: emissivity_urb  !< emissivity value retuned to RRTMG boundary cond.
689    REAL(wp)                   :: t_rad_urb       !< temperature value retuned to RRTMG boundary cond.
690
691!-- type for calculation of svf
692    TYPE t_svf
693        INTEGER(iwp)                               :: isurflt           !<
694        INTEGER(iwp)                               :: isurfs            !<
695        REAL(wp)                                   :: rsvf              !<
696        REAL(wp)                                   :: rtransp           !<
697    END TYPE
698
699!-- type for calculation of csf
700    TYPE t_csf
701        INTEGER(iwp)                               :: ip                !<
702        INTEGER(iwp)                               :: itx               !<
703        INTEGER(iwp)                               :: ity               !<
704        INTEGER(iwp)                               :: itz               !<
705        INTEGER(iwp)                               :: isurfs            !< Idx of source face / -1 for sky
706        REAL(wp)                                   :: rcvf              !< Canopy view factor for faces /
707                                                                        !< canopy sink factor for sky (-1)
708    END TYPE
709
710!-- arrays storing the values of USM
711    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  svfsurf          !< svfsurf[:,isvf] = index of target and source surface for svf[isvf]
712    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  svf              !< array of shape view factors+direct irradiation factors for local surfaces
713    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfins          !< array of sw radiation falling to local surface after i-th reflection
714    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinl          !< array of lw radiation for local surface after i-th reflection
715
716    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  skyvf            !< array of sky view factor for each local surface
717    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  skyvft           !< array of sky view factor including transparency for each local surface
718    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  dsitrans         !< dsidir[isvfl,i] = path transmittance of i-th
719                                                                        !< direction of direct solar irradiance per target surface
720    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  dsitransc        !< dtto per plant canopy box
721    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  dsidir           !< dsidir[:,i] = unit vector of i-th
722                                                                        !< direction of direct solar irradiance
723    INTEGER(iwp)                                   ::  ndsidir          !< number of apparent solar directions used
724    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  dsidir_rev       !< dsidir_rev[ielev,iazim] = i for dsidir or -1 if not present
725
726    INTEGER(iwp)                                   ::  nmrtbl           !< No. of local grid boxes for which MRT is calculated
727    INTEGER(iwp)                                   ::  nmrtf            !< number of MRT factors for local processor
728    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  mrtbl            !< coordinates of i-th local MRT box - surfl[:,i] = [z, y, x]
729    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  mrtfsurf         !< mrtfsurf[:,imrtf] = index of target MRT box and source surface for mrtf[imrtf]
730    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrtf             !< array of MRT factors for each local MRT box
731    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrtft            !< array of MRT factors including transparency for each local MRT box
732    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrtsky           !< array of sky view factor for each local MRT box
733    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrtskyt          !< array of sky view factor including transparency for each local MRT box
734    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  mrtdsit          !< array of direct solar transparencies for each local MRT box
735    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrtinsw          !< mean SW radiant flux for each MRT box
736    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrtinlw          !< mean LW radiant flux for each MRT box
737    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrt              !< mean radiant temperature for each MRT box
738    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrtinsw_av       !< time average mean SW radiant flux for each MRT box
739    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrtinlw_av       !< time average mean LW radiant flux for each MRT box
740    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  mrt_av           !< time average mean radiant temperature for each MRT box
741
742    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinsw         !< array of sw radiation falling to local surface including radiation from reflections
743    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinlw         !< array of lw radiation falling to local surface including radiation from reflections
744    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinswdir      !< array of direct sw radiation falling to local surface
745    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinswdif      !< array of diffuse sw radiation from sky and model boundary falling to local surface
746    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinlwdif      !< array of diffuse lw radiation from sky and model boundary falling to local surface
747   
748                                                                        !< Outward radiation is only valid for nonvirtual surfaces
749    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfoutsl        !< array of reflected sw radiation for local surface in i-th reflection
750    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfoutll        !< array of reflected + emitted lw radiation for local surface in i-th reflection
751    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfouts         !< array of reflected sw radiation for all surfaces in i-th reflection
752    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfoutl         !< array of reflected + emitted lw radiation for all surfaces in i-th reflection
753    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinlg         !< global array of incoming lw radiation from plant canopy
754    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfoutsw        !< array of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection
755    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfoutlw        !< array of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection
756    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfemitlwl      !< array of emitted lw radiation for local surface used to calculate effective surface temperature for radiation model
757
758!-- block variables needed for calculation of the plant canopy model inside the urban surface model
759    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  csfsurf          !< csfsurf[:,icsf] = index of target surface and csf grid index for csf[icsf]
760    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  csf              !< array of plant canopy sink fators + direct irradiation factors (transparency)
761    REAL(wp), DIMENSION(:,:,:), POINTER            ::  sub_lad          !< subset of lad_s within urban surface, transformed to plain Z coordinate
762    REAL(wp), DIMENSION(:), POINTER                ::  sub_lad_g        !< sub_lad globalized (used to avoid MPI RMA calls in raytracing)
763    REAL(wp)                                       ::  prototype_lad    !< prototype leaf area density for computing effective optical depth
764    INTEGER(iwp), DIMENSION(:), ALLOCATABLE        ::  nzterr, plantt   !< temporary global arrays for raytracing
765    INTEGER(iwp)                                   ::  plantt_max
766
767!-- arrays and variables for calculation of svf and csf
768    TYPE(t_svf), DIMENSION(:), POINTER             ::  asvf             !< pointer to growing svc array
769    TYPE(t_csf), DIMENSION(:), POINTER             ::  acsf             !< pointer to growing csf array
770    TYPE(t_svf), DIMENSION(:), POINTER             ::  amrtf            !< pointer to growing mrtf array
771    TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET ::  asvf1, asvf2     !< realizations of svf array
772    TYPE(t_csf), DIMENSION(:), ALLOCATABLE, TARGET ::  acsf1, acsf2     !< realizations of csf array
773    TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET ::  amrtf1, amrtf2   !< realizations of mftf array
774    INTEGER(iwp)                                   ::  nsvfla           !< dimmension of array allocated for storage of svf in local processor
775    INTEGER(iwp)                                   ::  ncsfla           !< dimmension of array allocated for storage of csf in local processor
776    INTEGER(iwp)                                   ::  nmrtfa           !< dimmension of array allocated for storage of mrt
777    INTEGER(iwp)                                   ::  msvf, mcsf, mmrtf!< mod for swapping the growing array
778    INTEGER(iwp), PARAMETER                        ::  gasize = 100000_iwp  !< initial size of growing arrays
779    REAL(wp), PARAMETER                            ::  grow_factor = 1.4_wp !< growth factor of growing arrays
780    INTEGER(iwp)                                   ::  nsvfl            !< number of svf for local processor
781    INTEGER(iwp)                                   ::  ncsfl            !< no. of csf in local processor
782                                                                        !< needed only during calc_svf but must be here because it is
783                                                                        !< shared between subroutines calc_svf and raytrace
784    INTEGER(iwp), DIMENSION(:,:,:,:), POINTER      ::  gridsurf         !< reverse index of local surfl[d,k,j,i] (for case rad_angular_discretization)
785    INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE    ::  gridpcbl         !< reverse index of local pcbl[k,j,i]
786    INTEGER(iwp), PARAMETER                        ::  nsurf_type_u = 6 !< number of urban surf types (used in gridsurf)
787
788!-- temporary arrays for calculation of csf in raytracing
789    INTEGER(iwp)                                   ::  maxboxesg        !< max number of boxes ray can cross in the domain
790    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  boxes            !< coordinates of gridboxes being crossed by ray
791    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  crlens           !< array of crossing lengths of ray for particular grid boxes
792    INTEGER(iwp), DIMENSION(:), ALLOCATABLE        ::  lad_ip           !< array of numbers of process where lad is stored
793#if defined( __parallel )
794    INTEGER(kind=MPI_ADDRESS_KIND), &
795                  DIMENSION(:), ALLOCATABLE        ::  lad_disp         !< array of displaycements of lad in local array of proc lad_ip
796    INTEGER(iwp)                                   ::  win_lad          !< MPI RMA window for leaf area density
797    INTEGER(iwp)                                   ::  win_gridsurf     !< MPI RMA window for reverse grid surface index
798#endif
799    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  lad_s_ray        !< array of received lad_s for appropriate gridboxes crossed by ray
800    INTEGER(iwp), DIMENSION(:), ALLOCATABLE        ::  target_surfl
801    INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE      ::  rt2_track
802    REAL(wp), DIMENSION(:,:), ALLOCATABLE          ::  rt2_track_lad
803    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  rt2_track_dist
804    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  rt2_dist
805
806!-- arrays for time averages
807    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfradnet_av    !< average of net radiation to local surface including radiation from reflections
808    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinsw_av      !< average of sw radiation falling to local surface including radiation from reflections
809    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinlw_av      !< average of lw radiation falling to local surface including radiation from reflections
810    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinswdir_av   !< average of direct sw radiation falling to local surface
811    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinswdif_av   !< average of diffuse sw radiation from sky and model boundary falling to local surface
812    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinlwdif_av   !< average of diffuse lw radiation from sky and model boundary falling to local surface
813    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinswref_av   !< average of sw radiation falling to surface from reflections
814    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinlwref_av   !< average of lw radiation falling to surface from reflections
815    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfoutsw_av     !< average of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection
816    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfoutlw_av     !< average of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection
817    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfins_av       !< average of array of residua of sw radiation absorbed in surface after last reflection
818    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  surfinl_av       !< average of array of residua of lw radiation absorbed in surface after last reflection
819    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  pcbinlw_av       !< Average of pcbinlw
820    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  pcbinsw_av       !< Average of pcbinsw
821    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  pcbinswdir_av    !< Average of pcbinswdir
822    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  pcbinswdif_av    !< Average of pcbinswdif
823    REAL(wp), DIMENSION(:), ALLOCATABLE            ::  pcbinswref_av    !< Average of pcbinswref
824
825
826!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
827!-- Energy balance variables
828!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
829!-- parameters of the land, roof and wall surfaces
830    REAL(wp), DIMENSION(:), ALLOCATABLE            :: albedo_surf        !< albedo of the surface
831    REAL(wp), DIMENSION(:), ALLOCATABLE            :: emiss_surf         !< emissivity of the wall surface
832!
833!-- External radiation. Depending on the given level of detail either a 1D or
834!-- a 3D array will be allocated.
835    TYPE( real_1d_3d ) ::  rad_lw_in_f     !< external incoming longwave radiation, from observation or model
836    TYPE( real_1d_3d ) ::  rad_sw_in_f     !< external incoming shortwave radiation, from observation or model
837    TYPE( real_1d_3d ) ::  rad_sw_in_dif_f !< external incoming shortwave radiation, diffuse part, from observation or model
838    TYPE( real_1d_3d ) ::  time_rad_f      !< time dimension for external radiation, from observation or model
839
840    INTERFACE radiation_check_data_output
841       MODULE PROCEDURE radiation_check_data_output
842    END INTERFACE radiation_check_data_output
843
844    INTERFACE radiation_check_data_output_ts
845       MODULE PROCEDURE radiation_check_data_output_ts
846    END INTERFACE radiation_check_data_output_ts
847
848    INTERFACE radiation_check_data_output_pr
849       MODULE PROCEDURE radiation_check_data_output_pr
850    END INTERFACE radiation_check_data_output_pr
851 
852    INTERFACE radiation_check_parameters
853       MODULE PROCEDURE radiation_check_parameters
854    END INTERFACE radiation_check_parameters
855 
856    INTERFACE radiation_clearsky
857       MODULE PROCEDURE radiation_clearsky
858    END INTERFACE radiation_clearsky
859 
860    INTERFACE radiation_constant
861       MODULE PROCEDURE radiation_constant
862    END INTERFACE radiation_constant
863 
864    INTERFACE radiation_control
865       MODULE PROCEDURE radiation_control
866    END INTERFACE radiation_control
867
868    INTERFACE radiation_3d_data_averaging
869       MODULE PROCEDURE radiation_3d_data_averaging
870    END INTERFACE radiation_3d_data_averaging
871
872    INTERFACE radiation_data_output_2d
873       MODULE PROCEDURE radiation_data_output_2d
874    END INTERFACE radiation_data_output_2d
875
876    INTERFACE radiation_data_output_3d
877       MODULE PROCEDURE radiation_data_output_3d
878    END INTERFACE radiation_data_output_3d
879
880    INTERFACE radiation_data_output_mask
881       MODULE PROCEDURE radiation_data_output_mask
882    END INTERFACE radiation_data_output_mask
883
884    INTERFACE radiation_define_netcdf_grid
885       MODULE PROCEDURE radiation_define_netcdf_grid
886    END INTERFACE radiation_define_netcdf_grid
887
888    INTERFACE radiation_header
889       MODULE PROCEDURE radiation_header
890    END INTERFACE radiation_header 
891 
892    INTERFACE radiation_init
893       MODULE PROCEDURE radiation_init
894    END INTERFACE radiation_init
895
896    INTERFACE radiation_parin
897       MODULE PROCEDURE radiation_parin
898    END INTERFACE radiation_parin
899   
900    INTERFACE radiation_rrtmg
901       MODULE PROCEDURE radiation_rrtmg
902    END INTERFACE radiation_rrtmg
903
904#if defined( __rrtmg )
905    INTERFACE radiation_tendency
906       MODULE PROCEDURE radiation_tendency
907       MODULE PROCEDURE radiation_tendency_ij
908    END INTERFACE radiation_tendency
909#endif
910
911    INTERFACE radiation_rrd_local
912       MODULE PROCEDURE radiation_rrd_local
913    END INTERFACE radiation_rrd_local
914
915    INTERFACE radiation_wrd_local
916       MODULE PROCEDURE radiation_wrd_local
917    END INTERFACE radiation_wrd_local
918
919    INTERFACE radiation_interaction
920       MODULE PROCEDURE radiation_interaction
921    END INTERFACE radiation_interaction
922
923    INTERFACE radiation_interaction_init
924       MODULE PROCEDURE radiation_interaction_init
925    END INTERFACE radiation_interaction_init
926 
927    INTERFACE radiation_presimulate_solar_pos
928       MODULE PROCEDURE radiation_presimulate_solar_pos
929    END INTERFACE radiation_presimulate_solar_pos
930
931    INTERFACE radiation_calc_svf
932       MODULE PROCEDURE radiation_calc_svf
933    END INTERFACE radiation_calc_svf
934
935    INTERFACE radiation_write_svf
936       MODULE PROCEDURE radiation_write_svf
937    END INTERFACE radiation_write_svf
938
939    INTERFACE radiation_read_svf
940       MODULE PROCEDURE radiation_read_svf
941    END INTERFACE radiation_read_svf
942
943
944    SAVE
945
946    PRIVATE
947
948!
949!-- Public functions / NEEDS SORTING
950    PUBLIC radiation_check_data_output, radiation_check_data_output_pr,        &
951           radiation_check_data_output_ts,                                     &
952           radiation_check_parameters, radiation_control,                      &
953           radiation_header, radiation_init, radiation_parin,                  &
954           radiation_3d_data_averaging,                                        &
955           radiation_data_output_2d, radiation_data_output_3d,                 &
956           radiation_define_netcdf_grid, radiation_wrd_local,                  &
957           radiation_rrd_local, radiation_data_output_mask,                    &
958           radiation_calc_svf, radiation_write_svf,                            &
959           radiation_interaction, radiation_interaction_init,                  &
960           radiation_read_svf, radiation_presimulate_solar_pos
961
962   
963!
964!-- Public variables and constants / NEEDS SORTING
965    PUBLIC albedo, albedo_type, decl_1, decl_2, decl_3, dots_rad, dt_radiation,&
966           emissivity, force_radiation_call, lat, lon, mrt_geom_human,         &
967           mrt_include_sw, mrt_nlevels, mrtbl, mrtinsw, mrtinlw, nmrtbl,       &
968           rad_net_av, radiation, radiation_scheme, rad_lw_in,                 &
969           rad_lw_in_av, rad_lw_out, rad_lw_out_av,                            &
970           rad_lw_cs_hr, rad_lw_cs_hr_av, rad_lw_hr, rad_lw_hr_av, rad_sw_in,  &
971           rad_sw_in_av, rad_sw_out, rad_sw_out_av, rad_sw_cs_hr,              &
972           rad_sw_cs_hr_av, rad_sw_hr, rad_sw_hr_av, solar_constant,           &
973           skip_time_do_radiation, time_radiation, unscheduled_radiation_calls,&
974           cos_zenith, calc_zenith, sun_direction, sun_dir_lat, sun_dir_lon,   &
975           idir, jdir, kdir, id, iz, iy, ix,                                   &
976           iup_u, inorth_u, isouth_u, ieast_u, iwest_u,                        &
977           iup_l, inorth_l, isouth_l, ieast_l, iwest_l,                        &
978           nsurf_type, nz_urban_b, nz_urban_t, nz_urban, pch, nsurf,                 &
979           idsvf, ndsvf, idcsf, ndcsf, kdcsf, pct,                             &
980           radiation_interactions, startwall, startland, endland, endwall,     &
981           skyvf, skyvft, radiation_interactions_on, average_radiation,        &
982           rad_sw_in_diff, rad_sw_in_dir
983
984
985#if defined ( __rrtmg )
986    PUBLIC radiation_tendency, rrtm_aldif, rrtm_aldir, rrtm_asdif, rrtm_asdir
987#endif
988
989 CONTAINS
990
991
992!------------------------------------------------------------------------------!
993! Description:
994! ------------
995!> This subroutine controls the calls of the radiation schemes
996!------------------------------------------------------------------------------!
997    SUBROUTINE radiation_control
998 
999 
1000       IMPLICIT NONE
1001
1002
1003       IF ( debug_output_timestep )  CALL debug_message( 'radiation_control', 'start' )
1004
1005
1006       SELECT CASE ( TRIM( radiation_scheme ) )
1007
1008          CASE ( 'constant' )
1009             CALL radiation_constant
1010         
1011          CASE ( 'clear-sky' ) 
1012             CALL radiation_clearsky
1013       
1014          CASE ( 'rrtmg' )
1015             CALL radiation_rrtmg
1016             
1017          CASE ( 'external' )
1018!
1019!--          During spinup apply clear-sky model
1020             IF ( time_since_reference_point < 0.0_wp )  THEN
1021                CALL radiation_clearsky
1022             ELSE
1023                CALL radiation_external
1024             ENDIF
1025
1026          CASE DEFAULT
1027
1028       END SELECT
1029
1030       IF ( debug_output_timestep )  CALL debug_message( 'radiation_control', 'end' )
1031
1032    END SUBROUTINE radiation_control
1033
1034!------------------------------------------------------------------------------!
1035! Description:
1036! ------------
1037!> Check data output for radiation model
1038!------------------------------------------------------------------------------!
1039    SUBROUTINE radiation_check_data_output( variable, unit, i, ilen, k )
1040 
1041 
1042       USE control_parameters,                                                 &
1043           ONLY: data_output, message_string
1044
1045       IMPLICIT NONE
1046
1047       CHARACTER (LEN=*) ::  unit          !<
1048       CHARACTER (LEN=*) ::  variable      !<
1049
1050       INTEGER(iwp) :: i, k
1051       INTEGER(iwp) :: ilen
1052       CHARACTER(LEN=varnamelength) :: var  !< TRIM(variable)
1053
1054       var = TRIM(variable)
1055
1056       IF ( len(var) < 3_iwp  )  THEN
1057          unit = 'illegal'
1058          RETURN
1059       ENDIF
1060
1061       IF ( var(1:3) /= 'rad'  .AND.  var(1:3) /= 'rtm' )  THEN
1062          unit = 'illegal'
1063          RETURN
1064       ENDIF
1065
1066!--    first process diractional variables
1067       IF ( var(1:12) == 'rtm_rad_net_'  .OR.  var(1:13) == 'rtm_rad_insw_'  .OR.        &
1068            var(1:13) == 'rtm_rad_inlw_'  .OR.  var(1:16) == 'rtm_rad_inswdir_'  .OR.    &
1069            var(1:16) == 'rtm_rad_inswdif_'  .OR.  var(1:16) == 'rtm_rad_inswref_'  .OR. &
1070            var(1:16) == 'rtm_rad_inlwdif_'  .OR.  var(1:16) == 'rtm_rad_inlwref_'  .OR. &
1071            var(1:14) == 'rtm_rad_outsw_'  .OR.  var(1:14) == 'rtm_rad_outlw_'  .OR.     &
1072            var(1:14) == 'rtm_rad_ressw_'  .OR.  var(1:14) == 'rtm_rad_reslw_'  ) THEN
1073          IF ( .NOT.  radiation ) THEN
1074                message_string = 'output of "' // TRIM( var ) // '" require'&
1075                                 // 's radiation = .TRUE.'
1076                CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1077          ENDIF
1078          unit = 'W/m2'
1079       ELSE IF ( var(1:7) == 'rtm_svf'  .OR.  var(1:7) == 'rtm_dif'  .OR.                &
1080                 var(1:9) == 'rtm_skyvf' .OR. var(1:9) == 'rtm_skyvft'  .OR.             &
1081                 var(1:12) == 'rtm_surfalb_'  .OR.  var(1:13) == 'rtm_surfemis_'  ) THEN
1082          IF ( .NOT.  radiation ) THEN
1083                message_string = 'output of "' // TRIM( var ) // '" require'&
1084                                 // 's radiation = .TRUE.'
1085                CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1086          ENDIF
1087          unit = '1'
1088       ELSE
1089!--       non-directional variables
1090          SELECT CASE ( TRIM( var ) )
1091             CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_lw_in', 'rad_lw_out', &
1092                    'rad_sw_cs_hr', 'rad_sw_hr', 'rad_sw_in', 'rad_sw_out'  )
1093                IF (  .NOT.  radiation  .OR.  radiation_scheme /= 'rrtmg' )  THEN
1094                   message_string = '"output of "' // TRIM( var ) // '" requi' // &
1095                                    'res radiation = .TRUE. and ' //              &
1096                                    'radiation_scheme = "rrtmg"'
1097                   CALL message( 'check_parameters', 'PA0406', 1, 2, 0, 6, 0 )
1098                ENDIF
1099                unit = 'K/h'
1100
1101             CASE ( 'rad_net*', 'rrtm_aldif*', 'rrtm_aldir*', 'rrtm_asdif*',      &
1102                    'rrtm_asdir*', 'rad_lw_in*', 'rad_lw_out*', 'rad_sw_in*',     &
1103                    'rad_sw_out*')
1104                IF ( i == 0 .AND. ilen == 0 .AND. k == 0)  THEN
1105                   ! Workaround for masked output (calls with i=ilen=k=0)
1106                   unit = 'illegal'
1107                   RETURN
1108                ENDIF
1109                IF ( k == 0  .OR.  data_output(i)(ilen-2:ilen) /= '_xy' )  THEN
1110                   message_string = 'illegal value for data_output: "' //         &
1111                                    TRIM( var ) // '" & only 2d-horizontal ' //   &
1112                                    'cross sections are allowed for this value'
1113                   CALL message( 'check_parameters', 'PA0111', 1, 2, 0, 6, 0 )
1114                ENDIF
1115                IF (  .NOT.  radiation  .OR.  radiation_scheme /= "rrtmg" )  THEN
1116                   IF ( TRIM( var ) == 'rrtm_aldif*'  .OR.                        &
1117                        TRIM( var ) == 'rrtm_aldir*'  .OR.                        &
1118                        TRIM( var ) == 'rrtm_asdif*'  .OR.                        &
1119                        TRIM( var ) == 'rrtm_asdir*'      )                       &
1120                   THEN
1121                      message_string = 'output of "' // TRIM( var ) // '" require'&
1122                                       // 's radiation = .TRUE. and radiation_sch'&
1123                                       // 'eme = "rrtmg"'
1124                      CALL message( 'check_parameters', 'PA0409', 1, 2, 0, 6, 0 )
1125                   ENDIF
1126                ENDIF
1127
1128                IF ( TRIM( var ) == 'rad_net*'      ) unit = 'W/m2'
1129                IF ( TRIM( var ) == 'rad_lw_in*'    ) unit = 'W/m2'
1130                IF ( TRIM( var ) == 'rad_lw_out*'   ) unit = 'W/m2'
1131                IF ( TRIM( var ) == 'rad_sw_in*'    ) unit = 'W/m2'
1132                IF ( TRIM( var ) == 'rad_sw_out*'   ) unit = 'W/m2'
1133                IF ( TRIM( var ) == 'rad_sw_in'     ) unit = 'W/m2'
1134                IF ( TRIM( var ) == 'rrtm_aldif*'   ) unit = ''
1135                IF ( TRIM( var ) == 'rrtm_aldir*'   ) unit = ''
1136                IF ( TRIM( var ) == 'rrtm_asdif*'   ) unit = ''
1137                IF ( TRIM( var ) == 'rrtm_asdir*'   ) unit = ''
1138
1139             CASE ( 'rtm_rad_pc_inlw', 'rtm_rad_pc_insw', 'rtm_rad_pc_inswdir', &
1140                    'rtm_rad_pc_inswdif', 'rtm_rad_pc_inswref')
1141                IF ( .NOT.  radiation ) THEN
1142                   message_string = 'output of "' // TRIM( var ) // '" require'&
1143                                    // 's radiation = .TRUE.'
1144                   CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1145                ENDIF
1146                unit = 'W'
1147
1148             CASE ( 'rtm_mrt', 'rtm_mrt_sw', 'rtm_mrt_lw'  )
1149                IF ( i == 0 .AND. ilen == 0 .AND. k == 0)  THEN
1150                   ! Workaround for masked output (calls with i=ilen=k=0)
1151                   unit = 'illegal'
1152                   RETURN
1153                ENDIF
1154
1155                IF ( .NOT.  radiation ) THEN
1156                   message_string = 'output of "' // TRIM( var ) // '" require'&
1157                                    // 's radiation = .TRUE.'
1158                   CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 )
1159                ENDIF
1160                IF ( mrt_nlevels == 0 ) THEN
1161                   message_string = 'output of "' // TRIM( var ) // '" require'&
1162                                    // 's mrt_nlevels > 0'
1163                   CALL message( 'check_parameters', 'PA0510', 1, 2, 0, 6, 0 )
1164                ENDIF
1165                IF ( TRIM( var ) == 'rtm_mrt_sw'  .AND.  .NOT. mrt_include_sw ) THEN
1166                   message_string = 'output of "' // TRIM( var ) // '" require'&
1167                                    // 's rtm_mrt_sw = .TRUE.'
1168                   CALL message( 'check_parameters', 'PA0511', 1, 2, 0, 6, 0 )
1169                ENDIF
1170                IF ( TRIM( var ) == 'rtm_mrt' ) THEN
1171                   unit = 'K'
1172                ELSE
1173                   unit = 'W m-2'
1174                ENDIF
1175
1176             CASE DEFAULT
1177                unit = 'illegal'
1178
1179          END SELECT
1180       ENDIF
1181
1182    END SUBROUTINE radiation_check_data_output
1183
1184
1185!------------------------------------------------------------------------------!
1186! Description:
1187! ------------
1188!> Set module-specific timeseries units and labels
1189!------------------------------------------------------------------------------!
1190 SUBROUTINE radiation_check_data_output_ts( dots_max, dots_num )
1191
1192
1193    INTEGER(iwp),      INTENT(IN)     ::  dots_max
1194    INTEGER(iwp),      INTENT(INOUT)  ::  dots_num
1195
1196!
1197!-- Next line is just to avoid compiler warning about unused variable.
1198    IF ( dots_max == 0 )  CONTINUE
1199
1200!
1201!-- Temporary solution to add LSM and radiation time series to the default
1202!-- output
1203    IF ( land_surface  .OR.  radiation )  THEN
1204       IF ( TRIM( radiation_scheme ) == 'rrtmg' )  THEN
1205          dots_num = dots_num + 15
1206       ELSE
1207          dots_num = dots_num + 11
1208       ENDIF
1209    ENDIF
1210
1211
1212 END SUBROUTINE radiation_check_data_output_ts
1213
1214!------------------------------------------------------------------------------!
1215! Description:
1216! ------------
1217!> Check data output of profiles for radiation model
1218!------------------------------------------------------------------------------! 
1219    SUBROUTINE radiation_check_data_output_pr( variable, var_count, unit,      &
1220               dopr_unit )
1221 
1222       USE arrays_3d,                                                          &
1223           ONLY: zu
1224
1225       USE control_parameters,                                                 &
1226           ONLY: data_output_pr, message_string
1227
1228       USE indices
1229
1230       USE profil_parameter
1231
1232       USE statistics
1233
1234       IMPLICIT NONE
1235   
1236       CHARACTER (LEN=*) ::  unit      !<
1237       CHARACTER (LEN=*) ::  variable  !<
1238       CHARACTER (LEN=*) ::  dopr_unit !< local value of dopr_unit
1239 
1240       INTEGER(iwp) ::  var_count     !<
1241
1242       SELECT CASE ( TRIM( variable ) )
1243       
1244         CASE ( 'rad_net' )
1245             IF ( (  .NOT.  radiation )  .OR.  radiation_scheme == 'constant' )&
1246             THEN
1247                message_string = 'data_output_pr = ' //                        &
1248                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1249                                 'not available for radiation = .FALSE. or ' //&
1250                                 'radiation_scheme = "constant"'
1251                CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1252             ELSE
1253                dopr_index(var_count) = 99
1254                dopr_unit  = 'W/m2'
1255                hom(:,2,99,:)  = SPREAD( zw, 2, statistic_regions+1 )
1256                unit = dopr_unit
1257             ENDIF
1258
1259          CASE ( 'rad_lw_in' )
1260             IF ( (  .NOT.  radiation)  .OR.  radiation_scheme == 'constant' ) &
1261             THEN
1262                message_string = 'data_output_pr = ' //                        &
1263                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1264                                 'not available for radiation = .FALSE. or ' //&
1265                                 'radiation_scheme = "constant"'
1266                CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1267             ELSE
1268                dopr_index(var_count) = 100
1269                dopr_unit  = 'W/m2'
1270                hom(:,2,100,:)  = SPREAD( zw, 2, statistic_regions+1 )
1271                unit = dopr_unit 
1272             ENDIF
1273
1274          CASE ( 'rad_lw_out' )
1275             IF ( (  .NOT. radiation )  .OR.  radiation_scheme == 'constant' ) &
1276             THEN
1277                message_string = 'data_output_pr = ' //                        &
1278                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1279                                 'not available for radiation = .FALSE. or ' //&
1280                                 'radiation_scheme = "constant"'
1281                CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1282             ELSE
1283                dopr_index(var_count) = 101
1284                dopr_unit  = 'W/m2'
1285                hom(:,2,101,:)  = SPREAD( zw, 2, statistic_regions+1 )
1286                unit = dopr_unit   
1287             ENDIF
1288
1289          CASE ( 'rad_sw_in' )
1290             IF ( (  .NOT. radiation )  .OR.  radiation_scheme == 'constant' ) &
1291             THEN
1292                message_string = 'data_output_pr = ' //                        &
1293                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1294                                 'not available for radiation = .FALSE. or ' //&
1295                                 'radiation_scheme = "constant"'
1296                CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1297             ELSE
1298                dopr_index(var_count) = 102
1299                dopr_unit  = 'W/m2'
1300                hom(:,2,102,:)  = SPREAD( zw, 2, statistic_regions+1 )
1301                unit = dopr_unit
1302             ENDIF
1303
1304          CASE ( 'rad_sw_out')
1305             IF ( (  .NOT.  radiation )  .OR.  radiation_scheme == 'constant' )&
1306             THEN
1307                message_string = 'data_output_pr = ' //                        &
1308                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1309                                 'not available for radiation = .FALSE. or ' //&
1310                                 'radiation_scheme = "constant"'
1311                CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 )
1312             ELSE
1313                dopr_index(var_count) = 103
1314                dopr_unit  = 'W/m2'
1315                hom(:,2,103,:)  = SPREAD( zw, 2, statistic_regions+1 )
1316                unit = dopr_unit
1317             ENDIF
1318
1319          CASE ( 'rad_lw_cs_hr' )
1320             IF ( (  .NOT.  radiation )  .OR.  radiation_scheme /= 'rrtmg' )   &
1321             THEN
1322                message_string = 'data_output_pr = ' //                        &
1323                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1324                                 'not available for radiation = .FALSE. or ' //&
1325                                 'radiation_scheme /= "rrtmg"'
1326                CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1327             ELSE
1328                dopr_index(var_count) = 104
1329                dopr_unit  = 'K/h'
1330                hom(:,2,104,:)  = SPREAD( zu, 2, statistic_regions+1 )
1331                unit = dopr_unit
1332             ENDIF
1333
1334          CASE ( 'rad_lw_hr' )
1335             IF ( (  .NOT.  radiation )  .OR.  radiation_scheme /= 'rrtmg' )   &
1336             THEN
1337                message_string = 'data_output_pr = ' //                        &
1338                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1339                                 'not available for radiation = .FALSE. or ' //&
1340                                 'radiation_scheme /= "rrtmg"'
1341                CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1342             ELSE
1343                dopr_index(var_count) = 105
1344                dopr_unit  = 'K/h'
1345                hom(:,2,105,:)  = SPREAD( zu, 2, statistic_regions+1 )
1346                unit = dopr_unit
1347             ENDIF
1348
1349          CASE ( 'rad_sw_cs_hr' )
1350             IF ( (  .NOT.  radiation )  .OR.  radiation_scheme /= 'rrtmg' )   &
1351             THEN
1352                message_string = 'data_output_pr = ' //                        &
1353                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1354                                 'not available for radiation = .FALSE. or ' //&
1355                                 'radiation_scheme /= "rrtmg"'
1356                CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1357             ELSE
1358                dopr_index(var_count) = 106
1359                dopr_unit  = 'K/h'
1360                hom(:,2,106,:)  = SPREAD( zu, 2, statistic_regions+1 )
1361                unit = dopr_unit
1362             ENDIF
1363
1364          CASE ( 'rad_sw_hr' )
1365             IF ( (  .NOT.  radiation )  .OR.  radiation_scheme /= 'rrtmg' )   &
1366             THEN
1367                message_string = 'data_output_pr = ' //                        &
1368                                 TRIM( data_output_pr(var_count) ) // ' is' // &
1369                                 'not available for radiation = .FALSE. or ' //&
1370                                 'radiation_scheme /= "rrtmg"'
1371                CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 )
1372             ELSE
1373                dopr_index(var_count) = 107
1374                dopr_unit  = 'K/h'
1375                hom(:,2,107,:)  = SPREAD( zu, 2, statistic_regions+1 )
1376                unit = dopr_unit
1377             ENDIF
1378
1379
1380          CASE DEFAULT
1381             unit = 'illegal'
1382
1383       END SELECT
1384
1385
1386    END SUBROUTINE radiation_check_data_output_pr
1387 
1388 
1389!------------------------------------------------------------------------------!
1390! Description:
1391! ------------
1392!> Check parameters routine for radiation model
1393!------------------------------------------------------------------------------!
1394    SUBROUTINE radiation_check_parameters
1395
1396       USE control_parameters,                                                 &
1397           ONLY: land_surface, message_string, rotation_angle, urban_surface
1398
1399       USE netcdf_data_input_mod,                                              &
1400           ONLY:  input_pids_static                 
1401   
1402       IMPLICIT NONE
1403       
1404!
1405!--    In case no urban-surface or land-surface model is applied, usage of
1406!--    a radiation model make no sense.         
1407       IF ( .NOT. land_surface  .AND.  .NOT. urban_surface )  THEN
1408          message_string = 'Usage of radiation module is only allowed if ' //  &
1409                           'land-surface and/or urban-surface model is applied.'
1410          CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 )
1411       ENDIF
1412
1413       IF ( radiation_scheme /= 'constant'   .AND.                             &
1414            radiation_scheme /= 'clear-sky'  .AND.                             &
1415            radiation_scheme /= 'rrtmg'      .AND.                             &
1416            radiation_scheme /= 'external' )  THEN
1417          message_string = 'unknown radiation_scheme = '//                     &
1418                           TRIM( radiation_scheme )
1419          CALL message( 'check_parameters', 'PA0405', 1, 2, 0, 6, 0 )
1420       ELSEIF ( radiation_scheme == 'rrtmg' )  THEN
1421#if ! defined ( __rrtmg )
1422          message_string = 'radiation_scheme = "rrtmg" requires ' //           & 
1423                           'compilation of PALM with pre-processor ' //        &
1424                           'directive -D__rrtmg'
1425          CALL message( 'check_parameters', 'PA0407', 1, 2, 0, 6, 0 )
1426#endif
1427#if defined ( __rrtmg ) && ! defined( __netcdf )
1428          message_string = 'radiation_scheme = "rrtmg" requires ' //           & 
1429                           'the use of NetCDF (preprocessor directive ' //     &
1430                           '-D__netcdf'
1431          CALL message( 'check_parameters', 'PA0412', 1, 2, 0, 6, 0 )
1432#endif
1433
1434       ENDIF
1435!
1436!--    Checks performed only if data is given via namelist only.
1437       IF ( .NOT. input_pids_static )  THEN
1438          IF ( albedo_type == 0  .AND.  albedo == 9999999.9_wp  .AND.          &
1439               radiation_scheme == 'clear-sky')  THEN
1440             message_string = 'radiation_scheme = "clear-sky" in combination'//& 
1441                              'with albedo_type = 0 requires setting of'//     &
1442                              'albedo /= 9999999.9'
1443             CALL message( 'check_parameters', 'PA0410', 1, 2, 0, 6, 0 )
1444          ENDIF
1445
1446          IF ( albedo_type == 0  .AND.  radiation_scheme == 'rrtmg'  .AND.     &
1447             ( albedo_lw_dif == 9999999.9_wp .OR. albedo_lw_dir == 9999999.9_wp&
1448          .OR. albedo_sw_dif == 9999999.9_wp .OR. albedo_sw_dir == 9999999.9_wp& 
1449             ) ) THEN
1450             message_string = 'radiation_scheme = "rrtmg" in combination' //   & 
1451                              'with albedo_type = 0 requires setting of ' //   &
1452                              'albedo_lw_dif /= 9999999.9' //                  &
1453                              'albedo_lw_dir /= 9999999.9' //                  &
1454                              'albedo_sw_dif /= 9999999.9 and' //              &
1455                              'albedo_sw_dir /= 9999999.9'
1456             CALL message( 'check_parameters', 'PA0411', 1, 2, 0, 6, 0 )
1457          ENDIF
1458       ENDIF
1459!
1460!--    Parallel rad_angular_discretization without raytrace_mpi_rma is not implemented
1461#if defined( __parallel )     
1462       IF ( rad_angular_discretization  .AND.  .NOT. raytrace_mpi_rma )  THEN
1463          message_string = 'rad_angular_discretization can only be used ' //  &
1464                           'together with raytrace_mpi_rma or when ' //  &
1465                           'no parallelization is applied.'
1466          CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 )
1467       ENDIF
1468#endif
1469
1470       IF ( cloud_droplets  .AND.   radiation_scheme == 'rrtmg'  .AND.         &
1471            average_radiation ) THEN
1472          message_string = 'average_radiation = .T. with radiation_scheme'//   & 
1473                           '= "rrtmg" in combination cloud_droplets = .T.'//   &
1474                           'is not implementd'
1475          CALL message( 'check_parameters', 'PA0560', 1, 2, 0, 6, 0 )
1476       ENDIF
1477
1478!
1479!--    Incialize svf normalization reporting histogram
1480       svfnorm_report_num = 1
1481       DO WHILE ( svfnorm_report_thresh(svfnorm_report_num) < 1e20_wp          &
1482                   .AND. svfnorm_report_num <= 30 )
1483          svfnorm_report_num = svfnorm_report_num + 1
1484       ENDDO
1485       svfnorm_report_num = svfnorm_report_num - 1
1486!
1487!--    Check for dt_radiation
1488       IF ( dt_radiation <= 0.0 )  THEN
1489          message_string = 'dt_radiation must be > 0.0' 
1490          CALL message( 'check_parameters', 'PA0591', 1, 2, 0, 6, 0 ) 
1491       ENDIF
1492!
1493!--    Check rotation angle
1494       !> @todo Remove this limitation
1495       IF ( rotation_angle /= 0.0 )  THEN
1496          message_string = 'rotation of the model domain is not considered in the radiation ' //   &
1497                           'model.&Using rotation_angle /= 0.0 is not allowed in combination ' //  &
1498                           'with the radiation model at the moment!'
1499          CALL message( 'check_parameters', 'PA0675', 1, 2, 0, 6, 0 ) 
1500       ENDIF
1501 
1502    END SUBROUTINE radiation_check_parameters 
1503 
1504 
1505!------------------------------------------------------------------------------!
1506! Description:
1507! ------------
1508!> Initialization of the radiation model
1509!------------------------------------------------------------------------------!
1510    SUBROUTINE radiation_init
1511   
1512       IMPLICIT NONE
1513
1514       INTEGER(iwp) ::  i         !< running index x-direction
1515       INTEGER(iwp) ::  is        !< running index for input surface elements
1516       INTEGER(iwp) ::  ioff      !< offset in x between surface element reference grid point in atmosphere and actual surface
1517       INTEGER(iwp) ::  j         !< running index y-direction
1518       INTEGER(iwp) ::  joff      !< offset in y between surface element reference grid point in atmosphere and actual surface
1519       INTEGER(iwp) ::  k         !< running index z-direction
1520       INTEGER(iwp) ::  l         !< running index for orientation of vertical surfaces
1521       INTEGER(iwp) ::  m         !< running index for surface elements
1522       INTEGER(iwp) ::  ntime = 0 !< number of available external radiation timesteps
1523#if defined( __rrtmg )
1524       INTEGER(iwp) ::  ind_type  !< running index for subgrid-surface tiles
1525#endif
1526       LOGICAL      ::  radiation_input_root_domain !< flag indicating the existence of a dynamic input file for the root domain
1527
1528
1529       IF ( debug_output )  CALL debug_message( 'radiation_init', 'start' )
1530!
1531!--    Activate radiation_interactions according to the existence of vertical surfaces and/or trees.
1532!--    The namelist parameter radiation_interactions_on can override this behavior.
1533!--    (This check cannot be performed in check_parameters, because vertical_surfaces_exist is first set in
1534!--    init_surface_arrays.)
1535       IF ( radiation_interactions_on )  THEN
1536          IF ( vertical_surfaces_exist  .OR.  plant_canopy )  THEN
1537             radiation_interactions    = .TRUE.
1538             average_radiation         = .TRUE.
1539          ELSE
1540             radiation_interactions_on = .FALSE.   !< reset namelist parameter: no interactions
1541                                                   !< calculations necessary in case of flat surface
1542          ENDIF
1543       ELSEIF ( vertical_surfaces_exist  .OR.  plant_canopy )  THEN
1544          message_string = 'radiation_interactions_on is set to .FALSE. although '     // &
1545                           'vertical surfaces and/or trees exist. The model will run ' // &
1546                           'without RTM (no shadows, no radiation reflections)'
1547          CALL message( 'init_3d_model', 'PA0348', 0, 1, 0, 6, 0 )
1548       ENDIF
1549!
1550!--    Precalculate some time constants
1551       d_hours_day    = 1.0_wp / REAL( hours_per_day, KIND = wp )
1552       d_seconds_hour = 1.0_wp / seconds_per_hour
1553
1554!
1555!--    If required, initialize radiation interactions between surfaces
1556!--    via sky-view factors. This must be done before radiation is initialized.
1557       IF ( radiation_interactions )  CALL radiation_interaction_init
1558!
1559!--    Allocate array for storing the surface net radiation
1560       IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_net )  .AND.                      &
1561                  surf_lsm_h%ns > 0  )   THEN
1562          ALLOCATE( surf_lsm_h%rad_net(1:surf_lsm_h%ns) )
1563          surf_lsm_h%rad_net = 0.0_wp 
1564       ENDIF
1565       IF ( .NOT. ALLOCATED ( surf_usm_h%rad_net )  .AND.                      &
1566                  surf_usm_h%ns > 0  )  THEN
1567          ALLOCATE( surf_usm_h%rad_net(1:surf_usm_h%ns) )
1568          surf_usm_h%rad_net = 0.0_wp 
1569       ENDIF
1570       DO  l = 0, 3
1571          IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_net )  .AND.                &
1572                     surf_lsm_v(l)%ns > 0  )  THEN
1573             ALLOCATE( surf_lsm_v(l)%rad_net(1:surf_lsm_v(l)%ns) )
1574             surf_lsm_v(l)%rad_net = 0.0_wp 
1575          ENDIF
1576          IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_net )  .AND.                &
1577                     surf_usm_v(l)%ns > 0  )  THEN
1578             ALLOCATE( surf_usm_v(l)%rad_net(1:surf_usm_v(l)%ns) )
1579             surf_usm_v(l)%rad_net = 0.0_wp 
1580          ENDIF
1581       ENDDO
1582
1583
1584!
1585!--    Allocate array for storing the surface longwave (out) radiation change
1586       IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_lw_out_change_0 )  .AND.          &
1587                  surf_lsm_h%ns > 0  )   THEN
1588          ALLOCATE( surf_lsm_h%rad_lw_out_change_0(1:surf_lsm_h%ns) )
1589          surf_lsm_h%rad_lw_out_change_0 = 0.0_wp 
1590       ENDIF
1591       IF ( .NOT. ALLOCATED ( surf_usm_h%rad_lw_out_change_0 )  .AND.          &
1592                  surf_usm_h%ns > 0  )  THEN
1593          ALLOCATE( surf_usm_h%rad_lw_out_change_0(1:surf_usm_h%ns) )
1594          surf_usm_h%rad_lw_out_change_0 = 0.0_wp 
1595       ENDIF
1596       DO  l = 0, 3
1597          IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_lw_out_change_0 )  .AND.    &
1598                     surf_lsm_v(l)%ns > 0  )  THEN
1599             ALLOCATE( surf_lsm_v(l)%rad_lw_out_change_0(1:surf_lsm_v(l)%ns) )
1600             surf_lsm_v(l)%rad_lw_out_change_0 = 0.0_wp 
1601          ENDIF
1602          IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_lw_out_change_0 )  .AND.    &
1603                     surf_usm_v(l)%ns > 0  )  THEN
1604             ALLOCATE( surf_usm_v(l)%rad_lw_out_change_0(1:surf_usm_v(l)%ns) )
1605             surf_usm_v(l)%rad_lw_out_change_0 = 0.0_wp 
1606          ENDIF
1607       ENDDO
1608
1609!
1610!--    Allocate surface arrays for incoming/outgoing short/longwave radiation
1611       IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_sw_in )  .AND.                    &
1612                  surf_lsm_h%ns > 0  )   THEN
1613          ALLOCATE( surf_lsm_h%rad_sw_in(1:surf_lsm_h%ns)  )
1614          ALLOCATE( surf_lsm_h%rad_sw_out(1:surf_lsm_h%ns) )
1615          ALLOCATE( surf_lsm_h%rad_sw_dir(1:surf_lsm_h%ns) )
1616          ALLOCATE( surf_lsm_h%rad_sw_dif(1:surf_lsm_h%ns) )
1617          ALLOCATE( surf_lsm_h%rad_sw_ref(1:surf_lsm_h%ns) )
1618          ALLOCATE( surf_lsm_h%rad_sw_res(1:surf_lsm_h%ns) )
1619          ALLOCATE( surf_lsm_h%rad_lw_in(1:surf_lsm_h%ns)  )
1620          ALLOCATE( surf_lsm_h%rad_lw_out(1:surf_lsm_h%ns) )
1621          ALLOCATE( surf_lsm_h%rad_lw_dif(1:surf_lsm_h%ns) )
1622          ALLOCATE( surf_lsm_h%rad_lw_ref(1:surf_lsm_h%ns) )
1623          ALLOCATE( surf_lsm_h%rad_lw_res(1:surf_lsm_h%ns) )
1624          surf_lsm_h%rad_sw_in  = 0.0_wp 
1625          surf_lsm_h%rad_sw_out = 0.0_wp 
1626          surf_lsm_h%rad_sw_dir = 0.0_wp 
1627          surf_lsm_h%rad_sw_dif = 0.0_wp 
1628          surf_lsm_h%rad_sw_ref = 0.0_wp 
1629          surf_lsm_h%rad_sw_res = 0.0_wp 
1630          surf_lsm_h%rad_lw_in  = 0.0_wp 
1631          surf_lsm_h%rad_lw_out = 0.0_wp 
1632          surf_lsm_h%rad_lw_dif = 0.0_wp 
1633          surf_lsm_h%rad_lw_ref = 0.0_wp 
1634          surf_lsm_h%rad_lw_res = 0.0_wp 
1635       ENDIF
1636       IF ( .NOT. ALLOCATED ( surf_usm_h%rad_sw_in )  .AND.                    &
1637                  surf_usm_h%ns > 0  )  THEN
1638          ALLOCATE( surf_usm_h%rad_sw_in(1:surf_usm_h%ns)  )
1639          ALLOCATE( surf_usm_h%rad_sw_out(1:surf_usm_h%ns) )
1640          ALLOCATE( surf_usm_h%rad_sw_dir(1:surf_usm_h%ns) )
1641          ALLOCATE( surf_usm_h%rad_sw_dif(1:surf_usm_h%ns) )
1642          ALLOCATE( surf_usm_h%rad_sw_ref(1:surf_usm_h%ns) )
1643          ALLOCATE( surf_usm_h%rad_sw_res(1:surf_usm_h%ns) )
1644          ALLOCATE( surf_usm_h%rad_lw_in(1:surf_usm_h%ns)  )
1645          ALLOCATE( surf_usm_h%rad_lw_out(1:surf_usm_h%ns) )
1646          ALLOCATE( surf_usm_h%rad_lw_dif(1:surf_usm_h%ns) )
1647          ALLOCATE( surf_usm_h%rad_lw_ref(1:surf_usm_h%ns) )
1648          ALLOCATE( surf_usm_h%rad_lw_res(1:surf_usm_h%ns) )
1649          surf_usm_h%rad_sw_in  = 0.0_wp 
1650          surf_usm_h%rad_sw_out = 0.0_wp 
1651          surf_usm_h%rad_sw_dir = 0.0_wp 
1652          surf_usm_h%rad_sw_dif = 0.0_wp 
1653          surf_usm_h%rad_sw_ref = 0.0_wp 
1654          surf_usm_h%rad_sw_res = 0.0_wp 
1655          surf_usm_h%rad_lw_in  = 0.0_wp 
1656          surf_usm_h%rad_lw_out = 0.0_wp 
1657          surf_usm_h%rad_lw_dif = 0.0_wp 
1658          surf_usm_h%rad_lw_ref = 0.0_wp 
1659          surf_usm_h%rad_lw_res = 0.0_wp 
1660       ENDIF
1661       DO  l = 0, 3
1662          IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_sw_in )  .AND.              &
1663                     surf_lsm_v(l)%ns > 0  )  THEN
1664             ALLOCATE( surf_lsm_v(l)%rad_sw_in(1:surf_lsm_v(l)%ns)  )
1665             ALLOCATE( surf_lsm_v(l)%rad_sw_out(1:surf_lsm_v(l)%ns) )
1666             ALLOCATE( surf_lsm_v(l)%rad_sw_dir(1:surf_lsm_v(l)%ns) )
1667             ALLOCATE( surf_lsm_v(l)%rad_sw_dif(1:surf_lsm_v(l)%ns) )
1668             ALLOCATE( surf_lsm_v(l)%rad_sw_ref(1:surf_lsm_v(l)%ns) )
1669             ALLOCATE( surf_lsm_v(l)%rad_sw_res(1:surf_lsm_v(l)%ns) )
1670
1671             ALLOCATE( surf_lsm_v(l)%rad_lw_in(1:surf_lsm_v(l)%ns)  )
1672             ALLOCATE( surf_lsm_v(l)%rad_lw_out(1:surf_lsm_v(l)%ns) )
1673             ALLOCATE( surf_lsm_v(l)%rad_lw_dif(1:surf_lsm_v(l)%ns) )
1674             ALLOCATE( surf_lsm_v(l)%rad_lw_ref(1:surf_lsm_v(l)%ns) )
1675             ALLOCATE( surf_lsm_v(l)%rad_lw_res(1:surf_lsm_v(l)%ns) )
1676
1677             surf_lsm_v(l)%rad_sw_in  = 0.0_wp 
1678             surf_lsm_v(l)%rad_sw_out = 0.0_wp
1679             surf_lsm_v(l)%rad_sw_dir = 0.0_wp
1680             surf_lsm_v(l)%rad_sw_dif = 0.0_wp
1681             surf_lsm_v(l)%rad_sw_ref = 0.0_wp
1682             surf_lsm_v(l)%rad_sw_res = 0.0_wp
1683
1684             surf_lsm_v(l)%rad_lw_in  = 0.0_wp 
1685             surf_lsm_v(l)%rad_lw_out = 0.0_wp 
1686             surf_lsm_v(l)%rad_lw_dif = 0.0_wp 
1687             surf_lsm_v(l)%rad_lw_ref = 0.0_wp 
1688             surf_lsm_v(l)%rad_lw_res = 0.0_wp 
1689          ENDIF
1690          IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_sw_in )  .AND.              &
1691                     surf_usm_v(l)%ns > 0  )  THEN
1692             ALLOCATE( surf_usm_v(l)%rad_sw_in(1:surf_usm_v(l)%ns)  )
1693             ALLOCATE( surf_usm_v(l)%rad_sw_out(1:surf_usm_v(l)%ns) )
1694             ALLOCATE( surf_usm_v(l)%rad_sw_dir(1:surf_usm_v(l)%ns) )
1695             ALLOCATE( surf_usm_v(l)%rad_sw_dif(1:surf_usm_v(l)%ns) )
1696             ALLOCATE( surf_usm_v(l)%rad_sw_ref(1:surf_usm_v(l)%ns) )
1697             ALLOCATE( surf_usm_v(l)%rad_sw_res(1:surf_usm_v(l)%ns) )
1698             ALLOCATE( surf_usm_v(l)%rad_lw_in(1:surf_usm_v(l)%ns)  )
1699             ALLOCATE( surf_usm_v(l)%rad_lw_out(1:surf_usm_v(l)%ns) )
1700             ALLOCATE( surf_usm_v(l)%rad_lw_dif(1:surf_usm_v(l)%ns) )
1701             ALLOCATE( surf_usm_v(l)%rad_lw_ref(1:surf_usm_v(l)%ns) )
1702             ALLOCATE( surf_usm_v(l)%rad_lw_res(1:surf_usm_v(l)%ns) )
1703             surf_usm_v(l)%rad_sw_in  = 0.0_wp 
1704             surf_usm_v(l)%rad_sw_out = 0.0_wp
1705             surf_usm_v(l)%rad_sw_dir = 0.0_wp
1706             surf_usm_v(l)%rad_sw_dif = 0.0_wp
1707             surf_usm_v(l)%rad_sw_ref = 0.0_wp
1708             surf_usm_v(l)%rad_sw_res = 0.0_wp
1709             surf_usm_v(l)%rad_lw_in  = 0.0_wp 
1710             surf_usm_v(l)%rad_lw_out = 0.0_wp 
1711             surf_usm_v(l)%rad_lw_dif = 0.0_wp 
1712             surf_usm_v(l)%rad_lw_ref = 0.0_wp 
1713             surf_usm_v(l)%rad_lw_res = 0.0_wp 
1714          ENDIF
1715       ENDDO
1716!
1717!--    Fix net radiation in case of radiation_scheme = 'constant'
1718       IF ( radiation_scheme == 'constant' )  THEN
1719          IF ( ALLOCATED( surf_lsm_h%rad_net ) )                               &
1720             surf_lsm_h%rad_net    = net_radiation
1721          IF ( ALLOCATED( surf_usm_h%rad_net ) )                               &
1722             surf_usm_h%rad_net    = net_radiation
1723!
1724!--       Todo: weight with inclination angle
1725          DO  l = 0, 3
1726             IF ( ALLOCATED( surf_lsm_v(l)%rad_net ) )                         &
1727                surf_lsm_v(l)%rad_net = net_radiation
1728             IF ( ALLOCATED( surf_usm_v(l)%rad_net ) )                         &
1729                surf_usm_v(l)%rad_net = net_radiation
1730          ENDDO
1731!          radiation = .FALSE.
1732!
1733!--    Calculate orbital constants
1734       ELSE
1735          decl_1 = SIN(23.45_wp * pi / 180.0_wp)
1736          decl_2 = 2.0_wp * pi / 365.0_wp
1737          decl_3 = decl_2 * 81.0_wp
1738          lat    = latitude * pi / 180.0_wp
1739          lon    = longitude * pi / 180.0_wp
1740       ENDIF
1741
1742       IF ( radiation_scheme == 'clear-sky'  .OR.                              &
1743            radiation_scheme == 'constant'   .OR.                              &
1744            radiation_scheme == 'external' )  THEN
1745!
1746!--       Allocate arrays for incoming/outgoing short/longwave radiation
1747          IF ( .NOT. ALLOCATED ( rad_sw_in ) )  THEN
1748             ALLOCATE ( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) )
1749          ENDIF
1750          IF ( .NOT. ALLOCATED ( rad_sw_out ) )  THEN
1751             ALLOCATE ( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) )
1752          ENDIF
1753
1754          IF ( .NOT. ALLOCATED ( rad_lw_in ) )  THEN
1755             ALLOCATE ( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) )
1756          ENDIF
1757          IF ( .NOT. ALLOCATED ( rad_lw_out ) )  THEN
1758             ALLOCATE ( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) )
1759          ENDIF
1760
1761!
1762!--       Allocate average arrays for incoming/outgoing short/longwave radiation
1763          IF ( .NOT. ALLOCATED ( rad_sw_in_av ) )  THEN
1764             ALLOCATE ( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
1765          ENDIF
1766          IF ( .NOT. ALLOCATED ( rad_sw_out_av ) )  THEN
1767             ALLOCATE ( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
1768          ENDIF
1769
1770          IF ( .NOT. ALLOCATED ( rad_lw_in_av ) )  THEN
1771             ALLOCATE ( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
1772          ENDIF
1773          IF ( .NOT. ALLOCATED ( rad_lw_out_av ) )  THEN
1774             ALLOCATE ( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
1775          ENDIF
1776!
1777!--       Allocate arrays for broadband albedo, and level 1 initialization
1778!--       via namelist paramter, unless not already allocated.
1779          IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) )  THEN
1780             ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns)     )
1781             surf_lsm_h%albedo    = albedo
1782          ENDIF
1783          IF ( .NOT. ALLOCATED(surf_usm_h%albedo) )  THEN
1784             ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns)     )
1785             surf_usm_h%albedo    = albedo
1786          ENDIF
1787
1788          DO  l = 0, 3
1789             IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) )  THEN
1790                ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) )
1791                surf_lsm_v(l)%albedo = albedo
1792             ENDIF
1793             IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) )  THEN
1794                ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) )
1795                surf_usm_v(l)%albedo = albedo
1796             ENDIF
1797          ENDDO
1798!
1799!--       Level 2 initialization of broadband albedo via given albedo_type.
1800!--       Only if albedo_type is non-zero. In case of urban surface and
1801!--       input data is read from ASCII file, albedo_type will be zero, so that
1802!--       albedo won't be overwritten.
1803          DO  m = 1, surf_lsm_h%ns
1804             IF ( surf_lsm_h%albedo_type(ind_veg_wall,m) /= 0 )                &
1805                surf_lsm_h%albedo(ind_veg_wall,m) =                            &
1806                           albedo_pars(0,surf_lsm_h%albedo_type(ind_veg_wall,m))
1807             IF ( surf_lsm_h%albedo_type(ind_pav_green,m) /= 0 )               &
1808                surf_lsm_h%albedo(ind_pav_green,m) =                           &
1809                           albedo_pars(0,surf_lsm_h%albedo_type(ind_pav_green,m))
1810             IF ( surf_lsm_h%albedo_type(ind_wat_win,m) /= 0 )                 &
1811                surf_lsm_h%albedo(ind_wat_win,m) =                             &
1812                           albedo_pars(0,surf_lsm_h%albedo_type(ind_wat_win,m))
1813          ENDDO
1814          DO  m = 1, surf_usm_h%ns
1815             IF ( surf_usm_h%albedo_type(ind_veg_wall,m) /= 0 )                &
1816                surf_usm_h%albedo(ind_veg_wall,m) =                            &
1817                           albedo_pars(0,surf_usm_h%albedo_type(ind_veg_wall,m))
1818             IF ( surf_usm_h%albedo_type(ind_pav_green,m) /= 0 )               &
1819                surf_usm_h%albedo(ind_pav_green,m) =                           &
1820                           albedo_pars(0,surf_usm_h%albedo_type(ind_pav_green,m))
1821             IF ( surf_usm_h%albedo_type(ind_wat_win,m) /= 0 )                 &
1822                surf_usm_h%albedo(ind_wat_win,m) =                             &
1823                           albedo_pars(0,surf_usm_h%albedo_type(ind_wat_win,m))
1824          ENDDO
1825
1826          DO  l = 0, 3
1827             DO  m = 1, surf_lsm_v(l)%ns
1828                IF ( surf_lsm_v(l)%albedo_type(ind_veg_wall,m) /= 0 )          &
1829                   surf_lsm_v(l)%albedo(ind_veg_wall,m) =                      &
1830                        albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_veg_wall,m))
1831                IF ( surf_lsm_v(l)%albedo_type(ind_pav_green,m) /= 0 )         &
1832                   surf_lsm_v(l)%albedo(ind_pav_green,m) =                     &
1833                        albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_pav_green,m))
1834                IF ( surf_lsm_v(l)%albedo_type(ind_wat_win,m) /= 0 )           &
1835                   surf_lsm_v(l)%albedo(ind_wat_win,m) =                       &
1836                        albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_wat_win,m))
1837             ENDDO
1838             DO  m = 1, surf_usm_v(l)%ns
1839                IF ( surf_usm_v(l)%albedo_type(ind_veg_wall,m) /= 0 )          &
1840                   surf_usm_v(l)%albedo(ind_veg_wall,m) =                      &
1841                        albedo_pars(0,surf_usm_v(l)%albedo_type(ind_veg_wall,m))
1842                IF ( surf_usm_v(l)%albedo_type(ind_pav_green,m) /= 0 )         &
1843                   surf_usm_v(l)%albedo(ind_pav_green,m) =                     &
1844                        albedo_pars(0,surf_usm_v(l)%albedo_type(ind_pav_green,m))
1845                IF ( surf_usm_v(l)%albedo_type(ind_wat_win,m) /= 0 )           &
1846                   surf_usm_v(l)%albedo(ind_wat_win,m) =                       &
1847                        albedo_pars(0,surf_usm_v(l)%albedo_type(ind_wat_win,m))
1848             ENDDO
1849          ENDDO
1850
1851!
1852!--       Level 3 initialization at grid points where albedo type is zero.
1853!--       This case, albedo is taken from file. In case of constant radiation
1854!--       or clear sky, only broadband albedo is given.
1855          IF ( albedo_pars_f%from_file )  THEN
1856!
1857!--          Horizontal surfaces
1858             DO  m = 1, surf_lsm_h%ns
1859                i = surf_lsm_h%i(m)
1860                j = surf_lsm_h%j(m)
1861                IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )  THEN
1862                   surf_lsm_h%albedo(ind_veg_wall,m)  = albedo_pars_f%pars_xy(0,j,i)
1863                   surf_lsm_h%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1864                   surf_lsm_h%albedo(ind_wat_win,m)   = albedo_pars_f%pars_xy(0,j,i)
1865                ENDIF
1866             ENDDO
1867             DO  m = 1, surf_usm_h%ns
1868                i = surf_usm_h%i(m)
1869                j = surf_usm_h%j(m)
1870                IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )  THEN
1871                   surf_usm_h%albedo(ind_veg_wall,m)  = albedo_pars_f%pars_xy(0,j,i)
1872                   surf_usm_h%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1873                   surf_usm_h%albedo(ind_wat_win,m)   = albedo_pars_f%pars_xy(0,j,i)
1874                ENDIF
1875             ENDDO 
1876!
1877!--          Vertical surfaces           
1878             DO  l = 0, 3
1879
1880                ioff = surf_lsm_v(l)%ioff
1881                joff = surf_lsm_v(l)%joff
1882                DO  m = 1, surf_lsm_v(l)%ns
1883                   i = surf_lsm_v(l)%i(m) + ioff
1884                   j = surf_lsm_v(l)%j(m) + joff
1885                   IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )  THEN
1886                      surf_lsm_v(l)%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1887                      surf_lsm_v(l)%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1888                      surf_lsm_v(l)%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1889                   ENDIF
1890                ENDDO
1891
1892                ioff = surf_usm_v(l)%ioff
1893                joff = surf_usm_v(l)%joff
1894                DO  m = 1, surf_usm_v(l)%ns
1895                   i = surf_usm_v(l)%i(m) + ioff
1896                   j = surf_usm_v(l)%j(m) + joff
1897                   IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )  THEN
1898                      surf_usm_v(l)%albedo(ind_veg_wall,m) = albedo_pars_f%pars_xy(0,j,i)
1899                      surf_usm_v(l)%albedo(ind_pav_green,m) = albedo_pars_f%pars_xy(0,j,i)
1900                      surf_usm_v(l)%albedo(ind_wat_win,m) = albedo_pars_f%pars_xy(0,j,i)
1901                   ENDIF
1902                ENDDO
1903             ENDDO
1904
1905          ENDIF 
1906!
1907!--       Read explicit albedo values from building surface pars. If present,
1908!--       they override all less specific albedo values and force a albedo_type
1909!--       to zero in order to take effect.
1910          IF ( building_surface_pars_f%from_file )  THEN
1911             DO  m = 1, surf_usm_h%ns
1912                i = surf_usm_h%i(m)
1913                j = surf_usm_h%j(m)
1914                k = surf_usm_h%k(m)
1915!
1916!--             Iterate over surfaces in column, check height and orientation
1917                DO  is = building_surface_pars_f%index_ji(1,j,i), &
1918                         building_surface_pars_f%index_ji(2,j,i)
1919                   IF ( building_surface_pars_f%coords(4,is) == -surf_usm_h%koff .AND. &
1920                        building_surface_pars_f%coords(1,is) == k )  THEN
1921
1922                      IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /=      &
1923                           building_surface_pars_f%fill )  THEN
1924                         surf_usm_h%albedo(ind_veg_wall,m) =                         &
1925                                  building_surface_pars_f%pars(ind_s_alb_b_wall,is)
1926                         surf_usm_h%albedo_type(ind_veg_wall,m) = 0
1927                      ENDIF
1928
1929                      IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /=       &
1930                           building_surface_pars_f%fill )  THEN
1931                         surf_usm_h%albedo(ind_wat_win,m) =                          &
1932                                  building_surface_pars_f%pars(ind_s_alb_b_win,is)
1933                         surf_usm_h%albedo_type(ind_wat_win,m) = 0
1934                      ENDIF
1935
1936                      IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /=     &
1937                           building_surface_pars_f%fill )  THEN
1938                         surf_usm_h%albedo(ind_pav_green,m) =                        &
1939                                  building_surface_pars_f%pars(ind_s_alb_b_green,is)
1940                         surf_usm_h%albedo_type(ind_pav_green,m) = 0
1941                      ENDIF
1942
1943                      EXIT ! surface was found and processed
1944                   ENDIF
1945                ENDDO
1946             ENDDO
1947
1948             DO  l = 0, 3
1949                DO  m = 1, surf_usm_v(l)%ns
1950                   i = surf_usm_v(l)%i(m)
1951                   j = surf_usm_v(l)%j(m)
1952                   k = surf_usm_v(l)%k(m)
1953!
1954!--                Iterate over surfaces in column, check height and orientation
1955                   DO  is = building_surface_pars_f%index_ji(1,j,i), &
1956                            building_surface_pars_f%index_ji(2,j,i)
1957                      IF ( building_surface_pars_f%coords(5,is) == -surf_usm_v(l)%joff .AND. &
1958                           building_surface_pars_f%coords(6,is) == -surf_usm_v(l)%ioff .AND. &
1959                           building_surface_pars_f%coords(1,is) == k )  THEN
1960
1961                         IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /=      &
1962                              building_surface_pars_f%fill )  THEN
1963                            surf_usm_v(l)%albedo(ind_veg_wall,m) =                      &
1964                                     building_surface_pars_f%pars(ind_s_alb_b_wall,is)
1965                            surf_usm_v(l)%albedo_type(ind_veg_wall,m) = 0
1966                         ENDIF
1967
1968                         IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /=       &
1969                              building_surface_pars_f%fill )  THEN
1970                            surf_usm_v(l)%albedo(ind_wat_win,m) =                       &
1971                                     building_surface_pars_f%pars(ind_s_alb_b_win,is)
1972                            surf_usm_v(l)%albedo_type(ind_wat_win,m) = 0
1973                         ENDIF
1974
1975                         IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /=     &
1976                              building_surface_pars_f%fill )  THEN
1977                            surf_usm_v(l)%albedo(ind_pav_green,m) =                     &
1978                                     building_surface_pars_f%pars(ind_s_alb_b_green,is)
1979                            surf_usm_v(l)%albedo_type(ind_pav_green,m) = 0
1980                         ENDIF
1981
1982                         EXIT ! surface was found and processed
1983                      ENDIF
1984                   ENDDO
1985                ENDDO
1986             ENDDO
1987          ENDIF
1988!
1989!--    Initialization actions for RRTMG
1990       ELSEIF ( radiation_scheme == 'rrtmg' )  THEN
1991#if defined ( __rrtmg )
1992!
1993!--       Allocate albedos for short/longwave radiation, horizontal surfaces
1994!--       for wall/green/window (USM) or vegetation/pavement/water surfaces
1995!--       (LSM).
1996          ALLOCATE ( surf_lsm_h%aldif(0:2,1:surf_lsm_h%ns)       )
1997          ALLOCATE ( surf_lsm_h%aldir(0:2,1:surf_lsm_h%ns)       )
1998          ALLOCATE ( surf_lsm_h%asdif(0:2,1:surf_lsm_h%ns)       )
1999          ALLOCATE ( surf_lsm_h%asdir(0:2,1:surf_lsm_h%ns)       )
2000          ALLOCATE ( surf_lsm_h%rrtm_aldif(0:2,1:surf_lsm_h%ns)  )
2001          ALLOCATE ( surf_lsm_h%rrtm_aldir(0:2,1:surf_lsm_h%ns)  )
2002          ALLOCATE ( surf_lsm_h%rrtm_asdif(0:2,1:surf_lsm_h%ns)  )
2003          ALLOCATE ( surf_lsm_h%rrtm_asdir(0:2,1:surf_lsm_h%ns)  )
2004
2005          ALLOCATE ( surf_usm_h%aldif(0:2,1:surf_usm_h%ns)       )
2006          ALLOCATE ( surf_usm_h%aldir(0:2,1:surf_usm_h%ns)       )
2007          ALLOCATE ( surf_usm_h%asdif(0:2,1:surf_usm_h%ns)       )
2008          ALLOCATE ( surf_usm_h%asdir(0:2,1:surf_usm_h%ns)       )
2009          ALLOCATE ( surf_usm_h%rrtm_aldif(0:2,1:surf_usm_h%ns)  )
2010          ALLOCATE ( surf_usm_h%rrtm_aldir(0:2,1:surf_usm_h%ns)  )
2011          ALLOCATE ( surf_usm_h%rrtm_asdif(0:2,1:surf_usm_h%ns)  )
2012          ALLOCATE ( surf_usm_h%rrtm_asdir(0:2,1:surf_usm_h%ns)  )
2013
2014!
2015!--       Allocate broadband albedo (temporary for the current radiation
2016!--       implementations)
2017          IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) )                            &
2018             ALLOCATE( surf_lsm_h%albedo(0:2,1:surf_lsm_h%ns)     )
2019          IF ( .NOT. ALLOCATED(surf_usm_h%albedo) )                            &
2020             ALLOCATE( surf_usm_h%albedo(0:2,1:surf_usm_h%ns)     )
2021
2022!
2023!--       Allocate albedos for short/longwave radiation, vertical surfaces
2024          DO  l = 0, 3
2025
2026             ALLOCATE ( surf_lsm_v(l)%aldif(0:2,1:surf_lsm_v(l)%ns)      )
2027             ALLOCATE ( surf_lsm_v(l)%aldir(0:2,1:surf_lsm_v(l)%ns)      )
2028             ALLOCATE ( surf_lsm_v(l)%asdif(0:2,1:surf_lsm_v(l)%ns)      )
2029             ALLOCATE ( surf_lsm_v(l)%asdir(0:2,1:surf_lsm_v(l)%ns)      )
2030
2031             ALLOCATE ( surf_lsm_v(l)%rrtm_aldif(0:2,1:surf_lsm_v(l)%ns) )
2032             ALLOCATE ( surf_lsm_v(l)%rrtm_aldir(0:2,1:surf_lsm_v(l)%ns) )
2033             ALLOCATE ( surf_lsm_v(l)%rrtm_asdif(0:2,1:surf_lsm_v(l)%ns) )
2034             ALLOCATE ( surf_lsm_v(l)%rrtm_asdir(0:2,1:surf_lsm_v(l)%ns) )
2035
2036             ALLOCATE ( surf_usm_v(l)%aldif(0:2,1:surf_usm_v(l)%ns)      )
2037             ALLOCATE ( surf_usm_v(l)%aldir(0:2,1:surf_usm_v(l)%ns)      )
2038             ALLOCATE ( surf_usm_v(l)%asdif(0:2,1:surf_usm_v(l)%ns)      )
2039             ALLOCATE ( surf_usm_v(l)%asdir(0:2,1:surf_usm_v(l)%ns)      )
2040
2041             ALLOCATE ( surf_usm_v(l)%rrtm_aldif(0:2,1:surf_usm_v(l)%ns) )
2042             ALLOCATE ( surf_usm_v(l)%rrtm_aldir(0:2,1:surf_usm_v(l)%ns) )
2043             ALLOCATE ( surf_usm_v(l)%rrtm_asdif(0:2,1:surf_usm_v(l)%ns) )
2044             ALLOCATE ( surf_usm_v(l)%rrtm_asdir(0:2,1:surf_usm_v(l)%ns) )
2045!
2046!--          Allocate broadband albedo (temporary for the current radiation
2047!--          implementations)
2048             IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) )                    &
2049                ALLOCATE( surf_lsm_v(l)%albedo(0:2,1:surf_lsm_v(l)%ns) )
2050             IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) )                    &
2051                ALLOCATE( surf_usm_v(l)%albedo(0:2,1:surf_usm_v(l)%ns) )
2052
2053          ENDDO
2054!
2055!--       Level 1 initialization of spectral albedos via namelist
2056!--       paramters. Please note, this case all surface tiles are initialized
2057!--       the same.
2058          IF ( surf_lsm_h%ns > 0 )  THEN
2059             surf_lsm_h%aldif  = albedo_lw_dif
2060             surf_lsm_h%aldir  = albedo_lw_dir
2061             surf_lsm_h%asdif  = albedo_sw_dif
2062             surf_lsm_h%asdir  = albedo_sw_dir
2063             surf_lsm_h%albedo = albedo_sw_dif
2064          ENDIF
2065          IF ( surf_usm_h%ns > 0 )  THEN
2066             IF ( surf_usm_h%albedo_from_ascii )  THEN
2067                surf_usm_h%aldif  = surf_usm_h%albedo
2068                surf_usm_h%aldir  = surf_usm_h%albedo
2069                surf_usm_h%asdif  = surf_usm_h%albedo
2070                surf_usm_h%asdir  = surf_usm_h%albedo
2071             ELSE
2072                surf_usm_h%aldif  = albedo_lw_dif
2073                surf_usm_h%aldir  = albedo_lw_dir
2074                surf_usm_h%asdif  = albedo_sw_dif
2075                surf_usm_h%asdir  = albedo_sw_dir
2076                surf_usm_h%albedo = albedo_sw_dif
2077             ENDIF
2078          ENDIF
2079
2080          DO  l = 0, 3
2081
2082             IF ( surf_lsm_v(l)%ns > 0 )  THEN
2083                surf_lsm_v(l)%aldif  = albedo_lw_dif
2084                surf_lsm_v(l)%aldir  = albedo_lw_dir
2085                surf_lsm_v(l)%asdif  = albedo_sw_dif
2086                surf_lsm_v(l)%asdir  = albedo_sw_dir
2087                surf_lsm_v(l)%albedo = albedo_sw_dif
2088             ENDIF
2089
2090             IF ( surf_usm_v(l)%ns > 0 )  THEN
2091                IF ( surf_usm_v(l)%albedo_from_ascii )  THEN
2092                   surf_usm_v(l)%aldif  = surf_usm_v(l)%albedo
2093                   surf_usm_v(l)%aldir  = surf_usm_v(l)%albedo
2094                   surf_usm_v(l)%asdif  = surf_usm_v(l)%albedo
2095                   surf_usm_v(l)%asdir  = surf_usm_v(l)%albedo
2096                ELSE
2097                   surf_usm_v(l)%aldif  = albedo_lw_dif
2098                   surf_usm_v(l)%aldir  = albedo_lw_dir
2099                   surf_usm_v(l)%asdif  = albedo_sw_dif
2100                   surf_usm_v(l)%asdir  = albedo_sw_dir
2101                ENDIF
2102             ENDIF
2103          ENDDO
2104
2105!
2106!--       Level 2 initialization of spectral albedos via albedo_type.
2107!--       Please note, for natural- and urban-type surfaces, a tile approach
2108!--       is applied so that the resulting albedo is calculated via the weighted
2109!--       average of respective surface fractions.
2110          DO  m = 1, surf_lsm_h%ns
2111!
2112!--          Spectral albedos for vegetation/pavement/water surfaces
2113             DO  ind_type = 0, 2
2114                IF ( surf_lsm_h%albedo_type(ind_type,m) /= 0 )  THEN
2115                   surf_lsm_h%aldif(ind_type,m) =                              &
2116                               albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m))
2117                   surf_lsm_h%asdif(ind_type,m) =                              &
2118                               albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m))
2119                   surf_lsm_h%aldir(ind_type,m) =                              &
2120                               albedo_pars(1,surf_lsm_h%albedo_type(ind_type,m))
2121                   surf_lsm_h%asdir(ind_type,m) =                              &
2122                               albedo_pars(2,surf_lsm_h%albedo_type(ind_type,m))
2123                   surf_lsm_h%albedo(ind_type,m) =                             &
2124                               albedo_pars(0,surf_lsm_h%albedo_type(ind_type,m))
2125                ENDIF
2126             ENDDO
2127
2128          ENDDO
2129!
2130!--       For urban surface only if albedo has not been already initialized
2131!--       in the urban-surface model via the ASCII file.
2132          IF ( .NOT. surf_usm_h%albedo_from_ascii )  THEN
2133             DO  m = 1, surf_usm_h%ns
2134!
2135!--             Spectral albedos for wall/green/window surfaces
2136                DO  ind_type = 0, 2
2137                   IF ( surf_usm_h%albedo_type(ind_type,m) /= 0 )  THEN
2138                      surf_usm_h%aldif(ind_type,m) =                           &
2139                               albedo_pars(1,surf_usm_h%albedo_type(ind_type,m))
2140                      surf_usm_h%asdif(ind_type,m) =                           &
2141                               albedo_pars(2,surf_usm_h%albedo_type(ind_type,m))
2142                      surf_usm_h%aldir(ind_type,m) =                           &
2143                               albedo_pars(1,surf_usm_h%albedo_type(ind_type,m))
2144                      surf_usm_h%asdir(ind_type,m) =                           &
2145                               albedo_pars(2,surf_usm_h%albedo_type(ind_type,m))
2146                      surf_usm_h%albedo(ind_type,m) =                          &
2147                               albedo_pars(0,surf_usm_h%albedo_type(ind_type,m))
2148                   ENDIF
2149                ENDDO
2150
2151             ENDDO
2152          ENDIF
2153
2154          DO l = 0, 3
2155
2156             DO  m = 1, surf_lsm_v(l)%ns
2157!
2158!--             Spectral albedos for vegetation/pavement/water surfaces
2159                DO  ind_type = 0, 2
2160                   IF ( surf_lsm_v(l)%albedo_type(ind_type,m) /= 0 )  THEN
2161                      surf_lsm_v(l)%aldif(ind_type,m) =                        &
2162                            albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m))
2163                      surf_lsm_v(l)%asdif(ind_type,m) =                        &
2164                            albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m))
2165                      surf_lsm_v(l)%aldir(ind_type,m) =                        &
2166                            albedo_pars(1,surf_lsm_v(l)%albedo_type(ind_type,m))
2167                      surf_lsm_v(l)%asdir(ind_type,m) =                        &
2168                            albedo_pars(2,surf_lsm_v(l)%albedo_type(ind_type,m))
2169                      surf_lsm_v(l)%albedo(ind_type,m) =                       &
2170                            albedo_pars(0,surf_lsm_v(l)%albedo_type(ind_type,m))
2171                   ENDIF
2172                ENDDO
2173             ENDDO
2174!
2175!--          For urban surface only if albedo has not been already initialized
2176!--          in the urban-surface model via the ASCII file.
2177             IF ( .NOT. surf_usm_v(l)%albedo_from_ascii )  THEN
2178                DO  m = 1, surf_usm_v(l)%ns
2179!
2180!--                Spectral albedos for wall/green/window surfaces
2181                   DO  ind_type = 0, 2
2182                      IF ( surf_usm_v(l)%albedo_type(ind_type,m) /= 0 )  THEN
2183                         surf_usm_v(l)%aldif(ind_type,m) =                     &
2184                            albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m))
2185                         surf_usm_v(l)%asdif(ind_type,m) =                     &
2186                            albedo_pars(2,surf_usm_v(l)%albedo_type(ind_type,m))
2187                         surf_usm_v(l)%aldir(ind_type,m) =                     &
2188                            albedo_pars(1,surf_usm_v(l)%albedo_type(ind_type,m))
2189                         surf_usm_v(l)%asdir(ind_type,m) =                     &
2190                            albedo_pars(2,surf_usm_v(l)%albedo_type(ind_type,m))
2191                         surf_usm_v(l)%albedo(ind_type,m) =                    &
2192                            albedo_pars(0,surf_usm_v(l)%albedo_type(ind_type,m))
2193                      ENDIF
2194                   ENDDO
2195
2196                ENDDO
2197             ENDIF
2198          ENDDO
2199!
2200!--       Level 3 initialization at grid points where albedo type is zero.
2201!--       This case, spectral albedos are taken from file if available
2202          IF ( albedo_pars_f%from_file )  THEN
2203!
2204!--          Horizontal
2205             DO  m = 1, surf_lsm_h%ns
2206                i = surf_lsm_h%i(m)
2207                j = surf_lsm_h%j(m)
2208!
2209!--             Spectral albedos for vegetation/pavement/water surfaces
2210                DO  ind_type = 0, 2
2211                   IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )   &
2212                      surf_lsm_h%albedo(ind_type,m) =                          &
2213                                             albedo_pars_f%pars_xy(0,j,i)     
2214                   IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )   &
2215                      surf_lsm_h%aldir(ind_type,m) =                           &
2216                                             albedo_pars_f%pars_xy(1,j,i)     
2217                   IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )   &
2218                      surf_lsm_h%aldif(ind_type,m) =                           &
2219                                             albedo_pars_f%pars_xy(1,j,i)     
2220                   IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill )   &
2221                      surf_lsm_h%asdir(ind_type,m) =                           &
2222                                             albedo_pars_f%pars_xy(2,j,i)     
2223                   IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill )   &
2224                      surf_lsm_h%asdif(ind_type,m) =                           &
2225                                             albedo_pars_f%pars_xy(2,j,i)
2226                ENDDO
2227             ENDDO
2228!
2229!--          For urban surface only if albedo has not been already initialized
2230!--          in the urban-surface model via the ASCII file.
2231             IF ( .NOT. surf_usm_h%albedo_from_ascii )  THEN
2232                DO  m = 1, surf_usm_h%ns
2233                   i = surf_usm_h%i(m)
2234                   j = surf_usm_h%j(m)
2235!
2236!--                Broadband albedos for wall/green/window surfaces
2237                   DO  ind_type = 0, 2
2238                      IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )&
2239                         surf_usm_h%albedo(ind_type,m) =                       &
2240                                             albedo_pars_f%pars_xy(0,j,i)
2241                   ENDDO
2242!
2243!--                Spectral albedos especially for building wall surfaces
2244                   IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill )  THEN
2245                      surf_usm_h%aldir(ind_veg_wall,m) =                       &
2246                                                albedo_pars_f%pars_xy(1,j,i)
2247                      surf_usm_h%aldif(ind_veg_wall,m) =                       &
2248                                                albedo_pars_f%pars_xy(1,j,i)
2249                   ENDIF
2250                   IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill )  THEN
2251                      surf_usm_h%asdir(ind_veg_wall,m) =                       &
2252                                                albedo_pars_f%pars_xy(2,j,i)
2253                      surf_usm_h%asdif(ind_veg_wall,m) =                       &
2254                                                albedo_pars_f%pars_xy(2,j,i)
2255                   ENDIF
2256!
2257!--                Spectral albedos especially for building green surfaces
2258                   IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill )  THEN
2259                      surf_usm_h%aldir(ind_pav_green,m) =                      &
2260                                                albedo_pars_f%pars_xy(3,j,i)
2261                      surf_usm_h%aldif(ind_pav_green,m) =                      &
2262                                                albedo_pars_f%pars_xy(3,j,i)
2263                   ENDIF
2264                   IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill )  THEN
2265                      surf_usm_h%asdir(ind_pav_green,m) =                      &
2266                                                albedo_pars_f%pars_xy(4,j,i)
2267                      surf_usm_h%asdif(ind_pav_green,m) =                      &
2268                                                albedo_pars_f%pars_xy(4,j,i)
2269                   ENDIF
2270!
2271!--                Spectral albedos especially for building window surfaces
2272                   IF ( albedo_pars_f%pars_xy(5,j,i) /= albedo_pars_f%fill )  THEN
2273                      surf_usm_h%aldir(ind_wat_win,m) =                        &
2274                                                albedo_pars_f%pars_xy(5,j,i)
2275                      surf_usm_h%aldif(ind_wat_win,m) =                        &
2276                                                albedo_pars_f%pars_xy(5,j,i)
2277                   ENDIF
2278                   IF ( albedo_pars_f%pars_xy(6,j,i) /= albedo_pars_f%fill )  THEN
2279                      surf_usm_h%asdir(ind_wat_win,m) =                        &
2280                                                albedo_pars_f%pars_xy(6,j,i)
2281                      surf_usm_h%asdif(ind_wat_win,m) =                        &
2282                                                albedo_pars_f%pars_xy(6,j,i)
2283                   ENDIF
2284
2285                ENDDO
2286             ENDIF
2287!
2288!--          Vertical
2289             DO  l = 0, 3
2290                ioff = surf_lsm_v(l)%ioff
2291                joff = surf_lsm_v(l)%joff
2292
2293                DO  m = 1, surf_lsm_v(l)%ns
2294                   i = surf_lsm_v(l)%i(m)
2295                   j = surf_lsm_v(l)%j(m)
2296!
2297!--                Spectral albedos for vegetation/pavement/water surfaces
2298                   DO  ind_type = 0, 2
2299                      IF ( albedo_pars_f%pars_xy(0,j+joff,i+ioff) /=           &
2300                           albedo_pars_f%fill )                                &
2301                         surf_lsm_v(l)%albedo(ind_type,m) =                    &
2302                                       albedo_pars_f%pars_xy(0,j+joff,i+ioff)
2303                      IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /=           &
2304                           albedo_pars_f%fill )                                &
2305                         surf_lsm_v(l)%aldir(ind_type,m) =                     &
2306                                       albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2307                      IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /=           &
2308                           albedo_pars_f%fill )                                &
2309                         surf_lsm_v(l)%aldif(ind_type,m) =                     &
2310                                       albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2311                      IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /=           &
2312                           albedo_pars_f%fill )                                &
2313                         surf_lsm_v(l)%asdir(ind_type,m) =                     &
2314                                       albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2315                      IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /=           &
2316                           albedo_pars_f%fill )                                &
2317                         surf_lsm_v(l)%asdif(ind_type,m) =                     &
2318                                       albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2319                   ENDDO
2320                ENDDO
2321!
2322!--             For urban surface only if albedo has not been already initialized
2323!--             in the urban-surface model via the ASCII file.
2324                IF ( .NOT. surf_usm_v(l)%albedo_from_ascii )  THEN
2325                   ioff = surf_usm_v(l)%ioff
2326                   joff = surf_usm_v(l)%joff
2327
2328                   DO  m = 1, surf_usm_v(l)%ns
2329                      i = surf_usm_v(l)%i(m)
2330                      j = surf_usm_v(l)%j(m)
2331!
2332!--                   Broadband albedos for wall/green/window surfaces
2333                      DO  ind_type = 0, 2
2334                         IF ( albedo_pars_f%pars_xy(0,j+joff,i+ioff) /=        &
2335                              albedo_pars_f%fill )                             &
2336                            surf_usm_v(l)%albedo(ind_type,m) =                 &
2337                                          albedo_pars_f%pars_xy(0,j+joff,i+ioff)
2338                      ENDDO
2339!
2340!--                   Spectral albedos especially for building wall surfaces
2341                      IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /=           &
2342                           albedo_pars_f%fill )  THEN
2343                         surf_usm_v(l)%aldir(ind_veg_wall,m) =                 &
2344                                         albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2345                         surf_usm_v(l)%aldif(ind_veg_wall,m) =                 &
2346                                         albedo_pars_f%pars_xy(1,j+joff,i+ioff)
2347                      ENDIF
2348                      IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /=           &
2349                           albedo_pars_f%fill )  THEN
2350                         surf_usm_v(l)%asdir(ind_veg_wall,m) =                 &
2351                                         albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2352                         surf_usm_v(l)%asdif(ind_veg_wall,m) =                 &
2353                                         albedo_pars_f%pars_xy(2,j+joff,i+ioff)
2354                      ENDIF
2355!                     
2356!--                   Spectral albedos especially for building green surfaces
2357                      IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /=           &
2358                           albedo_pars_f%fill )  THEN
2359                         surf_usm_v(l)%aldir(ind_pav_green,m) =                &
2360                                         albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2361                         surf_usm_v(l)%aldif(ind_pav_green,m) =                &
2362                                         albedo_pars_f%pars_xy(3,j+joff,i+ioff)
2363                      ENDIF
2364                      IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /=           &
2365                           albedo_pars_f%fill )  THEN
2366                         surf_usm_v(l)%asdir(ind_pav_green,m) =                &
2367                                         albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2368                         surf_usm_v(l)%asdif(ind_pav_green,m) =                &
2369                                         albedo_pars_f%pars_xy(4,j+joff,i+ioff)
2370                      ENDIF
2371!                     
2372!--                   Spectral albedos especially for building window surfaces
2373                      IF ( albedo_pars_f%pars_xy(5,j+joff,i+ioff) /=           &
2374                           albedo_pars_f%fill )  THEN
2375                         surf_usm_v(l)%aldir(ind_wat_win,m) =                  &
2376                                         albedo_pars_f%pars_xy(5,j+joff,i+ioff)
2377                         surf_usm_v(l)%aldif(ind_wat_win,m) =                  &
2378                                         albedo_pars_f%pars_xy(5,j+joff,i+ioff)
2379                      ENDIF
2380                      IF ( albedo_pars_f%pars_xy(6,j+joff,i+ioff) /=           &
2381                           albedo_pars_f%fill )  THEN
2382                         surf_usm_v(l)%asdir(ind_wat_win,m) =                  &
2383                                         albedo_pars_f%pars_xy(6,j+joff,i+ioff)
2384                         surf_usm_v(l)%asdif(ind_wat_win,m) =                  &
2385                                         albedo_pars_f%pars_xy(6,j+joff,i+ioff)
2386                      ENDIF
2387                   ENDDO
2388                ENDIF
2389             ENDDO
2390
2391          ENDIF
2392!
2393!--       Read explicit albedo values from building surface pars. If present,
2394!--       they override all less specific albedo values and force a albedo_type
2395!--       to zero in order to take effect.
2396          IF ( building_surface_pars_f%from_file )  THEN
2397             DO  m = 1, surf_usm_h%ns
2398                i = surf_usm_h%i(m)
2399                j = surf_usm_h%j(m)
2400                k = surf_usm_h%k(m)
2401!
2402!--             Iterate over surfaces in column, check height and orientation
2403                DO  is = building_surface_pars_f%index_ji(1,j,i), &
2404                         building_surface_pars_f%index_ji(2,j,i)
2405                   IF ( building_surface_pars_f%coords(4,is) == -surf_usm_h%koff .AND. &
2406                        building_surface_pars_f%coords(1,is) == k )  THEN
2407
2408                      IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /=      &
2409                           building_surface_pars_f%fill )  THEN
2410                         surf_usm_h%albedo(ind_veg_wall,m) =                         &
2411                                  building_surface_pars_f%pars(ind_s_alb_b_wall,is)
2412                         surf_usm_h%albedo_type(ind_veg_wall,m) = 0
2413                      ENDIF
2414
2415                      IF ( building_surface_pars_f%pars(ind_s_alb_l_wall,is) /=      &
2416                           building_surface_pars_f%fill )  THEN
2417                         surf_usm_h%aldir(ind_veg_wall,m) =                          &
2418                                  building_surface_pars_f%pars(ind_s_alb_l_wall,is)
2419                         surf_usm_h%aldif(ind_veg_wall,m) =                          &
2420                                  building_surface_pars_f%pars(ind_s_alb_l_wall,is)
2421                         surf_usm_h%albedo_type(ind_veg_wall,m) = 0
2422                      ENDIF
2423
2424                      IF ( building_surface_pars_f%pars(ind_s_alb_s_wall,is) /=      &
2425                           building_surface_pars_f%fill )  THEN
2426                         surf_usm_h%asdir(ind_veg_wall,m) =                          &
2427                                  building_surface_pars_f%pars(ind_s_alb_s_wall,is)
2428                         surf_usm_h%asdif(ind_veg_wall,m) =                          &
2429                                  building_surface_pars_f%pars(ind_s_alb_s_wall,is)
2430                         surf_usm_h%albedo_type(ind_veg_wall,m) = 0
2431                      ENDIF
2432
2433                      IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /=       &
2434                           building_surface_pars_f%fill )  THEN
2435                         surf_usm_h%albedo(ind_wat_win,m) =                          &
2436                                  building_surface_pars_f%pars(ind_s_alb_b_win,is)
2437                         surf_usm_h%albedo_type(ind_wat_win,m) = 0
2438                      ENDIF
2439
2440                      IF ( building_surface_pars_f%pars(ind_s_alb_l_win,is) /=       &
2441                           building_surface_pars_f%fill )  THEN
2442                         surf_usm_h%aldir(ind_wat_win,m) =                           &
2443                                  building_surface_pars_f%pars(ind_s_alb_l_win,is)
2444                         surf_usm_h%aldif(ind_wat_win,m) =                           &
2445                                  building_surface_pars_f%pars(ind_s_alb_l_win,is)
2446                         surf_usm_h%albedo_type(ind_wat_win,m) = 0
2447                      ENDIF
2448
2449                      IF ( building_surface_pars_f%pars(ind_s_alb_s_win,is) /=       &
2450                           building_surface_pars_f%fill )  THEN
2451                         surf_usm_h%asdir(ind_wat_win,m) =                           &
2452                                  building_surface_pars_f%pars(ind_s_alb_s_win,is)
2453                         surf_usm_h%asdif(ind_wat_win,m) =                           &
2454                                  building_surface_pars_f%pars(ind_s_alb_s_win,is)
2455                         surf_usm_h%albedo_type(ind_wat_win,m) = 0
2456                      ENDIF
2457
2458                      IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /=     &
2459                           building_surface_pars_f%fill )  THEN
2460                         surf_usm_h%albedo(ind_pav_green,m) =                        &
2461                                  building_surface_pars_f%pars(ind_s_alb_b_green,is)
2462                         surf_usm_h%albedo_type(ind_pav_green,m) = 0
2463                      ENDIF
2464
2465                      IF ( building_surface_pars_f%pars(ind_s_alb_l_green,is) /=     &
2466                           building_surface_pars_f%fill )  THEN
2467                         surf_usm_h%aldir(ind_pav_green,m) =                         &
2468                                  building_surface_pars_f%pars(ind_s_alb_l_green,is)
2469                         surf_usm_h%aldif(ind_pav_green,m) =                         &
2470                                  building_surface_pars_f%pars(ind_s_alb_l_green,is)
2471                         surf_usm_h%albedo_type(ind_pav_green,m) = 0
2472                      ENDIF
2473
2474                      IF ( building_surface_pars_f%pars(ind_s_alb_s_green,is) /=     &
2475                           building_surface_pars_f%fill )  THEN
2476                         surf_usm_h%asdir(ind_pav_green,m) =                         &
2477                                  building_surface_pars_f%pars(ind_s_alb_s_green,is)
2478                         surf_usm_h%asdif(ind_pav_green,m) =                         &
2479                                  building_surface_pars_f%pars(ind_s_alb_s_green,is)
2480                         surf_usm_h%albedo_type(ind_pav_green,m) = 0
2481                      ENDIF
2482
2483                      EXIT ! surface was found and processed
2484                   ENDIF
2485                ENDDO
2486             ENDDO
2487
2488             DO  l = 0, 3
2489                DO  m = 1, surf_usm_v(l)%ns
2490                   i = surf_usm_v(l)%i(m)
2491                   j = surf_usm_v(l)%j(m)
2492                   k = surf_usm_v(l)%k(m)
2493!
2494!--                Iterate over surfaces in column, check height and orientation
2495                   DO  is = building_surface_pars_f%index_ji(1,j,i), &
2496                            building_surface_pars_f%index_ji(2,j,i)
2497                      IF ( building_surface_pars_f%coords(5,is) == -surf_usm_v(l)%joff .AND. &
2498                           building_surface_pars_f%coords(6,is) == -surf_usm_v(l)%ioff .AND. &
2499                           building_surface_pars_f%coords(1,is) == k )  THEN
2500
2501                         IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /=      &
2502                              building_surface_pars_f%fill )  THEN
2503                            surf_usm_v(l)%albedo(ind_veg_wall,m) =                      &
2504                                     building_surface_pars_f%pars(ind_s_alb_b_wall,is)
2505                            surf_usm_v(l)%albedo_type(ind_veg_wall,m) = 0
2506                         ENDIF
2507
2508                         IF ( building_surface_pars_f%pars(ind_s_alb_l_wall,is) /=      &
2509                              building_surface_pars_f%fill )  THEN
2510                            surf_usm_v(l)%aldir(ind_veg_wall,m) =                       &
2511                                     building_surface_pars_f%pars(ind_s_alb_l_wall,is)
2512                            surf_usm_v(l)%aldif(ind_veg_wall,m) =                       &
2513                                     building_surface_pars_f%pars(ind_s_alb_l_wall,is)
2514                            surf_usm_v(l)%albedo_type(ind_veg_wall,m) = 0
2515                         ENDIF
2516
2517                         IF ( building_surface_pars_f%pars(ind_s_alb_s_wall,is) /=      &
2518                              building_surface_pars_f%fill )  THEN
2519                            surf_usm_v(l)%asdir(ind_veg_wall,m) =                       &
2520                                     building_surface_pars_f%pars(ind_s_alb_s_wall,is)
2521                            surf_usm_v(l)%asdif(ind_veg_wall,m) =                       &
2522                                     building_surface_pars_f%pars(ind_s_alb_s_wall,is)
2523                            surf_usm_v(l)%albedo_type(ind_veg_wall,m) = 0
2524                         ENDIF
2525
2526                         IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /=       &
2527                              building_surface_pars_f%fill )  THEN
2528                            surf_usm_v(l)%albedo(ind_wat_win,m) =                       &
2529                                     building_surface_pars_f%pars(ind_s_alb_b_win,is)
2530                            surf_usm_v(l)%albedo_type(ind_wat_win,m) = 0
2531                         ENDIF
2532
2533                         IF ( building_surface_pars_f%pars(ind_s_alb_l_win,is) /=       &
2534                              building_surface_pars_f%fill )  THEN
2535                            surf_usm_v(l)%aldir(ind_wat_win,m) =                        &
2536                                     building_surface_pars_f%pars(ind_s_alb_l_win,is)
2537                            surf_usm_v(l)%aldif(ind_wat_win,m) =                        &
2538                                     building_surface_pars_f%pars(ind_s_alb_l_win,is)
2539                            surf_usm_v(l)%albedo_type(ind_wat_win,m) = 0
2540                         ENDIF
2541
2542                         IF ( building_surface_pars_f%pars(ind_s_alb_s_win,is) /=       &
2543                              building_surface_pars_f%fill )  THEN
2544                            surf_usm_v(l)%asdir(ind_wat_win,m) =                        &
2545                                     building_surface_pars_f%pars(ind_s_alb_s_win,is)
2546                            surf_usm_v(l)%asdif(ind_wat_win,m) =                        &
2547                                     building_surface_pars_f%pars(ind_s_alb_s_win,is)
2548                            surf_usm_v(l)%albedo_type(ind_wat_win,m) = 0
2549                         ENDIF
2550
2551                         IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /=     &
2552                              building_surface_pars_f%fill )  THEN
2553                            surf_usm_v(l)%albedo(ind_pav_green,m) =                     &
2554                                     building_surface_pars_f%pars(ind_s_alb_b_green,is)
2555                            surf_usm_v(l)%albedo_type(ind_pav_green,m) = 0
2556                         ENDIF
2557
2558                         IF ( building_surface_pars_f%pars(ind_s_alb_l_green,is) /=     &
2559                              building_surface_pars_f%fill )  THEN
2560                            surf_usm_v(l)%aldir(ind_pav_green,m) =                      &
2561                                     building_surface_pars_f%pars(ind_s_alb_l_green,is)
2562                            surf_usm_v(l)%aldif(ind_pav_green,m) =                      &
2563                                     building_surface_pars_f%pars(ind_s_alb_l_green,is)
2564                            surf_usm_v(l)%albedo_type(ind_pav_green,m) = 0
2565                         ENDIF
2566
2567                         IF ( building_surface_pars_f%pars(ind_s_alb_s_green,is) /=     &
2568                              building_surface_pars_f%fill )  THEN
2569                            surf_usm_v(l)%asdir(ind_pav_green,m) =                      &
2570                                     building_surface_pars_f%pars(ind_s_alb_s_green,is)
2571                            surf_usm_v(l)%asdif(ind_pav_green,m) =                      &
2572                                     building_surface_pars_f%pars(ind_s_alb_s_green,is)
2573                            surf_usm_v(l)%albedo_type(ind_pav_green,m) = 0
2574                         ENDIF
2575
2576                         EXIT ! surface was found and processed
2577                      ENDIF
2578                   ENDDO
2579                ENDDO
2580             ENDDO
2581          ENDIF
2582
2583!
2584!--       Calculate initial values of current (cosine of) the zenith angle and
2585!--       whether the sun is up
2586          CALL get_date_time( time_since_reference_point, &
2587                              day_of_year=day_of_year,    &
2588                              second_of_day=second_of_day )
2589          CALL calc_zenith( day_of_year, second_of_day )
2590!
2591!--       Calculate initial surface albedo for different surfaces
2592          IF ( .NOT. constant_albedo )  THEN
2593#if defined( __netcdf )
2594!
2595!--          Horizontally aligned natural and urban surfaces
2596             CALL calc_albedo( surf_lsm_h )
2597             CALL calc_albedo( surf_usm_h )
2598!
2599!--          Vertically aligned natural and urban surfaces
2600             DO  l = 0, 3
2601                CALL calc_albedo( surf_lsm_v(l) )
2602                CALL calc_albedo( surf_usm_v(l) )
2603             ENDDO
2604#endif
2605          ELSE
2606!
2607!--          Initialize sun-inclination independent spectral albedos
2608!--          Horizontal surfaces
2609             IF ( surf_lsm_h%ns > 0 )  THEN
2610                surf_lsm_h%rrtm_aldir = surf_lsm_h%aldir
2611                surf_lsm_h%rrtm_asdir = surf_lsm_h%asdir
2612                surf_lsm_h%rrtm_aldif = surf_lsm_h%aldif
2613                surf_lsm_h%rrtm_asdif = surf_lsm_h%asdif
2614             ENDIF
2615             IF ( surf_usm_h%ns > 0 )  THEN
2616                surf_usm_h%rrtm_aldir = surf_usm_h%aldir
2617                surf_usm_h%rrtm_asdir = surf_usm_h%asdir
2618                surf_usm_h%rrtm_aldif = surf_usm_h%aldif
2619                surf_usm_h%rrtm_asdif = surf_usm_h%asdif
2620             ENDIF
2621!
2622!--          Vertical surfaces
2623             DO  l = 0, 3
2624                IF ( surf_lsm_v(l)%ns > 0 )  THEN
2625                   surf_lsm_v(l)%rrtm_aldir = surf_lsm_v(l)%aldir
2626                   surf_lsm_v(l)%rrtm_asdir = surf_lsm_v(l)%asdir
2627                   surf_lsm_v(l)%rrtm_aldif = surf_lsm_v(l)%aldif
2628                   surf_lsm_v(l)%rrtm_asdif = surf_lsm_v(l)%asdif
2629                ENDIF
2630                IF ( surf_usm_v(l)%ns > 0 )  THEN
2631                   surf_usm_v(l)%rrtm_aldir = surf_usm_v(l)%aldir
2632                   surf_usm_v(l)%rrtm_asdir = surf_usm_v(l)%asdir
2633                   surf_usm_v(l)%rrtm_aldif = surf_usm_v(l)%aldif
2634                   surf_usm_v(l)%rrtm_asdif = surf_usm_v(l)%asdif
2635                ENDIF
2636             ENDDO
2637
2638          ENDIF
2639
2640!
2641!--       Allocate 3d arrays of radiative fluxes and heating rates
2642          IF ( .NOT. ALLOCATED ( rad_sw_in ) )  THEN
2643             ALLOCATE ( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2644             rad_sw_in = 0.0_wp
2645          ENDIF
2646
2647          IF ( .NOT. ALLOCATED ( rad_sw_in_av ) )  THEN
2648             ALLOCATE ( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2649          ENDIF
2650
2651          IF ( .NOT. ALLOCATED ( rad_sw_out ) )  THEN
2652             ALLOCATE ( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2653             rad_sw_out = 0.0_wp
2654          ENDIF
2655
2656          IF ( .NOT. ALLOCATED ( rad_sw_out_av ) )  THEN
2657             ALLOCATE ( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2658          ENDIF
2659
2660          IF ( .NOT. ALLOCATED ( rad_sw_hr ) )  THEN
2661             ALLOCATE ( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2662             rad_sw_hr = 0.0_wp
2663          ENDIF
2664
2665          IF ( .NOT. ALLOCATED ( rad_sw_hr_av ) )  THEN
2666             ALLOCATE ( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2667             rad_sw_hr_av = 0.0_wp
2668          ENDIF
2669
2670          IF ( .NOT. ALLOCATED ( rad_sw_cs_hr ) )  THEN
2671             ALLOCATE ( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2672             rad_sw_cs_hr = 0.0_wp
2673          ENDIF
2674
2675          IF ( .NOT. ALLOCATED ( rad_sw_cs_hr_av ) )  THEN
2676             ALLOCATE ( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2677             rad_sw_cs_hr_av = 0.0_wp
2678          ENDIF
2679
2680          IF ( .NOT. ALLOCATED ( rad_lw_in ) )  THEN
2681             ALLOCATE ( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2682             rad_lw_in = 0.0_wp
2683          ENDIF
2684
2685          IF ( .NOT. ALLOCATED ( rad_lw_in_av ) )  THEN
2686             ALLOCATE ( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2687          ENDIF
2688
2689          IF ( .NOT. ALLOCATED ( rad_lw_out ) )  THEN
2690             ALLOCATE ( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2691            rad_lw_out = 0.0_wp
2692          ENDIF
2693
2694          IF ( .NOT. ALLOCATED ( rad_lw_out_av ) )  THEN
2695             ALLOCATE ( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2696          ENDIF
2697
2698          IF ( .NOT. ALLOCATED ( rad_lw_hr ) )  THEN
2699             ALLOCATE ( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2700             rad_lw_hr = 0.0_wp
2701          ENDIF
2702
2703          IF ( .NOT. ALLOCATED ( rad_lw_hr_av ) )  THEN
2704             ALLOCATE ( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2705             rad_lw_hr_av = 0.0_wp
2706          ENDIF
2707
2708          IF ( .NOT. ALLOCATED ( rad_lw_cs_hr ) )  THEN
2709             ALLOCATE ( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2710             rad_lw_cs_hr = 0.0_wp
2711          ENDIF
2712
2713          IF ( .NOT. ALLOCATED ( rad_lw_cs_hr_av ) )  THEN
2714             ALLOCATE ( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2715             rad_lw_cs_hr_av = 0.0_wp
2716          ENDIF
2717
2718          ALLOCATE ( rad_sw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2719          ALLOCATE ( rad_sw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2720          rad_sw_cs_in  = 0.0_wp
2721          rad_sw_cs_out = 0.0_wp
2722
2723          ALLOCATE ( rad_lw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2724          ALLOCATE ( rad_lw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
2725          rad_lw_cs_in  = 0.0_wp
2726          rad_lw_cs_out = 0.0_wp
2727
2728!
2729!--       Allocate 1-element array for surface temperature
2730!--       (RRTMG anticipates an array as passed argument).
2731          ALLOCATE ( rrtm_tsfc(1) )
2732!
2733!--       Allocate surface emissivity.
2734!--       Values will be given directly before calling rrtm_lw.
2735          ALLOCATE ( rrtm_emis(0:0,1:nbndlw+1) )
2736
2737!
2738!--       Initialize RRTMG, before check if files are existent
2739          INQUIRE( FILE='rrtmg_lw.nc', EXIST=lw_exists )
2740          IF ( .NOT. lw_exists )  THEN
2741             message_string = 'Input file rrtmg_lw.nc' //                &
2742                            '&for rrtmg missing. ' // &
2743                            '&Please provide <jobname>_lsw file in the INPUT directory.'
2744             CALL message( 'radiation_init', 'PA0583', 1, 2, 0, 6, 0 )
2745          ENDIF         
2746          INQUIRE( FILE='rrtmg_sw.nc', EXIST=sw_exists )
2747          IF ( .NOT. sw_exists )  THEN
2748             message_string = 'Input file rrtmg_sw.nc' //                &
2749                            '&for rrtmg missing. ' // &
2750                            '&Please provide <jobname>_rsw file in the INPUT directory.'
2751             CALL message( 'radiation_init', 'PA0584', 1, 2, 0, 6, 0 )
2752          ENDIF         
2753         
2754          IF ( lw_radiation )  CALL rrtmg_lw_ini ( c_p )
2755          IF ( sw_radiation )  CALL rrtmg_sw_ini ( c_p )
2756         
2757!
2758!--       Set input files for RRTMG
2759          INQUIRE(FILE="RAD_SND_DATA", EXIST=snd_exists) 
2760          IF ( .NOT. snd_exists )  THEN
2761             rrtm_input_file = "rrtmg_lw.nc"
2762          ENDIF
2763
2764!
2765!--       Read vertical layers for RRTMG from sounding data
2766!--       The routine provides nzt_rad, hyp_snd(1:nzt_rad),
2767!--       t_snd(nzt+2:nzt_rad), rrtm_play(1:nzt_rad), rrtm_plev(1_nzt_rad+1),
2768!--       rrtm_tlay(nzt+2:nzt_rad), rrtm_tlev(nzt+2:nzt_rad+1)
2769          CALL read_sounding_data
2770
2771!
2772!--       Read trace gas profiles from file. This routine provides
2773!--       the rrtm_ arrays (1:nzt_rad+1)
2774          CALL read_trace_gas_data
2775#endif
2776       ENDIF
2777!
2778!--    Initializaion actions exclusively required for external
2779!--    radiation forcing
2780       IF ( radiation_scheme == 'external' )  THEN
2781!
2782!--       Open the radiation input file. Note, for child domain, a dynamic
2783!--       input file is often not provided. In order to do not need to
2784!--       duplicate the dynamic input file just for the radiation input, take
2785!--       it from the dynamic file for the parent if not available for the
2786!--       child domain(s). In this case this is possible because radiation
2787!--       input should be the same for each model.
2788          INQUIRE( FILE = TRIM( input_file_dynamic ),                          &
2789                   EXIST = radiation_input_root_domain  )
2790                   
2791          IF ( .NOT. input_pids_dynamic  .AND.                                 &
2792               .NOT. radiation_input_root_domain )  THEN
2793             message_string = 'In case of external radiation forcing ' //      &
2794                              'a dynamic input file is required. If no ' //    &
2795                              'dynamic input for the child domain(s) is ' //   &
2796                              'provided, at least one for the root domain ' // &
2797                              'is needed.'
2798             CALL message( 'radiation_init', 'PA0315', 1, 2, 0, 6, 0 )
2799          ENDIF
2800#if defined( __netcdf )
2801!
2802!--       Open dynamic input file for child domain if available, else, open
2803!--       dynamic input file for the root domain.
2804          IF ( input_pids_dynamic )  THEN
2805             CALL open_read_file( TRIM( input_file_dynamic ) //                &
2806                                  TRIM( coupling_char ),                       &
2807                                  pids_id )
2808          ELSEIF ( radiation_input_root_domain )  THEN
2809             CALL open_read_file( TRIM( input_file_dynamic ),                  &
2810                                  pids_id )
2811          ENDIF
2812                               
2813          CALL inquire_num_variables( pids_id, num_var_pids )
2814!         
2815!--       Allocate memory to store variable names and read them
2816          ALLOCATE( vars_pids(1:num_var_pids) )
2817          CALL inquire_variable_names( pids_id, vars_pids )
2818!         
2819!--       Input time dimension.
2820          IF ( check_existence( vars_pids, 'time_rad' ) )  THEN
2821             CALL get_dimension_length( pids_id, ntime, 'time_rad' )
2822         
2823             ALLOCATE( time_rad_f%var1d(0:ntime-1) )
2824!                                                                                 
2825!--          Read variable                   
2826             CALL get_variable( pids_id, 'time_rad', time_rad_f%var1d )
2827                               
2828             time_rad_f%from_file = .TRUE.
2829          ENDIF           
2830!         
2831!--       Input shortwave downwelling.
2832          IF ( check_existence( vars_pids, 'rad_sw_in' ) )  THEN
2833!         
2834!--          Get _FillValue attribute
2835             CALL get_attribute( pids_id, char_fill, rad_sw_in_f%fill,         &
2836                                 .FALSE., 'rad_sw_in' )
2837!         
2838!--          Get level-of-detail
2839             CALL get_attribute( pids_id, char_lod, rad_sw_in_f%lod,           &
2840                                 .FALSE., 'rad_sw_in' )
2841!
2842!--          Level-of-detail 1 - radiation depends only on time_rad
2843             IF ( rad_sw_in_f%lod == 1 )  THEN
2844                ALLOCATE( rad_sw_in_f%var1d(0:ntime-1) )
2845                CALL get_variable( pids_id, 'rad_sw_in', rad_sw_in_f%var1d )
2846                rad_sw_in_f%from_file = .TRUE.
2847!
2848!--          Level-of-detail 2 - radiation depends on time_rad, y, x
2849             ELSEIF ( rad_sw_in_f%lod == 2 )  THEN 
2850                ALLOCATE( rad_sw_in_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2851               
2852                CALL get_variable( pids_id, 'rad_sw_in', rad_sw_in_f%var3d,    &
2853                                   nxl, nxr, nys, nyn, 0, ntime-1 )
2854                                   
2855                rad_sw_in_f%from_file = .TRUE.
2856             ELSE
2857                message_string = '"rad_sw_in" has no valid lod attribute'
2858                CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2859             ENDIF
2860          ENDIF
2861!         
2862!--       Input longwave downwelling.
2863          IF ( check_existence( vars_pids, 'rad_lw_in' ) )  THEN
2864!         
2865!--          Get _FillValue attribute
2866             CALL get_attribute( pids_id, char_fill, rad_lw_in_f%fill,         &
2867                                 .FALSE., 'rad_lw_in' )
2868!         
2869!--          Get level-of-detail
2870             CALL get_attribute( pids_id, char_lod, rad_lw_in_f%lod,           &
2871                                 .FALSE., 'rad_lw_in' )
2872!
2873!--          Level-of-detail 1 - radiation depends only on time_rad
2874             IF ( rad_lw_in_f%lod == 1 )  THEN
2875                ALLOCATE( rad_lw_in_f%var1d(0:ntime-1) )
2876                CALL get_variable( pids_id, 'rad_lw_in', rad_lw_in_f%var1d )
2877                rad_lw_in_f%from_file = .TRUE.
2878!
2879!--          Level-of-detail 2 - radiation depends on time_rad, y, x
2880             ELSEIF ( rad_lw_in_f%lod == 2 )  THEN 
2881                ALLOCATE( rad_lw_in_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2882               
2883                CALL get_variable( pids_id, 'rad_lw_in', rad_lw_in_f%var3d,    &
2884                                   nxl, nxr, nys, nyn, 0, ntime-1 )
2885                                   
2886                rad_lw_in_f%from_file = .TRUE.
2887             ELSE
2888                message_string = '"rad_lw_in" has no valid lod attribute'
2889                CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2890             ENDIF
2891          ENDIF
2892!         
2893!--       Input shortwave downwelling, diffuse part.
2894          IF ( check_existence( vars_pids, 'rad_sw_in_dif' ) )  THEN
2895!         
2896!--          Read _FillValue attribute
2897             CALL get_attribute( pids_id, char_fill, rad_sw_in_dif_f%fill,     &
2898                                 .FALSE., 'rad_sw_in_dif' )
2899!         
2900!--          Get level-of-detail
2901             CALL get_attribute( pids_id, char_lod, rad_sw_in_dif_f%lod,       &
2902                                 .FALSE., 'rad_sw_in_dif' )
2903!
2904!--          Level-of-detail 1 - radiation depends only on time_rad
2905             IF ( rad_sw_in_dif_f%lod == 1 )  THEN
2906                ALLOCATE( rad_sw_in_dif_f%var1d(0:ntime-1) )
2907                CALL get_variable( pids_id, 'rad_sw_in_dif',                   &
2908                                   rad_sw_in_dif_f%var1d )
2909                rad_sw_in_dif_f%from_file = .TRUE.
2910!
2911!--          Level-of-detail 2 - radiation depends on time_rad, y, x
2912             ELSEIF ( rad_sw_in_dif_f%lod == 2 )  THEN 
2913                ALLOCATE( rad_sw_in_dif_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) )
2914               
2915                CALL get_variable( pids_id, 'rad_sw_in_dif',                   &
2916                                   rad_sw_in_dif_f%var3d,                      &
2917                                   nxl, nxr, nys, nyn, 0, ntime-1 )
2918                                   
2919                rad_sw_in_dif_f%from_file = .TRUE.
2920             ELSE
2921                message_string = '"rad_sw_in_dif" has no valid lod attribute'
2922                CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 )
2923             ENDIF
2924          ENDIF
2925!         
2926!--       Finally, close the input file and deallocate temporary arrays
2927          DEALLOCATE( vars_pids )
2928         
2929          CALL close_input_file( pids_id )
2930#endif
2931!
2932!--       Make some consistency checks.
2933          IF ( .NOT. rad_sw_in_f%from_file  .OR.                               &
2934               .NOT. rad_lw_in_f%from_file )  THEN
2935             message_string = 'In case of external radiation forcing ' //      &
2936                              'both, rad_sw_in and rad_lw_in are required.'
2937             CALL message( 'radiation_init', 'PA0195', 1, 2, 0, 6, 0 )
2938          ENDIF
2939         
2940          IF ( .NOT. time_rad_f%from_file )  THEN
2941             message_string = 'In case of external radiation forcing ' //      &
2942                              'dimension time_rad is required.'
2943             CALL message( 'radiation_init', 'PA0196', 1, 2, 0, 6, 0 )
2944          ENDIF
2945         
2946          CALL get_date_time( 0.0_wp, second_of_day=second_of_day )
2947
2948          IF ( ABS( time_rad_f%var1d(0) - second_of_day ) > 1E-6_wp )  THEN
2949             message_string = 'External radiation forcing: first point in ' // &
2950                              'time is /= origin_date_time.'
2951             CALL message( 'radiation_init', 'PA0313', 1, 2, 0, 6, 0 )
2952          ENDIF
2953         
2954          IF ( end_time - spinup_time > time_rad_f%var1d(ntime-1)              &
2955                                      - second_of_day )  THEN
2956             message_string = 'External radiation forcing does not cover ' //  &
2957                              'the entire simulation time.'
2958             CALL message( 'radiation_init', 'PA0314', 1, 2, 0, 6, 0 )
2959          ENDIF
2960!
2961!--       Check for fill values in radiation
2962          IF ( ALLOCATED( rad_sw_in_f%var1d ) )  THEN
2963             IF ( ANY( rad_sw_in_f%var1d == rad_sw_in_f%fill ) )  THEN
2964                message_string = 'External radiation array "rad_sw_in" ' //    &
2965                                 'must not contain any fill values.'
2966                CALL message( 'radiation_init', 'PA0197', 1, 2, 0, 6, 0 )
2967             ENDIF
2968          ENDIF
2969         
2970          IF ( ALLOCATED( rad_lw_in_f%var1d ) )  THEN
2971             IF ( ANY( rad_lw_in_f%var1d == rad_lw_in_f%fill ) )  THEN
2972                message_string = 'External radiation array "rad_lw_in" ' //    &
2973                                 'must not contain any fill values.'
2974                CALL message( 'radiation_init', 'PA0198', 1, 2, 0, 6, 0 )
2975             ENDIF
2976          ENDIF
2977         
2978          IF ( ALLOCATED( rad_sw_in_dif_f%var1d ) )  THEN
2979             IF ( ANY( rad_sw_in_dif_f%var1d == rad_sw_in_dif_f%fill ) )  THEN
2980                message_string = 'External radiation array "rad_sw_in_dif" ' //&
2981                                 'must not contain any fill values.'
2982                CALL message( 'radiation_init', 'PA0199', 1, 2, 0, 6, 0 )
2983             ENDIF
2984          ENDIF
2985         
2986          IF ( ALLOCATED( rad_sw_in_f%var3d ) )  THEN
2987             IF ( ANY( rad_sw_in_f%var3d == rad_sw_in_f%fill ) )  THEN
2988                message_string = 'External radiation array "rad_sw_in" ' //    &
2989                                 'must not contain any fill values.'
2990                CALL message( 'radiation_init', 'PA0197', 1, 2, 0, 6, 0 )
2991             ENDIF
2992          ENDIF
2993         
2994          IF ( ALLOCATED( rad_lw_in_f%var3d ) )  THEN
2995             IF ( ANY( rad_lw_in_f%var3d == rad_lw_in_f%fill ) )  THEN
2996                message_string = 'External radiation array "rad_lw_in" ' //    &
2997                                 'must not contain any fill values.'
2998                CALL message( 'radiation_init', 'PA0198', 1, 2, 0, 6, 0 )
2999             ENDIF
3000          ENDIF
3001         
3002          IF ( ALLOCATED( rad_sw_in_dif_f%var3d ) )  THEN
3003             IF ( ANY( rad_sw_in_dif_f%var3d == rad_sw_in_dif_f%fill ) )  THEN
3004                message_string = 'External radiation array "rad_sw_in_dif" ' //&
3005                                 'must not contain any fill values.'
3006                CALL message( 'radiation_init', 'PA0199', 1, 2, 0, 6, 0 )
3007             ENDIF
3008          ENDIF
3009!
3010!--       Currently, 2D external radiation input is not possible in
3011!--       combination with topography where average radiation is used.
3012          IF ( ( rad_lw_in_f%lod == 2  .OR.  rad_sw_in_f%lod == 2  .OR.      &
3013                 rad_sw_in_dif_f%lod == 2  )  .AND. average_radiation )  THEN
3014             message_string = 'External radiation with lod = 2 is currently '//&
3015                              'not possible with average_radiation = .T..'
3016                CALL message( 'radiation_init', 'PA0670', 1, 2, 0, 6, 0 )
3017          ENDIF
3018!
3019!--       All radiation input should have the same level of detail. The sum
3020!--       of lods divided by the number of available radiation arrays must be
3021!--       1 (if all are lod = 1) or 2 (if all are lod = 2).
3022          IF ( REAL( MERGE( rad_lw_in_f%lod, 0, rad_lw_in_f%from_file ) +       &
3023                     MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) +       &
3024                     MERGE( rad_sw_in_dif_f%lod, 0, rad_sw_in_dif_f%from_file ),&
3025                     KIND = wp ) /                                              &
3026                   ( MERGE( 1.0_wp, 0.0_wp, rad_lw_in_f%from_file ) +           &
3027                     MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) +           &
3028                     MERGE( 1.0_wp, 0.0_wp, rad_sw_in_dif_f%from_file ) )       &
3029                     /= 1.0_wp  .AND.                                           &
3030               REAL( MERGE( rad_lw_in_f%lod, 0, rad_lw_in_f%from_file ) +       &
3031                     MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) +       &
3032                     MERGE( rad_sw_in_dif_f%lod, 0, rad_sw_in_dif_f%from_file ),&
3033                     KIND = wp ) /                                              &
3034                   ( MERGE( 1.0_wp, 0.0_wp, rad_lw_in_f%from_file ) +           &
3035                     MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) +           &
3036                     MERGE( 1.0_wp, 0.0_wp, rad_sw_in_dif_f%from_file ) )       &
3037                     /= 2.0_wp )  THEN
3038             message_string = 'External radiation input should have the same '//&
3039                              'lod.'
3040             CALL message( 'radiation_init', 'PA0673', 1, 2, 0, 6, 0 )
3041          ENDIF
3042
3043       ENDIF
3044!
3045!--    Perform user actions if required
3046       CALL user_init_radiation
3047
3048!
3049!--    Calculate radiative fluxes at model start
3050       SELECT CASE ( TRIM( radiation_scheme ) )
3051
3052          CASE ( 'rrtmg' )
3053             CALL radiation_rrtmg
3054
3055          CASE ( 'clear-sky' )
3056             CALL radiation_clearsky
3057
3058          CASE ( 'constant' )
3059             CALL radiation_constant
3060             
3061          CASE ( 'external' )
3062!
3063!--          During spinup apply clear-sky model
3064             IF ( time_since_reference_point < 0.0_wp )  THEN
3065                CALL radiation_clearsky
3066             ELSE
3067                CALL radiation_external
3068             ENDIF
3069
3070          CASE DEFAULT
3071
3072       END SELECT
3073
3074!
3075!--    Find all discretized apparent solar positions for radiation interaction.
3076       IF ( radiation_interactions )  CALL radiation_presimulate_solar_pos
3077
3078!
3079!--    If required, read or calculate and write out the SVF
3080       IF ( radiation_interactions .AND. read_svf)  THEN
3081!
3082!--       Read sky-view factors and further required data from file
3083          CALL radiation_read_svf()
3084
3085       ELSEIF ( radiation_interactions .AND. .NOT. read_svf)  THEN
3086!
3087!--       calculate SFV and CSF
3088          CALL radiation_calc_svf()
3089       ENDIF
3090
3091       IF ( radiation_interactions .AND. write_svf)  THEN
3092!
3093!--       Write svf, csf svfsurf and csfsurf data to file
3094          CALL radiation_write_svf()
3095       ENDIF
3096
3097!
3098!--    Adjust radiative fluxes. In case of urban and land surfaces, also
3099!--    call an initial interaction.
3100       IF ( radiation_interactions )  THEN
3101          CALL radiation_interaction
3102       ENDIF
3103
3104       IF ( debug_output )  CALL debug_message( 'radiation_init', 'end' )
3105
3106       RETURN !todo: remove, I don't see what we need this for here
3107
3108    END SUBROUTINE radiation_init
3109
3110
3111!------------------------------------------------------------------------------!
3112! Description:
3113! ------------
3114!> A simple clear sky radiation model
3115!------------------------------------------------------------------------------!
3116    SUBROUTINE radiation_external
3117
3118       IMPLICIT NONE
3119
3120       INTEGER(iwp) ::  l   !< running index for surface orientation
3121       INTEGER(iwp) ::  t   !< index of current timestep
3122       INTEGER(iwp) ::  tm  !< index of previous timestep
3123       
3124       LOGICAL      ::  horizontal !< flag indicating treatment of horinzontal surfaces
3125       
3126       REAL(wp) ::  fac_dt               !< interpolation factor 
3127       REAL(wp) ::  second_of_day_init   !< second of the day at model start
3128
3129       TYPE(surf_type), POINTER ::  surf !< pointer on respective surface type, used to generalize routine   
3130
3131!
3132!--    Calculate current zenith angle
3133       CALL get_date_time( time_since_reference_point, &
3134                           day_of_year=day_of_year,    &
3135                           second_of_day=second_of_day )
3136       CALL calc_zenith( day_of_year, second_of_day )
3137!
3138!--    Interpolate external radiation on current timestep
3139       IF ( time_since_reference_point  <= 0.0_wp )  THEN
3140          t      = 0
3141          tm     = 0
3142          fac_dt = 0
3143       ELSE
3144          CALL get_date_time( 0.0_wp, second_of_day=second_of_day_init )
3145          t = 0
3146          DO WHILE ( time_rad_f%var1d(t) <=                                    &
3147                     time_since_reference_point + second_of_day_init )
3148             t = t + 1
3149          ENDDO
3150         
3151          tm = MAX( t-1, 0 )
3152         
3153          fac_dt = ( time_since_reference_point + second_of_day_init           &
3154                   - time_rad_f%var1d(tm) + dt_3d )                            &
3155                 / ( time_rad_f%var1d(t)  - time_rad_f%var1d(tm) )
3156          fac_dt = MIN( 1.0_wp, fac_dt )
3157       ENDIF
3158!
3159!--    Call clear-sky calculation for each surface orientation.
3160!--    First, horizontal surfaces
3161       horizontal = .TRUE.
3162       surf => surf_lsm_h
3163       CALL radiation_external_surf
3164       surf => surf_usm_h
3165       CALL radiation_external_surf
3166       horizontal = .FALSE.
3167!
3168!--    Vertical surfaces
3169       DO  l = 0, 3
3170          surf => surf_lsm_v(l)
3171          CALL radiation_external_surf
3172          surf => surf_usm_v(l)
3173          CALL radiation_external_surf
3174       ENDDO
3175       
3176       CONTAINS
3177
3178          SUBROUTINE radiation_external_surf
3179
3180             USE control_parameters
3181         
3182             IMPLICIT NONE
3183
3184             INTEGER(iwp) ::  i    !< grid index along x-dimension   
3185             INTEGER(iwp) ::  j    !< grid index along y-dimension 
3186             INTEGER(iwp) ::  k    !< grid index along z-dimension   
3187             INTEGER(iwp) ::  m    !< running index for surface elements
3188             
3189             REAL(wp) ::  lw_in     !< downwelling longwave radiation, interpolated value     
3190             REAL(wp) ::  sw_in     !< downwelling shortwave radiation, interpolated value
3191             REAL(wp) ::  sw_in_dif !< downwelling diffuse shortwave radiation, interpolated value   
3192
3193             IF ( surf%ns < 1 )  RETURN
3194!
3195!--          level-of-detail = 1. Note, here it must be distinguished between
3196!--          averaged radiation and non-averaged radiation for the upwelling
3197!--          fluxes.
3198             IF ( rad_sw_in_f%lod == 1 )  THEN
3199             
3200                sw_in = ( 1.0_wp - fac_dt ) * rad_sw_in_f%var1d(tm)            &
3201                                   + fac_dt * rad_sw_in_f%var1d(t)
3202                                         
3203                lw_in = ( 1.0_wp - fac_dt ) * rad_lw_in_f%var1d(tm)            &
3204                                   + fac_dt * rad_lw_in_f%var1d(t)
3205!
3206!--             Limit shortwave incoming radiation to positive values, in order
3207!--             to overcome possible observation errors.
3208                sw_in = MAX( 0.0_wp, sw_in )
3209                sw_in = MERGE( sw_in, 0.0_wp, sun_up )
3210                         
3211                surf%rad_sw_in = sw_in                                         
3212                surf%rad_lw_in = lw_in
3213             
3214                IF ( average_radiation )  THEN
3215                   surf%rad_sw_out = albedo_urb * surf%rad_sw_in
3216                   
3217                   surf%rad_lw_out = emissivity_urb * sigma_sb * t_rad_urb**4  &
3218                                  + ( 1.0_wp - emissivity_urb ) * surf%rad_lw_in
3219                   
3220                   surf%rad_net = surf%rad_sw_in - surf%rad_sw_out             &
3221                                + surf%rad_lw_in - surf%rad_lw_out
3222                   
3223                   surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb          &
3224                                                     * sigma_sb                &
3225                                                     * t_rad_urb**3
3226                ELSE
3227                   DO  m = 1, surf%ns
3228                      k = surf%k(m)
3229                      surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m)  *      &
3230                                             surf%albedo(ind_veg_wall,m)       &
3231                                           + surf%frac(ind_pav_green,m) *      &
3232                                             surf%albedo(ind_pav_green,m)      &
3233                                           + surf%frac(ind_wat_win,m)   *      &
3234                                             surf%albedo(ind_wat_win,m) )      &
3235                                           * surf%rad_sw_in(m)
3236                   
3237                      surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m)  *      &
3238                                             surf%emissivity(ind_veg_wall,m)   &
3239                                           + surf%frac(ind_pav_green,m) *      &
3240                                             surf%emissivity(ind_pav_green,m)  &
3241                                           + surf%frac(ind_wat_win,m)   *      &
3242                                             surf%emissivity(ind_wat_win,m)    &
3243                                           )                                   &
3244                                           * sigma_sb                          &
3245                                           * ( surf%pt_surface(m) * exner(k) )**4
3246                   
3247                      surf%rad_lw_out_change_0(m) =                            &
3248                                         ( surf%frac(ind_veg_wall,m)  *        &
3249                                           surf%emissivity(ind_veg_wall,m)     &
3250                                         + surf%frac(ind_pav_green,m) *        &
3251                                           surf%emissivity(ind_pav_green,m)    &
3252                                         + surf%frac(ind_wat_win,m)   *        &
3253                                           surf%emissivity(ind_wat_win,m)      &
3254                                         ) * 4.0_wp * sigma_sb                 &
3255                                         * ( surf%pt_surface(m) * exner(k) )**3
3256                   ENDDO
3257               
3258                ENDIF
3259!
3260!--             If diffuse shortwave radiation is available, store it on
3261!--             the respective files.
3262                IF ( rad_sw_in_dif_f%from_file )  THEN
3263                   sw_in_dif= ( 1.0_wp - fac_dt ) * rad_sw_in_dif_f%var1d(tm)  &
3264                                         + fac_dt * rad_sw_in_dif_f%var1d(t)
3265                                         
3266                   IF ( ALLOCATED( rad_sw_in_diff ) )  rad_sw_in_diff = sw_in_dif
3267                   IF ( ALLOCATED( rad_sw_in_dir  ) )  rad_sw_in_dir  = sw_in  &
3268                                                                    - sw_in_dif
3269!             
3270!--                Diffuse longwave radiation equals the total downwelling
3271!--                longwave radiation
3272                   IF ( ALLOCATED( rad_lw_in_diff ) )  rad_lw_in_diff = lw_in
3273                ENDIF
3274!
3275!--          level-of-detail = 2
3276             ELSE
3277
3278                DO  m = 1, surf%ns
3279                   i = surf%i(m)
3280                   j = surf%j(m)
3281                   k = surf%k(m)
3282                   
3283                   surf%rad_sw_in(m) = ( 1.0_wp - fac_dt )                     &
3284                                            * rad_sw_in_f%var3d(tm,j,i)        &
3285                                   + fac_dt * rad_sw_in_f%var3d(t,j,i)                                   
3286!
3287!--                Limit shortwave incoming radiation to positive values, in
3288!--                order to overcome possible observation errors.
3289                   surf%rad_sw_in(m) = MAX( 0.0_wp, surf%rad_sw_in(m) )
3290                   surf%rad_sw_in(m) = MERGE( surf%rad_sw_in(m), 0.0_wp, sun_up )
3291                                         
3292                   surf%rad_lw_in(m) = ( 1.0_wp - fac_dt )                     &
3293                                            * rad_lw_in_f%var3d(tm,j,i)        &
3294                                   + fac_dt * rad_lw_in_f%var3d(t,j,i) 
3295!
3296!--                Weighted average according to surface fraction.
3297                   surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m)  *         &
3298                                          surf%albedo(ind_veg_wall,m)          &
3299                                        + surf%frac(ind_pav_green,m) *         &
3300                                          surf%albedo(ind_pav_green,m)         &
3301                                        + surf%frac(ind_wat_win,m)   *         &
3302                                          surf%albedo(ind_wat_win,m) )         &
3303                                        * surf%rad_sw_in(m)
3304
3305                   surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m)  *         &
3306                                          surf%emissivity(ind_veg_wall,m)      &
3307                                        + surf%frac(ind_pav_green,m) *         &
3308                                          surf%emissivity(ind_pav_green,m)     &
3309                                        + surf%frac(ind_wat_win,m)   *         &
3310                                          surf%emissivity(ind_wat_win,m)       &
3311                                        )                                      &
3312                                        * sigma_sb                             &
3313                                        * ( surf%pt_surface(m) * exner(k) )**4
3314
3315                   surf%rad_lw_out_change_0(m) =                               &
3316                                      ( surf%frac(ind_veg_wall,m)  *           &
3317                                        surf%emissivity(ind_veg_wall,m)        &
3318                                      + surf%frac(ind_pav_green,m) *           &
3319                                        surf%emissivity(ind_pav_green,m)       &
3320                                      + surf%frac(ind_wat_win,m)   *           &
3321                                        surf%emissivity(ind_wat_win,m)         &
3322                                      ) * 4.0_wp * sigma_sb                    &
3323                                      * ( surf%pt_surface(m) * exner(k) )**3
3324
3325                   surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m)    &
3326                                   + surf%rad_lw_in(m) - surf%rad_lw_out(m)
3327!
3328!--                If diffuse shortwave radiation is available, store it on
3329!--                the respective files.
3330                   IF ( rad_sw_in_dif_f%from_file )  THEN
3331                      IF ( ALLOCATED( rad_sw_in_diff ) )                       &
3332                         rad_sw_in_diff(j,i) = ( 1.0_wp - fac_dt )             &
3333                                              * rad_sw_in_dif_f%var3d(tm,j,i)  &
3334                                     + fac_dt * rad_sw_in_dif_f%var3d(t,j,i)
3335!
3336!--                   dir = sw_in - sw_in_dif.
3337                      IF ( ALLOCATED( rad_sw_in_dir  ) )                       &
3338                         rad_sw_in_dir(j,i)  = surf%rad_sw_in(m) -             &
3339                                               rad_sw_in_diff(j,i)
3340!                 
3341!--                   Diffuse longwave radiation equals the total downwelling
3342!--                   longwave radiation
3343                      IF ( ALLOCATED( rad_lw_in_diff ) )                       &
3344                         rad_lw_in_diff(j,i) = surf%rad_lw_in(m)
3345                   ENDIF
3346
3347                ENDDO
3348
3349             ENDIF
3350!
3351!--          Store radiation also on 2D arrays, which are still used for
3352!--          direct-diffuse splitting. Note, this is only required
3353!--          for horizontal surfaces, which covers all x,y position.
3354             IF ( horizontal )  THEN
3355                DO  m = 1, surf%ns
3356                   i = surf%i(m)
3357                   j = surf%j(m)
3358                   
3359                   rad_sw_in(0,j,i)  = surf%rad_sw_in(m)
3360                   rad_lw_in(0,j,i)  = surf%rad_lw_in(m)
3361                   rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3362                   rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3363                ENDDO
3364             ENDIF
3365 
3366          END SUBROUTINE radiation_external_surf
3367
3368    END SUBROUTINE radiation_external   
3369   
3370!------------------------------------------------------------------------------!
3371! Description:
3372! ------------
3373!> A simple clear sky radiation model
3374!------------------------------------------------------------------------------!
3375    SUBROUTINE radiation_clearsky
3376
3377       IMPLICIT NONE
3378
3379       INTEGER(iwp) ::  l         !< running index for surface orientation
3380
3381       LOGICAL      ::  horizontal !< flag indicating treatment of horinzontal surfaces
3382
3383       REAL(wp)     ::  pt1       !< potential temperature at first grid level or mean value at urban layer top
3384       REAL(wp)     ::  pt1_l     !< potential temperature at first grid level or mean value at urban layer top at local subdomain
3385       REAL(wp)     ::  ql1       !< liquid water mixing ratio at first grid level or mean value at urban layer top
3386       REAL(wp)     ::  ql1_l     !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain
3387
3388       TYPE(surf_type), POINTER ::  surf !< pointer on respective surface type, used to generalize routine   
3389
3390!
3391!--    Calculate current zenith angle
3392       CALL get_date_time( time_since_reference_point, &
3393                           day_of_year=day_of_year,    &
3394                           second_of_day=second_of_day )
3395       CALL calc_zenith( day_of_year, second_of_day )
3396
3397!
3398!--    Calculate sky transmissivity
3399       sky_trans = 0.6_wp + 0.2_wp * cos_zenith
3400
3401!
3402!--    Calculate value of the Exner function at model surface
3403!
3404!--    In case averaged radiation is used, calculate mean temperature and
3405!--    liquid water mixing ratio at the urban-layer top.
3406       IF ( average_radiation ) THEN
3407          pt1   = 0.0_wp
3408          IF ( bulk_cloud_model  .OR.  cloud_droplets )  ql1   = 0.0_wp
3409
3410          pt1_l = SUM( pt(nz_urban_t,nys:nyn,nxl:nxr) )
3411          IF ( bulk_cloud_model  .OR.  cloud_droplets  )  ql1_l = SUM( ql(nz_urban_t,nys:nyn,nxl:nxr) )
3412
3413#if defined( __parallel )     
3414          IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
3415          CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3416          IF ( ierr /= 0 ) THEN
3417              WRITE(9,*) 'Error MPI_AllReduce1:', ierr, pt1_l, pt1
3418              FLUSH(9)
3419          ENDIF
3420
3421          IF ( bulk_cloud_model  .OR.  cloud_droplets ) THEN
3422              CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3423              IF ( ierr /= 0 ) THEN
3424                  WRITE(9,*) 'Error MPI_AllReduce2:', ierr, ql1_l, ql1
3425                  FLUSH(9)
3426              ENDIF
3427          ENDIF
3428#else
3429          pt1 = pt1_l 
3430          IF ( bulk_cloud_model  .OR.  cloud_droplets )  ql1 = ql1_l
3431#endif
3432
3433          IF ( bulk_cloud_model  .OR.  cloud_droplets  )  pt1 = pt1 + lv_d_cp / exner(nz_urban_t) * ql1
3434!
3435!--       Finally, divide by number of grid points
3436          pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp )
3437       ENDIF
3438!
3439!--    Call clear-sky calculation for each surface orientation.
3440!--    First, horizontal surfaces
3441       horizontal = .TRUE.
3442       surf => surf_lsm_h
3443       CALL radiation_clearsky_surf
3444       surf => surf_usm_h
3445       CALL radiation_clearsky_surf
3446       horizontal = .FALSE.
3447!
3448!--    Vertical surfaces
3449       DO  l = 0, 3
3450          surf => surf_lsm_v(l)
3451          CALL radiation_clearsky_surf
3452          surf => surf_usm_v(l)
3453          CALL radiation_clearsky_surf
3454       ENDDO
3455
3456       CONTAINS
3457
3458          SUBROUTINE radiation_clearsky_surf
3459
3460             IMPLICIT NONE
3461
3462             INTEGER(iwp) ::  i         !< index x-direction
3463             INTEGER(iwp) ::  j         !< index y-direction
3464             INTEGER(iwp) ::  k         !< index z-direction
3465             INTEGER(iwp) ::  m         !< running index for surface elements
3466
3467             IF ( surf%ns < 1 )  RETURN
3468
3469!
3470!--          Calculate radiation fluxes and net radiation (rad_net) assuming
3471!--          homogeneous urban radiation conditions.
3472             IF ( average_radiation ) THEN       
3473
3474                k = nz_urban_t
3475
3476                surf%rad_sw_in  = solar_constant * sky_trans * cos_zenith
3477                surf%rad_sw_out = albedo_urb * surf%rad_sw_in
3478               
3479                surf%rad_lw_in  = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k+1))**4
3480
3481                surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4   &
3482                                    + (1.0_wp - emissivity_urb) * surf%rad_lw_in
3483
3484                surf%rad_net = surf%rad_sw_in - surf%rad_sw_out                &
3485                             + surf%rad_lw_in - surf%rad_lw_out
3486
3487                surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb  &
3488                                           * (t_rad_urb)**3
3489
3490!
3491!--          Calculate radiation fluxes and net radiation (rad_net) for each surface
3492!--          element.
3493             ELSE
3494
3495                DO  m = 1, surf%ns
3496                   i = surf%i(m)
3497                   j = surf%j(m)
3498                   k = surf%k(m)
3499
3500                   surf%rad_sw_in(m) = solar_constant * sky_trans * cos_zenith
3501
3502!
3503!--                Weighted average according to surface fraction.
3504!--                ATTENTION: when radiation interactions are switched on the
3505!--                calculated fluxes below are not actually used as they are
3506!--                overwritten in radiation_interaction.
3507                   surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m)  *         &
3508                                          surf%albedo(ind_veg_wall,m)          &
3509                                        + surf%frac(ind_pav_green,m) *         &
3510                                          surf%albedo(ind_pav_green,m)         &
3511                                        + surf%frac(ind_wat_win,m)   *         &
3512                                          surf%albedo(ind_wat_win,m) )         &
3513                                        * surf%rad_sw_in(m)
3514
3515                   surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m)  *         &
3516                                          surf%emissivity(ind_veg_wall,m)      &
3517                                        + surf%frac(ind_pav_green,m) *         &
3518                                          surf%emissivity(ind_pav_green,m)     &
3519                                        + surf%frac(ind_wat_win,m)   *         &
3520                                          surf%emissivity(ind_wat_win,m)       &
3521                                        )                                      &
3522                                        * sigma_sb                             &
3523                                        * ( surf%pt_surface(m) * exner(nzb) )**4
3524
3525                   surf%rad_lw_out_change_0(m) =                               &
3526                                      ( surf%frac(ind_veg_wall,m)  *           &
3527                                        surf%emissivity(ind_veg_wall,m)        &
3528                                      + surf%frac(ind_pav_green,m) *           &
3529                                        surf%emissivity(ind_pav_green,m)       &
3530                                      + surf%frac(ind_wat_win,m)   *           &
3531                                        surf%emissivity(ind_wat_win,m)         &
3532                                      ) * 4.0_wp * sigma_sb                    &
3533                                      * ( surf%pt_surface(m) * exner(nzb) )** 3
3534
3535
3536                   IF ( bulk_cloud_model  .OR.  cloud_droplets  )  THEN
3537                      pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i)
3538                      surf%rad_lw_in(m)  = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k))**4
3539                   ELSE
3540                      surf%rad_lw_in(m)  = emissivity_atm_clsky * sigma_sb * (pt(k,j,i) * exner(k))**4
3541                   ENDIF
3542
3543                   surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m)    &
3544                                   + surf%rad_lw_in(m) - surf%rad_lw_out(m)
3545
3546                ENDDO
3547
3548             ENDIF
3549
3550!
3551!--          Fill out values in radiation arrays. Note, this is only required
3552!--          for horizontal surfaces, which covers all x,y position.
3553             IF ( horizontal )  THEN
3554                DO  m = 1, surf%ns
3555                   i = surf%i(m)
3556                   j = surf%j(m)
3557                   rad_sw_in(0,j,i)  = surf%rad_sw_in(m)
3558                   rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3559                   rad_lw_in(0,j,i)  = surf%rad_lw_in(m)
3560                   rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3561                ENDDO
3562             ENDIF
3563 
3564          END SUBROUTINE radiation_clearsky_surf
3565
3566    END SUBROUTINE radiation_clearsky
3567
3568
3569!------------------------------------------------------------------------------!
3570! Description:
3571! ------------
3572!> This scheme keeps the prescribed net radiation constant during the run
3573!------------------------------------------------------------------------------!
3574    SUBROUTINE radiation_constant
3575
3576
3577       IMPLICIT NONE
3578
3579       INTEGER(iwp) ::  l         !< running index for surface orientation
3580       
3581       LOGICAL      ::  horizontal !< flag indicating treatment of horinzontal surfaces
3582
3583       REAL(wp)     ::  pt1       !< potential temperature at first grid level or mean value at urban layer top
3584       REAL(wp)     ::  pt1_l     !< potential temperature at first grid level or mean value at urban layer top at local subdomain
3585       REAL(wp)     ::  ql1       !< liquid water mixing ratio at first grid level or mean value at urban layer top
3586       REAL(wp)     ::  ql1_l     !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain
3587
3588       TYPE(surf_type), POINTER ::  surf !< pointer on respective surface type, used to generalize routine
3589
3590!
3591!--    In case averaged radiation is used, calculate mean temperature and
3592!--    liquid water mixing ratio at the urban-layer top.
3593       IF ( average_radiation ) THEN   
3594          pt1   = 0.0_wp
3595          IF ( bulk_cloud_model  .OR.  cloud_droplets )  ql1   = 0.0_wp
3596
3597          pt1_l = SUM( pt(nz_urban_t,nys:nyn,nxl:nxr) )
3598          IF ( bulk_cloud_model  .OR.  cloud_droplets )  ql1_l = SUM( ql(nz_urban_t,nys:nyn,nxl:nxr) )
3599
3600#if defined( __parallel )     
3601          IF ( collective_wait )  CALL MPI_BARRIER( comm2d, ierr )
3602          CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3603          IF ( ierr /= 0 ) THEN
3604              WRITE(9,*) 'Error MPI_AllReduce3:', ierr, pt1_l, pt1
3605              FLUSH(9)
3606          ENDIF
3607          IF ( bulk_cloud_model  .OR.  cloud_droplets )  THEN
3608             CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr )
3609             IF ( ierr /= 0 ) THEN
3610                 WRITE(9,*) 'Error MPI_AllReduce4:', ierr, ql1_l, ql1
3611                 FLUSH(9)
3612             ENDIF
3613          ENDIF
3614#else
3615          pt1 = pt1_l
3616          IF ( bulk_cloud_model  .OR.  cloud_droplets )  ql1 = ql1_l
3617#endif
3618          IF ( bulk_cloud_model  .OR.  cloud_droplets )  pt1 = pt1 + lv_d_cp / exner(nz_urban_t+1) * ql1
3619!
3620!--       Finally, divide by number of grid points
3621          pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp )
3622       ENDIF
3623
3624!
3625!--    First, horizontal surfaces
3626       horizontal = .TRUE.
3627       surf => surf_lsm_h
3628       CALL radiation_constant_surf
3629       surf => surf_usm_h
3630       CALL radiation_constant_surf
3631       horizontal = .FALSE.
3632!
3633!--    Vertical surfaces
3634       DO  l = 0, 3
3635          surf => surf_lsm_v(l)
3636          CALL radiation_constant_surf
3637          surf => surf_usm_v(l)
3638          CALL radiation_constant_surf
3639       ENDDO
3640
3641       CONTAINS
3642
3643          SUBROUTINE radiation_constant_surf
3644
3645             IMPLICIT NONE
3646
3647             INTEGER(iwp) ::  i         !< index x-direction
3648             INTEGER(iwp) ::  ioff      !< offset between surface element and adjacent grid point along x
3649             INTEGER(iwp) ::  j         !< index y-direction
3650             INTEGER(iwp) ::  joff      !< offset between surface element and adjacent grid point along y
3651             INTEGER(iwp) ::  k         !< index z-direction
3652             INTEGER(iwp) ::  koff      !< offset between surface element and adjacent grid point along z
3653             INTEGER(iwp) ::  m         !< running index for surface elements
3654
3655             IF ( surf%ns < 1 )  RETURN
3656
3657!--          Calculate homogenoeus urban radiation fluxes
3658             IF ( average_radiation ) THEN
3659
3660                surf%rad_net = net_radiation
3661
3662                surf%rad_lw_in  = emissivity_atm_clsky * sigma_sb * (pt1 * exner(nz_urban_t+1))**4
3663
3664                surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4   &
3665                                    + ( 1.0_wp - emissivity_urb )             & ! shouldn't be this a bulk value -- emissivity_urb?
3666                                    * surf%rad_lw_in
3667
3668                surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb  &
3669                                           * t_rad_urb**3
3670
3671                surf%rad_sw_in = ( surf%rad_net - surf%rad_lw_in               &
3672                                     + surf%rad_lw_out )                       &
3673                                     / ( 1.0_wp - albedo_urb )
3674
3675                surf%rad_sw_out =  albedo_urb * surf%rad_sw_in
3676
3677!
3678!--          Calculate radiation fluxes for each surface element
3679             ELSE
3680!
3681!--             Determine index offset between surface element and adjacent
3682!--             atmospheric grid point
3683                ioff = surf%ioff
3684                joff = surf%joff
3685                koff = surf%koff
3686
3687!
3688!--             Prescribe net radiation and estimate the remaining radiative fluxes
3689                DO  m = 1, surf%ns
3690                   i = surf%i(m)
3691                   j = surf%j(m)
3692                   k = surf%k(m)
3693
3694                   surf%rad_net(m) = net_radiation
3695
3696                   IF ( bulk_cloud_model  .OR.  cloud_droplets )  THEN
3697                      pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i)
3698                      surf%rad_lw_in(m)  = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k))**4
3699                   ELSE
3700                      surf%rad_lw_in(m)  = emissivity_atm_clsky * sigma_sb *                 &
3701                                             ( pt(k,j,i) * exner(k) )**4
3702                   ENDIF
3703
3704!
3705!--                Weighted average according to surface fraction.
3706                   surf%rad_lw_out(m) = ( surf%frac(ind_veg_wall,m)  *         &
3707                                          surf%emissivity(ind_veg_wall,m)      &
3708                                        + surf%frac(ind_pav_green,m) *         &
3709                                          surf%emissivity(ind_pav_green,m)     &
3710                                        + surf%frac(ind_wat_win,m)   *         &
3711                                          surf%emissivity(ind_wat_win,m)       &
3712                                        )                                      &
3713                                      * sigma_sb                               &
3714                                      * ( surf%pt_surface(m) * exner(nzb) )**4
3715
3716                   surf%rad_sw_in(m) = ( surf%rad_net(m) - surf%rad_lw_in(m)   &
3717                                       + surf%rad_lw_out(m) )                  &
3718                                       / ( 1.0_wp -                            &
3719                                          ( surf%frac(ind_veg_wall,m)  *       &
3720                                            surf%albedo(ind_veg_wall,m)        &
3721                                         +  surf%frac(ind_pav_green,m) *       &
3722                                            surf%albedo(ind_pav_green,m)       &
3723                                         +  surf%frac(ind_wat_win,m)   *       &
3724                                            surf%albedo(ind_wat_win,m) )       &
3725                                         )
3726
3727                   surf%rad_sw_out(m) = ( surf%frac(ind_veg_wall,m)  *         &
3728                                          surf%albedo(ind_veg_wall,m)          &
3729                                        + surf%frac(ind_pav_green,m) *         &
3730                                          surf%albedo(ind_pav_green,m)         &
3731                                        + surf%frac(ind_wat_win,m)   *         &
3732                                          surf%albedo(ind_wat_win,m) )         &
3733                                      * surf%rad_sw_in(m)
3734
3735                ENDDO
3736
3737             ENDIF
3738
3739!
3740!--          Fill out values in radiation arrays. Note, this is only required
3741!--          for horizontal surfaces, which covers all x,y position.
3742             IF ( horizontal )  THEN
3743                DO  m = 1, surf%ns
3744                   i = surf%i(m)
3745                   j = surf%j(m)
3746                   rad_sw_in(0,j,i)  = surf%rad_sw_in(m)
3747                   rad_sw_out(0,j,i) = surf%rad_sw_out(m)
3748                   rad_lw_in(0,j,i)  = surf%rad_lw_in(m)
3749                   rad_lw_out(0,j,i) = surf%rad_lw_out(m)
3750                ENDDO
3751             ENDIF
3752
3753          END SUBROUTINE radiation_constant_surf
3754         
3755
3756    END SUBROUTINE radiation_constant
3757
3758!------------------------------------------------------------------------------!
3759! Description:
3760! ------------
3761!> Header output for radiation model
3762!------------------------------------------------------------------------------!
3763    SUBROUTINE radiation_header ( io )
3764
3765
3766       IMPLICIT NONE
3767 
3768       INTEGER(iwp), INTENT(IN) ::  io            !< Unit of the output file
3769   
3770
3771       
3772!
3773!--    Write radiation model header
3774       WRITE( io, 3 )
3775
3776       IF ( radiation_scheme == "constant" )  THEN
3777          WRITE( io, 4 ) net_radiation
3778       ELSEIF ( radiation_scheme == "clear-sky" )  THEN
3779          WRITE( io, 5 )
3780       ELSEIF ( radiation_scheme == "rrtmg" )  THEN
3781          WRITE( io, 6 )
3782          IF ( .NOT. lw_radiation )  WRITE( io, 10 )
3783          IF ( .NOT. sw_radiation )  WRITE( io, 11 )
3784       ELSEIF ( radiation_scheme == "external" )  THEN
3785          WRITE( io, 14 )
3786       ENDIF
3787
3788       IF ( albedo_type_f%from_file  .OR.  vegetation_type_f%from_file  .OR.   &
3789            pavement_type_f%from_file  .OR.  water_type_f%from_file  .OR.      &
3790            building_type_f%from_file )  THEN
3791             WRITE( io, 13 )
3792       ELSE 
3793          IF ( albedo_type == 0 )  THEN
3794             WRITE( io, 7 ) albedo
3795          ELSE
3796             WRITE( io, 8 ) TRIM( albedo_type_name(albedo_type) )
3797          ENDIF
3798       ENDIF
3799       IF ( constant_albedo )  THEN
3800          WRITE( io, 9 )
3801       ENDIF
3802       
3803       WRITE( io, 12 ) dt_radiation
3804 
3805
3806 3 FORMAT (//' Radiation model information:'/                                  &
3807              ' ----------------------------'/)
3808 4 FORMAT ('    --> Using constant net radiation: net_radiation = ', F6.2,     &
3809           // 'W/m**2')
3810 5 FORMAT ('    --> Simple radiation scheme for clear sky is used (no clouds,',&
3811                   ' default)')
3812 6 FORMAT ('    --> RRTMG scheme is used')
3813 7 FORMAT (/'    User-specific surface albedo: albedo =', F6.3)
3814 8 FORMAT (/'    Albedo is set for land surface type: ', A)
3815 9 FORMAT (/'    --> Albedo is fixed during the run')
381610 FORMAT (/'    --> Longwave radiation is disabled')
381711 FORMAT (/'    --> Shortwave radiation is disabled.')
381812 FORMAT  ('    Timestep: dt_radiation = ', F6.2, '  s')
381913 FORMAT (/'    Albedo is set individually for each xy-location, according ', &
3820                 'to given surface type.')
382114 FORMAT ('    --> External radiation forcing is used')
3822
3823
3824    END SUBROUTINE radiation_header
3825   
3826
3827!------------------------------------------------------------------------------!
3828! Description:
3829! ------------
3830!> Parin for &radiation_parameters for radiation model
3831!------------------------------------------------------------------------------!
3832    SUBROUTINE radiation_parin
3833
3834
3835       IMPLICIT NONE
3836
3837       CHARACTER (LEN=80) ::  line  !< dummy string that contains the current line of the parameter file
3838       
3839       NAMELIST /radiation_par/   albedo, albedo_lw_dif, albedo_lw_dir,         &
3840                                  albedo_sw_dif, albedo_sw_dir, albedo_type,    &
3841                                  constant_albedo, dt_radiation, emissivity,    &
3842                                  lw_radiation, max_raytracing_dist,            &
3843                                  min_irrf_value, mrt_geom_human,               &
3844                                  mrt_include_sw, mrt_nlevels,                  &
3845                                  mrt_skip_roof, net_radiation, nrefsteps,      &
3846                                  plant_lw_interact, rad_angular_discretization,&
3847                                  radiation_interactions_on, radiation_scheme,  &
3848                                  raytrace_discrete_azims,                      &
3849                                  raytrace_discrete_elevs, raytrace_mpi_rma,    &
3850                                  skip_time_do_radiation, surface_reflections,  &
3851                                  svfnorm_report_thresh, sw_radiation,          &
3852                                  unscheduled_radiation_calls
3853
3854   
3855       NAMELIST /radiation_parameters/ albedo, albedo_lw_dif, albedo_lw_dir,    &
3856                                  albedo_sw_dif, albedo_sw_dir, albedo_type,    &
3857                                  constant_albedo, dt_radiation, emissivity,    &
3858                                  lw_radiation, max_raytracing_dist,            &
3859                                  min_irrf_value, mrt_geom_human,               &
3860                                  mrt_include_sw, mrt_nlevels,                  &
3861                                  mrt_skip_roof, net_radiation, nrefsteps,      &
3862                                  plant_lw_interact, rad_angular_discretization,&
3863                                  radiation_interactions_on, radiation_scheme,  &
3864                                  raytrace_discrete_azims,                      &
3865                                  raytrace_discrete_elevs, raytrace_mpi_rma,    &
3866                                  skip_time_do_radiation, surface_reflections,  &
3867                                  svfnorm_report_thresh, sw_radiation,          &
3868                                  unscheduled_radiation_calls
3869   
3870       line = ' '
3871       
3872!
3873!--    Try to find radiation model namelist
3874       REWIND ( 11 )
3875       line = ' '
3876       DO WHILE ( INDEX( line, '&radiation_parameters' ) == 0 )
3877          READ ( 11, '(A)', END=12 )  line
3878       ENDDO
3879       BACKSPACE ( 11 )
3880
3881!
3882!--    Read user-defined namelist
3883       READ ( 11, radiation_parameters, ERR = 10 )
3884
3885!
3886!--    Set flag that indicates that the radiation model is switched on
3887       radiation = .TRUE.
3888
3889       GOTO 14
3890
3891 10    BACKSPACE( 11 )
3892       READ( 11 , '(A)') line
3893       CALL parin_fail_message( 'radiation_parameters', line )
3894!
3895!--    Try to find old namelist
3896 12    REWIND ( 11 )
3897       line = ' '
3898       DO WHILE ( INDEX( line, '&radiation_par' ) == 0 )
3899          READ ( 11, '(A)', END=14 )  line
3900       ENDDO
3901       BACKSPACE ( 11 )
3902
3903!
3904!--    Read user-defined namelist
3905       READ ( 11, radiation_par, ERR = 13, END = 14 )
3906
3907       message_string = 'namelist radiation_par is deprecated and will be ' // &
3908                     'removed in near future. Please use namelist ' //         &
3909                     'radiation_parameters instead'
3910       CALL message( 'radiation_parin', 'PA0487', 0, 1, 0, 6, 0 )
3911
3912!
3913!--    Set flag that indicates that the radiation model is switched on
3914       radiation = .TRUE.
3915
3916       IF ( .NOT.  radiation_interactions_on  .AND.  surface_reflections )  THEN
3917          message_string = 'surface_reflections is allowed only when '      // &
3918               'radiation_interactions_on is set to TRUE'
3919          CALL message( 'radiation_parin', 'PA0293',1, 2, 0, 6, 0 )
3920       ENDIF
3921
3922       GOTO 14
3923
3924 13    BACKSPACE( 11 )
3925       READ( 11 , '(A)') line
3926       CALL parin_fail_message( 'radiation_par', line )
3927
3928 14    CONTINUE
3929       
3930    END SUBROUTINE radiation_parin
3931
3932
3933!------------------------------------------------------------------------------!
3934! Description:
3935! ------------
3936!> Implementation of the RRTMG radiation_scheme
3937!------------------------------------------------------------------------------!
3938    SUBROUTINE radiation_rrtmg
3939
3940#if defined ( __rrtmg )
3941       USE indices,                                                            &
3942           ONLY:  nbgp
3943
3944       USE palm_date_time_mod,                                                 &
3945           ONLY:  hours_per_day
3946
3947       USE particle_attributes,                                                &
3948           ONLY:  grid_particles, number_of_particles, particles, prt_count
3949
3950       IMPLICIT NONE
3951
3952
3953       INTEGER(iwp) ::  i, j, k, l, m, n !< loop indices
3954       INTEGER(iwp) ::  k_topo_l   !< topography top index
3955       INTEGER(iwp) ::  k_topo     !< topography top index
3956
3957       REAL(wp)     ::  d_hours_day  !< 1 / hours-per-day
3958       REAL(wp)     ::  nc_rad, &    !< number concentration of cloud droplets
3959                        s_r2,   &    !< weighted sum over all droplets with r^2
3960                        s_r3         !< weighted sum over all droplets with r^3
3961
3962       REAL(wp), DIMENSION(0:nzt+1) :: pt_av, q_av, ql_av
3963       REAL(wp), DIMENSION(0:0)     :: zenith   !< to provide indexed array
3964!
3965!--    Just dummy arguments
3966       REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rrtm_lw_taucld_dum,          &
3967                                                  rrtm_lw_tauaer_dum,          &
3968                                                  rrtm_sw_taucld_dum,          &
3969                                                  rrtm_sw_ssacld_dum,          &
3970                                                  rrtm_sw_asmcld_dum,          &
3971                                                  rrtm_sw_fsfcld_dum,          &
3972                                                  rrtm_sw_tauaer_dum,          &
3973                                                  rrtm_sw_ssaaer_dum,          &
3974                                                  rrtm_sw_asmaer_dum,          &
3975                                                  rrtm_sw_ecaer_dum
3976
3977!
3978!--    Pre-calculate parameters
3979       d_hours_day = 1.0_wp / REAL( hours_per_day, KIND=wp )
3980
3981!
3982!--    Calculate current (cosine of) zenith angle and whether the sun is up
3983       CALL get_date_time( time_since_reference_point, &
3984                           day_of_year=day_of_year,    &
3985                           second_of_day=second_of_day )
3986       CALL calc_zenith( day_of_year, second_of_day )
3987       zenith(0) = cos_zenith
3988!
3989!--    Calculate surface albedo. In case average radiation is applied,
3990!--    this is not required.
3991#if defined( __netcdf )
3992       IF ( .NOT. constant_albedo )  THEN
3993!
3994!--       Horizontally aligned default, natural and urban surfaces
3995          CALL calc_albedo( surf_lsm_h    )
3996          CALL calc_albedo( surf_usm_h    )
3997!
3998!--       Vertically aligned default, natural and urban surfaces
3999          DO  l = 0, 3
4000             CALL calc_albedo( surf_lsm_v(l) )
4001             CALL calc_albedo( surf_usm_v(l) )
4002          ENDDO
4003       ENDIF
4004#endif
4005
4006!
4007!--    Prepare input data for RRTMG
4008
4009!
4010!--    In case of large scale forcing with surface data, calculate new pressure
4011!--    profile. nzt_rad might be modified by these calls and all required arrays
4012!--    will then be re-allocated
4013       IF ( large_scale_forcing  .AND.  lsf_surf )  THEN
4014          CALL read_sounding_data
4015          CALL read_trace_gas_data
4016       ENDIF
4017
4018
4019       IF ( average_radiation ) THEN
4020!
4021!--       Determine minimum topography top index.
4022          k_topo_l = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
4023#if defined( __parallel )
4024          CALL MPI_ALLREDUCE( k_topo_l, k_topo, 1, MPI_INTEGER, MPI_MIN, &
4025                              comm2d, ierr)
4026#else
4027          k_topo = k_topo_l
4028#endif
4029       
4030          rrtm_asdir(1)  = albedo_urb
4031          rrtm_asdif(1)  = albedo_urb
4032          rrtm_aldir(1)  = albedo_urb
4033          rrtm_aldif(1)  = albedo_urb
4034
4035          rrtm_emis = emissivity_urb
4036!
4037!--       Calculate mean pt profile.
4038          CALL calc_mean_profile( pt, 4 )
4039          pt_av = hom(:, 1, 4, 0)
4040         
4041          IF ( humidity )  THEN
4042             CALL calc_mean_profile( q, 41 )
4043             q_av  = hom(:, 1, 41, 0)
4044          ENDIF
4045!
4046!--       Prepare profiles of temperature and H2O volume mixing ratio
4047          rrtm_tlev(0,k_topo+1) = t_rad_urb
4048
4049          IF ( bulk_cloud_model )  THEN
4050
4051             CALL calc_mean_profile( ql, 54 )
4052             ! average ql is now in hom(:, 1, 54, 0)
4053             ql_av = hom(:, 1, 54, 0)
4054             
4055             DO k = nzb+1, nzt+1
4056                rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp       &
4057                                 )**.286_wp + lv_d_cp * ql_av(k)
4058                rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q_av(k) - ql_av(k))
4059             ENDDO
4060          ELSE
4061             DO k = nzb+1, nzt+1
4062                rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp       &
4063                                 )**.286_wp
4064             ENDDO
4065
4066             IF ( humidity )  THEN
4067                DO k = nzb+1, nzt+1
4068                   rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q_av(k)
4069                ENDDO
4070             ELSE
4071                rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp
4072             ENDIF
4073          ENDIF
4074
4075!
4076!--       Avoid temperature/humidity jumps at the top of the PALM domain by
4077!--       linear interpolation from nzt+2 to nzt+7. Jumps are induced by
4078!--       discrepancies between the values in the  domain and those above that
4079!--       are prescribed in RRTMG
4080          DO k = nzt+2, nzt+7
4081             rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1)                            &
4082                           + ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) )    &
4083                           / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )    &
4084                           * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
4085
4086             rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1)                        &
4087                           + ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )&
4088                           / ( rrtm_play(0,nzt+8)   - rrtm_play(0,nzt+1)   )&
4089                           * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) )
4090
4091          ENDDO
4092
4093!--       Linear interpolate to zw grid. Loop reaches one level further up
4094!--       due to the staggered grid in RRTMG
4095          DO k = k_topo+2, nzt+8
4096             rrtm_tlev(0,k)   = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) -        &
4097                                rrtm_tlay(0,k-1))                           &
4098                                / ( rrtm_play(0,k) - rrtm_play(0,k-1) )     &
4099                                * ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
4100          ENDDO
4101!
4102!--       Calculate liquid water path and cloud fraction for each column.
4103!--       Note that LWP is required in g/m2 instead of kg/kg m.
4104          rrtm_cldfr  = 0.0_wp
4105          rrtm_reliq  = 0.0_wp
4106          rrtm_cliqwp = 0.0_wp
4107          rrtm_icld   = 0
4108
4109          IF ( bulk_cloud_model )  THEN
4110             DO k = nzb+1, nzt+1
4111                rrtm_cliqwp(0,k) =  ql_av(k) * 1000._wp *                   &
4112                                    (rrtm_plev(0,k) - rrtm_plev(0,k+1))     &
4113                                    * 100._wp / g 
4114
4115                IF ( rrtm_cliqwp(0,k) > 0._wp )  THEN
4116                   rrtm_cldfr(0,k) = 1._wp
4117                   IF ( rrtm_icld == 0 )  rrtm_icld = 1
4118
4119!
4120!--                Calculate cloud droplet effective radius
4121                   rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql_av(k)         &
4122                                     * rho_surface                          &
4123                                     / ( 4.0_wp * pi * nc_const * rho_l )   &
4124                                     )**0.33333333333333_wp                 &
4125                                     * EXP( LOG( sigma_gc )**2 )
4126!
4127!--                Limit effective radius
4128                   IF ( rrtm_reliq(0,k) > 0.0_wp )  THEN
4129                      rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp)
4130                      rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp)
4131                   ENDIF
4132                ENDIF
4133             ENDDO
4134          ENDIF
4135
4136!
4137!--       Set surface temperature
4138          rrtm_tsfc = t_rad_urb
4139         
4140          IF ( lw_radiation )  THEN 
4141!
4142!--          Due to technical reasons, copy optical depth to dummy arguments
4143!--          which are allocated on the exact size as the rrtmg_lw is called.
4144!--          As one dimesion is allocated with zero size, compiler complains
4145!--          that rank of the array does not match that of the
4146!--          assumed-shaped arguments in the RRTMG library. In order to
4147!--          avoid this, write to dummy arguments and give pass the entire
4148!--          dummy array. Seems to be the only existing work-around. 
4149             ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) )
4150             ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) )
4151
4152             rrtm_lw_taucld_dum =                                              &
4153                             rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1)
4154             rrtm_lw_tauaer_dum =                                              &
4155                             rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1)
4156         
4157             CALL rrtmg_lw( 1,                                                 &                                       
4158                            nzt_rad-k_topo,                                    &
4159                            rrtm_icld,                                         &
4160                            rrtm_idrv,                                         &
4161                            rrtm_play(:,k_topo+1:),                   &
4162                            rrtm_plev(:,k_topo+1:),                   &
4163                            rrtm_tlay(:,k_topo+1:),                   &
4164                            rrtm_tlev(:,k_topo+1:),                   &
4165                            rrtm_tsfc,                                         &
4166                            rrtm_h2ovmr(:,k_topo+1:),                 &
4167                            rrtm_o3vmr(:,k_topo+1:),                  &
4168                            rrtm_co2vmr(:,k_topo+1:),                 &
4169                            rrtm_ch4vmr(:,k_topo+1:),                 &
4170                            rrtm_n2ovmr(:,k_topo+1:),                 &
4171                            rrtm_o2vmr(:,k_topo+1:),                  &
4172                            rrtm_cfc11vmr(:,k_topo+1:),               &
4173                            rrtm_cfc12vmr(:,k_topo+1:),               &
4174                            rrtm_cfc22vmr(:,k_topo+1:),               &
4175                            rrtm_ccl4vmr(:,k_topo+1:),                &
4176                            rrtm_emis,                                         &
4177                            rrtm_inflglw,                                      &
4178                            rrtm_iceflglw,                                     &
4179                            rrtm_liqflglw,                                     &
4180                            rrtm_cldfr(:,k_topo+1:),                  &
4181                            rrtm_lw_taucld_dum,                                &
4182                            rrtm_cicewp(:,k_topo+1:),                 &
4183                            rrtm_cliqwp(:,k_topo+1:),                 &
4184                            rrtm_reice(:,k_topo+1:),                  & 
4185                            rrtm_reliq(:,k_topo+1:),                  &
4186                            rrtm_lw_tauaer_dum,                                &
4187                            rrtm_lwuflx(:,k_topo:),                   &
4188                            rrtm_lwdflx(:,k_topo:),                   &
4189                            rrtm_lwhr(:,k_topo+1:),                   &
4190                            rrtm_lwuflxc(:,k_topo:),                  &
4191                            rrtm_lwdflxc(:,k_topo:),                  &
4192                            rrtm_lwhrc(:,k_topo+1:),                  &
4193                            rrtm_lwuflx_dt(:,k_topo:),                &
4194                            rrtm_lwuflxc_dt(:,k_topo:) )
4195                           
4196             DEALLOCATE ( rrtm_lw_taucld_dum )
4197             DEALLOCATE ( rrtm_lw_tauaer_dum )
4198!
4199!--          Save fluxes
4200             DO k = nzb, nzt+1
4201                rad_lw_in(k,:,:)  = rrtm_lwdflx(0,k)
4202                rad_lw_out(k,:,:) = rrtm_lwuflx(0,k)
4203             ENDDO
4204             rad_lw_in_diff(:,:) = rad_lw_in(k_topo,:,:)
4205!
4206!--          Save heating rates (convert from K/d to K/h).
4207!--          Further, even though an aggregated radiation is computed, map
4208!--          signle-column profiles on top of any topography, in order to
4209!--          obtain correct near surface radiation heating/cooling rates.
4210             DO  i = nxl, nxr
4211                DO  j = nys, nyn
4212                   k_topo_l = topo_top_ind(j,i,0)
4213                   DO k = k_topo_l+1, nzt+1
4214                      rad_lw_hr(k,j,i)     = rrtm_lwhr(0,k-k_topo_l)  * d_hours_day
4215                      rad_lw_cs_hr(k,j,i)  = rrtm_lwhrc(0,k-k_topo_l) * d_hours_day
4216                   ENDDO
4217                ENDDO
4218             ENDDO
4219
4220          ENDIF
4221
4222          IF ( sw_radiation .AND. sun_up )  THEN
4223!
4224!--          Due to technical reasons, copy optical depths and other
4225!--          to dummy arguments which are allocated on the exact size as the
4226!--          rrtmg_sw is called.
4227!--          As one dimesion is allocated with zero size, compiler complains
4228!--          that rank of the array does not match that of the
4229!--          assumed-shaped arguments in the RRTMG library. In order to
4230!--          avoid this, write to dummy arguments and give pass the entire
4231!--          dummy array. Seems to be the only existing work-around. 
4232             ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4233             ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4234             ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4235             ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4236             ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4237             ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4238             ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4239             ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1)  )
4240     
4241             rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4242             rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4243             rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4244             rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4245             rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4246             rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4247             rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4248             rrtm_sw_ecaer_dum  = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1)
4249
4250             CALL rrtmg_sw( 1,                                                 &
4251                            nzt_rad-k_topo,                                    &
4252                            rrtm_icld,                                         &
4253                            rrtm_iaer,                                         &
4254                            rrtm_play(:,k_topo+1:nzt_rad+1),                   &
4255                            rrtm_plev(:,k_topo+1:nzt_rad+2),                   &
4256                            rrtm_tlay(:,k_topo+1:nzt_rad+1),                   &
4257                            rrtm_tlev(:,k_topo+1:nzt_rad+2),                   &
4258                            rrtm_tsfc,                                         &
4259                            rrtm_h2ovmr(:,k_topo+1:nzt_rad+1),                 &                               
4260                            rrtm_o3vmr(:,k_topo+1:nzt_rad+1),                  &       
4261                            rrtm_co2vmr(:,k_topo+1:nzt_rad+1),                 &
4262                            rrtm_ch4vmr(:,k_topo+1:nzt_rad+1),                 &
4263                            rrtm_n2ovmr(:,k_topo+1:nzt_rad+1),                 &
4264                            rrtm_o2vmr(:,k_topo+1:nzt_rad+1),                  &
4265                            rrtm_asdir,                                        & 
4266                            rrtm_asdif,                                        &
4267                            rrtm_aldir,                                        &
4268                            rrtm_aldif,                                        &
4269                            zenith,                                            &
4270                            0.0_wp,                                            &
4271                            day_of_year,                                       &
4272                            solar_constant,                                    &
4273                            rrtm_inflgsw,                                      &
4274                            rrtm_iceflgsw,                                     &
4275                            rrtm_liqflgsw,                                     &
4276                            rrtm_cldfr(:,k_topo+1:nzt_rad+1),                  &
4277                            rrtm_sw_taucld_dum,                                &
4278                            rrtm_sw_ssacld_dum,                                &
4279                            rrtm_sw_asmcld_dum,                                &
4280                            rrtm_sw_fsfcld_dum,                                &
4281                            rrtm_cicewp(:,k_topo+1:nzt_rad+1),                 &
4282                            rrtm_cliqwp(:,k_topo+1:nzt_rad+1),                 &
4283                            rrtm_reice(:,k_topo+1:nzt_rad+1),                  &
4284                            rrtm_reliq(:,k_topo+1:nzt_rad+1),                  &
4285                            rrtm_sw_tauaer_dum,                                &
4286                            rrtm_sw_ssaaer_dum,                                &
4287                            rrtm_sw_asmaer_dum,                                &
4288                            rrtm_sw_ecaer_dum,                                 &
4289                            rrtm_swuflx(:,k_topo:nzt_rad+1),                   & 
4290                            rrtm_swdflx(:,k_topo:nzt_rad+1),                   & 
4291                            rrtm_swhr(:,k_topo+1:nzt_rad+1),                   & 
4292                            rrtm_swuflxc(:,k_topo:nzt_rad+1),                  & 
4293                            rrtm_swdflxc(:,k_topo:nzt_rad+1),                  &
4294                            rrtm_swhrc(:,k_topo+1:nzt_rad+1),                  &
4295                            rrtm_dirdflux(:,k_topo:nzt_rad+1),                 &
4296                            rrtm_difdflux(:,k_topo:nzt_rad+1) )
4297                           
4298             DEALLOCATE( rrtm_sw_taucld_dum )
4299             DEALLOCATE( rrtm_sw_ssacld_dum )
4300             DEALLOCATE( rrtm_sw_asmcld_dum )
4301             DEALLOCATE( rrtm_sw_fsfcld_dum )
4302             DEALLOCATE( rrtm_sw_tauaer_dum )
4303             DEALLOCATE( rrtm_sw_ssaaer_dum )
4304             DEALLOCATE( rrtm_sw_asmaer_dum )
4305             DEALLOCATE( rrtm_sw_ecaer_dum )
4306 
4307!
4308!--          Save radiation fluxes for the entire depth of the model domain
4309             DO k = nzb, nzt+1
4310                rad_sw_in(k,:,:)  = rrtm_swdflx(0,k)
4311                rad_sw_out(k,:,:) = rrtm_swuflx(0,k)
4312             ENDDO
4313!--          Save direct and diffuse SW radiation at the surface (required by RTM)
4314             rad_sw_in_dir(:,:) = rrtm_dirdflux(0,k_topo)
4315             rad_sw_in_diff(:,:) = rrtm_difdflux(0,k_topo)
4316
4317!
4318!--          Save heating rates (convert from K/d to K/s)
4319             DO k = nzb+1, nzt+1
4320                rad_sw_hr(k,:,:)     = rrtm_swhr(0,k)  * d_hours_day
4321                rad_sw_cs_hr(k,:,:)  = rrtm_swhrc(0,k) * d_hours_day
4322             ENDDO
4323!
4324!--       Solar radiation is zero during night
4325          ELSE
4326             rad_sw_in  = 0.0_wp
4327             rad_sw_out = 0.0_wp
4328             rad_sw_in_dir(:,:) = 0.0_wp
4329             rad_sw_in_diff(:,:) = 0.0_wp
4330          ENDIF
4331!
4332!--    RRTMG is called for each (j,i) grid point separately, starting at the
4333!--    highest topography level. Here no RTM is used since average_radiation is false
4334       ELSE
4335!
4336!--       Loop over all grid points
4337          DO i = nxl, nxr
4338             DO j = nys, nyn
4339
4340!
4341!--             Prepare profiles of temperature and H2O volume mixing ratio
4342                DO  m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
4343                   rrtm_tlev(0,nzb+1) = surf_lsm_h%pt_surface(m) * exner(nzb)
4344                ENDDO
4345                DO  m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
4346                   rrtm_tlev(0,nzb+1) = surf_usm_h%pt_surface(m) * exner(nzb)
4347                ENDDO
4348
4349
4350                IF ( bulk_cloud_model )  THEN
4351                   DO k = nzb+1, nzt+1
4352                      rrtm_tlay(0,k) = pt(k,j,i) * exner(k)                    &
4353                                        + lv_d_cp * ql(k,j,i)
4354                      rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q(k,j,i) - ql(k,j,i))
4355                   ENDDO
4356                ELSEIF ( cloud_droplets )  THEN
4357                   DO k = nzb+1, nzt+1
4358                      rrtm_tlay(0,k) = pt(k,j,i) * exner(k)                     &
4359                                        + lv_d_cp * ql(k,j,i)
4360                      rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i) 
4361                   ENDDO
4362                ELSE
4363                   DO k = nzb+1, nzt+1
4364                      rrtm_tlay(0,k) = pt(k,j,i) * exner(k)
4365                   ENDDO
4366
4367                   IF ( humidity )  THEN
4368                      DO k = nzb+1, nzt+1
4369                         rrtm_h2ovmr(0,k) =  mol_mass_air_d_wv * q(k,j,i)
4370                      ENDDO   
4371                   ELSE
4372                      rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp
4373                   ENDIF
4374                ENDIF
4375
4376!
4377!--             Avoid temperature/humidity jumps at the top of the LES domain by
4378!--             linear interpolation from nzt+2 to nzt+7
4379                DO k = nzt+2, nzt+7
4380                   rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1)                         &
4381                                 + ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) &
4382                                 / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) &
4383                                 * ( rrtm_play(0,k)     - rrtm_play(0,nzt+1) )
4384
4385                   rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1)                     &
4386                              + ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )&
4387                              / ( rrtm_play(0,nzt+8)   - rrtm_play(0,nzt+1)   )&
4388                              * ( rrtm_play(0,k)       - rrtm_play(0,nzt+1) )
4389
4390                ENDDO
4391
4392!--             Linear interpolate to zw grid
4393                DO k = nzb+2, nzt+8
4394                   rrtm_tlev(0,k)   = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) -     &
4395                                      rrtm_tlay(0,k-1))                        &
4396                                      / ( rrtm_play(0,k) - rrtm_play(0,k-1) )  &
4397                                      * ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
4398                ENDDO
4399
4400
4401!
4402!--             Calculate liquid water path and cloud fraction for each column.
4403!--             Note that LWP is required in g/m2 instead of kg/kg m.
4404                rrtm_cldfr  = 0.0_wp
4405                rrtm_reliq  = 0.0_wp
4406                rrtm_cliqwp = 0.0_wp
4407                rrtm_icld   = 0
4408
4409                IF ( bulk_cloud_model  .OR.  cloud_droplets )  THEN
4410                   DO k = nzb+1, nzt+1
4411                      rrtm_cliqwp(0,k) =  ql(k,j,i) * 1000.0_wp *              &
4412                                          (rrtm_plev(0,k) - rrtm_plev(0,k+1))  &
4413                                          * 100.0_wp / g 
4414
4415                      IF ( rrtm_cliqwp(0,k) > 0.0_wp )  THEN
4416                         rrtm_cldfr(0,k) = 1.0_wp
4417                         IF ( rrtm_icld == 0 )  rrtm_icld = 1
4418
4419!
4420!--                      Calculate cloud droplet effective radius
4421                         IF ( bulk_cloud_model )  THEN
4422!
4423!--                         Calculete effective droplet radius. In case of using
4424!--                         cloud_scheme = 'morrison' and a non reasonable number
4425!--                         of cloud droplets the inital aerosol number 
4426!--                         concentration is considered.
4427                            IF ( microphysics_morrison )  THEN
4428                               IF ( nc(k,j,i) > 1.0E-20_wp )  THEN
4429                                  nc_rad = nc(k,j,i)
4430                               ELSE
4431                                  nc_rad = na_init
4432                               ENDIF
4433                            ELSE
4434                               nc_rad = nc_const
4435                            ENDIF 
4436
4437                            rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql(k,j,i)     &
4438                                              * rho_surface                       &
4439                                              / ( 4.0_wp * pi * nc_rad * rho_l )  &
4440                                              )**0.33333333333333_wp              &
4441                                              * EXP( LOG( sigma_gc )**2 )
4442
4443                         ELSEIF ( cloud_droplets )  THEN
4444                            number_of_particles = prt_count(k,j,i)
4445
4446                            IF (number_of_particles <= 0)  CYCLE
4447                            particles => grid_particles(k,j,i)%particles(1:number_of_particles)
4448                            s_r2 = 0.0_wp
4449                            s_r3 = 0.0_wp
4450
4451                            DO  n = 1, number_of_particles
4452                               IF ( particles(n)%particle_mask )  THEN
4453                                  s_r2 = s_r2 + particles(n)%radius**2 *       &
4454                                         particles(n)%weight_factor
4455                                  s_r3 = s_r3 + particles(n)%radius**3 *       &
4456                                         particles(n)%weight_factor
4457                               ENDIF
4458                            ENDDO
4459
4460                            IF ( s_r2 > 0.0_wp )  rrtm_reliq(0,k) = s_r3 / s_r2
4461
4462                         ENDIF
4463
4464!
4465!--                      Limit effective radius
4466                         IF ( rrtm_reliq(0,k) > 0.0_wp )  THEN
4467                            rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp)
4468                            rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp)
4469                        ENDIF
4470                      ENDIF
4471                   ENDDO
4472                ENDIF
4473
4474!
4475!--             Write surface emissivity and surface temperature at current
4476!--             surface element on RRTMG-shaped array.
4477!--             Please note, as RRTMG is a single column model, surface attributes
4478!--             are only obtained from horizontally aligned surfaces (for
4479!--             simplicity). Taking surface attributes from horizontal and
4480!--             vertical walls would lead to multiple solutions. 
4481!--             Moreover, for natural- and urban-type surfaces, several surface
4482!--             classes can exist at a surface element next to each other.
4483!--             To obtain bulk parameters, apply a weighted average for these
4484!--             surfaces.
4485                DO  m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
4486                   rrtm_emis = surf_lsm_h%frac(ind_veg_wall,m)  *              &
4487                               surf_lsm_h%emissivity(ind_veg_wall,m)  +        &
4488                               surf_lsm_h%frac(ind_pav_green,m) *              &
4489                               surf_lsm_h%emissivity(ind_pav_green,m) +        & 
4490                               surf_lsm_h%frac(ind_wat_win,m)   *              &
4491                               surf_lsm_h%emissivity(ind_wat_win,m)
4492                   rrtm_tsfc = surf_lsm_h%pt_surface(m) * exner(nzb)
4493                ENDDO             
4494                DO  m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
4495                   rrtm_emis = surf_usm_h%frac(ind_veg_wall,m)  *              &
4496                               surf_usm_h%emissivity(ind_veg_wall,m)  +        &
4497                               surf_usm_h%frac(ind_pav_green,m) *              &
4498                               surf_usm_h%emissivity(ind_pav_green,m) +        & 
4499                               surf_usm_h%frac(ind_wat_win,m)   *              &
4500                               surf_usm_h%emissivity(ind_wat_win,m)
4501                   rrtm_tsfc = surf_usm_h%pt_surface(m) * exner(nzb)
4502                ENDDO
4503!
4504!--             Obtain topography top index (lower bound of RRTMG)
4505                k_topo = topo_top_ind(j,i,0)
4506
4507                IF ( lw_radiation )  THEN
4508!
4509!--                Due to technical reasons, copy optical depth to dummy arguments
4510!--                which are allocated on the exact size as the rrtmg_lw is called.
4511!--                As one dimesion is allocated with zero size, compiler complains
4512!--                that rank of the array does not match that of the
4513!--                assumed-shaped arguments in the RRTMG library. In order to
4514!--                avoid this, write to dummy arguments and give pass the entire
4515!--                dummy array. Seems to be the only existing work-around. 
4516                   ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) )
4517                   ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) )
4518
4519                   rrtm_lw_taucld_dum =                                        &
4520                               rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1)
4521                   rrtm_lw_tauaer_dum =                                        &
4522                               rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1)
4523
4524                   CALL rrtmg_lw( 1,                                           &                                       
4525                                  nzt_rad-k_topo,                              &
4526                                  rrtm_icld,                                   &
4527                                  rrtm_idrv,                                   &
4528                                  rrtm_play(:,k_topo+1:nzt_rad+1),             &
4529                                  rrtm_plev(:,k_topo+1:nzt_rad+2),             &
4530                                  rrtm_tlay(:,k_topo+1:nzt_rad+1),             &
4531                                  rrtm_tlev(:,k_topo+1:nzt_rad+2),             &
4532                                  rrtm_tsfc,                                   &
4533                                  rrtm_h2ovmr(:,k_topo+1:nzt_rad+1),           &
4534                                  rrtm_o3vmr(:,k_topo+1:nzt_rad+1),            &
4535                                  rrtm_co2vmr(:,k_topo+1:nzt_rad+1),           &
4536                                  rrtm_ch4vmr(:,k_topo+1:nzt_rad+1),           &
4537                                  rrtm_n2ovmr(:,k_topo+1:nzt_rad+1),           &
4538                                  rrtm_o2vmr(:,k_topo+1:nzt_rad+1),            &
4539                                  rrtm_cfc11vmr(:,k_topo+1:nzt_rad+1),         &
4540                                  rrtm_cfc12vmr(:,k_topo+1:nzt_rad+1),         &
4541                                  rrtm_cfc22vmr(:,k_topo+1:nzt_rad+1),         &
4542                                  rrtm_ccl4vmr(:,k_topo+1:nzt_rad+1),          &
4543                                  rrtm_emis,                                   &
4544                                  rrtm_inflglw,                                &
4545                                  rrtm_iceflglw,                               &
4546                                  rrtm_liqflglw,                               &
4547                                  rrtm_cldfr(:,k_topo+1:nzt_rad+1),            &
4548                                  rrtm_lw_taucld_dum,                          &
4549                                  rrtm_cicewp(:,k_topo+1:nzt_rad+1),           &
4550                                  rrtm_cliqwp(:,k_topo+1:nzt_rad+1),           &
4551                                  rrtm_reice(:,k_topo+1:nzt_rad+1),            & 
4552                                  rrtm_reliq(:,k_topo+1:nzt_rad+1),            &
4553                                  rrtm_lw_tauaer_dum,                          &
4554                                  rrtm_lwuflx(:,k_topo:nzt_rad+1),             &
4555                                  rrtm_lwdflx(:,k_topo:nzt_rad+1),             &
4556                                  rrtm_lwhr(:,k_topo+1:nzt_rad+1),             &
4557                                  rrtm_lwuflxc(:,k_topo:nzt_rad+1),            &
4558                                  rrtm_lwdflxc(:,k_topo:nzt_rad+1),            &
4559                                  rrtm_lwhrc(:,k_topo+1:nzt_rad+1),            &
4560                                  rrtm_lwuflx_dt(:,k_topo:nzt_rad+1),          &
4561                                  rrtm_lwuflxc_dt(:,k_topo:nzt_rad+1) )
4562
4563                   DEALLOCATE ( rrtm_lw_taucld_dum )
4564                   DEALLOCATE ( rrtm_lw_tauaer_dum )
4565!
4566!--                Save fluxes
4567                   DO k = k_topo, nzt+1
4568                      rad_lw_in(k,j,i)  = rrtm_lwdflx(0,k)
4569                      rad_lw_out(k,j,i) = rrtm_lwuflx(0,k)
4570                   ENDDO
4571
4572!
4573!--                Save heating rates (convert from K/d to K/h)
4574                   DO k = k_topo+1, nzt+1
4575                      rad_lw_hr(k,j,i)     = rrtm_lwhr(0,k-k_topo)  * d_hours_day
4576                      rad_lw_cs_hr(k,j,i)  = rrtm_lwhrc(0,k-k_topo) * d_hours_day
4577                   ENDDO
4578
4579!
4580!--                Save surface radiative fluxes and change in LW heating rate
4581!--                onto respective surface elements
4582!--                Horizontal surfaces
4583                   DO  m = surf_lsm_h%start_index(j,i),                        &
4584                           surf_lsm_h%end_index(j,i)
4585                      surf_lsm_h%rad_lw_in(m)           = rrtm_lwdflx(0,k_topo)
4586                      surf_lsm_h%rad_lw_out(m)          = rrtm_lwuflx(0,k_topo)
4587                      surf_lsm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo)
4588                   ENDDO             
4589                   DO  m = surf_usm_h%start_index(j,i),                        &
4590                           surf_usm_h%end_index(j,i)
4591                      surf_usm_h%rad_lw_in(m)           = rrtm_lwdflx(0,k_topo)
4592                      surf_usm_h%rad_lw_out(m)          = rrtm_lwuflx(0,k_topo)
4593                      surf_usm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo)
4594                   ENDDO 
4595!
4596!--                Vertical surfaces. Fluxes are obtain at vertical level of the
4597!--                respective surface element
4598                   DO  l = 0, 3
4599                      DO  m = surf_lsm_v(l)%start_index(j,i),                  &
4600                              surf_lsm_v(l)%end_index(j,i)
4601                         k                                    = surf_lsm_v(l)%k(m)
4602                         surf_lsm_v(l)%rad_lw_in(m)           = rrtm_lwdflx(0,k)
4603                         surf_lsm_v(l)%rad_lw_out(m)          = rrtm_lwuflx(0,k)
4604                         surf_lsm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
4605                      ENDDO             
4606                      DO  m = surf_usm_v(l)%start_index(j,i),                  &
4607                              surf_usm_v(l)%end_index(j,i)
4608                         k                                    = surf_usm_v(l)%k(m)
4609                         surf_usm_v(l)%rad_lw_in(m)           = rrtm_lwdflx(0,k)
4610                         surf_usm_v(l)%rad_lw_out(m)          = rrtm_lwuflx(0,k)
4611                         surf_usm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k)
4612                      ENDDO 
4613                   ENDDO
4614
4615                ENDIF
4616
4617                IF ( sw_radiation .AND. sun_up )  THEN
4618!
4619!--                Get albedo for direct/diffusive long/shortwave radiation at
4620!--                current (y,x)-location from surface variables.
4621!--                Only obtain it from horizontal surfaces, as RRTMG is a single
4622!--                column model
4623!--                (Please note, only one loop will entered, controlled by
4624!--                start-end index.)
4625                   DO  m = surf_lsm_h%start_index(j,i),                        &
4626                           surf_lsm_h%end_index(j,i)
4627                      rrtm_asdir(1)  = SUM( surf_lsm_h%frac(:,m) *             &
4628                                            surf_lsm_h%rrtm_asdir(:,m) )
4629                      rrtm_asdif(1)  = SUM( surf_lsm_h%frac(:,m) *             &
4630                                            surf_lsm_h%rrtm_asdif(:,m) )
4631                      rrtm_aldir(1)  = SUM( surf_lsm_h%frac(:,m) *             &
4632                                            surf_lsm_h%rrtm_aldir(:,m) )
4633                      rrtm_aldif(1)  = SUM( surf_lsm_h%frac(:,m) *             &
4634                                            surf_lsm_h%rrtm_aldif(:,m) )
4635                   ENDDO             
4636                   DO  m = surf_usm_h%start_index(j,i),                        &
4637                           surf_usm_h%end_index(j,i)
4638                      rrtm_asdir(1)  = SUM( surf_usm_h%frac(:,m) *             &
4639                                            surf_usm_h%rrtm_asdir(:,m) )
4640                      rrtm_asdif(1)  = SUM( surf_usm_h%frac(:,m) *             &
4641                                            surf_usm_h%rrtm_asdif(:,m) )
4642                      rrtm_aldir(1)  = SUM( surf_usm_h%frac(:,m) *             &
4643                                            surf_usm_h%rrtm_aldir(:,m) )
4644                      rrtm_aldif(1)  = SUM( surf_usm_h%frac(:,m) *             &
4645                                            surf_usm_h%rrtm_aldif(:,m) )
4646                   ENDDO
4647!
4648!--                Due to technical reasons, copy optical depths and other
4649!--                to dummy arguments which are allocated on the exact size as the
4650!--                rrtmg_sw is called.
4651!--                As one dimesion is allocated with zero size, compiler complains
4652!--                that rank of the array does not match that of the
4653!--                assumed-shaped arguments in the RRTMG library. In order to
4654!--                avoid this, write to dummy arguments and give pass the entire
4655!--                dummy array. Seems to be the only existing work-around. 
4656                   ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4657                   ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4658                   ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4659                   ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) )
4660                   ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4661                   ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4662                   ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) )
4663                   ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1)  )
4664     
4665                   rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4666                   rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4667                   rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4668                   rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1)
4669                   rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4670                   rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4671                   rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1)
4672                   rrtm_sw_ecaer_dum  = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1)
4673
4674                   CALL rrtmg_sw( 1,                                           &
4675                                  nzt_rad-k_topo,                              &
4676                                  rrtm_icld,                                   &
4677                                  rrtm_iaer,                                   &
4678                                  rrtm_play(:,k_topo+1:nzt_rad+1),             &
4679                                  rrtm_plev(:,k_topo+1:nzt_rad+2),             &
4680                                  rrtm_tlay(:,k_topo+1:nzt_rad+1),             &
4681                                  rrtm_tlev(:,k_topo+1:nzt_rad+2),             &
4682                                  rrtm_tsfc,                                   &
4683                                  rrtm_h2ovmr(:,k_topo+1:nzt_rad+1),           &                               
4684                                  rrtm_o3vmr(:,k_topo+1:nzt_rad+1),            &       
4685                                  rrtm_co2vmr(:,k_topo+1:nzt_rad+1),           &
4686                                  rrtm_ch4vmr(:,k_topo+1:nzt_rad+1),           &
4687                                  rrtm_n2ovmr(:,k_topo+1:nzt_rad+1),           &
4688                                  rrtm_o2vmr(:,k_topo+1:nzt_rad+1),            &
4689                                  rrtm_asdir,                                  & 
4690                                  rrtm_asdif,                                  &
4691                                  rrtm_aldir,                                  &
4692                                  rrtm_aldif,                                  &
4693                                  zenith,                                      &
4694                                  0.0_wp,                                      &
4695                                  day_of_year,                                 &
4696                                  solar_constant,                              &
4697                                  rrtm_inflgsw,                                &
4698                                  rrtm_iceflgsw,                               &
4699                                  rrtm_liqflgsw,                               &
4700                                  rrtm_cldfr(:,k_topo+1:nzt_rad+1),            &
4701                                  rrtm_sw_taucld_dum,                          &
4702                                  rrtm_sw_ssacld_dum,                          &
4703                                  rrtm_sw_asmcld_dum,                          &
4704                                  rrtm_sw_fsfcld_dum,                          &
4705                                  rrtm_cicewp(:,k_topo+1:nzt_rad+1),           &
4706                                  rrtm_cliqwp(:,k_topo+1:nzt_rad+1),           &
4707                                  rrtm_reice(:,k_topo+1:nzt_rad+1),            &
4708                                  rrtm_reliq(:,k_topo+1:nzt_rad+1),            &
4709                                  rrtm_sw_tauaer_dum,                          &
4710                                  rrtm_sw_ssaaer_dum,                          &
4711                                  rrtm_sw_asmaer_dum,                          &
4712                                  rrtm_sw_ecaer_dum,                           &
4713                                  rrtm_swuflx(:,k_topo:nzt_rad+1),             & 
4714                                  rrtm_swdflx(:,k_topo:nzt_rad+1),             & 
4715                                  rrtm_swhr(:,k_topo+1:nzt_rad+1),             & 
4716                                  rrtm_swuflxc(:,k_topo:nzt_rad+1),            & 
4717                                  rrtm_swdflxc(:,k_topo:nzt_rad+1),            &
4718                                  rrtm_swhrc(:,k_topo+1:nzt_rad+1),            &
4719                                  rrtm_dirdflux(:,k_topo:nzt_rad+1),           &
4720                                  rrtm_difdflux(:,k_topo:nzt_rad+1) )
4721
4722                   DEALLOCATE( rrtm_sw_taucld_dum )
4723                   DEALLOCATE( rrtm_sw_ssacld_dum )
4724                   DEALLOCATE( rrtm_sw_asmcld_dum )
4725                   DEALLOCATE( rrtm_sw_fsfcld_dum )
4726                   DEALLOCATE( rrtm_sw_tauaer_dum )
4727                   DEALLOCATE( rrtm_sw_ssaaer_dum )
4728                   DEALLOCATE( rrtm_sw_asmaer_dum )
4729                   DEALLOCATE( rrtm_sw_ecaer_dum )
4730!
4731!--                Save fluxes
4732                   DO k = nzb, nzt+1
4733                      rad_sw_in(k,j,i)  = rrtm_swdflx(0,k)
4734                      rad_sw_out(k,j,i) = rrtm_swuflx(0,k)
4735                   ENDDO
4736!
4737!--                Save heating rates (convert from K/d to K/s)
4738                   DO k = nzb+1, nzt+1
4739                      rad_sw_hr(k,j,i)     = rrtm_swhr(0,k)  * d_hours_day
4740                      rad_sw_cs_hr(k,j,i)  = rrtm_swhrc(0,k) * d_hours_day
4741                   ENDDO
4742
4743!
4744!--                Save surface radiative fluxes onto respective surface elements
4745!--                Horizontal surfaces
4746                   DO  m = surf_lsm_h%start_index(j,i),                        &
4747                           surf_lsm_h%end_index(j,i)
4748                      surf_lsm_h%rad_sw_in(m)     = rrtm_swdflx(0,k_topo)
4749                      surf_lsm_h%rad_sw_out(m)    = rrtm_swuflx(0,k_topo)
4750                   ENDDO             
4751                   DO  m = surf_usm_h%start_index(j,i),                        &
4752                           surf_usm_h%end_index(j,i)
4753                      surf_usm_h%rad_sw_in(m)     = rrtm_swdflx(0,k_topo)
4754                      surf_usm_h%rad_sw_out(m)    = rrtm_swuflx(0,k_topo)
4755                   ENDDO 
4756!
4757!--                Vertical surfaces. Fluxes are obtain at respective vertical
4758!--                level of the surface element
4759                   DO  l = 0, 3
4760                      DO  m = surf_lsm_v(l)%start_index(j,i),                  &
4761                              surf_lsm_v(l)%end_index(j,i)
4762                         k                           = surf_lsm_v(l)%k(m)
4763                         surf_lsm_v(l)%rad_sw_in(m)  = rrtm_swdflx(0,k)
4764                         surf_lsm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
4765                      ENDDO             
4766                      DO  m = surf_usm_v(l)%start_index(j,i),                  &
4767                              surf_usm_v(l)%end_index(j,i)
4768                         k                           = surf_usm_v(l)%k(m)
4769                         surf_usm_v(l)%rad_sw_in(m)  = rrtm_swdflx(0,k)
4770                         surf_usm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k)
4771                      ENDDO 
4772                   ENDDO
4773!
4774!--             Solar radiation is zero during night
4775                ELSE
4776                   rad_sw_in  = 0.0_wp
4777                   rad_sw_out = 0.0_wp
4778!--             !!!!!!!! ATTENSION !!!!!!!!!!!!!!!
4779!--             Surface radiative fluxes should be also set to zero here                 
4780!--                Save surface radiative fluxes onto respective surface elements
4781!--                Horizontal surfaces
4782                   DO  m = surf_lsm_h%start_index(j,i),                        &
4783                           surf_lsm_h%end_index(j,i)
4784                      surf_lsm_h%rad_sw_in(m)     = 0.0_wp
4785                      surf_lsm_h%rad_sw_out(m)    = 0.0_wp
4786                   ENDDO             
4787                   DO  m = surf_usm_h%start_index(j,i),                        &
4788                           surf_usm_h%end_index(j,i)
4789                      surf_usm_h%rad_sw_in(m)     = 0.0_wp
4790                      surf_usm_h%rad_sw_out(m)    = 0.0_wp
4791                   ENDDO 
4792!
4793!--                Vertical surfaces. Fluxes are obtain at respective vertical
4794!--                level of the surface element
4795                   DO  l = 0, 3
4796                      DO  m = surf_lsm_v(l)%start_index(j,i),                  &
4797                              surf_lsm_v(l)%end_index(j,i)
4798                         k                           = surf_lsm_v(l)%k(m)
4799                         surf_lsm_v(l)%rad_sw_in(m)  = 0.0_wp
4800                         surf_lsm_v(l)%rad_sw_out(m) = 0.0_wp
4801                      ENDDO             
4802                      DO  m = surf_usm_v(l)%start_index(j,i),                  &
4803                              surf_usm_v(l)%end_index(j,i)
4804                         k                           = surf_usm_v(l)%k(m)
4805                         surf_usm_v(l)%rad_sw_in(m)  = 0.0_wp
4806                         surf_usm_v(l)%rad_sw_out(m) = 0.0_wp
4807                      ENDDO 
4808                   ENDDO
4809                ENDIF
4810
4811             ENDDO
4812          ENDDO
4813
4814       ENDIF
4815!
4816!--    Finally, calculate surface net radiation for surface elements.
4817       IF (  .NOT.  radiation_interactions  ) THEN
4818!--       First, for horizontal surfaces   
4819          DO  m = 1, surf_lsm_h%ns
4820             surf_lsm_h%rad_net(m) = surf_lsm_h%rad_sw_in(m)                   &
4821                                   - surf_lsm_h%rad_sw_out(m)                  &
4822                                   + surf_lsm_h%rad_lw_in(m)                   &
4823                                   - surf_lsm_h%rad_lw_out(m)
4824          ENDDO
4825          DO  m = 1, surf_usm_h%ns
4826             surf_usm_h%rad_net(m) = surf_usm_h%rad_sw_in(m)                   &
4827                                   - surf_usm_h%rad_sw_out(m)                  &
4828                                   + surf_usm_h%rad_lw_in(m)                   &
4829                                   - surf_usm_h%rad_lw_out(m)
4830          ENDDO
4831!
4832!--       Vertical surfaces.
4833!--       Todo: weight with azimuth and zenith angle according to their orientation!
4834          DO  l = 0, 3     
4835             DO  m = 1, surf_lsm_v(l)%ns
4836                surf_lsm_v(l)%rad_net(m) = surf_lsm_v(l)%rad_sw_in(m)          &
4837                                         - surf_lsm_v(l)%rad_sw_out(m)         &
4838                                         + surf_lsm_v(l)%rad_lw_in(m)          &
4839                                         - surf_lsm_v(l)%rad_lw_out(m)
4840             ENDDO
4841             DO  m = 1, surf_usm_v(l)%ns
4842                surf_usm_v(l)%rad_net(m) = surf_usm_v(l)%rad_sw_in(m)          &
4843                                         - surf_usm_v(l)%rad_sw_out(m)         &
4844                                         + surf_usm_v(l)%rad_lw_in(m)          &
4845                                         - surf_usm_v(l)%rad_lw_out(m)
4846             ENDDO
4847          ENDDO
4848       ENDIF
4849
4850
4851       CALL exchange_horiz( rad_lw_in,  nbgp )
4852       CALL exchange_horiz( rad_lw_out, nbgp )
4853       CALL exchange_horiz( rad_lw_hr,    nbgp )
4854       CALL exchange_horiz( rad_lw_cs_hr, nbgp )
4855
4856       CALL exchange_horiz( rad_sw_in,  nbgp )
4857       CALL exchange_horiz( rad_sw_out, nbgp ) 
4858       CALL exchange_horiz( rad_sw_hr,    nbgp )
4859       CALL exchange_horiz( rad_sw_cs_hr, nbgp )
4860
4861#endif
4862
4863    END SUBROUTINE radiation_rrtmg
4864
4865
4866!------------------------------------------------------------------------------!
4867! Description:
4868! ------------
4869!> Calculate the cosine of the zenith angle (variable is called zenith)
4870!------------------------------------------------------------------------------!
4871    SUBROUTINE calc_zenith( day_of_year, second_of_day ) 
4872
4873       USE palm_date_time_mod,                                                 &
4874           ONLY:  seconds_per_day
4875
4876       IMPLICIT NONE
4877
4878       INTEGER(iwp), INTENT(IN) ::  day_of_year    !< day of the year
4879
4880       REAL(wp)                 ::  declination    !< solar declination angle
4881       REAL(wp)                 ::  hour_angle     !< solar hour angle
4882       REAL(wp),     INTENT(IN) ::  second_of_day  !< current time of the day in UTC
4883
4884!
4885!--    Calculate solar declination and hour angle
4886       declination = ASIN( decl_1 * SIN(decl_2 * REAL(day_of_year, KIND=wp) - decl_3) )
4887       hour_angle  = 2.0_wp * pi * ( second_of_day / seconds_per_day ) + lon - pi
4888
4889!
4890!--    Calculate cosine of solar zenith angle
4891       cos_zenith = SIN(lat) * SIN(declination) + COS(lat) * COS(declination)   &
4892                                            * COS(hour_angle)
4893       cos_zenith = MAX(0.0_wp,cos_zenith)
4894
4895!
4896!--    Calculate solar directional vector
4897       IF ( sun_direction )  THEN
4898
4899!
4900!--       Direction in longitudes equals to sin(solar_azimuth) * sin(zenith)
4901          sun_dir_lon = -SIN(hour_angle) * COS(declination)
4902
4903!
4904!--       Direction in latitues equals to cos(solar_azimuth) * sin(zenith)
4905          sun_dir_lat = SIN(declination) * COS(lat) - COS(hour_angle) &
4906                              * COS(declination) * SIN(lat)
4907       ENDIF
4908
4909!
4910!--    Check if the sun is up (otheriwse shortwave calculations can be skipped)
4911       IF ( cos_zenith > 0.0_wp )  THEN
4912          sun_up = .TRUE.
4913       ELSE
4914          sun_up = .FALSE.
4915       END IF
4916
4917    END SUBROUTINE calc_zenith
4918
4919#if defined ( __rrtmg ) && defined ( __netcdf )
4920!------------------------------------------------------------------------------!
4921! Description:
4922! ------------
4923!> Calculates surface albedo components based on Briegleb (1992) and
4924!> Briegleb et al. (1986)
4925!------------------------------------------------------------------------------!
4926    SUBROUTINE calc_albedo( surf )
4927
4928        IMPLICIT NONE
4929
4930        INTEGER(iwp)    ::  ind_type !< running index surface tiles
4931        INTEGER(iwp)    ::  m        !< running index surface elements
4932
4933        TYPE(surf_type) ::  surf !< treated surfaces
4934
4935        IF ( sun_up  .AND.  .NOT. average_radiation )  THEN
4936
4937           DO  m = 1, surf%ns
4938!
4939!--           Loop over surface elements
4940              DO  ind_type = 0, SIZE( surf%albedo_type, 1 ) - 1
4941           
4942!
4943!--              Ocean
4944                 IF ( surf%albedo_type(ind_type,m) == 1 )  THEN
4945                    surf%rrtm_aldir(ind_type,m) = 0.026_wp /                    &
4946                                                ( cos_zenith**1.7_wp + 0.065_wp )&
4947                                     + 0.15_wp * ( cos_zenith - 0.1_wp )         &
4948                                               * ( cos_zenith - 0.5_wp )         &
4949                                               * ( cos_zenith - 1.0_wp )
4950                    surf%rrtm_asdir(ind_type,m) = surf%rrtm_aldir(ind_type,m)
4951!
4952!--              Snow
4953                 ELSEIF ( surf%albedo_type(ind_type,m) == 16 )  THEN
4954                    IF ( cos_zenith < 0.5_wp )  THEN
4955                       surf%rrtm_aldir(ind_type,m) =                           &
4956                                 0.5_wp * ( 1.0_wp - surf%aldif(ind_type,m) )  &
4957                                        * ( 3.0_wp / ( 1.0_wp + 4.0_wp         &
4958                                        * cos_zenith ) ) - 1.0_wp
4959                       surf%rrtm_asdir(ind_type,m) =                           &
4960                                 0.5_wp * ( 1.0_wp - surf%asdif(ind_type,m) )  &
4961                                        * ( 3.0_wp / ( 1.0_wp + 4.0_wp         &
4962                                        * cos_zenith ) ) - 1.0_wp
4963
4964                       surf%rrtm_aldir(ind_type,m) =                           &
4965                                       MIN(0.98_wp, surf%rrtm_aldir(ind_type,m))
4966                       surf%rrtm_asdir(ind_type,m) =                           &
4967                                       MIN(0.98_wp, surf%rrtm_asdir(ind_type,m))
4968                    ELSE
4969                       surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4970                       surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4971                    ENDIF
4972!
4973!--              Sea ice
4974                 ELSEIF ( surf%albedo_type(ind_type,m) == 15 )  THEN
4975                    surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4976                    surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4977
4978!
4979!--              Asphalt
4980                 ELSEIF ( surf%albedo_type(ind_type,m) == 17 )  THEN
4981                    surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4982                    surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4983
4984
4985!
4986!--              Bare soil
4987                 ELSEIF ( surf%albedo_type(ind_type,m) == 18 )  THEN
4988                    surf%rrtm_aldir(ind_type,m) = surf%aldif(ind_type,m)
4989                    surf%rrtm_asdir(ind_type,m) = surf%asdif(ind_type,m)
4990
4991!
4992!--              Land surfaces
4993                 ELSE
4994                    SELECT CASE ( surf%albedo_type(ind_type,m) )
4995
4996!
4997!--                    Surface types with strong zenith dependence
4998                       CASE ( 1, 2, 3, 4, 11, 12, 13 )
4999                          surf%rrtm_aldir(ind_type,m) =                        &
5000                                surf%aldif(ind_type,m) * 1.4_wp /              &
5001                                           ( 1.0_wp + 0.8_wp * cos_zenith )
5002                          surf%rrtm_asdir(ind_type,m) =                        &
5003                                surf%asdif(ind_type,m) * 1.4_wp /              &
5004                                           ( 1.0_wp + 0.8_wp * cos_zenith )
5005!
5006!--                    Surface types with weak zenith dependence
5007                       CASE ( 5, 6, 7, 8, 9, 10, 14 )
5008                          surf%rrtm_aldir(ind_type,m) =                        &
5009                                surf%aldif(ind_type,m) * 1.1_wp /              &
5010                                           ( 1.0_wp + 0.2_wp * cos_zenith )
5011                          surf%rrtm_asdir(ind_type,m) =                        &
5012                                surf%asdif(ind_type,m) * 1.1_wp /              &
5013                                           ( 1.0_wp + 0.2_wp * cos_zenith )
5014
5015                       CASE DEFAULT
5016
5017                    END SELECT
5018                 ENDIF
5019!
5020!--              Diffusive albedo is taken from Table 2
5021                 surf%rrtm_aldif(ind_type,m) = surf%aldif(ind_type,m)
5022                 surf%rrtm_asdif(ind_type,m) = surf%asdif(ind_type,m)
5023              ENDDO
5024           ENDDO
5025!
5026!--     Set albedo in case of average radiation
5027        ELSEIF ( sun_up  .AND.  average_radiation )  THEN
5028           surf%rrtm_asdir = albedo_urb
5029           surf%rrtm_asdif = albedo_urb
5030           surf%rrtm_aldir = albedo_urb
5031           surf%rrtm_aldif = albedo_urb 
5032!
5033!--     Darkness
5034        ELSE
5035           surf%rrtm_aldir = 0.0_wp
5036           surf%rrtm_asdir = 0.0_wp
5037           surf%rrtm_aldif = 0.0_wp
5038           surf%rrtm_asdif = 0.0_wp
5039        ENDIF
5040
5041    END SUBROUTINE calc_albedo
5042
5043!------------------------------------------------------------------------------!
5044! Description:
5045! ------------
5046!> Read sounding data (pressure and temperature) from RADIATION_DATA.
5047!------------------------------------------------------------------------------!
5048    SUBROUTINE read_sounding_data
5049
5050       IMPLICIT NONE
5051
5052       INTEGER(iwp) :: id,           & !< NetCDF id of input file
5053                       id_dim_zrad,  & !< pressure level id in the NetCDF file
5054                       id_var,       & !< NetCDF variable id
5055                       k,            & !< loop index
5056                       nz_snd,       & !< number of vertical levels in the sounding data
5057                       nz_snd_start, & !< start vertical index for sounding data to be used
5058                       nz_snd_end      !< end vertical index for souding data to be used
5059
5060       REAL(wp) :: t_surface           !< actual surface temperature
5061
5062       REAL(wp), DIMENSION(:), ALLOCATABLE ::  hyp_snd_tmp, & !< temporary hydrostatic pressure profile (sounding)
5063                                               t_snd_tmp      !< temporary temperature profile (sounding)
5064
5065!
5066!--    In case of updates, deallocate arrays first (sufficient to check one
5067!--    array as the others are automatically allocated). This is required
5068!--    because nzt_rad might change during the update
5069       IF ( ALLOCATED ( hyp_snd ) )  THEN
5070          DEALLOCATE( hyp_snd )
5071          DEALLOCATE( t_snd )
5072          DEALLOCATE ( rrtm_play )
5073          DEALLOCATE ( rrtm_plev )
5074          DEALLOCATE ( rrtm_tlay )
5075          DEALLOCATE ( rrtm_tlev )
5076
5077          DEALLOCATE ( rrtm_cicewp )
5078          DEALLOCATE ( rrtm_cldfr )
5079          DEALLOCATE ( rrtm_cliqwp )
5080          DEALLOCATE ( rrtm_reice )
5081          DEALLOCATE ( rrtm_reliq )
5082          DEALLOCATE ( rrtm_lw_taucld )
5083          DEALLOCATE ( rrtm_lw_tauaer )
5084
5085          DEALLOCATE ( rrtm_lwdflx  )
5086          DEALLOCATE ( rrtm_lwdflxc )
5087          DEALLOCATE ( rrtm_lwuflx  )
5088          DEALLOCATE ( rrtm_lwuflxc )
5089          DEALLOCATE ( rrtm_lwuflx_dt )
5090          DEALLOCATE ( rrtm_lwuflxc_dt )
5091          DEALLOCATE ( rrtm_lwhr  )
5092          DEALLOCATE ( rrtm_lwhrc )
5093
5094          DEALLOCATE ( rrtm_sw_taucld )
5095          DEALLOCATE ( rrtm_sw_ssacld )
5096          DEALLOCATE ( rrtm_sw_asmcld )
5097          DEALLOCATE ( rrtm_sw_fsfcld )
5098          DEALLOCATE ( rrtm_sw_tauaer )
5099          DEALLOCATE ( rrtm_sw_ssaaer )
5100          DEALLOCATE ( rrtm_sw_asmaer ) 
5101          DEALLOCATE ( rrtm_sw_ecaer )   
5102 
5103          DEALLOCATE ( rrtm_swdflx  )
5104          DEALLOCATE ( rrtm_swdflxc )
5105          DEALLOCATE ( rrtm_swuflx  )
5106          DEALLOCATE ( rrtm_swuflxc )
5107          DEALLOCATE ( rrtm_swhr  )
5108          DEALLOCATE ( rrtm_swhrc )
5109          DEALLOCATE ( rrtm_dirdflux )
5110          DEALLOCATE ( rrtm_difdflux )
5111
5112       ENDIF
5113
5114!
5115!--    Open file for reading
5116       nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id )
5117       CALL netcdf_handle_error_rad( 'read_sounding_data', 549 )
5118
5119!
5120!--    Inquire dimension of z axis and save in nz_snd
5121       nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim_zrad )
5122       nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim_zrad, len = nz_snd )
5123       CALL netcdf_handle_error_rad( 'read_sounding_data', 551 )
5124
5125!
5126! !--    Allocate temporary array for storing pressure data
5127       ALLOCATE( hyp_snd_tmp(1:nz_snd) )
5128       hyp_snd_tmp = 0.0_wp
5129
5130
5131!--    Read pressure from file
5132       nc_stat = NF90_INQ_VARID( id, "Pressure", id_var )
5133       nc_stat = NF90_GET_VAR( id, id_var, hyp_snd_tmp(:), start = (/1/),      &
5134                               count = (/nz_snd/) )
5135       CALL netcdf_handle_error_rad( 'read_sounding_data', 552 )
5136
5137!
5138!--    Allocate temporary array for storing temperature data
5139       ALLOCATE( t_snd_tmp(1:nz_snd) )
5140       t_snd_tmp = 0.0_wp
5141
5142!
5143!--    Read temperature from file
5144       nc_stat = NF90_INQ_VARID( id, "ReferenceTemperature", id_var )
5145       nc_stat = NF90_GET_VAR( id, id_var, t_snd_tmp(:), start = (/1/),        &
5146                               count = (/nz_snd/) )
5147       CALL netcdf_handle_error_rad( 'read_sounding_data', 553 )
5148
5149!
5150!--    Calculate start of sounding data
5151       nz_snd_start = nz_snd + 1
5152       nz_snd_end   = nz_snd + 1
5153
5154!
5155!--    Start filling vertical dimension at 10hPa above the model domain (hyp is
5156!--    in Pa, hyp_snd in hPa).
5157       DO  k = 1, nz_snd
5158          IF ( hyp_snd_tmp(k) < ( hyp(nzt+1) - 1000.0_wp) * 0.01_wp )  THEN
5159             nz_snd_start = k
5160             EXIT
5161          END IF
5162       END DO
5163
5164       IF ( nz_snd_start <= nz_snd )  THEN
5165          nz_snd_end = nz_snd
5166       END IF
5167
5168
5169!
5170!--    Calculate of total grid points for RRTMG calculations
5171       nzt_rad = nzt + nz_snd_end - nz_snd_start + 1
5172
5173!
5174!--    Save data above LES domain in hyp_snd, t_snd
5175       ALLOCATE( hyp_snd(nzb+1:nzt_rad) )
5176       ALLOCATE( t_snd(nzb+1:nzt_rad)   )
5177       hyp_snd = 0.0_wp
5178       t_snd = 0.0_wp
5179
5180       hyp_snd(nzt+2:nzt_rad) = hyp_snd_tmp(nz_snd_start+1:nz_snd_end)
5181       t_snd(nzt+2:nzt_rad)   = t_snd_tmp(nz_snd_start+1:nz_snd_end)
5182
5183       nc_stat = NF90_CLOSE( id )
5184
5185!
5186!--    Calculate pressure levels on zu and zw grid. Sounding data is added at
5187!--    top of the LES domain. This routine does not consider horizontal or
5188!--    vertical variability of pressure and temperature
5189       ALLOCATE ( rrtm_play(0:0,nzb+1:nzt_rad+1)   )
5190       ALLOCATE ( rrtm_plev(0:0,nzb+1:nzt_rad+2)   )
5191
5192       t_surface = pt_surface * exner(nzb)
5193       DO k = nzb+1, nzt+1
5194          rrtm_play(0,k) = hyp(k) * 0.01_wp
5195          rrtm_plev(0,k) = barometric_formula(zw(k-1),                         &
5196                              pt_surface * exner(nzb), &
5197                              surface_pressure )
5198       ENDDO
5199
5200       DO k = nzt+2, nzt_rad
5201          rrtm_play(0,k) = hyp_snd(k)
5202          rrtm_plev(0,k) = 0.5_wp * ( rrtm_play(0,k) + rrtm_play(0,k-1) )
5203       ENDDO
5204       rrtm_plev(0,nzt_rad+1) = MAX( 0.5 * hyp_snd(nzt_rad),                   &
5205                                   1.5 * hyp_snd(nzt_rad)                      &
5206                                 - 0.5 * hyp_snd(nzt_rad-1) )
5207       rrtm_plev(0,nzt_rad+2)  = MIN( 1.0E-4_wp,                               &
5208                                      0.25_wp * rrtm_plev(0,nzt_rad+1) )
5209
5210       rrtm_play(0,nzt_rad+1) = 0.5 * rrtm_plev(0,nzt_rad+1)
5211
5212!
5213!--    Calculate temperature/humidity levels at top of the LES domain.
5214!--    Currently, the temperature is taken from sounding data (might lead to a
5215!--    temperature jump at interface. To do: Humidity is currently not
5216!--    calculated above the LES domain.
5217       ALLOCATE ( rrtm_tlay(0:0,nzb+1:nzt_rad+1)   )
5218       ALLOCATE ( rrtm_tlev(0:0,nzb+1:nzt_rad+2)   )
5219
5220       DO k = nzt+8, nzt_rad
5221          rrtm_tlay(0,k)   = t_snd(k)
5222       ENDDO
5223       rrtm_tlay(0,nzt_rad+1) = 2.0_wp * rrtm_tlay(0,nzt_rad)                  &
5224                                - rrtm_tlay(0,nzt_rad-1)
5225       DO k = nzt+9, nzt_rad+1
5226          rrtm_tlev(0,k)   = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k)                &
5227                             - rrtm_tlay(0,k-1))                               &
5228                             / ( rrtm_play(0,k) - rrtm_play(0,k-1) )           &
5229                             * ( rrtm_plev(0,k) - rrtm_play(0,k-1) )
5230       ENDDO
5231
5232       rrtm_tlev(0,nzt_rad+2)   = 2.0_wp * rrtm_tlay(0,nzt_rad+1)              &
5233                                  - rrtm_tlev(0,nzt_rad)
5234!
5235!--    Allocate remaining RRTMG arrays
5236       ALLOCATE ( rrtm_cicewp(0:0,nzb+1:nzt_rad+1) )
5237       ALLOCATE ( rrtm_cldfr(0:0,nzb+1:nzt_rad+1) )
5238       ALLOCATE ( rrtm_cliqwp(0:0,nzb+1:nzt_rad+1) )
5239       ALLOCATE ( rrtm_reice(0:0,nzb+1:nzt_rad+1) )
5240       ALLOCATE ( rrtm_reliq(0:0,nzb+1:nzt_rad+1) )
5241       ALLOCATE ( rrtm_lw_taucld(1:nbndlw+1,0:0,nzb+1:nzt_rad+1) )
5242       ALLOCATE ( rrtm_lw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndlw+1) )
5243       ALLOCATE ( rrtm_sw_taucld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
5244       ALLOCATE ( rrtm_sw_ssacld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
5245       ALLOCATE ( rrtm_sw_asmcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
5246       ALLOCATE ( rrtm_sw_fsfcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) )
5247       ALLOCATE ( rrtm_sw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
5248       ALLOCATE ( rrtm_sw_ssaaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) )
5249       ALLOCATE ( rrtm_sw_asmaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) ) 
5250       ALLOCATE ( rrtm_sw_ecaer(0:0,nzb+1:nzt_rad+1,1:naerec+1) )   
5251
5252!
5253!--    The ice phase is currently not considered in PALM
5254       rrtm_cicewp = 0.0_wp
5255       rrtm_reice  = 0.0_wp
5256
5257!
5258!--    Set other parameters (move to NAMELIST parameters in the future)
5259       rrtm_lw_tauaer = 0.0_wp
5260       rrtm_lw_taucld = 0.0_wp
5261       rrtm_sw_taucld = 0.0_wp
5262       rrtm_sw_ssacld = 0.0_wp
5263       rrtm_sw_asmcld = 0.0_wp
5264       rrtm_sw_fsfcld = 0.0_wp
5265       rrtm_sw_tauaer = 0.0_wp
5266       rrtm_sw_ssaaer = 0.0_wp
5267       rrtm_sw_asmaer = 0.0_wp
5268       rrtm_sw_ecaer  = 0.0_wp
5269
5270
5271       ALLOCATE ( rrtm_swdflx(0:0,nzb:nzt_rad+1)  )
5272       ALLOCATE ( rrtm_swuflx(0:0,nzb:nzt_rad+1)  )
5273       ALLOCATE ( rrtm_swhr(0:0,nzb+1:nzt_rad+1)  )
5274       ALLOCATE ( rrtm_swuflxc(0:0,nzb:nzt_rad+1) )
5275       ALLOCATE ( rrtm_swdflxc(0:0,nzb:nzt_rad+1) )
5276       ALLOCATE ( rrtm_swhrc(0:0,nzb+1:nzt_rad+1) )
5277       ALLOCATE ( rrtm_dirdflux(0:0,nzb:nzt_rad+1) )
5278       ALLOCATE ( rrtm_difdflux(0:0,nzb:nzt_rad+1) )
5279
5280       rrtm_swdflx  = 0.0_wp
5281       rrtm_swuflx  = 0.0_wp
5282       rrtm_swhr    = 0.0_wp 
5283       rrtm_swuflxc = 0.0_wp
5284       rrtm_swdflxc = 0.0_wp
5285       rrtm_swhrc   = 0.0_wp
5286       rrtm_dirdflux = 0.0_wp
5287       rrtm_difdflux = 0.0_wp
5288
5289       ALLOCATE ( rrtm_lwdflx(0:0,nzb:nzt_rad+1)  )
5290       ALLOCATE ( rrtm_lwuflx(0:0,nzb:nzt_rad+1)  )
5291       ALLOCATE ( rrtm_lwhr(0:0,nzb+1:nzt_rad+1)  )
5292       ALLOCATE ( rrtm_lwuflxc(0:0,nzb:nzt_rad+1) )
5293       ALLOCATE ( rrtm_lwdflxc(0:0,nzb:nzt_rad+1) )
5294       ALLOCATE ( rrtm_lwhrc(0:0,nzb+1:nzt_rad+1) )
5295
5296       rrtm_lwdflx  = 0.0_wp
5297       rrtm_lwuflx  = 0.0_wp
5298       rrtm_lwhr    = 0.0_wp 
5299       rrtm_lwuflxc = 0.0_wp
5300       rrtm_lwdflxc = 0.0_wp
5301       rrtm_lwhrc   = 0.0_wp
5302
5303       ALLOCATE ( rrtm_lwuflx_dt(0:0,nzb:nzt_rad+1) )
5304       ALLOCATE ( rrtm_lwuflxc_dt(0:0,nzb:nzt_rad+1) )
5305
5306       rrtm_lwuflx_dt = 0.0_wp
5307       rrtm_lwuflxc_dt = 0.0_wp
5308
5309    END SUBROUTINE read_sounding_data
5310
5311
5312!------------------------------------------------------------------------------!
5313! Description:
5314! ------------
5315!> Read trace gas data from file and convert into trace gas paths / volume
5316!> mixing ratios. If a user-defined input file is provided it needs to follow
5317!> the convections used in RRTMG (see respective netCDF files shipped with
5318!> RRTMG)
5319!------------------------------------------------------------------------------!
5320    SUBROUTINE read_trace_gas_data
5321
5322       USE rrsw_ncpar
5323
5324       IMPLICIT NONE
5325
5326       INTEGER(iwp), PARAMETER :: num_trace_gases = 10 !< number of trace gases (absorbers)
5327
5328       CHARACTER(LEN=5), DIMENSION(num_trace_gases), PARAMETER ::              & !< trace gas names
5329           trace_names = (/'O3   ', 'CO2  ', 'CH4  ', 'N2O  ', 'O2   ',        &
5330                           'CFC11', 'CFC12', 'CFC22', 'CCL4 ', 'H2O  '/)
5331
5332       INTEGER(iwp) :: id,     & !< NetCDF id
5333                       k,      & !< loop index
5334                       m,      & !< loop index
5335                       n,      & !< loop index
5336                       nabs,   & !< number of absorbers
5337                       np,     & !< number of pressure levels
5338                       id_abs, & !< NetCDF id of the respective absorber
5339                       id_dim, & !< NetCDF id of asborber's dimension
5340                       id_var    !< NetCDf id ot the absorber
5341
5342       REAL(wp) :: p_mls_l, &    !< pressure lower limit for interpolation
5343                   p_mls_u, &    !< pressure upper limit for interpolation
5344                   p_wgt_l, &    !< pressure weight lower limit for interpolation
5345                   p_wgt_u, &    !< pressure weight upper limit for interpolation
5346                   p_mls_m       !< mean pressure between upper and lower limits
5347
5348
5349       REAL(wp), DIMENSION(:), ALLOCATABLE   ::  p_mls,          & !< pressure levels for the absorbers
5350                                                 rrtm_play_tmp,  & !< temporary array for pressure zu-levels
5351                                                 rrtm_plev_tmp,  & !< temporary array for pressure zw-levels
5352                                                 trace_path_tmp    !< temporary array for storing trace gas path data
5353
5354       REAL(wp), DIMENSION(:,:), ALLOCATABLE ::  trace_mls,      & !< array for storing the absorber amounts
5355                                                 trace_mls_path, & !< array for storing trace gas path data
5356                                                 trace_mls_tmp     !< temporary array for storing trace gas data
5357
5358
5359!
5360!--    In case of updates, deallocate arrays first (sufficient to check one
5361!--    array as the others are automatically allocated)
5362       IF ( ALLOCATED ( rrtm_o3vmr ) )  THEN
5363          DEALLOCATE ( rrtm_o3vmr  )
5364          DEALLOCATE ( rrtm_co2vmr )
5365          DEALLOCATE ( rrtm_ch4vmr )
5366          DEALLOCATE ( rrtm_n2ovmr )
5367          DEALLOCATE ( rrtm_o2vmr  )
5368          DEALLOCATE ( rrtm_cfc11vmr )
5369          DEALLOCATE ( rrtm_cfc12vmr )
5370          DEALLOCATE ( rrtm_cfc22vmr )
5371          DEALLOCATE ( rrtm_ccl4vmr  )
5372          DEALLOCATE ( rrtm_h2ovmr  )     
5373       ENDIF
5374
5375!
5376!--    Allocate trace gas profiles
5377       ALLOCATE ( rrtm_o3vmr(0:0,1:nzt_rad+1)  )
5378       ALLOCATE ( rrtm_co2vmr(0:0,1:nzt_rad+1) )
5379       ALLOCATE ( rrtm_ch4vmr(0:0,1:nzt_rad+1) )
5380       ALLOCATE ( rrtm_n2ovmr(0:0,1:nzt_rad+1) )
5381       ALLOCATE ( rrtm_o2vmr(0:0,1:nzt_rad+1)  )
5382       ALLOCATE ( rrtm_cfc11vmr(0:0,1:nzt_rad+1) )
5383       ALLOCATE ( rrtm_cfc12vmr(0:0,1:nzt_rad+1) )
5384       ALLOCATE ( rrtm_cfc22vmr(0:0,1:nzt_rad+1) )
5385       ALLOCATE ( rrtm_ccl4vmr(0:0,1:nzt_rad+1)  )
5386       ALLOCATE ( rrtm_h2ovmr(0:0,1:nzt_rad+1)  )
5387
5388!
5389!--    Open file for reading
5390       nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id )
5391       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 549 )
5392!
5393!--    Inquire dimension ids and dimensions
5394       nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim )
5395       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5396       nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = np) 
5397       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5398
5399       nc_stat = NF90_INQ_DIMID( id, "Absorber", id_dim )
5400       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5401       nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = nabs ) 
5402       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5403   
5404
5405!
5406!--    Allocate pressure, and trace gas arrays     
5407       ALLOCATE( p_mls(1:np) )
5408       ALLOCATE( trace_mls(1:num_trace_gases,1:np) ) 
5409       ALLOCATE( trace_mls_tmp(1:nabs,1:np) ) 
5410
5411
5412       nc_stat = NF90_INQ_VARID( id, "Pressure", id_var )
5413       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5414       nc_stat = NF90_GET_VAR( id, id_var, p_mls )
5415       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5416
5417       nc_stat = NF90_INQ_VARID( id, "AbsorberAmountMLS", id_var )
5418       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5419       nc_stat = NF90_GET_VAR( id, id_var, trace_mls_tmp )
5420       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 )
5421
5422
5423!
5424!--    Write absorber amounts (mls) to trace_mls
5425       DO n = 1, num_trace_gases
5426          CALL getAbsorberIndex( TRIM( trace_names(n) ), id_abs )
5427
5428          trace_mls(n,1:np) = trace_mls_tmp(id_abs,1:np)
5429
5430!
5431!--       Replace missing values by zero
5432          WHERE ( trace_mls(n,:) > 2.0_wp ) 
5433             trace_mls(n,:) = 0.0_wp
5434          END WHERE
5435       END DO
5436
5437       DEALLOCATE ( trace_mls_tmp )
5438
5439       nc_stat = NF90_CLOSE( id )
5440       CALL netcdf_handle_error_rad( 'read_trace_gas_data', 551 )
5441
5442!
5443!--    Add extra pressure level for calculations of the trace gas paths
5444       ALLOCATE ( rrtm_play_tmp(1:nzt_rad+1) )
5445       ALLOCATE ( rrtm_plev_tmp(1:nzt_rad+2) )
5446
5447       rrtm_play_tmp(1:nzt_rad)   = rrtm_play(0,1:nzt_rad) 
5448       rrtm_plev_tmp(1:nzt_rad+1) = rrtm_plev(0,1:nzt_rad+1)
5449       rrtm_play_tmp(nzt_rad+1)   = rrtm_plev(0,nzt_rad+1) * 0.5_wp
5450       rrtm_plev_tmp(nzt_rad+2)   = MIN( 1.0E-4_wp, 0.25_wp                    &
5451                                         * rrtm_plev(0,nzt_rad+1) )
5452 
5453!
5454!--    Calculate trace gas path (zero at surface) with interpolation to the
5455!--    sounding levels
5456       ALLOCATE ( trace_mls_path(1:nzt_rad+2,1:num_trace_gases) )
5457
5458       trace_mls_path(nzb+1,:) = 0.0_wp
5459       
5460       DO k = nzb+2, nzt_rad+2
5461          DO m = 1, num_trace_gases
5462             trace_mls_path(k,m) = trace_mls_path(k-1,m)
5463
5464!
5465!--          When the pressure level is higher than the trace gas pressure
5466!--          level, assume that
5467             IF ( rrtm_plev_tmp(k-1) > p_mls(1) )  THEN             
5468               
5469                trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,1)     &
5470                                      * ( rrtm_plev_tmp(k-1)                   &
5471                                          - MAX( p_mls(1), rrtm_plev_tmp(k) )  &
5472                                        ) / g
5473             ENDIF
5474
5475!
5476!--          Integrate for each sounding level from the contributing p_mls
5477!--          levels
5478             DO n = 2, np
5479!
5480!--             Limit p_mls so that it is within the model level
5481                p_mls_u = MIN( rrtm_plev_tmp(k-1),                             &
5482                          MAX( rrtm_plev_tmp(k), p_mls(n) ) )
5483                p_mls_l = MIN( rrtm_plev_tmp(k-1),                             &
5484                          MAX( rrtm_plev_tmp(k), p_mls(n-1) ) )
5485
5486                IF ( p_mls_l > p_mls_u )  THEN
5487
5488!
5489!--                Calculate weights for interpolation
5490                   p_mls_m = 0.5_wp * (p_mls_l + p_mls_u)
5491                   p_wgt_u = (p_mls(n-1) - p_mls_m) / (p_mls(n-1) - p_mls(n))
5492                   p_wgt_l = (p_mls_m - p_mls(n))   / (p_mls(n-1) - p_mls(n))
5493
5494!
5495!--                Add level to trace gas path
5496                   trace_mls_path(k,m) = trace_mls_path(k,m)                   &
5497                                         +  ( p_wgt_u * trace_mls(m,n)         &
5498                                            + p_wgt_l * trace_mls(m,n-1) )     &
5499                                         * (p_mls_l - p_mls_u) / g
5500                ENDIF
5501             ENDDO
5502
5503             IF ( rrtm_plev_tmp(k) < p_mls(np) )  THEN
5504                trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,np)    &
5505                                      * ( MIN( rrtm_plev_tmp(k-1), p_mls(np) ) &
5506                                          - rrtm_plev_tmp(k)                   &
5507                                        ) / g 
5508             ENDIF 
5509          ENDDO
5510       ENDDO
5511
5512
5513!
5514!--    Prepare trace gas path profiles
5515       ALLOCATE ( trace_path_tmp(1:nzt_rad+1) )
5516
5517       DO m = 1, num_trace_gases
5518
5519          trace_path_tmp(1:nzt_rad+1) = ( trace_mls_path(2:nzt_rad+2,m)        &
5520                                       - trace_mls_path(1:nzt_rad+1,m) ) * g   &
5521                                       / ( rrtm_plev_tmp(1:nzt_rad+1)          &
5522                                       - rrtm_plev_tmp(2:nzt_rad+2) )
5523
5524!
5525!--       Save trace gas paths to the respective arrays
5526          SELECT CASE ( TRIM( trace_names(m) ) )
5527
5528             CASE ( 'O3' )
5529
5530                rrtm_o3vmr(0,:) = trace_path_tmp(:)
5531
5532             CASE ( 'CO2' )
5533
5534                rrtm_co2vmr(0,:) = trace_path_tmp(:)
5535
5536             CASE ( 'CH4' )
5537
5538                rrtm_ch4vmr(0,:) = trace_path_tmp(:)
5539
5540             CASE ( 'N2O' )
5541
5542                rrtm_n2ovmr(0,:) = trace_path_tmp(:)
5543
5544             CASE ( 'O2' )
5545
5546                rrtm_o2vmr(0,:) = trace_path_tmp(:)
5547
5548             CASE ( 'CFC11' )
5549
5550                rrtm_cfc11vmr(0,:) = trace_path_tmp(:)
5551
5552             CASE ( 'CFC12' )
5553
5554                rrtm_cfc12vmr(0,:) = trace_path_tmp(:)
5555
5556             CASE ( 'CFC22' )
5557
5558                rrtm_cfc22vmr(0,:) = trace_path_tmp(:)
5559
5560             CASE ( 'CCL4' )
5561
5562                rrtm_ccl4vmr(0,:) = trace_path_tmp(:)
5563
5564             CASE ( 'H2O' )
5565
5566                rrtm_h2ovmr(0,:) = trace_path_tmp(:)
5567               
5568             CASE DEFAULT
5569
5570          END SELECT
5571
5572       ENDDO
5573
5574       DEALLOCATE ( trace_path_tmp )
5575       DEALLOCATE ( trace_mls_path )
5576       DEALLOCATE ( rrtm_play_tmp )
5577       DEALLOCATE ( rrtm_plev_tmp )
5578       DEALLOCATE ( trace_mls )
5579       DEALLOCATE ( p_mls )
5580
5581    END SUBROUTINE read_trace_gas_data
5582
5583
5584    SUBROUTINE netcdf_handle_error_rad( routine_name, errno )
5585
5586       USE control_parameters,                                                 &
5587           ONLY:  message_string
5588
5589       USE NETCDF
5590
5591       USE pegrid
5592
5593       IMPLICIT NONE
5594
5595       CHARACTER(LEN=6) ::  message_identifier
5596       CHARACTER(LEN=*) ::  routine_name
5597
5598       INTEGER(iwp) ::  errno
5599
5600       IF ( nc_stat /= NF90_NOERR )  THEN
5601
5602          WRITE( message_identifier, '(''NC'',I4.4)' )  errno
5603          message_string = TRIM( NF90_STRERROR( nc_stat ) )
5604
5605          CALL message( routine_name, message_identifier, 2, 2, 0, 6, 1 )
5606
5607       ENDIF
5608
5609    END SUBROUTINE netcdf_handle_error_rad
5610#endif
5611
5612
5613!------------------------------------------------------------------------------!
5614! Description:
5615! ------------
5616!> Calculate temperature tendency due to radiative cooling/heating.
5617!> Cache-optimized version.
5618!------------------------------------------------------------------------------!
5619#if defined( __rrtmg )
5620 SUBROUTINE radiation_tendency_ij ( i, j, tend )
5621
5622    IMPLICIT NONE
5623
5624    INTEGER(iwp) :: i, j, k !< loop indices
5625
5626    REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term
5627
5628    IF ( radiation_scheme == 'rrtmg' )  THEN
5629!
5630!--    Calculate tendency based on heating rate
5631       DO k = nzb+1, nzt+1
5632          tend(k,j,i) = tend(k,j,i) + (rad_lw_hr(k,j,i) + rad_sw_hr(k,j,i))    &
5633                                         * d_exner(k) * d_seconds_hour
5634       ENDDO
5635
5636    ENDIF
5637
5638 END SUBROUTINE radiation_tendency_ij
5639#endif
5640
5641
5642!------------------------------------------------------------------------------!
5643! Description:
5644! ------------
5645!> Calculate temperature tendency due to radiative cooling/heating.
5646!> Vector-optimized version
5647!------------------------------------------------------------------------------!
5648#if defined( __rrtmg )
5649 SUBROUTINE radiation_tendency ( tend )
5650
5651    USE indices,                                                               &
5652        ONLY:  nxl, nxr, nyn, nys
5653
5654    IMPLICIT NONE
5655
5656    INTEGER(iwp) :: i, j, k !< loop indices
5657
5658    REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term
5659
5660    IF ( radiation_scheme == 'rrtmg' )  THEN
5661!
5662!--    Calculate tendency based on heating rate
5663       DO  i = nxl, nxr
5664          DO  j = nys, nyn
5665             DO k = nzb+1, nzt+1
5666                tend(k,j,i) = tend(k,j,i) + ( rad_lw_hr(k,j,i)                 &
5667                                          +  rad_sw_hr(k,j,i) ) * d_exner(k)   &
5668                                          * d_seconds_hour
5669             ENDDO
5670          ENDDO
5671       ENDDO
5672    ENDIF
5673
5674 END SUBROUTINE radiation_tendency
5675#endif
5676
5677!------------------------------------------------------------------------------!
5678! Description:
5679! ------------
5680!> This subroutine calculates interaction of the solar radiation
5681!> with urban and land surfaces and updates all surface heatfluxes.
5682!> It calculates also the required parameters for RRTMG lower BC.
5683!>
5684!> For more info. see Resler et al. 2017
5685!>
5686!> The new version 2.0 was radically rewriten, the discretization scheme
5687!> has been changed. This new version significantly improves effectivity
5688!> of the paralelization and the scalability of the model.
5689!------------------------------------------------------------------------------!
5690
5691 SUBROUTINE radiation_interaction
5692
5693    USE control_parameters,                                                    &
5694        ONLY:  rotation_angle
5695
5696     IMPLICIT NONE
5697
5698     INTEGER(iwp)                      ::  i, j, k, kk, d, refstep, m, mm, l, ll
5699     INTEGER(iwp)                      ::  isurf, isurfsrc, isvf, icsf, ipcgb
5700     INTEGER(iwp)                      ::  imrt, imrtf
5701     INTEGER(iwp)                      ::  isd                !< solar direction number
5702     INTEGER(iwp)                      ::  pc_box_dimshift    !< transform for best accuracy
5703     INTEGER(iwp), DIMENSION(0:3)      ::  reorder = (/ 1, 0, 3, 2 /)
5704                                           
5705     REAL(wp), DIMENSION(3,3)          ::  mrot               !< grid rotation matrix (zyx)
5706     REAL(wp), DIMENSION(3,0:nsurf_type)::  vnorm             !< face direction normal vectors (zyx)
5707     REAL(wp), DIMENSION(3)            ::  sunorig            !< grid rotated solar direction unit vector (zyx)
5708     REAL(wp), DIMENSION(3)            ::  sunorig_grid       !< grid squashed solar direction unit vector (zyx)
5709     REAL(wp), DIMENSION(0:nsurf_type) ::  costheta           !< direct irradiance factor of solar angle
5710     REAL(wp), DIMENSION(nz_urban_b:nz_urban_t) ::  pchf_prep          !< precalculated factor for canopy temperature tendency
5711     REAL(wp)                          ::  pc_box_area, pc_abs_frac, pc_abs_eff
5712     REAL(wp)                          ::  asrc               !< area of source face
5713     REAL(wp)                          ::  pcrad              !< irradiance from plant canopy
5714     REAL(wp)                          ::  pabsswl  = 0.0_wp  !< total absorbed SW radiation energy in local processor (W)
5715     REAL(wp)                          ::  pabssw   = 0.0_wp  !< total absorbed SW radiation energy in all processors (W)
5716     REAL(wp)                          ::  pabslwl  = 0.0_wp  !< total absorbed LW radiation energy in local processor (W)
5717     REAL(wp)                          ::  pabslw   = 0.0_wp  !< total absorbed LW radiation energy in all processors (W)
5718     REAL(wp)                          ::  pemitlwl = 0.0_wp  !< total emitted LW radiation energy in all processors (W)
5719     REAL(wp)                          ::  pemitlw  = 0.0_wp  !< total emitted LW radiation energy in all processors (W)
5720     REAL(wp)                          ::  pinswl   = 0.0_wp  !< total received SW radiation energy in local processor (W)
5721     REAL(wp)                          ::  pinsw    = 0.0_wp  !< total received SW radiation energy in all processor (W)
5722     REAL(wp)                          ::  pinlwl   = 0.0_wp  !< total received LW radiation energy in local processor (W)
5723     REAL(wp)                          ::  pinlw    = 0.0_wp  !< total received LW radiation energy in all processor (W)
5724     REAL(wp)                          ::  emiss_sum_surfl    !< sum of emissisivity of surfaces in local processor
5725     REAL(wp)                          ::  emiss_sum_surf     !< sum of emissisivity of surfaces in all processor
5726     REAL(wp)                          ::  area_surfl         !< total area of surfaces in local processor
5727     REAL(wp)                          ::  area_surf          !< total area of surfaces in all processor
5728     REAL(wp)                          ::  area_hor           !< total horizontal area of domain in all processor
5729#if defined( __parallel )     
5730     REAL(wp), DIMENSION(1:7)          ::  combine_allreduce   !< dummy array used to combine several MPI_ALLREDUCE calls
5731     REAL(wp), DIMENSION(1:7)          ::  combine_allreduce_l !< dummy array used to combine several MPI_ALLREDUCE calls
5732#endif
5733
5734     IF ( debug_output_timestep )  CALL debug_message( 'radiation_interaction', 'start' )
5735
5736     IF ( plant_canopy )  THEN
5737         pchf_prep(:) = r_d * exner(nz_urban_b:nz_urban_t)                                 &
5738                     / (c_p * hyp(nz_urban_b:nz_urban_t) * dx*dy*dz(1)) !< equals to 1 / (rho * c_p * Vbox * T)
5739     ENDIF
5740
5741     sun_direction = .TRUE.
5742     CALL get_date_time( time_since_reference_point, &
5743                         day_of_year=day_of_year,    &
5744                         second_of_day=second_of_day )
5745     CALL calc_zenith( day_of_year, second_of_day ) !< required also for diffusion radiation
5746
5747!
5748!--     prepare rotated normal vectors and irradiance factor
5749     vnorm(1,:) = kdir(:)
5750     vnorm(2,:) = jdir(:)
5751     vnorm(3,:) = idir(:)
5752     mrot(1, :) = (/ 1._wp,  0._wp,      0._wp      /)
5753     mrot(2, :) = (/ 0._wp,  COS(rotation_angle), SIN(rotation_angle) /)
5754     mrot(3, :) = (/ 0._wp, -SIN(rotation_angle), COS(rotation_angle) /)
5755     sunorig = (/ cos_zenith, sun_dir_lat, sun_dir_lon /)
5756     sunorig = MATMUL(mrot, sunorig)
5757     DO d = 0, nsurf_type
5758         costheta(d) = DOT_PRODUCT(sunorig, vnorm(:,d))
5759     ENDDO
5760
5761     IF ( cos_zenith > 0 )  THEN
5762!--      now we will "squash" the sunorig vector by grid box size in
5763!--      each dimension, so that this new direction vector will allow us
5764!--      to traverse the ray path within grid coordinates directly
5765         sunorig_grid = (/ sunorig(1)/dz(1), sunorig(2)/dy, sunorig(3)/dx /)
5766!--      sunorig_grid = sunorig_grid / norm2(sunorig_grid)
5767         sunorig_grid = sunorig_grid / SQRT(SUM(sunorig_grid**2))
5768
5769         IF ( npcbl > 0 )  THEN
5770!--         precompute effective box depth with prototype Leaf Area Density
5771            pc_box_dimshift = MAXLOC(ABS(sunorig), 1) - 1
5772            CALL box_absorb(CSHIFT((/dz(1),dy,dx/), pc_box_dimshift),       &
5773                                60, prototype_lad,                          &
5774                                CSHIFT(ABS(sunorig), pc_box_dimshift),      &
5775                                pc_box_area, pc_abs_frac)
5776            pc_box_area = pc_box_area * ABS(sunorig(pc_box_dimshift+1)      &
5777                          / sunorig(1))
5778            pc_abs_eff = LOG(1._wp - pc_abs_frac) / prototype_lad
5779         ENDIF
5780     ENDIF
5781!
5782!--  Split downwelling shortwave radiation into a diffuse and a direct part.
5783!--  Note, if radiation scheme is RRTMG or diffuse radiation is externally
5784!--  prescribed, this is not required. Please note, in case of external
5785!--  radiation, the clear-sky model is applied during spinup, so that
5786!--  radiation need to be split also in this case.
5787     IF ( radiation_scheme == 'constant'   .OR.                                &
5788          radiation_scheme == 'clear-sky'  .OR.                                &
5789          ( radiation_scheme == 'external'  .AND.                              &
5790            .NOT. rad_sw_in_dif_f%from_file  )  .OR.                           &
5791          ( radiation_scheme == 'external'  .AND.                              &
5792            time_since_reference_point < 0.0_wp ) )  THEN
5793        CALL calc_diffusion_radiation
5794     ENDIF
5795
5796!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5797!--     First pass: direct + diffuse irradiance + thermal
5798!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
5799     surfinswdir   = 0._wp !nsurfl
5800     surfins       = 0._wp !nsurfl
5801     surfinl       = 0._wp !nsurfl
5802     surfoutsl(:)  = 0.0_wp !start-end
5803     surfoutll(:)  = 0.0_wp !start-end
5804     IF ( nmrtbl > 0 )  THEN
5805        mrtinsw(:) = 0._wp
5806        mrtinlw(:) = 0._wp
5807     ENDIF
5808     surfinlg(:)  = 0._wp !global
5809
5810
5811!--  Set up thermal radiation from surfaces
5812!--  emiss_surf is defined only for surfaces for which energy balance is calculated
5813!--  Workaround: reorder surface data type back on 1D array including all surfaces,
5814!--  which implies to reorder horizontal and vertical surfaces
5815!
5816!--  Horizontal walls
5817     mm = 1
5818     DO  i = nxl, nxr
5819        DO  j = nys, nyn
5820!--           urban
5821           DO  m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
5822              surfoutll(mm) = SUM ( surf_usm_h%frac(:,m) *                  &
5823                                    surf_usm_h%emissivity(:,m) )            &
5824                                  * sigma_sb                                &
5825                                  * surf_usm_h%pt_surface(m)**4
5826              albedo_surf(mm) = SUM ( surf_usm_h%frac(:,m) *                &
5827                                      surf_usm_h%albedo(:,m) )
5828              emiss_surf(mm)  = SUM ( surf_usm_h%frac(:,m) *                &
5829                                      surf_usm_h%emissivity(:,m) )
5830              mm = mm + 1
5831           ENDDO
5832!--           land
5833           DO  m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
5834              surfoutll(mm) = SUM ( surf_lsm_h%frac(:,m) *                  &
5835                                    surf_lsm_h%emissivity(:,m) )            &
5836                                  * sigma_sb                                &
5837                                  * surf_lsm_h%pt_surface(m)**4
5838              albedo_surf(mm) = SUM ( surf_lsm_h%frac(:,m) *                &
5839                                      surf_lsm_h%albedo(:,m) )
5840              emiss_surf(mm)  = SUM ( surf_lsm_h%frac(:,m) *                &
5841                                      surf_lsm_h%emissivity(:,m) )
5842              mm = mm + 1
5843           ENDDO
5844        ENDDO
5845     ENDDO
5846!
5847!--     Vertical walls
5848     DO  i = nxl, nxr
5849        DO  j = nys, nyn
5850           DO  ll = 0, 3
5851              l = reorder(ll)
5852!--              urban
5853              DO  m = surf_usm_v(l)%start_index(j,i),                       &
5854                      surf_usm_v(l)%end_index(j,i)
5855                 surfoutll(mm) = SUM ( surf_usm_v(l)%frac(:,m) *            &
5856                                       surf_usm_v(l)%emissivity(:,m) )      &
5857                                  * sigma_sb                                &
5858                                  * surf_usm_v(l)%pt_surface(m)**4
5859                 albedo_surf(mm) = SUM ( surf_usm_v(l)%frac(:,m) *          &
5860                                         surf_usm_v(l)%albedo(:,m) )
5861                 emiss_surf(mm)  = SUM ( surf_usm_v(l)%frac(:,m) *          &
5862                                         surf_usm_v(l)%emissivity(:,m) )
5863                 mm = mm + 1
5864              ENDDO
5865!--              land
5866              DO  m = surf_lsm_v(l)%start_index(j,i),                       &
5867                      surf_lsm_v(l)%end_index(j,i)
5868                 surfoutll(mm) = SUM ( surf_lsm_v(l)%frac(:,m) *            &
5869                                       surf_lsm_v(l)%emissivity(:,m) )      &
5870                                  * sigma_sb                                &
5871                                  * surf_lsm_v(l)%pt_surface(m)**4
5872                 albedo_surf(mm) = SUM ( surf_lsm_v(l)%frac(:,m) *          &
5873                                         surf_lsm_v(l)%albedo(:,m) )
5874                 emiss_surf(mm)  = SUM ( surf_lsm_v(l)%frac(:,m) *          &
5875                                         surf_lsm_v(l)%emissivity(:,m) )
5876                 mm = mm + 1
5877              ENDDO
5878           ENDDO
5879        ENDDO
5880     ENDDO
5881
5882#if defined( __parallel )
5883!--     might be optimized and gather only values relevant for current processor
5884     CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, &
5885                         surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) !nsurf global
5886     IF ( ierr /= 0 ) THEN
5887         WRITE(9,*) 'Error MPI_AllGatherv1:', ierr, SIZE(surfoutll), nsurfl, &
5888                     SIZE(surfoutl), nsurfs, surfstart
5889         FLUSH(9)
5890     ENDIF
5891#else
5892     surfoutl(:) = surfoutll(:) !nsurf global
5893#endif
5894
5895     IF ( surface_reflections)  THEN
5896        DO  isvf = 1, nsvfl
5897           isurf = svfsurf(1, isvf)
5898           k     = surfl(iz, isurf)
5899           j     = surfl(iy, isurf)
5900           i     = surfl(ix, isurf)
5901           isurfsrc = svfsurf(2, isvf)
5902!
5903!--        For surface-to-surface factors we calculate thermal radiation in 1st pass
5904           IF ( plant_lw_interact )  THEN
5905              surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc)
5906           ELSE
5907              surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)
5908           ENDIF
5909        ENDDO
5910     ENDIF
5911!
5912!--  diffuse radiation using sky view factor
5913     DO isurf = 1, nsurfl
5914        j = surfl(iy, isurf)
5915        i = surfl(ix, isurf)
5916        surfinswdif(isurf) = rad_sw_in_diff(j,i) * skyvft(isurf)
5917        IF ( plant_lw_interact )  THEN
5918           surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvft(isurf)
5919        ELSE
5920           surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvf(isurf)
5921        ENDIF
5922     ENDDO
5923!
5924!--  MRT diffuse irradiance
5925     DO  imrt = 1, nmrtbl
5926        j = mrtbl(iy, imrt)
5927        i = mrtbl(ix, imrt)
5928        mrtinsw(imrt) = mrtskyt(imrt) * rad_sw_in_diff(j,i)
5929        mrtinlw(imrt) = mrtsky(imrt) * rad_lw_in_diff(j,i)
5930     ENDDO
5931
5932     !-- direct radiation
5933     IF ( cos_zenith > 0 )  THEN
5934        !--Identify solar direction vector (discretized number) 1)
5935        !--
5936        j = FLOOR(ACOS(cos_zenith) / pi * raytrace_discrete_elevs)
5937        i = MODULO(NINT(ATAN2(sun_dir_lon, sun_dir_lat)               &
5938                        / (2._wp*pi) * raytrace_discrete_azims-.5_wp, iwp), &
5939                   raytrace_discrete_azims)
5940        isd = dsidir_rev(j, i)
5941!-- TODO: check if isd = -1 to report that this solar position is not precalculated
5942        DO isurf = 1, nsurfl
5943           j = surfl(iy, isurf)
5944           i = surfl(ix, isurf)
5945           surfinswdir(isurf) = rad_sw_in_dir(j,i) *                        &
5946                costheta(surfl(id, isurf)) * dsitrans(isurf, isd) / cos_zenith
5947        ENDDO
5948!
5949!--     MRT direct irradiance
5950        DO  imrt = 1, nmrtbl
5951           j = mrtbl(iy, imrt)
5952           i = mrtbl(ix, imrt)
5953           mrtinsw(imrt) = mrtinsw(imrt) + mrtdsit(imrt, isd) * rad_sw_in_dir(j,i) &
5954                                     / cos_zenith / 4._wp ! normal to sphere
5955        ENDDO
5956     ENDIF
5957!
5958!--  MRT first pass thermal
5959     DO  imrtf = 1, nmrtf
5960        imrt = mrtfsurf(1, imrtf)
5961        isurfsrc = mrtfsurf(2, imrtf)
5962        mrtinlw(imrt) = mrtinlw(imrt) + mrtf(imrtf) * surfoutl(isurfsrc)
5963     ENDDO
5964!
5965!--  Absorption in each local plant canopy grid box from the first atmospheric
5966!--  pass of radiation
5967     IF ( npcbl > 0 )  THEN
5968
5969         pcbinswdir(:) = 0._wp
5970         pcbinswdif(:) = 0._wp
5971         pcbinlw(:) = 0._wp
5972
5973         DO icsf = 1, ncsfl
5974             ipcgb = csfsurf(1, icsf)
5975             i = pcbl(ix,ipcgb)
5976             j = pcbl(iy,ipcgb)
5977             k = pcbl(iz,ipcgb)
5978             isurfsrc = csfsurf(2, icsf)
5979
5980             IF ( isurfsrc == -1 )  THEN
5981!
5982!--             Diffuse radiation from sky
5983                pcbinswdif(ipcgb) = csf(1,icsf) * rad_sw_in_diff(j,i)
5984!
5985!--             Absorbed diffuse LW radiation from sky minus emitted to sky
5986                IF ( plant_lw_interact )  THEN
5987                   pcbinlw(ipcgb) = csf(1,icsf)                                  &
5988                                       * (rad_lw_in_diff(j, i)                   &
5989                                          - sigma_sb * (pt(k,j,i)*exner(k))**4)
5990                ENDIF
5991!
5992!--             Direct solar radiation
5993                IF ( cos_zenith > 0 )  THEN
5994!--                Estimate directed box absorption
5995                   pc_abs_frac = 1._wp - exp(pc_abs_eff * lad_s(k,j,i))
5996!
5997!--                isd has already been established, see 1)
5998                   pcbinswdir(ipcgb) = rad_sw_in_dir(j, i) * pc_box_area &
5999                                       * pc_abs_frac * dsitransc(ipcgb, isd)
6000                ENDIF
6001             ELSE
6002                IF ( plant_lw_interact )  THEN
6003!
6004!--                Thermal emission from plan canopy towards respective face
6005                   pcrad = sigma_sb * (pt(k,j,i) * exner(k))**4 * csf(1,icsf)
6006                   surfinlg(isurfsrc) = surfinlg(isurfsrc) + pcrad
6007!
6008!--                Remove the flux above + absorb LW from first pass from surfaces
6009                   asrc = facearea(surf(id, isurfsrc))
6010                   pcbinlw(ipcgb) = pcbinlw(ipcgb)                      &
6011                                    + (csf(1,icsf) * surfoutl(isurfsrc) & ! Absorb from first pass surf emit
6012                                       - pcrad)                         & ! Remove emitted heatflux
6013                                    * asrc
6014                ENDIF
6015             ENDIF
6016         ENDDO
6017
6018         pcbinsw(:) = pcbinswdir(:) + pcbinswdif(:)
6019     ENDIF
6020
6021     IF ( plant_lw_interact )  THEN
6022!
6023!--     Exchange incoming lw radiation from plant canopy
6024#if defined( __parallel )
6025        CALL MPI_Allreduce(MPI_IN_PLACE, surfinlg, nsurf, MPI_REAL, MPI_SUM, comm2d, ierr)
6026        IF ( ierr /= 0 )  THEN
6027           WRITE (9,*) 'Error MPI_Allreduce:', ierr
6028           FLUSH(9)
6029        ENDIF
6030        surfinl(:) = surfinl(:) + surfinlg(surfstart(myid)+1:surfstart(myid+1))
6031#else
6032        surfinl(:) = surfinl(:) + surfinlg(:)
6033#endif
6034     ENDIF
6035
6036     surfins = surfinswdir + surfinswdif
6037     surfinl = surfinl + surfinlwdif
6038     surfinsw = surfins
6039     surfinlw = surfinl
6040     surfoutsw = 0.0_wp
6041     surfoutlw = surfoutll
6042     surfemitlwl = surfoutll
6043
6044     IF ( .NOT.  surface_reflections )  THEN
6045!
6046!--     Set nrefsteps to 0 to disable reflections       
6047        nrefsteps = 0
6048        surfoutsl = albedo_surf * surfins
6049        surfoutll = (1._wp - emiss_surf) * surfinl
6050        surfoutsw = surfoutsw + surfoutsl
6051        surfoutlw = surfoutlw + surfoutll
6052     ENDIF
6053
6054!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6055!--     Next passes - reflections
6056!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
6057     DO refstep = 1, nrefsteps
6058
6059         surfoutsl = albedo_surf * surfins
6060!
6061!--      for non-transparent surfaces, longwave albedo is 1 - emissivity
6062         surfoutll = (1._wp - emiss_surf) * surfinl
6063
6064#if defined( __parallel )
6065         CALL MPI_AllGatherv(surfoutsl, nsurfl, MPI_REAL, &
6066             surfouts, nsurfs, surfstart, MPI_REAL, comm2d, ierr)
6067         IF ( ierr /= 0 )  THEN
6068             WRITE(9,*) 'Error MPI_AllGatherv2:', ierr, SIZE(surfoutsl), nsurfl, &
6069                        SIZE(surfouts), nsurfs, surfstart
6070             FLUSH(9)
6071         ENDIF
6072
6073         CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, &
6074             surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr)
6075         IF ( ierr /= 0 )  THEN
6076             WRITE(9,*) 'Error MPI_AllGatherv3:', ierr, SIZE(surfoutll), nsurfl, &
6077                        SIZE(surfoutl), nsurfs, surfstart
6078             FLUSH(9)
6079         ENDIF
6080
6081#else
6082         surfouts = surfoutsl
6083         surfoutl = surfoutll
6084#endif
6085!
6086!--      Reset for the input from next reflective pass
6087         surfins = 0._wp
6088         surfinl = 0._wp
6089!
6090!--      Reflected radiation
6091         DO isvf = 1, nsvfl
6092             isurf = svfsurf(1, isvf)
6093             isurfsrc = svfsurf(2, isvf)
6094             surfins(isurf) = surfins(isurf) + svf(1,isvf) * svf(2,isvf) * surfouts(isurfsrc)
6095             IF ( plant_lw_interact )  THEN
6096                surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc)
6097             ELSE
6098                surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)
6099             ENDIF
6100         ENDDO
6101!
6102!--      NOTE: PC absorbtion and MRT from reflected can both be done at once
6103!--      after all reflections if we do one more MPI_ALLGATHERV on surfout.
6104!--      Advantage: less local computation. Disadvantage: one more collective
6105!--      MPI call.
6106!
6107!--      Radiation absorbed by plant canopy
6108         DO  icsf = 1, ncsfl
6109             ipcgb = csfsurf(1, icsf)
6110             isurfsrc = csfsurf(2, icsf)
6111             IF ( isurfsrc == -1 )  CYCLE ! sky->face only in 1st pass, not here
6112!
6113!--          Calculate source surface area. If the `surf' array is removed
6114!--          before timestepping starts (future version), then asrc must be
6115!--          stored within `csf'
6116             asrc = facearea(surf(id, isurfsrc))
6117             pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * surfouts(isurfsrc) * asrc
6118             IF ( plant_lw_interact )  THEN
6119                pcbinlw(ipcgb) = pcbinlw(ipcgb) + csf(1,icsf) * surfoutl(isurfsrc) * asrc
6120             ENDIF
6121         ENDDO
6122!
6123!--      MRT reflected
6124         DO  imrtf = 1, nmrtf
6125            imrt = mrtfsurf(1, imrtf)
6126            isurfsrc = mrtfsurf(2, imrtf)
6127            mrtinsw(imrt) = mrtinsw(imrt) + mrtft(imrtf) * surfouts(isurfsrc)
6128            mrtinlw(imrt) = mrtinlw(imrt) + mrtf(imrtf) * surfoutl(isurfsrc)
6129         ENDDO
6130
6131         surfinsw = surfinsw  + surfins
6132         surfinlw = surfinlw  + surfinl
6133         surfoutsw = surfoutsw + surfoutsl
6134         surfoutlw = surfoutlw + surfoutll
6135
6136     ENDDO ! refstep
6137
6138!--  push heat flux absorbed by plant canopy to respective 3D arrays
6139     IF ( npcbl > 0 )  THEN
6140         pc_heating_rate(:,:,:) = 0.0_wp
6141         DO ipcgb = 1, npcbl
6142             j = pcbl(iy, ipcgb)
6143             i = pcbl(ix, ipcgb)
6144             k = pcbl(iz, ipcgb)
6145!
6146!--          Following expression equals former kk = k - nzb_s_inner(j,i)
6147             kk = k - topo_top_ind(j,i,0)  !- lad arrays are defined flat
6148             pc_heating_rate(kk, j, i) = (pcbinsw(ipcgb) + pcbinlw(ipcgb)) &
6149                 * pchf_prep(k) * pt(k, j, i) !-- = dT/dt
6150         ENDDO
6151
6152         IF ( humidity .AND. plant_canopy_transpiration ) THEN
6153!--          Calculation of plant canopy transpiration rate and correspondidng latent heat rate
6154             pc_transpiration_rate(:,:,:) = 0.0_wp
6155             pc_latent_rate(:,:,:) = 0.0_wp
6156             DO ipcgb = 1, npcbl
6157                 i = pcbl(ix, ipcgb)
6158                 j = pcbl(iy, ipcgb)
6159                 k = pcbl(iz, ipcgb)
6160                 kk = k - topo_top_ind(j,i,0)  !- lad arrays are defined flat
6161                 CALL pcm_calc_transpiration_rate( i, j, k, kk, pcbinsw(ipcgb), pcbinlw(ipcgb), &
6162                                                   pc_transpiration_rate(kk,j,i), pc_latent_rate(kk,j,i) )
6163              ENDDO
6164         ENDIF
6165     ENDIF
6166!
6167!--  Calculate black body MRT (after all reflections)
6168     IF ( nmrtbl > 0 )  THEN
6169        IF ( mrt_include_sw )  THEN
6170           mrt(:) = ((mrtinsw(:) + mrtinlw(:)) / sigma_sb) ** .25_wp
6171        ELSE
6172           mrt(:) = (mrtinlw(:) / sigma_sb) ** .25_wp
6173        ENDIF
6174     ENDIF
6175!
6176!--     Transfer radiation arrays required for energy balance to the respective data types
6177     DO  i = 1, nsurfl
6178        m  = surfl(im,i)
6179!
6180!--     (1) Urban surfaces
6181!--     upward-facing
6182        IF ( surfl(1,i) == iup_u )  THEN
6183           surf_usm_h%rad_sw_in(m)  = surfinsw(i)
6184           surf_usm_h%rad_sw_out(m) = surfoutsw(i)
6185           surf_usm_h%rad_sw_dir(m) = surfinswdir(i)
6186           surf_usm_h%rad_sw_dif(m) = surfinswdif(i)
6187           surf_usm_h%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) -        &
6188                                      surfinswdif(i)
6189           surf_usm_h%rad_sw_res(m) = surfins(i)
6190           surf_usm_h%rad_lw_in(m)  = surfinlw(i)
6191           surf_usm_h%rad_lw_out(m) = surfoutlw(i)
6192           surf_usm_h%rad_net(m)    = surfinsw(i) - surfoutsw(i) +          &
6193                                      surfinlw(i) - surfoutlw(i)
6194           surf_usm_h%rad_net_l(m)  = surf_usm_h%rad_net(m)
6195           surf_usm_h%rad_lw_dif(m) = surfinlwdif(i)
6196           surf_usm_h%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6197           surf_usm_h%rad_lw_res(m) = surfinl(i)
6198!
6199!--     northward-facding
6200        ELSEIF ( surfl(1,i) == inorth_u )  THEN
6201           surf_usm_v(0)%rad_sw_in(m)  = surfinsw(i)
6202           surf_usm_v(0)%rad_sw_out(m) = surfoutsw(i)
6203           surf_usm_v(0)%rad_sw_dir(m) = surfinswdir(i)
6204           surf_usm_v(0)%rad_sw_dif(m) = surfinswdif(i)
6205           surf_usm_v(0)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) -     &
6206                                         surfinswdif(i)
6207           surf_usm_v(0)%rad_sw_res(m) = surfins(i)
6208           surf_usm_v(0)%rad_lw_in(m)  = surfinlw(i)
6209           surf_usm_v(0)%rad_lw_out(m) = surfoutlw(i)
6210           surf_usm_v(0)%rad_net(m)    = surfinsw(i) - surfoutsw(i) +       &
6211                                         surfinlw(i) - surfoutlw(i)
6212           surf_usm_v(0)%rad_net_l(m)  = surf_usm_v(0)%rad_net(m)
6213           surf_usm_v(0)%rad_lw_dif(m) = surfinlwdif(i)
6214           surf_usm_v(0)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6215           surf_usm_v(0)%rad_lw_res(m) = surfinl(i)
6216!
6217!--     southward-facding
6218        ELSEIF ( surfl(1,i) == isouth_u )  THEN
6219           surf_usm_v(1)%rad_sw_in(m)  = surfinsw(i)
6220           surf_usm_v(1)%rad_sw_out(m) = surfoutsw(i)
6221           surf_usm_v(1)%rad_sw_dir(m) = surfinswdir(i)
6222           surf_usm_v(1)%rad_sw_dif(m) = surfinswdif(i)
6223           surf_usm_v(1)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) -     &
6224                                         surfinswdif(i)
6225           surf_usm_v(1)%rad_sw_res(m) = surfins(i)
6226           surf_usm_v(1)%rad_lw_in(m)  = surfinlw(i)
6227           surf_usm_v(1)%rad_lw_out(m) = surfoutlw(i)
6228           surf_usm_v(1)%rad_net(m)    = surfinsw(i) - surfoutsw(i) +       &
6229                                         surfinlw(i) - surfoutlw(i)
6230           surf_usm_v(1)%rad_net_l(m)  = surf_usm_v(1)%rad_net(m)
6231           surf_usm_v(1)%rad_lw_dif(m) = surfinlwdif(i)
6232           surf_usm_v(1)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6233           surf_usm_v(1)%rad_lw_res(m) = surfinl(i)
6234!
6235!--     eastward-facing
6236        ELSEIF ( surfl(1,i) == ieast_u )  THEN
6237           surf_usm_v(2)%rad_sw_in(m)  = surfinsw(i)
6238           surf_usm_v(2)%rad_sw_out(m) = surfoutsw(i)
6239           surf_usm_v(2)%rad_sw_dir(m) = surfinswdir(i)
6240           surf_usm_v(2)%rad_sw_dif(m) = surfinswdif(i)
6241           surf_usm_v(2)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) -     &
6242                                         surfinswdif(i)
6243           surf_usm_v(2)%rad_sw_res(m) = surfins(i)
6244           surf_usm_v(2)%rad_lw_in(m)  = surfinlw(i)
6245           surf_usm_v(2)%rad_lw_out(m) = surfoutlw(i)
6246           surf_usm_v(2)%rad_net(m)    = surfinsw(i) - surfoutsw(i) +       &
6247                                         surfinlw(i) - surfoutlw(i)
6248           surf_usm_v(2)%rad_net_l(m)  = surf_usm_v(2)%rad_net(m)
6249           surf_usm_v(2)%rad_lw_dif(m) = surfinlwdif(i)
6250           surf_usm_v(2)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6251           surf_usm_v(2)%rad_lw_res(m) = surfinl(i)
6252!
6253!--     westward-facding
6254        ELSEIF ( surfl(1,i) == iwest_u )  THEN
6255           surf_usm_v(3)%rad_sw_in(m)  = surfinsw(i)
6256           surf_usm_v(3)%rad_sw_out(m) = surfoutsw(i)
6257           surf_usm_v(3)%rad_sw_dir(m) = surfinswdir(i)
6258           surf_usm_v(3)%rad_sw_dif(m) = surfinswdif(i)
6259           surf_usm_v(3)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) -     &
6260                                         surfinswdif(i)
6261           surf_usm_v(3)%rad_sw_res(m) = surfins(i)
6262           surf_usm_v(3)%rad_lw_in(m)  = surfinlw(i)
6263           surf_usm_v(3)%rad_lw_out(m) = surfoutlw(i)
6264           surf_usm_v(3)%rad_net(m)    = surfinsw(i) - surfoutsw(i) +       &
6265                                         surfinlw(i) - surfoutlw(i)
6266           surf_usm_v(3)%rad_net_l(m)  = surf_usm_v(3)%rad_net(m)
6267           surf_usm_v(3)%rad_lw_dif(m) = surfinlwdif(i)
6268           surf_usm_v(3)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6269           surf_usm_v(3)%rad_lw_res(m) = surfinl(i)
6270!
6271!--     (2) land surfaces
6272!--     upward-facing
6273        ELSEIF ( surfl(1,i) == iup_l )  THEN
6274           surf_lsm_h%rad_sw_in(m)  = surfinsw(i)
6275           surf_lsm_h%rad_sw_out(m) = surfoutsw(i)
6276           surf_lsm_h%rad_sw_dir(m) = surfinswdir(i)
6277           surf_lsm_h%rad_sw_dif(m) = surfinswdif(i)
6278           surf_lsm_h%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) -        &
6279                                         surfinswdif(i)
6280           surf_lsm_h%rad_sw_res(m) = surfins(i)
6281           surf_lsm_h%rad_lw_in(m)  = surfinlw(i)
6282           surf_lsm_h%rad_lw_out(m) = surfoutlw(i)
6283           surf_lsm_h%rad_net(m)    = surfinsw(i) - surfoutsw(i) +          &
6284                                      surfinlw(i) - surfoutlw(i)
6285           surf_lsm_h%rad_lw_dif(m) = surfinlwdif(i)
6286           surf_lsm_h%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6287           surf_lsm_h%rad_lw_res(m) = surfinl(i)
6288!
6289!--     northward-facding
6290        ELSEIF ( surfl(1,i) == inorth_l )  THEN
6291           surf_lsm_v(0)%rad_sw_in(m)  = surfinsw(i)
6292           surf_lsm_v(0)%rad_sw_out(m) = surfoutsw(i)
6293           surf_lsm_v(0)%rad_sw_dir(m) = surfinswdir(i)
6294           surf_lsm_v(0)%rad_sw_dif(m) = surfinswdif(i)
6295           surf_lsm_v(0)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) -     &
6296                                         surfinswdif(i)
6297           surf_lsm_v(0)%rad_sw_res(m) = surfins(i)
6298           surf_lsm_v(0)%rad_lw_in(m)  = surfinlw(i)
6299           surf_lsm_v(0)%rad_lw_out(m) = surfoutlw(i)
6300           surf_lsm_v(0)%rad_net(m)    = surfinsw(i) - surfoutsw(i) +       &
6301                                         surfinlw(i) - surfoutlw(i)
6302           surf_lsm_v(0)%rad_lw_dif(m) = surfinlwdif(i)
6303           surf_lsm_v(0)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6304           surf_lsm_v(0)%rad_lw_res(m) = surfinl(i)
6305!
6306!--     southward-facding
6307        ELSEIF ( surfl(1,i) == isouth_l )  THEN
6308           surf_lsm_v(1)%rad_sw_in(m)  = surfinsw(i)
6309           surf_lsm_v(1)%rad_sw_out(m) = surfoutsw(i)
6310           surf_lsm_v(1)%rad_sw_dir(m) = surfinswdir(i)
6311           surf_lsm_v(1)%rad_sw_dif(m) = surfinswdif(i)
6312           surf_lsm_v(1)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) -     &
6313                                         surfinswdif(i)
6314           surf_lsm_v(1)%rad_sw_res(m) = surfins(i)
6315           surf_lsm_v(1)%rad_lw_in(m)  = surfinlw(i)
6316           surf_lsm_v(1)%rad_lw_out(m) = surfoutlw(i)
6317           surf_lsm_v(1)%rad_net(m)    = surfinsw(i) - surfoutsw(i) +       &
6318                                         surfinlw(i) - surfoutlw(i)
6319           surf_lsm_v(1)%rad_lw_dif(m) = surfinlwdif(i)
6320           surf_lsm_v(1)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6321           surf_lsm_v(1)%rad_lw_res(m) = surfinl(i)
6322!
6323!--     eastward-facing
6324        ELSEIF ( surfl(1,i) == ieast_l )  THEN
6325           surf_lsm_v(2)%rad_sw_in(m)  = surfinsw(i)
6326           surf_lsm_v(2)%rad_sw_out(m) = surfoutsw(i)
6327           surf_lsm_v(2)%rad_sw_dir(m) = surfinswdir(i)
6328           surf_lsm_v(2)%rad_sw_dif(m) = surfinswdif(i)
6329           surf_lsm_v(2)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) -     &
6330                                         surfinswdif(i)
6331           surf_lsm_v(2)%rad_sw_res(m) = surfins(i)
6332           surf_lsm_v(2)%rad_lw_in(m)  = surfinlw(i)
6333           surf_lsm_v(2)%rad_lw_out(m) = surfoutlw(i)
6334           surf_lsm_v(2)%rad_net(m)    = surfinsw(i) - surfoutsw(i) +       &
6335                                         surfinlw(i) - surfoutlw(i)
6336           surf_lsm_v(2)%rad_lw_dif(m) = surfinlwdif(i)
6337           surf_lsm_v(2)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6338           surf_lsm_v(2)%rad_lw_res(m) = surfinl(i)
6339!
6340!--     westward-facing
6341        ELSEIF ( surfl(1,i) == iwest_l )  THEN
6342           surf_lsm_v(3)%rad_sw_in(m)  = surfinsw(i)
6343           surf_lsm_v(3)%rad_sw_out(m) = surfoutsw(i)
6344           surf_lsm_v(3)%rad_sw_dir(m) = surfinswdir(i)
6345           surf_lsm_v(3)%rad_sw_dif(m) = surfinswdif(i)
6346           surf_lsm_v(3)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) -     &
6347                                         surfinswdif(i)
6348           surf_lsm_v(3)%rad_sw_res(m) = surfins(i)
6349           surf_lsm_v(3)%rad_lw_in(m)  = surfinlw(i)
6350           surf_lsm_v(3)%rad_lw_out(m) = surfoutlw(i)
6351           surf_lsm_v(3)%rad_net(m)    = surfinsw(i) - surfoutsw(i) +       &
6352                                         surfinlw(i) - surfoutlw(i)
6353           surf_lsm_v(3)%rad_lw_dif(m) = surfinlwdif(i)
6354           surf_lsm_v(3)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i)
6355           surf_lsm_v(3)%rad_lw_res(m) = surfinl(i)
6356        ENDIF
6357
6358     ENDDO
6359
6360     DO  m = 1, surf_usm_h%ns
6361        surf_usm_h%surfhf(m) = surf_usm_h%rad_sw_in(m)  +                   &
6362                               surf_usm_h%rad_lw_in(m)  -                   &
6363                               surf_usm_h%rad_sw_out(m) -                   &
6364                               surf_usm_h%rad_lw_out(m)
6365     ENDDO
6366     DO  m = 1, surf_lsm_h%ns
6367        surf_lsm_h%surfhf(m) = surf_lsm_h%rad_sw_in(m)  +                   &
6368                               surf_lsm_h%rad_lw_in(m)  -                   &
6369                               surf_lsm_h%rad_sw_out(m) -                   &
6370                               surf_lsm_h%rad_lw_out(m)
6371     ENDDO
6372
6373     DO  l = 0, 3
6374!--     urban
6375        DO  m = 1, surf_usm_v(l)%ns
6376           surf_usm_v(l)%surfhf(m) = surf_usm_v(l)%rad_sw_in(m)  +          &
6377                                     surf_usm_v(l)%rad_lw_in(m)  -          &
6378                                     surf_usm_v(l)%rad_sw_out(m) -          &
6379                                     surf_usm_v(l)%rad_lw_out(m)
6380        ENDDO
6381!--     land
6382        DO  m = 1, surf_lsm_v(l)%ns
6383           surf_lsm_v(l)%surfhf(m) = surf_lsm_v(l)%rad_sw_in(m)  +          &
6384                                     surf_lsm_v(l)%rad_lw_in(m)  -          &
6385                                     surf_lsm_v(l)%rad_sw_out(m) -          &
6386                                     surf_lsm_v(l)%rad_lw_out(m)
6387
6388        ENDDO
6389     ENDDO
6390!
6391!--  Calculate the average temperature, albedo, and emissivity for urban/land
6392!--  domain when using average_radiation in the respective radiation model
6393
6394!--  calculate horizontal area
6395! !!! ATTENTION!!! uniform grid is assumed here
6396     area_hor = (nx+1) * (ny+1) * dx * dy
6397!
6398!--  absorbed/received SW & LW and emitted LW energy of all physical
6399!--  surfaces (land and urban) in local processor
6400     pinswl = 0._wp
6401     pinlwl = 0._wp
6402     pabsswl = 0._wp
6403     pabslwl = 0._wp
6404     pemitlwl = 0._wp
6405     emiss_sum_surfl = 0._wp
6406     area_surfl = 0._wp
6407     DO  i = 1, nsurfl
6408        d = surfl(id, i)
6409!--  received SW & LW
6410        pinswl = pinswl + (surfinswdir(i) + surfinswdif(i)) * facearea(d)
6411        pinlwl = pinlwl + surfinlwdif(i) * facearea(d)
6412!--   absorbed SW & LW
6413        pabsswl = pabsswl + (1._wp - albedo_surf(i)) *                   &
6414                                                surfinsw(i) * facearea(d)
6415        pabslwl = pabslwl + emiss_surf(i) * surfinlw(i) * facearea(d)
6416!--   emitted LW
6417        pemitlwl = pemitlwl + surfemitlwl(i) * facearea(d)
6418!--   emissivity and area sum
6419        emiss_sum_surfl = emiss_sum_surfl + emiss_surf(i) * facearea(d)
6420        area_surfl = area_surfl + facearea(d)
6421     END DO
6422!
6423!--  add the absorbed SW energy by plant canopy
6424     IF ( npcbl > 0 )  THEN
6425        pabsswl = pabsswl + SUM(pcbinsw)
6426        pabslwl = pabslwl + SUM(pcbinlw)
6427        pinswl  = pinswl + SUM(pcbinswdir) + SUM(pcbinswdif)
6428     ENDIF
6429!
6430!--  gather all rad flux energy in all processors. In order to reduce
6431!--  the number of MPI calls (to reduce latencies), combine the required
6432!--  quantities in one array, sum it up, and subsequently re-distribute
6433!--  back to the respective quantities.
6434#if defined( __parallel )
6435     combine_allreduce_l(1) = pinswl
6436     combine_allreduce_l(2) = pinlwl
6437     combine_allreduce_l(3) = pabsswl
6438     combine_allreduce_l(4) = pabslwl
6439     combine_allreduce_l(5) = pemitlwl
6440     combine_allreduce_l(6) = emiss_sum_surfl
6441     combine_allreduce_l(7) = area_surfl
6442     
6443     CALL MPI_ALLREDUCE( combine_allreduce_l,                                  &
6444                         combine_allreduce,                                    &
6445                         SIZE( combine_allreduce ),                            &
6446                         MPI_REAL,                                             &
6447                         MPI_SUM,                                              &
6448                         comm2d,                                               &
6449                         ierr )
6450     
6451     pinsw          = combine_allreduce(1)
6452     pinlw          = combine_allreduce(2)
6453     pabssw         = combine_allreduce(3)
6454     pabslw         = combine_allreduce(4)
6455     pemitlw        = combine_allreduce(5)
6456     emiss_sum_surf = combine_allreduce(6)
6457     area_surf      = combine_allreduce(7)
6458#else
6459     pinsw          = pinswl
6460     pinlw          = pinlwl
6461     pabssw         = pabsswl
6462     pabslw         = pabslwl
6463     pemitlw        = pemitlwl
6464     emiss_sum_surf = emiss_sum_surfl
6465     area_surf      = area_surfl
6466#endif
6467
6468!--  (1) albedo
6469     IF ( pinsw /= 0.0_wp )  albedo_urb = ( pinsw - pabssw ) / pinsw
6470!--  (2) average emmsivity
6471     IF ( area_surf /= 0.0_wp )  emissivity_urb = emiss_sum_surf / area_surf
6472!
6473!--  Temporally comment out calculation of effective radiative temperature.
6474!--  See below for more explanation.
6475!--  (3) temperature
6476!--   first we calculate an effective horizontal area to account for
6477!--   the effect of vertical surfaces (which contributes to LW emission)
6478!--   We simply use the ratio of the total LW to the incoming LW flux
6479      area_hor = pinlw / rad_lw_in_diff(nyn,nxl)
6480      t_rad_urb = ( ( pemitlw - pabslw + emissivity_urb * pinlw ) / &
6481           (emissivity_urb * sigma_sb * area_hor) )**0.25_wp     
6482
6483     IF ( debug_output_timestep )  CALL debug_message( 'radiation_interaction', 'end' )
6484
6485
6486    CONTAINS
6487
6488!------------------------------------------------------------------------------!
6489!> Calculates radiation absorbed by box with given size and LAD.
6490!>
6491!> Simulates resol**2 rays (by equally spacing a bounding horizontal square
6492!> conatining all possible rays that would cross the box) and calculates
6493!> average transparency per ray. Returns fraction of absorbed radiation flux
6494!> and area for which this fraction is effective.
6495!------------------------------------------------------------------------------!
6496    PURE SUBROUTINE box_absorb(boxsize, resol, dens, uvec, area, absorb)
6497       IMPLICIT NONE
6498
6499       REAL(wp), DIMENSION(3), INTENT(in) :: &
6500            boxsize, &      !< z, y, x size of box in m
6501            uvec            !< z, y, x unit vector of incoming flux
6502       INTEGER(iwp), INTENT(in) :: &
6503            resol           !< No. of rays in x and y dimensions
6504       REAL(wp), INTENT(in) :: &
6505            dens            !< box density (e.g. Leaf Area Density)
6506       REAL(wp), INTENT(out) :: &
6507            area, &         !< horizontal area for flux absorbtion
6508            absorb          !< fraction of absorbed flux
6509       REAL(wp) :: &
6510            xshift, yshift, &
6511            xmin, xmax, ymin, ymax, &
6512            xorig, yorig, &
6513            dx1, dy1, dz1, dx2, dy2, dz2, &
6514            crdist, &
6515            transp
6516       INTEGER(iwp) :: &
6517            i, j
6518
6519       xshift = uvec(3) / uvec(1) * boxsize(1)
6520       xmin = min(0._wp, -xshift)
6521       xmax = boxsize(3) + max(0._wp, -xshift)
6522       yshift = uvec(2) / uvec(1) * boxsize(1)
6523       ymin = min(0._wp, -yshift)
6524       ymax = boxsize(2) + max(0._wp, -yshift)
6525
6526       transp = 0._wp
6527       DO i = 1, resol
6528          xorig = xmin + (xmax-xmin) * (i-.5_wp) / resol
6529          DO j = 1, resol
6530             yorig = ymin + (ymax-ymin) * (j-.5_wp) / resol
6531
6532             dz1 = 0._wp
6533             dz2 = boxsize(1)/uvec(1)
6534
6535             IF ( uvec(2) > 0._wp )  THEN
6536                dy1 = -yorig             / uvec(2) !< crossing with y=0
6537                dy2 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2)
6538             ELSE !uvec(2)==0
6539                dy1 = -huge(1._wp)
6540                dy2 = huge(1._wp)
6541             ENDIF
6542
6543             IF ( uvec(3) > 0._wp )  THEN
6544                dx1 = -xorig             / uvec(3) !< crossing with x=0
6545                dx2 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3)
6546             ELSE !uvec(3)==0
6547                dx1 = -huge(1._wp)
6548                dx2 = huge(1._wp)
6549             ENDIF
6550
6551             crdist = max(0._wp, (min(dz2, dy2, dx2) - max(dz1, dy1, dx1)))
6552             transp = transp + exp(-ext_coef * dens * crdist)
6553          ENDDO
6554       ENDDO
6555       transp = transp / resol**2
6556       area = (boxsize(3)+xshift)*(boxsize(2)+yshift)
6557       absorb = 1._wp - transp
6558
6559    END SUBROUTINE box_absorb
6560
6561!------------------------------------------------------------------------------!
6562! Description:
6563! ------------
6564!> This subroutine splits direct and diffusion dw radiation
6565!> It sould not be called in case the radiation model already does it
6566!> It follows Boland, Ridley & Brown (2008)
6567!------------------------------------------------------------------------------!
6568    SUBROUTINE calc_diffusion_radiation 
6569
6570       USE palm_date_time_mod,                                                 &
6571           ONLY:  seconds_per_day
6572
6573       INTEGER(iwp)        ::  i                        !< grid index x-direction
6574       INTEGER(iwp)        ::  j                        !< grid index y-direction
6575       INTEGER(iwp)        ::  days_per_year            !< days in the current year
6576
6577       REAL(wp)            ::  clearnessIndex           !< clearness index
6578       REAL(wp)            ::  corrected_solarUp        !< corrected solar up radiation
6579       REAL(wp)            ::  diff_frac                !< diffusion fraction of the radiation
6580       REAL(wp)            ::  etr                      !< extraterestrial radiation
6581       REAL(wp)            ::  horizontalETR            !< horizontal extraterestrial radiation
6582       REAL(wp), PARAMETER ::  lowest_solarUp = 0.1_wp  !< limit the sun elevation to protect stability of the calculation
6583       REAL(wp)            ::  second_of_year           !< current second of the year
6584       REAL(wp)            ::  year_angle               !< angle
6585
6586!
6587!--     Calculate current day and time based on the initial values and simulation time
6588        CALL get_date_time( time_since_reference_point,      &
6589                            second_of_year = second_of_year, &
6590                            days_per_year = days_per_year    )
6591        year_angle = second_of_year / ( REAL( days_per_year, KIND=wp ) * seconds_per_day ) &
6592                   * 2.0_wp * pi
6593
6594        etr = solar_constant * (1.00011_wp +                                   &
6595                          0.034221_wp * cos(year_angle) +                      &
6596                          0.001280_wp * sin(year_angle) +                      &
6597                          0.000719_wp * cos(2.0_wp * year_angle) +             &
6598                          0.000077_wp * sin(2.0_wp * year_angle))
6599       
6600!--   
6601!--     Under a very low angle, we keep extraterestrial radiation at
6602!--     the last small value, therefore the clearness index will be pushed
6603!--     towards 0 while keeping full continuity.   
6604        IF ( cos_zenith <= lowest_solarUp )  THEN
6605            corrected_solarUp = lowest_solarUp
6606        ELSE
6607            corrected_solarUp = cos_zenith
6608        ENDIF
6609       
6610        horizontalETR = etr * corrected_solarUp
6611       
6612        DO i = nxl, nxr
6613            DO j = nys, nyn
6614                clearnessIndex = rad_sw_in(0,j,i) / horizontalETR
6615                diff_frac = 1.0_wp / (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex))
6616                rad_sw_in_diff(j,i) = rad_sw_in(0,j,i) * diff_frac
6617                rad_sw_in_dir(j,i)  = rad_sw_in(0,j,i) * (1.0_wp - diff_frac)
6618                rad_lw_in_diff(j,i) = rad_lw_in(0,j,i)
6619            ENDDO
6620        ENDDO
6621       
6622    END SUBROUTINE calc_diffusion_radiation
6623
6624 END SUBROUTINE radiation_interaction
6625   
6626!------------------------------------------------------------------------------!
6627! Description:
6628! ------------
6629!> This subroutine initializes structures needed for radiative transfer
6630!> model. This model calculates transformation processes of the
6631!> radiation inside urban and land canopy layer. The module includes also
6632!> the interaction of the radiation with the resolved plant canopy.
6633!>
6634!> For more info. see Resler et al. 2017
6635!>
6636!> The new version 2.0 was radically rewriten, the discretization scheme
6637!> has been changed. This new version significantly improves effectivity
6638!> of the paralelization and the scalability of the model.
6639!>
6640!------------------------------------------------------------------------------!
6641    SUBROUTINE radiation_interaction_init
6642
6643       USE control_parameters,                                                 &
6644           ONLY:  dz_stretch_level_start
6645
6646       USE plant_canopy_model_mod,                                             &
6647           ONLY:  lad_s
6648
6649       IMPLICIT NONE
6650
6651       INTEGER(iwp) :: i, j, k, l, m, d
6652       INTEGER(iwp) :: k_topo     !< vertical index indicating topography top for given (j,i)
6653       INTEGER(iwp) :: nzptl, nzubl, nzutl, isurf, ipcgb, imrt
6654       REAL(wp)     :: mrl
6655#if defined( __parallel )
6656       INTEGER(iwp), DIMENSION(:), POINTER, SAVE ::  gridsurf_rma   !< fortran pointer, but lower bounds are 1
6657       TYPE(c_ptr)                               ::  gridsurf_rma_p !< allocated c pointer
6658       INTEGER(iwp)                              ::  minfo          !< MPI RMA window info handle
6659#endif
6660
6661!
6662!--     precalculate face areas for different face directions using normal vector
6663        DO d = 0, nsurf_type
6664            facearea(d) = 1._wp
6665            IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx
6666            IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy
6667            IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz(1)
6668        ENDDO
6669!
6670!--    Find nz_urban_b, nz_urban_t, nz_urban via wall_flag_0 array (nzb_s_inner will be
6671!--    removed later). The following contruct finds the lowest / largest index
6672!--    for any upward-facing wall (see bit 12).
6673       nzubl = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
6674       nzutl = MAXVAL( topo_top_ind(nys:nyn,nxl:nxr,0) )
6675
6676       nzubl = MAX( nzubl, nzb )
6677
6678       IF ( plant_canopy )  THEN
6679!--        allocate needed arrays
6680           ALLOCATE( pct(nys:nyn,nxl:nxr) )
6681           ALLOCATE( pch(nys:nyn,nxl:nxr) )
6682
6683!--        calculate plant canopy height
6684           npcbl = 0
6685           pct   = 0
6686           pch   = 0
6687           DO i = nxl, nxr
6688               DO j = nys, nyn
6689!
6690!--                Find topography top index
6691                   k_topo = topo_top_ind(j,i,0)
6692
6693                   DO k = nzt+1, 0, -1
6694                       IF ( lad_s(k,j,i) /= 0.0_wp )  THEN
6695!--                        we are at the top of the pcs
6696                           pct(j,i) = k + k_topo
6697                           pch(j,i) = k
6698                           npcbl = npcbl + pch(j,i)
6699                           EXIT
6700                       ENDIF
6701                   ENDDO
6702               ENDDO
6703           ENDDO
6704
6705           nzutl = MAX( nzutl, MAXVAL( pct ) )
6706           nzptl = MAXVAL( pct )
6707
6708           prototype_lad = MAXVAL( lad_s ) * .9_wp  !< better be *1.0 if lad is either 0 or maxval(lad) everywhere
6709           IF ( prototype_lad <= 0._wp ) prototype_lad = .3_wp
6710           !WRITE(message_string, '(a,f6.3)') 'Precomputing effective box optical ' &
6711           !    // 'depth using prototype leaf area density = ', prototype_lad
6712           !CALL message('radiation_interaction_init', 'PA0520', 0, 0, -1, 6, 0)
6713       ENDIF
6714
6715       nzutl = MIN( nzutl + nzut_free, nzt )
6716
6717#if defined( __parallel )
6718       CALL MPI_AllReduce(nzubl, nz_urban_b, 1, MPI_INTEGER, MPI_MIN, comm2d, ierr )
6719       IF ( ierr /= 0 ) THEN
6720           WRITE(9,*) 'Error MPI_AllReduce11:', ierr, nzubl, nz_urban_b
6721           FLUSH(9)
6722       ENDIF
6723       CALL MPI_AllReduce(nzutl, nz_urban_t, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr )
6724       IF ( ierr /= 0 ) THEN
6725           WRITE(9,*) 'Error MPI_AllReduce12:', ierr, nzutl, nz_urban_t
6726           FLUSH(9)
6727       ENDIF
6728       CALL MPI_AllReduce(nzptl, nz_plant_t, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr )
6729       IF ( ierr /= 0 ) THEN
6730           WRITE(9,*) 'Error MPI_AllReduce13:', ierr, nzptl, nz_plant_t
6731           FLUSH(9)
6732       ENDIF
6733#else
6734       nz_urban_b = nzubl
6735       nz_urban_t = nzutl
6736       nz_plant_t = nzptl
6737#endif
6738!
6739!--    Stretching (non-uniform grid spacing) is not considered in the radiation
6740!--    model. Therefore, vertical stretching has to be applied above the area
6741!--    where the parts of the radiation model which assume constant grid spacing
6742!--    are active. ABS (...) is required because the default value of
6743!--    dz_stretch_level_start is -9999999.9_wp (negative).
6744       IF ( ABS( dz_stretch_level_start(1) ) <= zw(nz_urban_t) ) THEN
6745          WRITE( message_string, * ) 'The lowest level where vertical ',       &
6746                                     'stretching is applied have to be ',      &
6747                                     'greater than ', zw(nz_urban_t)
6748          CALL message( 'radiation_interaction_init', 'PA0496', 1, 2, 0, 6, 0 )
6749       ENDIF 
6750!
6751!--    global number of urban and plant layers
6752       nz_urban = nz_urban_t - nz_urban_b + 1
6753       nz_plant = nz_plant_t - nz_urban_b + 1
6754!
6755!--    check max_raytracing_dist relative to urban surface layer height
6756       mrl = 2.0_wp * nz_urban * dz(1)
6757!--    set max_raytracing_dist to double the urban surface layer height, if not set
6758       IF ( max_raytracing_dist == -999.0_wp ) THEN
6759          max_raytracing_dist = mrl
6760       ENDIF
6761!--    check if max_raytracing_dist set too low (here we only warn the user. Other
6762!      option is to correct the value again to double the urban surface layer height)
6763       IF ( max_raytracing_dist  <  mrl ) THEN
6764          WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist is set less than ' // &
6765               'double the urban surface layer height, i.e. ', mrl
6766          CALL message('radiation_interaction_init', 'PA0521', 0, 0, 0, 6, 0 )
6767       ENDIF
6768!        IF ( max_raytracing_dist <= mrl ) THEN
6769!           IF ( max_raytracing_dist /= -999.0_wp ) THEN
6770! !--          max_raytracing_dist too low
6771!              WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist too low, ' &
6772!                    // 'override to value ', mrl
6773!              CALL message('radiation_interaction_init', 'PA0521', 0, 0, -1, 6, 0)
6774!           ENDIF
6775!           max_raytracing_dist = mrl
6776!        ENDIF
6777!
6778!--    allocate urban surfaces grid
6779!--    calc number of surfaces in local proc
6780       IF ( debug_output )  CALL debug_message( 'calculation of indices for surfaces', 'info' )
6781
6782       nsurfl = 0
6783!
6784!--    Number of horizontal surfaces including land- and roof surfaces in both USM and LSM. Note that
6785!--    All horizontal surface elements are already counted in surface_mod.
6786       startland = 1
6787       nsurfl    = surf_usm_h%ns + surf_lsm_h%ns
6788       endland   = nsurfl
6789       nlands    = endland - startland + 1
6790
6791!
6792!--    Number of vertical surfaces in both USM and LSM. Note that all vertical surface elements are
6793!--    already counted in surface_mod.
6794       startwall = nsurfl+1
6795       DO  i = 0,3
6796          nsurfl = nsurfl + surf_usm_v(i)%ns + surf_lsm_v(i)%ns
6797       ENDDO
6798       endwall = nsurfl
6799       nwalls  = endwall - startwall + 1
6800       dirstart = (/ startland, startwall, startwall, startwall, startwall /)
6801       dirend = (/ endland, endwall, endwall, endwall, endwall /)
6802
6803!--    fill gridpcbl and pcbl
6804       IF ( npcbl > 0 )  THEN
6805           ALLOCATE( pcbl(iz:ix, 1:npcbl) )
6806           ALLOCATE( gridpcbl(nz_urban_b:nz_plant_t,nys:nyn,nxl:nxr) )
6807           pcbl = -1
6808           gridpcbl(:,:,:) = 0
6809           ipcgb = 0
6810           DO i = nxl, nxr
6811               DO j = nys, nyn
6812!
6813!--                Find topography top index
6814                   k_topo = topo_top_ind(j,i,0)
6815
6816                   DO k = k_topo + 1, pct(j,i)
6817                       ipcgb = ipcgb + 1
6818                       gridpcbl(k,j,i) = ipcgb
6819                       pcbl(:,ipcgb) = (/ k, j, i /)
6820                   ENDDO
6821               ENDDO
6822           ENDDO
6823           ALLOCATE( pcbinsw( 1:npcbl ) )
6824           ALLOCATE( pcbinswdir( 1:npcbl ) )
6825           ALLOCATE( pcbinswdif( 1:npcbl ) )
6826           ALLOCATE( pcbinlw( 1:npcbl ) )
6827       ENDIF
6828
6829!
6830!--    Fill surfl (the ordering of local surfaces given by the following
6831!--    cycles must not be altered, certain file input routines may depend
6832!--    on it).
6833!
6834!--    We allocate the array as linear and then use a two-dimensional pointer
6835!--    into it, because some MPI implementations crash with 2D-allocated arrays.
6836       ALLOCATE(surfl_linear(nidx_surf*nsurfl))
6837       surfl(1:nidx_surf,1:nsurfl) => surfl_linear(1:nidx_surf*nsurfl)
6838       isurf = 0
6839       IF ( rad_angular_discretization )  THEN
6840!
6841!--       Allocate and fill the reverse indexing array gridsurf
6842#if defined( __parallel )
6843!
6844!--       raytrace_mpi_rma is asserted
6845
6846          CALL MPI_Info_create(minfo, ierr)
6847          IF ( ierr /= 0 ) THEN
6848              WRITE(9,*) 'Error MPI_Info_create1:', ierr
6849              FLUSH(9)
6850          ENDIF
6851          CALL MPI_Info_set(minfo, 'accumulate_ordering', 'none', ierr)
6852          IF ( ierr /= 0 ) THEN
6853              WRITE(9,*) 'Error MPI_Info_set1:', ierr
6854              FLUSH(9)
6855          ENDIF
6856          CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr)
6857          IF ( ierr /= 0 ) THEN
6858              WRITE(9,*) 'Error MPI_Info_set2:', ierr
6859              FLUSH(9)
6860          ENDIF
6861          CALL MPI_Info_set(minfo, 'same_size', 'true', ierr)
6862          IF ( ierr /= 0 ) THEN
6863              WRITE(9,*) 'Error MPI_Info_set3:', ierr
6864              FLUSH(9)
6865          ENDIF
6866          CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr)
6867          IF ( ierr /= 0 ) THEN
6868              WRITE(9,*) 'Error MPI_Info_set4:', ierr
6869              FLUSH(9)
6870          ENDIF
6871
6872          CALL MPI_Win_allocate(INT(STORAGE_SIZE(1_iwp)/8*nsurf_type_u*nz_urban*nny*nnx, &
6873                                    kind=MPI_ADDRESS_KIND), STORAGE_SIZE(1_iwp)/8,  &
6874                                minfo, comm2d, gridsurf_rma_p, win_gridsurf, ierr)
6875          IF ( ierr /= 0 ) THEN
6876              WRITE(9,*) 'Error MPI_Win_allocate1:', ierr, &
6877                 INT(STORAGE_SIZE(1_iwp)/8*nsurf_type_u*nz_urban*nny*nnx,kind=MPI_ADDRESS_KIND), &
6878                 STORAGE_SIZE(1_iwp)/8, win_gridsurf
6879              FLUSH(9)
6880          ENDIF
6881
6882          CALL MPI_Info_free(minfo, ierr)
6883          IF ( ierr /= 0 ) THEN
6884              WRITE(9,*) 'Error MPI_Info_free1:', ierr
6885              FLUSH(9)
6886          ENDIF
6887
6888!
6889!--       On Intel compilers, calling c_f_pointer to transform a C pointer
6890!--       directly to a multi-dimensional Fotran pointer leads to strange
6891!--       errors on dimension boundaries. However, transforming to a 1D
6892!--       pointer and then redirecting a multidimensional pointer to it works
6893!--       fine.
6894          CALL c_f_pointer(gridsurf_rma_p, gridsurf_rma, (/ nsurf_type_u*nz_urban*nny*nnx /))
6895          gridsurf(0:nsurf_type_u-1, nz_urban_b:nz_urban_t, nys:nyn, nxl:nxr) =>                &
6896                     gridsurf_rma(1:nsurf_type_u*nz_urban*nny*nnx)
6897#else
6898          ALLOCATE(gridsurf(0:nsurf_type_u-1,nz_urban_b:nz_urban_t,nys:nyn,nxl:nxr) )
6899#endif
6900          gridsurf(:,:,:,:) = -999
6901       ENDIF
6902
6903!--    add horizontal surface elements (land and urban surfaces)
6904!--    TODO: add urban overhanging surfaces (idown_u)
6905       DO i = nxl, nxr
6906           DO j = nys, nyn
6907              DO  m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
6908                 k = surf_usm_h%k(m)
6909                 isurf = isurf + 1
6910                 surfl(:,isurf) = (/iup_u,k,j,i,m/)
6911                 IF ( rad_angular_discretization ) THEN
6912                    gridsurf(iup_u,k,j,i) = isurf
6913                 ENDIF
6914              ENDDO
6915
6916              DO  m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
6917                 k = surf_lsm_h%k(m)
6918                 isurf = isurf + 1
6919                 surfl(:,isurf) = (/iup_l,k,j,i,m/)
6920                 IF ( rad_angular_discretization ) THEN
6921                    gridsurf(iup_u,k,j,i) = isurf
6922                 ENDIF
6923              ENDDO
6924
6925           ENDDO
6926       ENDDO
6927
6928!--    add vertical surface elements (land and urban surfaces)
6929!--    TODO: remove the hard coding of l = 0 to l = idirection
6930       DO i = nxl, nxr
6931           DO j = nys, nyn
6932              l = 0
6933              DO  m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6934                 k = surf_usm_v(l)%k(m)
6935                 isurf = isurf + 1
6936                 surfl(:,isurf) = (/inorth_u,k,j,i,m/)
6937                 IF ( rad_angular_discretization ) THEN
6938                    gridsurf(inorth_u,k,j,i) = isurf
6939                 ENDIF
6940              ENDDO
6941              DO  m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6942                 k = surf_lsm_v(l)%k(m)
6943                 isurf = isurf + 1
6944                 surfl(:,isurf) = (/inorth_l,k,j,i,m/)
6945                 IF ( rad_angular_discretization ) THEN
6946                    gridsurf(inorth_u,k,j,i) = isurf
6947                 ENDIF
6948              ENDDO
6949
6950              l = 1
6951              DO  m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6952                 k = surf_usm_v(l)%k(m)
6953                 isurf = isurf + 1
6954                 surfl(:,isurf) = (/isouth_u,k,j,i,m/)
6955                 IF ( rad_angular_discretization ) THEN
6956                    gridsurf(isouth_u,k,j,i) = isurf
6957                 ENDIF
6958              ENDDO
6959              DO  m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6960                 k = surf_lsm_v(l)%k(m)
6961                 isurf = isurf + 1
6962                 surfl(:,isurf) = (/isouth_l,k,j,i,m/)
6963                 IF ( rad_angular_discretization ) THEN
6964                    gridsurf(isouth_u,k,j,i) = isurf
6965                 ENDIF
6966              ENDDO
6967
6968              l = 2
6969              DO  m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6970                 k = surf_usm_v(l)%k(m)
6971                 isurf = isurf + 1
6972                 surfl(:,isurf) = (/ieast_u,k,j,i,m/)
6973                 IF ( rad_angular_discretization ) THEN
6974                    gridsurf(ieast_u,k,j,i) = isurf
6975                 ENDIF
6976              ENDDO
6977              DO  m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6978                 k = surf_lsm_v(l)%k(m)
6979                 isurf = isurf + 1
6980                 surfl(:,isurf) = (/ieast_l,k,j,i,m/)
6981                 IF ( rad_angular_discretization ) THEN
6982                    gridsurf(ieast_u,k,j,i) = isurf
6983                 ENDIF
6984              ENDDO
6985
6986              l = 3
6987              DO  m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i)
6988                 k = surf_usm_v(l)%k(m)
6989                 isurf = isurf + 1
6990                 surfl(:,isurf) = (/iwest_u,k,j,i,m/)
6991                 IF ( rad_angular_discretization ) THEN
6992                    gridsurf(iwest_u,k,j,i) = isurf
6993                 ENDIF
6994              ENDDO
6995              DO  m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i)
6996                 k = surf_lsm_v(l)%k(m)
6997                 isurf = isurf + 1
6998                 surfl(:,isurf) = (/iwest_l,k,j,i,m/)
6999                 IF ( rad_angular_discretization ) THEN
7000                    gridsurf(iwest_u,k,j,i) = isurf
7001                 ENDIF
7002              ENDDO
7003           ENDDO
7004       ENDDO
7005!
7006!--    Add local MRT boxes for specified number of levels
7007       nmrtbl = 0
7008       IF ( mrt_nlevels > 0 )  THEN
7009          DO  i = nxl, nxr
7010             DO  j = nys, nyn
7011                DO  m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
7012!
7013!--                Skip roof if requested
7014                   IF ( mrt_skip_roof  .AND.  surf_usm_h%isroof_surf(m) )  CYCLE
7015!
7016!--                Cycle over specified no of levels
7017                   nmrtbl = nmrtbl + mrt_nlevels
7018                ENDDO
7019!
7020!--             Dtto for LSM
7021                DO  m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
7022                   nmrtbl = nmrtbl + mrt_nlevels
7023                ENDDO
7024             ENDDO
7025          ENDDO
7026
7027          ALLOCATE( mrtbl(iz:ix,nmrtbl), mrtsky(nmrtbl), mrtskyt(nmrtbl), &
7028                    mrtinsw(nmrtbl), mrtinlw(nmrtbl), mrt(nmrtbl) )
7029
7030          imrt = 0
7031          DO  i = nxl, nxr
7032             DO  j = nys, nyn
7033                DO  m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i)
7034!
7035!--                Skip roof if requested
7036                   IF ( mrt_skip_roof  .AND.  surf_usm_h%isroof_surf(m) )  CYCLE
7037!
7038!--                Cycle over specified no of levels
7039                   l = surf_usm_h%k(m)
7040                   DO  k = l, l + mrt_nlevels - 1
7041                      imrt = imrt + 1
7042                      mrtbl(:,imrt) = (/k,j,i/)
7043                   ENDDO
7044                ENDDO
7045!
7046!--             Dtto for LSM
7047                DO  m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i)
7048                   l = surf_lsm_h%k(m)
7049                   DO  k = l, l + mrt_nlevels - 1
7050                      imrt = imrt + 1
7051                      mrtbl(:,imrt) = (/k,j,i/)
7052                   ENDDO
7053                ENDDO
7054             ENDDO
7055          ENDDO
7056       ENDIF
7057
7058!
7059!--    broadband albedo of the land, roof and wall surface
7060!--    for domain border and sky set artifically to 1.0
7061!--    what allows us to calculate heat flux leaving over
7062!--    side and top borders of the domain
7063       ALLOCATE ( albedo_surf(nsurfl) )
7064       albedo_surf = 1.0_wp
7065!
7066!--    Also allocate further array for emissivity with identical order of
7067!--    surface elements as radiation arrays.
7068       ALLOCATE ( emiss_surf(nsurfl)  )
7069
7070
7071!
7072!--    global array surf of indices of surfaces and displacement index array surfstart
7073       ALLOCATE(nsurfs(0:numprocs-1))
7074
7075#if defined( __parallel )
7076       CALL MPI_Allgather(nsurfl,1,MPI_INTEGER,nsurfs,1,MPI_INTEGER,comm2d,ierr)
7077       IF ( ierr /= 0 ) THEN
7078         WRITE(9,*) 'Error MPI_AllGather1:', ierr, nsurfl, nsurfs
7079         FLUSH(9)
7080     ENDIF
7081
7082#else
7083       nsurfs(0) = nsurfl
7084#endif
7085       ALLOCATE(surfstart(0:numprocs))
7086       k = 0
7087       DO i=0,numprocs-1
7088           surfstart(i) = k
7089           k = k+nsurfs(i)
7090       ENDDO
7091       surfstart(numprocs) = k
7092       nsurf = k
7093!
7094!--    We allocate the array as linear and then use a two-dimensional pointer
7095!--    into it, because some MPI implementations crash with 2D-allocated arrays.
7096       ALLOCATE(surf_linear(nidx_surf*nsurf))
7097       surf(1:nidx_surf,1:nsurf) => surf_linear(1:nidx_surf*nsurf)
7098
7099#if defined( __parallel )
7100       CALL MPI_AllGatherv(surfl_linear, nsurfl*nidx_surf, MPI_INTEGER,    &
7101                           surf_linear, nsurfs*nidx_surf,                  &
7102                           surfstart(0:numprocs-1)*nidx_surf, MPI_INTEGER, &
7103                           comm2d, ierr)
7104       IF ( ierr /= 0 ) THEN
7105           WRITE(9,*) 'Error MPI_AllGatherv4:', ierr, SIZE(surfl_linear),    &
7106                      nsurfl*nidx_surf, SIZE(surf_linear), nsurfs*nidx_surf, &
7107                      surfstart(0:numprocs-1)*nidx_surf
7108           FLUSH(9)
7109       ENDIF
7110#else
7111       surf = surfl
7112#endif
7113
7114!--
7115!--    allocation of the arrays for direct and diffusion radiation
7116       IF ( debug_output )  CALL debug_message( 'allocation of radiation arrays', 'info' )
7117!--    rad_sw_in, rad_lw_in are computed in radiation model,
7118!--    splitting of direct and diffusion part is done
7119!--    in calc_diffusion_radiation for now
7120
7121       ALLOCATE( rad_sw_in_dir(nysg:nyng,nxlg:nxrg) )
7122       ALLOCATE( rad_sw_in_diff(nysg:nyng,nxlg:nxrg) )
7123       ALLOCATE( rad_lw_in_diff(nysg:nyng,nxlg:nxrg) )
7124       rad_sw_in_dir  = 0.0_wp
7125       rad_sw_in_diff = 0.0_wp
7126       rad_lw_in_diff = 0.0_wp
7127
7128!--    allocate radiation arrays
7129       ALLOCATE( surfins(nsurfl) )
7130       ALLOCATE( surfinl(nsurfl) )
7131       ALLOCATE( surfinsw(nsurfl) )
7132       ALLOCATE( surfinlw(nsurfl) )
7133       ALLOCATE( surfinswdir(nsurfl) )
7134       ALLOCATE( surfinswdif(nsurfl) )
7135       ALLOCATE( surfinlwdif(nsurfl) )
7136       ALLOCATE( surfoutsl(nsurfl) )
7137       ALLOCATE( surfoutll(nsurfl) )
7138       ALLOCATE( surfoutsw(nsurfl) )
7139       ALLOCATE( surfoutlw(nsurfl) )
7140       ALLOCATE( surfouts(nsurf) )
7141       ALLOCATE( surfoutl(nsurf) )
7142       ALLOCATE( surfinlg(nsurf) )
7143       ALLOCATE( skyvf(nsurfl) )
7144       ALLOCATE( skyvft(nsurfl) )
7145       ALLOCATE( surfemitlwl(nsurfl) )
7146
7147!
7148!--    In case of average_radiation, aggregated surface albedo and emissivity,
7149!--    also set initial value for t_rad_urb.
7150!--    For now set an arbitrary initial value.
7151       IF ( average_radiation )  THEN
7152          albedo_urb = 0.1_wp
7153          emissivity_urb = 0.9_wp
7154          t_rad_urb = pt_surface
7155       ENDIF
7156
7157    END SUBROUTINE radiation_interaction_init
7158
7159!------------------------------------------------------------------------------!
7160! Description:
7161! ------------
7162!> Calculates shape view factors (SVF), plant sink canopy factors (PCSF),
7163!> sky-view factors, discretized path for direct solar radiation, MRT factors
7164!> and other preprocessed data needed for radiation_interaction.
7165!------------------------------------------------------------------------------!
7166    SUBROUTINE radiation_calc_svf
7167   
7168        IMPLICIT NONE
7169       
7170        INTEGER(iwp)                                  :: i, j, k, d, ip, jp
7171        INTEGER(iwp)                                  :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrt, imrtf, ipcgb
7172        INTEGER(iwp)                                  :: sd, td
7173        INTEGER(iwp)                                  :: iaz, izn      !< azimuth, zenith counters
7174        INTEGER(iwp)                                  :: naz, nzn      !< azimuth, zenith num of steps
7175        REAL(wp)                                      :: az0, zn0      !< starting azimuth/zenith
7176        REAL(wp)                                      :: azs, zns      !< azimuth/zenith cycle step
7177        REAL(wp)                                      :: az1, az2      !< relative azimuth of section borders
7178        REAL(wp)                                      :: azmid         !< ray (center) azimuth
7179        REAL(wp)                                      :: yxlen         !< |yxdir|
7180        REAL(wp), DIMENSION(2)                        :: yxdir         !< y,x *unit* vector of ray direction (in grid units)
7181        REAL(wp), DIMENSION(:), ALLOCATABLE           :: zdirs         !< directions in z (tangent of elevation)
7182        REAL(wp), DIMENSION(:), ALLOCATABLE           :: zcent         !< zenith angle centers
7183        REAL(wp), DIMENSION(:), ALLOCATABLE           :: zbdry         !< zenith angle boundaries
7184        REAL(wp), DIMENSION(:), ALLOCATABLE           :: vffrac        !< view factor fractions for individual rays
7185        REAL(wp), DIMENSION(:), ALLOCATABLE           :: vffrac0       !< dtto (original values)
7186        REAL(wp), DIMENSION(:), ALLOCATABLE           :: ztransp       !< array of transparency in z steps
7187        INTEGER(iwp)                                  :: lowest_free_ray !< index into zdirs
7188        INTEGER(iwp), DIMENSION(:), ALLOCATABLE       :: itarget       !< face indices of detected obstacles
7189        INTEGER(iwp)                                  :: itarg0, itarg1
7190
7191        INTEGER(iwp)                                  :: udim
7192        INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: nzterrl_l
7193        INTEGER(iwp), DIMENSION(:,:), POINTER         :: nzterrl
7194        REAL(wp),     DIMENSION(:), ALLOCATABLE,TARGET:: csflt_l, pcsflt_l
7195        REAL(wp),     DIMENSION(:,:), POINTER         :: csflt, pcsflt
7196        INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: kcsflt_l,kpcsflt_l
7197        INTEGER(iwp), DIMENSION(:,:), POINTER         :: kcsflt,kpcsflt
7198        INTEGER(iwp), DIMENSION(:), ALLOCATABLE       :: icsflt,dcsflt,ipcsflt,dpcsflt
7199        REAL(wp), DIMENSION(3)                        :: uv
7200        LOGICAL                                       :: visible
7201        REAL(wp), DIMENSION(3)                        :: sa, ta          !< real coordinates z,y,x of source and target
7202        REAL(wp)                                      :: difvf           !< differential view factor
7203        REAL(wp)                                      :: transparency, rirrf, sqdist, svfsum
7204        INTEGER(iwp)                                  :: isurflt, isurfs, isurflt_prev
7205        INTEGER(idp)                                  :: ray_skip_maxdist, ray_skip_minval !< skipped raytracing counts
7206        INTEGER(iwp)                                  :: max_track_len !< maximum 2d track length
7207        INTEGER(iwp)                                  :: minfo
7208        REAL(wp), DIMENSION(:), POINTER, SAVE         :: lad_s_rma       !< fortran 1D pointer
7209        TYPE(c_ptr)                                   :: lad_s_rma_p     !< allocated c pointer
7210#if defined( __parallel )
7211        INTEGER(kind=MPI_ADDRESS_KIND)                :: size_lad_rma
7212#endif
7213!   
7214        INTEGER(iwp), DIMENSION(0:svfnorm_report_num) :: svfnorm_counts
7215
7216
7217!--     calculation of the SVF
7218        CALL location_message( 'calculating view factors for radiation interaction', 'start' )
7219
7220!--     initialize variables and temporary arrays for calculation of svf and csf
7221        nsvfl  = 0
7222        ncsfl  = 0
7223        nsvfla = gasize
7224        msvf   = 1
7225        ALLOCATE( asvf1(nsvfla) )
7226        asvf => asvf1
7227        IF ( plant_canopy )  THEN
7228            ncsfla = gasize
7229            mcsf   = 1
7230            ALLOCATE( acsf1(ncsfla) )
7231            acsf => acsf1
7232        ENDIF
7233        nmrtf = 0
7234        IF ( mrt_nlevels > 0 )  THEN
7235           nmrtfa = gasize
7236           mmrtf = 1
7237           ALLOCATE ( amrtf1(nmrtfa) )
7238           amrtf => amrtf1
7239        ENDIF
7240        ray_skip_maxdist = 0
7241        ray_skip_minval = 0
7242       
7243!--     initialize temporary terrain and plant canopy height arrays (global 2D array!)
7244        ALLOCATE( nzterr(0:(nx+1)*(ny+1)-1) )
7245#if defined( __parallel )
7246        !ALLOCATE( nzterrl(nys:nyn,nxl:nxr) )
7247        ALLOCATE( nzterrl_l((nyn-nys+1)*(nxr-nxl+1)) )
7248        nzterrl(nys:nyn,nxl:nxr) => nzterrl_l(1:(nyn-nys+1)*(nxr-nxl+1))
7249        nzterrl = topo_top_ind(nys:nyn,nxl:nxr,0)
7250        CALL MPI_AllGather( nzterrl_l, nnx*nny, MPI_INTEGER, &
7251                            nzterr, nnx*nny, MPI_INTEGER, comm2d, ierr )
7252        IF ( ierr /= 0 ) THEN
7253            WRITE(9,*) 'Error MPI_AllGather1:', ierr, SIZE(nzterrl_l), nnx*nny, &
7254                       SIZE(nzterr), nnx*nny
7255            FLUSH(9)
7256        ENDIF
7257        DEALLOCATE(nzterrl_l)
7258#else
7259        nzterr = RESHAPE( topo_top_ind(nys:nyn,nxl:nxr,0), (/(nx+1)*(ny+1)/) )
7260#endif
7261        IF ( plant_canopy )  THEN
7262            ALLOCATE( plantt(0:(nx+1)*(ny+1)-1) )
7263            maxboxesg = nx + ny + nz_plant + 1
7264            max_track_len = nx + ny + 1
7265!--         temporary arrays storing values for csf calculation during raytracing
7266            ALLOCATE( boxes(3, maxboxesg) )
7267            ALLOCATE( crlens(maxboxesg) )
7268
7269#if defined( __parallel )
7270            CALL MPI_AllGather( pct, nnx*nny, MPI_INTEGER, &
7271                                plantt, nnx*nny, MPI_INTEGER, comm2d, ierr )
7272            IF ( ierr /= 0 ) THEN
7273                WRITE(9,*) 'Error MPI_AllGather2:', ierr, SIZE(pct), nnx*nny, &
7274                           SIZE(plantt), nnx*nny
7275                FLUSH(9)
7276            ENDIF
7277
7278!--         temporary arrays storing values for csf calculation during raytracing
7279            ALLOCATE( lad_ip(maxboxesg) )
7280            ALLOCATE( lad_disp(maxboxesg) )
7281
7282            IF ( raytrace_mpi_rma )  THEN
7283                ALLOCATE( lad_s_ray(maxboxesg) )
7284               
7285                ! set conditions for RMA communication
7286                CALL MPI_Info_create(minfo, ierr)
7287                IF ( ierr /= 0 ) THEN
7288                    WRITE(9,*) 'Error MPI_Info_create2:', ierr
7289                    FLUSH(9)
7290                ENDIF
7291                CALL MPI_Info_set(minfo, 'accumulate_ordering', 'none', ierr)
7292                IF ( ierr /= 0 ) THEN
7293                    WRITE(9,*) 'Error MPI_Info_set5:', ierr
7294                    FLUSH(9)
7295                ENDIF
7296                CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr)
7297                IF ( ierr /= 0 ) THEN
7298                    WRITE(9,*) 'Error MPI_Info_set6:', ierr
7299                    FLUSH(9)
7300                ENDIF
7301                CALL MPI_Info_set(minfo, 'same_size', 'true', ierr)
7302                IF ( ierr /= 0 ) THEN
7303                    WRITE(9,*) 'Error MPI_Info_set7:', ierr
7304                    FLUSH(9)
7305                ENDIF
7306                CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr)
7307                IF ( ierr /= 0 ) THEN
7308                    WRITE(9,*) 'Error MPI_Info_set8:', ierr
7309                    FLUSH(9)
7310                ENDIF
7311
7312!--             Allocate and initialize the MPI RMA window
7313!--             must be in accordance with allocation of lad_s in plant_canopy_model
7314!--             optimization of memory should be done
7315!--             Argument X of function STORAGE_SIZE(X) needs arbitrary REAL(wp) value, set to 1.0_wp for now
7316                size_lad_rma = STORAGE_SIZE(1.0_wp)/8*nnx*nny*nz_plant
7317                CALL MPI_Win_allocate(size_lad_rma, STORAGE_SIZE(1.0_wp)/8, minfo, comm2d, &
7318                                        lad_s_rma_p, win_lad, ierr)
7319                IF ( ierr /= 0 ) THEN
7320                    WRITE(9,*) 'Error MPI_Win_allocate2:', ierr, size_lad_rma, &
7321                                STORAGE_SIZE(1.0_wp)/8, win_lad
7322                    FLUSH(9)
7323                ENDIF
7324                CALL c_f_pointer(lad_s_rma_p, lad_s_rma, (/ nz_plant*nny*nnx /))
7325                sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr) => lad_s_rma(1:nz_plant*nny*nnx)
7326            ELSE
7327                ALLOCATE(sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr))
7328            ENDIF
7329#else
7330            plantt = RESHAPE( pct(nys:nyn,nxl:nxr), (/(nx+1)*(ny+1)/) )
7331            ALLOCATE(sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr))
7332#endif
7333            plantt_max = MAXVAL(plantt)
7334            ALLOCATE( rt2_track(2, max_track_len), rt2_track_lad(nz_urban_b:plantt_max, max_track_len), &
7335                      rt2_track_dist(0:max_track_len), rt2_dist(plantt_max-nz_urban_b+2) )
7336
7337            sub_lad(:,:,:) = 0._wp
7338            DO i = nxl, nxr
7339                DO j = nys, nyn
7340                    k = topo_top_ind(j,i,0)
7341
7342                    sub_lad(k:nz_plant_t, j, i) = lad_s(0:nz_plant_t-k, j, i)
7343                ENDDO
7344            ENDDO
7345
7346#if defined( __parallel )
7347            IF ( raytrace_mpi_rma )  THEN
7348                CALL MPI_Info_free(minfo, ierr)
7349                IF ( ierr /= 0 ) THEN
7350                    WRITE(9,*) 'Error MPI_Info_free2:', ierr
7351                    FLUSH(9)
7352                ENDIF
7353                CALL MPI_Win_lock_all(0, win_lad, ierr)
7354                IF ( ierr /= 0 ) THEN
7355                    WRITE(9,*) 'Error MPI_Win_lock_all1:', ierr, win_lad
7356                    FLUSH(9)
7357                ENDIF
7358               
7359            ELSE
7360                ALLOCATE( sub_lad_g(0:(nx+1)*(ny+1)*nz_plant-1) )
7361                CALL MPI_AllGather( sub_lad, nnx*nny*nz_plant, MPI_REAL, &
7362                                    sub_lad_g, nnx*nny*nz_plant, MPI_REAL, comm2d, ierr )
7363                IF ( ierr /= 0 ) THEN
7364                    WRITE(9,*) 'Error MPI_AllGather3:', ierr, SIZE(sub_lad), &
7365                                nnx*nny*nz_plant, SIZE(sub_lad_g), nnx*nny*nz_plant
7366                    FLUSH(9)
7367                ENDIF
7368            ENDIF
7369#endif
7370        ENDIF
7371
7372!--     prepare the MPI_Win for collecting the surface indices
7373!--     from the reverse index arrays gridsurf from processors of target surfaces
7374#if defined( __parallel )
7375        IF ( rad_angular_discretization )  THEN
7376!
7377!--         raytrace_mpi_rma is asserted
7378            CALL MPI_Win_lock_all(0, win_gridsurf, ierr)
7379            IF ( ierr /= 0 ) THEN
7380                WRITE(9,*) 'Error MPI_Win_lock_all2:', ierr, win_gridsurf
7381                FLUSH(9)
7382            ENDIF
7383        ENDIF
7384#endif
7385
7386
7387        !--Directions opposite to face normals are not even calculated,
7388        !--they must be preset to 0
7389        !--
7390        dsitrans(:,:) = 0._wp
7391       
7392        DO isurflt = 1, nsurfl
7393!--         determine face centers
7394            td = surfl(id, isurflt)
7395            ta = (/ REAL(surfl(iz, isurflt), wp) - 0.5_wp * kdir(td),  &
7396                      REAL(surfl(iy, isurflt), wp) - 0.5_wp * jdir(td),  &
7397                      REAL(surfl(ix, isurflt), wp) - 0.5_wp * idir(td)  /)
7398
7399            !--Calculate sky view factor and raytrace DSI paths
7400            skyvf(isurflt) = 0._wp
7401            skyvft(isurflt) = 0._wp
7402
7403            !--Select a proper half-sphere for 2D raytracing
7404            SELECT CASE ( td )
7405               CASE ( iup_u, iup_l )
7406                  az0 = 0._wp
7407                  naz = raytrace_discrete_azims
7408                  azs = 2._wp * pi / REAL(naz, wp)
7409                  zn0 = 0._wp
7410                  nzn = raytrace_discrete_elevs / 2
7411                  zns = pi / 2._wp / REAL(nzn, wp)
7412               CASE ( isouth_u, isouth_l )
7413                  az0 = pi / 2._wp
7414                  naz = raytrace_discrete_azims / 2
7415                  azs = pi / REAL(naz, wp)
7416                  zn0 = 0._wp
7417                  nzn = raytrace_discrete_elevs
7418                  zns = pi / REAL(nzn, wp)
7419               CASE ( inorth_u, inorth_l )
7420                  az0 = - pi / 2._wp
7421                  naz = raytrace_discrete_azims / 2
7422                  azs = pi / REAL(naz, wp)
7423                  zn0 = 0._wp
7424                  nzn = raytrace_discrete_elevs
7425                  zns = pi / REAL(nzn, wp)
7426               CASE ( iwest_u, iwest_l )
7427                  az0 = pi
7428                  naz = raytrace_discrete_azims / 2
7429                  azs = pi / REAL(naz, wp)
7430                  zn0 = 0._wp
7431                  nzn = raytrace_discrete_elevs
7432                  zns = pi / REAL(nzn, wp)
7433               CASE ( ieast_u, ieast_l )
7434                  az0 = 0._wp
7435                  naz = raytrace_discrete_azims / 2
7436                  azs = pi / REAL(naz, wp)
7437                  zn0 = 0._wp
7438                  nzn = raytrace_discrete_elevs
7439                  zns = pi / REAL(nzn, wp)
7440               CASE DEFAULT
7441                  WRITE(message_string, *) 'ERROR: the surface type ', td,     &
7442                                           ' is not supported for calculating',&
7443                                           ' SVF'
7444                  CALL message( 'radiation_calc_svf', 'PA0488', 1, 2, 0, 6, 0 )
7445            END SELECT
7446
7447            ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), &
7448                       ztransp(1:nzn*naz), itarget(1:nzn*naz) )   !FIXME allocate itarget only
7449                                                                  !in case of rad_angular_discretization
7450
7451            itarg0 = 1
7452            itarg1 = nzn
7453            zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7454            zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/)
7455            IF ( td == iup_u  .OR.  td == iup_l )  THEN
7456               vffrac(1:nzn) = (COS(2 * zbdry(0:nzn-1)) - COS(2 * zbdry(1:nzn))) / 2._wp / REAL(naz, wp)
7457!
7458!--            For horizontal target, vf fractions are constant per azimuth
7459               DO iaz = 1, naz-1
7460                  vffrac(iaz*nzn+1:(iaz+1)*nzn) = vffrac(1:nzn)
7461               ENDDO
7462!--            sum of whole vffrac equals 1, verified
7463            ENDIF
7464!
7465!--         Calculate sky-view factor and direct solar visibility using 2D raytracing
7466            DO iaz = 1, naz
7467               azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7468               IF ( td /= iup_u  .AND.  td /= iup_l )  THEN
7469                  az2 = REAL(iaz, wp) * azs - pi/2._wp
7470                  az1 = az2 - azs
7471                  !TODO precalculate after 1st line
7472                  vffrac(itarg0:itarg1) = (SIN(az2) - SIN(az1))               &
7473                              * (zbdry(1:nzn) - zbdry(0:nzn-1)                &
7474                                 + SIN(zbdry(0:nzn-1))*COS(zbdry(0:nzn-1))    &
7475                                 - SIN(zbdry(1:nzn))*COS(zbdry(1:nzn)))       &
7476                              / (2._wp * pi)
7477!--               sum of whole vffrac equals 1, verified
7478               ENDIF
7479               yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7480               yxlen = SQRT(SUM(yxdir(:)**2))
7481               zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7482               yxdir(:) = yxdir(:) / yxlen
7483
7484               CALL raytrace_2d(ta, yxdir, nzn, zdirs,                        &
7485                                    surfstart(myid) + isurflt, facearea(td),  &
7486                                    vffrac(itarg0:itarg1), .TRUE., .TRUE.,    &
7487                                    .FALSE., lowest_free_ray,                 &
7488                                    ztransp(itarg0:itarg1),                   &
7489                                    itarget(itarg0:itarg1))
7490
7491               skyvf(isurflt) = skyvf(isurflt) + &
7492                                SUM(vffrac(itarg0:itarg0+lowest_free_ray-1))
7493               skyvft(isurflt) = skyvft(isurflt) + &
7494                                 SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) &
7495                                             * vffrac(itarg0:itarg0+lowest_free_ray-1))
7496 
7497!--            Save direct solar transparency
7498               j = MODULO(NINT(azmid/                                          &
7499                               (2._wp*pi)*raytrace_discrete_azims-.5_wp, iwp), &
7500                          raytrace_discrete_azims)
7501
7502               DO k = 1, raytrace_discrete_elevs/2
7503                  i = dsidir_rev(k-1, j)
7504                  IF ( i /= -1  .AND.  k <= lowest_free_ray )  &
7505                     dsitrans(isurflt, i) = ztransp(itarg0+k-1)
7506               ENDDO
7507
7508!
7509!--            Advance itarget indices
7510               itarg0 = itarg1 + 1
7511               itarg1 = itarg1 + nzn
7512            ENDDO
7513
7514            IF ( rad_angular_discretization )  THEN
7515!--            sort itarget by face id
7516               CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz)
7517!
7518!--            For aggregation, we need fractions multiplied by transmissivities
7519               ztransp(:) = vffrac(:) * ztransp(:)
7520!
7521!--            find the first valid position
7522               itarg0 = 1
7523               DO WHILE ( itarg0 <= nzn*naz )
7524                  IF ( itarget(itarg0) /= -1 )  EXIT
7525                  itarg0 = itarg0 + 1
7526               ENDDO
7527
7528               DO  i = itarg0, nzn*naz
7529!
7530!--               For duplicate values, only sum up vf fraction value
7531                  IF ( i < nzn*naz )  THEN
7532                     IF ( itarget(i+1) == itarget(i) )  THEN
7533                        vffrac(i+1) = vffrac(i+1) + vffrac(i)
7534                        ztransp(i+1) = ztransp(i+1) + ztransp(i)
7535                        CYCLE
7536                     ENDIF
7537                  ENDIF
7538!
7539!--               write to the svf array
7540                  nsvfl = nsvfl + 1
7541!--               check dimmension of asvf array and enlarge it if needed
7542                  IF ( nsvfla < nsvfl )  THEN
7543                     k = CEILING(REAL(nsvfla, kind=wp) * grow_factor)
7544                     IF ( msvf == 0 )  THEN
7545                        msvf = 1
7546                        ALLOCATE( asvf1(k) )
7547                        asvf => asvf1
7548                        asvf1(1:nsvfla) = asvf2
7549                        DEALLOCATE( asvf2 )
7550                     ELSE
7551                        msvf = 0
7552                        ALLOCATE( asvf2(k) )
7553                        asvf => asvf2
7554                        asvf2(1:nsvfla) = asvf1
7555                        DEALLOCATE( asvf1 )
7556                     ENDIF
7557
7558                     IF ( debug_output )  THEN
7559                        WRITE( debug_string, '(A,3I12)' ) 'Grow asvf:', nsvfl, nsvfla, k
7560                        CALL debug_message( debug_string, 'info' )
7561                     ENDIF
7562                     
7563                     nsvfla = k
7564                  ENDIF
7565!--               write svf values into the array
7566                  asvf(nsvfl)%isurflt = isurflt
7567                  asvf(nsvfl)%isurfs = itarget(i)
7568                  asvf(nsvfl)%rsvf = vffrac(i)
7569                  asvf(nsvfl)%rtransp = ztransp(i) / vffrac(i)
7570               END DO
7571
7572            ENDIF ! rad_angular_discretization
7573
7574            DEALLOCATE ( zdirs, zcent, zbdry, vffrac, ztransp, itarget ) !FIXME itarget shall be allocated only
7575                                                                  !in case of rad_angular_discretization
7576!
7577!--         Following calculations only required for surface_reflections
7578            IF ( surface_reflections  .AND.  .NOT. rad_angular_discretization )  THEN
7579
7580               DO  isurfs = 1, nsurf
7581                  IF ( .NOT.  surface_facing(surfl(ix, isurflt), surfl(iy, isurflt), &
7582                     surfl(iz, isurflt), surfl(id, isurflt), &
7583                     surf(ix, isurfs), surf(iy, isurfs), &
7584                     surf(iz, isurfs), surf(id, isurfs)) )  THEN
7585                     CYCLE
7586                  ENDIF
7587                 
7588                  sd = surf(id, isurfs)
7589                  sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd),  &
7590                          REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd),  &
7591                          REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd)  /)
7592
7593!--               unit vector source -> target
7594                  uv = (/ (ta(1)-sa(1))*dz(1), (ta(2)-sa(2))*dy, (ta(3)-sa(3))*dx /)
7595                  sqdist = SUM(uv(:)**2)
7596                  uv = uv / SQRT(sqdist)
7597
7598!--               reject raytracing above max distance
7599                  IF ( SQRT(sqdist) > max_raytracing_dist ) THEN
7600                     ray_skip_maxdist = ray_skip_maxdist + 1
7601                     CYCLE
7602                  ENDIF
7603                 
7604                  difvf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) & ! cosine of source normal and direction
7605                      * dot_product((/ kdir(td), jdir(td), idir(td) /), -uv) &  ! cosine of target normal and reverse direction
7606                      / (pi * sqdist) ! square of distance between centers
7607!
7608!--               irradiance factor (our unshaded shape view factor) = view factor per differential target area * source area
7609                  rirrf = difvf * facearea(sd)
7610
7611!--               reject raytracing for potentially too small view factor values
7612                  IF ( rirrf < min_irrf_value ) THEN
7613                      ray_skip_minval = ray_skip_minval + 1
7614                      CYCLE
7615                  ENDIF
7616
7617!--               raytrace + process plant canopy sinks within
7618                  CALL raytrace(sa, ta, isurfs, difvf, facearea(td), .TRUE., &
7619                                visible, transparency)
7620
7621                  IF ( .NOT.  visible ) CYCLE
7622                 ! rsvf = rirrf * transparency
7623
7624!--               write to the svf array
7625                  nsvfl = nsvfl + 1
7626!--               check dimmension of asvf array and enlarge it if needed
7627                  IF ( nsvfla < nsvfl )  THEN
7628                     k = CEILING(REAL(nsvfla, kind=wp) * grow_factor)
7629                     IF ( msvf == 0 )  THEN
7630                        msvf = 1
7631                        ALLOCATE( asvf1(k) )
7632                        asvf => asvf1
7633                        asvf1(1:nsvfla) = asvf2
7634                        DEALLOCATE( asvf2 )
7635                     ELSE
7636                        msvf = 0
7637                        ALLOCATE( asvf2(k) )
7638                        asvf => asvf2
7639                        asvf2(1:nsvfla) = asvf1
7640                        DEALLOCATE( asvf1 )
7641                     ENDIF
7642
7643                     IF ( debug_output )  THEN
7644                        WRITE( debug_string, '(A,3I12)' ) 'Grow asvf:', nsvfl, nsvfla, k
7645                        CALL debug_message( debug_string, 'info' )
7646                     ENDIF
7647                     
7648                     nsvfla = k
7649                  ENDIF
7650!--               write svf values into the array
7651                  asvf(nsvfl)%isurflt = isurflt
7652                  asvf(nsvfl)%isurfs = isurfs
7653                  asvf(nsvfl)%rsvf = rirrf !we postopne multiplication by transparency
7654                  asvf(nsvfl)%rtransp = transparency !a.k.a. Direct Irradiance Factor
7655               ENDDO
7656            ENDIF
7657        ENDDO
7658
7659!--
7660!--     Raytrace to canopy boxes to fill dsitransc TODO optimize
7661        dsitransc(:,:) = 0._wp
7662        az0 = 0._wp
7663        naz = raytrace_discrete_azims
7664        azs = 2._wp * pi / REAL(naz, wp)
7665        zn0 = 0._wp
7666        nzn = raytrace_discrete_elevs / 2
7667        zns = pi / 2._wp / REAL(nzn, wp)
7668        ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), vffrac(1:nzn), ztransp(1:nzn), &
7669               itarget(1:nzn) )
7670        zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7671        vffrac(:) = 0._wp
7672
7673        DO  ipcgb = 1, npcbl
7674           ta = (/ REAL(pcbl(iz, ipcgb), wp),  &
7675                   REAL(pcbl(iy, ipcgb), wp),  &
7676                   REAL(pcbl(ix, ipcgb), wp) /)
7677!--        Calculate direct solar visibility using 2D raytracing
7678           DO  iaz = 1, naz
7679              azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7680              yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7681              yxlen = SQRT(SUM(yxdir(:)**2))
7682              zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7683              yxdir(:) = yxdir(:) / yxlen
7684              CALL raytrace_2d(ta, yxdir, nzn, zdirs,                                &
7685                                   -999, -999._wp, vffrac, .FALSE., .FALSE., .TRUE., &
7686                                   lowest_free_ray, ztransp, itarget)
7687
7688!--           Save direct solar transparency
7689              j = MODULO(NINT(azmid/                                         &
7690                             (2._wp*pi)*raytrace_discrete_azims-.5_wp, iwp), &
7691                         raytrace_discrete_azims)
7692              DO  k = 1, raytrace_discrete_elevs/2
7693                 i = dsidir_rev(k-1, j)
7694                 IF ( i /= -1  .AND.  k <= lowest_free_ray ) &
7695                    dsitransc(ipcgb, i) = ztransp(k)
7696              ENDDO
7697           ENDDO
7698        ENDDO
7699        DEALLOCATE ( zdirs, zcent, vffrac, ztransp, itarget )
7700!--
7701!--     Raytrace to MRT boxes
7702        IF ( nmrtbl > 0 )  THEN
7703           mrtdsit(:,:) = 0._wp
7704           mrtsky(:) = 0._wp
7705           mrtskyt(:) = 0._wp
7706           az0 = 0._wp
7707           naz = raytrace_discrete_azims
7708           azs = 2._wp * pi / REAL(naz, wp)
7709           zn0 = 0._wp
7710           nzn = raytrace_discrete_elevs
7711           zns = pi / REAL(nzn, wp)
7712           ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), vffrac0(1:nzn), &
7713                      ztransp(1:nzn*naz), itarget(1:nzn*naz) )   !FIXME allocate itarget only
7714                                                                 !in case of rad_angular_discretization
7715
7716           zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/)
7717           zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/)
7718           vffrac0(:) = (COS(zbdry(0:nzn-1)) - COS(zbdry(1:nzn))) / 2._wp / REAL(naz, wp)
7719           !
7720           !--Modify direction weights to simulate human body (lower weight for top-down)
7721           IF ( mrt_geom_human )  THEN
7722              vffrac0(:) = vffrac0(:) * MAX(0._wp, SIN(zcent(:))*0.88_wp + COS(zcent(:))*0.12_wp)
7723              vffrac0(:) = vffrac0(:) / (SUM(vffrac0) * REAL(naz, wp))
7724           ENDIF
7725
7726           DO  imrt = 1, nmrtbl
7727              ta = (/ REAL(mrtbl(iz, imrt), wp),  &
7728                      REAL(mrtbl(iy, imrt), wp),  &
7729                      REAL(mrtbl(ix, imrt), wp) /)
7730!
7731!--           vf fractions are constant per azimuth
7732              DO iaz = 0, naz-1
7733                 vffrac(iaz*nzn+1:(iaz+1)*nzn) = vffrac0(:)
7734              ENDDO
7735!--           sum of whole vffrac equals 1, verified
7736              itarg0 = 1
7737              itarg1 = nzn
7738!
7739!--           Calculate sky-view factor and direct solar visibility using 2D raytracing
7740              DO  iaz = 1, naz
7741                 azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs
7742                 yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /)
7743                 yxlen = SQRT(SUM(yxdir(:)**2))
7744                 zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:)))
7745                 yxdir(:) = yxdir(:) / yxlen
7746
7747                 CALL raytrace_2d(ta, yxdir, nzn, zdirs,                         &
7748                                  -999, -999._wp, vffrac(itarg0:itarg1), .TRUE., &
7749                                  .FALSE., .TRUE., lowest_free_ray,              &
7750                                  ztransp(itarg0:itarg1),                        &
7751                                  itarget(itarg0:itarg1))
7752
7753!--              Sky view factors for MRT
7754                 mrtsky(imrt) = mrtsky(imrt) + &
7755                                  SUM(vffrac(itarg0:itarg0+lowest_free_ray-1))
7756                 mrtskyt(imrt) = mrtskyt(imrt) + &
7757                                   SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) &
7758                                               * vffrac(itarg0:itarg0+lowest_free_ray-1))
7759!--              Direct solar transparency for MRT
7760                 j = MODULO(NINT(azmid/                                         &
7761                                (2._wp*pi)*raytrace_discrete_azims-.5_wp, iwp), &
7762                            raytrace_discrete_azims)
7763                 DO  k = 1, raytrace_discrete_elevs/2
7764                    i = dsidir_rev(k-1, j)
7765                    IF ( i /= -1  .AND.  k <= lowest_free_ray ) &
7766                       mrtdsit(imrt, i) = ztransp(itarg0+k-1)
7767                 ENDDO
7768!
7769!--              Advance itarget indices
7770                 itarg0 = itarg1 + 1
7771                 itarg1 = itarg1 + nzn
7772              ENDDO
7773
7774!--           sort itarget by face id
7775              CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz)
7776!
7777!--           find the first valid position
7778              itarg0 = 1
7779              DO WHILE ( itarg0 <= nzn*naz )
7780                 IF ( itarget(itarg0) /= -1 )  EXIT
7781                 itarg0 = itarg0 + 1
7782              ENDDO
7783
7784              DO  i = itarg0, nzn*naz
7785!
7786!--              For duplicate values, only sum up vf fraction value
7787                 IF ( i < nzn*naz )  THEN
7788                    IF ( itarget(i+1) == itarget(i) )  THEN
7789                       vffrac(i+1) = vffrac(i+1) + vffrac(i)
7790                       CYCLE
7791                    ENDIF
7792                 ENDIF
7793!
7794!--              write to the mrtf array
7795                 nmrtf = nmrtf + 1
7796!--              check dimmension of mrtf array and enlarge it if needed
7797                 IF ( nmrtfa < nmrtf )  THEN
7798                    k = CEILING(REAL(nmrtfa, kind=wp) * grow_factor)
7799                    IF ( mmrtf == 0 )  THEN
7800                       mmrtf = 1
7801                       ALLOCATE( amrtf1(k) )
7802                       amrtf => amrtf1
7803                       amrtf1(1:nmrtfa) = amrtf2
7804                       DEALLOCATE( amrtf2 )
7805                    ELSE
7806                       mmrtf = 0
7807                       ALLOCATE( amrtf2(k) )
7808                       amrtf => amrtf2
7809                       amrtf2(1:nmrtfa) = amrtf1
7810                       DEALLOCATE( amrtf1 )
7811                    ENDIF
7812
7813                    IF ( debug_output )  THEN
7814                       WRITE( debug_string, '(A,3I12)' ) 'Grow amrtf:', nmrtf, nmrtfa, k
7815                       CALL debug_message( debug_string, 'info' )
7816                    ENDIF
7817
7818                    nmrtfa = k
7819                 ENDIF
7820!--              write mrtf values into the array
7821                 amrtf(nmrtf)%isurflt = imrt
7822                 amrtf(nmrtf)%isurfs = itarget(i)
7823                 amrtf(nmrtf)%rsvf = vffrac(i)
7824                 amrtf(nmrtf)%rtransp = ztransp(i)
7825              ENDDO ! itarg
7826
7827           ENDDO ! imrt
7828           DEALLOCATE ( zdirs, zcent, zbdry, vffrac, vffrac0, ztransp, itarget )
7829!
7830!--        Move MRT factors to final arrays
7831           ALLOCATE ( mrtf(nmrtf), mrtft(nmrtf), mrtfsurf(2,nmrtf) )
7832           DO  imrtf = 1, nmrtf
7833              mrtf(imrtf) = amrtf(imrtf)%rsvf
7834              mrtft(imrtf) = amrtf(imrtf)%rsvf * amrtf(imrtf)%rtransp
7835              mrtfsurf(:,imrtf) = (/amrtf(imrtf)%isurflt, amrtf(imrtf)%isurfs /)
7836           ENDDO
7837           IF ( ALLOCATED(amrtf1) )  DEALLOCATE( amrtf1 )
7838           IF ( ALLOCATED(amrtf2) )  DEALLOCATE( amrtf2 )
7839        ENDIF ! nmrtbl > 0
7840
7841        IF ( rad_angular_discretization )  THEN
7842#if defined( __parallel )
7843!--        finalize MPI_RMA communication established to get global index of the surface from grid indices
7844!--        flush all MPI window pending requests
7845           CALL MPI_Win_flush_all(win_gridsurf, ierr)
7846           IF ( ierr /= 0 ) THEN
7847               WRITE(9,*) 'Error MPI_Win_flush_all1:', ierr, win_gridsurf
7848               FLUSH(9)
7849           ENDIF
7850!--        unlock MPI window
7851           CALL MPI_Win_unlock_all(win_gridsurf, ierr)
7852           IF ( ierr /= 0 ) THEN
7853               WRITE(9,*) 'Error MPI_Win_unlock_all1:', ierr, win_gridsurf
7854               FLUSH(9)
7855           ENDIF
7856!--        free MPI window
7857           CALL MPI_Win_free(win_gridsurf, ierr)
7858           IF ( ierr /= 0 ) THEN
7859               WRITE(9,*) 'Error MPI_Win_free1:', ierr, win_gridsurf
7860               FLUSH(9)
7861           ENDIF
7862#else
7863           DEALLOCATE ( gridsurf )
7864#endif
7865        ENDIF
7866
7867        IF ( debug_output )  CALL debug_message( 'waiting for completion of SVF and CSF calculation in all processes', 'info' )
7868
7869!--     deallocate temporary global arrays
7870        DEALLOCATE(nzterr)
7871       
7872        IF ( plant_canopy )  THEN
7873!--         finalize mpi_rma communication and deallocate temporary arrays
7874#if defined( __parallel )
7875            IF ( raytrace_mpi_rma )  THEN
7876                CALL MPI_Win_flush_all(win_lad, ierr)
7877                IF ( ierr /= 0 ) THEN
7878                    WRITE(9,*) 'Error MPI_Win_flush_all2:', ierr, win_lad
7879                    FLUSH(9)
7880                ENDIF
7881!--             unlock MPI window
7882                CALL MPI_Win_unlock_all(win_lad, ierr)
7883                IF ( ierr /= 0 ) THEN
7884                    WRITE(9,*) 'Error MPI_Win_unlock_all2:', ierr, win_lad
7885                    FLUSH(9)
7886                ENDIF
7887!--             free MPI window
7888                CALL MPI_Win_free(win_lad, ierr)
7889                IF ( ierr /= 0 ) THEN
7890                    WRITE(9,*) 'Error MPI_Win_free2:', ierr, win_lad
7891                    FLUSH(9)
7892                ENDIF
7893!--             deallocate temporary arrays storing values for csf calculation during raytracing
7894                DEALLOCATE( lad_s_ray )
7895!--             sub_lad is the pointer to lad_s_rma in case of raytrace_mpi_rma
7896!--             and must not be deallocated here
7897            ELSE
7898                DEALLOCATE(sub_lad)
7899                DEALLOCATE(sub_lad_g)
7900            ENDIF
7901#else
7902            DEALLOCATE(sub_lad)
7903#endif
7904            DEALLOCATE( boxes )
7905            DEALLOCATE( crlens )
7906            DEALLOCATE( plantt )
7907            DEALLOCATE( rt2_track, rt2_track_lad, rt2_track_dist, rt2_dist )
7908        ENDIF
7909
7910        IF ( debug_output )  CALL debug_message( 'calculation of the complete SVF array', 'info' )
7911
7912        IF ( rad_angular_discretization )  THEN
7913           IF ( debug_output )  CALL debug_message( 'Load svf from the structure array to plain arrays', 'info' )
7914           ALLOCATE( svf(ndsvf,nsvfl) )
7915           ALLOCATE( svfsurf(idsvf,nsvfl) )
7916
7917           DO isvf = 1, nsvfl
7918               svf(:, isvf) = (/ asvf(isvf)%rsvf, asvf(isvf)%rtransp /)
7919               svfsurf(:, isvf) = (/ asvf(isvf)%isurflt, asvf(isvf)%isurfs /)
7920           ENDDO
7921        ELSE
7922           IF ( debug_output )  CALL debug_message( 'Start SVF sort', 'info' )
7923!--        sort svf ( a version of quicksort )
7924           CALL quicksort_svf(asvf,1,nsvfl)
7925
7926           !< load svf from the structure array to plain arrays
7927           IF ( debug_output )  CALL debug_message( 'Load svf from the structure array to plain arrays', 'info' )
7928           ALLOCATE( svf(ndsvf,nsvfl) )
7929           ALLOCATE( svfsurf(idsvf,nsvfl) )
7930           svfnorm_counts(:) = 0._wp
7931           isurflt_prev = -1
7932           ksvf = 1
7933           svfsum = 0._wp
7934           DO isvf = 1, nsvfl
7935!--            normalize svf per target face
7936               IF ( asvf(ksvf)%isurflt /= isurflt_prev )  THEN
7937                   IF ( isurflt_prev /= -1  .AND.  svfsum /= 0._wp )  THEN
7938                       !< update histogram of logged svf normalization values
7939                       i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev)))
7940                       svfnorm_counts(i) = svfnorm_counts(i) + 1
7941
7942                       svf(1, isvf_surflt:isvf-1) = svf(1, isvf_surflt:isvf-1) / svfsum * (1._wp-skyvf(isurflt_prev))
7943                   ENDIF
7944                   isurflt_prev = asvf(ksvf)%isurflt
7945                   isvf_surflt = isvf
7946                   svfsum = asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp
7947               ELSE
7948                   svfsum = svfsum + asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp
7949               ENDIF
7950
7951               svf(:, isvf) = (/ asvf(ksvf)%rsvf, asvf(ksvf)%rtransp /)
7952               svfsurf(:, isvf) = (/ asvf(ksvf)%isurflt, asvf(ksvf)%isurfs /)
7953
7954!--            next element
7955               ksvf = ksvf + 1
7956           ENDDO
7957
7958           IF ( isurflt_prev /= -1  .AND.  svfsum /= 0._wp )  THEN
7959               i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev)))
7960               svfnorm_counts(i) = svfnorm_counts(i) + 1
7961
7962               svf(1, isvf_surflt:nsvfl) = svf(1, isvf_surflt:nsvfl) / svfsum * (1._wp-skyvf(isurflt_prev))
7963           ENDIF
7964           WRITE(9, *) 'SVF normalization histogram:', svfnorm_counts,  &
7965                       'on thresholds:', svfnorm_report_thresh(1:svfnorm_report_num), '(val < thresh <= val)'
7966           !TODO we should be able to deallocate skyvf, from now on we only need skyvft
7967        ENDIF ! rad_angular_discretization
7968
7969!--     deallocate temporary asvf array
7970!--     DEALLOCATE(asvf) - ifort has a problem with deallocation of allocatable target
7971!--     via pointing pointer - we need to test original targets
7972        IF ( ALLOCATED(asvf1) )  THEN
7973            DEALLOCATE(asvf1)
7974        ENDIF
7975        IF ( ALLOCATED(asvf2) )  THEN
7976            DEALLOCATE(asvf2)
7977        ENDIF
7978
7979        npcsfl = 0
7980        IF ( plant_canopy )  THEN
7981
7982            IF ( debug_output )  CALL debug_message( 'Calculation of the complete CSF array', 'info' )
7983!--         sort and merge csf for the last time, keeping the array size to minimum
7984            CALL merge_and_grow_csf(-1)
7985           
7986!--         aggregate csb among processors
7987!--         allocate necessary arrays
7988            udim = max(ncsfl,1)
7989            ALLOCATE( csflt_l(ndcsf*udim) )
7990            csflt(1:ndcsf,1:udim) => csflt_l(1:ndcsf*udim)
7991            ALLOCATE( kcsflt_l(kdcsf*udim) )
7992            kcsflt(1:kdcsf,1:udim) => kcsflt_l(1:kdcsf*udim)
7993            ALLOCATE( icsflt(0:numprocs-1) )
7994            ALLOCATE( dcsflt(0:numprocs-1) )
7995            ALLOCATE( ipcsflt(0:numprocs-1) )
7996            ALLOCATE( dpcsflt(0:numprocs-1) )
7997           
7998!--         fill out arrays of csf values and
7999!--         arrays of number of elements and displacements
8000!--         for particular precessors
8001            icsflt = 0
8002            dcsflt = 0
8003            ip = -1
8004            j = -1
8005            d = 0
8006            DO kcsf = 1, ncsfl
8007                j = j+1
8008                IF ( acsf(kcsf)%ip /= ip )  THEN
8009!--                 new block of the processor
8010!--                 number of elements of previous block
8011                    IF ( ip>=0) icsflt(ip) = j
8012                    d = d+j
8013!--                 blank blocks
8014                    DO jp = ip+1, acsf(kcsf)%ip-1
8015!--                     number of elements is zero, displacement is equal to previous
8016                        icsflt(jp) = 0
8017                        dcsflt(jp) = d
8018                    ENDDO
8019!--                 the actual block
8020                    ip = acsf(kcsf)%ip
8021                    dcsflt(ip) = d
8022                    j = 0
8023                ENDIF
8024                csflt(1,kcsf) = acsf(kcsf)%rcvf
8025!--             fill out integer values of itz,ity,itx,isurfs
8026                kcsflt(1,kcsf) = acsf(kcsf)%itz
8027                kcsflt(2,kcsf) = acsf(kcsf)%ity
8028                kcsflt(3,kcsf) = acsf(kcsf)%itx
8029                kcsflt(4,kcsf) = acsf(kcsf)%isurfs
8030            ENDDO
8031!--         last blank blocks at the end of array
8032            j = j+1
8033            IF ( ip>=0 ) icsflt(ip) = j
8034            d = d+j
8035            DO jp = ip+1, numprocs-1
8036!--             number of elements is zero, displacement is equal to previous
8037                icsflt(jp) = 0
8038                dcsflt(jp) = d
8039            ENDDO
8040           
8041!--         deallocate temporary acsf array
8042!--         DEALLOCATE(acsf) - ifort has a problem with deallocation of allocatable target
8043!--         via pointing pointer - we need to test original targets
8044            IF ( ALLOCATED(acsf1) )  THEN
8045                DEALLOCATE(acsf1)
8046            ENDIF
8047            IF ( ALLOCATED(acsf2) )  THEN
8048                DEALLOCATE(acsf2)
8049            ENDIF
8050                   
8051#if defined( __parallel )
8052!--         scatter and gather the number of elements to and from all processor
8053!--         and calculate displacements
8054            IF ( debug_output )  CALL debug_message( 'Scatter and gather the number of elements to and from all processor', 'info' )
8055
8056            CALL MPI_AlltoAll(icsflt,1,MPI_INTEGER,ipcsflt,1,MPI_INTEGER,comm2d, ierr)
8057
8058            IF ( ierr /= 0 ) THEN
8059                WRITE(9,*) 'Error MPI_AlltoAll1:', ierr, SIZE(icsflt), SIZE(ipcsflt)
8060                FLUSH(9)
8061            ENDIF
8062
8063            npcsfl = SUM(ipcsflt)
8064            d = 0
8065            DO i = 0, numprocs-1
8066                dpcsflt(i) = d
8067                d = d + ipcsflt(i)
8068            ENDDO
8069
8070!--         exchange csf fields between processors
8071            IF ( debug_output )  CALL debug_message( 'Exchange csf fields between processors', 'info' )
8072            udim = max(npcsfl,1)
8073            ALLOCATE( pcsflt_l(ndcsf*udim) )
8074            pcsflt(1:ndcsf,1:udim) => pcsflt_l(1:ndcsf*udim)
8075            ALLOCATE( kpcsflt_l(kdcsf*udim) )
8076            kpcsflt(1:kdcsf,1:udim) => kpcsflt_l(1:kdcsf*udim)
8077            CALL MPI_AlltoAllv(csflt_l, ndcsf*icsflt, ndcsf*dcsflt, MPI_REAL, &
8078                pcsflt_l, ndcsf*ipcsflt, ndcsf*dpcsflt, MPI_REAL, comm2d, ierr)
8079            IF ( ierr /= 0 ) THEN
8080                WRITE(9,*) 'Error MPI_AlltoAllv1:', ierr, SIZE(ipcsflt), ndcsf*icsflt, &
8081                            ndcsf*dcsflt, SIZE(pcsflt_l),ndcsf*ipcsflt, ndcsf*dpcsflt
8082                FLUSH(9)
8083            ENDIF
8084
8085            CALL MPI_AlltoAllv(kcsflt_l, kdcsf*icsflt, kdcsf*dcsflt, MPI_INTEGER, &
8086                kpcsflt_l, kdcsf*ipcsflt, kdcsf*dpcsflt, MPI_INTEGER, comm2d, ierr)
8087            IF ( ierr /= 0 ) THEN
8088                WRITE(9,*) 'Error MPI_AlltoAllv2:', ierr, SIZE(kcsflt_l),kdcsf*icsflt, &
8089                           kdcsf*dcsflt, SIZE(kpcsflt_l), kdcsf*ipcsflt, kdcsf*dpcsflt
8090                FLUSH(9)
8091            ENDIF
8092           
8093#else
8094            npcsfl = ncsfl
8095            ALLOCATE( pcsflt(ndcsf,max(npcsfl,ndcsf)) )
8096            ALLOCATE( kpcsflt(kdcsf,max(npcsfl,kdcsf)) )
8097            pcsflt = csflt
8098            kpcsflt = kcsflt
8099#endif
8100
8101!--         deallocate temporary arrays
8102            DEALLOCATE( csflt_l )
8103            DEALLOCATE( kcsflt_l )
8104            DEALLOCATE( icsflt )
8105            DEALLOCATE( dcsflt )
8106            DEALLOCATE( ipcsflt )
8107            DEALLOCATE( dpcsflt )
8108
8109!--         sort csf ( a version of quicksort )
8110            IF ( debug_output )  CALL debug_message( 'Sort csf', 'info' )
8111            CALL quicksort_csf2(kpcsflt, pcsflt, 1, npcsfl)
8112
8113!--         aggregate canopy sink factor records with identical box & source
8114!--         againg across all values from all processors
8115            IF ( debug_output )  CALL debug_message( 'Aggregate canopy sink factor records with identical box', 'info' )
8116
8117            IF ( npcsfl > 0 )  THEN
8118                icsf = 1 !< reading index
8119                kcsf = 1 !< writing index
8120                DO WHILE (icsf < npcsfl)
8121!--                 here kpcsf(kcsf) already has values from kpcsf(icsf)
8122                    IF ( kpcsflt(3,icsf) == kpcsflt(3,icsf+1)  .AND.  &
8123                         kpcsflt(2,icsf) == kpcsflt(2,icsf+1)  .AND.  &
8124                         kpcsflt(1,icsf) == kpcsflt(1,icsf+1)  .AND.  &
8125                         kpcsflt(4,icsf) == kpcsflt(4,icsf+1) )  THEN
8126
8127                        pcsflt(1,kcsf) = pcsflt(1,kcsf) + pcsflt(1,icsf+1)
8128
8129!--                     advance reading index, keep writing index
8130                        icsf = icsf + 1
8131                    ELSE
8132!--                     not identical, just advance and copy
8133                        icsf = icsf + 1
8134                        kcsf = kcsf + 1
8135                        kpcsflt(:,kcsf) = kpcsflt(:,icsf)
8136                        pcsflt(:,kcsf) = pcsflt(:,icsf)
8137                    ENDIF
8138                ENDDO
8139!--             last written item is now also the last item in valid part of array
8140                npcsfl = kcsf
8141            ENDIF
8142
8143            ncsfl = npcsfl
8144            IF ( ncsfl > 0 )  THEN
8145                ALLOCATE( csf(ndcsf,ncsfl) )
8146                ALLOCATE( csfsurf(idcsf,ncsfl) )
8147                DO icsf = 1, ncsfl
8148                    csf(:,icsf) = pcsflt(:,icsf)
8149                    csfsurf(1,icsf) =  gridpcbl(kpcsflt(1,icsf),kpcsflt(2,icsf),kpcsflt(3,icsf))
8150                    csfsurf(2,icsf) =  kpcsflt(4,icsf)
8151                ENDDO
8152            ENDIF
8153           
8154!--         deallocation of temporary arrays
8155            IF ( npcbl > 0 )  DEALLOCATE( gridpcbl )
8156            DEALLOCATE( pcsflt_l )
8157            DEALLOCATE( kpcsflt_l )
8158            IF ( debug_output )  CALL debug_message( 'End of aggregate csf', 'info' )
8159           
8160        ENDIF
8161
8162#if defined( __parallel )
8163        CALL MPI_BARRIER( comm2d, ierr )
8164#endif
8165        CALL location_message( 'calculating view factors for radiation interaction', 'finished' )
8166
8167        RETURN  !todo: remove
8168       
8169!        WRITE( message_string, * )  &
8170!            'I/O error when processing shape view factors / ',  &
8171!            'plant canopy sink factors / direct irradiance factors.'
8172!        CALL message( 'init_urban_surface', 'PA0502', 2, 2, 0, 6, 0 )
8173       
8174    END SUBROUTINE radiation_calc_svf
8175
8176   
8177!------------------------------------------------------------------------------!
8178! Description:
8179! ------------
8180!> Raytracing for detecting obstacles and calculating compound canopy sink
8181!> factors. (A simple obstacle detection would only need to process faces in
8182!> 3 dimensions without any ordering.)
8183!> Assumtions:
8184!> -----------
8185!> 1. The ray always originates from a face midpoint (only one coordinate equals
8186!>    *.5, i.e. wall) and doesn't travel parallel to the surface (that would mean
8187!>    shape factor=0). Therefore, the ray may never travel exactly along a face
8188!>    or an edge.
8189!> 2. From grid bottom to urban surface top the grid has to be *equidistant*
8190!>    within each of the dimensions, including vertical (but the resolution
8191!>    doesn't need to be the same in all three dimensions).
8192!------------------------------------------------------------------------------!
8193    SUBROUTINE raytrace(src, targ, isrc, difvf, atarg, create_csf, visible, transparency)
8194        IMPLICIT NONE
8195
8196        REAL(wp), DIMENSION(3), INTENT(in)     :: src, targ    !< real coordinates z,y,x
8197        INTEGER(iwp), INTENT(in)               :: isrc         !< index of source face for csf
8198        REAL(wp), INTENT(in)                   :: difvf        !< differential view factor for csf
8199        REAL(wp), INTENT(in)                   :: atarg        !< target surface area for csf
8200        LOGICAL, INTENT(in)                    :: create_csf   !< whether to generate new CSFs during raytracing
8201        LOGICAL, INTENT(out)                   :: visible
8202        REAL(wp), INTENT(out)                  :: transparency !< along whole path
8203        INTEGER(iwp)                           :: i, k, d
8204        INTEGER(iwp)                           :: seldim       !< dimension to be incremented
8205        INTEGER(iwp)                           :: ncsb         !< no of written plant canopy sinkboxes
8206        INTEGER(iwp)                           :: maxboxes     !< max no of gridboxes visited
8207        REAL(wp)                               :: distance     !< euclidean along path
8208        REAL(wp)                               :: crlen        !< length of gridbox crossing
8209        REAL(wp)                               :: lastdist     !< beginning of current crossing
8210        REAL(wp)                               :: nextdist     !< end of current crossing
8211        REAL(wp)                               :: realdist     !< distance in meters per unit distance
8212        REAL(wp)                               :: crmid        !< midpoint of crossing
8213        REAL(wp)                               :: cursink      !< sink factor for current canopy box
8214        REAL(wp), DIMENSION(3)                 :: delta        !< path vector
8215        REAL(wp), DIMENSION(3)                 :: uvect        !< unit vector
8216        REAL(wp), DIMENSION(3)                 :: dimnextdist  !< distance for each dimension increments
8217        INTEGER(iwp), DIMENSION(3)             :: box          !< gridbox being crossed
8218        INTEGER(iwp), DIMENSION(3)             :: dimnext      !< next dimension increments along path
8219        INTEGER(iwp), DIMENSION(3)             :: dimdelta     !< dimension direction = +- 1
8220        INTEGER(iwp)                           :: px, py       !< number of processors in x and y dir before
8221                                                               !< the processor in the question
8222        INTEGER(iwp)                           :: ip           !< number of processor where gridbox reside
8223        INTEGER(iwp)                           :: ig           !< 1D index of gridbox in global 2D array
8224       
8225        REAL(wp)                               :: eps = 1E-10_wp !< epsilon for value comparison
8226        REAL(wp)                               :: lad_s_target   !< recieved lad_s of particular grid box
8227
8228!
8229!--     Maximum number of gridboxes visited equals to maximum number of boundaries crossed in each dimension plus one. That's also
8230!--     the maximum number of plant canopy boxes written. We grow the acsf array accordingly using exponential factor.
8231        maxboxes = SUM(ABS(NINT(targ, iwp) - NINT(src, iwp))) + 1
8232        IF ( plant_canopy  .AND.  ncsfl + maxboxes > ncsfla )  THEN
8233!--         use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1)
8234!--         k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) &
8235!--                                                / log(grow_factor)), kind=wp))
8236!--         or use this code to simply always keep some extra space after growing
8237            k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor)
8238
8239            CALL merge_and_grow_csf(k)
8240        ENDIF
8241       
8242        transparency = 1._wp
8243        ncsb = 0
8244
8245        delta(:) = targ(:) - src(:)
8246        distance = SQRT(SUM(delta(:)**2))
8247        IF ( distance == 0._wp )  THEN
8248            visible = .TRUE.
8249            RETURN
8250        ENDIF
8251        uvect(:) = delta(:) / distance
8252        realdist = SQRT(SUM( (uvect(:)*(/dz(1),dy,dx/))**2 ))
8253
8254        lastdist = 0._wp
8255
8256!--     Since all face coordinates have values *.5 and we'd like to use
8257!--     integers, all these have .5 added
8258        DO d = 1, 3
8259            IF ( uvect(d) == 0._wp )  THEN
8260                dimnext(d) = 999999999
8261                dimdelta(d) = 999999999
8262                dimnextdist(d) = 1.0E20_wp
8263            ELSE IF ( uvect(d) > 0._wp )  THEN
8264                dimnext(d) = CEILING(src(d) + .5_wp)
8265                dimdelta(d) = 1
8266                dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d)
8267            ELSE
8268                dimnext(d) = FLOOR(src(d) + .5_wp)
8269                dimdelta(d) = -1
8270                dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d)
8271            ENDIF
8272        ENDDO
8273
8274        DO
8275!--         along what dimension will the next wall crossing be?
8276            seldim = minloc(dimnextdist, 1)
8277            nextdist = dimnextdist(seldim)
8278            IF ( nextdist > distance ) nextdist = distance
8279
8280            crlen = nextdist - lastdist
8281            IF ( crlen > .001_wp )  THEN
8282                crmid = (lastdist + nextdist) * .5_wp
8283                box = NINT(src(:) + uvect(:) * crmid, iwp)
8284
8285!--             calculate index of the grid with global indices (box(2),box(3))
8286!--             in the array nzterr and plantt and id of the coresponding processor
8287                px = box(3)/nnx
8288                py = box(2)/nny
8289                ip = px*pdims(2)+py
8290                ig = ip*nnx*nny + (box(3)-px*nnx)*nny + box(2)-py*nny
8291                IF ( box(1) <= nzterr(ig) )  THEN
8292                    visible = .FALSE.
8293                    RETURN
8294                ENDIF
8295
8296                IF ( plant_canopy )  THEN
8297                    IF ( box(1) <= plantt(ig) )  THEN
8298                        ncsb = ncsb + 1
8299                        boxes(:,ncsb) = box
8300                        crlens(ncsb) = crlen
8301#if defined( __parallel )
8302                        lad_ip(ncsb) = ip
8303                        lad_disp(ncsb) = (box(3)-px*nnx)*(nny*nz_plant) + (box(2)-py*nny)*nz_plant + box(1)-nz_urban_b
8304#endif
8305                    ENDIF
8306                ENDIF
8307            ENDIF
8308
8309            IF ( ABS(distance - nextdist) < eps )  EXIT
8310            lastdist = nextdist
8311            dimnext(seldim) = dimnext(seldim) + dimdelta(seldim)
8312            dimnextdist(seldim) = (dimnext(seldim) - .5_wp - src(seldim)) / uvect(seldim)
8313        ENDDO
8314       
8315        IF ( plant_canopy )  THEN
8316#if defined( __parallel )
8317            IF ( raytrace_mpi_rma )  THEN
8318!--             send requests for lad_s to appropriate processor
8319                CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'start' )
8320                DO i = 1, ncsb
8321                    CALL MPI_Get(lad_s_ray(i), 1, MPI_REAL, lad_ip(i), lad_disp(i), &
8322                                 1, MPI_REAL, win_lad, ierr)
8323                    IF ( ierr /= 0 )  THEN
8324                        WRITE(9,*) 'Error MPI_Get1:', ierr, lad_s_ray(i), &
8325                                   lad_ip(i), lad_disp(i), win_lad
8326                        FLUSH(9)
8327                    ENDIF
8328                ENDDO
8329               
8330!--             wait for all pending local requests complete
8331                CALL MPI_Win_flush_local_all(win_lad, ierr)
8332                IF ( ierr /= 0 )  THEN
8333                    WRITE(9,*) 'Error MPI_Win_flush_local_all1:', ierr, win_lad
8334                    FLUSH(9)
8335                ENDIF
8336                CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'stop' )
8337               
8338            ENDIF
8339#endif
8340
8341!--         calculate csf and transparency
8342            DO i = 1, ncsb
8343#if defined( __parallel )
8344                IF ( raytrace_mpi_rma )  THEN
8345                    lad_s_target = lad_s_ray(i)
8346                ELSE
8347                    lad_s_target = sub_lad_g(lad_ip(i)*nnx*nny*nz_plant + lad_disp(i))
8348                ENDIF
8349#else
8350                lad_s_target = sub_lad(boxes(1,i),boxes(2,i),boxes(3,i))
8351#endif
8352                cursink = 1._wp - exp(-ext_coef * lad_s_target * crlens(i)*realdist)
8353
8354                IF ( create_csf )  THEN
8355!--                 write svf values into the array
8356                    ncsfl = ncsfl + 1
8357                    acsf(ncsfl)%ip = lad_ip(i)
8358                    acsf(ncsfl)%itx = boxes(3,i)
8359                    acsf(ncsfl)%ity = boxes(2,i)
8360                    acsf(ncsfl)%itz = boxes(1,i)
8361                    acsf(ncsfl)%isurfs = isrc
8362                    acsf(ncsfl)%rcvf = cursink*transparency*difvf*atarg
8363                ENDIF  !< create_csf
8364
8365                transparency = transparency * (1._wp - cursink)
8366               
8367            ENDDO
8368        ENDIF
8369       
8370        visible = .TRUE.
8371
8372    END SUBROUTINE raytrace
8373   
8374 
8375!------------------------------------------------------------------------------!
8376! Description:
8377! ------------
8378!> A new, more efficient version of ray tracing algorithm that processes a whole
8379!> arc instead of a single ray.
8380!>
8381!> In all comments, horizon means tangent of horizon angle, i.e.
8382!> vertical_delta / horizontal_distance
8383!------------------------------------------------------------------------------!
8384   SUBROUTINE raytrace_2d(origin, yxdir, nrays, zdirs, iorig, aorig, vffrac,  &
8385                              calc_svf, create_csf, skip_1st_pcb,             &
8386                              lowest_free_ray, transparency, itarget)
8387      IMPLICIT NONE
8388
8389      REAL(wp), DIMENSION(3), INTENT(IN)     ::  origin        !< z,y,x coordinates of ray origin
8390      REAL(wp), DIMENSION(2), INTENT(IN)     ::  yxdir         !< y,x *unit* vector of ray direction (in grid units)
8391      INTEGER(iwp)                           ::  nrays         !< number of rays (z directions) to raytrace
8392      REAL(wp), DIMENSION(nrays), INTENT(IN) ::  zdirs         !< list of z directions to raytrace (z/hdist, grid, zenith->nadir)
8393      INTEGER(iwp), INTENT(in)               ::  iorig         !< index of origin face for csf
8394      REAL(wp), INTENT(in)                   ::  aorig         !< origin face area for csf
8395      REAL(wp), DIMENSION(nrays), INTENT(in) ::  vffrac        !< view factor fractions of each ray for csf
8396      LOGICAL, INTENT(in)                    ::  calc_svf      !< whether to calculate SFV (identify obstacle surfaces)
8397      LOGICAL, INTENT(in)                    ::  create_csf    !< whether to create canopy sink factors
8398      LOGICAL, INTENT(in)                    ::  skip_1st_pcb  !< whether to skip first plant canopy box during raytracing
8399      INTEGER(iwp), INTENT(out)              ::  lowest_free_ray !< index into zdirs
8400      REAL(wp), DIMENSION(nrays), INTENT(OUT) ::  transparency !< transparencies of zdirs paths
8401      INTEGER(iwp), DIMENSION(nrays), INTENT(OUT) ::  itarget  !< global indices of target faces for zdirs
8402
8403      INTEGER(iwp), DIMENSION(nrays)         ::  target_procs
8404      REAL(wp)                               ::  horizon       !< highest horizon found after raytracing (z/hdist)
8405      INTEGER(iwp)                           ::  i, k, l, d
8406      INTEGER(iwp)                           ::  seldim       !< dimension to be incremented
8407      REAL(wp), DIMENSION(2)                 ::  yxorigin     !< horizontal copy of origin (y,x)
8408      REAL(wp)                               ::  distance     !< euclidean along path
8409      REAL(wp)                               ::  lastdist     !< beginning of current crossing
8410      REAL(wp)                               ::  nextdist     !< end of current crossing
8411      REAL(wp)                               ::  crmid        !< midpoint of crossing
8412      REAL(wp)                               ::  horz_entry   !< horizon at entry to column
8413      REAL(wp)                               ::  horz_exit    !< horizon at exit from column
8414      REAL(wp)                               ::  bdydim       !< boundary for current dimension
8415      REAL(wp), DIMENSION(2)                 ::  crossdist    !< distances to boundary for dimensions
8416      REAL(wp), DIMENSION(2)                 ::  dimnextdist  !< distance for each dimension increments
8417      INTEGER(iwp), DIMENSION(2)             ::  column       !< grid column being crossed
8418      INTEGER(iwp), DIMENSION(2)             ::  dimnext      !< next dimension increments along path
8419      INTEGER(iwp), DIMENSION(2)             ::  dimdelta     !< dimension direction = +- 1
8420      INTEGER(iwp)                           ::  px, py       !< number of processors in x and y dir before
8421                                                              !< the processor in the question
8422      INTEGER(iwp)                           ::  ip           !< number of processor where gridbox reside
8423      INTEGER(iwp)                           ::  ig           !< 1D index of gridbox in global 2D array
8424      INTEGER(iwp)                           ::  wcount       !< RMA window item count
8425      INTEGER(iwp)                           ::  maxboxes     !< max no of CSF created
8426      INTEGER(iwp)                           ::  nly          !< maximum  plant canopy height
8427      INTEGER(iwp)                           ::  ntrack
8428     
8429      INTEGER(iwp)                           ::  zb0
8430      INTEGER(iwp)                           ::  zb1
8431      INTEGER(iwp)                           ::  nz
8432      INTEGER(iwp)                           ::  iz
8433      INTEGER(iwp)                           ::  zsgn
8434      INTEGER(iwp)                           ::  lowest_lad   !< lowest column cell for which we need LAD
8435      INTEGER(iwp)                           ::  lastdir      !< wall direction before hitting this column
8436      INTEGER(iwp), DIMENSION(2)             ::  lastcolumn
8437
8438#if defined( __parallel )
8439      INTEGER(MPI_ADDRESS_KIND)              ::  wdisp        !< RMA window displacement
8440#endif
8441     
8442      REAL(wp)                               ::  eps = 1E-10_wp !< epsilon for value comparison
8443      REAL(wp)                               ::  zbottom, ztop !< urban surface boundary in real numbers
8444      REAL(wp)                               ::  zorig         !< z coordinate of ray column entry
8445      REAL(wp)                               ::  zexit         !< z coordinate of ray column exit
8446      REAL(wp)                               ::  qdist         !< ratio of real distance to z coord difference
8447      REAL(wp)                               ::  dxxyy         !< square of real horizontal distance
8448      REAL(wp)                               ::  curtrans      !< transparency of current PC box crossing
8449     
8450
8451     
8452      yxorigin(:) = origin(2:3)
8453      transparency(:) = 1._wp !-- Pre-set the all rays to transparent before reducing
8454      horizon = -HUGE(1._wp)
8455      lowest_free_ray = nrays
8456      IF ( rad_angular_discretization  .AND.  calc_svf )  THEN
8457         ALLOCATE(target_surfl(nrays))
8458         target_surfl(:) = -1
8459         lastdir = -999
8460         lastcolumn(:) = -999
8461      ENDIF
8462
8463!--   Determine distance to boundary (in 2D xy)
8464      IF ( yxdir(1) > 0._wp )  THEN
8465         bdydim = ny + .5_wp !< north global boundary
8466         crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1)
8467      ELSEIF ( yxdir(1) == 0._wp )  THEN
8468         crossdist(1) = HUGE(1._wp)
8469      ELSE
8470          bdydim = -.5_wp !< south global boundary
8471          crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1)
8472      ENDIF
8473
8474      IF ( yxdir(2) > 0._wp )  THEN
8475          bdydim = nx + .5_wp !< east global boundary
8476          crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2)
8477      ELSEIF ( yxdir(2) == 0._wp )  THEN
8478         crossdist(2) = HUGE(1._wp)
8479      ELSE
8480          bdydim = -.5_wp !< west global boundary
8481          crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2)
8482      ENDIF
8483      distance = minval(crossdist, 1)
8484
8485      IF ( plant_canopy )  THEN
8486         rt2_track_dist(0) = 0._wp
8487         rt2_track_lad(:,:) = 0._wp
8488         nly = plantt_max - nz_urban_b + 1
8489      ENDIF
8490
8491      lastdist = 0._wp
8492
8493!--   Since all face coordinates have values *.5 and we'd like to use
8494!--   integers, all these have .5 added
8495      DO  d = 1, 2
8496          IF ( yxdir(d) == 0._wp )  THEN
8497              dimnext(d) = HUGE(1_iwp)
8498              dimdelta(d) = HUGE(1_iwp)
8499              dimnextdist(d) = HUGE(1._wp)
8500          ELSE IF ( yxdir(d) > 0._wp )  THEN
8501              dimnext(d) = FLOOR(yxorigin(d) + .5_wp) + 1
8502              dimdelta(d) = 1
8503              dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d)
8504          ELSE
8505              dimnext(d) = CEILING(yxorigin(d) + .5_wp) - 1
8506              dimdelta(d) = -1
8507              dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d)
8508          ENDIF
8509      ENDDO
8510
8511      ntrack = 0
8512      DO
8513!--      along what dimension will the next wall crossing be?
8514         seldim = minloc(dimnextdist, 1)
8515         nextdist = dimnextdist(seldim)
8516         IF ( nextdist > distance )  nextdist = distance
8517
8518         IF ( nextdist > lastdist )  THEN
8519            ntrack = ntrack + 1
8520            crmid = (lastdist + nextdist) * .5_wp
8521            column = NINT(yxorigin(:) + yxdir(:) * crmid, iwp)
8522
8523!--         calculate index of the grid with global indices (column(1),column(2))
8524!--         in the array nzterr and plantt and id of the coresponding processor
8525            px = column(2)/nnx
8526            py = column(1)/nny
8527            ip = px*pdims(2)+py
8528            ig = ip*nnx*nny + (column(2)-px*nnx)*nny + column(1)-py*nny
8529
8530            IF ( lastdist == 0._wp )  THEN
8531               horz_entry = -HUGE(1._wp)
8532            ELSE
8533               horz_entry = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / lastdist
8534            ENDIF
8535            horz_exit = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / nextdist
8536
8537            IF ( rad_angular_discretization  .AND.  calc_svf )  THEN
8538!
8539!--            Identify vertical obstacles hit by rays in current column
8540               DO WHILE ( lowest_free_ray > 0 )
8541                  IF ( zdirs(lowest_free_ray) > horz_entry )  EXIT
8542!
8543!--               This may only happen after 1st column, so lastdir and lastcolumn are valid
8544                  CALL request_itarget(lastdir,                                         &
8545                        CEILING(-0.5_wp + origin(1) + zdirs(lowest_free_ray)*lastdist), &
8546                        lastcolumn(1), lastcolumn(2),                                   &
8547                        target_surfl(lowest_free_ray), target_procs(lowest_free_ray))
8548                  lowest_free_ray = lowest_free_ray - 1
8549               ENDDO
8550!
8551!--            Identify horizontal obstacles hit by rays in current column
8552               DO WHILE ( lowest_free_ray > 0 )
8553                  IF ( zdirs(lowest_free_ray) > horz_exit )  EXIT
8554                  CALL request_itarget(iup_u, nzterr(ig)+1, column(1), column(2), &
8555                                       target_surfl(lowest_free_ray),           &
8556                                       target_procs(lowest_free_ray))
8557                  lowest_free_ray = lowest_free_ray - 1
8558               ENDDO
8559            ENDIF
8560
8561            horizon = MAX(horizon, horz_entry, horz_exit)
8562
8563            IF ( plant_canopy )  THEN
8564               rt2_track(:, ntrack) = column(:)
8565               rt2_track_dist(ntrack) = nextdist
8566            ENDIF
8567         ENDIF
8568
8569         IF ( nextdist + eps >= distance )  EXIT
8570
8571         IF ( rad_angular_discretization  .AND.  calc_svf )  THEN
8572!
8573!--         Save wall direction of coming building column (= this air column)
8574            IF ( seldim == 1 )  THEN
8575               IF ( dimdelta(seldim) == 1 )  THEN
8576                  lastdir = isouth_u
8577               ELSE
8578                  lastdir = inorth_u
8579               ENDIF
8580            ELSE
8581               IF ( dimdelta(seldim) == 1 )  THEN
8582                  lastdir = iwest_u
8583               ELSE
8584                  lastdir = ieast_u
8585               ENDIF
8586            ENDIF
8587            lastcolumn = column
8588         ENDIF
8589         lastdist = nextdist
8590         dimnext(seldim) = dimnext(seldim) + dimdelta(seldim)
8591         dimnextdist(seldim) = (dimnext(seldim) - .5_wp - yxorigin(seldim)) / yxdir(seldim)
8592      ENDDO
8593
8594      IF ( plant_canopy )  THEN
8595!--      Request LAD WHERE applicable
8596!--     
8597#if defined( __parallel )
8598         IF ( raytrace_mpi_rma )  THEN
8599!--         send requests for lad_s to appropriate processor
8600            !CALL cpu_log( log_point_s(77), 'usm_init_rma', 'start' )
8601            DO  i = 1, ntrack
8602               px = rt2_track(2,i)/nnx
8603               py = rt2_track(1,i)/nny
8604               ip = px*pdims(2)+py
8605               ig = ip*nnx*nny + (rt2_track(2,i)-px*nnx)*nny + rt2_track(1,i)-py*nny
8606
8607               IF ( rad_angular_discretization  .AND.  calc_svf )  THEN
8608!
8609!--               For fixed view resolution, we need plant canopy even for rays
8610!--               to opposing surfaces
8611                  lowest_lad = nzterr(ig) + 1
8612               ELSE
8613!
8614!--               We only need LAD for rays directed above horizon (to sky)
8615                  lowest_lad = CEILING( -0.5_wp + origin(1) +            &
8616                                    MIN( horizon * rt2_track_dist(i-1),  & ! entry
8617                                         horizon * rt2_track_dist(i)   ) ) ! exit
8618               ENDIF
8619!
8620!--            Skip asking for LAD where all plant canopy is under requested level
8621               IF ( plantt(ig) < lowest_lad )  CYCLE
8622
8623               wdisp = (rt2_track(2,i)-px*nnx)*(nny*nz_plant) + (rt2_track(1,i)-py*nny)*nz_plant + lowest_lad-nz_urban_b
8624               wcount = plantt(ig)-lowest_lad+1
8625               ! TODO send request ASAP - even during raytracing
8626               CALL MPI_Get(rt2_track_lad(lowest_lad:plantt(ig), i), wcount, MPI_REAL, ip,    &
8627                            wdisp, wcount, MPI_REAL, win_lad, ierr)
8628               IF ( ierr /= 0 )  THEN
8629                  WRITE(9,*) 'Error MPI_Get2:', ierr, rt2_track_lad(lowest_lad:plantt(ig), i), &
8630                             wcount, ip, wdisp, win_lad
8631                  FLUSH(9)
8632               ENDIF
8633            ENDDO
8634
8635!--         wait for all pending local requests complete
8636            ! TODO WAIT selectively for each column later when needed
8637            CALL MPI_Win_flush_local_all(win_lad, ierr)
8638            IF ( ierr /= 0 )  THEN
8639               WRITE(9,*) 'Error MPI_Win_flush_local_all2:', ierr, win_lad
8640               FLUSH(9)
8641            ENDIF
8642            !CALL cpu_log( log_point_s(77), 'usm_init_rma', 'stop' )
8643
8644         ELSE ! raytrace_mpi_rma = .F.
8645            DO  i = 1, ntrack
8646               px = rt2_track(2,i)/nnx
8647               py = rt2_track(1,i)/nny
8648               ip = px*pdims(2)+py
8649               ig = ip*nnx*nny*nz_plant + (rt2_track(2,i)-px*nnx)*(nny*nz_plant) + (rt2_track(1,i)-py*nny)*nz_plant
8650               rt2_track_lad(nz_urban_b:plantt_max, i) = sub_lad_g(ig:ig+nly-1)
8651            ENDDO
8652         ENDIF
8653#else
8654         DO  i = 1, ntrack
8655            rt2_track_lad(nz_urban_b:plantt_max, i) = sub_lad(rt2_track(1,i), rt2_track(2,i), nz_urban_b:plantt_max)
8656         ENDDO
8657#endif
8658      ENDIF ! plant_canopy
8659
8660      IF ( rad_angular_discretization  .AND.  calc_svf )  THEN
8661#if defined( __parallel )
8662!--      wait for all gridsurf requests to complete
8663         CALL MPI_Win_flush_local_all(win_gridsurf, ierr)
8664         IF ( ierr /= 0 )  THEN
8665            WRITE(9,*) 'Error MPI_Win_flush_local_all3:', ierr, win_gridsurf
8666            FLUSH(9)
8667         ENDIF
8668#endif
8669!
8670!--      recalculate local surf indices into global ones
8671         DO i = 1, nrays
8672            IF ( target_surfl(i) == -1 )  THEN
8673               itarget(i) = -1
8674            ELSE
8675               itarget(i) = target_surfl(i) + surfstart(target_procs(i))
8676            ENDIF
8677         ENDDO
8678         
8679         DEALLOCATE( target_surfl )
8680         
8681      ELSE
8682         itarget(:) = -1
8683      ENDIF ! rad_angular_discretization
8684
8685      IF ( plant_canopy )  THEN
8686!--      Skip the PCB around origin if requested (for MRT, the PCB might not be there)
8687!--     
8688         IF ( skip_1st_pcb  .AND.  NINT(origin(1)) <= plantt_max )  THEN
8689            rt2_track_lad(NINT(origin(1), iwp), 1) = 0._wp
8690         ENDIF
8691
8692!--      Assert that we have space allocated for CSFs
8693!--     
8694         maxboxes = (ntrack + MAX(CEILING(origin(1)-.5_wp) - nz_urban_b,          &
8695                                  nz_urban_t - CEILING(origin(1)-.5_wp))) * nrays
8696         IF ( ncsfl + maxboxes > ncsfla )  THEN
8697!--         use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1)
8698!--         k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) &
8699!--                                                / log(grow_factor)), kind=wp))
8700!--         or use this code to simply always keep some extra space after growing
8701            k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor)
8702            CALL merge_and_grow_csf(k)
8703         ENDIF
8704
8705!--      Calculate transparencies and store new CSFs
8706!--     
8707         zbottom = REAL(nz_urban_b, wp) - .5_wp
8708         ztop = REAL(plantt_max, wp) + .5_wp
8709
8710!--      Reverse direction of radiation (face->sky), only when calc_svf
8711!--     
8712         IF ( calc_svf )  THEN
8713            DO  i = 1, ntrack ! for each column
8714               dxxyy = ((dy*yxdir(1))**2 + (dx*yxdir(2))**2) * (rt2_track_dist(i)-rt2_track_dist(i-1))**2
8715               px = rt2_track(2,i)/nnx
8716               py = rt2_track(1,i)/nny
8717               ip = px*pdims(2)+py
8718
8719               DO  k = 1, nrays ! for each ray
8720!
8721!--               NOTE 6778:
8722!--               With traditional svf discretization, CSFs under the horizon
8723!--               (i.e. for surface to surface radiation)  are created in
8724!--               raytrace(). With rad_angular_discretization, we must create
8725!--               CSFs under horizon only for one direction, otherwise we would
8726!--               have duplicate amount of energy. Although we could choose
8727!--               either of the two directions (they differ only by
8728!--               discretization error with no bias), we choose the the backward
8729!--               direction, because it tends to cumulate high canopy sink
8730!--               factors closer to raytrace origin, i.e. it should potentially
8731!--               cause less moiree.
8732                  IF ( .NOT. rad_angular_discretization )  THEN
8733                     IF ( zdirs(k) <= horizon )  CYCLE
8734                  ENDIF
8735
8736                  zorig = origin(1) + zdirs(k) * rt2_track_dist(i-1)
8737                  IF ( zorig <= zbottom  .OR.  zorig >= ztop )  CYCLE
8738
8739                  zsgn = INT(SIGN(1._wp, zdirs(k)), iwp)
8740                  rt2_dist(1) = 0._wp
8741                  IF ( zdirs(k) == 0._wp )  THEN ! ray is exactly horizontal
8742                     nz = 2
8743                     rt2_dist(nz) = SQRT(dxxyy)
8744                     iz = CEILING(-.5_wp + zorig, iwp)
8745                  ELSE
8746                     zexit = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop)
8747
8748                     zb0 = FLOOR(  zorig * zsgn - .5_wp) + 1  ! because it must be greater than orig
8749                     zb1 = CEILING(zexit * zsgn - .5_wp) - 1  ! because it must be smaller than exit
8750                     nz = MAX(zb1 - zb0 + 3, 2)
8751                     rt2_dist(nz) = SQRT(((zexit-zorig)*dz(1))**2 + dxxyy)
8752                     qdist = rt2_dist(nz) / (zexit-zorig)
8753                     rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/)
8754                     iz = zb0 * zsgn
8755                  ENDIF
8756
8757                  DO  l = 2, nz
8758                     IF ( rt2_track_lad(iz, i) > 0._wp )  THEN
8759                        curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1)))
8760
8761                        IF ( create_csf )  THEN
8762                           ncsfl = ncsfl + 1
8763                           acsf(ncsfl)%ip = ip
8764                           acsf(ncsfl)%itx = rt2_track(2,i)
8765                           acsf(ncsfl)%ity = rt2_track(1,i)
8766                           acsf(ncsfl)%itz = iz
8767                           acsf(ncsfl)%isurfs = iorig
8768                           acsf(ncsfl)%rcvf = (1._wp - curtrans)*transparency(k)*vffrac(k)
8769                        ENDIF
8770
8771                        transparency(k) = transparency(k) * curtrans
8772                     ENDIF
8773                     iz = iz + zsgn
8774                  ENDDO ! l = 1, nz - 1
8775               ENDDO ! k = 1, nrays
8776            ENDDO ! i = 1, ntrack
8777
8778            transparency(1:lowest_free_ray) = 1._wp !-- Reset rays above horizon to transparent (see NOTE 6778)
8779         ENDIF
8780
8781!--      Forward direction of radiation (sky->face), always
8782!--     
8783         DO  i = ntrack, 1, -1 ! for each column backwards
8784            dxxyy = ((dy*yxdir(1))**2 + (dx*yxdir(2))**2) * (rt2_track_dist(i)-rt2_track_dist(i-1))**2
8785            px = rt2_track(2,i)/nnx
8786            py = rt2_track(1,i)/nny
8787            ip = px*pdims(2)+py
8788
8789            DO  k = 1, nrays ! for each ray
8790!
8791!--            See NOTE 6778 above
8792               IF ( zdirs(k) <= horizon )  CYCLE
8793
8794               zexit = origin(1) + zdirs(k) * rt2_track_dist(i-1)
8795               IF ( zexit <= zbottom  .OR.  zexit >= ztop )  CYCLE
8796
8797               zsgn = -INT(SIGN(1._wp, zdirs(k)), iwp)
8798               rt2_dist(1) = 0._wp
8799               IF ( zdirs(k) == 0._wp )  THEN ! ray is exactly horizontal
8800                  nz = 2
8801                  rt2_dist(nz) = SQRT(dxxyy)
8802                  iz = NINT(zexit, iwp)
8803               ELSE
8804                  zorig = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop)
8805
8806                  zb0 = FLOOR(  zorig * zsgn - .5_wp) + 1  ! because it must be greater than orig
8807                  zb1 = CEILING(zexit * zsgn - .5_wp) - 1  ! because it must be smaller than exit
8808                  nz = MAX(zb1 - zb0 + 3, 2)
8809                  rt2_dist(nz) = SQRT(((zexit-zorig)*dz(1))**2 + dxxyy)
8810                  qdist = rt2_dist(nz) / (zexit-zorig)
8811                  rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/)
8812                  iz = zb0 * zsgn
8813               ENDIF
8814
8815               DO  l = 2, nz
8816                  IF ( rt2_track_lad(iz, i) > 0._wp )  THEN
8817                     curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1)))
8818
8819                     IF ( create_csf )  THEN
8820                        ncsfl = ncsfl + 1
8821                        acsf(ncsfl)%ip = ip
8822                        acsf(ncsfl)%itx = rt2_track(2,i)
8823                        acsf(ncsfl)%ity = rt2_track(1,i)
8824                        acsf(ncsfl)%itz = iz
8825                        IF ( itarget(k) /= -1 ) STOP 1 !FIXME remove after test
8826                        acsf(ncsfl)%isurfs = -1
8827                        acsf(ncsfl)%rcvf = (1._wp - curtrans)*transparency(k)*aorig*vffrac(k)
8828                     ENDIF  ! create_csf
8829
8830                     transparency(k) = transparency(k) * curtrans
8831                  ENDIF
8832                  iz = iz + zsgn
8833               ENDDO ! l = 1, nz - 1
8834            ENDDO ! k = 1, nrays
8835         ENDDO ! i = 1, ntrack
8836      ENDIF ! plant_canopy
8837
8838      IF ( .NOT. (rad_angular_discretization  .AND.  calc_svf) )  THEN
8839!
8840!--      Just update lowest_free_ray according to horizon
8841         DO WHILE ( lowest_free_ray > 0 )
8842            IF ( zdirs(lowest_free_ray) > horizon )  EXIT
8843            lowest_free_ray = lowest_free_ray - 1
8844         ENDDO
8845      ENDIF
8846
8847   CONTAINS
8848
8849      SUBROUTINE request_itarget( d, z, y, x, isurfl, iproc )
8850
8851         INTEGER(iwp), INTENT(in)            ::  d, z, y, x
8852         INTEGER(iwp), TARGET, INTENT(out)   ::  isurfl
8853         INTEGER(iwp), INTENT(out)           ::  iproc
8854#if defined( __parallel )
8855#else
8856         INTEGER(iwp)                        ::  target_displ  !< index of the grid in the local gridsurf array
8857#endif
8858         INTEGER(iwp)                        ::  px, py        !< number of processors in x and y direction
8859                                                               !< before the processor in the question
8860#if defined( __parallel )
8861         INTEGER(KIND=MPI_ADDRESS_KIND)      ::  target_displ  !< index of the grid in the local gridsurf array
8862
8863!
8864!--      Calculate target processor and index in the remote local target gridsurf array
8865         px = x / nnx
8866         py = y / nny
8867         iproc = px * pdims(2) + py
8868         target_displ = ((x-px*nnx) * nny + y - py*nny ) * nz_urban * nsurf_type_u +&
8869                        ( z-nz_urban_b ) * nsurf_type_u + d
8870!
8871!--      Send MPI_Get request to obtain index target_surfl(i)
8872         CALL MPI_GET( isurfl, 1, MPI_INTEGER, iproc, target_displ,            &
8873                       1, MPI_INTEGER, win_gridsurf, ierr)
8874         IF ( ierr /= 0 )  THEN
8875            WRITE( 9,* ) 'Error MPI_Get3:', ierr, isurfl, iproc, target_displ, &
8876                         win_gridsurf
8877            FLUSH( 9 )
8878         ENDIF
8879#else
8880!--      set index target_surfl(i)
8881         isurfl = gridsurf(d,z,y,x)
8882#endif
8883
8884      END SUBROUTINE request_itarget
8885
8886   END SUBROUTINE raytrace_2d
8887 
8888
8889!------------------------------------------------------------------------------!
8890!
8891! Description:
8892! ------------
8893!> Calculates apparent solar positions for all timesteps and stores discretized
8894!> positions.
8895!------------------------------------------------------------------------------!
8896   SUBROUTINE radiation_presimulate_solar_pos
8897
8898      IMPLICIT NONE
8899
8900      INTEGER(iwp) ::  it, i, j                           !< loop indices
8901
8902      REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir_tmp !< dsidir_tmp[:,i] = unit vector of i-th
8903                                                          !< appreant solar direction
8904
8905      ALLOCATE ( dsidir_rev(0:raytrace_discrete_elevs/2-1,                 &
8906                            0:raytrace_discrete_azims-1) )
8907      dsidir_rev(:,:) = -1
8908      ALLOCATE ( dsidir_tmp(3,                                             &
8909                     raytrace_discrete_elevs/2*raytrace_discrete_azims) )
8910      ndsidir = 0
8911      sun_direction = .TRUE.
8912     
8913!
8914!--   Process spinup time if configured
8915      IF ( spinup_time > 0._wp )  THEN
8916         DO  it = 0, CEILING(spinup_time / dt_spinup)
8917            CALL simulate_pos( it * dt_spinup - spinup_time )
8918         ENDDO
8919      ENDIF
8920!
8921!--   Process simulation time
8922      DO  it = 0, CEILING(( end_time - spinup_time ) / dt_radiation)
8923         CALL simulate_pos( it * dt_radiation )
8924      ENDDO
8925!
8926!--   Allocate global vars which depend on ndsidir
8927      ALLOCATE ( dsidir ( 3, ndsidir ) )
8928      dsidir(:,:) = dsidir_tmp(:, 1:ndsidir)
8929      DEALLOCATE ( dsidir_tmp )
8930
8931      ALLOCATE ( dsitrans(nsurfl, ndsidir) )
8932      ALLOCATE ( dsitransc(npcbl, ndsidir) )
8933      IF ( nmrtbl > 0 )  ALLOCATE ( mrtdsit(nmrtbl, ndsidir) )
8934
8935      WRITE ( message_string, * ) 'Precalculated', ndsidir, ' solar positions', &
8936                                  ' from', it, ' timesteps.'
8937      CALL message( 'radiation_presimulate_solar_pos', 'UI0013', 0, 0, 0, 6, 0 )
8938
8939      CONTAINS
8940
8941      !------------------------------------------------------------------------!
8942      ! Description:
8943      ! ------------
8944      !> Simuates a single position
8945      !------------------------------------------------------------------------!
8946      SUBROUTINE simulate_pos( time_since_reference_local )
8947
8948         REAL(wp), INTENT(IN) ::  time_since_reference_local  !< local time since reference
8949!
8950!--      Update apparent solar position based on modified t_s_r_p
8951         CALL get_date_time( time_since_reference_local, &
8952                             day_of_year=day_of_year,    &
8953                             second_of_day=second_of_day )
8954         CALL calc_zenith( day_of_year, second_of_day )
8955         IF ( cos_zenith > 0 )  THEN
8956!--         
8957!--         Identify solar direction vector (discretized number) 1)
8958            i = MODULO(NINT(ATAN2(sun_dir_lon, sun_dir_lat)               &
8959                            / (2._wp*pi) * raytrace_discrete_azims-.5_wp, iwp), &
8960                       raytrace_discrete_azims)
8961            j = FLOOR(ACOS(cos_zenith) / pi * raytrace_discrete_elevs)
8962            IF ( dsidir_rev(j, i) == -1 )  THEN
8963               ndsidir = ndsidir + 1
8964               dsidir_tmp(:, ndsidir) =                                              &
8965                     (/ COS((REAL(j,wp)+.5_wp) * pi      / raytrace_discrete_elevs), &
8966                        SIN((REAL(j,wp)+.5_wp) * pi      / raytrace_discrete_elevs)  &
8967                      * COS((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims), &
8968                        SIN((REAL(j,wp)+.5_wp) * pi      / raytrace_discrete_elevs)  &
8969                      * SIN((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims) /)
8970               dsidir_rev(j, i) = ndsidir
8971            ENDIF
8972         ENDIF
8973      END SUBROUTINE simulate_pos
8974
8975   END SUBROUTINE radiation_presimulate_solar_pos
8976
8977
8978
8979!------------------------------------------------------------------------------!
8980! Description:
8981! ------------
8982!> Determines whether two faces are oriented towards each other. Since the
8983!> surfaces follow the gird box surfaces, it checks first whether the two surfaces
8984!> are directed in the same direction, then it checks if the two surfaces are
8985!> located in confronted direction but facing away from each other, e.g. <--| |-->
8986!------------------------------------------------------------------------------!
8987    PURE LOGICAL FUNCTION surface_facing(x, y, z, d, x2, y2, z2, d2)
8988        IMPLICIT NONE
8989        INTEGER(iwp),   INTENT(in)  :: x, y, z, d, x2, y2, z2, d2
8990     
8991        surface_facing = .FALSE.
8992
8993!-- first check: are the two surfaces directed in the same direction
8994        IF ( (d==iup_u  .OR.  d==iup_l )                             &
8995             .AND. (d2==iup_u  .OR. d2==iup_l) ) RETURN
8996        IF ( (d==isouth_u  .OR.  d==isouth_l ) &
8997             .AND.  (d2==isouth_u  .OR.  d2==isouth_l) ) RETURN
8998        IF ( (d==inorth_u  .OR.  d==inorth_l ) &
8999             .AND.  (d2==inorth_u  .OR.  d2==inorth_l) ) RETURN
9000        IF ( (d==iwest_u  .OR.  d==iwest_l )     &
9001             .AND.  (d2==iwest_u  .OR.  d2==iwest_l ) ) RETURN
9002        IF ( (d==ieast_u  .OR.  d==ieast_l )     &
9003             .AND.  (d2==ieast_u  .OR.  d2==ieast_l ) ) RETURN
9004
9005!-- second check: are surfaces facing away from each other
9006        SELECT CASE (d)
9007            CASE (iup_u, iup_l)                     !< upward facing surfaces
9008                IF ( z2 < z ) RETURN
9009            CASE (isouth_u, isouth_l)               !< southward facing surfaces
9010                IF ( y2 > y ) RETURN
9011            CASE (inorth_u, inorth_l)               !< northward facing surfaces
9012                IF ( y2 < y ) RETURN
9013            CASE (iwest_u, iwest_l)                 !< westward facing surfaces
9014                IF ( x2 > x ) RETURN
9015            CASE (ieast_u, ieast_l)                 !< eastward facing surfaces
9016                IF ( x2 < x ) RETURN
9017        END SELECT
9018
9019        SELECT CASE (d2)
9020            CASE (iup_u)                            !< ground, roof
9021                IF ( z < z2 ) RETURN
9022            CASE (isouth_u, isouth_l)               !< south facing
9023                IF ( y > y2 ) RETURN
9024            CASE (inorth_u, inorth_l)               !< north facing
9025                IF ( y < y2 ) RETURN
9026            CASE (iwest_u, iwest_l)                 !< west facing
9027                IF ( x > x2 ) RETURN
9028            CASE (ieast_u, ieast_l)                 !< east facing
9029                IF ( x < x2 ) RETURN
9030            CASE (-1)
9031                CONTINUE
9032        END SELECT
9033
9034        surface_facing = .TRUE.
9035       
9036    END FUNCTION surface_facing
9037
9038
9039!------------------------------------------------------------------------------!
9040!
9041! Description:
9042! ------------
9043!> Reads svf, svfsurf, csf, csfsurf and mrt factors data from saved file
9044!> SVF means sky view factors and CSF means canopy sink factors
9045!------------------------------------------------------------------------------!
9046    SUBROUTINE radiation_read_svf
9047
9048       IMPLICIT NONE
9049       
9050       CHARACTER(rad_version_len)   :: rad_version_field
9051       
9052       INTEGER(iwp)                 :: i
9053       INTEGER(iwp)                 :: ndsidir_from_file = 0
9054       INTEGER(iwp)                 :: npcbl_from_file = 0
9055       INTEGER(iwp)                 :: nsurfl_from_file = 0
9056       INTEGER(iwp)                 :: nmrtbl_from_file = 0
9057
9058
9059       CALL location_message( 'reading view factors for radiation interaction', 'start' )
9060
9061       DO  i = 0, io_blocks-1
9062          IF ( i == io_group )  THEN
9063
9064!
9065!--          numprocs_previous_run is only known in case of reading restart
9066!--          data. If a new initial run which reads svf data is started the
9067!--          following query will be skipped
9068             IF ( initializing_actions == 'read_restart_data' ) THEN
9069
9070                IF ( numprocs_previous_run /= numprocs ) THEN
9071                   WRITE( message_string, * ) 'A different number of ',        &
9072                                              'processors between the run ',   &
9073                                              'that has written the svf data ',&
9074                                              'and the one that will read it ',&
9075                                              'is not allowed' 
9076                   CALL message( 'check_open', 'PA0491', 1, 2, 0, 6, 0 )
9077                ENDIF
9078
9079             ENDIF
9080             
9081!
9082!--          Open binary file
9083             CALL check_open( 88 )
9084
9085!
9086!--          read and check version
9087             READ ( 88 ) rad_version_field
9088             IF ( TRIM(rad_version_field) /= TRIM(rad_version) )  THEN
9089                 WRITE( message_string, * ) 'Version of binary SVF file "',    &
9090                             TRIM(rad_version_field), '" does not match ',     &
9091                             'the version of model "', TRIM(rad_version), '"'
9092                 CALL message( 'radiation_read_svf', 'PA0482', 1, 2, 0, 6, 0 )
9093             ENDIF
9094             
9095!
9096!--          read nsvfl, ncsfl, nsurfl, nmrtf
9097             READ ( 88 ) nsvfl, ncsfl, nsurfl_from_file, npcbl_from_file,      &
9098                         ndsidir_from_file, nmrtbl_from_file, nmrtf
9099             
9100             IF ( nsvfl < 0  .OR.  ncsfl < 0 )  THEN
9101                 WRITE( message_string, * ) 'Wrong number of SVF or CSF'
9102                 CALL message( 'radiation_read_svf', 'PA0483', 1, 2, 0, 6, 0 )
9103             ELSE
9104                 WRITE(debug_string,*)   'Number of SVF, CSF, and nsurfl ',    &
9105                                         'to read', nsvfl, ncsfl,              &
9106                                         nsurfl_from_file
9107                 IF ( debug_output )  CALL debug_message( debug_string, 'info' )
9108             ENDIF
9109             
9110             IF ( nsurfl_from_file /= nsurfl )  THEN
9111                 WRITE( message_string, * ) 'nsurfl from SVF file does not ',  &
9112                                            'match calculated nsurfl from ',   &
9113                                            'radiation_interaction_init'
9114                 CALL message( 'radiation_read_svf', 'PA0490', 1, 2, 0, 6, 0 )
9115             ENDIF
9116             
9117             IF ( npcbl_from_file /= npcbl )  THEN
9118                 WRITE( message_string, * ) 'npcbl from SVF file does not ',   &
9119                                            'match calculated npcbl from ',    &
9120                                            'radiation_interaction_init'
9121                 CALL message( 'radiation_read_svf', 'PA0493', 1, 2, 0, 6, 0 )
9122             ENDIF
9123             
9124             IF ( ndsidir_from_file /= ndsidir )  THEN
9125                 WRITE( message_string, * ) 'ndsidir from SVF file does not ', &
9126                                            'match calculated ndsidir from ',  &
9127                                            'radiation_presimulate_solar_pos'
9128                 CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 )
9129             ENDIF
9130             IF ( nmrtbl_from_file /= nmrtbl )  THEN
9131                 WRITE( message_string, * ) 'nmrtbl from SVF file does not ',  &
9132                                            'match calculated nmrtbl from ',   &
9133                                            'radiation_interaction_init'
9134                 CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 )
9135             ELSE
9136                 WRITE(debug_string,*) 'Number of nmrtf to read ', nmrtf
9137                 IF ( debug_output )  CALL debug_message( debug_string, 'info' )
9138             ENDIF
9139             
9140!
9141!--          Arrays skyvf, skyvft, dsitrans and dsitransc are allready
9142!--          allocated in radiation_interaction_init and
9143!--          radiation_presimulate_solar_pos
9144             IF ( nsurfl > 0 )  THEN
9145                READ(88) skyvf
9146                READ(88) skyvft
9147                READ(88) dsitrans 
9148             ENDIF
9149             
9150             IF ( plant_canopy  .AND.  npcbl > 0 ) THEN
9151                READ ( 88 )  dsitransc
9152             ENDIF
9153             
9154!
9155!--          The allocation of svf, svfsurf, csf, csfsurf, mrtf, mrtft, and
9156!--          mrtfsurf happens in routine radiation_calc_svf which is not
9157!--          called if the program enters radiation_read_svf. Therefore
9158!--          these arrays has to allocate in the following
9159             IF ( nsvfl > 0 )  THEN
9160                ALLOCATE( svf(ndsvf,nsvfl) )
9161                ALLOCATE( svfsurf(idsvf,nsvfl) )
9162                READ(88) svf
9163                READ(88) svfsurf
9164             ENDIF
9165
9166             IF ( plant_canopy  .AND.  ncsfl > 0 )  THEN
9167                ALLOCATE( csf(ndcsf,ncsfl) )
9168                ALLOCATE( csfsurf(idcsf,ncsfl) )
9169                READ(88) csf
9170                READ(88) csfsurf
9171             ENDIF
9172
9173             IF ( nmrtbl > 0 )  THEN
9174                READ(88) mrtsky
9175                READ(88) mrtskyt
9176                READ(88) mrtdsit
9177             ENDIF
9178
9179             IF ( nmrtf > 0 )  THEN
9180                ALLOCATE ( mrtf(nmrtf) )
9181                ALLOCATE ( mrtft(nmrtf) )
9182                ALLOCATE ( mrtfsurf(2,nmrtf) )
9183                READ(88) mrtf
9184                READ(88) mrtft
9185                READ(88) mrtfsurf
9186             ENDIF
9187             
9188!
9189!--          Close binary file                 
9190             CALL close_file( 88 )
9191               
9192          ENDIF
9193#if defined( __parallel )
9194          CALL MPI_BARRIER( comm2d, ierr )
9195#endif
9196       ENDDO
9197
9198       CALL location_message( 'reading view factors for radiation interaction', 'finished' )
9199
9200
9201    END SUBROUTINE radiation_read_svf
9202
9203
9204!------------------------------------------------------------------------------!
9205!
9206! Description:
9207! ------------
9208!> Subroutine stores svf, svfsurf, csf, csfsurf and mrt data to a file.
9209!------------------------------------------------------------------------------!
9210    SUBROUTINE radiation_write_svf
9211
9212       IMPLICIT NONE
9213       
9214       INTEGER(iwp)        :: i
9215
9216
9217       CALL location_message( 'writing view factors for radiation interaction', 'start' )
9218
9219       DO  i = 0, io_blocks-1
9220          IF ( i == io_group )  THEN
9221!
9222!--          Open binary file
9223             CALL check_open( 89 )
9224
9225             WRITE ( 89 )  rad_version
9226             WRITE ( 89 )  nsvfl, ncsfl, nsurfl, npcbl, ndsidir, nmrtbl, nmrtf
9227             IF ( nsurfl > 0 ) THEN
9228                WRITE ( 89 )  skyvf
9229                WRITE ( 89 )  skyvft
9230                WRITE ( 89 )  dsitrans
9231             ENDIF
9232             IF ( npcbl > 0 ) THEN
9233                WRITE ( 89 )  dsitransc
9234             ENDIF
9235             IF ( nsvfl > 0 ) THEN
9236                WRITE ( 89 )  svf
9237                WRITE ( 89 )  svfsurf
9238             ENDIF
9239             IF ( plant_canopy  .AND.  ncsfl > 0 )  THEN
9240                 WRITE ( 89 )  csf
9241                 WRITE ( 89 )  csfsurf
9242             ENDIF
9243             IF ( nmrtbl > 0 )  THEN
9244                WRITE ( 89 ) mrtsky
9245                WRITE ( 89 ) mrtskyt
9246                WRITE ( 89 ) mrtdsit
9247             ENDIF
9248             IF ( nmrtf > 0 )  THEN
9249                 WRITE ( 89 )  mrtf
9250                 WRITE ( 89 )  mrtft               
9251                 WRITE ( 89 )  mrtfsurf
9252             ENDIF
9253!
9254!--          Close binary file                 
9255             CALL close_file( 89 )
9256
9257          ENDIF
9258#if defined( __parallel )
9259          CALL MPI_BARRIER( comm2d, ierr )
9260#endif
9261       ENDDO
9262
9263       CALL location_message( 'writing view factors for radiation interaction', 'finished' )
9264
9265
9266    END SUBROUTINE radiation_write_svf
9267
9268
9269!------------------------------------------------------------------------------!
9270!
9271! Description:
9272! ------------
9273!> Block of auxiliary subroutines:
9274!> 1. quicksort and corresponding comparison
9275!> 2. merge_and_grow_csf for implementation of "dynamical growing"
9276!>    array for csf
9277!------------------------------------------------------------------------------!
9278!-- quicksort.f -*-f90-*-
9279!-- Author: t-nissie, adaptation J.Resler
9280!-- License: GPLv3
9281!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9282    RECURSIVE SUBROUTINE quicksort_itarget(itarget, vffrac, ztransp, first, last)
9283        IMPLICIT NONE
9284        INTEGER(iwp), DIMENSION(:), INTENT(INOUT)   :: itarget
9285        REAL(wp), DIMENSION(:), INTENT(INOUT)       :: vffrac, ztransp
9286        INTEGER(iwp), INTENT(IN)                    :: first, last
9287        INTEGER(iwp)                                :: x, t
9288        INTEGER(iwp)                                :: i, j
9289        REAL(wp)                                    :: tr
9290
9291        IF ( first>=last ) RETURN
9292        x = itarget((first+last)/2)
9293        i = first
9294        j = last
9295        DO
9296            DO WHILE ( itarget(i) < x )
9297               i=i+1
9298            ENDDO
9299            DO WHILE ( x < itarget(j) )
9300                j=j-1
9301            ENDDO
9302            IF ( i >= j ) EXIT
9303            t = itarget(i);  itarget(i) = itarget(j);  itarget(j) = t
9304            tr = vffrac(i);  vffrac(i) = vffrac(j);  vffrac(j) = tr
9305            tr = ztransp(i);  ztransp(i) = ztransp(j);  ztransp(j) = tr
9306            i=i+1
9307            j=j-1
9308        ENDDO
9309        IF ( first < i-1 ) CALL quicksort_itarget(itarget, vffrac, ztransp, first, i-1)
9310        IF ( j+1 < last )  CALL quicksort_itarget(itarget, vffrac, ztransp, j+1, last)
9311    END SUBROUTINE quicksort_itarget
9312
9313    PURE FUNCTION svf_lt(svf1,svf2) result (res)
9314      TYPE (t_svf), INTENT(in) :: svf1,svf2
9315      LOGICAL                  :: res
9316      IF ( svf1%isurflt < svf2%isurflt  .OR.    &
9317          (svf1%isurflt == svf2%isurflt  .AND.  svf1%isurfs < svf2%isurfs) )  THEN
9318          res = .TRUE.
9319      ELSE
9320          res = .FALSE.
9321      ENDIF
9322    END FUNCTION svf_lt
9323
9324
9325!-- quicksort.f -*-f90-*-
9326!-- Author: t-nissie, adaptation J.Resler
9327!-- License: GPLv3
9328!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9329    RECURSIVE SUBROUTINE quicksort_svf(svfl, first, last)
9330        IMPLICIT NONE
9331        TYPE(t_svf), DIMENSION(:), INTENT(INOUT)  :: svfl
9332        INTEGER(iwp), INTENT(IN)                  :: first, last
9333        TYPE(t_svf)                               :: x, t
9334        INTEGER(iwp)                              :: i, j
9335
9336        IF ( first>=last ) RETURN
9337        x = svfl( (first+last) / 2 )
9338        i = first
9339        j = last
9340        DO
9341            DO while ( svf_lt(svfl(i),x) )
9342               i=i+1
9343            ENDDO
9344            DO while ( svf_lt(x,svfl(j)) )
9345                j=j-1
9346            ENDDO
9347            IF ( i >= j ) EXIT
9348            t = svfl(i);  svfl(i) = svfl(j);  svfl(j) = t
9349            i=i+1
9350            j=j-1
9351        ENDDO
9352        IF ( first < i-1 ) CALL quicksort_svf(svfl, first, i-1)
9353        IF ( j+1 < last )  CALL quicksort_svf(svfl, j+1, last)
9354    END SUBROUTINE quicksort_svf
9355
9356    PURE FUNCTION csf_lt(csf1,csf2) result (res)
9357      TYPE (t_csf), INTENT(in) :: csf1,csf2
9358      LOGICAL                  :: res
9359      IF ( csf1%ip < csf2%ip  .OR.    &
9360           (csf1%ip == csf2%ip  .AND.  csf1%itx < csf2%itx)  .OR.  &
9361           (csf1%ip == csf2%ip  .AND.  csf1%itx == csf2%itx  .AND.  csf1%ity < csf2%ity)  .OR.  &
9362           (csf1%ip == csf2%ip  .AND.  csf1%itx == csf2%itx  .AND.  csf1%ity == csf2%ity  .AND.   &
9363            csf1%itz < csf2%itz)  .OR.  &
9364           (csf1%ip == csf2%ip  .AND.  csf1%itx == csf2%itx  .AND.  csf1%ity == csf2%ity  .AND.   &
9365            csf1%itz == csf2%itz  .AND.  csf1%isurfs < csf2%isurfs) )  THEN
9366          res = .TRUE.
9367      ELSE
9368          res = .FALSE.
9369      ENDIF
9370    END FUNCTION csf_lt
9371
9372
9373!-- quicksort.f -*-f90-*-
9374!-- Author: t-nissie, adaptation J.Resler
9375!-- License: GPLv3
9376!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9377    RECURSIVE SUBROUTINE quicksort_csf(csfl, first, last)
9378        IMPLICIT NONE
9379        TYPE(t_csf), DIMENSION(:), INTENT(INOUT)  :: csfl
9380        INTEGER(iwp), INTENT(IN)                  :: first, last
9381        TYPE(t_csf)                               :: x, t
9382        INTEGER(iwp)                              :: i, j
9383
9384        IF ( first>=last ) RETURN
9385        x = csfl( (first+last)/2 )
9386        i = first
9387        j = last
9388        DO
9389            DO while ( csf_lt(csfl(i),x) )
9390                i=i+1
9391            ENDDO
9392            DO while ( csf_lt(x,csfl(j)) )
9393                j=j-1
9394            ENDDO
9395            IF ( i >= j ) EXIT
9396            t = csfl(i);  csfl(i) = csfl(j);  csfl(j) = t
9397            i=i+1
9398            j=j-1
9399        ENDDO
9400        IF ( first < i-1 ) CALL quicksort_csf(csfl, first, i-1)
9401        IF ( j+1 < last )  CALL quicksort_csf(csfl, j+1, last)
9402    END SUBROUTINE quicksort_csf
9403
9404   
9405!------------------------------------------------------------------------------!
9406!
9407! Description:
9408! ------------
9409!> Grows the CSF array exponentially after it is full. During that, the ray
9410!> canopy sink factors with common source face and target plant canopy grid
9411!> cell are merged together so that the size doesn't grow out of control.
9412!------------------------------------------------------------------------------!
9413    SUBROUTINE merge_and_grow_csf(newsize)
9414        INTEGER(iwp), INTENT(in)                :: newsize  !< new array size after grow, must be >= ncsfl
9415                                                            !< or -1 to shrink to minimum
9416        INTEGER(iwp)                            :: iread, iwrite
9417        TYPE(t_csf), DIMENSION(:), POINTER      :: acsfnew
9418
9419
9420        IF ( newsize == -1 )  THEN
9421!--         merge in-place
9422            acsfnew => acsf
9423        ELSE
9424!--         allocate new array
9425            IF ( mcsf == 0 )  THEN
9426                ALLOCATE( acsf1(newsize) )
9427                acsfnew => acsf1
9428            ELSE
9429                ALLOCATE( acsf2(newsize) )
9430                acsfnew => acsf2
9431            ENDIF
9432        ENDIF
9433
9434        IF ( ncsfl >= 1 )  THEN
9435!--         sort csf in place (quicksort)
9436            CALL quicksort_csf(acsf,1,ncsfl)
9437
9438!--         while moving to a new array, aggregate canopy sink factor records with identical box & source
9439            acsfnew(1) = acsf(1)
9440            iwrite = 1
9441            DO iread = 2, ncsfl
9442!--             here acsf(kcsf) already has values from acsf(icsf)
9443                IF ( acsfnew(iwrite)%itx == acsf(iread)%itx &
9444                         .AND.  acsfnew(iwrite)%ity == acsf(iread)%ity &
9445                         .AND.  acsfnew(iwrite)%itz == acsf(iread)%itz &
9446                         .AND.  acsfnew(iwrite)%isurfs == acsf(iread)%isurfs )  THEN
9447
9448                    acsfnew(iwrite)%rcvf = acsfnew(iwrite)%rcvf + acsf(iread)%rcvf
9449!--                 advance reading index, keep writing index
9450                ELSE
9451!--                 not identical, just advance and copy
9452                    iwrite = iwrite + 1
9453                    acsfnew(iwrite) = acsf(iread)
9454                ENDIF
9455            ENDDO
9456            ncsfl = iwrite
9457        ENDIF
9458
9459        IF ( newsize == -1 )  THEN
9460!--         allocate new array and copy shrinked data
9461            IF ( mcsf == 0 )  THEN
9462                ALLOCATE( acsf1(ncsfl) )
9463                acsf1(1:ncsfl) = acsf2(1:ncsfl)
9464            ELSE
9465                ALLOCATE( acsf2(ncsfl) )
9466                acsf2(1:ncsfl) = acsf1(1:ncsfl)
9467            ENDIF
9468        ENDIF
9469
9470!--     deallocate old array
9471        IF ( mcsf == 0 )  THEN
9472            mcsf = 1
9473            acsf => acsf1
9474            DEALLOCATE( acsf2 )
9475        ELSE
9476            mcsf = 0
9477            acsf => acsf2
9478            DEALLOCATE( acsf1 )
9479        ENDIF
9480        ncsfla = newsize
9481
9482        IF ( debug_output )  THEN
9483           WRITE( debug_string, '(A,2I12)' ) 'Grow acsf2:', ncsfl, ncsfla
9484           CALL debug_message( debug_string, 'info' )
9485        ENDIF
9486
9487    END SUBROUTINE merge_and_grow_csf
9488
9489   
9490!-- quicksort.f -*-f90-*-
9491!-- Author: t-nissie, adaptation J.Resler
9492!-- License: GPLv3
9493!-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea
9494    RECURSIVE SUBROUTINE quicksort_csf2(kpcsflt, pcsflt, first, last)
9495        IMPLICIT NONE
9496        INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT)  :: kpcsflt
9497        REAL(wp), DIMENSION(:,:), INTENT(INOUT)      :: pcsflt
9498        INTEGER(iwp), INTENT(IN)                     :: first, last
9499        REAL(wp), DIMENSION(ndcsf)                   :: t2
9500        INTEGER(iwp), DIMENSION(kdcsf)               :: x, t1
9501        INTEGER(iwp)                                 :: i, j
9502
9503        IF ( first>=last ) RETURN
9504        x = kpcsflt(:, (first+last)/2 )
9505        i = first
9506        j = last
9507        DO
9508            DO while ( csf_lt2(kpcsflt(:,i),x) )
9509                i=i+1
9510            ENDDO
9511            DO while ( csf_lt2(x,kpcsflt(:,j)) )
9512                j=j-1
9513            ENDDO
9514            IF ( i >= j ) EXIT
9515            t1 = kpcsflt(:,i);  kpcsflt(:,i) = kpcsflt(:,j);  kpcsflt(:,j) = t1
9516            t2 = pcsflt(:,i);  pcsflt(:,i) = pcsflt(:,j);  pcsflt(:,j) = t2
9517            i=i+1
9518            j=j-1
9519        ENDDO
9520        IF ( first < i-1 ) CALL quicksort_csf2(kpcsflt, pcsflt, first, i-1)
9521        IF ( j+1 < last )  CALL quicksort_csf2(kpcsflt, pcsflt, j+1, last)
9522    END SUBROUTINE quicksort_csf2
9523   
9524
9525    PURE FUNCTION csf_lt2(item1, item2) result(res)
9526        INTEGER(iwp), DIMENSION(kdcsf), INTENT(in)  :: item1, item2
9527        LOGICAL                                     :: res
9528        res = ( (item1(3) < item2(3))                                                        &
9529             .OR.  (item1(3) == item2(3)  .AND.  item1(2) < item2(2))                            &
9530             .OR.  (item1(3) == item2(3)  .AND.  item1(2) == item2(2)  .AND.  item1(1) < item2(1)) &
9531             .OR.  (item1(3) == item2(3)  .AND.  item1(2) == item2(2)  .AND.  item1(1) == item2(1) &
9532                 .AND.  item1(4) < item2(4)) )
9533    END FUNCTION csf_lt2
9534
9535    PURE FUNCTION searchsorted(athresh, val) result(ind)
9536        REAL(wp), DIMENSION(:), INTENT(IN)  :: athresh
9537        REAL(wp), INTENT(IN)                :: val
9538        INTEGER(iwp)                        :: ind
9539        INTEGER(iwp)                        :: i
9540
9541        DO i = LBOUND(athresh, 1), UBOUND(athresh, 1)
9542            IF ( val < athresh(i) ) THEN
9543                ind = i - 1
9544                RETURN
9545            ENDIF
9546        ENDDO
9547        ind = UBOUND(athresh, 1)
9548    END FUNCTION searchsorted
9549
9550
9551!------------------------------------------------------------------------------!
9552!
9553! Description:
9554! ------------
9555!> Subroutine for averaging 3D data
9556!------------------------------------------------------------------------------!
9557SUBROUTINE radiation_3d_data_averaging( mode, variable )
9558 
9559
9560    USE control_parameters
9561
9562    USE indices
9563
9564    USE kinds
9565
9566    IMPLICIT NONE
9567
9568    CHARACTER (LEN=*) ::  mode    !<
9569    CHARACTER (LEN=*) :: variable !<
9570
9571    LOGICAL      ::  match_lsm !< flag indicating natural-type surface
9572    LOGICAL      ::  match_usm !< flag indicating urban-type surface
9573   
9574    INTEGER(iwp) ::  i !<
9575    INTEGER(iwp) ::  j !<
9576    INTEGER(iwp) ::  k !<
9577    INTEGER(iwp) ::  l, m !< index of current surface element
9578
9579    INTEGER(iwp)                                       :: ids, idsint_u, idsint_l, isurf
9580    CHARACTER(LEN=varnamelength)                       :: var
9581
9582!-- find the real name of the variable
9583    ids = -1
9584    l = -1
9585    var = TRIM(variable)
9586    DO i = 0, nd-1
9587        k = len(TRIM(var))
9588        j = len(TRIM(dirname(i)))
9589        IF ( k-j+1 >= 1_iwp ) THEN
9590           IF ( TRIM(var(k-j+1:k)) == TRIM(dirname(i)) )  THEN
9591               ids = i
9592               idsint_u = dirint_u(ids)
9593               idsint_l = dirint_l(ids)
9594               var = var(:k-j)
9595               EXIT
9596           ENDIF
9597        ENDIF
9598    ENDDO
9599    IF ( ids == -1 )  THEN
9600        var = TRIM(variable)
9601    ENDIF
9602
9603    IF ( mode == 'allocate' )  THEN
9604
9605       SELECT CASE ( TRIM( var ) )
9606!--          block of large scale (e.g. RRTMG) radiation output variables
9607             CASE ( 'rad_net*' )
9608                IF ( .NOT. ALLOCATED( rad_net_av ) )  THEN
9609                   ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
9610                ENDIF
9611                rad_net_av = 0.0_wp
9612             
9613             CASE ( 'rad_lw_in*' )
9614                IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) )  THEN
9615                   ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
9616                ENDIF
9617                rad_lw_in_xy_av = 0.0_wp
9618               
9619             CASE ( 'rad_lw_out*' )
9620                IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) )  THEN
9621                   ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
9622                ENDIF
9623                rad_lw_out_xy_av = 0.0_wp
9624               
9625             CASE ( 'rad_sw_in*' )
9626                IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) )  THEN
9627                   ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
9628                ENDIF
9629                rad_sw_in_xy_av = 0.0_wp
9630               
9631             CASE ( 'rad_sw_out*' )
9632                IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) )  THEN
9633                   ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
9634                ENDIF
9635                rad_sw_out_xy_av = 0.0_wp               
9636
9637             CASE ( 'rad_lw_in' )
9638                IF ( .NOT. ALLOCATED( rad_lw_in_av ) )  THEN
9639                   ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9640                ENDIF
9641                rad_lw_in_av = 0.0_wp
9642
9643             CASE ( 'rad_lw_out' )
9644                IF ( .NOT. ALLOCATED( rad_lw_out_av ) )  THEN
9645                   ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9646                ENDIF
9647                rad_lw_out_av = 0.0_wp
9648
9649             CASE ( 'rad_lw_cs_hr' )
9650                IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) )  THEN
9651                   ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9652                ENDIF
9653                rad_lw_cs_hr_av = 0.0_wp
9654
9655             CASE ( 'rad_lw_hr' )
9656                IF ( .NOT. ALLOCATED( rad_lw_hr_av ) )  THEN
9657                   ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9658                ENDIF
9659                rad_lw_hr_av = 0.0_wp
9660
9661             CASE ( 'rad_sw_in' )
9662                IF ( .NOT. ALLOCATED( rad_sw_in_av ) )  THEN
9663                   ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9664                ENDIF
9665                rad_sw_in_av = 0.0_wp
9666
9667             CASE ( 'rad_sw_out' )
9668                IF ( .NOT. ALLOCATED( rad_sw_out_av ) )  THEN
9669                   ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
9670                ENDIF
9671                rad_sw_out_av = 0.0_wp
9672
9673             CASE ( 'rad_sw_cs_hr' )
9674                IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) )  THEN
9675                   ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9676                ENDIF
9677                rad_sw_cs_hr_av = 0.0_wp
9678
9679             CASE ( 'rad_sw_hr' )
9680                IF ( .NOT. ALLOCATED( rad_sw_hr_av ) )  THEN
9681                   ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
9682                ENDIF
9683                rad_sw_hr_av = 0.0_wp
9684
9685!--          block of RTM output variables
9686             CASE ( 'rtm_rad_net' )
9687!--              array of complete radiation balance
9688                 IF ( .NOT.  ALLOCATED(surfradnet_av) )  THEN
9689                     ALLOCATE( surfradnet_av(nsurfl) )
9690                     surfradnet_av = 0.0_wp
9691                 ENDIF
9692
9693             CASE ( 'rtm_rad_insw' )
9694!--                 array of sw radiation falling to surface after i-th reflection
9695                 IF ( .NOT.  ALLOCATED(surfinsw_av) )  THEN
9696                     ALLOCATE( surfinsw_av(nsurfl) )
9697                     surfinsw_av = 0.0_wp
9698                 ENDIF
9699
9700             CASE ( 'rtm_rad_inlw' )
9701!--                 array of lw radiation falling to surface after i-th reflection
9702                 IF ( .NOT.  ALLOCATED(surfinlw_av) )  THEN
9703                     ALLOCATE( surfinlw_av(nsurfl) )
9704                     surfinlw_av = 0.0_wp
9705                 ENDIF
9706
9707             CASE ( 'rtm_rad_inswdir' )
9708!--                 array of direct sw radiation falling to surface from sun
9709                 IF ( .NOT.  ALLOCATED(surfinswdir_av) )  THEN
9710                     ALLOCATE( surfinswdir_av(nsurfl) )
9711                     surfinswdir_av = 0.0_wp
9712                 ENDIF
9713
9714             CASE ( 'rtm_rad_inswdif' )
9715!--                 array of difusion sw radiation falling to surface from sky and borders of the domain
9716                 IF ( .NOT.  ALLOCATED(surfinswdif_av) )  THEN
9717                     ALLOCATE( surfinswdif_av(nsurfl) )
9718                     surfinswdif_av = 0.0_wp
9719                 ENDIF
9720
9721             CASE ( 'rtm_rad_inswref' )
9722!--                 array of sw radiation falling to surface from reflections
9723                 IF ( .NOT.  ALLOCATED(surfinswref_av) )  THEN
9724                     ALLOCATE( surfinswref_av(nsurfl) )
9725                     surfinswref_av = 0.0_wp
9726                 ENDIF
9727
9728             CASE ( 'rtm_rad_inlwdif' )
9729!--                 array of sw radiation falling to surface after i-th reflection
9730                IF ( .NOT.  ALLOCATED(surfinlwdif_av) )  THEN
9731                     ALLOCATE( surfinlwdif_av(nsurfl) )
9732                     surfinlwdif_av = 0.0_wp
9733                 ENDIF
9734
9735             CASE ( 'rtm_rad_inlwref' )
9736!--                 array of lw radiation falling to surface from reflections
9737                 IF ( .NOT.  ALLOCATED(surfinlwref_av) )  THEN
9738                     ALLOCATE( surfinlwref_av(nsurfl) )
9739                     surfinlwref_av = 0.0_wp
9740                 ENDIF
9741
9742             CASE ( 'rtm_rad_outsw' )
9743!--                 array of sw radiation emitted from surface after i-th reflection
9744                 IF ( .NOT.  ALLOCATED(surfoutsw_av) )  THEN
9745                     ALLOCATE( surfoutsw_av(nsurfl) )
9746                     surfoutsw_av = 0.0_wp
9747                 ENDIF
9748
9749             CASE ( 'rtm_rad_outlw' )
9750!--                 array of lw radiation emitted from surface after i-th reflection
9751                 IF ( .NOT.  ALLOCATED(surfoutlw_av) )  THEN
9752                     ALLOCATE( surfoutlw_av(nsurfl) )
9753                     surfoutlw_av = 0.0_wp
9754                 ENDIF
9755             CASE ( 'rtm_rad_ressw' )
9756!--                 array of residua of sw radiation absorbed in surface after last reflection
9757                 IF ( .NOT.  ALLOCATED(surfins_av) )  THEN
9758                     ALLOCATE( surfins_av(nsurfl) )
9759                     surfins_av = 0.0_wp
9760                 ENDIF
9761
9762             CASE ( 'rtm_rad_reslw' )
9763!--                 array of residua of lw radiation absorbed in surface after last reflection
9764                 IF ( .NOT.  ALLOCATED(surfinl_av) )  THEN
9765                     ALLOCATE( surfinl_av(nsurfl) )
9766                     surfinl_av = 0.0_wp
9767                 ENDIF
9768
9769             CASE ( 'rtm_rad_pc_inlw' )
9770!--                 array of of lw radiation absorbed in plant canopy
9771                 IF ( .NOT.  ALLOCATED(pcbinlw_av) )  THEN
9772                     ALLOCATE( pcbinlw_av(1:npcbl) )
9773                     pcbinlw_av = 0.0_wp
9774                 ENDIF
9775
9776             CASE ( 'rtm_rad_pc_insw' )
9777!--                 array of of sw radiation absorbed in plant canopy
9778                 IF ( .NOT.  ALLOCATED(pcbinsw_av) )  THEN
9779                     ALLOCATE( pcbinsw_av(1:npcbl) )
9780                     pcbinsw_av = 0.0_wp
9781                 ENDIF
9782
9783             CASE ( 'rtm_rad_pc_inswdir' )
9784!--                 array of of direct sw radiation absorbed in plant canopy
9785                 IF ( .NOT.  ALLOCATED(pcbinswdir_av) )  THEN
9786                     ALLOCATE( pcbinswdir_av(1:npcbl) )
9787                     pcbinswdir_av = 0.0_wp
9788                 ENDIF
9789
9790             CASE ( 'rtm_rad_pc_inswdif' )
9791!--                 array of of diffuse sw radiation absorbed in plant canopy
9792                 IF ( .NOT.  ALLOCATED(pcbinswdif_av) )  THEN
9793                     ALLOCATE( pcbinswdif_av(1:npcbl) )
9794                     pcbinswdif_av = 0.0_wp
9795                 ENDIF
9796
9797             CASE ( 'rtm_rad_pc_inswref' )
9798!--                 array of of reflected sw radiation absorbed in plant canopy
9799                 IF ( .NOT.  ALLOCATED(pcbinswref_av) )  THEN
9800                     ALLOCATE( pcbinswref_av(1:npcbl) )
9801                     pcbinswref_av = 0.0_wp
9802                 ENDIF
9803
9804             CASE ( 'rtm_mrt_sw' )
9805                IF ( .NOT. ALLOCATED( mrtinsw_av ) )  THEN
9806                   ALLOCATE( mrtinsw_av(nmrtbl) )
9807                ENDIF
9808                mrtinsw_av = 0.0_wp
9809
9810             CASE ( 'rtm_mrt_lw' )
9811                IF ( .NOT. ALLOCATED( mrtinlw_av ) )  THEN
9812                   ALLOCATE( mrtinlw_av(nmrtbl) )
9813                ENDIF
9814                mrtinlw_av = 0.0_wp
9815
9816             CASE ( 'rtm_mrt' )
9817                IF ( .NOT. ALLOCATED( mrt_av ) )  THEN
9818                   ALLOCATE( mrt_av(nmrtbl) )
9819                ENDIF
9820                mrt_av = 0.0_wp
9821
9822          CASE DEFAULT
9823             CONTINUE
9824
9825       END SELECT
9826
9827    ELSEIF ( mode == 'sum' )  THEN
9828
9829       SELECT CASE ( TRIM( var ) )
9830!--       block of large scale (e.g. RRTMG) radiation output variables
9831          CASE ( 'rad_net*' )
9832             IF ( ALLOCATED( rad_net_av ) ) THEN
9833                DO  i = nxl, nxr
9834                   DO  j = nys, nyn
9835                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
9836                                  surf_lsm_h%end_index(j,i)
9837                      match_usm = surf_usm_h%start_index(j,i) <=               &
9838                                  surf_usm_h%end_index(j,i)
9839
9840                     IF ( match_lsm  .AND.  .NOT. match_usm )  THEN
9841                         m = surf_lsm_h%end_index(j,i)
9842                         rad_net_av(j,i) = rad_net_av(j,i) +                   &
9843                                         surf_lsm_h%rad_net(m)
9844                      ELSEIF ( match_usm )  THEN
9845                         m = surf_usm_h%end_index(j,i)
9846                         rad_net_av(j,i) = rad_net_av(j,i) +                   &
9847                                         surf_usm_h%rad_net(m)
9848                      ENDIF
9849                   ENDDO
9850                ENDDO
9851             ENDIF
9852
9853          CASE ( 'rad_lw_in*' )
9854             IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
9855                DO  i = nxl, nxr
9856                   DO  j = nys, nyn
9857                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
9858                                  surf_lsm_h%end_index(j,i)
9859                      match_usm = surf_usm_h%start_index(j,i) <=               &
9860                                  surf_usm_h%end_index(j,i)
9861
9862                      IF ( match_lsm  .AND.  .NOT. match_usm )  THEN
9863                         m = surf_lsm_h%end_index(j,i)
9864                         rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) +         &
9865                                         surf_lsm_h%rad_lw_in(m)
9866                      ELSEIF ( match_usm )  THEN
9867                         m = surf_usm_h%end_index(j,i)
9868                         rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) +         &
9869                                         surf_usm_h%rad_lw_in(m)
9870                      ENDIF
9871                   ENDDO
9872                ENDDO
9873             ENDIF
9874             
9875          CASE ( 'rad_lw_out*' )
9876             IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
9877                DO  i = nxl, nxr
9878                   DO  j = nys, nyn
9879                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
9880                                  surf_lsm_h%end_index(j,i)
9881                      match_usm = surf_usm_h%start_index(j,i) <=               &
9882                                  surf_usm_h%end_index(j,i)
9883
9884                      IF ( match_lsm  .AND.  .NOT. match_usm )  THEN
9885                         m = surf_lsm_h%end_index(j,i)
9886                         rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) +       &
9887                                                 surf_lsm_h%rad_lw_out(m)
9888                      ELSEIF ( match_usm )  THEN
9889                         m = surf_usm_h%end_index(j,i)
9890                         rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) +       &
9891                                                 surf_usm_h%rad_lw_out(m)
9892                      ENDIF
9893                   ENDDO
9894                ENDDO
9895             ENDIF
9896             
9897          CASE ( 'rad_sw_in*' )
9898             IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
9899                DO  i = nxl, nxr
9900                   DO  j = nys, nyn
9901                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
9902                                  surf_lsm_h%end_index(j,i)
9903                      match_usm = surf_usm_h%start_index(j,i) <=               &
9904                                  surf_usm_h%end_index(j,i)
9905
9906                      IF ( match_lsm  .AND.  .NOT. match_usm )  THEN
9907                         m = surf_lsm_h%end_index(j,i)
9908                         rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) +         &
9909                                                surf_lsm_h%rad_sw_in(m)
9910                      ELSEIF ( match_usm )  THEN
9911                         m = surf_usm_h%end_index(j,i)
9912                         rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) +         &
9913                                                surf_usm_h%rad_sw_in(m)
9914                      ENDIF
9915                   ENDDO
9916                ENDDO
9917             ENDIF
9918             
9919          CASE ( 'rad_sw_out*' )
9920             IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
9921                DO  i = nxl, nxr
9922                   DO  j = nys, nyn
9923                      match_lsm = surf_lsm_h%start_index(j,i) <=               &
9924                                  surf_lsm_h%end_index(j,i)
9925                      match_usm = surf_usm_h%start_index(j,i) <=               &
9926                                  surf_usm_h%end_index(j,i)
9927
9928                      IF ( match_lsm  .AND.  .NOT. match_usm )  THEN
9929                         m = surf_lsm_h%end_index(j,i)
9930                         rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) +       &
9931                                                 surf_lsm_h%rad_sw_out(m)
9932                      ELSEIF ( match_usm )  THEN
9933                         m = surf_usm_h%end_index(j,i)
9934                         rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) +       &
9935                                                 surf_usm_h%rad_sw_out(m)
9936                      ENDIF
9937                   ENDDO
9938                ENDDO
9939             ENDIF
9940             
9941          CASE ( 'rad_lw_in' )
9942             IF ( ALLOCATED( rad_lw_in_av ) ) THEN
9943                DO  i = nxlg, nxrg
9944                   DO  j = nysg, nyng
9945                      DO  k = nzb, nzt+1
9946                         rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i)             &
9947                                               + rad_lw_in(k,j,i)
9948                      ENDDO
9949                   ENDDO
9950                ENDDO
9951             ENDIF
9952
9953          CASE ( 'rad_lw_out' )
9954             IF ( ALLOCATED( rad_lw_out_av ) ) THEN
9955                DO  i = nxlg, nxrg
9956                   DO  j = nysg, nyng
9957                      DO  k = nzb, nzt+1
9958                         rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i)           &
9959                                                + rad_lw_out(k,j,i)
9960                      ENDDO
9961                   ENDDO
9962                ENDDO
9963             ENDIF
9964
9965          CASE ( 'rad_lw_cs_hr' )
9966             IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN
9967                DO  i = nxlg, nxrg
9968                   DO  j = nysg, nyng
9969                      DO  k = nzb, nzt+1
9970                         rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i)       &
9971                                                  + rad_lw_cs_hr(k,j,i)
9972                      ENDDO
9973                   ENDDO
9974                ENDDO
9975             ENDIF
9976
9977          CASE ( 'rad_lw_hr' )
9978             IF ( ALLOCATED( rad_lw_hr_av ) ) THEN
9979                DO  i = nxlg, nxrg
9980                   DO  j = nysg, nyng
9981                      DO  k = nzb, nzt+1
9982                         rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i)             &
9983                                               + rad_lw_hr(k,j,i)
9984                      ENDDO
9985                   ENDDO
9986                ENDDO
9987             ENDIF
9988
9989          CASE ( 'rad_sw_in' )
9990             IF ( ALLOCATED( rad_sw_in_av ) ) THEN
9991                DO  i = nxlg, nxrg
9992                   DO  j = nysg, nyng
9993                      DO  k = nzb, nzt+1
9994                         rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i)             &
9995                                               + rad_sw_in(k,j,i)
9996                      ENDDO
9997                   ENDDO
9998                ENDDO
9999             ENDIF
10000
10001          CASE ( 'rad_sw_out' )
10002             IF ( ALLOCATED( rad_sw_out_av ) ) THEN
10003                DO  i = nxlg, nxrg
10004                   DO  j = nysg, nyng
10005                      DO  k = nzb, nzt+1
10006                         rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i)           &
10007                                                + rad_sw_out(k,j,i)
10008                      ENDDO
10009                   ENDDO
10010                ENDDO
10011             ENDIF
10012
10013          CASE ( 'rad_sw_cs_hr' )
10014             IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN
10015                DO  i = nxlg, nxrg
10016                   DO  j = nysg, nyng
10017                      DO  k = nzb, nzt+1
10018                         rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i)       &
10019                                                  + rad_sw_cs_hr(k,j,i)
10020                      ENDDO
10021                   ENDDO
10022                ENDDO
10023             ENDIF
10024
10025          CASE ( 'rad_sw_hr' )
10026             IF ( ALLOCATED( rad_sw_hr_av ) ) THEN
10027                DO  i = nxlg, nxrg
10028                   DO  j = nysg, nyng
10029                      DO  k = nzb, nzt+1
10030                         rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i)             &
10031                                               + rad_sw_hr(k,j,i)
10032                      ENDDO
10033                   ENDDO
10034                ENDDO
10035             ENDIF
10036
10037!--       block of RTM output variables
10038          CASE ( 'rtm_rad_net' )
10039!--           array of complete radiation balance
10040              DO isurf = dirstart(ids), dirend(ids)
10041                 IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10042                    surfradnet_av(isurf) = surfinsw(isurf) - surfoutsw(isurf) +  surfinlw(isurf) - surfoutlw(isurf)
10043                 ENDIF
10044              ENDDO
10045
10046          CASE ( 'rtm_rad_insw' )
10047!--           array of sw radiation falling to surface after i-th reflection
10048              DO isurf = dirstart(ids), dirend(ids)
10049                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10050                      surfinsw_av(isurf) = surfinsw_av(isurf) + surfinsw(isurf)
10051                  ENDIF
10052              ENDDO
10053
10054          CASE ( 'rtm_rad_inlw' )
10055!--           array of lw radiation falling to surface after i-th reflection
10056              DO isurf = dirstart(ids), dirend(ids)
10057                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10058                      surfinlw_av(isurf) = surfinlw_av(isurf) + surfinlw(isurf)
10059                  ENDIF
10060              ENDDO
10061
10062          CASE ( 'rtm_rad_inswdir' )
10063!--           array of direct sw radiation falling to surface from sun
10064              DO isurf = dirstart(ids), dirend(ids)
10065                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10066                      surfinswdir_av(isurf) = surfinswdir_av(isurf) + surfinswdir(isurf)
10067                  ENDIF
10068              ENDDO
10069
10070          CASE ( 'rtm_rad_inswdif' )
10071!--           array of difusion sw radiation falling to surface from sky and borders of the domain
10072              DO isurf = dirstart(ids), dirend(ids)
10073                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10074                      surfinswdif_av(isurf) = surfinswdif_av(isurf) + surfinswdif(isurf)
10075                  ENDIF
10076              ENDDO
10077
10078          CASE ( 'rtm_rad_inswref' )
10079!--           array of sw radiation falling to surface from reflections
10080              DO isurf = dirstart(ids), dirend(ids)
10081                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10082                      surfinswref_av(isurf) = surfinswref_av(isurf) + surfinsw(isurf) - &
10083                                          surfinswdir(isurf) - surfinswdif(isurf)
10084                  ENDIF
10085              ENDDO
10086
10087
10088          CASE ( 'rtm_rad_inlwdif' )
10089!--           array of sw radiation falling to surface after i-th reflection
10090              DO isurf = dirstart(ids), dirend(ids)
10091                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10092                      surfinlwdif_av(isurf) = surfinlwdif_av(isurf) + surfinlwdif(isurf)
10093                  ENDIF
10094              ENDDO
10095!
10096          CASE ( 'rtm_rad_inlwref' )
10097!--           array of lw radiation falling to surface from reflections
10098              DO isurf = dirstart(ids), dirend(ids)
10099                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10100                      surfinlwref_av(isurf) = surfinlwref_av(isurf) + &
10101                                          surfinlw(isurf) - surfinlwdif(isurf)
10102                  ENDIF
10103              ENDDO
10104
10105          CASE ( 'rtm_rad_outsw' )
10106!--           array of sw radiation emitted from surface after i-th reflection
10107              DO isurf = dirstart(ids), dirend(ids)
10108                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10109                      surfoutsw_av(isurf) = surfoutsw_av(isurf) + surfoutsw(isurf)
10110                  ENDIF
10111              ENDDO
10112
10113          CASE ( 'rtm_rad_outlw' )
10114!--           array of lw radiation emitted from surface after i-th reflection
10115              DO isurf = dirstart(ids), dirend(ids)
10116                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10117                      surfoutlw_av(isurf) = surfoutlw_av(isurf) + surfoutlw(isurf)
10118                  ENDIF
10119              ENDDO
10120
10121          CASE ( 'rtm_rad_ressw' )
10122!--           array of residua of sw radiation absorbed in surface after last reflection
10123              DO isurf = dirstart(ids), dirend(ids)
10124                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10125                      surfins_av(isurf) = surfins_av(isurf) + surfins(isurf)
10126                  ENDIF
10127              ENDDO
10128
10129          CASE ( 'rtm_rad_reslw' )
10130!--           array of residua of lw radiation absorbed in surface after last reflection
10131              DO isurf = dirstart(ids), dirend(ids)
10132                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10133                      surfinl_av(isurf) = surfinl_av(isurf) + surfinl(isurf)
10134                  ENDIF
10135              ENDDO
10136
10137          CASE ( 'rtm_rad_pc_inlw' )
10138              DO l = 1, npcbl
10139                 pcbinlw_av(l) = pcbinlw_av(l) + pcbinlw(l)
10140              ENDDO
10141
10142          CASE ( 'rtm_rad_pc_insw' )
10143              DO l = 1, npcbl
10144                 pcbinsw_av(l) = pcbinsw_av(l) + pcbinsw(l)
10145              ENDDO
10146
10147          CASE ( 'rtm_rad_pc_inswdir' )
10148              DO l = 1, npcbl
10149                 pcbinswdir_av(l) = pcbinswdir_av(l) + pcbinswdir(l)
10150              ENDDO
10151
10152          CASE ( 'rtm_rad_pc_inswdif' )
10153              DO l = 1, npcbl
10154                 pcbinswdif_av(l) = pcbinswdif_av(l) + pcbinswdif(l)
10155              ENDDO
10156
10157          CASE ( 'rtm_rad_pc_inswref' )
10158              DO l = 1, npcbl
10159                 pcbinswref_av(l) = pcbinswref_av(l) + pcbinsw(l) - pcbinswdir(l) - pcbinswdif(l)
10160              ENDDO
10161
10162          CASE ( 'rad_mrt_sw' )
10163             IF ( ALLOCATED( mrtinsw_av ) )  THEN
10164                mrtinsw_av(:) = mrtinsw_av(:) + mrtinsw(:)
10165             ENDIF
10166
10167          CASE ( 'rad_mrt_lw' )
10168             IF ( ALLOCATED( mrtinlw_av ) )  THEN
10169                mrtinlw_av(:) = mrtinlw_av(:) + mrtinlw(:)
10170             ENDIF
10171
10172          CASE ( 'rad_mrt' )
10173             IF ( ALLOCATED( mrt_av ) )  THEN
10174                mrt_av(:) = mrt_av(:) + mrt(:)
10175             ENDIF
10176
10177          CASE DEFAULT
10178             CONTINUE
10179
10180       END SELECT
10181
10182    ELSEIF ( mode == 'average' )  THEN
10183
10184       SELECT CASE ( TRIM( var ) )
10185!--       block of large scale (e.g. RRTMG) radiation output variables
10186          CASE ( 'rad_net*' )
10187             IF ( ALLOCATED( rad_net_av ) ) THEN
10188                DO  i = nxlg, nxrg
10189                   DO  j = nysg, nyng
10190                      rad_net_av(j,i) = rad_net_av(j,i)                        &
10191                                        / REAL( average_count_3d, KIND=wp )
10192                   ENDDO
10193                ENDDO
10194             ENDIF
10195             
10196          CASE ( 'rad_lw_in*' )
10197             IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN
10198                DO  i = nxlg, nxrg
10199                   DO  j = nysg, nyng
10200                      rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i)              &
10201                                        / REAL( average_count_3d, KIND=wp )
10202                   ENDDO
10203                ENDDO
10204             ENDIF
10205             
10206          CASE ( 'rad_lw_out*' )
10207             IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN
10208                DO  i = nxlg, nxrg
10209                   DO  j = nysg, nyng
10210                      rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i)            &
10211                                        / REAL( average_count_3d, KIND=wp )
10212                   ENDDO
10213                ENDDO
10214             ENDIF
10215             
10216          CASE ( 'rad_sw_in*' )
10217             IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN
10218                DO  i = nxlg, nxrg
10219                   DO  j = nysg, nyng
10220                      rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i)              &
10221                                        / REAL( average_count_3d, KIND=wp )
10222                   ENDDO
10223                ENDDO
10224             ENDIF
10225             
10226          CASE ( 'rad_sw_out*' )
10227             IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN
10228                DO  i = nxlg, nxrg
10229                   DO  j = nysg, nyng
10230                      rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i)             &
10231                                        / REAL( average_count_3d, KIND=wp )
10232                   ENDDO
10233                ENDDO
10234             ENDIF
10235
10236          CASE ( 'rad_lw_in' )
10237             IF ( ALLOCATED( rad_lw_in_av ) ) THEN
10238                DO  i = nxlg, nxrg
10239                   DO  j = nysg, nyng
10240                      DO  k = nzb, nzt+1
10241                         rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i)             &
10242                                               / REAL( average_count_3d, KIND=wp )
10243                      ENDDO
10244                   ENDDO
10245                ENDDO
10246             ENDIF
10247
10248          CASE ( 'rad_lw_out' )
10249             IF ( ALLOCATED( rad_lw_out_av ) ) THEN
10250                DO  i = nxlg, nxrg
10251                   DO  j = nysg, nyng
10252                      DO  k = nzb, nzt+1
10253                         rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i)           &
10254                                                / REAL( average_count_3d, KIND=wp )
10255                      ENDDO
10256                   ENDDO
10257                ENDDO
10258             ENDIF
10259
10260          CASE ( 'rad_lw_cs_hr' )
10261             IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN
10262                DO  i = nxlg, nxrg
10263                   DO  j = nysg, nyng
10264                      DO  k = nzb, nzt+1
10265                         rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i)       &
10266                                                / REAL( average_count_3d, KIND=wp )
10267                      ENDDO
10268                   ENDDO
10269                ENDDO
10270             ENDIF
10271
10272          CASE ( 'rad_lw_hr' )
10273             IF ( ALLOCATED( rad_lw_hr_av ) ) THEN
10274                DO  i = nxlg, nxrg
10275                   DO  j = nysg, nyng
10276                      DO  k = nzb, nzt+1
10277                         rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i)             &
10278                                               / REAL( average_count_3d, KIND=wp )
10279                      ENDDO
10280                   ENDDO
10281                ENDDO
10282             ENDIF
10283
10284          CASE ( 'rad_sw_in' )
10285             IF ( ALLOCATED( rad_sw_in_av ) ) THEN
10286                DO  i = nxlg, nxrg
10287                   DO  j = nysg, nyng
10288                      DO  k = nzb, nzt+1
10289                         rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i)             &
10290                                               / REAL( average_count_3d, KIND=wp )
10291                      ENDDO
10292                   ENDDO
10293                ENDDO
10294             ENDIF
10295
10296          CASE ( 'rad_sw_out' )
10297             IF ( ALLOCATED( rad_sw_out_av ) ) THEN
10298                DO  i = nxlg, nxrg
10299                   DO  j = nysg, nyng
10300                      DO  k = nzb, nzt+1
10301                         rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i)           &
10302                                                / REAL( average_count_3d, KIND=wp )
10303                      ENDDO
10304                   ENDDO
10305                ENDDO
10306             ENDIF
10307
10308          CASE ( 'rad_sw_cs_hr' )
10309             IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN
10310                DO  i = nxlg, nxrg
10311                   DO  j = nysg, nyng
10312                      DO  k = nzb, nzt+1
10313                         rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i)       &
10314                                                / REAL( average_count_3d, KIND=wp )
10315                      ENDDO
10316                   ENDDO
10317                ENDDO
10318             ENDIF
10319
10320          CASE ( 'rad_sw_hr' )
10321             IF ( ALLOCATED( rad_sw_hr_av ) ) THEN
10322                DO  i = nxlg, nxrg
10323                   DO  j = nysg, nyng
10324                      DO  k = nzb, nzt+1
10325                         rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i)             &
10326                                               / REAL( average_count_3d, KIND=wp )
10327                      ENDDO
10328                   ENDDO
10329                ENDDO
10330             ENDIF
10331
10332!--       block of RTM output variables
10333          CASE ( 'rtm_rad_net' )
10334!--           array of complete radiation balance
10335              DO isurf = dirstart(ids), dirend(ids)
10336                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10337                      surfradnet_av(isurf) = surfinsw_av(isurf) / REAL( average_count_3d, kind=wp )
10338                  ENDIF
10339              ENDDO
10340
10341          CASE ( 'rtm_rad_insw' )
10342!--           array of sw radiation falling to surface after i-th reflection
10343              DO isurf = dirstart(ids), dirend(ids)
10344                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10345                      surfinsw_av(isurf) = surfinsw_av(isurf) / REAL( average_count_3d, kind=wp )
10346                  ENDIF
10347              ENDDO
10348
10349          CASE ( 'rtm_rad_inlw' )
10350!--           array of lw radiation falling to surface after i-th reflection
10351              DO isurf = dirstart(ids), dirend(ids)
10352                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10353                      surfinlw_av(isurf) = surfinlw_av(isurf) / REAL( average_count_3d, kind=wp )
10354                  ENDIF
10355              ENDDO
10356
10357          CASE ( 'rtm_rad_inswdir' )
10358!--           array of direct sw radiation falling to surface from sun
10359              DO isurf = dirstart(ids), dirend(ids)
10360                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10361                      surfinswdir_av(isurf) = surfinswdir_av(isurf) / REAL( average_count_3d, kind=wp )
10362                  ENDIF
10363              ENDDO
10364
10365          CASE ( 'rtm_rad_inswdif' )
10366!--           array of difusion sw radiation falling to surface from sky and borders of the domain
10367              DO isurf = dirstart(ids), dirend(ids)
10368                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10369                      surfinswdif_av(isurf) = surfinswdif_av(isurf) / REAL( average_count_3d, kind=wp )
10370                  ENDIF
10371              ENDDO
10372
10373          CASE ( 'rtm_rad_inswref' )
10374!--           array of sw radiation falling to surface from reflections
10375              DO isurf = dirstart(ids), dirend(ids)
10376                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10377                      surfinswref_av(isurf) = surfinswref_av(isurf) / REAL( average_count_3d, kind=wp )
10378                  ENDIF
10379              ENDDO
10380
10381          CASE ( 'rtm_rad_inlwdif' )
10382!--           array of sw radiation falling to surface after i-th reflection
10383              DO isurf = dirstart(ids), dirend(ids)
10384                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10385                      surfinlwdif_av(isurf) = surfinlwdif_av(isurf) / REAL( average_count_3d, kind=wp )
10386                  ENDIF
10387              ENDDO
10388
10389          CASE ( 'rtm_rad_inlwref' )
10390!--           array of lw radiation falling to surface from reflections
10391              DO isurf = dirstart(ids), dirend(ids)
10392                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10393                      surfinlwref_av(isurf) = surfinlwref_av(isurf) / REAL( average_count_3d, kind=wp )
10394                  ENDIF
10395              ENDDO
10396
10397          CASE ( 'rtm_rad_outsw' )
10398!--           array of sw radiation emitted from surface after i-th reflection
10399              DO isurf = dirstart(ids), dirend(ids)
10400                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10401                      surfoutsw_av(isurf) = surfoutsw_av(isurf) / REAL( average_count_3d, kind=wp )
10402                  ENDIF
10403              ENDDO
10404
10405          CASE ( 'rtm_rad_outlw' )
10406!--           array of lw radiation emitted from surface after i-th reflection
10407              DO isurf = dirstart(ids), dirend(ids)
10408                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10409                      surfoutlw_av(isurf) = surfoutlw_av(isurf) / REAL( average_count_3d, kind=wp )
10410                  ENDIF
10411              ENDDO
10412
10413          CASE ( 'rtm_rad_ressw' )
10414!--           array of residua of sw radiation absorbed in surface after last reflection
10415              DO isurf = dirstart(ids), dirend(ids)
10416                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10417                      surfins_av(isurf) = surfins_av(isurf) / REAL( average_count_3d, kind=wp )
10418                  ENDIF
10419              ENDDO
10420
10421          CASE ( 'rtm_rad_reslw' )
10422!--           array of residua of lw radiation absorbed in surface after last reflection
10423              DO isurf = dirstart(ids), dirend(ids)
10424                  IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
10425                      surfinl_av(isurf) = surfinl_av(isurf) / REAL( average_count_3d, kind=wp )
10426                  ENDIF
10427              ENDDO
10428
10429          CASE ( 'rtm_rad_pc_inlw' )
10430              DO l = 1, npcbl
10431                 pcbinlw_av(:) = pcbinlw_av(:) / REAL( average_count_3d, kind=wp )
10432              ENDDO
10433
10434          CASE ( 'rtm_rad_pc_insw' )
10435              DO l = 1, npcbl
10436                 pcbinsw_av(:) = pcbinsw_av(:) / REAL( average_count_3d, kind=wp )
10437              ENDDO
10438
10439          CASE ( 'rtm_rad_pc_inswdir' )
10440              DO l = 1, npcbl
10441                 pcbinswdir_av(:) = pcbinswdir_av(:) / REAL( average_count_3d, kind=wp )
10442              ENDDO
10443
10444          CASE ( 'rtm_rad_pc_inswdif' )
10445              DO l = 1, npcbl
10446                 pcbinswdif_av(:) = pcbinswdif_av(:) / REAL( average_count_3d, kind=wp )
10447              ENDDO
10448
10449          CASE ( 'rtm_rad_pc_inswref' )
10450              DO l = 1, npcbl
10451                 pcbinswref_av(:) = pcbinswref_av(:) / REAL( average_count_3d, kind=wp )
10452              ENDDO
10453
10454          CASE ( 'rad_mrt_lw' )
10455             IF ( ALLOCATED( mrtinlw_av ) )  THEN
10456                mrtinlw_av(:) = mrtinlw_av(:) / REAL( average_count_3d, KIND=wp )
10457             ENDIF
10458
10459          CASE ( 'rad_mrt' )
10460             IF ( ALLOCATED( mrt_av ) )  THEN
10461                mrt_av(:) = mrt_av(:) / REAL( average_count_3d, KIND=wp )
10462             ENDIF
10463
10464       END SELECT
10465
10466    ENDIF
10467
10468END SUBROUTINE radiation_3d_data_averaging
10469
10470
10471!------------------------------------------------------------------------------!
10472!
10473! Description:
10474! ------------
10475!> Subroutine defining appropriate grid for netcdf variables.
10476!> It is called out from subroutine netcdf.
10477!------------------------------------------------------------------------------!
10478SUBROUTINE radiation_define_netcdf_grid( variable, found, grid_x, grid_y, grid_z )
10479   
10480    IMPLICIT NONE
10481
10482    CHARACTER (LEN=*), INTENT(IN)  ::  variable    !<
10483    LOGICAL, INTENT(OUT)           ::  found       !<
10484    CHARACTER (LEN=*), INTENT(OUT) ::  grid_x      !<
10485    CHARACTER (LEN=*), INTENT(OUT) ::  grid_y      !<
10486    CHARACTER (LEN=*), INTENT(OUT) ::  grid_z      !<
10487
10488    CHARACTER (len=varnamelength)  :: var
10489
10490    found  = .TRUE.
10491
10492!
10493!-- Check for the grid
10494    var = TRIM(variable)
10495!-- RTM directional variables
10496    IF ( var(1:12) == 'rtm_rad_net_'  .OR.  var(1:13) == 'rtm_rad_insw_'  .OR.          &
10497         var(1:13) == 'rtm_rad_inlw_'  .OR.  var(1:16) == 'rtm_rad_inswdir_'  .OR.      &
10498         var(1:16) == 'rtm_rad_inswdif_'  .OR.  var(1:16) == 'rtm_rad_inswref_'  .OR.   &
10499         var(1:16) == 'rtm_rad_inlwdif_'  .OR.  var(1:16) == 'rtm_rad_inlwref_'  .OR.   &
10500         var(1:14) == 'rtm_rad_outsw_'  .OR.  var(1:14) == 'rtm_rad_outlw_'  .OR.       &
10501         var(1:14) == 'rtm_rad_ressw_'  .OR.  var(1:14) == 'rtm_rad_reslw_'  .OR.       &
10502         var == 'rtm_rad_pc_inlw'  .OR.                                                 &
10503         var == 'rtm_rad_pc_insw'  .OR.  var == 'rtm_rad_pc_inswdir'  .OR.              &
10504         var == 'rtm_rad_pc_inswdif'  .OR.  var == 'rtm_rad_pc_inswref'  .OR.           &
10505         var(1:7) == 'rtm_svf'  .OR.  var(1:7) == 'rtm_dif'  .OR.                       &
10506         var(1:9) == 'rtm_skyvf' .OR. var(1:10) == 'rtm_skyvft'  .OR.                   &
10507         var(1:12) == 'rtm_surfalb_'  .OR.  var(1:13) == 'rtm_surfemis_'  .OR.          &
10508         var == 'rtm_mrt'  .OR.  var ==  'rtm_mrt_sw'  .OR.  var == 'rtm_mrt_lw' )  THEN
10509
10510         found = .TRUE.
10511         grid_x = 'x'
10512         grid_y = 'y'
10513         grid_z = 'zu'
10514    ELSE
10515
10516       SELECT CASE ( TRIM( var ) )
10517
10518          CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_sw_cs_hr', 'rad_sw_hr',        &
10519                 'rad_lw_cs_hr_xy', 'rad_lw_hr_xy', 'rad_sw_cs_hr_xy',            &
10520                 'rad_sw_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_hr_xz',               &
10521                 'rad_sw_cs_hr_xz', 'rad_sw_hr_xz', 'rad_lw_cs_hr_yz',            &
10522                 'rad_lw_hr_yz', 'rad_sw_cs_hr_yz', 'rad_sw_hr_yz',               &
10523                 'rad_mrt', 'rad_mrt_sw', 'rad_mrt_lw' )
10524             grid_x = 'x'
10525             grid_y = 'y'
10526             grid_z = 'zu'
10527
10528          CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out',            &
10529                 'rad_lw_in_xy', 'rad_lw_out_xy', 'rad_sw_in_xy','rad_sw_out_xy', &
10530                 'rad_lw_in_xz', 'rad_lw_out_xz', 'rad_sw_in_xz','rad_sw_out_xz', &
10531                 'rad_lw_in_yz', 'rad_lw_out_yz', 'rad_sw_in_yz','rad_sw_out_yz' )
10532             grid_x = 'x'
10533             grid_y = 'y'
10534             grid_z = 'zw'
10535
10536
10537          CASE DEFAULT
10538             found  = .FALSE.
10539             grid_x = 'none'
10540             grid_y = 'none'
10541             grid_z = 'none'
10542
10543           END SELECT
10544       ENDIF
10545
10546    END SUBROUTINE radiation_define_netcdf_grid
10547
10548!------------------------------------------------------------------------------!
10549!
10550! Description:
10551! ------------
10552!> Subroutine defining 2D output variables
10553!------------------------------------------------------------------------------!
10554 SUBROUTINE radiation_data_output_2d( av, variable, found, grid, mode,         &
10555                                      local_pf, two_d, nzb_do, nzt_do )
10556 
10557    USE indices
10558
10559    USE kinds
10560
10561
10562    IMPLICIT NONE
10563
10564    CHARACTER (LEN=*) ::  grid     !<
10565    CHARACTER (LEN=*) ::  mode     !<
10566    CHARACTER (LEN=*) ::  variable !<
10567
10568    INTEGER(iwp) ::  av !<
10569    INTEGER(iwp) ::  i  !<
10570    INTEGER(iwp) ::  j  !<
10571    INTEGER(iwp) ::  k  !<
10572    INTEGER(iwp) ::  m  !< index of surface element at grid point (j,i)
10573    INTEGER(iwp) ::  nzb_do   !<
10574    INTEGER(iwp) ::  nzt_do   !<
10575
10576    LOGICAL      ::  found !<
10577    LOGICAL      ::  two_d !< flag parameter that indicates 2D variables (horizontal cross sections)
10578
10579    REAL(wp) ::  fill_value = -999.0_wp    !< value for the _FillValue attribute
10580
10581    REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) ::  local_pf !<
10582
10583    found = .TRUE.
10584
10585    SELECT CASE ( TRIM( variable ) )
10586
10587       CASE ( 'rad_net*_xy' )        ! 2d-array
10588          IF ( av == 0 ) THEN
10589             DO  i = nxl, nxr
10590                DO  j = nys, nyn
10591!
10592!--                Obtain rad_net from its respective surface type
10593!--                Natural-type surfaces
10594                   DO  m = surf_lsm_h%start_index(j,i),                        &
10595                           surf_lsm_h%end_index(j,i) 
10596                      local_pf(i,j,nzb+1) = surf_lsm_h%rad_net(m)
10597                   ENDDO
10598!
10599!--                Urban-type surfaces
10600                   DO  m = surf_usm_h%start_index(j,i),                        &
10601                           surf_usm_h%end_index(j,i) 
10602                      local_pf(i,j,nzb+1) = surf_usm_h%rad_net(m)
10603                   ENDDO
10604                ENDDO
10605             ENDDO
10606          ELSE
10607             IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN
10608                ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
10609                rad_net_av = REAL( fill_value, KIND = wp )
10610             ENDIF
10611             DO  i = nxl, nxr
10612                DO  j = nys, nyn 
10613                   local_pf(i,j,nzb+1) = rad_net_av(j,i)
10614                ENDDO
10615             ENDDO
10616          ENDIF
10617          two_d = .TRUE.
10618          grid = 'zu1'
10619         
10620       CASE ( 'rad_lw_in*_xy' )        ! 2d-array
10621          IF ( av == 0 ) THEN
10622             DO  i = nxl, nxr
10623                DO  j = nys, nyn
10624!
10625!--                Obtain rad_net from its respective surface type
10626!--                Natural-type surfaces
10627                   DO  m = surf_lsm_h%start_index(j,i),                        &
10628                           surf_lsm_h%end_index(j,i) 
10629                      local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_in(m)
10630                   ENDDO
10631!
10632!--                Urban-type surfaces
10633                   DO  m = surf_usm_h%start_index(j,i),                        &
10634                           surf_usm_h%end_index(j,i) 
10635                      local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_in(m)
10636                   ENDDO
10637                ENDDO
10638             ENDDO
10639          ELSE
10640             IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN
10641                ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
10642                rad_lw_in_xy_av = REAL( fill_value, KIND = wp )
10643             ENDIF
10644             DO  i = nxl, nxr
10645                DO  j = nys, nyn 
10646                   local_pf(i,j,nzb+1) = rad_lw_in_xy_av(j,i)
10647                ENDDO
10648             ENDDO
10649          ENDIF
10650          two_d = .TRUE.
10651          grid = 'zu1'
10652         
10653       CASE ( 'rad_lw_out*_xy' )        ! 2d-array
10654          IF ( av == 0 ) THEN
10655             DO  i = nxl, nxr
10656                DO  j = nys, nyn
10657!
10658!--                Obtain rad_net from its respective surface type
10659!--                Natural-type surfaces
10660                   DO  m = surf_lsm_h%start_index(j,i),                        &
10661                           surf_lsm_h%end_index(j,i) 
10662                      local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_out(m)
10663                   ENDDO
10664!
10665!--                Urban-type surfaces
10666                   DO  m = surf_usm_h%start_index(j,i),                        &
10667                           surf_usm_h%end_index(j,i) 
10668                      local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_out(m)
10669                   ENDDO
10670                ENDDO
10671             ENDDO
10672          ELSE
10673             IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN
10674                ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
10675                rad_lw_out_xy_av = REAL( fill_value, KIND = wp )
10676             ENDIF
10677             DO  i = nxl, nxr
10678                DO  j = nys, nyn 
10679                   local_pf(i,j,nzb+1) = rad_lw_out_xy_av(j,i)
10680                ENDDO
10681             ENDDO
10682          ENDIF
10683          two_d = .TRUE.
10684          grid = 'zu1'
10685         
10686       CASE ( 'rad_sw_in*_xy' )        ! 2d-array
10687          IF ( av == 0 ) THEN
10688             DO  i = nxl, nxr
10689                DO  j = nys, nyn
10690!
10691!--                Obtain rad_net from its respective surface type
10692!--                Natural-type surfaces
10693                   DO  m = surf_lsm_h%start_index(j,i),                        &
10694                           surf_lsm_h%end_index(j,i) 
10695                      local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_in(m)
10696                   ENDDO
10697!
10698!--                Urban-type surfaces
10699                   DO  m = surf_usm_h%start_index(j,i),                        &
10700                           surf_usm_h%end_index(j,i) 
10701                      local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_in(m)
10702                   ENDDO
10703                ENDDO
10704             ENDDO
10705          ELSE
10706             IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN
10707                ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
10708                rad_sw_in_xy_av = REAL( fill_value, KIND = wp )
10709             ENDIF
10710             DO  i = nxl, nxr
10711                DO  j = nys, nyn 
10712                   local_pf(i,j,nzb+1) = rad_sw_in_xy_av(j,i)
10713                ENDDO
10714             ENDDO
10715          ENDIF
10716          two_d = .TRUE.
10717          grid = 'zu1'
10718         
10719       CASE ( 'rad_sw_out*_xy' )        ! 2d-array
10720          IF ( av == 0 ) THEN
10721             DO  i = nxl, nxr
10722                DO  j = nys, nyn
10723!
10724!--                Obtain rad_net from its respective surface type
10725!--                Natural-type surfaces
10726                   DO  m = surf_lsm_h%start_index(j,i),                        &
10727                           surf_lsm_h%end_index(j,i) 
10728                      local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_out(m)
10729                   ENDDO
10730!
10731!--                Urban-type surfaces
10732                   DO  m = surf_usm_h%start_index(j,i),                        &
10733                           surf_usm_h%end_index(j,i) 
10734                      local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_out(m)
10735                   ENDDO
10736                ENDDO
10737             ENDDO
10738          ELSE
10739             IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN
10740                ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
10741                rad_sw_out_xy_av = REAL( fill_value, KIND = wp )
10742             ENDIF
10743             DO  i = nxl, nxr
10744                DO  j = nys, nyn 
10745                   local_pf(i,j,nzb+1) = rad_sw_out_xy_av(j,i)
10746                ENDDO
10747             ENDDO
10748          ENDIF
10749          two_d = .TRUE.
10750          grid = 'zu1'         
10751         
10752       CASE ( 'rad_lw_in_xy', 'rad_lw_in_xz', 'rad_lw_in_yz' )
10753          IF ( av == 0 ) THEN
10754             DO  i = nxl, nxr
10755                DO  j = nys, nyn
10756                   DO  k = nzb_do, nzt_do
10757                      local_pf(i,j,k) = rad_lw_in(k,j,i)
10758                   ENDDO
10759                ENDDO
10760             ENDDO
10761          ELSE
10762            IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
10763               ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10764               rad_lw_in_av = REAL( fill_value, KIND = wp )
10765            ENDIF
10766             DO  i = nxl, nxr
10767                DO  j = nys, nyn 
10768                   DO  k = nzb_do, nzt_do
10769                      local_pf(i,j,k) = rad_lw_in_av(k,j,i)
10770                   ENDDO
10771                ENDDO
10772             ENDDO
10773          ENDIF
10774          IF ( mode == 'xy' )  grid = 'zu'
10775
10776       CASE ( 'rad_lw_out_xy', 'rad_lw_out_xz', 'rad_lw_out_yz' )
10777          IF ( av == 0 ) THEN
10778             DO  i = nxl, nxr
10779                DO  j = nys, nyn
10780                   DO  k = nzb_do, nzt_do
10781                      local_pf(i,j,k) = rad_lw_out(k,j,i)
10782                   ENDDO
10783                ENDDO
10784             ENDDO
10785          ELSE
10786            IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
10787               ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10788               rad_lw_out_av = REAL( fill_value, KIND = wp )
10789            ENDIF
10790             DO  i = nxl, nxr
10791                DO  j = nys, nyn 
10792                   DO  k = nzb_do, nzt_do
10793                      local_pf(i,j,k) = rad_lw_out_av(k,j,i)
10794                   ENDDO
10795                ENDDO
10796             ENDDO
10797          ENDIF   
10798          IF ( mode == 'xy' )  grid = 'zu'
10799
10800       CASE ( 'rad_lw_cs_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_cs_hr_yz' )
10801          IF ( av == 0 ) THEN
10802             DO  i = nxl, nxr
10803                DO  j = nys, nyn
10804                   DO  k = nzb_do, nzt_do
10805                      local_pf(i,j,k) = rad_lw_cs_hr(k,j,i)
10806                   ENDDO
10807                ENDDO
10808             ENDDO
10809          ELSE
10810            IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
10811               ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10812               rad_lw_cs_hr_av = REAL( fill_value, KIND = wp )
10813            ENDIF
10814             DO  i = nxl, nxr
10815                DO  j = nys, nyn 
10816                   DO  k = nzb_do, nzt_do
10817                      local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i)
10818                   ENDDO
10819                ENDDO
10820             ENDDO
10821          ENDIF
10822          IF ( mode == 'xy' )  grid = 'zw'
10823
10824       CASE ( 'rad_lw_hr_xy', 'rad_lw_hr_xz', 'rad_lw_hr_yz' )
10825          IF ( av == 0 ) THEN
10826             DO  i = nxl, nxr
10827                DO  j = nys, nyn
10828                   DO  k = nzb_do, nzt_do
10829                      local_pf(i,j,k) = rad_lw_hr(k,j,i)
10830                   ENDDO
10831                ENDDO
10832             ENDDO
10833          ELSE
10834            IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
10835               ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10836               rad_lw_hr_av= REAL( fill_value, KIND = wp )
10837            ENDIF
10838             DO  i = nxl, nxr
10839                DO  j = nys, nyn 
10840                   DO  k = nzb_do, nzt_do
10841                      local_pf(i,j,k) = rad_lw_hr_av(k,j,i)
10842                   ENDDO
10843                ENDDO
10844             ENDDO
10845          ENDIF
10846          IF ( mode == 'xy' )  grid = 'zw'
10847
10848       CASE ( 'rad_sw_in_xy', 'rad_sw_in_xz', 'rad_sw_in_yz' )
10849          IF ( av == 0 ) THEN
10850             DO  i = nxl, nxr
10851                DO  j = nys, nyn
10852                   DO  k = nzb_do, nzt_do
10853                      local_pf(i,j,k) = rad_sw_in(k,j,i)
10854                   ENDDO
10855                ENDDO
10856             ENDDO
10857          ELSE
10858            IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
10859               ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10860               rad_sw_in_av = REAL( fill_value, KIND = wp )
10861            ENDIF
10862             DO  i = nxl, nxr
10863                DO  j = nys, nyn 
10864                   DO  k = nzb_do, nzt_do
10865                      local_pf(i,j,k) = rad_sw_in_av(k,j,i)
10866                   ENDDO
10867                ENDDO
10868             ENDDO
10869          ENDIF
10870          IF ( mode == 'xy' )  grid = 'zu'
10871
10872       CASE ( 'rad_sw_out_xy', 'rad_sw_out_xz', 'rad_sw_out_yz' )
10873          IF ( av == 0 ) THEN
10874             DO  i = nxl, nxr
10875                DO  j = nys, nyn
10876                   DO  k = nzb_do, nzt_do
10877                      local_pf(i,j,k) = rad_sw_out(k,j,i)
10878                   ENDDO
10879                ENDDO
10880             ENDDO
10881          ELSE
10882            IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
10883               ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
10884               rad_sw_out_av = REAL( fill_value, KIND = wp )
10885            ENDIF
10886             DO  i = nxl, nxr
10887                DO  j = nys, nyn 
10888                   DO  k = nzb, nzt+1
10889                      local_pf(i,j,k) = rad_sw_out_av(k,j,i)
10890                   ENDDO
10891                ENDDO
10892             ENDDO
10893          ENDIF
10894          IF ( mode == 'xy' )  grid = 'zu'
10895
10896       CASE ( 'rad_sw_cs_hr_xy', 'rad_sw_cs_hr_xz', 'rad_sw_cs_hr_yz' )
10897          IF ( av == 0 ) THEN
10898             DO  i = nxl, nxr
10899                DO  j = nys, nyn
10900                   DO  k = nzb_do, nzt_do
10901                      local_pf(i,j,k) = rad_sw_cs_hr(k,j,i)
10902                   ENDDO
10903                ENDDO
10904             ENDDO
10905          ELSE
10906            IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
10907               ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10908               rad_sw_cs_hr_av = REAL( fill_value, KIND = wp )
10909            ENDIF
10910             DO  i = nxl, nxr
10911                DO  j = nys, nyn 
10912                   DO  k = nzb_do, nzt_do
10913                      local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i)
10914                   ENDDO
10915                ENDDO
10916             ENDDO
10917          ENDIF
10918          IF ( mode == 'xy' )  grid = 'zw'
10919
10920       CASE ( 'rad_sw_hr_xy', 'rad_sw_hr_xz', 'rad_sw_hr_yz' )
10921          IF ( av == 0 ) THEN
10922             DO  i = nxl, nxr
10923                DO  j = nys, nyn
10924                   DO  k = nzb_do, nzt_do
10925                      local_pf(i,j,k) = rad_sw_hr(k,j,i)
10926                   ENDDO
10927                ENDDO
10928             ENDDO
10929          ELSE
10930            IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
10931               ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
10932               rad_sw_hr_av = REAL( fill_value, KIND = wp )
10933            ENDIF
10934             DO  i = nxl, nxr
10935                DO  j = nys, nyn 
10936                   DO  k = nzb_do, nzt_do
10937                      local_pf(i,j,k) = rad_sw_hr_av(k,j,i)
10938                   ENDDO
10939                ENDDO
10940             ENDDO
10941          ENDIF
10942          IF ( mode == 'xy' )  grid = 'zw'
10943
10944       CASE DEFAULT
10945          found = .FALSE.
10946          grid  = 'none'
10947
10948    END SELECT
10949 
10950 END SUBROUTINE radiation_data_output_2d
10951
10952
10953!------------------------------------------------------------------------------!
10954!
10955! Description:
10956! ------------
10957!> Subroutine defining 3D output variables
10958!------------------------------------------------------------------------------!
10959 SUBROUTINE radiation_data_output_3d( av, variable, found, local_pf, nzb_do, nzt_do )
10960 
10961
10962    USE indices
10963
10964    USE kinds
10965
10966
10967    IMPLICIT NONE
10968
10969    CHARACTER (LEN=*) ::  variable !<
10970
10971    INTEGER(iwp) ::  av          !<
10972    INTEGER(iwp) ::  i, j, k, l  !<
10973    INTEGER(iwp) ::  nzb_do      !<
10974    INTEGER(iwp) ::  nzt_do      !<
10975
10976    LOGICAL      ::  found       !<
10977
10978    REAL(wp)     ::  fill_value = -999.0_wp    !< value for the _FillValue attribute
10979
10980    REAL(sp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) ::  local_pf !<
10981
10982    CHARACTER (len=varnamelength)                   :: var, surfid
10983    INTEGER(iwp)                                    :: ids,idsint_u,idsint_l,isurf,isvf,isurfs,isurflt,ipcgb
10984    INTEGER(iwp)                                    :: is, js, ks, istat
10985
10986    found = .TRUE.
10987    var = TRIM(variable)
10988
10989!-- check if variable belongs to radiation related variables (starts with rad or rtm)
10990    IF ( len(var) < 3_iwp  )  THEN
10991       found = .FALSE.
10992       RETURN
10993    ENDIF
10994   
10995    IF ( var(1:3) /= 'rad'  .AND.  var(1:3) /= 'rtm' )  THEN
10996       found = .FALSE.
10997       RETURN
10998    ENDIF
10999
11000    ids = -1
11001    DO i = 0, nd-1
11002        k = len(TRIM(var))
11003        j = len(TRIM(dirname(i)))
11004        IF ( k-j+1 >= 1_iwp ) THEN
11005           IF ( TRIM(var(k-j+1:k)) == TRIM(dirname(i)) )  THEN
11006              ids = i
11007              idsint_u = dirint_u(ids)
11008              idsint_l = dirint_l(ids)
11009              var = var(:k-j)
11010              EXIT
11011           ENDIF
11012        ENDIF
11013    ENDDO
11014    IF ( ids == -1 )  THEN
11015        var = TRIM(variable)
11016    ENDIF
11017
11018    IF ( (var(1:8) == 'rtm_svf_'  .OR.  var(1:8) == 'rtm_dif_')  .AND.  len(TRIM(var)) >= 13 )  THEN
11019!--     svf values to particular surface
11020        surfid = var(9:)
11021        i = index(surfid,'_')
11022        j = index(surfid(i+1:),'_')
11023        READ(surfid(1:i-1),*, iostat=istat ) is
11024        IF ( istat == 0 )  THEN
11025            READ(surfid(i+1:i+j-1),*, iostat=istat ) js
11026        ENDIF
11027        IF ( istat == 0 )  THEN
11028            READ(surfid(i+j+1:),*, iostat=istat ) ks
11029        ENDIF
11030        IF ( istat == 0 )  THEN
11031            var = var(1:7)
11032        ENDIF
11033    ENDIF
11034
11035    local_pf = fill_value
11036
11037    SELECT CASE ( TRIM( var ) )
11038!--   block of large scale radiation model (e.g. RRTMG) output variables
11039      CASE ( 'rad_sw_in' )
11040         IF ( av == 0 )  THEN
11041            DO  i = nxl, nxr
11042               DO  j = nys, nyn
11043                  DO  k = nzb_do, nzt_do
11044                     local_pf(i,j,k) = rad_sw_in(k,j,i)
11045                  ENDDO
11046               ENDDO
11047            ENDDO
11048         ELSE
11049            IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN
11050               ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11051               rad_sw_in_av = REAL( fill_value, KIND = wp )
11052            ENDIF
11053            DO  i = nxl, nxr
11054               DO  j = nys, nyn
11055                  DO  k = nzb_do, nzt_do
11056                     local_pf(i,j,k) = rad_sw_in_av(k,j,i)
11057                  ENDDO
11058               ENDDO
11059            ENDDO
11060         ENDIF
11061
11062      CASE ( 'rad_sw_out' )
11063         IF ( av == 0 )  THEN
11064            DO  i = nxl, nxr
11065               DO  j = nys, nyn
11066                  DO  k = nzb_do, nzt_do
11067                     local_pf(i,j,k) = rad_sw_out(k,j,i)
11068                  ENDDO
11069               ENDDO
11070            ENDDO
11071         ELSE
11072            IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN
11073               ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11074               rad_sw_out_av = REAL( fill_value, KIND = wp )
11075            ENDIF
11076            DO  i = nxl, nxr
11077               DO  j = nys, nyn
11078                  DO  k = nzb_do, nzt_do
11079                     local_pf(i,j,k) = rad_sw_out_av(k,j,i)
11080                  ENDDO
11081               ENDDO
11082            ENDDO
11083         ENDIF
11084
11085      CASE ( 'rad_sw_cs_hr' )
11086         IF ( av == 0 )  THEN
11087            DO  i = nxl, nxr
11088               DO  j = nys, nyn
11089                  DO  k = nzb_do, nzt_do
11090                     local_pf(i,j,k) = rad_sw_cs_hr(k,j,i)
11091                  ENDDO
11092               ENDDO
11093            ENDDO
11094         ELSE
11095            IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN
11096               ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
11097               rad_sw_cs_hr_av = REAL( fill_value, KIND = wp )
11098            ENDIF
11099            DO  i = nxl, nxr
11100               DO  j = nys, nyn
11101                  DO  k = nzb_do, nzt_do
11102                     local_pf(i,j,k) = rad_sw_cs_hr_av(k,j,i)
11103                  ENDDO
11104               ENDDO
11105            ENDDO
11106         ENDIF
11107
11108      CASE ( 'rad_sw_hr' )
11109         IF ( av == 0 )  THEN
11110            DO  i = nxl, nxr
11111               DO  j = nys, nyn
11112                  DO  k = nzb_do, nzt_do
11113                     local_pf(i,j,k) = rad_sw_hr(k,j,i)
11114                  ENDDO
11115               ENDDO
11116            ENDDO
11117         ELSE
11118            IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN
11119               ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
11120               rad_sw_hr_av = REAL( fill_value, KIND = wp )
11121            ENDIF
11122            DO  i = nxl, nxr
11123               DO  j = nys, nyn
11124                  DO  k = nzb_do, nzt_do
11125                     local_pf(i,j,k) = rad_sw_hr_av(k,j,i)
11126                  ENDDO
11127               ENDDO
11128            ENDDO
11129         ENDIF
11130
11131      CASE ( 'rad_lw_in' )
11132         IF ( av == 0 )  THEN
11133            DO  i = nxl, nxr
11134               DO  j = nys, nyn
11135                  DO  k = nzb_do, nzt_do
11136                     local_pf(i,j,k) = rad_lw_in(k,j,i)
11137                  ENDDO
11138               ENDDO
11139            ENDDO
11140         ELSE
11141            IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN
11142               ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11143               rad_lw_in_av = REAL( fill_value, KIND = wp )
11144            ENDIF
11145            DO  i = nxl, nxr
11146               DO  j = nys, nyn
11147                  DO  k = nzb_do, nzt_do
11148                     local_pf(i,j,k) = rad_lw_in_av(k,j,i)
11149                  ENDDO
11150               ENDDO
11151            ENDDO
11152         ENDIF
11153
11154      CASE ( 'rad_lw_out' )
11155         IF ( av == 0 )  THEN
11156            DO  i = nxl, nxr
11157               DO  j = nys, nyn
11158                  DO  k = nzb_do, nzt_do
11159                     local_pf(i,j,k) = rad_lw_out(k,j,i)
11160                  ENDDO
11161               ENDDO
11162            ENDDO
11163         ELSE
11164            IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN
11165               ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11166               rad_lw_out_av = REAL( fill_value, KIND = wp )
11167            ENDIF
11168            DO  i = nxl, nxr
11169               DO  j = nys, nyn
11170                  DO  k = nzb_do, nzt_do
11171                     local_pf(i,j,k) = rad_lw_out_av(k,j,i)
11172                  ENDDO
11173               ENDDO
11174            ENDDO
11175         ENDIF
11176
11177      CASE ( 'rad_lw_cs_hr' )
11178         IF ( av == 0 )  THEN
11179            DO  i = nxl, nxr
11180               DO  j = nys, nyn
11181                  DO  k = nzb_do, nzt_do
11182                     local_pf(i,j,k) = rad_lw_cs_hr(k,j,i)
11183                  ENDDO
11184               ENDDO
11185            ENDDO
11186         ELSE
11187            IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN
11188               ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
11189               rad_lw_cs_hr_av = REAL( fill_value, KIND = wp )
11190            ENDIF
11191            DO  i = nxl, nxr
11192               DO  j = nys, nyn
11193                  DO  k = nzb_do, nzt_do
11194                     local_pf(i,j,k) = rad_lw_cs_hr_av(k,j,i)
11195                  ENDDO
11196               ENDDO
11197            ENDDO
11198         ENDIF
11199
11200      CASE ( 'rad_lw_hr' )
11201         IF ( av == 0 )  THEN
11202            DO  i = nxl, nxr
11203               DO  j = nys, nyn
11204                  DO  k = nzb_do, nzt_do
11205                     local_pf(i,j,k) = rad_lw_hr(k,j,i)
11206                  ENDDO
11207               ENDDO
11208            ENDDO
11209         ELSE
11210            IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN
11211               ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) )
11212              rad_lw_hr_av = REAL( fill_value, KIND = wp )
11213            ENDIF
11214            DO  i = nxl, nxr
11215               DO  j = nys, nyn
11216                  DO  k = nzb_do, nzt_do
11217                     local_pf(i,j,k) = rad_lw_hr_av(k,j,i)
11218                  ENDDO
11219               ENDDO
11220            ENDDO
11221         ENDIF
11222
11223      CASE ( 'rtm_rad_net' )
11224!--     array of complete radiation balance
11225         DO isurf = dirstart(ids), dirend(ids)
11226            IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
11227               IF ( av == 0 )  THEN
11228                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = &
11229                         surfinsw(isurf) - surfoutsw(isurf) +  surfinlw(isurf) - surfoutlw(isurf)
11230               ELSE
11231                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfradnet_av(isurf)
11232               ENDIF
11233            ENDIF
11234         ENDDO
11235
11236      CASE ( 'rtm_rad_insw' )
11237!--      array of sw radiation falling to surface after i-th reflection
11238         DO isurf = dirstart(ids), dirend(ids)
11239            IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
11240               IF ( av == 0 )  THEN
11241                 local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinsw(isurf)
11242               ELSE
11243                 local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinsw_av(isurf)
11244               ENDIF
11245            ENDIF
11246         ENDDO
11247
11248      CASE ( 'rtm_rad_inlw' )
11249!--      array of lw radiation falling to surface after i-th reflection
11250         DO isurf = dirstart(ids), dirend(ids)
11251            IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
11252               IF ( av == 0 )  THEN
11253                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw(isurf)
11254               ELSE
11255                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw_av(isurf)
11256               ENDIF
11257             ENDIF
11258         ENDDO
11259
11260      CASE ( 'rtm_rad_inswdir' )
11261!--      array of direct sw radiation falling to surface from sun
11262         DO isurf = dirstart(ids), dirend(ids)
11263            IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
11264               IF ( av == 0 )  THEN
11265                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdir(isurf)
11266               ELSE
11267                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdir_av(isurf)
11268               ENDIF
11269            ENDIF
11270         ENDDO
11271
11272      CASE ( 'rtm_rad_inswdif' )
11273!--      array of difusion sw radiation falling to surface from sky and borders of the domain
11274         DO isurf = dirstart(ids), dirend(ids)
11275            IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
11276               IF ( av == 0 )  THEN
11277                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdif(isurf)
11278               ELSE
11279                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswdif_av(isurf)
11280               ENDIF
11281            ENDIF
11282         ENDDO
11283
11284      CASE ( 'rtm_rad_inswref' )
11285!--      array of sw radiation falling to surface from reflections
11286         DO isurf = dirstart(ids), dirend(ids)
11287            IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
11288               IF ( av == 0 )  THEN
11289                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = &
11290                    surfinsw(isurf) - surfinswdir(isurf) - surfinswdif(isurf)
11291               ELSE
11292                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswref_av(isurf)
11293               ENDIF
11294            ENDIF
11295         ENDDO
11296
11297      CASE ( 'rtm_rad_inlwdif' )
11298!--      array of difusion lw radiation falling to surface from sky and borders of the domain
11299         DO isurf = dirstart(ids), dirend(ids)
11300            IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
11301               IF ( av == 0 )  THEN
11302                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwdif(isurf)
11303               ELSE
11304                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwdif_av(isurf)
11305               ENDIF
11306            ENDIF
11307         ENDDO
11308
11309      CASE ( 'rtm_rad_inlwref' )
11310!--      array of lw radiation falling to surface from reflections
11311         DO isurf = dirstart(ids), dirend(ids)
11312            IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
11313               IF ( av == 0 )  THEN
11314                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw(isurf) - surfinlwdif(isurf)
11315               ELSE
11316                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwref_av(isurf)
11317               ENDIF
11318            ENDIF
11319         ENDDO
11320
11321      CASE ( 'rtm_rad_outsw' )
11322!--      array of sw radiation emitted from surface after i-th reflection
11323         DO isurf = dirstart(ids), dirend(ids)
11324            IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
11325               IF ( av == 0 )  THEN
11326                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutsw(isurf)
11327               ELSE
11328                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutsw_av(isurf)
11329               ENDIF
11330            ENDIF
11331         ENDDO
11332
11333      CASE ( 'rtm_rad_outlw' )
11334!--      array of lw radiation emitted from surface after i-th reflection
11335         DO isurf = dirstart(ids), dirend(ids)
11336            IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
11337               IF ( av == 0 )  THEN
11338                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutlw(isurf)
11339               ELSE
11340                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfoutlw_av(isurf)
11341               ENDIF
11342            ENDIF
11343         ENDDO
11344
11345      CASE ( 'rtm_rad_ressw' )
11346!--      average of array of residua of sw radiation absorbed in surface after last reflection
11347         DO isurf = dirstart(ids), dirend(ids)
11348            IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
11349               IF ( av == 0 )  THEN
11350                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfins(isurf)
11351               ELSE
11352                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfins_av(isurf)
11353               ENDIF
11354            ENDIF
11355         ENDDO
11356
11357      CASE ( 'rtm_rad_reslw' )
11358!--      average of array of residua of lw radiation absorbed in surface after last reflection
11359         DO isurf = dirstart(ids), dirend(ids)
11360            IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
11361               IF ( av == 0 )  THEN
11362                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinl(isurf)
11363               ELSE
11364                  local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinl_av(isurf)
11365               ENDIF
11366            ENDIF
11367         ENDDO
11368
11369      CASE ( 'rtm_rad_pc_inlw' )
11370!--      array of lw radiation absorbed by plant canopy
11371         DO ipcgb = 1, npcbl
11372            IF ( av == 0 )  THEN
11373               local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinlw(ipcgb)
11374            ELSE
11375               local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinlw_av(ipcgb)
11376            ENDIF
11377         ENDDO
11378
11379      CASE ( 'rtm_rad_pc_insw' )
11380!--      array of sw radiation absorbed by plant canopy
11381         DO ipcgb = 1, npcbl
11382            IF ( av == 0 )  THEN
11383              local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinsw(ipcgb)
11384            ELSE
11385              local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinsw_av(ipcgb)
11386            ENDIF
11387         ENDDO
11388
11389      CASE ( 'rtm_rad_pc_inswdir' )
11390!--      array of direct sw radiation absorbed by plant canopy
11391         DO ipcgb = 1, npcbl
11392            IF ( av == 0 )  THEN
11393               local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdir(ipcgb)
11394            ELSE
11395               local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdir_av(ipcgb)
11396            ENDIF
11397         ENDDO
11398
11399      CASE ( 'rtm_rad_pc_inswdif' )
11400!--      array of diffuse sw radiation absorbed by plant canopy
11401         DO ipcgb = 1, npcbl
11402            IF ( av == 0 )  THEN
11403               local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdif(ipcgb)
11404            ELSE
11405               local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdif_av(ipcgb)
11406            ENDIF
11407         ENDDO
11408
11409      CASE ( 'rtm_rad_pc_inswref' )
11410!--      array of reflected sw radiation absorbed by plant canopy
11411         DO ipcgb = 1, npcbl
11412            IF ( av == 0 )  THEN
11413               local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = &
11414                                    pcbinsw(ipcgb) - pcbinswdir(ipcgb) - pcbinswdif(ipcgb)
11415            ELSE
11416               local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswref_av(ipcgb)
11417            ENDIF
11418         ENDDO
11419
11420      CASE ( 'rtm_mrt_sw' )
11421         local_pf = REAL( fill_value, KIND = wp )
11422         IF ( av == 0 )  THEN
11423            DO  l = 1, nmrtbl
11424               local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinsw(l)
11425            ENDDO
11426         ELSE
11427            IF ( ALLOCATED( mrtinsw_av ) ) THEN
11428               DO  l = 1, nmrtbl
11429                  local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinsw_av(l)
11430               ENDDO
11431            ENDIF
11432         ENDIF
11433
11434      CASE ( 'rtm_mrt_lw' )
11435         local_pf = REAL( fill_value, KIND = wp )
11436         IF ( av == 0 )  THEN
11437            DO  l = 1, nmrtbl
11438               local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinlw(l)
11439            ENDDO
11440         ELSE
11441            IF ( ALLOCATED( mrtinlw_av ) ) THEN
11442               DO  l = 1, nmrtbl
11443                  local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinlw_av(l)
11444               ENDDO
11445            ENDIF
11446         ENDIF
11447
11448      CASE ( 'rtm_mrt' )
11449         local_pf = REAL( fill_value, KIND = wp )
11450         IF ( av == 0 )  THEN
11451            DO  l = 1, nmrtbl
11452               local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrt(l)
11453            ENDDO
11454         ELSE
11455            IF ( ALLOCATED( mrt_av ) ) THEN
11456               DO  l = 1, nmrtbl
11457                  local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrt_av(l)
11458               ENDDO
11459            ENDIF
11460         ENDIF
11461!         
11462!--   block of RTM output variables
11463!--   variables are intended mainly for debugging and detailed analyse purposes
11464      CASE ( 'rtm_skyvf' )
11465!     
11466!--      sky view factor
11467         DO isurf = dirstart(ids), dirend(ids)
11468            IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
11469               local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = skyvf(isurf)
11470            ENDIF
11471         ENDDO
11472
11473      CASE ( 'rtm_skyvft' )
11474!
11475!--      sky view factor
11476         DO isurf = dirstart(ids), dirend(ids)
11477            IF ( surfl(id,isurf) == ids )  THEN
11478               local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = skyvft(isurf)
11479            ENDIF
11480         ENDDO
11481
11482      CASE ( 'rtm_svf', 'rtm_dif' )
11483!
11484!--      shape view factors or iradiance factors to selected surface
11485         IF ( TRIM(var)=='rtm_svf' )  THEN
11486             k = 1
11487         ELSE
11488             k = 2
11489         ENDIF
11490         DO isvf = 1, nsvfl
11491            isurflt = svfsurf(1, isvf)
11492            isurfs = svfsurf(2, isvf)
11493
11494            IF ( surf(ix,isurfs) == is  .AND.  surf(iy,isurfs) == js  .AND. surf(iz,isurfs) == ks  .AND. &
11495                 (surf(id,isurfs) == idsint_u .OR. surfl(id,isurfs) == idsint_l ) ) THEN
11496!
11497!--            correct source surface
11498               local_pf(surfl(ix,isurflt),surfl(iy,isurflt),surfl(iz,isurflt)) = svf(k,isvf)
11499            ENDIF
11500         ENDDO
11501
11502      CASE ( 'rtm_surfalb' )
11503!
11504!--      surface albedo
11505         DO isurf = dirstart(ids), dirend(ids)
11506            IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
11507               local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = albedo_surf(isurf)
11508            ENDIF
11509         ENDDO
11510
11511      CASE ( 'rtm_surfemis' )
11512!
11513!--      surface emissivity, weighted average
11514         DO isurf = dirstart(ids), dirend(ids)
11515            IF ( surfl(id,isurf) == idsint_u  .OR.  surfl(id,isurf) == idsint_l )  THEN
11516               local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = emiss_surf(isurf)
11517            ENDIF
11518         ENDDO
11519
11520      CASE DEFAULT
11521         found = .FALSE.
11522
11523    END SELECT
11524
11525
11526 END SUBROUTINE radiation_data_output_3d
11527
11528!------------------------------------------------------------------------------!
11529!
11530! Description:
11531! ------------
11532!> Subroutine defining masked data output
11533!------------------------------------------------------------------------------!
11534 SUBROUTINE radiation_data_output_mask( av, variable, found, local_pf, mid )
11535 
11536    USE control_parameters
11537       
11538    USE indices
11539   
11540    USE kinds
11541   
11542
11543    IMPLICIT NONE
11544
11545    CHARACTER (LEN=*) ::  variable   !<
11546
11547    CHARACTER(LEN=5) ::  grid        !< flag to distinquish between staggered grids
11548
11549    INTEGER(iwp) ::  av              !<
11550    INTEGER(iwp) ::  i               !<
11551    INTEGER(iwp) ::  j               !<
11552    INTEGER(iwp) ::  k               !<
11553    INTEGER(iwp) ::  mid             !< masked output running index
11554    INTEGER(iwp) ::  topo_top_index  !< k index of highest horizontal surface
11555
11556    LOGICAL ::  found                !< true if output array was found
11557    LOGICAL ::  resorted             !< true if array is resorted
11558
11559
11560    REAL(wp),                                                                  &
11561       DIMENSION(mask_size_l(mid,1),mask_size_l(mid,2),mask_size_l(mid,3)) ::  &
11562          local_pf   !<
11563
11564    REAL(wp), DIMENSION(:,:,:), POINTER ::  to_be_resorted  !< points to array which needs to be resorted for output
11565
11566
11567    found    = .TRUE.
11568    grid     = 's'
11569    resorted = .FALSE.
11570
11571    SELECT CASE ( TRIM( variable ) )
11572
11573
11574       CASE ( 'rad_lw_in' )
11575          IF ( av == 0 )  THEN
11576             to_be_resorted => rad_lw_in
11577          ELSE
11578             to_be_resorted => rad_lw_in_av
11579          ENDIF
11580
11581       CASE ( 'rad_lw_out' )
11582          IF ( av == 0 )  THEN
11583             to_be_resorted => rad_lw_out
11584          ELSE
11585             to_be_resorted => rad_lw_out_av
11586          ENDIF
11587
11588       CASE ( 'rad_lw_cs_hr' )
11589          IF ( av == 0 )  THEN
11590             to_be_resorted => rad_lw_cs_hr
11591          ELSE
11592             to_be_resorted => rad_lw_cs_hr_av
11593          ENDIF
11594
11595       CASE ( 'rad_lw_hr' )
11596          IF ( av == 0 )  THEN
11597             to_be_resorted => rad_lw_hr
11598          ELSE
11599             to_be_resorted => rad_lw_hr_av
11600          ENDIF
11601
11602       CASE ( 'rad_sw_in' )
11603          IF ( av == 0 )  THEN
11604             to_be_resorted => rad_sw_in
11605          ELSE
11606             to_be_resorted => rad_sw_in_av
11607          ENDIF
11608
11609       CASE ( 'rad_sw_out' )
11610          IF ( av == 0 )  THEN
11611             to_be_resorted => rad_sw_out
11612          ELSE
11613             to_be_resorted => rad_sw_out_av
11614          ENDIF
11615
11616       CASE ( 'rad_sw_cs_hr' )
11617          IF ( av == 0 )  THEN
11618             to_be_resorted => rad_sw_cs_hr
11619          ELSE
11620             to_be_resorted => rad_sw_cs_hr_av
11621          ENDIF
11622
11623       CASE ( 'rad_sw_hr' )
11624          IF ( av == 0 )  THEN
11625             to_be_resorted => rad_sw_hr
11626          ELSE
11627             to_be_resorted => rad_sw_hr_av
11628          ENDIF
11629
11630       CASE DEFAULT
11631          found = .FALSE.
11632
11633    END SELECT
11634
11635!
11636!-- Resort the array to be output, if not done above
11637    IF ( found  .AND.  .NOT. resorted )  THEN
11638       IF ( .NOT. mask_surface(mid) )  THEN
11639!
11640!--       Default masked output
11641          DO  i = 1, mask_size_l(mid,1)
11642             DO  j = 1, mask_size_l(mid,2)
11643                DO  k = 1, mask_size_l(mid,3)
11644                   local_pf(i,j,k) =  to_be_resorted(mask_k(mid,k), &
11645                                      mask_j(mid,j),mask_i(mid,i))
11646                ENDDO
11647             ENDDO
11648          ENDDO
11649
11650       ELSE
11651!
11652!--       Terrain-following masked output
11653          DO  i = 1, mask_size_l(mid,1)
11654             DO  j = 1, mask_size_l(mid,2)
11655!
11656!--             Get k index of highest horizontal surface
11657                topo_top_index = topo_top_ind(mask_j(mid,j), &
11658                                              mask_i(mid,i),   &
11659                                              0 )
11660!
11661!--             Save output array
11662                DO  k = 1, mask_size_l(mid,3)
11663                   local_pf(i,j,k) = to_be_resorted(                         &
11664                                          MIN( topo_top_index+mask_k(mid,k), &
11665                                               nzt+1 ),                      &
11666                                          mask_j(mid,j),                     &
11667                                          mask_i(mid,i)                     )
11668                ENDDO
11669             ENDDO
11670          ENDDO
11671
11672       ENDIF
11673    ENDIF
11674
11675
11676
11677 END SUBROUTINE radiation_data_output_mask
11678
11679
11680!------------------------------------------------------------------------------!
11681! Description:
11682! ------------
11683!> Subroutine writes local (subdomain) restart data
11684!------------------------------------------------------------------------------!
11685 SUBROUTINE radiation_wrd_local
11686
11687
11688    IMPLICIT NONE
11689
11690
11691    IF ( ALLOCATED( rad_net_av ) )  THEN
11692       CALL wrd_write_string( 'rad_net_av' )
11693       WRITE ( 14 )  rad_net_av
11694    ENDIF
11695   
11696    IF ( ALLOCATED( rad_lw_in_xy_av ) )  THEN
11697       CALL wrd_write_string( 'rad_lw_in_xy_av' )
11698       WRITE ( 14 )  rad_lw_in_xy_av
11699    ENDIF
11700   
11701    IF ( ALLOCATED( rad_lw_out_xy_av ) )  THEN
11702       CALL wrd_write_string( 'rad_lw_out_xy_av' )
11703       WRITE ( 14 )  rad_lw_out_xy_av
11704    ENDIF
11705   
11706    IF ( ALLOCATED( rad_sw_in_xy_av ) )  THEN
11707       CALL wrd_write_string( 'rad_sw_in_xy_av' )
11708       WRITE ( 14 )  rad_sw_in_xy_av
11709    ENDIF
11710   
11711    IF ( ALLOCATED( rad_sw_out_xy_av ) )  THEN
11712       CALL wrd_write_string( 'rad_sw_out_xy_av' )
11713       WRITE ( 14 )  rad_sw_out_xy_av
11714    ENDIF
11715
11716    IF ( ALLOCATED( rad_lw_in ) )  THEN
11717       CALL wrd_write_string( 'rad_lw_in' )
11718       WRITE ( 14 )  rad_lw_in
11719    ENDIF
11720
11721    IF ( ALLOCATED( rad_lw_in_av ) )  THEN
11722       CALL wrd_write_string( 'rad_lw_in_av' )
11723       WRITE ( 14 )  rad_lw_in_av
11724    ENDIF
11725
11726    IF ( ALLOCATED( rad_lw_out ) )  THEN
11727       CALL wrd_write_string( 'rad_lw_out' )
11728       WRITE ( 14 )  rad_lw_out
11729    ENDIF
11730
11731    IF ( ALLOCATED( rad_lw_out_av) )  THEN
11732       CALL wrd_write_string( 'rad_lw_out_av' )
11733       WRITE ( 14 )  rad_lw_out_av
11734    ENDIF
11735
11736    IF ( ALLOCATED( rad_lw_cs_hr) )  THEN
11737       CALL wrd_write_string( 'rad_lw_cs_hr' )
11738       WRITE ( 14 )  rad_lw_cs_hr
11739    ENDIF
11740
11741    IF ( ALLOCATED( rad_lw_cs_hr_av) )  THEN
11742       CALL wrd_write_string( 'rad_lw_cs_hr_av' )
11743       WRITE ( 14 )  rad_lw_cs_hr_av
11744    ENDIF
11745
11746    IF ( ALLOCATED( rad_lw_hr) )  THEN
11747       CALL wrd_write_string( 'rad_lw_hr' )
11748       WRITE ( 14 )  rad_lw_hr
11749    ENDIF
11750
11751    IF ( ALLOCATED( rad_lw_hr_av) )  THEN
11752       CALL wrd_write_string( 'rad_lw_hr_av' )
11753       WRITE ( 14 )  rad_lw_hr_av
11754    ENDIF
11755
11756    IF ( ALLOCATED( rad_sw_in) )  THEN
11757       CALL wrd_write_string( 'rad_sw_in' )
11758       WRITE ( 14 )  rad_sw_in
11759    ENDIF
11760
11761    IF ( ALLOCATED( rad_sw_in_av) )  THEN
11762       CALL wrd_write_string( 'rad_sw_in_av' )
11763       WRITE ( 14 )  rad_sw_in_av
11764    ENDIF
11765
11766    IF ( ALLOCATED( rad_sw_out) )  THEN
11767       CALL wrd_write_string( 'rad_sw_out' )
11768       WRITE ( 14 )  rad_sw_out
11769    ENDIF
11770
11771    IF ( ALLOCATED( rad_sw_out_av) )  THEN
11772       CALL wrd_write_string( 'rad_sw_out_av' )
11773       WRITE ( 14 )  rad_sw_out_av
11774    ENDIF
11775
11776    IF ( ALLOCATED( rad_sw_cs_hr) )  THEN
11777       CALL wrd_write_string( 'rad_sw_cs_hr' )
11778       WRITE ( 14 )  rad_sw_cs_hr
11779    ENDIF
11780
11781    IF ( ALLOCATED( rad_sw_cs_hr_av) )  THEN
11782       CALL wrd_write_string( 'rad_sw_cs_hr_av' )
11783       WRITE ( 14 )  rad_sw_cs_hr_av
11784    ENDIF
11785
11786    IF ( ALLOCATED( rad_sw_hr) )  THEN
11787       CALL wrd_write_string( 'rad_sw_hr' )
11788       WRITE ( 14 )  rad_sw_hr
11789    ENDIF
11790
11791    IF ( ALLOCATED( rad_sw_hr_av) )  THEN
11792       CALL wrd_write_string( 'rad_sw_hr_av' )
11793       WRITE ( 14 )  rad_sw_hr_av
11794    ENDIF
11795
11796
11797 END SUBROUTINE radiation_wrd_local
11798
11799!------------------------------------------------------------------------------!
11800! Description:
11801! ------------
11802!> Subroutine reads local (subdomain) restart data
11803!------------------------------------------------------------------------------!
11804 SUBROUTINE radiation_rrd_local( k, nxlf, nxlc, nxl_on_file, nxrf, nxrc,       &
11805                                nxr_on_file, nynf, nync, nyn_on_file, nysf,    &
11806                                nysc, nys_on_file, tmp_2d, tmp_3d, found )
11807 
11808
11809    USE control_parameters
11810       
11811    USE indices
11812   
11813    USE kinds
11814   
11815    USE pegrid
11816
11817
11818    IMPLICIT NONE
11819
11820    INTEGER(iwp) ::  k               !<
11821    INTEGER(iwp) ::  nxlc            !<
11822    INTEGER(iwp) ::  nxlf            !<
11823    INTEGER(iwp) ::  nxl_on_file     !<
11824    INTEGER(iwp) ::  nxrc            !<
11825    INTEGER(iwp) ::  nxrf            !<
11826    INTEGER(iwp) ::  nxr_on_file     !<
11827    INTEGER(iwp) ::  nync            !<
11828    INTEGER(iwp) ::  nynf            !<
11829    INTEGER(iwp) ::  nyn_on_file     !<
11830    INTEGER(iwp) ::  nysc            !<
11831    INTEGER(iwp) ::  nysf            !<
11832    INTEGER(iwp) ::  nys_on_file     !<
11833
11834    LOGICAL, INTENT(OUT)  :: found
11835
11836    REAL(wp), DIMENSION(nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_2d   !<
11837
11838    REAL(wp), DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d   !<
11839
11840    REAL(wp), DIMENSION(0:0,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d2   !<
11841
11842
11843    found = .TRUE.
11844
11845
11846    SELECT CASE ( restart_string(1:length) )
11847
11848       CASE ( 'rad_net_av' )
11849          IF ( .NOT. ALLOCATED( rad_net_av ) )  THEN
11850             ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) )
11851          ENDIF 
11852          IF ( k == 1 )  READ ( 13 )  tmp_2d
11853          rad_net_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp)  =           &
11854                        tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11855                       
11856       CASE ( 'rad_lw_in_xy_av' )
11857          IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) )  THEN
11858             ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) )
11859          ENDIF 
11860          IF ( k == 1 )  READ ( 13 )  tmp_2d
11861          rad_lw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp)  =      &
11862                        tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11863                       
11864       CASE ( 'rad_lw_out_xy_av' )
11865          IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) )  THEN
11866             ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) )
11867          ENDIF 
11868          IF ( k == 1 )  READ ( 13 )  tmp_2d
11869          rad_lw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp)  =     &
11870                        tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11871                       
11872       CASE ( 'rad_sw_in_xy_av' )
11873          IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) )  THEN
11874             ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) )
11875          ENDIF 
11876          IF ( k == 1 )  READ ( 13 )  tmp_2d
11877          rad_sw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp)  =      &
11878                        tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11879                       
11880       CASE ( 'rad_sw_out_xy_av' )
11881          IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) )  THEN
11882             ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) )
11883          ENDIF 
11884          IF ( k == 1 )  READ ( 13 )  tmp_2d
11885          rad_sw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp)  =     &
11886                        tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11887                       
11888       CASE ( 'rad_lw_in' )
11889          IF ( .NOT. ALLOCATED( rad_lw_in ) )  THEN
11890             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
11891                  radiation_scheme == 'constant'   .OR.                    &
11892                  radiation_scheme == 'external' )  THEN
11893                ALLOCATE( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) )
11894             ELSE
11895                ALLOCATE( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11896             ENDIF
11897          ENDIF 
11898          IF ( k == 1 )  THEN
11899             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
11900                  radiation_scheme == 'constant'   .OR.                    &
11901                  radiation_scheme == 'external' )  THEN
11902                READ ( 13 )  tmp_3d2
11903                rad_lw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =   &
11904                   tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11905             ELSE
11906                READ ( 13 )  tmp_3d
11907                rad_lw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =     &
11908                    tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11909             ENDIF
11910          ENDIF
11911
11912       CASE ( 'rad_lw_in_av' )
11913          IF ( .NOT. ALLOCATED( rad_lw_in_av ) )  THEN
11914             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
11915                  radiation_scheme == 'constant'   .OR.                    &
11916                  radiation_scheme == 'external' )  THEN
11917                ALLOCATE( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
11918             ELSE
11919                ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11920             ENDIF
11921          ENDIF 
11922          IF ( k == 1 )  THEN
11923             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
11924                  radiation_scheme == 'constant'   .OR.                    &
11925                  radiation_scheme == 'external' )  THEN
11926                READ ( 13 )  tmp_3d2
11927                rad_lw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&
11928                    tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11929             ELSE
11930                READ ( 13 )  tmp_3d
11931                rad_lw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =  &
11932                    tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11933             ENDIF
11934          ENDIF
11935
11936       CASE ( 'rad_lw_out' )
11937          IF ( .NOT. ALLOCATED( rad_lw_out ) )  THEN
11938             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
11939                  radiation_scheme == 'constant'   .OR.                    &
11940                  radiation_scheme == 'external' )  THEN
11941                ALLOCATE( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) )
11942             ELSE
11943                ALLOCATE( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11944             ENDIF
11945          ENDIF 
11946          IF ( k == 1 )  THEN
11947             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
11948                  radiation_scheme == 'constant'   .OR.                    &
11949                  radiation_scheme == 'external' )  THEN
11950                READ ( 13 )  tmp_3d2
11951                rad_lw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =  &
11952                    tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11953             ELSE
11954                READ ( 13 )  tmp_3d
11955                rad_lw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =    &
11956                    tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11957             ENDIF
11958          ENDIF
11959
11960       CASE ( 'rad_lw_out_av' )
11961          IF ( .NOT. ALLOCATED( rad_lw_out_av ) )  THEN
11962             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
11963                  radiation_scheme == 'constant'   .OR.                    &
11964                  radiation_scheme == 'external' )  THEN
11965                ALLOCATE( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
11966             ELSE
11967                ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11968             ENDIF
11969          ENDIF 
11970          IF ( k == 1 )  THEN
11971             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
11972                  radiation_scheme == 'constant'   .OR.                    &
11973                  radiation_scheme == 'external' )  THEN
11974                READ ( 13 )  tmp_3d2
11975                rad_lw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) &
11976                   = tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11977             ELSE
11978                READ ( 13 )  tmp_3d
11979                rad_lw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
11980                    tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11981             ENDIF
11982          ENDIF
11983
11984       CASE ( 'rad_lw_cs_hr' )
11985          IF ( .NOT. ALLOCATED( rad_lw_cs_hr ) )  THEN
11986             ALLOCATE( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11987          ENDIF
11988          IF ( k == 1 )  READ ( 13 )  tmp_3d
11989          rad_lw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =        &
11990                  tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11991
11992       CASE ( 'rad_lw_cs_hr_av' )
11993          IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) )  THEN
11994             ALLOCATE( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
11995          ENDIF
11996          IF ( k == 1 )  READ ( 13 )  tmp_3d
11997          rad_lw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =     &
11998                  tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
11999
12000       CASE ( 'rad_lw_hr' )
12001          IF ( .NOT. ALLOCATED( rad_lw_hr ) )  THEN
12002             ALLOCATE( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12003          ENDIF
12004          IF ( k == 1 )  READ ( 13 )  tmp_3d
12005          rad_lw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =           &
12006                  tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12007
12008       CASE ( 'rad_lw_hr_av' )
12009          IF ( .NOT. ALLOCATED( rad_lw_hr_av ) )  THEN
12010             ALLOCATE( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12011          ENDIF
12012          IF ( k == 1 )  READ ( 13 )  tmp_3d
12013          rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =        &
12014                  tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12015
12016       CASE ( 'rad_sw_in' )
12017          IF ( .NOT. ALLOCATED( rad_sw_in ) )  THEN
12018             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
12019                  radiation_scheme == 'constant'   .OR.                    &
12020                  radiation_scheme == 'external' )  THEN
12021                ALLOCATE( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) )
12022             ELSE
12023                ALLOCATE( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12024             ENDIF
12025          ENDIF 
12026          IF ( k == 1 )  THEN
12027             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
12028                  radiation_scheme == 'constant'   .OR.                    &
12029                  radiation_scheme == 'external' )  THEN
12030                READ ( 13 )  tmp_3d2
12031                rad_sw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =   &
12032                    tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12033             ELSE
12034                READ ( 13 )  tmp_3d
12035                rad_sw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =     &
12036                    tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12037             ENDIF
12038          ENDIF
12039
12040       CASE ( 'rad_sw_in_av' )
12041          IF ( .NOT. ALLOCATED( rad_sw_in_av ) )  THEN
12042             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
12043                  radiation_scheme == 'constant'   .OR.                    &
12044                  radiation_scheme == 'external' )  THEN
12045                ALLOCATE( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) )
12046             ELSE
12047                ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12048             ENDIF
12049          ENDIF 
12050          IF ( k == 1 )  THEN
12051             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
12052                  radiation_scheme == 'constant'   .OR.                    &
12053                  radiation_scheme == 'external' )  THEN
12054                READ ( 13 )  tmp_3d2
12055                rad_sw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&
12056                    tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12057             ELSE
12058                READ ( 13 )  tmp_3d
12059                rad_sw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =  &
12060                    tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12061             ENDIF
12062          ENDIF
12063
12064       CASE ( 'rad_sw_out' )
12065          IF ( .NOT. ALLOCATED( rad_sw_out ) )  THEN
12066             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
12067                  radiation_scheme == 'constant'   .OR.                    &
12068                  radiation_scheme == 'external' )  THEN
12069                ALLOCATE( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) )
12070             ELSE
12071                ALLOCATE( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12072             ENDIF
12073          ENDIF 
12074          IF ( k == 1 )  THEN
12075             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
12076                  radiation_scheme == 'constant'   .OR.                    &
12077                  radiation_scheme == 'external' )  THEN
12078                READ ( 13 )  tmp_3d2
12079                rad_sw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =  &
12080                    tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12081             ELSE
12082                READ ( 13 )  tmp_3d
12083                rad_sw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =    &
12084                    tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12085             ENDIF
12086          ENDIF
12087
12088       CASE ( 'rad_sw_out_av' )
12089          IF ( .NOT. ALLOCATED( rad_sw_out_av ) )  THEN
12090             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
12091                  radiation_scheme == 'constant'   .OR.                    &
12092                  radiation_scheme == 'external' )  THEN
12093                ALLOCATE( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) )
12094             ELSE
12095                ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12096             ENDIF
12097          ENDIF 
12098          IF ( k == 1 )  THEN
12099             IF ( radiation_scheme == 'clear-sky'  .OR.                    &
12100                  radiation_scheme == 'constant'   .OR.                    &
12101                  radiation_scheme == 'external' )  THEN
12102                READ ( 13 )  tmp_3d2
12103                rad_sw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) &
12104                   = tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12105             ELSE
12106                READ ( 13 )  tmp_3d
12107                rad_sw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = &
12108                    tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12109             ENDIF
12110          ENDIF
12111
12112       CASE ( 'rad_sw_cs_hr' )
12113          IF ( .NOT. ALLOCATED( rad_sw_cs_hr ) )  THEN
12114             ALLOCATE( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12115          ENDIF
12116          IF ( k == 1 )  READ ( 13 )  tmp_3d
12117          rad_sw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =        &
12118                  tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12119
12120       CASE ( 'rad_sw_cs_hr_av' )
12121          IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) )  THEN
12122             ALLOCATE( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12123          ENDIF
12124          IF ( k == 1 )  READ ( 13 )  tmp_3d
12125          rad_sw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =     &
12126                  tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12127
12128       CASE ( 'rad_sw_hr' )
12129          IF ( .NOT. ALLOCATED( rad_sw_hr ) )  THEN
12130             ALLOCATE( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12131          ENDIF
12132          IF ( k == 1 )  READ ( 13 )  tmp_3d
12133          rad_sw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =           &
12134                  tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12135
12136       CASE ( 'rad_sw_hr_av' )
12137          IF ( .NOT. ALLOCATED( rad_sw_hr_av ) )  THEN
12138             ALLOCATE( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) )
12139          ENDIF
12140          IF ( k == 1 )  READ ( 13 )  tmp_3d
12141          rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =        &
12142                  tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)
12143
12144       CASE DEFAULT
12145
12146          found = .FALSE.
12147
12148    END SELECT
12149
12150 END SUBROUTINE radiation_rrd_local
12151
12152
12153 END MODULE radiation_model_mod
Note: See TracBrowser for help on using the repository browser.