- Timestamp:
- Aug 5, 2020 3:42:28 PM (5 years ago)
- File:
-
- 1 edited
-
palm/trunk/SOURCE/radiation_model_mod.f90 (modified) (234 diffs)
Legend:
- Unmodified
- Added
- Removed
-
TabularUnified palm/trunk/SOURCE/radiation_model_mod.f90 ¶
r4632 r4634 1 1 !> @file radiation_model_mod.f90 2 !------------------------------------------------------------------------------ --------------------!2 !------------------------------------------------------------------------------! 3 3 ! This file is part of the PALM model system. 4 4 ! 5 ! PALM is free software: you can redistribute it and/or modify it under the terms of the GNU General 6 ! Public License as published by the Free Software Foundation, either version 3 of the License, or 7 ! (at your option) any later version. 8 ! 9 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the 10 ! implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General 11 ! Public License for more details. 12 ! 13 ! You should have received a copy of the GNU General Public License along with PALM. If not, see 14 ! <http://www.gnu.org/licenses/>. 15 ! 16 ! Copyright 2015-2020 Institute of Computer Science of the Czech Academy of Sciences, Prague 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-2020 Institute of Computer Science of the 18 ! Czech Academy of Sciences, Prague 17 19 ! Copyright 2015-2020 Czech Technical University in Prague 18 20 ! Copyright 1997-2020 Leibniz Universitaet Hannover 19 !--------------------------------------------------------------------------------------------------! 20 ! 21 !------------------------------------------------------------------------------! 21 22 ! 22 23 ! Current revisions: 23 ! ----------------- 24 ! ------------------ 24 25 ! 25 26 ! … … 29 30 ! - Bugfix: rtm_svf_, rtm_dif_ outputs 30 31 ! - Bugfix: correct average transparency for MRT factors 31 ! 32 ! 4624 2020-07-24 09:53:17Z raasch 33 ! File re-formatted to follow the PALM coding standard 34 ! 32 ! 35 33 ! 4587 2020-07-06 08:53:45Z pavelkrc 36 34 ! RTM version 3.1 (see also previous commits): 37 ! - Rotation_angle supported38 ! - Plant canopy box count minimized39 ! - Multiple enhancements and bugfixes40 ! 35 ! - rotation_angle supported 36 ! - plant canopy box count minimized 37 ! - multiple enhancements and bugfixes 38 ! 41 39 ! 4584 2020-06-29 13:16:14Z pavelkrc 42 40 ! Consider only boxes with LAD>0 as plant canopy (credit: S. Schubert) 43 ! 41 ! 44 42 ! 4576 2020-06-24 17:58:55Z pavelkrc 45 43 ! Allow the use of rotation_angle in RTM 46 ! 44 ! 47 45 ! 4574 2020-06-24 16:33:32Z pavelkrc 48 46 ! - Restructure code in radiation_check_data_output 49 47 ! - Move calculation of MPI global array offsets to a subroutine 50 ! 48 ! 51 49 ! 4571 2020-06-24 08:59:06Z sebschub 52 50 ! Bugfix in vertical lad_s coordinate 53 ! 51 ! 54 52 ! 4558 2020-06-10 16:27:30Z moh.hefny 55 ! Bugfix: - Reset RTM output average values after each averaging timestep to zero56 ! - Correct calculation of rtm_rad_net_av57 ! 53 ! Bugfix: - reset RTM output average values after each averaging timestep to zero 54 ! - correct calculation of rtm_rad_net_av 55 ! 58 56 ! 4555 2020-06-05 21:52:00Z moh.hefny 59 57 ! Bugfix in averaging PC and MRT related quantities 60 ! 58 ! 61 59 ! 4552 2020-06-02 20:33:29Z moh.hefny 62 60 ! Bugfix in IF statement in the emissivity coupling parameter for radiation-RTM 63 ! 61 ! 64 62 ! 4535 2020-05-15 12:07:23Z raasch 65 ! Bugfix for restart data format query66 ! 63 ! bugfix for restart data format query 64 ! 67 65 ! 4531 2020-05-13 09:52:22Z moh.hefny 68 66 ! Bugfix in gather flux pabs_pc_lwdif in non_parallel case 69 67 ! 70 68 ! 4529 2020-05-12 09:14:57Z moh.hefny 71 ! - Added the following new features to the coupling of RTM-radiation model:72 ! 1) Considering the vegetation interaction with LW in the coupling73 ! 2) Considering PC emissivity in calculating the effective emissivity74 ! 3) New algorithm for claculating the coupling parameters so that each term is calculated within75 ! i ts original line and not at the end.76 ! - Minor formatting and comments changes77 ! 69 ! - added the following new features to the coupling of RTM-radiation model: 70 ! 1) considering the vegetation interaction with LW in the coupling 71 ! 2) considering PC emissivity in calculating the effective emissivity 72 ! 3) new algorithm for claculating the coupling parameters so that each term 73 ! is calculated within its original line and not at the end. 74 ! - minor formatting and comments changes 75 ! 78 76 ! 4517 2020-05-03 14:29:30Z raasch 79 ! Added restart with MPI-IO for reading local arrays80 ! 77 ! added restart with MPI-IO for reading local arrays 78 ! 81 79 ! 4495 2020-04-13 20:11:20Z raasch 82 ! Restart data handling with MPI-IO added83 ! 80 ! restart data handling with MPI-IO added 81 ! 84 82 ! 4493 2020-04-10 09:49:43Z pavelkrc 85 83 ! Avoid unstable direct normal radiation near horizon 86 ! 84 ! 87 85 ! 4481 2020-03-31 18:55:54Z maronga 88 ! Use statement for exchange horiz added89 ! 86 ! use statement for exchange horiz added 87 ! 90 88 ! 4452 2020-03-10 20:15:32Z suehring 91 89 ! Bugfix in calc_albedo 92 90 ! 93 91 ! 4442 2020-03-04 19:21:13Z suehring 94 ! - Change order of dimension in surface arrays %frac, %emissivity and %albedo to allow for better95 ! vectorization in the radiation interactions.92 ! - Change order of dimension in surface arrays %frac, %emissivity and %albedo 93 ! to allow for better vectorization in the radiation interactions. 96 94 ! - Minor formatting issues 97 95 ! 98 96 ! 4441 2020-03-04 19:20:35Z suehring 99 ! Bugfixes: cpp-directives for serial mode moved, small changes to get serial mode compiled97 ! bugfixes: cpp-directives for serial mode moved, small changes to get serial mode compiled 100 98 ! 101 99 ! 4400 2020-02-10 20:32:41Z suehring … … 108 106 ! 109 107 ! 4360 2020-01-07 11:25:50Z suehring 110 ! Renamed pc_heating_rate, pc_transpiration_rate, pc_transpiration_rate to pcm_heating_rate,111 ! pcm_ latent_rate, pcm_transpiration_rate108 ! Renamed pc_heating_rate, pc_transpiration_rate, pc_transpiration_rate to 109 ! pcm_heating_rate, pcm_latent_rate, pcm_transpiration_rate 112 110 ! 113 111 ! 4340 2019-12-16 08:17:03Z Giersch 114 ! Albedo indices for building_surface_pars are now declared as parameters to prevent an error if the115 ! gfortran compiler with -Werror=unused-value is used112 ! Albedo indices for building_surface_pars are now declared as parameters to 113 ! prevent an error if the gfortran compiler with -Werror=unused-value is used 116 114 ! 117 115 ! 4291 2019-11-11 12:36:54Z moh.hefny 118 ! Enabled RTM in case of biometeorology even if there is no vertical surfaces or 3D vegetation in119 ! the domain116 ! Enabled RTM in case of biometeorology even if there is no vertical 117 ! surfaces or 3D vegetation in the domain 120 118 ! 121 119 ! 4286 2019-10-30 16:01:14Z resler … … 134 132 ! 135 133 ! 4227 2019-09-10 18:04:34Z gronemeier 136 ! Implement new palm_date_time_mod134 ! implement new palm_date_time_mod 137 135 ! 138 136 ! 4226 2019-09-10 17:03:24Z suehring … … 143 141 ! - Revise steering of splitting diffuse and direct radiation 144 142 ! - Bugfixes in checks 145 ! - Optimize mapping of radiation components onto 2D arrays, avoid unnecessary operations 143 ! - Optimize mapping of radiation components onto 2D arrays, avoid unnecessary 144 ! operations 146 145 ! 147 146 ! 4208 2019-09-02 09:01:07Z suehring 148 ! Bugfix in accessing albedo_pars in the clear-sky branch (merge from branch resler) 147 ! Bugfix in accessing albedo_pars in the clear-sky branch 148 ! (merge from branch resler) 149 149 ! 150 150 ! 4198 2019-08-29 15:17:48Z gronemeier … … 155 155 ! 156 156 ! 4190 2019-08-27 15:42:37Z suehring 157 ! Implement external radiation forcing also for level-of-detail = 2 (horizontally 2D radiation) 157 ! Implement external radiation forcing also for level-of-detail = 2 158 ! (horizontally 2D radiation) 158 159 ! 159 160 ! 4188 2019-08-26 14:15:47Z suehring … … 161 162 ! 162 163 ! 4187 2019-08-26 12:43:15Z suehring 163 ! - Take external radiation from root domain dynamic input if not provided for each nested domain 164 ! - Take external radiation from root domain dynamic input if not provided for 165 ! each nested domain 164 166 ! - Combine MPI_ALLREDUCE calls to reduce mpi overhead 165 167 ! … … 189 191 ! 190 192 ! 4089 2019-07-11 14:30:27Z suehring 191 ! - Correct level 2 initialization of spectral albedos in rrtmg branch, long- and shortwave albedos192 ! were mixed-up.193 ! - Change order of albedo_pars so that it is now consistent with the defined order of albedo_pars194 ! in PIDS193 ! - Correct level 2 initialization of spectral albedos in rrtmg branch, long- and 194 ! shortwave albedos were mixed-up. 195 ! - Change order of albedo_pars so that it is now consistent with the defined 196 ! order of albedo_pars in PIDS 195 197 ! 196 198 ! 4069 2019-07-01 14:05:51Z Giersch 197 ! Masked output running index mid has been introduced as a local variable to avoid runtime error198 ! (Loop variable has been modified) in time_integration199 ! Masked output running index mid has been introduced as a local variable to 200 ! avoid runtime error (Loop variable has been modified) in time_integration 199 201 ! 200 202 ! 4067 2019-07-01 13:29:25Z suehring … … 205 207 ! 206 208 ! 4008 2019-05-30 09:50:11Z moh.hefny 207 ! Bugfix in check variable when a variable's string is less than 3 characters is processed. All 208 ! variables now are checked if they belong to radiation 209 ! Bugfix in check variable when a variable's string is less than 3 210 ! characters is processed. All variables now are checked if they 211 ! belong to radiation 209 212 ! 210 213 ! 3992 2019-05-22 16:49:38Z suehring 211 ! Bugfix in rrtmg radiation branch in a nested run when the lowest prognistic grid points in a child212 ! domain are all inside topography214 ! Bugfix in rrtmg radiation branch in a nested run when the lowest prognistic 215 ! grid points in a child domain are all inside topography 213 216 ! 214 217 ! 3987 2019-05-22 09:52:13Z kanani … … 222 225 ! 223 226 ! 3885 2019-04-11 11:29:34Z kanani 224 ! Changes related to global restructuring of location messages and introduction of additional debug225 ! messages227 ! Changes related to global restructuring of location messages and introduction 228 ! of additional debug messages 226 229 ! 227 230 ! 3881 2019-04-10 09:31:22Z suehring 228 ! Output of albedo and emissivity moved from USM, bugfixes in initialization of albedo 231 ! Output of albedo and emissivity moved from USM, bugfixes in initialization 232 ! of albedo 229 233 ! 230 234 ! 3861 2019-04-04 06:27:41Z maronga … … 238 242 ! 239 243 ! 3846 2019-04-01 13:55:30Z suehring 240 ! Unused variable removed244 ! unused variable removed 241 245 ! 242 246 ! 3814 2019-03-26 08:40:31Z pavelkrc … … 246 250 ! 247 251 ! 3771 2019-02-28 12:19:33Z raasch 248 ! rrtmg preprocessor for directives moved/added, save attribute added to temporary pointers to avoid249 ! compiler warnings about outlived pointer targets, statement added to avoid compiler warning about250 ! unused variable252 ! rrtmg preprocessor for directives moved/added, save attribute added to temporary 253 ! pointers to avoid compiler warnings about outlived pointer targets, 254 ! statement added to avoid compiler warning about unused variable 251 255 ! 252 256 ! 3769 2019-02-28 10:16:49Z moh.hefny 253 ! Removed unused variables and subroutine radiation_radflux_gridbox257 ! removed unused variables and subroutine radiation_radflux_gridbox 254 258 ! 255 259 ! 3767 2019-02-27 08:18:02Z raasch 256 ! Unused variable for file index removed from rrd-subroutines parameter list260 ! unused variable for file index removed from rrd-subroutines parameter list 257 261 ! 258 262 ! 3760 2019-02-21 18:47:35Z moh.hefny 259 ! Bugfix: initialized simulated_time before calculating solar position to enable restart option with260 ! reading in SVF from file(s).263 ! Bugfix: initialized simulated_time before calculating solar position 264 ! to enable restart option with reading in SVF from file(s). 261 265 ! 262 266 ! 3754 2019-02-19 17:02:26Z kanani 263 267 ! (resler, pavelkrc) 264 ! Bugfixes: add further required MRT factors to read/write_svf, fix for aggregating view factors to 265 ! eliminate local noise in reflected irradiance at mutually close surfaces (corners, presence of 266 ! trees) in the angular discretization scheme. 268 ! Bugfixes: add further required MRT factors to read/write_svf, 269 ! fix for aggregating view factors to eliminate local noise in reflected 270 ! irradiance at mutually close surfaces (corners, presence of trees) in the 271 ! angular discretization scheme. 267 272 ! 268 273 ! 3752 2019-02-19 09:37:22Z resler 269 ! Added read/write number of MRT factors to the respective routines274 ! added read/write number of MRT factors to the respective routines 270 275 ! 271 276 ! 3705 2019-01-29 19:56:39Z suehring … … 279 284 ! 280 285 ! 3655 2019-01-07 16:51:22Z knoop 281 ! Nopointer option removed286 ! nopointer option removed 282 287 ! 283 288 ! 1496 2014-12-02 17:25:50Z maronga … … 285 290 ! 286 291 ! 287 !--------------------------------------------------------------------------------------------------!288 292 ! Description: 289 293 ! ------------ 290 294 !> Radiation models and interfaces: 291 !> Constant, simple and RRTMG models, interface to external radiation model295 !> constant, simple and RRTMG models, interface to external radiation model 292 296 !> Radiative Transfer Model (RTM) version 3.0 for modelling of radiation 293 !> Interactions within urban canopy or other surface layer in complex terrain297 !> interactions within urban canopy or other surface layer in complex terrain 294 298 !> Integrations of RTM with other PALM-4U modules: 295 !> Integration with RRTMG, USM, LSM, PCM, BIO modules299 !> integration with RRTMG, USM, LSM, PCM, BIO modules 296 300 !> 297 !> @todo Move variable definitions used in radiation_init only to the subroutine as they are no298 !> longer required after initialization.301 !> @todo move variable definitions used in radiation_init only to the subroutine 302 !> as they are no longer required after initialization. 299 303 !> @todo Output of full column vertical profiles used in RRTMG 300 304 !> @todo Output of other rrtm arrays (such as volume mixing ratios) 301 305 !> @todo Optimize radiation_tendency routines 302 306 !> 303 !> @note Many variables have a leading dummy dimension (0:0) in order to match the assume-size shape304 !> expected by the RRTMG model.305 !------------------------------------------------------------------------------ --------------------!307 !> @note Many variables have a leading dummy dimension (0:0) in order to 308 !> match the assume-size shape expected by the RRTMG model. 309 !------------------------------------------------------------------------------! 306 310 MODULE radiation_model_mod 307 311 308 USE arrays_3d, & 309 ONLY: dzw, & 310 d_exner, & 311 exner, & 312 hyp, & 313 nc, & 314 pt, & 315 p, & 316 q, & 317 ql, & 318 u, & 319 v, & 320 w, & 321 zu, & 322 zw 323 324 325 326 USE basic_constants_and_equations_mod, & 327 ONLY: barometric_formula, & 328 c_p, & 329 g, & 330 lv_d_cp, & 331 l_v, & 332 pi, & 333 r_d, & 334 rho_l, & 335 sigma_sb, & 336 solar_constant 337 338 339 340 USE calc_mean_profile_mod, & 312 USE arrays_3d, & 313 ONLY: dzw, hyp, nc, pt, p, q, ql, u, v, w, zu, zw, exner, d_exner 314 315 USE basic_constants_and_equations_mod, & 316 ONLY: c_p, g, lv_d_cp, l_v, pi, r_d, rho_l, solar_constant, sigma_sb, & 317 barometric_formula 318 319 USE calc_mean_profile_mod, & 341 320 ONLY: calc_mean_profile 342 321 343 USE control_parameters, & 344 ONLY: biometeorology, & 345 cloud_droplets, & 346 coupling_char, & 347 debug_output, & 348 debug_output_timestep, & 349 debug_string, & 350 dt_3d, & 351 dz, & 352 dt_spinup, & 353 end_time, & 354 humidity, & 355 initializing_actions, & 356 io_blocks, & 357 io_group, & 358 land_surface, & 359 large_scale_forcing, & 360 latitude, & 361 longitude, & 362 lsf_surf, & 363 message_string, & 364 plant_canopy, & 365 pt_surface, & 366 read_svf, & 367 restart_data_format_output, & 368 rho_surface, & 369 simulated_time, & 370 spinup_time, & 371 surface_pressure, & 372 time_since_reference_point, & 373 urban_surface, & 374 varnamelength, & 375 write_svf 376 377 USE cpulog, & 378 ONLY: cpu_log, & 379 log_point, & 380 log_point_s 381 382 USE grid_variables, & 383 ONLY: ddx, & 384 ddy, & 385 dx, & 386 dy 387 388 USE indices, & 389 ONLY: nnx, & 390 nny, & 391 nx, & 392 nxl, & 393 nxlg, & 394 nxr, & 395 nxrg, & 396 ny, & 397 nyn, & 398 nyng, & 399 nys, & 400 nysg, & 401 nzb, & 402 nzt, & 403 topo_top_ind 322 USE control_parameters, & 323 ONLY: biometeorology, cloud_droplets, coupling_char, & 324 debug_output, debug_output_timestep, debug_string, & 325 dt_3d, & 326 dz, dt_spinup, end_time, & 327 humidity, & 328 initializing_actions, io_blocks, io_group, & 329 land_surface, large_scale_forcing, & 330 latitude, longitude, lsf_surf, & 331 message_string, plant_canopy, pt_surface, & 332 rho_surface, simulated_time, spinup_time, surface_pressure, & 333 read_svf, restart_data_format_output, write_svf, & 334 time_since_reference_point, urban_surface, varnamelength 335 336 USE cpulog, & 337 ONLY: cpu_log, log_point, log_point_s 338 339 USE grid_variables, & 340 ONLY: ddx, ddy, dx, dy 341 342 USE indices, & 343 ONLY: nnx, nny, nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, & 344 nzb, nzt, topo_top_ind 404 345 405 346 USE, INTRINSIC :: iso_c_binding … … 407 348 USE kinds 408 349 409 USE bulk_cloud_model_mod, & 410 ONLY: bulk_cloud_model, & 411 microphysics_morrison, & 412 na_init, & 413 nc_const, & 414 sigma_gc 350 USE bulk_cloud_model_mod, & 351 ONLY: bulk_cloud_model, microphysics_morrison, na_init, nc_const, sigma_gc 415 352 416 353 #if defined ( __netcdf ) … … 418 355 #endif 419 356 420 USE netcdf_data_input_mod, & 421 ONLY: albedo_type_f, & 422 albedo_pars_f, & 423 building_type_f, & 424 building_surface_pars_f, & 425 char_fill, & 426 char_lod, & 427 check_existence, & 428 close_input_file, & 429 get_attribute, & 430 get_dimension_length, & 431 get_variable, & 432 inquire_num_variables, & 433 inquire_variable_names, & 434 input_file_dynamic, & 435 input_pids_dynamic, & 436 num_var_pids, & 437 open_read_file, & 438 pavement_type_f, & 439 pids_id, & 440 real_1d_3d, & 441 vars_pids, & 442 vegetation_type_f, & 443 water_type_f 444 445 446 447 USE palm_date_time_mod, & 448 ONLY: date_time_str_len, & 449 get_date_time, & 450 hours_per_day, & 451 seconds_per_hour 452 453 USE plant_canopy_model_mod, & 454 ONLY: lad_s, & 455 pcm_calc_transpiration_rate, & 456 pcm_heating_rate, & 457 pcm_transpiration_rate, & 458 pcm_latent_rate, & 459 plant_canopy_transpiration 460 357 USE netcdf_data_input_mod, & 358 ONLY: albedo_type_f, & 359 albedo_pars_f, & 360 building_type_f, & 361 building_surface_pars_f, & 362 pavement_type_f, & 363 vegetation_type_f, & 364 water_type_f, & 365 char_fill, & 366 char_lod, & 367 check_existence, & 368 close_input_file, & 369 get_attribute, & 370 get_dimension_length, & 371 get_variable, & 372 inquire_num_variables, & 373 inquire_variable_names, & 374 input_file_dynamic, & 375 input_pids_dynamic, & 376 num_var_pids, & 377 pids_id, & 378 open_read_file, & 379 real_1d_3d, & 380 vars_pids 381 382 USE palm_date_time_mod, & 383 ONLY: date_time_str_len, get_date_time, & 384 hours_per_day, seconds_per_hour 385 386 USE plant_canopy_model_mod, & 387 ONLY: lad_s, & 388 pcm_heating_rate, & 389 pcm_transpiration_rate, & 390 pcm_latent_rate, & 391 plant_canopy_transpiration, & 392 pcm_calc_transpiration_rate 461 393 462 394 USE pegrid 463 395 464 396 #if defined ( __rrtmg ) 465 USE parrrsw, & 466 ONLY: naerec, & 467 nbndsw 468 469 USE parrrtm, & 397 USE parrrsw, & 398 ONLY: naerec, nbndsw 399 400 USE parrrtm, & 470 401 ONLY: nbndlw 471 402 472 USE rrtmg_lw_init, 403 USE rrtmg_lw_init, & 473 404 ONLY: rrtmg_lw_ini 474 405 475 USE rrtmg_sw_init, 406 USE rrtmg_sw_init, & 476 407 ONLY: rrtmg_sw_ini 477 408 478 USE rrtmg_lw_rad, 409 USE rrtmg_lw_rad, & 479 410 ONLY: rrtmg_lw 480 411 481 USE rrtmg_sw_rad, 412 USE rrtmg_sw_rad, & 482 413 ONLY: rrtmg_sw 483 414 #endif 484 415 USE restart_data_mpi_io_mod, & 485 ONLY: rd_mpi_io_check_array, & 486 rrd_mpi_io, & 487 wrd_mpi_io 488 489 USE statistics, & 416 ONLY: rd_mpi_io_check_array, rrd_mpi_io, wrd_mpi_io 417 418 USE statistics, & 490 419 ONLY: hom 491 420 492 USE surface_mod, & 493 ONLY: ind_pav_green, & 494 ind_veg_wall, & 495 ind_wat_win, & 496 surf_lsm_h, & 497 surf_lsm_v, & 498 surf_type, & 499 surf_usm_h, & 500 surf_usm_v, & 421 USE surface_mod, & 422 ONLY: ind_pav_green, ind_veg_wall, ind_wat_win, & 423 surf_lsm_h, surf_lsm_v, surf_type, surf_usm_h, surf_usm_v, & 501 424 vertical_surfaces_exist 502 425 503 426 IMPLICIT NONE 504 427 505 CHARACTER(10) :: radiation_scheme = 'clear-sky'! 'constant', 'clear-sky', or 'rrtmg'428 CHARACTER(10) :: radiation_scheme = 'clear-sky' ! 'constant', 'clear-sky', or 'rrtmg' 506 429 507 430 ! 508 431 !-- Predefined Land surface classes (albedo_type) after Briegleb (1992) 509 CHARACTER(37), DIMENSION(0:33), PARAMETER :: albedo_type_name = (/ 510 'user defined ', & !<0511 'ocean ', & !<1512 'mixed farming, tall grassland ', & !<2513 'tall/medium grassland ', & !<3514 'evergreen shrubland ', & !<4515 'short grassland/meadow/shrubland ', & !<5516 'evergreen needleleaf forest ', & !<6517 'mixed deciduous evergreen forest ', & !<7518 'deciduous forest ', & !<8519 'tropical evergreen broadleaved forest', & !<9520 'medium/tall grassland/woodland ', & !<10521 'desert, sandy ', & !<11522 'desert, rocky ', & !<12523 'tundra ', & !<13524 'land ice ', & !<14525 'sea ice ', & !<15526 'snow ', & !<16527 'bare soil ', & !<17528 'asphalt/concrete mix ', & !<18529 'asphalt (asphalt concrete) ', & !<19530 'concrete (Portland concrete) ', & !<20531 'sett ', & !<21532 'paving stones ', & !<22533 'cobblestone ', & !<23534 'metal ', & !<24535 'wood ', & !<25536 'gravel ', & !<26537 'fine gravel ', & !<27538 'pebblestone ', & !<28539 'woodchips ', & !<29540 'tartan (sports) ', & !<30541 'artifical turf (sports) ', & !<31542 'clay (sports) ', & !<32543 'building (dummy) ' & !<33432 CHARACTER(37), DIMENSION(0:33), PARAMETER :: albedo_type_name = (/ & 433 'user defined ', & ! 0 434 'ocean ', & ! 1 435 'mixed farming, tall grassland ', & ! 2 436 'tall/medium grassland ', & ! 3 437 'evergreen shrubland ', & ! 4 438 'short grassland/meadow/shrubland ', & ! 5 439 'evergreen needleleaf forest ', & ! 6 440 'mixed deciduous evergreen forest ', & ! 7 441 'deciduous forest ', & ! 8 442 'tropical evergreen broadleaved forest', & ! 9 443 'medium/tall grassland/woodland ', & ! 10 444 'desert, sandy ', & ! 11 445 'desert, rocky ', & ! 12 446 'tundra ', & ! 13 447 'land ice ', & ! 14 448 'sea ice ', & ! 15 449 'snow ', & ! 16 450 'bare soil ', & ! 17 451 'asphalt/concrete mix ', & ! 18 452 'asphalt (asphalt concrete) ', & ! 19 453 'concrete (Portland concrete) ', & ! 20 454 'sett ', & ! 21 455 'paving stones ', & ! 22 456 'cobblestone ', & ! 23 457 'metal ', & ! 24 458 'wood ', & ! 25 459 'gravel ', & ! 26 460 'fine gravel ', & ! 27 461 'pebblestone ', & ! 28 462 'woodchips ', & ! 29 463 'tartan (sports) ', & ! 30 464 'artifical turf (sports) ', & ! 31 465 'clay (sports) ', & ! 32 466 'building (dummy) ' & ! 33 544 467 /) 545 468 ! 546 !-- Indices of radiation-related input attributes in building_surface_pars (others are in 547 !-- urban_surface_mod) 548 INTEGER(iwp), PARAMETER :: ind_s_alb_b_wall = 19 !< index for Broadband albedo of wall fraction 549 INTEGER(iwp), PARAMETER :: ind_s_alb_l_wall = 20 !< index for Longwave albedo of wall fraction 550 INTEGER(iwp), PARAMETER :: ind_s_alb_s_wall = 21 !< index for Shortwave albedo of wall fraction 551 INTEGER(iwp), PARAMETER :: ind_s_alb_b_win = 22 !< index for Broadband albedo of window fraction 552 INTEGER(iwp), PARAMETER :: ind_s_alb_l_win = 23 !< index for Longwave albedo of window fraction 553 INTEGER(iwp), PARAMETER :: ind_s_alb_s_win = 24 !< index for Shortwave albedo of window fraction 554 INTEGER(iwp), PARAMETER :: ind_s_alb_b_green = 24 !< index for Broadband albedo of green fraction 555 INTEGER(iwp), PARAMETER :: ind_s_alb_l_green = 25 !< index for Longwave albedo of green fraction 556 INTEGER(iwp), PARAMETER :: ind_s_alb_s_green = 26 !< index for Shortwave albedo of green fraction 557 558 INTEGER(iwp) :: albedo_type = 9999999_iwp, & !< Albedo surface type 559 dots_rad = 0_iwp !< starting index for timeseries output 560 INTEGER(iwp) :: day_of_year !< day of the current year 561 562 LOGICAL :: unscheduled_radiation_calls = .TRUE., & !< flag parameter indicating whether additional calls of the radiation 563 !< code are allowed 564 constant_albedo = .FALSE., & !< flag parameter indicating whether the albedo may change depending on 565 !< zenith 566 force_radiation_call = .FALSE., & !< flag parameter for unscheduled radiation calls 567 lw_radiation = .TRUE., & !< flag parameter indicating whether longwave radiation shall be calculated 568 radiation = .FALSE., & !< flag parameter indicating whether the radiation model is used 569 sun_up = .TRUE., & !< flag parameter indicating whether the sun is up or down 570 sw_radiation = .TRUE., & !< flag parameter indicating whether shortwave radiation shall be 571 !< calculated 572 sun_direction = .FALSE., & !< flag parameter indicating whether solar direction shall be calculated 573 average_radiation = .FALSE., & !< flag to set the calculation of radiation averaging for the domain 574 radiation_interactions = .FALSE., & !< flag to activiate RTM (TRUE only if vertical urban/land surface and 575 !< trees exist) 576 surface_reflections = .TRUE., & !< flag to switch the calculation of radiation interaction between 577 !< surfaces. When it switched off, only the effect of buildings and trees 578 !< shadow will be considered. However fewer SVFs are expected. 579 radiation_interactions_on = .TRUE. !< namelist flag to force RTM activiation regardless to vertical urban/ 580 !< land surface and trees 581 582 REAL(wp) :: albedo = 9999999.9_wp, & !< NAMELIST alpha 583 albedo_lw_dif = 9999999.9_wp, & !< NAMELIST aldif 584 albedo_lw_dir = 9999999.9_wp, & !< NAMELIST aldir 585 albedo_sw_dif = 9999999.9_wp, & !< NAMELIST asdif 586 albedo_sw_dir = 9999999.9_wp, & !< NAMELIST asdir 587 decl_1, & !< declination coef. 1 588 decl_2, & !< declination coef. 2 589 decl_3, & !< declination coef. 3 590 dt_radiation = 0.0_wp, & !< radiation model timestep 591 emissivity = 9999999.9_wp, & !< NAMELIST surface emissivity 592 lon = 0.0_wp, & !< longitude in radians 593 lat = 0.0_wp, & !< latitude in radians 594 net_radiation = 0.0_wp, & !< net radiation at surface 595 skip_time_do_radiation = 0.0_wp, & !< Radiation model is not called before this time 596 sky_trans, & !< sky transmissivity 597 time_radiation = 0.0_wp, & !< time since last call of radiation code 598 trace_fluxes_above = -1.0_wp, & !< NAMELIST option for debug tracing of large radiative fluxes (W/m2;W/m3) 599 min_stable_coszen = 0.0262_wp !< 1.5 deg above horizon, eliminates most of circumsolar 600 601 REAL(wp) :: cos_zenith !< cosine of solar zenith angle, also z-coordinate of solar unit vector 602 REAL(wp) :: d_hours_day !< 1 / hours-per-day 603 REAL(wp) :: d_seconds_hour !< 1 / seconds-per-hour 604 REAL(wp) :: second_of_day !< second of the current day 605 REAL(wp) :: sun_dir_lat !< y-coordinate of solar unit vector 606 REAL(wp) :: sun_dir_lon !< x-coordinate of solar unit vector 607 608 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_net_av !< average of net radiation (rad_net) at surface 609 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_xy_av !< average of incoming longwave radiation at surface 610 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_out_xy_av !< average of outgoing longwave radiation at surface 611 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_xy_av !< average of incoming shortwave radiation at surface 612 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_out_xy_av !< average of outgoing shortwave radiation at surface 613 614 REAL(wp), PARAMETER :: emissivity_atm_clsky = 0.8_wp !< emissivity of the clear-sky atmosphere 469 !-- Indices of radiation-related input attributes in building_surface_pars 470 !-- (other are in urban_surface_mod) 471 INTEGER(iwp), PARAMETER :: ind_s_alb_b_wall = 19 !< index for Broadband albedo of wall fraction 472 INTEGER(iwp), PARAMETER :: ind_s_alb_l_wall = 20 !< index for Longwave albedo of wall fraction 473 INTEGER(iwp), PARAMETER :: ind_s_alb_s_wall = 21 !< index for Shortwave albedo of wall fraction 474 INTEGER(iwp), PARAMETER :: ind_s_alb_b_win = 22 !< index for Broadband albedo of window fraction 475 INTEGER(iwp), PARAMETER :: ind_s_alb_l_win = 23 !< index for Longwave albedo of window fraction 476 INTEGER(iwp), PARAMETER :: ind_s_alb_s_win = 24 !< index for Shortwave albedo of window fraction 477 INTEGER(iwp), PARAMETER :: ind_s_alb_b_green = 24 !< index for Broadband albedo of green fraction 478 INTEGER(iwp), PARAMETER :: ind_s_alb_l_green = 25 !< index for Longwave albedo of green fraction 479 INTEGER(iwp), PARAMETER :: ind_s_alb_s_green = 26 !< index for Shortwave albedo of green fraction 480 481 INTEGER(iwp) :: albedo_type = 9999999_iwp, & !< Albedo surface type 482 dots_rad = 0_iwp !< starting index for timeseries output 483 484 LOGICAL :: unscheduled_radiation_calls = .TRUE., & !< flag parameter indicating whether additional calls of the radiation code are allowed 485 constant_albedo = .FALSE., & !< flag parameter indicating whether the albedo may change depending on zenith 486 force_radiation_call = .FALSE., & !< flag parameter for unscheduled radiation calls 487 lw_radiation = .TRUE., & !< flag parameter indicating whether longwave radiation shall be calculated 488 radiation = .FALSE., & !< flag parameter indicating whether the radiation model is used 489 sun_up = .TRUE., & !< flag parameter indicating whether the sun is up or down 490 sw_radiation = .TRUE., & !< flag parameter indicating whether shortwave radiation shall be calculated 491 sun_direction = .FALSE., & !< flag parameter indicating whether solar direction shall be calculated 492 average_radiation = .FALSE., & !< flag to set the calculation of radiation averaging for the domain 493 radiation_interactions = .FALSE., & !< flag to activiate RTM (TRUE only if vertical urban/land surface and trees exist) 494 surface_reflections = .TRUE., & !< flag to switch the calculation of radiation interaction between surfaces. 495 !< When it switched off, only the effect of buildings and trees shadow 496 !< will be considered. However fewer SVFs are expected. 497 radiation_interactions_on = .TRUE. !< namelist flag to force RTM activiation regardless to vertical urban/land surface and trees 498 499 REAL(wp) :: albedo = 9999999.9_wp, & !< NAMELIST alpha 500 albedo_lw_dif = 9999999.9_wp, & !< NAMELIST aldif 501 albedo_lw_dir = 9999999.9_wp, & !< NAMELIST aldir 502 albedo_sw_dif = 9999999.9_wp, & !< NAMELIST asdif 503 albedo_sw_dir = 9999999.9_wp, & !< NAMELIST asdir 504 decl_1, & !< declination coef. 1 505 decl_2, & !< declination coef. 2 506 decl_3, & !< declination coef. 3 507 dt_radiation = 0.0_wp, & !< radiation model timestep 508 emissivity = 9999999.9_wp, & !< NAMELIST surface emissivity 509 lon = 0.0_wp, & !< longitude in radians 510 lat = 0.0_wp, & !< latitude in radians 511 net_radiation = 0.0_wp, & !< net radiation at surface 512 skip_time_do_radiation = 0.0_wp, & !< Radiation model is not called before this time 513 sky_trans, & !< sky transmissivity 514 time_radiation = 0.0_wp, & !< time since last call of radiation code 515 trace_fluxes_above = -1.0_wp, & !< NAMELIST option for debug tracing of large radiative fluxes (W/m2;W/m3) 516 min_stable_coszen = 0.0262_wp !< 1.5 deg above horizon, eliminates most of circumsolar 517 518 INTEGER(iwp) :: day_of_year !< day of the current year 519 520 REAL(wp) :: cos_zenith !< cosine of solar zenith angle, also z-coordinate of solar unit vector 521 REAL(wp) :: d_hours_day !< 1 / hours-per-day 522 REAL(wp) :: d_seconds_hour !< 1 / seconds-per-hour 523 REAL(wp) :: second_of_day !< second of the current day 524 REAL(wp) :: sun_dir_lat !< y-coordinate of solar unit vector 525 REAL(wp) :: sun_dir_lon !< x-coordinate of solar unit vector 526 527 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_net_av !< average of net radiation (rad_net) at surface 528 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_xy_av !< average of incoming longwave radiation at surface 529 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_out_xy_av !< average of outgoing longwave radiation at surface 530 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_xy_av !< average of incoming shortwave radiation at surface 531 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_out_xy_av !< average of outgoing shortwave radiation at surface 532 533 REAL(wp), PARAMETER :: emissivity_atm_clsky = 0.8_wp !< emissivity of the clear-sky atmosphere 615 534 ! 616 535 !-- Land surface albedos for solar zenith angle of 60degree after Briegleb (1992) 617 !-- (broadband, longwave, shortwave ): 618 REAL(wp), DIMENSION(0:2,1:33), PARAMETER :: 619 0.06_wp, 0.06_wp, 0.06_wp, &! 1620 0.19_wp, 0.28_wp, 0.09_wp, &! 2621 0.23_wp, 0.33_wp, 0.11_wp, &! 3622 0.23_wp, 0.33_wp, 0.11_wp, &! 4623 0.25_wp, 0.34_wp, 0.14_wp, &! 5624 0.14_wp, 0.22_wp, 0.06_wp, &! 6625 0.17_wp, 0.27_wp, 0.06_wp, &! 7626 0.19_wp, 0.31_wp, 0.06_wp, &! 8627 0.14_wp, 0.22_wp, 0.06_wp, &! 9628 0.18_wp, 0.28_wp, 0.06_wp, &! 10629 0.43_wp, 0.51_wp, 0.35_wp, &! 11630 0.32_wp, 0.40_wp, 0.24_wp, &! 12631 0.19_wp, 0.27_wp, 0.10_wp, &! 13632 0.77_wp, 0.65_wp, 0.90_wp, &! 14633 0.77_wp, 0.65_wp, 0.90_wp, &! 15634 0.82_wp, 0.70_wp, 0.95_wp, &! 16635 0.08_wp, 0.08_wp, 0.08_wp, &! 17636 0.17_wp, 0.17_wp, 0.17_wp, &! 18637 0.17_wp, 0.17_wp, 0.17_wp, &! 19638 0.30_wp, 0.30_wp, 0.30_wp, &! 20639 0.17_wp, 0.17_wp, 0.17_wp, &! 21640 0.17_wp, 0.17_wp, 0.17_wp, &! 22641 0.17_wp, 0.17_wp, 0.17_wp, &! 23642 0.17_wp, 0.17_wp, 0.17_wp, &! 24643 0.17_wp, 0.17_wp, 0.17_wp, &! 25644 0.17_wp, 0.17_wp, 0.17_wp, &! 26645 0.17_wp, 0.17_wp, 0.17_wp, &! 27646 0.17_wp, 0.17_wp, 0.17_wp, &! 28647 0.17_wp, 0.17_wp, 0.17_wp, &! 29648 0.17_wp, 0.17_wp, 0.17_wp, &! 30649 0.17_wp, 0.17_wp, 0.17_wp, &! 31650 0.17_wp, 0.17_wp, 0.17_wp, &! 32651 0.17_wp, 0.17_wp, 0.17_wp &! 33652 653 654 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: 655 rad_lw_cs_hr, &!< longwave clear sky radiation heating rate (K/s)656 rad_lw_cs_hr_av, &!< average of rad_lw_cs_hr657 rad_lw_hr, &!< longwave radiation heating rate (K/s)658 rad_lw_hr_av, &!< average of rad_sw_hr659 rad_lw_in, &!< incoming longwave radiation (W/m2)660 rad_lw_in_av, &!< average of rad_lw_in661 rad_lw_out, &!< outgoing longwave radiation (W/m2)662 rad_lw_out_av, &!< average of rad_lw_out663 rad_sw_cs_hr, &!< shortwave clear sky radiation heating rate (K/s)664 rad_sw_cs_hr_av, &!< average of rad_sw_cs_hr665 rad_sw_hr, &!< shortwave radiation heating rate (K/s)666 rad_sw_hr_av, &!< average of rad_sw_hr667 rad_sw_in, &!< incoming shortwave radiation (W/m2)668 rad_sw_in_av, &!< average of rad_sw_in669 rad_sw_out, &!< outgoing shortwave radiation (W/m2)670 rad_sw_out_av 536 !-- (broadband, longwave, shortwave ): bb, lw, sw, 537 REAL(wp), DIMENSION(0:2,1:33), PARAMETER :: albedo_pars = RESHAPE( (/& 538 0.06_wp, 0.06_wp, 0.06_wp, & ! 1 539 0.19_wp, 0.28_wp, 0.09_wp, & ! 2 540 0.23_wp, 0.33_wp, 0.11_wp, & ! 3 541 0.23_wp, 0.33_wp, 0.11_wp, & ! 4 542 0.25_wp, 0.34_wp, 0.14_wp, & ! 5 543 0.14_wp, 0.22_wp, 0.06_wp, & ! 6 544 0.17_wp, 0.27_wp, 0.06_wp, & ! 7 545 0.19_wp, 0.31_wp, 0.06_wp, & ! 8 546 0.14_wp, 0.22_wp, 0.06_wp, & ! 9 547 0.18_wp, 0.28_wp, 0.06_wp, & ! 10 548 0.43_wp, 0.51_wp, 0.35_wp, & ! 11 549 0.32_wp, 0.40_wp, 0.24_wp, & ! 12 550 0.19_wp, 0.27_wp, 0.10_wp, & ! 13 551 0.77_wp, 0.65_wp, 0.90_wp, & ! 14 552 0.77_wp, 0.65_wp, 0.90_wp, & ! 15 553 0.82_wp, 0.70_wp, 0.95_wp, & ! 16 554 0.08_wp, 0.08_wp, 0.08_wp, & ! 17 555 0.17_wp, 0.17_wp, 0.17_wp, & ! 18 556 0.17_wp, 0.17_wp, 0.17_wp, & ! 19 557 0.30_wp, 0.30_wp, 0.30_wp, & ! 20 558 0.17_wp, 0.17_wp, 0.17_wp, & ! 21 559 0.17_wp, 0.17_wp, 0.17_wp, & ! 22 560 0.17_wp, 0.17_wp, 0.17_wp, & ! 23 561 0.17_wp, 0.17_wp, 0.17_wp, & ! 24 562 0.17_wp, 0.17_wp, 0.17_wp, & ! 25 563 0.17_wp, 0.17_wp, 0.17_wp, & ! 26 564 0.17_wp, 0.17_wp, 0.17_wp, & ! 27 565 0.17_wp, 0.17_wp, 0.17_wp, & ! 28 566 0.17_wp, 0.17_wp, 0.17_wp, & ! 29 567 0.17_wp, 0.17_wp, 0.17_wp, & ! 30 568 0.17_wp, 0.17_wp, 0.17_wp, & ! 31 569 0.17_wp, 0.17_wp, 0.17_wp, & ! 32 570 0.17_wp, 0.17_wp, 0.17_wp & ! 33 571 /), (/ 3, 33 /) ) 572 573 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: & 574 rad_lw_cs_hr, & !< longwave clear sky radiation heating rate (K/s) 575 rad_lw_cs_hr_av, & !< average of rad_lw_cs_hr 576 rad_lw_hr, & !< longwave radiation heating rate (K/s) 577 rad_lw_hr_av, & !< average of rad_sw_hr 578 rad_lw_in, & !< incoming longwave radiation (W/m2) 579 rad_lw_in_av, & !< average of rad_lw_in 580 rad_lw_out, & !< outgoing longwave radiation (W/m2) 581 rad_lw_out_av, & !< average of rad_lw_out 582 rad_sw_cs_hr, & !< shortwave clear sky radiation heating rate (K/s) 583 rad_sw_cs_hr_av, & !< average of rad_sw_cs_hr 584 rad_sw_hr, & !< shortwave radiation heating rate (K/s) 585 rad_sw_hr_av, & !< average of rad_sw_hr 586 rad_sw_in, & !< incoming shortwave radiation (W/m2) 587 rad_sw_in_av, & !< average of rad_sw_in 588 rad_sw_out, & !< outgoing shortwave radiation (W/m2) 589 rad_sw_out_av !< average of rad_sw_out 671 590 672 591 … … 674 593 !-- Variables and parameters used in RRTMG only 675 594 #if defined ( __rrtmg ) 676 CHARACTER(LEN=12) :: rrtm_input_file = "RAD_SND_DATA"!< name of the NetCDF input file (sounding data)595 CHARACTER(LEN=12) :: rrtm_input_file = "RAD_SND_DATA" !< name of the NetCDF input file (sounding data) 677 596 678 597 679 598 ! 680 599 !-- Flag parameters to be passed to RRTMG (should not be changed until ice phase in clouds is allowed) 681 INTEGER(iwp), PARAMETER :: rrtm_idrv = 1, &!< flag for longwave upward flux calculation option (0,1)682 rrtm_inflglw = 2, &!< flag for lw cloud optical properties (0,1,2)683 rrtm_iceflglw = 0, &!< flag for lw ice particle specifications (0,1,2,3)684 rrtm_liqflglw = 1, &!< flag for lw liquid droplet specifications685 rrtm_inflgsw = 2, &!< flag for sw cloud optical properties (0,1,2)686 rrtm_iceflgsw = 0, &!< flag for sw ice particle specifications (0,1,2,3)687 rrtm_liqflgsw = 1!< flag for sw liquid droplet specifications688 689 ! 690 !-- The following variables should be only changed with care, as this will require further setting691 !-- of some variables, which is currently not implemented (aerosols, ice phase).692 INTEGER(iwp) :: nzt_rad, & !< upper vertical limit for radiation calculations 693 rrtm_icld = 0, & !< cloud flag (0: clear sky column, 1: cloudy column)694 rrtm_i aer = 0 !< aerosol option flag (0: no aerosol layers, for lw only: 6695 !<(requires setting of rrtm_sw_ecaer), 10: one or more aerosol layers (not implemented)696 INTEGER(iwp) :: nc_stat !< local variable for storin the result of netCDF calls for error message handling 697 698 LOGICAL :: snd_exists = .FALSE. !< flag parameter to check whether a user-defined input files exists 699 LOGICAL :: sw_exists = .FALSE. !< flag parameter to check whether that required rrtmg sw fileexists700 LOGICAL :: lw_exists = .FALSE. !< flag parameter to check whether that required rrtmg lw file exists701 702 703 REAL(wp), PARAMETER :: mol_mass_air_d_wv = 1.607793_wp !< molecular weight dry air / water vapor 704 705 REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd, & !< hypostatic pressure from sounding data (hPa) 706 rrtm_tsfc, & !< dummy array for storing surface temperature707 t_snd !< actual temperature from sounding data (hPa)708 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rrtm_ccl4vmr, & !< CCL4 volume mixing ratio (g/mol)709 rrtm_cfc11vmr, & !< CFC11 volume mixing ratio (g/mol) 710 rrtm_cfc12vmr, & !< CFC12volume mixing ratio (g/mol)711 rrtm_cfc22vmr, & !< CFC22volume mixing ratio (g/mol)712 rrtm_ch4vmr, & !< CH4 volume mixing ratio713 rrtm_cicewp, & !< in-cloud ice water path (g/m2)714 rrtm_cldfr, & !< cloud fraction (0,1)715 rrtm_cliqwp, & !< in-cloud liquidwater path (g/m2)716 rrtm_co2vmr, & !< CO2 volume mixing ratio (g/mol)717 rrtm_emis, & !< surface emissivity (0-1)718 rrtm_h2ovmr, & !< H2O volume mixing ratio719 rrtm_n2ovmr, & !< N2O volume mixing ratio720 rrtm_o2vmr, & !< O2volume mixing ratio721 rrtm_o3vmr, & !< O3volume mixing ratio722 rrtm_play, & !< pressure layers (hPa, zu-grid)723 rrtm_plev, & !< pressure layers (hPa, zw-grid)724 rrtm_reice, & !< cloud ice effective radius (microns)725 rrtm_reliq, & !< cloud water drop effective radius (microns)726 rrtm_tlay, & !< actual temperature (K, zu-grid)727 rrtm_tlev, & !< actual temperature (K, zw-grid)728 rrtm_lwdflx, & !< RRTM output of incoming longwave radiation flux (W/m2)729 rrtm_lwdflxc, & !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)730 rrtm_lwuflx, & !< RRTM output of outgoing longwave radiation flux (W/m2)731 rrtm_lwuflxc, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2)732 rrtm_lwuflx_dt, & !< RRTM output of incoming clear skylongwave radiation flux (W/m2)733 rrtm_lwuflxc_dt,& !< RRTM output of outgoing clear sky longwave radiation flux (W/m2)734 rrtm_lwhr, & !< RRTM output of longwave radiation heating rate (K/d)735 rrtm_lwhrc, & !< RRTM output of incoming longwave clear sky radiation heating736 !<rate (K/d)737 rrtm_swdflx, & !< RRTM output of incoming shortwave radiation flux (W/m2)738 rrtm_swdflxc, & !< RRTM output of outgoing clear sky shortwave radiation flux(W/m2)739 rrtm_swuflx, & !< RRTM output of outgoingshortwave radiation flux (W/m2)740 rrtm_swuflxc, & !< RRTM output of incoming clear sky shortwave radiation flux(W/m2)741 rrtm_swhr, & !< RRTM output of shortwave radiation heating rate (K/d)742 rrtm_swhrc, & !< RRTM output of incoming shortwave clear sky radiation heating743 !<rate (K/d)744 rrtm_dirdflux, &!< RRTM output of incoming direct shortwave (W/m2)745 rrtm_difdflux!< RRTM output of incoming diffuse shortwave (W/m2)746 747 REAL(wp), DIMENSION(1) :: rrtm_aldif, &!< surface albedo for longwave diffuse radiation748 rrtm_aldir, &!< surface albedo for longwave direct radiation749 rrtm_asdif, &!< surface albedo for shortwave diffuse radiation750 rrtm_asdir!< surface albedo for shortwave direct radiation600 INTEGER(iwp), PARAMETER :: rrtm_idrv = 1, & !< flag for longwave upward flux calculation option (0,1) 601 rrtm_inflglw = 2, & !< flag for lw cloud optical properties (0,1,2) 602 rrtm_iceflglw = 0, & !< flag for lw ice particle specifications (0,1,2,3) 603 rrtm_liqflglw = 1, & !< flag for lw liquid droplet specifications 604 rrtm_inflgsw = 2, & !< flag for sw cloud optical properties (0,1,2) 605 rrtm_iceflgsw = 0, & !< flag for sw ice particle specifications (0,1,2,3) 606 rrtm_liqflgsw = 1 !< flag for sw liquid droplet specifications 607 608 ! 609 !-- The following variables should be only changed with care, as this will 610 !-- require further setting of some variables, which is currently not 611 !-- implemented (aerosols, ice phase). 612 INTEGER(iwp) :: nzt_rad, & !< upper vertical limit for radiation calculations 613 rrtm_icld = 0, & !< cloud flag (0: clear sky column, 1: cloudy column) 614 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) 615 616 INTEGER(iwp) :: nc_stat !< local variable for storin the result of netCDF calls for error message handling 617 618 LOGICAL :: snd_exists = .FALSE. !< flag parameter to check whether a user-defined input files exists 619 LOGICAL :: sw_exists = .FALSE. !< flag parameter to check whether that required rrtmg sw file exists 620 LOGICAL :: lw_exists = .FALSE. !< flag parameter to check whether that required rrtmg lw file exists 621 622 623 REAL(wp), PARAMETER :: mol_mass_air_d_wv = 1.607793_wp !< molecular weight dry air / water vapor 624 625 REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd, & !< hypostatic pressure from sounding data (hPa) 626 rrtm_tsfc, & !< dummy array for storing surface temperature 627 t_snd !< actual temperature from sounding data (hPa) 628 629 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rrtm_ccl4vmr, & !< CCL4 volume mixing ratio (g/mol) 630 rrtm_cfc11vmr, & !< CFC11 volume mixing ratio (g/mol) 631 rrtm_cfc12vmr, & !< CFC12 volume mixing ratio (g/mol) 632 rrtm_cfc22vmr, & !< CFC22 volume mixing ratio (g/mol) 633 rrtm_ch4vmr, & !< CH4 volume mixing ratio 634 rrtm_cicewp, & !< in-cloud ice water path (g/m2) 635 rrtm_cldfr, & !< cloud fraction (0,1) 636 rrtm_cliqwp, & !< in-cloud liquid water path (g/m2) 637 rrtm_co2vmr, & !< CO2 volume mixing ratio (g/mol) 638 rrtm_emis, & !< surface emissivity (0-1) 639 rrtm_h2ovmr, & !< H2O volume mixing ratio 640 rrtm_n2ovmr, & !< N2O volume mixing ratio 641 rrtm_o2vmr, & !< O2 volume mixing ratio 642 rrtm_o3vmr, & !< O3 volume mixing ratio 643 rrtm_play, & !< pressure layers (hPa, zu-grid) 644 rrtm_plev, & !< pressure layers (hPa, zw-grid) 645 rrtm_reice, & !< cloud ice effective radius (microns) 646 rrtm_reliq, & !< cloud water drop effective radius (microns) 647 rrtm_tlay, & !< actual temperature (K, zu-grid) 648 rrtm_tlev, & !< actual temperature (K, zw-grid) 649 rrtm_lwdflx, & !< RRTM output of incoming longwave radiation flux (W/m2) 650 rrtm_lwdflxc, & !< RRTM output of outgoing clear sky longwave radiation flux (W/m2) 651 rrtm_lwuflx, & !< RRTM output of outgoing longwave radiation flux (W/m2) 652 rrtm_lwuflxc, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2) 653 rrtm_lwuflx_dt, & !< RRTM output of incoming clear sky longwave radiation flux (W/m2) 654 rrtm_lwuflxc_dt,& !< RRTM output of outgoing clear sky longwave radiation flux (W/m2) 655 rrtm_lwhr, & !< RRTM output of longwave radiation heating rate (K/d) 656 rrtm_lwhrc, & !< RRTM output of incoming longwave clear sky radiation heating rate (K/d) 657 rrtm_swdflx, & !< RRTM output of incoming shortwave radiation flux (W/m2) 658 rrtm_swdflxc, & !< RRTM output of outgoing clear sky shortwave radiation flux (W/m2) 659 rrtm_swuflx, & !< RRTM output of outgoing shortwave radiation flux (W/m2) 660 rrtm_swuflxc, & !< RRTM output of incoming clear sky shortwave radiation flux (W/m2) 661 rrtm_swhr, & !< RRTM output of shortwave radiation heating rate (K/d) 662 rrtm_swhrc, & !< RRTM output of incoming shortwave clear sky radiation heating rate (K/d) 663 rrtm_dirdflux, & !< RRTM output of incoming direct shortwave (W/m2) 664 rrtm_difdflux !< RRTM output of incoming diffuse shortwave (W/m2) 665 666 REAL(wp), DIMENSION(1) :: rrtm_aldif, & !< surface albedo for longwave diffuse radiation 667 rrtm_aldir, & !< surface albedo for longwave direct radiation 668 rrtm_asdif, & !< surface albedo for shortwave diffuse radiation 669 rrtm_asdir !< surface albedo for shortwave direct radiation 751 670 752 671 ! 753 672 !-- Definition of arrays that are currently not used for calling RRTMG (due to setting of flag parameters) 754 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rad_lw_cs_in, & 755 rad_lw_cs_out, & 756 rad_sw_cs_in, & 757 rad_sw_cs_out, & 758 rrtm_lw_tauaer, & 759 rrtm_lw_taucld, & 760 rrtm_sw_taucld, & 761 rrtm_sw_ssacld, & 762 rrtm_sw_asmcld, & 763 rrtm_sw_fsfcld, & 764 rrtm_sw_tauaer, & 765 rrtm_sw_ssaaer, & 766 rrtm_sw_asmaer, & 767 rrtm_sw_ecaer 673 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rad_lw_cs_in, & !< incoming clear sky longwave radiation (W/m2) (not used) 674 rad_lw_cs_out, & !< outgoing clear sky longwave radiation (W/m2) (not used) 675 rad_sw_cs_in, & !< incoming clear sky shortwave radiation (W/m2) (not used) 676 rad_sw_cs_out, & !< outgoing clear sky shortwave radiation (W/m2) (not used) 677 rrtm_lw_tauaer, & !< lw aerosol optical depth 678 rrtm_lw_taucld, & !< lw in-cloud optical depth 679 rrtm_sw_taucld, & !< sw in-cloud optical depth 680 rrtm_sw_ssacld, & !< sw in-cloud single scattering albedo 681 rrtm_sw_asmcld, & !< sw in-cloud asymmetry parameter 682 rrtm_sw_fsfcld, & !< sw in-cloud forward scattering fraction 683 rrtm_sw_tauaer, & !< sw aerosol optical depth 684 rrtm_sw_ssaaer, & !< sw aerosol single scattering albedo 685 rrtm_sw_asmaer, & !< sw aerosol asymmetry parameter 686 rrtm_sw_ecaer !< sw aerosol optical detph at 0.55 microns (rrtm_iaer = 6 only) 768 687 769 688 #endif 770 689 ! 771 690 !-- Parameters of urban and land surface models 772 INTEGER(iwp) :: nz_urban !< number of layers of urban surface (will be calculated) 773 INTEGER(iwp) :: nz_plant !< number of layers of plant canopy (will be calculated) 774 INTEGER(iwp) :: nz_urban_b !< bottom layer of urban surface (will be calculated) 775 INTEGER(iwp) :: nz_urban_t !< top layer of urban surface (will be calculated) 776 INTEGER(iwp) :: nz_plant_t !< top layer of plant canopy (will be calculated) 777 !-- Parameters of urban and land surface models 778 INTEGER(iwp), PARAMETER :: nzut_free = 3 !< number of free layers above top of of topography 779 INTEGER(iwp), PARAMETER :: ndsvf = 2 !< number of dimensions of real values in SVF 780 INTEGER(iwp), PARAMETER :: idsvf = 2 !< number of dimensions of integer values in SVF 781 INTEGER(iwp), PARAMETER :: ndcsf = 1 !< number of dimensions of real values in CSF 782 INTEGER(iwp), PARAMETER :: idcsf = 2 !< number of dimensions of integer values in CSF 783 INTEGER(iwp), PARAMETER :: kdcsf = 4 !< number of dimensions of integer values in CSF calculation array 784 INTEGER(iwp), PARAMETER :: id = 1 !< position of d-index in surfl and surf 785 INTEGER(iwp), PARAMETER :: iz = 2 !< position of k-index in surfl and surf 786 INTEGER(iwp), PARAMETER :: iy = 3 !< position of j-index in surfl and surf 787 INTEGER(iwp), PARAMETER :: ix = 4 !< position of i-index in surfl and surf 788 INTEGER(iwp), PARAMETER :: im = 5 !< position of surface m-index in surfl and surf 789 INTEGER(iwp), PARAMETER :: nidx_surf = 5 !< number of indices in surfl and surf 790 INTEGER(iwp), PARAMETER :: nsurf_type = 10 !< number of surf types incl. phys.(land+urban) & (atm.,sky,boundary) surfaces - 1 791 INTEGER(iwp), PARAMETER :: iup_u = 0 !< 0 - index of urban upward surface (ground or roof) 792 INTEGER(iwp), PARAMETER :: idown_u = 1 !< 1 - index of urban downward surface (overhanging) 793 INTEGER(iwp), PARAMETER :: inorth_u = 2 !< 2 - index of urban northward facing wall 794 INTEGER(iwp), PARAMETER :: isouth_u = 3 !< 3 - index of urban southward facing wall 795 INTEGER(iwp), PARAMETER :: ieast_u = 4 !< 4 - index of urban eastward facing wall 796 INTEGER(iwp), PARAMETER :: iwest_u = 5 !< 5 - index of urban westward facing wall 797 INTEGER(iwp), PARAMETER :: iup_l = 6 !< 6 - index of land upward surface (ground or roof) 798 INTEGER(iwp), PARAMETER :: inorth_l = 7 !< 7 - index of land northward facing wall 799 INTEGER(iwp), PARAMETER :: isouth_l = 8 !< 8 - index of land southward facing wall 800 INTEGER(iwp), PARAMETER :: ieast_l = 9 !< 9 - index of land eastward facing wall 801 INTEGER(iwp), PARAMETER :: iwest_l = 10 !< 10- index of land westward facing wall 802 803 INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: idir = (/0, 0,0, 0,1,-1,0,0, 0,1,-1/) !< surface normal direction x indic. 804 INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: jdir = (/0, 0,1,-1,0, 0,0,1,-1,0, 0/) !< surface normal direction y indic. 805 INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: kdir = (/1,-1,0, 0,0, 0,1,0, 0,0, 0/) !< surface normal direction z indic. 806 807 REAL(wp), DIMENSION(0:nsurf_type) :: facearea !< area of single face in respective direction (will be calc'd) 808 809 ! 810 !-- Indices and sizes of urban and land surface models 811 INTEGER(iwp) :: startland !< start index of block of land and roof surfaces 812 INTEGER(iwp) :: endland !< end index of block of land and roof surfaces 813 INTEGER(iwp) :: nlands !< number of land and roof surfaces in local processor 814 INTEGER(iwp) :: startwall !< start index of block of wall surfaces 815 INTEGER(iwp) :: endwall !< end index of block of wall surfaces 816 INTEGER(iwp) :: nwalls !< number of wall surfaces in local processor 817 ! 818 !-- Indices needed for RTM netcdf output subroutines 819 INTEGER(iwp), PARAMETER :: nd = 5 !< 820 821 CHARACTER(LEN=6), DIMENSION(0:nd-1), PARAMETER :: dirname = (/ '_roof ', '_south', '_north', '_west ', '_east ' /) !< 822 823 INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint_u = (/ iup_u, isouth_u, inorth_u, iwest_u, ieast_u /) !< 824 INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint_l = (/ iup_l, isouth_l, inorth_l, iwest_l, ieast_l /) !< 825 826 INTEGER(iwp), DIMENSION(0:nd-1) :: dirstart !< 827 INTEGER(iwp), DIMENSION(0:nd-1) :: dirend !< 828 ! 829 !-- Indices and sizes of urban and land surface models 830 INTEGER(iwp), DIMENSION(:,:), POINTER :: surfl !< coordinates of i-th local surface in local grid 831 !< - surfl[:,k] = [d, z, y, x, m] 832 INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surfl_linear !< dtto (linearly allocated array) 833 INTEGER(iwp), DIMENSION(:,:), POINTER :: surf !< coordinates of i-th surface in grid 834 !< - surf[:,k] = [d, z, y, x, m] 835 INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surf_linear !< dtto (linearly allocated array) 836 INTEGER(iwp) :: nsurfl !< number of all surfaces in local processor 837 INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: nsurfs !< array of number of all surfaces in individual processors 838 INTEGER(iwp) :: nsurf !< global number of surfaces in index array of surfaces 839 !< (nsurf = proc nsurfs) 840 INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surfstart !< starts of blocks of surfaces for individual processors in 841 !< array surf (indexed from 1) 842 !< respective block for particular processor is surfstart[iproc+1]+1 : surfstart[iproc+1]+nsurfs[iproc+1] 843 ! 844 !-- Block variables needed for calculation of the plant canopy model inside the urban surface model 845 INTEGER(iwp) :: npcbl = 0 !< number of the plant canopy gridboxes in local processor 846 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pct !< top layer of the plant canopy 847 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pch !< heights of the plant canopy 848 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pcbl !< k,j,i coordinates of l-th local plant canopy box 849 !< pcbl[:,l] = [k, j, i] 850 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw !< array of absorbed sw radiation for local plant canopy box 851 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdir !< array of absorbed direct sw radiation for local plant canopy box 852 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdif !< array of absorbed diffusion sw radiation for local plant canopy box 853 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw !< array of absorbed lw radiation for local plant canopy box 854 ! 855 !-- Configuration parameters (they can be setup in PALM config) 856 INTEGER(iwp), PARAMETER :: rad_version_len = 10 !< length of identification string of rad version 857 858 CHARACTER(rad_version_len), PARAMETER :: rad_version = 'RAD v. 3.0' !< identification of version of binary svf and restart 859 !< files 860 INTEGER(iwp) :: mrt_nlevels = 0 !< number of vertical boxes above surface for which to calculate MRT 861 INTEGER(iwp) :: svfnorm_report_num !< number of SVF normalization thresholds to report 862 INTEGER(iwp) :: raytrace_discrete_elevs = 40 !< number of discretization steps for elevation (nadir to zenith) 863 INTEGER(iwp) :: raytrace_discrete_azims = 80 !< number of discretization steps for azimuth (out of 360 degrees) 864 INTEGER(wp) :: mrt_geom = 1 !< method for MRT direction weights simulating a sphere or a human body 865 INTEGER(iwp) :: nrefsteps = 3 !< number of reflection steps to perform 866 867 LOGICAL :: raytrace_mpi_rma = .TRUE. !< use MPI RMA to access LAD and gridsurf from remote processes during 868 !< raytracing 869 LOGICAL :: rad_angular_discretization = .TRUE. !< whether to use fixed resolution discretization of view factors for 870 !< reflected radiation (as opposed to all mutually visible pairs) 871 LOGICAL :: plant_lw_interact = .TRUE. !< whether plant canopy interacts with LW radiation (in addition to SW) 872 LOGICAL :: mrt_skip_roof = .TRUE. !< do not calculate MRT above roof surfaces 873 LOGICAL :: mrt_include_sw = .TRUE. !< should MRT calculation include SW radiation as well? 874 875 REAL(wp) :: max_raytracing_dist = -999.0_wp !< maximum distance for raytracing (in metres) 876 REAL(wp) :: min_irrf_value = 1.0E-6_wp !< minimum potential irradiance factor value for raytracing 877 878 REAL(wp), PARAMETER :: ext_coef = 0.6_wp !< extinction coefficient (a.k.a. alpha) 879 880 REAL(wp), DIMENSION(2) :: mrt_geom_params = (/ .12_wp, .88_wp /) !< parameters for the selected method 881 REAL(wp), DIMENSION(1:30) :: svfnorm_report_thresh = 1e21_wp !< thresholds of SVF normalization values to report 882 ! 883 !-- Radiation related arrays to be used in radiation_interaction routine 884 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_dir !< direct sw radiation 885 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_diff !< diffusion sw radiation 886 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_diff !< diffusion lw radiation 887 ! 888 !-- Parameters required for RRTMG lower boundary condition 889 REAL(wp) :: albedo_urb !< albedo value retuned to RRTMG boundary cond. 890 REAL(wp) :: emissivity_urb !< emissivity value retuned to RRTMG boundary cond. 891 REAL(wp) :: t_rad_urb !< temperature value retuned to RRTMG boundary cond. 892 ! 893 !-- Type for calculation of svf 691 INTEGER(iwp) :: nz_urban !< number of layers of urban surface (will be calculated) 692 INTEGER(iwp) :: nz_plant !< number of layers of plant canopy (will be calculated) 693 INTEGER(iwp) :: nz_urban_b !< bottom layer of urban surface (will be calculated) 694 INTEGER(iwp) :: nz_urban_t !< top layer of urban surface (will be calculated) 695 INTEGER(iwp) :: nz_plant_t !< top layer of plant canopy (will be calculated) 696 !-- parameters of urban and land surface models 697 INTEGER(iwp), PARAMETER :: nzut_free = 3 !< number of free layers above top of of topography 698 INTEGER(iwp), PARAMETER :: ndsvf = 2 !< number of dimensions of real values in SVF 699 INTEGER(iwp), PARAMETER :: idsvf = 2 !< number of dimensions of integer values in SVF 700 INTEGER(iwp), PARAMETER :: ndcsf = 1 !< number of dimensions of real values in CSF 701 INTEGER(iwp), PARAMETER :: idcsf = 2 !< number of dimensions of integer values in CSF 702 INTEGER(iwp), PARAMETER :: kdcsf = 4 !< number of dimensions of integer values in CSF calculation array 703 INTEGER(iwp), PARAMETER :: id = 1 !< position of d-index in surfl and surf 704 INTEGER(iwp), PARAMETER :: iz = 2 !< position of k-index in surfl and surf 705 INTEGER(iwp), PARAMETER :: iy = 3 !< position of j-index in surfl and surf 706 INTEGER(iwp), PARAMETER :: ix = 4 !< position of i-index in surfl and surf 707 INTEGER(iwp), PARAMETER :: im = 5 !< position of surface m-index in surfl and surf 708 INTEGER(iwp), PARAMETER :: nidx_surf = 5 !< number of indices in surfl and surf 709 710 INTEGER(iwp), PARAMETER :: nsurf_type = 10 !< number of surf types incl. phys.(land+urban) & (atm.,sky,boundary) surfaces - 1 711 712 INTEGER(iwp), PARAMETER :: iup_u = 0 !< 0 - index of urban upward surface (ground or roof) 713 INTEGER(iwp), PARAMETER :: idown_u = 1 !< 1 - index of urban downward surface (overhanging) 714 INTEGER(iwp), PARAMETER :: inorth_u = 2 !< 2 - index of urban northward facing wall 715 INTEGER(iwp), PARAMETER :: isouth_u = 3 !< 3 - index of urban southward facing wall 716 INTEGER(iwp), PARAMETER :: ieast_u = 4 !< 4 - index of urban eastward facing wall 717 INTEGER(iwp), PARAMETER :: iwest_u = 5 !< 5 - index of urban westward facing wall 718 719 INTEGER(iwp), PARAMETER :: iup_l = 6 !< 6 - index of land upward surface (ground or roof) 720 INTEGER(iwp), PARAMETER :: inorth_l = 7 !< 7 - index of land northward facing wall 721 INTEGER(iwp), PARAMETER :: isouth_l = 8 !< 8 - index of land southward facing wall 722 INTEGER(iwp), PARAMETER :: ieast_l = 9 !< 9 - index of land eastward facing wall 723 INTEGER(iwp), PARAMETER :: iwest_l = 10 !< 10- index of land westward facing wall 724 725 INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: idir = (/0, 0,0, 0,1,-1,0,0, 0,1,-1/) !< surface normal direction x indices 726 INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: jdir = (/0, 0,1,-1,0, 0,0,1,-1,0, 0/) !< surface normal direction y indices 727 INTEGER(iwp), DIMENSION(0:nsurf_type), PARAMETER :: kdir = (/1,-1,0, 0,0, 0,1,0, 0,0, 0/) !< surface normal direction z indices 728 REAL(wp), DIMENSION(0:nsurf_type) :: facearea !< area of single face in respective 729 !< direction (will be calc'd) 730 731 732 !-- indices and sizes of urban and land surface models 733 INTEGER(iwp) :: startland !< start index of block of land and roof surfaces 734 INTEGER(iwp) :: endland !< end index of block of land and roof surfaces 735 INTEGER(iwp) :: nlands !< number of land and roof surfaces in local processor 736 INTEGER(iwp) :: startwall !< start index of block of wall surfaces 737 INTEGER(iwp) :: endwall !< end index of block of wall surfaces 738 INTEGER(iwp) :: nwalls !< number of wall surfaces in local processor 739 740 !-- indices needed for RTM netcdf output subroutines 741 INTEGER(iwp), PARAMETER :: nd = 5 742 CHARACTER(LEN=6), DIMENSION(0:nd-1), PARAMETER :: dirname = (/ '_roof ', '_south', '_north', '_west ', '_east ' /) 743 INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint_u = (/ iup_u, isouth_u, inorth_u, iwest_u, ieast_u /) 744 INTEGER(iwp), DIMENSION(0:nd-1), PARAMETER :: dirint_l = (/ iup_l, isouth_l, inorth_l, iwest_l, ieast_l /) 745 INTEGER(iwp), DIMENSION(0:nd-1) :: dirstart 746 INTEGER(iwp), DIMENSION(0:nd-1) :: dirend 747 748 !-- indices and sizes of urban and land surface models 749 INTEGER(iwp), DIMENSION(:,:), POINTER :: surfl !< coordinates of i-th local surface in local grid - surfl[:,k] = [d, z, y, x, m] 750 INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surfl_linear !< dtto (linearly allocated array) 751 INTEGER(iwp), DIMENSION(:,:), POINTER :: surf !< coordinates of i-th surface in grid - surf[:,k] = [d, z, y, x, m] 752 INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surf_linear !< dtto (linearly allocated array) 753 INTEGER(iwp) :: nsurfl !< number of all surfaces in local processor 754 INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: nsurfs !< array of number of all surfaces in individual processors 755 INTEGER(iwp) :: nsurf !< global number of surfaces in index array of surfaces (nsurf = proc nsurfs) 756 INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: surfstart !< starts of blocks of surfaces for individual processors in array surf (indexed from 1) 757 !< respective block for particular processor is surfstart[iproc+1]+1 : surfstart[iproc+1]+nsurfs[iproc+1] 758 759 !-- block variables needed for calculation of the plant canopy model inside the urban surface model 760 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pct !< top layer of the plant canopy 761 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pch !< heights of the plant canopy 762 INTEGER(iwp) :: npcbl = 0 !< number of the plant canopy gridboxes in local processor 763 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: pcbl !< k,j,i coordinates of l-th local plant canopy box pcbl[:,l] = [k, j, i] 764 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw !< array of absorbed sw radiation for local plant canopy box 765 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdir !< array of absorbed direct sw radiation for local plant canopy box 766 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdif !< array of absorbed diffusion sw radiation for local plant canopy box 767 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw !< array of absorbed lw radiation for local plant canopy box 768 769 !-- configuration parameters (they can be setup in PALM config) 770 LOGICAL :: raytrace_mpi_rma = .TRUE. !< use MPI RMA to access LAD and gridsurf from remote processes during raytracing 771 LOGICAL :: rad_angular_discretization = .TRUE.!< whether to use fixed resolution discretization of view factors for 772 !< reflected radiation (as opposed to all mutually visible pairs) 773 LOGICAL :: plant_lw_interact = .TRUE. !< whether plant canopy interacts with LW radiation (in addition to SW) 774 INTEGER(iwp) :: mrt_nlevels = 0 !< number of vertical boxes above surface for which to calculate MRT 775 LOGICAL :: mrt_skip_roof = .TRUE. !< do not calculate MRT above roof surfaces 776 LOGICAL :: mrt_include_sw = .TRUE. !< should MRT calculation include SW radiation as well? 777 INTEGER(wp) :: mrt_geom = 1 !< method for MRT direction weights simulating a sphere or a human body 778 REAL(wp), DIMENSION(2) :: mrt_geom_params = (/ .12_wp, .88_wp /) !< parameters for the selected method 779 INTEGER(iwp) :: nrefsteps = 3 !< number of reflection steps to perform 780 REAL(wp), PARAMETER :: ext_coef = 0.6_wp !< extinction coefficient (a.k.a. alpha) 781 INTEGER(iwp), PARAMETER :: rad_version_len = 10 !< length of identification string of rad version 782 CHARACTER(rad_version_len), PARAMETER :: rad_version = 'RAD v. 3.0' !< identification of version of binary svf and restart files 783 INTEGER(iwp) :: raytrace_discrete_elevs = 40 !< number of discretization steps for elevation (nadir to zenith) 784 INTEGER(iwp) :: raytrace_discrete_azims = 80 !< number of discretization steps for azimuth (out of 360 degrees) 785 REAL(wp) :: max_raytracing_dist = -999.0_wp !< maximum distance for raytracing (in metres) 786 REAL(wp) :: min_irrf_value = 1e-6_wp !< minimum potential irradiance factor value for raytracing 787 REAL(wp), DIMENSION(1:30) :: svfnorm_report_thresh = 1e21_wp !< thresholds of SVF normalization values to report 788 INTEGER(iwp) :: svfnorm_report_num !< number of SVF normalization thresholds to report 789 790 !-- radiation related arrays to be used in radiation_interaction routine 791 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_dir !< direct sw radiation 792 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_sw_in_diff !< diffusion sw radiation 793 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rad_lw_in_diff !< diffusion lw radiation 794 795 !-- parameters required for RRTMG lower boundary condition 796 REAL(wp) :: albedo_urb !< albedo value retuned to RRTMG boundary cond. 797 REAL(wp) :: emissivity_urb !< emissivity value retuned to RRTMG boundary cond. 798 REAL(wp) :: t_rad_urb !< temperature value retuned to RRTMG boundary cond. 799 800 !-- type for calculation of svf 894 801 TYPE t_svf 895 INTEGER(iwp) :: isurflt!<896 INTEGER(iwp) :: isurfs!<897 REAL(wp) :: rsvf!<898 REAL(wp) :: rtransp!<802 INTEGER(iwp) :: isurflt !< 803 INTEGER(iwp) :: isurfs !< 804 REAL(wp) :: rsvf !< 805 REAL(wp) :: rtransp !< 899 806 END TYPE 900 ! 901 !-- Type for calculation of csf807 808 !-- type for calculation of csf 902 809 TYPE t_csf 903 INTEGER(iwp) :: ip !< 904 INTEGER(iwp) :: itx !< 905 INTEGER(iwp) :: ity !< 906 INTEGER(iwp) :: itz !< 907 INTEGER(iwp) :: isurfs !< Idx of source face / -1 for sky 908 REAL(wp) :: rcvf !< Canopy view factor for faces / canopy sink factor for sky (-1) 810 INTEGER(iwp) :: ip !< 811 INTEGER(iwp) :: itx !< 812 INTEGER(iwp) :: ity !< 813 INTEGER(iwp) :: itz !< 814 INTEGER(iwp) :: isurfs !< Idx of source face / -1 for sky 815 REAL(wp) :: rcvf !< Canopy view factor for faces / 816 !< canopy sink factor for sky (-1) 909 817 END TYPE 910 ! 911 !-- Arrays storing the values of USM 912 INTEGER(iwp) :: ndsidir !< number of apparent solar directions used 913 INTEGER(iwp) :: nmrtbl !< No. of local grid boxes for which MRT is calculated 914 INTEGER(iwp) :: nmrtf !< number of MRT factors for local processor 915 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mrtbl !< coordinates of i-th local MRT box - surfl[:,i] = [z, y, x] 916 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mrtfsurf !< mrtfsurf[:,imrtf] = index of target MRT box and source surface for 917 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: dsidir_rev !< dsidir_rev[ielev,iazim] = i for dsidir or -1 if not present 918 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: svfsurf !< svfsurf[:,isvf] = index of target and source surface for svf[isvf] 919 !< mrtf[imrtf] 920 921 922 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins !< array of sw radiation falling to local surface after i-th 923 !< reflection 924 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl !< array of lw radiation for local surface after i-th reflection 925 REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvf !< array of sky view factor for each local surface 926 REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvft !< array of sky view factor including transparency for each local 927 !< surface 928 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtf !< array of MRT factors for each local MRT box 929 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtft !< array of MRT factors including transparency for each local MRT box 930 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtsky !< array of sky view factor for each local MRT box 931 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtskyt !< array of sky view factor including transparency for each local 932 !< MRT box 933 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinsw !< mean SW radiant flux for each MRT box 934 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinlw !< mean LW radiant flux for each MRT box 935 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt !< mean radiant temperature for each MRT box 936 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinsw_av !< time average mean SW radiant flux for each MRT box 937 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinlw_av !< time average mean LW radiant flux for each MRT box 938 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt_av !< time average mean radiant temperature for each MRT box 939 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw !< array of sw radiation falling to local surface including radiation 940 !< from reflections 941 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw !< array of lw radiation falling to local surface including radiation 942 !< from reflections 943 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir !< array of direct sw radiation falling to local surface 944 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif !< array of diffuse sw radiation from sky and model boundary falling 945 !< to local surface 946 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif !< array of diffuse lw radiation from sky and model boundary falling 947 !< to local surface 948 !< Outward radiation is only valid for nonvirtual surfaces 949 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsl !< array of reflected sw radiation for local surface in i-th 950 !< reflection 951 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutll !< array of reflected + emitted lw radiation for local surface in 952 !< i-th reflection 953 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfouts !< array of reflected sw radiation for all surfaces in i-th 954 !< reflection 955 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutl !< array of reflected + emitted lw radiation for all surfaces in 956 !< i-th reflection 957 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlg !< global array of incoming lw radiation from plant canopy 958 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw !< array of total sw radiation outgoing from nonvirtual surfaces 959 !< surfaces after all reflection 960 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw !< array of total lw radiation outgoing from nonvirtual surfaces 961 !< surfaces after all reflection 962 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfemitlwl !< array of emitted lw radiation for local surface used to calculate 963 !< effective surface temperature for radiation model 964 965 966 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: svf !< array of shape view factors+direct irradiation factors for local 967 !< surfaces 968 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: mrtdsit !< array of direct solar transparencies for each local MRT box 969 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitrans !< dsidir[isvfl,i] = path transmittance of i-th 970 !< direction of direct solar irradiance per target surface 971 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitransc !< dtto per plant canopy box 972 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir !< dsidir[:,i] = unit vector of i-th 973 !< direction of direct solar irradiance 974 ! 975 !-- Block variables needed for calculation of the plant canopy model inside the urban surface model 976 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: csfsurf !< csfsurf[:,icsf] = index of target surface and csf grid index 977 !< for csf[icsf] 978 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csf !< array of plant canopy sink fators + direct irradiation factors 979 !< (transparency) 980 REAL(wp), DIMENSION(:,:,:), POINTER :: sub_lad !< subset of lad_s within urban surface, transformed to plain 981 !< Z coordinate 818 819 !-- arrays storing the values of USM 820 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: svfsurf !< svfsurf[:,isvf] = index of target and source surface for svf[isvf] 821 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: svf !< array of shape view factors+direct irradiation factors for local surfaces 822 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins !< array of sw radiation falling to local surface after i-th reflection 823 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl !< array of lw radiation for local surface after i-th reflection 824 825 REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvf !< array of sky view factor for each local surface 826 REAL(wp), DIMENSION(:), ALLOCATABLE :: skyvft !< array of sky view factor including transparency for each local surface 827 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitrans !< dsidir[isvfl,i] = path transmittance of i-th 828 !< direction of direct solar irradiance per target surface 829 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsitransc !< dtto per plant canopy box 830 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir !< dsidir[:,i] = unit vector of i-th 831 !< direction of direct solar irradiance 832 INTEGER(iwp) :: ndsidir !< number of apparent solar directions used 833 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: dsidir_rev !< dsidir_rev[ielev,iazim] = i for dsidir or -1 if not present 834 835 INTEGER(iwp) :: nmrtbl !< No. of local grid boxes for which MRT is calculated 836 INTEGER(iwp) :: nmrtf !< number of MRT factors for local processor 837 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mrtbl !< coordinates of i-th local MRT box - surfl[:,i] = [z, y, x] 838 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mrtfsurf !< mrtfsurf[:,imrtf] = index of target MRT box and source surface for mrtf[imrtf] 839 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtf !< array of MRT factors for each local MRT box 840 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtft !< array of MRT factors including transparency for each local MRT box 841 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtsky !< array of sky view factor for each local MRT box 842 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtskyt !< array of sky view factor including transparency for each local MRT box 843 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: mrtdsit !< array of direct solar transparencies for each local MRT box 844 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinsw !< mean SW radiant flux for each MRT box 845 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinlw !< mean LW radiant flux for each MRT box 846 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt !< mean radiant temperature for each MRT box 847 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinsw_av !< time average mean SW radiant flux for each MRT box 848 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrtinlw_av !< time average mean LW radiant flux for each MRT box 849 REAL(wp), DIMENSION(:), ALLOCATABLE :: mrt_av !< time average mean radiant temperature for each MRT box 850 851 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw !< array of sw radiation falling to local surface including radiation from reflections 852 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw !< array of lw radiation falling to local surface including radiation from reflections 853 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir !< array of direct sw radiation falling to local surface 854 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif !< array of diffuse sw radiation from sky and model boundary falling to local surface 855 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif !< array of diffuse lw radiation from sky and model boundary falling to local surface 856 857 !< Outward radiation is only valid for nonvirtual surfaces 858 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsl !< array of reflected sw radiation for local surface in i-th reflection 859 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutll !< array of reflected + emitted lw radiation for local surface in i-th reflection 860 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfouts !< array of reflected sw radiation for all surfaces in i-th reflection 861 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutl !< array of reflected + emitted lw radiation for all surfaces in i-th reflection 862 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlg !< global array of incoming lw radiation from plant canopy 863 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw !< array of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection 864 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw !< array of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection 865 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfemitlwl !< array of emitted lw radiation for local surface used to calculate effective surface temperature for radiation model 866 867 !-- block variables needed for calculation of the plant canopy model inside the urban surface model 868 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: csfsurf !< csfsurf[:,icsf] = index of target surface and csf grid index for csf[icsf] 869 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: csf !< array of plant canopy sink fators + direct irradiation factors (transparency) 870 REAL(wp), DIMENSION(:,:,:), POINTER :: sub_lad !< subset of lad_s within urban surface, transformed to plain Z coordinate 982 871 #if defined( __parallel ) 983 REAL(wp), DIMENSION(:), POINTER :: sub_lad_g!< sub_lad globalized (used to avoid MPI RMA calls in raytracing)872 REAL(wp), DIMENSION(:), POINTER :: sub_lad_g !< sub_lad globalized (used to avoid MPI RMA calls in raytracing) 984 873 #endif 985 INTEGER(iwp) :: plantt_max 986 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nzterr, plantt !< temporary global arrays for raytracing 987 988 REAL(wp) :: prototype_lad !< prototype leaf area density for computing effective optical depth 989 ! 990 !-- Arrays and variables for calculation of svf and csf 991 TYPE(t_svf), DIMENSION(:), POINTER :: asvf !< pointer to growing svc array 992 TYPE(t_csf), DIMENSION(:), POINTER :: acsf !< pointer to growing csf array 993 TYPE(t_svf), DIMENSION(:), POINTER :: amrtf !< pointer to growing mrtf array 994 TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: asvf1, asvf2 !< realizations of svf array 995 TYPE(t_csf), DIMENSION(:), ALLOCATABLE, TARGET :: acsf1, acsf2 !< realizations of csf array 996 TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: amrtf1, amrtf2 !< realizations of mftf array 997 998 INTEGER(iwp) :: nsvfla !< dimmension of array allocated for storage of svf in local processor 999 INTEGER(iwp) :: ncsfla !< dimmension of array allocated for storage of csf in local processor 1000 INTEGER(iwp) :: nmrtfa !< dimmension of array allocated for storage of mrt 1001 INTEGER(iwp) :: msvf, mcsf, mmrtf !< mod for swapping the growing array 1002 INTEGER(iwp) :: nsvfl !< number of svf for local processor 1003 INTEGER(iwp) :: ncsfl !< no. of csf in local processor needed only during calc_svf but must be here because 1004 !< it is shared between subroutines calc_svf and raytrace 1005 1006 INTEGER(iwp), PARAMETER :: gasize = 100000_iwp !< initial size of growing arrays 1007 INTEGER(iwp), PARAMETER :: nsurf_type_u = 6 !< number of urban surf types (used in gridsurf) 1008 1009 INTEGER(iwp), DIMENSION(:,:,:,:), POINTER :: gridsurf !< reverse index of local surfl[d,k,j,i] (for case 1010 !< rad_angular_discretization) 1011 INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: gridpcbl !< reverse index of local pcbl[k,j,i] 1012 1013 REAL(wp), PARAMETER :: grow_factor = 1.4_wp !< growth factor of growing arrays 1014 1015 ! 1016 !-- Temporary arrays for calculation of csf in raytracing 1017 INTEGER(iwp) :: maxboxesg !< max number of boxes ray can cross in the domain 1018 1019 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: boxes !< coordinates of gridboxes being crossed by ray 1020 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: lad_ip !< array of numbers of process where lad is stored 1021 1022 REAL(wp), DIMENSION(:), ALLOCATABLE :: crlens !< array of crossing lengths of ray for particular grid boxes 1023 874 REAL(wp) :: prototype_lad !< prototype leaf area density for computing effective optical depth 875 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nzterr, plantt !< temporary global arrays for raytracing 876 INTEGER(iwp) :: plantt_max 877 878 !-- arrays and variables for calculation of svf and csf 879 TYPE(t_svf), DIMENSION(:), POINTER :: asvf !< pointer to growing svc array 880 TYPE(t_csf), DIMENSION(:), POINTER :: acsf !< pointer to growing csf array 881 TYPE(t_svf), DIMENSION(:), POINTER :: amrtf !< pointer to growing mrtf array 882 TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: asvf1, asvf2 !< realizations of svf array 883 TYPE(t_csf), DIMENSION(:), ALLOCATABLE, TARGET :: acsf1, acsf2 !< realizations of csf array 884 TYPE(t_svf), DIMENSION(:), ALLOCATABLE, TARGET :: amrtf1, amrtf2 !< realizations of mftf array 885 INTEGER(iwp) :: nsvfla !< dimmension of array allocated for storage of svf in local processor 886 INTEGER(iwp) :: ncsfla !< dimmension of array allocated for storage of csf in local processor 887 INTEGER(iwp) :: nmrtfa !< dimmension of array allocated for storage of mrt 888 INTEGER(iwp) :: msvf, mcsf, mmrtf!< mod for swapping the growing array 889 INTEGER(iwp), PARAMETER :: gasize = 100000_iwp !< initial size of growing arrays 890 REAL(wp), PARAMETER :: grow_factor = 1.4_wp !< growth factor of growing arrays 891 INTEGER(iwp) :: nsvfl !< number of svf for local processor 892 INTEGER(iwp) :: ncsfl !< no. of csf in local processor 893 !< needed only during calc_svf but must be here because it is 894 !< shared between subroutines calc_svf and raytrace 895 INTEGER(iwp), DIMENSION(:,:,:,:), POINTER :: gridsurf !< reverse index of local surfl[d,k,j,i] (for case rad_angular_discretization) 896 INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: gridpcbl !< reverse index of local pcbl[k,j,i] 897 INTEGER(iwp), PARAMETER :: nsurf_type_u = 6 !< number of urban surf types (used in gridsurf) 898 899 !-- temporary arrays for calculation of csf in raytracing 900 INTEGER(iwp) :: maxboxesg !< max number of boxes ray can cross in the domain 901 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: boxes !< coordinates of gridboxes being crossed by ray 902 REAL(wp), DIMENSION(:), ALLOCATABLE :: crlens !< array of crossing lengths of ray for particular grid boxes 903 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: lad_ip !< array of numbers of process where lad is stored 1024 904 #if defined( __parallel ) 1025 INTEGER(iwp) :: win_lad !< MPI RMA window for leaf area density 1026 INTEGER(iwp) :: win_gridsurf !< MPI RMA window for reverse grid surface index 1027 1028 INTEGER(KIND=MPI_ADDRESS_KIND), DIMENSION(:), ALLOCATABLE :: lad_disp !< array of displaycements of lad in local array of 1029 !< proc lad_ip 1030 REAL(wp), DIMENSION(:), ALLOCATABLE :: lad_s_ray !< array of received lad_s for appropriate gridboxes crossed by ray 905 INTEGER(kind=MPI_ADDRESS_KIND), & 906 DIMENSION(:), ALLOCATABLE :: lad_disp !< array of displaycements of lad in local array of proc lad_ip 907 INTEGER(iwp) :: win_lad !< MPI RMA window for leaf area density 908 INTEGER(iwp) :: win_gridsurf !< MPI RMA window for reverse grid surface index 909 REAL(wp), DIMENSION(:), ALLOCATABLE :: lad_s_ray !< array of received lad_s for appropriate gridboxes crossed by ray 1031 910 #endif 1032 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: target_surfl !< 1033 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: rt2_track !< 1034 1035 REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_track_dist !< 1036 REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_dist !< 1037 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rt2_track_lad !< 1038 ! 1039 !-- Arrays for time averages 1040 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfradnet_av !< average of net radiation to local surface including radiation from 1041 !< reflections 1042 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw_av !< average of sw radiation falling to local surface including radiation 1043 !< from reflections 1044 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw_av !< average of lw radiation falling to local surface including radiation 1045 !< from reflections 1046 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir_av !< average of direct sw radiation falling to local surface 1047 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif_av !< average of diffuse sw radiation from sky and model boundary falling 1048 !< to local surface 1049 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif_av !< average of diffuse lw radiation from sky and model boundary falling 1050 !< to local surface 1051 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswref_av !< average of sw radiation falling to surface from reflections 1052 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwref_av !< average of lw radiation falling to surface from reflections 1053 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw_av !< average of total sw radiation outgoing from nonvirtual surfaces 1054 !< surfaces after all reflection 1055 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw_av !< average of total lw radiation outgoing from nonvirtual surfaces 1056 !< surfaces after all reflection 1057 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins_av !< average of array of residua of sw radiation absorbed in surface after 1058 !< last reflection 1059 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl_av !< average of array of residua of lw radiation absorbed in surface after 1060 !< last reflection 1061 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw_av !< Average of pcbinlw 1062 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw_av !< Average of pcbinsw 1063 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdir_av !< Average of pcbinswdir 1064 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdif_av !< Average of pcbinswdif 1065 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswref_av !< Average of pcbinswref 911 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: target_surfl 912 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: rt2_track 913 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rt2_track_lad 914 REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_track_dist 915 REAL(wp), DIMENSION(:), ALLOCATABLE :: rt2_dist 916 917 !-- arrays for time averages 918 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfradnet_av !< average of net radiation to local surface including radiation from reflections 919 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinsw_av !< average of sw radiation falling to local surface including radiation from reflections 920 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlw_av !< average of lw radiation falling to local surface including radiation from reflections 921 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdir_av !< average of direct sw radiation falling to local surface 922 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswdif_av !< average of diffuse sw radiation from sky and model boundary falling to local surface 923 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwdif_av !< average of diffuse lw radiation from sky and model boundary falling to local surface 924 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinswref_av !< average of sw radiation falling to surface from reflections 925 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinlwref_av !< average of lw radiation falling to surface from reflections 926 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutsw_av !< average of total sw radiation outgoing from nonvirtual surfaces surfaces after all reflection 927 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfoutlw_av !< average of total lw radiation outgoing from nonvirtual surfaces surfaces after all reflection 928 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfins_av !< average of array of residua of sw radiation absorbed in surface after last reflection 929 REAL(wp), DIMENSION(:), ALLOCATABLE :: surfinl_av !< average of array of residua of lw radiation absorbed in surface after last reflection 930 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinlw_av !< Average of pcbinlw 931 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinsw_av !< Average of pcbinsw 932 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdir_av !< Average of pcbinswdir 933 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswdif_av !< Average of pcbinswdif 934 REAL(wp), DIMENSION(:), ALLOCATABLE :: pcbinswref_av !< Average of pcbinswref 1066 935 1067 936 … … 1069 938 !-- Energy balance variables 1070 939 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1071 !-- Parameters of the land, roof and wall surfaces1072 REAL(wp), DIMENSION(:), ALLOCATABLE :: albedo_surf!< albedo of the surface1073 REAL(wp), DIMENSION(:), ALLOCATABLE :: emiss_surf!< emissivity of the wall surface1074 ! 1075 !-- External radiation. Depending on the given level of detail either a 1D or a 3D array will be1076 !-- a llocated.1077 TYPE( real_1d_3d ) :: rad_lw_in_f 1078 TYPE( real_1d_3d ) :: rad_sw_in_f 1079 TYPE( real_1d_3d ) :: rad_sw_in_dif_f 1080 TYPE( real_1d_3d ) :: time_rad_f 940 !-- parameters of the land, roof and wall surfaces 941 REAL(wp), DIMENSION(:), ALLOCATABLE :: albedo_surf !< albedo of the surface 942 REAL(wp), DIMENSION(:), ALLOCATABLE :: emiss_surf !< emissivity of the wall surface 943 ! 944 !-- External radiation. Depending on the given level of detail either a 1D or 945 !-- a 3D array will be allocated. 946 TYPE( real_1d_3d ) :: rad_lw_in_f !< external incoming longwave radiation, from observation or model 947 TYPE( real_1d_3d ) :: rad_sw_in_f !< external incoming shortwave radiation, from observation or model 948 TYPE( real_1d_3d ) :: rad_sw_in_dif_f !< external incoming shortwave radiation, diffuse part, from observation or model 949 TYPE( real_1d_3d ) :: time_rad_f !< time dimension for external radiation, from observation or model 1081 950 1082 951 INTERFACE radiation_check_data_output … … 1191 1060 ! 1192 1061 !-- Public functions / NEEDS SORTING 1193 PUBLIC radiation_check_data_output, & 1194 radiation_check_data_output_pr, & 1195 radiation_check_data_output_ts, & 1196 radiation_check_parameters, & 1197 radiation_control, & 1198 radiation_header, & 1199 radiation_init, & 1200 radiation_parin, & 1201 radiation_3d_data_averaging, & 1202 radiation_data_output_2d, & 1203 radiation_data_output_3d, & 1204 radiation_define_netcdf_grid, & 1205 radiation_wrd_local, & 1206 radiation_rrd_local, & 1207 radiation_data_output_mask, & 1208 radiation_calc_svf, & 1209 radiation_write_svf, & 1210 radiation_interaction, & 1211 radiation_interaction_init, & 1212 radiation_read_svf, & 1213 radiation_presimulate_solar_pos 1062 PUBLIC radiation_check_data_output, radiation_check_data_output_pr, & 1063 radiation_check_data_output_ts, & 1064 radiation_check_parameters, radiation_control, & 1065 radiation_header, radiation_init, radiation_parin, & 1066 radiation_3d_data_averaging, & 1067 radiation_data_output_2d, radiation_data_output_3d, & 1068 radiation_define_netcdf_grid, radiation_wrd_local, & 1069 radiation_rrd_local, radiation_data_output_mask, & 1070 radiation_calc_svf, radiation_write_svf, & 1071 radiation_interaction, radiation_interaction_init, & 1072 radiation_read_svf, radiation_presimulate_solar_pos 1214 1073 1215 1074 1216 1075 ! 1217 1076 !-- Public variables and constants / NEEDS SORTING 1218 PUBLIC albedo, & 1219 albedo_type, & 1220 average_radiation, & 1221 calc_zenith, & 1222 cos_zenith, & 1223 decl_1, & 1224 decl_2, & 1225 decl_3, & 1226 dots_rad, & 1227 dt_radiation, & 1228 endland, & 1229 endwall, & 1230 emissivity, & 1231 force_radiation_call, & 1232 id, & 1233 idcsf, & 1234 idir, & 1235 idsvf, & 1236 ieast_l, & 1237 ieast_u, & 1238 inorth_l, & 1239 inorth_u, & 1240 isouth_l, & 1241 isouth_u, & 1242 iup_l, & 1243 iup_u, & 1244 iwest_l, & 1245 iwest_u, & 1246 ix, & 1247 iy, & 1248 iz, & 1249 jdir, & 1250 kdcsf, & 1251 kdir, & 1252 lat, & 1253 lon, & 1254 mrtbl, & 1255 mrt_geom, & 1256 mrt_geom_params, & 1257 mrt_include_sw, & 1258 mrt_nlevels, & 1259 mrtinsw, & 1260 mrtinlw, & 1261 nmrtbl, & 1262 nsurf_type, & 1263 nz_urban_b, & 1264 nz_urban_t, & 1265 nz_urban, & 1266 nsurf, & 1267 ndsvf, & 1268 ndcsf, & 1269 pch, & 1270 pct, & 1271 rad_net_av, & 1272 radiation, & 1273 radiation_scheme, & 1274 rad_lw_in, & 1275 rad_lw_in_av, & 1276 rad_lw_out, & 1277 rad_lw_out_av, & 1278 rad_lw_cs_hr, & 1279 rad_lw_cs_hr_av, & 1280 rad_lw_hr, & 1281 rad_lw_hr_av, & 1282 rad_sw_in, & 1283 rad_sw_in_av, & 1284 rad_sw_out, & 1285 rad_sw_out_av, & 1286 rad_sw_cs_hr, & 1287 rad_sw_cs_hr_av, & 1288 rad_sw_hr, & 1289 rad_sw_hr_av, & 1290 radiation_interactions, & 1291 radiation_interactions_on, & 1292 rad_sw_in_diff, & 1293 rad_sw_in_dir, & 1294 solar_constant, & 1295 skip_time_do_radiation, & 1296 sun_direction, & 1297 sun_dir_lat, & 1298 sun_dir_lon, & 1299 startwall, & 1300 startland, & 1301 skyvf, & 1302 skyvft, & 1303 time_radiation, & 1304 unscheduled_radiation_calls 1305 1077 PUBLIC albedo, albedo_type, decl_1, decl_2, decl_3, dots_rad, dt_radiation,& 1078 emissivity, force_radiation_call, lat, lon, mrt_geom, & 1079 mrt_geom_params, & 1080 mrt_include_sw, mrt_nlevels, mrtbl, mrtinsw, mrtinlw, nmrtbl, & 1081 rad_net_av, radiation, radiation_scheme, rad_lw_in, & 1082 rad_lw_in_av, rad_lw_out, rad_lw_out_av, & 1083 rad_lw_cs_hr, rad_lw_cs_hr_av, rad_lw_hr, rad_lw_hr_av, rad_sw_in, & 1084 rad_sw_in_av, rad_sw_out, rad_sw_out_av, rad_sw_cs_hr, & 1085 rad_sw_cs_hr_av, rad_sw_hr, rad_sw_hr_av, solar_constant, & 1086 skip_time_do_radiation, time_radiation, unscheduled_radiation_calls,& 1087 cos_zenith, calc_zenith, sun_direction, sun_dir_lat, sun_dir_lon, & 1088 idir, jdir, kdir, id, iz, iy, ix, & 1089 iup_u, inorth_u, isouth_u, ieast_u, iwest_u, & 1090 iup_l, inorth_l, isouth_l, ieast_l, iwest_l, & 1091 nsurf_type, nz_urban_b, nz_urban_t, nz_urban, pch, nsurf, & 1092 idsvf, ndsvf, idcsf, ndcsf, kdcsf, pct, & 1093 radiation_interactions, startwall, startland, endland, endwall, & 1094 skyvf, skyvft, radiation_interactions_on, average_radiation, & 1095 rad_sw_in_diff, rad_sw_in_dir 1306 1096 1307 1097 … … 1313 1103 1314 1104 1315 !------------------------------------------------------------------------------ --------------------!1105 !------------------------------------------------------------------------------! 1316 1106 ! Description: 1317 1107 ! ------------ 1318 1108 !> This subroutine controls the calls of the radiation schemes 1319 !--------------------------------------------------------------------------------------------------! 1320 SUBROUTINE radiation_control 1321 1322 1323 IMPLICIT NONE 1324 1325 1326 IF ( debug_output_timestep ) CALL debug_message( 'radiation_control', 'start' ) 1327 1328 1329 SELECT CASE ( TRIM( radiation_scheme ) ) 1330 1331 CASE ( 'constant' ) 1332 CALL radiation_constant 1333 1334 CASE ( 'clear-sky' ) 1335 CALL radiation_clearsky 1336 1337 CASE ( 'rrtmg' ) 1338 CALL radiation_rrtmg 1339 1340 CASE ( 'external' ) 1341 ! 1342 !-- During spinup apply clear-sky model 1343 IF ( time_since_reference_point < 0.0_wp ) THEN 1109 !------------------------------------------------------------------------------! 1110 SUBROUTINE radiation_control 1111 1112 1113 IMPLICIT NONE 1114 1115 1116 IF ( debug_output_timestep ) CALL debug_message( 'radiation_control', 'start' ) 1117 1118 1119 SELECT CASE ( TRIM( radiation_scheme ) ) 1120 1121 CASE ( 'constant' ) 1122 CALL radiation_constant 1123 1124 CASE ( 'clear-sky' ) 1344 1125 CALL radiation_clearsky 1345 ELSE 1346 CALL radiation_external 1347 ENDIF 1348 1349 CASE DEFAULT 1350 1351 END SELECT 1352 1353 IF ( debug_output_timestep ) CALL debug_message( 'radiation_control', 'end' ) 1354 1355 END SUBROUTINE radiation_control 1356 1357 !--------------------------------------------------------------------------------------------------! 1126 1127 CASE ( 'rrtmg' ) 1128 CALL radiation_rrtmg 1129 1130 CASE ( 'external' ) 1131 ! 1132 !-- During spinup apply clear-sky model 1133 IF ( time_since_reference_point < 0.0_wp ) THEN 1134 CALL radiation_clearsky 1135 ELSE 1136 CALL radiation_external 1137 ENDIF 1138 1139 CASE DEFAULT 1140 1141 END SELECT 1142 1143 IF ( debug_output_timestep ) CALL debug_message( 'radiation_control', 'end' ) 1144 1145 END SUBROUTINE radiation_control 1146 1147 !------------------------------------------------------------------------------! 1358 1148 ! Description: 1359 1149 ! ------------ 1360 1150 !> Check data output for radiation model 1361 !--------------------------------------------------------------------------------------------------! 1362 SUBROUTINE radiation_check_data_output( variable, unit, i, ilen, k ) 1363 1364 1365 USE control_parameters, & 1366 ONLY: data_output, & 1367 message_string 1368 1369 IMPLICIT NONE 1370 1371 CHARACTER(LEN=*) :: unit !< 1372 CHARACTER(LEN=*) :: variable !< 1373 CHARACTER(LEN=varnamelength) :: var !< TRIM(variable) 1374 1375 INTEGER(iwp) :: i, k !< 1376 INTEGER(iwp) :: ilast_word !< 1377 INTEGER(iwp) :: ilen !< 1378 1379 LOGICAL :: directional !< 1380 1381 var = TRIM( variable ) 1382 ! 1383 !-- Identify directional variables 1384 ilast_word = SCAN( var, '_', back = .TRUE. ) 1385 IF ( ilast_word > 0 ) THEN 1386 SELECT CASE ( var(ilast_word:) ) 1387 CASE ( '_roof', '_south', '_north', '_west', '_east' ) 1388 directional = .TRUE. 1389 WRITE( 9, * ) 'vardir', var 1390 FLUSH( 9 ) 1391 var = var(1:ilast_word-1) 1392 CASE DEFAULT 1393 directional = .FALSE. 1394 WRITE( 9, * ) 'varnd', var 1395 FLUSH( 9 ) 1396 END SELECT 1397 ELSE 1398 directional = .FALSE. 1399 END IF 1400 1401 IF ( directional ) THEN 1402 IF ( var(1:8) == 'rtm_svf_' .OR. var(1:8) == 'rtm_dif_' ) THEN 1403 IF ( .NOT. radiation ) THEN 1404 message_string = 'output of "' // var // '" requires radiation = .TRUE.' 1405 CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 ) 1406 ENDIF 1407 unit = '1' 1151 !------------------------------------------------------------------------------! 1152 SUBROUTINE radiation_check_data_output( variable, unit, i, ilen, k ) 1153 1154 1155 USE control_parameters, & 1156 ONLY: data_output, message_string 1157 1158 IMPLICIT NONE 1159 1160 LOGICAL :: directional 1161 CHARACTER(LEN=*) :: unit !< 1162 CHARACTER(LEN=*) :: variable !< 1163 CHARACTER(LEN=varnamelength) :: var !< TRIM(variable) 1164 INTEGER(iwp) :: i, k 1165 INTEGER(iwp) :: ilast_word 1166 INTEGER(iwp) :: ilen 1167 1168 var = TRIM(variable) 1169 ! 1170 !-- Identify directional variables 1171 ilast_word = SCAN(var, '_', back=.TRUE.) 1172 IF ( ilast_word > 0 ) THEN 1173 SELECT CASE ( var(ilast_word:) ) 1174 CASE ( '_roof', '_south', '_north', '_west', '_east' ) 1175 directional = .TRUE. 1176 write(9, *) 'vardir', var 1177 flush(9) 1178 var = var(1:ilast_word-1) 1179 CASE DEFAULT 1180 directional = .FALSE. 1181 write(9, *) 'varnd', var 1182 flush(9) 1183 END SELECT 1184 ELSE 1185 directional = .FALSE. 1186 END IF 1187 1188 IF ( directional ) THEN 1189 IF ( var(1:8) == 'rtm_svf_' .OR. var(1:8) == 'rtm_dif_' ) THEN 1190 IF ( .NOT. radiation ) THEN 1191 message_string = 'output of "' // var // '" require'& 1192 // 's radiation = .TRUE.' 1193 CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 ) 1194 ENDIF 1195 unit = '1' 1196 ELSE 1197 SELECT CASE ( var ) 1198 CASE ( 'rtm_rad_net', 'rtm_rad_insw', 'rtm_rad_inlw', & 1199 'rtm_rad_inswdir', 'rtm_rad_inswdif', 'rtm_rad_inswref', & 1200 'rtm_rad_inlwdif', 'rtm_rad_inlwref', 'rtm_rad_outsw', & 1201 'rtm_rad_outlw', 'rtm_rad_ressw', 'rtm_rad_reslw' ) 1202 IF ( .NOT. radiation ) THEN 1203 message_string = 'output of "' // var // '" require' & 1204 // 's radiation = .TRUE.' 1205 CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 ) 1206 ENDIF 1207 unit = 'W/m2' 1208 1209 CASE ( 'rtm_skyvf', 'rtm_skyvft', 'rtm_surfalb', 'rtm_surfemis' ) 1210 IF ( .NOT. radiation ) THEN 1211 message_string = 'output of "' // var // '" require'& 1212 // 's radiation = .TRUE.' 1213 CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 ) 1214 ENDIF 1215 unit = '1' 1216 1217 CASE DEFAULT 1218 unit = 'illegal' 1219 END SELECT 1220 ENDIF 1221 1408 1222 ELSE 1409 1223 SELECT CASE ( var ) 1410 CASE ( 'rtm_rad_net', 'rtm_rad_insw', 'rtm_rad_inlw', 'rtm_rad_inswdir', & 1411 'rtm_rad_inswdif', 'rtm_rad_inswref', 'rtm_rad_inlwdif', 'rtm_rad_inlwref', & 1412 'rtm_rad_outsw', 'rtm_rad_outlw', 'rtm_rad_ressw', 'rtm_rad_reslw' ) 1224 CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_lw_in', 'rad_lw_out', & 1225 'rad_sw_cs_hr', 'rad_sw_hr', 'rad_sw_in', 'rad_sw_out' ) 1226 IF ( .NOT. radiation .OR. radiation_scheme /= 'rrtmg' ) THEN 1227 message_string = '"output of "' // var // '" requi' // & 1228 'res radiation = .TRUE. and ' // & 1229 'radiation_scheme = "rrtmg"' 1230 CALL message( 'check_parameters', 'PA0406', 1, 2, 0, 6, 0 ) 1231 ENDIF 1232 unit = 'K/h' 1233 1234 CASE ( 'rad_net*', 'rad_lw_in*', 'rad_lw_out*', 'rad_sw_in*', & 1235 'rad_sw_out*' ) 1236 IF ( k == 0 .OR. data_output(i)(ilen-2:ilen) /= '_xy' ) THEN 1237 message_string = 'illegal value for data_output: "' // & 1238 var // '" & only 2d-horizontal ' // & 1239 'cross sections are allowed for this value' 1240 CALL message( 'check_parameters', 'PA0111', 1, 2, 0, 6, 0 ) 1241 ENDIF 1242 unit = 'W/m2' 1243 1244 CASE ( 'rrtm_aldif*', 'rrtm_aldir*', 'rrtm_asdif*', 'rrtm_asdir*' ) 1245 IF ( k == 0 .OR. data_output(i)(ilen-2:ilen) /= '_xy' ) THEN 1246 message_string = 'illegal value for data_output: "' // & 1247 var // '" & only 2d-horizontal ' // & 1248 'cross sections are allowed for this value' 1249 CALL message( 'check_parameters', 'PA0111', 1, 2, 0, 6, 0 ) 1250 ENDIF 1251 IF ( .NOT. radiation .OR. radiation_scheme /= "rrtmg" ) THEN 1252 message_string = 'output of "' // var // '" require' & 1253 // 's radiation = .TRUE. and radiation_sch' & 1254 // 'eme = "rrtmg"' 1255 CALL message( 'check_parameters', 'PA0409', 1, 2, 0, 6, 0 ) 1256 ENDIF 1257 unit = '' 1258 1259 CASE ( 'rtm_rad_pc_inlw', 'rtm_rad_pc_insw', 'rtm_rad_pc_inswdir', & 1260 'rtm_rad_pc_inswdif', 'rtm_rad_pc_inswref') 1413 1261 IF ( .NOT. radiation ) THEN 1414 message_string = 'output of "' // var // '" requires radiation = .TRUE.' 1262 message_string = 'output of "' // var // '" require' & 1263 // 's radiation = .TRUE.' 1415 1264 CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 ) 1416 1265 ENDIF 1417 unit = 'W /m2'1418 1419 CASE ( 'rtm_ skyvf', 'rtm_skyvft', 'rtm_surfalb', 'rtm_surfemis')1266 unit = 'W' 1267 1268 CASE ( 'rtm_mrt', 'rtm_mrt_sw', 'rtm_mrt_lw' ) 1420 1269 IF ( .NOT. radiation ) THEN 1421 message_string = 'output of "' // var // '" requires radiation = .TRUE.' 1270 message_string = 'output of "' // var // '" require' & 1271 // 's radiation = .TRUE.' 1422 1272 CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 ) 1423 1273 ENDIF 1424 unit = '1' 1274 IF ( mrt_nlevels == 0 ) THEN 1275 message_string = 'output of "' // var // '" require' & 1276 // 's mrt_nlevels > 0' 1277 CALL message( 'check_parameters', 'PA0510', 1, 2, 0, 6, 0 ) 1278 ENDIF 1279 IF ( var == 'rtm_mrt_sw' .AND. .NOT. mrt_include_sw ) THEN 1280 message_string = 'output of "' // var // '" require' & 1281 // 's rtm_mrt_sw = .TRUE.' 1282 CALL message( 'check_parameters', 'PA0511', 1, 2, 0, 6, 0 ) 1283 ENDIF 1284 IF ( var == 'rtm_mrt' ) THEN 1285 unit = 'K' 1286 ELSE 1287 unit = 'W m-2' 1288 ENDIF 1425 1289 1426 1290 CASE DEFAULT 1427 1291 unit = 'illegal' 1292 1428 1293 END SELECT 1429 ENDIF 1430 ELSE 1431 SELECT CASE ( var ) 1432 CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_lw_in', 'rad_lw_out', 'rad_sw_cs_hr', & 1433 'rad_sw_hr', 'rad_sw_in', 'rad_sw_out' ) 1434 IF ( .NOT. radiation .OR. radiation_scheme /= 'rrtmg' ) THEN 1435 message_string = '"output of "' // var // '" requires radiation = .TRUE. and ' // & 1436 'radiation_scheme = "rrtmg"' 1437 CALL message( 'check_parameters', 'PA0406', 1, 2, 0, 6, 0 ) 1438 ENDIF 1439 unit = 'K/h' 1440 1441 CASE ( 'rad_net*', 'rad_lw_in*', 'rad_lw_out*', 'rad_sw_in*', 'rad_sw_out*' ) 1442 IF ( k == 0 .OR. data_output(i)(ilen-2:ilen) /= '_xy' ) THEN 1443 message_string = 'illegal value for data_output: "' // var // & 1444 '" & only 2d-horizontal cross sections are allowed for this value' 1445 CALL message( 'check_parameters', 'PA0111', 1, 2, 0, 6, 0 ) 1446 ENDIF 1447 unit = 'W/m2' 1448 1449 CASE ( 'rrtm_aldif*', 'rrtm_aldir*', 'rrtm_asdif*', 'rrtm_asdir*' ) 1450 IF ( k == 0 .OR. data_output(i)(ilen-2:ilen) /= '_xy' ) THEN 1451 message_string = 'illegal value for data_output: "' // var // & 1452 '" & only 2d-horizontal cross sections are allowed for this value' 1453 CALL message( 'check_parameters', 'PA0111', 1, 2, 0, 6, 0 ) 1454 ENDIF 1455 IF ( .NOT. radiation .OR. radiation_scheme /= "rrtmg" ) THEN 1456 message_string = 'output of "' // var // '" requires radiation = .TRUE. ' // & 1457 'and radiation_scheme = "rrtmg"' 1458 CALL message( 'check_parameters', 'PA0409', 1, 2, 0, 6, 0 ) 1459 ENDIF 1460 unit = '' 1461 1462 CASE ( 'rtm_rad_pc_inlw', 'rtm_rad_pc_insw', 'rtm_rad_pc_inswdir', 'rtm_rad_pc_inswdif', & 1463 'rtm_rad_pc_inswref') 1464 IF ( .NOT. radiation ) THEN 1465 message_string = 'output of "' // var // '" requires radiation = .TRUE.' 1466 CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 ) 1467 ENDIF 1468 unit = 'W' 1469 1470 CASE ( 'rtm_mrt', 'rtm_mrt_sw', 'rtm_mrt_lw' ) 1471 IF ( .NOT. radiation ) THEN 1472 message_string = 'output of "' // var // '" requires radiation = .TRUE.' 1473 CALL message( 'check_parameters', 'PA0509', 1, 2, 0, 6, 0 ) 1474 ENDIF 1475 IF ( mrt_nlevels == 0 ) THEN 1476 message_string = 'output of "' // var // '" requires mrt_nlevels > 0' 1477 CALL message( 'check_parameters', 'PA0510', 1, 2, 0, 6, 0 ) 1478 ENDIF 1479 IF ( var == 'rtm_mrt_sw' .AND. .NOT. mrt_include_sw ) THEN 1480 message_string = 'output of "' // var // '" requires rtm_mrt_sw = .TRUE.' 1481 CALL message( 'check_parameters', 'PA0511', 1, 2, 0, 6, 0 ) 1482 ENDIF 1483 IF ( var == 'rtm_mrt' ) THEN 1484 unit = 'K' 1485 ELSE 1486 unit = 'W m-2' 1487 ENDIF 1488 1489 CASE DEFAULT 1490 unit = 'illegal' 1491 1492 END SELECT 1493 END IF 1494 1495 END SUBROUTINE radiation_check_data_output 1496 1497 1498 !--------------------------------------------------------------------------------------------------! 1294 END IF 1295 1296 END SUBROUTINE radiation_check_data_output 1297 1298 1299 !------------------------------------------------------------------------------! 1499 1300 ! Description: 1500 1301 ! ------------ 1501 1302 !> Set module-specific timeseries units and labels 1502 !------------------------------------------------------------------------------ --------------------!1303 !------------------------------------------------------------------------------! 1503 1304 SUBROUTINE radiation_check_data_output_ts( dots_max, dots_num ) 1504 1305 1505 1306 1506 INTEGER(iwp), INTENT(IN) :: dots_max !<1507 INTEGER(iwp), INTENT(INOUT) :: dots_num !<1307 INTEGER(iwp), INTENT(IN) :: dots_max 1308 INTEGER(iwp), INTENT(INOUT) :: dots_num 1508 1309 1509 1310 ! … … 1512 1313 1513 1314 ! 1514 !-- Temporary solution to add LSM and radiation time series to the default output 1315 !-- Temporary solution to add LSM and radiation time series to the default 1316 !-- output 1515 1317 IF ( land_surface .OR. radiation ) THEN 1516 1318 IF ( TRIM( radiation_scheme ) == 'rrtmg' ) THEN … … 1524 1326 END SUBROUTINE radiation_check_data_output_ts 1525 1327 1526 !------------------------------------------------------------------------------ --------------------!1328 !------------------------------------------------------------------------------! 1527 1329 ! Description: 1528 1330 ! ------------ 1529 1331 !> Check data output of profiles for radiation model 1530 !--------------------------------------------------------------------------------------------------! 1531 SUBROUTINE radiation_check_data_output_pr( variable, var_count, unit, dopr_unit ) 1532 1533 USE arrays_3d, & 1534 ONLY: zu 1535 1536 USE control_parameters, & 1537 ONLY: data_output_pr, & 1538 message_string 1539 1540 USE indices 1541 1542 USE profil_parameter 1543 1544 USE statistics 1545 1546 IMPLICIT NONE 1547 1548 CHARACTER(LEN=*) :: unit !< 1549 CHARACTER(LEN=*) :: variable !< 1550 CHARACTER(LEN=*) :: dopr_unit !< local value of dopr_unit 1551 1552 INTEGER(iwp) :: var_count !< 1553 1554 SELECT CASE ( TRIM( variable ) ) 1555 1556 CASE ( 'rad_net' ) 1557 IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) THEN 1558 message_string = 'data_output_pr = ' // TRIM( data_output_pr(var_count) ) // ' is' // & 1559 'not available for radiation = .FALSE. or ' // & 1560 'radiation_scheme = "constant"' 1561 CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) 1562 ELSE 1563 dopr_index(var_count) = 99 1564 dopr_unit = 'W/m2' 1565 hom(:,2,99,:) = SPREAD( zw, 2, statistic_regions + 1 ) 1566 unit = dopr_unit 1567 ENDIF 1568 1569 CASE ( 'rad_lw_in' ) 1570 IF ( ( .NOT. radiation) .OR. radiation_scheme == 'constant' ) THEN 1571 message_string = 'data_output_pr = ' // TRIM( data_output_pr(var_count) ) // ' is' // & 1572 'not available for radiation = .FALSE. or ' // & 1573 'radiation_scheme = "constant"' 1574 CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) 1575 ELSE 1576 dopr_index(var_count) = 100 1577 dopr_unit = 'W/m2' 1578 hom(:,2,100,:) = SPREAD( zw, 2, statistic_regions + 1 ) 1579 unit = dopr_unit 1580 ENDIF 1581 1582 CASE ( 'rad_lw_out' ) 1583 IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) THEN 1584 message_string = 'data_output_pr = ' // TRIM( data_output_pr(var_count) ) // ' is' // & 1585 'not available for radiation = .FALSE. or ' // & 1586 'radiation_scheme = "constant"' 1587 CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) 1588 ELSE 1589 dopr_index(var_count) = 101 1590 dopr_unit = 'W/m2' 1591 hom(:,2,101,:) = SPREAD( zw, 2, statistic_regions + 1 ) 1592 unit = dopr_unit 1593 ENDIF 1594 1595 CASE ( 'rad_sw_in' ) 1596 IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) THEN 1597 message_string = 'data_output_pr = ' // TRIM( data_output_pr(var_count) ) // ' is' // & 1598 'not available for radiation = .FALSE. or ' // & 1599 'radiation_scheme = "constant"' 1600 CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) 1601 ELSE 1602 dopr_index(var_count) = 102 1603 dopr_unit = 'W/m2' 1604 hom(:,2,102,:) = SPREAD( zw, 2, statistic_regions + 1 ) 1605 unit = dopr_unit 1606 ENDIF 1607 1608 CASE ( 'rad_sw_out') 1609 IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) THEN 1610 message_string = 'data_output_pr = ' // TRIM( data_output_pr(var_count) ) // ' is' // & 1611 'not available for radiation = .FALSE. or ' // & 1612 'radiation_scheme = "constant"' 1613 CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) 1614 ELSE 1615 dopr_index(var_count) = 103 1616 dopr_unit = 'W/m2' 1617 hom(:,2,103,:) = SPREAD( zw, 2, statistic_regions + 1 ) 1618 unit = dopr_unit 1619 ENDIF 1620 1621 CASE ( 'rad_lw_cs_hr' ) 1622 IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) THEN 1623 message_string = 'data_output_pr = ' // TRIM( data_output_pr(var_count) ) // ' is' // & 1624 'not available for radiation = .FALSE. or ' // & 1625 'radiation_scheme /= "rrtmg"' 1626 CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 ) 1627 ELSE 1628 dopr_index(var_count) = 104 1629 dopr_unit = 'K/h' 1630 hom(:,2,104,:) = SPREAD( zu, 2, statistic_regions + 1 ) 1631 unit = dopr_unit 1632 ENDIF 1633 1634 CASE ( 'rad_lw_hr' ) 1635 IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) THEN 1636 message_string = 'data_output_pr = ' // TRIM( data_output_pr(var_count) ) // ' is' // & 1637 'not available for radiation = .FALSE. or ' // & 1638 'radiation_scheme /= "rrtmg"' 1639 CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 ) 1640 ELSE 1641 dopr_index(var_count) = 105 1642 dopr_unit = 'K/h' 1643 hom(:,2,105,:) = SPREAD( zu, 2, statistic_regions + 1 ) 1644 unit = dopr_unit 1645 ENDIF 1646 1647 CASE ( 'rad_sw_cs_hr' ) 1648 IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) THEN 1649 message_string = 'data_output_pr = ' // TRIM( data_output_pr(var_count) ) // ' is' // & 1650 'not available for radiation = .FALSE. or ' // & 1651 'radiation_scheme /= "rrtmg"' 1652 CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 ) 1653 ELSE 1654 dopr_index(var_count) = 106 1655 dopr_unit = 'K/h' 1656 hom(:,2,106,:) = SPREAD( zu, 2, statistic_regions + 1 ) 1657 unit = dopr_unit 1658 ENDIF 1659 1660 CASE ( 'rad_sw_hr' ) 1661 IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) THEN 1662 message_string = 'data_output_pr = ' // TRIM( data_output_pr(var_count) ) // ' is' // & 1663 'not available for radiation = .FALSE. or ' // & 1664 'radiation_scheme /= "rrtmg"' 1665 CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 ) 1666 ELSE 1667 dopr_index(var_count) = 107 1668 dopr_unit = 'K/h' 1669 hom(:,2,107,:) = SPREAD( zu, 2, statistic_regions + 1 ) 1670 unit = dopr_unit 1671 ENDIF 1672 1673 1674 CASE DEFAULT 1675 unit = 'illegal' 1676 1677 END SELECT 1678 1679 1680 END SUBROUTINE radiation_check_data_output_pr 1681 1682 1683 !--------------------------------------------------------------------------------------------------! 1332 !------------------------------------------------------------------------------! 1333 SUBROUTINE radiation_check_data_output_pr( variable, var_count, unit, & 1334 dopr_unit ) 1335 1336 USE arrays_3d, & 1337 ONLY: zu 1338 1339 USE control_parameters, & 1340 ONLY: data_output_pr, message_string 1341 1342 USE indices 1343 1344 USE profil_parameter 1345 1346 USE statistics 1347 1348 IMPLICIT NONE 1349 1350 CHARACTER (LEN=*) :: unit !< 1351 CHARACTER (LEN=*) :: variable !< 1352 CHARACTER (LEN=*) :: dopr_unit !< local value of dopr_unit 1353 1354 INTEGER(iwp) :: var_count !< 1355 1356 SELECT CASE ( TRIM( variable ) ) 1357 1358 CASE ( 'rad_net' ) 1359 IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )& 1360 THEN 1361 message_string = 'data_output_pr = ' // & 1362 TRIM( data_output_pr(var_count) ) // ' is' // & 1363 'not available for radiation = .FALSE. or ' //& 1364 'radiation_scheme = "constant"' 1365 CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) 1366 ELSE 1367 dopr_index(var_count) = 99 1368 dopr_unit = 'W/m2' 1369 hom(:,2,99,:) = SPREAD( zw, 2, statistic_regions+1 ) 1370 unit = dopr_unit 1371 ENDIF 1372 1373 CASE ( 'rad_lw_in' ) 1374 IF ( ( .NOT. radiation) .OR. radiation_scheme == 'constant' ) & 1375 THEN 1376 message_string = 'data_output_pr = ' // & 1377 TRIM( data_output_pr(var_count) ) // ' is' // & 1378 'not available for radiation = .FALSE. or ' //& 1379 'radiation_scheme = "constant"' 1380 CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) 1381 ELSE 1382 dopr_index(var_count) = 100 1383 dopr_unit = 'W/m2' 1384 hom(:,2,100,:) = SPREAD( zw, 2, statistic_regions+1 ) 1385 unit = dopr_unit 1386 ENDIF 1387 1388 CASE ( 'rad_lw_out' ) 1389 IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) & 1390 THEN 1391 message_string = 'data_output_pr = ' // & 1392 TRIM( data_output_pr(var_count) ) // ' is' // & 1393 'not available for radiation = .FALSE. or ' //& 1394 'radiation_scheme = "constant"' 1395 CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) 1396 ELSE 1397 dopr_index(var_count) = 101 1398 dopr_unit = 'W/m2' 1399 hom(:,2,101,:) = SPREAD( zw, 2, statistic_regions+1 ) 1400 unit = dopr_unit 1401 ENDIF 1402 1403 CASE ( 'rad_sw_in' ) 1404 IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' ) & 1405 THEN 1406 message_string = 'data_output_pr = ' // & 1407 TRIM( data_output_pr(var_count) ) // ' is' // & 1408 'not available for radiation = .FALSE. or ' //& 1409 'radiation_scheme = "constant"' 1410 CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) 1411 ELSE 1412 dopr_index(var_count) = 102 1413 dopr_unit = 'W/m2' 1414 hom(:,2,102,:) = SPREAD( zw, 2, statistic_regions+1 ) 1415 unit = dopr_unit 1416 ENDIF 1417 1418 CASE ( 'rad_sw_out') 1419 IF ( ( .NOT. radiation ) .OR. radiation_scheme == 'constant' )& 1420 THEN 1421 message_string = 'data_output_pr = ' // & 1422 TRIM( data_output_pr(var_count) ) // ' is' // & 1423 'not available for radiation = .FALSE. or ' //& 1424 'radiation_scheme = "constant"' 1425 CALL message( 'check_parameters', 'PA0408', 1, 2, 0, 6, 0 ) 1426 ELSE 1427 dopr_index(var_count) = 103 1428 dopr_unit = 'W/m2' 1429 hom(:,2,103,:) = SPREAD( zw, 2, statistic_regions+1 ) 1430 unit = dopr_unit 1431 ENDIF 1432 1433 CASE ( 'rad_lw_cs_hr' ) 1434 IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) & 1435 THEN 1436 message_string = 'data_output_pr = ' // & 1437 TRIM( data_output_pr(var_count) ) // ' is' // & 1438 'not available for radiation = .FALSE. or ' //& 1439 'radiation_scheme /= "rrtmg"' 1440 CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 ) 1441 ELSE 1442 dopr_index(var_count) = 104 1443 dopr_unit = 'K/h' 1444 hom(:,2,104,:) = SPREAD( zu, 2, statistic_regions+1 ) 1445 unit = dopr_unit 1446 ENDIF 1447 1448 CASE ( 'rad_lw_hr' ) 1449 IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) & 1450 THEN 1451 message_string = 'data_output_pr = ' // & 1452 TRIM( data_output_pr(var_count) ) // ' is' // & 1453 'not available for radiation = .FALSE. or ' //& 1454 'radiation_scheme /= "rrtmg"' 1455 CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 ) 1456 ELSE 1457 dopr_index(var_count) = 105 1458 dopr_unit = 'K/h' 1459 hom(:,2,105,:) = SPREAD( zu, 2, statistic_regions+1 ) 1460 unit = dopr_unit 1461 ENDIF 1462 1463 CASE ( 'rad_sw_cs_hr' ) 1464 IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) & 1465 THEN 1466 message_string = 'data_output_pr = ' // & 1467 TRIM( data_output_pr(var_count) ) // ' is' // & 1468 'not available for radiation = .FALSE. or ' //& 1469 'radiation_scheme /= "rrtmg"' 1470 CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 ) 1471 ELSE 1472 dopr_index(var_count) = 106 1473 dopr_unit = 'K/h' 1474 hom(:,2,106,:) = SPREAD( zu, 2, statistic_regions+1 ) 1475 unit = dopr_unit 1476 ENDIF 1477 1478 CASE ( 'rad_sw_hr' ) 1479 IF ( ( .NOT. radiation ) .OR. radiation_scheme /= 'rrtmg' ) & 1480 THEN 1481 message_string = 'data_output_pr = ' // & 1482 TRIM( data_output_pr(var_count) ) // ' is' // & 1483 'not available for radiation = .FALSE. or ' //& 1484 'radiation_scheme /= "rrtmg"' 1485 CALL message( 'check_parameters', 'PA0413', 1, 2, 0, 6, 0 ) 1486 ELSE 1487 dopr_index(var_count) = 107 1488 dopr_unit = 'K/h' 1489 hom(:,2,107,:) = SPREAD( zu, 2, statistic_regions+1 ) 1490 unit = dopr_unit 1491 ENDIF 1492 1493 1494 CASE DEFAULT 1495 unit = 'illegal' 1496 1497 END SELECT 1498 1499 1500 END SUBROUTINE radiation_check_data_output_pr 1501 1502 1503 !------------------------------------------------------------------------------! 1684 1504 ! Description: 1685 1505 ! ------------ 1686 1506 !> Check parameters routine for radiation model 1687 !--------------------------------------------------------------------------------------------------! 1688 SUBROUTINE radiation_check_parameters 1689 1690 USE control_parameters, & 1691 ONLY: land_surface, & 1692 message_string, & 1693 urban_surface 1694 1695 USE netcdf_data_input_mod, & 1696 ONLY: input_pids_static 1697 1698 IMPLICIT NONE 1699 1700 ! 1701 !-- In case no urban-surface or land-surface model is applied, usage of a radiation model makes no 1702 !-- sense. 1703 IF ( .NOT. land_surface .AND. .NOT. urban_surface ) THEN 1704 message_string = 'Usage of radiation module is only allowed if ' // & 1705 'land-surface and/or urban-surface model is applied.' 1706 CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 ) 1707 ENDIF 1708 1709 IF ( radiation_scheme /= 'constant' .AND. radiation_scheme /= 'clear-sky' .AND. & 1710 radiation_scheme /= 'rrtmg' .AND. radiation_scheme /= 'external' ) THEN 1711 message_string = 'unknown radiation_scheme = '// TRIM( radiation_scheme ) 1712 CALL message( 'check_parameters', 'PA0405', 1, 2, 0, 6, 0 ) 1713 ELSEIF ( radiation_scheme == 'rrtmg' ) THEN 1507 !------------------------------------------------------------------------------! 1508 SUBROUTINE radiation_check_parameters 1509 1510 USE control_parameters, & 1511 ONLY: land_surface, message_string, urban_surface 1512 1513 USE netcdf_data_input_mod, & 1514 ONLY: input_pids_static 1515 1516 IMPLICIT NONE 1517 1518 ! 1519 !-- In case no urban-surface or land-surface model is applied, usage of 1520 !-- a radiation model make no sense. 1521 IF ( .NOT. land_surface .AND. .NOT. urban_surface ) THEN 1522 message_string = 'Usage of radiation module is only allowed if ' // & 1523 'land-surface and/or urban-surface model is applied.' 1524 CALL message( 'check_parameters', 'PA0486', 1, 2, 0, 6, 0 ) 1525 ENDIF 1526 1527 IF ( radiation_scheme /= 'constant' .AND. & 1528 radiation_scheme /= 'clear-sky' .AND. & 1529 radiation_scheme /= 'rrtmg' .AND. & 1530 radiation_scheme /= 'external' ) THEN 1531 message_string = 'unknown radiation_scheme = '// & 1532 TRIM( radiation_scheme ) 1533 CALL message( 'check_parameters', 'PA0405', 1, 2, 0, 6, 0 ) 1534 ELSEIF ( radiation_scheme == 'rrtmg' ) THEN 1714 1535 #if ! defined ( __rrtmg ) 1715 message_string = 'radiation_scheme = "rrtmg" requires compilation of PALM with ' // & 1716 'pre-processor directive -D__rrtmg' 1717 CALL message( 'check_parameters', 'PA0407', 1, 2, 0, 6, 0 ) 1536 message_string = 'radiation_scheme = "rrtmg" requires ' // & 1537 'compilation of PALM with pre-processor ' // & 1538 'directive -D__rrtmg' 1539 CALL message( 'check_parameters', 'PA0407', 1, 2, 0, 6, 0 ) 1718 1540 #endif 1719 1541 #if defined ( __rrtmg ) && ! defined( __netcdf ) 1720 message_string = 'radiation_scheme = "rrtmg" requires the use of NetCDF ' // & 1721 '(preprocessor directive -D__netcdf' 1722 CALL message( 'check_parameters', 'PA0412', 1, 2, 0, 6, 0 ) 1542 message_string = 'radiation_scheme = "rrtmg" requires ' // & 1543 'the use of NetCDF (preprocessor directive ' // & 1544 '-D__netcdf' 1545 CALL message( 'check_parameters', 'PA0412', 1, 2, 0, 6, 0 ) 1723 1546 #endif 1724 1547 1725 ENDIF1726 !1727 !-- Checks performed if data is given via namelist only.1728 IF ( .NOT. input_pids_static ) THEN1729 IF ( albedo_type == 0 .AND. albedo == 9999999.9_wp .AND. &1730 radiation_scheme == 'clear-sky') THEN1731 message_string = 'radiation_scheme = "clear-sky" in combination with albedo_type = 0 ' //&1732 'requires setting of albedo /= 9999999.9'1733 CALL message( 'check_parameters', 'PA0410', 1, 2, 0, 6, 0 )1734 1548 ENDIF 1735 1736 IF ( albedo_type == 0 .AND. radiation_scheme == 'rrtmg' .AND. & 1737 ( albedo_lw_dif == 9999999.9_wp .OR. albedo_lw_dir == 9999999.9_wp & 1738 .OR. albedo_sw_dif == 9999999.9_wp .OR. albedo_sw_dir == 9999999.9_wp ) ) THEN 1739 message_string = 'radiation_scheme = "rrtmg" in combination with albedo_type = 0 ' // & 1740 'requires setting of albedo_lw_dif /= 9999999.9' // & 1741 'albedo_lw_dir /= 9999999.9' // & 1742 'albedo_sw_dif /= 9999999.9 and albedo_sw_dir /= 9999999.9' 1743 CALL message( 'check_parameters', 'PA0411', 1, 2, 0, 6, 0 ) 1549 ! 1550 !-- Checks performed only if data is given via namelist only. 1551 IF ( .NOT. input_pids_static ) THEN 1552 IF ( albedo_type == 0 .AND. albedo == 9999999.9_wp .AND. & 1553 radiation_scheme == 'clear-sky') THEN 1554 message_string = 'radiation_scheme = "clear-sky" in combination'//& 1555 'with albedo_type = 0 requires setting of'// & 1556 'albedo /= 9999999.9' 1557 CALL message( 'check_parameters', 'PA0410', 1, 2, 0, 6, 0 ) 1558 ENDIF 1559 1560 IF ( albedo_type == 0 .AND. radiation_scheme == 'rrtmg' .AND. & 1561 ( albedo_lw_dif == 9999999.9_wp .OR. albedo_lw_dir == 9999999.9_wp& 1562 .OR. albedo_sw_dif == 9999999.9_wp .OR. albedo_sw_dir == 9999999.9_wp& 1563 ) ) THEN 1564 message_string = 'radiation_scheme = "rrtmg" in combination' // & 1565 'with albedo_type = 0 requires setting of ' // & 1566 'albedo_lw_dif /= 9999999.9' // & 1567 'albedo_lw_dir /= 9999999.9' // & 1568 'albedo_sw_dif /= 9999999.9 and' // & 1569 'albedo_sw_dir /= 9999999.9' 1570 CALL message( 'check_parameters', 'PA0411', 1, 2, 0, 6, 0 ) 1571 ENDIF 1744 1572 ENDIF 1745 ENDIF 1746 ! 1747 !-- Parallel rad_angular_discretization without raytrace_mpi_rma is not implemented. Serial mode does 1748 !-- not allow mpi_rma 1573 ! 1574 !-- Parallel rad_angular_discretization without raytrace_mpi_rma is not implemented 1575 !-- Serial mode does not allow mpi_rma 1749 1576 #if defined( __parallel ) 1750 IF ( rad_angular_discretization .AND. .NOT. raytrace_mpi_rma ) THEN 1751 message_string = 'rad_angular_discretization can only be used together with ' // & 1752 'raytrace_mpi_rma or when no parallelization is applied.' 1753 CALL message( 'readiation_check_parameters', 'PA0486', 1, 2, 0, 6, 0 ) 1754 ENDIF 1577 IF ( rad_angular_discretization .AND. .NOT. raytrace_mpi_rma ) THEN 1578 message_string = 'rad_angular_discretization can only be used ' // & 1579 'together with raytrace_mpi_rma or when ' // & 1580 'no parallelization is applied.' 1581 CALL message( 'readiation_check_parameters', 'PA0486', 1, 2, 0, 6, 0 ) 1582 ENDIF 1755 1583 #else 1756 IF ( raytrace_mpi_rma ) THEN1757 message_string = 'raytrace_mpi_rma = .T. not allowed in serial mode'1758 CALL message( 'readiation_check_parameters', 'PA0710', 1, 2, 0, 6, 0 )1759 ENDIF1584 IF ( raytrace_mpi_rma ) THEN 1585 message_string = 'raytrace_mpi_rma = .T. not allowed in serial mode' 1586 CALL message( 'readiation_check_parameters', 'PA0710', 1, 2, 0, 6, 0 ) 1587 ENDIF 1760 1588 #endif 1761 1589 1762 IF ( cloud_droplets .AND. radiation_scheme == 'rrtmg' .AND. average_radiation ) THEN 1763 message_string = 'average_radiation = .T. with radiation_scheme = "rrtmg" ' // & 1764 'in combination cloud_droplets = .T. is not implementd' 1765 CALL message( 'check_parameters', 'PA0560', 1, 2, 0, 6, 0 ) 1766 ENDIF 1767 1768 ! 1769 !-- Initialize svf normalization reporting histogram 1770 svfnorm_report_num = 1 1771 DO WHILE ( svfnorm_report_thresh(svfnorm_report_num) < 1E20_wp .AND. svfnorm_report_num <= 30 ) 1772 svfnorm_report_num = svfnorm_report_num + 1 1773 ENDDO 1774 svfnorm_report_num = svfnorm_report_num - 1 1775 ! 1776 !-- Check for dt_radiation 1777 IF ( dt_radiation <= 0.0 ) THEN 1778 message_string = 'dt_radiation must be > 0.0' 1779 CALL message( 'check_parameters', 'PA0591', 1, 2, 0, 6, 0 ) 1780 ENDIF 1781 1782 END SUBROUTINE radiation_check_parameters 1783 1784 1785 !--------------------------------------------------------------------------------------------------! 1590 IF ( cloud_droplets .AND. radiation_scheme == 'rrtmg' .AND. & 1591 average_radiation ) THEN 1592 message_string = 'average_radiation = .T. with radiation_scheme'// & 1593 '= "rrtmg" in combination cloud_droplets = .T.'// & 1594 'is not implementd' 1595 CALL message( 'check_parameters', 'PA0560', 1, 2, 0, 6, 0 ) 1596 ENDIF 1597 1598 ! 1599 !-- Incialize svf normalization reporting histogram 1600 svfnorm_report_num = 1 1601 DO WHILE ( svfnorm_report_thresh(svfnorm_report_num) < 1e20_wp & 1602 .AND. svfnorm_report_num <= 30 ) 1603 svfnorm_report_num = svfnorm_report_num + 1 1604 ENDDO 1605 svfnorm_report_num = svfnorm_report_num - 1 1606 ! 1607 !-- Check for dt_radiation 1608 IF ( dt_radiation <= 0.0 ) THEN 1609 message_string = 'dt_radiation must be > 0.0' 1610 CALL message( 'check_parameters', 'PA0591', 1, 2, 0, 6, 0 ) 1611 ENDIF 1612 1613 END SUBROUTINE radiation_check_parameters 1614 1615 1616 !------------------------------------------------------------------------------! 1786 1617 ! Description: 1787 1618 ! ------------ 1788 1619 !> Initialization of the radiation model and Radiative Transfer Model 1789 !------------------------------------------------------------------------------ --------------------!1790 SUBROUTINE radiation_init1791 1792 IMPLICIT NONE1793 1794 INTEGER(iwp) :: i!< running index x-direction1795 INTEGER(iwp) :: is!< running index for input surface elements1796 INTEGER(iwp) :: ioff!< offset in x between surface element reference grid point in atmosphere and actual surface1797 INTEGER(iwp) :: j!< running index y-direction1798 INTEGER(iwp) :: joff!< offset in y between surface element reference grid point in atmosphere and actual surface1799 INTEGER(iwp) :: k!< running index z-direction1800 INTEGER(iwp) :: l!< running index for orientation of vertical surfaces1801 INTEGER(iwp) :: m!< running index for surface elements1802 INTEGER(iwp) :: ntime = 0!< number of available external radiation timesteps1620 !------------------------------------------------------------------------------! 1621 SUBROUTINE radiation_init 1622 1623 IMPLICIT NONE 1624 1625 INTEGER(iwp) :: i !< running index x-direction 1626 INTEGER(iwp) :: is !< running index for input surface elements 1627 INTEGER(iwp) :: ioff !< offset in x between surface element reference grid point in atmosphere and actual surface 1628 INTEGER(iwp) :: j !< running index y-direction 1629 INTEGER(iwp) :: joff !< offset in y between surface element reference grid point in atmosphere and actual surface 1630 INTEGER(iwp) :: k !< running index z-direction 1631 INTEGER(iwp) :: l !< running index for orientation of vertical surfaces 1632 INTEGER(iwp) :: m !< running index for surface elements 1633 INTEGER(iwp) :: ntime = 0 !< number of available external radiation timesteps 1803 1634 #if defined( __rrtmg ) 1804 INTEGER(iwp) :: ind_type!< running index for subgrid-surface tiles1635 INTEGER(iwp) :: ind_type !< running index for subgrid-surface tiles 1805 1636 #endif 1806 LOGICAL :: radiation_input_root_domain !< flag indicating the existence of a dynamic input file for the root domain 1807 1808 1809 IF ( debug_output ) CALL debug_message( 'radiation_init', 'start' ) 1810 ! 1811 !-- Activate radiation_interactions according to the existence of vertical surfaces and/or trees 1812 ! or if biometeorology output is required for flat surfaces. 1813 !-- The namelist parameter radiation_interactions_on can override this behavior. (This check cannot 1814 !-- be performed in check_parameters, because vertical_surfaces_exist is first set in 1815 !-- init_surface_arrays.) 1816 IF ( radiation_interactions_on ) THEN 1817 IF ( vertical_surfaces_exist .OR. plant_canopy .OR. biometeorology ) THEN 1818 radiation_interactions = .TRUE. 1819 average_radiation = .TRUE. 1637 LOGICAL :: radiation_input_root_domain !< flag indicating the existence of a dynamic input file for the root domain 1638 1639 1640 IF ( debug_output ) CALL debug_message( 'radiation_init', 'start' ) 1641 ! 1642 !-- Activate radiation_interactions according to the existence of vertical surfaces and/or trees 1643 ! or if biometeorology output is required for flat surfaces. 1644 !-- The namelist parameter radiation_interactions_on can override this behavior. 1645 !-- (This check cannot be performed in check_parameters, because vertical_surfaces_exist is first set in 1646 !-- init_surface_arrays.) 1647 IF ( radiation_interactions_on ) THEN 1648 IF ( vertical_surfaces_exist .OR. plant_canopy .OR. biometeorology ) THEN 1649 radiation_interactions = .TRUE. 1650 average_radiation = .TRUE. 1651 ELSE 1652 radiation_interactions_on = .FALSE. !< reset namelist parameter: no interactions 1653 !< calculations necessary in case of flat surface 1654 ENDIF 1655 ELSEIF ( vertical_surfaces_exist .OR. plant_canopy .OR. biometeorology ) THEN 1656 message_string = 'radiation_interactions_on is set to .FALSE. although ' // & 1657 'vertical surfaces and/or trees or biometeorology exist ' // & 1658 'is ON. The model will run without RTM (no shadows, no ' // & 1659 'radiation reflections)' 1660 CALL message( 'init_3d_model', 'PA0348', 0, 1, 0, 6, 0 ) 1661 ENDIF 1662 ! 1663 !-- Precalculate some time constants 1664 d_hours_day = 1.0_wp / REAL( hours_per_day, KIND = wp ) 1665 d_seconds_hour = 1.0_wp / seconds_per_hour 1666 1667 ! 1668 !-- If required, initialize radiation interactions between surfaces 1669 !-- via sky-view factors. This must be done before radiation is initialized. 1670 IF ( radiation_interactions ) CALL radiation_interaction_init 1671 ! 1672 !-- Allocate array for storing the surface net radiation 1673 IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_net ) .AND. & 1674 surf_lsm_h%ns > 0 ) THEN 1675 ALLOCATE( surf_lsm_h%rad_net(1:surf_lsm_h%ns) ) 1676 surf_lsm_h%rad_net = 0.0_wp 1677 ENDIF 1678 IF ( .NOT. ALLOCATED ( surf_usm_h%rad_net ) .AND. & 1679 surf_usm_h%ns > 0 ) THEN 1680 ALLOCATE( surf_usm_h%rad_net(1:surf_usm_h%ns) ) 1681 surf_usm_h%rad_net = 0.0_wp 1682 ENDIF 1683 DO l = 0, 3 1684 IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_net ) .AND. & 1685 surf_lsm_v(l)%ns > 0 ) THEN 1686 ALLOCATE( surf_lsm_v(l)%rad_net(1:surf_lsm_v(l)%ns) ) 1687 surf_lsm_v(l)%rad_net = 0.0_wp 1688 ENDIF 1689 IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_net ) .AND. & 1690 surf_usm_v(l)%ns > 0 ) THEN 1691 ALLOCATE( surf_usm_v(l)%rad_net(1:surf_usm_v(l)%ns) ) 1692 surf_usm_v(l)%rad_net = 0.0_wp 1693 ENDIF 1694 ENDDO 1695 1696 1697 ! 1698 !-- Allocate array for storing the surface longwave (out) radiation change 1699 IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_lw_out_change_0 ) .AND. & 1700 surf_lsm_h%ns > 0 ) THEN 1701 ALLOCATE( surf_lsm_h%rad_lw_out_change_0(1:surf_lsm_h%ns) ) 1702 surf_lsm_h%rad_lw_out_change_0 = 0.0_wp 1703 ENDIF 1704 IF ( .NOT. ALLOCATED ( surf_usm_h%rad_lw_out_change_0 ) .AND. & 1705 surf_usm_h%ns > 0 ) THEN 1706 ALLOCATE( surf_usm_h%rad_lw_out_change_0(1:surf_usm_h%ns) ) 1707 surf_usm_h%rad_lw_out_change_0 = 0.0_wp 1708 ENDIF 1709 DO l = 0, 3 1710 IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_lw_out_change_0 ) .AND. & 1711 surf_lsm_v(l)%ns > 0 ) THEN 1712 ALLOCATE( surf_lsm_v(l)%rad_lw_out_change_0(1:surf_lsm_v(l)%ns) ) 1713 surf_lsm_v(l)%rad_lw_out_change_0 = 0.0_wp 1714 ENDIF 1715 IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_lw_out_change_0 ) .AND. & 1716 surf_usm_v(l)%ns > 0 ) THEN 1717 ALLOCATE( surf_usm_v(l)%rad_lw_out_change_0(1:surf_usm_v(l)%ns) ) 1718 surf_usm_v(l)%rad_lw_out_change_0 = 0.0_wp 1719 ENDIF 1720 ENDDO 1721 1722 ! 1723 !-- Allocate surface arrays for incoming/outgoing short/longwave radiation 1724 IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_sw_in ) .AND. & 1725 surf_lsm_h%ns > 0 ) THEN 1726 ALLOCATE( surf_lsm_h%rad_sw_in(1:surf_lsm_h%ns) ) 1727 ALLOCATE( surf_lsm_h%rad_sw_out(1:surf_lsm_h%ns) ) 1728 ALLOCATE( surf_lsm_h%rad_sw_dir(1:surf_lsm_h%ns) ) 1729 ALLOCATE( surf_lsm_h%rad_sw_dif(1:surf_lsm_h%ns) ) 1730 ALLOCATE( surf_lsm_h%rad_sw_ref(1:surf_lsm_h%ns) ) 1731 ALLOCATE( surf_lsm_h%rad_sw_res(1:surf_lsm_h%ns) ) 1732 ALLOCATE( surf_lsm_h%rad_lw_in(1:surf_lsm_h%ns) ) 1733 ALLOCATE( surf_lsm_h%rad_lw_out(1:surf_lsm_h%ns) ) 1734 ALLOCATE( surf_lsm_h%rad_lw_dif(1:surf_lsm_h%ns) ) 1735 ALLOCATE( surf_lsm_h%rad_lw_ref(1:surf_lsm_h%ns) ) 1736 ALLOCATE( surf_lsm_h%rad_lw_res(1:surf_lsm_h%ns) ) 1737 surf_lsm_h%rad_sw_in = 0.0_wp 1738 surf_lsm_h%rad_sw_out = 0.0_wp 1739 surf_lsm_h%rad_sw_dir = 0.0_wp 1740 surf_lsm_h%rad_sw_dif = 0.0_wp 1741 surf_lsm_h%rad_sw_ref = 0.0_wp 1742 surf_lsm_h%rad_sw_res = 0.0_wp 1743 surf_lsm_h%rad_lw_in = 0.0_wp 1744 surf_lsm_h%rad_lw_out = 0.0_wp 1745 surf_lsm_h%rad_lw_dif = 0.0_wp 1746 surf_lsm_h%rad_lw_ref = 0.0_wp 1747 surf_lsm_h%rad_lw_res = 0.0_wp 1748 ENDIF 1749 IF ( .NOT. ALLOCATED ( surf_usm_h%rad_sw_in ) .AND. & 1750 surf_usm_h%ns > 0 ) THEN 1751 ALLOCATE( surf_usm_h%rad_sw_in(1:surf_usm_h%ns) ) 1752 ALLOCATE( surf_usm_h%rad_sw_out(1:surf_usm_h%ns) ) 1753 ALLOCATE( surf_usm_h%rad_sw_dir(1:surf_usm_h%ns) ) 1754 ALLOCATE( surf_usm_h%rad_sw_dif(1:surf_usm_h%ns) ) 1755 ALLOCATE( surf_usm_h%rad_sw_ref(1:surf_usm_h%ns) ) 1756 ALLOCATE( surf_usm_h%rad_sw_res(1:surf_usm_h%ns) ) 1757 ALLOCATE( surf_usm_h%rad_lw_in(1:surf_usm_h%ns) ) 1758 ALLOCATE( surf_usm_h%rad_lw_out(1:surf_usm_h%ns) ) 1759 ALLOCATE( surf_usm_h%rad_lw_dif(1:surf_usm_h%ns) ) 1760 ALLOCATE( surf_usm_h%rad_lw_ref(1:surf_usm_h%ns) ) 1761 ALLOCATE( surf_usm_h%rad_lw_res(1:surf_usm_h%ns) ) 1762 surf_usm_h%rad_sw_in = 0.0_wp 1763 surf_usm_h%rad_sw_out = 0.0_wp 1764 surf_usm_h%rad_sw_dir = 0.0_wp 1765 surf_usm_h%rad_sw_dif = 0.0_wp 1766 surf_usm_h%rad_sw_ref = 0.0_wp 1767 surf_usm_h%rad_sw_res = 0.0_wp 1768 surf_usm_h%rad_lw_in = 0.0_wp 1769 surf_usm_h%rad_lw_out = 0.0_wp 1770 surf_usm_h%rad_lw_dif = 0.0_wp 1771 surf_usm_h%rad_lw_ref = 0.0_wp 1772 surf_usm_h%rad_lw_res = 0.0_wp 1773 ENDIF 1774 DO l = 0, 3 1775 IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_sw_in ) .AND. & 1776 surf_lsm_v(l)%ns > 0 ) THEN 1777 ALLOCATE( surf_lsm_v(l)%rad_sw_in(1:surf_lsm_v(l)%ns) ) 1778 ALLOCATE( surf_lsm_v(l)%rad_sw_out(1:surf_lsm_v(l)%ns) ) 1779 ALLOCATE( surf_lsm_v(l)%rad_sw_dir(1:surf_lsm_v(l)%ns) ) 1780 ALLOCATE( surf_lsm_v(l)%rad_sw_dif(1:surf_lsm_v(l)%ns) ) 1781 ALLOCATE( surf_lsm_v(l)%rad_sw_ref(1:surf_lsm_v(l)%ns) ) 1782 ALLOCATE( surf_lsm_v(l)%rad_sw_res(1:surf_lsm_v(l)%ns) ) 1783 1784 ALLOCATE( surf_lsm_v(l)%rad_lw_in(1:surf_lsm_v(l)%ns) ) 1785 ALLOCATE( surf_lsm_v(l)%rad_lw_out(1:surf_lsm_v(l)%ns) ) 1786 ALLOCATE( surf_lsm_v(l)%rad_lw_dif(1:surf_lsm_v(l)%ns) ) 1787 ALLOCATE( surf_lsm_v(l)%rad_lw_ref(1:surf_lsm_v(l)%ns) ) 1788 ALLOCATE( surf_lsm_v(l)%rad_lw_res(1:surf_lsm_v(l)%ns) ) 1789 1790 surf_lsm_v(l)%rad_sw_in = 0.0_wp 1791 surf_lsm_v(l)%rad_sw_out = 0.0_wp 1792 surf_lsm_v(l)%rad_sw_dir = 0.0_wp 1793 surf_lsm_v(l)%rad_sw_dif = 0.0_wp 1794 surf_lsm_v(l)%rad_sw_ref = 0.0_wp 1795 surf_lsm_v(l)%rad_sw_res = 0.0_wp 1796 1797 surf_lsm_v(l)%rad_lw_in = 0.0_wp 1798 surf_lsm_v(l)%rad_lw_out = 0.0_wp 1799 surf_lsm_v(l)%rad_lw_dif = 0.0_wp 1800 surf_lsm_v(l)%rad_lw_ref = 0.0_wp 1801 surf_lsm_v(l)%rad_lw_res = 0.0_wp 1802 ENDIF 1803 IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_sw_in ) .AND. & 1804 surf_usm_v(l)%ns > 0 ) THEN 1805 ALLOCATE( surf_usm_v(l)%rad_sw_in(1:surf_usm_v(l)%ns) ) 1806 ALLOCATE( surf_usm_v(l)%rad_sw_out(1:surf_usm_v(l)%ns) ) 1807 ALLOCATE( surf_usm_v(l)%rad_sw_dir(1:surf_usm_v(l)%ns) ) 1808 ALLOCATE( surf_usm_v(l)%rad_sw_dif(1:surf_usm_v(l)%ns) ) 1809 ALLOCATE( surf_usm_v(l)%rad_sw_ref(1:surf_usm_v(l)%ns) ) 1810 ALLOCATE( surf_usm_v(l)%rad_sw_res(1:surf_usm_v(l)%ns) ) 1811 ALLOCATE( surf_usm_v(l)%rad_lw_in(1:surf_usm_v(l)%ns) ) 1812 ALLOCATE( surf_usm_v(l)%rad_lw_out(1:surf_usm_v(l)%ns) ) 1813 ALLOCATE( surf_usm_v(l)%rad_lw_dif(1:surf_usm_v(l)%ns) ) 1814 ALLOCATE( surf_usm_v(l)%rad_lw_ref(1:surf_usm_v(l)%ns) ) 1815 ALLOCATE( surf_usm_v(l)%rad_lw_res(1:surf_usm_v(l)%ns) ) 1816 surf_usm_v(l)%rad_sw_in = 0.0_wp 1817 surf_usm_v(l)%rad_sw_out = 0.0_wp 1818 surf_usm_v(l)%rad_sw_dir = 0.0_wp 1819 surf_usm_v(l)%rad_sw_dif = 0.0_wp 1820 surf_usm_v(l)%rad_sw_ref = 0.0_wp 1821 surf_usm_v(l)%rad_sw_res = 0.0_wp 1822 surf_usm_v(l)%rad_lw_in = 0.0_wp 1823 surf_usm_v(l)%rad_lw_out = 0.0_wp 1824 surf_usm_v(l)%rad_lw_dif = 0.0_wp 1825 surf_usm_v(l)%rad_lw_ref = 0.0_wp 1826 surf_usm_v(l)%rad_lw_res = 0.0_wp 1827 ENDIF 1828 ENDDO 1829 ! 1830 !-- Fix net radiation in case of radiation_scheme = 'constant' 1831 IF ( radiation_scheme == 'constant' ) THEN 1832 IF ( ALLOCATED( surf_lsm_h%rad_net ) ) & 1833 surf_lsm_h%rad_net = net_radiation 1834 IF ( ALLOCATED( surf_usm_h%rad_net ) ) & 1835 surf_usm_h%rad_net = net_radiation 1836 ! 1837 !-- Todo: weight with inclination angle 1838 DO l = 0, 3 1839 IF ( ALLOCATED( surf_lsm_v(l)%rad_net ) ) & 1840 surf_lsm_v(l)%rad_net = net_radiation 1841 IF ( ALLOCATED( surf_usm_v(l)%rad_net ) ) & 1842 surf_usm_v(l)%rad_net = net_radiation 1843 ENDDO 1844 ! radiation = .FALSE. 1845 ! 1846 !-- Calculate orbital constants 1820 1847 ELSE 1821 radiation_interactions_on = .FALSE. !< reset namelist parameter: no interactions 1822 !< calculations necessary in case of flat surface 1848 decl_1 = SIN(23.45_wp * pi / 180.0_wp) 1849 decl_2 = 2.0_wp * pi / 365.0_wp 1850 decl_3 = decl_2 * 81.0_wp 1851 lat = latitude * pi / 180.0_wp 1852 lon = longitude * pi / 180.0_wp 1823 1853 ENDIF 1824 ELSEIF ( vertical_surfaces_exist .OR. plant_canopy .OR. biometeorology ) THEN 1825 message_string = 'radiation_interactions_on is set to .FALSE. although vertical ' // & 1826 'surfaces and/or trees or biometeorology exist is ON. The model will ' // & 1827 'run without RTM (no shadows, no radiation reflections)' 1828 CALL message( 'init_3d_model', 'PA0348', 0, 1, 0, 6, 0 ) 1829 ENDIF 1830 ! 1831 !-- Precalculate some time constants 1832 d_hours_day = 1.0_wp / REAL( hours_per_day, KIND = wp ) 1833 d_seconds_hour = 1.0_wp / seconds_per_hour 1834 1835 ! 1836 !-- If required, initialize radiation interactions between surfaces via sky-view factors. This must 1837 !-- be done before radiation is initialized. 1838 IF ( radiation_interactions ) CALL radiation_interaction_init 1839 ! 1840 !-- Allocate array for storing the surface net radiation 1841 IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_net ) .AND. surf_lsm_h%ns > 0 ) THEN 1842 ALLOCATE( surf_lsm_h%rad_net(1:surf_lsm_h%ns) ) 1843 surf_lsm_h%rad_net = 0.0_wp 1844 ENDIF 1845 IF ( .NOT. ALLOCATED ( surf_usm_h%rad_net ) .AND. surf_usm_h%ns > 0 ) THEN 1846 ALLOCATE( surf_usm_h%rad_net(1:surf_usm_h%ns) ) 1847 surf_usm_h%rad_net = 0.0_wp 1848 ENDIF 1849 DO l = 0, 3 1850 IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_net ) .AND. surf_lsm_v(l)%ns > 0 ) THEN 1851 ALLOCATE( surf_lsm_v(l)%rad_net(1:surf_lsm_v(l)%ns) ) 1852 surf_lsm_v(l)%rad_net = 0.0_wp 1853 ENDIF 1854 IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_net ) .AND. surf_usm_v(l)%ns > 0 ) THEN 1855 ALLOCATE( surf_usm_v(l)%rad_net(1:surf_usm_v(l)%ns) ) 1856 surf_usm_v(l)%rad_net = 0.0_wp 1857 ENDIF 1858 ENDDO 1859 1860 1861 ! 1862 !-- Allocate array for storing the surface longwave (out) radiation change 1863 IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_lw_out_change_0 ) .AND. surf_lsm_h%ns > 0 ) THEN 1864 ALLOCATE( surf_lsm_h%rad_lw_out_change_0(1:surf_lsm_h%ns) ) 1865 surf_lsm_h%rad_lw_out_change_0 = 0.0_wp 1866 ENDIF 1867 IF ( .NOT. ALLOCATED ( surf_usm_h%rad_lw_out_change_0 ) .AND. surf_usm_h%ns > 0 ) THEN 1868 ALLOCATE( surf_usm_h%rad_lw_out_change_0(1:surf_usm_h%ns) ) 1869 surf_usm_h%rad_lw_out_change_0 = 0.0_wp 1870 ENDIF 1871 DO l = 0, 3 1872 IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_lw_out_change_0 ) .AND. surf_lsm_v(l)%ns > 0 ) & 1873 THEN 1874 ALLOCATE( surf_lsm_v(l)%rad_lw_out_change_0(1:surf_lsm_v(l)%ns) ) 1875 surf_lsm_v(l)%rad_lw_out_change_0 = 0.0_wp 1876 ENDIF 1877 IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_lw_out_change_0 ) .AND. surf_usm_v(l)%ns > 0 ) & 1878 THEN 1879 ALLOCATE( surf_usm_v(l)%rad_lw_out_change_0(1:surf_usm_v(l)%ns) ) 1880 surf_usm_v(l)%rad_lw_out_change_0 = 0.0_wp 1881 ENDIF 1882 ENDDO 1883 1884 ! 1885 !-- Allocate surface arrays for incoming/outgoing short/longwave radiation 1886 IF ( .NOT. ALLOCATED ( surf_lsm_h%rad_sw_in ) .AND. surf_lsm_h%ns > 0 ) THEN 1887 ALLOCATE( surf_lsm_h%rad_sw_in(1:surf_lsm_h%ns) ) 1888 ALLOCATE( surf_lsm_h%rad_sw_out(1:surf_lsm_h%ns) ) 1889 ALLOCATE( surf_lsm_h%rad_sw_dir(1:surf_lsm_h%ns) ) 1890 ALLOCATE( surf_lsm_h%rad_sw_dif(1:surf_lsm_h%ns) ) 1891 ALLOCATE( surf_lsm_h%rad_sw_ref(1:surf_lsm_h%ns) ) 1892 ALLOCATE( surf_lsm_h%rad_sw_res(1:surf_lsm_h%ns) ) 1893 ALLOCATE( surf_lsm_h%rad_lw_in(1:surf_lsm_h%ns) ) 1894 ALLOCATE( surf_lsm_h%rad_lw_out(1:surf_lsm_h%ns) ) 1895 ALLOCATE( surf_lsm_h%rad_lw_dif(1:surf_lsm_h%ns) ) 1896 ALLOCATE( surf_lsm_h%rad_lw_ref(1:surf_lsm_h%ns) ) 1897 ALLOCATE( surf_lsm_h%rad_lw_res(1:surf_lsm_h%ns) ) 1898 surf_lsm_h%rad_sw_in = 0.0_wp 1899 surf_lsm_h%rad_sw_out = 0.0_wp 1900 surf_lsm_h%rad_sw_dir = 0.0_wp 1901 surf_lsm_h%rad_sw_dif = 0.0_wp 1902 surf_lsm_h%rad_sw_ref = 0.0_wp 1903 surf_lsm_h%rad_sw_res = 0.0_wp 1904 surf_lsm_h%rad_lw_in = 0.0_wp 1905 surf_lsm_h%rad_lw_out = 0.0_wp 1906 surf_lsm_h%rad_lw_dif = 0.0_wp 1907 surf_lsm_h%rad_lw_ref = 0.0_wp 1908 surf_lsm_h%rad_lw_res = 0.0_wp 1909 ENDIF 1910 IF ( .NOT. ALLOCATED ( surf_usm_h%rad_sw_in ) .AND. surf_usm_h%ns > 0 ) THEN 1911 ALLOCATE( surf_usm_h%rad_sw_in(1:surf_usm_h%ns) ) 1912 ALLOCATE( surf_usm_h%rad_sw_out(1:surf_usm_h%ns) ) 1913 ALLOCATE( surf_usm_h%rad_sw_dir(1:surf_usm_h%ns) ) 1914 ALLOCATE( surf_usm_h%rad_sw_dif(1:surf_usm_h%ns) ) 1915 ALLOCATE( surf_usm_h%rad_sw_ref(1:surf_usm_h%ns) ) 1916 ALLOCATE( surf_usm_h%rad_sw_res(1:surf_usm_h%ns) ) 1917 ALLOCATE( surf_usm_h%rad_lw_in(1:surf_usm_h%ns) ) 1918 ALLOCATE( surf_usm_h%rad_lw_out(1:surf_usm_h%ns) ) 1919 ALLOCATE( surf_usm_h%rad_lw_dif(1:surf_usm_h%ns) ) 1920 ALLOCATE( surf_usm_h%rad_lw_ref(1:surf_usm_h%ns) ) 1921 ALLOCATE( surf_usm_h%rad_lw_res(1:surf_usm_h%ns) ) 1922 surf_usm_h%rad_sw_in = 0.0_wp 1923 surf_usm_h%rad_sw_out = 0.0_wp 1924 surf_usm_h%rad_sw_dir = 0.0_wp 1925 surf_usm_h%rad_sw_dif = 0.0_wp 1926 surf_usm_h%rad_sw_ref = 0.0_wp 1927 surf_usm_h%rad_sw_res = 0.0_wp 1928 surf_usm_h%rad_lw_in = 0.0_wp 1929 surf_usm_h%rad_lw_out = 0.0_wp 1930 surf_usm_h%rad_lw_dif = 0.0_wp 1931 surf_usm_h%rad_lw_ref = 0.0_wp 1932 surf_usm_h%rad_lw_res = 0.0_wp 1933 ENDIF 1934 DO l = 0, 3 1935 IF ( .NOT. ALLOCATED ( surf_lsm_v(l)%rad_sw_in ) .AND. surf_lsm_v(l)%ns > 0 ) THEN 1936 ALLOCATE( surf_lsm_v(l)%rad_sw_in(1:surf_lsm_v(l)%ns) ) 1937 ALLOCATE( surf_lsm_v(l)%rad_sw_out(1:surf_lsm_v(l)%ns) ) 1938 ALLOCATE( surf_lsm_v(l)%rad_sw_dir(1:surf_lsm_v(l)%ns) ) 1939 ALLOCATE( surf_lsm_v(l)%rad_sw_dif(1:surf_lsm_v(l)%ns) ) 1940 ALLOCATE( surf_lsm_v(l)%rad_sw_ref(1:surf_lsm_v(l)%ns) ) 1941 ALLOCATE( surf_lsm_v(l)%rad_sw_res(1:surf_lsm_v(l)%ns) ) 1942 1943 ALLOCATE( surf_lsm_v(l)%rad_lw_in(1:surf_lsm_v(l)%ns) ) 1944 ALLOCATE( surf_lsm_v(l)%rad_lw_out(1:surf_lsm_v(l)%ns) ) 1945 ALLOCATE( surf_lsm_v(l)%rad_lw_dif(1:surf_lsm_v(l)%ns) ) 1946 ALLOCATE( surf_lsm_v(l)%rad_lw_ref(1:surf_lsm_v(l)%ns) ) 1947 ALLOCATE( surf_lsm_v(l)%rad_lw_res(1:surf_lsm_v(l)%ns) ) 1948 1949 surf_lsm_v(l)%rad_sw_in = 0.0_wp 1950 surf_lsm_v(l)%rad_sw_out = 0.0_wp 1951 surf_lsm_v(l)%rad_sw_dir = 0.0_wp 1952 surf_lsm_v(l)%rad_sw_dif = 0.0_wp 1953 surf_lsm_v(l)%rad_sw_ref = 0.0_wp 1954 surf_lsm_v(l)%rad_sw_res = 0.0_wp 1955 1956 surf_lsm_v(l)%rad_lw_in = 0.0_wp 1957 surf_lsm_v(l)%rad_lw_out = 0.0_wp 1958 surf_lsm_v(l)%rad_lw_dif = 0.0_wp 1959 surf_lsm_v(l)%rad_lw_ref = 0.0_wp 1960 surf_lsm_v(l)%rad_lw_res = 0.0_wp 1961 ENDIF 1962 IF ( .NOT. ALLOCATED ( surf_usm_v(l)%rad_sw_in ) .AND. surf_usm_v(l)%ns > 0 ) THEN 1963 ALLOCATE( surf_usm_v(l)%rad_sw_in(1:surf_usm_v(l)%ns) ) 1964 ALLOCATE( surf_usm_v(l)%rad_sw_out(1:surf_usm_v(l)%ns) ) 1965 ALLOCATE( surf_usm_v(l)%rad_sw_dir(1:surf_usm_v(l)%ns) ) 1966 ALLOCATE( surf_usm_v(l)%rad_sw_dif(1:surf_usm_v(l)%ns) ) 1967 ALLOCATE( surf_usm_v(l)%rad_sw_ref(1:surf_usm_v(l)%ns) ) 1968 ALLOCATE( surf_usm_v(l)%rad_sw_res(1:surf_usm_v(l)%ns) ) 1969 ALLOCATE( surf_usm_v(l)%rad_lw_in(1:surf_usm_v(l)%ns) ) 1970 ALLOCATE( surf_usm_v(l)%rad_lw_out(1:surf_usm_v(l)%ns) ) 1971 ALLOCATE( surf_usm_v(l)%rad_lw_dif(1:surf_usm_v(l)%ns) ) 1972 ALLOCATE( surf_usm_v(l)%rad_lw_ref(1:surf_usm_v(l)%ns) ) 1973 ALLOCATE( surf_usm_v(l)%rad_lw_res(1:surf_usm_v(l)%ns) ) 1974 surf_usm_v(l)%rad_sw_in = 0.0_wp 1975 surf_usm_v(l)%rad_sw_out = 0.0_wp 1976 surf_usm_v(l)%rad_sw_dir = 0.0_wp 1977 surf_usm_v(l)%rad_sw_dif = 0.0_wp 1978 surf_usm_v(l)%rad_sw_ref = 0.0_wp 1979 surf_usm_v(l)%rad_sw_res = 0.0_wp 1980 surf_usm_v(l)%rad_lw_in = 0.0_wp 1981 surf_usm_v(l)%rad_lw_out = 0.0_wp 1982 surf_usm_v(l)%rad_lw_dif = 0.0_wp 1983 surf_usm_v(l)%rad_lw_ref = 0.0_wp 1984 surf_usm_v(l)%rad_lw_res = 0.0_wp 1985 ENDIF 1986 ENDDO 1987 ! 1988 !-- Fix net radiation in case of radiation_scheme = 'constant' 1989 IF ( radiation_scheme == 'constant' ) THEN 1990 IF ( ALLOCATED( surf_lsm_h%rad_net ) ) surf_lsm_h%rad_net = net_radiation 1991 IF ( ALLOCATED( surf_usm_h%rad_net ) ) surf_usm_h%rad_net = net_radiation 1992 ! 1993 !-- Todo: weight with inclination angle 1994 DO l = 0, 3 1995 IF ( ALLOCATED( surf_lsm_v(l)%rad_net ) ) surf_lsm_v(l)%rad_net = net_radiation 1996 IF ( ALLOCATED( surf_usm_v(l)%rad_net ) ) surf_usm_v(l)%rad_net = net_radiation 1997 ENDDO 1998 ! radiation = .FALSE. 1999 ! 2000 !-- Calculate orbital constants 2001 ELSE 2002 decl_1 = SIN( 23.45_wp * pi / 180.0_wp ) 2003 decl_2 = 2.0_wp * pi / 365.0_wp 2004 decl_3 = decl_2 * 81.0_wp 2005 lat = latitude * pi / 180.0_wp 2006 lon = longitude * pi / 180.0_wp 2007 ENDIF 2008 2009 IF ( radiation_scheme == 'clear-sky' .OR. & 2010 radiation_scheme == 'constant' .OR. & 2011 radiation_scheme == 'external' ) THEN 2012 ! 2013 !-- Allocate arrays for incoming/outgoing short/longwave radiation 2014 IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN 2015 ALLOCATE ( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) ) 2016 rad_sw_in = 0.0_wp 2017 ENDIF 2018 IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN 2019 ALLOCATE ( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) ) 2020 rad_sw_out = 0.0_wp 2021 ENDIF 2022 2023 IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN 2024 ALLOCATE ( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) ) 2025 rad_lw_in = 0.0_wp 2026 ENDIF 2027 IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN 2028 ALLOCATE ( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) ) 2029 rad_lw_out = 0.0_wp 2030 ENDIF 2031 2032 ! 2033 !-- Allocate average arrays for incoming/outgoing short/longwave radiation 2034 IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN 2035 ALLOCATE ( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) 2036 ENDIF 2037 IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN 2038 ALLOCATE ( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) 2039 ENDIF 2040 2041 IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN 2042 ALLOCATE ( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) 2043 ENDIF 2044 IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN 2045 ALLOCATE ( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) 2046 ENDIF 2047 ! 2048 !-- Allocate arrays for broadband albedo, and level 1 initialization via namelist paramter, 2049 !-- unless not already allocated. 2050 IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) THEN 2051 ALLOCATE( surf_lsm_h%albedo(1:surf_lsm_h%ns,0:2) ) 2052 surf_lsm_h%albedo = albedo 2053 ENDIF 2054 IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) THEN 2055 ALLOCATE( surf_usm_h%albedo(1:surf_usm_h%ns,0:2) ) 2056 surf_usm_h%albedo = albedo 2057 ENDIF 2058 2059 DO l = 0, 3 2060 IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) THEN 2061 ALLOCATE( surf_lsm_v(l)%albedo(1:surf_lsm_v(l)%ns,0:2) ) 2062 surf_lsm_v(l)%albedo = albedo 2063 ENDIF 2064 IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) THEN 2065 ALLOCATE( surf_usm_v(l)%albedo(1:surf_usm_v(l)%ns,0:2) ) 2066 surf_usm_v(l)%albedo = albedo 2067 ENDIF 2068 ENDDO 2069 ! 2070 !-- Level 2 initialization of broadband albedo via given albedo_type. 2071 !-- Only if albedo_type is non-zero. In case of urban surface and input data is read from ASCII 2072 !-- file, albedo_type will be zero, so that albedo won't be overwritten. 2073 DO m = 1, surf_lsm_h%ns 2074 IF ( surf_lsm_h%albedo_type(m,ind_veg_wall) /= 0 ) & 2075 surf_lsm_h%albedo(m,ind_veg_wall) = & 2076 albedo_pars(0,surf_lsm_h%albedo_type(m,ind_veg_wall)) 2077 IF ( surf_lsm_h%albedo_type(m,ind_pav_green) /= 0 ) & 2078 surf_lsm_h%albedo(m,ind_pav_green) = & 2079 albedo_pars(0,surf_lsm_h%albedo_type(m,ind_pav_green)) 2080 IF ( surf_lsm_h%albedo_type(m,ind_wat_win) /= 0 ) & 2081 surf_lsm_h%albedo(m,ind_wat_win) = & 2082 albedo_pars(0,surf_lsm_h%albedo_type(m,ind_wat_win)) 2083 ENDDO 2084 DO m = 1, surf_usm_h%ns 2085 IF ( surf_usm_h%albedo_type(m,ind_veg_wall) /= 0 ) & 2086 surf_usm_h%albedo(m,ind_veg_wall) = & 2087 albedo_pars(0,surf_usm_h%albedo_type(m,ind_veg_wall)) 2088 IF ( surf_usm_h%albedo_type(m,ind_pav_green) /= 0 ) & 2089 surf_usm_h%albedo(m,ind_pav_green) = & 2090 albedo_pars(0,surf_usm_h%albedo_type(m,ind_pav_green)) 2091 IF ( surf_usm_h%albedo_type(m,ind_wat_win) /= 0 ) & 2092 surf_usm_h%albedo(m,ind_wat_win) = & 2093 albedo_pars(0,surf_usm_h%albedo_type(m,ind_wat_win)) 2094 ENDDO 2095 2096 DO l = 0, 3 2097 DO m = 1, surf_lsm_v(l)%ns 2098 IF ( surf_lsm_v(l)%albedo_type(m,ind_veg_wall) /= 0 ) & 2099 surf_lsm_v(l)%albedo(m,ind_veg_wall) = & 2100 albedo_pars(0,surf_lsm_v(l)%albedo_type(m,ind_veg_wall)) 2101 IF ( surf_lsm_v(l)%albedo_type(m,ind_pav_green) /= 0 ) & 2102 surf_lsm_v(l)%albedo(m,ind_pav_green) = & 2103 albedo_pars(0,surf_lsm_v(l)%albedo_type(m,ind_pav_green)) 2104 IF ( surf_lsm_v(l)%albedo_type(m,ind_wat_win) /= 0 ) & 2105 surf_lsm_v(l)%albedo(m,ind_wat_win) = & 2106 albedo_pars(0,surf_lsm_v(l)%albedo_type(m,ind_wat_win)) 2107 ENDDO 2108 DO m = 1, surf_usm_v(l)%ns 2109 IF ( surf_usm_v(l)%albedo_type(m,ind_veg_wall) /= 0 ) & 2110 surf_usm_v(l)%albedo(m,ind_veg_wall) = & 2111 albedo_pars(0,surf_usm_v(l)%albedo_type(m,ind_veg_wall)) 2112 IF ( surf_usm_v(l)%albedo_type(m,ind_pav_green) /= 0 ) & 2113 surf_usm_v(l)%albedo(m,ind_pav_green) = & 2114 albedo_pars(0,surf_usm_v(l)%albedo_type(m,ind_pav_green)) 2115 IF ( surf_usm_v(l)%albedo_type(m,ind_wat_win) /= 0 ) & 2116 surf_usm_v(l)%albedo(m,ind_wat_win) = & 2117 albedo_pars(0,surf_usm_v(l)%albedo_type(m,ind_wat_win)) 2118 ENDDO 2119 ENDDO 2120 2121 ! 2122 !-- Level 3 initialization at grid points where albedo type is zero. 2123 !-- This case, albedo is taken from file. In case of constant radiation or clear sky, only 2124 !-- broadband albedo is given. 2125 IF ( albedo_pars_f%from_file ) THEN 2126 ! 2127 !-- Horizontal surfaces 2128 DO m = 1, surf_lsm_h%ns 2129 i = surf_lsm_h%i(m) 2130 j = surf_lsm_h%j(m) 2131 IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN 2132 surf_lsm_h%albedo(m,ind_veg_wall) = albedo_pars_f%pars_xy(0,j,i) 2133 surf_lsm_h%albedo(m,ind_pav_green) = albedo_pars_f%pars_xy(0,j,i) 2134 surf_lsm_h%albedo(m,ind_wat_win) = albedo_pars_f%pars_xy(0,j,i) 1854 1855 IF ( radiation_scheme == 'clear-sky' .OR. & 1856 radiation_scheme == 'constant' .OR. & 1857 radiation_scheme == 'external' ) THEN 1858 ! 1859 !-- Allocate arrays for incoming/outgoing short/longwave radiation 1860 IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN 1861 ALLOCATE ( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) ) 1862 rad_sw_in = 0.0_wp 1863 ENDIF 1864 IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN 1865 ALLOCATE ( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) ) 1866 rad_sw_out = 0.0_wp 1867 ENDIF 1868 1869 IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN 1870 ALLOCATE ( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) ) 1871 rad_lw_in = 0.0_wp 1872 ENDIF 1873 IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN 1874 ALLOCATE ( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) ) 1875 rad_lw_out = 0.0_wp 1876 ENDIF 1877 1878 ! 1879 !-- Allocate average arrays for incoming/outgoing short/longwave radiation 1880 IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN 1881 ALLOCATE ( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) 1882 ENDIF 1883 IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN 1884 ALLOCATE ( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) 1885 ENDIF 1886 1887 IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN 1888 ALLOCATE ( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) 1889 ENDIF 1890 IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN 1891 ALLOCATE ( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) 1892 ENDIF 1893 ! 1894 !-- Allocate arrays for broadband albedo, and level 1 initialization 1895 !-- via namelist paramter, unless not already allocated. 1896 IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) THEN 1897 ALLOCATE( surf_lsm_h%albedo(1:surf_lsm_h%ns,0:2) ) 1898 surf_lsm_h%albedo = albedo 1899 ENDIF 1900 IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) THEN 1901 ALLOCATE( surf_usm_h%albedo(1:surf_usm_h%ns,0:2) ) 1902 surf_usm_h%albedo = albedo 1903 ENDIF 1904 1905 DO l = 0, 3 1906 IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) THEN 1907 ALLOCATE( surf_lsm_v(l)%albedo(1:surf_lsm_v(l)%ns,0:2) ) 1908 surf_lsm_v(l)%albedo = albedo 1909 ENDIF 1910 IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) THEN 1911 ALLOCATE( surf_usm_v(l)%albedo(1:surf_usm_v(l)%ns,0:2) ) 1912 surf_usm_v(l)%albedo = albedo 2135 1913 ENDIF 2136 1914 ENDDO 1915 ! 1916 !-- Level 2 initialization of broadband albedo via given albedo_type. 1917 !-- Only if albedo_type is non-zero. In case of urban surface and 1918 !-- input data is read from ASCII file, albedo_type will be zero, so that 1919 !-- albedo won't be overwritten. 1920 DO m = 1, surf_lsm_h%ns 1921 IF ( surf_lsm_h%albedo_type(m,ind_veg_wall) /= 0 ) & 1922 surf_lsm_h%albedo(m,ind_veg_wall) = & 1923 albedo_pars(0,surf_lsm_h%albedo_type(m,ind_veg_wall)) 1924 IF ( surf_lsm_h%albedo_type(m,ind_pav_green) /= 0 ) & 1925 surf_lsm_h%albedo(m,ind_pav_green) = & 1926 albedo_pars(0,surf_lsm_h%albedo_type(m,ind_pav_green)) 1927 IF ( surf_lsm_h%albedo_type(m,ind_wat_win) /= 0 ) & 1928 surf_lsm_h%albedo(m,ind_wat_win) = & 1929 albedo_pars(0,surf_lsm_h%albedo_type(m,ind_wat_win)) 1930 ENDDO 2137 1931 DO m = 1, surf_usm_h%ns 2138 i = surf_usm_h%i(m) 2139 j = surf_usm_h%j(m) 2140 IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN 2141 surf_usm_h%albedo(m,ind_veg_wall) = albedo_pars_f%pars_xy(0,j,i) 2142 surf_usm_h%albedo(m,ind_pav_green) = albedo_pars_f%pars_xy(0,j,i) 2143 surf_usm_h%albedo(m,ind_wat_win) = albedo_pars_f%pars_xy(0,j,i) 2144 ENDIF 1932 IF ( surf_usm_h%albedo_type(m,ind_veg_wall) /= 0 ) & 1933 surf_usm_h%albedo(m,ind_veg_wall) = & 1934 albedo_pars(0,surf_usm_h%albedo_type(m,ind_veg_wall)) 1935 IF ( surf_usm_h%albedo_type(m,ind_pav_green) /= 0 ) & 1936 surf_usm_h%albedo(m,ind_pav_green) = & 1937 albedo_pars(0,surf_usm_h%albedo_type(m,ind_pav_green)) 1938 IF ( surf_usm_h%albedo_type(m,ind_wat_win) /= 0 ) & 1939 surf_usm_h%albedo(m,ind_wat_win) = & 1940 albedo_pars(0,surf_usm_h%albedo_type(m,ind_wat_win)) 2145 1941 ENDDO 2146 ! 2147 !-- Vertical surfaces 1942 2148 1943 DO l = 0, 3 2149 2150 ioff = surf_lsm_v(l)%ioff2151 joff = surf_lsm_v(l)%joff2152 1944 DO m = 1, surf_lsm_v(l)%ns 2153 i = surf_lsm_v(l)%i(m) + ioff 2154 j = surf_lsm_v(l)%j(m) + joff 1945 IF ( surf_lsm_v(l)%albedo_type(m,ind_veg_wall) /= 0 ) & 1946 surf_lsm_v(l)%albedo(m,ind_veg_wall) = & 1947 albedo_pars(0,surf_lsm_v(l)%albedo_type(m,ind_veg_wall)) 1948 IF ( surf_lsm_v(l)%albedo_type(m,ind_pav_green) /= 0 ) & 1949 surf_lsm_v(l)%albedo(m,ind_pav_green) = & 1950 albedo_pars(0,surf_lsm_v(l)%albedo_type(m,ind_pav_green)) 1951 IF ( surf_lsm_v(l)%albedo_type(m,ind_wat_win) /= 0 ) & 1952 surf_lsm_v(l)%albedo(m,ind_wat_win) = & 1953 albedo_pars(0,surf_lsm_v(l)%albedo_type(m,ind_wat_win)) 1954 ENDDO 1955 DO m = 1, surf_usm_v(l)%ns 1956 IF ( surf_usm_v(l)%albedo_type(m,ind_veg_wall) /= 0 ) & 1957 surf_usm_v(l)%albedo(m,ind_veg_wall) = & 1958 albedo_pars(0,surf_usm_v(l)%albedo_type(m,ind_veg_wall)) 1959 IF ( surf_usm_v(l)%albedo_type(m,ind_pav_green) /= 0 ) & 1960 surf_usm_v(l)%albedo(m,ind_pav_green) = & 1961 albedo_pars(0,surf_usm_v(l)%albedo_type(m,ind_pav_green)) 1962 IF ( surf_usm_v(l)%albedo_type(m,ind_wat_win) /= 0 ) & 1963 surf_usm_v(l)%albedo(m,ind_wat_win) = & 1964 albedo_pars(0,surf_usm_v(l)%albedo_type(m,ind_wat_win)) 1965 ENDDO 1966 ENDDO 1967 1968 ! 1969 !-- Level 3 initialization at grid points where albedo type is zero. 1970 !-- This case, albedo is taken from file. In case of constant radiation 1971 !-- or clear sky, only broadband albedo is given. 1972 IF ( albedo_pars_f%from_file ) THEN 1973 ! 1974 !-- Horizontal surfaces 1975 DO m = 1, surf_lsm_h%ns 1976 i = surf_lsm_h%i(m) 1977 j = surf_lsm_h%j(m) 2155 1978 IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN 2156 surf_lsm_ v(l)%albedo(m,ind_veg_wall)= albedo_pars_f%pars_xy(0,j,i)2157 surf_lsm_ v(l)%albedo(m,ind_pav_green) = albedo_pars_f%pars_xy(0,j,i)2158 surf_lsm_ v(l)%albedo(m,ind_wat_win)= albedo_pars_f%pars_xy(0,j,i)1979 surf_lsm_h%albedo(m,ind_veg_wall) = albedo_pars_f%pars_xy(0,j,i) 1980 surf_lsm_h%albedo(m,ind_pav_green) = albedo_pars_f%pars_xy(0,j,i) 1981 surf_lsm_h%albedo(m,ind_wat_win) = albedo_pars_f%pars_xy(0,j,i) 2159 1982 ENDIF 2160 1983 ENDDO 2161 2162 ioff = surf_usm_v(l)%ioff 2163 joff = surf_usm_v(l)%joff 2164 DO m = 1, surf_usm_v(l)%ns 2165 i = surf_usm_v(l)%i(m) + ioff 2166 j = surf_usm_v(l)%j(m) + joff 1984 DO m = 1, surf_usm_h%ns 1985 i = surf_usm_h%i(m) 1986 j = surf_usm_h%j(m) 2167 1987 IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN 2168 surf_usm_ v(l)%albedo(m,ind_veg_wall)= albedo_pars_f%pars_xy(0,j,i)2169 surf_usm_ v(l)%albedo(m,ind_pav_green) = albedo_pars_f%pars_xy(0,j,i)2170 surf_usm_ v(l)%albedo(m,ind_wat_win)= albedo_pars_f%pars_xy(0,j,i)1988 surf_usm_h%albedo(m,ind_veg_wall) = albedo_pars_f%pars_xy(0,j,i) 1989 surf_usm_h%albedo(m,ind_pav_green) = albedo_pars_f%pars_xy(0,j,i) 1990 surf_usm_h%albedo(m,ind_wat_win) = albedo_pars_f%pars_xy(0,j,i) 2171 1991 ENDIF 2172 1992 ENDDO 2173 ENDDO 2174 2175 ENDIF 2176 ! 2177 !-- Read explicit albedo values from building surface pars. If present, they override all less 2178 !-- specific albedo values and force a albedo_type to zero in order to take effect. 2179 IF ( building_surface_pars_f%from_file ) THEN 2180 DO m = 1, surf_usm_h%ns 2181 i = surf_usm_h%i(m) 2182 j = surf_usm_h%j(m) 2183 k = surf_usm_h%k(m) 2184 ! 2185 !-- Iterate over surfaces in column, check height and orientation 2186 DO is = building_surface_pars_f%index_ji(1,j,i), & 2187 building_surface_pars_f%index_ji(2,j,i) 2188 IF ( building_surface_pars_f%coords(4,is) == -surf_usm_h%koff .AND. & 2189 building_surface_pars_f%coords(1,is) == k ) THEN 2190 2191 IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /= & 2192 building_surface_pars_f%fill ) THEN 2193 surf_usm_h%albedo(m,ind_veg_wall) = & 2194 building_surface_pars_f%pars(ind_s_alb_b_wall,is) 2195 surf_usm_h%albedo_type(m,ind_veg_wall) = 0 1993 ! 1994 !-- Vertical surfaces 1995 DO l = 0, 3 1996 1997 ioff = surf_lsm_v(l)%ioff 1998 joff = surf_lsm_v(l)%joff 1999 DO m = 1, surf_lsm_v(l)%ns 2000 i = surf_lsm_v(l)%i(m) + ioff 2001 j = surf_lsm_v(l)%j(m) + joff 2002 IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN 2003 surf_lsm_v(l)%albedo(m,ind_veg_wall) = albedo_pars_f%pars_xy(0,j,i) 2004 surf_lsm_v(l)%albedo(m,ind_pav_green) = albedo_pars_f%pars_xy(0,j,i) 2005 surf_lsm_v(l)%albedo(m,ind_wat_win) = albedo_pars_f%pars_xy(0,j,i) 2196 2006 ENDIF 2197 2198 IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /= & 2199 building_surface_pars_f%fill ) THEN 2200 surf_usm_h%albedo(m,ind_wat_win) = & 2201 building_surface_pars_f%pars(ind_s_alb_b_win,is) 2202 surf_usm_h%albedo_type(m,ind_wat_win) = 0 2203 ENDIF 2204 2205 IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /= & 2206 building_surface_pars_f%fill ) THEN 2207 surf_usm_h%albedo(m,ind_pav_green) = & 2208 building_surface_pars_f%pars(ind_s_alb_b_green,is) 2209 surf_usm_h%albedo_type(m,ind_pav_green) = 0 2210 ENDIF 2211 2212 EXIT ! Surface was found and processed 2213 ENDIF 2214 ENDDO 2215 ENDDO 2216 2217 DO l = 0, 3 2218 DO m = 1, surf_usm_v(l)%ns 2219 i = surf_usm_v(l)%i(m) 2220 j = surf_usm_v(l)%j(m) 2221 k = surf_usm_v(l)%k(m) 2222 ! 2223 !-- Iterate over surfaces in column, check height and orientation 2224 DO is = building_surface_pars_f%index_ji(1,j,i), & 2225 building_surface_pars_f%index_ji(2,j,i) 2226 IF ( building_surface_pars_f%coords(5,is) == -surf_usm_v(l)%joff .AND. & 2227 building_surface_pars_f%coords(6,is) == -surf_usm_v(l)%ioff .AND. & 2228 building_surface_pars_f%coords(1,is) == k ) THEN 2229 2230 IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /= & 2231 building_surface_pars_f%fill ) THEN 2232 surf_usm_v(l)%albedo(m,ind_veg_wall) = & 2233 building_surface_pars_f%pars(ind_s_alb_b_wall,is) 2234 surf_usm_v(l)%albedo_type(m,ind_veg_wall) = 0 2235 ENDIF 2236 2237 IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /= & 2238 building_surface_pars_f%fill ) THEN 2239 surf_usm_v(l)%albedo(m,ind_wat_win) = & 2240 building_surface_pars_f%pars(ind_s_alb_b_win,is) 2241 surf_usm_v(l)%albedo_type(m,ind_wat_win) = 0 2242 ENDIF 2243 2244 IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /= & 2245 building_surface_pars_f%fill ) THEN 2246 surf_usm_v(l)%albedo(m,ind_pav_green) = & 2247 building_surface_pars_f%pars(ind_s_alb_b_green,is) 2248 surf_usm_v(l)%albedo_type(m,ind_pav_green) = 0 2249 ENDIF 2250 2251 EXIT ! Surface was found and processed 2007 ENDDO 2008 2009 ioff = surf_usm_v(l)%ioff 2010 joff = surf_usm_v(l)%joff 2011 DO m = 1, surf_usm_v(l)%ns 2012 i = surf_usm_v(l)%i(m) + ioff 2013 j = surf_usm_v(l)%j(m) + joff 2014 IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) THEN 2015 surf_usm_v(l)%albedo(m,ind_veg_wall) = albedo_pars_f%pars_xy(0,j,i) 2016 surf_usm_v(l)%albedo(m,ind_pav_green) = albedo_pars_f%pars_xy(0,j,i) 2017 surf_usm_v(l)%albedo(m,ind_wat_win) = albedo_pars_f%pars_xy(0,j,i) 2252 2018 ENDIF 2253 2019 ENDDO 2254 2020 ENDDO 2255 ENDDO 2256 ENDIF 2257 ! 2258 !-- Initialization actions for RRTMG 2259 ELSEIF ( radiation_scheme == 'rrtmg' ) THEN 2260 #if defined ( __rrtmg ) 2261 ! 2262 !-- Allocate albedos for short/longwave radiation, horizontal surfaces for wall/green/window 2263 !-- (USM) or vegetation/pavement/water surfaces (LSM). 2264 ALLOCATE ( surf_lsm_h%aldif(1:surf_lsm_h%ns,0:2) ) 2265 ALLOCATE ( surf_lsm_h%aldir(1:surf_lsm_h%ns,0:2) ) 2266 ALLOCATE ( surf_lsm_h%asdif(1:surf_lsm_h%ns,0:2) ) 2267 ALLOCATE ( surf_lsm_h%asdir(1:surf_lsm_h%ns,0:2) ) 2268 ALLOCATE ( surf_lsm_h%rrtm_aldif(1:surf_lsm_h%ns,0:2) ) 2269 ALLOCATE ( surf_lsm_h%rrtm_aldir(1:surf_lsm_h%ns,0:2) ) 2270 ALLOCATE ( surf_lsm_h%rrtm_asdif(1:surf_lsm_h%ns,0:2) ) 2271 ALLOCATE ( surf_lsm_h%rrtm_asdir(1:surf_lsm_h%ns,0:2) ) 2272 2273 ALLOCATE ( surf_usm_h%aldif(1:surf_usm_h%ns,0:2) ) 2274 ALLOCATE ( surf_usm_h%aldir(1:surf_usm_h%ns,0:2) ) 2275 ALLOCATE ( surf_usm_h%asdif(1:surf_usm_h%ns,0:2) ) 2276 ALLOCATE ( surf_usm_h%asdir(1:surf_usm_h%ns,0:2) ) 2277 ALLOCATE ( surf_usm_h%rrtm_aldif(1:surf_usm_h%ns,0:2) ) 2278 ALLOCATE ( surf_usm_h%rrtm_aldir(1:surf_usm_h%ns,0:2) ) 2279 ALLOCATE ( surf_usm_h%rrtm_asdif(1:surf_usm_h%ns,0:2) ) 2280 ALLOCATE ( surf_usm_h%rrtm_asdir(1:surf_usm_h%ns,0:2) ) 2281 2282 ! 2283 !-- Allocate broadband albedo (temporary for the current radiation implementations) 2284 IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) & 2285 ALLOCATE( surf_lsm_h%albedo(1:surf_lsm_h%ns,0:2) ) 2286 IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) & 2287 ALLOCATE( surf_usm_h%albedo(1:surf_usm_h%ns,0:2) ) 2288 2289 ! 2290 !-- Allocate albedos for short/longwave radiation, vertical surfaces 2291 DO l = 0, 3 2292 2293 ALLOCATE ( surf_lsm_v(l)%aldif(1:surf_lsm_v(l)%ns,0:2) ) 2294 ALLOCATE ( surf_lsm_v(l)%aldir(1:surf_lsm_v(l)%ns,0:2) ) 2295 ALLOCATE ( surf_lsm_v(l)%asdif(1:surf_lsm_v(l)%ns,0:2) ) 2296 ALLOCATE ( surf_lsm_v(l)%asdir(1:surf_lsm_v(l)%ns,0:2) ) 2297 2298 ALLOCATE ( surf_lsm_v(l)%rrtm_aldif(1:surf_lsm_v(l)%ns,0:2) ) 2299 ALLOCATE ( surf_lsm_v(l)%rrtm_aldir(1:surf_lsm_v(l)%ns,0:2) ) 2300 ALLOCATE ( surf_lsm_v(l)%rrtm_asdif(1:surf_lsm_v(l)%ns,0:2) ) 2301 ALLOCATE ( surf_lsm_v(l)%rrtm_asdir(1:surf_lsm_v(l)%ns,0:2) ) 2302 2303 ALLOCATE ( surf_usm_v(l)%aldif(1:surf_usm_v(l)%ns,0:2) ) 2304 ALLOCATE ( surf_usm_v(l)%aldir(1:surf_usm_v(l)%ns,0:2) ) 2305 ALLOCATE ( surf_usm_v(l)%asdif(1:surf_usm_v(l)%ns,0:2) ) 2306 ALLOCATE ( surf_usm_v(l)%asdir(1:surf_usm_v(l)%ns,0:2) ) 2307 2308 ALLOCATE ( surf_usm_v(l)%rrtm_aldif(1:surf_usm_v(l)%ns,0:2) ) 2309 ALLOCATE ( surf_usm_v(l)%rrtm_aldir(1:surf_usm_v(l)%ns,0:2) ) 2310 ALLOCATE ( surf_usm_v(l)%rrtm_asdif(1:surf_usm_v(l)%ns,0:2) ) 2311 ALLOCATE ( surf_usm_v(l)%rrtm_asdir(1:surf_usm_v(l)%ns,0:2) ) 2312 ! 2313 !-- Allocate broadband albedo (temporary for the current radiation implementations) 2314 IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) & 2315 ALLOCATE( surf_lsm_v(l)%albedo(1:surf_lsm_v(l)%ns,0:2) ) 2316 IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) & 2317 ALLOCATE( surf_usm_v(l)%albedo(1:surf_usm_v(l)%ns,0:2) ) 2318 2319 ENDDO 2320 ! 2321 !-- Level 1 initialization of spectral albedos via namelist paramters. Please note, this case all 2322 !-- surface tiles are initialized the same. 2323 IF ( surf_lsm_h%ns > 0 ) THEN 2324 surf_lsm_h%aldif = albedo_lw_dif 2325 surf_lsm_h%aldir = albedo_lw_dir 2326 surf_lsm_h%asdif = albedo_sw_dif 2327 surf_lsm_h%asdir = albedo_sw_dir 2328 surf_lsm_h%albedo = albedo_sw_dif 2329 ENDIF 2330 IF ( surf_usm_h%ns > 0 ) THEN 2331 IF ( surf_usm_h%albedo_from_ascii ) THEN 2332 surf_usm_h%aldif = surf_usm_h%albedo 2333 surf_usm_h%aldir = surf_usm_h%albedo 2334 surf_usm_h%asdif = surf_usm_h%albedo 2335 surf_usm_h%asdir = surf_usm_h%albedo 2336 ELSE 2337 surf_usm_h%aldif = albedo_lw_dif 2338 surf_usm_h%aldir = albedo_lw_dir 2339 surf_usm_h%asdif = albedo_sw_dif 2340 surf_usm_h%asdir = albedo_sw_dir 2341 surf_usm_h%albedo = albedo_sw_dif 2342 ENDIF 2343 ENDIF 2344 2345 DO l = 0, 3 2346 2347 IF ( surf_lsm_v(l)%ns > 0 ) THEN 2348 surf_lsm_v(l)%aldif = albedo_lw_dif 2349 surf_lsm_v(l)%aldir = albedo_lw_dir 2350 surf_lsm_v(l)%asdif = albedo_sw_dif 2351 surf_lsm_v(l)%asdir = albedo_sw_dir 2352 surf_lsm_v(l)%albedo = albedo_sw_dif 2353 ENDIF 2354 2355 IF ( surf_usm_v(l)%ns > 0 ) THEN 2356 IF ( surf_usm_v(l)%albedo_from_ascii ) THEN 2357 surf_usm_v(l)%aldif = surf_usm_v(l)%albedo 2358 surf_usm_v(l)%aldir = surf_usm_v(l)%albedo 2359 surf_usm_v(l)%asdif = surf_usm_v(l)%albedo 2360 surf_usm_v(l)%asdir = surf_usm_v(l)%albedo 2361 ELSE 2362 surf_usm_v(l)%aldif = albedo_lw_dif 2363 surf_usm_v(l)%aldir = albedo_lw_dir 2364 surf_usm_v(l)%asdif = albedo_sw_dif 2365 surf_usm_v(l)%asdir = albedo_sw_dir 2366 ENDIF 2367 ENDIF 2368 ENDDO 2369 2370 ! 2371 !-- Level 2 initialization of spectral albedos via albedo_type. 2372 !-- Please note, for natural- and urban-type surfaces, a tile approach is applied so that the 2373 !-- resulting albedo is calculated via the weighted average of respective surface fractions. 2374 DO m = 1, surf_lsm_h%ns 2375 ! 2376 !-- Spectral albedos for vegetation/pavement/water surfaces 2377 DO ind_type = 0, 2 2378 IF ( surf_lsm_h%albedo_type(m,ind_type) /= 0 ) THEN 2379 surf_lsm_h%aldif(m,ind_type) = albedo_pars(1,surf_lsm_h%albedo_type(m,ind_type)) 2380 surf_lsm_h%asdif(m,ind_type) = albedo_pars(2,surf_lsm_h%albedo_type(m,ind_type)) 2381 surf_lsm_h%aldir(m,ind_type) = albedo_pars(1,surf_lsm_h%albedo_type(m,ind_type)) 2382 surf_lsm_h%asdir(m,ind_type) = albedo_pars(2,surf_lsm_h%albedo_type(m,ind_type)) 2383 surf_lsm_h%albedo(m,ind_type) = albedo_pars(0,surf_lsm_h%albedo_type(m,ind_type)) 2384 ENDIF 2385 ENDDO 2386 2387 ENDDO 2388 ! 2389 !-- For urban surface only if albedo has not already been initialized in the urban-surface model 2390 !-- via the ASCII file. 2391 IF ( .NOT. surf_usm_h%albedo_from_ascii ) THEN 2392 DO m = 1, surf_usm_h%ns 2393 ! 2394 !-- Spectral albedos for wall/green/window surfaces 2395 DO ind_type = 0, 2 2396 IF ( surf_usm_h%albedo_type(m,ind_type) /= 0 ) THEN 2397 surf_usm_h%aldif(m,ind_type) = albedo_pars(1,surf_usm_h%albedo_type(m,ind_type)) 2398 surf_usm_h%asdif(m,ind_type) = albedo_pars(2,surf_usm_h%albedo_type(m,ind_type)) 2399 surf_usm_h%aldir(m,ind_type) = albedo_pars(1,surf_usm_h%albedo_type(m,ind_type)) 2400 surf_usm_h%asdir(m,ind_type) = albedo_pars(2,surf_usm_h%albedo_type(m,ind_type)) 2401 surf_usm_h%albedo(m,ind_type) = albedo_pars(0,surf_usm_h%albedo_type(m,ind_type)) 2402 ENDIF 2403 ENDDO 2404 2405 ENDDO 2406 ENDIF 2407 2408 DO l = 0, 3 2409 2410 DO m = 1, surf_lsm_v(l)%ns 2411 ! 2412 !-- Spectral albedos for vegetation/pavement/water surfaces 2413 DO ind_type = 0, 2 2414 IF ( surf_lsm_v(l)%albedo_type(m,ind_type) /= 0 ) THEN 2415 surf_lsm_v(l)%aldif(m,ind_type) = & 2416 albedo_pars(1,surf_lsm_v(l)%albedo_type(m,ind_type)) 2417 surf_lsm_v(l)%asdif(m,ind_type) = & 2418 albedo_pars(2,surf_lsm_v(l)%albedo_type(m,ind_type)) 2419 surf_lsm_v(l)%aldir(m,ind_type) = & 2420 albedo_pars(1,surf_lsm_v(l)%albedo_type(m,ind_type)) 2421 surf_lsm_v(l)%asdir(m,ind_type) = & 2422 albedo_pars(2,surf_lsm_v(l)%albedo_type(m,ind_type)) 2423 surf_lsm_v(l)%albedo(m,ind_type) = & 2424 albedo_pars(0,surf_lsm_v(l)%albedo_type(m,ind_type)) 2425 ENDIF 2426 ENDDO 2427 ENDDO 2428 ! 2429 !-- For urban surface only if albedo has not already been initialized in the urban-surface 2430 !-- model via the ASCII file. 2431 IF ( .NOT. surf_usm_v(l)%albedo_from_ascii ) THEN 2432 DO m = 1, surf_usm_v(l)%ns 2433 ! 2434 !-- Spectral albedos for wall/green/window surfaces 2435 DO ind_type = 0, 2 2436 IF ( surf_usm_v(l)%albedo_type(m,ind_type) /= 0 ) THEN 2437 surf_usm_v(l)%aldif(m,ind_type) = & 2438 albedo_pars(1,surf_usm_v(l)%albedo_type(m,ind_type)) 2439 surf_usm_v(l)%asdif(m,ind_type) = & 2440 albedo_pars(2,surf_usm_v(l)%albedo_type(m,ind_type)) 2441 surf_usm_v(l)%aldir(m,ind_type) = & 2442 albedo_pars(1,surf_usm_v(l)%albedo_type(m,ind_type)) 2443 surf_usm_v(l)%asdir(m,ind_type) = & 2444 albedo_pars(2,surf_usm_v(l)%albedo_type(m,ind_type)) 2445 surf_usm_v(l)%albedo(m,ind_type) = & 2446 albedo_pars(0,surf_usm_v(l)%albedo_type(m,ind_type)) 2447 ENDIF 2448 ENDDO 2449 2450 ENDDO 2451 ENDIF 2452 ENDDO 2453 ! 2454 !-- Level 3 initialization at grid points where albedo type is zero. 2455 !-- In this case, spectral albedos are taken from file if available 2456 IF ( albedo_pars_f%from_file ) THEN 2457 ! 2458 !-- Horizontal 2459 DO m = 1, surf_lsm_h%ns 2460 i = surf_lsm_h%i(m) 2461 j = surf_lsm_h%j(m) 2462 ! 2463 !-- Spectral albedos for vegetation/pavement/water surfaces 2464 DO ind_type = 0, 2 2465 IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) & 2466 surf_lsm_h%albedo(m,ind_type) = albedo_pars_f%pars_xy(0,j,i) 2467 IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) & 2468 surf_lsm_h%aldir(m,ind_type) = albedo_pars_f%pars_xy(1,j,i) 2469 IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) & 2470 surf_lsm_h%aldif(m,ind_type) = albedo_pars_f%pars_xy(1,j,i) 2471 IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) & 2472 surf_lsm_h%asdir(m,ind_type) = albedo_pars_f%pars_xy(2,j,i) 2473 IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) & 2474 surf_lsm_h%asdif(m,ind_type) = albedo_pars_f%pars_xy(2,j,i) 2475 ENDDO 2476 ENDDO 2477 ! 2478 !-- For urban surface only if albedo has not been already initialized in the urban-surface 2479 !-- model via the ASCII file. 2480 IF ( .NOT. surf_usm_h%albedo_from_ascii ) THEN 2021 2022 ENDIF 2023 ! 2024 !-- Read explicit albedo values from building surface pars. If present, 2025 !-- they override all less specific albedo values and force a albedo_type 2026 !-- to zero in order to take effect. 2027 IF ( building_surface_pars_f%from_file ) THEN 2481 2028 DO m = 1, surf_usm_h%ns 2482 2029 i = surf_usm_h%i(m) 2483 2030 j = surf_usm_h%j(m) 2484 ! 2485 !-- Broadband albedos for wall/green/window surfaces 2486 DO ind_type = 0, 2 2487 IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) & 2488 surf_usm_h%albedo(m,ind_type) = albedo_pars_f%pars_xy(0,j,i) 2489 ENDDO 2490 ! 2491 !-- Spectral albedos especially for building wall surfaces 2492 IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) THEN 2493 surf_usm_h%aldir(m,ind_veg_wall) = albedo_pars_f%pars_xy(1,j,i) 2494 surf_usm_h%aldif(m,ind_veg_wall) = albedo_pars_f%pars_xy(1,j,i) 2495 ENDIF 2496 IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) THEN 2497 surf_usm_h%asdir(m,ind_veg_wall) = albedo_pars_f%pars_xy(2,j,i) 2498 surf_usm_h%asdif(m,ind_veg_wall) = albedo_pars_f%pars_xy(2,j,i) 2499 ENDIF 2500 ! 2501 !-- Spectral albedos especially for building green surfaces 2502 IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill ) THEN 2503 surf_usm_h%aldir(m,ind_pav_green) = albedo_pars_f%pars_xy(3,j,i) 2504 surf_usm_h%aldif(m,ind_pav_green) = albedo_pars_f%pars_xy(3,j,i) 2505 ENDIF 2506 IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill ) THEN 2507 surf_usm_h%asdir(m,ind_pav_green) = albedo_pars_f%pars_xy(4,j,i) 2508 surf_usm_h%asdif(m,ind_pav_green) = albedo_pars_f%pars_xy(4,j,i) 2509 ENDIF 2510 ! 2511 !-- Spectral albedos especially for building window surfaces 2512 IF ( albedo_pars_f%pars_xy(5,j,i) /= albedo_pars_f%fill ) THEN 2513 surf_usm_h%aldir(m,ind_wat_win) = albedo_pars_f%pars_xy(5,j,i) 2514 surf_usm_h%aldif(m,ind_wat_win) = albedo_pars_f%pars_xy(5,j,i) 2515 ENDIF 2516 IF ( albedo_pars_f%pars_xy(6,j,i) /= albedo_pars_f%fill ) THEN 2517 surf_usm_h%asdir(m,ind_wat_win) = albedo_pars_f%pars_xy(6,j,i) 2518 surf_usm_h%asdif(m,ind_wat_win) = albedo_pars_f%pars_xy(6,j,i) 2519 ENDIF 2520 2521 ENDDO 2522 ENDIF 2523 ! 2524 !-- Vertical 2525 DO l = 0, 3 2526 ioff = surf_lsm_v(l)%ioff 2527 joff = surf_lsm_v(l)%joff 2528 2529 DO m = 1, surf_lsm_v(l)%ns 2530 i = surf_lsm_v(l)%i(m) 2531 j = surf_lsm_v(l)%j(m) 2532 ! 2533 !-- Spectral albedos for vegetation/pavement/water surfaces 2534 DO ind_type = 0, 2 2535 IF ( albedo_pars_f%pars_xy(0,j+joff,i+ioff) /= albedo_pars_f%fill ) & 2536 surf_lsm_v(l)%albedo(m,ind_type) = albedo_pars_f%pars_xy(0,j+joff,i+ioff) 2537 IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= albedo_pars_f%fill ) & 2538 surf_lsm_v(l)%aldir(m,ind_type) = albedo_pars_f%pars_xy(1,j+joff,i+ioff) 2539 IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= albedo_pars_f%fill ) & 2540 surf_lsm_v(l)%aldif(m,ind_type) = albedo_pars_f%pars_xy(1,j+joff,i+ioff) 2541 IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= albedo_pars_f%fill ) & 2542 surf_lsm_v(l)%asdir(m,ind_type) = albedo_pars_f%pars_xy(2,j+joff,i+ioff) 2543 IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= albedo_pars_f%fill ) & 2544 surf_lsm_v(l)%asdif(m,ind_type) = albedo_pars_f%pars_xy(2,j+joff,i+ioff) 2031 k = surf_usm_h%k(m) 2032 ! 2033 !-- Iterate over surfaces in column, check height and orientation 2034 DO is = building_surface_pars_f%index_ji(1,j,i), & 2035 building_surface_pars_f%index_ji(2,j,i) 2036 IF ( building_surface_pars_f%coords(4,is) == -surf_usm_h%koff .AND. & 2037 building_surface_pars_f%coords(1,is) == k ) THEN 2038 2039 IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /= & 2040 building_surface_pars_f%fill ) THEN 2041 surf_usm_h%albedo(m,ind_veg_wall) = & 2042 building_surface_pars_f%pars(ind_s_alb_b_wall,is) 2043 surf_usm_h%albedo_type(m,ind_veg_wall) = 0 2044 ENDIF 2045 2046 IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /= & 2047 building_surface_pars_f%fill ) THEN 2048 surf_usm_h%albedo(m,ind_wat_win) = & 2049 building_surface_pars_f%pars(ind_s_alb_b_win,is) 2050 surf_usm_h%albedo_type(m,ind_wat_win) = 0 2051 ENDIF 2052 2053 IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /= & 2054 building_surface_pars_f%fill ) THEN 2055 surf_usm_h%albedo(m,ind_pav_green) = & 2056 building_surface_pars_f%pars(ind_s_alb_b_green,is) 2057 surf_usm_h%albedo_type(m,ind_pav_green) = 0 2058 ENDIF 2059 2060 EXIT ! surface was found and processed 2061 ENDIF 2545 2062 ENDDO 2546 2063 ENDDO 2547 ! 2548 !-- For urban surface only if albedo has not already been initialized in the urban-surface 2549 !-- model via the ASCII file. 2550 IF ( .NOT. surf_usm_v(l)%albedo_from_ascii ) THEN 2551 ioff = surf_usm_v(l)%ioff 2552 joff = surf_usm_v(l)%joff 2553 2064 2065 DO l = 0, 3 2554 2066 DO m = 1, surf_usm_v(l)%ns 2555 2067 i = surf_usm_v(l)%i(m) 2556 2068 j = surf_usm_v(l)%j(m) 2557 ! 2558 !-- Broadband albedos for wall/green/window surfaces 2069 k = surf_usm_v(l)%k(m) 2070 ! 2071 !-- Iterate over surfaces in column, check height and orientation 2072 DO is = building_surface_pars_f%index_ji(1,j,i), & 2073 building_surface_pars_f%index_ji(2,j,i) 2074 IF ( building_surface_pars_f%coords(5,is) == -surf_usm_v(l)%joff .AND. & 2075 building_surface_pars_f%coords(6,is) == -surf_usm_v(l)%ioff .AND. & 2076 building_surface_pars_f%coords(1,is) == k ) THEN 2077 2078 IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /= & 2079 building_surface_pars_f%fill ) THEN 2080 surf_usm_v(l)%albedo(m,ind_veg_wall) = & 2081 building_surface_pars_f%pars(ind_s_alb_b_wall,is) 2082 surf_usm_v(l)%albedo_type(m,ind_veg_wall) = 0 2083 ENDIF 2084 2085 IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /= & 2086 building_surface_pars_f%fill ) THEN 2087 surf_usm_v(l)%albedo(m,ind_wat_win) = & 2088 building_surface_pars_f%pars(ind_s_alb_b_win,is) 2089 surf_usm_v(l)%albedo_type(m,ind_wat_win) = 0 2090 ENDIF 2091 2092 IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /= & 2093 building_surface_pars_f%fill ) THEN 2094 surf_usm_v(l)%albedo(m,ind_pav_green) = & 2095 building_surface_pars_f%pars(ind_s_alb_b_green,is) 2096 surf_usm_v(l)%albedo_type(m,ind_pav_green) = 0 2097 ENDIF 2098 2099 EXIT ! surface was found and processed 2100 ENDIF 2101 ENDDO 2102 ENDDO 2103 ENDDO 2104 ENDIF 2105 ! 2106 !-- Initialization actions for RRTMG 2107 ELSEIF ( radiation_scheme == 'rrtmg' ) THEN 2108 #if defined ( __rrtmg ) 2109 ! 2110 !-- Allocate albedos for short/longwave radiation, horizontal surfaces 2111 !-- for wall/green/window (USM) or vegetation/pavement/water surfaces 2112 !-- (LSM). 2113 ALLOCATE ( surf_lsm_h%aldif(1:surf_lsm_h%ns,0:2) ) 2114 ALLOCATE ( surf_lsm_h%aldir(1:surf_lsm_h%ns,0:2) ) 2115 ALLOCATE ( surf_lsm_h%asdif(1:surf_lsm_h%ns,0:2) ) 2116 ALLOCATE ( surf_lsm_h%asdir(1:surf_lsm_h%ns,0:2) ) 2117 ALLOCATE ( surf_lsm_h%rrtm_aldif(1:surf_lsm_h%ns,0:2) ) 2118 ALLOCATE ( surf_lsm_h%rrtm_aldir(1:surf_lsm_h%ns,0:2) ) 2119 ALLOCATE ( surf_lsm_h%rrtm_asdif(1:surf_lsm_h%ns,0:2) ) 2120 ALLOCATE ( surf_lsm_h%rrtm_asdir(1:surf_lsm_h%ns,0:2) ) 2121 2122 ALLOCATE ( surf_usm_h%aldif(1:surf_usm_h%ns,0:2) ) 2123 ALLOCATE ( surf_usm_h%aldir(1:surf_usm_h%ns,0:2) ) 2124 ALLOCATE ( surf_usm_h%asdif(1:surf_usm_h%ns,0:2) ) 2125 ALLOCATE ( surf_usm_h%asdir(1:surf_usm_h%ns,0:2) ) 2126 ALLOCATE ( surf_usm_h%rrtm_aldif(1:surf_usm_h%ns,0:2) ) 2127 ALLOCATE ( surf_usm_h%rrtm_aldir(1:surf_usm_h%ns,0:2) ) 2128 ALLOCATE ( surf_usm_h%rrtm_asdif(1:surf_usm_h%ns,0:2) ) 2129 ALLOCATE ( surf_usm_h%rrtm_asdir(1:surf_usm_h%ns,0:2) ) 2130 2131 ! 2132 !-- Allocate broadband albedo (temporary for the current radiation 2133 !-- implementations) 2134 IF ( .NOT. ALLOCATED(surf_lsm_h%albedo) ) & 2135 ALLOCATE( surf_lsm_h%albedo(1:surf_lsm_h%ns,0:2) ) 2136 IF ( .NOT. ALLOCATED(surf_usm_h%albedo) ) & 2137 ALLOCATE( surf_usm_h%albedo(1:surf_usm_h%ns,0:2) ) 2138 2139 ! 2140 !-- Allocate albedos for short/longwave radiation, vertical surfaces 2141 DO l = 0, 3 2142 2143 ALLOCATE ( surf_lsm_v(l)%aldif(1:surf_lsm_v(l)%ns,0:2) ) 2144 ALLOCATE ( surf_lsm_v(l)%aldir(1:surf_lsm_v(l)%ns,0:2) ) 2145 ALLOCATE ( surf_lsm_v(l)%asdif(1:surf_lsm_v(l)%ns,0:2) ) 2146 ALLOCATE ( surf_lsm_v(l)%asdir(1:surf_lsm_v(l)%ns,0:2) ) 2147 2148 ALLOCATE ( surf_lsm_v(l)%rrtm_aldif(1:surf_lsm_v(l)%ns,0:2) ) 2149 ALLOCATE ( surf_lsm_v(l)%rrtm_aldir(1:surf_lsm_v(l)%ns,0:2) ) 2150 ALLOCATE ( surf_lsm_v(l)%rrtm_asdif(1:surf_lsm_v(l)%ns,0:2) ) 2151 ALLOCATE ( surf_lsm_v(l)%rrtm_asdir(1:surf_lsm_v(l)%ns,0:2) ) 2152 2153 ALLOCATE ( surf_usm_v(l)%aldif(1:surf_usm_v(l)%ns,0:2) ) 2154 ALLOCATE ( surf_usm_v(l)%aldir(1:surf_usm_v(l)%ns,0:2) ) 2155 ALLOCATE ( surf_usm_v(l)%asdif(1:surf_usm_v(l)%ns,0:2) ) 2156 ALLOCATE ( surf_usm_v(l)%asdir(1:surf_usm_v(l)%ns,0:2) ) 2157 2158 ALLOCATE ( surf_usm_v(l)%rrtm_aldif(1:surf_usm_v(l)%ns,0:2) ) 2159 ALLOCATE ( surf_usm_v(l)%rrtm_aldir(1:surf_usm_v(l)%ns,0:2) ) 2160 ALLOCATE ( surf_usm_v(l)%rrtm_asdif(1:surf_usm_v(l)%ns,0:2) ) 2161 ALLOCATE ( surf_usm_v(l)%rrtm_asdir(1:surf_usm_v(l)%ns,0:2) ) 2162 ! 2163 !-- Allocate broadband albedo (temporary for the current radiation 2164 !-- implementations) 2165 IF ( .NOT. ALLOCATED( surf_lsm_v(l)%albedo ) ) & 2166 ALLOCATE( surf_lsm_v(l)%albedo(1:surf_lsm_v(l)%ns,0:2) ) 2167 IF ( .NOT. ALLOCATED( surf_usm_v(l)%albedo ) ) & 2168 ALLOCATE( surf_usm_v(l)%albedo(1:surf_usm_v(l)%ns,0:2) ) 2169 2170 ENDDO 2171 ! 2172 !-- Level 1 initialization of spectral albedos via namelist 2173 !-- paramters. Please note, this case all surface tiles are initialized 2174 !-- the same. 2175 IF ( surf_lsm_h%ns > 0 ) THEN 2176 surf_lsm_h%aldif = albedo_lw_dif 2177 surf_lsm_h%aldir = albedo_lw_dir 2178 surf_lsm_h%asdif = albedo_sw_dif 2179 surf_lsm_h%asdir = albedo_sw_dir 2180 surf_lsm_h%albedo = albedo_sw_dif 2181 ENDIF 2182 IF ( surf_usm_h%ns > 0 ) THEN 2183 IF ( surf_usm_h%albedo_from_ascii ) THEN 2184 surf_usm_h%aldif = surf_usm_h%albedo 2185 surf_usm_h%aldir = surf_usm_h%albedo 2186 surf_usm_h%asdif = surf_usm_h%albedo 2187 surf_usm_h%asdir = surf_usm_h%albedo 2188 ELSE 2189 surf_usm_h%aldif = albedo_lw_dif 2190 surf_usm_h%aldir = albedo_lw_dir 2191 surf_usm_h%asdif = albedo_sw_dif 2192 surf_usm_h%asdir = albedo_sw_dir 2193 surf_usm_h%albedo = albedo_sw_dif 2194 ENDIF 2195 ENDIF 2196 2197 DO l = 0, 3 2198 2199 IF ( surf_lsm_v(l)%ns > 0 ) THEN 2200 surf_lsm_v(l)%aldif = albedo_lw_dif 2201 surf_lsm_v(l)%aldir = albedo_lw_dir 2202 surf_lsm_v(l)%asdif = albedo_sw_dif 2203 surf_lsm_v(l)%asdir = albedo_sw_dir 2204 surf_lsm_v(l)%albedo = albedo_sw_dif 2205 ENDIF 2206 2207 IF ( surf_usm_v(l)%ns > 0 ) THEN 2208 IF ( surf_usm_v(l)%albedo_from_ascii ) THEN 2209 surf_usm_v(l)%aldif = surf_usm_v(l)%albedo 2210 surf_usm_v(l)%aldir = surf_usm_v(l)%albedo 2211 surf_usm_v(l)%asdif = surf_usm_v(l)%albedo 2212 surf_usm_v(l)%asdir = surf_usm_v(l)%albedo 2213 ELSE 2214 surf_usm_v(l)%aldif = albedo_lw_dif 2215 surf_usm_v(l)%aldir = albedo_lw_dir 2216 surf_usm_v(l)%asdif = albedo_sw_dif 2217 surf_usm_v(l)%asdir = albedo_sw_dir 2218 ENDIF 2219 ENDIF 2220 ENDDO 2221 2222 ! 2223 !-- Level 2 initialization of spectral albedos via albedo_type. 2224 !-- Please note, for natural- and urban-type surfaces, a tile approach 2225 !-- is applied so that the resulting albedo is calculated via the weighted 2226 !-- average of respective surface fractions. 2227 DO m = 1, surf_lsm_h%ns 2228 ! 2229 !-- Spectral albedos for vegetation/pavement/water surfaces 2230 DO ind_type = 0, 2 2231 IF ( surf_lsm_h%albedo_type(m,ind_type) /= 0 ) THEN 2232 surf_lsm_h%aldif(m,ind_type) = & 2233 albedo_pars(1,surf_lsm_h%albedo_type(m,ind_type)) 2234 surf_lsm_h%asdif(m,ind_type) = & 2235 albedo_pars(2,surf_lsm_h%albedo_type(m,ind_type)) 2236 surf_lsm_h%aldir(m,ind_type) = & 2237 albedo_pars(1,surf_lsm_h%albedo_type(m,ind_type)) 2238 surf_lsm_h%asdir(m,ind_type) = & 2239 albedo_pars(2,surf_lsm_h%albedo_type(m,ind_type)) 2240 surf_lsm_h%albedo(m,ind_type) = & 2241 albedo_pars(0,surf_lsm_h%albedo_type(m,ind_type)) 2242 ENDIF 2243 ENDDO 2244 2245 ENDDO 2246 ! 2247 !-- For urban surface only if albedo has not been already initialized 2248 !-- in the urban-surface model via the ASCII file. 2249 IF ( .NOT. surf_usm_h%albedo_from_ascii ) THEN 2250 DO m = 1, surf_usm_h%ns 2251 ! 2252 !-- Spectral albedos for wall/green/window surfaces 2253 DO ind_type = 0, 2 2254 IF ( surf_usm_h%albedo_type(m,ind_type) /= 0 ) THEN 2255 surf_usm_h%aldif(m,ind_type) = & 2256 albedo_pars(1,surf_usm_h%albedo_type(m,ind_type)) 2257 surf_usm_h%asdif(m,ind_type) = & 2258 albedo_pars(2,surf_usm_h%albedo_type(m,ind_type)) 2259 surf_usm_h%aldir(m,ind_type) = & 2260 albedo_pars(1,surf_usm_h%albedo_type(m,ind_type)) 2261 surf_usm_h%asdir(m,ind_type) = & 2262 albedo_pars(2,surf_usm_h%albedo_type(m,ind_type)) 2263 surf_usm_h%albedo(m,ind_type) = & 2264 albedo_pars(0,surf_usm_h%albedo_type(m,ind_type)) 2265 ENDIF 2266 ENDDO 2267 2268 ENDDO 2269 ENDIF 2270 2271 DO l = 0, 3 2272 2273 DO m = 1, surf_lsm_v(l)%ns 2274 ! 2275 !-- Spectral albedos for vegetation/pavement/water surfaces 2276 DO ind_type = 0, 2 2277 IF ( surf_lsm_v(l)%albedo_type(m,ind_type) /= 0 ) THEN 2278 surf_lsm_v(l)%aldif(m,ind_type) = & 2279 albedo_pars(1,surf_lsm_v(l)%albedo_type(m,ind_type)) 2280 surf_lsm_v(l)%asdif(m,ind_type) = & 2281 albedo_pars(2,surf_lsm_v(l)%albedo_type(m,ind_type)) 2282 surf_lsm_v(l)%aldir(m,ind_type) = & 2283 albedo_pars(1,surf_lsm_v(l)%albedo_type(m,ind_type)) 2284 surf_lsm_v(l)%asdir(m,ind_type) = & 2285 albedo_pars(2,surf_lsm_v(l)%albedo_type(m,ind_type)) 2286 surf_lsm_v(l)%albedo(m,ind_type) = & 2287 albedo_pars(0,surf_lsm_v(l)%albedo_type(m,ind_type)) 2288 ENDIF 2289 ENDDO 2290 ENDDO 2291 ! 2292 !-- For urban surface only if albedo has not been already initialized 2293 !-- in the urban-surface model via the ASCII file. 2294 IF ( .NOT. surf_usm_v(l)%albedo_from_ascii ) THEN 2295 DO m = 1, surf_usm_v(l)%ns 2296 ! 2297 !-- Spectral albedos for wall/green/window surfaces 2559 2298 DO ind_type = 0, 2 2560 IF ( albedo_pars_f%pars_xy(0,j+joff,i+ioff) /= albedo_pars_f%fill ) & 2561 surf_usm_v(l)%albedo(m,ind_type) = albedo_pars_f%pars_xy(0,j+joff,i+ioff) 2299 IF ( surf_usm_v(l)%albedo_type(m,ind_type) /= 0 ) THEN 2300 surf_usm_v(l)%aldif(m,ind_type) = & 2301 albedo_pars(1,surf_usm_v(l)%albedo_type(m,ind_type)) 2302 surf_usm_v(l)%asdif(m,ind_type) = & 2303 albedo_pars(2,surf_usm_v(l)%albedo_type(m,ind_type)) 2304 surf_usm_v(l)%aldir(m,ind_type) = & 2305 albedo_pars(1,surf_usm_v(l)%albedo_type(m,ind_type)) 2306 surf_usm_v(l)%asdir(m,ind_type) = & 2307 albedo_pars(2,surf_usm_v(l)%albedo_type(m,ind_type)) 2308 surf_usm_v(l)%albedo(m,ind_type) = & 2309 albedo_pars(0,surf_usm_v(l)%albedo_type(m,ind_type)) 2310 ENDIF 2562 2311 ENDDO 2563 ! 2564 !-- Spectral albedos especially for building wall surfaces 2565 IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= albedo_pars_f%fill ) THEN 2566 surf_usm_v(l)%aldir(m,ind_veg_wall) = albedo_pars_f%pars_xy(1,j+joff,i+ioff) 2567 surf_usm_v(l)%aldif(m,ind_veg_wall) = albedo_pars_f%pars_xy(1,j+joff,i+ioff) 2568 ENDIF 2569 IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= albedo_pars_f%fill ) THEN 2570 surf_usm_v(l)%asdir(m,ind_veg_wall) = albedo_pars_f%pars_xy(2,j+joff,i+ioff) 2571 surf_usm_v(l)%asdif(m,ind_veg_wall) = albedo_pars_f%pars_xy(2,j+joff,i+ioff) 2572 ENDIF 2573 ! 2574 !-- Spectral albedos especially for building green surfaces 2575 IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= albedo_pars_f%fill ) THEN 2576 surf_usm_v(l)%aldir(m,ind_pav_green) = albedo_pars_f%pars_xy(3,j+joff,i+ioff) 2577 surf_usm_v(l)%aldif(m,ind_pav_green) = albedo_pars_f%pars_xy(3,j+joff,i+ioff) 2578 ENDIF 2579 IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= albedo_pars_f%fill ) THEN 2580 surf_usm_v(l)%asdir(m,ind_pav_green) = albedo_pars_f%pars_xy(4,j+joff,i+ioff) 2581 surf_usm_v(l)%asdif(m,ind_pav_green) = albedo_pars_f%pars_xy(4,j+joff,i+ioff) 2582 ENDIF 2583 ! 2584 !-- Spectral albedos especially for building window surfaces 2585 IF ( albedo_pars_f%pars_xy(5,j+joff,i+ioff) /= albedo_pars_f%fill ) THEN 2586 surf_usm_v(l)%aldir(m,ind_wat_win) = albedo_pars_f%pars_xy(5,j+joff,i+ioff) 2587 surf_usm_v(l)%aldif(m,ind_wat_win) = albedo_pars_f%pars_xy(5,j+joff,i+ioff) 2588 ENDIF 2589 IF ( albedo_pars_f%pars_xy(6,j+joff,i+ioff) /= albedo_pars_f%fill ) THEN 2590 surf_usm_v(l)%asdir(m,ind_wat_win) = albedo_pars_f%pars_xy(6,j+joff,i+ioff) 2591 surf_usm_v(l)%asdif(m,ind_wat_win) = albedo_pars_f%pars_xy(6,j+joff,i+ioff) 2592 ENDIF 2312 2593 2313 ENDDO 2594 2314 ENDIF 2595 2315 ENDDO 2596 2597 ENDIF 2598 ! 2599 !-- Read explicit albedo values from building surface pars. If present they override all less 2600 !-- specific albedo values and force an albedo_type to zero in order to take effect. 2601 IF ( building_surface_pars_f%from_file ) THEN 2602 DO m = 1, surf_usm_h%ns 2603 i = surf_usm_h%i(m) 2604 j = surf_usm_h%j(m) 2605 k = surf_usm_h%k(m) 2606 ! 2607 !-- Iterate over surfaces in column, check height and orientation 2608 DO is = building_surface_pars_f%index_ji(1,j,i), & 2609 building_surface_pars_f%index_ji(2,j,i) 2610 IF ( building_surface_pars_f%coords(4,is) == -surf_usm_h%koff .AND. & 2611 building_surface_pars_f%coords(1,is) == k ) THEN 2612 2613 IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /= & 2614 building_surface_pars_f%fill ) THEN 2615 surf_usm_h%albedo(m,ind_veg_wall) = & 2616 building_surface_pars_f%pars(ind_s_alb_b_wall,is) 2617 surf_usm_h%albedo_type(m,ind_veg_wall) = 0 2316 ! 2317 !-- Level 3 initialization at grid points where albedo type is zero. 2318 !-- This case, spectral albedos are taken from file if available 2319 IF ( albedo_pars_f%from_file ) THEN 2320 ! 2321 !-- Horizontal 2322 DO m = 1, surf_lsm_h%ns 2323 i = surf_lsm_h%i(m) 2324 j = surf_lsm_h%j(m) 2325 ! 2326 !-- Spectral albedos for vegetation/pavement/water surfaces 2327 DO ind_type = 0, 2 2328 IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill ) & 2329 surf_lsm_h%albedo(m,ind_type) = & 2330 albedo_pars_f%pars_xy(0,j,i) 2331 IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) & 2332 surf_lsm_h%aldir(m,ind_type) = & 2333 albedo_pars_f%pars_xy(1,j,i) 2334 IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) & 2335 surf_lsm_h%aldif(m,ind_type) = & 2336 albedo_pars_f%pars_xy(1,j,i) 2337 IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) & 2338 surf_lsm_h%asdir(m,ind_type) = & 2339 albedo_pars_f%pars_xy(2,j,i) 2340 IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) & 2341 surf_lsm_h%asdif(m,ind_type) = & 2342 albedo_pars_f%pars_xy(2,j,i) 2343 ENDDO 2344 ENDDO 2345 ! 2346 !-- For urban surface only if albedo has not been already initialized 2347 !-- in the urban-surface model via the ASCII file. 2348 IF ( .NOT. surf_usm_h%albedo_from_ascii ) THEN 2349 DO m = 1, surf_usm_h%ns 2350 i = surf_usm_h%i(m) 2351 j = surf_usm_h%j(m) 2352 ! 2353 !-- Broadband albedos for wall/green/window surfaces 2354 DO ind_type = 0, 2 2355 IF ( albedo_pars_f%pars_xy(0,j,i) /= albedo_pars_f%fill )& 2356 surf_usm_h%albedo(m,ind_type) = & 2357 albedo_pars_f%pars_xy(0,j,i) 2358 ENDDO 2359 ! 2360 !-- Spectral albedos especially for building wall surfaces 2361 IF ( albedo_pars_f%pars_xy(1,j,i) /= albedo_pars_f%fill ) THEN 2362 surf_usm_h%aldir(m,ind_veg_wall) = & 2363 albedo_pars_f%pars_xy(1,j,i) 2364 surf_usm_h%aldif(m,ind_veg_wall) = & 2365 albedo_pars_f%pars_xy(1,j,i) 2618 2366 ENDIF 2619 2620 IF ( building_surface_pars_f%pars(ind_s_alb_l_wall,is) /= & 2621 building_surface_pars_f%fill ) THEN 2622 surf_usm_h%aldir(m,ind_veg_wall) = & 2623 building_surface_pars_f%pars(ind_s_alb_l_wall,is) 2624 surf_usm_h%aldif(m,ind_veg_wall) = & 2625 building_surface_pars_f%pars(ind_s_alb_l_wall,is) 2626 surf_usm_h%albedo_type(m,ind_veg_wall) = 0 2367 IF ( albedo_pars_f%pars_xy(2,j,i) /= albedo_pars_f%fill ) THEN 2368 surf_usm_h%asdir(m,ind_veg_wall) = & 2369 albedo_pars_f%pars_xy(2,j,i) 2370 surf_usm_h%asdif(m,ind_veg_wall) = & 2371 albedo_pars_f%pars_xy(2,j,i) 2627 2372 ENDIF 2628 2629 IF ( building_surface_pars_f%pars(ind_s_alb_s_wall,is) /= & 2630 building_surface_pars_f%fill ) THEN 2631 surf_usm_h%asdir(m,ind_veg_wall) = & 2632 building_surface_pars_f%pars(ind_s_alb_s_wall,is) 2633 surf_usm_h%asdif(m,ind_veg_wall) = & 2634 building_surface_pars_f%pars(ind_s_alb_s_wall,is) 2635 surf_usm_h%albedo_type(m,ind_veg_wall) = 0 2373 ! 2374 !-- Spectral albedos especially for building green surfaces 2375 IF ( albedo_pars_f%pars_xy(3,j,i) /= albedo_pars_f%fill ) THEN 2376 surf_usm_h%aldir(m,ind_pav_green) = & 2377 albedo_pars_f%pars_xy(3,j,i) 2378 surf_usm_h%aldif(m,ind_pav_green) = & 2379 albedo_pars_f%pars_xy(3,j,i) 2636 2380 ENDIF 2637 2638 IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /= & 2639 building_surface_pars_f%fill ) THEN 2640 surf_usm_h%albedo(m,ind_wat_win) = & 2641 building_surface_pars_f%pars(ind_s_alb_b_win,is) 2642 surf_usm_h%albedo_type(m,ind_wat_win) = 0 2381 IF ( albedo_pars_f%pars_xy(4,j,i) /= albedo_pars_f%fill ) THEN 2382 surf_usm_h%asdir(m,ind_pav_green) = & 2383 albedo_pars_f%pars_xy(4,j,i) 2384 surf_usm_h%asdif(m,ind_pav_green) = & 2385 albedo_pars_f%pars_xy(4,j,i) 2643 2386 ENDIF 2644 2645 IF ( building_surface_pars_f%pars(ind_s_alb_l_win,is) /= & 2646 building_surface_pars_f%fill ) THEN 2647 surf_usm_h%aldir(m,ind_wat_win) = & 2648 building_surface_pars_f%pars(ind_s_alb_l_win,is) 2649 surf_usm_h%aldif(m,ind_wat_win) = & 2650 building_surface_pars_f%pars(ind_s_alb_l_win,is) 2651 surf_usm_h%albedo_type(m,ind_wat_win) = 0 2387 ! 2388 !-- Spectral albedos especially for building window surfaces 2389 IF ( albedo_pars_f%pars_xy(5,j,i) /= albedo_pars_f%fill ) THEN 2390 surf_usm_h%aldir(m,ind_wat_win) = & 2391 albedo_pars_f%pars_xy(5,j,i) 2392 surf_usm_h%aldif(m,ind_wat_win) = & 2393 albedo_pars_f%pars_xy(5,j,i) 2652 2394 ENDIF 2653 2654 IF ( building_surface_pars_f%pars(ind_s_alb_s_win,is) /= & 2655 building_surface_pars_f%fill ) THEN 2656 surf_usm_h%asdir(m,ind_wat_win) = & 2657 building_surface_pars_f%pars(ind_s_alb_s_win,is) 2658 surf_usm_h%asdif(m,ind_wat_win) = & 2659 building_surface_pars_f%pars(ind_s_alb_s_win,is) 2660 surf_usm_h%albedo_type(m,ind_wat_win) = 0 2395 IF ( albedo_pars_f%pars_xy(6,j,i) /= albedo_pars_f%fill ) THEN 2396 surf_usm_h%asdir(m,ind_wat_win) = & 2397 albedo_pars_f%pars_xy(6,j,i) 2398 surf_usm_h%asdif(m,ind_wat_win) = & 2399 albedo_pars_f%pars_xy(6,j,i) 2661 2400 ENDIF 2662 2401 2663 IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /= & 2664 building_surface_pars_f%fill ) THEN 2665 surf_usm_h%albedo(m,ind_pav_green) = & 2666 building_surface_pars_f%pars(ind_s_alb_b_green,is) 2667 surf_usm_h%albedo_type(m,ind_pav_green) = 0 2668 ENDIF 2669 2670 IF ( building_surface_pars_f%pars(ind_s_alb_l_green,is) /= & 2671 building_surface_pars_f%fill ) THEN 2672 surf_usm_h%aldir(m,ind_pav_green) = & 2673 building_surface_pars_f%pars(ind_s_alb_l_green,is) 2674 surf_usm_h%aldif(m,ind_pav_green) = & 2675 building_surface_pars_f%pars(ind_s_alb_l_green,is) 2676 surf_usm_h%albedo_type(m,ind_pav_green) = 0 2677 ENDIF 2678 2679 IF ( building_surface_pars_f%pars(ind_s_alb_s_green,is) /= & 2680 building_surface_pars_f%fill ) THEN 2681 surf_usm_h%asdir(m,ind_pav_green) = & 2682 building_surface_pars_f%pars(ind_s_alb_s_green,is) 2683 surf_usm_h%asdif(m,ind_pav_green) = & 2684 building_surface_pars_f%pars(ind_s_alb_s_green,is) 2685 surf_usm_h%albedo_type(m,ind_pav_green) = 0 2686 ENDIF 2687 2688 EXIT ! Surface was found and processed 2402 ENDDO 2403 ENDIF 2404 ! 2405 !-- Vertical 2406 DO l = 0, 3 2407 ioff = surf_lsm_v(l)%ioff 2408 joff = surf_lsm_v(l)%joff 2409 2410 DO m = 1, surf_lsm_v(l)%ns 2411 i = surf_lsm_v(l)%i(m) 2412 j = surf_lsm_v(l)%j(m) 2413 ! 2414 !-- Spectral albedos for vegetation/pavement/water surfaces 2415 DO ind_type = 0, 2 2416 IF ( albedo_pars_f%pars_xy(0,j+joff,i+ioff) /= & 2417 albedo_pars_f%fill ) & 2418 surf_lsm_v(l)%albedo(m,ind_type) = & 2419 albedo_pars_f%pars_xy(0,j+joff,i+ioff) 2420 IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & 2421 albedo_pars_f%fill ) & 2422 surf_lsm_v(l)%aldir(m,ind_type) = & 2423 albedo_pars_f%pars_xy(1,j+joff,i+ioff) 2424 IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & 2425 albedo_pars_f%fill ) & 2426 surf_lsm_v(l)%aldif(m,ind_type) = & 2427 albedo_pars_f%pars_xy(1,j+joff,i+ioff) 2428 IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= & 2429 albedo_pars_f%fill ) & 2430 surf_lsm_v(l)%asdir(m,ind_type) = & 2431 albedo_pars_f%pars_xy(2,j+joff,i+ioff) 2432 IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= & 2433 albedo_pars_f%fill ) & 2434 surf_lsm_v(l)%asdif(m,ind_type) = & 2435 albedo_pars_f%pars_xy(2,j+joff,i+ioff) 2436 ENDDO 2437 ENDDO 2438 ! 2439 !-- For urban surface only if albedo has not been already initialized 2440 !-- in the urban-surface model via the ASCII file. 2441 IF ( .NOT. surf_usm_v(l)%albedo_from_ascii ) THEN 2442 ioff = surf_usm_v(l)%ioff 2443 joff = surf_usm_v(l)%joff 2444 2445 DO m = 1, surf_usm_v(l)%ns 2446 i = surf_usm_v(l)%i(m) 2447 j = surf_usm_v(l)%j(m) 2448 ! 2449 !-- Broadband albedos for wall/green/window surfaces 2450 DO ind_type = 0, 2 2451 IF ( albedo_pars_f%pars_xy(0,j+joff,i+ioff) /= & 2452 albedo_pars_f%fill ) & 2453 surf_usm_v(l)%albedo(m,ind_type) = & 2454 albedo_pars_f%pars_xy(0,j+joff,i+ioff) 2455 ENDDO 2456 ! 2457 !-- Spectral albedos especially for building wall surfaces 2458 IF ( albedo_pars_f%pars_xy(1,j+joff,i+ioff) /= & 2459 albedo_pars_f%fill ) THEN 2460 surf_usm_v(l)%aldir(m,ind_veg_wall) = & 2461 albedo_pars_f%pars_xy(1,j+joff,i+ioff) 2462 surf_usm_v(l)%aldif(m,ind_veg_wall) = & 2463 albedo_pars_f%pars_xy(1,j+joff,i+ioff) 2464 ENDIF 2465 IF ( albedo_pars_f%pars_xy(2,j+joff,i+ioff) /= & 2466 albedo_pars_f%fill ) THEN 2467 surf_usm_v(l)%asdir(m,ind_veg_wall) = & 2468 albedo_pars_f%pars_xy(2,j+joff,i+ioff) 2469 surf_usm_v(l)%asdif(m,ind_veg_wall) = & 2470 albedo_pars_f%pars_xy(2,j+joff,i+ioff) 2471 ENDIF 2472 ! 2473 !-- Spectral albedos especially for building green surfaces 2474 IF ( albedo_pars_f%pars_xy(3,j+joff,i+ioff) /= & 2475 albedo_pars_f%fill ) THEN 2476 surf_usm_v(l)%aldir(m,ind_pav_green) = & 2477 albedo_pars_f%pars_xy(3,j+joff,i+ioff) 2478 surf_usm_v(l)%aldif(m,ind_pav_green) = & 2479 albedo_pars_f%pars_xy(3,j+joff,i+ioff) 2480 ENDIF 2481 IF ( albedo_pars_f%pars_xy(4,j+joff,i+ioff) /= & 2482 albedo_pars_f%fill ) THEN 2483 surf_usm_v(l)%asdir(m,ind_pav_green) = & 2484 albedo_pars_f%pars_xy(4,j+joff,i+ioff) 2485 surf_usm_v(l)%asdif(m,ind_pav_green) = & 2486 albedo_pars_f%pars_xy(4,j+joff,i+ioff) 2487 ENDIF 2488 ! 2489 !-- Spectral albedos especially for building window surfaces 2490 IF ( albedo_pars_f%pars_xy(5,j+joff,i+ioff) /= & 2491 albedo_pars_f%fill ) THEN 2492 surf_usm_v(l)%aldir(m,ind_wat_win) = & 2493 albedo_pars_f%pars_xy(5,j+joff,i+ioff) 2494 surf_usm_v(l)%aldif(m,ind_wat_win) = & 2495 albedo_pars_f%pars_xy(5,j+joff,i+ioff) 2496 ENDIF 2497 IF ( albedo_pars_f%pars_xy(6,j+joff,i+ioff) /= & 2498 albedo_pars_f%fill ) THEN 2499 surf_usm_v(l)%asdir(m,ind_wat_win) = & 2500 albedo_pars_f%pars_xy(6,j+joff,i+ioff) 2501 surf_usm_v(l)%asdif(m,ind_wat_win) = & 2502 albedo_pars_f%pars_xy(6,j+joff,i+ioff) 2503 ENDIF 2504 ENDDO 2689 2505 ENDIF 2690 2506 ENDDO 2691 ENDDO 2692 2693 DO l = 0, 3 2694 DO m = 1, surf_usm_v(l)%ns 2695 i = surf_usm_v(l)%i(m) 2696 j = surf_usm_v(l)%j(m) 2697 k = surf_usm_v(l)%k(m) 2507 2508 ENDIF 2509 ! 2510 !-- Read explicit albedo values from building surface pars. If present, 2511 !-- they override all less specific albedo values and force a albedo_type 2512 !-- to zero in order to take effect. 2513 IF ( building_surface_pars_f%from_file ) THEN 2514 DO m = 1, surf_usm_h%ns 2515 i = surf_usm_h%i(m) 2516 j = surf_usm_h%j(m) 2517 k = surf_usm_h%k(m) 2698 2518 ! 2699 2519 !-- Iterate over surfaces in column, check height and orientation 2700 DO is = building_surface_pars_f%index_ji(1,j,i), 2520 DO is = building_surface_pars_f%index_ji(1,j,i), & 2701 2521 building_surface_pars_f%index_ji(2,j,i) 2702 IF ( building_surface_pars_f%coords(5,is) == -surf_usm_v(l)%joff .AND. & 2703 building_surface_pars_f%coords(6,is) == -surf_usm_v(l)%ioff .AND. & 2522 IF ( building_surface_pars_f%coords(4,is) == -surf_usm_h%koff .AND. & 2704 2523 building_surface_pars_f%coords(1,is) == k ) THEN 2705 2524 2706 IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /= 2525 IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /= & 2707 2526 building_surface_pars_f%fill ) THEN 2708 surf_usm_ v(l)%albedo(m,ind_veg_wall) =&2527 surf_usm_h%albedo(m,ind_veg_wall) = & 2709 2528 building_surface_pars_f%pars(ind_s_alb_b_wall,is) 2710 surf_usm_ v(l)%albedo_type(m,ind_veg_wall) = 02529 surf_usm_h%albedo_type(m,ind_veg_wall) = 0 2711 2530 ENDIF 2712 2531 2713 IF ( building_surface_pars_f%pars(ind_s_alb_l_wall,is) /= 2532 IF ( building_surface_pars_f%pars(ind_s_alb_l_wall,is) /= & 2714 2533 building_surface_pars_f%fill ) THEN 2715 surf_usm_ v(l)%aldir(m,ind_veg_wall) =&2534 surf_usm_h%aldir(m,ind_veg_wall) = & 2716 2535 building_surface_pars_f%pars(ind_s_alb_l_wall,is) 2717 surf_usm_ v(l)%aldif(m,ind_veg_wall) =&2536 surf_usm_h%aldif(m,ind_veg_wall) = & 2718 2537 building_surface_pars_f%pars(ind_s_alb_l_wall,is) 2719 surf_usm_ v(l)%albedo_type(m,ind_veg_wall) = 02538 surf_usm_h%albedo_type(m,ind_veg_wall) = 0 2720 2539 ENDIF 2721 2540 2722 IF ( building_surface_pars_f%pars(ind_s_alb_s_wall,is) /= 2541 IF ( building_surface_pars_f%pars(ind_s_alb_s_wall,is) /= & 2723 2542 building_surface_pars_f%fill ) THEN 2724 surf_usm_ v(l)%asdir(m,ind_veg_wall) =&2543 surf_usm_h%asdir(m,ind_veg_wall) = & 2725 2544 building_surface_pars_f%pars(ind_s_alb_s_wall,is) 2726 surf_usm_ v(l)%asdif(m,ind_veg_wall) =&2545 surf_usm_h%asdif(m,ind_veg_wall) = & 2727 2546 building_surface_pars_f%pars(ind_s_alb_s_wall,is) 2728 surf_usm_ v(l)%albedo_type(m,ind_veg_wall) = 02547 surf_usm_h%albedo_type(m,ind_veg_wall) = 0 2729 2548 ENDIF 2730 2549 2731 IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /= 2550 IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /= & 2732 2551 building_surface_pars_f%fill ) THEN 2733 surf_usm_ v(l)%albedo(m,ind_wat_win) =&2552 surf_usm_h%albedo(m,ind_wat_win) = & 2734 2553 building_surface_pars_f%pars(ind_s_alb_b_win,is) 2735 surf_usm_ v(l)%albedo_type(m,ind_wat_win) = 02554 surf_usm_h%albedo_type(m,ind_wat_win) = 0 2736 2555 ENDIF 2737 2556 2738 IF ( building_surface_pars_f%pars(ind_s_alb_l_win,is) /= 2557 IF ( building_surface_pars_f%pars(ind_s_alb_l_win,is) /= & 2739 2558 building_surface_pars_f%fill ) THEN 2740 surf_usm_ v(l)%aldir(m,ind_wat_win) =&2559 surf_usm_h%aldir(m,ind_wat_win) = & 2741 2560 building_surface_pars_f%pars(ind_s_alb_l_win,is) 2742 surf_usm_ v(l)%aldif(m,ind_wat_win) =&2561 surf_usm_h%aldif(m,ind_wat_win) = & 2743 2562 building_surface_pars_f%pars(ind_s_alb_l_win,is) 2744 surf_usm_ v(l)%albedo_type(m,ind_wat_win) = 02563 surf_usm_h%albedo_type(m,ind_wat_win) = 0 2745 2564 ENDIF 2746 2565 2747 IF ( building_surface_pars_f%pars(ind_s_alb_s_win,is) /= 2566 IF ( building_surface_pars_f%pars(ind_s_alb_s_win,is) /= & 2748 2567 building_surface_pars_f%fill ) THEN 2749 surf_usm_ v(l)%asdir(m,ind_wat_win) =&2568 surf_usm_h%asdir(m,ind_wat_win) = & 2750 2569 building_surface_pars_f%pars(ind_s_alb_s_win,is) 2751 surf_usm_ v(l)%asdif(m,ind_wat_win) =&2570 surf_usm_h%asdif(m,ind_wat_win) = & 2752 2571 building_surface_pars_f%pars(ind_s_alb_s_win,is) 2753 surf_usm_ v(l)%albedo_type(m,ind_wat_win) = 02572 surf_usm_h%albedo_type(m,ind_wat_win) = 0 2754 2573 ENDIF 2755 2574 2756 IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /= 2575 IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /= & 2757 2576 building_surface_pars_f%fill ) THEN 2758 surf_usm_ v(l)%albedo(m,ind_pav_green) =&2577 surf_usm_h%albedo(m,ind_pav_green) = & 2759 2578 building_surface_pars_f%pars(ind_s_alb_b_green,is) 2760 surf_usm_ v(l)%albedo_type(m,ind_pav_green) = 02579 surf_usm_h%albedo_type(m,ind_pav_green) = 0 2761 2580 ENDIF 2762 2581 2763 IF ( building_surface_pars_f%pars(ind_s_alb_l_green,is) /= 2582 IF ( building_surface_pars_f%pars(ind_s_alb_l_green,is) /= & 2764 2583 building_surface_pars_f%fill ) THEN 2765 surf_usm_ v(l)%aldir(m,ind_pav_green) =&2584 surf_usm_h%aldir(m,ind_pav_green) = & 2766 2585 building_surface_pars_f%pars(ind_s_alb_l_green,is) 2767 surf_usm_ v(l)%aldif(m,ind_pav_green) =&2586 surf_usm_h%aldif(m,ind_pav_green) = & 2768 2587 building_surface_pars_f%pars(ind_s_alb_l_green,is) 2769 surf_usm_ v(l)%albedo_type(m,ind_pav_green) = 02588 surf_usm_h%albedo_type(m,ind_pav_green) = 0 2770 2589 ENDIF 2771 2590 2772 IF ( building_surface_pars_f%pars(ind_s_alb_s_green,is) /= 2591 IF ( building_surface_pars_f%pars(ind_s_alb_s_green,is) /= & 2773 2592 building_surface_pars_f%fill ) THEN 2774 surf_usm_ v(l)%asdir(m,ind_pav_green) =&2593 surf_usm_h%asdir(m,ind_pav_green) = & 2775 2594 building_surface_pars_f%pars(ind_s_alb_s_green,is) 2776 surf_usm_ v(l)%asdif(m,ind_pav_green) =&2595 surf_usm_h%asdif(m,ind_pav_green) = & 2777 2596 building_surface_pars_f%pars(ind_s_alb_s_green,is) 2778 surf_usm_ v(l)%albedo_type(m,ind_pav_green) = 02597 surf_usm_h%albedo_type(m,ind_pav_green) = 0 2779 2598 ENDIF 2780 2599 2781 EXIT ! Surface was found and processed2600 EXIT ! surface was found and processed 2782 2601 ENDIF 2783 2602 ENDDO 2784 2603 ENDDO 2785 ENDDO 2604 2605 DO l = 0, 3 2606 DO m = 1, surf_usm_v(l)%ns 2607 i = surf_usm_v(l)%i(m) 2608 j = surf_usm_v(l)%j(m) 2609 k = surf_usm_v(l)%k(m) 2610 ! 2611 !-- Iterate over surfaces in column, check height and orientation 2612 DO is = building_surface_pars_f%index_ji(1,j,i), & 2613 building_surface_pars_f%index_ji(2,j,i) 2614 IF ( building_surface_pars_f%coords(5,is) == -surf_usm_v(l)%joff .AND. & 2615 building_surface_pars_f%coords(6,is) == -surf_usm_v(l)%ioff .AND. & 2616 building_surface_pars_f%coords(1,is) == k ) THEN 2617 2618 IF ( building_surface_pars_f%pars(ind_s_alb_b_wall,is) /= & 2619 building_surface_pars_f%fill ) THEN 2620 surf_usm_v(l)%albedo(m,ind_veg_wall) = & 2621 building_surface_pars_f%pars(ind_s_alb_b_wall,is) 2622 surf_usm_v(l)%albedo_type(m,ind_veg_wall) = 0 2623 ENDIF 2624 2625 IF ( building_surface_pars_f%pars(ind_s_alb_l_wall,is) /= & 2626 building_surface_pars_f%fill ) THEN 2627 surf_usm_v(l)%aldir(m,ind_veg_wall) = & 2628 building_surface_pars_f%pars(ind_s_alb_l_wall,is) 2629 surf_usm_v(l)%aldif(m,ind_veg_wall) = & 2630 building_surface_pars_f%pars(ind_s_alb_l_wall,is) 2631 surf_usm_v(l)%albedo_type(m,ind_veg_wall) = 0 2632 ENDIF 2633 2634 IF ( building_surface_pars_f%pars(ind_s_alb_s_wall,is) /= & 2635 building_surface_pars_f%fill ) THEN 2636 surf_usm_v(l)%asdir(m,ind_veg_wall) = & 2637 building_surface_pars_f%pars(ind_s_alb_s_wall,is) 2638 surf_usm_v(l)%asdif(m,ind_veg_wall) = & 2639 building_surface_pars_f%pars(ind_s_alb_s_wall,is) 2640 surf_usm_v(l)%albedo_type(m,ind_veg_wall) = 0 2641 ENDIF 2642 2643 IF ( building_surface_pars_f%pars(ind_s_alb_b_win,is) /= & 2644 building_surface_pars_f%fill ) THEN 2645 surf_usm_v(l)%albedo(m,ind_wat_win) = & 2646 building_surface_pars_f%pars(ind_s_alb_b_win,is) 2647 surf_usm_v(l)%albedo_type(m,ind_wat_win) = 0 2648 ENDIF 2649 2650 IF ( building_surface_pars_f%pars(ind_s_alb_l_win,is) /= & 2651 building_surface_pars_f%fill ) THEN 2652 surf_usm_v(l)%aldir(m,ind_wat_win) = & 2653 building_surface_pars_f%pars(ind_s_alb_l_win,is) 2654 surf_usm_v(l)%aldif(m,ind_wat_win) = & 2655 building_surface_pars_f%pars(ind_s_alb_l_win,is) 2656 surf_usm_v(l)%albedo_type(m,ind_wat_win) = 0 2657 ENDIF 2658 2659 IF ( building_surface_pars_f%pars(ind_s_alb_s_win,is) /= & 2660 building_surface_pars_f%fill ) THEN 2661 surf_usm_v(l)%asdir(m,ind_wat_win) = & 2662 building_surface_pars_f%pars(ind_s_alb_s_win,is) 2663 surf_usm_v(l)%asdif(m,ind_wat_win) = & 2664 building_surface_pars_f%pars(ind_s_alb_s_win,is) 2665 surf_usm_v(l)%albedo_type(m,ind_wat_win) = 0 2666 ENDIF 2667 2668 IF ( building_surface_pars_f%pars(ind_s_alb_b_green,is) /= & 2669 building_surface_pars_f%fill ) THEN 2670 surf_usm_v(l)%albedo(m,ind_pav_green) = & 2671 building_surface_pars_f%pars(ind_s_alb_b_green,is) 2672 surf_usm_v(l)%albedo_type(m,ind_pav_green) = 0 2673 ENDIF 2674 2675 IF ( building_surface_pars_f%pars(ind_s_alb_l_green,is) /= & 2676 building_surface_pars_f%fill ) THEN 2677 surf_usm_v(l)%aldir(m,ind_pav_green) = & 2678 building_surface_pars_f%pars(ind_s_alb_l_green,is) 2679 surf_usm_v(l)%aldif(m,ind_pav_green) = & 2680 building_surface_pars_f%pars(ind_s_alb_l_green,is) 2681 surf_usm_v(l)%albedo_type(m,ind_pav_green) = 0 2682 ENDIF 2683 2684 IF ( building_surface_pars_f%pars(ind_s_alb_s_green,is) /= & 2685 building_surface_pars_f%fill ) THEN 2686 surf_usm_v(l)%asdir(m,ind_pav_green) = & 2687 building_surface_pars_f%pars(ind_s_alb_s_green,is) 2688 surf_usm_v(l)%asdif(m,ind_pav_green) = & 2689 building_surface_pars_f%pars(ind_s_alb_s_green,is) 2690 surf_usm_v(l)%albedo_type(m,ind_pav_green) = 0 2691 ENDIF 2692 2693 EXIT ! surface was found and processed 2694 ENDIF 2695 ENDDO 2696 ENDDO 2697 ENDDO 2698 ENDIF 2699 2700 ! 2701 !-- Calculate initial values of current (cosine of) the zenith angle and 2702 !-- whether the sun is up 2703 CALL get_date_time( time_since_reference_point, & 2704 day_of_year=day_of_year, & 2705 second_of_day=second_of_day ) 2706 CALL calc_zenith( day_of_year, second_of_day ) 2707 ! 2708 !-- Calculate initial surface albedo for different surfaces 2709 IF ( .NOT. constant_albedo ) THEN 2710 #if defined( __netcdf ) 2711 ! 2712 !-- Horizontally aligned natural and urban surfaces 2713 CALL calc_albedo( surf_lsm_h ) 2714 CALL calc_albedo( surf_usm_h ) 2715 ! 2716 !-- Vertically aligned natural and urban surfaces 2717 DO l = 0, 3 2718 CALL calc_albedo( surf_lsm_v(l) ) 2719 CALL calc_albedo( surf_usm_v(l) ) 2720 ENDDO 2721 #endif 2722 ELSE 2723 ! 2724 !-- Initialize sun-inclination independent spectral albedos 2725 !-- Horizontal surfaces 2726 IF ( surf_lsm_h%ns > 0 ) THEN 2727 surf_lsm_h%rrtm_aldir = surf_lsm_h%aldir 2728 surf_lsm_h%rrtm_asdir = surf_lsm_h%asdir 2729 surf_lsm_h%rrtm_aldif = surf_lsm_h%aldif 2730 surf_lsm_h%rrtm_asdif = surf_lsm_h%asdif 2731 ENDIF 2732 IF ( surf_usm_h%ns > 0 ) THEN 2733 surf_usm_h%rrtm_aldir = surf_usm_h%aldir 2734 surf_usm_h%rrtm_asdir = surf_usm_h%asdir 2735 surf_usm_h%rrtm_aldif = surf_usm_h%aldif 2736 surf_usm_h%rrtm_asdif = surf_usm_h%asdif 2737 ENDIF 2738 ! 2739 !-- Vertical surfaces 2740 DO l = 0, 3 2741 IF ( surf_lsm_v(l)%ns > 0 ) THEN 2742 surf_lsm_v(l)%rrtm_aldir = surf_lsm_v(l)%aldir 2743 surf_lsm_v(l)%rrtm_asdir = surf_lsm_v(l)%asdir 2744 surf_lsm_v(l)%rrtm_aldif = surf_lsm_v(l)%aldif 2745 surf_lsm_v(l)%rrtm_asdif = surf_lsm_v(l)%asdif 2746 ENDIF 2747 IF ( surf_usm_v(l)%ns > 0 ) THEN 2748 surf_usm_v(l)%rrtm_aldir = surf_usm_v(l)%aldir 2749 surf_usm_v(l)%rrtm_asdir = surf_usm_v(l)%asdir 2750 surf_usm_v(l)%rrtm_aldif = surf_usm_v(l)%aldif 2751 surf_usm_v(l)%rrtm_asdif = surf_usm_v(l)%asdif 2752 ENDIF 2753 ENDDO 2754 2755 ENDIF 2756 2757 ! 2758 !-- Allocate 3d arrays of radiative fluxes and heating rates 2759 IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN 2760 ALLOCATE ( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2761 rad_sw_in = 0.0_wp 2762 ENDIF 2763 2764 IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN 2765 ALLOCATE ( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2766 ENDIF 2767 2768 IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN 2769 ALLOCATE ( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2770 rad_sw_out = 0.0_wp 2771 ENDIF 2772 2773 IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN 2774 ALLOCATE ( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2775 ENDIF 2776 2777 IF ( .NOT. ALLOCATED ( rad_sw_hr ) ) THEN 2778 ALLOCATE ( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2779 rad_sw_hr = 0.0_wp 2780 ENDIF 2781 2782 IF ( .NOT. ALLOCATED ( rad_sw_hr_av ) ) THEN 2783 ALLOCATE ( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2784 rad_sw_hr_av = 0.0_wp 2785 ENDIF 2786 2787 IF ( .NOT. ALLOCATED ( rad_sw_cs_hr ) ) THEN 2788 ALLOCATE ( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2789 rad_sw_cs_hr = 0.0_wp 2790 ENDIF 2791 2792 IF ( .NOT. ALLOCATED ( rad_sw_cs_hr_av ) ) THEN 2793 ALLOCATE ( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2794 rad_sw_cs_hr_av = 0.0_wp 2795 ENDIF 2796 2797 IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN 2798 ALLOCATE ( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2799 rad_lw_in = 0.0_wp 2800 ENDIF 2801 2802 IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN 2803 ALLOCATE ( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2804 ENDIF 2805 2806 IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN 2807 ALLOCATE ( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2808 rad_lw_out = 0.0_wp 2809 ENDIF 2810 2811 IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN 2812 ALLOCATE ( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2813 ENDIF 2814 2815 IF ( .NOT. ALLOCATED ( rad_lw_hr ) ) THEN 2816 ALLOCATE ( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2817 rad_lw_hr = 0.0_wp 2818 ENDIF 2819 2820 IF ( .NOT. ALLOCATED ( rad_lw_hr_av ) ) THEN 2821 ALLOCATE ( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2822 rad_lw_hr_av = 0.0_wp 2823 ENDIF 2824 2825 IF ( .NOT. ALLOCATED ( rad_lw_cs_hr ) ) THEN 2826 ALLOCATE ( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2827 rad_lw_cs_hr = 0.0_wp 2828 ENDIF 2829 2830 IF ( .NOT. ALLOCATED ( rad_lw_cs_hr_av ) ) THEN 2831 ALLOCATE ( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2832 rad_lw_cs_hr_av = 0.0_wp 2833 ENDIF 2834 2835 ALLOCATE ( rad_sw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2836 ALLOCATE ( rad_sw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2837 rad_sw_cs_in = 0.0_wp 2838 rad_sw_cs_out = 0.0_wp 2839 2840 ALLOCATE ( rad_lw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2841 ALLOCATE ( rad_lw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2842 rad_lw_cs_in = 0.0_wp 2843 rad_lw_cs_out = 0.0_wp 2844 2845 ! 2846 !-- Allocate 1-element array for surface temperature 2847 !-- (RRTMG anticipates an array as passed argument). 2848 ALLOCATE ( rrtm_tsfc(1) ) 2849 ! 2850 !-- Allocate surface emissivity. 2851 !-- Values will be given directly before calling rrtm_lw. 2852 ALLOCATE ( rrtm_emis(0:0,1:nbndlw+1) ) 2853 2854 ! 2855 !-- Initialize RRTMG, before check if files are existent 2856 INQUIRE( FILE='rrtmg_lw.nc', EXIST=lw_exists ) 2857 IF ( .NOT. lw_exists ) THEN 2858 message_string = 'Input file rrtmg_lw.nc' // & 2859 '&for rrtmg missing. ' // & 2860 '&Please provide <jobname>_lsw file in the INPUT directory.' 2861 CALL message( 'radiation_init', 'PA0583', 1, 2, 0, 6, 0 ) 2862 ENDIF 2863 INQUIRE( FILE='rrtmg_sw.nc', EXIST=sw_exists ) 2864 IF ( .NOT. sw_exists ) THEN 2865 message_string = 'Input file rrtmg_sw.nc' // & 2866 '&for rrtmg missing. ' // & 2867 '&Please provide <jobname>_rsw file in the INPUT directory.' 2868 CALL message( 'radiation_init', 'PA0584', 1, 2, 0, 6, 0 ) 2869 ENDIF 2870 2871 IF ( lw_radiation ) CALL rrtmg_lw_ini ( c_p ) 2872 IF ( sw_radiation ) CALL rrtmg_sw_ini ( c_p ) 2873 2874 ! 2875 !-- Set input files for RRTMG 2876 INQUIRE(FILE="RAD_SND_DATA", EXIST=snd_exists) 2877 IF ( .NOT. snd_exists ) THEN 2878 rrtm_input_file = "rrtmg_lw.nc" 2879 ENDIF 2880 2881 ! 2882 !-- Read vertical layers for RRTMG from sounding data 2883 !-- The routine provides nzt_rad, hyp_snd(1:nzt_rad), 2884 !-- t_snd(nzt+2:nzt_rad), rrtm_play(1:nzt_rad), rrtm_plev(1_nzt_rad+1), 2885 !-- rrtm_tlay(nzt+2:nzt_rad), rrtm_tlev(nzt+2:nzt_rad+1) 2886 CALL read_sounding_data 2887 2888 ! 2889 !-- Read trace gas profiles from file. This routine provides 2890 !-- the rrtm_ arrays (1:nzt_rad+1) 2891 CALL read_trace_gas_data 2892 #endif 2786 2893 ENDIF 2787 2788 ! 2789 !-- Calculate initial values of current (cosine of) zenith angle and whether the sun is up 2790 CALL get_date_time( time_since_reference_point, day_of_year = day_of_year, & 2791 second_of_day = second_of_day ) 2792 CALL calc_zenith( day_of_year, second_of_day ) 2793 ! 2794 !-- Calculate initial surface albedo for different surfaces 2795 IF ( .NOT. constant_albedo ) THEN 2894 ! 2895 !-- Initializaion actions exclusively required for external 2896 !-- radiation forcing 2897 IF ( radiation_scheme == 'external' ) THEN 2898 ! 2899 !-- Open the radiation input file. Note, for child domain, a dynamic 2900 !-- input file is often not provided. In order to do not need to 2901 !-- duplicate the dynamic input file just for the radiation input, take 2902 !-- it from the dynamic file for the parent if not available for the 2903 !-- child domain(s). In this case this is possible because radiation 2904 !-- input should be the same for each model. 2905 INQUIRE( FILE = TRIM( input_file_dynamic ), & 2906 EXIST = radiation_input_root_domain ) 2907 2908 IF ( .NOT. input_pids_dynamic .AND. & 2909 .NOT. radiation_input_root_domain ) THEN 2910 message_string = 'In case of external radiation forcing ' // & 2911 'a dynamic input file is required. If no ' // & 2912 'dynamic input for the child domain(s) is ' // & 2913 'provided, at least one for the root domain ' // & 2914 'is needed.' 2915 CALL message( 'radiation_init', 'PA0315', 1, 2, 0, 6, 0 ) 2916 ENDIF 2796 2917 #if defined( __netcdf ) 2797 2918 ! 2798 !-- Horizontally aligned natural and urban surfaces 2799 CALL calc_albedo( surf_lsm_h ) 2800 CALL calc_albedo( surf_usm_h ) 2801 ! 2802 !-- Vertically aligned natural and urban surfaces 2803 DO l = 0, 3 2804 CALL calc_albedo( surf_lsm_v(l) ) 2805 CALL calc_albedo( surf_usm_v(l) ) 2806 ENDDO 2919 !-- Open dynamic input file for child domain if available, else, open 2920 !-- dynamic input file for the root domain. 2921 IF ( input_pids_dynamic ) THEN 2922 CALL open_read_file( TRIM( input_file_dynamic ) // & 2923 TRIM( coupling_char ), & 2924 pids_id ) 2925 ELSEIF ( radiation_input_root_domain ) THEN 2926 CALL open_read_file( TRIM( input_file_dynamic ), & 2927 pids_id ) 2928 ENDIF 2929 2930 CALL inquire_num_variables( pids_id, num_var_pids ) 2931 ! 2932 !-- Allocate memory to store variable names and read them 2933 ALLOCATE( vars_pids(1:num_var_pids) ) 2934 CALL inquire_variable_names( pids_id, vars_pids ) 2935 ! 2936 !-- Input time dimension. 2937 IF ( check_existence( vars_pids, 'time_rad' ) ) THEN 2938 CALL get_dimension_length( pids_id, ntime, 'time_rad' ) 2939 2940 ALLOCATE( time_rad_f%var1d(0:ntime-1) ) 2941 ! 2942 !-- Read variable 2943 CALL get_variable( pids_id, 'time_rad', time_rad_f%var1d ) 2944 2945 time_rad_f%from_file = .TRUE. 2946 ENDIF 2947 ! 2948 !-- Input shortwave downwelling. 2949 IF ( check_existence( vars_pids, 'rad_sw_in' ) ) THEN 2950 ! 2951 !-- Get _FillValue attribute 2952 CALL get_attribute( pids_id, char_fill, rad_sw_in_f%fill, & 2953 .FALSE., 'rad_sw_in' ) 2954 ! 2955 !-- Get level-of-detail 2956 CALL get_attribute( pids_id, char_lod, rad_sw_in_f%lod, & 2957 .FALSE., 'rad_sw_in' ) 2958 ! 2959 !-- Level-of-detail 1 - radiation depends only on time_rad 2960 IF ( rad_sw_in_f%lod == 1 ) THEN 2961 ALLOCATE( rad_sw_in_f%var1d(0:ntime-1) ) 2962 CALL get_variable( pids_id, 'rad_sw_in', rad_sw_in_f%var1d ) 2963 rad_sw_in_f%from_file = .TRUE. 2964 ! 2965 !-- Level-of-detail 2 - radiation depends on time_rad, y, x 2966 ELSEIF ( rad_sw_in_f%lod == 2 ) THEN 2967 ALLOCATE( rad_sw_in_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) ) 2968 2969 CALL get_variable( pids_id, 'rad_sw_in', rad_sw_in_f%var3d, & 2970 nxl, nxr, nys, nyn, 0, ntime-1 ) 2971 2972 rad_sw_in_f%from_file = .TRUE. 2973 ELSE 2974 message_string = '"rad_sw_in" has no valid lod attribute' 2975 CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 ) 2976 ENDIF 2977 ENDIF 2978 ! 2979 !-- Input longwave downwelling. 2980 IF ( check_existence( vars_pids, 'rad_lw_in' ) ) THEN 2981 ! 2982 !-- Get _FillValue attribute 2983 CALL get_attribute( pids_id, char_fill, rad_lw_in_f%fill, & 2984 .FALSE., 'rad_lw_in' ) 2985 ! 2986 !-- Get level-of-detail 2987 CALL get_attribute( pids_id, char_lod, rad_lw_in_f%lod, & 2988 .FALSE., 'rad_lw_in' ) 2989 ! 2990 !-- Level-of-detail 1 - radiation depends only on time_rad 2991 IF ( rad_lw_in_f%lod == 1 ) THEN 2992 ALLOCATE( rad_lw_in_f%var1d(0:ntime-1) ) 2993 CALL get_variable( pids_id, 'rad_lw_in', rad_lw_in_f%var1d ) 2994 rad_lw_in_f%from_file = .TRUE. 2995 ! 2996 !-- Level-of-detail 2 - radiation depends on time_rad, y, x 2997 ELSEIF ( rad_lw_in_f%lod == 2 ) THEN 2998 ALLOCATE( rad_lw_in_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) ) 2999 3000 CALL get_variable( pids_id, 'rad_lw_in', rad_lw_in_f%var3d, & 3001 nxl, nxr, nys, nyn, 0, ntime-1 ) 3002 3003 rad_lw_in_f%from_file = .TRUE. 3004 ELSE 3005 message_string = '"rad_lw_in" has no valid lod attribute' 3006 CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 ) 3007 ENDIF 3008 ENDIF 3009 ! 3010 !-- Input shortwave downwelling, diffuse part. 3011 IF ( check_existence( vars_pids, 'rad_sw_in_dif' ) ) THEN 3012 ! 3013 !-- Read _FillValue attribute 3014 CALL get_attribute( pids_id, char_fill, rad_sw_in_dif_f%fill, & 3015 .FALSE., 'rad_sw_in_dif' ) 3016 ! 3017 !-- Get level-of-detail 3018 CALL get_attribute( pids_id, char_lod, rad_sw_in_dif_f%lod, & 3019 .FALSE., 'rad_sw_in_dif' ) 3020 ! 3021 !-- Level-of-detail 1 - radiation depends only on time_rad 3022 IF ( rad_sw_in_dif_f%lod == 1 ) THEN 3023 ALLOCATE( rad_sw_in_dif_f%var1d(0:ntime-1) ) 3024 CALL get_variable( pids_id, 'rad_sw_in_dif', & 3025 rad_sw_in_dif_f%var1d ) 3026 rad_sw_in_dif_f%from_file = .TRUE. 3027 ! 3028 !-- Level-of-detail 2 - radiation depends on time_rad, y, x 3029 ELSEIF ( rad_sw_in_dif_f%lod == 2 ) THEN 3030 ALLOCATE( rad_sw_in_dif_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) ) 3031 3032 CALL get_variable( pids_id, 'rad_sw_in_dif', & 3033 rad_sw_in_dif_f%var3d, & 3034 nxl, nxr, nys, nyn, 0, ntime-1 ) 3035 3036 rad_sw_in_dif_f%from_file = .TRUE. 3037 ELSE 3038 message_string = '"rad_sw_in_dif" has no valid lod attribute' 3039 CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 ) 3040 ENDIF 3041 ENDIF 3042 ! 3043 !-- Finally, close the input file and deallocate temporary arrays 3044 DEALLOCATE( vars_pids ) 3045 3046 CALL close_input_file( pids_id ) 2807 3047 #endif 2808 ELSE 2809 ! 2810 !-- Initialize sun-inclination independent spectral albedos 2811 !-- Horizontal surfaces 2812 IF ( surf_lsm_h%ns > 0 ) THEN 2813 surf_lsm_h%rrtm_aldir = surf_lsm_h%aldir 2814 surf_lsm_h%rrtm_asdir = surf_lsm_h%asdir 2815 surf_lsm_h%rrtm_aldif = surf_lsm_h%aldif 2816 surf_lsm_h%rrtm_asdif = surf_lsm_h%asdif 2817 ENDIF 2818 IF ( surf_usm_h%ns > 0 ) THEN 2819 surf_usm_h%rrtm_aldir = surf_usm_h%aldir 2820 surf_usm_h%rrtm_asdir = surf_usm_h%asdir 2821 surf_usm_h%rrtm_aldif = surf_usm_h%aldif 2822 surf_usm_h%rrtm_asdif = surf_usm_h%asdif 2823 ENDIF 2824 ! 2825 !-- Vertical surfaces 2826 DO l = 0, 3 2827 IF ( surf_lsm_v(l)%ns > 0 ) THEN 2828 surf_lsm_v(l)%rrtm_aldir = surf_lsm_v(l)%aldir 2829 surf_lsm_v(l)%rrtm_asdir = surf_lsm_v(l)%asdir 2830 surf_lsm_v(l)%rrtm_aldif = surf_lsm_v(l)%aldif 2831 surf_lsm_v(l)%rrtm_asdif = surf_lsm_v(l)%asdif 3048 ! 3049 !-- Make some consistency checks. 3050 IF ( .NOT. rad_sw_in_f%from_file .OR. & 3051 .NOT. rad_lw_in_f%from_file ) THEN 3052 message_string = 'In case of external radiation forcing ' // & 3053 'both, rad_sw_in and rad_lw_in are required.' 3054 CALL message( 'radiation_init', 'PA0195', 1, 2, 0, 6, 0 ) 3055 ENDIF 3056 3057 IF ( .NOT. time_rad_f%from_file ) THEN 3058 message_string = 'In case of external radiation forcing ' // & 3059 'dimension time_rad is required.' 3060 CALL message( 'radiation_init', 'PA0196', 1, 2, 0, 6, 0 ) 3061 ENDIF 3062 3063 CALL get_date_time( 0.0_wp, second_of_day=second_of_day ) 3064 3065 IF ( end_time - spinup_time > time_rad_f%var1d(ntime-1) ) THEN 3066 message_string = 'External radiation forcing does not cover ' // & 3067 'the entire simulation time.' 3068 CALL message( 'radiation_init', 'PA0314', 1, 2, 0, 6, 0 ) 3069 ENDIF 3070 ! 3071 !-- Check for fill values in radiation 3072 IF ( ALLOCATED( rad_sw_in_f%var1d ) ) THEN 3073 IF ( ANY( rad_sw_in_f%var1d == rad_sw_in_f%fill ) ) THEN 3074 message_string = 'External radiation array "rad_sw_in" ' // & 3075 'must not contain any fill values.' 3076 CALL message( 'radiation_init', 'PA0197', 1, 2, 0, 6, 0 ) 2832 3077 ENDIF 2833 IF ( surf_usm_v(l)%ns > 0 ) THEN 2834 surf_usm_v(l)%rrtm_aldir = surf_usm_v(l)%aldir 2835 surf_usm_v(l)%rrtm_asdir = surf_usm_v(l)%asdir 2836 surf_usm_v(l)%rrtm_aldif = surf_usm_v(l)%aldif 2837 surf_usm_v(l)%rrtm_asdif = surf_usm_v(l)%asdif 3078 ENDIF 3079 3080 IF ( ALLOCATED( rad_lw_in_f%var1d ) ) THEN 3081 IF ( ANY( rad_lw_in_f%var1d == rad_lw_in_f%fill ) ) THEN 3082 message_string = 'External radiation array "rad_lw_in" ' // & 3083 'must not contain any fill values.' 3084 CALL message( 'radiation_init', 'PA0198', 1, 2, 0, 6, 0 ) 2838 3085 ENDIF 2839 ENDDO 3086 ENDIF 3087 3088 IF ( ALLOCATED( rad_sw_in_dif_f%var1d ) ) THEN 3089 IF ( ANY( rad_sw_in_dif_f%var1d == rad_sw_in_dif_f%fill ) ) THEN 3090 message_string = 'External radiation array "rad_sw_in_dif" ' //& 3091 'must not contain any fill values.' 3092 CALL message( 'radiation_init', 'PA0199', 1, 2, 0, 6, 0 ) 3093 ENDIF 3094 ENDIF 3095 3096 IF ( ALLOCATED( rad_sw_in_f%var3d ) ) THEN 3097 IF ( ANY( rad_sw_in_f%var3d == rad_sw_in_f%fill ) ) THEN 3098 message_string = 'External radiation array "rad_sw_in" ' // & 3099 'must not contain any fill values.' 3100 CALL message( 'radiation_init', 'PA0197', 1, 2, 0, 6, 0 ) 3101 ENDIF 3102 ENDIF 3103 3104 IF ( ALLOCATED( rad_lw_in_f%var3d ) ) THEN 3105 IF ( ANY( rad_lw_in_f%var3d == rad_lw_in_f%fill ) ) THEN 3106 message_string = 'External radiation array "rad_lw_in" ' // & 3107 'must not contain any fill values.' 3108 CALL message( 'radiation_init', 'PA0198', 1, 2, 0, 6, 0 ) 3109 ENDIF 3110 ENDIF 3111 3112 IF ( ALLOCATED( rad_sw_in_dif_f%var3d ) ) THEN 3113 IF ( ANY( rad_sw_in_dif_f%var3d == rad_sw_in_dif_f%fill ) ) THEN 3114 message_string = 'External radiation array "rad_sw_in_dif" ' //& 3115 'must not contain any fill values.' 3116 CALL message( 'radiation_init', 'PA0199', 1, 2, 0, 6, 0 ) 3117 ENDIF 3118 ENDIF 3119 ! 3120 !-- Currently, 2D external radiation input is not possible in 3121 !-- combination with topography where average radiation is used. 3122 IF ( ( rad_lw_in_f%lod == 2 .OR. rad_sw_in_f%lod == 2 .OR. & 3123 rad_sw_in_dif_f%lod == 2 ) .AND. average_radiation ) THEN 3124 message_string = 'External radiation with lod = 2 is currently '//& 3125 'not possible with average_radiation = .T..' 3126 CALL message( 'radiation_init', 'PA0670', 1, 2, 0, 6, 0 ) 3127 ENDIF 3128 ! 3129 !-- All radiation input should have the same level of detail. The sum 3130 !-- of lods divided by the number of available radiation arrays must be 3131 !-- 1 (if all are lod = 1) or 2 (if all are lod = 2). 3132 IF ( REAL( MERGE( rad_lw_in_f%lod, 0, rad_lw_in_f%from_file ) + & 3133 MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + & 3134 MERGE( rad_sw_in_dif_f%lod, 0, rad_sw_in_dif_f%from_file ),& 3135 KIND = wp ) / & 3136 ( MERGE( 1.0_wp, 0.0_wp, rad_lw_in_f%from_file ) + & 3137 MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + & 3138 MERGE( 1.0_wp, 0.0_wp, rad_sw_in_dif_f%from_file ) ) & 3139 /= 1.0_wp .AND. & 3140 REAL( MERGE( rad_lw_in_f%lod, 0, rad_lw_in_f%from_file ) + & 3141 MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + & 3142 MERGE( rad_sw_in_dif_f%lod, 0, rad_sw_in_dif_f%from_file ),& 3143 KIND = wp ) / & 3144 ( MERGE( 1.0_wp, 0.0_wp, rad_lw_in_f%from_file ) + & 3145 MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + & 3146 MERGE( 1.0_wp, 0.0_wp, rad_sw_in_dif_f%from_file ) ) & 3147 /= 2.0_wp ) THEN 3148 message_string = 'External radiation input should have the same '//& 3149 'lod.' 3150 CALL message( 'radiation_init', 'PA0673', 1, 2, 0, 6, 0 ) 3151 ENDIF 2840 3152 2841 3153 ENDIF 2842 2843 ! 2844 !-- Allocate 3d arrays of radiative fluxes and heating rates 2845 IF ( .NOT. ALLOCATED ( rad_sw_in ) ) THEN 2846 ALLOCATE ( rad_sw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2847 rad_sw_in = 0.0_wp 3154 ! 3155 !-- Perform user actions if required 3156 CALL user_init_radiation 3157 3158 ! 3159 !-- Calculate radiative fluxes at model start 3160 SELECT CASE ( TRIM( radiation_scheme ) ) 3161 3162 CASE ( 'rrtmg' ) 3163 CALL radiation_rrtmg 3164 3165 CASE ( 'clear-sky' ) 3166 CALL radiation_clearsky 3167 3168 CASE ( 'constant' ) 3169 CALL radiation_constant 3170 3171 CASE ( 'external' ) 3172 ! 3173 !-- During spinup apply clear-sky model 3174 IF ( time_since_reference_point < 0.0_wp ) THEN 3175 CALL radiation_clearsky 3176 ELSE 3177 CALL radiation_external 3178 ENDIF 3179 3180 CASE DEFAULT 3181 3182 END SELECT 3183 3184 ! 3185 !-- Find all discretized apparent solar positions for radiation interaction. 3186 IF ( radiation_interactions ) CALL radiation_presimulate_solar_pos 3187 3188 ! 3189 !-- If required, read or calculate and write out the SVF 3190 IF ( radiation_interactions .AND. read_svf) THEN 3191 ! 3192 !-- Read sky-view factors and further required data from file 3193 CALL radiation_read_svf() 3194 3195 ELSEIF ( radiation_interactions .AND. .NOT. read_svf) THEN 3196 ! 3197 !-- calculate SFV and CSF 3198 CALL radiation_calc_svf() 2848 3199 ENDIF 2849 3200 2850 IF ( .NOT. ALLOCATED ( rad_sw_in_av ) ) THEN 2851 ALLOCATE ( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 3201 IF ( radiation_interactions .AND. write_svf) THEN 3202 ! 3203 !-- Write svf, csf svfsurf and csfsurf data to file 3204 CALL radiation_write_svf() 2852 3205 ENDIF 2853 3206 2854 IF ( .NOT. ALLOCATED ( rad_sw_out ) ) THEN 2855 ALLOCATE ( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2856 rad_sw_out = 0.0_wp 3207 ! 3208 !-- Adjust radiative fluxes. In case of urban and land surfaces, also 3209 !-- call an initial interaction. 3210 IF ( radiation_interactions ) THEN 3211 CALL radiation_interaction 2857 3212 ENDIF 2858 3213 2859 IF ( .NOT. ALLOCATED ( rad_sw_out_av ) ) THEN 2860 ALLOCATE ( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2861 ENDIF 2862 2863 IF ( .NOT. ALLOCATED ( rad_sw_hr ) ) THEN 2864 ALLOCATE ( rad_sw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2865 rad_sw_hr = 0.0_wp 2866 ENDIF 2867 2868 IF ( .NOT. ALLOCATED ( rad_sw_hr_av ) ) THEN 2869 ALLOCATE ( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2870 rad_sw_hr_av = 0.0_wp 2871 ENDIF 2872 2873 IF ( .NOT. ALLOCATED ( rad_sw_cs_hr ) ) THEN 2874 ALLOCATE ( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2875 rad_sw_cs_hr = 0.0_wp 2876 ENDIF 2877 2878 IF ( .NOT. ALLOCATED ( rad_sw_cs_hr_av ) ) THEN 2879 ALLOCATE ( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2880 rad_sw_cs_hr_av = 0.0_wp 2881 ENDIF 2882 2883 IF ( .NOT. ALLOCATED ( rad_lw_in ) ) THEN 2884 ALLOCATE ( rad_lw_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2885 rad_lw_in = 0.0_wp 2886 ENDIF 2887 2888 IF ( .NOT. ALLOCATED ( rad_lw_in_av ) ) THEN 2889 ALLOCATE ( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2890 ENDIF 2891 2892 IF ( .NOT. ALLOCATED ( rad_lw_out ) ) THEN 2893 ALLOCATE ( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2894 rad_lw_out = 0.0_wp 2895 ENDIF 2896 2897 IF ( .NOT. ALLOCATED ( rad_lw_out_av ) ) THEN 2898 ALLOCATE ( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2899 ENDIF 2900 2901 IF ( .NOT. ALLOCATED ( rad_lw_hr ) ) THEN 2902 ALLOCATE ( rad_lw_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2903 rad_lw_hr = 0.0_wp 2904 ENDIF 2905 2906 IF ( .NOT. ALLOCATED ( rad_lw_hr_av ) ) THEN 2907 ALLOCATE ( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2908 rad_lw_hr_av = 0.0_wp 2909 ENDIF 2910 2911 IF ( .NOT. ALLOCATED ( rad_lw_cs_hr ) ) THEN 2912 ALLOCATE ( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2913 rad_lw_cs_hr = 0.0_wp 2914 ENDIF 2915 2916 IF ( .NOT. ALLOCATED ( rad_lw_cs_hr_av ) ) THEN 2917 ALLOCATE ( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2918 rad_lw_cs_hr_av = 0.0_wp 2919 ENDIF 2920 2921 ALLOCATE ( rad_sw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2922 ALLOCATE ( rad_sw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2923 rad_sw_cs_in = 0.0_wp 2924 rad_sw_cs_out = 0.0_wp 2925 2926 ALLOCATE ( rad_lw_cs_in(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2927 ALLOCATE ( rad_lw_cs_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 2928 rad_lw_cs_in = 0.0_wp 2929 rad_lw_cs_out = 0.0_wp 2930 2931 ! 2932 !-- Allocate 1-element array for surface temperature 2933 !-- (RRTMG anticipates an array as passed argument). 2934 ALLOCATE ( rrtm_tsfc(1) ) 2935 ! 2936 !-- Allocate surface emissivity. 2937 !-- Values will be given directly before calling rrtm_lw. 2938 ALLOCATE ( rrtm_emis(0:0,1:nbndlw+1) ) 2939 2940 ! 2941 !-- Initialize RRTMG, before check if files are existent 2942 INQUIRE( FILE = 'rrtmg_lw.nc', EXIST = lw_exists ) 2943 IF ( .NOT. lw_exists ) THEN 2944 message_string = 'Input file rrtmg_lw.nc&for rrtmg missing. ' // & 2945 '&Please provide <jobname>_lsw file in the INPUT directory.' 2946 CALL message( 'radiation_init', 'PA0583', 1, 2, 0, 6, 0 ) 2947 ENDIF 2948 INQUIRE( FILE = 'rrtmg_sw.nc', EXIST = sw_exists ) 2949 IF ( .NOT. sw_exists ) THEN 2950 message_string = 'Input file rrtmg_sw.nc&for rrtmg missing. ' // & 2951 '&Please provide <jobname>_rsw file in the INPUT directory.' 2952 CALL message( 'radiation_init', 'PA0584', 1, 2, 0, 6, 0 ) 2953 ENDIF 2954 2955 IF ( lw_radiation ) CALL rrtmg_lw_ini ( c_p ) 2956 IF ( sw_radiation ) CALL rrtmg_sw_ini ( c_p ) 2957 2958 ! 2959 !-- Set input files for RRTMG 2960 INQUIRE( FILE = "RAD_SND_DATA", EXIST = snd_exists ) 2961 IF ( .NOT. snd_exists ) THEN 2962 rrtm_input_file = "rrtmg_lw.nc" 2963 ENDIF 2964 2965 ! 2966 !-- Read vertical layers for RRTMG from sounding data 2967 !-- The routine provides nzt_rad, hyp_snd(1:nzt_rad), t_snd(nzt+2:nzt_rad), rrtm_play(1:nzt_rad), 2968 !-- rrtm_plev(1_nzt_rad+1), rrtm_tlay(nzt+2:nzt_rad), rrtm_tlev(nzt+2:nzt_rad+1) 2969 CALL read_sounding_data 2970 2971 ! 2972 !-- Read trace gas profiles from file. This routine provides the rrtm_ arrays (1:nzt_rad+1) 2973 CALL read_trace_gas_data 2974 #endif 2975 ENDIF 2976 ! 2977 !-- Initializaion actions exclusively required for external radiation forcing 2978 IF ( radiation_scheme == 'external' ) THEN 2979 ! 2980 !-- Open the radiation input file. Note, for child domain, a dynamic input file is often not 2981 !-- provided. In order to not need to duplicate the dynamic input file just for the radiation 2982 !-- input, take it from the dynamic file for the parent if not available for the child domain(s). 2983 !-- In this case this is possible because radiation input should be the same for each model. 2984 INQUIRE( FILE = TRIM( input_file_dynamic ), EXIST = radiation_input_root_domain ) 2985 2986 IF ( .NOT. input_pids_dynamic .AND. .NOT. radiation_input_root_domain ) THEN 2987 message_string = 'In case of external radiation forcing a dynamic input file is ' // & 2988 'required. If no dynamic input for the child domain(s) is ' // & 2989 'provided, at least one for the root domain is needed.' 2990 CALL message( 'radiation_init', 'PA0315', 1, 2, 0, 6, 0 ) 2991 ENDIF 2992 #if defined( __netcdf ) 2993 ! 2994 !-- Open dynamic input file for child domain if available, else, open dynamic input file for the 2995 !-- root domain. 2996 IF ( input_pids_dynamic ) THEN 2997 CALL open_read_file( TRIM( input_file_dynamic ) // TRIM( coupling_char ), pids_id ) 2998 ELSEIF ( radiation_input_root_domain ) THEN 2999 CALL open_read_file( TRIM( input_file_dynamic ), pids_id ) 3000 ENDIF 3001 3002 CALL inquire_num_variables( pids_id, num_var_pids ) 3003 ! 3004 !-- Allocate memory to store variable names and read them 3005 ALLOCATE( vars_pids(1:num_var_pids) ) 3006 CALL inquire_variable_names( pids_id, vars_pids ) 3007 ! 3008 !-- Input time dimension. 3009 IF ( check_existence( vars_pids, 'time_rad' ) ) THEN 3010 CALL get_dimension_length( pids_id, ntime, 'time_rad' ) 3011 3012 ALLOCATE( time_rad_f%var1d(0:ntime-1) ) 3013 ! 3014 !-- Read variable 3015 CALL get_variable( pids_id, 'time_rad', time_rad_f%var1d ) 3016 3017 time_rad_f%from_file = .TRUE. 3018 ENDIF 3019 ! 3020 !-- Input shortwave downwelling. 3021 IF ( check_existence( vars_pids, 'rad_sw_in' ) ) THEN 3022 ! 3023 !-- Get _FillValue attribute 3024 CALL get_attribute( pids_id, char_fill, rad_sw_in_f%fill, .FALSE., 'rad_sw_in' ) 3025 ! 3026 !-- Get level-of-detail 3027 CALL get_attribute( pids_id, char_lod, rad_sw_in_f%lod, .FALSE., 'rad_sw_in' ) 3028 ! 3029 !-- Level-of-detail 1 - radiation depends only on time_rad 3030 IF ( rad_sw_in_f%lod == 1 ) THEN 3031 ALLOCATE( rad_sw_in_f%var1d(0:ntime-1) ) 3032 CALL get_variable( pids_id, 'rad_sw_in', rad_sw_in_f%var1d ) 3033 rad_sw_in_f%from_file = .TRUE. 3034 ! 3035 !-- Level-of-detail 2 - radiation depends on time_rad, y, x 3036 ELSEIF ( rad_sw_in_f%lod == 2 ) THEN 3037 ALLOCATE( rad_sw_in_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) ) 3038 3039 CALL get_variable( pids_id, 'rad_sw_in', rad_sw_in_f%var3d, nxl, nxr, nys, nyn, 0, & 3040 ntime-1 ) 3041 3042 rad_sw_in_f%from_file = .TRUE. 3043 ELSE 3044 message_string = '"rad_sw_in" has no valid lod attribute' 3045 CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 ) 3046 ENDIF 3047 ENDIF 3048 ! 3049 !-- Input longwave downwelling. 3050 IF ( check_existence( vars_pids, 'rad_lw_in' ) ) THEN 3051 ! 3052 !-- Get _FillValue attribute 3053 CALL get_attribute( pids_id, char_fill, rad_lw_in_f%fill, .FALSE., 'rad_lw_in' ) 3054 ! 3055 !-- Get level-of-detail 3056 CALL get_attribute( pids_id, char_lod, rad_lw_in_f%lod, .FALSE., 'rad_lw_in' ) 3057 ! 3058 !-- Level-of-detail 1 - radiation depends only on time_rad 3059 IF ( rad_lw_in_f%lod == 1 ) THEN 3060 ALLOCATE( rad_lw_in_f%var1d(0:ntime-1) ) 3061 CALL get_variable( pids_id, 'rad_lw_in', rad_lw_in_f%var1d ) 3062 rad_lw_in_f%from_file = .TRUE. 3063 ! 3064 !-- Level-of-detail 2 - radiation depends on time_rad, y, x 3065 ELSEIF ( rad_lw_in_f%lod == 2 ) THEN 3066 ALLOCATE( rad_lw_in_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) ) 3067 3068 CALL get_variable( pids_id, 'rad_lw_in', rad_lw_in_f%var3d, nxl, nxr, nys, nyn, 0, & 3069 ntime-1 ) 3070 3071 rad_lw_in_f%from_file = .TRUE. 3072 ELSE 3073 message_string = '"rad_lw_in" has no valid lod attribute' 3074 CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 ) 3075 ENDIF 3076 ENDIF 3077 ! 3078 !-- Input shortwave downwelling, diffuse part. 3079 IF ( check_existence( vars_pids, 'rad_sw_in_dif' ) ) THEN 3080 ! 3081 !-- Read _FillValue attribute 3082 CALL get_attribute( pids_id, char_fill, rad_sw_in_dif_f%fill, .FALSE., 'rad_sw_in_dif' ) 3083 ! 3084 !-- Get level-of-detail 3085 CALL get_attribute( pids_id, char_lod, rad_sw_in_dif_f%lod, .FALSE., 'rad_sw_in_dif' ) 3086 ! 3087 !-- Level-of-detail 1 - radiation depends only on time_rad 3088 IF ( rad_sw_in_dif_f%lod == 1 ) THEN 3089 ALLOCATE( rad_sw_in_dif_f%var1d(0:ntime-1) ) 3090 CALL get_variable( pids_id, 'rad_sw_in_dif', rad_sw_in_dif_f%var1d ) 3091 rad_sw_in_dif_f%from_file = .TRUE. 3092 ! 3093 !-- Level-of-detail 2 - radiation depends on time_rad, y, x 3094 ELSEIF ( rad_sw_in_dif_f%lod == 2 ) THEN 3095 ALLOCATE( rad_sw_in_dif_f%var3d(0:ntime-1,nys:nyn,nxl:nxr) ) 3096 3097 CALL get_variable( pids_id, 'rad_sw_in_dif', rad_sw_in_dif_f%var3d, nxl, nxr, nys, & 3098 nyn, 0, ntime-1 ) 3099 3100 rad_sw_in_dif_f%from_file = .TRUE. 3101 ELSE 3102 message_string = '"rad_sw_in_dif" has no valid lod attribute' 3103 CALL message( 'radiation_init', 'PA0646', 1, 2, 0, 6, 0 ) 3104 ENDIF 3105 ENDIF 3106 ! 3107 !-- Finally, close the input file and deallocate temporary arrays 3108 DEALLOCATE( vars_pids ) 3109 3110 CALL close_input_file( pids_id ) 3111 #endif 3112 ! 3113 !-- Make some consistency checks. 3114 IF ( .NOT. rad_sw_in_f%from_file .OR. .NOT. rad_lw_in_f%from_file ) THEN 3115 message_string = 'In case of external radiation forcing ' // & 3116 'both, rad_sw_in and rad_lw_in are required.' 3117 CALL message( 'radiation_init', 'PA0195', 1, 2, 0, 6, 0 ) 3118 ENDIF 3119 3120 IF ( .NOT. time_rad_f%from_file ) THEN 3121 message_string = 'In case of external radiation forcing ' // & 3122 'dimension time_rad is required.' 3123 CALL message( 'radiation_init', 'PA0196', 1, 2, 0, 6, 0 ) 3124 ENDIF 3125 3126 CALL get_date_time( 0.0_wp, second_of_day=second_of_day ) 3127 3128 IF ( end_time - spinup_time > time_rad_f%var1d(ntime-1) ) THEN 3129 message_string = 'External radiation forcing does not cover ' // & 3130 'the entire simulation time.' 3131 CALL message( 'radiation_init', 'PA0314', 1, 2, 0, 6, 0 ) 3132 ENDIF 3133 ! 3134 !-- Check for fill values in radiation 3135 IF ( ALLOCATED( rad_sw_in_f%var1d ) ) THEN 3136 IF ( ANY( rad_sw_in_f%var1d == rad_sw_in_f%fill ) ) THEN 3137 message_string = 'External radiation array "rad_sw_in" ' // & 3138 'must not contain any fill values.' 3139 CALL message( 'radiation_init', 'PA0197', 1, 2, 0, 6, 0 ) 3140 ENDIF 3141 ENDIF 3142 3143 IF ( ALLOCATED( rad_lw_in_f%var1d ) ) THEN 3144 IF ( ANY( rad_lw_in_f%var1d == rad_lw_in_f%fill ) ) THEN 3145 message_string = 'External radiation array "rad_lw_in" ' // & 3146 'must not contain any fill values.' 3147 CALL message( 'radiation_init', 'PA0198', 1, 2, 0, 6, 0 ) 3148 ENDIF 3149 ENDIF 3150 3151 IF ( ALLOCATED( rad_sw_in_dif_f%var1d ) ) THEN 3152 IF ( ANY( rad_sw_in_dif_f%var1d == rad_sw_in_dif_f%fill ) ) THEN 3153 message_string = 'External radiation array "rad_sw_in_dif" ' // & 3154 'must not contain any fill values.' 3155 CALL message( 'radiation_init', 'PA0199', 1, 2, 0, 6, 0 ) 3156 ENDIF 3157 ENDIF 3158 3159 IF ( ALLOCATED( rad_sw_in_f%var3d ) ) THEN 3160 IF ( ANY( rad_sw_in_f%var3d == rad_sw_in_f%fill ) ) THEN 3161 message_string = 'External radiation array "rad_sw_in" ' // & 3162 'must not contain any fill values.' 3163 CALL message( 'radiation_init', 'PA0197', 1, 2, 0, 6, 0 ) 3164 ENDIF 3165 ENDIF 3166 3167 IF ( ALLOCATED( rad_lw_in_f%var3d ) ) THEN 3168 IF ( ANY( rad_lw_in_f%var3d == rad_lw_in_f%fill ) ) THEN 3169 message_string = 'External radiation array "rad_lw_in" ' // & 3170 'must not contain any fill values.' 3171 CALL message( 'radiation_init', 'PA0198', 1, 2, 0, 6, 0 ) 3172 ENDIF 3173 ENDIF 3174 3175 IF ( ALLOCATED( rad_sw_in_dif_f%var3d ) ) THEN 3176 IF ( ANY( rad_sw_in_dif_f%var3d == rad_sw_in_dif_f%fill ) ) THEN 3177 message_string = 'External radiation array "rad_sw_in_dif" ' // & 3178 'must not contain any fill values.' 3179 CALL message( 'radiation_init', 'PA0199', 1, 2, 0, 6, 0 ) 3180 ENDIF 3181 ENDIF 3182 ! 3183 !-- Currently, 2D external radiation input is not possible in combination with topography where 3184 !-- average radiation is used. 3185 IF ( ( rad_lw_in_f%lod == 2 .OR. rad_sw_in_f%lod == 2 .OR. & 3186 rad_sw_in_dif_f%lod == 2 ) .AND. average_radiation ) THEN 3187 message_string = 'External radiation with lod = 2 is currently '// & 3188 'not possible with average_radiation = .T..' 3189 CALL message( 'radiation_init', 'PA0670', 1, 2, 0, 6, 0 ) 3190 ENDIF 3191 ! 3192 !-- All radiation input should have the same level of detail. The sum of lods divided by the 3193 !-- number of available radiation arrays must be 1 (if all are lod = 1) or 2 (if all are lod = 2). 3194 IF ( REAL( MERGE( rad_lw_in_f%lod, 0, rad_lw_in_f%from_file ) + & 3195 MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + & 3196 MERGE( rad_sw_in_dif_f%lod, 0, rad_sw_in_dif_f%from_file ), KIND = wp ) / & 3197 ( MERGE( 1.0_wp, 0.0_wp, rad_lw_in_f%from_file ) + & 3198 MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + & 3199 MERGE( 1.0_wp, 0.0_wp, rad_sw_in_dif_f%from_file ) ) /= 1.0_wp .AND. & 3200 REAL( MERGE( rad_lw_in_f%lod, 0, rad_lw_in_f%from_file ) + & 3201 MERGE( rad_sw_in_f%lod, 0, rad_sw_in_f%from_file ) + & 3202 MERGE( rad_sw_in_dif_f%lod, 0, rad_sw_in_dif_f%from_file ), KIND = wp ) / & 3203 ( MERGE( 1.0_wp, 0.0_wp, rad_lw_in_f%from_file ) + & 3204 MERGE( 1.0_wp, 0.0_wp, rad_sw_in_f%from_file ) + & 3205 MERGE( 1.0_wp, 0.0_wp, rad_sw_in_dif_f%from_file ) ) /= 2.0_wp ) THEN 3206 message_string = 'External radiation input should have the same lod.' 3207 CALL message( 'radiation_init', 'PA0673', 1, 2, 0, 6, 0 ) 3208 ENDIF 3209 3210 ENDIF 3211 ! 3212 !-- Perform user actions if required 3213 CALL user_init_radiation 3214 3215 ! 3216 !-- Calculate radiative fluxes at model start 3217 SELECT CASE ( TRIM( radiation_scheme ) ) 3218 3219 CASE ( 'rrtmg' ) 3220 CALL radiation_rrtmg 3221 3222 CASE ( 'clear-sky' ) 3223 CALL radiation_clearsky 3224 3225 CASE ( 'constant' ) 3226 CALL radiation_constant 3227 3228 CASE ( 'external' ) 3229 ! 3230 !-- During spinup apply clear-sky model 3231 IF ( time_since_reference_point < 0.0_wp ) THEN 3232 CALL radiation_clearsky 3233 ELSE 3234 CALL radiation_external 3235 ENDIF 3236 3237 CASE DEFAULT 3238 3239 END SELECT 3240 3241 ! 3242 !-- Find all discretized apparent solar positions for radiation interaction. 3243 IF ( radiation_interactions ) CALL radiation_presimulate_solar_pos 3244 3245 ! 3246 !-- If required, read or calculate and write out the SVF 3247 IF ( radiation_interactions .AND. read_svf) THEN 3248 ! 3249 !-- Read sky-view factors and further required data from file 3250 CALL radiation_read_svf() 3251 3252 ELSEIF ( radiation_interactions .AND. .NOT. read_svf) THEN 3253 ! 3254 !-- Calculate SFV and CSF 3255 CALL radiation_calc_svf() 3256 ENDIF 3257 3258 IF ( radiation_interactions .AND. write_svf) THEN 3259 ! 3260 !-- Write svf, csf svfsurf and csfsurf data to file 3261 CALL radiation_write_svf() 3262 ENDIF 3263 3264 ! 3265 !-- Adjust radiative fluxes. In case of urban and land surfaces, also call an initial interaction. 3266 IF ( radiation_interactions ) THEN 3267 CALL radiation_interaction 3268 ENDIF 3269 3270 IF ( debug_output ) CALL debug_message( 'radiation_init', 'end' ) 3271 3272 END SUBROUTINE radiation_init 3273 3274 3275 !--------------------------------------------------------------------------------------------------! 3214 IF ( debug_output ) CALL debug_message( 'radiation_init', 'end' ) 3215 3216 RETURN !todo: remove, I don't see what we need this for here 3217 3218 END SUBROUTINE radiation_init 3219 3220 3221 !------------------------------------------------------------------------------! 3276 3222 ! Description: 3277 3223 ! ------------ 3278 3224 !> A simple clear sky radiation model 3279 !--------------------------------------------------------------------------------------------------! 3280 SUBROUTINE radiation_external 3281 3282 IMPLICIT NONE 3283 3284 INTEGER(iwp) :: l !< running index for surface orientation 3285 INTEGER(iwp) :: t !< index of current timestep 3286 INTEGER(iwp) :: tm !< index of previous timestep 3287 3288 LOGICAL :: horizontal !< flag indicating treatment of horinzontal surfaces 3289 3290 REAL(wp) :: fac_dt !< interpolation factor 3291 REAL(wp) :: second_of_day_init !< second of the day at model start 3292 3293 TYPE(surf_type), POINTER :: surf !< pointer to respective surface type, used to generalize routine 3294 3295 ! 3296 !-- Calculate current zenith angle 3297 CALL get_date_time( time_since_reference_point, day_of_year = day_of_year, & 3298 second_of_day = second_of_day ) 3299 CALL calc_zenith( day_of_year, second_of_day ) 3300 ! 3301 !-- Interpolate external radiation on current timestep 3302 IF ( time_since_reference_point <= 0.0_wp ) THEN 3303 t = 0 3304 tm = 0 3305 fac_dt = 0 3306 ELSE 3307 CALL get_date_time( 0.0_wp, second_of_day=second_of_day_init ) 3308 t = 0 3309 DO WHILE ( time_rad_f%var1d(t) <= time_since_reference_point ) 3310 t = t + 1 3225 !------------------------------------------------------------------------------! 3226 SUBROUTINE radiation_external 3227 3228 IMPLICIT NONE 3229 3230 INTEGER(iwp) :: l !< running index for surface orientation 3231 INTEGER(iwp) :: t !< index of current timestep 3232 INTEGER(iwp) :: tm !< index of previous timestep 3233 3234 LOGICAL :: horizontal !< flag indicating treatment of horinzontal surfaces 3235 3236 REAL(wp) :: fac_dt !< interpolation factor 3237 REAL(wp) :: second_of_day_init !< second of the day at model start 3238 3239 TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine 3240 3241 ! 3242 !-- Calculate current zenith angle 3243 CALL get_date_time( time_since_reference_point, & 3244 day_of_year=day_of_year, & 3245 second_of_day=second_of_day ) 3246 CALL calc_zenith( day_of_year, second_of_day ) 3247 ! 3248 !-- Interpolate external radiation on current timestep 3249 IF ( time_since_reference_point <= 0.0_wp ) THEN 3250 t = 0 3251 tm = 0 3252 fac_dt = 0 3253 ELSE 3254 CALL get_date_time( 0.0_wp, second_of_day=second_of_day_init ) 3255 t = 0 3256 DO WHILE ( time_rad_f%var1d(t) <= time_since_reference_point ) 3257 t = t + 1 3258 ENDDO 3259 3260 tm = MAX( t-1, 0 ) 3261 3262 fac_dt = ( time_since_reference_point & 3263 - time_rad_f%var1d(tm) + dt_3d ) & 3264 / ( time_rad_f%var1d(t) - time_rad_f%var1d(tm) ) 3265 fac_dt = MIN( 1.0_wp, fac_dt ) 3266 ENDIF 3267 ! 3268 !-- Call clear-sky calculation for each surface orientation. 3269 !-- First, horizontal surfaces 3270 horizontal = .TRUE. 3271 surf => surf_lsm_h 3272 CALL radiation_external_surf 3273 surf => surf_usm_h 3274 CALL radiation_external_surf 3275 horizontal = .FALSE. 3276 ! 3277 !-- Vertical surfaces 3278 DO l = 0, 3 3279 surf => surf_lsm_v(l) 3280 CALL radiation_external_surf 3281 surf => surf_usm_v(l) 3282 CALL radiation_external_surf 3311 3283 ENDDO 3312 3284 3313 tm = MAX( t-1, 0 ) 3314 3315 fac_dt = ( time_since_reference_point - time_rad_f%var1d(tm) + dt_3d ) & 3316 / ( time_rad_f%var1d(t) - time_rad_f%var1d(tm) ) 3317 fac_dt = MIN( 1.0_wp, fac_dt ) 3318 ENDIF 3319 ! 3320 !-- Call clear-sky calculation for each surface orientation. 3321 !-- First, horizontal surfaces 3322 horizontal = .TRUE. 3323 surf => surf_lsm_h 3324 CALL radiation_external_surf 3325 surf => surf_usm_h 3326 CALL radiation_external_surf 3327 horizontal = .FALSE. 3328 ! 3329 !-- Vertical surfaces 3330 DO l = 0, 3 3331 surf => surf_lsm_v(l) 3332 CALL radiation_external_surf 3333 surf => surf_usm_v(l) 3334 CALL radiation_external_surf 3335 ENDDO 3336 3337 CONTAINS 3338 3339 3340 !--------------------------------------------------------------------------------------------------! 3341 ! Description: 3342 ! ------------ 3343 !> Todo: Missing subroutine description 3344 !--------------------------------------------------------------------------------------------------! 3345 SUBROUTINE radiation_external_surf 3346 3347 USE control_parameters 3348 3349 IMPLICIT NONE 3350 3351 INTEGER(iwp) :: i !< grid index along x-dimension 3352 INTEGER(iwp) :: j !< grid index along y-dimension 3353 INTEGER(iwp) :: k !< grid index along z-dimension 3354 INTEGER(iwp) :: m !< running index for surface elements 3355 3356 REAL(wp) :: lw_in !< downwelling longwave radiation, interpolated value 3357 REAL(wp) :: sw_in !< downwelling shortwave radiation, interpolated value 3358 REAL(wp) :: sw_in_dif !< downwelling diffuse shortwave radiation, interpolated value 3359 3360 IF ( surf%ns < 1 ) RETURN 3361 ! 3362 !-- Level-of-detail = 1. Note, here it must be distinguished between averaged radiation and 3363 !-- non-averaged radiation for the upwelling fluxes. 3364 IF ( rad_sw_in_f%lod == 1 ) THEN 3365 3366 sw_in = ( 1.0_wp - fac_dt ) * rad_sw_in_f%var1d(tm) + fac_dt * rad_sw_in_f%var1d(t) 3367 3368 lw_in = ( 1.0_wp - fac_dt ) * rad_lw_in_f%var1d(tm) + fac_dt * rad_lw_in_f%var1d(t) 3369 ! 3370 !-- Limit shortwave incoming radiation to positive values, in order to overcome possible 3371 !-- observation errors. 3372 sw_in = MAX( 0.0_wp, sw_in ) 3373 sw_in = MERGE( sw_in, 0.0_wp, sun_up ) 3374 3375 surf%rad_sw_in = sw_in 3376 surf%rad_lw_in = lw_in 3377 3378 IF ( average_radiation ) THEN 3379 surf%rad_sw_out = albedo_urb * surf%rad_sw_in 3380 3381 surf%rad_lw_out = emissivity_urb * sigma_sb * t_rad_urb**4 & 3382 + ( 1.0_wp - emissivity_urb ) * surf%rad_lw_in 3383 3384 surf%rad_net = surf%rad_sw_in - surf%rad_sw_out & 3385 + surf%rad_lw_in - surf%rad_lw_out 3386 3387 surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb * t_rad_urb**3 3388 ELSE 3389 DO m = 1, surf%ns 3390 k = surf%k(m) 3391 surf%rad_sw_out(m) = ( surf%frac(m,ind_veg_wall) * surf%albedo(m,ind_veg_wall) & 3392 + surf%frac(m,ind_pav_green) * surf%albedo(m,ind_pav_green) & 3393 + surf%frac(m,ind_wat_win) * surf%albedo(m,ind_wat_win) ) & 3394 * surf%rad_sw_in(m) 3395 3396 surf%rad_lw_out(m) = ( surf%frac(m,ind_veg_wall) * & 3397 surf%emissivity(m,ind_veg_wall) & 3398 + surf%frac(m,ind_pav_green) * & 3399 surf%emissivity(m,ind_pav_green) & 3400 + surf%frac(m,ind_wat_win) * & 3401 surf%emissivity(m,ind_wat_win) ) * sigma_sb & 3402 * ( surf%pt_surface(m) * exner(k) )**4 3403 3404 surf%rad_lw_out_change_0(m) = ( surf%frac(m,ind_veg_wall) * & 3405 surf%emissivity(m,ind_veg_wall) & 3406 + surf%frac(m,ind_pav_green) * & 3407 surf%emissivity(im,ind_pav_green) & 3408 + surf%frac(m,ind_wat_win) * & 3409 surf%emissivity(m,ind_wat_win) & 3410 ) * 4.0_wp * sigma_sb & 3411 * ( surf%pt_surface(m) * exner(k) )**3 3412 ENDDO 3413 3414 ENDIF 3415 ! 3416 !-- If diffuse shortwave radiation is available, store it on the respective files. 3417 IF ( rad_sw_in_dif_f%from_file ) THEN 3418 sw_in_dif= ( 1.0_wp - fac_dt ) * rad_sw_in_dif_f%var1d(tm) & 3419 + fac_dt * rad_sw_in_dif_f%var1d(t) 3420 3421 IF ( ALLOCATED( rad_sw_in_diff ) ) rad_sw_in_diff = sw_in_dif 3422 IF ( ALLOCATED( rad_sw_in_dir ) ) rad_sw_in_dir = sw_in - sw_in_dif 3423 ! 3424 !-- Diffuse longwave radiation equals the total downwelling longwave radiation 3425 IF ( ALLOCATED( rad_lw_in_diff ) ) rad_lw_in_diff = lw_in 3426 ENDIF 3427 ! 3428 !-- Level-of-detail = 2 3429 ELSE 3430 3431 DO m = 1, surf%ns 3432 i = surf%i(m) 3433 j = surf%j(m) 3434 k = surf%k(m) 3435 3436 surf%rad_sw_in(m) = ( 1.0_wp - fac_dt ) * rad_sw_in_f%var3d(tm,j,i) & 3437 + fac_dt * rad_sw_in_f%var3d(t,j,i) 3438 ! 3439 !-- Limit shortwave incoming radiation to positive values, in order to overcome possible 3440 !-- observation errors. 3441 surf%rad_sw_in(m) = MAX( 0.0_wp, surf%rad_sw_in(m) ) 3442 surf%rad_sw_in(m) = MERGE( surf%rad_sw_in(m), 0.0_wp, sun_up ) 3443 3444 surf%rad_lw_in(m) = ( 1.0_wp - fac_dt ) * rad_lw_in_f%var3d(tm,j,i) & 3445 + fac_dt * rad_lw_in_f%var3d(t,j,i) 3446 ! 3447 !-- Weighted average according to surface fraction. 3448 surf%rad_sw_out(m) = ( surf%frac(m,ind_veg_wall) * surf%albedo(m,ind_veg_wall) & 3449 + surf%frac(m,ind_pav_green) * surf%albedo(m,ind_pav_green) & 3450 + surf%frac(m,ind_wat_win) * surf%albedo(m,ind_wat_win) ) & 3451 * surf%rad_sw_in(m) 3452 3453 surf%rad_lw_out(m) = ( surf%frac(m,ind_veg_wall) * surf%emissivity(m,ind_veg_wall) & 3454 + surf%frac(m,ind_pav_green) * & 3455 surf%emissivity(m,ind_pav_green) & 3456 + surf%frac(m,ind_wat_win) * & 3457 surf%emissivity(m,ind_wat_win) ) * sigma_sb & 3458 * ( surf%pt_surface(m) * exner(k) )**4 3459 3460 surf%rad_lw_out_change_0(m) = ( surf%frac(m,ind_veg_wall) * & 3461 surf%emissivity(m,ind_veg_wall) & 3462 + surf%frac(m,ind_pav_green) * & 3463 surf%emissivity(m,ind_pav_green) & 3464 + surf%frac(m,ind_wat_win) * & 3465 surf%emissivity(m,ind_wat_win) & 3466 ) * 4.0_wp * sigma_sb & 3467 * ( surf%pt_surface(m) * exner(k) )**3 3468 3469 surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) & 3470 + surf%rad_lw_in(m) - surf%rad_lw_out(m) 3471 ! 3472 !-- If diffuse shortwave radiation is available, store it on the respective files. 3473 IF ( rad_sw_in_dif_f%from_file ) THEN 3474 IF ( ALLOCATED( rad_sw_in_diff ) ) & 3475 rad_sw_in_diff(j,i) = ( 1.0_wp - fac_dt ) * rad_sw_in_dif_f%var3d(tm,j,i) & 3476 + fac_dt * rad_sw_in_dif_f%var3d(t,j,i) 3477 ! 3478 !-- dir = sw_in - sw_in_dif. 3479 IF ( ALLOCATED( rad_sw_in_dir ) ) rad_sw_in_dir(j,i) = surf%rad_sw_in(m) - & 3480 rad_sw_in_diff(j,i) 3481 ! 3482 !-- Diffuse longwave radiation equals the total downwelling longwave radiation 3483 IF ( ALLOCATED( rad_lw_in_diff ) ) rad_lw_in_diff(j,i) = surf%rad_lw_in(m) 3484 ENDIF 3485 3486 ENDDO 3487 3488 ENDIF 3489 ! 3490 !-- Store radiation also on 2D arrays, which are still used for direct-diffuse splitting. 3491 !-- Note, this is only required for horizontal surfaces, which covers all x,y positions. 3492 IF ( horizontal ) THEN 3493 DO m = 1, surf%ns 3494 i = surf%i(m) 3495 j = surf%j(m) 3496 3497 rad_sw_in(0,j,i) = surf%rad_sw_in(m) 3498 rad_lw_in(0,j,i) = surf%rad_lw_in(m) 3499 rad_sw_out(0,j,i) = surf%rad_sw_out(m) 3500 rad_lw_out(0,j,i) = surf%rad_lw_out(m) 3501 ENDDO 3502 ENDIF 3503 3504 END SUBROUTINE radiation_external_surf 3505 3506 END SUBROUTINE radiation_external 3507 3508 !--------------------------------------------------------------------------------------------------! 3285 CONTAINS 3286 3287 SUBROUTINE radiation_external_surf 3288 3289 USE control_parameters 3290 3291 IMPLICIT NONE 3292 3293 INTEGER(iwp) :: i !< grid index along x-dimension 3294 INTEGER(iwp) :: j !< grid index along y-dimension 3295 INTEGER(iwp) :: k !< grid index along z-dimension 3296 INTEGER(iwp) :: m !< running index for surface elements 3297 3298 REAL(wp) :: lw_in !< downwelling longwave radiation, interpolated value 3299 REAL(wp) :: sw_in !< downwelling shortwave radiation, interpolated value 3300 REAL(wp) :: sw_in_dif !< downwelling diffuse shortwave radiation, interpolated value 3301 3302 IF ( surf%ns < 1 ) RETURN 3303 ! 3304 !-- level-of-detail = 1. Note, here it must be distinguished between 3305 !-- averaged radiation and non-averaged radiation for the upwelling 3306 !-- fluxes. 3307 IF ( rad_sw_in_f%lod == 1 ) THEN 3308 3309 sw_in = ( 1.0_wp - fac_dt ) * rad_sw_in_f%var1d(tm) & 3310 + fac_dt * rad_sw_in_f%var1d(t) 3311 3312 lw_in = ( 1.0_wp - fac_dt ) * rad_lw_in_f%var1d(tm) & 3313 + fac_dt * rad_lw_in_f%var1d(t) 3314 ! 3315 !-- Limit shortwave incoming radiation to positive values, in order 3316 !-- to overcome possible observation errors. 3317 sw_in = MAX( 0.0_wp, sw_in ) 3318 sw_in = MERGE( sw_in, 0.0_wp, sun_up ) 3319 3320 surf%rad_sw_in = sw_in 3321 surf%rad_lw_in = lw_in 3322 3323 IF ( average_radiation ) THEN 3324 surf%rad_sw_out = albedo_urb * surf%rad_sw_in 3325 3326 surf%rad_lw_out = emissivity_urb * sigma_sb * t_rad_urb**4 & 3327 + ( 1.0_wp - emissivity_urb ) * surf%rad_lw_in 3328 3329 surf%rad_net = surf%rad_sw_in - surf%rad_sw_out & 3330 + surf%rad_lw_in - surf%rad_lw_out 3331 3332 surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb & 3333 * sigma_sb & 3334 * t_rad_urb**3 3335 ELSE 3336 DO m = 1, surf%ns 3337 k = surf%k(m) 3338 surf%rad_sw_out(m) = ( surf%frac(m,ind_veg_wall) * & 3339 surf%albedo(m,ind_veg_wall) & 3340 + surf%frac(m,ind_pav_green) * & 3341 surf%albedo(m,ind_pav_green) & 3342 + surf%frac(m,ind_wat_win) * & 3343 surf%albedo(m,ind_wat_win) ) & 3344 * surf%rad_sw_in(m) 3345 3346 surf%rad_lw_out(m) = ( surf%frac(m,ind_veg_wall) * & 3347 surf%emissivity(m,ind_veg_wall) & 3348 + surf%frac(m,ind_pav_green) * & 3349 surf%emissivity(m,ind_pav_green) & 3350 + surf%frac(m,ind_wat_win) * & 3351 surf%emissivity(m,ind_wat_win) & 3352 ) & 3353 * sigma_sb & 3354 * ( surf%pt_surface(m) * exner(k) )**4 3355 3356 surf%rad_lw_out_change_0(m) = & 3357 ( surf%frac(m,ind_veg_wall) * & 3358 surf%emissivity(m,ind_veg_wall) & 3359 + surf%frac(m,ind_pav_green) * & 3360 surf%emissivity(im,ind_pav_green) & 3361 + surf%frac(m,ind_wat_win) * & 3362 surf%emissivity(m,ind_wat_win) & 3363 ) * 4.0_wp * sigma_sb & 3364 * ( surf%pt_surface(m) * exner(k) )**3 3365 ENDDO 3366 3367 ENDIF 3368 ! 3369 !-- If diffuse shortwave radiation is available, store it on 3370 !-- the respective files. 3371 IF ( rad_sw_in_dif_f%from_file ) THEN 3372 sw_in_dif= ( 1.0_wp - fac_dt ) * rad_sw_in_dif_f%var1d(tm) & 3373 + fac_dt * rad_sw_in_dif_f%var1d(t) 3374 3375 IF ( ALLOCATED( rad_sw_in_diff ) ) rad_sw_in_diff = sw_in_dif 3376 IF ( ALLOCATED( rad_sw_in_dir ) ) rad_sw_in_dir = sw_in & 3377 - sw_in_dif 3378 ! 3379 !-- Diffuse longwave radiation equals the total downwelling 3380 !-- longwave radiation 3381 IF ( ALLOCATED( rad_lw_in_diff ) ) rad_lw_in_diff = lw_in 3382 ENDIF 3383 ! 3384 !-- level-of-detail = 2 3385 ELSE 3386 3387 DO m = 1, surf%ns 3388 i = surf%i(m) 3389 j = surf%j(m) 3390 k = surf%k(m) 3391 3392 surf%rad_sw_in(m) = ( 1.0_wp - fac_dt ) & 3393 * rad_sw_in_f%var3d(tm,j,i) & 3394 + fac_dt * rad_sw_in_f%var3d(t,j,i) 3395 ! 3396 !-- Limit shortwave incoming radiation to positive values, in 3397 !-- order to overcome possible observation errors. 3398 surf%rad_sw_in(m) = MAX( 0.0_wp, surf%rad_sw_in(m) ) 3399 surf%rad_sw_in(m) = MERGE( surf%rad_sw_in(m), 0.0_wp, sun_up ) 3400 3401 surf%rad_lw_in(m) = ( 1.0_wp - fac_dt ) & 3402 * rad_lw_in_f%var3d(tm,j,i) & 3403 + fac_dt * rad_lw_in_f%var3d(t,j,i) 3404 ! 3405 !-- Weighted average according to surface fraction. 3406 surf%rad_sw_out(m) = ( surf%frac(m,ind_veg_wall) * & 3407 surf%albedo(m,ind_veg_wall) & 3408 + surf%frac(m,ind_pav_green) * & 3409 surf%albedo(m,ind_pav_green) & 3410 + surf%frac(m,ind_wat_win) * & 3411 surf%albedo(m,ind_wat_win) ) & 3412 * surf%rad_sw_in(m) 3413 3414 surf%rad_lw_out(m) = ( surf%frac(m,ind_veg_wall) * & 3415 surf%emissivity(m,ind_veg_wall) & 3416 + surf%frac(m,ind_pav_green) * & 3417 surf%emissivity(m,ind_pav_green) & 3418 + surf%frac(m,ind_wat_win) * & 3419 surf%emissivity(m,ind_wat_win) & 3420 ) & 3421 * sigma_sb & 3422 * ( surf%pt_surface(m) * exner(k) )**4 3423 3424 surf%rad_lw_out_change_0(m) = & 3425 ( surf%frac(m,ind_veg_wall) * & 3426 surf%emissivity(m,ind_veg_wall) & 3427 + surf%frac(m,ind_pav_green) * & 3428 surf%emissivity(m,ind_pav_green) & 3429 + surf%frac(m,ind_wat_win) * & 3430 surf%emissivity(m,ind_wat_win) & 3431 ) * 4.0_wp * sigma_sb & 3432 * ( surf%pt_surface(m) * exner(k) )**3 3433 3434 surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) & 3435 + surf%rad_lw_in(m) - surf%rad_lw_out(m) 3436 ! 3437 !-- If diffuse shortwave radiation is available, store it on 3438 !-- the respective files. 3439 IF ( rad_sw_in_dif_f%from_file ) THEN 3440 IF ( ALLOCATED( rad_sw_in_diff ) ) & 3441 rad_sw_in_diff(j,i) = ( 1.0_wp - fac_dt ) & 3442 * rad_sw_in_dif_f%var3d(tm,j,i) & 3443 + fac_dt * rad_sw_in_dif_f%var3d(t,j,i) 3444 ! 3445 !-- dir = sw_in - sw_in_dif. 3446 IF ( ALLOCATED( rad_sw_in_dir ) ) & 3447 rad_sw_in_dir(j,i) = surf%rad_sw_in(m) - & 3448 rad_sw_in_diff(j,i) 3449 ! 3450 !-- Diffuse longwave radiation equals the total downwelling 3451 !-- longwave radiation 3452 IF ( ALLOCATED( rad_lw_in_diff ) ) & 3453 rad_lw_in_diff(j,i) = surf%rad_lw_in(m) 3454 ENDIF 3455 3456 ENDDO 3457 3458 ENDIF 3459 ! 3460 !-- Store radiation also on 2D arrays, which are still used for 3461 !-- direct-diffuse splitting. Note, this is only required 3462 !-- for horizontal surfaces, which covers all x,y position. 3463 IF ( horizontal ) THEN 3464 DO m = 1, surf%ns 3465 i = surf%i(m) 3466 j = surf%j(m) 3467 3468 rad_sw_in(0,j,i) = surf%rad_sw_in(m) 3469 rad_lw_in(0,j,i) = surf%rad_lw_in(m) 3470 rad_sw_out(0,j,i) = surf%rad_sw_out(m) 3471 rad_lw_out(0,j,i) = surf%rad_lw_out(m) 3472 ENDDO 3473 ENDIF 3474 3475 END SUBROUTINE radiation_external_surf 3476 3477 END SUBROUTINE radiation_external 3478 3479 !------------------------------------------------------------------------------! 3509 3480 ! Description: 3510 3481 ! ------------ 3511 3482 !> A simple clear sky radiation model 3512 !------------------------------------------------------------------------------ --------------------!3513 SUBROUTINE radiation_clearsky3514 3515 IMPLICIT NONE3516 3517 INTEGER(iwp) :: l!< running index for surface orientation3518 3519 LOGICAL :: horizontal!< flag indicating treatment of horinzontal surfaces3520 3521 REAL(wp) :: pt1!< potential temperature at first grid level or mean value at urban layer top3522 REAL(wp) :: pt1_l!< potential temperature at first grid level or mean value at urban layer top at local subdomain3523 REAL(wp) :: ql1!< liquid water mixing ratio at first grid level or mean value at urban layer top3524 REAL(wp) :: ql1_l!< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain3525 3526 TYPE(surf_type), POINTER :: surf !< pointer torespective surface type, used to generalize routine3527 3528 ! 3529 !-- Calculate current zenith angle3530 CALL get_date_time( time_since_reference_point, day_of_year = day_of_year,&3531 second_of_day = second_of_day )3532 CALL calc_zenith( day_of_year,second_of_day )3533 3534 ! 3535 ! -- Calculate sky transmissivity3536 sky_trans = 0.6_wp + 0.2_wp * cos_zenith 3537 3538 ! 3539 ! -- Calculate value of the Exner function at model surface3540 ! 3541 ! -- In case averaged radiation is used, calculate mean temperature and liquid water mixing ratio3542 !-- at the urban-layer top.3543 IF ( average_radiation ) THEN 3544 pt1 = 0.0_wp3545 IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = 0.0_wp3546 3547 pt1_l = SUM( pt(nz_urban_t,nys:nyn,nxl:nxr) ) 3548 IF ( bulk_cloud_model .OR. cloud_droplets ) &3549 ql1_l = SUM( ql(nz_urban_t,nys:nyn,nxl:nxr) )3483 !------------------------------------------------------------------------------! 3484 SUBROUTINE radiation_clearsky 3485 3486 IMPLICIT NONE 3487 3488 INTEGER(iwp) :: l !< running index for surface orientation 3489 3490 LOGICAL :: horizontal !< flag indicating treatment of horinzontal surfaces 3491 3492 REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top 3493 REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain 3494 REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top 3495 REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain 3496 3497 TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine 3498 3499 ! 3500 !-- Calculate current zenith angle 3501 CALL get_date_time( time_since_reference_point, & 3502 day_of_year=day_of_year, & 3503 second_of_day=second_of_day ) 3504 CALL calc_zenith( day_of_year, second_of_day ) 3505 3506 ! 3507 !-- Calculate sky transmissivity 3508 sky_trans = 0.6_wp + 0.2_wp * cos_zenith 3509 3510 ! 3511 !-- Calculate value of the Exner function at model surface 3512 ! 3513 !-- In case averaged radiation is used, calculate mean temperature and 3514 !-- liquid water mixing ratio at the urban-layer top. 3515 IF ( average_radiation ) THEN 3516 pt1 = 0.0_wp 3517 IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = 0.0_wp 3518 3519 pt1_l = SUM( pt(nz_urban_t,nys:nyn,nxl:nxr) ) 3520 IF ( bulk_cloud_model .OR. cloud_droplets ) ql1_l = SUM( ql(nz_urban_t,nys:nyn,nxl:nxr) ) 3550 3521 3551 3522 #if defined( __parallel ) 3552 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 3553 CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 3554 IF ( ierr /= 0 ) THEN 3555 WRITE( 9, * ) 'Error MPI_AllReduce1:', ierr, pt1_l, pt1 3556 FLUSH( 9 ) 3523 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 3524 CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 3525 IF ( ierr /= 0 ) THEN 3526 WRITE(9,*) 'Error MPI_AllReduce1:', ierr, pt1_l, pt1 3527 FLUSH(9) 3528 ENDIF 3529 3530 IF ( bulk_cloud_model .OR. cloud_droplets ) THEN 3531 CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 3532 IF ( ierr /= 0 ) THEN 3533 WRITE(9,*) 'Error MPI_AllReduce2:', ierr, ql1_l, ql1 3534 FLUSH(9) 3535 ENDIF 3536 ENDIF 3537 #else 3538 pt1 = pt1_l 3539 IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = ql1_l 3540 #endif 3541 3542 IF ( bulk_cloud_model .OR. cloud_droplets ) pt1 = pt1 + lv_d_cp / exner(nz_urban_t) * ql1 3543 ! 3544 !-- Finally, divide by number of grid points 3545 pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp ) 3557 3546 ENDIF 3558 3559 IF ( bulk_cloud_model .OR. cloud_droplets ) THEN 3560 CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 3561 IF ( ierr /= 0 ) THEN 3562 WRITE( 9, *) 'Error MPI_AllReduce2:', ierr, ql1_l, ql1 3563 FLUSH( 9 ) 3564 ENDIF 3565 ENDIF 3566 #else 3567 pt1 = pt1_l 3568 IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = ql1_l 3569 #endif 3570 3571 IF ( bulk_cloud_model .OR. cloud_droplets ) & 3572 pt1 = pt1 + lv_d_cp / exner(nz_urban_t) * ql1 3573 ! 3574 !-- Finally, divide by number of grid points 3575 pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND = wp ) 3576 ENDIF 3577 ! 3578 !-- Call clear-sky calculation for each surface orientation. 3579 !-- First, horizontal surfaces 3580 horizontal = .TRUE. 3581 surf => surf_lsm_h 3582 CALL radiation_clearsky_surf 3583 surf => surf_usm_h 3584 CALL radiation_clearsky_surf 3585 horizontal = .FALSE. 3586 ! 3587 !-- Vertical surfaces 3588 DO l = 0, 3 3589 surf => surf_lsm_v(l) 3547 ! 3548 !-- Call clear-sky calculation for each surface orientation. 3549 !-- First, horizontal surfaces 3550 horizontal = .TRUE. 3551 surf => surf_lsm_h 3590 3552 CALL radiation_clearsky_surf 3591 surf => surf_usm_ v(l)3553 surf => surf_usm_h 3592 3554 CALL radiation_clearsky_surf 3593 ENDDO 3594 3595 CONTAINS 3596 3597 !--------------------------------------------------------------------------------------------------! 3598 ! Description: 3599 ! ------------ 3600 !> Todo: Missing subroutine description 3601 !--------------------------------------------------------------------------------------------------! 3602 SUBROUTINE radiation_clearsky_surf 3603 3604 IMPLICIT NONE 3605 3606 INTEGER(iwp) :: i !< index x-direction 3607 INTEGER(iwp) :: j !< index y-direction 3608 INTEGER(iwp) :: k !< index z-direction 3609 INTEGER(iwp) :: m !< running index for surface elements 3610 3611 IF ( surf%ns < 1 ) RETURN 3612 3613 ! 3614 !-- Calculate radiation fluxes and net radiation (rad_net) assuming homogeneous urban 3615 !-- radiation conditions. 3616 IF ( average_radiation ) THEN 3617 3618 k = nz_urban_t 3619 3620 surf%rad_sw_in = solar_constant * sky_trans * cos_zenith 3621 surf%rad_sw_out = albedo_urb * surf%rad_sw_in 3622 3623 surf%rad_lw_in = emissivity_atm_clsky * sigma_sb * ( pt1 * exner(k+1) )**4 3624 3625 surf%rad_lw_out = emissivity_urb * sigma_sb * ( t_rad_urb )**4 & 3626 + ( 1.0_wp - emissivity_urb ) * surf%rad_lw_in 3627 3628 surf%rad_net = surf%rad_sw_in - surf%rad_sw_out & 3629 + surf%rad_lw_in - surf%rad_lw_out 3630 3631 surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb * ( t_rad_urb )**3 3632 3633 ! 3634 !-- Calculate radiation fluxes and net radiation (rad_net) for each surface element. 3635 ELSE 3636 3637 DO m = 1, surf%ns 3638 i = surf%i(m) 3639 j = surf%j(m) 3640 k = surf%k(m) 3641 3642 surf%rad_sw_in(m) = solar_constant * sky_trans * cos_zenith 3643 3644 ! 3645 !-- Weighted average according to surface fraction. 3646 !-- ATTENTION: When radiation interactions are switched on, the calculated fluxes below are not 3647 !-- actually used as they are overwritten in radiation_interaction. 3648 surf%rad_sw_out(m) = ( surf%frac(m,ind_veg_wall) * surf%albedo(m,ind_veg_wall) & 3649 + surf%frac(m,ind_pav_green) * surf%albedo(m,ind_pav_green) & 3650 + surf%frac(m,ind_wat_win) * surf%albedo(m,ind_wat_win) ) & 3651 * surf%rad_sw_in(m) 3652 3653 surf%rad_lw_out(m) = ( surf%frac(m,ind_veg_wall) * surf%emissivity(m,ind_veg_wall) & 3654 + surf%frac(m,ind_pav_green) * surf%emissivity(m,ind_pav_green) & 3655 + surf%frac(m,ind_wat_win) * surf%emissivity(m,ind_wat_win) ) & 3656 * sigma_sb * ( surf%pt_surface(m) * exner(nzb) )**4 3657 3658 surf%rad_lw_out_change_0(m) = ( surf%frac(m,ind_veg_wall) * & 3659 surf%emissivity(m,ind_veg_wall) & 3660 + surf%frac(m,ind_pav_green) * & 3661 surf%emissivity(m,ind_pav_green) & 3662 + surf%frac(m,ind_wat_win) * & 3663 surf%emissivity(m,ind_wat_win) & 3664 ) * 4.0_wp * sigma_sb & 3665 * ( surf%pt_surface(m) * exner(nzb) )** 3 3666 3667 3668 IF ( bulk_cloud_model .OR. cloud_droplets ) THEN 3669 pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i) 3670 surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * ( pt1 * exner(k) )**4 3671 ELSE 3672 surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * ( pt(k,j,i) * exner(k) )**4 3673 ENDIF 3674 3675 surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) & 3676 + surf%rad_lw_in(m) - surf%rad_lw_out(m) 3677 3555 horizontal = .FALSE. 3556 ! 3557 !-- Vertical surfaces 3558 DO l = 0, 3 3559 surf => surf_lsm_v(l) 3560 CALL radiation_clearsky_surf 3561 surf => surf_usm_v(l) 3562 CALL radiation_clearsky_surf 3678 3563 ENDDO 3679 3564 3680 ENDIF 3681 3682 ! 3683 !-- Fill out values in radiation arrays. Note, this is only required for horizontal surfaces, which 3684 !-- covers all x,y position. 3685 IF ( horizontal ) THEN 3686 DO m = 1, surf%ns 3687 i = surf%i(m) 3688 j = surf%j(m) 3689 rad_sw_in(0,j,i) = surf%rad_sw_in(m) 3690 rad_sw_out(0,j,i) = surf%rad_sw_out(m) 3691 rad_lw_in(0,j,i) = surf%rad_lw_in(m) 3692 rad_lw_out(0,j,i) = surf%rad_lw_out(m) 3693 ENDDO 3694 ENDIF 3695 3696 END SUBROUTINE radiation_clearsky_surf 3697 3698 END SUBROUTINE radiation_clearsky 3699 3700 3701 !--------------------------------------------------------------------------------------------------! 3565 CONTAINS 3566 3567 SUBROUTINE radiation_clearsky_surf 3568 3569 IMPLICIT NONE 3570 3571 INTEGER(iwp) :: i !< index x-direction 3572 INTEGER(iwp) :: j !< index y-direction 3573 INTEGER(iwp) :: k !< index z-direction 3574 INTEGER(iwp) :: m !< running index for surface elements 3575 3576 IF ( surf%ns < 1 ) RETURN 3577 3578 ! 3579 !-- Calculate radiation fluxes and net radiation (rad_net) assuming 3580 !-- homogeneous urban radiation conditions. 3581 IF ( average_radiation ) THEN 3582 3583 k = nz_urban_t 3584 3585 surf%rad_sw_in = solar_constant * sky_trans * cos_zenith 3586 surf%rad_sw_out = albedo_urb * surf%rad_sw_in 3587 3588 surf%rad_lw_in = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k+1))**4 3589 3590 surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 & 3591 + (1.0_wp - emissivity_urb) * surf%rad_lw_in 3592 3593 surf%rad_net = surf%rad_sw_in - surf%rad_sw_out & 3594 + surf%rad_lw_in - surf%rad_lw_out 3595 3596 surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb & 3597 * (t_rad_urb)**3 3598 3599 ! 3600 !-- Calculate radiation fluxes and net radiation (rad_net) for each surface 3601 !-- element. 3602 ELSE 3603 3604 DO m = 1, surf%ns 3605 i = surf%i(m) 3606 j = surf%j(m) 3607 k = surf%k(m) 3608 3609 surf%rad_sw_in(m) = solar_constant * sky_trans * cos_zenith 3610 3611 ! 3612 !-- Weighted average according to surface fraction. 3613 !-- ATTENTION: when radiation interactions are switched on the 3614 !-- calculated fluxes below are not actually used as they are 3615 !-- overwritten in radiation_interaction. 3616 surf%rad_sw_out(m) = ( surf%frac(m,ind_veg_wall) * & 3617 surf%albedo(m,ind_veg_wall) & 3618 + surf%frac(m,ind_pav_green) * & 3619 surf%albedo(m,ind_pav_green) & 3620 + surf%frac(m,ind_wat_win) * & 3621 surf%albedo(m,ind_wat_win) ) & 3622 * surf%rad_sw_in(m) 3623 3624 surf%rad_lw_out(m) = ( surf%frac(m,ind_veg_wall) * & 3625 surf%emissivity(m,ind_veg_wall) & 3626 + surf%frac(m,ind_pav_green) * & 3627 surf%emissivity(m,ind_pav_green) & 3628 + surf%frac(m,ind_wat_win) * & 3629 surf%emissivity(m,ind_wat_win) & 3630 ) & 3631 * sigma_sb & 3632 * ( surf%pt_surface(m) * exner(nzb) )**4 3633 3634 surf%rad_lw_out_change_0(m) = & 3635 ( surf%frac(m,ind_veg_wall) * & 3636 surf%emissivity(m,ind_veg_wall) & 3637 + surf%frac(m,ind_pav_green) * & 3638 surf%emissivity(m,ind_pav_green) & 3639 + surf%frac(m,ind_wat_win) * & 3640 surf%emissivity(m,ind_wat_win) & 3641 ) * 4.0_wp * sigma_sb & 3642 * ( surf%pt_surface(m) * exner(nzb) )** 3 3643 3644 3645 IF ( bulk_cloud_model .OR. cloud_droplets ) THEN 3646 pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i) 3647 surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k))**4 3648 ELSE 3649 surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt(k,j,i) * exner(k))**4 3650 ENDIF 3651 3652 surf%rad_net(m) = surf%rad_sw_in(m) - surf%rad_sw_out(m) & 3653 + surf%rad_lw_in(m) - surf%rad_lw_out(m) 3654 3655 ENDDO 3656 3657 ENDIF 3658 3659 ! 3660 !-- Fill out values in radiation arrays. Note, this is only required 3661 !-- for horizontal surfaces, which covers all x,y position. 3662 IF ( horizontal ) THEN 3663 DO m = 1, surf%ns 3664 i = surf%i(m) 3665 j = surf%j(m) 3666 rad_sw_in(0,j,i) = surf%rad_sw_in(m) 3667 rad_sw_out(0,j,i) = surf%rad_sw_out(m) 3668 rad_lw_in(0,j,i) = surf%rad_lw_in(m) 3669 rad_lw_out(0,j,i) = surf%rad_lw_out(m) 3670 ENDDO 3671 ENDIF 3672 3673 END SUBROUTINE radiation_clearsky_surf 3674 3675 END SUBROUTINE radiation_clearsky 3676 3677 3678 !------------------------------------------------------------------------------! 3702 3679 ! Description: 3703 3680 ! ------------ 3704 3681 !> This scheme keeps the prescribed net radiation constant during the run 3705 !------------------------------------------------------------------------------ --------------------!3706 SUBROUTINE radiation_constant3707 3708 3709 IMPLICIT NONE3710 3711 INTEGER(iwp) :: l!< running index for surface orientation3712 3713 LOGICAL :: horizontal!< flag indicating treatment of horinzontal surfaces3714 3715 REAL(wp) :: pt1!< potential temperature at first grid level or mean value at urban layer top3716 REAL(wp) :: pt1_l!< potential temperature at first grid level or mean value at urban layer top at local subdomain3717 REAL(wp) :: ql1!< liquid water mixing ratio at first grid level or mean value at urban layer top3718 REAL(wp) :: ql1_l!< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain3719 3720 TYPE(surf_type), POINTER :: surf!< pointer on respective surface type, used to generalize routine3721 3722 ! 3723 !-- In case averaged radiation is used, calculate mean temperature and liquid water mixing ratio3724 !-- at the urban-layer top.3725 IF ( average_radiation ) THEN3726 pt1 = 0.0_wp3727 IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = 0.0_wp3728 3729 pt1_l = SUM( pt(nz_urban_t,nys:nyn,nxl:nxr) )3730 IF ( bulk_cloud_model .OR. cloud_droplets ) ql1_l = SUM( ql(nz_urban_t,nys:nyn,nxl:nxr) )3682 !------------------------------------------------------------------------------! 3683 SUBROUTINE radiation_constant 3684 3685 3686 IMPLICIT NONE 3687 3688 INTEGER(iwp) :: l !< running index for surface orientation 3689 3690 LOGICAL :: horizontal !< flag indicating treatment of horinzontal surfaces 3691 3692 REAL(wp) :: pt1 !< potential temperature at first grid level or mean value at urban layer top 3693 REAL(wp) :: pt1_l !< potential temperature at first grid level or mean value at urban layer top at local subdomain 3694 REAL(wp) :: ql1 !< liquid water mixing ratio at first grid level or mean value at urban layer top 3695 REAL(wp) :: ql1_l !< liquid water mixing ratio at first grid level or mean value at urban layer top at local subdomain 3696 3697 TYPE(surf_type), POINTER :: surf !< pointer on respective surface type, used to generalize routine 3698 3699 ! 3700 !-- In case averaged radiation is used, calculate mean temperature and 3701 !-- liquid water mixing ratio at the urban-layer top. 3702 IF ( average_radiation ) THEN 3703 pt1 = 0.0_wp 3704 IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = 0.0_wp 3705 3706 pt1_l = SUM( pt(nz_urban_t,nys:nyn,nxl:nxr) ) 3707 IF ( bulk_cloud_model .OR. cloud_droplets ) ql1_l = SUM( ql(nz_urban_t,nys:nyn,nxl:nxr) ) 3731 3708 3732 3709 #if defined( __parallel ) 3733 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 3734 CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 3735 IF ( ierr /= 0 ) THEN 3736 WRITE( 9, * ) 'Error MPI_AllReduce3:', ierr, pt1_l, pt1 3737 FLUSH( 9 ) 3710 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 3711 CALL MPI_ALLREDUCE( pt1_l, pt1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 3712 IF ( ierr /= 0 ) THEN 3713 WRITE(9,*) 'Error MPI_AllReduce3:', ierr, pt1_l, pt1 3714 FLUSH(9) 3715 ENDIF 3716 IF ( bulk_cloud_model .OR. cloud_droplets ) THEN 3717 CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 3718 IF ( ierr /= 0 ) THEN 3719 WRITE(9,*) 'Error MPI_AllReduce4:', ierr, ql1_l, ql1 3720 FLUSH(9) 3721 ENDIF 3722 ENDIF 3723 #else 3724 pt1 = pt1_l 3725 IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = ql1_l 3726 #endif 3727 IF ( bulk_cloud_model .OR. cloud_droplets ) pt1 = pt1 + lv_d_cp / exner(nz_urban_t+1) * ql1 3728 ! 3729 !-- Finally, divide by number of grid points 3730 pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND=wp ) 3738 3731 ENDIF 3739 IF ( bulk_cloud_model .OR. cloud_droplets ) THEN 3740 CALL MPI_ALLREDUCE( ql1_l, ql1, 1, MPI_REAL, MPI_SUM, comm2d, ierr ) 3741 IF ( ierr /= 0 ) THEN 3742 WRITE( 9, * ) 'Error MPI_AllReduce4:', ierr, ql1_l, ql1 3743 FLUSH( 9 ) 3744 ENDIF 3745 ENDIF 3746 #else 3747 pt1 = pt1_l 3748 IF ( bulk_cloud_model .OR. cloud_droplets ) ql1 = ql1_l 3749 #endif 3750 IF ( bulk_cloud_model .OR. cloud_droplets ) & 3751 pt1 = pt1 + lv_d_cp / exner(nz_urban_t+1) * ql1 3752 ! 3753 !-- Finally, divide by number of grid points 3754 pt1 = pt1 / REAL( ( nx + 1 ) * ( ny + 1 ), KIND = wp ) 3755 ENDIF 3756 3757 ! 3758 !-- First, horizontal surfaces 3759 horizontal = .TRUE. 3760 surf => surf_lsm_h 3761 CALL radiation_constant_surf 3762 surf => surf_usm_h 3763 CALL radiation_constant_surf 3764 horizontal = .FALSE. 3765 ! 3766 !-- Vertical surfaces 3767 DO l = 0, 3 3768 surf => surf_lsm_v(l) 3732 3733 ! 3734 !-- First, horizontal surfaces 3735 horizontal = .TRUE. 3736 surf => surf_lsm_h 3769 3737 CALL radiation_constant_surf 3770 surf => surf_usm_ v(l)3738 surf => surf_usm_h 3771 3739 CALL radiation_constant_surf 3772 ENDDO 3773 3774 CONTAINS 3775 3776 !--------------------------------------------------------------------------------------------------! 3777 ! Description: 3778 ! ------------ 3779 !> To do: Missing subroutine description 3780 !--------------------------------------------------------------------------------------------------! 3781 SUBROUTINE radiation_constant_surf 3782 3783 IMPLICIT NONE 3784 3785 INTEGER(iwp) :: i !< index x-direction 3786 INTEGER(iwp) :: ioff !< offset between surface element and adjacent grid point along x 3787 INTEGER(iwp) :: j !< index y-direction 3788 INTEGER(iwp) :: joff !< offset between surface element and adjacent grid point along y 3789 INTEGER(iwp) :: k !< index z-direction 3790 INTEGER(iwp) :: koff !< offset between surface element and adjacent grid point along z 3791 INTEGER(iwp) :: m !< running index for surface elements 3792 3793 IF ( surf%ns < 1 ) RETURN 3794 3795 !-- Calculate homogenoeus urban radiation fluxes 3796 IF ( average_radiation ) THEN 3797 3798 surf%rad_net = net_radiation 3799 3800 surf%rad_lw_in = emissivity_atm_clsky * sigma_sb * ( pt1 * exner(nz_urban_t+1) )**4 3801 3802 surf%rad_lw_out = emissivity_urb * sigma_sb * ( t_rad_urb )**4 & 3803 + ( 1.0_wp - emissivity_urb ) & ! shouldn't this be a bulk value -- emissivity_urb? 3804 * surf%rad_lw_in 3805 3806 surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb * t_rad_urb**3 3807 3808 surf%rad_sw_in = ( surf%rad_net - surf%rad_lw_in + surf%rad_lw_out ) & 3809 / ( 1.0_wp - albedo_urb ) 3810 3811 surf%rad_sw_out = albedo_urb * surf%rad_sw_in 3812 3813 ! 3814 !-- Calculate radiation fluxes for each surface element 3815 ELSE 3816 ! 3817 !-- Determine index offset between surface element and adjacent atmospheric grid point 3818 ioff = surf%ioff 3819 joff = surf%joff 3820 koff = surf%koff 3821 3822 ! 3823 !-- Prescribe net radiation and estimate the remaining radiative fluxes 3824 DO m = 1, surf%ns 3825 i = surf%i(m) 3826 j = surf%j(m) 3827 k = surf%k(m) 3828 3829 surf%rad_net(m) = net_radiation 3830 3831 IF ( bulk_cloud_model .OR. cloud_droplets ) THEN 3832 pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i) 3833 surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * ( pt1 * exner(k) )**4 3834 ELSE 3835 surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * ( pt(k,j,i) * exner(k) )**4 3836 ENDIF 3837 3838 ! 3839 !-- Weighted average according to surface fraction. 3840 surf%rad_lw_out(m) = ( surf%frac(m,ind_veg_wall) * surf%emissivity(m,ind_veg_wall) & 3841 + surf%frac(m,ind_pav_green) * surf%emissivity(m,ind_pav_green) & 3842 + surf%frac(m,ind_wat_win) * surf%emissivity(m,ind_wat_win) ) & 3843 * sigma_sb * ( surf%pt_surface(m) * exner(nzb) )**4 3844 3845 surf%rad_sw_in(m) = ( surf%rad_net(m) - surf%rad_lw_in(m) + surf%rad_lw_out(m) ) & 3846 / ( 1.0_wp - & 3847 ( surf%frac(m,ind_veg_wall) * surf%albedo(m,ind_veg_wall) & 3848 + surf%frac(m,ind_pav_green) * surf%albedo(m,ind_pav_green) & 3849 + surf%frac(m,ind_wat_win) * surf%albedo(m,ind_wat_win) ) & 3850 ) 3851 3852 surf%rad_sw_out(m) = ( surf%frac(m,ind_veg_wall) * surf%albedo(m,ind_veg_wall) & 3853 + surf%frac(m,ind_pav_green) * surf%albedo(m,ind_pav_green) & 3854 + surf%frac(m,ind_wat_win) * surf%albedo(m,ind_wat_win) ) & 3855 * surf%rad_sw_in(m) 3856 3740 horizontal = .FALSE. 3741 ! 3742 !-- Vertical surfaces 3743 DO l = 0, 3 3744 surf => surf_lsm_v(l) 3745 CALL radiation_constant_surf 3746 surf => surf_usm_v(l) 3747 CALL radiation_constant_surf 3857 3748 ENDDO 3858 3749 3859 ENDIF 3860 3861 ! 3862 !-- Fill out values in radiation arrays. Note, this is only required for horizontal surfaces, which 3863 !-- covers all x,y position. 3864 IF ( horizontal ) THEN 3865 DO m = 1, surf%ns 3866 i = surf%i(m) 3867 j = surf%j(m) 3868 rad_sw_in(0,j,i) = surf%rad_sw_in(m) 3869 rad_sw_out(0,j,i) = surf%rad_sw_out(m) 3870 rad_lw_in(0,j,i) = surf%rad_lw_in(m) 3871 rad_lw_out(0,j,i) = surf%rad_lw_out(m) 3872 ENDDO 3873 ENDIF 3874 3875 END SUBROUTINE radiation_constant_surf 3876 3877 3878 END SUBROUTINE radiation_constant 3879 3880 !--------------------------------------------------------------------------------------------------! 3750 CONTAINS 3751 3752 SUBROUTINE radiation_constant_surf 3753 3754 IMPLICIT NONE 3755 3756 INTEGER(iwp) :: i !< index x-direction 3757 INTEGER(iwp) :: ioff !< offset between surface element and adjacent grid point along x 3758 INTEGER(iwp) :: j !< index y-direction 3759 INTEGER(iwp) :: joff !< offset between surface element and adjacent grid point along y 3760 INTEGER(iwp) :: k !< index z-direction 3761 INTEGER(iwp) :: koff !< offset between surface element and adjacent grid point along z 3762 INTEGER(iwp) :: m !< running index for surface elements 3763 3764 IF ( surf%ns < 1 ) RETURN 3765 3766 !-- Calculate homogenoeus urban radiation fluxes 3767 IF ( average_radiation ) THEN 3768 3769 surf%rad_net = net_radiation 3770 3771 surf%rad_lw_in = emissivity_atm_clsky * sigma_sb * (pt1 * exner(nz_urban_t+1))**4 3772 3773 surf%rad_lw_out = emissivity_urb * sigma_sb * (t_rad_urb)**4 & 3774 + ( 1.0_wp - emissivity_urb ) & ! shouldn't be this a bulk value -- emissivity_urb? 3775 * surf%rad_lw_in 3776 3777 surf%rad_lw_out_change_0 = 4.0_wp * emissivity_urb * sigma_sb & 3778 * t_rad_urb**3 3779 3780 surf%rad_sw_in = ( surf%rad_net - surf%rad_lw_in & 3781 + surf%rad_lw_out ) & 3782 / ( 1.0_wp - albedo_urb ) 3783 3784 surf%rad_sw_out = albedo_urb * surf%rad_sw_in 3785 3786 ! 3787 !-- Calculate radiation fluxes for each surface element 3788 ELSE 3789 ! 3790 !-- Determine index offset between surface element and adjacent 3791 !-- atmospheric grid point 3792 ioff = surf%ioff 3793 joff = surf%joff 3794 koff = surf%koff 3795 3796 ! 3797 !-- Prescribe net radiation and estimate the remaining radiative fluxes 3798 DO m = 1, surf%ns 3799 i = surf%i(m) 3800 j = surf%j(m) 3801 k = surf%k(m) 3802 3803 surf%rad_net(m) = net_radiation 3804 3805 IF ( bulk_cloud_model .OR. cloud_droplets ) THEN 3806 pt1 = pt(k,j,i) + lv_d_cp / exner(k) * ql(k,j,i) 3807 surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * (pt1 * exner(k))**4 3808 ELSE 3809 surf%rad_lw_in(m) = emissivity_atm_clsky * sigma_sb * & 3810 ( pt(k,j,i) * exner(k) )**4 3811 ENDIF 3812 3813 ! 3814 !-- Weighted average according to surface fraction. 3815 surf%rad_lw_out(m) = ( surf%frac(m,ind_veg_wall) * & 3816 surf%emissivity(m,ind_veg_wall) & 3817 + surf%frac(m,ind_pav_green) * & 3818 surf%emissivity(m,ind_pav_green) & 3819 + surf%frac(m,ind_wat_win) * & 3820 surf%emissivity(m,ind_wat_win) & 3821 ) & 3822 * sigma_sb & 3823 * ( surf%pt_surface(m) * exner(nzb) )**4 3824 3825 surf%rad_sw_in(m) = ( surf%rad_net(m) - surf%rad_lw_in(m) & 3826 + surf%rad_lw_out(m) ) & 3827 / ( 1.0_wp - & 3828 ( surf%frac(m,ind_veg_wall) * & 3829 surf%albedo(m,ind_veg_wall) & 3830 + surf%frac(m,ind_pav_green) * & 3831 surf%albedo(m,ind_pav_green) & 3832 + surf%frac(m,ind_wat_win) * & 3833 surf%albedo(m,ind_wat_win) ) & 3834 ) 3835 3836 surf%rad_sw_out(m) = ( surf%frac(m,ind_veg_wall) * & 3837 surf%albedo(m,ind_veg_wall) & 3838 + surf%frac(m,ind_pav_green) * & 3839 surf%albedo(m,ind_pav_green) & 3840 + surf%frac(m,ind_wat_win) * & 3841 surf%albedo(m,ind_wat_win) ) & 3842 * surf%rad_sw_in(m) 3843 3844 ENDDO 3845 3846 ENDIF 3847 3848 ! 3849 !-- Fill out values in radiation arrays. Note, this is only required 3850 !-- for horizontal surfaces, which covers all x,y position. 3851 IF ( horizontal ) THEN 3852 DO m = 1, surf%ns 3853 i = surf%i(m) 3854 j = surf%j(m) 3855 rad_sw_in(0,j,i) = surf%rad_sw_in(m) 3856 rad_sw_out(0,j,i) = surf%rad_sw_out(m) 3857 rad_lw_in(0,j,i) = surf%rad_lw_in(m) 3858 rad_lw_out(0,j,i) = surf%rad_lw_out(m) 3859 ENDDO 3860 ENDIF 3861 3862 END SUBROUTINE radiation_constant_surf 3863 3864 3865 END SUBROUTINE radiation_constant 3866 3867 !------------------------------------------------------------------------------! 3881 3868 ! Description: 3882 3869 ! ------------ 3883 3870 !> Header output for radiation model 3884 !--------------------------------------------------------------------------------------------------! 3885 SUBROUTINE radiation_header( io ) 3886 3887 3888 IMPLICIT NONE 3889 3890 INTEGER(iwp), INTENT(IN) :: io !< Unit of the output file 3891 3892 3893 3894 ! 3895 !-- Write radiation model header 3896 WRITE( io, 3 ) 3897 3898 IF ( radiation_scheme == "constant" ) THEN 3899 WRITE( io, 4 ) net_radiation 3900 ELSEIF ( radiation_scheme == "clear-sky" ) THEN 3901 WRITE( io, 5 ) 3902 ELSEIF ( radiation_scheme == "rrtmg" ) THEN 3903 WRITE( io, 6 ) 3904 IF ( .NOT. lw_radiation ) WRITE( io, 10 ) 3905 IF ( .NOT. sw_radiation ) WRITE( io, 11 ) 3906 ELSEIF ( radiation_scheme == "external" ) THEN 3907 WRITE( io, 14 ) 3908 ENDIF 3909 3910 IF ( albedo_type_f%from_file .OR. vegetation_type_f%from_file .OR. & 3911 pavement_type_f%from_file .OR. water_type_f%from_file .OR. & 3912 building_type_f%from_file ) THEN 3913 WRITE( io, 13 ) 3914 ELSE 3915 IF ( albedo_type == 0 ) THEN 3916 WRITE( io, 7 ) albedo 3871 !------------------------------------------------------------------------------! 3872 SUBROUTINE radiation_header ( io ) 3873 3874 3875 IMPLICIT NONE 3876 3877 INTEGER(iwp), INTENT(IN) :: io !< Unit of the output file 3878 3879 3880 3881 ! 3882 !-- Write radiation model header 3883 WRITE( io, 3 ) 3884 3885 IF ( radiation_scheme == "constant" ) THEN 3886 WRITE( io, 4 ) net_radiation 3887 ELSEIF ( radiation_scheme == "clear-sky" ) THEN 3888 WRITE( io, 5 ) 3889 ELSEIF ( radiation_scheme == "rrtmg" ) THEN 3890 WRITE( io, 6 ) 3891 IF ( .NOT. lw_radiation ) WRITE( io, 10 ) 3892 IF ( .NOT. sw_radiation ) WRITE( io, 11 ) 3893 ELSEIF ( radiation_scheme == "external" ) THEN 3894 WRITE( io, 14 ) 3895 ENDIF 3896 3897 IF ( albedo_type_f%from_file .OR. vegetation_type_f%from_file .OR. & 3898 pavement_type_f%from_file .OR. water_type_f%from_file .OR. & 3899 building_type_f%from_file ) THEN 3900 WRITE( io, 13 ) 3917 3901 ELSE 3918 WRITE( io, 8 ) TRIM( albedo_type_name(albedo_type) ) 3902 IF ( albedo_type == 0 ) THEN 3903 WRITE( io, 7 ) albedo 3904 ELSE 3905 WRITE( io, 8 ) TRIM( albedo_type_name(albedo_type) ) 3906 ENDIF 3919 3907 ENDIF 3920 ENDIF 3921 IF ( constant_albedo ) THEN 3922 WRITE( io, 9 ) 3923 ENDIF 3924 3925 WRITE( io, 12 ) dt_radiation 3926 3927 3928 3 FORMAT (//' Radiation model information:'/' ----------------------------'/) 3929 4 FORMAT (' --> Using constant net radiation: net_radiation = ', F6.2, // 'W/m**2') 3930 5 FORMAT (' --> Simple radiation scheme for clear sky is used (no clouds, default)') 3908 IF ( constant_albedo ) THEN 3909 WRITE( io, 9 ) 3910 ENDIF 3911 3912 WRITE( io, 12 ) dt_radiation 3913 3914 3915 3 FORMAT (//' Radiation model information:'/ & 3916 ' ----------------------------'/) 3917 4 FORMAT (' --> Using constant net radiation: net_radiation = ', F6.2, & 3918 // 'W/m**2') 3919 5 FORMAT (' --> Simple radiation scheme for clear sky is used (no clouds,',& 3920 ' default)') 3931 3921 6 FORMAT (' --> RRTMG scheme is used') 3932 3922 7 FORMAT (/' User-specific surface albedo: albedo =', F6.3) … … 3936 3926 11 FORMAT (/' --> Shortwave radiation is disabled.') 3937 3927 12 FORMAT (' Timestep: dt_radiation = ', F6.2, ' s') 3938 13 FORMAT (/' Albedo is set individually for each xy-location, according ', 3928 13 FORMAT (/' Albedo is set individually for each xy-location, according ', & 3939 3929 'to given surface type.') 3940 3930 14 FORMAT (' --> External radiation forcing is used') 3941 3931 3942 3932 3943 END SUBROUTINE radiation_header3944 3945 3946 !------------------------------------------------------------------------------ --------------------!3933 END SUBROUTINE radiation_header 3934 3935 3936 !------------------------------------------------------------------------------! 3947 3937 ! Description: 3948 3938 ! ------------ 3949 3939 !> Parin for &radiation_parameters for radiation model and RTM 3950 !--------------------------------------------------------------------------------------------------! 3951 SUBROUTINE radiation_parin 3952 3953 3954 IMPLICIT NONE 3955 3956 CHARACTER (LEN=80) :: line !< dummy string that contains the current line of the parameter file 3957 3958 NAMELIST /radiation_par/ albedo, & 3959 albedo_lw_dif, & 3960 albedo_lw_dir, & 3961 albedo_sw_dif, & 3962 albedo_sw_dir, & 3963 albedo_type, & 3964 constant_albedo, & 3965 dt_radiation, & 3966 emissivity, & 3967 lw_radiation, & 3968 max_raytracing_dist, & 3969 min_irrf_value, & 3970 mrt_geom, & 3971 mrt_geom_params, & 3972 mrt_include_sw, & 3973 mrt_nlevels, & 3974 mrt_skip_roof, & 3975 net_radiation, & 3976 nrefsteps, & 3977 plant_lw_interact, & 3978 rad_angular_discretization, & 3979 radiation_interactions_on, & 3980 radiation_scheme, & 3981 raytrace_discrete_azims, & 3982 raytrace_discrete_elevs, & 3983 raytrace_mpi_rma, & 3984 skip_time_do_radiation, & 3985 surface_reflections, & 3986 svfnorm_report_thresh, & 3987 sw_radiation, & 3988 trace_fluxes_above, & 3989 unscheduled_radiation_calls 3990 3991 3992 NAMELIST /radiation_parameters/ albedo, & 3993 albedo_lw_dif, & 3994 albedo_lw_dir, & 3995 albedo_sw_dif, & 3996 albedo_sw_dir, & 3997 albedo_type, & 3998 constant_albedo, & 3999 dt_radiation, & 4000 emissivity, & 4001 lw_radiation, & 4002 max_raytracing_dist, & 4003 min_irrf_value, & 4004 mrt_geom, & 4005 mrt_geom_params, & 4006 mrt_include_sw, & 4007 mrt_nlevels, & 4008 mrt_skip_roof, & 4009 net_radiation, & 4010 nrefsteps, & 4011 plant_lw_interact, & 4012 rad_angular_discretization, & 4013 radiation_interactions_on, & 4014 radiation_scheme, & 4015 raytrace_discrete_azims, & 4016 raytrace_discrete_elevs, & 4017 raytrace_mpi_rma, & 4018 skip_time_do_radiation, & 4019 surface_reflections, & 4020 svfnorm_report_thresh, & 4021 sw_radiation, & 4022 trace_fluxes_above, & 4023 unscheduled_radiation_calls 4024 4025 line = ' ' 4026 4027 ! 4028 !-- Try to find radiation model namelist 4029 REWIND ( 11 ) 4030 line = ' ' 4031 DO WHILE ( INDEX( line, '&radiation_parameters' ) == 0 ) 4032 READ ( 11, '(A)', END = 12 ) line 4033 ENDDO 4034 BACKSPACE ( 11 ) 4035 4036 ! 4037 !-- Read user-defined namelist 4038 READ ( 11, radiation_parameters, ERR = 10 ) 4039 4040 ! 4041 !-- Set flag that indicates that the radiation model is switched on 4042 radiation = .TRUE. 4043 4044 GOTO 14 4045 4046 10 BACKSPACE( 11 ) 4047 READ( 11 , '(A)' ) line 4048 CALL parin_fail_message( 'radiation_parameters', line ) 4049 ! 4050 !-- Try to find old namelist 4051 12 REWIND ( 11 ) 4052 line = ' ' 4053 DO WHILE ( INDEX( line, '&radiation_par' ) == 0 ) 4054 READ ( 11, '(A)', END = 14 ) line 4055 ENDDO 4056 BACKSPACE ( 11 ) 4057 4058 ! 4059 !-- Read user-defined namelist 4060 READ ( 11, radiation_par, ERR = 13, END = 14 ) 4061 4062 message_string = 'namelist radiation_par is deprecated and will be removed in near future. ' //& 4063 'Please use namelist radiation_parameters instead' 4064 CALL message( 'radiation_parin', 'PA0487', 0, 1, 0, 6, 0 ) 4065 4066 ! 4067 !-- Set flag that indicates that the radiation model is switched on 4068 radiation = .TRUE. 4069 4070 IF ( .NOT. radiation_interactions_on .AND. surface_reflections ) THEN 4071 message_string = 'surface_reflections is allowed only when ' // & 4072 'radiation_interactions_on is set to TRUE' 4073 CALL message( 'radiation_parin', 'PA0293',1, 2, 0, 6, 0 ) 4074 ENDIF 4075 4076 GOTO 14 4077 4078 13 BACKSPACE( 11 ) 4079 READ( 11 , '(A)' ) line 4080 CALL parin_fail_message( 'radiation_par', line ) 4081 4082 14 CONTINUE 4083 4084 END SUBROUTINE radiation_parin 4085 4086 4087 !--------------------------------------------------------------------------------------------------! 3940 !------------------------------------------------------------------------------! 3941 SUBROUTINE radiation_parin 3942 3943 3944 IMPLICIT NONE 3945 3946 CHARACTER (LEN=80) :: line !< dummy string that contains the current line of the parameter file 3947 3948 NAMELIST /radiation_par/ albedo, albedo_lw_dif, albedo_lw_dir, & 3949 albedo_sw_dif, albedo_sw_dir, albedo_type, & 3950 constant_albedo, dt_radiation, emissivity, & 3951 lw_radiation, max_raytracing_dist, & 3952 min_irrf_value, mrt_geom, mrt_geom_params, & 3953 mrt_include_sw, mrt_nlevels, & 3954 mrt_skip_roof, net_radiation, nrefsteps, & 3955 plant_lw_interact, rad_angular_discretization,& 3956 radiation_interactions_on, radiation_scheme, & 3957 raytrace_discrete_azims, & 3958 raytrace_discrete_elevs, raytrace_mpi_rma, & 3959 trace_fluxes_above, & 3960 skip_time_do_radiation, surface_reflections, & 3961 svfnorm_report_thresh, sw_radiation, & 3962 unscheduled_radiation_calls 3963 3964 3965 NAMELIST /radiation_parameters/ albedo, albedo_lw_dif, albedo_lw_dir, & 3966 albedo_sw_dif, albedo_sw_dir, albedo_type, & 3967 constant_albedo, dt_radiation, emissivity, & 3968 lw_radiation, max_raytracing_dist, & 3969 min_irrf_value, mrt_geom, mrt_geom_params, & 3970 mrt_include_sw, mrt_nlevels, & 3971 mrt_skip_roof, net_radiation, nrefsteps, & 3972 plant_lw_interact, rad_angular_discretization,& 3973 radiation_interactions_on, radiation_scheme, & 3974 raytrace_discrete_azims, & 3975 raytrace_discrete_elevs, raytrace_mpi_rma, & 3976 trace_fluxes_above, & 3977 skip_time_do_radiation, surface_reflections, & 3978 svfnorm_report_thresh, sw_radiation, & 3979 unscheduled_radiation_calls 3980 3981 line = ' ' 3982 3983 ! 3984 !-- Try to find radiation model namelist 3985 REWIND ( 11 ) 3986 line = ' ' 3987 DO WHILE ( INDEX( line, '&radiation_parameters' ) == 0 ) 3988 READ ( 11, '(A)', END=12 ) line 3989 ENDDO 3990 BACKSPACE ( 11 ) 3991 3992 ! 3993 !-- Read user-defined namelist 3994 READ ( 11, radiation_parameters, ERR = 10 ) 3995 3996 ! 3997 !-- Set flag that indicates that the radiation model is switched on 3998 radiation = .TRUE. 3999 4000 GOTO 14 4001 4002 10 BACKSPACE( 11 ) 4003 READ( 11 , '(A)') line 4004 CALL parin_fail_message( 'radiation_parameters', line ) 4005 ! 4006 !-- Try to find old namelist 4007 12 REWIND ( 11 ) 4008 line = ' ' 4009 DO WHILE ( INDEX( line, '&radiation_par' ) == 0 ) 4010 READ ( 11, '(A)', END=14 ) line 4011 ENDDO 4012 BACKSPACE ( 11 ) 4013 4014 ! 4015 !-- Read user-defined namelist 4016 READ ( 11, radiation_par, ERR = 13, END = 14 ) 4017 4018 message_string = 'namelist radiation_par is deprecated and will be ' // & 4019 'removed in near future. Please use namelist ' // & 4020 'radiation_parameters instead' 4021 CALL message( 'radiation_parin', 'PA0487', 0, 1, 0, 6, 0 ) 4022 4023 ! 4024 !-- Set flag that indicates that the radiation model is switched on 4025 radiation = .TRUE. 4026 4027 IF ( .NOT. radiation_interactions_on .AND. surface_reflections ) THEN 4028 message_string = 'surface_reflections is allowed only when ' // & 4029 'radiation_interactions_on is set to TRUE' 4030 CALL message( 'radiation_parin', 'PA0293',1, 2, 0, 6, 0 ) 4031 ENDIF 4032 4033 GOTO 14 4034 4035 13 BACKSPACE( 11 ) 4036 READ( 11 , '(A)') line 4037 CALL parin_fail_message( 'radiation_par', line ) 4038 4039 14 CONTINUE 4040 4041 END SUBROUTINE radiation_parin 4042 4043 4044 !------------------------------------------------------------------------------! 4088 4045 ! Description: 4089 4046 ! ------------ 4090 4047 !> Implementation of the RRTMG radiation_scheme 4091 !------------------------------------------------------------------------------ --------------------!4092 SUBROUTINE radiation_rrtmg4048 !------------------------------------------------------------------------------! 4049 SUBROUTINE radiation_rrtmg 4093 4050 4094 4051 #if defined ( __rrtmg ) 4095 USE exchange_horiz_mod, & 4096 ONLY: exchange_horiz 4097 4098 USE indices, & 4099 ONLY: nbgp 4100 4101 USE palm_date_time_mod, & 4102 ONLY: hours_per_day 4103 4104 USE particle_attributes, & 4105 ONLY: grid_particles, & 4106 number_of_particles, & 4107 particles, & 4108 prt_count 4109 4110 IMPLICIT NONE 4111 4112 4113 INTEGER(iwp) :: i, j, k, l, m, n !< loop indices 4114 INTEGER(iwp) :: k_topo_l !< topography top index 4115 INTEGER(iwp) :: k_topo !< topography top index 4116 4117 REAL(wp) :: d_hours_day !< 1 / hours-per-day 4118 REAL(wp) :: nc_rad, & !< number concentration of cloud droplets 4119 s_r2, & !< weighted sum over all droplets with r^2 4120 s_r3 !< weighted sum over all droplets with r^3 4121 4122 REAL(wp), DIMENSION(0:nzt+1) :: pt_av, q_av, ql_av !< 4123 REAL(wp), DIMENSION(0:0) :: zenith !< to provide indexed array 4124 ! 4125 !-- Just dummy arguments 4126 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rrtm_lw_taucld_dum, & !< 4127 rrtm_lw_tauaer_dum, & !< 4128 rrtm_sw_taucld_dum, & !< 4129 rrtm_sw_ssacld_dum, & !< 4130 rrtm_sw_asmcld_dum, & !< 4131 rrtm_sw_fsfcld_dum, & !< 4132 rrtm_sw_tauaer_dum, & !< 4133 rrtm_sw_ssaaer_dum, & !< 4134 rrtm_sw_asmaer_dum, & !< 4135 rrtm_sw_ecaer_dum !< 4136 4137 ! 4138 !-- Pre-calculate parameters 4139 d_hours_day = 1.0_wp / REAL( hours_per_day, KIND = wp ) 4140 4141 ! 4142 !-- Calculate current (cosine of) zenith angle and whether the sun is up 4143 CALL get_date_time( time_since_reference_point, day_of_year = day_of_year, & 4144 second_of_day = second_of_day ) 4145 CALL calc_zenith( day_of_year, second_of_day ) 4146 zenith(0) = cos_zenith 4147 ! 4148 !-- Calculate surface albedo. In case average radiation is applied, this is not required. 4052 USE exchange_horiz_mod, & 4053 ONLY: exchange_horiz 4054 4055 USE indices, & 4056 ONLY: nbgp 4057 4058 USE palm_date_time_mod, & 4059 ONLY: hours_per_day 4060 4061 USE particle_attributes, & 4062 ONLY: grid_particles, number_of_particles, particles, prt_count 4063 4064 IMPLICIT NONE 4065 4066 4067 INTEGER(iwp) :: i, j, k, l, m, n !< loop indices 4068 INTEGER(iwp) :: k_topo_l !< topography top index 4069 INTEGER(iwp) :: k_topo !< topography top index 4070 4071 REAL(wp) :: d_hours_day !< 1 / hours-per-day 4072 REAL(wp) :: nc_rad, & !< number concentration of cloud droplets 4073 s_r2, & !< weighted sum over all droplets with r^2 4074 s_r3 !< weighted sum over all droplets with r^3 4075 4076 REAL(wp), DIMENSION(0:nzt+1) :: pt_av, q_av, ql_av 4077 REAL(wp), DIMENSION(0:0) :: zenith !< to provide indexed array 4078 ! 4079 !-- Just dummy arguments 4080 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: rrtm_lw_taucld_dum, & 4081 rrtm_lw_tauaer_dum, & 4082 rrtm_sw_taucld_dum, & 4083 rrtm_sw_ssacld_dum, & 4084 rrtm_sw_asmcld_dum, & 4085 rrtm_sw_fsfcld_dum, & 4086 rrtm_sw_tauaer_dum, & 4087 rrtm_sw_ssaaer_dum, & 4088 rrtm_sw_asmaer_dum, & 4089 rrtm_sw_ecaer_dum 4090 4091 ! 4092 !-- Pre-calculate parameters 4093 d_hours_day = 1.0_wp / REAL( hours_per_day, KIND=wp ) 4094 4095 ! 4096 !-- Calculate current (cosine of) zenith angle and whether the sun is up 4097 CALL get_date_time( time_since_reference_point, & 4098 day_of_year=day_of_year, & 4099 second_of_day=second_of_day ) 4100 CALL calc_zenith( day_of_year, second_of_day ) 4101 zenith(0) = cos_zenith 4102 ! 4103 !-- Calculate surface albedo. In case average radiation is applied, 4104 !-- this is not required. 4149 4105 #if defined( __netcdf ) 4150 IF ( .NOT. constant_albedo ) THEN4151 ! 4152 !-- Horizontally aligned default, natural and urban surfaces4153 CALL calc_albedo( surf_lsm_h)4154 CALL calc_albedo( surf_usm_h)4155 ! 4156 !-- Vertically aligned default, natural and urban surfaces4157 DO l = 0, 34158 CALL calc_albedo( surf_lsm_v(l) )4159 CALL calc_albedo( surf_usm_v(l) )4160 ENDDO4161 ENDIF4106 IF ( .NOT. constant_albedo ) THEN 4107 ! 4108 !-- Horizontally aligned default, natural and urban surfaces 4109 CALL calc_albedo( surf_lsm_h ) 4110 CALL calc_albedo( surf_usm_h ) 4111 ! 4112 !-- Vertically aligned default, natural and urban surfaces 4113 DO l = 0, 3 4114 CALL calc_albedo( surf_lsm_v(l) ) 4115 CALL calc_albedo( surf_usm_v(l) ) 4116 ENDDO 4117 ENDIF 4162 4118 #endif 4163 4119 4164 4120 ! 4165 !-- Prepare input data for RRTMG 4166 4167 ! 4168 !-- In case of large scale forcing with surface data, calculate new pressure profile. nzt_rad might 4169 !-- be modified by these calls and all required arrays will then be re-allocated 4170 IF ( large_scale_forcing .AND. lsf_surf ) THEN 4171 CALL read_sounding_data 4172 CALL read_trace_gas_data 4173 ENDIF 4174 4175 4176 IF ( average_radiation ) THEN 4177 ! 4178 !-- Determine minimum topography top index. 4179 k_topo_l = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) ) 4121 !-- Prepare input data for RRTMG 4122 4123 ! 4124 !-- In case of large scale forcing with surface data, calculate new pressure 4125 !-- profile. nzt_rad might be modified by these calls and all required arrays 4126 !-- will then be re-allocated 4127 IF ( large_scale_forcing .AND. lsf_surf ) THEN 4128 CALL read_sounding_data 4129 CALL read_trace_gas_data 4130 ENDIF 4131 4132 4133 IF ( average_radiation ) THEN 4134 ! 4135 !-- Determine minimum topography top index. 4136 k_topo_l = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) ) 4180 4137 #if defined( __parallel ) 4181 CALL MPI_ALLREDUCE( k_topo_l, k_topo, 1, MPI_INTEGER, MPI_MIN, comm2d, ierr) 4138 CALL MPI_ALLREDUCE( k_topo_l, k_topo, 1, MPI_INTEGER, MPI_MIN, & 4139 comm2d, ierr) 4182 4140 #else 4183 k_topo = k_topo_l4141 k_topo = k_topo_l 4184 4142 #endif 4185 4143 4186 rrtm_asdir(1) = albedo_urb 4187 rrtm_asdif(1) = albedo_urb 4188 rrtm_aldir(1) = albedo_urb 4189 rrtm_aldif(1) = albedo_urb 4190 4191 rrtm_emis = emissivity_urb 4192 ! 4193 !-- Calculate mean pt profile. 4194 CALL calc_mean_profile( pt, 4 ) 4195 pt_av = hom(:, 1, 4, 0) 4196 4197 IF ( humidity ) THEN 4198 CALL calc_mean_profile( q, 41 ) 4199 q_av = hom(:, 1, 41, 0) 4200 ENDIF 4201 ! 4202 !-- Prepare profiles of temperature and H2O volume mixing ratio 4203 rrtm_tlev(0, k_topo+1) = t_rad_urb 4204 4205 IF ( bulk_cloud_model ) THEN 4206 4207 CALL calc_mean_profile( ql, 54 ) 4208 ! Average ql is now in hom(:, 1, 54, 0) 4209 ql_av = hom(:, 1, 54, 0) 4210 4211 DO k = nzb+1, nzt+1 4212 rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp )**.286_wp + lv_d_cp * ql_av(k) 4213 rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * ( q_av(k) - ql_av(k) ) 4214 ENDDO 4215 ELSE 4216 DO k = nzb+1, nzt+1 4217 rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp )**.286_wp 4218 ENDDO 4144 rrtm_asdir(1) = albedo_urb 4145 rrtm_asdif(1) = albedo_urb 4146 rrtm_aldir(1) = albedo_urb 4147 rrtm_aldif(1) = albedo_urb 4148 4149 rrtm_emis = emissivity_urb 4150 ! 4151 !-- Calculate mean pt profile. 4152 CALL calc_mean_profile( pt, 4 ) 4153 pt_av = hom(:, 1, 4, 0) 4219 4154 4220 4155 IF ( humidity ) THEN 4221 DO k = nzb+1, nzt+1 4222 rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q_av(k) 4156 CALL calc_mean_profile( q, 41 ) 4157 q_av = hom(:, 1, 41, 0) 4158 ENDIF 4159 ! 4160 !-- Prepare profiles of temperature and H2O volume mixing ratio 4161 rrtm_tlev(0,k_topo+1) = t_rad_urb 4162 4163 IF ( bulk_cloud_model ) THEN 4164 4165 CALL calc_mean_profile( ql, 54 ) 4166 ! average ql is now in hom(:, 1, 54, 0) 4167 ql_av = hom(:, 1, 54, 0) 4168 4169 DO k = nzb+1, nzt+1 4170 rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp & 4171 )**.286_wp + lv_d_cp * ql_av(k) 4172 rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q_av(k) - ql_av(k)) 4223 4173 ENDDO 4224 4174 ELSE 4225 rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp 4226 ENDIF 4175 DO k = nzb+1, nzt+1 4176 rrtm_tlay(0,k) = pt_av(k) * ( (hyp(k) ) / 100000._wp & 4177 )**.286_wp 4178 ENDDO 4179 4180 IF ( humidity ) THEN 4181 DO k = nzb+1, nzt+1 4182 rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q_av(k) 4183 ENDDO 4184 ELSE 4185 rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp 4186 ENDIF 4187 ENDIF 4188 4189 ! 4190 !-- Avoid temperature/humidity jumps at the top of the PALM domain by 4191 !-- linear interpolation from nzt+2 to nzt+7. Jumps are induced by 4192 !-- discrepancies between the values in the domain and those above that 4193 !-- are prescribed in RRTMG 4194 DO k = nzt+2, nzt+7 4195 rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) & 4196 + ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) & 4197 / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) & 4198 * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) 4199 4200 rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) & 4201 + ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )& 4202 / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )& 4203 * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) 4204 4205 ENDDO 4206 4207 !-- Linear interpolate to zw grid. Loop reaches one level further up 4208 !-- due to the staggered grid in RRTMG 4209 DO k = k_topo+2, nzt+8 4210 rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - & 4211 rrtm_tlay(0,k-1)) & 4212 / ( rrtm_play(0,k) - rrtm_play(0,k-1) ) & 4213 * ( rrtm_plev(0,k) - rrtm_play(0,k-1) ) 4214 ENDDO 4215 ! 4216 !-- Calculate liquid water path and cloud fraction for each column. 4217 !-- Note that LWP is required in g/m2 instead of kg/kg m. 4218 rrtm_cldfr = 0.0_wp 4219 rrtm_reliq = 0.0_wp 4220 rrtm_cliqwp = 0.0_wp 4221 rrtm_icld = 0 4222 4223 IF ( bulk_cloud_model ) THEN 4224 DO k = nzb+1, nzt+1 4225 rrtm_cliqwp(0,k) = ql_av(k) * 1000._wp * & 4226 (rrtm_plev(0,k) - rrtm_plev(0,k+1)) & 4227 * 100._wp / g 4228 4229 IF ( rrtm_cliqwp(0,k) > 0._wp ) THEN 4230 rrtm_cldfr(0,k) = 1._wp 4231 IF ( rrtm_icld == 0 ) rrtm_icld = 1 4232 4233 ! 4234 !-- Calculate cloud droplet effective radius 4235 rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql_av(k) & 4236 * rho_surface & 4237 / ( 4.0_wp * pi * nc_const * rho_l ) & 4238 )**0.33333333333333_wp & 4239 * EXP( LOG( sigma_gc )**2 ) 4240 ! 4241 !-- Limit effective radius 4242 IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN 4243 rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp) 4244 rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp) 4245 ENDIF 4246 ENDIF 4247 ENDDO 4248 ENDIF 4249 4250 ! 4251 !-- Set surface temperature 4252 rrtm_tsfc = t_rad_urb 4253 4254 IF ( lw_radiation ) THEN 4255 ! 4256 !-- Due to technical reasons, copy optical depth to dummy arguments 4257 !-- which are allocated on the exact size as the rrtmg_lw is called. 4258 !-- As one dimesion is allocated with zero size, compiler complains 4259 !-- that rank of the array does not match that of the 4260 !-- assumed-shaped arguments in the RRTMG library. In order to 4261 !-- avoid this, write to dummy arguments and give pass the entire 4262 !-- dummy array. Seems to be the only existing work-around. 4263 ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) ) 4264 ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) ) 4265 4266 rrtm_lw_taucld_dum = & 4267 rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) 4268 rrtm_lw_tauaer_dum = & 4269 rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) 4270 4271 CALL rrtmg_lw( 1, & 4272 nzt_rad-k_topo, & 4273 rrtm_icld, & 4274 rrtm_idrv, & 4275 rrtm_play(:,k_topo+1:), & 4276 rrtm_plev(:,k_topo+1:), & 4277 rrtm_tlay(:,k_topo+1:), & 4278 rrtm_tlev(:,k_topo+1:), & 4279 rrtm_tsfc, & 4280 rrtm_h2ovmr(:,k_topo+1:), & 4281 rrtm_o3vmr(:,k_topo+1:), & 4282 rrtm_co2vmr(:,k_topo+1:), & 4283 rrtm_ch4vmr(:,k_topo+1:), & 4284 rrtm_n2ovmr(:,k_topo+1:), & 4285 rrtm_o2vmr(:,k_topo+1:), & 4286 rrtm_cfc11vmr(:,k_topo+1:), & 4287 rrtm_cfc12vmr(:,k_topo+1:), & 4288 rrtm_cfc22vmr(:,k_topo+1:), & 4289 rrtm_ccl4vmr(:,k_topo+1:), & 4290 rrtm_emis, & 4291 rrtm_inflglw, & 4292 rrtm_iceflglw, & 4293 rrtm_liqflglw, & 4294 rrtm_cldfr(:,k_topo+1:), & 4295 rrtm_lw_taucld_dum, & 4296 rrtm_cicewp(:,k_topo+1:), & 4297 rrtm_cliqwp(:,k_topo+1:), & 4298 rrtm_reice(:,k_topo+1:), & 4299 rrtm_reliq(:,k_topo+1:), & 4300 rrtm_lw_tauaer_dum, & 4301 rrtm_lwuflx(:,k_topo:), & 4302 rrtm_lwdflx(:,k_topo:), & 4303 rrtm_lwhr(:,k_topo+1:), & 4304 rrtm_lwuflxc(:,k_topo:), & 4305 rrtm_lwdflxc(:,k_topo:), & 4306 rrtm_lwhrc(:,k_topo+1:), & 4307 rrtm_lwuflx_dt(:,k_topo:), & 4308 rrtm_lwuflxc_dt(:,k_topo:) ) 4309 4310 DEALLOCATE ( rrtm_lw_taucld_dum ) 4311 DEALLOCATE ( rrtm_lw_tauaer_dum ) 4312 ! 4313 !-- Save fluxes 4314 DO k = nzb, nzt+1 4315 rad_lw_in(k,:,:) = rrtm_lwdflx(0,k) 4316 rad_lw_out(k,:,:) = rrtm_lwuflx(0,k) 4317 ENDDO 4318 rad_lw_in_diff(:,:) = rad_lw_in(k_topo,:,:) 4319 ! 4320 !-- Save heating rates (convert from K/d to K/h). 4321 !-- Further, even though an aggregated radiation is computed, map 4322 !-- signle-column profiles on top of any topography, in order to 4323 !-- obtain correct near surface radiation heating/cooling rates. 4324 DO i = nxl, nxr 4325 DO j = nys, nyn 4326 k_topo_l = topo_top_ind(j,i,0) 4327 DO k = k_topo_l+1, nzt+1 4328 rad_lw_hr(k,j,i) = rrtm_lwhr(0,k-k_topo_l) * d_hours_day 4329 rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k-k_topo_l) * d_hours_day 4330 ENDDO 4331 ENDDO 4332 ENDDO 4333 4334 ENDIF 4335 4336 IF ( sw_radiation .AND. sun_up ) THEN 4337 ! 4338 !-- Due to technical reasons, copy optical depths and other 4339 !-- to dummy arguments which are allocated on the exact size as the 4340 !-- rrtmg_sw is called. 4341 !-- As one dimesion is allocated with zero size, compiler complains 4342 !-- that rank of the array does not match that of the 4343 !-- assumed-shaped arguments in the RRTMG library. In order to 4344 !-- avoid this, write to dummy arguments and give pass the entire 4345 !-- dummy array. Seems to be the only existing work-around. 4346 ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 4347 ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 4348 ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 4349 ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 4350 ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) 4351 ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) 4352 ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) 4353 ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) ) 4354 4355 rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 4356 rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 4357 rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 4358 rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 4359 rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) 4360 rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) 4361 rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) 4362 rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1) 4363 4364 CALL rrtmg_sw( 1, & 4365 nzt_rad-k_topo, & 4366 rrtm_icld, & 4367 rrtm_iaer, & 4368 rrtm_play(:,k_topo+1:nzt_rad+1), & 4369 rrtm_plev(:,k_topo+1:nzt_rad+2), & 4370 rrtm_tlay(:,k_topo+1:nzt_rad+1), & 4371 rrtm_tlev(:,k_topo+1:nzt_rad+2), & 4372 rrtm_tsfc, & 4373 rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), & 4374 rrtm_o3vmr(:,k_topo+1:nzt_rad+1), & 4375 rrtm_co2vmr(:,k_topo+1:nzt_rad+1), & 4376 rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), & 4377 rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), & 4378 rrtm_o2vmr(:,k_topo+1:nzt_rad+1), & 4379 rrtm_asdir, & 4380 rrtm_asdif, & 4381 rrtm_aldir, & 4382 rrtm_aldif, & 4383 zenith, & 4384 0.0_wp, & 4385 day_of_year, & 4386 solar_constant, & 4387 rrtm_inflgsw, & 4388 rrtm_iceflgsw, & 4389 rrtm_liqflgsw, & 4390 rrtm_cldfr(:,k_topo+1:nzt_rad+1), & 4391 rrtm_sw_taucld_dum, & 4392 rrtm_sw_ssacld_dum, & 4393 rrtm_sw_asmcld_dum, & 4394 rrtm_sw_fsfcld_dum, & 4395 rrtm_cicewp(:,k_topo+1:nzt_rad+1), & 4396 rrtm_cliqwp(:,k_topo+1:nzt_rad+1), & 4397 rrtm_reice(:,k_topo+1:nzt_rad+1), & 4398 rrtm_reliq(:,k_topo+1:nzt_rad+1), & 4399 rrtm_sw_tauaer_dum, & 4400 rrtm_sw_ssaaer_dum, & 4401 rrtm_sw_asmaer_dum, & 4402 rrtm_sw_ecaer_dum, & 4403 rrtm_swuflx(:,k_topo:nzt_rad+1), & 4404 rrtm_swdflx(:,k_topo:nzt_rad+1), & 4405 rrtm_swhr(:,k_topo+1:nzt_rad+1), & 4406 rrtm_swuflxc(:,k_topo:nzt_rad+1), & 4407 rrtm_swdflxc(:,k_topo:nzt_rad+1), & 4408 rrtm_swhrc(:,k_topo+1:nzt_rad+1), & 4409 rrtm_dirdflux(:,k_topo:nzt_rad+1), & 4410 rrtm_difdflux(:,k_topo:nzt_rad+1) ) 4411 4412 DEALLOCATE( rrtm_sw_taucld_dum ) 4413 DEALLOCATE( rrtm_sw_ssacld_dum ) 4414 DEALLOCATE( rrtm_sw_asmcld_dum ) 4415 DEALLOCATE( rrtm_sw_fsfcld_dum ) 4416 DEALLOCATE( rrtm_sw_tauaer_dum ) 4417 DEALLOCATE( rrtm_sw_ssaaer_dum ) 4418 DEALLOCATE( rrtm_sw_asmaer_dum ) 4419 DEALLOCATE( rrtm_sw_ecaer_dum ) 4420 4421 ! 4422 !-- Save radiation fluxes for the entire depth of the model domain 4423 DO k = nzb, nzt+1 4424 rad_sw_in(k,:,:) = rrtm_swdflx(0,k) 4425 rad_sw_out(k,:,:) = rrtm_swuflx(0,k) 4426 ENDDO 4427 !-- Save direct and diffuse SW radiation at the surface (required by RTM) 4428 rad_sw_in_dir(:,:) = rrtm_dirdflux(0,k_topo) 4429 rad_sw_in_diff(:,:) = rrtm_difdflux(0,k_topo) 4430 4431 ! 4432 !-- Save heating rates (convert from K/d to K/s) 4433 DO k = nzb+1, nzt+1 4434 rad_sw_hr(k,:,:) = rrtm_swhr(0,k) * d_hours_day 4435 rad_sw_cs_hr(k,:,:) = rrtm_swhrc(0,k) * d_hours_day 4436 ENDDO 4437 ! 4438 !-- Solar radiation is zero during night 4439 ELSE 4440 rad_sw_in = 0.0_wp 4441 rad_sw_out = 0.0_wp 4442 rad_sw_in_dir(:,:) = 0.0_wp 4443 rad_sw_in_diff(:,:) = 0.0_wp 4444 ENDIF 4445 ! 4446 !-- RRTMG is called for each (j,i) grid point separately, starting at the 4447 !-- highest topography level. Here no RTM is used since average_radiation is false 4448 ELSE 4449 ! 4450 !-- Loop over all grid points 4451 DO i = nxl, nxr 4452 DO j = nys, nyn 4453 4454 ! 4455 !-- Prepare profiles of temperature and H2O volume mixing ratio 4456 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 4457 rrtm_tlev(0,nzb+1) = surf_lsm_h%pt_surface(m) * exner(nzb) 4458 ENDDO 4459 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 4460 rrtm_tlev(0,nzb+1) = surf_usm_h%pt_surface(m) * exner(nzb) 4461 ENDDO 4462 4463 4464 IF ( bulk_cloud_model ) THEN 4465 DO k = nzb+1, nzt+1 4466 rrtm_tlay(0,k) = pt(k,j,i) * exner(k) & 4467 + lv_d_cp * ql(k,j,i) 4468 rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * (q(k,j,i) - ql(k,j,i)) 4469 ENDDO 4470 ELSEIF ( cloud_droplets ) THEN 4471 DO k = nzb+1, nzt+1 4472 rrtm_tlay(0,k) = pt(k,j,i) * exner(k) & 4473 + lv_d_cp * ql(k,j,i) 4474 rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i) 4475 ENDDO 4476 ELSE 4477 DO k = nzb+1, nzt+1 4478 rrtm_tlay(0,k) = pt(k,j,i) * exner(k) 4479 ENDDO 4480 4481 IF ( humidity ) THEN 4482 DO k = nzb+1, nzt+1 4483 rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i) 4484 ENDDO 4485 ELSE 4486 rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp 4487 ENDIF 4488 ENDIF 4489 4490 ! 4491 !-- Avoid temperature/humidity jumps at the top of the LES domain by 4492 !-- linear interpolation from nzt+2 to nzt+7 4493 DO k = nzt+2, nzt+7 4494 rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) & 4495 + ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) & 4496 / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) & 4497 * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) 4498 4499 rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) & 4500 + ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )& 4501 / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) )& 4502 * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) 4503 4504 ENDDO 4505 4506 !-- Linear interpolate to zw grid 4507 DO k = nzb+2, nzt+8 4508 rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) - & 4509 rrtm_tlay(0,k-1)) & 4510 / ( rrtm_play(0,k) - rrtm_play(0,k-1) ) & 4511 * ( rrtm_plev(0,k) - rrtm_play(0,k-1) ) 4512 ENDDO 4513 4514 4515 ! 4516 !-- Calculate liquid water path and cloud fraction for each column. 4517 !-- Note that LWP is required in g/m2 instead of kg/kg m. 4518 rrtm_cldfr = 0.0_wp 4519 rrtm_reliq = 0.0_wp 4520 rrtm_cliqwp = 0.0_wp 4521 rrtm_icld = 0 4522 4523 IF ( bulk_cloud_model .OR. cloud_droplets ) THEN 4524 DO k = nzb+1, nzt+1 4525 rrtm_cliqwp(0,k) = ql(k,j,i) * 1000.0_wp * & 4526 (rrtm_plev(0,k) - rrtm_plev(0,k+1)) & 4527 * 100.0_wp / g 4528 4529 IF ( rrtm_cliqwp(0,k) > 0.0_wp ) THEN 4530 rrtm_cldfr(0,k) = 1.0_wp 4531 IF ( rrtm_icld == 0 ) rrtm_icld = 1 4532 4533 ! 4534 !-- Calculate cloud droplet effective radius 4535 IF ( bulk_cloud_model ) THEN 4536 ! 4537 !-- Calculete effective droplet radius. In case of using 4538 !-- cloud_scheme = 'morrison' and a non reasonable number 4539 !-- of cloud droplets the inital aerosol number 4540 !-- concentration is considered. 4541 IF ( microphysics_morrison ) THEN 4542 IF ( nc(k,j,i) > 1.0E-20_wp ) THEN 4543 nc_rad = nc(k,j,i) 4544 ELSE 4545 nc_rad = na_init 4546 ENDIF 4547 ELSE 4548 nc_rad = nc_const 4549 ENDIF 4550 4551 rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql(k,j,i) & 4552 * rho_surface & 4553 / ( 4.0_wp * pi * nc_rad * rho_l ) & 4554 )**0.33333333333333_wp & 4555 * EXP( LOG( sigma_gc )**2 ) 4556 4557 ELSEIF ( cloud_droplets ) THEN 4558 number_of_particles = prt_count(k,j,i) 4559 4560 IF (number_of_particles <= 0) CYCLE 4561 particles => grid_particles(k,j,i)%particles(1:number_of_particles) 4562 s_r2 = 0.0_wp 4563 s_r3 = 0.0_wp 4564 4565 DO n = 1, number_of_particles 4566 IF ( particles(n)%particle_mask ) THEN 4567 s_r2 = s_r2 + particles(n)%radius**2 * & 4568 particles(n)%weight_factor 4569 s_r3 = s_r3 + particles(n)%radius**3 * & 4570 particles(n)%weight_factor 4571 ENDIF 4572 ENDDO 4573 4574 IF ( s_r2 > 0.0_wp ) rrtm_reliq(0,k) = s_r3 / s_r2 4575 4576 ENDIF 4577 4578 ! 4579 !-- Limit effective radius 4580 IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN 4581 rrtm_reliq(0,k) = MAX(rrtm_reliq(0,k),2.5_wp) 4582 rrtm_reliq(0,k) = MIN(rrtm_reliq(0,k),60.0_wp) 4583 ENDIF 4584 ENDIF 4585 ENDDO 4586 ENDIF 4587 4588 ! 4589 !-- Write surface emissivity and surface temperature at current 4590 !-- surface element on RRTMG-shaped array. 4591 !-- Please note, as RRTMG is a single column model, surface attributes 4592 !-- are only obtained from horizontally aligned surfaces (for 4593 !-- simplicity). Taking surface attributes from horizontal and 4594 !-- vertical walls would lead to multiple solutions. 4595 !-- Moreover, for natural- and urban-type surfaces, several surface 4596 !-- classes can exist at a surface element next to each other. 4597 !-- To obtain bulk parameters, apply a weighted average for these 4598 !-- surfaces. 4599 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 4600 rrtm_emis = surf_lsm_h%frac(m,ind_veg_wall) * & 4601 surf_lsm_h%emissivity(m,ind_veg_wall) + & 4602 surf_lsm_h%frac(m,ind_pav_green) * & 4603 surf_lsm_h%emissivity(m,ind_pav_green) + & 4604 surf_lsm_h%frac(m,ind_wat_win) * & 4605 surf_lsm_h%emissivity(m,ind_wat_win) 4606 rrtm_tsfc = surf_lsm_h%pt_surface(m) * exner(nzb) 4607 ENDDO 4608 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 4609 rrtm_emis = surf_usm_h%frac(m,ind_veg_wall) * & 4610 surf_usm_h%emissivity(m,ind_veg_wall) + & 4611 surf_usm_h%frac(m,ind_pav_green) * & 4612 surf_usm_h%emissivity(m,ind_pav_green) + & 4613 surf_usm_h%frac(m,ind_wat_win) * & 4614 surf_usm_h%emissivity(m,ind_wat_win) 4615 rrtm_tsfc = surf_usm_h%pt_surface(m) * exner(nzb) 4616 ENDDO 4617 ! 4618 !-- Obtain topography top index (lower bound of RRTMG) 4619 k_topo = topo_top_ind(j,i,0) 4620 4621 IF ( lw_radiation ) THEN 4622 ! 4623 !-- Due to technical reasons, copy optical depth to dummy arguments 4624 !-- which are allocated on the exact size as the rrtmg_lw is called. 4625 !-- As one dimesion is allocated with zero size, compiler complains 4626 !-- that rank of the array does not match that of the 4627 !-- assumed-shaped arguments in the RRTMG library. In order to 4628 !-- avoid this, write to dummy arguments and give pass the entire 4629 !-- dummy array. Seems to be the only existing work-around. 4630 ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) ) 4631 ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) ) 4632 4633 rrtm_lw_taucld_dum = & 4634 rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) 4635 rrtm_lw_tauaer_dum = & 4636 rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) 4637 4638 CALL rrtmg_lw( 1, & 4639 nzt_rad-k_topo, & 4640 rrtm_icld, & 4641 rrtm_idrv, & 4642 rrtm_play(:,k_topo+1:nzt_rad+1), & 4643 rrtm_plev(:,k_topo+1:nzt_rad+2), & 4644 rrtm_tlay(:,k_topo+1:nzt_rad+1), & 4645 rrtm_tlev(:,k_topo+1:nzt_rad+2), & 4646 rrtm_tsfc, & 4647 rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), & 4648 rrtm_o3vmr(:,k_topo+1:nzt_rad+1), & 4649 rrtm_co2vmr(:,k_topo+1:nzt_rad+1), & 4650 rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), & 4651 rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), & 4652 rrtm_o2vmr(:,k_topo+1:nzt_rad+1), & 4653 rrtm_cfc11vmr(:,k_topo+1:nzt_rad+1), & 4654 rrtm_cfc12vmr(:,k_topo+1:nzt_rad+1), & 4655 rrtm_cfc22vmr(:,k_topo+1:nzt_rad+1), & 4656 rrtm_ccl4vmr(:,k_topo+1:nzt_rad+1), & 4657 rrtm_emis, & 4658 rrtm_inflglw, & 4659 rrtm_iceflglw, & 4660 rrtm_liqflglw, & 4661 rrtm_cldfr(:,k_topo+1:nzt_rad+1), & 4662 rrtm_lw_taucld_dum, & 4663 rrtm_cicewp(:,k_topo+1:nzt_rad+1), & 4664 rrtm_cliqwp(:,k_topo+1:nzt_rad+1), & 4665 rrtm_reice(:,k_topo+1:nzt_rad+1), & 4666 rrtm_reliq(:,k_topo+1:nzt_rad+1), & 4667 rrtm_lw_tauaer_dum, & 4668 rrtm_lwuflx(:,k_topo:nzt_rad+1), & 4669 rrtm_lwdflx(:,k_topo:nzt_rad+1), & 4670 rrtm_lwhr(:,k_topo+1:nzt_rad+1), & 4671 rrtm_lwuflxc(:,k_topo:nzt_rad+1), & 4672 rrtm_lwdflxc(:,k_topo:nzt_rad+1), & 4673 rrtm_lwhrc(:,k_topo+1:nzt_rad+1), & 4674 rrtm_lwuflx_dt(:,k_topo:nzt_rad+1), & 4675 rrtm_lwuflxc_dt(:,k_topo:nzt_rad+1) ) 4676 4677 DEALLOCATE ( rrtm_lw_taucld_dum ) 4678 DEALLOCATE ( rrtm_lw_tauaer_dum ) 4679 ! 4680 !-- Save fluxes 4681 DO k = k_topo, nzt+1 4682 rad_lw_in(k,j,i) = rrtm_lwdflx(0,k) 4683 rad_lw_out(k,j,i) = rrtm_lwuflx(0,k) 4684 ENDDO 4685 4686 ! 4687 !-- Save heating rates (convert from K/d to K/h) 4688 DO k = k_topo+1, nzt+1 4689 rad_lw_hr(k,j,i) = rrtm_lwhr(0,k-k_topo) * d_hours_day 4690 rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k-k_topo) * d_hours_day 4691 ENDDO 4692 4693 ! 4694 !-- Save surface radiative fluxes and change in LW heating rate 4695 !-- onto respective surface elements 4696 !-- Horizontal surfaces 4697 DO m = surf_lsm_h%start_index(j,i), & 4698 surf_lsm_h%end_index(j,i) 4699 surf_lsm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo) 4700 surf_lsm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo) 4701 surf_lsm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo) 4702 ENDDO 4703 DO m = surf_usm_h%start_index(j,i), & 4704 surf_usm_h%end_index(j,i) 4705 surf_usm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo) 4706 surf_usm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo) 4707 surf_usm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo) 4708 ENDDO 4709 ! 4710 !-- Vertical surfaces. Fluxes are obtain at vertical level of the 4711 !-- respective surface element 4712 DO l = 0, 3 4713 DO m = surf_lsm_v(l)%start_index(j,i), & 4714 surf_lsm_v(l)%end_index(j,i) 4715 k = surf_lsm_v(l)%k(m) 4716 surf_lsm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k) 4717 surf_lsm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k) 4718 surf_lsm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k) 4719 ENDDO 4720 DO m = surf_usm_v(l)%start_index(j,i), & 4721 surf_usm_v(l)%end_index(j,i) 4722 k = surf_usm_v(l)%k(m) 4723 surf_usm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k) 4724 surf_usm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k) 4725 surf_usm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k) 4726 ENDDO 4727 ENDDO 4728 4729 ENDIF 4730 4731 IF ( sw_radiation .AND. sun_up ) THEN 4732 ! 4733 !-- Get albedo for direct/diffusive long/shortwave radiation at 4734 !-- current (y,x)-location from surface variables. 4735 !-- Only obtain it from horizontal surfaces, as RRTMG is a single 4736 !-- column model 4737 !-- (Please note, only one loop will entered, controlled by 4738 !-- start-end index.) 4739 DO m = surf_lsm_h%start_index(j,i), & 4740 surf_lsm_h%end_index(j,i) 4741 rrtm_asdir(1) = SUM( surf_lsm_h%frac(m,:) * & 4742 surf_lsm_h%rrtm_asdir(m,:) ) 4743 rrtm_asdif(1) = SUM( surf_lsm_h%frac(m,:) * & 4744 surf_lsm_h%rrtm_asdif(m,:) ) 4745 rrtm_aldir(1) = SUM( surf_lsm_h%frac(m,:) * & 4746 surf_lsm_h%rrtm_aldir(m,:) ) 4747 rrtm_aldif(1) = SUM( surf_lsm_h%frac(m,:) * & 4748 surf_lsm_h%rrtm_aldif(m,:) ) 4749 ENDDO 4750 DO m = surf_usm_h%start_index(j,i), & 4751 surf_usm_h%end_index(j,i) 4752 rrtm_asdir(1) = SUM( surf_usm_h%frac(m,:) * & 4753 surf_usm_h%rrtm_asdir(m,:) ) 4754 rrtm_asdif(1) = SUM( surf_usm_h%frac(m,:) * & 4755 surf_usm_h%rrtm_asdif(m,:) ) 4756 rrtm_aldir(1) = SUM( surf_usm_h%frac(m,:) * & 4757 surf_usm_h%rrtm_aldir(m,:) ) 4758 rrtm_aldif(1) = SUM( surf_usm_h%frac(m,:) * & 4759 surf_usm_h%rrtm_aldif(m,:) ) 4760 ENDDO 4761 ! 4762 !-- Due to technical reasons, copy optical depths and other 4763 !-- to dummy arguments which are allocated on the exact size as the 4764 !-- rrtmg_sw is called. 4765 !-- As one dimesion is allocated with zero size, compiler complains 4766 !-- that rank of the array does not match that of the 4767 !-- assumed-shaped arguments in the RRTMG library. In order to 4768 !-- avoid this, write to dummy arguments and give pass the entire 4769 !-- dummy array. Seems to be the only existing work-around. 4770 ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 4771 ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 4772 ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 4773 ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 4774 ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) 4775 ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) 4776 ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) 4777 ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) ) 4778 4779 rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 4780 rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 4781 rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 4782 rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 4783 rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) 4784 rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) 4785 rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) 4786 rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1) 4787 4788 CALL rrtmg_sw( 1, & 4789 nzt_rad-k_topo, & 4790 rrtm_icld, & 4791 rrtm_iaer, & 4792 rrtm_play(:,k_topo+1:nzt_rad+1), & 4793 rrtm_plev(:,k_topo+1:nzt_rad+2), & 4794 rrtm_tlay(:,k_topo+1:nzt_rad+1), & 4795 rrtm_tlev(:,k_topo+1:nzt_rad+2), & 4796 rrtm_tsfc, & 4797 rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), & 4798 rrtm_o3vmr(:,k_topo+1:nzt_rad+1), & 4799 rrtm_co2vmr(:,k_topo+1:nzt_rad+1), & 4800 rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), & 4801 rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), & 4802 rrtm_o2vmr(:,k_topo+1:nzt_rad+1), & 4803 rrtm_asdir, & 4804 rrtm_asdif, & 4805 rrtm_aldir, & 4806 rrtm_aldif, & 4807 zenith, & 4808 0.0_wp, & 4809 day_of_year, & 4810 solar_constant, & 4811 rrtm_inflgsw, & 4812 rrtm_iceflgsw, & 4813 rrtm_liqflgsw, & 4814 rrtm_cldfr(:,k_topo+1:nzt_rad+1), & 4815 rrtm_sw_taucld_dum, & 4816 rrtm_sw_ssacld_dum, & 4817 rrtm_sw_asmcld_dum, & 4818 rrtm_sw_fsfcld_dum, & 4819 rrtm_cicewp(:,k_topo+1:nzt_rad+1), & 4820 rrtm_cliqwp(:,k_topo+1:nzt_rad+1), & 4821 rrtm_reice(:,k_topo+1:nzt_rad+1), & 4822 rrtm_reliq(:,k_topo+1:nzt_rad+1), & 4823 rrtm_sw_tauaer_dum, & 4824 rrtm_sw_ssaaer_dum, & 4825 rrtm_sw_asmaer_dum, & 4826 rrtm_sw_ecaer_dum, & 4827 rrtm_swuflx(:,k_topo:nzt_rad+1), & 4828 rrtm_swdflx(:,k_topo:nzt_rad+1), & 4829 rrtm_swhr(:,k_topo+1:nzt_rad+1), & 4830 rrtm_swuflxc(:,k_topo:nzt_rad+1), & 4831 rrtm_swdflxc(:,k_topo:nzt_rad+1), & 4832 rrtm_swhrc(:,k_topo+1:nzt_rad+1), & 4833 rrtm_dirdflux(:,k_topo:nzt_rad+1), & 4834 rrtm_difdflux(:,k_topo:nzt_rad+1) ) 4835 4836 DEALLOCATE( rrtm_sw_taucld_dum ) 4837 DEALLOCATE( rrtm_sw_ssacld_dum ) 4838 DEALLOCATE( rrtm_sw_asmcld_dum ) 4839 DEALLOCATE( rrtm_sw_fsfcld_dum ) 4840 DEALLOCATE( rrtm_sw_tauaer_dum ) 4841 DEALLOCATE( rrtm_sw_ssaaer_dum ) 4842 DEALLOCATE( rrtm_sw_asmaer_dum ) 4843 DEALLOCATE( rrtm_sw_ecaer_dum ) 4844 ! 4845 !-- Save fluxes 4846 DO k = nzb, nzt+1 4847 rad_sw_in(k,j,i) = rrtm_swdflx(0,k) 4848 rad_sw_out(k,j,i) = rrtm_swuflx(0,k) 4849 ENDDO 4850 ! 4851 !-- Save heating rates (convert from K/d to K/s) 4852 DO k = nzb+1, nzt+1 4853 rad_sw_hr(k,j,i) = rrtm_swhr(0,k) * d_hours_day 4854 rad_sw_cs_hr(k,j,i) = rrtm_swhrc(0,k) * d_hours_day 4855 ENDDO 4856 4857 ! 4858 !-- Save surface radiative fluxes onto respective surface elements 4859 !-- Horizontal surfaces 4860 DO m = surf_lsm_h%start_index(j,i), & 4861 surf_lsm_h%end_index(j,i) 4862 surf_lsm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo) 4863 surf_lsm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo) 4864 ENDDO 4865 DO m = surf_usm_h%start_index(j,i), & 4866 surf_usm_h%end_index(j,i) 4867 surf_usm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo) 4868 surf_usm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo) 4869 ENDDO 4870 ! 4871 !-- Vertical surfaces. Fluxes are obtain at respective vertical 4872 !-- level of the surface element 4873 DO l = 0, 3 4874 DO m = surf_lsm_v(l)%start_index(j,i), & 4875 surf_lsm_v(l)%end_index(j,i) 4876 k = surf_lsm_v(l)%k(m) 4877 surf_lsm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k) 4878 surf_lsm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k) 4879 ENDDO 4880 DO m = surf_usm_v(l)%start_index(j,i), & 4881 surf_usm_v(l)%end_index(j,i) 4882 k = surf_usm_v(l)%k(m) 4883 surf_usm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k) 4884 surf_usm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k) 4885 ENDDO 4886 ENDDO 4887 ! 4888 !-- Solar radiation is zero during night 4889 ELSE 4890 rad_sw_in = 0.0_wp 4891 rad_sw_out = 0.0_wp 4892 !-- !!!!!!!! ATTENSION !!!!!!!!!!!!!!! 4893 !-- Surface radiative fluxes should be also set to zero here 4894 !-- Save surface radiative fluxes onto respective surface elements 4895 !-- Horizontal surfaces 4896 DO m = surf_lsm_h%start_index(j,i), & 4897 surf_lsm_h%end_index(j,i) 4898 surf_lsm_h%rad_sw_in(m) = 0.0_wp 4899 surf_lsm_h%rad_sw_out(m) = 0.0_wp 4900 ENDDO 4901 DO m = surf_usm_h%start_index(j,i), & 4902 surf_usm_h%end_index(j,i) 4903 surf_usm_h%rad_sw_in(m) = 0.0_wp 4904 surf_usm_h%rad_sw_out(m) = 0.0_wp 4905 ENDDO 4906 ! 4907 !-- Vertical surfaces. Fluxes are obtain at respective vertical 4908 !-- level of the surface element 4909 DO l = 0, 3 4910 DO m = surf_lsm_v(l)%start_index(j,i), & 4911 surf_lsm_v(l)%end_index(j,i) 4912 k = surf_lsm_v(l)%k(m) 4913 surf_lsm_v(l)%rad_sw_in(m) = 0.0_wp 4914 surf_lsm_v(l)%rad_sw_out(m) = 0.0_wp 4915 ENDDO 4916 DO m = surf_usm_v(l)%start_index(j,i), & 4917 surf_usm_v(l)%end_index(j,i) 4918 k = surf_usm_v(l)%k(m) 4919 surf_usm_v(l)%rad_sw_in(m) = 0.0_wp 4920 surf_usm_v(l)%rad_sw_out(m) = 0.0_wp 4921 ENDDO 4922 ENDDO 4923 ENDIF 4924 4925 ENDDO 4926 ENDDO 4927 4227 4928 ENDIF 4228 4229 ! 4230 !-- Avoid temperature/humidity jumps at the top of the PALM domain by linear interpolation from 4231 !-- nzt+2 to nzt+7. Jumps are induced by discrepancies between the values in the domain and 4232 !-- those above that are prescribed in RRTMG 4233 DO k = nzt+2, nzt+7 4234 rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) + ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) & 4235 / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) & 4236 * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) 4237 4238 rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) + ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) )& 4239 / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) & 4240 * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) 4241 4242 ENDDO 4243 4244 !-- Linear interpolate to zw grid. Loop reaches one level further up due to the staggered grid 4245 !-- in RRTMG 4246 DO k = k_topo+2, nzt+8 4247 rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + ( rrtm_tlay(0,k) - rrtm_tlay(0,k-1) ) & 4248 / ( rrtm_play(0,k) - rrtm_play(0,k-1) ) & 4249 * ( rrtm_plev(0,k) - rrtm_play(0,k-1) ) 4250 ENDDO 4251 ! 4252 !-- Calculate liquid water path and cloud fraction for each column. 4253 !-- Note that LWP is required in g/m2 instead of kg/kg m. 4254 rrtm_cldfr = 0.0_wp 4255 rrtm_reliq = 0.0_wp 4256 rrtm_cliqwp = 0.0_wp 4257 rrtm_icld = 0 4258 4259 IF ( bulk_cloud_model ) THEN 4260 DO k = nzb+1, nzt+1 4261 rrtm_cliqwp(0,k) = ql_av(k) * 1000._wp * ( rrtm_plev(0,k) - rrtm_plev(0,k+1) ) & 4262 * 100._wp / g 4263 4264 IF ( rrtm_cliqwp(0,k) > 0._wp ) THEN 4265 rrtm_cldfr(0,k) = 1._wp 4266 IF ( rrtm_icld == 0 ) rrtm_icld = 1 4267 4268 ! 4269 !-- Calculate cloud droplet effective radius 4270 rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql_av(k) * rho_surface & 4271 / ( 4.0_wp * pi * nc_const * rho_l ) )**0.33333333333333_wp & 4272 * EXP( LOG( sigma_gc )**2 ) 4273 ! 4274 !-- Limit effective radius 4275 IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN 4276 rrtm_reliq(0,k) = MAX( rrtm_reliq(0,k),2.5_wp ) 4277 rrtm_reliq(0,k) = MIN( rrtm_reliq(0,k),60.0_wp ) 4278 ENDIF 4279 ENDIF 4929 ! 4930 !-- Finally, calculate surface net radiation for surface elements. 4931 IF ( .NOT. radiation_interactions ) THEN 4932 !-- First, for horizontal surfaces 4933 DO m = 1, surf_lsm_h%ns 4934 surf_lsm_h%rad_net(m) = surf_lsm_h%rad_sw_in(m) & 4935 - surf_lsm_h%rad_sw_out(m) & 4936 + surf_lsm_h%rad_lw_in(m) & 4937 - surf_lsm_h%rad_lw_out(m) 4938 ENDDO 4939 DO m = 1, surf_usm_h%ns 4940 surf_usm_h%rad_net(m) = surf_usm_h%rad_sw_in(m) & 4941 - surf_usm_h%rad_sw_out(m) & 4942 + surf_usm_h%rad_lw_in(m) & 4943 - surf_usm_h%rad_lw_out(m) 4944 ENDDO 4945 ! 4946 !-- Vertical surfaces. 4947 !-- Todo: weight with azimuth and zenith angle according to their orientation! 4948 DO l = 0, 3 4949 DO m = 1, surf_lsm_v(l)%ns 4950 surf_lsm_v(l)%rad_net(m) = surf_lsm_v(l)%rad_sw_in(m) & 4951 - surf_lsm_v(l)%rad_sw_out(m) & 4952 + surf_lsm_v(l)%rad_lw_in(m) & 4953 - surf_lsm_v(l)%rad_lw_out(m) 4954 ENDDO 4955 DO m = 1, surf_usm_v(l)%ns 4956 surf_usm_v(l)%rad_net(m) = surf_usm_v(l)%rad_sw_in(m) & 4957 - surf_usm_v(l)%rad_sw_out(m) & 4958 + surf_usm_v(l)%rad_lw_in(m) & 4959 - surf_usm_v(l)%rad_lw_out(m) 4960 ENDDO 4280 4961 ENDDO 4281 4962 ENDIF 4282 4963 4283 ! 4284 !-- Set surface temperature 4285 rrtm_tsfc = t_rad_urb 4286 4287 IF ( lw_radiation ) THEN 4288 ! 4289 !-- Due to technical reasons, copy optical depth to dummy arguments which are allocated on the 4290 !-- exact size as the rrtmg_lw is called. As one dimesion is allocated with zero size, 4291 !-- compiler complains that rank of the array does not match that of the assumed-shaped 4292 !-- arguments in the RRTMG library. In order to avoid this, write to dummy arguments and 4293 !-- pass the entire dummy array. Seems to be the only existing work-around. 4294 ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) ) 4295 ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) ) 4296 4297 rrtm_lw_taucld_dum = rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) 4298 rrtm_lw_tauaer_dum = rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) 4299 4300 CALL rrtmg_lw( 1, & 4301 nzt_rad-k_topo, & 4302 rrtm_icld, & 4303 rrtm_idrv, & 4304 rrtm_play(:,k_topo+1:), & 4305 rrtm_plev(:,k_topo+1:), & 4306 rrtm_tlay(:,k_topo+1:), & 4307 rrtm_tlev(:,k_topo+1:), & 4308 rrtm_tsfc, & 4309 rrtm_h2ovmr(:,k_topo+1:), & 4310 rrtm_o3vmr(:,k_topo+1:), & 4311 rrtm_co2vmr(:,k_topo+1:), & 4312 rrtm_ch4vmr(:,k_topo+1:), & 4313 rrtm_n2ovmr(:,k_topo+1:), & 4314 rrtm_o2vmr(:,k_topo+1:), & 4315 rrtm_cfc11vmr(:,k_topo+1:), & 4316 rrtm_cfc12vmr(:,k_topo+1:), & 4317 rrtm_cfc22vmr(:,k_topo+1:), & 4318 rrtm_ccl4vmr(:,k_topo+1:), & 4319 rrtm_emis, & 4320 rrtm_inflglw, & 4321 rrtm_iceflglw, & 4322 rrtm_liqflglw, & 4323 rrtm_cldfr(:,k_topo+1:), & 4324 rrtm_lw_taucld_dum, & 4325 rrtm_cicewp(:,k_topo+1:), & 4326 rrtm_cliqwp(:,k_topo+1:), & 4327 rrtm_reice(:,k_topo+1:), & 4328 rrtm_reliq(:,k_topo+1:), & 4329 rrtm_lw_tauaer_dum, & 4330 rrtm_lwuflx(:,k_topo:), & 4331 rrtm_lwdflx(:,k_topo:), & 4332 rrtm_lwhr(:,k_topo+1:), & 4333 rrtm_lwuflxc(:,k_topo:), & 4334 rrtm_lwdflxc(:,k_topo:), & 4335 rrtm_lwhrc(:,k_topo+1:), & 4336 rrtm_lwuflx_dt(:,k_topo:), & 4337 rrtm_lwuflxc_dt(:,k_topo:) ) 4338 4339 DEALLOCATE ( rrtm_lw_taucld_dum ) 4340 DEALLOCATE ( rrtm_lw_tauaer_dum ) 4341 ! 4342 !-- Save fluxes 4343 DO k = nzb, nzt+1 4344 rad_lw_in(k,:,:) = rrtm_lwdflx(0,k) 4345 rad_lw_out(k,:,:) = rrtm_lwuflx(0,k) 4346 ENDDO 4347 rad_lw_in_diff(:,:) = rad_lw_in(k_topo,:,:) 4348 ! 4349 !-- Save heating rates (convert from K/d to K/h). Further, even though an aggregated radiation 4350 !-- is computed, map single-column profiles on top of any topography, in order to obtain 4351 !-- correct near surface radiation heating/cooling rates. 4352 DO i = nxl, nxr 4353 DO j = nys, nyn 4354 k_topo_l = topo_top_ind(j,i,0) 4355 DO k = k_topo_l+1, nzt+1 4356 rad_lw_hr(k,j,i) = rrtm_lwhr(0,k-k_topo_l) * d_hours_day 4357 rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k-k_topo_l) * d_hours_day 4358 ENDDO 4359 ENDDO 4360 ENDDO 4361 4362 ENDIF 4363 4364 IF ( sw_radiation .AND. sun_up ) THEN 4365 ! 4366 !-- Due to technical reasons, copy optical depths and other to dummy arguments which are 4367 !-- allocated on the exact size as the rrtmg_sw is called. As one dimesion is allocated with 4368 !-- zero size, compiler complains that rank of the array does not match that of the 4369 !-- assumed-shaped arguments in the RRTMG library. In order to avoid this, write to dummy 4370 !-- arguments and pass the entire dummy array. Seems to be the only existing work-around. 4371 ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 4372 ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 4373 ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 4374 ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 4375 ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) 4376 ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) 4377 ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) 4378 ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) ) 4379 4380 rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 4381 rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 4382 rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 4383 rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 4384 rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) 4385 rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) 4386 rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) 4387 rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1) 4388 4389 CALL rrtmg_sw( 1, & 4390 nzt_rad-k_topo, & 4391 rrtm_icld, & 4392 rrtm_iaer, & 4393 rrtm_play(:,k_topo+1:nzt_rad+1), & 4394 rrtm_plev(:,k_topo+1:nzt_rad+2), & 4395 rrtm_tlay(:,k_topo+1:nzt_rad+1), & 4396 rrtm_tlev(:,k_topo+1:nzt_rad+2), & 4397 rrtm_tsfc, & 4398 rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), & 4399 rrtm_o3vmr(:,k_topo+1:nzt_rad+1), & 4400 rrtm_co2vmr(:,k_topo+1:nzt_rad+1), & 4401 rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), & 4402 rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), & 4403 rrtm_o2vmr(:,k_topo+1:nzt_rad+1), & 4404 rrtm_asdir, & 4405 rrtm_asdif, & 4406 rrtm_aldir, & 4407 rrtm_aldif, & 4408 zenith, & 4409 0.0_wp, & 4410 day_of_year, & 4411 solar_constant, & 4412 rrtm_inflgsw, & 4413 rrtm_iceflgsw, & 4414 rrtm_liqflgsw, & 4415 rrtm_cldfr(:,k_topo+1:nzt_rad+1), & 4416 rrtm_sw_taucld_dum, & 4417 rrtm_sw_ssacld_dum, & 4418 rrtm_sw_asmcld_dum, & 4419 rrtm_sw_fsfcld_dum, & 4420 rrtm_cicewp(:,k_topo+1:nzt_rad+1), & 4421 rrtm_cliqwp(:,k_topo+1:nzt_rad+1), & 4422 rrtm_reice(:,k_topo+1:nzt_rad+1), & 4423 rrtm_reliq(:,k_topo+1:nzt_rad+1), & 4424 rrtm_sw_tauaer_dum, & 4425 rrtm_sw_ssaaer_dum, & 4426 rrtm_sw_asmaer_dum, & 4427 rrtm_sw_ecaer_dum, & 4428 rrtm_swuflx(:,k_topo:nzt_rad+1), & 4429 rrtm_swdflx(:,k_topo:nzt_rad+1), & 4430 rrtm_swhr(:,k_topo+1:nzt_rad+1), & 4431 rrtm_swuflxc(:,k_topo:nzt_rad+1), & 4432 rrtm_swdflxc(:,k_topo:nzt_rad+1), & 4433 rrtm_swhrc(:,k_topo+1:nzt_rad+1), & 4434 rrtm_dirdflux(:,k_topo:nzt_rad+1), & 4435 rrtm_difdflux(:,k_topo:nzt_rad+1) ) 4436 4437 DEALLOCATE( rrtm_sw_taucld_dum ) 4438 DEALLOCATE( rrtm_sw_ssacld_dum ) 4439 DEALLOCATE( rrtm_sw_asmcld_dum ) 4440 DEALLOCATE( rrtm_sw_fsfcld_dum ) 4441 DEALLOCATE( rrtm_sw_tauaer_dum ) 4442 DEALLOCATE( rrtm_sw_ssaaer_dum ) 4443 DEALLOCATE( rrtm_sw_asmaer_dum ) 4444 DEALLOCATE( rrtm_sw_ecaer_dum ) 4445 4446 ! 4447 !-- Save radiation fluxes for the entire depth of the model domain 4448 DO k = nzb, nzt+1 4449 rad_sw_in(k,:,:) = rrtm_swdflx(0,k) 4450 rad_sw_out(k,:,:) = rrtm_swuflx(0,k) 4451 ENDDO 4452 !-- Save direct and diffuse SW radiation at the surface (required by RTM) 4453 rad_sw_in_dir(:,:) = rrtm_dirdflux(0,k_topo) 4454 rad_sw_in_diff(:,:) = rrtm_difdflux(0,k_topo) 4455 4456 ! 4457 !-- Save heating rates (convert from K/d to K/s) 4458 DO k = nzb+1, nzt+1 4459 rad_sw_hr(k,:,:) = rrtm_swhr(0,k) * d_hours_day 4460 rad_sw_cs_hr(k,:,:) = rrtm_swhrc(0,k) * d_hours_day 4461 ENDDO 4462 ! 4463 !-- Solar radiation is zero during night 4464 ELSE 4465 rad_sw_in = 0.0_wp 4466 rad_sw_out = 0.0_wp 4467 rad_sw_in_dir(:,:) = 0.0_wp 4468 rad_sw_in_diff(:,:) = 0.0_wp 4469 ENDIF 4470 ! 4471 !-- RRTMG is called for each (j,i) grid point separately, starting at the highest topography level. 4472 !-- Here no RTM is used since average_radiation is false 4473 ELSE 4474 ! 4475 !-- Loop over all grid points 4476 DO i = nxl, nxr 4477 DO j = nys, nyn 4478 4479 ! 4480 !-- Prepare profiles of temperature and H2O volume mixing ratio 4481 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 4482 rrtm_tlev(0,nzb+1) = surf_lsm_h%pt_surface(m) * exner(nzb) 4483 ENDDO 4484 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 4485 rrtm_tlev(0,nzb+1) = surf_usm_h%pt_surface(m) * exner(nzb) 4486 ENDDO 4487 4488 4489 IF ( bulk_cloud_model ) THEN 4490 DO k = nzb+1, nzt+1 4491 rrtm_tlay(0,k) = pt(k,j,i) * exner(k) + lv_d_cp * ql(k,j,i) 4492 rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * ( q(k,j,i) - ql(k,j,i) ) 4493 ENDDO 4494 ELSEIF ( cloud_droplets ) THEN 4495 DO k = nzb+1, nzt+1 4496 rrtm_tlay(0,k) = pt(k,j,i) * exner(k) + lv_d_cp * ql(k,j,i) 4497 rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i) 4498 ENDDO 4499 ELSE 4500 DO k = nzb+1, nzt+1 4501 rrtm_tlay(0,k) = pt(k,j,i) * exner(k) 4502 ENDDO 4503 4504 IF ( humidity ) THEN 4505 DO k = nzb+1, nzt+1 4506 rrtm_h2ovmr(0,k) = mol_mass_air_d_wv * q(k,j,i) 4507 ENDDO 4508 ELSE 4509 rrtm_h2ovmr(0,nzb+1:nzt+1) = 0.0_wp 4510 ENDIF 4511 ENDIF 4512 4513 ! 4514 !-- Avoid temperature/humidity jumps at the top of the LES domain by linear interpolation 4515 !-- from nzt+2 to nzt+7 4516 DO k = nzt+2, nzt+7 4517 rrtm_tlay(0,k) = rrtm_tlay(0,nzt+1) + ( rrtm_tlay(0,nzt+8) - rrtm_tlay(0,nzt+1) ) & 4518 / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) & 4519 * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) 4520 4521 rrtm_h2ovmr(0,k) = rrtm_h2ovmr(0,nzt+1) & 4522 + ( rrtm_h2ovmr(0,nzt+8) - rrtm_h2ovmr(0,nzt+1) ) & 4523 / ( rrtm_play(0,nzt+8) - rrtm_play(0,nzt+1) ) & 4524 * ( rrtm_play(0,k) - rrtm_play(0,nzt+1) ) 4525 4526 ENDDO 4527 4528 !-- Linear interpolate to zw grid 4529 DO k = nzb+2, nzt+8 4530 rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + ( rrtm_tlay(0,k) - rrtm_tlay(0,k-1) ) & 4531 / ( rrtm_play(0,k) - rrtm_play(0,k-1) ) & 4532 * ( rrtm_plev(0,k) - rrtm_play(0,k-1) ) 4533 ENDDO 4534 4535 4536 ! 4537 !-- Calculate liquid water path and cloud fraction for each column. Note that LWP is 4538 !-- required in g/m2 instead of kg/kg m. 4539 rrtm_cldfr = 0.0_wp 4540 rrtm_reliq = 0.0_wp 4541 rrtm_cliqwp = 0.0_wp 4542 rrtm_icld = 0 4543 4544 IF ( bulk_cloud_model .OR. cloud_droplets ) THEN 4545 DO k = nzb+1, nzt+1 4546 rrtm_cliqwp(0,k) = ql(k,j,i) * 1000.0_wp * & 4547 ( rrtm_plev(0,k) - rrtm_plev(0,k+1) ) * 100.0_wp / g 4548 4549 IF ( rrtm_cliqwp(0,k) > 0.0_wp ) THEN 4550 rrtm_cldfr(0,k) = 1.0_wp 4551 IF ( rrtm_icld == 0 ) rrtm_icld = 1 4552 4553 ! 4554 !-- Calculate cloud droplet effective radius 4555 IF ( bulk_cloud_model ) THEN 4556 ! 4557 !-- Calculete effective droplet radius. In case of using cloud_scheme = 4558 !-- 'morrison' and a non reasonable number of cloud droplets the inital aerosol 4559 !-- number concentration is considered. 4560 IF ( microphysics_morrison ) THEN 4561 IF ( nc(k,j,i) > 1.0E-20_wp ) THEN 4562 nc_rad = nc(k,j,i) 4563 ELSE 4564 nc_rad = na_init 4565 ENDIF 4566 ELSE 4567 nc_rad = nc_const 4568 ENDIF 4569 4570 rrtm_reliq(0,k) = 1.0E6_wp * ( 3.0_wp * ql(k,j,i) * rho_surface & 4571 / ( 4.0_wp * pi * nc_rad * rho_l ) & 4572 )**0.33333333333333_wp * EXP( LOG( sigma_gc )**2 ) 4573 4574 ELSEIF ( cloud_droplets ) THEN 4575 number_of_particles = prt_count(k,j,i) 4576 4577 IF ( number_of_particles <= 0 ) CYCLE 4578 particles => grid_particles(k,j,i)%particles(1:number_of_particles) 4579 s_r2 = 0.0_wp 4580 s_r3 = 0.0_wp 4581 4582 DO n = 1, number_of_particles 4583 IF ( particles(n)%particle_mask ) THEN 4584 s_r2 = s_r2 + particles(n)%radius**2 * particles(n)%weight_factor 4585 s_r3 = s_r3 + particles(n)%radius**3 * particles(n)%weight_factor 4586 ENDIF 4587 ENDDO 4588 4589 IF ( s_r2 > 0.0_wp ) rrtm_reliq(0,k) = s_r3 / s_r2 4590 4591 ENDIF 4592 4593 ! 4594 !-- Limit effective radius 4595 IF ( rrtm_reliq(0,k) > 0.0_wp ) THEN 4596 rrtm_reliq(0,k) = MAX( rrtm_reliq(0,k),2.5_wp ) 4597 rrtm_reliq(0,k) = MIN( rrtm_reliq(0,k),60.0_wp ) 4598 ENDIF 4599 ENDIF 4600 ENDDO 4601 ENDIF 4602 4603 ! 4604 !-- Write surface emissivity and surface temperature at current surface element on 4605 !-- RRTMG-shaped array. Please note, as RRTMG is a single column model, surface attributes 4606 !-- are only obtained from horizontally aligned surfaces (for simplicity). Taking surface 4607 !-- attributes from horizontal and vertical walls would lead to multiple solutions. 4608 !-- Moreover, for natural- and urban-type surfaces, several surface classes can exist at a 4609 !-- surface element next to each other. To obtain bulk parameters, apply a weighted average 4610 !-- for these surfaces. 4611 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 4612 rrtm_emis = surf_lsm_h%frac(m,ind_veg_wall) * & 4613 surf_lsm_h%emissivity(m,ind_veg_wall) + & 4614 surf_lsm_h%frac(m,ind_pav_green) * & 4615 surf_lsm_h%emissivity(m,ind_pav_green) + & 4616 surf_lsm_h%frac(m,ind_wat_win) * surf_lsm_h%emissivity(m,ind_wat_win) 4617 rrtm_tsfc = surf_lsm_h%pt_surface(m) * exner(nzb) 4618 ENDDO 4619 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 4620 rrtm_emis = surf_usm_h%frac(m,ind_veg_wall) * & 4621 surf_usm_h%emissivity(m,ind_veg_wall) + & 4622 surf_usm_h%frac(m,ind_pav_green) * & 4623 surf_usm_h%emissivity(m,ind_pav_green) + & 4624 surf_usm_h%frac(m,ind_wat_win) * surf_usm_h%emissivity(m,ind_wat_win) 4625 rrtm_tsfc = surf_usm_h%pt_surface(m) * exner(nzb) 4626 ENDDO 4627 ! 4628 !-- Obtain topography top index (lower bound of RRTMG) 4629 k_topo = topo_top_ind(j,i,0) 4630 4631 IF ( lw_radiation ) THEN 4632 ! 4633 !-- Due to technical reasons, copy optical depth to dummy arguments which are allocated 4634 !-- on the exact size as the rrtmg_lw is called. As one dimesion is allocated with zero 4635 !-- size, compiler complains that rank of the array does not match that of the 4636 !-- assumed-shaped arguments in the RRTMG library. In order to avoid this, write to 4637 !-- dummy arguments and pass the entire dummy array. Seems to be the only existing 4638 !-- work-around. 4639 ALLOCATE( rrtm_lw_taucld_dum(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) ) 4640 ALLOCATE( rrtm_lw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) ) 4641 4642 rrtm_lw_taucld_dum = rrtm_lw_taucld(1:nbndlw+1,0:0,k_topo+1:nzt_rad+1) 4643 rrtm_lw_tauaer_dum = rrtm_lw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndlw+1) 4644 4645 CALL rrtmg_lw( 1, & 4646 nzt_rad-k_topo, & 4647 rrtm_icld, & 4648 rrtm_idrv, & 4649 rrtm_play(:,k_topo+1:nzt_rad+1), & 4650 rrtm_plev(:,k_topo+1:nzt_rad+2), & 4651 rrtm_tlay(:,k_topo+1:nzt_rad+1), & 4652 rrtm_tlev(:,k_topo+1:nzt_rad+2), & 4653 rrtm_tsfc, & 4654 rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), & 4655 rrtm_o3vmr(:,k_topo+1:nzt_rad+1), & 4656 rrtm_co2vmr(:,k_topo+1:nzt_rad+1), & 4657 rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), & 4658 rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), & 4659 rrtm_o2vmr(:,k_topo+1:nzt_rad+1), & 4660 rrtm_cfc11vmr(:,k_topo+1:nzt_rad+1), & 4661 rrtm_cfc12vmr(:,k_topo+1:nzt_rad+1), & 4662 rrtm_cfc22vmr(:,k_topo+1:nzt_rad+1), & 4663 rrtm_ccl4vmr(:,k_topo+1:nzt_rad+1), & 4664 rrtm_emis, & 4665 rrtm_inflglw, & 4666 rrtm_iceflglw, & 4667 rrtm_liqflglw, & 4668 rrtm_cldfr(:,k_topo+1:nzt_rad+1), & 4669 rrtm_lw_taucld_dum, & 4670 rrtm_cicewp(:,k_topo+1:nzt_rad+1), & 4671 rrtm_cliqwp(:,k_topo+1:nzt_rad+1), & 4672 rrtm_reice(:,k_topo+1:nzt_rad+1), & 4673 rrtm_reliq(:,k_topo+1:nzt_rad+1), & 4674 rrtm_lw_tauaer_dum, & 4675 rrtm_lwuflx(:,k_topo:nzt_rad+1), & 4676 rrtm_lwdflx(:,k_topo:nzt_rad+1), & 4677 rrtm_lwhr(:,k_topo+1:nzt_rad+1), & 4678 rrtm_lwuflxc(:,k_topo:nzt_rad+1), & 4679 rrtm_lwdflxc(:,k_topo:nzt_rad+1), & 4680 rrtm_lwhrc(:,k_topo+1:nzt_rad+1), & 4681 rrtm_lwuflx_dt(:,k_topo:nzt_rad+1), & 4682 rrtm_lwuflxc_dt(:,k_topo:nzt_rad+1) ) 4683 4684 DEALLOCATE ( rrtm_lw_taucld_dum ) 4685 DEALLOCATE ( rrtm_lw_tauaer_dum ) 4686 ! 4687 !-- Save fluxes 4688 DO k = k_topo, nzt+1 4689 rad_lw_in(k,j,i) = rrtm_lwdflx(0,k) 4690 rad_lw_out(k,j,i) = rrtm_lwuflx(0,k) 4691 ENDDO 4692 4693 ! 4694 !-- Save heating rates (convert from K/d to K/h) 4695 DO k = k_topo+1, nzt+1 4696 rad_lw_hr(k,j,i) = rrtm_lwhr(0,k-k_topo) * d_hours_day 4697 rad_lw_cs_hr(k,j,i) = rrtm_lwhrc(0,k-k_topo) * d_hours_day 4698 ENDDO 4699 4700 ! 4701 !-- Save surface radiative fluxes and change in LW heating rate onto respective surface 4702 !-- elements 4703 !-- Horizontal surfaces 4704 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 4705 surf_lsm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo) 4706 surf_lsm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo) 4707 surf_lsm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo) 4708 ENDDO 4709 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 4710 surf_usm_h%rad_lw_in(m) = rrtm_lwdflx(0,k_topo) 4711 surf_usm_h%rad_lw_out(m) = rrtm_lwuflx(0,k_topo) 4712 surf_usm_h%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k_topo) 4713 ENDDO 4714 ! 4715 !-- Vertical surfaces. Fluxes are obtain at vertical level of the respective surface 4716 !-- element 4717 DO l = 0, 3 4718 DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) 4719 k = surf_lsm_v(l)%k(m) 4720 surf_lsm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k) 4721 surf_lsm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k) 4722 surf_lsm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k) 4723 ENDDO 4724 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) 4725 k = surf_usm_v(l)%k(m) 4726 surf_usm_v(l)%rad_lw_in(m) = rrtm_lwdflx(0,k) 4727 surf_usm_v(l)%rad_lw_out(m) = rrtm_lwuflx(0,k) 4728 surf_usm_v(l)%rad_lw_out_change_0(m) = rrtm_lwuflx_dt(0,k) 4729 ENDDO 4730 ENDDO 4731 4732 ENDIF 4733 4734 IF ( sw_radiation .AND. sun_up ) THEN 4735 ! 4736 !-- Get albedo for direct/diffusive long/shortwave radiation at current (y,x)-location 4737 !-- from surface variables. Only obtain it from horizontal surfaces, as RRTMG is a 4738 !-- single column model. (Please note, only one loop will entered, controlled by 4739 !-- start-end index.) 4740 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 4741 rrtm_asdir(1) = SUM( surf_lsm_h%frac(m,:) * surf_lsm_h%rrtm_asdir(m,:) ) 4742 rrtm_asdif(1) = SUM( surf_lsm_h%frac(m,:) * surf_lsm_h%rrtm_asdif(m,:) ) 4743 rrtm_aldir(1) = SUM( surf_lsm_h%frac(m,:) * surf_lsm_h%rrtm_aldir(m,:) ) 4744 rrtm_aldif(1) = SUM( surf_lsm_h%frac(m,:) * surf_lsm_h%rrtm_aldif(m,:) ) 4745 ENDDO 4746 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 4747 rrtm_asdir(1) = SUM( surf_usm_h%frac(m,:) * surf_usm_h%rrtm_asdir(m,:) ) 4748 rrtm_asdif(1) = SUM( surf_usm_h%frac(m,:) * surf_usm_h%rrtm_asdif(m,:) ) 4749 rrtm_aldir(1) = SUM( surf_usm_h%frac(m,:) * surf_usm_h%rrtm_aldir(m,:) ) 4750 rrtm_aldif(1) = SUM( surf_usm_h%frac(m,:) * surf_usm_h%rrtm_aldif(m,:) ) 4751 ENDDO 4752 ! 4753 !-- Due to technical reasons, copy optical depths and other to dummy arguments which are 4754 !-- allocated on the exact size as the rrtmg_sw is called. As one dimesion is allocated 4755 !-- with zero size, compiler complains that rank of the array does not match that of the 4756 !-- assumed-shaped arguments in the RRTMG library. In order to avoid this, write to 4757 !-- dummy arguments and pass the entire dummy array. Seems to be the only existing 4758 !-- work-around. 4759 ALLOCATE( rrtm_sw_taucld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 4760 ALLOCATE( rrtm_sw_ssacld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 4761 ALLOCATE( rrtm_sw_asmcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 4762 ALLOCATE( rrtm_sw_fsfcld_dum(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) ) 4763 ALLOCATE( rrtm_sw_tauaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) 4764 ALLOCATE( rrtm_sw_ssaaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) 4765 ALLOCATE( rrtm_sw_asmaer_dum(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) ) 4766 ALLOCATE( rrtm_sw_ecaer_dum(0:0,k_topo+1:nzt_rad+1,1:naerec+1) ) 4767 4768 rrtm_sw_taucld_dum = rrtm_sw_taucld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 4769 rrtm_sw_ssacld_dum = rrtm_sw_ssacld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 4770 rrtm_sw_asmcld_dum = rrtm_sw_asmcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 4771 rrtm_sw_fsfcld_dum = rrtm_sw_fsfcld(1:nbndsw+1,0:0,k_topo+1:nzt_rad+1) 4772 rrtm_sw_tauaer_dum = rrtm_sw_tauaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) 4773 rrtm_sw_ssaaer_dum = rrtm_sw_ssaaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) 4774 rrtm_sw_asmaer_dum = rrtm_sw_asmaer(0:0,k_topo+1:nzt_rad+1,1:nbndsw+1) 4775 rrtm_sw_ecaer_dum = rrtm_sw_ecaer(0:0,k_topo+1:nzt_rad+1,1:naerec+1) 4776 4777 CALL rrtmg_sw( 1, & 4778 nzt_rad-k_topo, & 4779 rrtm_icld, & 4780 rrtm_iaer, & 4781 rrtm_play(:,k_topo+1:nzt_rad+1), & 4782 rrtm_plev(:,k_topo+1:nzt_rad+2), & 4783 rrtm_tlay(:,k_topo+1:nzt_rad+1), & 4784 rrtm_tlev(:,k_topo+1:nzt_rad+2), & 4785 rrtm_tsfc, & 4786 rrtm_h2ovmr(:,k_topo+1:nzt_rad+1), & 4787 rrtm_o3vmr(:,k_topo+1:nzt_rad+1), & 4788 rrtm_co2vmr(:,k_topo+1:nzt_rad+1), & 4789 rrtm_ch4vmr(:,k_topo+1:nzt_rad+1), & 4790 rrtm_n2ovmr(:,k_topo+1:nzt_rad+1), & 4791 rrtm_o2vmr(:,k_topo+1:nzt_rad+1), & 4792 rrtm_asdir, & 4793 rrtm_asdif, & 4794 rrtm_aldir, & 4795 rrtm_aldif, & 4796 zenith, & 4797 0.0_wp, & 4798 day_of_year, & 4799 solar_constant, & 4800 rrtm_inflgsw, & 4801 rrtm_iceflgsw, & 4802 rrtm_liqflgsw, & 4803 rrtm_cldfr(:,k_topo+1:nzt_rad+1), & 4804 rrtm_sw_taucld_dum, & 4805 rrtm_sw_ssacld_dum, & 4806 rrtm_sw_asmcld_dum, & 4807 rrtm_sw_fsfcld_dum, & 4808 rrtm_cicewp(:,k_topo+1:nzt_rad+1), & 4809 rrtm_cliqwp(:,k_topo+1:nzt_rad+1), & 4810 rrtm_reice(:,k_topo+1:nzt_rad+1), & 4811 rrtm_reliq(:,k_topo+1:nzt_rad+1), & 4812 rrtm_sw_tauaer_dum, & 4813 rrtm_sw_ssaaer_dum, & 4814 rrtm_sw_asmaer_dum, & 4815 rrtm_sw_ecaer_dum, & 4816 rrtm_swuflx(:,k_topo:nzt_rad+1), & 4817 rrtm_swdflx(:,k_topo:nzt_rad+1), & 4818 rrtm_swhr(:,k_topo+1:nzt_rad+1), & 4819 rrtm_swuflxc(:,k_topo:nzt_rad+1), & 4820 rrtm_swdflxc(:,k_topo:nzt_rad+1), & 4821 rrtm_swhrc(:,k_topo+1:nzt_rad+1), & 4822 rrtm_dirdflux(:,k_topo:nzt_rad+1), & 4823 rrtm_difdflux(:,k_topo:nzt_rad+1) ) 4824 4825 DEALLOCATE( rrtm_sw_taucld_dum ) 4826 DEALLOCATE( rrtm_sw_ssacld_dum ) 4827 DEALLOCATE( rrtm_sw_asmcld_dum ) 4828 DEALLOCATE( rrtm_sw_fsfcld_dum ) 4829 DEALLOCATE( rrtm_sw_tauaer_dum ) 4830 DEALLOCATE( rrtm_sw_ssaaer_dum ) 4831 DEALLOCATE( rrtm_sw_asmaer_dum ) 4832 DEALLOCATE( rrtm_sw_ecaer_dum ) 4833 ! 4834 !-- Save fluxes 4835 DO k = nzb, nzt+1 4836 rad_sw_in(k,j,i) = rrtm_swdflx(0,k) 4837 rad_sw_out(k,j,i) = rrtm_swuflx(0,k) 4838 ENDDO 4839 ! 4840 !-- Save heating rates (convert from K/d to K/s) 4841 DO k = nzb+1, nzt+1 4842 rad_sw_hr(k,j,i) = rrtm_swhr(0,k) * d_hours_day 4843 rad_sw_cs_hr(k,j,i) = rrtm_swhrc(0,k) * d_hours_day 4844 ENDDO 4845 4846 ! 4847 !-- Save surface radiative fluxes onto respective surface elements 4848 !-- Horizontal surfaces 4849 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 4850 surf_lsm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo) 4851 surf_lsm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo) 4852 ENDDO 4853 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 4854 surf_usm_h%rad_sw_in(m) = rrtm_swdflx(0,k_topo) 4855 surf_usm_h%rad_sw_out(m) = rrtm_swuflx(0,k_topo) 4856 ENDDO 4857 ! 4858 !-- Vertical surfaces. Fluxes are obtain at respective vertical level of the surface 4859 !-- element 4860 DO l = 0, 3 4861 DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) 4862 k = surf_lsm_v(l)%k(m) 4863 surf_lsm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k) 4864 surf_lsm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k) 4865 ENDDO 4866 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) 4867 k = surf_usm_v(l)%k(m) 4868 surf_usm_v(l)%rad_sw_in(m) = rrtm_swdflx(0,k) 4869 surf_usm_v(l)%rad_sw_out(m) = rrtm_swuflx(0,k) 4870 ENDDO 4871 ENDDO 4872 ! 4873 !-- Solar radiation is zero during night 4874 ELSE 4875 rad_sw_in = 0.0_wp 4876 rad_sw_out = 0.0_wp 4877 !-- !!!!!!!! ATTENTION !!!!!!!!!!!!!!! 4878 !-- Surface radiative fluxes should be also set to zero here 4879 !-- Save surface radiative fluxes onto respective surface elements 4880 !-- Horizontal surfaces 4881 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 4882 surf_lsm_h%rad_sw_in(m) = 0.0_wp 4883 surf_lsm_h%rad_sw_out(m) = 0.0_wp 4884 ENDDO 4885 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 4886 surf_usm_h%rad_sw_in(m) = 0.0_wp 4887 surf_usm_h%rad_sw_out(m) = 0.0_wp 4888 ENDDO 4889 ! 4890 !-- Vertical surfaces. Fluxes are obtain at respective vertical level of the surface 4891 !-- element 4892 DO l = 0, 3 4893 DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) 4894 k = surf_lsm_v(l)%k(m) 4895 surf_lsm_v(l)%rad_sw_in(m) = 0.0_wp 4896 surf_lsm_v(l)%rad_sw_out(m) = 0.0_wp 4897 ENDDO 4898 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) 4899 k = surf_usm_v(l)%k(m) 4900 surf_usm_v(l)%rad_sw_in(m) = 0.0_wp 4901 surf_usm_v(l)%rad_sw_out(m) = 0.0_wp 4902 ENDDO 4903 ENDDO 4904 ENDIF 4905 4906 ENDDO 4907 ENDDO 4908 4909 ENDIF 4910 ! 4911 !-- Finally, calculate surface net radiation for surface elements. 4912 IF ( .NOT. radiation_interactions ) THEN 4913 !-- First, for horizontal surfaces 4914 DO m = 1, surf_lsm_h%ns 4915 surf_lsm_h%rad_net(m) = surf_lsm_h%rad_sw_in(m) - surf_lsm_h%rad_sw_out(m) & 4916 + surf_lsm_h%rad_lw_in(m) - surf_lsm_h%rad_lw_out(m) 4917 ENDDO 4918 DO m = 1, surf_usm_h%ns 4919 surf_usm_h%rad_net(m) = surf_usm_h%rad_sw_in(m) - surf_usm_h%rad_sw_out(m) & 4920 + surf_usm_h%rad_lw_in(m) - surf_usm_h%rad_lw_out(m) 4921 ENDDO 4922 ! 4923 !-- Vertical surfaces. 4924 !-- Todo: weight with azimuth and zenith angle according to their orientation! 4925 DO l = 0, 3 4926 DO m = 1, surf_lsm_v(l)%ns 4927 surf_lsm_v(l)%rad_net(m) = surf_lsm_v(l)%rad_sw_in(m) - surf_lsm_v(l)%rad_sw_out(m) & 4928 + surf_lsm_v(l)%rad_lw_in(m) - surf_lsm_v(l)%rad_lw_out(m) 4929 ENDDO 4930 DO m = 1, surf_usm_v(l)%ns 4931 surf_usm_v(l)%rad_net(m) = surf_usm_v(l)%rad_sw_in(m) - surf_usm_v(l)%rad_sw_out(m) & 4932 + surf_usm_v(l)%rad_lw_in(m) - surf_usm_v(l)%rad_lw_out(m) 4933 ENDDO 4934 ENDDO 4935 ENDIF 4936 4937 4938 CALL exchange_horiz( rad_lw_in, nbgp ) 4939 CALL exchange_horiz( rad_lw_out, nbgp ) 4940 CALL exchange_horiz( rad_lw_hr, nbgp ) 4941 CALL exchange_horiz( rad_lw_cs_hr, nbgp ) 4942 4943 CALL exchange_horiz( rad_sw_in, nbgp ) 4944 CALL exchange_horiz( rad_sw_out, nbgp ) 4945 CALL exchange_horiz( rad_sw_hr, nbgp ) 4946 CALL exchange_horiz( rad_sw_cs_hr, nbgp ) 4964 4965 CALL exchange_horiz( rad_lw_in, nbgp ) 4966 CALL exchange_horiz( rad_lw_out, nbgp ) 4967 CALL exchange_horiz( rad_lw_hr, nbgp ) 4968 CALL exchange_horiz( rad_lw_cs_hr, nbgp ) 4969 4970 CALL exchange_horiz( rad_sw_in, nbgp ) 4971 CALL exchange_horiz( rad_sw_out, nbgp ) 4972 CALL exchange_horiz( rad_sw_hr, nbgp ) 4973 CALL exchange_horiz( rad_sw_cs_hr, nbgp ) 4947 4974 4948 4975 #endif 4949 4976 4950 END SUBROUTINE radiation_rrtmg4951 4952 4953 !------------------------------------------------------------------------------ --------------------!4977 END SUBROUTINE radiation_rrtmg 4978 4979 4980 !------------------------------------------------------------------------------! 4954 4981 ! Description: 4955 4982 ! ------------ 4956 4983 !> Calculate the cosine of the zenith angle (variable is called zenith) 4957 !--------------------------------------------------------------------------------------------------! 4958 SUBROUTINE calc_zenith( day_of_year, second_of_day ) 4959 4960 USE palm_date_time_mod, & 4961 ONLY: seconds_per_day 4962 4963 IMPLICIT NONE 4964 4965 INTEGER(iwp), INTENT(IN) :: day_of_year !< day of the year 4966 4967 REAL(wp) :: declination !< solar declination angle 4968 REAL(wp) :: hour_angle !< solar hour angle 4969 4970 REAL(wp), INTENT(IN) :: second_of_day !< current time of the day in UTC 4971 4972 ! 4973 !-- Calculate solar declination and hour angle 4974 declination = ASIN( decl_1 * SIN( decl_2 * REAL( day_of_year, KIND = wp ) - decl_3 ) ) 4975 hour_angle = 2.0_wp * pi * ( second_of_day / seconds_per_day ) + lon - pi 4976 4977 ! 4978 !-- Calculate cosine of solar zenith angle 4979 cos_zenith = SIN( lat ) * SIN( declination ) + COS( lat ) * COS( declination ) & 4980 * COS( hour_angle ) 4981 cos_zenith = MAX( 0.0_wp, cos_zenith ) 4982 4983 ! 4984 !-- Calculate solar directional vector 4985 IF ( sun_direction ) THEN 4986 4987 ! 4988 !-- Direction in longitudes equals sin(solar_azimuth) * sin(zenith) 4989 sun_dir_lon = - SIN( hour_angle ) * COS( declination ) 4990 4991 ! 4992 !-- Direction in latitues equals cos(solar_azimuth) * sin(zenith) 4993 sun_dir_lat = SIN( declination ) * COS( lat ) - COS( hour_angle ) * COS( declination ) & 4994 * SIN( lat ) 4995 ENDIF 4996 4997 ! 4998 !-- Check if the sun is up (otheriwse shortwave calculations can be skipped) 4999 IF ( cos_zenith > 0.0_wp ) THEN 5000 sun_up = .TRUE. 5001 ELSE 5002 sun_up = .FALSE. 5003 END IF 5004 5005 END SUBROUTINE calc_zenith 4984 !------------------------------------------------------------------------------! 4985 SUBROUTINE calc_zenith( day_of_year, second_of_day ) 4986 4987 USE palm_date_time_mod, & 4988 ONLY: seconds_per_day 4989 4990 IMPLICIT NONE 4991 4992 INTEGER(iwp), INTENT(IN) :: day_of_year !< day of the year 4993 4994 REAL(wp) :: declination !< solar declination angle 4995 REAL(wp) :: hour_angle !< solar hour angle 4996 REAL(wp), INTENT(IN) :: second_of_day !< current time of the day in UTC 4997 4998 ! 4999 !-- Calculate solar declination and hour angle 5000 declination = ASIN( decl_1 * SIN(decl_2 * REAL(day_of_year, KIND=wp) - decl_3) ) 5001 hour_angle = 2.0_wp * pi * ( second_of_day / seconds_per_day ) + lon - pi 5002 5003 ! 5004 !-- Calculate cosine of solar zenith angle 5005 cos_zenith = SIN(lat) * SIN(declination) + COS(lat) * COS(declination) & 5006 * COS(hour_angle) 5007 cos_zenith = MAX(0.0_wp,cos_zenith) 5008 5009 ! 5010 !-- Calculate solar directional vector 5011 IF ( sun_direction ) THEN 5012 5013 ! 5014 !-- Direction in longitudes equals to sin(solar_azimuth) * sin(zenith) 5015 sun_dir_lon = -SIN(hour_angle) * COS(declination) 5016 5017 ! 5018 !-- Direction in latitues equals to cos(solar_azimuth) * sin(zenith) 5019 sun_dir_lat = SIN(declination) * COS(lat) - COS(hour_angle) & 5020 * COS(declination) * SIN(lat) 5021 ENDIF 5022 5023 ! 5024 !-- Check if the sun is up (otheriwse shortwave calculations can be skipped) 5025 IF ( cos_zenith > 0.0_wp ) THEN 5026 sun_up = .TRUE. 5027 ELSE 5028 sun_up = .FALSE. 5029 END IF 5030 5031 END SUBROUTINE calc_zenith 5006 5032 5007 5033 #if defined ( __rrtmg ) && defined ( __netcdf ) 5008 !------------------------------------------------------------------------------ --------------------!5034 !------------------------------------------------------------------------------! 5009 5035 ! Description: 5010 5036 ! ------------ 5011 !> Calculates surface albedo components based on Briegleb (1992) and Briegleb et al. (1986) 5012 !--------------------------------------------------------------------------------------------------! 5013 SUBROUTINE calc_albedo( surf ) 5014 5015 IMPLICIT NONE 5016 5017 INTEGER(iwp) :: ind_type !< running index surface tiles 5018 INTEGER(iwp) :: m !< running index surface elements 5019 5020 TYPE(surf_type) :: surf !< treated surfaces 5021 5022 IF ( sun_up .AND. .NOT. average_radiation ) THEN 5023 5024 DO m = 1, surf%ns 5025 ! 5026 !-- Loop over surface elements 5027 DO ind_type = 0, SIZE( surf%albedo_type, 2 ) - 1 5028 5029 ! 5030 !-- Ocean 5031 IF ( surf%albedo_type(m,ind_type) == 1 ) THEN 5032 surf%rrtm_aldir(m,ind_type) = 0.026_wp / ( cos_zenith**1.7_wp + 0.065_wp ) & 5033 + 0.15_wp * ( cos_zenith - 0.1_wp ) & 5034 * ( cos_zenith - 0.5_wp ) * ( cos_zenith - 1.0_wp ) 5035 surf%rrtm_asdir(m,ind_type) = surf%rrtm_aldir(m,ind_type) 5036 ! 5037 !-- Snow 5038 ELSEIF ( surf%albedo_type(m,ind_type) == 16 ) THEN 5039 IF ( cos_zenith < 0.5_wp ) THEN 5040 surf%rrtm_aldir(m,ind_type) = 0.5_wp * ( 1.0_wp - surf%aldif(im,ind_type) ) & 5041 * ( ( 3.0_wp / ( 1.0_wp + 4.0_wp * cos_zenith ) ) & 5042 - 1.0_wp ) 5043 surf%rrtm_asdir(m,ind_type) = 0.5_wp * ( 1.0_wp - surf%asdif(m,ind_type) ) & 5044 * ( ( 3.0_wp / ( 1.0_wp + 4.0_wp * cos_zenith ) ) & 5045 - 1.0_wp ) 5046 5047 surf%rrtm_aldir(m,ind_type) = MIN( 0.98_wp, surf%rrtm_aldir(m,ind_type) ) 5048 surf%rrtm_asdir(m,ind_type) = MIN( 0.98_wp, surf%rrtm_asdir(m,ind_type) ) 5049 ELSE 5037 !> Calculates surface albedo components based on Briegleb (1992) and 5038 !> Briegleb et al. (1986) 5039 !------------------------------------------------------------------------------! 5040 SUBROUTINE calc_albedo( surf ) 5041 5042 IMPLICIT NONE 5043 5044 INTEGER(iwp) :: ind_type !< running index surface tiles 5045 INTEGER(iwp) :: m !< running index surface elements 5046 5047 TYPE(surf_type) :: surf !< treated surfaces 5048 5049 IF ( sun_up .AND. .NOT. average_radiation ) THEN 5050 5051 DO m = 1, surf%ns 5052 ! 5053 !-- Loop over surface elements 5054 DO ind_type = 0, SIZE( surf%albedo_type, 2 ) - 1 5055 5056 ! 5057 !-- Ocean 5058 IF ( surf%albedo_type(m,ind_type) == 1 ) THEN 5059 surf%rrtm_aldir(m,ind_type) = 0.026_wp / & 5060 ( cos_zenith**1.7_wp + 0.065_wp )& 5061 + 0.15_wp * ( cos_zenith - 0.1_wp ) & 5062 * ( cos_zenith - 0.5_wp ) & 5063 * ( cos_zenith - 1.0_wp ) 5064 surf%rrtm_asdir(m,ind_type) = surf%rrtm_aldir(m,ind_type) 5065 ! 5066 !-- Snow 5067 ELSEIF ( surf%albedo_type(m,ind_type) == 16 ) THEN 5068 IF ( cos_zenith < 0.5_wp ) THEN 5069 surf%rrtm_aldir(m,ind_type) = & 5070 0.5_wp * ( 1.0_wp - surf%aldif(im,ind_type) ) & 5071 * ( ( 3.0_wp / ( 1.0_wp + 4.0_wp & 5072 * cos_zenith ) ) - 1.0_wp ) 5073 surf%rrtm_asdir(m,ind_type) = & 5074 0.5_wp * ( 1.0_wp - surf%asdif(m,ind_type) ) & 5075 * ( ( 3.0_wp / ( 1.0_wp + 4.0_wp & 5076 * cos_zenith ) ) - 1.0_wp ) 5077 5078 surf%rrtm_aldir(m,ind_type) = & 5079 MIN(0.98_wp, surf%rrtm_aldir(m,ind_type)) 5080 surf%rrtm_asdir(m,ind_type) = & 5081 MIN(0.98_wp, surf%rrtm_asdir(m,ind_type)) 5082 ELSE 5083 surf%rrtm_aldir(m,ind_type) = surf%aldif(m,ind_type) 5084 surf%rrtm_asdir(m,ind_type) = surf%asdif(m,ind_type) 5085 ENDIF 5086 ! 5087 !-- Sea ice 5088 ELSEIF ( surf%albedo_type(m,ind_type) == 15 ) THEN 5050 5089 surf%rrtm_aldir(m,ind_type) = surf%aldif(m,ind_type) 5051 5090 surf%rrtm_asdir(m,ind_type) = surf%asdif(m,ind_type) 5091 5092 ! 5093 !-- Asphalt 5094 ELSEIF ( surf%albedo_type(m,ind_type) == 17 ) THEN 5095 surf%rrtm_aldir(m,ind_type) = surf%aldif(m,ind_type) 5096 surf%rrtm_asdir(m,ind_type) = surf%asdif(m,ind_type) 5097 5098 5099 ! 5100 !-- Bare soil 5101 ELSEIF ( surf%albedo_type(m,ind_type) == 18 ) THEN 5102 surf%rrtm_aldir(m,ind_type) = surf%aldif(m,ind_type) 5103 surf%rrtm_asdir(m,ind_type) = surf%asdif(m,ind_type) 5104 5105 ! 5106 !-- Land surfaces 5107 ELSE 5108 SELECT CASE ( surf%albedo_type(m,ind_type) ) 5109 5110 ! 5111 !-- Surface types with strong zenith dependence 5112 CASE ( 1, 2, 3, 4, 11, 12, 13 ) 5113 surf%rrtm_aldir(m,ind_type) = & 5114 surf%aldif(m,ind_type) * 1.4_wp / & 5115 ( 1.0_wp + 0.8_wp * cos_zenith ) 5116 surf%rrtm_asdir(m,ind_type) = & 5117 surf%asdif(m,ind_type) * 1.4_wp / & 5118 ( 1.0_wp + 0.8_wp * cos_zenith ) 5119 ! 5120 !-- Surface types with weak zenith dependence 5121 CASE ( 5, 6, 7, 8, 9, 10, 14 ) 5122 surf%rrtm_aldir(m,ind_type) = & 5123 surf%aldif(m,ind_type) * 1.1_wp / & 5124 ( 1.0_wp + 0.2_wp * cos_zenith ) 5125 surf%rrtm_asdir(m,ind_type) = & 5126 surf%asdif(m,ind_type) * 1.1_wp / & 5127 ( 1.0_wp + 0.2_wp * cos_zenith ) 5128 5129 CASE DEFAULT 5130 5131 END SELECT 5052 5132 ENDIF 5053 5133 ! 5054 !-- Sea ice 5055 ELSEIF ( surf%albedo_type(m,ind_type) == 15 ) THEN 5056 surf%rrtm_aldir(m,ind_type) = surf%aldif(m,ind_type) 5057 surf%rrtm_asdir(m,ind_type) = surf%asdif(m,ind_type) 5058 5059 ! 5060 !-- Asphalt 5061 ELSEIF ( surf%albedo_type(m,ind_type) == 17 ) THEN 5062 surf%rrtm_aldir(m,ind_type) = surf%aldif(m,ind_type) 5063 surf%rrtm_asdir(m,ind_type) = surf%asdif(m,ind_type) 5064 5065 5066 ! 5067 !-- Bare soil 5068 ELSEIF ( surf%albedo_type(m,ind_type) == 18 ) THEN 5069 surf%rrtm_aldir(m,ind_type) = surf%aldif(m,ind_type) 5070 surf%rrtm_asdir(m,ind_type) = surf%asdif(m,ind_type) 5071 5072 ! 5073 !-- Land surfaces 5074 ELSE 5075 SELECT CASE ( surf%albedo_type(m,ind_type) ) 5076 5077 ! 5078 !-- Surface types with strong zenith dependence 5079 CASE ( 1, 2, 3, 4, 11, 12, 13 ) 5080 surf%rrtm_aldir(m,ind_type) = surf%aldif(m,ind_type) * 1.4_wp / & 5081 ( 1.0_wp + 0.8_wp * cos_zenith ) 5082 surf%rrtm_asdir(m,ind_type) = surf%asdif(m,ind_type) * 1.4_wp / & 5083 ( 1.0_wp + 0.8_wp * cos_zenith ) 5084 ! 5085 !-- Surface types with weak zenith dependence 5086 CASE ( 5, 6, 7, 8, 9, 10, 14 ) 5087 surf%rrtm_aldir(m,ind_type) = surf%aldif(m,ind_type) * 1.1_wp / & 5088 ( 1.0_wp + 0.2_wp * cos_zenith ) 5089 surf%rrtm_asdir(m,ind_type) = surf%asdif(m,ind_type) * 1.1_wp / & 5090 ( 1.0_wp + 0.2_wp * cos_zenith ) 5091 5092 CASE DEFAULT 5093 5094 END SELECT 5095 ENDIF 5096 ! 5097 !-- Diffusive albedo is taken from Table 2 5098 surf%rrtm_aldif(m,ind_type) = surf%aldif(m,ind_type) 5099 surf%rrtm_asdif(m,ind_type) = surf%asdif(m,ind_type) 5134 !-- Diffusive albedo is taken from Table 2 5135 surf%rrtm_aldif(m,ind_type) = surf%aldif(m,ind_type) 5136 surf%rrtm_asdif(m,ind_type) = surf%asdif(m,ind_type) 5137 ENDDO 5100 5138 ENDDO 5101 ENDDO 5102 ! 5103 !-- Set albedo in case of average radiation 5104 ELSEIF ( sun_up .AND. average_radiation ) THEN 5105 surf%rrtm_asdir = albedo_urb 5106 surf%rrtm_asdif = albedo_urb 5107 surf%rrtm_aldir = albedo_urb 5108 surf%rrtm_aldif = albedo_urb 5109 ! 5110 !-- Darkness 5111 ELSE 5112 surf%rrtm_aldir = 0.0_wp 5113 surf%rrtm_asdir = 0.0_wp 5114 surf%rrtm_aldif = 0.0_wp 5115 surf%rrtm_asdif = 0.0_wp 5116 ENDIF 5117 5118 END SUBROUTINE calc_albedo 5119 5120 !--------------------------------------------------------------------------------------------------! 5139 ! 5140 !-- Set albedo in case of average radiation 5141 ELSEIF ( sun_up .AND. average_radiation ) THEN 5142 surf%rrtm_asdir = albedo_urb 5143 surf%rrtm_asdif = albedo_urb 5144 surf%rrtm_aldir = albedo_urb 5145 surf%rrtm_aldif = albedo_urb 5146 ! 5147 !-- Darkness 5148 ELSE 5149 surf%rrtm_aldir = 0.0_wp 5150 surf%rrtm_asdir = 0.0_wp 5151 surf%rrtm_aldif = 0.0_wp 5152 surf%rrtm_asdif = 0.0_wp 5153 ENDIF 5154 5155 END SUBROUTINE calc_albedo 5156 5157 !------------------------------------------------------------------------------! 5121 5158 ! Description: 5122 5159 ! ------------ 5123 5160 !> Read sounding data (pressure and temperature) from RADIATION_DATA. 5124 !--------------------------------------------------------------------------------------------------! 5125 SUBROUTINE read_sounding_data 5126 5127 IMPLICIT NONE 5128 5129 INTEGER(iwp) :: id, & !< NetCDF id of input file 5130 id_dim_zrad, & !< pressure level id in the NetCDF file 5131 id_var, & !< NetCDF variable id 5132 k, & !< loop index 5133 nz_snd, & !< number of vertical levels in the sounding data 5134 nz_snd_start, & !< start vertical index for sounding data to be used 5135 nz_snd_end !< end vertical index for souding data to be used 5136 5137 REAL(wp) :: t_surface !< actual surface temperature 5138 5139 REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd_tmp, & !< temporary hydrostatic pressure profile (sounding) 5140 t_snd_tmp !< temporary temperature profile (sounding) 5141 5142 ! 5143 !-- In case of updates, deallocate arrays first (sufficient to check one array as the others are 5144 !-- automatically allocated). This is required because nzt_rad might change during the update 5145 IF ( ALLOCATED ( hyp_snd ) ) THEN 5146 DEALLOCATE( hyp_snd ) 5147 DEALLOCATE( t_snd ) 5148 DEALLOCATE( rrtm_play ) 5149 DEALLOCATE( rrtm_plev ) 5150 DEALLOCATE( rrtm_tlay ) 5151 DEALLOCATE( rrtm_tlev ) 5152 5153 DEALLOCATE( rrtm_cicewp ) 5154 DEALLOCATE( rrtm_cldfr ) 5155 DEALLOCATE( rrtm_cliqwp ) 5156 DEALLOCATE( rrtm_reice ) 5157 DEALLOCATE( rrtm_reliq ) 5158 DEALLOCATE( rrtm_lw_taucld ) 5159 DEALLOCATE( rrtm_lw_tauaer ) 5160 5161 DEALLOCATE( rrtm_lwdflx ) 5162 DEALLOCATE( rrtm_lwdflxc ) 5163 DEALLOCATE( rrtm_lwuflx ) 5164 DEALLOCATE( rrtm_lwuflxc ) 5165 DEALLOCATE( rrtm_lwuflx_dt ) 5166 DEALLOCATE( rrtm_lwuflxc_dt ) 5167 DEALLOCATE( rrtm_lwhr ) 5168 DEALLOCATE( rrtm_lwhrc ) 5169 5170 DEALLOCATE( rrtm_sw_taucld ) 5171 DEALLOCATE( rrtm_sw_ssacld ) 5172 DEALLOCATE( rrtm_sw_asmcld ) 5173 DEALLOCATE( rrtm_sw_fsfcld ) 5174 DEALLOCATE( rrtm_sw_tauaer ) 5175 DEALLOCATE( rrtm_sw_ssaaer ) 5176 DEALLOCATE( rrtm_sw_asmaer ) 5177 DEALLOCATE( rrtm_sw_ecaer ) 5178 5179 DEALLOCATE( rrtm_swdflx ) 5180 DEALLOCATE( rrtm_swdflxc ) 5181 DEALLOCATE( rrtm_swuflx ) 5182 DEALLOCATE( rrtm_swuflxc ) 5183 DEALLOCATE( rrtm_swhr ) 5184 DEALLOCATE( rrtm_swhrc ) 5185 DEALLOCATE( rrtm_dirdflux ) 5186 DEALLOCATE( rrtm_difdflux ) 5187 5188 ENDIF 5189 5190 ! 5191 !-- Open file for reading 5192 nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id ) 5193 CALL netcdf_handle_error_rad( 'read_sounding_data', 549 ) 5194 5195 ! 5196 !-- Inquire dimension of z axis and save in nz_snd 5197 nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim_zrad ) 5198 nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim_zrad, LEN = nz_snd ) 5199 CALL netcdf_handle_error_rad( 'read_sounding_data', 551 ) 5200 5201 ! 5202 !-- Allocate temporary array for storing pressure data 5203 ALLOCATE( hyp_snd_tmp(1:nz_snd) ) 5204 hyp_snd_tmp = 0.0_wp 5205 5206 5207 !-- Read pressure from file 5208 nc_stat = NF90_INQ_VARID( id, "Pressure", id_var ) 5209 nc_stat = NF90_GET_VAR( id, id_var, hyp_snd_tmp(:), START = (/1/), COUNT = (/nz_snd/) ) 5210 CALL netcdf_handle_error_rad( 'read_sounding_data', 552 ) 5211 5212 ! 5213 !-- Allocate temporary array for storing temperature data 5214 ALLOCATE( t_snd_tmp(1:nz_snd) ) 5215 t_snd_tmp = 0.0_wp 5216 5217 ! 5218 !-- Read temperature from file 5219 nc_stat = NF90_INQ_VARID( id, "ReferenceTemperature", id_var ) 5220 nc_stat = NF90_GET_VAR( id, id_var, t_snd_tmp(:), START = (/1/), COUNT = (/nz_snd/) ) 5221 CALL netcdf_handle_error_rad( 'read_sounding_data', 553 ) 5222 5223 ! 5224 !-- Calculate start of sounding data 5225 nz_snd_start = nz_snd + 1 5226 nz_snd_end = nz_snd + 1 5227 5228 ! 5229 !-- Start filling vertical dimension at 10hPa above the model domain (hyp is in Pa, hyp_snd in hPa). 5230 DO k = 1, nz_snd 5231 IF ( hyp_snd_tmp(k) < ( hyp(nzt+1) - 1000.0_wp) * 0.01_wp ) THEN 5232 nz_snd_start = k 5233 EXIT 5161 !------------------------------------------------------------------------------! 5162 SUBROUTINE read_sounding_data 5163 5164 IMPLICIT NONE 5165 5166 INTEGER(iwp) :: id, & !< NetCDF id of input file 5167 id_dim_zrad, & !< pressure level id in the NetCDF file 5168 id_var, & !< NetCDF variable id 5169 k, & !< loop index 5170 nz_snd, & !< number of vertical levels in the sounding data 5171 nz_snd_start, & !< start vertical index for sounding data to be used 5172 nz_snd_end !< end vertical index for souding data to be used 5173 5174 REAL(wp) :: t_surface !< actual surface temperature 5175 5176 REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp_snd_tmp, & !< temporary hydrostatic pressure profile (sounding) 5177 t_snd_tmp !< temporary temperature profile (sounding) 5178 5179 ! 5180 !-- In case of updates, deallocate arrays first (sufficient to check one 5181 !-- array as the others are automatically allocated). This is required 5182 !-- because nzt_rad might change during the update 5183 IF ( ALLOCATED ( hyp_snd ) ) THEN 5184 DEALLOCATE( hyp_snd ) 5185 DEALLOCATE( t_snd ) 5186 DEALLOCATE ( rrtm_play ) 5187 DEALLOCATE ( rrtm_plev ) 5188 DEALLOCATE ( rrtm_tlay ) 5189 DEALLOCATE ( rrtm_tlev ) 5190 5191 DEALLOCATE ( rrtm_cicewp ) 5192 DEALLOCATE ( rrtm_cldfr ) 5193 DEALLOCATE ( rrtm_cliqwp ) 5194 DEALLOCATE ( rrtm_reice ) 5195 DEALLOCATE ( rrtm_reliq ) 5196 DEALLOCATE ( rrtm_lw_taucld ) 5197 DEALLOCATE ( rrtm_lw_tauaer ) 5198 5199 DEALLOCATE ( rrtm_lwdflx ) 5200 DEALLOCATE ( rrtm_lwdflxc ) 5201 DEALLOCATE ( rrtm_lwuflx ) 5202 DEALLOCATE ( rrtm_lwuflxc ) 5203 DEALLOCATE ( rrtm_lwuflx_dt ) 5204 DEALLOCATE ( rrtm_lwuflxc_dt ) 5205 DEALLOCATE ( rrtm_lwhr ) 5206 DEALLOCATE ( rrtm_lwhrc ) 5207 5208 DEALLOCATE ( rrtm_sw_taucld ) 5209 DEALLOCATE ( rrtm_sw_ssacld ) 5210 DEALLOCATE ( rrtm_sw_asmcld ) 5211 DEALLOCATE ( rrtm_sw_fsfcld ) 5212 DEALLOCATE ( rrtm_sw_tauaer ) 5213 DEALLOCATE ( rrtm_sw_ssaaer ) 5214 DEALLOCATE ( rrtm_sw_asmaer ) 5215 DEALLOCATE ( rrtm_sw_ecaer ) 5216 5217 DEALLOCATE ( rrtm_swdflx ) 5218 DEALLOCATE ( rrtm_swdflxc ) 5219 DEALLOCATE ( rrtm_swuflx ) 5220 DEALLOCATE ( rrtm_swuflxc ) 5221 DEALLOCATE ( rrtm_swhr ) 5222 DEALLOCATE ( rrtm_swhrc ) 5223 DEALLOCATE ( rrtm_dirdflux ) 5224 DEALLOCATE ( rrtm_difdflux ) 5225 5226 ENDIF 5227 5228 ! 5229 !-- Open file for reading 5230 nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id ) 5231 CALL netcdf_handle_error_rad( 'read_sounding_data', 549 ) 5232 5233 ! 5234 !-- Inquire dimension of z axis and save in nz_snd 5235 nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim_zrad ) 5236 nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim_zrad, len = nz_snd ) 5237 CALL netcdf_handle_error_rad( 'read_sounding_data', 551 ) 5238 5239 ! 5240 ! !-- Allocate temporary array for storing pressure data 5241 ALLOCATE( hyp_snd_tmp(1:nz_snd) ) 5242 hyp_snd_tmp = 0.0_wp 5243 5244 5245 !-- Read pressure from file 5246 nc_stat = NF90_INQ_VARID( id, "Pressure", id_var ) 5247 nc_stat = NF90_GET_VAR( id, id_var, hyp_snd_tmp(:), start = (/1/), & 5248 count = (/nz_snd/) ) 5249 CALL netcdf_handle_error_rad( 'read_sounding_data', 552 ) 5250 5251 ! 5252 !-- Allocate temporary array for storing temperature data 5253 ALLOCATE( t_snd_tmp(1:nz_snd) ) 5254 t_snd_tmp = 0.0_wp 5255 5256 ! 5257 !-- Read temperature from file 5258 nc_stat = NF90_INQ_VARID( id, "ReferenceTemperature", id_var ) 5259 nc_stat = NF90_GET_VAR( id, id_var, t_snd_tmp(:), start = (/1/), & 5260 count = (/nz_snd/) ) 5261 CALL netcdf_handle_error_rad( 'read_sounding_data', 553 ) 5262 5263 ! 5264 !-- Calculate start of sounding data 5265 nz_snd_start = nz_snd + 1 5266 nz_snd_end = nz_snd + 1 5267 5268 ! 5269 !-- Start filling vertical dimension at 10hPa above the model domain (hyp is 5270 !-- in Pa, hyp_snd in hPa). 5271 DO k = 1, nz_snd 5272 IF ( hyp_snd_tmp(k) < ( hyp(nzt+1) - 1000.0_wp) * 0.01_wp ) THEN 5273 nz_snd_start = k 5274 EXIT 5275 END IF 5276 END DO 5277 5278 IF ( nz_snd_start <= nz_snd ) THEN 5279 nz_snd_end = nz_snd 5234 5280 END IF 5235 END DO 5236 5237 IF ( nz_snd_start <= nz_snd ) THEN 5238 nz_snd_end = nz_snd 5239 END IF 5240 5241 5242 ! 5243 !-- Calculate of total grid points for RRTMG calculations 5244 nzt_rad = nzt + nz_snd_end - nz_snd_start + 1 5245 5246 ! 5247 !-- Save data above LES domain in hyp_snd, t_snd 5248 ALLOCATE( hyp_snd(nzb+1:nzt_rad) ) 5249 ALLOCATE( t_snd(nzb+1:nzt_rad) ) 5250 hyp_snd = 0.0_wp 5251 t_snd = 0.0_wp 5252 5253 hyp_snd(nzt+2:nzt_rad) = hyp_snd_tmp(nz_snd_start+1:nz_snd_end) 5254 t_snd(nzt+2:nzt_rad) = t_snd_tmp(nz_snd_start+1:nz_snd_end) 5255 5256 nc_stat = NF90_CLOSE( id ) 5257 5258 ! 5259 !-- Calculate pressure levels on zu and zw grid. Sounding data is added at top of the LES domain. 5260 !-- This routine does not consider horizontal or vertical variability of pressure and temperature 5261 ALLOCATE( rrtm_play(0:0,nzb+1:nzt_rad+1) ) 5262 ALLOCATE( rrtm_plev(0:0,nzb+1:nzt_rad+2) ) 5263 5264 t_surface = pt_surface * exner(nzb) 5265 DO k = nzb+1, nzt+1 5266 rrtm_play(0,k) = hyp(k) * 0.01_wp 5267 rrtm_plev(0,k) = barometric_formula( zw(k-1), pt_surface * exner(nzb), surface_pressure ) 5268 ENDDO 5269 5270 DO k = nzt+2, nzt_rad 5271 rrtm_play(0,k) = hyp_snd(k) 5272 rrtm_plev(0,k) = 0.5_wp * ( rrtm_play(0,k) + rrtm_play(0,k-1) ) 5273 ENDDO 5274 rrtm_plev(0,nzt_rad+1) = MAX( 0.5 * hyp_snd(nzt_rad), 1.5 * hyp_snd(nzt_rad) - 0.5 & 5275 * hyp_snd(nzt_rad-1) ) 5276 rrtm_plev(0,nzt_rad+2) = MIN( 1.0E-4_wp, 0.25_wp * rrtm_plev(0,nzt_rad+1) ) 5277 5278 rrtm_play(0,nzt_rad+1) = 0.5 * rrtm_plev(0,nzt_rad+1) 5279 5280 ! 5281 !-- Calculate temperature/humidity levels at top of the LES domain. Currently, the temperature is 5282 !-- taken from sounding data (might lead to a temperature jump at interface. To do: Humidity is 5283 !-- currently not calculated above the LES domain. 5284 ALLOCATE( rrtm_tlay(0:0,nzb+1:nzt_rad+1) ) 5285 ALLOCATE( rrtm_tlev(0:0,nzb+1:nzt_rad+2) ) 5286 5287 DO k = nzt+8, nzt_rad 5288 rrtm_tlay(0,k) = t_snd(k) 5289 ENDDO 5290 rrtm_tlay(0,nzt_rad+1) = 2.0_wp * rrtm_tlay(0,nzt_rad) - rrtm_tlay(0,nzt_rad-1) 5291 DO k = nzt+9, nzt_rad+1 5292 rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + ( rrtm_tlay(0,k) - rrtm_tlay(0,k-1) ) & 5293 / ( rrtm_play(0,k) - rrtm_play(0,k-1) ) & 5294 * ( rrtm_plev(0,k) - rrtm_play(0,k-1) ) 5295 ENDDO 5296 5297 rrtm_tlev(0,nzt_rad+2) = 2.0_wp * rrtm_tlay(0,nzt_rad+1) - rrtm_tlev(0,nzt_rad) 5298 ! 5299 !-- Allocate remaining RRTMG arrays 5300 ALLOCATE( rrtm_cicewp(0:0,nzb+1:nzt_rad+1) ) 5301 ALLOCATE( rrtm_cldfr(0:0,nzb+1:nzt_rad+1) ) 5302 ALLOCATE( rrtm_cliqwp(0:0,nzb+1:nzt_rad+1) ) 5303 ALLOCATE( rrtm_reice(0:0,nzb+1:nzt_rad+1) ) 5304 ALLOCATE( rrtm_reliq(0:0,nzb+1:nzt_rad+1) ) 5305 ALLOCATE( rrtm_lw_taucld(1:nbndlw+1,0:0,nzb+1:nzt_rad+1) ) 5306 ALLOCATE( rrtm_lw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndlw+1) ) 5307 ALLOCATE( rrtm_sw_taucld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) ) 5308 ALLOCATE( rrtm_sw_ssacld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) ) 5309 ALLOCATE( rrtm_sw_asmcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) ) 5310 ALLOCATE( rrtm_sw_fsfcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) ) 5311 ALLOCATE( rrtm_sw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) ) 5312 ALLOCATE( rrtm_sw_ssaaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) ) 5313 ALLOCATE( rrtm_sw_asmaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) ) 5314 ALLOCATE( rrtm_sw_ecaer(0:0,nzb+1:nzt_rad+1,1:naerec+1) ) 5315 5316 ! 5317 !-- The ice phase is currently not considered in PALM 5318 rrtm_cicewp = 0.0_wp 5319 rrtm_reice = 0.0_wp 5320 5321 ! 5322 !-- Set other parameters (move to NAMELIST parameters in the future) 5323 rrtm_lw_tauaer = 0.0_wp 5324 rrtm_lw_taucld = 0.0_wp 5325 rrtm_sw_taucld = 0.0_wp 5326 rrtm_sw_ssacld = 0.0_wp 5327 rrtm_sw_asmcld = 0.0_wp 5328 rrtm_sw_fsfcld = 0.0_wp 5329 rrtm_sw_tauaer = 0.0_wp 5330 rrtm_sw_ssaaer = 0.0_wp 5331 rrtm_sw_asmaer = 0.0_wp 5332 rrtm_sw_ecaer = 0.0_wp 5333 5334 5335 ALLOCATE( rrtm_swdflx(0:0,nzb:nzt_rad+1) ) 5336 ALLOCATE( rrtm_swuflx(0:0,nzb:nzt_rad+1) ) 5337 ALLOCATE( rrtm_swhr(0:0,nzb+1:nzt_rad+1) ) 5338 ALLOCATE( rrtm_swuflxc(0:0,nzb:nzt_rad+1) ) 5339 ALLOCATE( rrtm_swdflxc(0:0,nzb:nzt_rad+1) ) 5340 ALLOCATE( rrtm_swhrc(0:0,nzb+1:nzt_rad+1) ) 5341 ALLOCATE( rrtm_dirdflux(0:0,nzb:nzt_rad+1) ) 5342 ALLOCATE( rrtm_difdflux(0:0,nzb:nzt_rad+1) ) 5343 5344 rrtm_swdflx = 0.0_wp 5345 rrtm_swuflx = 0.0_wp 5346 rrtm_swhr = 0.0_wp 5347 rrtm_swuflxc = 0.0_wp 5348 rrtm_swdflxc = 0.0_wp 5349 rrtm_swhrc = 0.0_wp 5350 rrtm_dirdflux = 0.0_wp 5351 rrtm_difdflux = 0.0_wp 5352 5353 ALLOCATE( rrtm_lwdflx(0:0,nzb:nzt_rad+1) ) 5354 ALLOCATE( rrtm_lwuflx(0:0,nzb:nzt_rad+1) ) 5355 ALLOCATE( rrtm_lwhr(0:0,nzb+1:nzt_rad+1) ) 5356 ALLOCATE( rrtm_lwuflxc(0:0,nzb:nzt_rad+1) ) 5357 ALLOCATE( rrtm_lwdflxc(0:0,nzb:nzt_rad+1) ) 5358 ALLOCATE( rrtm_lwhrc(0:0,nzb+1:nzt_rad+1) ) 5359 5360 rrtm_lwdflx = 0.0_wp 5361 rrtm_lwuflx = 0.0_wp 5362 rrtm_lwhr = 0.0_wp 5363 rrtm_lwuflxc = 0.0_wp 5364 rrtm_lwdflxc = 0.0_wp 5365 rrtm_lwhrc = 0.0_wp 5366 5367 ALLOCATE( rrtm_lwuflx_dt(0:0,nzb:nzt_rad+1) ) 5368 ALLOCATE( rrtm_lwuflxc_dt(0:0,nzb:nzt_rad+1) ) 5369 5370 rrtm_lwuflx_dt = 0.0_wp 5371 rrtm_lwuflxc_dt = 0.0_wp 5372 5373 END SUBROUTINE read_sounding_data 5374 5375 5376 !--------------------------------------------------------------------------------------------------! 5281 5282 5283 ! 5284 !-- Calculate of total grid points for RRTMG calculations 5285 nzt_rad = nzt + nz_snd_end - nz_snd_start + 1 5286 5287 ! 5288 !-- Save data above LES domain in hyp_snd, t_snd 5289 ALLOCATE( hyp_snd(nzb+1:nzt_rad) ) 5290 ALLOCATE( t_snd(nzb+1:nzt_rad) ) 5291 hyp_snd = 0.0_wp 5292 t_snd = 0.0_wp 5293 5294 hyp_snd(nzt+2:nzt_rad) = hyp_snd_tmp(nz_snd_start+1:nz_snd_end) 5295 t_snd(nzt+2:nzt_rad) = t_snd_tmp(nz_snd_start+1:nz_snd_end) 5296 5297 nc_stat = NF90_CLOSE( id ) 5298 5299 ! 5300 !-- Calculate pressure levels on zu and zw grid. Sounding data is added at 5301 !-- top of the LES domain. This routine does not consider horizontal or 5302 !-- vertical variability of pressure and temperature 5303 ALLOCATE ( rrtm_play(0:0,nzb+1:nzt_rad+1) ) 5304 ALLOCATE ( rrtm_plev(0:0,nzb+1:nzt_rad+2) ) 5305 5306 t_surface = pt_surface * exner(nzb) 5307 DO k = nzb+1, nzt+1 5308 rrtm_play(0,k) = hyp(k) * 0.01_wp 5309 rrtm_plev(0,k) = barometric_formula(zw(k-1), & 5310 pt_surface * exner(nzb), & 5311 surface_pressure ) 5312 ENDDO 5313 5314 DO k = nzt+2, nzt_rad 5315 rrtm_play(0,k) = hyp_snd(k) 5316 rrtm_plev(0,k) = 0.5_wp * ( rrtm_play(0,k) + rrtm_play(0,k-1) ) 5317 ENDDO 5318 rrtm_plev(0,nzt_rad+1) = MAX( 0.5 * hyp_snd(nzt_rad), & 5319 1.5 * hyp_snd(nzt_rad) & 5320 - 0.5 * hyp_snd(nzt_rad-1) ) 5321 rrtm_plev(0,nzt_rad+2) = MIN( 1.0E-4_wp, & 5322 0.25_wp * rrtm_plev(0,nzt_rad+1) ) 5323 5324 rrtm_play(0,nzt_rad+1) = 0.5 * rrtm_plev(0,nzt_rad+1) 5325 5326 ! 5327 !-- Calculate temperature/humidity levels at top of the LES domain. 5328 !-- Currently, the temperature is taken from sounding data (might lead to a 5329 !-- temperature jump at interface. To do: Humidity is currently not 5330 !-- calculated above the LES domain. 5331 ALLOCATE ( rrtm_tlay(0:0,nzb+1:nzt_rad+1) ) 5332 ALLOCATE ( rrtm_tlev(0:0,nzb+1:nzt_rad+2) ) 5333 5334 DO k = nzt+8, nzt_rad 5335 rrtm_tlay(0,k) = t_snd(k) 5336 ENDDO 5337 rrtm_tlay(0,nzt_rad+1) = 2.0_wp * rrtm_tlay(0,nzt_rad) & 5338 - rrtm_tlay(0,nzt_rad-1) 5339 DO k = nzt+9, nzt_rad+1 5340 rrtm_tlev(0,k) = rrtm_tlay(0,k-1) + (rrtm_tlay(0,k) & 5341 - rrtm_tlay(0,k-1)) & 5342 / ( rrtm_play(0,k) - rrtm_play(0,k-1) ) & 5343 * ( rrtm_plev(0,k) - rrtm_play(0,k-1) ) 5344 ENDDO 5345 5346 rrtm_tlev(0,nzt_rad+2) = 2.0_wp * rrtm_tlay(0,nzt_rad+1) & 5347 - rrtm_tlev(0,nzt_rad) 5348 ! 5349 !-- Allocate remaining RRTMG arrays 5350 ALLOCATE ( rrtm_cicewp(0:0,nzb+1:nzt_rad+1) ) 5351 ALLOCATE ( rrtm_cldfr(0:0,nzb+1:nzt_rad+1) ) 5352 ALLOCATE ( rrtm_cliqwp(0:0,nzb+1:nzt_rad+1) ) 5353 ALLOCATE ( rrtm_reice(0:0,nzb+1:nzt_rad+1) ) 5354 ALLOCATE ( rrtm_reliq(0:0,nzb+1:nzt_rad+1) ) 5355 ALLOCATE ( rrtm_lw_taucld(1:nbndlw+1,0:0,nzb+1:nzt_rad+1) ) 5356 ALLOCATE ( rrtm_lw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndlw+1) ) 5357 ALLOCATE ( rrtm_sw_taucld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) ) 5358 ALLOCATE ( rrtm_sw_ssacld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) ) 5359 ALLOCATE ( rrtm_sw_asmcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) ) 5360 ALLOCATE ( rrtm_sw_fsfcld(1:nbndsw+1,0:0,nzb+1:nzt_rad+1) ) 5361 ALLOCATE ( rrtm_sw_tauaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) ) 5362 ALLOCATE ( rrtm_sw_ssaaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) ) 5363 ALLOCATE ( rrtm_sw_asmaer(0:0,nzb+1:nzt_rad+1,1:nbndsw+1) ) 5364 ALLOCATE ( rrtm_sw_ecaer(0:0,nzb+1:nzt_rad+1,1:naerec+1) ) 5365 5366 ! 5367 !-- The ice phase is currently not considered in PALM 5368 rrtm_cicewp = 0.0_wp 5369 rrtm_reice = 0.0_wp 5370 5371 ! 5372 !-- Set other parameters (move to NAMELIST parameters in the future) 5373 rrtm_lw_tauaer = 0.0_wp 5374 rrtm_lw_taucld = 0.0_wp 5375 rrtm_sw_taucld = 0.0_wp 5376 rrtm_sw_ssacld = 0.0_wp 5377 rrtm_sw_asmcld = 0.0_wp 5378 rrtm_sw_fsfcld = 0.0_wp 5379 rrtm_sw_tauaer = 0.0_wp 5380 rrtm_sw_ssaaer = 0.0_wp 5381 rrtm_sw_asmaer = 0.0_wp 5382 rrtm_sw_ecaer = 0.0_wp 5383 5384 5385 ALLOCATE ( rrtm_swdflx(0:0,nzb:nzt_rad+1) ) 5386 ALLOCATE ( rrtm_swuflx(0:0,nzb:nzt_rad+1) ) 5387 ALLOCATE ( rrtm_swhr(0:0,nzb+1:nzt_rad+1) ) 5388 ALLOCATE ( rrtm_swuflxc(0:0,nzb:nzt_rad+1) ) 5389 ALLOCATE ( rrtm_swdflxc(0:0,nzb:nzt_rad+1) ) 5390 ALLOCATE ( rrtm_swhrc(0:0,nzb+1:nzt_rad+1) ) 5391 ALLOCATE ( rrtm_dirdflux(0:0,nzb:nzt_rad+1) ) 5392 ALLOCATE ( rrtm_difdflux(0:0,nzb:nzt_rad+1) ) 5393 5394 rrtm_swdflx = 0.0_wp 5395 rrtm_swuflx = 0.0_wp 5396 rrtm_swhr = 0.0_wp 5397 rrtm_swuflxc = 0.0_wp 5398 rrtm_swdflxc = 0.0_wp 5399 rrtm_swhrc = 0.0_wp 5400 rrtm_dirdflux = 0.0_wp 5401 rrtm_difdflux = 0.0_wp 5402 5403 ALLOCATE ( rrtm_lwdflx(0:0,nzb:nzt_rad+1) ) 5404 ALLOCATE ( rrtm_lwuflx(0:0,nzb:nzt_rad+1) ) 5405 ALLOCATE ( rrtm_lwhr(0:0,nzb+1:nzt_rad+1) ) 5406 ALLOCATE ( rrtm_lwuflxc(0:0,nzb:nzt_rad+1) ) 5407 ALLOCATE ( rrtm_lwdflxc(0:0,nzb:nzt_rad+1) ) 5408 ALLOCATE ( rrtm_lwhrc(0:0,nzb+1:nzt_rad+1) ) 5409 5410 rrtm_lwdflx = 0.0_wp 5411 rrtm_lwuflx = 0.0_wp 5412 rrtm_lwhr = 0.0_wp 5413 rrtm_lwuflxc = 0.0_wp 5414 rrtm_lwdflxc = 0.0_wp 5415 rrtm_lwhrc = 0.0_wp 5416 5417 ALLOCATE ( rrtm_lwuflx_dt(0:0,nzb:nzt_rad+1) ) 5418 ALLOCATE ( rrtm_lwuflxc_dt(0:0,nzb:nzt_rad+1) ) 5419 5420 rrtm_lwuflx_dt = 0.0_wp 5421 rrtm_lwuflxc_dt = 0.0_wp 5422 5423 END SUBROUTINE read_sounding_data 5424 5425 5426 !------------------------------------------------------------------------------! 5377 5427 ! Description: 5378 5428 ! ------------ 5379 !> Read trace gas data from file and convert into trace gas paths / volume mixing ratios. If a 5380 !> user-defined input file is provided it needs to follow the conventions used in RRTMG (see 5381 !> respective netCDF files shipped with RRTMG) 5382 !--------------------------------------------------------------------------------------------------! 5383 SUBROUTINE read_trace_gas_data 5384 5385 USE rrsw_ncpar 5386 5387 IMPLICIT NONE 5388 5389 INTEGER(iwp), PARAMETER :: num_trace_gases = 10 !< number of trace gases (absorbers) 5390 5391 CHARACTER(LEN=5), DIMENSION(num_trace_gases), PARAMETER :: & !< trace gas names 5392 trace_names = (/'O3 ', 'CO2 ', 'CH4 ', 'N2O ', 'O2 ', & 5393 'CFC11', 'CFC12', 'CFC22', 'CCL4 ', 'H2O '/) 5394 5395 INTEGER(iwp) :: id, & !< NetCDF id 5396 k, & !< loop index 5397 m, & !< loop index 5398 n, & !< loop index 5399 nabs, & !< number of absorbers 5400 np, & !< number of pressure levels 5401 id_abs, & !< NetCDF id of the respective absorber 5402 id_dim, & !< NetCDF id of asborber's dimension 5403 id_var !< NetCDf id ot the absorber 5404 5405 REAL(wp) :: p_mls_l, & !< pressure lower limit for interpolation 5406 p_mls_u, & !< pressure upper limit for interpolation 5407 p_wgt_l, & !< pressure weight lower limit for interpolation 5408 p_wgt_u, & !< pressure weight upper limit for interpolation 5409 p_mls_m !< mean pressure between upper and lower limits 5410 5411 5412 REAL(wp), DIMENSION(:), ALLOCATABLE :: p_mls, & !< pressure levels for the absorbers 5413 rrtm_play_tmp, & !< temporary array for pressure zu-levels 5414 rrtm_plev_tmp, & !< temporary array for pressure zw-levels 5415 trace_path_tmp !< temporary array for storing trace gas path data 5416 5417 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: trace_mls, & !< array for storing the absorber amounts 5418 trace_mls_path, & !< array for storing trace gas path data 5419 trace_mls_tmp !< temporary array for storing trace gas data 5420 5421 5422 ! 5423 !-- In case of updates, deallocate arrays first (sufficient to check one array as the others are 5424 !-- automatically allocated) 5425 IF ( ALLOCATED ( rrtm_o3vmr ) ) THEN 5426 DEALLOCATE( rrtm_o3vmr ) 5427 DEALLOCATE( rrtm_co2vmr ) 5428 DEALLOCATE( rrtm_ch4vmr ) 5429 DEALLOCATE( rrtm_n2ovmr ) 5430 DEALLOCATE( rrtm_o2vmr ) 5431 DEALLOCATE( rrtm_cfc11vmr ) 5432 DEALLOCATE( rrtm_cfc12vmr ) 5433 DEALLOCATE( rrtm_cfc22vmr ) 5434 DEALLOCATE( rrtm_ccl4vmr ) 5435 DEALLOCATE( rrtm_h2ovmr ) 5436 ENDIF 5437 5438 ! 5439 !-- Allocate trace gas profiles 5440 ALLOCATE( rrtm_o3vmr(0:0,1:nzt_rad+1) ) 5441 ALLOCATE( rrtm_co2vmr(0:0,1:nzt_rad+1) ) 5442 ALLOCATE( rrtm_ch4vmr(0:0,1:nzt_rad+1) ) 5443 ALLOCATE( rrtm_n2ovmr(0:0,1:nzt_rad+1) ) 5444 ALLOCATE( rrtm_o2vmr(0:0,1:nzt_rad+1) ) 5445 ALLOCATE( rrtm_cfc11vmr(0:0,1:nzt_rad+1) ) 5446 ALLOCATE( rrtm_cfc12vmr(0:0,1:nzt_rad+1) ) 5447 ALLOCATE( rrtm_cfc22vmr(0:0,1:nzt_rad+1) ) 5448 ALLOCATE( rrtm_ccl4vmr(0:0,1:nzt_rad+1) ) 5449 ALLOCATE( rrtm_h2ovmr(0:0,1:nzt_rad+1) ) 5450 5451 ! 5452 !-- Open file for reading 5453 nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id ) 5454 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 549 ) 5455 ! 5456 !-- Inquire dimension ids and dimensions 5457 nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim ) 5458 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) 5459 nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, LEN = np) 5460 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) 5461 5462 nc_stat = NF90_INQ_DIMID( id, "Absorber", id_dim ) 5463 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) 5464 nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, LEN = nabs ) 5465 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) 5466 5467 5468 ! 5469 !-- Allocate pressure, and trace gas arrays 5470 ALLOCATE( p_mls(1:np) ) 5471 ALLOCATE( trace_mls(1:num_trace_gases,1:np) ) 5472 ALLOCATE( trace_mls_tmp(1:nabs,1:np) ) 5473 5474 5475 nc_stat = NF90_INQ_VARID( id, "Pressure", id_var ) 5476 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) 5477 nc_stat = NF90_GET_VAR( id, id_var, p_mls ) 5478 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) 5479 5480 nc_stat = NF90_INQ_VARID( id, "AbsorberAmountMLS", id_var ) 5481 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) 5482 nc_stat = NF90_GET_VAR( id, id_var, trace_mls_tmp ) 5483 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) 5484 5485 5486 ! 5487 !-- Write absorber amounts (mls) to trace_mls 5488 DO n = 1, num_trace_gases 5489 CALL getAbsorberIndex( TRIM( trace_names(n) ), id_abs ) 5490 5491 trace_mls(n,1:np) = trace_mls_tmp(id_abs,1:np) 5492 5493 ! 5494 !-- Replace missing values by zero 5495 WHERE ( trace_mls(n,:) > 2.0_wp ) 5496 trace_mls(n,:) = 0.0_wp 5497 END WHERE 5498 END DO 5499 5500 DEALLOCATE ( trace_mls_tmp ) 5501 5502 nc_stat = NF90_CLOSE( id ) 5503 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 551 ) 5504 5505 ! 5506 !-- Add extra pressure level for calculations of the trace gas paths 5507 ALLOCATE( rrtm_play_tmp(1:nzt_rad+1) ) 5508 ALLOCATE( rrtm_plev_tmp(1:nzt_rad+2) ) 5509 5510 rrtm_play_tmp(1:nzt_rad) = rrtm_play(0,1:nzt_rad) 5511 rrtm_plev_tmp(1:nzt_rad+1) = rrtm_plev(0,1:nzt_rad+1) 5512 rrtm_play_tmp(nzt_rad+1) = rrtm_plev(0,nzt_rad+1) * 0.5_wp 5513 rrtm_plev_tmp(nzt_rad+2) = MIN( 1.0E-4_wp, 0.25_wp * rrtm_plev(0,nzt_rad+1) ) 5514 5515 ! 5516 !-- Calculate trace gas path (zero at surface) with interpolation to the sounding levels 5517 ALLOCATE( trace_mls_path(1:nzt_rad+2,1:num_trace_gases) ) 5518 5519 trace_mls_path(nzb+1,:) = 0.0_wp 5520 5521 DO k = nzb+2, nzt_rad+2 5522 DO m = 1, num_trace_gases 5523 trace_mls_path(k,m) = trace_mls_path(k-1,m) 5524 5525 ! 5526 !-- When the pressure level is higher than the trace gas pressure level, assume that 5527 IF ( rrtm_plev_tmp(k-1) > p_mls(1) ) THEN 5528 5529 trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,1) * ( rrtm_plev_tmp(k-1) & 5530 - MAX( p_mls(1), rrtm_plev_tmp(k) ) ) / g 5531 ENDIF 5532 5533 ! 5534 !-- Integrate for each sounding level from the contributing p_mls levels 5535 DO n = 2, np 5536 ! 5537 !-- Limit p_mls so that it is within the model level 5538 p_mls_u = MIN( rrtm_plev_tmp(k-1), MAX( rrtm_plev_tmp(k), p_mls(n) ) ) 5539 p_mls_l = MIN( rrtm_plev_tmp(k-1), MAX( rrtm_plev_tmp(k), p_mls(n-1) ) ) 5540 5541 IF ( p_mls_l > p_mls_u ) THEN 5542 5543 ! 5544 !-- Calculate weights for interpolation 5545 p_mls_m = 0.5_wp * ( p_mls_l + p_mls_u) 5546 p_wgt_u = ( p_mls(n-1) - p_mls_m ) / ( p_mls(n-1) - p_mls(n) ) 5547 p_wgt_l = ( p_mls_m - p_mls(n) ) / ( p_mls(n-1) - p_mls(n) ) 5548 5549 ! 5550 !-- Add level to trace gas path 5551 trace_mls_path(k,m) = trace_mls_path(k,m) + ( p_wgt_u * trace_mls(m,n) + p_wgt_l & 5552 * trace_mls(m,n-1) ) * ( p_mls_l - p_mls_u ) / g 5429 !> Read trace gas data from file and convert into trace gas paths / volume 5430 !> mixing ratios. If a user-defined input file is provided it needs to follow 5431 !> the convections used in RRTMG (see respective netCDF files shipped with 5432 !> RRTMG) 5433 !------------------------------------------------------------------------------! 5434 SUBROUTINE read_trace_gas_data 5435 5436 USE rrsw_ncpar 5437 5438 IMPLICIT NONE 5439 5440 INTEGER(iwp), PARAMETER :: num_trace_gases = 10 !< number of trace gases (absorbers) 5441 5442 CHARACTER(LEN=5), DIMENSION(num_trace_gases), PARAMETER :: & !< trace gas names 5443 trace_names = (/'O3 ', 'CO2 ', 'CH4 ', 'N2O ', 'O2 ', & 5444 'CFC11', 'CFC12', 'CFC22', 'CCL4 ', 'H2O '/) 5445 5446 INTEGER(iwp) :: id, & !< NetCDF id 5447 k, & !< loop index 5448 m, & !< loop index 5449 n, & !< loop index 5450 nabs, & !< number of absorbers 5451 np, & !< number of pressure levels 5452 id_abs, & !< NetCDF id of the respective absorber 5453 id_dim, & !< NetCDF id of asborber's dimension 5454 id_var !< NetCDf id ot the absorber 5455 5456 REAL(wp) :: p_mls_l, & !< pressure lower limit for interpolation 5457 p_mls_u, & !< pressure upper limit for interpolation 5458 p_wgt_l, & !< pressure weight lower limit for interpolation 5459 p_wgt_u, & !< pressure weight upper limit for interpolation 5460 p_mls_m !< mean pressure between upper and lower limits 5461 5462 5463 REAL(wp), DIMENSION(:), ALLOCATABLE :: p_mls, & !< pressure levels for the absorbers 5464 rrtm_play_tmp, & !< temporary array for pressure zu-levels 5465 rrtm_plev_tmp, & !< temporary array for pressure zw-levels 5466 trace_path_tmp !< temporary array for storing trace gas path data 5467 5468 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: trace_mls, & !< array for storing the absorber amounts 5469 trace_mls_path, & !< array for storing trace gas path data 5470 trace_mls_tmp !< temporary array for storing trace gas data 5471 5472 5473 ! 5474 !-- In case of updates, deallocate arrays first (sufficient to check one 5475 !-- array as the others are automatically allocated) 5476 IF ( ALLOCATED ( rrtm_o3vmr ) ) THEN 5477 DEALLOCATE ( rrtm_o3vmr ) 5478 DEALLOCATE ( rrtm_co2vmr ) 5479 DEALLOCATE ( rrtm_ch4vmr ) 5480 DEALLOCATE ( rrtm_n2ovmr ) 5481 DEALLOCATE ( rrtm_o2vmr ) 5482 DEALLOCATE ( rrtm_cfc11vmr ) 5483 DEALLOCATE ( rrtm_cfc12vmr ) 5484 DEALLOCATE ( rrtm_cfc22vmr ) 5485 DEALLOCATE ( rrtm_ccl4vmr ) 5486 DEALLOCATE ( rrtm_h2ovmr ) 5487 ENDIF 5488 5489 ! 5490 !-- Allocate trace gas profiles 5491 ALLOCATE ( rrtm_o3vmr(0:0,1:nzt_rad+1) ) 5492 ALLOCATE ( rrtm_co2vmr(0:0,1:nzt_rad+1) ) 5493 ALLOCATE ( rrtm_ch4vmr(0:0,1:nzt_rad+1) ) 5494 ALLOCATE ( rrtm_n2ovmr(0:0,1:nzt_rad+1) ) 5495 ALLOCATE ( rrtm_o2vmr(0:0,1:nzt_rad+1) ) 5496 ALLOCATE ( rrtm_cfc11vmr(0:0,1:nzt_rad+1) ) 5497 ALLOCATE ( rrtm_cfc12vmr(0:0,1:nzt_rad+1) ) 5498 ALLOCATE ( rrtm_cfc22vmr(0:0,1:nzt_rad+1) ) 5499 ALLOCATE ( rrtm_ccl4vmr(0:0,1:nzt_rad+1) ) 5500 ALLOCATE ( rrtm_h2ovmr(0:0,1:nzt_rad+1) ) 5501 5502 ! 5503 !-- Open file for reading 5504 nc_stat = NF90_OPEN( rrtm_input_file, NF90_NOWRITE, id ) 5505 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 549 ) 5506 ! 5507 !-- Inquire dimension ids and dimensions 5508 nc_stat = NF90_INQ_DIMID( id, "Pressure", id_dim ) 5509 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) 5510 nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = np) 5511 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) 5512 5513 nc_stat = NF90_INQ_DIMID( id, "Absorber", id_dim ) 5514 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) 5515 nc_stat = NF90_INQUIRE_DIMENSION( id, id_dim, len = nabs ) 5516 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) 5517 5518 5519 ! 5520 !-- Allocate pressure, and trace gas arrays 5521 ALLOCATE( p_mls(1:np) ) 5522 ALLOCATE( trace_mls(1:num_trace_gases,1:np) ) 5523 ALLOCATE( trace_mls_tmp(1:nabs,1:np) ) 5524 5525 5526 nc_stat = NF90_INQ_VARID( id, "Pressure", id_var ) 5527 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) 5528 nc_stat = NF90_GET_VAR( id, id_var, p_mls ) 5529 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) 5530 5531 nc_stat = NF90_INQ_VARID( id, "AbsorberAmountMLS", id_var ) 5532 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) 5533 nc_stat = NF90_GET_VAR( id, id_var, trace_mls_tmp ) 5534 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 550 ) 5535 5536 5537 ! 5538 !-- Write absorber amounts (mls) to trace_mls 5539 DO n = 1, num_trace_gases 5540 CALL getAbsorberIndex( TRIM( trace_names(n) ), id_abs ) 5541 5542 trace_mls(n,1:np) = trace_mls_tmp(id_abs,1:np) 5543 5544 ! 5545 !-- Replace missing values by zero 5546 WHERE ( trace_mls(n,:) > 2.0_wp ) 5547 trace_mls(n,:) = 0.0_wp 5548 END WHERE 5549 END DO 5550 5551 DEALLOCATE ( trace_mls_tmp ) 5552 5553 nc_stat = NF90_CLOSE( id ) 5554 CALL netcdf_handle_error_rad( 'read_trace_gas_data', 551 ) 5555 5556 ! 5557 !-- Add extra pressure level for calculations of the trace gas paths 5558 ALLOCATE ( rrtm_play_tmp(1:nzt_rad+1) ) 5559 ALLOCATE ( rrtm_plev_tmp(1:nzt_rad+2) ) 5560 5561 rrtm_play_tmp(1:nzt_rad) = rrtm_play(0,1:nzt_rad) 5562 rrtm_plev_tmp(1:nzt_rad+1) = rrtm_plev(0,1:nzt_rad+1) 5563 rrtm_play_tmp(nzt_rad+1) = rrtm_plev(0,nzt_rad+1) * 0.5_wp 5564 rrtm_plev_tmp(nzt_rad+2) = MIN( 1.0E-4_wp, 0.25_wp & 5565 * rrtm_plev(0,nzt_rad+1) ) 5566 5567 ! 5568 !-- Calculate trace gas path (zero at surface) with interpolation to the 5569 !-- sounding levels 5570 ALLOCATE ( trace_mls_path(1:nzt_rad+2,1:num_trace_gases) ) 5571 5572 trace_mls_path(nzb+1,:) = 0.0_wp 5573 5574 DO k = nzb+2, nzt_rad+2 5575 DO m = 1, num_trace_gases 5576 trace_mls_path(k,m) = trace_mls_path(k-1,m) 5577 5578 ! 5579 !-- When the pressure level is higher than the trace gas pressure 5580 !-- level, assume that 5581 IF ( rrtm_plev_tmp(k-1) > p_mls(1) ) THEN 5582 5583 trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,1) & 5584 * ( rrtm_plev_tmp(k-1) & 5585 - MAX( p_mls(1), rrtm_plev_tmp(k) ) & 5586 ) / g 5587 ENDIF 5588 5589 ! 5590 !-- Integrate for each sounding level from the contributing p_mls 5591 !-- levels 5592 DO n = 2, np 5593 ! 5594 !-- Limit p_mls so that it is within the model level 5595 p_mls_u = MIN( rrtm_plev_tmp(k-1), & 5596 MAX( rrtm_plev_tmp(k), p_mls(n) ) ) 5597 p_mls_l = MIN( rrtm_plev_tmp(k-1), & 5598 MAX( rrtm_plev_tmp(k), p_mls(n-1) ) ) 5599 5600 IF ( p_mls_l > p_mls_u ) THEN 5601 5602 ! 5603 !-- Calculate weights for interpolation 5604 p_mls_m = 0.5_wp * (p_mls_l + p_mls_u) 5605 p_wgt_u = (p_mls(n-1) - p_mls_m) / (p_mls(n-1) - p_mls(n)) 5606 p_wgt_l = (p_mls_m - p_mls(n)) / (p_mls(n-1) - p_mls(n)) 5607 5608 ! 5609 !-- Add level to trace gas path 5610 trace_mls_path(k,m) = trace_mls_path(k,m) & 5611 + ( p_wgt_u * trace_mls(m,n) & 5612 + p_wgt_l * trace_mls(m,n-1) ) & 5613 * (p_mls_l - p_mls_u) / g 5614 ENDIF 5615 ENDDO 5616 5617 IF ( rrtm_plev_tmp(k) < p_mls(np) ) THEN 5618 trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,np) & 5619 * ( MIN( rrtm_plev_tmp(k-1), p_mls(np) ) & 5620 - rrtm_plev_tmp(k) & 5621 ) / g 5553 5622 ENDIF 5554 5623 ENDDO 5555 5556 IF ( rrtm_plev_tmp(k) < p_mls(np) ) THEN5557 trace_mls_path(k,m) = trace_mls_path(k,m) + trace_mls(m,np) &5558 * ( MIN( rrtm_plev_tmp(k-1), p_mls(np) ) - rrtm_plev_tmp(k) ) / g5559 ENDIF5560 5624 ENDDO 5561 ENDDO 5562 5563 5564 ! 5565 !-- Prepare trace gas path profiles 5566 ALLOCATE( trace_path_tmp(1:nzt_rad+1) ) 5567 5568 DO m = 1, num_trace_gases 5569 5570 trace_path_tmp(1:nzt_rad+1) = ( trace_mls_path(2:nzt_rad+2,m) & 5571 - trace_mls_path(1:nzt_rad+1,m) ) * g & 5572 / ( rrtm_plev_tmp(1:nzt_rad+1) - rrtm_plev_tmp(2:nzt_rad+2) ) 5573 5574 ! 5575 !-- Save trace gas paths to the respective arrays 5576 SELECT CASE ( TRIM( trace_names(m) ) ) 5577 5578 CASE ( 'O3' ) 5579 5580 rrtm_o3vmr(0,:) = trace_path_tmp(:) 5581 5582 CASE ( 'CO2' ) 5583 5584 rrtm_co2vmr(0,:) = trace_path_tmp(:) 5585 5586 CASE ( 'CH4' ) 5587 5588 rrtm_ch4vmr(0,:) = trace_path_tmp(:) 5589 5590 CASE ( 'N2O' ) 5591 5592 rrtm_n2ovmr(0,:) = trace_path_tmp(:) 5593 5594 CASE ( 'O2' ) 5595 5596 rrtm_o2vmr(0,:) = trace_path_tmp(:) 5597 5598 CASE ( 'CFC11' ) 5599 5600 rrtm_cfc11vmr(0,:) = trace_path_tmp(:) 5601 5602 CASE ( 'CFC12' ) 5603 5604 rrtm_cfc12vmr(0,:) = trace_path_tmp(:) 5605 5606 CASE ( 'CFC22' ) 5607 5608 rrtm_cfc22vmr(0,:) = trace_path_tmp(:) 5609 5610 CASE ( 'CCL4' ) 5611 5612 rrtm_ccl4vmr(0,:) = trace_path_tmp(:) 5613 5614 CASE ( 'H2O' ) 5615 5616 rrtm_h2ovmr(0,:) = trace_path_tmp(:) 5617 5618 CASE DEFAULT 5619 5620 END SELECT 5621 5622 ENDDO 5623 5624 DEALLOCATE( trace_path_tmp ) 5625 DEALLOCATE( trace_mls_path ) 5626 DEALLOCATE( rrtm_play_tmp ) 5627 DEALLOCATE( rrtm_plev_tmp ) 5628 DEALLOCATE( trace_mls ) 5629 DEALLOCATE( p_mls ) 5630 5631 END SUBROUTINE read_trace_gas_data 5632 5633 !--------------------------------------------------------------------------------------------------! 5625 5626 5627 ! 5628 !-- Prepare trace gas path profiles 5629 ALLOCATE ( trace_path_tmp(1:nzt_rad+1) ) 5630 5631 DO m = 1, num_trace_gases 5632 5633 trace_path_tmp(1:nzt_rad+1) = ( trace_mls_path(2:nzt_rad+2,m) & 5634 - trace_mls_path(1:nzt_rad+1,m) ) * g & 5635 / ( rrtm_plev_tmp(1:nzt_rad+1) & 5636 - rrtm_plev_tmp(2:nzt_rad+2) ) 5637 5638 ! 5639 !-- Save trace gas paths to the respective arrays 5640 SELECT CASE ( TRIM( trace_names(m) ) ) 5641 5642 CASE ( 'O3' ) 5643 5644 rrtm_o3vmr(0,:) = trace_path_tmp(:) 5645 5646 CASE ( 'CO2' ) 5647 5648 rrtm_co2vmr(0,:) = trace_path_tmp(:) 5649 5650 CASE ( 'CH4' ) 5651 5652 rrtm_ch4vmr(0,:) = trace_path_tmp(:) 5653 5654 CASE ( 'N2O' ) 5655 5656 rrtm_n2ovmr(0,:) = trace_path_tmp(:) 5657 5658 CASE ( 'O2' ) 5659 5660 rrtm_o2vmr(0,:) = trace_path_tmp(:) 5661 5662 CASE ( 'CFC11' ) 5663 5664 rrtm_cfc11vmr(0,:) = trace_path_tmp(:) 5665 5666 CASE ( 'CFC12' ) 5667 5668 rrtm_cfc12vmr(0,:) = trace_path_tmp(:) 5669 5670 CASE ( 'CFC22' ) 5671 5672 rrtm_cfc22vmr(0,:) = trace_path_tmp(:) 5673 5674 CASE ( 'CCL4' ) 5675 5676 rrtm_ccl4vmr(0,:) = trace_path_tmp(:) 5677 5678 CASE ( 'H2O' ) 5679 5680 rrtm_h2ovmr(0,:) = trace_path_tmp(:) 5681 5682 CASE DEFAULT 5683 5684 END SELECT 5685 5686 ENDDO 5687 5688 DEALLOCATE ( trace_path_tmp ) 5689 DEALLOCATE ( trace_mls_path ) 5690 DEALLOCATE ( rrtm_play_tmp ) 5691 DEALLOCATE ( rrtm_plev_tmp ) 5692 DEALLOCATE ( trace_mls ) 5693 DEALLOCATE ( p_mls ) 5694 5695 END SUBROUTINE read_trace_gas_data 5696 5697 5698 SUBROUTINE netcdf_handle_error_rad( routine_name, errno ) 5699 5700 USE control_parameters, & 5701 ONLY: message_string 5702 5703 USE NETCDF 5704 5705 USE pegrid 5706 5707 IMPLICIT NONE 5708 5709 CHARACTER(LEN=6) :: message_identifier 5710 CHARACTER(LEN=*) :: routine_name 5711 5712 INTEGER(iwp) :: errno 5713 5714 IF ( nc_stat /= NF90_NOERR ) THEN 5715 5716 WRITE( message_identifier, '(''NC'',I4.4)' ) errno 5717 message_string = TRIM( NF90_STRERROR( nc_stat ) ) 5718 5719 CALL message( routine_name, message_identifier, 2, 2, 0, 6, 1 ) 5720 5721 ENDIF 5722 5723 END SUBROUTINE netcdf_handle_error_rad 5724 #endif 5725 5726 5727 !------------------------------------------------------------------------------! 5634 5728 ! Description: 5635 5729 ! ------------ 5636 !> Todo: Missing subroutine description 5637 !--------------------------------------------------------------------------------------------------! 5638 SUBROUTINE netcdf_handle_error_rad( routine_name, errno ) 5639 5640 USE control_parameters, & 5641 ONLY: message_string 5642 5643 USE NETCDF 5644 5645 USE pegrid 5730 !> Calculate temperature tendency due to radiative cooling/heating. 5731 !> Cache-optimized version. 5732 !------------------------------------------------------------------------------! 5733 #if defined( __rrtmg ) 5734 SUBROUTINE radiation_tendency_ij ( i, j, tend ) 5646 5735 5647 5736 IMPLICIT NONE 5648 5737 5649 CHARACTER(LEN=6) :: message_identifier !<5650 CHARACTER(LEN=*) :: routine_name !< 5651 5652 INTEGER(iwp) :: errno !< 5653 5654 IF ( nc_stat /= NF90_NOERR ) THEN 5655 5656 WRITE( message_identifier, '(''NC'',I4.4)' ) errno5657 message_string = TRIM( NF90_STRERROR( nc_stat ) )5658 5659 CALL message( routine_name, message_identifier, 2, 2, 0, 6, 1 )5738 INTEGER(iwp) :: i, j, k !< loop indices 5739 5740 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term 5741 5742 IF ( radiation_scheme == 'rrtmg' ) THEN 5743 ! 5744 !-- Calculate tendency based on heating rate 5745 DO k = nzb+1, nzt+1 5746 tend(k,j,i) = tend(k,j,i) + (rad_lw_hr(k,j,i) + rad_sw_hr(k,j,i)) & 5747 * d_exner(k) * d_seconds_hour 5748 ENDDO 5660 5749 5661 5750 ENDIF 5662 5751 5663 END SUBROUTINE netcdf_handle_error_rad5752 END SUBROUTINE radiation_tendency_ij 5664 5753 #endif 5665 5754 5666 5755 5667 !------------------------------------------------------------------------------ --------------------!5756 !------------------------------------------------------------------------------! 5668 5757 ! Description: 5669 5758 ! ------------ 5670 !> Calculate temperature tendency due to radiative cooling/heating. Cache-optimized version. 5671 !--------------------------------------------------------------------------------------------------! 5759 !> Calculate temperature tendency due to radiative cooling/heating. 5760 !> Vector-optimized version 5761 !------------------------------------------------------------------------------! 5672 5762 #if defined( __rrtmg ) 5673 SUBROUTINE radiation_tendency_ij( i, j, tend ) 5763 SUBROUTINE radiation_tendency ( tend ) 5764 5765 USE indices, & 5766 ONLY: nxl, nxr, nyn, nys 5674 5767 5675 5768 IMPLICIT NONE 5676 5769 5677 INTEGER(iwp) :: i, j, k !< loop indices 5678 5679 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term 5680 5681 IF ( radiation_scheme == 'rrtmg' ) THEN 5682 ! 5683 !-- Calculate tendency based on heating rate 5684 DO k = nzb+1, nzt+1 5685 tend(k,j,i) = tend(k,j,i) + ( rad_lw_hr(k,j,i) + rad_sw_hr(k,j,i) ) * d_exner(k) & 5686 * d_seconds_hour 5687 ENDDO 5688 5689 ENDIF 5690 5691 END SUBROUTINE radiation_tendency_ij 5692 #endif 5693 5694 5695 !--------------------------------------------------------------------------------------------------! 5696 ! Description: 5697 ! ------------ 5698 !> Calculate temperature tendency due to radiative cooling/heating. Vector-optimized version 5699 !--------------------------------------------------------------------------------------------------! 5700 #if defined( __rrtmg ) 5701 SUBROUTINE radiation_tendency( tend ) 5702 5703 USE indices, & 5704 ONLY: nxl, & 5705 nxr, & 5706 nyn, & 5707 nys 5708 5709 IMPLICIT NONE 5710 5711 INTEGER(iwp) :: i, j, k !< loop indices 5712 5713 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term 5770 INTEGER(iwp) :: i, j, k !< loop indices 5771 5772 REAL(wp), DIMENSION(nzb:nzt+1,nysg:nyng,nxlg:nxrg) :: tend !< pt tendency term 5714 5773 5715 5774 IF ( radiation_scheme == 'rrtmg' ) THEN … … 5718 5777 DO i = nxl, nxr 5719 5778 DO j = nys, nyn 5720 DO k = nzb+1, nzt+1 5721 tend(k,j,i) = tend(k,j,i) + ( rad_lw_hr(k,j,i) + rad_sw_hr(k,j,i) ) * d_exner(k) & 5722 * d_seconds_hour 5779 DO k = nzb+1, nzt+1 5780 tend(k,j,i) = tend(k,j,i) + ( rad_lw_hr(k,j,i) & 5781 + rad_sw_hr(k,j,i) ) * d_exner(k) & 5782 * d_seconds_hour 5723 5783 ENDDO 5724 5784 ENDDO … … 5729 5789 #endif 5730 5790 5731 !------------------------------------------------------------------------------ --------------------!5791 !------------------------------------------------------------------------------! 5732 5792 ! Description: 5733 5793 ! ------------ 5734 !> Radiative Transfer Model (RTM) version 3.0 for modelling of radiation interactions within urban 5735 !> canopy or inside of surface layer in complex terrain. This subroutine calculates interaction of 5736 !> the solar SW and LW radiation with urban and land surfaces and updates all surface heatfluxes. 5737 !> It also calculates interactions of SW and LW radiation with resolved plant canopy and calculates 5738 !> the corresponding plant canopy heat fluxes. The subroutine also models spatial and temporal 5739 !> distribution of Mean Radiant Temperature (MRT). The resulting values are provided to other 5794 !> Radiative Transfer Model (RTM) version 3.0 for modelling of radiation 5795 !> interactions within urban canopy or inside of surface layer in complex terrain. 5796 !> This subroutine calculates interaction of the solar SW and LW radiation 5797 !> with urban and land surfaces and updates all surface heatfluxes. 5798 !> It also calculates interactions of SW and LW radiation with resolved 5799 !> plant canopy and calculates the corresponding plant canopy heat fluxes. 5800 !> The subroutine also models spatial and temporal distribution of Mean 5801 !> Radiant Temperature (MRT). The resulting values are provided to other 5740 5802 !> PALM-4U modules (RRTMG, USM, LSM, PCM and BIO). 5741 5803 !> 5742 !> The new version 3.0 was radically rewriten from version 1.0. The most significant changes include 5743 !> new angular discretization scheme, redesigned and significantly optimized raytracing scheme, new 5744 !> processes included in modelling (e.g. intetrations of LW radiation with PC), integrated 5745 !> calculation of Mean Radiant Temperature (MRT), and improved and enhanced output and debug 5746 !> capabilities. This new version significantly improves effectivity of the paralelization and the 5747 !> scalability of the model and allows simulation of extensive domain with appropriate HPC resources. 5804 !> The new version 3.0 was radically rewriten from version 1.0. 5805 !> The most significant changes include new angular discretization scheme, 5806 !> redesigned and significantly optimized raytracing scheme, new processes 5807 !> included in modelling (e.g. intetrations of LW radiation with PC), 5808 !> integrated calculation of Mean Radiant Temperature (MRT), and improved 5809 !> and enhanced output and debug capabilities. This new version significantly 5810 !> improves effectivity of the paralelization and the scalability of the model 5811 !> and allows simulation of extensive domain with appropriate HPC resources. 5748 5812 !> 5749 5813 !> More info about RTM v.1.0. see: 5750 5814 !> Resler et al., GMD. 2017, https://doi.org/10.5194/gmd-10-3635-2017 5751 !> Info about RTM v. 3.0 see: Krc et al. 2020 (to appear in GMD), 5815 !> Info about RTM v. 3.0 see: 5816 !> Krc et al. 2020 (to appear in GMD), 5752 5817 !> Maronga et al., GMDD 2019, https://doi.org/10.5194/gmd-2019-103 5753 !--------------------------------------------------------------------------------------------------! 5818 !> 5819 5820 5821 !------------------------------------------------------------------------------! 5754 5822 5755 5823 SUBROUTINE radiation_interaction 5756 5824 5757 USE control_parameters, 5825 USE control_parameters, & 5758 5826 ONLY: rotation_angle 5759 5827 5760 5828 IMPLICIT NONE 5761 5829 5762 INTEGER(iwp) :: i, j, k, kk, d, refstep, m, mm, l, ll !< 5763 INTEGER(iwp) :: isurf, isurfsrc, isvf, icsf, ipcgb !< 5764 INTEGER(iwp) :: imrt, imrtf !< 5765 INTEGER(iwp) :: isd !< solar direction number 5766 INTEGER(iwp) :: pc_box_dimshift !< transform for best accuracy 5767 5768 INTEGER(iwp), DIMENSION(0:3) :: reorder = (/ 1, 0, 3, 2 /) !< 5769 5770 REAL(wp) :: pc_box_area, pc_abs_frac, pc_abs_eff !< 5771 REAL(wp) :: asrc !< area of source face 5772 REAL(wp) :: pcrad !< irradiance from plant canopy 5773 5774 REAL(wp), DIMENSION(3) :: sunorig !< grid rotated solar direction unit vector (zyx) 5775 REAL(wp), DIMENSION(3) :: sunorig_grid !< grid squashed solar direction unit vector (zyx) 5776 REAL(wp), DIMENSION(3,3) :: mrot !< grid rotation matrix (zyx) 5777 REAL(wp), DIMENSION(3,0:nsurf_type) :: vnorm !< face direction normal vectors (zyx) 5778 REAL(wp), DIMENSION(0:nsurf_type) :: costheta !< direct irradiance factor of solar angle 5779 REAL(wp), DIMENSION(nz_urban_b:nz_urban_t) :: pchf_prep !< precalculated factor for canopy temperature tendency 5780 5781 !- Variables for coupling the radiation modle (e.g. RRTMG) and RTM 5782 REAL(wp) :: pabsswl !< total absorbed SW radiation energy in local processor (W) 5783 REAL(wp) :: pabssw !< total absorbed SW radiation energy in all processors (W) 5784 REAL(wp) :: pabslwl !< total absorbed LW radiation energy in local processor (W) 5785 REAL(wp) :: pabslw !< total absorbed LW radiation energy in all processors (W) 5786 REAL(wp) :: pemitlwl !< total emitted LW radiation energy in all processors (W) 5787 REAL(wp) :: pemitlw !< total emitted LW radiation energy in all processors (W) 5788 REAL(wp) :: pinswl !< total received SW radiation energy in local processor (W) 5789 REAL(wp) :: pinsw !< total received SW radiation energy in all processor (W) 5790 REAL(wp) :: pinlwl !< total received LW radiation energy in local processor (W) 5791 REAL(wp) :: pinlw !< total received LW radiation energy in all processor (W) 5792 REAL(wp) :: area_norm !< reference horizontal area of domain in all processor 5793 REAL(wp) :: pabs_surf_lwdifl !< total absorbed LW radiation in surfaces from sky in local processor (W) 5794 REAL(wp) :: pabs_surf_lwdif !< total absorbed LW radiation in surfaces from sky in all processors (W) 5795 REAL(wp) :: pabs_pc_lwdifl !< total absorbed LW radiation in plant canopy from sky in local processor (W) 5796 REAL(wp) :: pabs_pc_lwdif !< total absorbed LW radiation in plant canopy from sky in all processors (W) 5797 REAL(wp) :: sun_direct_factor !< factor for direct normal radiation from direct horizontal 5798 REAL(wp) :: sin_rot !< sine of rotation_angle 5799 REAL(wp) :: cos_rot !< cosine of rotation_angle 5800 REAL(wp) :: solar_azim !< solar azimuth in rotated model coordinates 5830 INTEGER(iwp) :: i, j, k, kk, d, refstep, m, mm, l, ll 5831 INTEGER(iwp) :: isurf, isurfsrc, isvf, icsf, ipcgb 5832 INTEGER(iwp) :: imrt, imrtf 5833 INTEGER(iwp) :: isd !< solar direction number 5834 INTEGER(iwp) :: pc_box_dimshift !< transform for best accuracy 5835 INTEGER(iwp), DIMENSION(0:3) :: reorder = (/ 1, 0, 3, 2 /) 5836 5837 REAL(wp), DIMENSION(3,3) :: mrot !< grid rotation matrix (zyx) 5838 REAL(wp), DIMENSION(3,0:nsurf_type):: vnorm !< face direction normal vectors (zyx) 5839 REAL(wp), DIMENSION(3) :: sunorig !< grid rotated solar direction unit vector (zyx) 5840 REAL(wp), DIMENSION(3) :: sunorig_grid !< grid squashed solar direction unit vector (zyx) 5841 REAL(wp), DIMENSION(0:nsurf_type) :: costheta !< direct irradiance factor of solar angle 5842 REAL(wp), DIMENSION(nz_urban_b:nz_urban_t) :: pchf_prep !< precalculated factor for canopy temperature tendency 5843 REAL(wp) :: pc_box_area, pc_abs_frac, pc_abs_eff 5844 REAL(wp) :: asrc !< area of source face 5845 REAL(wp) :: pcrad !< irradiance from plant canopy 5846 !- variables for coupling the radiation modle (e.g. RRTMG) and RTM 5847 REAL(wp) :: pabsswl !< total absorbed SW radiation energy in local processor (W) 5848 REAL(wp) :: pabssw !< total absorbed SW radiation energy in all processors (W) 5849 REAL(wp) :: pabslwl !< total absorbed LW radiation energy in local processor (W) 5850 REAL(wp) :: pabslw !< total absorbed LW radiation energy in all processors (W) 5851 REAL(wp) :: pemitlwl !< total emitted LW radiation energy in all processors (W) 5852 REAL(wp) :: pemitlw !< total emitted LW radiation energy in all processors (W) 5853 REAL(wp) :: pinswl !< total received SW radiation energy in local processor (W) 5854 REAL(wp) :: pinsw !< total received SW radiation energy in all processor (W) 5855 REAL(wp) :: pinlwl !< total received LW radiation energy in local processor (W) 5856 REAL(wp) :: pinlw !< total received LW radiation energy in all processor (W) 5857 REAL(wp) :: area_norm !< reference horizontal area of domain in all processor 5858 REAL(wp) :: pabs_surf_lwdifl !< total absorbed LW radiation in surfaces from sky in local processor (W) 5859 REAL(wp) :: pabs_surf_lwdif !< total absorbed LW radiation in surfaces from sky in all processors (W) 5860 REAL(wp) :: pabs_pc_lwdifl !< total absorbed LW radiation in plant canopy from sky in local processor (W) 5861 REAL(wp) :: pabs_pc_lwdif !< total absorbed LW radiation in plant canopy from sky in all processors (W) 5862 5863 REAL(wp) :: sun_direct_factor !< factor for direct normal radiation from direct horizontal 5864 REAL(wp) :: sin_rot !< sine of rotation_angle 5865 REAL(wp) :: cos_rot !< cosine of rotation_angle 5866 REAL(wp) :: solar_azim !< solar azimuth in rotated model coordinates 5801 5867 #if defined( __parallel ) 5802 REAL(wp), DIMENSION(1:7) :: combine_allreduce!< dummy array used to combine several MPI_ALLREDUCE calls5803 REAL(wp), DIMENSION(1:7) :: combine_allreduce_l!< dummy array used to combine several MPI_ALLREDUCE calls5868 REAL(wp), DIMENSION(1:7) :: combine_allreduce !< dummy array used to combine several MPI_ALLREDUCE calls 5869 REAL(wp), DIMENSION(1:7) :: combine_allreduce_l !< dummy array used to combine several MPI_ALLREDUCE calls 5804 5870 #endif 5805 5871 … … 5807 5873 5808 5874 IF ( plant_canopy ) THEN 5809 pchf_prep(:) = r_d * exner(nz_urban_b:nz_urban_t) 5810 / ( c_p * hyp(nz_urban_b:nz_urban_t) * dx * dy * dz( 1 ) ) !< equals to 1 / ( rho * c_p * Vbox * T)5875 pchf_prep(:) = r_d * exner(nz_urban_b:nz_urban_t) & 5876 / (c_p * hyp(nz_urban_b:nz_urban_t) * dx*dy*dz(1)) !< equals to 1 / (rho * c_p * Vbox * T) 5811 5877 ENDIF 5812 5878 5813 5879 sun_direction = .TRUE. 5814 CALL get_date_time( time_since_reference_point, day_of_year = day_of_year, & 5815 second_of_day = second_of_day ) 5816 CALL calc_zenith( day_of_year, second_of_day ) !< Required also for diffusion radiation 5817 5818 ! 5819 !-- Prepare rotated normal vectors and irradiance factor 5880 CALL get_date_time( time_since_reference_point, & 5881 day_of_year=day_of_year, & 5882 second_of_day=second_of_day ) 5883 CALL calc_zenith( day_of_year, second_of_day ) !< required also for diffusion radiation 5884 5885 ! 5886 !-- prepare rotated normal vectors and irradiance factor 5820 5887 sin_rot = SIN( rotation_angle * pi / 180.0_wp ) 5821 5888 cos_rot = COS( rotation_angle * pi / 180.0_wp ) … … 5827 5894 mrot(3, :) = (/ 0._wp, -sin_rot, cos_rot /) 5828 5895 sunorig = (/ cos_zenith, sun_dir_lat, sun_dir_lon /) 5829 sunorig = MATMUL( mrot, sunorig)5830 DO 5831 costheta(d) = DOT_PRODUCT( sunorig, vnorm(:,d))5896 sunorig = MATMUL(mrot, sunorig) 5897 DO d = 0, nsurf_type 5898 costheta(d) = DOT_PRODUCT(sunorig, vnorm(:,d)) 5832 5899 ENDDO 5833 5900 5834 5901 IF ( cos_zenith > 0 ) THEN 5835 !-- Now we will "squash" the sunorig vector by grid box size in each dimension, so that this5836 !-- new direction vector will allow us to traverse the ray path within grid coordinates5837 !-- directly.5902 !-- now we will "squash" the sunorig vector by grid box size in 5903 !-- each dimension, so that this new direction vector will allow us 5904 !-- to traverse the ray path within grid coordinates directly 5838 5905 sunorig_grid = (/ sunorig(1)/dz(1), sunorig(2)/dy, sunorig(3)/dx /) 5839 5906 !-- sunorig_grid = sunorig_grid / norm2(sunorig_grid) 5840 sunorig_grid = sunorig_grid / SQRT( SUM( sunorig_grid**2 ))5907 sunorig_grid = sunorig_grid / SQRT(SUM(sunorig_grid**2)) 5841 5908 5842 5909 IF ( npcbl > 0 ) THEN 5843 !-- Precompute effective box depth with prototype Leaf Area Density. 5844 pc_box_dimshift = MAXLOC( ABS( sunorig ), 1 ) - 1 5845 CALL box_absorb( CSHIFT( (/dz(1), dy, dx/), pc_box_dimshift ), 60, prototype_lad, & 5846 CSHIFT( ABS( sunorig ), pc_box_dimshift ), pc_box_area, pc_abs_frac ) 5847 pc_box_area = pc_box_area * ABS( sunorig( pc_box_dimshift + 1 ) / sunorig( 1 ) ) 5848 pc_abs_eff = LOG( 1._wp - pc_abs_frac ) / prototype_lad 5910 !-- precompute effective box depth with prototype Leaf Area Density 5911 pc_box_dimshift = MAXLOC(ABS(sunorig), 1) - 1 5912 CALL box_absorb(CSHIFT((/dz(1),dy,dx/), pc_box_dimshift), & 5913 60, prototype_lad, & 5914 CSHIFT(ABS(sunorig), pc_box_dimshift), & 5915 pc_box_area, pc_abs_frac) 5916 pc_box_area = pc_box_area * ABS(sunorig(pc_box_dimshift+1) & 5917 / sunorig(1)) 5918 pc_abs_eff = LOG(1._wp - pc_abs_frac) / prototype_lad 5849 5919 ENDIF 5850 5920 ENDIF 5851 5921 ! 5852 !-- Split downwelling shortwave radiation into a diffuse and a direct part. Note, if radiation 5853 !-- scheme is RRTMG or diffuse radiation is externally prescribed, this is not required. Please 5854 !-- note, in case of external radiation, the clear-sky model is applied during spinup, so that 5855 !-- radiation needs to be split also in this case. 5856 IF ( radiation_scheme == 'constant' .OR. radiation_scheme == 'clear-sky' .OR. & 5857 ( radiation_scheme == 'external' .AND. .NOT. rad_sw_in_dif_f%from_file ) .OR. & 5858 ( radiation_scheme == 'external' .AND. time_since_reference_point < 0.0_wp ) ) THEN 5922 !-- Split downwelling shortwave radiation into a diffuse and a direct part. 5923 !-- Note, if radiation scheme is RRTMG or diffuse radiation is externally 5924 !-- prescribed, this is not required. Please note, in case of external 5925 !-- radiation, the clear-sky model is applied during spinup, so that 5926 !-- radiation need to be split also in this case. 5927 IF ( radiation_scheme == 'constant' .OR. & 5928 radiation_scheme == 'clear-sky' .OR. & 5929 ( radiation_scheme == 'external' .AND. & 5930 .NOT. rad_sw_in_dif_f%from_file ) .OR. & 5931 ( radiation_scheme == 'external' .AND. & 5932 time_since_reference_point < 0.0_wp ) ) THEN 5859 5933 CALL calc_diffusion_radiation 5860 5934 ENDIF … … 5862 5936 5863 5937 !-- First pass of radiation interaction: 5864 !-- 1) direct and diffuse irradiance 5938 !-- 1) direct and diffuse irradiance 5865 5939 !-- 2) thermal emissions 5866 5940 5867 !- Initialize relavant surface flux arrays and radiation energy sum surface flux5868 surfinswdir = 0.0_wp 5869 surfins 5870 surfin l= 0.0_wp5871 surf outsl(:)= 0.0_wp5872 surfout ll(:)= 0.0_wp5873 5941 !- Initialize relavant surface flux arrays and radiation energy sum 5942 !- surface flux 5943 surfinswdir = 0.0_wp 5944 surfins = 0.0_wp 5945 surfinl = 0.0_wp 5946 surfoutsl(:) = 0.0_wp 5947 surfoutll(:) = 0.0_wp 5874 5948 IF ( nmrtbl > 0 ) THEN 5875 5949 mrtinsw(:) = 0.0_wp 5876 5950 mrtinlw(:) = 0.0_wp 5877 5951 ENDIF 5878 5879 surfinlg(:) = 0.0_wp 5880 !- Radiation energy sum 5952 surfinlg(:) = 0.0_wp 5953 !- radiation energy sum 5881 5954 pinlwl = 0.0_wp 5882 5955 pinswl = 0.0_wp … … 5887 5960 pabs_pc_lwdifl = 0.0_wp 5888 5961 5889 !-- Set up thermal radiation from surfaces. emiss_surf is defined only for surfaces for which 5890 !-- energy balance is calculated. Workaround: reorder surface data type back on 1D array including 5891 !-- all surfaces, which implies to reorder horizontal and vertical surfaces. 5962 !-- Set up thermal radiation from surfaces 5963 !-- emiss_surf is defined only for surfaces for which energy balance is calculated 5964 !-- Workaround: reorder surface data type back on 1D array including all surfaces, 5965 !-- which implies to reorder horizontal and vertical surfaces 5892 5966 ! 5893 5967 !-- Horizontal walls … … 5896 5970 DO j = nys, nyn 5897 5971 ! 5898 !-- Urban5972 !-- urban 5899 5973 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 5900 surfoutll(mm) = SUM( surf_usm_h%frac(m,:) * surf_usm_h%emissivity(m,:) ) & 5901 * sigma_sb * surf_usm_h%pt_surface(m)**4 5902 albedo_surf(mm) = SUM( surf_usm_h%frac(m,:) * surf_usm_h%albedo(m,:) ) 5903 emiss_surf(mm) = SUM( surf_usm_h%frac(m,:) * surf_usm_h%emissivity(m,:) ) 5974 surfoutll(mm) = SUM ( surf_usm_h%frac(m,:) * & 5975 surf_usm_h%emissivity(m,:) ) & 5976 * sigma_sb & 5977 * surf_usm_h%pt_surface(m)**4 5978 albedo_surf(mm) = SUM ( surf_usm_h%frac(m,:) * & 5979 surf_usm_h%albedo(m,:) ) 5980 emiss_surf(mm) = SUM ( surf_usm_h%frac(m,:) * & 5981 surf_usm_h%emissivity(m,:) ) 5904 5982 mm = mm + 1 5905 5983 ENDDO 5906 5984 ! 5907 !-- Land5985 !-- land 5908 5986 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 5909 surfoutll(mm) = SUM( surf_lsm_h%frac(m,:) * surf_lsm_h%emissivity(m,:) ) & 5910 * sigma_sb * surf_lsm_h%pt_surface(m)**4 5911 albedo_surf(mm) = SUM( surf_lsm_h%frac(m,:) * surf_lsm_h%albedo(m,:) ) 5912 emiss_surf(mm) = SUM( surf_lsm_h%frac(m,:) * surf_lsm_h%emissivity(m,:) ) 5987 surfoutll(mm) = SUM ( surf_lsm_h%frac(m,:) * & 5988 surf_lsm_h%emissivity(m,:) ) & 5989 * sigma_sb & 5990 * surf_lsm_h%pt_surface(m)**4 5991 albedo_surf(mm) = SUM ( surf_lsm_h%frac(m,:) * & 5992 surf_lsm_h%albedo(m,:) ) 5993 emiss_surf(mm) = SUM ( surf_lsm_h%frac(m,:) * & 5994 surf_lsm_h%emissivity(m,:) ) 5913 5995 mm = mm + 1 5914 5996 ENDDO … … 5922 6004 l = reorder(ll) 5923 6005 ! 5924 !-- Urban 5925 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) 5926 surfoutll(mm) = SUM( surf_usm_v(l)%frac(m,:) * surf_usm_v(l)%emissivity(m,:) ) & 5927 * sigma_sb * surf_usm_v(l)%pt_surface(m)**4 5928 albedo_surf(mm) = SUM( surf_usm_v(l)%frac(m,:) * surf_usm_v(l)%albedo(m,:) ) 5929 emiss_surf(mm) = SUM( surf_usm_v(l)%frac(m,:) * surf_usm_v(l)%emissivity(m,:) ) 6006 !-- urban 6007 DO m = surf_usm_v(l)%start_index(j,i), & 6008 surf_usm_v(l)%end_index(j,i) 6009 surfoutll(mm) = SUM ( surf_usm_v(l)%frac(m,:) * & 6010 surf_usm_v(l)%emissivity(m,:) ) & 6011 * sigma_sb & 6012 * surf_usm_v(l)%pt_surface(m)**4 6013 albedo_surf(mm) = SUM ( surf_usm_v(l)%frac(m,:) * & 6014 surf_usm_v(l)%albedo(m,:) ) 6015 emiss_surf(mm) = SUM ( surf_usm_v(l)%frac(m,:) * & 6016 surf_usm_v(l)%emissivity(m,:) ) 5930 6017 mm = mm + 1 5931 6018 ENDDO 5932 6019 ! 5933 !-- Land 5934 DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) 5935 surfoutll(mm) = SUM( surf_lsm_v(l)%frac(m,:) * surf_lsm_v(l)%emissivity(m,:) ) & 5936 * sigma_sb * surf_lsm_v(l)%pt_surface(m)**4 5937 albedo_surf(mm) = SUM( surf_lsm_v(l)%frac(m,:) * surf_lsm_v(l)%albedo(m,:) ) 5938 emiss_surf(mm) = SUM( surf_lsm_v(l)%frac(m,:) * surf_lsm_v(l)%emissivity(m,:) ) 6020 !-- land 6021 DO m = surf_lsm_v(l)%start_index(j,i), & 6022 surf_lsm_v(l)%end_index(j,i) 6023 surfoutll(mm) = SUM ( surf_lsm_v(l)%frac(m,:) * & 6024 surf_lsm_v(l)%emissivity(m,:) ) & 6025 * sigma_sb & 6026 * surf_lsm_v(l)%pt_surface(m)**4 6027 albedo_surf(mm) = SUM ( surf_lsm_v(l)%frac(m,:) * & 6028 surf_lsm_v(l)%albedo(m,:) ) 6029 emiss_surf(mm) = SUM ( surf_lsm_v(l)%frac(m,:) * & 6030 surf_lsm_v(l)%emissivity(m,:) ) 5939 6031 mm = mm + 1 5940 6032 ENDDO … … 5951 6043 5952 6044 #if defined( __parallel ) 5953 !-- Might be optimized and gather only values relevant for current processor5954 CALL MPI_AllGatherv( surfoutll, nsurfl, MPI_REAL, surfoutl, nsurfs, surfstart, MPI_REAL,&5955 comm2d, ierr) !nsurf global6045 !-- might be optimized and gather only values relevant for current processor 6046 CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, & 6047 surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) !nsurf global 5956 6048 IF ( ierr /= 0 ) THEN 5957 WRITE( 9, * ) 'Error MPI_AllGatherv1:', ierr, SIZE( surfoutll ), nsurfl,&5958 SIZE( surfoutl), nsurfs, surfstart5959 FLUSH( 9)6049 WRITE(9,*) 'Error MPI_AllGatherv1:', ierr, SIZE(surfoutll), nsurfl, & 6050 SIZE(surfoutl), nsurfs, surfstart 6051 FLUSH(9) 5960 6052 ENDIF 5961 6053 #else … … 5980 6072 ENDIF 5981 6073 ! 5982 !-- Diffuse radiation using sky view factor5983 DO 6074 !-- diffuse radiation using sky view factor 6075 DO isurf = 1, nsurfl 5984 6076 j = surfl(iy, isurf) 5985 6077 i = surfl(ix, isurf) 5986 6078 d = surfl(id, isurf) 5987 6079 surfinswdif(isurf) = rad_sw_in_diff(j,i) * skyvft(isurf) 5988 !- Update received SW energy for RTM coupling6080 !- update received SW energy for RTM coupling 5989 6081 pinswl = pinswl + surfinswdif(isurf) * facearea(d) 5990 6082 IF ( plant_lw_interact ) THEN 5991 6083 surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvft(isurf) 5992 !- Update received LW energy for RTM coupling6084 !- update received LW energy for RTM coupling 5993 6085 pinlwl = pinlwl + surfinlwdif(isurf) * facearea(d) 5994 6086 ELSE 5995 6087 surfinlwdif(isurf) = rad_lw_in_diff(j,i) * skyvf(isurf) 5996 !- Update received LW energy for RTM coupling6088 !- update received LW energy for RTM coupling 5997 6089 pinlwl = pinlwl + surfinlwdif(isurf) * facearea(d) 5998 6090 ENDIF … … 6010 6102 IF ( cos_zenith > 0 ) THEN 6011 6103 ! 6012 !-- To avoid numerical instability near horizon depending on what direct radiation is used6013 !-- (slightly different zenith angle, considering circumsolar etc.), we use a minimum value for6014 !-- c os_zenith6015 sun_direct_factor = 1._wp / MAX( min_stable_coszen, cos_zenith)6104 !-- To avoid numerical instability near horizon depending on what direct 6105 !-- radiation is used (slightly different zenith angle, considering 6106 !-- circumsolar etc.), we use a minimum value for cos_zenith 6107 sun_direct_factor = 1._wp / MAX(min_stable_coszen, cos_zenith) 6016 6108 ! 6017 6109 !-- Identify solar direction vector (discretized number) (1) 6018 solar_azim = ATAN2( sun_dir_lon, sun_dir_lat ) * ( 180.0_wp / pi ) - rotation_angle 6019 j = FLOOR( ACOS( cos_zenith ) / pi * raytrace_discrete_elevs ) 6020 i = MODULO( NINT( solar_azim / 360.0_wp * raytrace_discrete_azims - 0.5_wp, iwp ), & 6021 raytrace_discrete_azims ) 6110 solar_azim = ATAN2(sun_dir_lon, sun_dir_lat) * (180.0_wp/pi) - rotation_angle 6111 j = FLOOR(ACOS(cos_zenith) / pi * raytrace_discrete_elevs) 6112 i = MODULO(NINT(solar_azim / 360.0_wp * & 6113 raytrace_discrete_azims - 0.5_wp, iwp), & 6114 raytrace_discrete_azims) 6022 6115 isd = dsidir_rev(j, i) 6023 6116 !-- TODO: check if isd = -1 to report that this solar position is not precalculated 6024 DO 6117 DO isurf = 1, nsurfl 6025 6118 j = surfl(iy, isurf) 6026 6119 i = surfl(ix, isurf) 6027 6120 d = surfl(id, isurf) 6028 surfinswdir(isurf) = rad_sw_in_dir(j,i) * costheta(surfl(id, isurf))&6029 6030 !- Update received SW energy for RTM coupling6121 surfinswdir(isurf) = rad_sw_in_dir(j,i) * & 6122 costheta(surfl(id, isurf)) * dsitrans(isurf, isd) * sun_direct_factor 6123 !- update received SW energy for RTM coupling 6031 6124 pinswl = pinswl + surfinswdir(isurf) * facearea(d) 6032 6125 ENDDO … … 6036 6129 j = mrtbl(iy, imrt) 6037 6130 i = mrtbl(ix, imrt) 6038 mrtinsw(imrt) = mrtinsw(imrt) + mrtdsit(imrt, isd) * rad_sw_in_dir(j,i) 6039 * sun_direct_factor / 4.0_wp ! Normal to sphere6131 mrtinsw(imrt) = mrtinsw(imrt) + mrtdsit(imrt, isd) * rad_sw_in_dir(j,i) & 6132 * sun_direct_factor / 4.0_wp ! normal to sphere 6040 6133 ENDDO 6041 6134 ENDIF … … 6048 6141 ENDDO 6049 6142 ! 6050 !-- Absorption in each local plant canopy grid box from the first atmospheric pass of radiation 6143 !-- Absorption in each local plant canopy grid box from the first atmospheric 6144 !-- pass of radiation 6051 6145 IF ( npcbl > 0 ) THEN 6052 6146 … … 6055 6149 pcbinlw(:) = 0.0_wp 6056 6150 6057 DO 6058 ipcgb = csfsurf(1, icsf)6059 i = pcbl(ix,ipcgb)6060 j = pcbl(iy,ipcgb)6061 k = pcbl(iz,ipcgb)6062 kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat6063 isurfsrc = csfsurf(2, icsf)6151 DO icsf = 1, ncsfl 6152 ipcgb = csfsurf(1, icsf) 6153 i = pcbl(ix,ipcgb) 6154 j = pcbl(iy,ipcgb) 6155 k = pcbl(iz,ipcgb) 6156 kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat 6157 isurfsrc = csfsurf(2, icsf) 6064 6158 6065 6159 IF ( isurfsrc == -1 ) THEN … … 6067 6161 !-- Diffuse radiation from sky 6068 6162 pcbinswdif(ipcgb) = csf(1,icsf) * rad_sw_in_diff(j,i) 6069 !-- Add to the sum of SW radiation energy6163 !-- add to the sum of SW radiation energy 6070 6164 pinswl = pinswl + pcbinswdif(ipcgb) 6071 6165 ! 6072 6166 !-- Absorbed diffuse LW radiation from sky minus emitted to sky 6073 6167 IF ( plant_lw_interact ) THEN 6074 pcbinlw(ipcgb) = csf(1,icsf) * ( rad_lw_in_diff(j, i) - sigma_sb & 6075 * ( pt(k,j,i) * exner(k) )**4 ) 6168 pcbinlw(ipcgb) = csf(1,icsf) & 6169 * (rad_lw_in_diff(j, i) & 6170 - sigma_sb * (pt(k,j,i)*exner(k))**4) 6076 6171 pinlwl = pinlwl + csf(1,icsf) * rad_lw_in_diff(j,i) 6077 6172 pabslwl = pabslwl + csf(1,icsf) * rad_lw_in_diff(j,i) 6078 pemitlwl = pemitlwl + csf(1,icsf) * sigma_sb * ( pt(k,j,i) * exner(k) )**4 6079 pabs_pc_lwdifl = pabs_pc_lwdifl + csf(1,icsf) * rad_lw_in_diff(j,i) 6173 pemitlwl = pemitlwl + & 6174 csf(1,icsf) * sigma_sb * (pt(k,j,i)*exner(k))**4 6175 pabs_pc_lwdifl = pabs_pc_lwdifl + & 6176 csf(1,icsf) * rad_lw_in_diff(j,i) 6080 6177 ENDIF 6081 6178 ! … … 6083 6180 IF ( cos_zenith > 0 ) THEN 6084 6181 !-- Estimate directed box absorption 6085 pc_abs_frac = 1.0_wp - EXP( pc_abs_eff * lad_s(kk,j,i))6182 pc_abs_frac = 1.0_wp - exp(pc_abs_eff * lad_s(kk,j,i)) 6086 6183 ! 6087 6184 !-- isd has already been established, see (1) 6088 pcbinswdir(ipcgb) = rad_sw_in_dir(j, i) * pc_box_area * pc_abs_frac&6089 * dsitransc(ipcgb, isd)6090 !-- Add to the sum of SW radiation energy6185 pcbinswdir(ipcgb) = rad_sw_in_dir(j, i) * pc_box_area & 6186 * pc_abs_frac * dsitransc(ipcgb, isd) 6187 !-- add to the sum of SW radiation energy 6091 6188 pinswl = pinswl + pcbinswdir(ipcgb) 6092 6189 ENDIF … … 6095 6192 ! 6096 6193 !-- Thermal emission from plan canopy towards respective face 6097 pcrad = sigma_sb * ( pt(k,j,i) * exner(k))**4 * csf(1,icsf)6194 pcrad = sigma_sb * (pt(k,j,i) * exner(k))**4 * csf(1,icsf) 6098 6195 surfinlg(isurfsrc) = surfinlg(isurfsrc) + pcrad 6099 6196 ! 6100 6197 !-- Remove the flux above + absorb LW from first pass from surfaces 6101 6198 asrc = facearea(surf(id, isurfsrc)) 6102 pcbinlw(ipcgb) = pcbinlw(ipcgb) + ( csf(1,icsf) * surfoutl(isurfsrc) & ! Absorb from first pass surf emit 6103 - pcrad ) & ! Remove emitted heatflux 6104 * asrc 6199 pcbinlw(ipcgb) = pcbinlw(ipcgb) & 6200 + (csf(1,icsf) * surfoutl(isurfsrc) & ! Absorb from first pass surf emit 6201 - pcrad) & ! Remove emitted heatflux 6202 * asrc 6105 6203 pabslwl = pabslwl + csf(1,icsf) * surfoutl(isurfsrc) * asrc 6106 6204 pemitlwl = pemitlwl + pcrad * asrc … … 6128 6226 !-- Exchange incoming lw radiation from plant canopy 6129 6227 #if defined( __parallel ) 6130 CALL MPI_Allreduce( MPI_IN_PLACE, surfinlg, nsurf, MPI_REAL, MPI_SUM, comm2d, ierr)6228 CALL MPI_Allreduce(MPI_IN_PLACE, surfinlg, nsurf, MPI_REAL, MPI_SUM, comm2d, ierr) 6131 6229 IF ( ierr /= 0 ) THEN 6132 WRITE ( 9, *) 'Error MPI_Allreduce:', ierr6133 FLUSH( 9)6230 WRITE (9,*) 'Error MPI_Allreduce:', ierr 6231 FLUSH(9) 6134 6232 ENDIF 6135 6233 surfinl(:) = surfinl(:) + surfinlg(surfstart(myid)+1:surfstart(myid+1)) … … 6156 6254 nrefsteps = 0 6157 6255 surfoutsl = albedo_surf * surfins 6158 surfoutll = ( 1.0_wp - emiss_surf) * surfinl6256 surfoutll = (1.0_wp - emiss_surf) * surfinl 6159 6257 surfoutsw = surfoutsw + surfoutsl 6160 6258 surfoutlw = surfoutlw + surfoutll … … 6162 6260 6163 6261 !-- Next passes of radiation interactions: 6164 !-- Radiation reflections6165 6166 DO 6262 !-- radiation reflections 6263 6264 DO refstep = 1, nrefsteps 6167 6265 6168 6266 surfoutsl = albedo_surf * surfins 6169 6267 ! 6170 !-- For non-transparent surfaces, longwave albedo is 1 - emissivity6171 surfoutll = ( 1.0_wp - emiss_surf) * surfinl6268 !-- for non-transparent surfaces, longwave albedo is 1 - emissivity 6269 surfoutll = (1.0_wp - emiss_surf) * surfinl 6172 6270 6173 6271 IF ( trace_fluxes_above >= 0.0_wp ) THEN … … 6177 6275 6178 6276 #if defined( __parallel ) 6179 CALL MPI_AllGatherv( surfoutsl, nsurfl, MPI_REAL, surfouts, nsurfs, surfstart, MPI_REAL,&6180 comm2d, ierr)6277 CALL MPI_AllGatherv(surfoutsl, nsurfl, MPI_REAL, & 6278 surfouts, nsurfs, surfstart, MPI_REAL, comm2d, ierr) 6181 6279 IF ( ierr /= 0 ) THEN 6182 WRITE( 9, * ) 'Error MPI_AllGatherv2:', ierr, SIZE( surfoutsl ), nsurfl,&6183 SIZE( surfouts), nsurfs, surfstart6184 FLUSH( 9)6280 WRITE(9,*) 'Error MPI_AllGatherv2:', ierr, SIZE(surfoutsl), nsurfl, & 6281 SIZE(surfouts), nsurfs, surfstart 6282 FLUSH(9) 6185 6283 ENDIF 6186 6284 6187 CALL MPI_AllGatherv( surfoutll, nsurfl, MPI_REAL, surfoutl, nsurfs, surfstart, MPI_REAL,&6188 comm2d, ierr)6285 CALL MPI_AllGatherv(surfoutll, nsurfl, MPI_REAL, & 6286 surfoutl, nsurfs, surfstart, MPI_REAL, comm2d, ierr) 6189 6287 IF ( ierr /= 0 ) THEN 6190 WRITE( 9, * ) 'Error MPI_AllGatherv3:', ierr, SIZE( surfoutll ), nsurfl,&6191 SIZE( surfoutl), nsurfs, surfstart6192 FLUSH( 9)6288 WRITE(9,*) 'Error MPI_AllGatherv3:', ierr, SIZE(surfoutll), nsurfl, & 6289 SIZE(surfoutl), nsurfs, surfstart 6290 FLUSH(9) 6193 6291 ENDIF 6194 6292 … … 6203 6301 ! 6204 6302 !-- Reflected radiation 6205 DO 6206 isurf = svfsurf(1, isvf)6207 isurfsrc = svfsurf(2, isvf)6208 surfins(isurf) = surfins(isurf) + svf(1,isvf) * svf(2,isvf) * surfouts(isurfsrc)6209 IF ( plant_lw_interact ) THEN6210 surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc)6211 ELSE6212 surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc)6213 ENDIF6303 DO isvf = 1, nsvfl 6304 isurf = svfsurf(1, isvf) 6305 isurfsrc = svfsurf(2, isvf) 6306 surfins(isurf) = surfins(isurf) + svf(1,isvf) * svf(2,isvf) * surfouts(isurfsrc) 6307 IF ( plant_lw_interact ) THEN 6308 surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * svf(2,isvf) * surfoutl(isurfsrc) 6309 ELSE 6310 surfinl(isurf) = surfinl(isurf) + svf(1,isvf) * surfoutl(isurfsrc) 6311 ENDIF 6214 6312 ENDDO 6215 6313 ! 6216 !-- NOTE: PC absorbtion and MRT from reflected can both be done at once after all reflections 6217 !-- if we do one more MPI_ALLGATHERV on surfout. Advantage: less local computation. 6218 !-- Disadvantage: one more collective MPI call. 6314 !-- NOTE: PC absorbtion and MRT from reflected can both be done at once 6315 !-- after all reflections if we do one more MPI_ALLGATHERV on surfout. 6316 !-- Advantage: less local computation. Disadvantage: one more collective 6317 !-- MPI call. 6219 6318 ! 6220 6319 !-- Radiation absorbed by plant canopy 6221 6320 DO icsf = 1, ncsfl 6222 ipcgb = csfsurf(1, icsf) 6223 isurfsrc = csfsurf(2, icsf) 6224 IF ( isurfsrc == -1 ) CYCLE ! Sky->face only in 1st pass, not here 6225 ! 6226 !-- Calculate source surface area. If the 'surf' array is removed before timestepping starts 6227 !-- (future version), then asrc must be stored within 'csf' 6228 asrc = facearea(surf(id, isurfsrc)) 6229 pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * surfouts(isurfsrc) * asrc 6230 IF ( plant_lw_interact ) THEN 6231 pcbinlw(ipcgb) = pcbinlw(ipcgb) + csf(1,icsf) * surfoutl(isurfsrc) * asrc 6232 ENDIF 6321 ipcgb = csfsurf(1, icsf) 6322 isurfsrc = csfsurf(2, icsf) 6323 IF ( isurfsrc == -1 ) CYCLE ! sky->face only in 1st pass, not here 6324 ! 6325 !-- Calculate source surface area. If the `surf' array is removed 6326 !-- before timestepping starts (future version), then asrc must be 6327 !-- stored within `csf' 6328 asrc = facearea(surf(id, isurfsrc)) 6329 pcbinsw(ipcgb) = pcbinsw(ipcgb) + csf(1,icsf) * surfouts(isurfsrc) * asrc 6330 IF ( plant_lw_interact ) THEN 6331 pcbinlw(ipcgb) = pcbinlw(ipcgb) + csf(1,icsf) * surfoutl(isurfsrc) * asrc 6332 ENDIF 6233 6333 ENDDO 6234 6334 ! … … 6255 6355 ENDDO ! refstep 6256 6356 ! 6257 !-- Push heat flux absorbed by plant canopy to respective 3D arrays and add absorbed SW radiation6258 !-- energy for RTM coupling variables6357 !-- push heat flux absorbed by plant canopy to respective 3D arrays and 6358 !-- add absorbed SW radiation energy for RTM coupling variables 6259 6359 IF ( npcbl > 0 ) THEN 6260 6360 pcm_heating_rate(:,:,:) = 0.0_wp 6261 DO 6262 j = pcbl(iy, ipcgb)6263 i = pcbl(ix, ipcgb)6264 k = pcbl(iz, ipcgb)6265 ! 6266 !-- Following expression equals former kk = k - nzb_s_inner(j,i)6267 kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat6268 pcm_heating_rate(kk, j, i) = ( pcbinsw(ipcgb) + pcbinlw(ipcgb) ) * pchf_prep(k)&6269 6270 !-- Add the absorbed SW radiation energy by plant canopy6271 pabsswl = pabsswl + pcbinsw(ipcgb)6361 DO ipcgb = 1, npcbl 6362 j = pcbl(iy, ipcgb) 6363 i = pcbl(ix, ipcgb) 6364 k = pcbl(iz, ipcgb) 6365 ! 6366 !-- Following expression equals former kk = k - nzb_s_inner(j,i) 6367 kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat 6368 pcm_heating_rate(kk, j, i) = (pcbinsw(ipcgb) + pcbinlw(ipcgb)) & 6369 * pchf_prep(k) * pt(k, j, i) !-- = dT/dt 6370 !-- add the absorbed SW radiation energy by plant canopy 6371 pabsswl = pabsswl + pcbinsw(ipcgb) 6272 6372 ENDDO 6273 6373 6274 IF ( humidity .AND. plant_canopy_transpiration ) 6374 IF ( humidity .AND. plant_canopy_transpiration ) THEN 6275 6375 !-- Calculation of plant canopy transpiration rate and correspondidng latent heat rate 6276 6376 pcm_transpiration_rate(:,:,:) = 0.0_wp 6277 6377 pcm_latent_rate(:,:,:) = 0.0_wp 6278 DO ipcgb = 1, npcbl 6279 i = pcbl(ix, ipcgb) 6280 j = pcbl(iy, ipcgb) 6281 k = pcbl(iz, ipcgb) 6282 kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat 6283 CALL pcm_calc_transpiration_rate( i, j, k, kk, pcbinsw(ipcgb), pcbinlw(ipcgb), & 6284 pcm_transpiration_rate(kk,j,i), & 6285 pcm_latent_rate(kk,j,i) ) 6378 DO ipcgb = 1, npcbl 6379 i = pcbl(ix, ipcgb) 6380 j = pcbl(iy, ipcgb) 6381 k = pcbl(iz, ipcgb) 6382 kk = k - topo_top_ind(j,i,0) !- lad arrays are defined flat 6383 CALL pcm_calc_transpiration_rate( i, j, k, kk, pcbinsw(ipcgb), & 6384 pcbinlw(ipcgb), & 6385 pcm_transpiration_rate(kk,j,i), & 6386 pcm_latent_rate(kk,j,i) ) 6286 6387 ENDDO 6287 6388 ENDIF … … 6291 6392 IF ( nmrtbl > 0 ) THEN 6292 6393 IF ( mrt_include_sw ) THEN 6293 mrt(:) = ( ( mrtinsw(:) + mrtinlw(:) ) / sigma_sb) ** 0.25_wp6394 mrt(:) = ((mrtinsw(:) + mrtinlw(:)) / sigma_sb) ** 0.25_wp 6294 6395 ELSE 6295 mrt(:) = ( mrtinlw(:) / sigma_sb) ** 0.25_wp6396 mrt(:) = (mrtinlw(:) / sigma_sb) ** 0.25_wp 6296 6397 ENDIF 6297 6398 ENDIF 6298 6399 ! 6299 !-- Transfer radiation arrays required for energy balance to the respective data types and6300 ! --claculate relevant radiation model-RTM coupling terms6400 !-- Transfer radiation arrays required for energy balance to the respective data types 6401 ! and claculate relevant radiation model-RTM coupling terms 6301 6402 6302 6403 DO i = 1, nsurfl … … 6305 6406 ! 6306 6407 !-- (1) Urban surfaces 6307 !-- Upward-facing6408 !-- upward-facing 6308 6409 IF ( surfl(1,i) == iup_u ) THEN 6309 6410 surf_usm_h%rad_sw_in(m) = surfinsw(i) … … 6311 6412 surf_usm_h%rad_sw_dir(m) = surfinswdir(i) 6312 6413 surf_usm_h%rad_sw_dif(m) = surfinswdif(i) 6313 surf_usm_h%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - surfinswdif(i) 6414 surf_usm_h%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - & 6415 surfinswdif(i) 6314 6416 surf_usm_h%rad_sw_res(m) = surfins(i) 6315 6417 surf_usm_h%rad_lw_in(m) = surfinlw(i) 6316 6418 surf_usm_h%rad_lw_out(m) = surfoutlw(i) 6317 surf_usm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + surfinlw(i) - surfoutlw(i) 6419 surf_usm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 6420 surfinlw(i) - surfoutlw(i) 6318 6421 surf_usm_h%rad_net_l(m) = surf_usm_h%rad_net(m) 6319 6422 surf_usm_h%rad_lw_dif(m) = surfinlwdif(i) … … 6321 6424 surf_usm_h%rad_lw_res(m) = surfinl(i) 6322 6425 ! 6323 !-- Northward-facding6426 !-- northward-facding 6324 6427 ELSEIF ( surfl(1,i) == inorth_u ) THEN 6325 6428 surf_usm_v(0)%rad_sw_in(m) = surfinsw(i) … … 6327 6430 surf_usm_v(0)%rad_sw_dir(m) = surfinswdir(i) 6328 6431 surf_usm_v(0)%rad_sw_dif(m) = surfinswdif(i) 6329 surf_usm_v(0)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - surfinswdif(i) 6432 surf_usm_v(0)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - & 6433 surfinswdif(i) 6330 6434 surf_usm_v(0)%rad_sw_res(m) = surfins(i) 6331 6435 surf_usm_v(0)%rad_lw_in(m) = surfinlw(i) 6332 6436 surf_usm_v(0)%rad_lw_out(m) = surfoutlw(i) 6333 surf_usm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + surfinlw(i) - surfoutlw(i) 6437 surf_usm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 6438 surfinlw(i) - surfoutlw(i) 6334 6439 surf_usm_v(0)%rad_net_l(m) = surf_usm_v(0)%rad_net(m) 6335 6440 surf_usm_v(0)%rad_lw_dif(m) = surfinlwdif(i) … … 6337 6442 surf_usm_v(0)%rad_lw_res(m) = surfinl(i) 6338 6443 ! 6339 !-- Southward-facding6444 !-- southward-facding 6340 6445 ELSEIF ( surfl(1,i) == isouth_u ) THEN 6341 6446 surf_usm_v(1)%rad_sw_in(m) = surfinsw(i) … … 6343 6448 surf_usm_v(1)%rad_sw_dir(m) = surfinswdir(i) 6344 6449 surf_usm_v(1)%rad_sw_dif(m) = surfinswdif(i) 6345 surf_usm_v(1)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - surfinswdif(i) 6450 surf_usm_v(1)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - & 6451 surfinswdif(i) 6346 6452 surf_usm_v(1)%rad_sw_res(m) = surfins(i) 6347 6453 surf_usm_v(1)%rad_lw_in(m) = surfinlw(i) 6348 6454 surf_usm_v(1)%rad_lw_out(m) = surfoutlw(i) 6349 surf_usm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + surfinlw(i) - surfoutlw(i) 6455 surf_usm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 6456 surfinlw(i) - surfoutlw(i) 6350 6457 surf_usm_v(1)%rad_net_l(m) = surf_usm_v(1)%rad_net(m) 6351 6458 surf_usm_v(1)%rad_lw_dif(m) = surfinlwdif(i) … … 6353 6460 surf_usm_v(1)%rad_lw_res(m) = surfinl(i) 6354 6461 ! 6355 !-- Eastward-facing6462 !-- eastward-facing 6356 6463 ELSEIF ( surfl(1,i) == ieast_u ) THEN 6357 6464 surf_usm_v(2)%rad_sw_in(m) = surfinsw(i) … … 6359 6466 surf_usm_v(2)%rad_sw_dir(m) = surfinswdir(i) 6360 6467 surf_usm_v(2)%rad_sw_dif(m) = surfinswdif(i) 6361 surf_usm_v(2)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - surfinswdif(i) 6468 surf_usm_v(2)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - & 6469 surfinswdif(i) 6362 6470 surf_usm_v(2)%rad_sw_res(m) = surfins(i) 6363 6471 surf_usm_v(2)%rad_lw_in(m) = surfinlw(i) 6364 6472 surf_usm_v(2)%rad_lw_out(m) = surfoutlw(i) 6365 surf_usm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + surfinlw(i) - surfoutlw(i) 6473 surf_usm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 6474 surfinlw(i) - surfoutlw(i) 6366 6475 surf_usm_v(2)%rad_net_l(m) = surf_usm_v(2)%rad_net(m) 6367 6476 surf_usm_v(2)%rad_lw_dif(m) = surfinlwdif(i) … … 6369 6478 surf_usm_v(2)%rad_lw_res(m) = surfinl(i) 6370 6479 ! 6371 !-- Westward-facding6480 !-- westward-facding 6372 6481 ELSEIF ( surfl(1,i) == iwest_u ) THEN 6373 6482 surf_usm_v(3)%rad_sw_in(m) = surfinsw(i) … … 6375 6484 surf_usm_v(3)%rad_sw_dir(m) = surfinswdir(i) 6376 6485 surf_usm_v(3)%rad_sw_dif(m) = surfinswdif(i) 6377 surf_usm_v(3)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - surfinswdif(i) 6486 surf_usm_v(3)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - & 6487 surfinswdif(i) 6378 6488 surf_usm_v(3)%rad_sw_res(m) = surfins(i) 6379 6489 surf_usm_v(3)%rad_lw_in(m) = surfinlw(i) 6380 6490 surf_usm_v(3)%rad_lw_out(m) = surfoutlw(i) 6381 surf_usm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + surfinlw(i) - surfoutlw(i) 6491 surf_usm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 6492 surfinlw(i) - surfoutlw(i) 6382 6493 surf_usm_v(3)%rad_net_l(m) = surf_usm_v(3)%rad_net(m) 6383 6494 surf_usm_v(3)%rad_lw_dif(m) = surfinlwdif(i) … … 6385 6496 surf_usm_v(3)%rad_lw_res(m) = surfinl(i) 6386 6497 ! 6387 !-- (2) Land surfaces6388 !-- Upward-facing6498 !-- (2) land surfaces 6499 !-- upward-facing 6389 6500 ELSEIF ( surfl(1,i) == iup_l ) THEN 6390 6501 surf_lsm_h%rad_sw_in(m) = surfinsw(i) … … 6392 6503 surf_lsm_h%rad_sw_dir(m) = surfinswdir(i) 6393 6504 surf_lsm_h%rad_sw_dif(m) = surfinswdif(i) 6394 surf_lsm_h%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - surfinswdif(i) 6505 surf_lsm_h%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - & 6506 surfinswdif(i) 6395 6507 surf_lsm_h%rad_sw_res(m) = surfins(i) 6396 6508 surf_lsm_h%rad_lw_in(m) = surfinlw(i) 6397 6509 surf_lsm_h%rad_lw_out(m) = surfoutlw(i) 6398 surf_lsm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + surfinlw(i) - surfoutlw(i) 6510 surf_lsm_h%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 6511 surfinlw(i) - surfoutlw(i) 6399 6512 surf_lsm_h%rad_lw_dif(m) = surfinlwdif(i) 6400 6513 surf_lsm_h%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i) 6401 6514 surf_lsm_h%rad_lw_res(m) = surfinl(i) 6402 6515 ! 6403 !-- Northward-facding6516 !-- northward-facding 6404 6517 ELSEIF ( surfl(1,i) == inorth_l ) THEN 6405 6518 surf_lsm_v(0)%rad_sw_in(m) = surfinsw(i) … … 6407 6520 surf_lsm_v(0)%rad_sw_dir(m) = surfinswdir(i) 6408 6521 surf_lsm_v(0)%rad_sw_dif(m) = surfinswdif(i) 6409 surf_lsm_v(0)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - surfinswdif(i) 6522 surf_lsm_v(0)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - & 6523 surfinswdif(i) 6410 6524 surf_lsm_v(0)%rad_sw_res(m) = surfins(i) 6411 6525 surf_lsm_v(0)%rad_lw_in(m) = surfinlw(i) 6412 6526 surf_lsm_v(0)%rad_lw_out(m) = surfoutlw(i) 6413 surf_lsm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + surfinlw(i) - surfoutlw(i) 6527 surf_lsm_v(0)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 6528 surfinlw(i) - surfoutlw(i) 6414 6529 surf_lsm_v(0)%rad_lw_dif(m) = surfinlwdif(i) 6415 6530 surf_lsm_v(0)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i) 6416 6531 surf_lsm_v(0)%rad_lw_res(m) = surfinl(i) 6417 6532 ! 6418 !-- Southward-facding6533 !-- southward-facding 6419 6534 ELSEIF ( surfl(1,i) == isouth_l ) THEN 6420 6535 surf_lsm_v(1)%rad_sw_in(m) = surfinsw(i) … … 6422 6537 surf_lsm_v(1)%rad_sw_dir(m) = surfinswdir(i) 6423 6538 surf_lsm_v(1)%rad_sw_dif(m) = surfinswdif(i) 6424 surf_lsm_v(1)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - surfinswdif(i) 6539 surf_lsm_v(1)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - & 6540 surfinswdif(i) 6425 6541 surf_lsm_v(1)%rad_sw_res(m) = surfins(i) 6426 6542 surf_lsm_v(1)%rad_lw_in(m) = surfinlw(i) 6427 6543 surf_lsm_v(1)%rad_lw_out(m) = surfoutlw(i) 6428 surf_lsm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + surfinlw(i) - surfoutlw(i) 6544 surf_lsm_v(1)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 6545 surfinlw(i) - surfoutlw(i) 6429 6546 surf_lsm_v(1)%rad_lw_dif(m) = surfinlwdif(i) 6430 6547 surf_lsm_v(1)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i) 6431 6548 surf_lsm_v(1)%rad_lw_res(m) = surfinl(i) 6432 6549 ! 6433 !-- Eastward-facing6550 !-- eastward-facing 6434 6551 ELSEIF ( surfl(1,i) == ieast_l ) THEN 6435 6552 surf_lsm_v(2)%rad_sw_in(m) = surfinsw(i) … … 6437 6554 surf_lsm_v(2)%rad_sw_dir(m) = surfinswdir(i) 6438 6555 surf_lsm_v(2)%rad_sw_dif(m) = surfinswdif(i) 6439 surf_lsm_v(2)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - surfinswdif(i) 6556 surf_lsm_v(2)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - & 6557 surfinswdif(i) 6440 6558 surf_lsm_v(2)%rad_sw_res(m) = surfins(i) 6441 6559 surf_lsm_v(2)%rad_lw_in(m) = surfinlw(i) 6442 6560 surf_lsm_v(2)%rad_lw_out(m) = surfoutlw(i) 6443 surf_lsm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + surfinlw(i) - surfoutlw(i) 6561 surf_lsm_v(2)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 6562 surfinlw(i) - surfoutlw(i) 6444 6563 surf_lsm_v(2)%rad_lw_dif(m) = surfinlwdif(i) 6445 6564 surf_lsm_v(2)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i) 6446 6565 surf_lsm_v(2)%rad_lw_res(m) = surfinl(i) 6447 6566 ! 6448 !-- Westward-facing6567 !-- westward-facing 6449 6568 ELSEIF ( surfl(1,i) == iwest_l ) THEN 6450 6569 surf_lsm_v(3)%rad_sw_in(m) = surfinsw(i) … … 6452 6571 surf_lsm_v(3)%rad_sw_dir(m) = surfinswdir(i) 6453 6572 surf_lsm_v(3)%rad_sw_dif(m) = surfinswdif(i) 6454 surf_lsm_v(3)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - surfinswdif(i) 6573 surf_lsm_v(3)%rad_sw_ref(m) = surfinsw(i) - surfinswdir(i) - & 6574 surfinswdif(i) 6455 6575 surf_lsm_v(3)%rad_sw_res(m) = surfins(i) 6456 6576 surf_lsm_v(3)%rad_lw_in(m) = surfinlw(i) 6457 6577 surf_lsm_v(3)%rad_lw_out(m) = surfoutlw(i) 6458 surf_lsm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + surfinlw(i) - surfoutlw(i) 6578 surf_lsm_v(3)%rad_net(m) = surfinsw(i) - surfoutsw(i) + & 6579 surfinlw(i) - surfoutlw(i) 6459 6580 surf_lsm_v(3)%rad_lw_dif(m) = surfinlwdif(i) 6460 6581 surf_lsm_v(3)%rad_lw_ref(m) = surfinlw(i) - surfinlwdif(i) … … 6463 6584 ! 6464 6585 !-- RTM coupling terms 6465 !-- Sum of absorbed SW & LW radiation energy 6466 pabsswl = pabsswl + ( 1.0_wp - albedo_surf(i) ) * surfinsw(i) * facearea(d) 6586 !-- sum of absorbed SW & LW radiation energy 6587 pabsswl = pabsswl + & 6588 (1.0_wp - albedo_surf(i)) * surfinsw(i) * facearea(d) 6467 6589 pabslwl = pabslwl + emiss_surf(i) * surfinlw(i) * facearea(d) 6468 !-- Sum of emitted LW radiation energy6590 !-- sum of emitted LW radiation energy 6469 6591 pemitlwl = pemitlwl + surfemitlwl(i) * facearea(d) 6470 6592 !-- emiss1 6471 pabs_surf_lwdifl = pabs_surf_lwdifl + emiss_surf(i) * facearea(d) * surfinlwdif(i) 6593 pabs_surf_lwdifl = pabs_surf_lwdifl + & 6594 emiss_surf(i) * facearea(d) * surfinlwdif(i) 6472 6595 ENDDO 6473 6596 6474 6597 DO m = 1, surf_usm_h%ns 6475 surf_usm_h%surfhf(m) = surf_usm_h%rad_sw_in(m) + surf_usm_h%rad_lw_in(m) - & 6476 surf_usm_h%rad_sw_out(m) - surf_usm_h%rad_lw_out(m) 6598 surf_usm_h%surfhf(m) = surf_usm_h%rad_sw_in(m) + & 6599 surf_usm_h%rad_lw_in(m) - & 6600 surf_usm_h%rad_sw_out(m) - & 6601 surf_usm_h%rad_lw_out(m) 6477 6602 ENDDO 6478 6603 DO m = 1, surf_lsm_h%ns 6479 surf_lsm_h%surfhf(m) = surf_lsm_h%rad_sw_in(m) + surf_lsm_h%rad_lw_in(m) - & 6480 surf_lsm_h%rad_sw_out(m) - surf_lsm_h%rad_lw_out(m) 6604 surf_lsm_h%surfhf(m) = surf_lsm_h%rad_sw_in(m) + & 6605 surf_lsm_h%rad_lw_in(m) - & 6606 surf_lsm_h%rad_sw_out(m) - & 6607 surf_lsm_h%rad_lw_out(m) 6481 6608 ENDDO 6482 6609 6483 6610 DO l = 0, 3 6484 !-- Urban6611 !-- urban 6485 6612 DO m = 1, surf_usm_v(l)%ns 6486 surf_usm_v(l)%surfhf(m) = surf_usm_v(l)%rad_sw_in(m) + surf_usm_v(l)%rad_lw_in(m) - & 6487 surf_usm_v(l)%rad_sw_out(m) - surf_usm_v(l)%rad_lw_out(m) 6613 surf_usm_v(l)%surfhf(m) = surf_usm_v(l)%rad_sw_in(m) + & 6614 surf_usm_v(l)%rad_lw_in(m) - & 6615 surf_usm_v(l)%rad_sw_out(m) - & 6616 surf_usm_v(l)%rad_lw_out(m) 6488 6617 ENDDO 6489 !-- Land6618 !-- land 6490 6619 DO m = 1, surf_lsm_v(l)%ns 6491 surf_lsm_v(l)%surfhf(m) = surf_lsm_v(l)%rad_sw_in(m) + surf_lsm_v(l)%rad_lw_in(m) - & 6492 surf_lsm_v(l)%rad_sw_out(m) - surf_lsm_v(l)%rad_lw_out(m) 6620 surf_lsm_v(l)%surfhf(m) = surf_lsm_v(l)%rad_sw_in(m) + & 6621 surf_lsm_v(l)%rad_lw_in(m) - & 6622 surf_lsm_v(l)%rad_sw_out(m) - & 6623 surf_lsm_v(l)%rad_lw_out(m) 6493 6624 6494 6625 ENDDO 6495 6626 ENDDO 6496 6627 ! 6497 !-- Gather all rad flux energy in all processors. In order to reduce the number of MPI calls 6498 !-- (to reduce latencies), combine the required quantities in one array, sum it up, and 6499 !-- subsequently re-distribute back to the respective quantities. 6628 !-- gather all rad flux energy in all processors. In order to reduce 6629 !-- the number of MPI calls (to reduce latencies), combine the required 6630 !-- quantities in one array, sum it up, and subsequently re-distribute 6631 !-- back to the respective quantities. 6500 6632 #if defined( __parallel ) 6501 6633 combine_allreduce_l(1) = pinswl … … 6507 6639 combine_allreduce_l(7) = pabs_pc_lwdifl 6508 6640 6509 CALL MPI_ALLREDUCE( combine_allreduce_l, combine_allreduce, SIZE( combine_allreduce ), & 6510 MPI_REAL, MPI_SUM, comm2d, ierr ) 6641 CALL MPI_ALLREDUCE( combine_allreduce_l, & 6642 combine_allreduce, & 6643 SIZE( combine_allreduce ), & 6644 MPI_REAL, & 6645 MPI_SUM, & 6646 comm2d, & 6647 ierr ) 6511 6648 6512 6649 pinsw = combine_allreduce(1) … … 6527 6664 #endif 6528 6665 ! 6529 !-- Calculate the effective radiation surface parameters based on the parameterizations in6530 !-- Krc et al. 20206531 6532 !- - (1) Albedo Eq. * in Krc et al. 20206666 !-- Calculate the effective radiation surface parameters based on 6667 !-- the parameterizations in Krc et al. 2020 6668 6669 !- (1) albedo Eq. * in Krc et al. 2020 6533 6670 IF ( pinsw /= 0.0_wp ) albedo_urb = ( pinsw - pabssw ) / pinsw 6534 6671 6535 !- - (2) Emmsivity Eq. * in Krc et al. 20206536 !- - Emissivity_urb weighted average of surface and PC emissivity = absorbed LW in6537 !- -[surfaces + plant canopy] / pinlw6538 emissivity_urb = ( pabs_surf_lwdif + pabs_pc_lwdif) / pinlw6539 6540 !- - (3) Temperature6541 !- - Effective horizontal area to account for the effect of vertical surfaces,6542 !- -Eq. * in Krc et al. 20206672 !- (2) emmsivity Eq. * in Krc et al. 2020 6673 !- emissivity_urb weighted average of surface and PC emissivity 6674 !- = absorbed LW in [surfaces + plant canopy] / pinlw 6675 emissivity_urb = (pabs_surf_lwdif + pabs_pc_lwdif) / pinlw 6676 6677 !- (3) temperature 6678 !- effective horizontal area to account for the effect of vertical 6679 !- surfaces, Eq. * in Krc et al. 2020 6543 6680 area_norm = pinlw / rad_lw_in_diff(nyn,nxl) 6544 !- - Temperature, Eq. * in Krc et al. 20206545 t_rad_urb = ( ( pemitlw - pabslw + emissivity_urb * pinlw ) /&6546 ( emissivity_urb * sigma_sb * area_norm) )**0.25_wp6681 !- temperature, Eq. * in Krc et al. 2020 6682 t_rad_urb = ( (pemitlw - pabslw + emissivity_urb * pinlw) / & 6683 (emissivity_urb * sigma_sb * area_norm) )**0.25_wp 6547 6684 6548 6685 IF ( debug_output_timestep ) CALL debug_message( 'radiation_interaction', 'end' ) 6549 6686 6550 6687 6551 CONTAINS6552 6553 !------------------------------------------------------------------------------ --------------------!6688 CONTAINS 6689 6690 !------------------------------------------------------------------------------! 6554 6691 !> Calculates radiation absorbed by box with given size and LAD. 6555 6692 !> 6556 !> Simulates resol**2 rays (by equally spacing a bounding horizontal square containing all possible 6557 !> rays that would cross the box) and calculates average transparency per ray. Returns fraction of 6558 !> absorbed radiation flux and area for which this fraction is effective. 6559 !--------------------------------------------------------------------------------------------------! 6560 PURE SUBROUTINE box_absorb( boxsize, resol, dens, uvec, area, absorb ) 6561 IMPLICIT NONE 6562 6563 INTEGER(iwp) :: i, j !< 6564 6565 INTEGER(iwp), INTENT(in) :: resol !< No. of rays in x and y dimensions 6566 6567 REAL(wp) :: xshift, yshift, xmin, xmax, ymin, ymax, xorig, yorig, dx1, dy1, dz1, dx2, dy2, & 6568 dz2, crdist, transp !< 6569 6570 REAL(wp), INTENT(IN) :: dens !< box density (e.g. Leaf Area Density) 6571 REAL(wp), INTENT(OUT) :: area, & !< horizontal area for flux absorbtion 6572 absorb !< fraction of absorbed flux 6573 6574 6575 6576 REAL(wp), DIMENSION(3), INTENT(in) :: boxsize, & !< z, y, x size of box in m 6577 uvec !< z, y, x unit vector of incoming flux 6578 6579 6580 xshift = uvec(3) / uvec(1) * boxsize(1) 6581 xmin = MIN( 0._wp, -xshift ) 6582 xmax = boxsize(3) + MAX( 0._wp, -xshift ) 6583 yshift = uvec(2) / uvec(1) * boxsize(1) 6584 ymin = MIN( 0._wp, -yshift ) 6585 ymax = boxsize(2) + MAX( 0._wp, -yshift ) 6586 6587 transp = 0._wp 6588 DO i = 1, resol 6589 xorig = xmin + ( xmax - xmin ) * ( i - .5_wp ) / resol 6590 DO j = 1, resol 6591 yorig = ymin + ( ymax - ymin ) * ( j - .5_wp ) / resol 6592 6593 dz1 = 0._wp 6594 dz2 = boxsize(1) / uvec(1) 6595 6596 IF ( uvec(2) > 0._wp ) THEN 6597 dy1 = - yorig / uvec(2) !< Crossing with y=0 6598 dy2 = ( boxsize(2) - yorig ) / uvec(2) !< Crossing with y=boxsize(2) 6599 ELSE !uvec(2)==0 6600 dy1 = - HUGE( 1._wp ) 6601 dy2 = HUGE( 1._wp ) 6602 ENDIF 6603 6604 IF ( uvec(3) > 0._wp ) THEN 6605 dx1 = -xorig / uvec(3) !< Crossing with x=0 6606 dx2 = (boxsize(3)-xorig) / uvec(3) !< Crossing with x=boxsize(3) 6607 ELSE !uvec(3)==0 6608 dx1 = - HUGE( 1._wp ) 6609 dx2 = HUGE( 1._wp ) 6610 ENDIF 6611 6612 crdist = MAX( 0._wp, ( MIN( dz2, dy2, dx2 ) - MAX( dz1, dy1, dx1 ) ) ) 6613 transp = transp + EXP( - ext_coef * dens * crdist ) 6693 !> Simulates resol**2 rays (by equally spacing a bounding horizontal square 6694 !> conatining all possible rays that would cross the box) and calculates 6695 !> average transparency per ray. Returns fraction of absorbed radiation flux 6696 !> and area for which this fraction is effective. 6697 !------------------------------------------------------------------------------! 6698 PURE SUBROUTINE box_absorb(boxsize, resol, dens, uvec, area, absorb) 6699 IMPLICIT NONE 6700 6701 REAL(wp), DIMENSION(3), INTENT(in) :: & 6702 boxsize, & !< z, y, x size of box in m 6703 uvec !< z, y, x unit vector of incoming flux 6704 INTEGER(iwp), INTENT(in) :: & 6705 resol !< No. of rays in x and y dimensions 6706 REAL(wp), INTENT(in) :: & 6707 dens !< box density (e.g. Leaf Area Density) 6708 REAL(wp), INTENT(out) :: & 6709 area, & !< horizontal area for flux absorbtion 6710 absorb !< fraction of absorbed flux 6711 REAL(wp) :: & 6712 xshift, yshift, & 6713 xmin, xmax, ymin, ymax, & 6714 xorig, yorig, & 6715 dx1, dy1, dz1, dx2, dy2, dz2, & 6716 crdist, & 6717 transp 6718 INTEGER(iwp) :: & 6719 i, j 6720 6721 xshift = uvec(3) / uvec(1) * boxsize(1) 6722 xmin = min(0._wp, -xshift) 6723 xmax = boxsize(3) + max(0._wp, -xshift) 6724 yshift = uvec(2) / uvec(1) * boxsize(1) 6725 ymin = min(0._wp, -yshift) 6726 ymax = boxsize(2) + max(0._wp, -yshift) 6727 6728 transp = 0._wp 6729 DO i = 1, resol 6730 xorig = xmin + (xmax-xmin) * (i-.5_wp) / resol 6731 DO j = 1, resol 6732 yorig = ymin + (ymax-ymin) * (j-.5_wp) / resol 6733 6734 dz1 = 0._wp 6735 dz2 = boxsize(1)/uvec(1) 6736 6737 IF ( uvec(2) > 0._wp ) THEN 6738 dy1 = -yorig / uvec(2) !< crossing with y=0 6739 dy2 = (boxsize(2)-yorig) / uvec(2) !< crossing with y=boxsize(2) 6740 ELSE !uvec(2)==0 6741 dy1 = -huge(1._wp) 6742 dy2 = huge(1._wp) 6743 ENDIF 6744 6745 IF ( uvec(3) > 0._wp ) THEN 6746 dx1 = -xorig / uvec(3) !< crossing with x=0 6747 dx2 = (boxsize(3)-xorig) / uvec(3) !< crossing with x=boxsize(3) 6748 ELSE !uvec(3)==0 6749 dx1 = -huge(1._wp) 6750 dx2 = huge(1._wp) 6751 ENDIF 6752 6753 crdist = max(0._wp, (min(dz2, dy2, dx2) - max(dz1, dy1, dx1))) 6754 transp = transp + exp(-ext_coef * dens * crdist) 6755 ENDDO 6614 6756 ENDDO 6615 ENDDO 6616 transp = transp / resol**2 6617 area = ( boxsize(3) + xshift ) * ( boxsize(2) + yshift ) 6618 absorb = 1._wp - transp 6619 6620 END SUBROUTINE box_absorb 6621 6622 !--------------------------------------------------------------------------------------------------! 6757 transp = transp / resol**2 6758 area = (boxsize(3)+xshift)*(boxsize(2)+yshift) 6759 absorb = 1._wp - transp 6760 6761 END SUBROUTINE box_absorb 6762 6763 !------------------------------------------------------------------------------! 6623 6764 ! Description: 6624 6765 ! ------------ 6625 !> This subroutine splits direct and diffuse dw radiation for RTM processing. It sould not be 6626 !> called in case the radiation model already does it. It follows Boland, Ridley & Brown (2008) 6627 !--------------------------------------------------------------------------------------------------! 6628 SUBROUTINE calc_diffusion_radiation 6629 6630 USE palm_date_time_mod, & 6631 ONLY: seconds_per_day 6632 6633 INTEGER(iwp) :: i !< grid index x-direction 6634 INTEGER(iwp) :: j !< grid index y-direction 6635 INTEGER(iwp) :: days_per_year !< days in the current year 6636 6637 REAL(wp), PARAMETER :: lowest_solarUp = 0.1_wp !< limit the sun elevation to protect stability of the calculation 6638 6639 REAL(wp) :: clearnessIndex !< clearness index 6640 REAL(wp) :: corrected_solarUp !< corrected solar up radiation 6641 REAL(wp) :: diff_frac !< diffusion fraction of the radiation 6642 REAL(wp) :: etr !< extraterestrial radiation 6643 REAL(wp) :: horizontalETR !< horizontal extraterestrial radiation 6644 REAL(wp) :: second_of_year !< current second of the year 6645 REAL(wp) :: year_angle !< angle 6646 6647 ! 6648 !-- Calculate current day and time based on the initial values and simulation time 6649 CALL get_date_time( time_since_reference_point, second_of_year = second_of_year, & 6650 days_per_year = days_per_year ) 6651 year_angle = second_of_year / ( REAL( days_per_year, KIND = wp ) * seconds_per_day ) & 6652 * 2.0_wp * pi 6653 6654 etr = solar_constant * ( 1.00011_wp + 0.034221_wp * COS( year_angle ) + & 6655 0.001280_wp * SIN( year_angle ) + & 6656 0.000719_wp * COS( 2.0_wp * year_angle ) + & 6657 0.000077_wp * SIN( 2.0_wp * year_angle ) ) 6658 6659 ! 6660 !-- Under a very low angle, we keep extraterestrial radiation at the last small value, therefore 6661 !-- the clearness index will be pushed towards 0 while keeping full continuity. 6662 IF ( cos_zenith <= lowest_solarUp ) THEN 6663 corrected_solarUp = lowest_solarUp 6664 ELSE 6665 corrected_solarUp = cos_zenith 6666 ENDIF 6667 6668 horizontalETR = etr * corrected_solarUp 6669 6670 DO i = nxl, nxr 6671 DO j = nys, nyn 6672 clearnessIndex = rad_sw_in(0,j,i) / horizontalETR 6673 diff_frac = 1.0_wp / ( 1.0_wp + EXP( - 5.0033_wp + 8.6025_wp * clearnessIndex ) ) 6674 rad_sw_in_diff(j,i) = rad_sw_in(0,j,i) * diff_frac 6675 rad_sw_in_dir(j,i) = rad_sw_in(0,j,i) * ( 1.0_wp - diff_frac ) 6676 rad_lw_in_diff(j,i) = rad_lw_in(0,j,i) 6766 !> This subroutine splits direct and diffusion dw radiation for RTM processing. 6767 !> It sould not be called in case the radiation model already does it 6768 !> It follows Boland, Ridley & Brown (2008) 6769 !------------------------------------------------------------------------------! 6770 SUBROUTINE calc_diffusion_radiation 6771 6772 USE palm_date_time_mod, & 6773 ONLY: seconds_per_day 6774 6775 INTEGER(iwp) :: i !< grid index x-direction 6776 INTEGER(iwp) :: j !< grid index y-direction 6777 INTEGER(iwp) :: days_per_year !< days in the current year 6778 6779 REAL(wp) :: clearnessIndex !< clearness index 6780 REAL(wp) :: corrected_solarUp !< corrected solar up radiation 6781 REAL(wp) :: diff_frac !< diffusion fraction of the radiation 6782 REAL(wp) :: etr !< extraterestrial radiation 6783 REAL(wp) :: horizontalETR !< horizontal extraterestrial radiation 6784 REAL(wp), PARAMETER :: lowest_solarUp = 0.1_wp !< limit the sun elevation to protect stability of the calculation 6785 REAL(wp) :: second_of_year !< current second of the year 6786 REAL(wp) :: year_angle !< angle 6787 6788 ! 6789 !-- Calculate current day and time based on the initial values and simulation time 6790 CALL get_date_time( time_since_reference_point, & 6791 second_of_year = second_of_year, & 6792 days_per_year = days_per_year ) 6793 year_angle = second_of_year / ( REAL( days_per_year, KIND=wp ) * seconds_per_day ) & 6794 * 2.0_wp * pi 6795 6796 etr = solar_constant * (1.00011_wp + & 6797 0.034221_wp * cos(year_angle) + & 6798 0.001280_wp * sin(year_angle) + & 6799 0.000719_wp * cos(2.0_wp * year_angle) + & 6800 0.000077_wp * sin(2.0_wp * year_angle)) 6801 6802 !-- 6803 !-- Under a very low angle, we keep extraterestrial radiation at 6804 !-- the last small value, therefore the clearness index will be pushed 6805 !-- towards 0 while keeping full continuity. 6806 IF ( cos_zenith <= lowest_solarUp ) THEN 6807 corrected_solarUp = lowest_solarUp 6808 ELSE 6809 corrected_solarUp = cos_zenith 6810 ENDIF 6811 6812 horizontalETR = etr * corrected_solarUp 6813 6814 DO i = nxl, nxr 6815 DO j = nys, nyn 6816 clearnessIndex = rad_sw_in(0,j,i) / horizontalETR 6817 diff_frac = 1.0_wp / (1.0_wp + exp(-5.0033_wp + 8.6025_wp * clearnessIndex)) 6818 rad_sw_in_diff(j,i) = rad_sw_in(0,j,i) * diff_frac 6819 rad_sw_in_dir(j,i) = rad_sw_in(0,j,i) * (1.0_wp - diff_frac) 6820 rad_lw_in_diff(j,i) = rad_lw_in(0,j,i) 6821 ENDDO 6677 6822 ENDDO 6678 ENDDO 6679 6680 END SUBROUTINE calc_diffusion_radiation 6681 6682 !--------------------------------------------------------------------------------------------------! 6823 6824 END SUBROUTINE calc_diffusion_radiation 6825 6826 !------------------------------------------------------------------------------! 6683 6827 ! Description: 6684 6828 ! ------------ 6685 !> Print consecutive radiative extremes if requested to trace early radiation interaction 6686 !> instabilities. 6687 !--------------------------------------------------------------------------------------------------! 6688 SUBROUTINE radiation_print_debug_surf( description, values, step ) 6689 6690 CHARACTER(LEN=*), INTENT(in) :: description !< 6691 CHARACTER(LEN=50) :: location !< 6692 CHARACTER(LEN=1024) :: debug_string !< 6693 6694 INTEGER :: isurf !< 6695 6696 INTEGER(iwp), INTENT(in), OPTIONAL :: step !< 6697 6698 REAL(wp) :: x !< 6699 6700 REAL(wp), DIMENSION(:), INTENT(in) :: values !< 6701 6702 6703 isurf = MAXLOC( values, DIM = 1 ) 6704 x = values(isurf) 6705 IF ( x < trace_fluxes_above ) RETURN 6706 6707 IF ( PRESENT( step ) ) THEN 6708 WRITE( location, '(A," #",I0)' ) description, step 6709 ELSE 6710 location = description 6711 ENDIF 6712 6713 WRITE( debug_string, '("Maximum of ",A50," = ",F12.1," at coords i=",I4,", j=",I4,", ' // & 6714 'k=",I4,", d=",I1,". Alb=",F7.3,", emis=",F7.3)' ) & 6715 location, x, surfl(ix,isurf), surfl(iy,isurf), surfl(iz,isurf), surfl(id,isurf), & 6716 albedo_surf(isurf), emiss_surf(isurf) 6717 CALL debug_message( debug_string, 'info' ) 6718 6719 END SUBROUTINE 6720 6721 !--------------------------------------------------------------------------------------------------! 6829 !> Print consecutive radiative extremes if requested to trace early radiation 6830 !> interaction instabilities. 6831 !------------------------------------------------------------------------------! 6832 SUBROUTINE radiation_print_debug_surf( description, values, step ) 6833 6834 CHARACTER (LEN=*), INTENT(in) :: description 6835 REAL(wp), DIMENSION(:), INTENT(in) :: values 6836 INTEGER(iwp), INTENT(in), OPTIONAL :: step 6837 6838 CHARACTER (LEN=50) :: location 6839 CHARACTER (LEN=1024) :: debug_string 6840 INTEGER :: isurf 6841 REAL(wp) :: x 6842 6843 isurf = MAXLOC( values, DIM=1 ) 6844 x = values(isurf) 6845 IF ( x < trace_fluxes_above ) RETURN 6846 6847 IF ( PRESENT( step ) ) THEN 6848 WRITE( location, '(A," #",I0)' ) description, step 6849 ELSE 6850 location = description 6851 ENDIF 6852 6853 WRITE( debug_string, '("Maximum of ",A50," = ",F12.1," at coords ' // & 6854 'i=",I4,", j=",I4,", k=",I4,", d=",I1,". ' // & 6855 'Alb=",F7.3,", emis=",F7.3)' ) & 6856 location, x, surfl(ix,isurf), surfl(iy,isurf), & 6857 surfl(iz,isurf), surfl(id,isurf), albedo_surf(isurf), & 6858 emiss_surf(isurf) 6859 CALL debug_message( debug_string, 'info' ) 6860 6861 END SUBROUTINE 6862 6863 SUBROUTINE radiation_print_debug_pcb( description, values, step ) 6864 6865 CHARACTER (LEN=*), INTENT(in) :: description 6866 REAL(wp), DIMENSION(:), INTENT(in) :: values 6867 INTEGER(iwp), INTENT(in), OPTIONAL :: step 6868 6869 CHARACTER (LEN=50) :: location 6870 CHARACTER (LEN=1024) :: debug_string 6871 INTEGER :: ipcb 6872 REAL(wp) :: x 6873 6874 IF ( npcbl <= 0 ) RETURN 6875 ipcb = MAXLOC( values, DIM=1 ) 6876 x = values(ipcb) / (dx*dy*dz(1)) 6877 IF ( x < trace_fluxes_above ) RETURN 6878 6879 IF ( PRESENT( step ) ) THEN 6880 WRITE( location, '(A," #",I0)' ) description, step 6881 ELSE 6882 location = description 6883 ENDIF 6884 6885 WRITE( debug_string, '("Maximum of ",A50," = ",F12.1," at coords ' // & 6886 'i=",I4,", j=",I4,", k=",I4)' ) & 6887 location, x, pcbl(ix,ipcb), pcbl(iy,ipcb), pcbl(iz,ipcb) 6888 CALL debug_message( debug_string, 'info' ) 6889 6890 END SUBROUTINE 6891 6892 SUBROUTINE radiation_print_debug_horz( description, values, step ) 6893 6894 CHARACTER (LEN=*), INTENT(in) :: description 6895 REAL(wp), DIMENSION(:,:), INTENT(in) :: values 6896 INTEGER(iwp), INTENT(in), OPTIONAL :: step 6897 6898 CHARACTER (LEN=50) :: location 6899 CHARACTER (LEN=1024) :: debug_string 6900 INTEGER, DIMENSION(2) :: ji 6901 REAL(wp) :: x 6902 6903 ji = MAXLOC( values ) 6904 x = values(ji(1),ji(2)) 6905 IF ( x < trace_fluxes_above ) RETURN 6906 6907 IF ( PRESENT( step ) ) THEN 6908 WRITE( location, '(A," #",I0)' ) description, step 6909 ELSE 6910 location = description 6911 ENDIF 6912 6913 WRITE( debug_string, '("Maximum of ",A50," = ",F12.1," at coords ' // & 6914 'i=",I4,", j=",I4)' ) & 6915 location, x, ji(2), ji(1) 6916 CALL debug_message( debug_string, 'info' ) 6917 6918 END SUBROUTINE 6919 6920 END SUBROUTINE radiation_interaction 6921 6922 !------------------------------------------------------------------------------! 6722 6923 ! Description: 6723 6924 ! ------------ 6724 !> Todo: Missing subroutine description 6725 !--------------------------------------------------------------------------------------------------! 6726 SUBROUTINE radiation_print_debug_pcb( description, values, step ) 6727 6728 CHARACTER (LEN=*), INTENT(in) :: description !< 6729 CHARACTER (LEN=50) :: location !< 6730 CHARACTER (LEN=1024) :: debug_string !< 6731 6732 INTEGER :: ipcb !< 6733 6734 INTEGER(iwp), INTENT(in), OPTIONAL :: step !< 6735 6736 REAL(wp) :: x !< 6737 6738 REAL(wp), DIMENSION(:), INTENT(in) :: values !< 6739 6740 IF ( npcbl <= 0 ) RETURN 6741 ipcb = MAXLOC( values, DIM = 1 ) 6742 x = values(ipcb) / ( dx * dy * dz(1) ) 6743 IF ( x < trace_fluxes_above ) RETURN 6744 6745 IF ( PRESENT( step ) ) THEN 6746 WRITE( location, '(A," #",I0)' ) description, step 6747 ELSE 6748 location = description 6749 ENDIF 6750 6751 WRITE( debug_string, '("Maximum of ",A50," = ",F12.1," at coords i=",I4,", j=",I4,", k=",I4)') & 6752 location, x, pcbl(ix,ipcb), pcbl(iy,ipcb), pcbl(iz,ipcb) 6753 CALL debug_message( debug_string, 'info' ) 6754 6755 END SUBROUTINE 6756 6757 !--------------------------------------------------------------------------------------------------! 6758 ! Description: 6759 ! ------------ 6760 !> Todo: Missing subroutine description 6761 !--------------------------------------------------------------------------------------------------! 6762 SUBROUTINE radiation_print_debug_horz( description, values, step ) 6763 6764 CHARACTER (LEN=*), INTENT(in) :: description !< 6765 CHARACTER (LEN=50) :: location !< 6766 CHARACTER (LEN=1024) :: debug_string !< 6767 6768 INTEGER, DIMENSION(2) :: ji !< 6769 6770 INTEGER(iwp), INTENT(in), OPTIONAL :: step !< 6771 6772 REAL(wp) :: x !< 6773 6774 REAL(wp), DIMENSION(:,:), INTENT(in) :: values !< 6775 6776 6777 6778 6779 6780 6781 6782 ji = MAXLOC( values ) 6783 x = values(ji(1),ji(2)) 6784 IF ( x < trace_fluxes_above ) RETURN 6785 6786 IF ( PRESENT( step ) ) THEN 6787 WRITE( location, '(A," #",I0)' ) description, step 6788 ELSE 6789 location = description 6790 ENDIF 6791 6792 WRITE( debug_string, '("Maximum of ",A50," = ",F12.1," at coords i=",I4,", j=",I4)' ) & 6793 location, x, ji(2), ji(1) 6794 CALL debug_message( debug_string, 'info' ) 6795 6796 END SUBROUTINE 6797 6798 END SUBROUTINE radiation_interaction 6799 6800 !--------------------------------------------------------------------------------------------------! 6801 ! Description: 6802 ! ------------ 6803 !> This subroutine initializes structures needed for Radiative Transfer Model (RTM). This model 6804 !> calculates transformation processes of the radiation inside urban and land canopy layer. The 6805 !> module includes also the interaction of the radiation with the resolved plant canopy. 6806 !--------------------------------------------------------------------------------------------------! 6807 SUBROUTINE radiation_interaction_init 6808 6809 USE control_parameters, & 6810 ONLY: dz_stretch_level_start 6811 6812 USE plant_canopy_model_mod, & 6813 ONLY: lad_s 6814 6815 IMPLICIT NONE 6816 6817 INTEGER(iwp) :: i, j, k, l, m, d !< 6818 INTEGER(iwp) :: k_topo !< vertical index indicating topography top for given (j,i) 6819 INTEGER(iwp) :: isurf, ipcgb, imrt !< 6820 INTEGER(iwp) :: nzptl, nzubl, nzutl !< 6821 6822 REAL(wp) :: mrl !< 6823 REAL(wp), PARAMETER :: eps_lad = 1E-10_wp !< minimum considered nonzero 6925 !> This subroutine initializes structures needed for Radiative Transfer 6926 !> Model (RTM). This model calculates transformation processes of the 6927 !> radiation inside urban and land canopy layer. The module includes also 6928 !> the interaction of the radiation with the resolved plant canopy. 6929 !> 6930 !------------------------------------------------------------------------------! 6931 SUBROUTINE radiation_interaction_init 6932 6933 USE control_parameters, & 6934 ONLY: dz_stretch_level_start 6935 6936 USE plant_canopy_model_mod, & 6937 ONLY: lad_s 6938 6939 IMPLICIT NONE 6940 6941 INTEGER(iwp) :: i, j, k, l, m, d 6942 INTEGER(iwp) :: k_topo !< vertical index indicating 6943 !< topography top for given (j,i) 6944 INTEGER(iwp) :: isurf, ipcgb, imrt 6945 INTEGER(iwp) :: nzptl, nzubl, nzutl 6946 REAL(wp) :: mrl 6947 REAL(wp), PARAMETER :: eps_lad = 1E-10_wp !< minimum considered nonzero 6824 6948 #if defined( __parallel ) 6825 INTEGER(iwp) :: minfo !< MPI RMA window info handle6826 INTEGER(iwp), DIMENSION(:), POINTER, SAVE :: gridsurf_rma !< fortran pointer, but lower bounds are 16827 TYPE(c_ptr) :: gridsurf_rma_p !< allocated c pointer6949 INTEGER(iwp), DIMENSION(:), POINTER, SAVE :: gridsurf_rma !< fortran pointer, but lower bounds are 1 6950 TYPE(c_ptr) :: gridsurf_rma_p !< allocated c pointer 6951 INTEGER(iwp) :: minfo !< MPI RMA window info handle 6828 6952 #endif 6829 6953 6830 6954 ! 6831 !-- Precalculate face areas for different face directions using normal vector 6832 DO d = 0, nsurf_type 6833 facearea(d) = 1._wp 6834 IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx 6835 IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy 6836 IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz(1) 6837 ENDDO 6838 ! 6839 !-- Find nz_urban_b, nz_urban_t, nz_urban via wall_flag_0 array (nzb_s_inner will be removed later). 6840 !-- The following contruct finds the lowest / largest index for any upward-facing wall (see bit 12). 6841 nzubl = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) ) 6842 nzutl = MAXVAL( topo_top_ind(nys:nyn,nxl:nxr,0) ) 6843 6844 nzubl = MAX( nzubl, nzb ) 6845 6846 IF ( plant_canopy ) THEN 6847 !-- Allocate needed arrays 6848 ALLOCATE( pct(nys:nyn,nxl:nxr) ) 6849 ALLOCATE( pch(nys:nyn,nxl:nxr) ) 6850 6851 !-- Calculate plant canopy height 6852 npcbl = 0 6853 pct = 0 6854 pch = 0 6855 DO i = nxl, nxr 6856 DO j = nys, nyn 6857 ! 6858 !-- Find topography top index 6859 k_topo = topo_top_ind(j,i,0) 6860 6861 DO k = nzt+1, 1, -1 6862 IF ( lad_s(k,j,i) > eps_lad ) THEN 6863 !-- We are at the top of the pcs 6864 pct(j,i) = k + k_topo 6865 pch(j,i) = k 6866 npcbl = npcbl + 1 + COUNT( lad_s(1:k-1,j,i) > eps_lad ) 6867 EXIT 6955 !-- precalculate face areas for different face directions using normal vector 6956 DO d = 0, nsurf_type 6957 facearea(d) = 1._wp 6958 IF ( idir(d) == 0 ) facearea(d) = facearea(d) * dx 6959 IF ( jdir(d) == 0 ) facearea(d) = facearea(d) * dy 6960 IF ( kdir(d) == 0 ) facearea(d) = facearea(d) * dz(1) 6961 ENDDO 6962 ! 6963 !-- Find nz_urban_b, nz_urban_t, nz_urban via wall_flag_0 array (nzb_s_inner will be 6964 !-- removed later). The following contruct finds the lowest / largest index 6965 !-- for any upward-facing wall (see bit 12). 6966 nzubl = MINVAL( topo_top_ind(nys:nyn,nxl:nxr,0) ) 6967 nzutl = MAXVAL( topo_top_ind(nys:nyn,nxl:nxr,0) ) 6968 6969 nzubl = MAX( nzubl, nzb ) 6970 6971 IF ( plant_canopy ) THEN 6972 !-- allocate needed arrays 6973 ALLOCATE( pct(nys:nyn,nxl:nxr) ) 6974 ALLOCATE( pch(nys:nyn,nxl:nxr) ) 6975 6976 !-- calculate plant canopy height 6977 npcbl = 0 6978 pct = 0 6979 pch = 0 6980 DO i = nxl, nxr 6981 DO j = nys, nyn 6982 ! 6983 !-- Find topography top index 6984 k_topo = topo_top_ind(j,i,0) 6985 6986 DO k = nzt+1, 1, -1 6987 IF ( lad_s(k,j,i) > eps_lad ) THEN 6988 !-- we are at the top of the pcs 6989 pct(j,i) = k + k_topo 6990 pch(j,i) = k 6991 npcbl = npcbl + 1 + COUNT(lad_s(1:k-1,j,i) > eps_lad) 6992 EXIT 6993 ENDIF 6994 ENDDO 6995 ENDDO 6996 ENDDO 6997 6998 nzutl = MAX( nzutl, MAXVAL( pct ) ) 6999 nzptl = MAXVAL( pct ) 7000 7001 prototype_lad = MAXVAL( lad_s ) * .9_wp !< better be *1.0 if lad is either 0 or maxval(lad) everywhere 7002 IF ( prototype_lad <= 0._wp ) prototype_lad = .3_wp 7003 !WRITE(message_string, '(a,f6.3)') 'Precomputing effective box optical ' & 7004 ! // 'depth using prototype leaf area density = ', prototype_lad 7005 !CALL message('radiation_interaction_init', 'PA0520', 0, 0, -1, 6, 0) 7006 ENDIF 7007 7008 nzutl = MIN( nzutl + nzut_free, nzt ) 7009 7010 #if defined( __parallel ) 7011 CALL MPI_AllReduce(nzubl, nz_urban_b, 1, MPI_INTEGER, MPI_MIN, comm2d, ierr ) 7012 IF ( ierr /= 0 ) THEN 7013 WRITE(9,*) 'Error MPI_AllReduce11:', ierr, nzubl, nz_urban_b 7014 FLUSH(9) 7015 ENDIF 7016 CALL MPI_AllReduce(nzutl, nz_urban_t, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr ) 7017 IF ( ierr /= 0 ) THEN 7018 WRITE(9,*) 'Error MPI_AllReduce12:', ierr, nzutl, nz_urban_t 7019 FLUSH(9) 7020 ENDIF 7021 CALL MPI_AllReduce(nzptl, nz_plant_t, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr ) 7022 IF ( ierr /= 0 ) THEN 7023 WRITE(9,*) 'Error MPI_AllReduce13:', ierr, nzptl, nz_plant_t 7024 FLUSH(9) 7025 ENDIF 7026 #else 7027 nz_urban_b = nzubl 7028 nz_urban_t = nzutl 7029 nz_plant_t = nzptl 7030 #endif 7031 ! 7032 !-- Stretching (non-uniform grid spacing) is not considered in the radiation 7033 !-- model. Therefore, vertical stretching has to be applied above the area 7034 !-- where the parts of the radiation model which assume constant grid spacing 7035 !-- are active. ABS (...) is required because the default value of 7036 !-- dz_stretch_level_start is -9999999.9_wp (negative). 7037 IF ( ABS( dz_stretch_level_start(1) ) <= zw(nz_urban_t) ) THEN 7038 WRITE( message_string, * ) 'The lowest level where vertical ', & 7039 'stretching is applied have to be ', & 7040 'greater than ', zw(nz_urban_t) 7041 CALL message( 'radiation_interaction_init', 'PA0496', 1, 2, 0, 6, 0 ) 7042 ENDIF 7043 ! 7044 !-- global number of urban and plant layers 7045 nz_urban = nz_urban_t - nz_urban_b + 1 7046 nz_plant = nz_plant_t - nz_urban_b + 1 7047 ! 7048 !-- check max_raytracing_dist relative to urban surface layer height 7049 mrl = 2.0_wp * nz_urban * dz(1) 7050 !-- set max_raytracing_dist to double the urban surface layer height, if not set 7051 IF ( max_raytracing_dist == -999.0_wp ) THEN 7052 max_raytracing_dist = mrl 7053 ENDIF 7054 !-- check if max_raytracing_dist set too low (here we only warn the user. Other 7055 ! option is to correct the value again to double the urban surface layer height) 7056 IF ( max_raytracing_dist < mrl ) THEN 7057 WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist is set less than ' // & 7058 'double the urban surface layer height, i.e. ', mrl 7059 CALL message('radiation_interaction_init', 'PA0521', 0, 0, 0, 6, 0 ) 7060 ENDIF 7061 ! IF ( max_raytracing_dist <= mrl ) THEN 7062 ! IF ( max_raytracing_dist /= -999.0_wp ) THEN 7063 ! !-- max_raytracing_dist too low 7064 ! WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist too low, ' & 7065 ! // 'override to value ', mrl 7066 ! CALL message('radiation_interaction_init', 'PA0521', 0, 0, -1, 6, 0) 7067 ! ENDIF 7068 ! max_raytracing_dist = mrl 7069 ! ENDIF 7070 ! 7071 !-- allocate urban surfaces grid 7072 !-- calc number of surfaces in local proc 7073 IF ( debug_output ) CALL debug_message( 'calculation of indices for surfaces', 'info' ) 7074 7075 nsurfl = 0 7076 ! 7077 !-- Number of horizontal surfaces including land- and roof surfaces in both USM and LSM. Note that 7078 !-- All horizontal surface elements are already counted in surface_mod. 7079 startland = 1 7080 nsurfl = surf_usm_h%ns + surf_lsm_h%ns 7081 endland = nsurfl 7082 nlands = endland - startland + 1 7083 7084 ! 7085 !-- Number of vertical surfaces in both USM and LSM. Note that all vertical surface elements are 7086 !-- already counted in surface_mod. 7087 startwall = nsurfl+1 7088 DO i = 0,3 7089 nsurfl = nsurfl + surf_usm_v(i)%ns + surf_lsm_v(i)%ns 7090 ENDDO 7091 endwall = nsurfl 7092 nwalls = endwall - startwall + 1 7093 dirstart = (/ startland, startwall, startwall, startwall, startwall /) 7094 dirend = (/ endland, endwall, endwall, endwall, endwall /) 7095 7096 !-- fill gridpcbl and pcbl 7097 IF ( npcbl > 0 ) THEN 7098 ALLOCATE( pcbl(iz:ix, 1:npcbl) ) 7099 ALLOCATE( gridpcbl(nz_urban_b:nz_plant_t,nys:nyn,nxl:nxr) ) 7100 pcbl = -1 7101 gridpcbl(:,:,:) = 0 7102 ipcgb = 0 7103 DO i = nxl, nxr 7104 DO j = nys, nyn 7105 ! 7106 !-- Find topography top index 7107 k_topo = topo_top_ind(j,i,0) 7108 7109 DO k = k_topo + 1, pct(j,i) 7110 IF ( lad_s(k-k_topo,j,i) > eps_lad ) THEN 7111 ipcgb = ipcgb + 1 7112 gridpcbl(k,j,i) = ipcgb 7113 pcbl(:,ipcgb) = (/ k, j, i /) 7114 ENDIF 7115 ENDDO 7116 ENDDO 7117 ENDDO 7118 ALLOCATE( pcbinsw( 1:npcbl ) ) 7119 ALLOCATE( pcbinswdir( 1:npcbl ) ) 7120 ALLOCATE( pcbinswdif( 1:npcbl ) ) 7121 ALLOCATE( pcbinlw( 1:npcbl ) ) 7122 ENDIF 7123 7124 ! 7125 !-- Fill surfl (the ordering of local surfaces given by the following 7126 !-- cycles must not be altered, certain file input routines may depend 7127 !-- on it). 7128 ! 7129 !-- We allocate the array as linear and then use a two-dimensional pointer 7130 !-- into it, because some MPI implementations crash with 2D-allocated arrays. 7131 ALLOCATE(surfl_linear(nidx_surf*nsurfl)) 7132 surfl(1:nidx_surf,1:nsurfl) => surfl_linear(1:nidx_surf*nsurfl) 7133 isurf = 0 7134 IF ( rad_angular_discretization ) THEN 7135 ! 7136 !-- Allocate and fill the reverse indexing array gridsurf 7137 #if defined( __parallel ) 7138 ! 7139 !-- raytrace_mpi_rma is asserted 7140 7141 CALL MPI_Info_create(minfo, ierr) 7142 IF ( ierr /= 0 ) THEN 7143 WRITE(9,*) 'Error MPI_Info_create1:', ierr 7144 FLUSH(9) 7145 ENDIF 7146 CALL MPI_Info_set(minfo, 'accumulate_ordering', 'none', ierr) 7147 IF ( ierr /= 0 ) THEN 7148 WRITE(9,*) 'Error MPI_Info_set1:', ierr 7149 FLUSH(9) 7150 ENDIF 7151 CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr) 7152 IF ( ierr /= 0 ) THEN 7153 WRITE(9,*) 'Error MPI_Info_set2:', ierr 7154 FLUSH(9) 7155 ENDIF 7156 CALL MPI_Info_set(minfo, 'same_size', 'true', ierr) 7157 IF ( ierr /= 0 ) THEN 7158 WRITE(9,*) 'Error MPI_Info_set3:', ierr 7159 FLUSH(9) 7160 ENDIF 7161 CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr) 7162 IF ( ierr /= 0 ) THEN 7163 WRITE(9,*) 'Error MPI_Info_set4:', ierr 7164 FLUSH(9) 7165 ENDIF 7166 7167 CALL MPI_Win_allocate(INT(STORAGE_SIZE(1_iwp)/8*nsurf_type_u*nz_urban*nny*nnx, & 7168 kind=MPI_ADDRESS_KIND), STORAGE_SIZE(1_iwp)/8, & 7169 minfo, comm2d, gridsurf_rma_p, win_gridsurf, ierr) 7170 IF ( ierr /= 0 ) THEN 7171 WRITE(9,*) 'Error MPI_Win_allocate1:', ierr, & 7172 INT(STORAGE_SIZE(1_iwp)/8*nsurf_type_u*nz_urban*nny*nnx,kind=MPI_ADDRESS_KIND), & 7173 STORAGE_SIZE(1_iwp)/8, win_gridsurf 7174 FLUSH(9) 7175 ENDIF 7176 7177 CALL MPI_Info_free(minfo, ierr) 7178 IF ( ierr /= 0 ) THEN 7179 WRITE(9,*) 'Error MPI_Info_free1:', ierr 7180 FLUSH(9) 7181 ENDIF 7182 7183 ! 7184 !-- On Intel compilers, calling c_f_pointer to transform a C pointer 7185 !-- directly to a multi-dimensional Fotran pointer leads to strange 7186 !-- errors on dimension boundaries. However, transforming to a 1D 7187 !-- pointer and then redirecting a multidimensional pointer to it works 7188 !-- fine. 7189 CALL c_f_pointer(gridsurf_rma_p, gridsurf_rma, (/ nsurf_type_u*nz_urban*nny*nnx /)) 7190 gridsurf(0:nsurf_type_u-1, nz_urban_b:nz_urban_t, nys:nyn, nxl:nxr) => & 7191 gridsurf_rma(1:nsurf_type_u*nz_urban*nny*nnx) 7192 #else 7193 ALLOCATE(gridsurf(0:nsurf_type_u-1,nz_urban_b:nz_urban_t,nys:nyn,nxl:nxr) ) 7194 #endif 7195 gridsurf(:,:,:,:) = -999 7196 ENDIF 7197 7198 !-- add horizontal surface elements (land and urban surfaces) 7199 !-- TODO: add urban overhanging surfaces (idown_u) 7200 DO i = nxl, nxr 7201 DO j = nys, nyn 7202 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 7203 k = surf_usm_h%k(m) 7204 isurf = isurf + 1 7205 surfl(:,isurf) = (/iup_u,k,j,i,m/) 7206 IF ( rad_angular_discretization ) THEN 7207 gridsurf(iup_u,k,j,i) = isurf 7208 ENDIF 7209 ENDDO 7210 7211 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 7212 k = surf_lsm_h%k(m) 7213 isurf = isurf + 1 7214 surfl(:,isurf) = (/iup_l,k,j,i,m/) 7215 IF ( rad_angular_discretization ) THEN 7216 gridsurf(iup_u,k,j,i) = isurf 7217 ENDIF 7218 ENDDO 7219 7220 ENDDO 7221 ENDDO 7222 7223 !-- add vertical surface elements (land and urban surfaces) 7224 !-- TODO: remove the hard coding of l = 0 to l = idirection 7225 DO i = nxl, nxr 7226 DO j = nys, nyn 7227 l = 0 7228 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) 7229 k = surf_usm_v(l)%k(m) 7230 isurf = isurf + 1 7231 surfl(:,isurf) = (/inorth_u,k,j,i,m/) 7232 IF ( rad_angular_discretization ) THEN 7233 gridsurf(inorth_u,k,j,i) = isurf 7234 ENDIF 7235 ENDDO 7236 DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) 7237 k = surf_lsm_v(l)%k(m) 7238 isurf = isurf + 1 7239 surfl(:,isurf) = (/inorth_l,k,j,i,m/) 7240 IF ( rad_angular_discretization ) THEN 7241 gridsurf(inorth_u,k,j,i) = isurf 7242 ENDIF 7243 ENDDO 7244 7245 l = 1 7246 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) 7247 k = surf_usm_v(l)%k(m) 7248 isurf = isurf + 1 7249 surfl(:,isurf) = (/isouth_u,k,j,i,m/) 7250 IF ( rad_angular_discretization ) THEN 7251 gridsurf(isouth_u,k,j,i) = isurf 7252 ENDIF 7253 ENDDO 7254 DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) 7255 k = surf_lsm_v(l)%k(m) 7256 isurf = isurf + 1 7257 surfl(:,isurf) = (/isouth_l,k,j,i,m/) 7258 IF ( rad_angular_discretization ) THEN 7259 gridsurf(isouth_u,k,j,i) = isurf 7260 ENDIF 7261 ENDDO 7262 7263 l = 2 7264 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) 7265 k = surf_usm_v(l)%k(m) 7266 isurf = isurf + 1 7267 surfl(:,isurf) = (/ieast_u,k,j,i,m/) 7268 IF ( rad_angular_discretization ) THEN 7269 gridsurf(ieast_u,k,j,i) = isurf 7270 ENDIF 7271 ENDDO 7272 DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) 7273 k = surf_lsm_v(l)%k(m) 7274 isurf = isurf + 1 7275 surfl(:,isurf) = (/ieast_l,k,j,i,m/) 7276 IF ( rad_angular_discretization ) THEN 7277 gridsurf(ieast_u,k,j,i) = isurf 7278 ENDIF 7279 ENDDO 7280 7281 l = 3 7282 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) 7283 k = surf_usm_v(l)%k(m) 7284 isurf = isurf + 1 7285 surfl(:,isurf) = (/iwest_u,k,j,i,m/) 7286 IF ( rad_angular_discretization ) THEN 7287 gridsurf(iwest_u,k,j,i) = isurf 7288 ENDIF 7289 ENDDO 7290 DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) 7291 k = surf_lsm_v(l)%k(m) 7292 isurf = isurf + 1 7293 surfl(:,isurf) = (/iwest_l,k,j,i,m/) 7294 IF ( rad_angular_discretization ) THEN 7295 gridsurf(iwest_u,k,j,i) = isurf 6868 7296 ENDIF 6869 7297 ENDDO 6870 7298 ENDDO 7299 ENDDO 7300 ! 7301 !-- Add local MRT boxes for specified number of levels 7302 nmrtbl = 0 7303 IF ( mrt_nlevels > 0 ) THEN 7304 DO i = nxl, nxr 7305 DO j = nys, nyn 7306 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 7307 ! 7308 !-- Skip roof if requested 7309 IF ( mrt_skip_roof .AND. surf_usm_h%isroof_surf(m) ) CYCLE 7310 ! 7311 !-- Cycle over specified no of levels 7312 nmrtbl = nmrtbl + mrt_nlevels 7313 ENDDO 7314 ! 7315 !-- Dtto for LSM 7316 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 7317 nmrtbl = nmrtbl + mrt_nlevels 7318 ENDDO 7319 ENDDO 7320 ENDDO 7321 7322 ALLOCATE( mrtbl(iz:ix,nmrtbl), mrtsky(nmrtbl), mrtskyt(nmrtbl), & 7323 mrtinsw(nmrtbl), mrtinlw(nmrtbl), mrt(nmrtbl) ) 7324 7325 imrt = 0 7326 DO i = nxl, nxr 7327 DO j = nys, nyn 7328 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 7329 ! 7330 !-- Skip roof if requested 7331 IF ( mrt_skip_roof .AND. surf_usm_h%isroof_surf(m) ) CYCLE 7332 ! 7333 !-- Cycle over specified no of levels 7334 l = surf_usm_h%k(m) 7335 DO k = l, l + mrt_nlevels - 1 7336 imrt = imrt + 1 7337 mrtbl(:,imrt) = (/k,j,i/) 7338 ENDDO 7339 ENDDO 7340 ! 7341 !-- Dtto for LSM 7342 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 7343 l = surf_lsm_h%k(m) 7344 DO k = l, l + mrt_nlevels - 1 7345 imrt = imrt + 1 7346 mrtbl(:,imrt) = (/k,j,i/) 7347 ENDDO 7348 ENDDO 7349 ENDDO 7350 ENDDO 7351 ENDIF 7352 7353 ! 7354 !-- broadband albedo of the land, roof and wall surface 7355 !-- for domain border and sky set artifically to 1.0 7356 !-- what allows us to calculate heat flux leaving over 7357 !-- side and top borders of the domain 7358 ALLOCATE ( albedo_surf(nsurfl) ) 7359 albedo_surf = 1.0_wp 7360 ! 7361 !-- Also allocate further array for emissivity with identical order of 7362 !-- surface elements as radiation arrays. 7363 ALLOCATE ( emiss_surf(nsurfl) ) 7364 7365 7366 ! 7367 !-- global array surf of indices of surfaces and displacement index array surfstart 7368 ALLOCATE(nsurfs(0:numprocs-1)) 7369 7370 #if defined( __parallel ) 7371 CALL MPI_Allgather(nsurfl,1,MPI_INTEGER,nsurfs,1,MPI_INTEGER,comm2d,ierr) 7372 IF ( ierr /= 0 ) THEN 7373 WRITE(9,*) 'Error MPI_AllGather1:', ierr, nsurfl, nsurfs 7374 FLUSH(9) 7375 ENDIF 7376 7377 #else 7378 nsurfs(0) = nsurfl 7379 #endif 7380 ALLOCATE(surfstart(0:numprocs)) 7381 k = 0 7382 DO i=0,numprocs-1 7383 surfstart(i) = k 7384 k = k+nsurfs(i) 7385 ENDDO 7386 surfstart(numprocs) = k 7387 nsurf = k 7388 ! 7389 !-- We allocate the array as linear and then use a two-dimensional pointer 7390 !-- into it, because some MPI implementations crash with 2D-allocated arrays. 7391 ALLOCATE(surf_linear(nidx_surf*nsurf)) 7392 surf(1:nidx_surf,1:nsurf) => surf_linear(1:nidx_surf*nsurf) 7393 7394 #if defined( __parallel ) 7395 CALL MPI_AllGatherv(surfl_linear, nsurfl*nidx_surf, MPI_INTEGER, & 7396 surf_linear, nsurfs*nidx_surf, & 7397 surfstart(0:numprocs-1)*nidx_surf, MPI_INTEGER, & 7398 comm2d, ierr) 7399 IF ( ierr /= 0 ) THEN 7400 WRITE(9,*) 'Error MPI_AllGatherv4:', ierr, SIZE(surfl_linear), & 7401 nsurfl*nidx_surf, SIZE(surf_linear), nsurfs*nidx_surf, & 7402 surfstart(0:numprocs-1)*nidx_surf 7403 FLUSH(9) 7404 ENDIF 7405 #else 7406 surf = surfl 7407 #endif 7408 7409 !-- 7410 !-- allocation of the arrays for direct and diffusion radiation 7411 IF ( debug_output ) CALL debug_message( 'allocation of radiation arrays', 'info' ) 7412 !-- rad_sw_in, rad_lw_in are computed in radiation model, 7413 !-- splitting of direct and diffusion part is done 7414 !-- in calc_diffusion_radiation for now 7415 7416 ALLOCATE( rad_sw_in_dir(nysg:nyng,nxlg:nxrg) ) 7417 ALLOCATE( rad_sw_in_diff(nysg:nyng,nxlg:nxrg) ) 7418 ALLOCATE( rad_lw_in_diff(nysg:nyng,nxlg:nxrg) ) 7419 rad_sw_in_dir = 0.0_wp 7420 rad_sw_in_diff = 0.0_wp 7421 rad_lw_in_diff = 0.0_wp 7422 7423 !-- allocate radiation arrays 7424 ALLOCATE( surfins(nsurfl) ) 7425 ALLOCATE( surfinl(nsurfl) ) 7426 ALLOCATE( surfinsw(nsurfl) ) 7427 ALLOCATE( surfinlw(nsurfl) ) 7428 ALLOCATE( surfinswdir(nsurfl) ) 7429 ALLOCATE( surfinswdif(nsurfl) ) 7430 ALLOCATE( surfinlwdif(nsurfl) ) 7431 ALLOCATE( surfoutsl(nsurfl) ) 7432 ALLOCATE( surfoutll(nsurfl) ) 7433 ALLOCATE( surfoutsw(nsurfl) ) 7434 ALLOCATE( surfoutlw(nsurfl) ) 7435 ALLOCATE( surfouts(nsurf) ) 7436 ALLOCATE( surfoutl(nsurf) ) 7437 ALLOCATE( surfinlg(nsurf) ) 7438 ALLOCATE( skyvf(nsurfl) ) 7439 ALLOCATE( skyvft(nsurfl) ) 7440 ALLOCATE( surfemitlwl(nsurfl) ) 7441 7442 ! 7443 !-- In case of average_radiation, aggregated surface albedo and emissivity, 7444 !-- also set initial value for t_rad_urb. 7445 !-- For now set an arbitrary initial value. 7446 IF ( average_radiation ) THEN 7447 albedo_urb = 0.1_wp 7448 emissivity_urb = 0.9_wp 7449 t_rad_urb = pt_surface 7450 ENDIF 7451 7452 END SUBROUTINE radiation_interaction_init 7453 7454 !------------------------------------------------------------------------------! 7455 ! Description: 7456 ! ------------ 7457 !> Calculates shape view factors (SVF), plant sink canopy factors (PCSF), 7458 !> sky-view factors, discretized path for direct solar radiation, MRT factors 7459 !> and other preprocessed data needed for radiation_interaction inside RTM. 7460 !> This subroutine is called only one at the beginning of the simulation. 7461 !> The resulting factors can be stored to files and reused with other 7462 !> simulations utilizing the same surface and plant canopy structure. 7463 !------------------------------------------------------------------------------! 7464 SUBROUTINE radiation_calc_svf 7465 7466 IMPLICIT NONE 7467 7468 INTEGER(iwp) :: i, j, k, d, ip, jp 7469 INTEGER(iwp) :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrt, imrtf, ipcgb 7470 INTEGER(iwp) :: sd, td 7471 INTEGER(iwp) :: iaz, izn !< azimuth, zenith counters 7472 INTEGER(iwp) :: naz, nzn !< azimuth, zenith num of steps 7473 REAL(wp) :: az0, zn0 !< starting azimuth/zenith 7474 REAL(wp) :: azs, zns !< azimuth/zenith cycle step 7475 REAL(wp) :: az1, az2 !< relative azimuth of section borders 7476 REAL(wp) :: azmid !< ray (center) azimuth 7477 REAL(wp) :: yxlen !< |yxdir| 7478 REAL(wp), DIMENSION(2) :: yxdir !< y,x *unit* vector of ray direction (in grid units) 7479 REAL(wp), DIMENSION(:), ALLOCATABLE :: zdirs !< directions in z (tangent of elevation) 7480 REAL(wp), DIMENSION(:), ALLOCATABLE :: zcent !< zenith angle centers 7481 REAL(wp), DIMENSION(:), ALLOCATABLE :: zbdry !< zenith angle boundaries 7482 REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac !< view factor fractions for individual rays 7483 REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac0 !< dtto (original values) 7484 REAL(wp), DIMENSION(:), ALLOCATABLE :: ztransp !< array of transparency in z steps 7485 INTEGER(iwp) :: lowest_free_ray !< index into zdirs 7486 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: itarget !< face indices of detected obstacles 7487 INTEGER(iwp) :: itarg0, itarg1 7488 7489 INTEGER(iwp) :: udim 7490 REAL(wp), DIMENSION(:), ALLOCATABLE,TARGET:: csflt_l, pcsflt_l 7491 REAL(wp), DIMENSION(:,:), POINTER :: csflt, pcsflt 7492 INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: kcsflt_l,kpcsflt_l 7493 INTEGER(iwp), DIMENSION(:,:), POINTER :: kcsflt,kpcsflt 7494 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: icsflt,dcsflt,ipcsflt,dpcsflt 7495 REAL(wp), DIMENSION(3) :: uv 7496 LOGICAL :: visible 7497 REAL(wp), DIMENSION(3) :: sa, ta !< real coordinates z,y,x of source and target 7498 REAL(wp) :: difvf !< differential view factor 7499 REAL(wp) :: transparency, rirrf, sqdist, svfsum 7500 INTEGER(iwp) :: isurflt, isurfs, isurflt_prev 7501 INTEGER(idp) :: ray_skip_maxdist, ray_skip_minval !< skipped raytracing counts 7502 INTEGER(iwp) :: max_track_len !< maximum 2d track length 7503 #if defined( __parallel ) 7504 INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET:: nzterrl_l 7505 INTEGER(iwp), DIMENSION(:,:), POINTER :: nzterrl 7506 INTEGER(iwp) :: minfo 7507 REAL(wp), DIMENSION(:), POINTER, SAVE :: lad_s_rma !< fortran 1D pointer 7508 TYPE(c_ptr) :: lad_s_rma_p !< allocated c pointer 7509 INTEGER(kind=MPI_ADDRESS_KIND) :: size_lad_rma 7510 #endif 7511 ! 7512 INTEGER(iwp), DIMENSION(0:svfnorm_report_num) :: svfnorm_counts 7513 7514 7515 !-- calculation of the SVF 7516 CALL location_message( 'calculating view factors for radiation interaction', 'start' ) 7517 7518 !-- initialize variables and temporary arrays for calculation of svf and csf 7519 nsvfl = 0 7520 ncsfl = 0 7521 nsvfla = gasize 7522 msvf = 1 7523 ALLOCATE( asvf1(nsvfla) ) 7524 asvf => asvf1 7525 IF ( plant_canopy ) THEN 7526 ncsfla = gasize 7527 mcsf = 1 7528 ALLOCATE( acsf1(ncsfla) ) 7529 acsf => acsf1 7530 ENDIF 7531 nmrtf = 0 7532 IF ( mrt_nlevels > 0 ) THEN 7533 nmrtfa = gasize 7534 mmrtf = 1 7535 ALLOCATE ( amrtf1(nmrtfa) ) 7536 amrtf => amrtf1 7537 ENDIF 7538 ray_skip_maxdist = 0 7539 ray_skip_minval = 0 7540 7541 !-- initialize temporary terrain and plant canopy height arrays (global 2D array!) 7542 ALLOCATE( nzterr(0:(nx+1)*(ny+1)-1) ) 7543 #if defined( __parallel ) 7544 !ALLOCATE( nzterrl(nys:nyn,nxl:nxr) ) 7545 ALLOCATE( nzterrl_l((nyn-nys+1)*(nxr-nxl+1)) ) 7546 nzterrl(nys:nyn,nxl:nxr) => nzterrl_l(1:(nyn-nys+1)*(nxr-nxl+1)) 7547 nzterrl = topo_top_ind(nys:nyn,nxl:nxr,0) 7548 CALL MPI_AllGather( nzterrl_l, nnx*nny, MPI_INTEGER, & 7549 nzterr, nnx*nny, MPI_INTEGER, comm2d, ierr ) 7550 IF ( ierr /= 0 ) THEN 7551 WRITE(9,*) 'Error MPI_AllGather1:', ierr, SIZE(nzterrl_l), nnx*nny, & 7552 SIZE(nzterr), nnx*nny 7553 FLUSH(9) 7554 ENDIF 7555 DEALLOCATE(nzterrl_l) 7556 #else 7557 nzterr = RESHAPE( topo_top_ind(nys:nyn,nxl:nxr,0), (/(nx+1)*(ny+1)/) ) 7558 #endif 7559 IF ( plant_canopy ) THEN 7560 ALLOCATE( plantt(0:(nx+1)*(ny+1)-1) ) 7561 maxboxesg = nx + ny + nz_plant + 1 7562 max_track_len = nx + ny + 1 7563 !-- temporary arrays storing values for csf calculation during raytracing 7564 ALLOCATE( boxes(3, maxboxesg) ) 7565 ALLOCATE( crlens(maxboxesg) ) 7566 7567 #if defined( __parallel ) 7568 CALL MPI_AllGather( pct, nnx*nny, MPI_INTEGER, & 7569 plantt, nnx*nny, MPI_INTEGER, comm2d, ierr ) 7570 IF ( ierr /= 0 ) THEN 7571 WRITE(9,*) 'Error MPI_AllGather2:', ierr, SIZE(pct), nnx*nny, & 7572 SIZE(plantt), nnx*nny 7573 FLUSH(9) 7574 ENDIF 7575 7576 !-- temporary arrays storing values for csf calculation during raytracing 7577 ALLOCATE( lad_ip(maxboxesg) ) 7578 ALLOCATE( lad_disp(maxboxesg) ) 7579 7580 IF ( raytrace_mpi_rma ) THEN 7581 ALLOCATE( lad_s_ray(maxboxesg) ) 7582 7583 ! set conditions for RMA communication 7584 CALL MPI_Info_create(minfo, ierr) 7585 IF ( ierr /= 0 ) THEN 7586 WRITE(9,*) 'Error MPI_Info_create2:', ierr 7587 FLUSH(9) 7588 ENDIF 7589 CALL MPI_Info_set(minfo, 'accumulate_ordering', 'none', ierr) 7590 IF ( ierr /= 0 ) THEN 7591 WRITE(9,*) 'Error MPI_Info_set5:', ierr 7592 FLUSH(9) 7593 ENDIF 7594 CALL MPI_Info_set(minfo, 'accumulate_ops', 'same_op', ierr) 7595 IF ( ierr /= 0 ) THEN 7596 WRITE(9,*) 'Error MPI_Info_set6:', ierr 7597 FLUSH(9) 7598 ENDIF 7599 CALL MPI_Info_set(minfo, 'same_size', 'true', ierr) 7600 IF ( ierr /= 0 ) THEN 7601 WRITE(9,*) 'Error MPI_Info_set7:', ierr 7602 FLUSH(9) 7603 ENDIF 7604 CALL MPI_Info_set(minfo, 'same_disp_unit', 'true', ierr) 7605 IF ( ierr /= 0 ) THEN 7606 WRITE(9,*) 'Error MPI_Info_set8:', ierr 7607 FLUSH(9) 7608 ENDIF 7609 7610 !-- Allocate and initialize the MPI RMA window 7611 !-- must be in accordance with allocation of lad_s in plant_canopy_model 7612 !-- optimization of memory should be done 7613 !-- Argument X of function STORAGE_SIZE(X) needs arbitrary REAL(wp) value, set to 1.0_wp for now 7614 size_lad_rma = STORAGE_SIZE(1.0_wp)/8*nnx*nny*nz_plant 7615 CALL MPI_Win_allocate(size_lad_rma, STORAGE_SIZE(1.0_wp)/8, minfo, comm2d, & 7616 lad_s_rma_p, win_lad, ierr) 7617 IF ( ierr /= 0 ) THEN 7618 WRITE(9,*) 'Error MPI_Win_allocate2:', ierr, size_lad_rma, & 7619 STORAGE_SIZE(1.0_wp)/8, win_lad 7620 FLUSH(9) 7621 ENDIF 7622 CALL c_f_pointer(lad_s_rma_p, lad_s_rma, (/ nz_plant*nny*nnx /)) 7623 sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr) => lad_s_rma(1:nz_plant*nny*nnx) 7624 ELSE 7625 ALLOCATE(sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr)) 7626 ENDIF 7627 #else 7628 plantt = RESHAPE( pct(nys:nyn,nxl:nxr), (/(nx+1)*(ny+1)/) ) 7629 ALLOCATE(sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr)) 7630 #endif 7631 plantt_max = MAXVAL(plantt) 7632 ALLOCATE( rt2_track(2, max_track_len), rt2_track_lad(nz_urban_b:plantt_max, max_track_len), & 7633 rt2_track_dist(0:max_track_len), rt2_dist(plantt_max-nz_urban_b+2) ) 7634 7635 sub_lad(:,:,:) = 0._wp 7636 DO i = nxl, nxr 7637 DO j = nys, nyn 7638 k = topo_top_ind(j,i,0) 7639 7640 sub_lad(k:nz_plant_t, j, i) = lad_s(0:nz_plant_t-k, j, i) 7641 ENDDO 7642 ENDDO 7643 7644 #if defined( __parallel ) 7645 IF ( raytrace_mpi_rma ) THEN 7646 CALL MPI_Info_free(minfo, ierr) 7647 IF ( ierr /= 0 ) THEN 7648 WRITE(9,*) 'Error MPI_Info_free2:', ierr 7649 FLUSH(9) 7650 ENDIF 7651 CALL MPI_Win_lock_all(0, win_lad, ierr) 7652 IF ( ierr /= 0 ) THEN 7653 WRITE(9,*) 'Error MPI_Win_lock_all1:', ierr, win_lad 7654 FLUSH(9) 7655 ENDIF 7656 7657 ELSE 7658 ALLOCATE( sub_lad_g(0:(nx+1)*(ny+1)*nz_plant-1) ) 7659 CALL MPI_AllGather( sub_lad, nnx*nny*nz_plant, MPI_REAL, & 7660 sub_lad_g, nnx*nny*nz_plant, MPI_REAL, comm2d, ierr ) 7661 IF ( ierr /= 0 ) THEN 7662 WRITE(9,*) 'Error MPI_AllGather3:', ierr, SIZE(sub_lad), & 7663 nnx*nny*nz_plant, SIZE(sub_lad_g), nnx*nny*nz_plant 7664 FLUSH(9) 7665 ENDIF 7666 ENDIF 7667 #endif 7668 ENDIF 7669 7670 !-- prepare the MPI_Win for collecting the surface indices 7671 !-- from the reverse index arrays gridsurf from processors of target surfaces 7672 #if defined( __parallel ) 7673 IF ( rad_angular_discretization ) THEN 7674 ! 7675 !-- raytrace_mpi_rma is asserted 7676 CALL MPI_Win_lock_all(0, win_gridsurf, ierr) 7677 IF ( ierr /= 0 ) THEN 7678 WRITE(9,*) 'Error MPI_Win_lock_all2:', ierr, win_gridsurf 7679 FLUSH(9) 7680 ENDIF 7681 ENDIF 7682 #endif 7683 7684 7685 !--Directions opposite to face normals are not even calculated, 7686 !--they must be preset to 0 7687 !-- 7688 dsitrans(:,:) = 0._wp 7689 7690 DO isurflt = 1, nsurfl 7691 !-- determine face centers 7692 td = surfl(id, isurflt) 7693 ta = (/ REAL(surfl(iz, isurflt), wp) - 0.5_wp * kdir(td), & 7694 REAL(surfl(iy, isurflt), wp) - 0.5_wp * jdir(td), & 7695 REAL(surfl(ix, isurflt), wp) - 0.5_wp * idir(td) /) 7696 7697 !--Calculate sky view factor and raytrace DSI paths 7698 skyvf(isurflt) = 0._wp 7699 skyvft(isurflt) = 0._wp 7700 7701 !--Select a proper half-sphere for 2D raytracing 7702 SELECT CASE ( td ) 7703 CASE ( iup_u, iup_l ) 7704 az0 = 0._wp 7705 naz = raytrace_discrete_azims 7706 azs = 2._wp * pi / REAL(naz, wp) 7707 zn0 = 0._wp 7708 nzn = raytrace_discrete_elevs / 2 7709 zns = pi / 2._wp / REAL(nzn, wp) 7710 CASE ( isouth_u, isouth_l ) 7711 az0 = pi / 2._wp 7712 naz = raytrace_discrete_azims / 2 7713 azs = pi / REAL(naz, wp) 7714 zn0 = 0._wp 7715 nzn = raytrace_discrete_elevs 7716 zns = pi / REAL(nzn, wp) 7717 CASE ( inorth_u, inorth_l ) 7718 az0 = - pi / 2._wp 7719 naz = raytrace_discrete_azims / 2 7720 azs = pi / REAL(naz, wp) 7721 zn0 = 0._wp 7722 nzn = raytrace_discrete_elevs 7723 zns = pi / REAL(nzn, wp) 7724 CASE ( iwest_u, iwest_l ) 7725 az0 = pi 7726 naz = raytrace_discrete_azims / 2 7727 azs = pi / REAL(naz, wp) 7728 zn0 = 0._wp 7729 nzn = raytrace_discrete_elevs 7730 zns = pi / REAL(nzn, wp) 7731 CASE ( ieast_u, ieast_l ) 7732 az0 = 0._wp 7733 naz = raytrace_discrete_azims / 2 7734 azs = pi / REAL(naz, wp) 7735 zn0 = 0._wp 7736 nzn = raytrace_discrete_elevs 7737 zns = pi / REAL(nzn, wp) 7738 CASE DEFAULT 7739 WRITE(message_string, *) 'ERROR: the surface type ', td, & 7740 ' is not supported for calculating',& 7741 ' SVF' 7742 CALL message( 'radiation_calc_svf', 'PA0488', 1, 2, 0, 6, 0 ) 7743 END SELECT 7744 7745 ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), & 7746 ztransp(1:nzn*naz), itarget(1:nzn*naz) ) !FIXME allocate itarget only 7747 !in case of rad_angular_discretization 7748 7749 itarg0 = 1 7750 itarg1 = nzn 7751 zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/) 7752 zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/) 7753 IF ( td == iup_u .OR. td == iup_l ) THEN 7754 vffrac(1:nzn) = (COS(2 * zbdry(0:nzn-1)) - COS(2 * zbdry(1:nzn))) / 2._wp / REAL(naz, wp) 7755 ! 7756 !-- For horizontal target, vf fractions are constant per azimuth 7757 DO iaz = 1, naz-1 7758 vffrac(iaz*nzn+1:(iaz+1)*nzn) = vffrac(1:nzn) 7759 ENDDO 7760 !-- sum of whole vffrac equals 1, verified 7761 ENDIF 7762 ! 7763 !-- Calculate sky-view factor and direct solar visibility using 2D raytracing 7764 DO iaz = 1, naz 7765 azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs 7766 IF ( td /= iup_u .AND. td /= iup_l ) THEN 7767 az2 = REAL(iaz, wp) * azs - pi/2._wp 7768 az1 = az2 - azs 7769 !TODO precalculate after 1st line 7770 vffrac(itarg0:itarg1) = (SIN(az2) - SIN(az1)) & 7771 * (zbdry(1:nzn) - zbdry(0:nzn-1) & 7772 + SIN(zbdry(0:nzn-1))*COS(zbdry(0:nzn-1)) & 7773 - SIN(zbdry(1:nzn))*COS(zbdry(1:nzn))) & 7774 / (2._wp * pi) 7775 !-- sum of whole vffrac equals 1, verified 7776 ENDIF 7777 yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /) 7778 yxlen = SQRT(SUM(yxdir(:)**2)) 7779 zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:))) 7780 yxdir(:) = yxdir(:) / yxlen 7781 7782 CALL raytrace_2d(ta, yxdir, nzn, zdirs, & 7783 surfstart(myid) + isurflt, facearea(td), & 7784 vffrac(itarg0:itarg1), .TRUE., .TRUE., & 7785 .FALSE., lowest_free_ray, & 7786 ztransp(itarg0:itarg1), & 7787 itarget(itarg0:itarg1)) 7788 7789 skyvf(isurflt) = skyvf(isurflt) + & 7790 SUM(vffrac(itarg0:itarg0+lowest_free_ray-1)) 7791 skyvft(isurflt) = skyvft(isurflt) + & 7792 SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) & 7793 * vffrac(itarg0:itarg0+lowest_free_ray-1)) 7794 7795 !-- Save direct solar transparency 7796 j = MODULO(NINT(azmid/ & 7797 (2._wp*pi)*raytrace_discrete_azims-.5_wp, iwp), & 7798 raytrace_discrete_azims) 7799 7800 DO k = 1, raytrace_discrete_elevs/2 7801 i = dsidir_rev(k-1, j) 7802 IF ( i /= -1 .AND. k <= lowest_free_ray ) & 7803 dsitrans(isurflt, i) = ztransp(itarg0+k-1) 7804 ENDDO 7805 7806 ! 7807 !-- Advance itarget indices 7808 itarg0 = itarg1 + 1 7809 itarg1 = itarg1 + nzn 7810 ENDDO 7811 7812 IF ( rad_angular_discretization ) THEN 7813 !-- sort itarget by face id 7814 CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz) 7815 ! 7816 !-- For aggregation, we need fractions multiplied by transmissivities 7817 ztransp(:) = vffrac(:) * ztransp(:) 7818 ! 7819 !-- find the first valid position 7820 itarg0 = 1 7821 DO WHILE ( itarg0 <= nzn*naz ) 7822 IF ( itarget(itarg0) /= -1 ) EXIT 7823 itarg0 = itarg0 + 1 7824 ENDDO 7825 7826 DO i = itarg0, nzn*naz 7827 ! 7828 !-- For duplicate values, only sum up vf fraction value 7829 IF ( i < nzn*naz ) THEN 7830 IF ( itarget(i+1) == itarget(i) ) THEN 7831 vffrac(i+1) = vffrac(i+1) + vffrac(i) 7832 ztransp(i+1) = ztransp(i+1) + ztransp(i) 7833 CYCLE 7834 ENDIF 7835 ENDIF 7836 ! 7837 !-- write to the svf array 7838 nsvfl = nsvfl + 1 7839 !-- check dimmension of asvf array and enlarge it if needed 7840 IF ( nsvfla < nsvfl ) THEN 7841 k = CEILING(REAL(nsvfla, kind=wp) * grow_factor) 7842 IF ( msvf == 0 ) THEN 7843 msvf = 1 7844 ALLOCATE( asvf1(k) ) 7845 asvf => asvf1 7846 asvf1(1:nsvfla) = asvf2 7847 DEALLOCATE( asvf2 ) 7848 ELSE 7849 msvf = 0 7850 ALLOCATE( asvf2(k) ) 7851 asvf => asvf2 7852 asvf2(1:nsvfla) = asvf1 7853 DEALLOCATE( asvf1 ) 7854 ENDIF 7855 7856 IF ( debug_output ) THEN 7857 WRITE( debug_string, '(A,3I12)' ) 'Grow asvf:', nsvfl, nsvfla, k 7858 CALL debug_message( debug_string, 'info' ) 7859 ENDIF 7860 7861 nsvfla = k 7862 ENDIF 7863 !-- write svf values into the array 7864 asvf(nsvfl)%isurflt = isurflt 7865 asvf(nsvfl)%isurfs = itarget(i) 7866 asvf(nsvfl)%rsvf = vffrac(i) 7867 asvf(nsvfl)%rtransp = ztransp(i) / vffrac(i) 7868 END DO 7869 7870 ENDIF ! rad_angular_discretization 7871 7872 DEALLOCATE ( zdirs, zcent, zbdry, vffrac, ztransp, itarget ) !FIXME itarget shall be allocated only 7873 !in case of rad_angular_discretization 7874 ! 7875 !-- Following calculations only required for surface_reflections 7876 IF ( surface_reflections .AND. .NOT. rad_angular_discretization ) THEN 7877 7878 DO isurfs = 1, nsurf 7879 IF ( .NOT. surface_facing(surfl(ix, isurflt), surfl(iy, isurflt), & 7880 surfl(iz, isurflt), surfl(id, isurflt), & 7881 surf(ix, isurfs), surf(iy, isurfs), & 7882 surf(iz, isurfs), surf(id, isurfs)) ) THEN 7883 CYCLE 7884 ENDIF 7885 7886 sd = surf(id, isurfs) 7887 sa = (/ REAL(surf(iz, isurfs), wp) - 0.5_wp * kdir(sd), & 7888 REAL(surf(iy, isurfs), wp) - 0.5_wp * jdir(sd), & 7889 REAL(surf(ix, isurfs), wp) - 0.5_wp * idir(sd) /) 7890 7891 !-- unit vector source -> target 7892 uv = (/ (ta(1)-sa(1))*dz(1), (ta(2)-sa(2))*dy, (ta(3)-sa(3))*dx /) 7893 sqdist = SUM(uv(:)**2) 7894 uv = uv / SQRT(sqdist) 7895 7896 !-- reject raytracing above max distance 7897 IF ( SQRT(sqdist) > max_raytracing_dist ) THEN 7898 ray_skip_maxdist = ray_skip_maxdist + 1 7899 CYCLE 7900 ENDIF 7901 7902 difvf = dot_product((/ kdir(sd), jdir(sd), idir(sd) /), uv) & ! cosine of source normal and direction 7903 * dot_product((/ kdir(td), jdir(td), idir(td) /), -uv) & ! cosine of target normal and reverse direction 7904 / (pi * sqdist) ! square of distance between centers 7905 ! 7906 !-- irradiance factor (our unshaded shape view factor) = view factor per differential target area * source area 7907 rirrf = difvf * facearea(sd) 7908 7909 !-- reject raytracing for potentially too small view factor values 7910 IF ( rirrf < min_irrf_value ) THEN 7911 ray_skip_minval = ray_skip_minval + 1 7912 CYCLE 7913 ENDIF 7914 7915 !-- raytrace + process plant canopy sinks within 7916 CALL raytrace(sa, ta, isurfs, difvf, facearea(td), .TRUE., & 7917 visible, transparency) 7918 7919 IF ( .NOT. visible ) CYCLE 7920 ! rsvf = rirrf * transparency 7921 7922 !-- write to the svf array 7923 nsvfl = nsvfl + 1 7924 !-- check dimmension of asvf array and enlarge it if needed 7925 IF ( nsvfla < nsvfl ) THEN 7926 k = CEILING(REAL(nsvfla, kind=wp) * grow_factor) 7927 IF ( msvf == 0 ) THEN 7928 msvf = 1 7929 ALLOCATE( asvf1(k) ) 7930 asvf => asvf1 7931 asvf1(1:nsvfla) = asvf2 7932 DEALLOCATE( asvf2 ) 7933 ELSE 7934 msvf = 0 7935 ALLOCATE( asvf2(k) ) 7936 asvf => asvf2 7937 asvf2(1:nsvfla) = asvf1 7938 DEALLOCATE( asvf1 ) 7939 ENDIF 7940 7941 IF ( debug_output ) THEN 7942 WRITE( debug_string, '(A,3I12)' ) 'Grow asvf:', nsvfl, nsvfla, k 7943 CALL debug_message( debug_string, 'info' ) 7944 ENDIF 7945 7946 nsvfla = k 7947 ENDIF 7948 !-- write svf values into the array 7949 asvf(nsvfl)%isurflt = isurflt 7950 asvf(nsvfl)%isurfs = isurfs 7951 asvf(nsvfl)%rsvf = rirrf !we postopne multiplication by transparency 7952 asvf(nsvfl)%rtransp = transparency !a.k.a. Direct Irradiance Factor 7953 ENDDO 7954 ENDIF 6871 7955 ENDDO 6872 7956 6873 nzutl = MAX( nzutl, MAXVAL( pct ) ) 6874 nzptl = MAXVAL( pct ) 6875 6876 prototype_lad = MAXVAL( lad_s ) * .9_wp !< Better be *1.0 if lad is either 0 or maxval(lad) everywhere 6877 IF ( prototype_lad <= 0._wp ) prototype_lad = .3_wp 6878 !WRITE(message_string, '(a,f6.3)') 'Precomputing effective box optical ' & 6879 ! // 'depth using prototype leaf area density = ', prototype_lad 6880 !CALL message('radiation_interaction_init', 'PA0520', 0, 0, -1, 6, 0) 6881 ENDIF 6882 6883 nzutl = MIN( nzutl + nzut_free, nzt ) 6884 6885 #if defined( __parallel ) 6886 CALL MPI_AllReduce(nzubl, nz_urban_b, 1, MPI_INTEGER, MPI_MIN, comm2d, ierr ) 6887 IF ( ierr /= 0 ) THEN 6888 WRITE( 9, * ) 'Error MPI_AllReduce11:', ierr, nzubl, nz_urban_b 6889 FLUSH( 9 ) 6890 ENDIF 6891 CALL MPI_AllReduce( nzutl, nz_urban_t, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr ) 6892 IF ( ierr /= 0 ) THEN 6893 WRITE( 9, * ) 'Error MPI_AllReduce12:', ierr, nzutl, nz_urban_t 6894 FLUSH( 9 ) 6895 ENDIF 6896 CALL MPI_AllReduce( nzptl, nz_plant_t, 1, MPI_INTEGER, MPI_MAX, comm2d, ierr ) 6897 IF ( ierr /= 0 ) THEN 6898 WRITE( 9, * ) 'Error MPI_AllReduce13:', ierr, nzptl, nz_plant_t 6899 FLUSH( 9 ) 6900 ENDIF 6901 #else 6902 nz_urban_b = nzubl 6903 nz_urban_t = nzutl 6904 nz_plant_t = nzptl 6905 #endif 6906 ! 6907 !-- Stretching (non-uniform grid spacing) is not considered in the radiation model. Therefore, 6908 !-- vertical stretching has to be applied above the area where the parts of the radiation model 6909 !-- which assume constant grid spacing are active. ABS (...) is required because the default value 6910 !-- of dz_stretch_level_start is -9999999.9_wp (negative). 6911 IF ( ABS( dz_stretch_level_start(1) ) <= zw(nz_urban_t) ) THEN 6912 WRITE( message_string, * ) 'The lowest level where vertical stretching is applied have ' // & 6913 'to be greater than ', zw(nz_urban_t) 6914 CALL message( 'radiation_interaction_init', 'PA0496', 1, 2, 0, 6, 0 ) 6915 ENDIF 6916 ! 6917 !-- Global number of urban and plant layers 6918 nz_urban = nz_urban_t - nz_urban_b + 1 6919 nz_plant = nz_plant_t - nz_urban_b + 1 6920 ! 6921 !-- Check max_raytracing_dist relative to urban surface layer height 6922 mrl = 2.0_wp * nz_urban * dz(1) 6923 !-- Set max_raytracing_dist to double the urban surface layer height, if not set 6924 IF ( max_raytracing_dist == -999.0_wp ) THEN 6925 max_raytracing_dist = mrl 6926 ENDIF 6927 !-- Check if max_raytracing_dist set too low (here we only warn the user. Other option is to correct 6928 !-- the value again to double the urban surface layer height) 6929 IF ( max_raytracing_dist < mrl ) THEN 6930 WRITE( message_string, '(a,f6.1)' ) 'Max_raytracing_dist is set less than double the ' // & 6931 'urban surface layer height, i.e. ', mrl 6932 CALL message( 'radiation_interaction_init', 'PA0521', 0, 0, 0, 6, 0 ) 6933 ENDIF 6934 ! IF ( max_raytracing_dist <= mrl ) THEN 6935 ! IF ( max_raytracing_dist /= -999.0_wp ) THEN 6936 ! !- max_raytracing_dist too low 6937 ! WRITE(message_string, '(a,f6.1)') 'Max_raytracing_dist too low, ' & 6938 ! // 'override to value ', mrl 6939 ! CALL message('radiation_interaction_init', 'PA0521', 0, 0, -1, 6, 0) 6940 ! ENDIF 6941 ! max_raytracing_dist = mrl 6942 ! ENDIF 6943 ! 6944 !-- Allocate urban surfaces grid 6945 !-- Calc number of surfaces in local proc 6946 IF ( debug_output ) CALL debug_message( 'calculation of indices for surfaces', 'info' ) 6947 6948 nsurfl = 0 6949 ! 6950 !-- Number of horizontal surfaces including land- and roof surfaces in both USM and LSM. Note that 6951 !-- All horizontal surface elements are already counted in surface_mod. 6952 startland = 1 6953 nsurfl = surf_usm_h%ns + surf_lsm_h%ns 6954 endland = nsurfl 6955 nlands = endland - startland + 1 6956 6957 ! 6958 !-- Number of vertical surfaces in both USM and LSM. Note that all vertical surface elements are 6959 !-- already counted in surface_mod. 6960 startwall = nsurfl+1 6961 DO i = 0,3 6962 nsurfl = nsurfl + surf_usm_v(i)%ns + surf_lsm_v(i)%ns 6963 ENDDO 6964 endwall = nsurfl 6965 nwalls = endwall - startwall + 1 6966 dirstart = (/ startland, startwall, startwall, startwall, startwall /) 6967 dirend = (/ endland, endwall, endwall, endwall, endwall /) 6968 6969 !-- Fill gridpcbl and pcbl 6970 IF ( npcbl > 0 ) THEN 6971 ALLOCATE( pcbl(iz:ix, 1:npcbl) ) 6972 ALLOCATE( gridpcbl(nz_urban_b:nz_plant_t,nys:nyn,nxl:nxr) ) 6973 pcbl = -1 6974 gridpcbl(:,:,:) = 0 6975 ipcgb = 0 6976 DO i = nxl, nxr 6977 DO j = nys, nyn 6978 ! 6979 !-- Find topography top index 6980 k_topo = topo_top_ind(j,i,0) 6981 6982 DO k = k_topo + 1, pct(j,i) 6983 IF ( lad_s(k-k_topo,j,i) > eps_lad ) THEN 6984 ipcgb = ipcgb + 1 6985 gridpcbl(k,j,i) = ipcgb 6986 pcbl(:,ipcgb) = (/ k, j, i /) 6987 ENDIF 7957 !-- 7958 !-- Raytrace to canopy boxes to fill dsitransc 7959 !-- TODO: consider replacing by DSI rays toward surfaces 7960 dsitransc(:,:) = 0._wp 7961 az0 = 0._wp 7962 naz = raytrace_discrete_azims 7963 azs = 2._wp * pi / REAL(naz, wp) 7964 zn0 = 0._wp 7965 nzn = raytrace_discrete_elevs / 2 7966 zns = pi / 2._wp / REAL(nzn, wp) 7967 ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), vffrac(1:nzn), ztransp(1:nzn), & 7968 itarget(1:nzn) ) 7969 zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/) 7970 vffrac(:) = 0._wp 7971 7972 DO ipcgb = 1, npcbl 7973 ta = (/ REAL(pcbl(iz, ipcgb), wp), & 7974 REAL(pcbl(iy, ipcgb), wp), & 7975 REAL(pcbl(ix, ipcgb), wp) /) 7976 !-- Calculate direct solar visibility using 2D raytracing 7977 DO iaz = 1, naz 7978 azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs 7979 yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /) 7980 yxlen = SQRT(SUM(yxdir(:)**2)) 7981 zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:))) 7982 yxdir(:) = yxdir(:) / yxlen 7983 CALL raytrace_2d(ta, yxdir, nzn, zdirs, & 7984 -999, -999._wp, vffrac, .FALSE., .FALSE., .TRUE., & 7985 lowest_free_ray, ztransp, itarget) 7986 7987 !-- Save direct solar transparency 7988 j = MODULO(NINT(azmid/ & 7989 (2._wp*pi)*raytrace_discrete_azims-.5_wp, iwp), & 7990 raytrace_discrete_azims) 7991 DO k = 1, raytrace_discrete_elevs/2 7992 i = dsidir_rev(k-1, j) 7993 IF ( i /= -1 .AND. k <= lowest_free_ray ) & 7994 dsitransc(ipcgb, i) = ztransp(k) 6988 7995 ENDDO 6989 7996 ENDDO 6990 7997 ENDDO 6991 ALLOCATE( pcbinsw( 1:npcbl ) ) 6992 ALLOCATE( pcbinswdir( 1:npcbl ) ) 6993 ALLOCATE( pcbinswdif( 1:npcbl ) ) 6994 ALLOCATE( pcbinlw( 1:npcbl ) ) 6995 ENDIF 6996 6997 ! 6998 !-- Fill surfl (the ordering of local surfaces given by the following cycles must not be altered, 6999 !-- certain file input routines may depend on it). 7000 ! 7001 !-- We allocate the array as linear and then use a two-dimensional pointer to it, because some MPI 7002 !-- implementations crash with 2D-allocated arrays. 7003 ALLOCATE( surfl_linear(nidx_surf*nsurfl) ) 7004 surfl(1:nidx_surf,1:nsurfl) => surfl_linear(1:nidx_surf*nsurfl) 7005 isurf = 0 7006 IF ( rad_angular_discretization ) THEN 7007 ! 7008 !-- Allocate and fill the reverse indexing array gridsurf 7998 DEALLOCATE ( zdirs, zcent, vffrac, ztransp, itarget ) 7999 !-- 8000 !-- Raytrace to MRT boxes 8001 IF ( nmrtbl > 0 ) THEN 8002 mrtdsit(:,:) = 0._wp 8003 mrtsky(:) = 0._wp 8004 mrtskyt(:) = 0._wp 8005 az0 = 0._wp 8006 naz = raytrace_discrete_azims 8007 azs = 2._wp * pi / REAL(naz, wp) 8008 zn0 = 0._wp 8009 nzn = raytrace_discrete_elevs 8010 zns = pi / REAL(nzn, wp) 8011 ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), vffrac0(1:nzn), & 8012 ztransp(1:nzn*naz), itarget(1:nzn*naz) ) !FIXME allocate itarget only 8013 !in case of rad_angular_discretization 8014 8015 zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/) 8016 zbdry(:) = (/( zn0+REAL(izn,wp)*zns, izn=0, nzn )/) 8017 vffrac0(:) = (COS(zbdry(0:nzn-1)) - COS(zbdry(1:nzn))) / 2._wp / REAL(naz, wp) 8018 ! 8019 !-- Modify direction weights to simulate human body (lower weight for 8020 !-- irradiance from zenith, higher from sides) depending on selection. 8021 !-- For mrt_geom=0, no weighting is done (simulates spherical globe 8022 !-- thermometer). 8023 SELECT CASE ( mrt_geom ) 8024 8025 CASE ( 1 ) 8026 vffrac0(:) = vffrac0(:) * MAX(0._wp, SIN(zcent(:))*mrt_geom_params(2) & 8027 + COS(zcent(:))*mrt_geom_params(1)) 8028 vffrac0(:) = vffrac0(:) / (SUM(vffrac0) * REAL(naz, wp)) 8029 8030 CASE ( 2 ) 8031 vffrac0(:) = vffrac0(:) & 8032 * SQRT( ( mrt_geom_params(1) * COS(zcent(:)) ) ** 2 & 8033 + ( mrt_geom_params(2) * SIN(zcent(:)) ) ** 2 ) 8034 vffrac0(:) = vffrac0(:) / (SUM(vffrac0) * REAL(naz, wp)) 8035 8036 END SELECT 8037 8038 DO imrt = 1, nmrtbl 8039 ta = (/ REAL(mrtbl(iz, imrt), wp), & 8040 REAL(mrtbl(iy, imrt), wp), & 8041 REAL(mrtbl(ix, imrt), wp) /) 8042 ! 8043 !-- vf fractions are constant per azimuth 8044 DO iaz = 0, naz-1 8045 vffrac(iaz*nzn+1:(iaz+1)*nzn) = vffrac0(:) 8046 ENDDO 8047 !-- sum of whole vffrac equals 1, verified 8048 itarg0 = 1 8049 itarg1 = nzn 8050 ! 8051 !-- Calculate sky-view factor and direct solar visibility using 2D raytracing 8052 DO iaz = 1, naz 8053 azmid = az0 + (REAL(iaz, wp) - .5_wp) * azs 8054 yxdir(:) = (/ COS(azmid) / dy, SIN(azmid) / dx /) 8055 yxlen = SQRT(SUM(yxdir(:)**2)) 8056 zdirs(:) = COS(zcent(:)) / (dz(1) * yxlen * SIN(zcent(:))) 8057 yxdir(:) = yxdir(:) / yxlen 8058 8059 CALL raytrace_2d(ta, yxdir, nzn, zdirs, & 8060 -999, -999._wp, vffrac(itarg0:itarg1), .TRUE., & 8061 .FALSE., .TRUE., lowest_free_ray, & 8062 ztransp(itarg0:itarg1), & 8063 itarget(itarg0:itarg1)) 8064 8065 !-- Sky view factors for MRT 8066 mrtsky(imrt) = mrtsky(imrt) + & 8067 SUM(vffrac(itarg0:itarg0+lowest_free_ray-1)) 8068 mrtskyt(imrt) = mrtskyt(imrt) + & 8069 SUM(ztransp(itarg0:itarg0+lowest_free_ray-1) & 8070 * vffrac(itarg0:itarg0+lowest_free_ray-1)) 8071 !-- Direct solar transparency for MRT 8072 j = MODULO(NINT(azmid/ & 8073 (2._wp*pi)*raytrace_discrete_azims-.5_wp, iwp), & 8074 raytrace_discrete_azims) 8075 DO k = 1, raytrace_discrete_elevs/2 8076 i = dsidir_rev(k-1, j) 8077 IF ( i /= -1 .AND. k <= lowest_free_ray ) & 8078 mrtdsit(imrt, i) = ztransp(itarg0+k-1) 8079 ENDDO 8080 ! 8081 !-- Advance itarget indices 8082 itarg0 = itarg1 + 1 8083 itarg1 = itarg1 + nzn 8084 ENDDO 8085 8086 !-- sort itarget by face id 8087 CALL quicksort_itarget(itarget,vffrac,ztransp,1,nzn*naz) 8088 ! 8089 !-- For aggregation, we need fractions multiplied by transmissivities 8090 ztransp(:) = vffrac(:) * ztransp(:) 8091 !-- find the first valid position 8092 itarg0 = 1 8093 DO WHILE ( itarg0 <= nzn*naz ) 8094 IF ( itarget(itarg0) /= -1 ) EXIT 8095 itarg0 = itarg0 + 1 8096 ENDDO 8097 8098 DO i = itarg0, nzn*naz 8099 ! 8100 !-- For duplicate values, only sum up vf fraction value 8101 IF ( i < nzn*naz ) THEN 8102 IF ( itarget(i+1) == itarget(i) ) THEN 8103 vffrac(i+1) = vffrac(i+1) + vffrac(i) 8104 ztransp(i+1) = ztransp(i+1) + ztransp(i) 8105 CYCLE 8106 ENDIF 8107 ENDIF 8108 ! 8109 !-- write to the mrtf array 8110 nmrtf = nmrtf + 1 8111 !-- check dimmension of mrtf array and enlarge it if needed 8112 IF ( nmrtfa < nmrtf ) THEN 8113 k = CEILING(REAL(nmrtfa, kind=wp) * grow_factor) 8114 IF ( mmrtf == 0 ) THEN 8115 mmrtf = 1 8116 ALLOCATE( amrtf1(k) ) 8117 amrtf => amrtf1 8118 amrtf1(1:nmrtfa) = amrtf2 8119 DEALLOCATE( amrtf2 ) 8120 ELSE 8121 mmrtf = 0 8122 ALLOCATE( amrtf2(k) ) 8123 amrtf => amrtf2 8124 amrtf2(1:nmrtfa) = amrtf1 8125 DEALLOCATE( amrtf1 ) 8126 ENDIF 8127 8128 IF ( debug_output ) THEN 8129 WRITE( debug_string, '(A,3I12)' ) 'Grow amrtf:', nmrtf, nmrtfa, k 8130 CALL debug_message( debug_string, 'info' ) 8131 ENDIF 8132 8133 nmrtfa = k 8134 ENDIF 8135 !-- write mrtf values into the array 8136 amrtf(nmrtf)%isurflt = imrt 8137 amrtf(nmrtf)%isurfs = itarget(i) 8138 amrtf(nmrtf)%rsvf = vffrac(i) 8139 amrtf(nmrtf)%rtransp = ztransp(i) / vffrac(i) 8140 ENDDO ! itarg 8141 8142 ENDDO ! imrt 8143 DEALLOCATE ( zdirs, zcent, zbdry, vffrac, vffrac0, ztransp, itarget ) 8144 ! 8145 !-- Move MRT factors to final arrays 8146 ALLOCATE ( mrtf(nmrtf), mrtft(nmrtf), mrtfsurf(2,nmrtf) ) 8147 DO imrtf = 1, nmrtf 8148 mrtf(imrtf) = amrtf(imrtf)%rsvf 8149 mrtft(imrtf) = amrtf(imrtf)%rsvf * amrtf(imrtf)%rtransp 8150 mrtfsurf(:,imrtf) = (/amrtf(imrtf)%isurflt, amrtf(imrtf)%isurfs /) 8151 ENDDO 8152 IF ( ALLOCATED(amrtf1) ) DEALLOCATE( amrtf1 ) 8153 IF ( ALLOCATED(amrtf2) ) DEALLOCATE( amrtf2 ) 8154 ENDIF ! nmrtbl > 0 8155 8156 IF ( rad_angular_discretization ) THEN 7009 8157 #if defined( __parallel ) 7010 ! 7011 !-- Raytrace_mpi_rma is asserted 7012 7013 CALL MPI_Info_create( minfo, ierr ) 7014 IF ( ierr /= 0 ) THEN 7015 WRITE( 9, * ) 'Error MPI_Info_create1:', ierr 7016 FLUSH( 9 ) 7017 ENDIF 7018 CALL MPI_Info_set( minfo, 'accumulate_ordering', 'none', ierr ) 7019 IF ( ierr /= 0 ) THEN 7020 WRITE( 9, * ) 'Error MPI_Info_set1:', ierr 7021 FLUSH( 9 ) 7022 ENDIF 7023 CALL MPI_Info_set( minfo, 'accumulate_ops', 'same_op', ierr ) 7024 IF ( ierr /= 0 ) THEN 7025 WRITE( 9, * ) 'Error MPI_Info_set2:', ierr 7026 FLUSH( 9 ) 7027 ENDIF 7028 CALL MPI_Info_set( minfo, 'same_size', 'true', ierr ) 7029 IF ( ierr /= 0 ) THEN 7030 WRITE( 9, * ) 'Error MPI_Info_set3:', ierr 7031 FLUSH( 9 ) 7032 ENDIF 7033 CALL MPI_Info_set( minfo, 'same_disp_unit', 'true', ierr ) 7034 IF ( ierr /= 0 ) THEN 7035 WRITE( 9, * ) 'Error MPI_Info_set4:', ierr 7036 FLUSH( 9 ) 7037 ENDIF 7038 7039 CALL MPI_Win_allocate( INT( STORAGE_SIZE( 1_iwp ) / 8 * nsurf_type_u * nz_urban * nny * nnx,& 7040 KIND = MPI_ADDRESS_KIND ), STORAGE_SIZE( 1_iwp ) / 8, & 7041 minfo, comm2d, gridsurf_rma_p, win_gridsurf, ierr ) 7042 IF ( ierr /= 0 ) THEN 7043 WRITE( 9, * ) 'Error MPI_Win_allocate1:', ierr, & 7044 INT( STORAGE_SIZE( 1_iwp ) / 8 * nsurf_type_u * nz_urban * nny * nnx, & 7045 KIND = MPI_ADDRESS_KIND ), STORAGE_SIZE( 1_iwp ) / 8, win_gridsurf 7046 FLUSH( 9 ) 7047 ENDIF 7048 7049 CALL MPI_Info_free( minfo, ierr ) 7050 IF ( ierr /= 0 ) THEN 7051 WRITE( 9, * ) 'Error MPI_Info_free1:', ierr 7052 FLUSH( 9 ) 7053 ENDIF 7054 7055 ! 7056 !-- On Intel compilers, calling c_f_pointer to transform a C pointer directly to a 7057 !-- multi-dimensional Fotran pointer leads to strange errors on dimension boundaries. However, 7058 !-- transforming to a 1D pointer and then redirecting a multidimensional pointer to it works 7059 !-- fine. 7060 CALL c_f_pointer( gridsurf_rma_p, gridsurf_rma, (/ nsurf_type_u*nz_urban*nny*nnx /) ) 7061 gridsurf(0:nsurf_type_u-1, nz_urban_b:nz_urban_t, nys:nyn, nxl:nxr) => & 7062 gridsurf_rma(1:nsurf_type_u*nz_urban*nny*nnx) 8158 !-- finalize MPI_RMA communication established to get global index of the surface from grid indices 8159 !-- flush all MPI window pending requests 8160 CALL MPI_Win_flush_all(win_gridsurf, ierr) 8161 IF ( ierr /= 0 ) THEN 8162 WRITE(9,*) 'Error MPI_Win_flush_all1:', ierr, win_gridsurf 8163 FLUSH(9) 8164 ENDIF 8165 !-- unlock MPI window 8166 CALL MPI_Win_unlock_all(win_gridsurf, ierr) 8167 IF ( ierr /= 0 ) THEN 8168 WRITE(9,*) 'Error MPI_Win_unlock_all1:', ierr, win_gridsurf 8169 FLUSH(9) 8170 ENDIF 8171 !-- free MPI window 8172 CALL MPI_Win_free(win_gridsurf, ierr) 8173 IF ( ierr /= 0 ) THEN 8174 WRITE(9,*) 'Error MPI_Win_free1:', ierr, win_gridsurf 8175 FLUSH(9) 8176 ENDIF 7063 8177 #else 7064 ALLOCATE( gridsurf(0:nsurf_type_u-1,nz_urban_b:nz_urban_t,nys:nyn,nxl:nxr))8178 DEALLOCATE ( gridsurf ) 7065 8179 #endif 7066 gridsurf(:,:,:,:) = -999 7067 ENDIF 7068 7069 !-- Add horizontal surface elements (land and urban surfaces) 7070 !-- TODO: add urban overhanging surfaces (idown_u) 7071 DO i = nxl, nxr 7072 DO j = nys, nyn 7073 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 7074 k = surf_usm_h%k(m) 7075 isurf = isurf + 1 7076 surfl(:,isurf) = (/iup_u,k,j,i,m/) 7077 IF ( rad_angular_discretization ) THEN 7078 gridsurf(iup_u,k,j,i) = isurf 7079 ENDIF 7080 ENDDO 7081 7082 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 7083 k = surf_lsm_h%k(m) 7084 isurf = isurf + 1 7085 surfl(:,isurf) = (/iup_l,k,j,i,m/) 7086 IF ( rad_angular_discretization ) THEN 7087 gridsurf(iup_u,k,j,i) = isurf 7088 ENDIF 7089 ENDDO 7090 7091 ENDDO 7092 ENDDO 7093 7094 !-- Add vertical surface elements (land and urban surfaces) 7095 !-- TODO: remove the hard coding of l = 0 to l = idirection 7096 DO i = nxl, nxr 7097 DO j = nys, nyn 7098 l = 0 7099 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) 7100 k = surf_usm_v(l)%k(m) 7101 isurf = isurf + 1 7102 surfl(:,isurf) = (/inorth_u,k,j,i,m/) 7103 IF ( rad_angular_discretization ) THEN 7104 gridsurf(inorth_u,k,j,i) = isurf 7105 ENDIF 7106 ENDDO 7107 DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) 7108 k = surf_lsm_v(l)%k(m) 7109 isurf = isurf + 1 7110 surfl(:,isurf) = (/inorth_l,k,j,i,m/) 7111 IF ( rad_angular_discretization ) THEN 7112 gridsurf(inorth_u,k,j,i) = isurf 7113 ENDIF 7114 ENDDO 7115 7116 l = 1 7117 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) 7118 k = surf_usm_v(l)%k(m) 7119 isurf = isurf + 1 7120 surfl(:,isurf) = (/isouth_u,k,j,i,m/) 7121 IF ( rad_angular_discretization ) THEN 7122 gridsurf(isouth_u,k,j,i) = isurf 7123 ENDIF 7124 ENDDO 7125 DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) 7126 k = surf_lsm_v(l)%k(m) 7127 isurf = isurf + 1 7128 surfl(:,isurf) = (/isouth_l,k,j,i,m/) 7129 IF ( rad_angular_discretization ) THEN 7130 gridsurf(isouth_u,k,j,i) = isurf 7131 ENDIF 7132 ENDDO 7133 7134 l = 2 7135 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) 7136 k = surf_usm_v(l)%k(m) 7137 isurf = isurf + 1 7138 surfl(:,isurf) = (/ieast_u,k,j,i,m/) 7139 IF ( rad_angular_discretization ) THEN 7140 gridsurf(ieast_u,k,j,i) = isurf 7141 ENDIF 7142 ENDDO 7143 DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) 7144 k = surf_lsm_v(l)%k(m) 7145 isurf = isurf + 1 7146 surfl(:,isurf) = (/ieast_l,k,j,i,m/) 7147 IF ( rad_angular_discretization ) THEN 7148 gridsurf(ieast_u,k,j,i) = isurf 7149 ENDIF 7150 ENDDO 7151 7152 l = 3 7153 DO m = surf_usm_v(l)%start_index(j,i), surf_usm_v(l)%end_index(j,i) 7154 k = surf_usm_v(l)%k(m) 7155 isurf = isurf + 1 7156 surfl(:,isurf) = (/iwest_u,k,j,i,m/) 7157 IF ( rad_angular_discretization ) THEN 7158 gridsurf(iwest_u,k,j,i) = isurf 7159 ENDIF 7160 ENDDO 7161 DO m = surf_lsm_v(l)%start_index(j,i), surf_lsm_v(l)%end_index(j,i) 7162 k = surf_lsm_v(l)%k(m) 7163 isurf = isurf + 1 7164 surfl(:,isurf) = (/iwest_l,k,j,i,m/) 7165 IF ( rad_angular_discretization ) THEN 7166 gridsurf(iwest_u,k,j,i) = isurf 7167 ENDIF 7168 ENDDO 7169 ENDDO 7170 ENDDO 7171 ! 7172 !-- Add local MRT boxes for specified number of levels 7173 nmrtbl = 0 7174 IF ( mrt_nlevels > 0 ) THEN 7175 DO i = nxl, nxr 7176 DO j = nys, nyn 7177 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 7178 ! 7179 !-- Skip roof if requested 7180 IF ( mrt_skip_roof .AND. surf_usm_h%isroof_surf(m) ) CYCLE 7181 ! 7182 !-- Cycle over specified no of levels 7183 nmrtbl = nmrtbl + mrt_nlevels 7184 ENDDO 7185 ! 7186 !-- Dtto for LSM 7187 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 7188 nmrtbl = nmrtbl + mrt_nlevels 7189 ENDDO 7190 ENDDO 7191 ENDDO 7192 7193 ALLOCATE( mrtbl(iz:ix,nmrtbl), mrtsky(nmrtbl), mrtskyt(nmrtbl), mrtinsw(nmrtbl), & 7194 mrtinlw(nmrtbl), mrt(nmrtbl) ) 7195 7196 imrt = 0 7197 DO i = nxl, nxr 7198 DO j = nys, nyn 7199 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 7200 ! 7201 !-- Skip roof if requested 7202 IF ( mrt_skip_roof .AND. surf_usm_h%isroof_surf(m) ) CYCLE 7203 ! 7204 !-- Cycle over specified no of levels 7205 l = surf_usm_h%k(m) 7206 DO k = l, l + mrt_nlevels - 1 7207 imrt = imrt + 1 7208 mrtbl(:,imrt) = (/k,j,i/) 8180 ENDIF 8181 8182 IF ( debug_output ) CALL debug_message( 'waiting for completion of SVF and CSF calculation in all processes', 'info' ) 8183 8184 !-- deallocate temporary global arrays 8185 DEALLOCATE(nzterr) 8186 8187 IF ( plant_canopy ) THEN 8188 !-- finalize mpi_rma communication and deallocate temporary arrays 8189 #if defined( __parallel ) 8190 IF ( raytrace_mpi_rma ) THEN 8191 CALL MPI_Win_flush_all(win_lad, ierr) 8192 IF ( ierr /= 0 ) THEN 8193 WRITE(9,*) 'Error MPI_Win_flush_all2:', ierr, win_lad 8194 FLUSH(9) 8195 ENDIF 8196 !-- unlock MPI window 8197 CALL MPI_Win_unlock_all(win_lad, ierr) 8198 IF ( ierr /= 0 ) THEN 8199 WRITE(9,*) 'Error MPI_Win_unlock_all2:', ierr, win_lad 8200 FLUSH(9) 8201 ENDIF 8202 !-- free MPI window 8203 CALL MPI_Win_free(win_lad, ierr) 8204 IF ( ierr /= 0 ) THEN 8205 WRITE(9,*) 'Error MPI_Win_free2:', ierr, win_lad 8206 FLUSH(9) 8207 ENDIF 8208 !-- deallocate temporary arrays storing values for csf calculation during raytracing 8209 DEALLOCATE( lad_s_ray ) 8210 !-- sub_lad is the pointer to lad_s_rma in case of raytrace_mpi_rma 8211 !-- and must not be deallocated here 8212 ELSE 8213 DEALLOCATE(sub_lad) 8214 DEALLOCATE(sub_lad_g) 8215 ENDIF 8216 #else 8217 DEALLOCATE(sub_lad) 8218 #endif 8219 DEALLOCATE( boxes ) 8220 DEALLOCATE( crlens ) 8221 DEALLOCATE( plantt ) 8222 DEALLOCATE( rt2_track, rt2_track_lad, rt2_track_dist, rt2_dist ) 8223 ENDIF 8224 8225 IF ( debug_output ) CALL debug_message( 'calculation of the complete SVF array', 'info' ) 8226 8227 IF ( rad_angular_discretization ) THEN 8228 IF ( debug_output ) THEN 8229 WRITE( debug_string, '("Load ",I0," SVFs from the structure array to plain arrays")' ) nsvfl 8230 CALL debug_message( debug_string, 'info' ) 8231 ENDIF 8232 ALLOCATE( svf(ndsvf,nsvfl) ) 8233 ALLOCATE( svfsurf(idsvf,nsvfl) ) 8234 8235 DO isvf = 1, nsvfl 8236 svf(:, isvf) = (/ asvf(isvf)%rsvf, asvf(isvf)%rtransp /) 8237 svfsurf(:, isvf) = (/ asvf(isvf)%isurflt, asvf(isvf)%isurfs /) 8238 ENDDO 8239 ELSE 8240 IF ( debug_output ) CALL debug_message( 'Start SVF sort', 'info' ) 8241 !-- sort svf ( a version of quicksort ) 8242 CALL quicksort_svf(asvf,1,nsvfl) 8243 8244 !< load svf from the structure array to plain arrays 8245 IF ( debug_output ) THEN 8246 WRITE( debug_string, '("Load ",I0," SVFs from the structure array to plain arrays")' ) nsvfl 8247 CALL debug_message( debug_string, 'info' ) 8248 ENDIF 8249 ALLOCATE( svf(ndsvf,nsvfl) ) 8250 ALLOCATE( svfsurf(idsvf,nsvfl) ) 8251 svfnorm_counts(:) = 0._wp 8252 isurflt_prev = -1 8253 ksvf = 1 8254 svfsum = 0._wp 8255 DO isvf = 1, nsvfl 8256 !-- normalize svf per target face 8257 IF ( asvf(ksvf)%isurflt /= isurflt_prev ) THEN 8258 IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN 8259 !< update histogram of logged svf normalization values 8260 i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev))) 8261 svfnorm_counts(i) = svfnorm_counts(i) + 1 8262 8263 svf(1, isvf_surflt:isvf-1) = svf(1, isvf_surflt:isvf-1) / svfsum * (1._wp-skyvf(isurflt_prev)) 8264 ENDIF 8265 isurflt_prev = asvf(ksvf)%isurflt 8266 isvf_surflt = isvf 8267 svfsum = asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp 8268 ELSE 8269 svfsum = svfsum + asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp 8270 ENDIF 8271 8272 svf(:, isvf) = (/ asvf(ksvf)%rsvf, asvf(ksvf)%rtransp /) 8273 svfsurf(:, isvf) = (/ asvf(ksvf)%isurflt, asvf(ksvf)%isurfs /) 8274 8275 !-- next element 8276 ksvf = ksvf + 1 8277 ENDDO 8278 8279 IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN 8280 i = searchsorted(svfnorm_report_thresh, svfsum / (1._wp-skyvf(isurflt_prev))) 8281 svfnorm_counts(i) = svfnorm_counts(i) + 1 8282 8283 svf(1, isvf_surflt:nsvfl) = svf(1, isvf_surflt:nsvfl) / svfsum * (1._wp-skyvf(isurflt_prev)) 8284 ENDIF 8285 WRITE(9, *) 'SVF normalization histogram:', svfnorm_counts, & 8286 'on thresholds:', svfnorm_report_thresh(1:svfnorm_report_num), '(val < thresh <= val)' 8287 !TODO we should be able to deallocate skyvf, from now on we only need skyvft 8288 ENDIF ! rad_angular_discretization 8289 8290 !-- deallocate temporary asvf array 8291 !-- DEALLOCATE(asvf) - ifort has a problem with deallocation of allocatable target 8292 !-- via pointing pointer - we need to test original targets 8293 IF ( ALLOCATED(asvf1) ) THEN 8294 DEALLOCATE(asvf1) 8295 ENDIF 8296 IF ( ALLOCATED(asvf2) ) THEN 8297 DEALLOCATE(asvf2) 8298 ENDIF 8299 8300 npcsfl = 0 8301 IF ( plant_canopy ) THEN 8302 8303 IF ( debug_output ) CALL debug_message( 'Calculation of the complete CSF array', 'info' ) 8304 !-- sort and merge csf for the last time, keeping the array size to minimum 8305 CALL merge_and_grow_csf(-1) 8306 8307 !-- aggregate csb among processors 8308 !-- allocate necessary arrays 8309 udim = max(ncsfl,1) 8310 ALLOCATE( csflt_l(ndcsf*udim) ) 8311 csflt(1:ndcsf,1:udim) => csflt_l(1:ndcsf*udim) 8312 ALLOCATE( kcsflt_l(kdcsf*udim) ) 8313 kcsflt(1:kdcsf,1:udim) => kcsflt_l(1:kdcsf*udim) 8314 ALLOCATE( icsflt(0:numprocs-1) ) 8315 ALLOCATE( dcsflt(0:numprocs-1) ) 8316 ALLOCATE( ipcsflt(0:numprocs-1) ) 8317 ALLOCATE( dpcsflt(0:numprocs-1) ) 8318 8319 !-- fill out arrays of csf values and 8320 !-- arrays of number of elements and displacements 8321 !-- for particular precessors 8322 icsflt = 0 8323 dcsflt = 0 8324 ip = -1 8325 j = -1 8326 d = 0 8327 DO kcsf = 1, ncsfl 8328 j = j+1 8329 IF ( acsf(kcsf)%ip /= ip ) THEN 8330 !-- new block of the processor 8331 !-- number of elements of previous block 8332 IF ( ip>=0) icsflt(ip) = j 8333 d = d+j 8334 !-- blank blocks 8335 DO jp = ip+1, acsf(kcsf)%ip-1 8336 !-- number of elements is zero, displacement is equal to previous 8337 icsflt(jp) = 0 8338 dcsflt(jp) = d 8339 ENDDO 8340 !-- the actual block 8341 ip = acsf(kcsf)%ip 8342 dcsflt(ip) = d 8343 j = 0 8344 ENDIF 8345 csflt(1,kcsf) = acsf(kcsf)%rcvf 8346 !-- fill out integer values of itz,ity,itx,isurfs 8347 kcsflt(1,kcsf) = acsf(kcsf)%itz 8348 kcsflt(2,kcsf) = acsf(kcsf)%ity 8349 kcsflt(3,kcsf) = acsf(kcsf)%itx 8350 kcsflt(4,kcsf) = acsf(kcsf)%isurfs 8351 ENDDO 8352 !-- last blank blocks at the end of array 8353 j = j+1 8354 IF ( ip>=0 ) icsflt(ip) = j 8355 d = d+j 8356 DO jp = ip+1, numprocs-1 8357 !-- number of elements is zero, displacement is equal to previous 8358 icsflt(jp) = 0 8359 dcsflt(jp) = d 8360 ENDDO 8361 8362 !-- deallocate temporary acsf array 8363 !-- DEALLOCATE(acsf) - ifort has a problem with deallocation of allocatable target 8364 !-- via pointing pointer - we need to test original targets 8365 IF ( ALLOCATED(acsf1) ) THEN 8366 DEALLOCATE(acsf1) 8367 ENDIF 8368 IF ( ALLOCATED(acsf2) ) THEN 8369 DEALLOCATE(acsf2) 8370 ENDIF 8371 8372 #if defined( __parallel ) 8373 !-- scatter and gather the number of elements to and from all processor 8374 !-- and calculate displacements 8375 IF ( debug_output ) CALL debug_message( 'Scatter and gather the number of elements to and from all processor', 'info' ) 8376 8377 CALL MPI_AlltoAll(icsflt,1,MPI_INTEGER,ipcsflt,1,MPI_INTEGER,comm2d, ierr) 8378 8379 IF ( ierr /= 0 ) THEN 8380 WRITE(9,*) 'Error MPI_AlltoAll1:', ierr, SIZE(icsflt), SIZE(ipcsflt) 8381 FLUSH(9) 8382 ENDIF 8383 8384 npcsfl = SUM(ipcsflt) 8385 d = 0 8386 DO i = 0, numprocs-1 8387 dpcsflt(i) = d 8388 d = d + ipcsflt(i) 8389 ENDDO 8390 8391 !-- exchange csf fields between processors 8392 IF ( debug_output ) CALL debug_message( 'Exchange csf fields between processors', 'info' ) 8393 udim = max(npcsfl,1) 8394 ALLOCATE( pcsflt_l(ndcsf*udim) ) 8395 pcsflt(1:ndcsf,1:udim) => pcsflt_l(1:ndcsf*udim) 8396 ALLOCATE( kpcsflt_l(kdcsf*udim) ) 8397 kpcsflt(1:kdcsf,1:udim) => kpcsflt_l(1:kdcsf*udim) 8398 CALL MPI_AlltoAllv(csflt_l, ndcsf*icsflt, ndcsf*dcsflt, MPI_REAL, & 8399 pcsflt_l, ndcsf*ipcsflt, ndcsf*dpcsflt, MPI_REAL, comm2d, ierr) 8400 IF ( ierr /= 0 ) THEN 8401 WRITE(9,*) 'Error MPI_AlltoAllv1:', ierr, SIZE(ipcsflt), ndcsf*icsflt, & 8402 ndcsf*dcsflt, SIZE(pcsflt_l),ndcsf*ipcsflt, ndcsf*dpcsflt 8403 FLUSH(9) 8404 ENDIF 8405 8406 CALL MPI_AlltoAllv(kcsflt_l, kdcsf*icsflt, kdcsf*dcsflt, MPI_INTEGER, & 8407 kpcsflt_l, kdcsf*ipcsflt, kdcsf*dpcsflt, MPI_INTEGER, comm2d, ierr) 8408 IF ( ierr /= 0 ) THEN 8409 WRITE(9,*) 'Error MPI_AlltoAllv2:', ierr, SIZE(kcsflt_l),kdcsf*icsflt, & 8410 kdcsf*dcsflt, SIZE(kpcsflt_l), kdcsf*ipcsflt, kdcsf*dpcsflt 8411 FLUSH(9) 8412 ENDIF 8413 8414 #else 8415 npcsfl = ncsfl 8416 ALLOCATE( pcsflt(ndcsf,max(npcsfl,ndcsf)) ) 8417 ALLOCATE( kpcsflt(kdcsf,max(npcsfl,kdcsf)) ) 8418 pcsflt = csflt 8419 kpcsflt = kcsflt 8420 #endif 8421 8422 !-- deallocate temporary arrays 8423 DEALLOCATE( csflt_l ) 8424 DEALLOCATE( kcsflt_l ) 8425 DEALLOCATE( icsflt ) 8426 DEALLOCATE( dcsflt ) 8427 DEALLOCATE( ipcsflt ) 8428 DEALLOCATE( dpcsflt ) 8429 8430 !-- sort csf ( a version of quicksort ) 8431 IF ( debug_output ) CALL debug_message( 'Sort csf', 'info' ) 8432 CALL quicksort_csf2(kpcsflt, pcsflt, 1, npcsfl) 8433 8434 !-- aggregate canopy sink factor records with identical box & source 8435 !-- againg across all values from all processors 8436 IF ( debug_output ) CALL debug_message( 'Aggregate canopy sink factor records with identical box', 'info' ) 8437 8438 IF ( npcsfl > 0 ) THEN 8439 icsf = 1 !< reading index 8440 kcsf = 1 !< writing index 8441 DO WHILE (icsf < npcsfl) 8442 !-- here kpcsf(kcsf) already has values from kpcsf(icsf) 8443 IF ( kpcsflt(3,icsf) == kpcsflt(3,icsf+1) .AND. & 8444 kpcsflt(2,icsf) == kpcsflt(2,icsf+1) .AND. & 8445 kpcsflt(1,icsf) == kpcsflt(1,icsf+1) .AND. & 8446 kpcsflt(4,icsf) == kpcsflt(4,icsf+1) ) THEN 8447 8448 pcsflt(1,kcsf) = pcsflt(1,kcsf) + pcsflt(1,icsf+1) 8449 8450 !-- advance reading index, keep writing index 8451 icsf = icsf + 1 8452 ELSE 8453 !-- not identical, just advance and copy 8454 icsf = icsf + 1 8455 kcsf = kcsf + 1 8456 kpcsflt(:,kcsf) = kpcsflt(:,icsf) 8457 pcsflt(:,kcsf) = pcsflt(:,icsf) 8458 ENDIF 7209 8459 ENDDO 7210 ENDDO 7211 ! 7212 !-- Dtto for LSM 7213 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 7214 l = surf_lsm_h%k(m) 7215 DO k = l, l + mrt_nlevels - 1 7216 imrt = imrt + 1 7217 mrtbl(:,imrt) = (/k,j,i/) 8460 !-- last written item is now also the last item in valid part of array 8461 npcsfl = kcsf 8462 ENDIF 8463 8464 ncsfl = npcsfl 8465 IF ( ncsfl > 0 ) THEN 8466 ALLOCATE( csf(ndcsf,ncsfl) ) 8467 ALLOCATE( csfsurf(idcsf,ncsfl) ) 8468 DO icsf = 1, ncsfl 8469 csf(:,icsf) = pcsflt(:,icsf) 8470 csfsurf(1,icsf) = gridpcbl(kpcsflt(1,icsf),kpcsflt(2,icsf),kpcsflt(3,icsf)) 8471 csfsurf(2,icsf) = kpcsflt(4,icsf) 7218 8472 ENDDO 7219 ENDDO 7220 ENDDO 7221 ENDDO 7222 ENDIF 7223 7224 ! 7225 !-- Broadband albedo of the land, roof and wall surface for domain border and sky set artifically to 7226 !-- 1.0 what allows us to calculate heat flux leaving over side and top borders of the domain 7227 ALLOCATE ( albedo_surf(nsurfl) ) 7228 albedo_surf = 1.0_wp 7229 ! 7230 !-- Also allocate further array for emissivity with identical order of surface elements as radiation 7231 !-- arrays. 7232 ALLOCATE ( emiss_surf(nsurfl) ) 7233 7234 7235 ! 7236 !-- Global array surf of indices of surfaces and displacement index array surfstart 7237 ALLOCATE( nsurfs(0:numprocs-1) ) 8473 ENDIF 8474 8475 !-- deallocation of temporary arrays 8476 IF ( npcbl > 0 ) DEALLOCATE( gridpcbl ) 8477 DEALLOCATE( pcsflt_l ) 8478 DEALLOCATE( kpcsflt_l ) 8479 IF ( debug_output ) THEN 8480 WRITE( debug_string, '("Finished aggregating ",I0," CSFs.")') ncsfl 8481 CALL debug_message( debug_string, 'info' ) 8482 ENDIF 8483 8484 ENDIF 7238 8485 7239 8486 #if defined( __parallel ) 7240 CALL MPI_Allgather( nsurfl, 1, MPI_INTEGER, nsurfs, 1, MPI_INTEGER, comm2d, ierr ) 7241 IF ( ierr /= 0 ) THEN 7242 WRITE( 9, * ) 'Error MPI_AllGather1:', ierr, nsurfl, nsurfs 7243 FLUSH( 9 ) 7244 ENDIF 7245 7246 #else 7247 nsurfs(0) = nsurfl 8487 CALL MPI_BARRIER( comm2d, ierr ) 7248 8488 #endif 7249 ALLOCATE( surfstart(0:numprocs) ) 7250 k = 0 7251 DO i = 0, numprocs-1 7252 surfstart(i) = k 7253 k = k+nsurfs(i) 7254 ENDDO 7255 surfstart(numprocs) = k 7256 nsurf = k 7257 ! 7258 !-- We allocate the array as linear and then use a two-dimensional pointer to it, because some MPI 7259 !-- implementations crash with 2D-allocated arrays. 7260 ALLOCATE( surf_linear(nidx_surf*nsurf) ) 7261 surf(1:nidx_surf,1:nsurf) => surf_linear(1:nidx_surf*nsurf) 7262 7263 #if defined( __parallel ) 7264 CALL MPI_AllGatherv( surfl_linear, nsurfl * nidx_surf, MPI_INTEGER, surf_linear, & 7265 nsurfs * nidx_surf, surfstart(0:numprocs-1) * nidx_surf, MPI_INTEGER, & 7266 comm2d, ierr ) 7267 IF ( ierr /= 0 ) THEN 7268 WRITE( 9, * ) 'Error MPI_AllGatherv4:', ierr, SIZE( surfl_linear ), nsurfl * nidx_surf, & 7269 SIZE( surf_linear ), nsurfs * nidx_surf, surfstart(0:numprocs-1) * nidx_surf 7270 FLUSH( 9 ) 7271 ENDIF 7272 #else 7273 surf = surfl 7274 #endif 7275 7276 !-- 7277 !-- Allocation of the arrays for direct and diffusion radiation 7278 IF ( debug_output ) CALL debug_message( 'allocation of radiation arrays', 'info' ) 7279 !-- rad_sw_in, rad_lw_in are computed in radiation model, splitting of direct and diffusion part is 7280 !-- done in calc_diffusion_radiation for now 7281 7282 ALLOCATE( rad_sw_in_dir(nysg:nyng,nxlg:nxrg) ) 7283 ALLOCATE( rad_sw_in_diff(nysg:nyng,nxlg:nxrg) ) 7284 ALLOCATE( rad_lw_in_diff(nysg:nyng,nxlg:nxrg) ) 7285 rad_sw_in_dir = 0.0_wp 7286 rad_sw_in_diff = 0.0_wp 7287 rad_lw_in_diff = 0.0_wp 7288 7289 !-- Allocate radiation arrays 7290 ALLOCATE( surfins(nsurfl) ) 7291 ALLOCATE( surfinl(nsurfl) ) 7292 ALLOCATE( surfinsw(nsurfl) ) 7293 ALLOCATE( surfinlw(nsurfl) ) 7294 ALLOCATE( surfinswdir(nsurfl) ) 7295 ALLOCATE( surfinswdif(nsurfl) ) 7296 ALLOCATE( surfinlwdif(nsurfl) ) 7297 ALLOCATE( surfoutsl(nsurfl) ) 7298 ALLOCATE( surfoutll(nsurfl) ) 7299 ALLOCATE( surfoutsw(nsurfl) ) 7300 ALLOCATE( surfoutlw(nsurfl) ) 7301 ALLOCATE( surfouts(nsurf) ) 7302 ALLOCATE( surfoutl(nsurf) ) 7303 ALLOCATE( surfinlg(nsurf) ) 7304 ALLOCATE( skyvf(nsurfl) ) 7305 ALLOCATE( skyvft(nsurfl) ) 7306 ALLOCATE( surfemitlwl(nsurfl) ) 7307 7308 ! 7309 !-- In case of average_radiation, aggregated surface albedo and emissivity, also set initial value 7310 !-- for t_rad_urb. For now set an arbitrary initial value. 7311 IF ( average_radiation ) THEN 7312 albedo_urb = 0.1_wp 7313 emissivity_urb = 0.9_wp 7314 t_rad_urb = pt_surface 7315 ENDIF 7316 7317 END SUBROUTINE radiation_interaction_init 7318 7319 !--------------------------------------------------------------------------------------------------! 8489 CALL location_message( 'calculating view factors for radiation interaction', 'finished' ) 8490 8491 RETURN !todo: remove 8492 8493 ! WRITE( message_string, * ) & 8494 ! 'I/O error when processing shape view factors / ', & 8495 ! 'plant canopy sink factors / direct irradiance factors.' 8496 ! CALL message( 'init_urban_surface', 'PA0502', 2, 2, 0, 6, 0 ) 8497 8498 END SUBROUTINE radiation_calc_svf 8499 8500 8501 !------------------------------------------------------------------------------! 7320 8502 ! Description: 7321 8503 ! ------------ 7322 !> Calculates shape view factors (SVF), plant sink canopy factors (PCSF), sky-view factors, 7323 !> discretized path for direct solar radiation, MRT factors and other preprocessed data needed for 7324 !> radiation_interaction inside RTM. This subroutine is called only once at the beginning of the 7325 !> simulation. The resulting factors can be stored to files and reused with other simulations 7326 !> utilizing the same surface and plant canopy structure. 7327 !--------------------------------------------------------------------------------------------------! 7328 SUBROUTINE radiation_calc_svf 7329 7330 IMPLICIT NONE 7331 7332 INTEGER(iwp) :: i, j, k, d, ip, jp !< 7333 INTEGER(iwp) :: isvf, ksvf, icsf, kcsf, npcsfl, isvf_surflt, imrt, imrtf, ipcgb !< 7334 INTEGER(iwp) :: sd, td !< 7335 INTEGER(iwp) :: iaz, izn !< azimuth, zenith counters 7336 INTEGER(iwp) :: naz, nzn !< azimuth, zenith num of steps 7337 INTEGER(iwp) :: lowest_free_ray !< index into zdirs 7338 INTEGER(iwp) :: itarg0, itarg1 !< 7339 INTEGER(iwp) :: udim !< 7340 INTEGER(iwp) :: isurflt, isurfs, isurflt_prev !< 7341 INTEGER(idp) :: ray_skip_maxdist, ray_skip_minval !< skipped raytracing counts 7342 INTEGER(iwp) :: max_track_len !< maximum 2d track length 7343 7344 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: itarget !< face indices of detected obstacles 7345 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: icsflt,dcsflt,ipcsflt,dpcsflt !< 7346 7347 INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: kcsflt_l,kpcsflt_l !< 7348 7349 INTEGER(iwp), DIMENSION(:,:), POINTER :: kcsflt,kpcsflt !< 7350 7351 LOGICAL :: visible !< 7352 7353 REAL(wp) :: az0, zn0 !< starting azimuth/zenith 7354 REAL(wp) :: azs, zns !< azimuth/zenith cycle step 7355 REAL(wp) :: az1, az2 !< relative azimuth of section borders 7356 REAL(wp) :: azmid !< ray (center) azimuth 7357 REAL(wp) :: yxlen !< |yxdir| 7358 REAL(wp) :: difvf !< differential view factor 7359 REAL(wp) :: transparency, rirrf, sqdist, svfsum !< 7360 7361 REAL(wp), DIMENSION(2) :: yxdir !< y,x *unit* vector of ray direction (in grid units) 7362 REAL(wp), DIMENSION(3) :: uv !< 7363 REAL(wp), DIMENSION(3) :: sa, ta !< real coordinates z,y,x of source and target 7364 7365 REAL(wp), DIMENSION(:), ALLOCATABLE :: zdirs !< directions in z (tangent of elevation) 7366 REAL(wp), DIMENSION(:), ALLOCATABLE :: zcent !< zenith angle centers 7367 REAL(wp), DIMENSION(:), ALLOCATABLE :: zbdry !< zenith angle boundaries 7368 REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac !< view factor fractions for individual rays 7369 REAL(wp), DIMENSION(:), ALLOCATABLE :: vffrac0 !< dtto (original values) 7370 REAL(wp), DIMENSION(:), ALLOCATABLE :: ztransp !< array of transparency in z steps 7371 REAL(wp), DIMENSION(:), ALLOCATABLE,TARGET :: csflt_l, pcsflt_l !< 7372 7373 REAL(wp), DIMENSION(:,:), POINTER :: csflt, pcsflt !< 7374 7375 8504 !> Raytracing for detecting obstacles and calculating compound canopy sink 8505 !> factors for RTM. (A simple obstacle detection would only need to process 8506 !> faces in 3 dimensions without any ordering.) 8507 !> Assumtions: 8508 !> ----------- 8509 !> 1. The ray always originates from a face midpoint (only one coordinate equals 8510 !> *.5, i.e. wall) and doesn't travel parallel to the surface (that would mean 8511 !> shape factor=0). Therefore, the ray may never travel exactly along a face 8512 !> or an edge. 8513 !> 2. From grid bottom to urban surface top the grid has to be *equidistant* 8514 !> within each of the dimensions, including vertical (but the resolution 8515 !> doesn't need to be the same in all three dimensions). 8516 !------------------------------------------------------------------------------! 8517 SUBROUTINE raytrace(src, targ, isrc, difvf, atarg, create_csf, visible, transparency) 8518 IMPLICIT NONE 8519 8520 REAL(wp), DIMENSION(3), INTENT(in) :: src, targ !< real coordinates z,y,x 8521 INTEGER(iwp), INTENT(in) :: isrc !< index of source face for csf 8522 REAL(wp), INTENT(in) :: difvf !< differential view factor for csf 8523 REAL(wp), INTENT(in) :: atarg !< target surface area for csf 8524 LOGICAL, INTENT(in) :: create_csf !< whether to generate new CSFs during raytracing 8525 LOGICAL, INTENT(out) :: visible 8526 REAL(wp), INTENT(out) :: transparency !< along whole path 8527 INTEGER(iwp) :: i, k, d 8528 INTEGER(iwp) :: seldim !< dimension to be incremented 8529 INTEGER(iwp) :: ncsb !< no of written plant canopy sinkboxes 8530 INTEGER(iwp) :: maxboxes !< max no of gridboxes visited 8531 REAL(wp) :: distance !< euclidean along path 8532 REAL(wp) :: crlen !< length of gridbox crossing 8533 REAL(wp) :: lastdist !< beginning of current crossing 8534 REAL(wp) :: nextdist !< end of current crossing 8535 REAL(wp) :: realdist !< distance in meters per unit distance 8536 REAL(wp) :: crmid !< midpoint of crossing 8537 REAL(wp) :: cursink !< sink factor for current canopy box 8538 REAL(wp), DIMENSION(3) :: delta !< path vector 8539 REAL(wp), DIMENSION(3) :: uvect !< unit vector 8540 REAL(wp), DIMENSION(3) :: dimnextdist !< distance for each dimension increments 8541 INTEGER(iwp), DIMENSION(3) :: box !< gridbox being crossed 8542 INTEGER(iwp), DIMENSION(3) :: dimnext !< next dimension increments along path 8543 INTEGER(iwp), DIMENSION(3) :: dimdelta !< dimension direction = +- 1 8544 INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array 8545 8546 REAL(wp) :: eps = 1E-10_wp !< epsilon for value comparison 8547 REAL(wp) :: lad_s_target !< recieved lad_s of particular grid box 8548 8549 ! 8550 !-- Maximum number of gridboxes visited equals to maximum number of boundaries crossed in each dimension plus one. That's also 8551 !-- the maximum number of plant canopy boxes written. We grow the acsf array accordingly using exponential factor. 8552 maxboxes = SUM(ABS(NINT(targ, iwp) - NINT(src, iwp))) + 1 8553 IF ( plant_canopy .AND. ncsfl + maxboxes > ncsfla ) THEN 8554 !-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1) 8555 !-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) & 8556 !-- / log(grow_factor)), kind=wp)) 8557 !-- or use this code to simply always keep some extra space after growing 8558 k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor) 8559 8560 CALL merge_and_grow_csf(k) 8561 ENDIF 8562 8563 transparency = 1._wp 8564 ncsb = 0 8565 8566 delta(:) = targ(:) - src(:) 8567 distance = SQRT(SUM(delta(:)**2)) 8568 IF ( distance == 0._wp ) THEN 8569 visible = .TRUE. 8570 RETURN 8571 ENDIF 8572 uvect(:) = delta(:) / distance 8573 realdist = SQRT(SUM( (uvect(:)*(/dz(1),dy,dx/))**2 )) 8574 8575 lastdist = 0._wp 8576 8577 !-- Since all face coordinates have values *.5 and we'd like to use 8578 !-- integers, all these have .5 added 8579 DO d = 1, 3 8580 IF ( uvect(d) == 0._wp ) THEN 8581 dimnext(d) = 999999999 8582 dimdelta(d) = 999999999 8583 dimnextdist(d) = 1.0E20_wp 8584 ELSE IF ( uvect(d) > 0._wp ) THEN 8585 dimnext(d) = CEILING(src(d) + .5_wp) 8586 dimdelta(d) = 1 8587 dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d) 8588 ELSE 8589 dimnext(d) = FLOOR(src(d) + .5_wp) 8590 dimdelta(d) = -1 8591 dimnextdist(d) = (dimnext(d) - .5_wp - src(d)) / uvect(d) 8592 ENDIF 8593 ENDDO 8594 8595 DO 8596 !-- along what dimension will the next wall crossing be? 8597 seldim = minloc(dimnextdist, 1) 8598 nextdist = dimnextdist(seldim) 8599 IF ( nextdist > distance ) nextdist = distance 8600 8601 crlen = nextdist - lastdist 8602 IF ( crlen > .001_wp ) THEN 8603 crmid = (lastdist + nextdist) * .5_wp 8604 box = NINT(src(:) + uvect(:) * crmid, iwp) 8605 8606 !-- calculate index of the grid with global indices (box(2),box(3)) 8607 !-- in the array nzterr and plantt and id of the coresponding processor 8608 CALL radiation_calc_global_offset( box(3), box(2), 0, 1, offs_glob=ig ) 8609 IF ( box(1) <= nzterr(ig) ) THEN 8610 visible = .FALSE. 8611 RETURN 8612 ENDIF 8613 8614 IF ( plant_canopy ) THEN 8615 IF ( box(1) <= plantt(ig) ) THEN 8616 ncsb = ncsb + 1 8617 boxes(:,ncsb) = box 8618 crlens(ncsb) = crlen 7376 8619 #if defined( __parallel ) 7377 INTEGER(iwp) :: minfo !< 7378 INTEGER(KIND=MPI_ADDRESS_KIND) :: size_lad_rma !< 7379 INTEGER(iwp), DIMENSION(:), ALLOCATABLE,TARGET :: nzterrl_l !< 7380 INTEGER(iwp), DIMENSION(:,:), POINTER :: nzterrl !< 7381 REAL(wp), DIMENSION(:), POINTER, SAVE :: lad_s_rma !< fortran 1D pointer 7382 TYPE(c_ptr) :: lad_s_rma_p !< allocated c pointer 7383 8620 CALL radiation_calc_global_offset( box(3), box(2), box(1)-nz_urban_b, & 8621 nz_plant, iproc=lad_ip(ncsb), & 8622 offs_proc=lad_disp(ncsb) ) 7384 8623 #endif 7385 ! 7386 INTEGER(iwp), DIMENSION(0:svfnorm_report_num) :: svfnorm_counts !< 7387 7388 7389 !-- Calculation of the SVF 7390 CALL location_message( 'calculating view factors for radiation interaction', 'start' ) 7391 7392 !-- Initialize variables and temporary arrays for calculation of svf and csf 7393 nsvfl = 0 7394 ncsfl = 0 7395 nsvfla = gasize 7396 msvf = 1 7397 ALLOCATE( asvf1(nsvfla) ) 7398 asvf => asvf1 7399 IF ( plant_canopy ) THEN 7400 ncsfla = gasize 7401 mcsf = 1 7402 ALLOCATE( acsf1(ncsfla) ) 7403 acsf => acsf1 7404 ENDIF 7405 nmrtf = 0 7406 IF ( mrt_nlevels > 0 ) THEN 7407 nmrtfa = gasize 7408 mmrtf = 1 7409 ALLOCATE( amrtf1(nmrtfa) ) 7410 amrtf => amrtf1 7411 ENDIF 7412 ray_skip_maxdist = 0 7413 ray_skip_minval = 0 7414 7415 !-- Initialize temporary terrain and plant canopy height arrays (global 2D array!) 7416 ALLOCATE( nzterr(0:(nx+1)*(ny+1)-1) ) 8624 ENDIF 8625 ENDIF 8626 ENDIF 8627 8628 IF ( ABS(distance - nextdist) < eps ) EXIT 8629 lastdist = nextdist 8630 dimnext(seldim) = dimnext(seldim) + dimdelta(seldim) 8631 dimnextdist(seldim) = (dimnext(seldim) - .5_wp - src(seldim)) / uvect(seldim) 8632 ENDDO 8633 8634 IF ( plant_canopy ) THEN 7417 8635 #if defined( __parallel ) 7418 !ALLOCATE( nzterrl(nys:nyn,nxl:nxr) ) 7419 ALLOCATE( nzterrl_l((nyn-nys+1)*(nxr-nxl+1)) ) 7420 nzterrl(nys:nyn,nxl:nxr) => nzterrl_l(1:(nyn-nys+1)*(nxr-nxl+1)) 7421 nzterrl = topo_top_ind(nys:nyn,nxl:nxr,0) 7422 CALL MPI_AllGather( nzterrl_l, nnx * nny, MPI_INTEGER, nzterr, nnx * nny, MPI_INTEGER, comm2d, & 7423 ierr ) 7424 IF ( ierr /= 0 ) THEN 7425 WRITE( 9, * ) 'Error MPI_AllGather1:', ierr, SIZE( nzterrl_l ), nnx * nny, & 7426 SIZE( nzterr ), nnx * nny 7427 FLUSH(9) 7428 ENDIF 7429 DEALLOCATE( nzterrl_l ) 8636 IF ( raytrace_mpi_rma ) THEN 8637 !-- send requests for lad_s to appropriate processor 8638 CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'start' ) 8639 DO i = 1, ncsb 8640 CALL MPI_Get(lad_s_ray(i), 1, MPI_REAL, lad_ip(i), lad_disp(i), & 8641 1, MPI_REAL, win_lad, ierr) 8642 IF ( ierr /= 0 ) THEN 8643 WRITE(9,*) 'Error MPI_Get1:', ierr, lad_s_ray(i), & 8644 lad_ip(i), lad_disp(i), win_lad 8645 FLUSH(9) 8646 ENDIF 8647 ENDDO 8648 8649 !-- wait for all pending local requests complete 8650 CALL MPI_Win_flush_local_all(win_lad, ierr) 8651 IF ( ierr /= 0 ) THEN 8652 WRITE(9,*) 'Error MPI_Win_flush_local_all1:', ierr, win_lad 8653 FLUSH(9) 8654 ENDIF 8655 CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'stop' ) 8656 8657 ENDIF 8658 #endif 8659 8660 !-- calculate csf and transparency 8661 DO i = 1, ncsb 8662 #if defined( __parallel ) 8663 IF ( raytrace_mpi_rma ) THEN 8664 lad_s_target = lad_s_ray(i) 8665 ELSE 8666 lad_s_target = sub_lad_g(lad_ip(i)*nnx*nny*nz_plant + lad_disp(i)) 8667 ENDIF 7430 8668 #else 7431 nzterr = RESHAPE( topo_top_ind(nys:nyn,nxl:nxr,0), (/(nx+1)*(ny+1)/))8669 lad_s_target = sub_lad(boxes(1,i),boxes(2,i),boxes(3,i)) 7432 8670 #endif 7433 IF ( plant_canopy ) THEN 7434 ALLOCATE( plantt(0:(nx+1)*(ny+1)-1) ) 7435 maxboxesg = nx + ny + nz_plant + 1 7436 max_track_len = nx + ny + 1 7437 !-- Temporary arrays storing values for csf calculation during raytracing 7438 ALLOCATE( boxes(3, maxboxesg) ) 7439 ALLOCATE( crlens(maxboxesg) ) 7440 7441 #if defined( __parallel ) 7442 CALL MPI_AllGather( pct, nnx*nny, MPI_INTEGER, plantt, nnx * nny, MPI_INTEGER, comm2d, & 7443 ierr ) 7444 IF ( ierr /= 0 ) THEN 7445 WRITE( 9, * ) 'Error MPI_AllGather2:', ierr, SIZE( pct ), nnx * nny, SIZE( plantt ), & 7446 nnx * nny 7447 FLUSH( 9 ) 7448 ENDIF 7449 ! 7450 !-- Temporary arrays storing values for csf calculation during raytracing 7451 ALLOCATE( lad_ip(maxboxesg) ) 7452 ALLOCATE( lad_disp(maxboxesg) ) 7453 7454 IF ( raytrace_mpi_rma ) THEN 7455 ALLOCATE( lad_s_ray(maxboxesg) ) 7456 ! 7457 !-- Set conditions for RMA communication 7458 CALL MPI_Info_create( minfo, ierr ) 7459 IF ( ierr /= 0 ) THEN 7460 WRITE( 9, * ) 'Error MPI_Info_create2:', ierr 7461 FLUSH( 9 ) 7462 ENDIF 7463 CALL MPI_Info_set( minfo, 'accumulate_ordering', 'none', ierr ) 7464 IF ( ierr /= 0 ) THEN 7465 WRITE( 9, * ) 'Error MPI_Info_set5:', ierr 7466 FLUSH( 9 ) 7467 ENDIF 7468 CALL MPI_Info_set( minfo, 'accumulate_ops', 'same_op', ierr ) 7469 IF ( ierr /= 0 ) THEN 7470 WRITE( 9, * ) 'Error MPI_Info_set6:', ierr 7471 FLUSH( 9 ) 7472 ENDIF 7473 CALL MPI_Info_set( minfo, 'same_size', 'true', ierr ) 7474 IF ( ierr /= 0 ) THEN 7475 WRITE( 9, * ) 'Error MPI_Info_set7:', ierr 7476 FLUSH( 9 ) 7477 ENDIF 7478 CALL MPI_Info_set( minfo, 'same_disp_unit', 'true', ierr ) 7479 IF ( ierr /= 0 ) THEN 7480 WRITE( 9, * ) 'Error MPI_Info_set8:', ierr 7481 FLUSH( 9 ) 7482 ENDIF 7483 7484 !-- Allocate and initialize the MPI RMA window must be in accordance with allocation of 7485 !-- lad_s in plant_canopy_model. Optimization of memory should be done. Argument X of 7486 !-- function STORAGE_SIZE(X) needs arbitrary REAL(wp) value, set to 1.0_wp for now 7487 size_lad_rma = STORAGE_SIZE( 1.0_wp ) / 8 * nnx * nny * nz_plant 7488 CALL MPI_Win_allocate( size_lad_rma, STORAGE_SIZE( 1.0_wp ) / 8, minfo, comm2d, & 7489 lad_s_rma_p, win_lad, ierr) 7490 IF ( ierr /= 0 ) THEN 7491 WRITE( 9, * ) 'Error MPI_Win_allocate2:', ierr, size_lad_rma, & 7492 STORAGE_SIZE( 1.0_wp ) / 8, win_lad 7493 FLUSH(9) 7494 ENDIF 7495 CALL c_f_pointer( lad_s_rma_p, lad_s_rma, (/ nz_plant*nny*nnx /) ) 7496 sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr) => lad_s_rma(1:nz_plant*nny*nnx) 7497 ELSE 7498 ALLOCATE( sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr) ) 7499 ENDIF 7500 #else 7501 plantt = RESHAPE( pct(nys:nyn,nxl:nxr), (/(nx+1)*(ny+1)/) ) 7502 ALLOCATE( sub_lad(nz_urban_b:nz_plant_t, nys:nyn, nxl:nxr) ) 7503 #endif 7504 plantt_max = MAXVAL( plantt ) 7505 ALLOCATE( rt2_track(2, max_track_len), rt2_track_lad(nz_urban_b:plantt_max, max_track_len),& 7506 rt2_track_dist(0:max_track_len), rt2_dist(plantt_max-nz_urban_b+2) ) 7507 7508 sub_lad(:,:,:) = 0._wp 7509 DO i = nxl, nxr 7510 DO j = nys, nyn 7511 k = topo_top_ind(j,i,0) 7512 7513 sub_lad(k:nz_plant_t, j, i) = lad_s(0:nz_plant_t-k, j, i) 7514 ENDDO 7515 ENDDO 7516 7517 #if defined( __parallel ) 7518 IF ( raytrace_mpi_rma ) THEN 7519 CALL MPI_Info_free( minfo, ierr ) 7520 IF ( ierr /= 0 ) THEN 7521 WRITE( 9, * ) 'Error MPI_Info_free2:', ierr 7522 FLUSH( 9 ) 7523 ENDIF 7524 CALL MPI_Win_lock_all( 0, win_lad, ierr ) 7525 IF ( ierr /= 0 ) THEN 7526 WRITE( 9, * ) 'Error MPI_Win_lock_all1:', ierr, win_lad 7527 FLUSH( 9 ) 7528 ENDIF 7529 7530 ELSE 7531 ALLOCATE( sub_lad_g(0:(nx+1)*(ny+1)*nz_plant-1) ) 7532 CALL MPI_AllGather( sub_lad, nnx * nny * nz_plant, MPI_REAL, sub_lad_g, & 7533 nnx * nny * nz_plant, MPI_REAL, comm2d, ierr ) 7534 IF ( ierr /= 0 ) THEN 7535 WRITE( 9, * ) 'Error MPI_AllGather3:', ierr, SIZE( sub_lad ), & 7536 nnx * nny * nz_plant, SIZE( sub_lad_g ), nnx * nny * nz_plant 7537 FLUSH( 9 ) 7538 ENDIF 7539 ENDIF 7540 #endif 7541 ENDIF 7542 7543 !-- Prepare the MPI_Win for collecting the surface indices from the reverse index arrays gridsurf 7544 !-- from processors of target surfaces 7545 #if defined( __parallel ) 7546 IF ( rad_angular_discretization ) THEN 7547 ! 7548 !-- raytrace_mpi_rma is asserted 7549 CALL MPI_Win_lock_all( 0, win_gridsurf, ierr ) 7550 IF ( ierr /= 0 ) THEN 7551 WRITE( 9, * ) 'Error MPI_Win_lock_all2:', ierr, win_gridsurf 7552 FLUSH( 9 ) 7553 ENDIF 7554 ENDIF 7555 #endif 7556 7557 7558 !-- Directions opposite to face normals are not even calculated, they must be preset to 0 7559 dsitrans(:,:) = 0._wp 7560 7561 DO isurflt = 1, nsurfl 7562 !-- Determine face centers 7563 td = surfl(id, isurflt) 7564 ta = (/ REAL( surfl(iz, isurflt), wp ) - 0.5_wp * kdir(td), & 7565 REAL( surfl(iy, isurflt), wp ) - 0.5_wp * jdir(td), & 7566 REAL( surfl(ix, isurflt), wp ) - 0.5_wp * idir(td) /) 7567 7568 !-- Calculate sky view factor and raytrace DSI paths 7569 skyvf(isurflt) = 0._wp 7570 skyvft(isurflt) = 0._wp 7571 7572 !-- Select a proper half-sphere for 2D raytracing 7573 SELECT CASE ( td ) 7574 CASE ( iup_u, iup_l ) 7575 az0 = 0._wp 7576 naz = raytrace_discrete_azims 7577 azs = 2._wp * pi / REAL( naz, wp ) 7578 zn0 = 0._wp 7579 nzn = raytrace_discrete_elevs / 2 7580 zns = pi / 2._wp / REAL( nzn, wp ) 7581 CASE ( isouth_u, isouth_l ) 7582 az0 = pi / 2._wp 7583 naz = raytrace_discrete_azims / 2 7584 azs = pi / REAL( naz, wp ) 7585 zn0 = 0._wp 7586 nzn = raytrace_discrete_elevs 7587 zns = pi / REAL( nzn, wp ) 7588 CASE ( inorth_u, inorth_l ) 7589 az0 = - pi / 2._wp 7590 naz = raytrace_discrete_azims / 2 7591 azs = pi / REAL( naz, wp ) 7592 zn0 = 0._wp 7593 nzn = raytrace_discrete_elevs 7594 zns = pi / REAL( nzn, wp ) 7595 CASE ( iwest_u, iwest_l ) 7596 az0 = pi 7597 naz = raytrace_discrete_azims / 2 7598 azs = pi / REAL( naz, wp ) 7599 zn0 = 0._wp 7600 nzn = raytrace_discrete_elevs 7601 zns = pi / REAL( nzn, wp ) 7602 CASE ( ieast_u, ieast_l ) 7603 az0 = 0._wp 7604 naz = raytrace_discrete_azims / 2 7605 azs = pi / REAL( naz, wp ) 7606 zn0 = 0._wp 7607 nzn = raytrace_discrete_elevs 7608 zns = pi / REAL( nzn, wp ) 7609 CASE DEFAULT 7610 WRITE( message_string, * ) 'ERROR: the surface type ', td, 'is not supported for ' // & 7611 'calculating SVF' 7612 CALL message( 'radiation_calc_svf', 'PA0488', 1, 2, 0, 6, 0 ) 7613 END SELECT 7614 7615 ALLOCATE ( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), & 7616 ztransp(1:nzn*naz), itarget(1:nzn*naz) ) !FIXME allocate itarget only 7617 !in case of rad_angular_discretization 7618 7619 itarg0 = 1 7620 itarg1 = nzn 7621 zcent(:) = (/( zn0 + ( REAL( izn, wp ) - .5_wp ) * zns, izn = 1, nzn )/) 7622 zbdry(:) = (/( zn0 + REAL( izn, wp ) * zns, izn = 0, nzn )/) 7623 IF ( td == iup_u .OR. td == iup_l ) THEN 7624 vffrac(1:nzn) = ( COS( 2 * zbdry(0:nzn-1) ) - COS( 2 * zbdry(1:nzn) ) ) / 2._wp / & 7625 REAL( naz, wp ) 7626 ! 7627 !-- For horizontal target, vf fractions are constant per azimuth 7628 DO iaz = 1, naz-1 7629 vffrac(iaz*nzn+1:(iaz+1)*nzn) = vffrac(1:nzn) 7630 ENDDO 7631 !-- Sum of whole vffrac equals 1, verified 7632 ENDIF 7633 ! 7634 !-- Calculate sky-view factor and direct solar visibility using 2D raytracing 7635 DO iaz = 1, naz 7636 azmid = az0 + ( REAL( iaz, wp ) - .5_wp ) * azs 7637 IF ( td /= iup_u .AND. td /= iup_l ) THEN 7638 az2 = REAL( iaz, wp ) * azs - pi / 2._wp 7639 az1 = az2 - azs 7640 !TODO precalculate after 1st line 7641 vffrac(itarg0:itarg1) = ( SIN( az2 ) - SIN( az1 ) ) * ( zbdry(1:nzn) - zbdry(0:nzn-1) & 7642 + SIN( zbdry(0:nzn-1) ) * COS( zbdry(0:nzn-1) ) & 7643 - SIN( zbdry(1:nzn) ) * COS( zbdry(1:nzn) ) ) / (2._wp * pi) 7644 !-- Sum of whole vffrac equals 1, verified 7645 ENDIF 7646 yxdir(:) = (/ COS( azmid ) / dy, SIN( azmid ) / dx /) 7647 yxlen = SQRT( SUM( yxdir(:)**2 ) ) 7648 zdirs(:) = COS( zcent(:) ) / ( dz(1) * yxlen * SIN( zcent(:) ) ) 7649 yxdir(:) = yxdir(:) / yxlen 7650 7651 CALL raytrace_2d( ta, yxdir, nzn, zdirs, surfstart(myid) + isurflt, facearea(td), & 7652 vffrac(itarg0:itarg1), .TRUE., .TRUE., .FALSE., lowest_free_ray, & 7653 ztransp(itarg0:itarg1), itarget(itarg0:itarg1) ) 7654 7655 skyvf(isurflt) = skyvf(isurflt) + SUM( vffrac(itarg0:itarg0+lowest_free_ray-1) ) 7656 skyvft(isurflt) = skyvft(isurflt) + SUM( ztransp(itarg0:itarg0+lowest_free_ray-1) & 7657 * vffrac(itarg0:itarg0+lowest_free_ray-1) ) 7658 7659 !-- Save direct solar transparency 7660 j = MODULO( NINT( azmid/ ( 2._wp * pi ) * raytrace_discrete_azims - .5_wp, iwp ), & 7661 raytrace_discrete_azims ) 7662 7663 DO k = 1, raytrace_discrete_elevs / 2 7664 i = dsidir_rev(k-1, j) 7665 IF ( i /= -1 .AND. k <= lowest_free_ray ) dsitrans(isurflt, i) = ztransp(itarg0+k-1) 7666 ENDDO 7667 7668 ! 7669 !-- Advance itarget indices 7670 itarg0 = itarg1 + 1 7671 itarg1 = itarg1 + nzn 7672 ENDDO 7673 7674 IF ( rad_angular_discretization ) THEN 7675 !-- sort itarget by face id 7676 CALL quicksort_itarget( itarget, vffrac, ztransp, 1, nzn * naz ) 7677 ! 7678 !-- For aggregation, we need fractions multiplied by transmissivities 7679 ztransp(:) = vffrac(:) * ztransp(:) 7680 ! 7681 !-- Find the first valid position 7682 itarg0 = 1 7683 DO WHILE ( itarg0 <= nzn * naz ) 7684 IF ( itarget(itarg0) /= -1 ) EXIT 7685 itarg0 = itarg0 + 1 7686 ENDDO 7687 7688 DO i = itarg0, nzn * naz 7689 ! 7690 !-- For duplicate values, only sum up vf fraction value 7691 IF ( i < nzn * naz ) THEN 7692 IF ( itarget(i+1) == itarget(i) ) THEN 7693 vffrac(i+1) = vffrac(i+1) + vffrac(i) 7694 ztransp(i+1) = ztransp(i+1) + ztransp(i) 7695 CYCLE 7696 ENDIF 7697 ENDIF 7698 ! 7699 !-- Write to the svf array 7700 nsvfl = nsvfl + 1 7701 !-- Check dimmension of asvf array and enlarge it if needed 7702 IF ( nsvfla < nsvfl ) THEN 7703 k = CEILING( REAL( nsvfla, KIND = wp ) * grow_factor ) 7704 IF ( msvf == 0 ) THEN 7705 msvf = 1 7706 ALLOCATE( asvf1(k) ) 7707 asvf => asvf1 7708 asvf1(1:nsvfla) = asvf2 7709 DEALLOCATE( asvf2 ) 7710 ELSE 7711 msvf = 0 7712 ALLOCATE( asvf2(k) ) 7713 asvf => asvf2 7714 asvf2(1:nsvfla) = asvf1 7715 DEALLOCATE( asvf1 ) 7716 ENDIF 7717 7718 IF ( debug_output ) THEN 7719 WRITE( debug_string, '(A,3I12)' ) 'Grow asvf:', nsvfl, nsvfla, k 7720 CALL debug_message( debug_string, 'info' ) 7721 ENDIF 7722 7723 nsvfla = k 7724 ENDIF 7725 !-- Write svf values into the array 7726 asvf(nsvfl)%isurflt = isurflt 7727 asvf(nsvfl)%isurfs = itarget(i) 7728 asvf(nsvfl)%rsvf = vffrac(i) 7729 asvf(nsvfl)%rtransp = ztransp(i) / vffrac(i) 7730 END DO 7731 7732 ENDIF ! rad_angular_discretization 7733 7734 DEALLOCATE ( zdirs, zcent, zbdry, vffrac, ztransp, itarget ) !FIXME itarget shall be allocated only 7735 !in case of rad_angular_discretization 7736 ! 7737 !-- Following calculations only required for surface_reflections 7738 IF ( surface_reflections .AND. .NOT. rad_angular_discretization ) THEN 7739 7740 DO isurfs = 1, nsurf 7741 IF ( .NOT. surface_facing(surfl(ix, isurflt), surfl(iy, isurflt), & 7742 surfl(iz, isurflt), surfl(id, isurflt), surf(ix, isurfs), surf(iy, isurfs), & 7743 surf(iz, isurfs), surf(id, isurfs)) ) THEN 7744 CYCLE 7745 ENDIF 7746 7747 sd = surf(id, isurfs) 7748 sa = (/ REAL( surf(iz, isurfs), wp ) - 0.5_wp * kdir(sd), & 7749 REAL( surf(iy, isurfs), wp ) - 0.5_wp * jdir(sd), & 7750 REAL( surf(ix, isurfs), wp ) - 0.5_wp * idir(sd) /) 7751 ! 7752 !-- Unit vector source -> target 7753 uv = (/ ( ta(1) - sa(1) ) * dz(1), ( ta(2) - sa(2) ) * dy, ( ta(3) - sa(3) ) * dx /) 7754 sqdist = SUM( uv(:)**2 ) 7755 uv = uv / SQRT( sqdist ) 7756 ! 7757 !-- Reject raytracing above max distance 7758 IF ( SQRT( sqdist ) > max_raytracing_dist ) THEN 7759 ray_skip_maxdist = ray_skip_maxdist + 1 7760 CYCLE 7761 ENDIF 7762 7763 difvf = DOT_PRODUCT( (/ kdir(sd), jdir(sd), idir(sd) /), uv ) & ! cosine of source normal and direction 7764 * DOT_PRODUCT( (/ kdir(td), jdir(td), idir(td) /), - uv ) & ! cosine of target normal and reverse direction 7765 / ( pi * sqdist ) ! square of distance between centers 7766 ! 7767 !-- Irradiance factor (our unshaded shape view factor) = view factor per differential target area * source area 7768 rirrf = difvf * facearea(sd) 7769 ! 7770 !-- Reject raytracing for potentially too small view factor values 7771 IF ( rirrf < min_irrf_value ) THEN 7772 ray_skip_minval = ray_skip_minval + 1 7773 CYCLE 7774 ENDIF 7775 ! 7776 !-- raytrace + process plant canopy sinks within 7777 CALL raytrace( sa, ta, isurfs, difvf, facearea(td), .TRUE., visible, transparency ) 7778 7779 IF ( .NOT. visible ) CYCLE 7780 ! rsvf = rirrf * transparency 7781 ! 7782 !-- Write to the svf array 7783 nsvfl = nsvfl + 1 7784 !-- check dimmension of asvf array and enlarge it if needed 7785 IF ( nsvfla < nsvfl ) THEN 7786 k = CEILING( REAL( nsvfla, KIND = wp ) * grow_factor ) 7787 IF ( msvf == 0 ) THEN 7788 msvf = 1 7789 ALLOCATE( asvf1(k) ) 7790 asvf => asvf1 7791 asvf1(1:nsvfla) = asvf2 7792 DEALLOCATE( asvf2 ) 7793 ELSE 7794 msvf = 0 7795 ALLOCATE( asvf2(k) ) 7796 asvf => asvf2 7797 asvf2(1:nsvfla) = asvf1 7798 DEALLOCATE( asvf1 ) 7799 ENDIF 7800 7801 IF ( debug_output ) THEN 7802 WRITE( debug_string, '(A,3I12)' ) 'Grow asvf:', nsvfl, nsvfla, k 7803 CALL debug_message( debug_string, 'info' ) 7804 ENDIF 7805 7806 nsvfla = k 7807 ENDIF 7808 !-- Write svf values into the array 7809 asvf(nsvfl)%isurflt = isurflt 7810 asvf(nsvfl)%isurfs = isurfs 7811 asvf(nsvfl)%rsvf = rirrf !We postpone multiplication by transparency 7812 asvf(nsvfl)%rtransp = transparency !a.k.a. Direct Irradiance Factor 7813 ENDDO 7814 ENDIF 7815 ENDDO 7816 7817 ! 7818 !-- Raytrace to canopy boxes to fill dsitransc 7819 !-- TODO: consider replacing by DSI rays toward surfaces 7820 dsitransc(:,:) = 0._wp 7821 az0 = 0._wp 7822 naz = raytrace_discrete_azims 7823 azs = 2._wp * pi / REAL( naz, wp ) 7824 zn0 = 0._wp 7825 nzn = raytrace_discrete_elevs / 2 7826 zns = pi / 2._wp / REAL( nzn, wp ) 7827 ALLOCATE( zdirs(1:nzn), zcent(1:nzn), vffrac(1:nzn), ztransp(1:nzn), itarget(1:nzn) ) 7828 zcent(:) = (/( zn0+(REAL(izn,wp)-.5_wp)*zns, izn=1, nzn )/) 7829 vffrac(:) = 0._wp 7830 7831 DO ipcgb = 1, npcbl 7832 ta = (/ REAL(pcbl(iz, ipcgb), wp), REAL(pcbl(iy, ipcgb), wp), REAL(pcbl(ix, ipcgb), wp) /) 7833 !-- Calculate direct solar visibility using 2D raytracing 7834 DO iaz = 1, naz 7835 azmid = az0 + ( REAL( iaz, wp ) - .5_wp) * azs 7836 yxdir(:) = (/ COS( azmid ) / dy, SIN( azmid ) / dx /) 7837 yxlen = SQRT( SUM( yxdir(:)**2 ) ) 7838 zdirs(:) = COS( zcent(:) ) / ( dz(1) * yxlen * SIN( zcent(:) ) ) 7839 yxdir(:) = yxdir(:) / yxlen 7840 CALL raytrace_2d(ta, yxdir, nzn, zdirs, -999, -999._wp, vffrac, .FALSE., .FALSE., & 7841 .TRUE., lowest_free_ray, ztransp, itarget ) 7842 ! 7843 !-- Save direct solar transparency 7844 j = MODULO( NINT( azmid / ( 2._wp * pi ) * raytrace_discrete_azims - .5_wp, iwp ), & 7845 raytrace_discrete_azims ) 7846 DO k = 1, raytrace_discrete_elevs / 2 7847 i = dsidir_rev(k-1, j) 7848 IF ( i /= -1 .AND. k <= lowest_free_ray ) dsitransc(ipcgb, i) = ztransp(k) 7849 ENDDO 7850 ENDDO 7851 ENDDO 7852 DEALLOCATE ( zdirs, zcent, vffrac, ztransp, itarget ) 7853 ! 7854 !-- Raytrace to MRT boxes 7855 IF ( nmrtbl > 0 ) THEN 7856 mrtdsit(:,:) = 0._wp 7857 mrtsky(:) = 0._wp 7858 mrtskyt(:) = 0._wp 7859 az0 = 0._wp 7860 naz = raytrace_discrete_azims 7861 azs = 2._wp * pi / REAL( naz, wp ) 7862 zn0 = 0._wp 7863 nzn = raytrace_discrete_elevs 7864 zns = pi / REAL( nzn, wp ) 7865 ALLOCATE( zdirs(1:nzn), zcent(1:nzn), zbdry(0:nzn), vffrac(1:nzn*naz), vffrac0(1:nzn), & 7866 ztransp(1:nzn*naz), itarget(1:nzn*naz) ) !FIXME allocate itarget only 7867 !in case of rad_angular_discretization 7868 7869 zcent(:) = (/ ( zn0 + ( REAL( izn, wp ) - .5_wp ) * zns, izn = 1, nzn ) /) 7870 zbdry(:) = (/ ( zn0 + REAL( izn, wp ) * zns, izn = 0, nzn ) /) 7871 vffrac0(:) = ( COS( zbdry(0:nzn-1) ) - COS( zbdry(1:nzn) ) ) / 2._wp / REAL( naz, wp ) 7872 ! 7873 !-- Modify direction weights to simulate human body (lower weight for irradiance from zenith, 7874 !-- higher from sides) depending on selection. For mrt_geom=0, no weighting is done (simulates 7875 !-- spherical globe thermometer). 7876 SELECT CASE ( mrt_geom ) 7877 7878 CASE ( 1 ) 7879 vffrac0(:) = vffrac0(:) * MAX( 0._wp, SIN( zcent(:) ) * mrt_geom_params(2) & 7880 + COS( zcent(:) ) * mrt_geom_params(1) ) 7881 vffrac0(:) = vffrac0(:) / ( SUM( vffrac0 ) * REAL( naz, wp ) ) 7882 7883 CASE ( 2 ) 7884 vffrac0(:) = vffrac0(:) * SQRT( ( mrt_geom_params(1) * COS( zcent(:) ) )** 2 & 7885 + ( mrt_geom_params(2) * SIN( zcent(:) ) )** 2 ) 7886 vffrac0(:) = vffrac0(:) / ( SUM( vffrac0 ) * REAL( naz, wp ) ) 7887 7888 END SELECT 7889 7890 DO imrt = 1, nmrtbl 7891 ta = (/ REAL( mrtbl(iz, imrt), wp ), REAL( mrtbl(iy, imrt), wp ), & 7892 REAL( mrtbl(ix, imrt), wp ) /) 7893 ! 7894 !-- vf fractions are constant per azimuth 7895 DO iaz = 0, naz-1 7896 vffrac(iaz*nzn+1:(iaz+1)*nzn) = vffrac0(:) 7897 ENDDO 7898 !-- Sum of whole vffrac equals 1, verified 7899 itarg0 = 1 7900 itarg1 = nzn 7901 ! 7902 !-- Calculate sky-view factor and direct solar visibility using 2D raytracing 7903 DO iaz = 1, naz 7904 azmid = az0 + ( REAL( iaz, wp ) - .5_wp ) * azs 7905 yxdir(:) = (/ COS( azmid ) / dy, SIN( azmid ) / dx /) 7906 yxlen = SQRT( SUM( yxdir(:)**2 ) ) 7907 zdirs(:) = COS( zcent(:) ) / ( dz(1) * yxlen * SIN( zcent(:) ) ) 7908 yxdir(:) = yxdir(:) / yxlen 7909 7910 CALL raytrace_2d( ta, yxdir, nzn, zdirs, -999, -999._wp, vffrac(itarg0:itarg1), & 7911 .TRUE., .FALSE., .TRUE., lowest_free_ray, ztransp(itarg0:itarg1), & 7912 itarget(itarg0:itarg1) ) 7913 ! 7914 !-- Sky view factors for MRT 7915 mrtsky(imrt) = mrtsky(imrt) + SUM( vffrac(itarg0:itarg0+lowest_free_ray-1) ) 7916 mrtskyt(imrt) = mrtskyt(imrt) + SUM( ztransp(itarg0:itarg0+lowest_free_ray-1) & 7917 * vffrac(itarg0:itarg0+lowest_free_ray-1) ) 7918 !-- Direct solar transparency for MRT 7919 j = MODULO( NINT( azmid / ( 2._wp * pi ) * raytrace_discrete_azims - .5_wp, iwp ), & 7920 raytrace_discrete_azims ) 7921 DO k = 1, raytrace_discrete_elevs / 2 7922 i = dsidir_rev(k-1, j) 7923 IF ( i /= -1 .AND. k <= lowest_free_ray ) mrtdsit(imrt, i) = ztransp(itarg0+k-1) 7924 ENDDO 7925 ! 7926 !-- Advance itarget indices 7927 itarg0 = itarg1 + 1 7928 itarg1 = itarg1 + nzn 7929 ENDDO 7930 ! 7931 !-- Sort itarget by face id 7932 CALL quicksort_itarget( itarget, vffrac, ztransp, 1, nzn * naz ) 7933 ! 7934 !-- For aggregation, we need fractions multiplied by transmissivities 7935 ztransp(:) = vffrac(:) * ztransp(:) 7936 ! 7937 !-- Find the first valid position 7938 itarg0 = 1 7939 DO WHILE ( itarg0 <= nzn * naz ) 7940 IF ( itarget(itarg0) /= -1 ) EXIT 7941 itarg0 = itarg0 + 1 7942 ENDDO 7943 7944 DO i = itarg0, nzn*naz 7945 ! 7946 !-- For duplicate values, only sum up vf fraction value 7947 IF ( i < nzn * naz ) THEN 7948 IF ( itarget(i+1) == itarget(i) ) THEN 7949 vffrac(i+1) = vffrac(i+1) + vffrac(i) 7950 ztransp(i+1) = ztransp(i+1) + ztransp(i) 7951 CYCLE 7952 ENDIF 7953 ENDIF 7954 ! 7955 !-- Write to the mrtf array 7956 nmrtf = nmrtf + 1 7957 !-- Check dimmension of mrtf array and enlarge it if needed 7958 IF ( nmrtfa < nmrtf ) THEN 7959 k = CEILING( REAL( nmrtfa, KIND = wp ) * grow_factor ) 7960 IF ( mmrtf == 0 ) THEN 7961 mmrtf = 1 7962 ALLOCATE( amrtf1(k) ) 7963 amrtf => amrtf1 7964 amrtf1(1:nmrtfa) = amrtf2 7965 DEALLOCATE( amrtf2 ) 7966 ELSE 7967 mmrtf = 0 7968 ALLOCATE( amrtf2(k) ) 7969 amrtf => amrtf2 7970 amrtf2(1:nmrtfa) = amrtf1 7971 DEALLOCATE( amrtf1 ) 7972 ENDIF 7973 7974 IF ( debug_output ) THEN 7975 WRITE( debug_string, '(A,3I12)' ) 'Grow amrtf:', nmrtf, nmrtfa, k 7976 CALL debug_message( debug_string, 'info' ) 7977 ENDIF 7978 7979 nmrtfa = k 7980 ENDIF 7981 !-- Write mrtf values into the array 7982 amrtf(nmrtf)%isurflt = imrt 7983 amrtf(nmrtf)%isurfs = itarget(i) 7984 amrtf(nmrtf)%rsvf = vffrac(i) 7985 amrtf(nmrtf)%rtransp = ztransp(i) / vffrac(i) 7986 ENDDO ! itarg 7987 7988 ENDDO ! imrt 7989 DEALLOCATE( zdirs, zcent, zbdry, vffrac, vffrac0, ztransp, itarget ) 7990 ! 7991 !-- Move MRT factors to final arrays 7992 ALLOCATE( mrtf(nmrtf), mrtft(nmrtf), mrtfsurf(2,nmrtf) ) 7993 DO imrtf = 1, nmrtf 7994 mrtf(imrtf) = amrtf(imrtf)%rsvf 7995 mrtft(imrtf) = amrtf(imrtf)%rsvf * amrtf(imrtf)%rtransp 7996 mrtfsurf(:,imrtf) = (/ amrtf(imrtf)%isurflt, amrtf(imrtf)%isurfs /) 7997 ENDDO 7998 IF ( ALLOCATED( amrtf1 ) ) DEALLOCATE( amrtf1 ) 7999 IF ( ALLOCATED( amrtf2 ) ) DEALLOCATE( amrtf2 ) 8000 ENDIF ! nmrtbl > 0 8001 8002 IF ( rad_angular_discretization ) THEN 8003 #if defined( __parallel ) 8004 !-- Finalize MPI_RMA communication established to get global index of the surface from grid 8005 !-- indices. Flush all MPI window pending requests 8006 CALL MPI_Win_flush_all( win_gridsurf, ierr ) 8007 IF ( ierr /= 0 ) THEN 8008 WRITE( 9, * ) 'Error MPI_Win_flush_all1:', ierr, win_gridsurf 8009 FLUSH( 9 ) 8010 ENDIF 8011 !-- Unlock MPI window 8012 CALL MPI_Win_unlock_all( win_gridsurf, ierr ) 8013 IF ( ierr /= 0 ) THEN 8014 WRITE( 9, * ) 'Error MPI_Win_unlock_all1:', ierr, win_gridsurf 8015 FLUSH( 9 ) 8016 ENDIF 8017 !-- Free MPI window 8018 CALL MPI_Win_free( win_gridsurf, ierr ) 8019 IF ( ierr /= 0 ) THEN 8020 WRITE( 9, * ) 'Error MPI_Win_free1:', ierr, win_gridsurf 8021 FLUSH( 9 ) 8022 ENDIF 8023 #else 8024 DEALLOCATE( gridsurf ) 8025 #endif 8026 ENDIF 8027 8028 IF ( debug_output ) CALL debug_message( 'waiting for completion of SVF and CSF ' // & 8029 'calculation in all processes', 'info' ) 8030 8031 !-- Deallocate temporary global arrays 8032 DEALLOCATE( nzterr ) 8033 8034 IF ( plant_canopy ) THEN 8035 !-- Finalize mpi_rma communication and deallocate temporary arrays 8036 #if defined( __parallel ) 8037 IF ( raytrace_mpi_rma ) THEN 8038 CALL MPI_Win_flush_all( win_lad, ierr ) 8039 IF ( ierr /= 0 ) THEN 8040 WRITE( 9, * ) 'Error MPI_Win_flush_all2:', ierr, win_lad 8041 FLUSH( 9 ) 8042 ENDIF 8043 !-- Unlock MPI window 8044 CALL MPI_Win_unlock_all( win_lad, ierr ) 8045 IF ( ierr /= 0 ) THEN 8046 WRITE( 9, * ) 'Error MPI_Win_unlock_all2:', ierr, win_lad 8047 FLUSH( 9 ) 8048 ENDIF 8049 !-- Free MPI window 8050 CALL MPI_Win_free( win_lad, ierr ) 8051 IF ( ierr /= 0 ) THEN 8052 WRITE( 9, * ) 'Error MPI_Win_free2:', ierr, win_lad 8053 FLUSH( 9 ) 8054 ENDIF 8055 !-- Deallocate temporary arrays storing values for csf calculation during raytracing 8056 DEALLOCATE( lad_s_ray ) 8057 !-- sub_lad is the pointer to lad_s_rma in case of raytrace_mpi_rma and must not be 8058 !-- deallocated here 8059 ELSE 8060 DEALLOCATE( sub_lad ) 8061 DEALLOCATE( sub_lad_g ) 8062 ENDIF 8063 #else 8064 DEALLOCATE( sub_lad ) 8065 #endif 8066 DEALLOCATE( boxes ) 8067 DEALLOCATE( crlens ) 8068 DEALLOCATE( plantt ) 8069 DEALLOCATE( rt2_track, rt2_track_lad, rt2_track_dist, rt2_dist ) 8070 ENDIF 8071 8072 IF ( debug_output ) CALL debug_message( 'calculation of the complete SVF array', 'info' ) 8073 8074 IF ( rad_angular_discretization ) THEN 8075 IF ( debug_output ) THEN 8076 WRITE( debug_string, '("Load ",I0," SVFs from the structure array to plain arrays")' ) & 8077 nsvfl 8078 CALL debug_message( debug_string, 'info' ) 8079 ENDIF 8080 ALLOCATE( svf(ndsvf,nsvfl) ) 8081 ALLOCATE( svfsurf(idsvf,nsvfl) ) 8082 8083 DO isvf = 1, nsvfl 8084 svf(:, isvf) = (/ asvf(isvf)%rsvf, asvf(isvf)%rtransp /) 8085 svfsurf(:, isvf) = (/ asvf(isvf)%isurflt, asvf(isvf)%isurfs /) 8086 ENDDO 8087 ELSE 8088 IF ( debug_output ) CALL debug_message( 'Start SVF sort', 'info' ) 8089 !-- Sort svf ( a version of quicksort ) 8090 CALL quicksort_svf( asvf, 1, nsvfl ) 8091 8092 !< Load svf from the structure array to plain arrays 8093 IF ( debug_output ) THEN 8094 WRITE( debug_string, '("Load ",I0," SVFs from the structure array to plain arrays")' ) & 8095 nsvfl 8096 CALL debug_message( debug_string, 'info' ) 8097 ENDIF 8098 ALLOCATE( svf(ndsvf,nsvfl) ) 8099 ALLOCATE( svfsurf(idsvf,nsvfl) ) 8100 svfnorm_counts(:) = 0._wp 8101 isurflt_prev = -1 8102 ksvf = 1 8103 svfsum = 0._wp 8104 DO isvf = 1, nsvfl 8105 !-- Normalize svf per target face 8106 IF ( asvf(ksvf)%isurflt /= isurflt_prev ) THEN 8107 IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN 8108 !< Update histogram of logged svf normalization values 8109 i = searchsorted(svfnorm_report_thresh, svfsum / ( 1._wp - skyvf(isurflt_prev) )) 8110 svfnorm_counts(i) = svfnorm_counts(i) + 1 8111 8112 svf(1, isvf_surflt:isvf-1) = svf(1, isvf_surflt:isvf-1) / svfsum * & 8113 ( 1._wp - skyvf(isurflt_prev) ) 8114 ENDIF 8115 isurflt_prev = asvf(ksvf)%isurflt 8116 isvf_surflt = isvf 8117 svfsum = asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp 8118 ELSE 8119 svfsum = svfsum + asvf(ksvf)%rsvf !?? / asvf(ksvf)%rtransp 8120 ENDIF 8121 8122 svf(:, isvf) = (/ asvf(ksvf)%rsvf, asvf(ksvf)%rtransp /) 8123 svfsurf(:, isvf) = (/ asvf(ksvf)%isurflt, asvf(ksvf)%isurfs /) 8124 ! 8125 !-- Next element 8126 ksvf = ksvf + 1 8127 ENDDO 8128 8129 IF ( isurflt_prev /= -1 .AND. svfsum /= 0._wp ) THEN 8130 i = searchsorted(svfnorm_report_thresh, svfsum / ( 1._wp - skyvf(isurflt_prev) )) 8131 svfnorm_counts(i) = svfnorm_counts(i) + 1 8132 8133 svf(1, isvf_surflt:nsvfl) = svf(1, isvf_surflt:nsvfl) / svfsum * & 8134 ( 1._wp - skyvf(isurflt_prev) ) 8135 ENDIF 8136 WRITE( 9, * ) 'SVF normalization histogram:', svfnorm_counts, & 8137 'on thresholds:', svfnorm_report_thresh(1:svfnorm_report_num), & 8138 '(val < thresh <= val)' 8139 !TODO we should be able to deallocate skyvf, from now on we only need skyvft 8140 ENDIF ! rad_angular_discretization 8141 8142 !-- Deallocate temporary asvf array 8143 !-- DEALLOCATE(asvf) - ifort has a problem with deallocation of allocatable target via pointing 8144 !-- pointer - we need to test original targets 8145 IF ( ALLOCATED( asvf1 ) ) THEN 8146 DEALLOCATE( asvf1 ) 8147 ENDIF 8148 IF ( ALLOCATED( asvf2 ) ) THEN 8149 DEALLOCATE( asvf2 ) 8150 ENDIF 8151 8152 npcsfl = 0 8153 IF ( plant_canopy ) THEN 8154 8155 IF ( debug_output ) CALL debug_message( 'Calculation of the complete CSF array', 'info' ) 8156 !-- Sort and merge csf for the last time, keeping the array size to minimum 8157 CALL merge_and_grow_csf( - 1 ) 8158 ! 8159 !-- Aggregate csb among processors 8160 !-- Allocate necessary arrays 8161 udim = MAX( ncsfl, 1 ) 8162 ALLOCATE( csflt_l(ndcsf*udim) ) 8163 csflt(1:ndcsf,1:udim) => csflt_l(1:ndcsf*udim) 8164 ALLOCATE( kcsflt_l(kdcsf*udim) ) 8165 kcsflt(1:kdcsf,1:udim) => kcsflt_l(1:kdcsf*udim) 8166 ALLOCATE( icsflt(0:numprocs-1) ) 8167 ALLOCATE( dcsflt(0:numprocs-1) ) 8168 ALLOCATE( ipcsflt(0:numprocs-1) ) 8169 ALLOCATE( dpcsflt(0:numprocs-1) ) 8170 ! 8171 !-- Fill out arrays of csf values and arrays of number of elements and displacements for 8172 !-- particular precessors 8173 icsflt = 0 8174 dcsflt = 0 8175 ip = -1 8176 j = -1 8177 d = 0 8178 DO kcsf = 1, ncsfl 8179 j = j + 1 8180 IF ( acsf(kcsf)%ip /= ip ) THEN 8181 !-- New block of the processor 8182 !-- Number of elements of previous block 8183 IF ( ip >= 0 ) icsflt(ip) = j 8184 d = d + j 8185 !-- Blank blocks 8186 DO jp = ip + 1, acsf(kcsf)%ip - 1 8187 !-- Number of elements is zero, displacement is equal to previous 8188 icsflt(jp) = 0 8189 dcsflt(jp) = d 8190 ENDDO 8191 !-- The actual block 8192 ip = acsf(kcsf)%ip 8193 dcsflt(ip) = d 8194 j = 0 8195 ENDIF 8196 csflt(1,kcsf) = acsf(kcsf)%rcvf 8197 !-- Fill out integer values of itz,ity,itx,isurfs 8198 kcsflt(1,kcsf) = acsf(kcsf)%itz 8199 kcsflt(2,kcsf) = acsf(kcsf)%ity 8200 kcsflt(3,kcsf) = acsf(kcsf)%itx 8201 kcsflt(4,kcsf) = acsf(kcsf)%isurfs 8202 ENDDO 8203 !-- Last blank blocks at the end of array 8204 j = j + 1 8205 IF ( ip >= 0 ) icsflt(ip) = j 8206 d = d + j 8207 DO jp = ip + 1, numprocs - 1 8208 !-- Number of elements is zero, displacement is equal to previous 8209 icsflt(jp) = 0 8210 dcsflt(jp) = d 8211 ENDDO 8212 ! 8213 !-- Deallocate temporary acsf array 8214 !-- DEALLOCATE(acsf) - ifort has a problem with deallocation of allocatable target via pointing 8215 !-- pointer - we need to test original targets 8216 IF ( ALLOCATED(acsf1) ) THEN 8217 DEALLOCATE(acsf1) 8218 ENDIF 8219 IF ( ALLOCATED(acsf2) ) THEN 8220 DEALLOCATE(acsf2) 8221 ENDIF 8222 8223 #if defined( __parallel ) 8224 !-- Scatter and gather the number of elements to and from all processor and calculate 8225 !-- displacements 8226 IF ( debug_output ) CALL debug_message( 'Scatter and gather the number of elements ' // & 8227 'to and from all processor', 'info' ) 8228 8229 CALL MPI_AlltoAll( icsflt, 1, MPI_INTEGER, ipcsflt, 1, MPI_INTEGER, comm2d, ierr ) 8230 8231 IF ( ierr /= 0 ) THEN 8232 WRITE( 9, * ) 'Error MPI_AlltoAll1:', ierr, SIZE( icsflt ), SIZE( ipcsflt ) 8233 FLUSH( 9 ) 8234 ENDIF 8235 8236 npcsfl = SUM( ipcsflt ) 8237 d = 0 8238 DO i = 0, numprocs-1 8239 dpcsflt(i) = d 8240 d = d + ipcsflt(i) 8241 ENDDO 8242 8243 !-- Exchange csf fields between processors 8244 IF ( debug_output ) CALL debug_message( 'Exchange csf fields between processors', 'info' ) 8245 udim = MAX( npcsfl, 1 ) 8246 ALLOCATE( pcsflt_l(ndcsf*udim) ) 8247 pcsflt(1:ndcsf,1:udim) => pcsflt_l(1:ndcsf*udim) 8248 ALLOCATE( kpcsflt_l(kdcsf*udim) ) 8249 kpcsflt(1:kdcsf,1:udim) => kpcsflt_l(1:kdcsf*udim) 8250 CALL MPI_AlltoAllv( csflt_l, ndcsf * icsflt, ndcsf * dcsflt, MPI_REAL, pcsflt_l, & 8251 ndcsf * ipcsflt, ndcsf * dpcsflt, MPI_REAL, comm2d, ierr ) 8252 IF ( ierr /= 0 ) THEN 8253 WRITE( 9, * ) 'Error MPI_AlltoAllv1:', ierr, SIZE( ipcsflt ), ndcsf * icsflt, & 8254 ndcsf * dcsflt, SIZE( pcsflt_l ), ndcsf * ipcsflt, ndcsf * dpcsflt 8255 FLUSH( 9 ) 8256 ENDIF 8257 8258 CALL MPI_AlltoAllv( kcsflt_l, kdcsf * icsflt, kdcsf * dcsflt, MPI_INTEGER, kpcsflt_l, & 8259 kdcsf * ipcsflt, kdcsf * dpcsflt, MPI_INTEGER, comm2d, ierr ) 8260 IF ( ierr /= 0 ) THEN 8261 WRITE( 9, * ) 'Error MPI_AlltoAllv2:', ierr, SIZE( kcsflt_l ), kdcsf * icsflt, & 8262 kdcsf * dcsflt, SIZE( kpcsflt_l ), kdcsf * ipcsflt, kdcsf * dpcsflt 8263 FLUSH( 9 ) 8264 ENDIF 8265 8266 #else 8267 npcsfl = ncsfl 8268 ALLOCATE( pcsflt(ndcsf,MAX( npcsfl, ndcsf )) ) 8269 ALLOCATE( kpcsflt(kdcsf,MAX( npcsfl, kdcsf )) ) 8270 pcsflt = csflt 8271 kpcsflt = kcsflt 8272 #endif 8273 ! 8274 !-- Deallocate temporary arrays 8275 DEALLOCATE( csflt_l ) 8276 DEALLOCATE( kcsflt_l ) 8277 DEALLOCATE( icsflt ) 8278 DEALLOCATE( dcsflt ) 8279 DEALLOCATE( ipcsflt ) 8280 DEALLOCATE( dpcsflt ) 8281 ! 8282 !-- Sort csf ( a version of quicksort ) 8283 IF ( debug_output ) CALL debug_message( 'Sort csf', 'info' ) 8284 CALL quicksort_csf2( kpcsflt, pcsflt, 1, npcsfl ) 8285 ! 8286 !-- Aggregate canopy sink factor records with identical box & source againg across all values 8287 !-- from all processors 8288 IF ( debug_output ) CALL debug_message( 'Aggregate canopy sink factor records with ' // & 8289 'identical box', 'info' ) 8290 8291 IF ( npcsfl > 0 ) THEN 8292 icsf = 1 !< reading index 8293 kcsf = 1 !< writing index 8294 DO WHILE (icsf < npcsfl) 8295 !-- Here kpcsf(kcsf) already has values from kpcsf(icsf) 8296 IF ( kpcsflt(3,icsf) == kpcsflt(3,icsf+1) .AND. & 8297 kpcsflt(2,icsf) == kpcsflt(2,icsf+1) .AND. & 8298 kpcsflt(1,icsf) == kpcsflt(1,icsf+1) .AND. & 8299 kpcsflt(4,icsf) == kpcsflt(4,icsf+1) ) THEN 8300 8301 pcsflt(1,kcsf) = pcsflt(1,kcsf) + pcsflt(1,icsf+1) 8302 8303 !-- Advance reading index, keep writing index 8304 icsf = icsf + 1 8305 ELSE 8306 !-- Not identical, just advance and copy 8307 icsf = icsf + 1 8308 kcsf = kcsf + 1 8309 kpcsflt(:,kcsf) = kpcsflt(:,icsf) 8310 pcsflt(:,kcsf) = pcsflt(:,icsf) 8311 ENDIF 8312 ENDDO 8313 !-- Last written item is now also the last item in valid part of array 8314 npcsfl = kcsf 8315 ENDIF 8316 8317 ncsfl = npcsfl 8318 IF ( ncsfl > 0 ) THEN 8319 ALLOCATE( csf(ndcsf,ncsfl) ) 8320 ALLOCATE( csfsurf(idcsf,ncsfl) ) 8321 DO icsf = 1, ncsfl 8322 csf(:,icsf) = pcsflt(:,icsf) 8323 csfsurf(1,icsf) = gridpcbl(kpcsflt(1,icsf),kpcsflt(2,icsf),kpcsflt(3,icsf)) 8324 csfsurf(2,icsf) = kpcsflt(4,icsf) 8671 cursink = 1._wp - exp(-ext_coef * lad_s_target * crlens(i)*realdist) 8672 8673 IF ( create_csf ) THEN 8674 !-- write svf values into the array 8675 ncsfl = ncsfl + 1 8676 acsf(ncsfl)%ip = lad_ip(i) 8677 acsf(ncsfl)%itx = boxes(3,i) 8678 acsf(ncsfl)%ity = boxes(2,i) 8679 acsf(ncsfl)%itz = boxes(1,i) 8680 acsf(ncsfl)%isurfs = isrc 8681 acsf(ncsfl)%rcvf = cursink*transparency*difvf*atarg 8682 ENDIF !< create_csf 8683 8684 transparency = transparency * (1._wp - cursink) 8685 8325 8686 ENDDO 8326 8687 ENDIF 8327 8688 8328 !-- Deallocation of temporary arrays 8329 IF ( npcbl > 0 ) DEALLOCATE( gridpcbl ) 8330 DEALLOCATE( pcsflt_l ) 8331 DEALLOCATE( kpcsflt_l ) 8332 IF ( debug_output ) THEN 8333 WRITE( debug_string, '("Finished aggregating ",I0," CSFs.")' ) ncsfl 8334 CALL debug_message( debug_string, 'info' ) 8335 ENDIF 8336 8337 ENDIF 8338 8339 #if defined( __parallel ) 8340 CALL MPI_BARRIER( comm2d, ierr ) 8341 #endif 8342 CALL location_message( 'calculating view factors for radiation interaction', 'finished' ) 8343 8344 RETURN !Todo: remove 8345 8346 ! WRITE( message_string, * ) & 8347 ! 'I/O error when processing shape view factors / ', & 8348 ! 'plant canopy sink factors / direct irradiance factors.' 8349 ! CALL message( 'init_urban_surface', 'PA0502', 2, 2, 0, 6, 0 ) 8350 8351 END SUBROUTINE radiation_calc_svf 8352 8353 8354 !--------------------------------------------------------------------------------------------------! 8689 visible = .TRUE. 8690 8691 END SUBROUTINE raytrace 8692 8693 8694 !------------------------------------------------------------------------------! 8355 8695 ! Description: 8356 8696 ! ------------ 8357 !> Raytracing for detecting obstacles and calculating compound canopy sink factors for RTM. 8358 !> (A simple obstacle detection would only need to process faces in 3 dimensions without any 8359 !> ordering.) 8360 !> Assumtions: 8361 !> ----------- 8362 !> 1. The ray always originates from a face midpoint (only one coordinate equals *.5, i.e. wall) and 8363 !> doesn't travel parallel to the surface (that would mean shape factor=0). Therefore, the ray 8364 !> may never travel exactly along a face or an edge. 8365 !> 2. From grid bottom to urban surface top the grid has to be *equidistant* within each of the 8366 !> dimensions, including vertical (but the resolution doesn't need to be the same in all three 8367 !> dimensions). 8368 !--------------------------------------------------------------------------------------------------! 8369 SUBROUTINE raytrace( src, targ, isrc, difvf, atarg, create_csf, visible, transparency ) 8370 IMPLICIT NONE 8371 8372 INTEGER(iwp) :: i, k, d !< 8373 INTEGER(iwp) :: seldim !< dimension to be incremented 8374 INTEGER(iwp) :: ncsb !< no of written plant canopy sinkboxes 8375 INTEGER(iwp) :: maxboxes !< max no of gridboxes visited 8376 INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array 8377 INTEGER(iwp), INTENT(in) :: isrc !< index of source face for csf 8378 8379 INTEGER(iwp), DIMENSION(3) :: box !< gridbox being crossed 8380 INTEGER(iwp), DIMENSION(3) :: dimnext !< next dimension increments along path 8381 INTEGER(iwp), DIMENSION(3) :: dimdelta !< dimension direction = +- 1 8382 8383 LOGICAL, INTENT(IN) :: create_csf !< whether to generate new CSFs during raytracing 8384 LOGICAL, INTENT(OUT) :: visible !< 8385 8386 REAL(wp) :: eps = 1E-10_wp !< epsilon for value comparison 8387 REAL(wp) :: lad_s_target !< recieved lad_s of particular grid box 8388 REAL(wp) :: distance !< euclidean along path 8389 REAL(wp) :: crlen !< length of gridbox crossing 8390 REAL(wp) :: lastdist !< beginning of current crossing 8391 REAL(wp) :: nextdist !< end of current crossing 8392 REAL(wp) :: realdist !< distance in meters per unit distance 8393 REAL(wp) :: crmid !< midpoint of crossing 8394 REAL(wp) :: cursink !< sink factor for current canopy box 8395 8396 REAL(wp), INTENT(IN) :: difvf !< differential view factor for csf 8397 REAL(wp), INTENT(IN) :: atarg !< target surface area for csf 8398 REAL(wp), INTENT(OUT) :: transparency !< along whole path 8399 8400 REAL(wp), DIMENSION(3) :: delta !< path vector 8401 REAL(wp), DIMENSION(3) :: uvect !< unit vector 8402 REAL(wp), DIMENSION(3) :: dimnextdist !< distance for each dimension increments 8403 8404 REAL(wp), DIMENSION(3), INTENT(in) :: src, targ !< real coordinates z,y,x 8405 8406 ! 8407 !-- Maximum number of gridboxes visited equals the maximum number of boundaries crossed in each 8408 !-- dimension plus one. That's also the maximum number of plant canopy boxes written. We grow the 8409 !-- acsf array accordingly using exponential factor. 8410 maxboxes = SUM( ABS( NINT( targ, iwp ) - NINT( src, iwp ) ) ) + 1 8411 IF ( plant_canopy .AND. ncsfl + maxboxes > ncsfla ) THEN 8412 !-- Use this code for growing by fixed exponential increments (equivalent to case where ncsfl 8413 !-- always increases by 1) 8414 !-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) & 8415 !-- / log(grow_factor)), kind=wp)) 8416 !-- Or use this code to simply always keep some extra space after growing 8417 k = CEILING( REAL( ncsfl + maxboxes, KIND = wp ) * grow_factor ) 8418 8419 CALL merge_and_grow_csf(k) 8420 ENDIF 8421 8422 transparency = 1._wp 8423 ncsb = 0 8424 8425 delta(:) = targ(:) - src(:) 8426 distance = SQRT( SUM( delta(:)**2 ) ) 8427 IF ( distance == 0._wp ) THEN 8428 visible = .TRUE. 8429 RETURN 8430 ENDIF 8431 uvect(:) = delta(:) / distance 8432 realdist = SQRT( SUM( (uvect(:) * (/ dz(1), dy, dx /) )**2 ) ) 8433 8434 lastdist = 0._wp 8435 ! 8436 !-- Since all face coordinates have values *.5 and we'd like to use integers, all these have .5 added 8437 DO d = 1, 3 8438 IF ( uvect(d) == 0._wp ) THEN 8439 dimnext(d) = 999999999 8440 dimdelta(d) = 999999999 8441 dimnextdist(d) = 1.0E20_wp 8442 ELSE IF ( uvect(d) > 0._wp ) THEN 8443 dimnext(d) = CEILING( src(d) + .5_wp ) 8444 dimdelta(d) = 1 8445 dimnextdist(d) = ( dimnext(d) - .5_wp - src(d) ) / uvect(d) 8446 ELSE 8447 dimnext(d) = FLOOR( src(d) + .5_wp ) 8448 dimdelta(d) = -1 8449 dimnextdist(d) = ( dimnext(d) - .5_wp - src(d) ) / uvect(d) 8450 ENDIF 8451 ENDDO 8452 8453 DO 8454 !-- Along what dimension will the next wall crossing be? 8455 seldim = MINLOC( dimnextdist, 1 ) 8456 nextdist = dimnextdist(seldim) 8457 IF ( nextdist > distance ) nextdist = distance 8458 8459 crlen = nextdist - lastdist 8460 IF ( crlen > .001_wp ) THEN 8461 crmid = ( lastdist + nextdist ) * .5_wp 8462 box = NINT( src(:) + uvect(:) * crmid, iwp ) 8463 ! 8464 !-- Calculate index of the grid with global indices (box(2),box(3)) in the array nzterr and 8465 !-- plantt and id of the coresponding processor 8466 CALL radiation_calc_global_offset( box(3), box(2), 0, 1, offs_glob = ig ) 8467 IF ( box(1) <= nzterr(ig) ) THEN 8468 visible = .FALSE. 8469 RETURN 8697 !> A new, more efficient version of ray tracing algorithm that processes a whole 8698 !> arc instead of a single ray (new in RTM version 2.5). 8699 !> 8700 !> In all comments, horizon means tangent of horizon angle, i.e. 8701 !> vertical_delta / horizontal_distance 8702 !------------------------------------------------------------------------------! 8703 SUBROUTINE raytrace_2d(origin, yxdir, nrays, zdirs, iorig, aorig, vffrac, & 8704 calc_svf, create_csf, skip_1st_pcb, & 8705 lowest_free_ray, transparency, itarget) 8706 IMPLICIT NONE 8707 8708 REAL(wp), DIMENSION(3), INTENT(IN) :: origin !< z,y,x coordinates of ray origin 8709 REAL(wp), DIMENSION(2), INTENT(IN) :: yxdir !< y,x *unit* vector of ray direction (in grid units) 8710 INTEGER(iwp) :: nrays !< number of rays (z directions) to raytrace 8711 REAL(wp), DIMENSION(nrays), INTENT(IN) :: zdirs !< list of z directions to raytrace (z/hdist, grid, zenith->nadir) 8712 INTEGER(iwp), INTENT(in) :: iorig !< index of origin face for csf 8713 REAL(wp), INTENT(in) :: aorig !< origin face area for csf 8714 REAL(wp), DIMENSION(nrays), INTENT(in) :: vffrac !< view factor fractions of each ray for csf 8715 LOGICAL, INTENT(in) :: calc_svf !< whether to calculate SFV (identify obstacle surfaces) 8716 LOGICAL, INTENT(in) :: create_csf !< whether to create canopy sink factors 8717 LOGICAL, INTENT(in) :: skip_1st_pcb !< whether to skip first plant canopy box during raytracing 8718 INTEGER(iwp), INTENT(out) :: lowest_free_ray !< index into zdirs 8719 REAL(wp), DIMENSION(nrays), INTENT(OUT) :: transparency !< transparencies of zdirs paths 8720 INTEGER(iwp), DIMENSION(nrays), INTENT(OUT) :: itarget !< global indices of target faces for zdirs 8721 8722 INTEGER(iwp), DIMENSION(nrays) :: target_procs 8723 REAL(wp) :: horizon !< highest horizon found after raytracing (z/hdist) 8724 INTEGER(iwp) :: i, k, l, d 8725 INTEGER(iwp) :: seldim !< dimension to be incremented 8726 REAL(wp), DIMENSION(2) :: yxorigin !< horizontal copy of origin (y,x) 8727 REAL(wp) :: distance !< euclidean along path 8728 REAL(wp) :: lastdist !< beginning of current crossing 8729 REAL(wp) :: nextdist !< end of current crossing 8730 REAL(wp) :: crmid !< midpoint of crossing 8731 REAL(wp) :: horz_entry !< horizon at entry to column 8732 REAL(wp) :: horz_exit !< horizon at exit from column 8733 REAL(wp) :: bdydim !< boundary for current dimension 8734 REAL(wp), DIMENSION(2) :: crossdist !< distances to boundary for dimensions 8735 REAL(wp), DIMENSION(2) :: dimnextdist !< distance for each dimension increments 8736 INTEGER(iwp), DIMENSION(2) :: column !< grid column being crossed 8737 INTEGER(iwp), DIMENSION(2) :: dimnext !< next dimension increments along path 8738 INTEGER(iwp), DIMENSION(2) :: dimdelta !< dimension direction = +- 1 8739 INTEGER(iwp) :: ip !< number of processor where gridbox reside 8740 INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array 8741 INTEGER(iwp) :: maxboxes !< max no of CSF created 8742 INTEGER(iwp) :: nly !< maximum plant canopy height 8743 INTEGER(iwp) :: ntrack 8744 8745 INTEGER(iwp) :: zb0 8746 INTEGER(iwp) :: zb1 8747 INTEGER(iwp) :: nz 8748 INTEGER(iwp) :: iz 8749 INTEGER(iwp) :: zsgn 8750 INTEGER(iwp) :: lastdir !< wall direction before hitting this column 8751 INTEGER(iwp), DIMENSION(2) :: lastcolumn 8752 8753 #if defined( __parallel ) 8754 INTEGER(iwp) :: lowest_lad !< lowest column cell for which we need LAD 8755 INTEGER(iwp) :: wcount !< RMA window item count 8756 INTEGER(MPI_ADDRESS_KIND) :: wdisp !< RMA window displacement 8757 #endif 8758 8759 REAL(wp) :: eps = 1E-10_wp !< epsilon for value comparison 8760 REAL(wp) :: zbottom, ztop !< urban surface boundary in real numbers 8761 REAL(wp) :: zorig !< z coordinate of ray column entry 8762 REAL(wp) :: zexit !< z coordinate of ray column exit 8763 REAL(wp) :: qdist !< ratio of real distance to z coord difference 8764 REAL(wp) :: dxxyy !< square of real horizontal distance 8765 REAL(wp) :: curtrans !< transparency of current PC box crossing 8766 8767 8768 8769 yxorigin(:) = origin(2:3) 8770 transparency(:) = 1._wp !-- Pre-set the all rays to transparent before reducing 8771 horizon = -HUGE(1._wp) 8772 lowest_free_ray = nrays 8773 IF ( rad_angular_discretization .AND. calc_svf ) THEN 8774 ALLOCATE(target_surfl(nrays)) 8775 target_surfl(:) = -1 8776 lastdir = -999 8777 lastcolumn(:) = -999 8778 ENDIF 8779 8780 !-- Determine distance to boundary (in 2D xy) 8781 IF ( yxdir(1) > 0._wp ) THEN 8782 bdydim = ny + .5_wp !< north global boundary 8783 crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1) 8784 ELSEIF ( yxdir(1) == 0._wp ) THEN 8785 crossdist(1) = HUGE(1._wp) 8786 ELSE 8787 bdydim = -.5_wp !< south global boundary 8788 crossdist(1) = (bdydim - yxorigin(1)) / yxdir(1) 8789 ENDIF 8790 8791 IF ( yxdir(2) > 0._wp ) THEN 8792 bdydim = nx + .5_wp !< east global boundary 8793 crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2) 8794 ELSEIF ( yxdir(2) == 0._wp ) THEN 8795 crossdist(2) = HUGE(1._wp) 8796 ELSE 8797 bdydim = -.5_wp !< west global boundary 8798 crossdist(2) = (bdydim - yxorigin(2)) / yxdir(2) 8799 ENDIF 8800 distance = minval(crossdist, 1) 8801 8802 IF ( plant_canopy ) THEN 8803 rt2_track_dist(0) = 0._wp 8804 rt2_track_lad(:,:) = 0._wp 8805 nly = plantt_max - nz_urban_b + 1 8806 ENDIF 8807 8808 lastdist = 0._wp 8809 8810 !-- Since all face coordinates have values *.5 and we'd like to use 8811 !-- integers, all these have .5 added 8812 DO d = 1, 2 8813 IF ( yxdir(d) == 0._wp ) THEN 8814 dimnext(d) = HUGE(1_iwp) 8815 dimdelta(d) = HUGE(1_iwp) 8816 dimnextdist(d) = HUGE(1._wp) 8817 ELSE IF ( yxdir(d) > 0._wp ) THEN 8818 dimnext(d) = FLOOR(yxorigin(d) + .5_wp) + 1 8819 dimdelta(d) = 1 8820 dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d) 8821 ELSE 8822 dimnext(d) = CEILING(yxorigin(d) + .5_wp) - 1 8823 dimdelta(d) = -1 8824 dimnextdist(d) = (dimnext(d) - .5_wp - yxorigin(d)) / yxdir(d) 8825 ENDIF 8826 ENDDO 8827 8828 ntrack = 0 8829 DO 8830 !-- along what dimension will the next wall crossing be? 8831 seldim = minloc(dimnextdist, 1) 8832 nextdist = dimnextdist(seldim) 8833 IF ( nextdist > distance ) nextdist = distance 8834 8835 IF ( nextdist > lastdist ) THEN 8836 ntrack = ntrack + 1 8837 crmid = (lastdist + nextdist) * .5_wp 8838 column = NINT(yxorigin(:) + yxdir(:) * crmid, iwp) 8839 8840 !-- calculate index of the grid with global indices (column(1),column(2)) 8841 !-- in the array nzterr and plantt and id of the coresponding processor 8842 CALL radiation_calc_global_offset( column(2), column(1), 0, 1, offs_glob=ig ) 8843 8844 IF ( lastdist == 0._wp ) THEN 8845 horz_entry = -HUGE(1._wp) 8846 ELSE 8847 horz_entry = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / lastdist 8470 8848 ENDIF 8849 horz_exit = (REAL(nzterr(ig), wp) + .5_wp - origin(1)) / nextdist 8850 8851 IF ( rad_angular_discretization .AND. calc_svf ) THEN 8852 ! 8853 !-- Identify vertical obstacles hit by rays in current column 8854 DO WHILE ( lowest_free_ray > 0 ) 8855 IF ( zdirs(lowest_free_ray) > horz_entry ) EXIT 8856 ! 8857 !-- This may only happen after 1st column, so lastdir and lastcolumn are valid 8858 CALL request_itarget(lastdir, & 8859 CEILING(-0.5_wp + origin(1) + zdirs(lowest_free_ray)*lastdist), & 8860 lastcolumn(1), lastcolumn(2), & 8861 target_surfl(lowest_free_ray), target_procs(lowest_free_ray)) 8862 lowest_free_ray = lowest_free_ray - 1 8863 ENDDO 8864 ! 8865 !-- Identify horizontal obstacles hit by rays in current column 8866 DO WHILE ( lowest_free_ray > 0 ) 8867 IF ( zdirs(lowest_free_ray) > horz_exit ) EXIT 8868 CALL request_itarget(iup_u, nzterr(ig)+1, column(1), column(2), & 8869 target_surfl(lowest_free_ray), & 8870 target_procs(lowest_free_ray)) 8871 lowest_free_ray = lowest_free_ray - 1 8872 ENDDO 8873 ENDIF 8874 8875 horizon = MAX(horizon, horz_entry, horz_exit) 8471 8876 8472 8877 IF ( plant_canopy ) THEN 8473 IF ( box(1) <= plantt(ig) ) THEN 8474 ncsb = ncsb + 1 8475 boxes(:,ncsb) = box 8476 crlens(ncsb) = crlen 8878 rt2_track(:, ntrack) = column(:) 8879 rt2_track_dist(ntrack) = nextdist 8880 ENDIF 8881 ENDIF 8882 8883 IF ( nextdist + eps >= distance ) EXIT 8884 8885 IF ( rad_angular_discretization .AND. calc_svf ) THEN 8886 ! 8887 !-- Save wall direction of coming building column (= this air column) 8888 IF ( seldim == 1 ) THEN 8889 IF ( dimdelta(seldim) == 1 ) THEN 8890 lastdir = isouth_u 8891 ELSE 8892 lastdir = inorth_u 8893 ENDIF 8894 ELSE 8895 IF ( dimdelta(seldim) == 1 ) THEN 8896 lastdir = iwest_u 8897 ELSE 8898 lastdir = ieast_u 8899 ENDIF 8900 ENDIF 8901 lastcolumn = column 8902 ENDIF 8903 lastdist = nextdist 8904 dimnext(seldim) = dimnext(seldim) + dimdelta(seldim) 8905 dimnextdist(seldim) = (dimnext(seldim) - .5_wp - yxorigin(seldim)) / yxdir(seldim) 8906 ENDDO 8907 8908 IF ( plant_canopy ) THEN 8909 !-- Request LAD WHERE applicable 8910 !-- 8477 8911 #if defined( __parallel ) 8478 CALL radiation_calc_global_offset( box(3), box(2), box(1) - nz_urban_b, & 8479 nz_plant, iproc = lad_ip(ncsb), & 8480 offs_proc = lad_disp(ncsb) ) 8481 #endif 8482 ENDIF 8483 ENDIF 8484 ENDIF 8485 8486 IF ( ABS( distance - nextdist ) < eps ) EXIT 8487 lastdist = nextdist 8488 dimnext(seldim) = dimnext(seldim) + dimdelta(seldim) 8489 dimnextdist(seldim) = ( dimnext(seldim) - .5_wp - src(seldim) ) / uvect(seldim) 8490 ENDDO 8491 8492 IF ( plant_canopy ) THEN 8493 #if defined( __parallel ) 8494 IF ( raytrace_mpi_rma ) THEN 8495 !-- Send requests for lad_s to appropriate processor 8496 CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'start' ) 8497 DO i = 1, ncsb 8498 CALL MPI_Get( lad_s_ray(i), 1, MPI_REAL, lad_ip(i), lad_disp(i), 1, MPI_REAL, & 8499 win_lad, ierr ) 8912 IF ( raytrace_mpi_rma ) THEN 8913 !-- send requests for lad_s to appropriate processor 8914 !CALL cpu_log( log_point_s(77), 'usm_init_rma', 'start' ) 8915 DO i = 1, ntrack 8916 CALL radiation_calc_global_offset( rt2_track(2,i), rt2_track(1,i), 0, 1, & 8917 offs_glob=ig ) 8918 8919 IF ( rad_angular_discretization .AND. calc_svf ) THEN 8920 ! 8921 !-- For fixed view resolution, we need plant canopy even for rays 8922 !-- to opposing surfaces 8923 lowest_lad = nzterr(ig) + 1 8924 ELSE 8925 ! 8926 !-- We only need LAD for rays directed above horizon (to sky) 8927 lowest_lad = CEILING( -0.5_wp + origin(1) + & 8928 MIN( horizon * rt2_track_dist(i-1), & ! entry 8929 horizon * rt2_track_dist(i) ) ) ! exit 8930 ENDIF 8931 ! 8932 !-- Skip asking for LAD where all plant canopy is under requested level 8933 IF ( plantt(ig) < lowest_lad ) CYCLE 8934 8935 CALL radiation_calc_global_offset( rt2_track(2,i), rt2_track(1,i), & 8936 lowest_lad-nz_urban_b, nz_plant, iproc=ip, & 8937 offs_proc=wdisp ) 8938 wcount = plantt(ig)-lowest_lad+1 8939 ! TODO send request ASAP - even during raytracing 8940 CALL MPI_Get(rt2_track_lad(lowest_lad:plantt(ig), i), wcount, MPI_REAL, ip, & 8941 wdisp, wcount, MPI_REAL, win_lad, ierr) 8500 8942 IF ( ierr /= 0 ) THEN 8501 WRITE( 9, * ) 'Error MPI_Get1:', ierr, lad_s_ray(i), lad_ip(i), lad_disp(i),&8502 8503 FLUSH( 9)8943 WRITE(9,*) 'Error MPI_Get2:', ierr, rt2_track_lad(lowest_lad:plantt(ig), i), & 8944 wcount, ip, wdisp, win_lad 8945 FLUSH(9) 8504 8946 ENDIF 8505 8947 ENDDO 8506 8948 8507 !-- Wait for all pending local requests to complete 8508 CALL MPI_Win_flush_local_all( win_lad, ierr ) 8949 !-- wait for all pending local requests complete 8950 ! TODO WAIT selectively for each column later when needed 8951 CALL MPI_Win_flush_local_all(win_lad, ierr) 8509 8952 IF ( ierr /= 0 ) THEN 8510 WRITE( 9, * ) 'Error MPI_Win_flush_local_all1:', ierr, win_lad8511 FLUSH( 9)8953 WRITE(9,*) 'Error MPI_Win_flush_local_all2:', ierr, win_lad 8954 FLUSH(9) 8512 8955 ENDIF 8513 CALL cpu_log( log_point_s(77), 'rad_rma_lad', 'stop' ) 8514 8515 ENDIF 8956 !CALL cpu_log( log_point_s(77), 'usm_init_rma', 'stop' ) 8957 8958 ELSE ! raytrace_mpi_rma = .F. 8959 DO i = 1, ntrack 8960 CALL radiation_calc_global_offset( rt2_track(2,i), rt2_track(1,i), 0, nz_plant, & 8961 offs_glob=ig ) 8962 rt2_track_lad(nz_urban_b:plantt_max, i) = sub_lad_g(ig:ig+nly-1) 8963 ENDDO 8964 ENDIF 8965 #else 8966 DO i = 1, ntrack 8967 rt2_track_lad(nz_urban_b:plantt_max, i) = sub_lad(rt2_track(1,i), rt2_track(2,i), nz_urban_b:plantt_max) 8968 ENDDO 8516 8969 #endif 8517 8518 !-- Calculate csf and transparency 8519 DO i = 1, ncsb8970 ENDIF ! plant_canopy 8971 8972 IF ( rad_angular_discretization .AND. calc_svf ) THEN 8520 8973 #if defined( __parallel ) 8521 IF ( raytrace_mpi_rma ) THEN 8522 lad_s_target = lad_s_ray(i) 8523 ELSE 8524 lad_s_target = sub_lad_g(lad_ip(i) * nnx * nny * nz_plant + lad_disp(i)) 8525 ENDIF 8974 !-- wait for all gridsurf requests to complete 8975 CALL MPI_Win_flush_local_all(win_gridsurf, ierr) 8976 IF ( ierr /= 0 ) THEN 8977 WRITE(9,*) 'Error MPI_Win_flush_local_all3:', ierr, win_gridsurf 8978 FLUSH(9) 8979 ENDIF 8980 #endif 8981 ! 8982 !-- recalculate local surf indices into global ones 8983 DO i = 1, nrays 8984 IF ( target_surfl(i) == -1 ) THEN 8985 itarget(i) = -1 8986 ELSE 8987 itarget(i) = target_surfl(i) + surfstart(target_procs(i)) 8988 ENDIF 8989 ENDDO 8990 8991 DEALLOCATE( target_surfl ) 8992 8993 ELSE 8994 itarget(:) = -1 8995 ENDIF ! rad_angular_discretization 8996 8997 IF ( plant_canopy ) THEN 8998 !-- Skip the PCB around origin if requested (for MRT, the PCB might not be there) 8999 !-- 9000 IF ( skip_1st_pcb .AND. NINT(origin(1)) <= plantt_max ) THEN 9001 rt2_track_lad(NINT(origin(1), iwp), 1) = 0._wp 9002 ENDIF 9003 9004 !-- Assert that we have space allocated for CSFs 9005 !-- 9006 maxboxes = (ntrack + MAX(CEILING(origin(1)-.5_wp) - nz_urban_b, & 9007 nz_urban_t - CEILING(origin(1)-.5_wp))) * nrays 9008 IF ( ncsfl + maxboxes > ncsfla ) THEN 9009 !-- use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1) 9010 !-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) & 9011 !-- / log(grow_factor)), kind=wp)) 9012 !-- or use this code to simply always keep some extra space after growing 9013 k = CEILING(REAL(ncsfl + maxboxes, kind=wp) * grow_factor) 9014 CALL merge_and_grow_csf(k) 9015 ENDIF 9016 9017 !-- Calculate transparencies and store new CSFs 9018 !-- 9019 zbottom = REAL(nz_urban_b, wp) - .5_wp 9020 ztop = REAL(plantt_max, wp) + .5_wp 9021 9022 !-- Reverse direction of radiation (face->sky), only when calc_svf 9023 !-- 9024 IF ( calc_svf ) THEN 9025 DO i = 1, ntrack ! for each column 9026 dxxyy = ((dy*yxdir(1))**2 + (dx*yxdir(2))**2) * (rt2_track_dist(i)-rt2_track_dist(i-1))**2 9027 CALL radiation_calc_global_offset( rt2_track(2,i), rt2_track(1,i), 0, 1, iproc=ip ) 9028 9029 DO k = 1, nrays ! for each ray 9030 ! 9031 !-- NOTE 6778: 9032 !-- With traditional svf discretization, CSFs under the horizon 9033 !-- (i.e. for surface to surface radiation) are created in 9034 !-- raytrace(). With rad_angular_discretization, we must create 9035 !-- CSFs under horizon only for one direction, otherwise we would 9036 !-- have duplicate amount of energy. Although we could choose 9037 !-- either of the two directions (they differ only by 9038 !-- discretization error with no bias), we choose the the backward 9039 !-- direction, because it tends to cumulate high canopy sink 9040 !-- factors closer to raytrace origin, i.e. it should potentially 9041 !-- cause less moiree. 9042 IF ( .NOT. rad_angular_discretization ) THEN 9043 IF ( zdirs(k) <= horizon ) CYCLE 9044 ENDIF 9045 9046 zorig = origin(1) + zdirs(k) * rt2_track_dist(i-1) 9047 IF ( zorig <= zbottom .OR. zorig >= ztop ) CYCLE 9048 9049 zsgn = INT(SIGN(1._wp, zdirs(k)), iwp) 9050 rt2_dist(1) = 0._wp 9051 IF ( zdirs(k) == 0._wp ) THEN ! ray is exactly horizontal 9052 nz = 2 9053 rt2_dist(nz) = SQRT(dxxyy) 9054 iz = CEILING(-.5_wp + zorig, iwp) 9055 ELSE 9056 zexit = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop) 9057 9058 zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! because it must be greater than orig 9059 zb1 = CEILING(zexit * zsgn - .5_wp) - 1 ! because it must be smaller than exit 9060 nz = MAX(zb1 - zb0 + 3, 2) 9061 rt2_dist(nz) = SQRT(((zexit-zorig)*dz(1))**2 + dxxyy) 9062 qdist = rt2_dist(nz) / (zexit-zorig) 9063 rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/) 9064 iz = zb0 * zsgn 9065 ENDIF 9066 9067 DO l = 2, nz 9068 IF ( rt2_track_lad(iz, i) > 0._wp ) THEN 9069 curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1))) 9070 9071 IF ( create_csf ) THEN 9072 ncsfl = ncsfl + 1 9073 acsf(ncsfl)%ip = ip 9074 acsf(ncsfl)%itx = rt2_track(2,i) 9075 acsf(ncsfl)%ity = rt2_track(1,i) 9076 acsf(ncsfl)%itz = iz 9077 acsf(ncsfl)%isurfs = iorig 9078 acsf(ncsfl)%rcvf = (1._wp - curtrans)*transparency(k)*vffrac(k) 9079 ENDIF 9080 9081 transparency(k) = transparency(k) * curtrans 9082 ENDIF 9083 iz = iz + zsgn 9084 ENDDO ! l = 1, nz - 1 9085 ENDDO ! k = 1, nrays 9086 ENDDO ! i = 1, ntrack 9087 9088 transparency(1:lowest_free_ray) = 1._wp !-- Reset rays above horizon to transparent (see NOTE 6778) 9089 ENDIF 9090 9091 !-- Forward direction of radiation (sky->face), always 9092 !-- 9093 DO i = ntrack, 1, -1 ! for each column backwards 9094 dxxyy = ((dy*yxdir(1))**2 + (dx*yxdir(2))**2) * (rt2_track_dist(i)-rt2_track_dist(i-1))**2 9095 CALL radiation_calc_global_offset( rt2_track(2,i), rt2_track(1,i), 0, 1, iproc=ip ) 9096 9097 DO k = 1, nrays ! for each ray 9098 ! 9099 !-- See NOTE 6778 above 9100 IF ( zdirs(k) <= horizon ) CYCLE 9101 9102 zexit = origin(1) + zdirs(k) * rt2_track_dist(i-1) 9103 IF ( zexit <= zbottom .OR. zexit >= ztop ) CYCLE 9104 9105 zsgn = -INT(SIGN(1._wp, zdirs(k)), iwp) 9106 rt2_dist(1) = 0._wp 9107 IF ( zdirs(k) == 0._wp ) THEN ! ray is exactly horizontal 9108 nz = 2 9109 rt2_dist(nz) = SQRT(dxxyy) 9110 iz = NINT(zexit, iwp) 9111 ELSE 9112 zorig = MIN(MAX(origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop) 9113 9114 zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! because it must be greater than orig 9115 zb1 = CEILING(zexit * zsgn - .5_wp) - 1 ! because it must be smaller than exit 9116 nz = MAX(zb1 - zb0 + 3, 2) 9117 rt2_dist(nz) = SQRT(((zexit-zorig)*dz(1))**2 + dxxyy) 9118 qdist = rt2_dist(nz) / (zexit-zorig) 9119 rt2_dist(2:nz-1) = (/( ((REAL(l, wp) + .5_wp) * zsgn - zorig) * qdist , l = zb0, zb1 )/) 9120 iz = zb0 * zsgn 9121 ENDIF 9122 9123 DO l = 2, nz 9124 IF ( rt2_track_lad(iz, i) > 0._wp ) THEN 9125 curtrans = exp(-ext_coef * rt2_track_lad(iz, i) * (rt2_dist(l)-rt2_dist(l-1))) 9126 9127 IF ( create_csf ) THEN 9128 ncsfl = ncsfl + 1 9129 acsf(ncsfl)%ip = ip 9130 acsf(ncsfl)%itx = rt2_track(2,i) 9131 acsf(ncsfl)%ity = rt2_track(1,i) 9132 acsf(ncsfl)%itz = iz 9133 IF ( itarget(k) /= -1 ) STOP 1 !FIXME remove after test 9134 acsf(ncsfl)%isurfs = -1 9135 acsf(ncsfl)%rcvf = (1._wp - curtrans)*transparency(k)*aorig*vffrac(k) 9136 ENDIF ! create_csf 9137 9138 transparency(k) = transparency(k) * curtrans 9139 ENDIF 9140 iz = iz + zsgn 9141 ENDDO ! l = 1, nz - 1 9142 ENDDO ! k = 1, nrays 9143 ENDDO ! i = 1, ntrack 9144 ENDIF ! plant_canopy 9145 9146 IF ( .NOT. (rad_angular_discretization .AND. calc_svf) ) THEN 9147 ! 9148 !-- Just update lowest_free_ray according to horizon 9149 DO WHILE ( lowest_free_ray > 0 ) 9150 IF ( zdirs(lowest_free_ray) > horizon ) EXIT 9151 lowest_free_ray = lowest_free_ray - 1 9152 ENDDO 9153 ENDIF 9154 9155 CONTAINS 9156 9157 SUBROUTINE request_itarget( d, z, y, x, isurfl, iproc ) 9158 9159 INTEGER(iwp), INTENT(in) :: d, z, y, x 9160 INTEGER(iwp), TARGET, INTENT(out) :: isurfl 9161 INTEGER(iwp), INTENT(out) :: iproc 9162 9163 #if defined( __parallel ) 9164 INTEGER(KIND=MPI_ADDRESS_KIND) :: target_displ !< index of the grid in the local gridsurf array 9165 9166 ! 9167 !-- Calculate target processor and index in the remote local target gridsurf array 9168 CALL radiation_calc_global_offset( x, y, (z - nz_urban_b) * nsurf_type_u + d, & 9169 nz_urban * nsurf_type_u, iproc=iproc, & 9170 offs_proc=target_displ ) 9171 ! 9172 !-- Send MPI_Get request to obtain index target_surfl(i) 9173 CALL MPI_GET( isurfl, 1, MPI_INTEGER, iproc, target_displ, & 9174 1, MPI_INTEGER, win_gridsurf, ierr) 9175 IF ( ierr /= 0 ) THEN 9176 WRITE( 9,* ) 'Error MPI_Get3:', ierr, isurfl, iproc, target_displ, & 9177 win_gridsurf 9178 FLUSH( 9 ) 9179 ENDIF 8526 9180 #else 8527 lad_s_target = sub_lad(boxes(1,i),boxes(2,i),boxes(3,i)) 9181 !-- set index target_surfl(i) 9182 isurfl = gridsurf(d,z,y,x) 9183 iproc = 0 ! required to avoid compile error about unused variable in serial mode 8528 9184 #endif 8529 cursink = 1._wp - EXP( - ext_coef * lad_s_target * crlens(i) * realdist ) 8530 8531 IF ( create_csf ) THEN 8532 !-- Write svf values into the array 8533 ncsfl = ncsfl + 1 8534 acsf(ncsfl)%ip = lad_ip(i) 8535 acsf(ncsfl)%itx = boxes(3,i) 8536 acsf(ncsfl)%ity = boxes(2,i) 8537 acsf(ncsfl)%itz = boxes(1,i) 8538 acsf(ncsfl)%isurfs = isrc 8539 acsf(ncsfl)%rcvf = cursink * transparency * difvf * atarg 8540 ENDIF !< create_csf 8541 8542 transparency = transparency * ( 1._wp - cursink ) 8543 8544 ENDDO 8545 ENDIF 8546 8547 visible = .TRUE. 8548 8549 END SUBROUTINE raytrace 8550 8551 8552 !--------------------------------------------------------------------------------------------------! 9185 9186 END SUBROUTINE request_itarget 9187 9188 END SUBROUTINE raytrace_2d 9189 9190 9191 !------------------------------------------------------------------------------! 9192 ! 8553 9193 ! Description: 8554 9194 ! ------------ 8555 !>A new, more efficient version of ray tracing algorithm that processes a whole arc instead of a 8556 !>single ray (new in RTM version 2.5). 8557 !> 8558 !>In all comments, horizon means tangent of horizon angle, i.e. vertical_delta / horizontal_distance 8559 !--------------------------------------------------------------------------------------------------! 8560 SUBROUTINE raytrace_2d( origin, yxdir, nrays, zdirs, iorig, aorig, vffrac, calc_svf, create_csf, & 8561 skip_1st_pcb, lowest_free_ray, transparency, itarget ) 8562 IMPLICIT NONE 8563 8564 INTEGER(iwp) :: ip !< number of processor where gridbox reside 8565 INTEGER(iwp) :: ig !< 1D index of gridbox in global 2D array 8566 INTEGER(iwp) :: maxboxes !< max no of CSF created 8567 INTEGER(iwp) :: nly !< maximum plant canopy height 8568 INTEGER(iwp) :: ntrack !< 8569 INTEGER(iwp) :: zb0 !< 8570 INTEGER(iwp) :: zb1 !< 8571 INTEGER(iwp) :: nz !< 8572 INTEGER(iwp) :: iz !< 8573 INTEGER(iwp) :: zsgn !< 8574 INTEGER(iwp) :: lastdir !< wall direction before hitting this column 8575 INTEGER(iwp) :: nrays !< number of rays (z directions) to raytrace 8576 INTEGER(iwp) :: i, k, l, d !< 8577 INTEGER(iwp) :: seldim !< dimension to be incremented 8578 INTEGER(iwp), INTENT(IN) :: iorig !< index of origin face for csf 8579 INTEGER(iwp), INTENT(OUT) :: lowest_free_ray !< index into zdirs 8580 8581 INTEGER(iwp), DIMENSION(2) :: column !< grid column being crossed 8582 INTEGER(iwp), DIMENSION(2) :: dimnext !< next dimension increments along path 8583 INTEGER(iwp), DIMENSION(2) :: dimdelta !< dimension direction = +- 1 8584 INTEGER(iwp), DIMENSION(2) :: lastcolumn !< 8585 8586 INTEGER(iwp), DIMENSION(nrays) :: target_procs !< 8587 INTEGER(iwp), DIMENSION(nrays), INTENT(OUT) :: itarget !< global indices of target faces for zdirs 8588 8589 LOGICAL, INTENT(IN) :: calc_svf !< whether to calculate SFV (identify obstacle surfaces) 8590 LOGICAL, INTENT(IN) :: create_csf !< whether to create canopy sink factors 8591 LOGICAL, INTENT(IN) :: skip_1st_pcb !< whether to skip first plant canopy box during raytracing 8592 8593 REAL(wp) :: horizon !< highest horizon found after raytracing (z/hdist) 8594 REAL(wp) :: distance !< euclidean along path 8595 REAL(wp) :: lastdist !< beginning of current crossing 8596 REAL(wp) :: nextdist !< end of current crossing 8597 REAL(wp) :: crmid !< midpoint of crossing 8598 REAL(wp) :: horz_entry !< horizon at entry to column 8599 REAL(wp) :: horz_exit !< horizon at exit from column 8600 REAL(wp) :: bdydim !< boundary for current dimension 8601 REAL(wp), INTENT(IN) :: aorig !< origin face area for csf 8602 8603 REAL(wp), DIMENSION(2) :: yxorigin !< horizontal copy of origin (y,x) 8604 REAL(wp), DIMENSION(2) :: crossdist !< distances to boundary for dimensions 8605 REAL(wp), DIMENSION(2) :: dimnextdist !< distance for each dimension increments 8606 REAL(wp), DIMENSION(2), INTENT(IN) :: yxdir !< y,x *unit* vector of ray direction (in grid units) 8607 REAL(wp), DIMENSION(3), INTENT(IN) :: origin !< z,y,x coordinates of ray origin 8608 8609 8610 REAL(wp), DIMENSION(nrays), INTENT(IN) :: zdirs !< list of z directions to raytrace (z/hdist, grid, zenith->nadir) 8611 REAL(wp), DIMENSION(nrays), INTENT(IN) :: vffrac !< view factor fractions of each ray for csf 8612 REAL(wp), DIMENSION(nrays), INTENT(OUT) :: transparency !< transparencies of zdirs paths 8613 8614 8615 #if defined( __parallel ) 8616 INTEGER(iwp) :: lowest_lad !< lowest column cell for which we need LAD 8617 INTEGER(iwp) :: wcount !< RMA window item count 8618 INTEGER(MPI_ADDRESS_KIND) :: wdisp !< RMA window displacement 8619 #endif 8620 8621 REAL(wp) :: eps = 1E-10_wp !< epsilon for value comparison 8622 REAL(wp) :: zbottom, ztop !< urban surface boundary in real numbers 8623 REAL(wp) :: zorig !< z coordinate of ray column entry 8624 REAL(wp) :: zexit !< z coordinate of ray column exit 8625 REAL(wp) :: qdist !< ratio of real distance to z coord difference 8626 REAL(wp) :: dxxyy !< square of real horizontal distance 8627 REAL(wp) :: curtrans !< transparency of current PC box crossing 8628 8629 8630 8631 yxorigin(:) = origin(2:3) 8632 transparency(:) = 1._wp !-- Pre-set the all rays to transparent before reducing 8633 horizon = -HUGE( 1._wp ) 8634 lowest_free_ray = nrays 8635 IF ( rad_angular_discretization .AND. calc_svf ) THEN 8636 ALLOCATE( target_surfl(nrays) ) 8637 target_surfl(:) = -1 8638 lastdir = -999 8639 lastcolumn(:) = -999 8640 ENDIF 8641 ! 8642 !-- Determine distance to boundary (in 2D xy) 8643 IF ( yxdir(1) > 0._wp ) THEN 8644 bdydim = ny + .5_wp !< North global boundary 8645 crossdist(1) = ( bdydim - yxorigin(1) ) / yxdir(1) 8646 ELSEIF ( yxdir(1) == 0._wp ) THEN 8647 crossdist(1) = HUGE( 1._wp ) 8648 ELSE 8649 bdydim = -.5_wp !< South global boundary 8650 crossdist(1) = ( bdydim - yxorigin(1) ) / yxdir(1) 8651 ENDIF 8652 8653 IF ( yxdir(2) > 0._wp ) THEN 8654 bdydim = nx + .5_wp !< East global boundary 8655 crossdist(2) = ( bdydim - yxorigin(2) ) / yxdir(2) 8656 ELSEIF ( yxdir(2) == 0._wp ) THEN 8657 crossdist(2) = HUGE( 1._wp ) 8658 ELSE 8659 bdydim = -.5_wp !< West global boundary 8660 crossdist(2) = ( bdydim - yxorigin(2) ) / yxdir(2) 8661 ENDIF 8662 distance = MINVAL( crossdist, 1 ) 8663 8664 IF ( plant_canopy ) THEN 8665 rt2_track_dist(0) = 0._wp 8666 rt2_track_lad(:,:) = 0._wp 8667 nly = plantt_max - nz_urban_b + 1 8668 ENDIF 8669 8670 lastdist = 0._wp 8671 ! 8672 !-- Since all face coordinates have values *.5 and we'd like to use integers, all these have .5 added 8673 DO d = 1, 2 8674 IF ( yxdir(d) == 0._wp ) THEN 8675 dimnext(d) = HUGE( 1_iwp ) 8676 dimdelta(d) = HUGE( 1_iwp ) 8677 dimnextdist(d) = HUGE( 1._wp ) 8678 ELSE IF ( yxdir(d) > 0._wp ) THEN 8679 dimnext(d) = FLOOR( yxorigin(d) + .5_wp ) + 1 8680 dimdelta(d) = 1 8681 dimnextdist(d) = ( dimnext(d) - .5_wp - yxorigin(d) ) / yxdir(d) 8682 ELSE 8683 dimnext(d) = CEILING( yxorigin(d) + .5_wp ) - 1 8684 dimdelta(d) = -1 8685 dimnextdist(d) = ( dimnext(d) - .5_wp - yxorigin(d) ) / yxdir(d) 8686 ENDIF 8687 ENDDO 8688 8689 ntrack = 0 8690 DO 8691 !-- Along what dimension will the next wall crossing be? 8692 seldim = MINLOC( dimnextdist, 1 ) 8693 nextdist = dimnextdist(seldim) 8694 IF ( nextdist > distance ) nextdist = distance 8695 8696 IF ( nextdist > lastdist ) THEN 8697 ntrack = ntrack + 1 8698 crmid = ( lastdist + nextdist ) * .5_wp 8699 column = NINT( yxorigin(:) + yxdir(:) * crmid, iwp ) 8700 ! 8701 !-- Calculate index of the grid with global indices (column(1),column(2)) in the array nzterr 8702 !-- and plantt and id of the coresponding processor 8703 CALL radiation_calc_global_offset( column(2), column(1), 0, 1, offs_glob = ig ) 8704 8705 IF ( lastdist == 0._wp ) THEN 8706 horz_entry = -HUGE( 1._wp ) 8707 ELSE 8708 horz_entry = ( REAL( nzterr(ig), wp ) + .5_wp - origin(1) ) / lastdist 8709 ENDIF 8710 horz_exit = ( REAL( nzterr(ig), wp ) + .5_wp - origin(1) ) / nextdist 8711 8712 IF ( rad_angular_discretization .AND. calc_svf ) THEN 8713 ! 8714 !-- Identify vertical obstacles hit by rays in current column 8715 DO WHILE ( lowest_free_ray > 0 ) 8716 IF ( zdirs(lowest_free_ray) > horz_entry ) EXIT 8717 ! 8718 !-- This may only happen after 1st column, so lastdir and lastcolumn are valid 8719 CALL request_itarget(lastdir, CEILING( - 0.5_wp + origin(1) + & 8720 zdirs(lowest_free_ray) * lastdist ), & 8721 lastcolumn(1), lastcolumn(2), target_surfl(lowest_free_ray), & 8722 target_procs(lowest_free_ray) ) 8723 lowest_free_ray = lowest_free_ray - 1 8724 ENDDO 8725 ! 8726 !-- Identify horizontal obstacles hit by rays in current column 8727 DO WHILE ( lowest_free_ray > 0 ) 8728 IF ( zdirs(lowest_free_ray) > horz_exit ) EXIT 8729 CALL request_itarget( iup_u, nzterr(ig) + 1, column(1), column(2), & 8730 target_surfl(lowest_free_ray), target_procs(lowest_free_ray) ) 8731 lowest_free_ray = lowest_free_ray - 1 8732 ENDDO 8733 ENDIF 8734 8735 horizon = MAX( horizon, horz_entry, horz_exit ) 8736 8737 IF ( plant_canopy ) THEN 8738 rt2_track(:, ntrack) = column(:) 8739 rt2_track_dist(ntrack) = nextdist 8740 ENDIF 8741 ENDIF 8742 8743 IF ( nextdist + eps >= distance ) EXIT 8744 8745 IF ( rad_angular_discretization .AND. calc_svf ) THEN 8746 ! 8747 !-- Save wall direction of coming building column (= this air column) 8748 IF ( seldim == 1 ) THEN 8749 IF ( dimdelta(seldim) == 1 ) THEN 8750 lastdir = isouth_u 8751 ELSE 8752 lastdir = inorth_u 8753 ENDIF 8754 ELSE 8755 IF ( dimdelta(seldim) == 1 ) THEN 8756 lastdir = iwest_u 8757 ELSE 8758 lastdir = ieast_u 8759 ENDIF 8760 ENDIF 8761 lastcolumn = column 8762 ENDIF 8763 lastdist = nextdist 8764 dimnext(seldim) = dimnext(seldim) + dimdelta(seldim) 8765 dimnextdist(seldim) = ( dimnext(seldim) - .5_wp - yxorigin(seldim) ) / yxdir(seldim) 8766 ENDDO 8767 8768 IF ( plant_canopy ) THEN 8769 !-- Request LAD WHERE applicable 9195 !> Calculates apparent solar positions for all timesteps and stores discretized 9196 !> positions for RTM. 9197 !------------------------------------------------------------------------------! 9198 SUBROUTINE radiation_presimulate_solar_pos 9199 9200 USE control_parameters, & 9201 ONLY: rotation_angle 9202 9203 IMPLICIT NONE 9204 9205 INTEGER(iwp) :: it, i, j !< loop indices 9206 9207 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir_tmp !< dsidir_tmp[:,i] = unit vector of i-th 9208 !< appreant solar direction 9209 9210 ALLOCATE ( dsidir_rev(0:raytrace_discrete_elevs/2-1, & 9211 0:raytrace_discrete_azims-1) ) 9212 dsidir_rev(:,:) = -1 9213 ALLOCATE ( dsidir_tmp(3, & 9214 raytrace_discrete_elevs/2*raytrace_discrete_azims) ) 9215 ndsidir = 0 9216 sun_direction = .TRUE. 9217 9218 ! 9219 !-- Process spinup time if configured 9220 IF ( spinup_time > 0._wp ) THEN 9221 DO it = 0, CEILING(spinup_time / dt_spinup) 9222 CALL simulate_pos( it * dt_spinup - spinup_time ) 9223 ENDDO 9224 ENDIF 9225 ! 9226 !-- Process simulation time 9227 DO it = 0, CEILING(( end_time - spinup_time ) / dt_radiation) 9228 CALL simulate_pos( it * dt_radiation ) 9229 ENDDO 9230 ! 9231 !-- Allocate global vars which depend on ndsidir 9232 ALLOCATE ( dsidir ( 3, ndsidir ) ) 9233 dsidir(:,:) = dsidir_tmp(:, 1:ndsidir) 9234 DEALLOCATE ( dsidir_tmp ) 9235 9236 ALLOCATE ( dsitrans(nsurfl, ndsidir) ) 9237 ALLOCATE ( dsitransc(npcbl, ndsidir) ) 9238 IF ( nmrtbl > 0 ) ALLOCATE ( mrtdsit(nmrtbl, ndsidir) ) 9239 9240 WRITE ( message_string, * ) 'Precalculated', ndsidir, ' solar positions', & 9241 ' from', it, ' timesteps.' 9242 CALL message( 'radiation_presimulate_solar_pos', 'UI0013', 0, 0, 0, 6, 0 ) 9243 9244 CONTAINS 9245 9246 !------------------------------------------------------------------------! 9247 ! Description: 9248 ! ------------ 9249 !> Simuates a single position 9250 !------------------------------------------------------------------------! 9251 SUBROUTINE simulate_pos( time_since_reference_local ) 9252 9253 REAL(wp), INTENT(IN) :: time_since_reference_local !< local time since reference 9254 REAL(wp) :: solar_azim !< solar azimuth in rotated model coordinates 9255 ! 9256 !-- Update apparent solar position based on modified t_s_r_p 9257 CALL get_date_time( time_since_reference_local, & 9258 day_of_year=day_of_year, & 9259 second_of_day=second_of_day ) 9260 CALL calc_zenith( day_of_year, second_of_day ) 9261 IF ( cos_zenith > 0 ) THEN 8770 9262 !-- 8771 #if defined( __parallel ) 8772 IF ( raytrace_mpi_rma ) THEN 8773 !-- Send requests for lad_s to appropriate processor 8774 !CALL cpu_log( log_point_s(77), 'usm_init_rma', 'start' ) 8775 DO i = 1, ntrack 8776 CALL radiation_calc_global_offset( rt2_track(2,i), rt2_track(1,i), 0, 1, & 8777 offs_glob = ig ) 8778 8779 IF ( rad_angular_discretization .AND. calc_svf ) THEN 8780 ! 8781 !-- For fixed view resolution, we need plant canopy even for rays to opposing surfaces 8782 lowest_lad = nzterr(ig) + 1 8783 ELSE 8784 ! 8785 !-- We only need LAD for rays directed above horizon (to sky) 8786 lowest_lad = CEILING( -0.5_wp + origin(1) + MIN( horizon * rt2_track_dist(i-1), & ! Entry 8787 horizon * rt2_track_dist(i) ) ) ! Exit 8788 ENDIF 8789 ! 8790 !-- Skip asking for LAD where all plant canopy is under requested level 8791 IF ( plantt(ig) < lowest_lad ) CYCLE 8792 8793 CALL radiation_calc_global_offset( rt2_track(2,i), rt2_track(1,i), & 8794 lowest_lad - nz_urban_b, nz_plant, iproc = ip, & 8795 offs_proc = wdisp ) 8796 wcount = plantt(ig) - lowest_lad + 1 8797 ! TODO send request ASAP - even during raytracing 8798 CALL MPI_Get( rt2_track_lad(lowest_lad:plantt(ig), i), wcount, MPI_REAL, ip, & 8799 wdisp, wcount, MPI_REAL, win_lad, ierr ) 8800 IF ( ierr /= 0 ) THEN 8801 WRITE( 9, * ) 'Error MPI_Get2:', ierr, rt2_track_lad(lowest_lad:plantt(ig), i), & 8802 wcount, ip, wdisp, win_lad 8803 FLUSH( 9 ) 8804 ENDIF 8805 ENDDO 8806 ! 8807 !-- Wait for all pending local requests to complete 8808 ! TODO WAIT selectively for each column later when needed 8809 CALL MPI_Win_flush_local_all( win_lad, ierr ) 8810 IF ( ierr /= 0 ) THEN 8811 WRITE( 9, * ) 'Error MPI_Win_flush_local_all2:', ierr, win_lad 8812 FLUSH( 9 ) 8813 ENDIF 8814 !CALL cpu_log( log_point_s(77), 'usm_init_rma', 'stop' ) 8815 8816 ELSE ! raytrace_mpi_rma = .F. 8817 DO i = 1, ntrack 8818 CALL radiation_calc_global_offset( rt2_track(2,i), rt2_track(1,i), 0, nz_plant, & 8819 offs_glob = ig ) 8820 rt2_track_lad(nz_urban_b:plantt_max, i) = sub_lad_g(ig:ig+nly-1) 8821 ENDDO 8822 ENDIF 8823 #else 8824 DO i = 1, ntrack 8825 rt2_track_lad(nz_urban_b:plantt_max, i) = sub_lad(rt2_track(1,i), rt2_track(2,i), & 8826 nz_urban_b:plantt_max) 8827 ENDDO 8828 #endif 8829 ENDIF ! Plant_canopy 8830 8831 IF ( rad_angular_discretization .AND. calc_svf ) THEN 8832 #if defined( __parallel ) 8833 !-- Wait for all gridsurf requests to complete 8834 CALL MPI_Win_flush_local_all( win_gridsurf, ierr ) 8835 IF ( ierr /= 0 ) THEN 8836 WRITE( 9, * ) 'Error MPI_Win_flush_local_all3:', ierr, win_gridsurf 8837 FLUSH( 9 ) 8838 ENDIF 8839 #endif 8840 ! 8841 !-- Recalculate local surf indices into global ones 8842 DO i = 1, nrays 8843 IF ( target_surfl(i) == -1 ) THEN 8844 itarget(i) = -1 8845 ELSE 8846 itarget(i) = target_surfl(i) + surfstart(target_procs(i)) 8847 ENDIF 8848 ENDDO 8849 8850 DEALLOCATE( target_surfl ) 8851 8852 ELSE 8853 itarget(:) = -1 8854 ENDIF ! rad_angular_discretization 8855 8856 IF ( plant_canopy ) THEN 8857 ! 8858 !-- Skip the PCB around origin if requested (for MRT, the PCB might not be there) 8859 IF ( skip_1st_pcb .AND. NINT( origin(1) ) <= plantt_max ) THEN 8860 rt2_track_lad(NINT( origin(1), iwp ), 1) = 0._wp 8861 ENDIF 8862 ! 8863 !-- Assert that we have space allocated for CSFs 8864 maxboxes = ( ntrack + MAX( CEILING( origin(1) - .5_wp ) - nz_urban_b, nz_urban_t - & 8865 CEILING( origin(1) - .5_wp ) ) ) * nrays 8866 IF ( ncsfl + maxboxes > ncsfla ) THEN 8867 !-- Use this code for growing by fixed exponential increments (equivalent to case where ncsfl always increases by 1) 8868 !-- k = CEILING(grow_factor ** real(CEILING(log(real(ncsfl + maxboxes, kind=wp)) & 8869 !-- / log(grow_factor)), kind=wp)) 8870 !-- Or use this code to simply always keep some extra space after growing 8871 k = CEILING( REAL( ncsfl + maxboxes, KIND = wp ) * grow_factor ) 8872 CALL merge_and_grow_csf(k) 8873 ENDIF 8874 ! 8875 !-- Calculate transparencies and store new CSFs 8876 zbottom = REAL( nz_urban_b, wp ) - .5_wp 8877 ztop = REAL( plantt_max, wp ) + .5_wp 8878 ! 8879 !-- Reverse direction of radiation (face->sky), only when calc_svf 8880 IF ( calc_svf ) THEN 8881 DO i = 1, ntrack ! For each column 8882 dxxyy = ( ( dy * yxdir(1) )**2 + ( dx * yxdir(2) )**2 ) * ( rt2_track_dist(i) - & 8883 rt2_track_dist(i-1) )**2 8884 CALL radiation_calc_global_offset( rt2_track(2,i), rt2_track(1,i), 0, 1, iproc = ip ) 8885 8886 DO k = 1, nrays ! For each ray 8887 ! 8888 !-- NOTE 6778: 8889 !-- With traditional svf discretization, CSFs under the horizon (i.e. for surface to 8890 !-- surface radiation) are created in raytrace(). With rad_angular_discretization, we 8891 !-- must create CSFs under horizon only for one direction, otherwise we would have 8892 !-- duplicated the amount of energy. Although we could choose either of the two 8893 !-- directions (they differ only by discretization error with no bias), we choose the 8894 !-- backward direction, because it tends to cumulate high canopy sink factors closer to 8895 !-- raytrace origin, i.e. it should potentially cause less moiree. 8896 IF ( .NOT. rad_angular_discretization ) THEN 8897 IF ( zdirs(k) <= horizon ) CYCLE 8898 ENDIF 8899 8900 zorig = origin(1) + zdirs(k) * rt2_track_dist(i-1) 8901 IF ( zorig <= zbottom .OR. zorig >= ztop ) CYCLE 8902 8903 zsgn = INT( SIGN( 1._wp, zdirs(k) ), iwp) 8904 rt2_dist(1) = 0._wp 8905 IF ( zdirs(k) == 0._wp ) THEN ! Ray is exactly horizontal 8906 nz = 2 8907 rt2_dist(nz) = SQRT( dxxyy ) 8908 iz = CEILING( - .5_wp + zorig, iwp ) 8909 ELSE 8910 zexit = MIN( MAX( origin(1) + zdirs(k) * rt2_track_dist(i), zbottom ), ztop ) 8911 8912 zb0 = FLOOR( zorig * zsgn - .5_wp) + 1 ! Because it must be greater than orig 8913 zb1 = CEILING( zexit * zsgn - .5_wp ) - 1 ! Because it must be smaller than exit 8914 nz = MAX( zb1 - zb0 + 3, 2 ) 8915 rt2_dist(nz) = SQRT( ( ( zexit-zorig ) *dz(1) )**2 + dxxyy ) 8916 qdist = rt2_dist(nz) / ( zexit - zorig ) 8917 rt2_dist(2:nz-1) = (/ ( ( ( REAL(l, wp) + .5_wp ) * zsgn - zorig ) * qdist, & 8918 l = zb0, zb1 ) /) 8919 iz = zb0 * zsgn 8920 ENDIF 8921 8922 DO l = 2, nz 8923 IF ( rt2_track_lad(iz, i) > 0._wp ) THEN 8924 curtrans = EXP( - ext_coef * rt2_track_lad(iz, i) * & 8925 ( rt2_dist(l) - rt2_dist(l-1) ) ) 8926 8927 IF ( create_csf ) THEN 8928 ncsfl = ncsfl + 1 8929 acsf(ncsfl)%ip = ip 8930 acsf(ncsfl)%itx = rt2_track(2,i) 8931 acsf(ncsfl)%ity = rt2_track(1,i) 8932 acsf(ncsfl)%itz = iz 8933 acsf(ncsfl)%isurfs = iorig 8934 acsf(ncsfl)%rcvf = ( 1._wp - curtrans ) * transparency(k) * vffrac(k) 8935 ENDIF 8936 8937 transparency(k) = transparency(k) * curtrans 8938 ENDIF 8939 iz = iz + zsgn 8940 ENDDO ! l = 1, nz - 1 8941 ENDDO ! k = 1, nrays 8942 ENDDO ! i = 1, ntrack 8943 8944 transparency(1:lowest_free_ray) = 1._wp !-- Reset rays above horizon to transparent (see NOTE 6778) 8945 ENDIF 8946 ! 8947 !-- Forward direction of radiation (sky->face), always 8948 DO i = ntrack, 1, -1 ! for each column backwards 8949 dxxyy = ( ( dy * yxdir(1) )**2 + ( dx * yxdir(2) )**2 ) * & 8950 ( rt2_track_dist(i) - rt2_track_dist(i-1) )**2 8951 CALL radiation_calc_global_offset( rt2_track(2,i), rt2_track(1,i), 0, 1, iproc = ip ) 8952 8953 DO k = 1, nrays ! For each ray 8954 ! 8955 !-- See NOTE 6778 above 8956 IF ( zdirs(k) <= horizon ) CYCLE 8957 8958 zexit = origin(1) + zdirs(k) * rt2_track_dist(i-1) 8959 IF ( zexit <= zbottom .OR. zexit >= ztop ) CYCLE 8960 8961 zsgn = -INT( SIGN( 1._wp, zdirs(k) ), iwp ) 8962 rt2_dist(1) = 0._wp 8963 IF ( zdirs(k) == 0._wp ) THEN ! Ray is exactly horizontal 8964 nz = 2 8965 rt2_dist(nz) = SQRT( dxxyy ) 8966 iz = NINT( zexit, iwp ) 8967 ELSE 8968 zorig = MIN( MAX( origin(1) + zdirs(k) * rt2_track_dist(i), zbottom), ztop ) 8969 8970 zb0 = FLOOR( zorig * zsgn - .5_wp ) + 1 ! Because it must be greater than orig 8971 zb1 = CEILING( zexit * zsgn - .5_wp ) - 1 ! Because it must be smaller than exit 8972 nz = MAX( zb1 - zb0 + 3, 2 ) 8973 rt2_dist(nz) = SQRT( ( ( zexit - zorig ) * dz(1) )**2 + dxxyy ) 8974 qdist = rt2_dist(nz) / ( zexit - zorig ) 8975 rt2_dist(2:nz-1) = (/ ( ( ( REAL( l, wp ) + .5_wp ) * zsgn - zorig ) * qdist, & 8976 l = zb0, zb1 ) /) 8977 iz = zb0 * zsgn 8978 ENDIF 8979 8980 DO l = 2, nz 8981 IF ( rt2_track_lad(iz, i) > 0._wp ) THEN 8982 curtrans = EXP( - ext_coef * rt2_track_lad(iz, i) * & 8983 ( rt2_dist(l) - rt2_dist(l-1) ) ) 8984 8985 IF ( create_csf ) THEN 8986 ncsfl = ncsfl + 1 8987 acsf(ncsfl)%ip = ip 8988 acsf(ncsfl)%itx = rt2_track(2,i) 8989 acsf(ncsfl)%ity = rt2_track(1,i) 8990 acsf(ncsfl)%itz = iz 8991 IF ( itarget(k) /= -1 ) STOP 1 !FIXME remove after test 8992 acsf(ncsfl)%isurfs = -1 8993 acsf(ncsfl)%rcvf = ( 1._wp - curtrans ) * transparency(k) * aorig * vffrac(k) 8994 ENDIF ! create_csf 8995 8996 transparency(k) = transparency(k) * curtrans 8997 ENDIF 8998 iz = iz + zsgn 8999 ENDDO ! l = 1, nz - 1 9000 ENDDO ! k = 1, nrays 9001 ENDDO ! i = 1, ntrack 9002 ENDIF ! plant_canopy 9003 9004 IF ( .NOT. ( rad_angular_discretization .AND. calc_svf ) ) THEN 9005 ! 9006 !-- Just update lowest_free_ray according to horizon 9007 DO WHILE ( lowest_free_ray > 0 ) 9008 IF ( zdirs(lowest_free_ray) > horizon ) EXIT 9009 lowest_free_ray = lowest_free_ray - 1 9010 ENDDO 9011 ENDIF 9012 9013 CONTAINS 9014 9015 SUBROUTINE request_itarget( d, z, y, x, isurfl, iproc ) 9016 9017 INTEGER(iwp), INTENT(IN) :: d, z, y, x !< 9018 INTEGER(iwp), INTENT(OUT) :: iproc !< 9019 INTEGER(iwp), TARGET, INTENT(OUT) :: isurfl !< 9020 9021 #if defined( __parallel ) 9022 INTEGER(KIND=MPI_ADDRESS_KIND) :: target_displ !< index of the grid in the local gridsurf array 9023 9024 ! 9025 !-- Calculate target processor and index in the remote local target gridsurf array 9026 CALL radiation_calc_global_offset( x, y, ( z - nz_urban_b ) * nsurf_type_u + d, nz_urban * & 9027 nsurf_type_u, iproc = iproc, offs_proc=target_displ ) 9028 ! 9029 !-- Send MPI_Get request to obtain index target_surfl(i) 9030 CALL MPI_GET( isurfl, 1, MPI_INTEGER, iproc, target_displ, 1, MPI_INTEGER, win_gridsurf, ierr ) 9031 IF ( ierr /= 0 ) THEN 9032 WRITE( 9,* ) 'Error MPI_Get3:', ierr, isurfl, iproc, target_displ, win_gridsurf 9033 FLUSH( 9 ) 9034 ENDIF 9035 #else 9036 !-- Set index target_surfl(i) 9037 isurfl = gridsurf(d,z,y,x) 9038 iproc = 0 ! Required to avoid compile error about unused variable in serial mode 9039 #endif 9040 9041 END SUBROUTINE request_itarget 9042 9043 END SUBROUTINE raytrace_2d 9044 9045 9046 !--------------------------------------------------------------------------------------------------! 9047 ! 9263 !-- Identify solar direction vector (discretized number) 1) 9264 solar_azim = ATAN2(sun_dir_lon, sun_dir_lat) * (180.0_wp/pi) - rotation_angle 9265 i = MODULO(NINT(solar_azim / 360.0_wp * & 9266 raytrace_discrete_azims - .5_wp, iwp), & 9267 raytrace_discrete_azims) 9268 j = FLOOR(ACOS(cos_zenith) / pi * raytrace_discrete_elevs) 9269 IF ( dsidir_rev(j, i) == -1 ) THEN 9270 ndsidir = ndsidir + 1 9271 dsidir_tmp(:, ndsidir) = & 9272 (/ COS((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs), & 9273 SIN((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs) & 9274 * COS((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims), & 9275 SIN((REAL(j,wp)+.5_wp) * pi / raytrace_discrete_elevs) & 9276 * SIN((REAL(i,wp)+.5_wp) * 2_wp*pi / raytrace_discrete_azims) /) 9277 dsidir_rev(j, i) = ndsidir 9278 ENDIF 9279 ENDIF 9280 END SUBROUTINE simulate_pos 9281 9282 END SUBROUTINE radiation_presimulate_solar_pos 9283 9284 9285 9286 !------------------------------------------------------------------------------! 9048 9287 ! Description: 9049 9288 ! ------------ 9050 !> Calculates apparent solar positions for all timesteps and stores discretized positions for RTM. 9051 !--------------------------------------------------------------------------------------------------! 9052 SUBROUTINE radiation_presimulate_solar_pos 9053 9054 USE control_parameters, & 9055 ONLY: rotation_angle 9056 9057 IMPLICIT NONE 9058 9059 INTEGER(iwp) :: it, i, j !< loop indices 9060 9061 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dsidir_tmp !< dsidir_tmp[:,i] = unit vector of i-th 9062 !< apparent solar direction 9063 9064 ALLOCATE ( dsidir_rev(0:raytrace_discrete_elevs/2-1, 0:raytrace_discrete_azims-1) ) 9065 dsidir_rev(:,:) = -1 9066 ALLOCATE ( dsidir_tmp(3, raytrace_discrete_elevs/2*raytrace_discrete_azims) ) 9067 ndsidir = 0 9068 sun_direction = .TRUE. 9069 9070 ! 9071 !-- Process spinup time if configured 9072 IF ( spinup_time > 0._wp ) THEN 9073 DO it = 0, CEILING( spinup_time / dt_spinup ) 9074 CALL simulate_pos( it * dt_spinup - spinup_time ) 9075 ENDDO 9076 ENDIF 9077 ! 9078 !-- Process simulation time 9079 DO it = 0, CEILING( ( end_time - spinup_time ) / dt_radiation ) 9080 CALL simulate_pos( it * dt_radiation ) 9081 ENDDO 9082 ! 9083 !-- Allocate global vars which depend on ndsidir 9084 ALLOCATE ( dsidir ( 3, ndsidir ) ) 9085 dsidir(:,:) = dsidir_tmp(:, 1:ndsidir) 9086 DEALLOCATE ( dsidir_tmp ) 9087 9088 ALLOCATE ( dsitrans(nsurfl, ndsidir) ) 9089 ALLOCATE ( dsitransc(npcbl, ndsidir) ) 9090 IF ( nmrtbl > 0 ) ALLOCATE ( mrtdsit(nmrtbl, ndsidir) ) 9091 9092 WRITE ( message_string, * ) 'Precalculated', ndsidir, ' solar positions', ' from', it, & 9093 ' timesteps.' 9094 CALL message( 'radiation_presimulate_solar_pos', 'UI0013', 0, 0, 0, 6, 0 ) 9095 9096 CONTAINS 9097 9098 !--------------------------------------------------------------------------------------------------! 9289 !> Determines whether two faces are oriented towards each other in RTM. Since the 9290 !> surfaces follow the gird box surfaces, it checks first whether the two surfaces 9291 !> are directed in the same direction, then it checks if the two surfaces are 9292 !> located in confronted direction but facing away from each other, e.g. <--| |--> 9293 !------------------------------------------------------------------------------! 9294 PURE LOGICAL FUNCTION surface_facing(x, y, z, d, x2, y2, z2, d2) 9295 IMPLICIT NONE 9296 INTEGER(iwp), INTENT(in) :: x, y, z, d, x2, y2, z2, d2 9297 9298 surface_facing = .FALSE. 9299 9300 !-- first check: are the two surfaces directed in the same direction 9301 IF ( (d==iup_u .OR. d==iup_l ) & 9302 .AND. (d2==iup_u .OR. d2==iup_l) ) RETURN 9303 IF ( (d==isouth_u .OR. d==isouth_l ) & 9304 .AND. (d2==isouth_u .OR. d2==isouth_l) ) RETURN 9305 IF ( (d==inorth_u .OR. d==inorth_l ) & 9306 .AND. (d2==inorth_u .OR. d2==inorth_l) ) RETURN 9307 IF ( (d==iwest_u .OR. d==iwest_l ) & 9308 .AND. (d2==iwest_u .OR. d2==iwest_l ) ) RETURN 9309 IF ( (d==ieast_u .OR. d==ieast_l ) & 9310 .AND. (d2==ieast_u .OR. d2==ieast_l ) ) RETURN 9311 9312 !-- second check: are surfaces facing away from each other 9313 SELECT CASE (d) 9314 CASE (iup_u, iup_l) !< upward facing surfaces 9315 IF ( z2 < z ) RETURN 9316 CASE (isouth_u, isouth_l) !< southward facing surfaces 9317 IF ( y2 > y ) RETURN 9318 CASE (inorth_u, inorth_l) !< northward facing surfaces 9319 IF ( y2 < y ) RETURN 9320 CASE (iwest_u, iwest_l) !< westward facing surfaces 9321 IF ( x2 > x ) RETURN 9322 CASE (ieast_u, ieast_l) !< eastward facing surfaces 9323 IF ( x2 < x ) RETURN 9324 END SELECT 9325 9326 SELECT CASE (d2) 9327 CASE (iup_u) !< ground, roof 9328 IF ( z < z2 ) RETURN 9329 CASE (isouth_u, isouth_l) !< south facing 9330 IF ( y > y2 ) RETURN 9331 CASE (inorth_u, inorth_l) !< north facing 9332 IF ( y < y2 ) RETURN 9333 CASE (iwest_u, iwest_l) !< west facing 9334 IF ( x > x2 ) RETURN 9335 CASE (ieast_u, ieast_l) !< east facing 9336 IF ( x < x2 ) RETURN 9337 CASE (-1) 9338 CONTINUE 9339 END SELECT 9340 9341 surface_facing = .TRUE. 9342 9343 END FUNCTION surface_facing 9344 9345 9346 !------------------------------------------------------------------------------! 9347 ! 9099 9348 ! Description: 9100 9349 ! ------------ 9101 !> Simuates a single position 9102 !--------------------------------------------------------------------------------------------------! 9103 SUBROUTINE simulate_pos( time_since_reference_local ) 9104 9105 REAL(wp) :: solar_azim !< solar azimuth in rotated model coordinates 9106 REAL(wp), INTENT(IN) :: time_since_reference_local !< local time since reference 9107 ! 9108 !-- Update apparent solar position based on modified t_s_r_p 9109 CALL get_date_time( time_since_reference_local, day_of_year = day_of_year, & 9110 second_of_day = second_of_day ) 9111 CALL calc_zenith( day_of_year, second_of_day ) 9112 IF ( cos_zenith > 0 ) THEN 9113 ! 9114 !-- Identify solar direction vector (discretized number) 1) 9115 solar_azim = ATAN2( sun_dir_lon, sun_dir_lat ) * ( 180.0_wp / pi ) - rotation_angle 9116 i = MODULO( NINT( solar_azim / 360.0_wp * raytrace_discrete_azims - .5_wp, iwp ), & 9117 raytrace_discrete_azims ) 9118 j = FLOOR( ACOS( cos_zenith ) / pi * raytrace_discrete_elevs ) 9119 IF ( dsidir_rev(j, i) == -1 ) THEN 9120 ndsidir = ndsidir + 1 9121 dsidir_tmp(:, ndsidir) = & 9122 (/ COS( ( REAL( j,wp ) + .5_wp ) * pi / raytrace_discrete_elevs ), & 9123 SIN( ( REAL( j,wp ) + .5_wp ) * pi / raytrace_discrete_elevs ) & 9124 * COS( ( REAL( i,wp ) + .5_wp ) * 2_wp*pi / raytrace_discrete_azims ), & 9125 SIN( ( REAL( j,wp ) + .5_wp ) * pi / raytrace_discrete_elevs ) & 9126 * SIN( ( REAL( i,wp ) + .5_wp ) * 2_wp*pi / raytrace_discrete_azims ) /) 9127 dsidir_rev(j, i) = ndsidir 9128 ENDIF 9129 ENDIF 9130 END SUBROUTINE simulate_pos 9131 9132 END SUBROUTINE radiation_presimulate_solar_pos 9133 9134 9135 9136 !--------------------------------------------------------------------------------------------------! 9350 !> Reads svf, svfsurf, csf, csfsurf and mrt factors data from saved file. 9351 !> This allows to skip their calculation during of RTM init phase. 9352 !> SVF means sky view factors and CSF means canopy sink factors. 9353 !------------------------------------------------------------------------------! 9354 SUBROUTINE radiation_read_svf 9355 9356 IMPLICIT NONE 9357 9358 CHARACTER(rad_version_len) :: rad_version_field 9359 9360 INTEGER(iwp) :: i 9361 INTEGER(iwp) :: ndsidir_from_file = 0 9362 INTEGER(iwp) :: npcbl_from_file = 0 9363 INTEGER(iwp) :: nsurfl_from_file = 0 9364 INTEGER(iwp) :: nmrtbl_from_file = 0 9365 9366 9367 CALL location_message( 'reading view factors for radiation interaction', 'start' ) 9368 9369 DO i = 0, io_blocks-1 9370 IF ( i == io_group ) THEN 9371 9372 ! 9373 !-- numprocs_previous_run is only known in case of reading restart 9374 !-- data. If a new initial run which reads svf data is started the 9375 !-- following query will be skipped 9376 IF ( initializing_actions == 'read_restart_data' ) THEN 9377 9378 IF ( numprocs_previous_run /= numprocs ) THEN 9379 WRITE( message_string, * ) 'A different number of ', & 9380 'processors between the run ', & 9381 'that has written the svf data ',& 9382 'and the one that will read it ',& 9383 'is not allowed' 9384 CALL message( 'check_open', 'PA0491', 1, 2, 0, 6, 0 ) 9385 ENDIF 9386 9387 ENDIF 9388 9389 ! 9390 !-- Open binary file 9391 CALL check_open( 88 ) 9392 9393 ! 9394 !-- read and check version 9395 READ ( 88 ) rad_version_field 9396 IF ( TRIM(rad_version_field) /= TRIM(rad_version) ) THEN 9397 WRITE( message_string, * ) 'Version of binary SVF file "', & 9398 TRIM(rad_version_field), '" does not match ', & 9399 'the version of model "', TRIM(rad_version), '"' 9400 CALL message( 'radiation_read_svf', 'PA0482', 1, 2, 0, 6, 0 ) 9401 ENDIF 9402 9403 ! 9404 !-- read nsvfl, ncsfl, nsurfl, nmrtf 9405 READ ( 88 ) nsvfl, ncsfl, nsurfl_from_file, npcbl_from_file, & 9406 ndsidir_from_file, nmrtbl_from_file, nmrtf 9407 9408 IF ( nsvfl < 0 .OR. ncsfl < 0 ) THEN 9409 WRITE( message_string, * ) 'Wrong number of SVF or CSF' 9410 CALL message( 'radiation_read_svf', 'PA0483', 1, 2, 0, 6, 0 ) 9411 ELSE 9412 WRITE(debug_string,*) 'Number of SVF, CSF, and nsurfl ', & 9413 'to read', nsvfl, ncsfl, & 9414 nsurfl_from_file 9415 IF ( debug_output ) CALL debug_message( debug_string, 'info' ) 9416 ENDIF 9417 9418 IF ( nsurfl_from_file /= nsurfl ) THEN 9419 WRITE( message_string, * ) 'nsurfl from SVF file does not ', & 9420 'match calculated nsurfl from ', & 9421 'radiation_interaction_init' 9422 CALL message( 'radiation_read_svf', 'PA0490', 1, 2, 0, 6, 0 ) 9423 ENDIF 9424 9425 IF ( npcbl_from_file /= npcbl ) THEN 9426 WRITE( message_string, * ) 'npcbl from SVF file does not ', & 9427 'match calculated npcbl from ', & 9428 'radiation_interaction_init' 9429 CALL message( 'radiation_read_svf', 'PA0493', 1, 2, 0, 6, 0 ) 9430 ENDIF 9431 9432 IF ( ndsidir_from_file /= ndsidir ) THEN 9433 WRITE( message_string, * ) 'ndsidir from SVF file does not ', & 9434 'match calculated ndsidir from ', & 9435 'radiation_presimulate_solar_pos' 9436 CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 ) 9437 ENDIF 9438 IF ( nmrtbl_from_file /= nmrtbl ) THEN 9439 WRITE( message_string, * ) 'nmrtbl from SVF file does not ', & 9440 'match calculated nmrtbl from ', & 9441 'radiation_interaction_init' 9442 CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 ) 9443 ELSE 9444 WRITE(debug_string,*) 'Number of nmrtf to read ', nmrtf 9445 IF ( debug_output ) CALL debug_message( debug_string, 'info' ) 9446 ENDIF 9447 9448 ! 9449 !-- Arrays skyvf, skyvft, dsitrans and dsitransc are allready 9450 !-- allocated in radiation_interaction_init and 9451 !-- radiation_presimulate_solar_pos 9452 IF ( nsurfl > 0 ) THEN 9453 READ(88) skyvf 9454 READ(88) skyvft 9455 READ(88) dsitrans 9456 ENDIF 9457 9458 IF ( plant_canopy .AND. npcbl > 0 ) THEN 9459 READ ( 88 ) dsitransc 9460 ENDIF 9461 9462 ! 9463 !-- The allocation of svf, svfsurf, csf, csfsurf, mrtf, mrtft, and 9464 !-- mrtfsurf happens in routine radiation_calc_svf which is not 9465 !-- called if the program enters radiation_read_svf. Therefore 9466 !-- these arrays has to allocate in the following 9467 IF ( nsvfl > 0 ) THEN 9468 ALLOCATE( svf(ndsvf,nsvfl) ) 9469 ALLOCATE( svfsurf(idsvf,nsvfl) ) 9470 READ(88) svf 9471 READ(88) svfsurf 9472 ENDIF 9473 9474 IF ( plant_canopy .AND. ncsfl > 0 ) THEN 9475 ALLOCATE( csf(ndcsf,ncsfl) ) 9476 ALLOCATE( csfsurf(idcsf,ncsfl) ) 9477 READ(88) csf 9478 READ(88) csfsurf 9479 ENDIF 9480 9481 IF ( nmrtbl > 0 ) THEN 9482 READ(88) mrtsky 9483 READ(88) mrtskyt 9484 READ(88) mrtdsit 9485 ENDIF 9486 9487 IF ( nmrtf > 0 ) THEN 9488 ALLOCATE ( mrtf(nmrtf) ) 9489 ALLOCATE ( mrtft(nmrtf) ) 9490 ALLOCATE ( mrtfsurf(2,nmrtf) ) 9491 READ(88) mrtf 9492 READ(88) mrtft 9493 READ(88) mrtfsurf 9494 ENDIF 9495 9496 ! 9497 !-- Close binary file 9498 CALL close_file( 88 ) 9499 9500 ENDIF 9501 #if defined( __parallel ) 9502 CALL MPI_BARRIER( comm2d, ierr ) 9503 #endif 9504 ENDDO 9505 9506 CALL location_message( 'reading view factors for radiation interaction', 'finished' ) 9507 9508 9509 END SUBROUTINE radiation_read_svf 9510 9511 9512 !------------------------------------------------------------------------------! 9513 ! 9137 9514 ! Description: 9138 9515 ! ------------ 9139 !> Determines whether two faces are oriented towards each other in RTM. Since the surfaces follow 9140 !> the gird box surfaces, it checks first whether the two surfaces are directed in the same 9141 !> direction, then it checks if the two surfaces are located in confronted direction but facing away 9142 !> from each other, e.g. <--| |--> 9143 !--------------------------------------------------------------------------------------------------! 9144 PURE LOGICAL FUNCTION surface_facing( x, y, z, d, x2, y2, z2, d2 ) 9145 9146 IMPLICIT NONE 9147 INTEGER(iwp), INTENT(in) :: x, y, z, d, x2, y2, z2, d2 !< 9148 9149 surface_facing = .FALSE. 9150 ! 9151 !-- First check: are the two surfaces directed in the same direction 9152 IF ( ( d == iup_u .OR. d == iup_l ) .AND. ( d2 == iup_u .OR. d2 == iup_l ) ) RETURN 9153 IF ( ( d == isouth_u .OR. d == isouth_l ) & 9154 .AND. ( d2 == isouth_u .OR. d2 == isouth_l ) ) RETURN 9155 IF ( ( d == inorth_u .OR. d == inorth_l ) & 9156 .AND. ( d2 == inorth_u .OR. d2 == inorth_l ) ) RETURN 9157 IF ( ( d == iwest_u .OR. d == iwest_l ) & 9158 .AND. ( d2 == iwest_u .OR. d2 == iwest_l ) ) RETURN 9159 IF ( ( d == ieast_u .OR. d == ieast_l ) & 9160 .AND. ( d2 == ieast_u .OR. d2 == ieast_l ) ) RETURN 9161 ! 9162 !-- Second check: are surfaces facing away from each other 9163 SELECT CASE (d) 9164 CASE (iup_u, iup_l) !< Upward facing surfaces 9165 IF ( z2 < z ) RETURN 9166 CASE (isouth_u, isouth_l) !< Southward facing surfaces 9167 IF ( y2 > y ) RETURN 9168 CASE (inorth_u, inorth_l) !< Northward facing surfaces 9169 IF ( y2 < y ) RETURN 9170 CASE (iwest_u, iwest_l) !< Westward facing surfaces 9171 IF ( x2 > x ) RETURN 9172 CASE (ieast_u, ieast_l) !< Eastward facing surfaces 9173 IF ( x2 < x ) RETURN 9174 END SELECT 9175 9176 SELECT CASE (d2) 9177 CASE (iup_u) !< Ground, roof 9178 IF ( z < z2 ) RETURN 9179 CASE (isouth_u, isouth_l) !< South facing 9180 IF ( y > y2 ) RETURN 9181 CASE (inorth_u, inorth_l) !< North facing 9182 IF ( y < y2 ) RETURN 9183 CASE (iwest_u, iwest_l) !< West facing 9184 IF ( x > x2 ) RETURN 9185 CASE (ieast_u, ieast_l) !< East facing 9186 IF ( x < x2 ) RETURN 9187 CASE (-1) 9188 CONTINUE 9189 END SELECT 9190 9191 surface_facing = .TRUE. 9192 9193 END FUNCTION surface_facing 9194 9195 9196 !--------------------------------------------------------------------------------------------------! 9197 ! Description: 9198 ! ------------ 9199 !> Reads svf, svfsurf, csf, csfsurf and mrt factors data from saved file. This allows to skip their 9200 !> calculation during of RTM init phase. SVF means sky view factors and CSF means canopy sink 9201 !> factors. 9202 !--------------------------------------------------------------------------------------------------! 9203 SUBROUTINE radiation_read_svf 9204 9205 IMPLICIT NONE 9206 9207 CHARACTER(rad_version_len) :: rad_version_field !< 9208 9209 INTEGER(iwp) :: i !< 9210 INTEGER(iwp) :: ndsidir_from_file = 0 !< 9211 INTEGER(iwp) :: npcbl_from_file = 0 !< 9212 INTEGER(iwp) :: nsurfl_from_file = 0 !< 9213 INTEGER(iwp) :: nmrtbl_from_file = 0 !< 9214 9215 9216 CALL location_message( 'reading view factors for radiation interaction', 'start' ) 9217 9218 DO i = 0, io_blocks-1 9219 IF ( i == io_group ) THEN 9220 9221 ! 9222 !-- Numprocs_previous_run is only known in case of reading restart data. If a new initial run 9223 !-- which reads svf data is started the following query will be skipped 9224 IF ( initializing_actions == 'read_restart_data' ) THEN 9225 9226 IF ( numprocs_previous_run /= numprocs ) THEN 9227 WRITE( message_string, * ) 'A different number of processors between the run ', & 9228 'that has written the svf data and the one that ' // & 9229 'will read it is not allowed' 9230 CALL message( 'check_open', 'PA0491', 1, 2, 0, 6, 0 ) 9516 !> Subroutine stores svf, svfsurf, csf, csfsurf and mrt data to a file. 9517 !> The stored factors can be reused in future simulation with the same 9518 !> geometry structure of the surfaces and resolved plant canopy. 9519 !------------------------------------------------------------------------------! 9520 SUBROUTINE radiation_write_svf 9521 9522 IMPLICIT NONE 9523 9524 INTEGER(iwp) :: i 9525 9526 9527 CALL location_message( 'writing view factors for radiation interaction', 'start' ) 9528 9529 DO i = 0, io_blocks-1 9530 IF ( i == io_group ) THEN 9531 ! 9532 !-- Open binary file 9533 CALL check_open( 89 ) 9534 9535 WRITE ( 89 ) rad_version 9536 WRITE ( 89 ) nsvfl, ncsfl, nsurfl, npcbl, ndsidir, nmrtbl, nmrtf 9537 IF ( nsurfl > 0 ) THEN 9538 WRITE ( 89 ) skyvf 9539 WRITE ( 89 ) skyvft 9540 WRITE ( 89 ) dsitrans 9231 9541 ENDIF 9232 9233 ENDIF 9234 9235 ! 9236 !-- Open binary file 9237 CALL check_open( 88 ) 9238 9239 ! 9240 !-- Read and check version 9241 READ ( 88 ) rad_version_field 9242 IF ( TRIM( rad_version_field ) /= TRIM( rad_version ) ) THEN 9243 WRITE( message_string, * ) 'Version of binary SVF file "', TRIM( rad_version_field ),& 9244 '" does not match the version of model "', & 9245 TRIM(rad_version), '"' 9246 CALL message( 'radiation_read_svf', 'PA0482', 1, 2, 0, 6, 0 ) 9247 ENDIF 9248 9249 ! 9250 !-- Read nsvfl, ncsfl, nsurfl, nmrtf 9251 READ ( 88 ) nsvfl, ncsfl, nsurfl_from_file, npcbl_from_file, ndsidir_from_file, & 9252 nmrtbl_from_file, nmrtf 9253 9254 IF ( nsvfl < 0 .OR. ncsfl < 0 ) THEN 9255 WRITE( message_string, * ) 'Wrong number of SVF or CSF' 9256 CALL message( 'radiation_read_svf', 'PA0483', 1, 2, 0, 6, 0 ) 9257 ELSE 9258 WRITE( debug_string, * ) 'Number of SVF, CSF, and nsurfl to read', nsvfl, ncsfl, & 9259 nsurfl_from_file 9260 IF ( debug_output ) CALL debug_message( debug_string, 'info' ) 9261 ENDIF 9262 9263 IF ( nsurfl_from_file /= nsurfl ) THEN 9264 WRITE( message_string, * ) 'nsurfl from SVF file does not match calculated ' // & 9265 'nsurfl from radiation_interaction_init' 9266 CALL message( 'radiation_read_svf', 'PA0490', 1, 2, 0, 6, 0 ) 9267 ENDIF 9268 9269 IF ( npcbl_from_file /= npcbl ) THEN 9270 WRITE( message_string, * ) 'npcbl from SVF file does not match calculated ' // & 9271 'npcbl from radiation_interaction_init' 9272 CALL message( 'radiation_read_svf', 'PA0493', 1, 2, 0, 6, 0 ) 9273 ENDIF 9274 9275 IF ( ndsidir_from_file /= ndsidir ) THEN 9276 WRITE( message_string, * ) 'ndsidir from SVF file does not match calculated ' // & 9277 'ndsidir from radiation_presimulate_solar_pos' 9278 CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 ) 9279 ENDIF 9280 IF ( nmrtbl_from_file /= nmrtbl ) THEN 9281 WRITE( message_string, * ) 'nmrtbl from SVF file does not match calculated ' // & 9282 'nmrtbl from radiation_interaction_init' 9283 CALL message( 'radiation_read_svf', 'PA0494', 1, 2, 0, 6, 0 ) 9284 ELSE 9285 WRITE( debug_string, * ) 'Number of nmrtf to read ', nmrtf 9286 IF ( debug_output ) CALL debug_message( debug_string, 'info' ) 9287 ENDIF 9288 9289 ! 9290 !-- Arrays skyvf, skyvft, dsitrans and dsitransc are already allocated in 9291 !-- radiation_interaction_init and radiation_presimulate_solar_pos 9292 IF ( nsurfl > 0 ) THEN 9293 READ( 88 ) skyvf 9294 READ( 88 ) skyvft 9295 READ( 88 ) dsitrans 9296 ENDIF 9297 9298 IF ( plant_canopy .AND. npcbl > 0 ) THEN 9299 READ ( 88 ) dsitransc 9300 ENDIF 9301 9302 ! 9303 !-- The allocation of svf, svfsurf, csf, csfsurf, mrtf, mrtft, and mrtfsurf happens in routine 9304 !-- radiation_calc_svf which is not called if the program enters radiation_read_svf. Therefore 9305 !-- these arrays have to be allocated in the following 9306 IF ( nsvfl > 0 ) THEN 9307 ALLOCATE( svf(ndsvf,nsvfl) ) 9308 ALLOCATE( svfsurf(idsvf,nsvfl) ) 9309 READ( 88 ) svf 9310 READ( 88 ) svfsurf 9311 ENDIF 9312 9313 IF ( plant_canopy .AND. ncsfl > 0 ) THEN 9314 ALLOCATE( csf(ndcsf,ncsfl) ) 9315 ALLOCATE( csfsurf(idcsf,ncsfl) ) 9316 READ( 88 ) csf 9317 READ( 88 ) csfsurf 9318 ENDIF 9319 9320 IF ( nmrtbl > 0 ) THEN 9321 READ( 88 ) mrtsky 9322 READ( 88 ) mrtskyt 9323 READ( 88 ) mrtdsit 9324 ENDIF 9325 9326 IF ( nmrtf > 0 ) THEN 9327 ALLOCATE( mrtf(nmrtf) ) 9328 ALLOCATE( mrtft(nmrtf) ) 9329 ALLOCATE( mrtfsurf(2,nmrtf) ) 9330 READ( 88 ) mrtf 9331 READ( 88 ) mrtft 9332 READ( 88 ) mrtfsurf 9333 ENDIF 9334 9335 ! 9336 !-- Close binary file 9337 CALL close_file( 88 ) 9338 9339 ENDIF 9542 IF ( npcbl > 0 ) THEN 9543 WRITE ( 89 ) dsitransc 9544 ENDIF 9545 IF ( nsvfl > 0 ) THEN 9546 WRITE ( 89 ) svf 9547 WRITE ( 89 ) svfsurf 9548 ENDIF 9549 IF ( plant_canopy .AND. ncsfl > 0 ) THEN 9550 WRITE ( 89 ) csf 9551 WRITE ( 89 ) csfsurf 9552 ENDIF 9553 IF ( nmrtbl > 0 ) THEN 9554 WRITE ( 89 ) mrtsky 9555 WRITE ( 89 ) mrtskyt 9556 WRITE ( 89 ) mrtdsit 9557 ENDIF 9558 IF ( nmrtf > 0 ) THEN 9559 WRITE ( 89 ) mrtf 9560 WRITE ( 89 ) mrtft 9561 WRITE ( 89 ) mrtfsurf 9562 ENDIF 9563 ! 9564 !-- Close binary file 9565 CALL close_file( 89 ) 9566 9567 ENDIF 9340 9568 #if defined( __parallel ) 9341 CALL MPI_BARRIER( comm2d, ierr )9569 CALL MPI_BARRIER( comm2d, ierr ) 9342 9570 #endif 9343 ENDDO 9344 9345 CALL location_message( 'reading view factors for radiation interaction', 'finished' ) 9346 9347 9348 END SUBROUTINE radiation_read_svf 9349 9350 9351 !--------------------------------------------------------------------------------------------------! 9352 ! Description: 9353 ! ------------ 9354 !> Subroutine stores svf, svfsurf, csf, csfsurf and mrt data to a file. The stored factors can be 9355 !> reused in future simulation with the same geometry structure of the surfaces and resolved plant 9356 !> canopy. 9357 !--------------------------------------------------------------------------------------------------! 9358 SUBROUTINE radiation_write_svf 9359 9360 IMPLICIT NONE 9361 9362 INTEGER(iwp) :: i !< 9363 9364 9365 CALL location_message( 'writing view factors for radiation interaction', 'start' ) 9366 9367 DO i = 0, io_blocks-1 9368 IF ( i == io_group ) THEN 9369 ! 9370 !-- Open binary file 9371 CALL check_open( 89 ) 9372 9373 WRITE( 89 ) rad_version 9374 WRITE( 89 ) nsvfl, ncsfl, nsurfl, npcbl, ndsidir, nmrtbl, nmrtf 9375 IF ( nsurfl > 0 ) THEN 9376 WRITE( 89 ) skyvf 9377 WRITE( 89 ) skyvft 9378 WRITE( 89 ) dsitrans 9379 ENDIF 9380 IF ( npcbl > 0 ) THEN 9381 WRITE( 89 ) dsitransc 9382 ENDIF 9383 IF ( nsvfl > 0 ) THEN 9384 WRITE( 89 ) svf 9385 WRITE( 89 ) svfsurf 9386 ENDIF 9387 IF ( plant_canopy .AND. ncsfl > 0 ) THEN 9388 WRITE( 89 ) csf 9389 WRITE( 89 ) csfsurf 9390 ENDIF 9391 IF ( nmrtbl > 0 ) THEN 9392 WRITE( 89 ) mrtsky 9393 WRITE( 89 ) mrtskyt 9394 WRITE( 89 ) mrtdsit 9395 ENDIF 9396 IF ( nmrtf > 0 ) THEN 9397 WRITE( 89 ) mrtf 9398 WRITE( 89 ) mrtft 9399 WRITE( 89 ) mrtfsurf 9400 ENDIF 9401 ! 9402 !-- Close binary file 9403 CALL close_file( 89 ) 9404 9405 ENDIF 9406 #if defined( __parallel ) 9407 CALL MPI_BARRIER( comm2d, ierr ) 9408 #endif 9409 ENDDO 9410 9411 CALL location_message( 'writing view factors for radiation interaction', 'finished' ) 9412 9413 9414 END SUBROUTINE radiation_write_svf 9415 9416 9417 !--------------------------------------------------------------------------------------------------! 9571 ENDDO 9572 9573 CALL location_message( 'writing view factors for radiation interaction', 'finished' ) 9574 9575 9576 END SUBROUTINE radiation_write_svf 9577 9578 9579 !------------------------------------------------------------------------------! 9580 ! 9418 9581 ! Description: 9419 9582 ! ------------ 9420 9583 !> Block of auxiliary subroutines for RTM: 9421 9584 !> 1. quicksort and corresponding comparison 9422 !> 2. merge_and_grow_csf for implementation of "dynamical growing" array for csf 9423 !--------------------------------------------------------------------------------------------------! 9585 !> 2. merge_and_grow_csf for implementation of "dynamical growing" 9586 !> array for csf 9587 !------------------------------------------------------------------------------! 9424 9588 !-- quicksort.f -*-f90-*- 9425 9589 !-- Author: t-nissie, adaptation J.Resler 9426 9590 !-- License: GPLv3 9427 9591 !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea 9428 RECURSIVE SUBROUTINE quicksort_itarget( itarget, vffrac, ztransp, first, last ) 9429 9430 IMPLICIT NONE 9431 INTEGER(iwp) :: x, t !< 9432 INTEGER(iwp) :: i, j !< 9433 INTEGER(iwp), INTENT(IN) :: first, last !< 9434 INTEGER(iwp), DIMENSION(:), INTENT(INOUT) :: itarget !< 9435 9436 REAL(wp) :: tr !< 9437 REAL(wp), DIMENSION(:), INTENT(INOUT) :: vffrac, ztransp !< 9438 9439 9440 9441 IF ( first >= last ) RETURN 9442 x = itarget((first+last)/2) 9443 i = first 9444 j = last 9445 DO 9446 DO WHILE ( itarget(i) < x ) 9447 i = i + 1 9592 RECURSIVE SUBROUTINE quicksort_itarget(itarget, vffrac, ztransp, first, last) 9593 IMPLICIT NONE 9594 INTEGER(iwp), DIMENSION(:), INTENT(INOUT) :: itarget 9595 REAL(wp), DIMENSION(:), INTENT(INOUT) :: vffrac, ztransp 9596 INTEGER(iwp), INTENT(IN) :: first, last 9597 INTEGER(iwp) :: x, t 9598 INTEGER(iwp) :: i, j 9599 REAL(wp) :: tr 9600 9601 IF ( first>=last ) RETURN 9602 x = itarget((first+last)/2) 9603 i = first 9604 j = last 9605 DO 9606 DO WHILE ( itarget(i) < x ) 9607 i=i+1 9608 ENDDO 9609 DO WHILE ( x < itarget(j) ) 9610 j=j-1 9611 ENDDO 9612 IF ( i >= j ) EXIT 9613 t = itarget(i); itarget(i) = itarget(j); itarget(j) = t 9614 tr = vffrac(i); vffrac(i) = vffrac(j); vffrac(j) = tr 9615 tr = ztransp(i); ztransp(i) = ztransp(j); ztransp(j) = tr 9616 i=i+1 9617 j=j-1 9448 9618 ENDDO 9449 DO WHILE ( x < itarget(j) ) 9450 j = j - 1 9451 ENDDO 9452 IF ( i >= j ) EXIT 9453 t = itarget(i); itarget(i) = itarget(j); itarget(j) = t 9454 tr = vffrac(i); vffrac(i) = vffrac(j); vffrac(j) = tr 9455 tr = ztransp(i); ztransp(i) = ztransp(j); ztransp(j) = tr 9456 i= i + 1 9457 j= j - 1 9458 ENDDO 9459 IF ( first < i - 1 ) CALL quicksort_itarget( itarget, vffrac, ztransp, first, i - 1 ) 9460 IF ( j + 1 < last ) CALL quicksort_itarget( itarget, vffrac, ztransp, j + 1, last ) 9461 9462 END SUBROUTINE quicksort_itarget 9463 9464 9465 PURE FUNCTION svf_lt( svf1,svf2 ) result (res) 9466 9467 LOGICAL :: res !< 9468 TYPE (t_svf), INTENT(in) :: svf1,svf2 !< 9469 9470 IF ( svf1%isurflt < svf2%isurflt .OR. & 9471 ( svf1%isurflt == svf2%isurflt .AND. svf1%isurfs < svf2%isurfs ) ) THEN 9472 res = .TRUE. 9473 ELSE 9474 res = .FALSE. 9475 ENDIF 9476 END FUNCTION svf_lt 9619 IF ( first < i-1 ) CALL quicksort_itarget(itarget, vffrac, ztransp, first, i-1) 9620 IF ( j+1 < last ) CALL quicksort_itarget(itarget, vffrac, ztransp, j+1, last) 9621 END SUBROUTINE quicksort_itarget 9622 9623 PURE FUNCTION svf_lt(svf1,svf2) result (res) 9624 TYPE (t_svf), INTENT(in) :: svf1,svf2 9625 LOGICAL :: res 9626 IF ( svf1%isurflt < svf2%isurflt .OR. & 9627 (svf1%isurflt == svf2%isurflt .AND. svf1%isurfs < svf2%isurfs) ) THEN 9628 res = .TRUE. 9629 ELSE 9630 res = .FALSE. 9631 ENDIF 9632 END FUNCTION svf_lt 9477 9633 9478 9634 … … 9481 9637 !-- License: GPLv3 9482 9638 !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea 9483 RECURSIVE SUBROUTINE quicksort_svf( svfl, first, last) 9484 9485 IMPLICIT NONE 9486 INTEGER(iwp) :: i, j !< 9487 INTEGER(iwp), INTENT(IN) :: first, last !< 9488 TYPE(t_svf) :: x, t !< 9489 TYPE(t_svf), DIMENSION(:), INTENT(INOUT) :: svfl !< 9490 9491 9492 9493 9494 IF ( first >= last ) RETURN 9495 x = svfl((first+last)/2) 9496 i = first 9497 j = last 9498 DO 9499 DO while ( svf_lt(svfl(i),x) ) 9500 i = i + 1 9639 RECURSIVE SUBROUTINE quicksort_svf(svfl, first, last) 9640 IMPLICIT NONE 9641 TYPE(t_svf), DIMENSION(:), INTENT(INOUT) :: svfl 9642 INTEGER(iwp), INTENT(IN) :: first, last 9643 TYPE(t_svf) :: x, t 9644 INTEGER(iwp) :: i, j 9645 9646 IF ( first>=last ) RETURN 9647 x = svfl( (first+last) / 2 ) 9648 i = first 9649 j = last 9650 DO 9651 DO while ( svf_lt(svfl(i),x) ) 9652 i=i+1 9653 ENDDO 9654 DO while ( svf_lt(x,svfl(j)) ) 9655 j=j-1 9656 ENDDO 9657 IF ( i >= j ) EXIT 9658 t = svfl(i); svfl(i) = svfl(j); svfl(j) = t 9659 i=i+1 9660 j=j-1 9501 9661 ENDDO 9502 DO while ( svf_lt(x,svfl(j)) ) 9503 j = j - 1 9504 ENDDO 9505 IF ( i >= j ) EXIT 9506 t = svfl(i); svfl(i) = svfl(j); svfl(j) = t 9507 i = i + 1 9508 j = j - 1 9509 ENDDO 9510 IF ( first < i - 1 ) CALL quicksort_svf( svfl, first, i - 1 ) 9511 IF ( j + 1 < last ) CALL quicksort_svf( svfl, j + 1, last ) 9512 9513 END SUBROUTINE quicksort_svf 9514 9515 9516 PURE FUNCTION csf_lt( csf1, csf2 ) result (res) 9517 9518 LOGICAL :: res !< 9519 TYPE (t_csf), INTENT(in) :: csf1,csf2 !< 9520 9521 IF ( csf1%ip < csf2%ip .OR. ( csf1%ip == csf2%ip .AND. csf1%itx < csf2%itx ) .OR. & 9522 ( csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity < csf2%ity ) .OR. & 9523 ( csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. & 9524 csf1%itz < csf2%itz ) .OR. ( csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. & 9525 csf1%ity == csf2%ity .AND. csf1%itz == csf2%itz .AND. csf1%isurfs < csf2%isurfs ) ) & 9526 THEN 9527 res = .TRUE. 9528 ELSE 9529 res = .FALSE. 9530 ENDIF 9531 END FUNCTION csf_lt 9662 IF ( first < i-1 ) CALL quicksort_svf(svfl, first, i-1) 9663 IF ( j+1 < last ) CALL quicksort_svf(svfl, j+1, last) 9664 END SUBROUTINE quicksort_svf 9665 9666 PURE FUNCTION csf_lt(csf1,csf2) result (res) 9667 TYPE (t_csf), INTENT(in) :: csf1,csf2 9668 LOGICAL :: res 9669 IF ( csf1%ip < csf2%ip .OR. & 9670 (csf1%ip == csf2%ip .AND. csf1%itx < csf2%itx) .OR. & 9671 (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity < csf2%ity) .OR. & 9672 (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. & 9673 csf1%itz < csf2%itz) .OR. & 9674 (csf1%ip == csf2%ip .AND. csf1%itx == csf2%itx .AND. csf1%ity == csf2%ity .AND. & 9675 csf1%itz == csf2%itz .AND. csf1%isurfs < csf2%isurfs) ) THEN 9676 res = .TRUE. 9677 ELSE 9678 res = .FALSE. 9679 ENDIF 9680 END FUNCTION csf_lt 9532 9681 9533 9682 … … 9536 9685 !-- License: GPLv3 9537 9686 !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea 9538 RECURSIVE SUBROUTINE quicksort_csf( csfl, first, last ) 9539 9540 IMPLICIT NONE 9541 INTEGER(iwp) :: i, j !< 9542 INTEGER(iwp), INTENT(IN) :: first, last !< 9543 TYPE(t_csf) :: x, t !< 9544 TYPE(t_csf), DIMENSION(:), INTENT(INOUT) :: csfl !< 9545 9546 9547 IF ( first >= last ) RETURN 9548 x = csfl((first+last)/2) 9549 i = first 9550 j = last 9551 DO 9552 DO while ( csf_lt(csfl(i),x) ) 9553 i = i + 1 9687 RECURSIVE SUBROUTINE quicksort_csf(csfl, first, last) 9688 IMPLICIT NONE 9689 TYPE(t_csf), DIMENSION(:), INTENT(INOUT) :: csfl 9690 INTEGER(iwp), INTENT(IN) :: first, last 9691 TYPE(t_csf) :: x, t 9692 INTEGER(iwp) :: i, j 9693 9694 IF ( first>=last ) RETURN 9695 x = csfl( (first+last)/2 ) 9696 i = first 9697 j = last 9698 DO 9699 DO while ( csf_lt(csfl(i),x) ) 9700 i=i+1 9701 ENDDO 9702 DO while ( csf_lt(x,csfl(j)) ) 9703 j=j-1 9704 ENDDO 9705 IF ( i >= j ) EXIT 9706 t = csfl(i); csfl(i) = csfl(j); csfl(j) = t 9707 i=i+1 9708 j=j-1 9554 9709 ENDDO 9555 DO while ( csf_lt(x,csfl(j)) ) 9556 j = j - 1 9557 ENDDO 9558 IF ( i >= j ) EXIT 9559 t = csfl(i); csfl(i) = csfl(j); csfl(j) = t 9560 i = i + 1 9561 j = j - 1 9562 ENDDO 9563 IF ( first < i - 1 ) CALL quicksort_csf( csfl, first, i - 1 ) 9564 IF ( j + 1 < last ) CALL quicksort_csf( csfl, j + 1, last ) 9565 9566 END SUBROUTINE quicksort_csf 9567 9568 9569 !--------------------------------------------------------------------------------------------------! 9710 IF ( first < i-1 ) CALL quicksort_csf(csfl, first, i-1) 9711 IF ( j+1 < last ) CALL quicksort_csf(csfl, j+1, last) 9712 END SUBROUTINE quicksort_csf 9713 9714 9715 !------------------------------------------------------------------------------! 9716 ! 9570 9717 ! Description: 9571 9718 ! ------------ 9572 !> Grows the CSF array in RTM exponentially when it is full. During that, the ray canopy sink 9573 !> factors with common source face and target plant canopy grid cell are merged together so that the 9574 !> size doesn't grow out of control. 9575 !--------------------------------------------------------------------------------------------------! 9576 SUBROUTINE merge_and_grow_csf( newsize ) 9577 9578 INTEGER(iwp) :: iread, iwrite !< 9579 INTEGER(iwp), INTENT(in) :: newsize !< new array size after grow, must be >= ncsfl 9719 !> Grows the CSF array in RTM exponentially when it is full. During that, 9720 !> the ray canopy sink factors with common source face and target plant canopy 9721 !> grid cell are merged together so that the size doesn't grow out of control. 9722 !------------------------------------------------------------------------------! 9723 SUBROUTINE merge_and_grow_csf(newsize) 9724 INTEGER(iwp), INTENT(in) :: newsize !< new array size after grow, must be >= ncsfl 9580 9725 !< or -1 to shrink to minimum 9581 TYPE(t_csf), DIMENSION(:), POINTER :: acsfnew !< 9582 9583 9584 IF ( newsize == -1 ) THEN 9585 !-- Merge in-place 9586 acsfnew => acsf 9587 ELSE 9588 !-- Allocate new array 9726 INTEGER(iwp) :: iread, iwrite 9727 TYPE(t_csf), DIMENSION(:), POINTER :: acsfnew 9728 9729 9730 IF ( newsize == -1 ) THEN 9731 !-- merge in-place 9732 acsfnew => acsf 9733 ELSE 9734 !-- allocate new array 9735 IF ( mcsf == 0 ) THEN 9736 ALLOCATE( acsf1(newsize) ) 9737 acsfnew => acsf1 9738 ELSE 9739 ALLOCATE( acsf2(newsize) ) 9740 acsfnew => acsf2 9741 ENDIF 9742 ENDIF 9743 9744 IF ( ncsfl >= 1 ) THEN 9745 !-- sort csf in place (quicksort) 9746 CALL quicksort_csf(acsf,1,ncsfl) 9747 9748 !-- while moving to a new array, aggregate canopy sink factor records with identical box & source 9749 acsfnew(1) = acsf(1) 9750 iwrite = 1 9751 DO iread = 2, ncsfl 9752 !-- here acsf(kcsf) already has values from acsf(icsf) 9753 IF ( acsfnew(iwrite)%itx == acsf(iread)%itx & 9754 .AND. acsfnew(iwrite)%ity == acsf(iread)%ity & 9755 .AND. acsfnew(iwrite)%itz == acsf(iread)%itz & 9756 .AND. acsfnew(iwrite)%isurfs == acsf(iread)%isurfs ) THEN 9757 9758 acsfnew(iwrite)%rcvf = acsfnew(iwrite)%rcvf + acsf(iread)%rcvf 9759 !-- advance reading index, keep writing index 9760 ELSE 9761 !-- not identical, just advance and copy 9762 iwrite = iwrite + 1 9763 acsfnew(iwrite) = acsf(iread) 9764 ENDIF 9765 ENDDO 9766 ncsfl = iwrite 9767 ENDIF 9768 9769 IF ( newsize == -1 ) THEN 9770 !-- allocate new array and copy shrinked data 9771 IF ( mcsf == 0 ) THEN 9772 ALLOCATE( acsf1(ncsfl) ) 9773 acsf1(1:ncsfl) = acsf2(1:ncsfl) 9774 ELSE 9775 ALLOCATE( acsf2(ncsfl) ) 9776 acsf2(1:ncsfl) = acsf1(1:ncsfl) 9777 ENDIF 9778 ENDIF 9779 9780 !-- deallocate old array 9589 9781 IF ( mcsf == 0 ) THEN 9590 ALLOCATE( acsf1(newsize) ) 9591 acsfnew => acsf1 9782 mcsf = 1 9783 acsf => acsf1 9784 DEALLOCATE( acsf2 ) 9592 9785 ELSE 9593 ALLOCATE( acsf2(newsize) ) 9594 acsfnew => acsf2 9786 mcsf = 0 9787 acsf => acsf2 9788 DEALLOCATE( acsf1 ) 9595 9789 ENDIF 9596 ENDIF 9597 9598 IF ( ncsfl >= 1 ) THEN 9599 !-- Sort csf in place (quicksort) 9600 CALL quicksort_csf( acsf, 1, ncsfl ) 9601 9602 !-- While moving to a new array, aggregate canopy sink factor records with identical box & source 9603 acsfnew(1) = acsf(1) 9604 iwrite = 1 9605 DO iread = 2, ncsfl 9606 !-- Here acsf(kcsf) already has values from acsf(icsf) 9607 IF ( acsfnew(iwrite)%itx == acsf(iread)%itx & 9608 .AND. acsfnew(iwrite)%ity == acsf(iread)%ity & 9609 .AND. acsfnew(iwrite)%itz == acsf(iread)%itz & 9610 .AND. acsfnew(iwrite)%isurfs == acsf(iread)%isurfs ) THEN 9611 9612 acsfnew(iwrite)%rcvf = acsfnew(iwrite)%rcvf + acsf(iread)%rcvf 9613 !-- Advance reading index, keep writing index 9614 ELSE 9615 !-- Not identical, just advance and copy 9616 iwrite = iwrite + 1 9617 acsfnew(iwrite) = acsf(iread) 9618 ENDIF 9619 ENDDO 9620 ncsfl = iwrite 9621 ENDIF 9622 9623 IF ( newsize == -1 ) THEN 9624 !-- Allocate new array and copy shrinked data 9625 IF ( mcsf == 0 ) THEN 9626 ALLOCATE( acsf1(ncsfl) ) 9627 acsf1(1:ncsfl) = acsf2(1:ncsfl) 9628 ELSE 9629 ALLOCATE( acsf2(ncsfl) ) 9630 acsf2(1:ncsfl) = acsf1(1:ncsfl) 9790 ncsfla = newsize 9791 9792 IF ( debug_output ) THEN 9793 WRITE( debug_string, '(A,2I12)' ) 'Grow acsf2:', ncsfl, ncsfla 9794 CALL debug_message( debug_string, 'info' ) 9631 9795 ENDIF 9632 ENDIF 9633 9634 !-- Deallocate old array 9635 IF ( mcsf == 0 ) THEN 9636 mcsf = 1 9637 acsf => acsf1 9638 DEALLOCATE( acsf2 ) 9639 ELSE 9640 mcsf = 0 9641 acsf => acsf2 9642 DEALLOCATE( acsf1 ) 9643 ENDIF 9644 ncsfla = newsize 9645 9646 IF ( debug_output ) THEN 9647 WRITE( debug_string, '(A,2I12)' ) 'Grow acsf2:', ncsfl, ncsfla 9648 CALL debug_message( debug_string, 'info' ) 9649 ENDIF 9650 9651 END SUBROUTINE merge_and_grow_csf 9796 9797 END SUBROUTINE merge_and_grow_csf 9652 9798 9653 9799 … … 9656 9802 !-- License: GPLv3 9657 9803 !-- Gist: https://gist.github.com/t-nissie/479f0f16966925fa29ea 9658 RECURSIVE SUBROUTINE quicksort_csf2( kpcsflt, pcsflt, first, last ) 9659 9660 IMPLICIT NONE 9661 9662 INTEGER(iwp) :: i, j !< 9663 INTEGER(iwp), INTENT(IN) :: first, last !< 9664 INTEGER(iwp), DIMENSION(kdcsf) :: x, t1 !< 9665 INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT) :: kpcsflt !< 9666 9667 REAL(wp), DIMENSION(ndcsf) :: t2 !< 9668 REAL(wp), DIMENSION(:,:), INTENT(INOUT) :: pcsflt !< 9669 9670 IF ( first >= last ) RETURN 9671 x = kpcsflt(:,(first+last)/2) 9672 i = first 9673 j = last 9674 DO 9675 DO while ( csf_lt2(kpcsflt(:,i),x) ) 9676 i = i + 1 9804 RECURSIVE SUBROUTINE quicksort_csf2(kpcsflt, pcsflt, first, last) 9805 IMPLICIT NONE 9806 INTEGER(iwp), DIMENSION(:,:), INTENT(INOUT) :: kpcsflt 9807 REAL(wp), DIMENSION(:,:), INTENT(INOUT) :: pcsflt 9808 INTEGER(iwp), INTENT(IN) :: first, last 9809 REAL(wp), DIMENSION(ndcsf) :: t2 9810 INTEGER(iwp), DIMENSION(kdcsf) :: x, t1 9811 INTEGER(iwp) :: i, j 9812 9813 IF ( first>=last ) RETURN 9814 x = kpcsflt(:, (first+last)/2 ) 9815 i = first 9816 j = last 9817 DO 9818 DO while ( csf_lt2(kpcsflt(:,i),x) ) 9819 i=i+1 9820 ENDDO 9821 DO while ( csf_lt2(x,kpcsflt(:,j)) ) 9822 j=j-1 9823 ENDDO 9824 IF ( i >= j ) EXIT 9825 t1 = kpcsflt(:,i); kpcsflt(:,i) = kpcsflt(:,j); kpcsflt(:,j) = t1 9826 t2 = pcsflt(:,i); pcsflt(:,i) = pcsflt(:,j); pcsflt(:,j) = t2 9827 i=i+1 9828 j=j-1 9677 9829 ENDDO 9678 DO while ( csf_lt2(x,kpcsflt(:,j)) ) 9679 j = j - 1 9830 IF ( first < i-1 ) CALL quicksort_csf2(kpcsflt, pcsflt, first, i-1) 9831 IF ( j+1 < last ) CALL quicksort_csf2(kpcsflt, pcsflt, j+1, last) 9832 END SUBROUTINE quicksort_csf2 9833 9834 9835 PURE FUNCTION csf_lt2(item1, item2) result(res) 9836 INTEGER(iwp), DIMENSION(kdcsf), INTENT(in) :: item1, item2 9837 LOGICAL :: res 9838 res = ( (item1(3) < item2(3)) & 9839 .OR. (item1(3) == item2(3) .AND. item1(2) < item2(2)) & 9840 .OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) < item2(1)) & 9841 .OR. (item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) == item2(1) & 9842 .AND. item1(4) < item2(4)) ) 9843 END FUNCTION csf_lt2 9844 9845 PURE FUNCTION searchsorted(athresh, val) result(ind) 9846 REAL(wp), DIMENSION(:), INTENT(IN) :: athresh 9847 REAL(wp), INTENT(IN) :: val 9848 INTEGER(iwp) :: ind 9849 INTEGER(iwp) :: i 9850 9851 DO i = LBOUND(athresh, 1), UBOUND(athresh, 1) 9852 IF ( val < athresh(i) ) THEN 9853 ind = i - 1 9854 RETURN 9855 ENDIF 9680 9856 ENDDO 9681 IF ( i >= j ) EXIT 9682 t1 = kpcsflt(:,i); kpcsflt(:,i) = kpcsflt(:,j); kpcsflt(:,j) = t1 9683 t2 = pcsflt(:,i); pcsflt(:,i) = pcsflt(:,j); pcsflt(:,j) = t2 9684 i = i + 1 9685 j = j - 1 9686 ENDDO 9687 IF ( first < i - 1 ) CALL quicksort_csf2( kpcsflt, pcsflt, first, i - 1 ) 9688 IF ( j + 1 < last ) CALL quicksort_csf2( kpcsflt, pcsflt, j + 1, last ) 9689 9690 END SUBROUTINE quicksort_csf2 9691 9692 9693 PURE FUNCTION csf_lt2( item1, item2 ) result(res) 9694 9695 INTEGER(iwp), DIMENSION(kdcsf), INTENT(in) :: item1, item2 !< 9696 LOGICAL :: res !< 9697 9698 res = ( ( item1(3) < item2(3) ) & 9699 .OR. ( item1(3) == item2(3) .AND. item1(2) < item2(2) ) & 9700 .OR. ( item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) < item2(1) ) & 9701 .OR. ( item1(3) == item2(3) .AND. item1(2) == item2(2) .AND. item1(1) == item2(1) & 9702 .AND. item1(4) < item2(4) ) ) 9703 9704 END FUNCTION csf_lt2 9705 9706 9707 PURE FUNCTION searchsorted(athresh, val) result(ind) 9708 9709 INTEGER(iwp) :: ind !< 9710 INTEGER(iwp) :: i !< 9711 9712 REAL(wp), INTENT(IN) :: val !< 9713 REAL(wp), DIMENSION(:), INTENT(IN) :: athresh !< 9714 9715 DO i = LBOUND( athresh, 1 ), UBOUND( athresh, 1 ) 9716 IF ( val < athresh(i) ) THEN 9717 ind = i - 1 9718 RETURN 9719 ENDIF 9720 ENDDO 9721 ind = UBOUND( athresh, 1 ) 9722 9723 END FUNCTION searchsorted 9724 9725 9726 !--------------------------------------------------------------------------------------------------! 9857 ind = UBOUND(athresh, 1) 9858 END FUNCTION searchsorted 9859 9860 9861 !------------------------------------------------------------------------------! 9862 ! 9727 9863 ! Description: 9728 9864 ! ------------ 9729 !> For given coordinates, calculates indices within a global 3D (or 2D if nlayers=1) field, e.g. an 9730 !> MPI one-sided window or an array which has been created using e.g. MPI_AllGather. 9731 !--------------------------------------------------------------------------------------------------! 9732 PURE SUBROUTINE radiation_calc_global_offset( i, j, k, nlayers, iproc, offs_proc, offs_glob ) 9865 !> For given coordinates, calculates indices within a global 3D (or 2D if 9866 !> nlayers=1) field, e.g. an MPI one-sided window or an array which has been 9867 !> created using e.g. MPI_AllGather. 9868 !------------------------------------------------------------------------------! 9869 PURE SUBROUTINE radiation_calc_global_offset( i, j, k, nlayers, & 9870 iproc, offs_proc, offs_glob ) 9733 9871 9734 9872 IMPLICIT NONE 9735 9873 9736 INTEGER(iwp), INTENT(IN) :: i !< x-coordinate9737 INTEGER(iwp), INTENT(IN) :: j !< y-coordinate9738 INTEGER(iwp), INTENT(IN) :: k !< z-coordinate9739 INTEGER(iwp), INTENT(IN) :: nlayers !< number of z-layers9740 INTEGER(iwp), INTENT(OUT), OPTIONAL :: iproc !< MPI process rank9874 INTEGER(iwp), INTENT(IN) :: i !< x-coordinate 9875 INTEGER(iwp), INTENT(IN) :: j !< y-coordinate 9876 INTEGER(iwp), INTENT(IN) :: k !< z-coordinate 9877 INTEGER(iwp), INTENT(IN) :: nlayers !< number of z-layers 9878 INTEGER(iwp), INTENT(OUT), OPTIONAL :: iproc !< MPI process rank 9741 9879 #if defined( __parallel ) 9742 INTEGER(kind=MPI_ADDRESS_KIND), INTENT(OUT), OPTIONAL :: offs_proc !< offset within MPI proc9880 INTEGER(kind=MPI_ADDRESS_KIND), INTENT(OUT), OPTIONAL :: offs_proc !< offset within MPI proc 9743 9881 #else 9744 INTEGER(iwp), INTENT(OUT), OPTIONAL :: offs_proc !(actually unused without __parallel)9882 INTEGER(iwp), INTENT(OUT), OPTIONAL :: offs_proc !(actually unused without __parallel) 9745 9883 #endif 9746 INTEGER(iwp), INTENT(OUT), OPTIONAL :: offs_glob !< global offset9747 9748 INTEGER(iwp) :: ipx!< process index in x-direction9749 INTEGER(iwp) :: ipy!< process index in y-direction9750 INTEGER(iwp) :: iproc_l!< local variable for iproc9751 INTEGER(iwp) :: oproc_l!< local variable for offs_proc9752 INTEGER(iwp) :: offs_pstart!< global start of the MPI process9884 INTEGER(iwp), INTENT(OUT), OPTIONAL :: offs_glob !< global offset 9885 9886 INTEGER(iwp) :: ipx !< process index in x-direction 9887 INTEGER(iwp) :: ipy !< process index in y-direction 9888 INTEGER(iwp) :: iproc_l !< local variable for iproc 9889 INTEGER(iwp) :: oproc_l !< local variable for offs_proc 9890 INTEGER(iwp) :: offs_pstart !< global start of the MPI process 9753 9891 9754 9892 ipx = i / nnx 9755 9893 ipy = j / nny 9756 9894 iproc_l = ipx * pdims(2) + ipy 9757 IF ( PRESENT( iproc) ) iproc = iproc_l9758 9759 IF ( PRESENT( offs_proc ) .OR. PRESENT( offs_glob) ) THEN9760 oproc_l = ( i - ipx * nnx ) * nny * nlayers + & ! Columns before9761 ( j - ipy * nny ) * nlayers +& ! rows in column9895 IF ( PRESENT(iproc) ) iproc = iproc_l 9896 9897 IF ( PRESENT(offs_proc) .OR. PRESENT(offs_glob) ) THEN 9898 oproc_l = (i - ipx*nnx) * nny * nlayers + & ! columns before 9899 (j - ipy*nny) * nlayers + & ! rows in column 9762 9900 k 9763 IF ( PRESENT( offs_proc) ) offs_proc = oproc_l9764 IF ( PRESENT( offs_glob) ) THEN9901 IF ( PRESENT(offs_proc) ) offs_proc = oproc_l 9902 IF ( PRESENT(offs_glob) ) THEN 9765 9903 offs_pstart = iproc_l * nnx * nny * nlayers 9766 9904 offs_glob = offs_pstart + oproc_l … … 9771 9909 9772 9910 9773 !--------------------------------------------------------------------------------------------------! 9911 !------------------------------------------------------------------------------! 9912 ! 9774 9913 ! Description: 9775 9914 ! ------------ 9776 9915 !> Subroutine for averaging 3D data 9777 !------------------------------------------------------------------------------ --------------------!9778 9916 !------------------------------------------------------------------------------! 9917 SUBROUTINE radiation_3d_data_averaging( mode, variable ) 9779 9918 9780 9919 … … 9787 9926 IMPLICIT NONE 9788 9927 9789 CHARACTER (LEN=*) :: mode!<9790 CHARACTER (LEN=*) :: variable!<9791 CHARACTER(LEN=varnamelength) :: var !< 9792 9793 INTEGER(iwp) :: i !<9794 INTEGER(iwp) :: imrt !< index of MRT 9795 INTEGER(iwp) :: i ds, idsint_u, idsint_l, isurf!<9796 INTEGER(iwp) :: j !<9797 INTEGER(iwp) :: k!<9798 INTEGER(iwp) :: l, m !< index of current surface element9799 9800 LOGICAL :: match_lsm !< flag indicating natural-type surface9801 LOGICAL :: match_usm !< flag indicating urban-type surface9802 9803 ! 9804 !-- Find the real name of the variable9928 CHARACTER (LEN=*) :: mode !< 9929 CHARACTER (LEN=*) :: variable !< 9930 9931 LOGICAL :: match_lsm !< flag indicating natural-type surface 9932 LOGICAL :: match_usm !< flag indicating urban-type surface 9933 9934 INTEGER(iwp) :: i !< 9935 INTEGER(iwp) :: imrt !< index of MRT 9936 INTEGER(iwp) :: j !< 9937 INTEGER(iwp) :: k !< 9938 INTEGER(iwp) :: l, m !< index of current surface element 9939 9940 INTEGER(iwp) :: ids, idsint_u, idsint_l, isurf 9941 CHARACTER(LEN=varnamelength) :: var 9942 9943 !-- find the real name of the variable 9805 9944 ids = -1 9806 9945 l = -1 9807 var = TRIM( variable)9808 DO i = 0, nd -19809 k = LEN( TRIM( var ))9810 j = LEN( TRIM( dirname(i) ))9811 IF ( k - j + 1 >= 1_iwp )THEN9812 IF ( TRIM( var(k-j+1:k) ) == TRIM( dirname(i)) ) THEN9813 ids = i9814 idsint_u = dirint_u(ids)9815 idsint_l = dirint_l(ids)9816 var = var(:k-j)9817 EXIT9818 ENDIF9819 ENDIF9946 var = TRIM(variable) 9947 DO i = 0, nd-1 9948 k = len(TRIM(var)) 9949 j = len(TRIM(dirname(i))) 9950 IF ( k-j+1 >= 1_iwp ) THEN 9951 IF ( TRIM(var(k-j+1:k)) == TRIM(dirname(i)) ) THEN 9952 ids = i 9953 idsint_u = dirint_u(ids) 9954 idsint_l = dirint_l(ids) 9955 var = var(:k-j) 9956 EXIT 9957 ENDIF 9958 ENDIF 9820 9959 ENDDO 9821 9960 IF ( ids == -1 ) THEN 9822 var = TRIM( variable)9961 var = TRIM(variable) 9823 9962 ENDIF 9824 9963 … … 9826 9965 9827 9966 SELECT CASE ( TRIM( var ) ) 9828 !-- Block of large scale (e.g. RRTMG) radiation output variables9967 !-- block of large scale (e.g. RRTMG) radiation output variables 9829 9968 CASE ( 'rad_net*' ) 9830 9969 IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN … … 9905 10044 rad_sw_hr_av = 0.0_wp 9906 10045 9907 !-- Block of RTM output variables10046 !-- block of RTM output variables 9908 10047 CASE ( 'rtm_rad_net' ) 9909 !-- Array of complete radiation balance9910 IF ( .NOT. ALLOCATED( surfradnet_av) ) THEN10048 !-- array of complete radiation balance 10049 IF ( .NOT. ALLOCATED(surfradnet_av) ) THEN 9911 10050 ALLOCATE( surfradnet_av(nsurfl) ) 9912 10051 ENDIF … … 9914 10053 9915 10054 CASE ( 'rtm_rad_insw' ) 9916 !-- Array of sw radiation falling to surface after i-th reflection9917 IF ( .NOT. ALLOCATED( surfinsw_av) ) THEN10055 !-- array of sw radiation falling to surface after i-th reflection 10056 IF ( .NOT. ALLOCATED(surfinsw_av) ) THEN 9918 10057 ALLOCATE( surfinsw_av(nsurfl) ) 9919 10058 ENDIF … … 9921 10060 9922 10061 CASE ( 'rtm_rad_inlw' ) 9923 !-- Array of lw radiation falling to surface after i-th reflection9924 IF ( .NOT. ALLOCATED( surfinlw_av) ) THEN10062 !-- array of lw radiation falling to surface after i-th reflection 10063 IF ( .NOT. ALLOCATED(surfinlw_av) ) THEN 9925 10064 ALLOCATE( surfinlw_av(nsurfl) ) 9926 10065 ENDIF … … 9928 10067 9929 10068 CASE ( 'rtm_rad_inswdir' ) 9930 !-- Array of direct sw radiation falling to surface from sun9931 IF ( .NOT. ALLOCATED( surfinswdir_av) ) THEN10069 !-- array of direct sw radiation falling to surface from sun 10070 IF ( .NOT. ALLOCATED(surfinswdir_av) ) THEN 9932 10071 ALLOCATE( surfinswdir_av(nsurfl) ) 9933 10072 ENDIF … … 9935 10074 9936 10075 CASE ( 'rtm_rad_inswdif' ) 9937 !-- Array of difusion sw radiation falling to surface from sky and borders of the domain9938 IF ( .NOT. ALLOCATED( surfinswdif_av) ) THEN10076 !-- array of difusion sw radiation falling to surface from sky and borders of the domain 10077 IF ( .NOT. ALLOCATED(surfinswdif_av) ) THEN 9939 10078 ALLOCATE( surfinswdif_av(nsurfl) ) 9940 10079 ENDIF … … 9942 10081 9943 10082 CASE ( 'rtm_rad_inswref' ) 9944 !-- Array of sw radiation falling to surface from reflections9945 IF ( .NOT. ALLOCATED( surfinswref_av) ) THEN10083 !-- array of sw radiation falling to surface from reflections 10084 IF ( .NOT. ALLOCATED(surfinswref_av) ) THEN 9946 10085 ALLOCATE( surfinswref_av(nsurfl) ) 9947 10086 ENDIF … … 9949 10088 9950 10089 CASE ( 'rtm_rad_inlwdif' ) 9951 !-- Array of sw radiation falling to surface after i-th reflection9952 IF ( .NOT. ALLOCATED( surfinlwdif_av) ) THEN10090 !-- array of sw radiation falling to surface after i-th reflection 10091 IF ( .NOT. ALLOCATED(surfinlwdif_av) ) THEN 9953 10092 ALLOCATE( surfinlwdif_av(nsurfl) ) 9954 10093 ENDIF … … 9956 10095 9957 10096 CASE ( 'rtm_rad_inlwref' ) 9958 !-- Array of lw radiation falling to surface from reflections9959 IF ( .NOT. ALLOCATED( surfinlwref_av) ) THEN10097 !-- array of lw radiation falling to surface from reflections 10098 IF ( .NOT. ALLOCATED(surfinlwref_av) ) THEN 9960 10099 ALLOCATE( surfinlwref_av(nsurfl) ) 9961 10100 ENDIF … … 9963 10102 9964 10103 CASE ( 'rtm_rad_outsw' ) 9965 !-- Array of sw radiation emitted from surface after i-th reflection9966 IF ( .NOT. ALLOCATED( surfoutsw_av) ) THEN10104 !-- array of sw radiation emitted from surface after i-th reflection 10105 IF ( .NOT. ALLOCATED(surfoutsw_av) ) THEN 9967 10106 ALLOCATE( surfoutsw_av(nsurfl) ) 9968 10107 ENDIF … … 9970 10109 9971 10110 CASE ( 'rtm_rad_outlw' ) 9972 !-- Array of lw radiation emitted from surface after i-th reflection9973 IF ( .NOT. ALLOCATED( surfoutlw_av) ) THEN10111 !-- array of lw radiation emitted from surface after i-th reflection 10112 IF ( .NOT. ALLOCATED(surfoutlw_av) ) THEN 9974 10113 ALLOCATE( surfoutlw_av(nsurfl) ) 9975 10114 surfoutlw_av = 0.0_wp 9976 10115 ENDIF 9977 10116 CASE ( 'rtm_rad_ressw' ) 9978 !-- Array of residua of sw radiation absorbed in surface after last reflection9979 IF ( .NOT. ALLOCATED( surfins_av) ) THEN10117 !-- array of residua of sw radiation absorbed in surface after last reflection 10118 IF ( .NOT. ALLOCATED(surfins_av) ) THEN 9980 10119 ALLOCATE( surfins_av(nsurfl) ) 9981 10120 ENDIF … … 9983 10122 9984 10123 CASE ( 'rtm_rad_reslw' ) 9985 !-- Array of residua of lw radiation absorbed in surface after last reflection9986 IF ( .NOT. ALLOCATED( surfinl_av) ) THEN10124 !-- array of residua of lw radiation absorbed in surface after last reflection 10125 IF ( .NOT. ALLOCATED(surfinl_av) ) THEN 9987 10126 ALLOCATE( surfinl_av(nsurfl) ) 9988 10127 ENDIF … … 9990 10129 9991 10130 CASE ( 'rtm_rad_pc_inlw' ) 9992 !-- Array of of lw radiation absorbed in plant canopy9993 IF ( .NOT. ALLOCATED( pcbinlw_av) ) THEN10131 !-- array of of lw radiation absorbed in plant canopy 10132 IF ( .NOT. ALLOCATED(pcbinlw_av) ) THEN 9994 10133 ALLOCATE( pcbinlw_av(1:npcbl) ) 9995 10134 pcbinlw_av = 0.0_wp … … 9997 10136 9998 10137 CASE ( 'rtm_rad_pc_insw' ) 9999 !-- Array of of sw radiation absorbed in plant canopy10000 IF ( .NOT. ALLOCATED( pcbinsw_av) ) THEN10138 !-- array of of sw radiation absorbed in plant canopy 10139 IF ( .NOT. ALLOCATED(pcbinsw_av) ) THEN 10001 10140 ALLOCATE( pcbinsw_av(1:npcbl) ) 10002 10141 ENDIF … … 10004 10143 10005 10144 CASE ( 'rtm_rad_pc_inswdir' ) 10006 !-- Array of of direct sw radiation absorbed in plant canopy10007 IF ( .NOT. ALLOCATED( pcbinswdir_av) ) THEN10145 !-- array of of direct sw radiation absorbed in plant canopy 10146 IF ( .NOT. ALLOCATED(pcbinswdir_av) ) THEN 10008 10147 ALLOCATE( pcbinswdir_av(1:npcbl) ) 10009 10148 ENDIF … … 10011 10150 10012 10151 CASE ( 'rtm_rad_pc_inswdif' ) 10013 !-- Array of of diffuse sw radiation absorbed in plant canopy10014 IF ( .NOT. ALLOCATED( pcbinswdif_av) ) THEN10152 !-- array of of diffuse sw radiation absorbed in plant canopy 10153 IF ( .NOT. ALLOCATED(pcbinswdif_av) ) THEN 10015 10154 ALLOCATE( pcbinswdif_av(1:npcbl) ) 10016 10155 ENDIF … … 10018 10157 10019 10158 CASE ( 'rtm_rad_pc_inswref' ) 10020 !-- Array of of reflected sw radiation absorbed in plant canopy10021 IF ( .NOT. ALLOCATED( pcbinswref_av) ) THEN10159 !-- array of of reflected sw radiation absorbed in plant canopy 10160 IF ( .NOT. ALLOCATED(pcbinswref_av) ) THEN 10022 10161 ALLOCATE( pcbinswref_av(1:npcbl) ) 10023 10162 ENDIF … … 10050 10189 10051 10190 SELECT CASE ( TRIM( var ) ) 10052 !-- Block of large scale (e.g. RRTMG) radiation output variables10191 !-- block of large scale (e.g. RRTMG) radiation output variables 10053 10192 CASE ( 'rad_net*' ) 10054 10193 IF ( ALLOCATED( rad_net_av ) ) THEN 10055 10194 DO i = nxl, nxr 10056 10195 DO j = nys, nyn 10057 match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i) 10058 match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i) 10196 match_lsm = surf_lsm_h%start_index(j,i) <= & 10197 surf_lsm_h%end_index(j,i) 10198 match_usm = surf_usm_h%start_index(j,i) <= & 10199 surf_usm_h%end_index(j,i) 10059 10200 10060 10201 IF ( match_lsm .AND. .NOT. match_usm ) THEN 10061 10202 m = surf_lsm_h%end_index(j,i) 10062 rad_net_av(j,i) = rad_net_av(j,i) + surf_lsm_h%rad_net(m) 10203 rad_net_av(j,i) = rad_net_av(j,i) + & 10204 surf_lsm_h%rad_net(m) 10063 10205 ELSEIF ( match_usm ) THEN 10064 10206 m = surf_usm_h%end_index(j,i) 10065 rad_net_av(j,i) = rad_net_av(j,i) + surf_usm_h%rad_net(m) 10207 rad_net_av(j,i) = rad_net_av(j,i) + & 10208 surf_usm_h%rad_net(m) 10066 10209 ENDIF 10067 10210 ENDDO … … 10073 10216 DO i = nxl, nxr 10074 10217 DO j = nys, nyn 10075 match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i) 10076 match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i) 10218 match_lsm = surf_lsm_h%start_index(j,i) <= & 10219 surf_lsm_h%end_index(j,i) 10220 match_usm = surf_usm_h%start_index(j,i) <= & 10221 surf_usm_h%end_index(j,i) 10077 10222 10078 10223 IF ( match_lsm .AND. .NOT. match_usm ) THEN 10079 10224 m = surf_lsm_h%end_index(j,i) 10080 rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) + surf_lsm_h%rad_lw_in(m) 10225 rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) + & 10226 surf_lsm_h%rad_lw_in(m) 10081 10227 ELSEIF ( match_usm ) THEN 10082 10228 m = surf_usm_h%end_index(j,i) 10083 rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) + surf_usm_h%rad_lw_in(m) 10229 rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) + & 10230 surf_usm_h%rad_lw_in(m) 10084 10231 ENDIF 10085 10232 ENDDO … … 10088 10235 10089 10236 CASE ( 'rad_lw_out*' ) 10090 IF ( ALLOCATED( rad_lw_out_xy_av ) ) 10237 IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN 10091 10238 DO i = nxl, nxr 10092 10239 DO j = nys, nyn 10093 match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i) 10094 match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i) 10240 match_lsm = surf_lsm_h%start_index(j,i) <= & 10241 surf_lsm_h%end_index(j,i) 10242 match_usm = surf_usm_h%start_index(j,i) <= & 10243 surf_usm_h%end_index(j,i) 10095 10244 10096 10245 IF ( match_lsm .AND. .NOT. match_usm ) THEN 10097 10246 m = surf_lsm_h%end_index(j,i) 10098 rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) + surf_lsm_h%rad_lw_out(m) 10247 rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) + & 10248 surf_lsm_h%rad_lw_out(m) 10099 10249 ELSEIF ( match_usm ) THEN 10100 10250 m = surf_usm_h%end_index(j,i) 10101 rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) + surf_usm_h%rad_lw_out(m) 10251 rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) + & 10252 surf_usm_h%rad_lw_out(m) 10102 10253 ENDIF 10103 10254 ENDDO … … 10106 10257 10107 10258 CASE ( 'rad_sw_in*' ) 10108 IF ( ALLOCATED( rad_sw_in_xy_av ) ) 10259 IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN 10109 10260 DO i = nxl, nxr 10110 10261 DO j = nys, nyn 10111 match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i) 10112 match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i) 10262 match_lsm = surf_lsm_h%start_index(j,i) <= & 10263 surf_lsm_h%end_index(j,i) 10264 match_usm = surf_usm_h%start_index(j,i) <= & 10265 surf_usm_h%end_index(j,i) 10113 10266 10114 10267 IF ( match_lsm .AND. .NOT. match_usm ) THEN 10115 10268 m = surf_lsm_h%end_index(j,i) 10116 rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) + surf_lsm_h%rad_sw_in(m) 10269 rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) + & 10270 surf_lsm_h%rad_sw_in(m) 10117 10271 ELSEIF ( match_usm ) THEN 10118 10272 m = surf_usm_h%end_index(j,i) 10119 rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) + surf_usm_h%rad_sw_in(m) 10273 rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) + & 10274 surf_usm_h%rad_sw_in(m) 10120 10275 ENDIF 10121 10276 ENDDO … … 10124 10279 10125 10280 CASE ( 'rad_sw_out*' ) 10126 IF ( ALLOCATED( rad_sw_out_xy_av ) ) 10281 IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN 10127 10282 DO i = nxl, nxr 10128 10283 DO j = nys, nyn 10129 match_lsm = surf_lsm_h%start_index(j,i) <= surf_lsm_h%end_index(j,i) 10130 match_usm = surf_usm_h%start_index(j,i) <= surf_usm_h%end_index(j,i) 10284 match_lsm = surf_lsm_h%start_index(j,i) <= & 10285 surf_lsm_h%end_index(j,i) 10286 match_usm = surf_usm_h%start_index(j,i) <= & 10287 surf_usm_h%end_index(j,i) 10131 10288 10132 10289 IF ( match_lsm .AND. .NOT. match_usm ) THEN 10133 10290 m = surf_lsm_h%end_index(j,i) 10134 rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) + surf_lsm_h%rad_sw_out(m) 10291 rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) + & 10292 surf_lsm_h%rad_sw_out(m) 10135 10293 ELSEIF ( match_usm ) THEN 10136 10294 m = surf_usm_h%end_index(j,i) 10137 rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) + surf_usm_h%rad_sw_out(m) 10295 rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) + & 10296 surf_usm_h%rad_sw_out(m) 10138 10297 ENDIF 10139 10298 ENDDO … … 10146 10305 DO j = nysg, nyng 10147 10306 DO k = nzb, nzt+1 10148 rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) + rad_lw_in(k,j,i) 10307 rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) & 10308 + rad_lw_in(k,j,i) 10149 10309 ENDDO 10150 10310 ENDDO … … 10153 10313 10154 10314 CASE ( 'rad_lw_out' ) 10155 IF ( ALLOCATED( rad_lw_out_av ) ) 10315 IF ( ALLOCATED( rad_lw_out_av ) ) THEN 10156 10316 DO i = nxlg, nxrg 10157 10317 DO j = nysg, nyng 10158 10318 DO k = nzb, nzt+1 10159 rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) + rad_lw_out(k,j,i) 10319 rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) & 10320 + rad_lw_out(k,j,i) 10160 10321 ENDDO 10161 10322 ENDDO … … 10164 10325 10165 10326 CASE ( 'rad_lw_cs_hr' ) 10166 IF ( ALLOCATED( rad_lw_cs_hr_av ) ) 10327 IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN 10167 10328 DO i = nxlg, nxrg 10168 10329 DO j = nysg, nyng 10169 10330 DO k = nzb, nzt+1 10170 rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) + rad_lw_cs_hr(k,j,i) 10331 rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) & 10332 + rad_lw_cs_hr(k,j,i) 10171 10333 ENDDO 10172 10334 ENDDO … … 10179 10341 DO j = nysg, nyng 10180 10342 DO k = nzb, nzt+1 10181 rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) + rad_lw_hr(k,j,i) 10343 rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) & 10344 + rad_lw_hr(k,j,i) 10182 10345 ENDDO 10183 10346 ENDDO … … 10190 10353 DO j = nysg, nyng 10191 10354 DO k = nzb, nzt+1 10192 rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) + rad_sw_in(k,j,i) 10355 rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) & 10356 + rad_sw_in(k,j,i) 10193 10357 ENDDO 10194 10358 ENDDO … … 10201 10365 DO j = nysg, nyng 10202 10366 DO k = nzb, nzt+1 10203 rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) + rad_sw_out(k,j,i) 10367 rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) & 10368 + rad_sw_out(k,j,i) 10204 10369 ENDDO 10205 10370 ENDDO … … 10212 10377 DO j = nysg, nyng 10213 10378 DO k = nzb, nzt+1 10214 rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) + rad_sw_cs_hr(k,j,i) 10379 rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) & 10380 + rad_sw_cs_hr(k,j,i) 10215 10381 ENDDO 10216 10382 ENDDO … … 10223 10389 DO j = nysg, nyng 10224 10390 DO k = nzb, nzt+1 10225 rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) + rad_sw_hr(k,j,i) 10391 rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) & 10392 + rad_sw_hr(k,j,i) 10226 10393 ENDDO 10227 10394 ENDDO 10228 10395 ENDDO 10229 10396 ENDIF 10230 ! 10231 !-- Block of RTM output variables10397 10398 !-- block of RTM output variables 10232 10399 CASE ( 'rtm_rad_net' ) 10233 !-- Array of complete radiation balance10234 DO 10400 !-- array of complete radiation balance 10401 DO isurf = dirstart(ids), dirend(ids) 10235 10402 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10236 surfradnet_av(isurf) = surfradnet_av(isurf) + surfinsw(isurf) & 10237 - surfoutsw(isurf) + surfinlw(isurf) - surfoutlw(isurf) 10403 surfradnet_av(isurf) = surfradnet_av(isurf) + & 10404 surfinsw(isurf) - surfoutsw(isurf) + & 10405 surfinlw(isurf) - surfoutlw(isurf) 10238 10406 ENDIF 10239 10407 ENDDO 10240 10408 10241 10409 CASE ( 'rtm_rad_insw' ) 10242 !-- Array of sw radiation falling to surface after i-th reflection10243 DO 10244 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10245 surfinsw_av(isurf) = surfinsw_av(isurf) + surfinsw(isurf)10246 ENDIF10410 !-- array of sw radiation falling to surface after i-th reflection 10411 DO isurf = dirstart(ids), dirend(ids) 10412 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10413 surfinsw_av(isurf) = surfinsw_av(isurf) + surfinsw(isurf) 10414 ENDIF 10247 10415 ENDDO 10248 10416 10249 10417 CASE ( 'rtm_rad_inlw' ) 10250 !-- Array of lw radiation falling to surface after i-th reflection10251 DO 10252 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10253 surfinlw_av(isurf) = surfinlw_av(isurf) + surfinlw(isurf)10254 ENDIF10418 !-- array of lw radiation falling to surface after i-th reflection 10419 DO isurf = dirstart(ids), dirend(ids) 10420 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10421 surfinlw_av(isurf) = surfinlw_av(isurf) + surfinlw(isurf) 10422 ENDIF 10255 10423 ENDDO 10256 10424 10257 10425 CASE ( 'rtm_rad_inswdir' ) 10258 !-- Array of direct sw radiation falling to surface from sun10259 DO 10260 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10261 surfinswdir_av(isurf) = surfinswdir_av(isurf) + surfinswdir(isurf)10262 ENDIF10426 !-- array of direct sw radiation falling to surface from sun 10427 DO isurf = dirstart(ids), dirend(ids) 10428 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10429 surfinswdir_av(isurf) = surfinswdir_av(isurf) + surfinswdir(isurf) 10430 ENDIF 10263 10431 ENDDO 10264 10432 10265 10433 CASE ( 'rtm_rad_inswdif' ) 10266 !-- Array of diffusesw radiation falling to surface from sky and borders of the domain10267 DO 10268 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10269 surfinswdif_av(isurf) = surfinswdif_av(isurf) + surfinswdif(isurf)10270 ENDIF10434 !-- array of difusion sw radiation falling to surface from sky and borders of the domain 10435 DO isurf = dirstart(ids), dirend(ids) 10436 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10437 surfinswdif_av(isurf) = surfinswdif_av(isurf) + surfinswdif(isurf) 10438 ENDIF 10271 10439 ENDDO 10272 10440 10273 10441 CASE ( 'rtm_rad_inswref' ) 10274 !-- Array of sw radiation falling to surface from reflections10275 DO 10276 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10277 surfinswref_av(isurf) = surfinswref_av(isurf) + surfinsw(isurf)&10278 -surfinswdir(isurf) - surfinswdif(isurf)10279 ENDIF10442 !-- array of sw radiation falling to surface from reflections 10443 DO isurf = dirstart(ids), dirend(ids) 10444 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10445 surfinswref_av(isurf) = surfinswref_av(isurf) + surfinsw(isurf) - & 10446 surfinswdir(isurf) - surfinswdif(isurf) 10447 ENDIF 10280 10448 ENDDO 10281 10449 10282 10450 10283 10451 CASE ( 'rtm_rad_inlwdif' ) 10284 !-- Array of sw radiation falling to surface after i-th reflection10285 DO 10286 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10287 surfinlwdif_av(isurf) = surfinlwdif_av(isurf) + surfinlwdif(isurf)10288 ENDIF10452 !-- array of sw radiation falling to surface after i-th reflection 10453 DO isurf = dirstart(ids), dirend(ids) 10454 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10455 surfinlwdif_av(isurf) = surfinlwdif_av(isurf) + surfinlwdif(isurf) 10456 ENDIF 10289 10457 ENDDO 10290 10458 ! 10291 10459 CASE ( 'rtm_rad_inlwref' ) 10292 !-- Array of lw radiation falling to surface from reflections10293 DO 10294 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10295 surfinlwref_av(isurf) = surfinlwref_av(isurf) + surfinlw(isurf)&10296 - surfinlwdif(isurf)10297 ENDIF10460 !-- array of lw radiation falling to surface from reflections 10461 DO isurf = dirstart(ids), dirend(ids) 10462 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10463 surfinlwref_av(isurf) = surfinlwref_av(isurf) + & 10464 surfinlw(isurf) - surfinlwdif(isurf) 10465 ENDIF 10298 10466 ENDDO 10299 10467 10300 10468 CASE ( 'rtm_rad_outsw' ) 10301 !-- Array of sw radiation emitted from surface after i-th reflection10302 DO 10303 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10304 surfoutsw_av(isurf) = surfoutsw_av(isurf) + surfoutsw(isurf)10305 ENDIF10469 !-- array of sw radiation emitted from surface after i-th reflection 10470 DO isurf = dirstart(ids), dirend(ids) 10471 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10472 surfoutsw_av(isurf) = surfoutsw_av(isurf) + surfoutsw(isurf) 10473 ENDIF 10306 10474 ENDDO 10307 10475 10308 10476 CASE ( 'rtm_rad_outlw' ) 10309 !-- Array of lw radiation emitted from surface after i-th reflection10310 DO 10311 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10312 surfoutlw_av(isurf) = surfoutlw_av(isurf) + surfoutlw(isurf)10313 ENDIF10477 !-- array of lw radiation emitted from surface after i-th reflection 10478 DO isurf = dirstart(ids), dirend(ids) 10479 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10480 surfoutlw_av(isurf) = surfoutlw_av(isurf) + surfoutlw(isurf) 10481 ENDIF 10314 10482 ENDDO 10315 10483 10316 10484 CASE ( 'rtm_rad_ressw' ) 10317 !-- Array of residua of sw radiation absorbed in surface after last reflection10318 DO 10319 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10320 surfins_av(isurf) = surfins_av(isurf) + surfins(isurf)10321 ENDIF10485 !-- array of residua of sw radiation absorbed in surface after last reflection 10486 DO isurf = dirstart(ids), dirend(ids) 10487 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10488 surfins_av(isurf) = surfins_av(isurf) + surfins(isurf) 10489 ENDIF 10322 10490 ENDDO 10323 10491 10324 10492 CASE ( 'rtm_rad_reslw' ) 10325 !-- Array of residua of lw radiation absorbed in surface after last reflection10326 DO 10327 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10328 surfinl_av(isurf) = surfinl_av(isurf) + surfinl(isurf)10329 ENDIF10493 !-- array of residua of lw radiation absorbed in surface after last reflection 10494 DO isurf = dirstart(ids), dirend(ids) 10495 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10496 surfinl_av(isurf) = surfinl_av(isurf) + surfinl(isurf) 10497 ENDIF 10330 10498 ENDDO 10331 10499 10332 10500 CASE ( 'rtm_rad_pc_inlw' ) 10333 DO 10501 DO l = 1, npcbl 10334 10502 pcbinlw_av(l) = pcbinlw_av(l) + pcbinlw(l) 10335 10503 ENDDO 10336 10504 10337 10505 CASE ( 'rtm_rad_pc_insw' ) 10338 DO 10506 DO l = 1, npcbl 10339 10507 pcbinsw_av(l) = pcbinsw_av(l) + pcbinsw(l) 10340 10508 ENDDO 10341 10509 10342 10510 CASE ( 'rtm_rad_pc_inswdir' ) 10343 DO 10511 DO l = 1, npcbl 10344 10512 pcbinswdir_av(l) = pcbinswdir_av(l) + pcbinswdir(l) 10345 10513 ENDDO 10346 10514 10347 10515 CASE ( 'rtm_rad_pc_inswdif' ) 10348 DO 10516 DO l = 1, npcbl 10349 10517 pcbinswdif_av(l) = pcbinswdif_av(l) + pcbinswdif(l) 10350 10518 ENDDO 10351 10519 10352 10520 CASE ( 'rtm_rad_pc_inswref' ) 10353 DO 10521 DO l = 1, npcbl 10354 10522 pcbinswref_av(l) = pcbinswref_av(l) + pcbinsw(l) - pcbinswdir(l) - pcbinswdif(l) 10355 10523 ENDDO … … 10378 10546 10379 10547 SELECT CASE ( TRIM( var ) ) 10380 !-- Block of large scale (e.g. RRTMG) radiation output variables10548 !-- block of large scale (e.g. RRTMG) radiation output variables 10381 10549 CASE ( 'rad_net*' ) 10382 IF ( ALLOCATED( rad_net_av ) ) 10550 IF ( ALLOCATED( rad_net_av ) ) THEN 10383 10551 DO i = nxlg, nxrg 10384 10552 DO j = nysg, nyng 10385 rad_net_av(j,i) = rad_net_av(j,i) / REAL( average_count_3d, KIND = wp ) 10553 rad_net_av(j,i) = rad_net_av(j,i) & 10554 / REAL( average_count_3d, KIND=wp ) 10386 10555 ENDDO 10387 10556 ENDDO … … 10389 10558 10390 10559 CASE ( 'rad_lw_in*' ) 10391 IF ( ALLOCATED( rad_lw_in_xy_av ) ) 10560 IF ( ALLOCATED( rad_lw_in_xy_av ) ) THEN 10392 10561 DO i = nxlg, nxrg 10393 10562 DO j = nysg, nyng 10394 rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) 10395 / REAL( average_count_3d, KIND =wp )10563 rad_lw_in_xy_av(j,i) = rad_lw_in_xy_av(j,i) & 10564 / REAL( average_count_3d, KIND=wp ) 10396 10565 ENDDO 10397 10566 ENDDO … … 10399 10568 10400 10569 CASE ( 'rad_lw_out*' ) 10401 IF ( ALLOCATED( rad_lw_out_xy_av ) ) 10570 IF ( ALLOCATED( rad_lw_out_xy_av ) ) THEN 10402 10571 DO i = nxlg, nxrg 10403 10572 DO j = nysg, nyng 10404 rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) 10405 / REAL( average_count_3d, KIND =wp )10573 rad_lw_out_xy_av(j,i) = rad_lw_out_xy_av(j,i) & 10574 / REAL( average_count_3d, KIND=wp ) 10406 10575 ENDDO 10407 10576 ENDDO … … 10409 10578 10410 10579 CASE ( 'rad_sw_in*' ) 10411 IF ( ALLOCATED( rad_sw_in_xy_av ) ) 10580 IF ( ALLOCATED( rad_sw_in_xy_av ) ) THEN 10412 10581 DO i = nxlg, nxrg 10413 10582 DO j = nysg, nyng 10414 rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) 10415 / REAL( average_count_3d, KIND =wp )10583 rad_sw_in_xy_av(j,i) = rad_sw_in_xy_av(j,i) & 10584 / REAL( average_count_3d, KIND=wp ) 10416 10585 ENDDO 10417 10586 ENDDO … … 10419 10588 10420 10589 CASE ( 'rad_sw_out*' ) 10421 IF ( ALLOCATED( rad_sw_out_xy_av ) ) 10590 IF ( ALLOCATED( rad_sw_out_xy_av ) ) THEN 10422 10591 DO i = nxlg, nxrg 10423 10592 DO j = nysg, nyng 10424 rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) 10425 / REAL( average_count_3d, KIND =wp )10593 rad_sw_out_xy_av(j,i) = rad_sw_out_xy_av(j,i) & 10594 / REAL( average_count_3d, KIND=wp ) 10426 10595 ENDDO 10427 10596 ENDDO … … 10429 10598 10430 10599 CASE ( 'rad_lw_in' ) 10431 IF ( ALLOCATED( rad_lw_in_av ) ) 10600 IF ( ALLOCATED( rad_lw_in_av ) ) THEN 10432 10601 DO i = nxlg, nxrg 10433 10602 DO j = nysg, nyng 10434 10603 DO k = nzb, nzt+1 10435 rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) 10436 / REAL( average_count_3d, KIND =wp )10604 rad_lw_in_av(k,j,i) = rad_lw_in_av(k,j,i) & 10605 / REAL( average_count_3d, KIND=wp ) 10437 10606 ENDDO 10438 10607 ENDDO … … 10441 10610 10442 10611 CASE ( 'rad_lw_out' ) 10443 IF ( ALLOCATED( rad_lw_out_av ) ) 10612 IF ( ALLOCATED( rad_lw_out_av ) ) THEN 10444 10613 DO i = nxlg, nxrg 10445 10614 DO j = nysg, nyng 10446 10615 DO k = nzb, nzt+1 10447 rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) 10448 / REAL( average_count_3d, KIND =wp )10616 rad_lw_out_av(k,j,i) = rad_lw_out_av(k,j,i) & 10617 / REAL( average_count_3d, KIND=wp ) 10449 10618 ENDDO 10450 10619 ENDDO … … 10453 10622 10454 10623 CASE ( 'rad_lw_cs_hr' ) 10455 IF ( ALLOCATED( rad_lw_cs_hr_av ) ) 10624 IF ( ALLOCATED( rad_lw_cs_hr_av ) ) THEN 10456 10625 DO i = nxlg, nxrg 10457 10626 DO j = nysg, nyng 10458 10627 DO k = nzb, nzt+1 10459 rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) 10460 / REAL( average_count_3d, KIND =wp )10628 rad_lw_cs_hr_av(k,j,i) = rad_lw_cs_hr_av(k,j,i) & 10629 / REAL( average_count_3d, KIND=wp ) 10461 10630 ENDDO 10462 10631 ENDDO … … 10465 10634 10466 10635 CASE ( 'rad_lw_hr' ) 10467 IF ( ALLOCATED( rad_lw_hr_av ) ) 10636 IF ( ALLOCATED( rad_lw_hr_av ) ) THEN 10468 10637 DO i = nxlg, nxrg 10469 10638 DO j = nysg, nyng 10470 10639 DO k = nzb, nzt+1 10471 rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) 10472 / REAL( average_count_3d, KIND =wp )10640 rad_lw_hr_av(k,j,i) = rad_lw_hr_av(k,j,i) & 10641 / REAL( average_count_3d, KIND=wp ) 10473 10642 ENDDO 10474 10643 ENDDO … … 10477 10646 10478 10647 CASE ( 'rad_sw_in' ) 10479 IF ( ALLOCATED( rad_sw_in_av ) ) 10648 IF ( ALLOCATED( rad_sw_in_av ) ) THEN 10480 10649 DO i = nxlg, nxrg 10481 10650 DO j = nysg, nyng 10482 10651 DO k = nzb, nzt+1 10483 rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) 10484 / REAL( average_count_3d, KIND =wp )10652 rad_sw_in_av(k,j,i) = rad_sw_in_av(k,j,i) & 10653 / REAL( average_count_3d, KIND=wp ) 10485 10654 ENDDO 10486 10655 ENDDO … … 10489 10658 10490 10659 CASE ( 'rad_sw_out' ) 10491 IF ( ALLOCATED( rad_sw_out_av ) ) 10660 IF ( ALLOCATED( rad_sw_out_av ) ) THEN 10492 10661 DO i = nxlg, nxrg 10493 10662 DO j = nysg, nyng 10494 10663 DO k = nzb, nzt+1 10495 rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) 10496 / REAL( average_count_3d, KIND =wp )10664 rad_sw_out_av(k,j,i) = rad_sw_out_av(k,j,i) & 10665 / REAL( average_count_3d, KIND=wp ) 10497 10666 ENDDO 10498 10667 ENDDO … … 10501 10670 10502 10671 CASE ( 'rad_sw_cs_hr' ) 10503 IF ( ALLOCATED( rad_sw_cs_hr_av ) ) 10672 IF ( ALLOCATED( rad_sw_cs_hr_av ) ) THEN 10504 10673 DO i = nxlg, nxrg 10505 10674 DO j = nysg, nyng 10506 10675 DO k = nzb, nzt+1 10507 rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) 10508 / REAL( average_count_3d, KIND =wp )10676 rad_sw_cs_hr_av(k,j,i) = rad_sw_cs_hr_av(k,j,i) & 10677 / REAL( average_count_3d, KIND=wp ) 10509 10678 ENDDO 10510 10679 ENDDO … … 10513 10682 10514 10683 CASE ( 'rad_sw_hr' ) 10515 IF ( ALLOCATED( rad_sw_hr_av ) ) 10684 IF ( ALLOCATED( rad_sw_hr_av ) ) THEN 10516 10685 DO i = nxlg, nxrg 10517 10686 DO j = nysg, nyng 10518 10687 DO k = nzb, nzt+1 10519 rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) 10520 / REAL( average_count_3d, KIND =wp )10688 rad_sw_hr_av(k,j,i) = rad_sw_hr_av(k,j,i) & 10689 / REAL( average_count_3d, KIND=wp ) 10521 10690 ENDDO 10522 10691 ENDDO 10523 10692 ENDDO 10524 10693 ENDIF 10525 ! 10526 !-- Block of RTM output variables10694 10695 !-- block of RTM output variables 10527 10696 CASE ( 'rtm_rad_net' ) 10528 !-- Array of complete radiation balance 10529 DO isurf = dirstart(ids), dirend(ids) 10530 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10531 surfradnet_av(isurf) = surfradnet_av(isurf) & 10532 / REAL( average_count_3d, KIND = wp ) 10697 !-- array of complete radiation balance 10698 DO isurf = dirstart(ids), dirend(ids) 10699 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10700 surfradnet_av(isurf) = surfradnet_av(isurf) / REAL( average_count_3d, kind=wp ) 10533 10701 ENDIF 10534 10702 ENDDO 10535 10703 10536 10704 CASE ( 'rtm_rad_insw' ) 10537 !-- Array of sw radiation falling to surface after i-th reflection10538 DO 10539 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10540 surfinsw_av(isurf) = surfinsw_av(isurf) / REAL( average_count_3d, KIND =wp )10541 ENDIF10705 !-- array of sw radiation falling to surface after i-th reflection 10706 DO isurf = dirstart(ids), dirend(ids) 10707 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10708 surfinsw_av(isurf) = surfinsw_av(isurf) / REAL( average_count_3d, kind=wp ) 10709 ENDIF 10542 10710 ENDDO 10543 10711 10544 10712 CASE ( 'rtm_rad_inlw' ) 10545 !-- Array of lw radiation falling to surface after i-th reflection10546 DO 10547 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10548 surfinlw_av(isurf) = surfinlw_av(isurf) / REAL( average_count_3d, KIND =wp )10549 ENDIF10713 !-- array of lw radiation falling to surface after i-th reflection 10714 DO isurf = dirstart(ids), dirend(ids) 10715 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10716 surfinlw_av(isurf) = surfinlw_av(isurf) / REAL( average_count_3d, kind=wp ) 10717 ENDIF 10550 10718 ENDDO 10551 10719 10552 10720 CASE ( 'rtm_rad_inswdir' ) 10553 !-- Array of direct sw radiation falling to surface from sun 10554 DO isurf = dirstart(ids), dirend(ids) 10555 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10556 surfinswdir_av(isurf) = surfinswdir_av(isurf) & 10557 / REAL( average_count_3d, KIND = wp ) 10558 ENDIF 10721 !-- array of direct sw radiation falling to surface from sun 10722 DO isurf = dirstart(ids), dirend(ids) 10723 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10724 surfinswdir_av(isurf) = surfinswdir_av(isurf) / REAL( average_count_3d, kind=wp ) 10725 ENDIF 10559 10726 ENDDO 10560 10727 10561 10728 CASE ( 'rtm_rad_inswdif' ) 10562 !-- Array of diffuse sw radiation falling to surface from sky and borders of the domain 10563 DO isurf = dirstart(ids), dirend(ids) 10564 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10565 surfinswdif_av(isurf) = surfinswdif_av(isurf) & 10566 / REAL( average_count_3d, KIND = wp ) 10567 ENDIF 10729 !-- array of difusion sw radiation falling to surface from sky and borders of the domain 10730 DO isurf = dirstart(ids), dirend(ids) 10731 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10732 surfinswdif_av(isurf) = surfinswdif_av(isurf) / REAL( average_count_3d, kind=wp ) 10733 ENDIF 10568 10734 ENDDO 10569 10735 10570 10736 CASE ( 'rtm_rad_inswref' ) 10571 !-- Array of sw radiation falling to surface from reflections 10572 DO isurf = dirstart(ids), dirend(ids) 10573 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10574 surfinswref_av(isurf) = surfinswref_av(isurf) & 10575 / REAL( average_count_3d, KIND = wp ) 10576 ENDIF 10737 !-- array of sw radiation falling to surface from reflections 10738 DO isurf = dirstart(ids), dirend(ids) 10739 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10740 surfinswref_av(isurf) = surfinswref_av(isurf) / REAL( average_count_3d, kind=wp ) 10741 ENDIF 10577 10742 ENDDO 10578 10743 10579 10744 CASE ( 'rtm_rad_inlwdif' ) 10580 !-- Array of sw radiation falling to surface after i-th reflection 10581 DO isurf = dirstart(ids), dirend(ids) 10582 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10583 surfinlwdif_av(isurf) = surfinlwdif_av(isurf) & 10584 / REAL( average_count_3d, KIND = wp ) 10585 ENDIF 10745 !-- array of sw radiation falling to surface after i-th reflection 10746 DO isurf = dirstart(ids), dirend(ids) 10747 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10748 surfinlwdif_av(isurf) = surfinlwdif_av(isurf) / REAL( average_count_3d, kind=wp ) 10749 ENDIF 10586 10750 ENDDO 10587 10751 10588 10752 CASE ( 'rtm_rad_inlwref' ) 10589 !-- Array of lw radiation falling to surface from reflections 10590 DO isurf = dirstart(ids), dirend(ids) 10591 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10592 surfinlwref_av(isurf) = surfinlwref_av(isurf) & 10593 / REAL( average_count_3d, KIND = wp ) 10594 ENDIF 10753 !-- array of lw radiation falling to surface from reflections 10754 DO isurf = dirstart(ids), dirend(ids) 10755 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10756 surfinlwref_av(isurf) = surfinlwref_av(isurf) / REAL( average_count_3d, kind=wp ) 10757 ENDIF 10595 10758 ENDDO 10596 10759 10597 10760 CASE ( 'rtm_rad_outsw' ) 10598 !-- Array of sw radiation emitted from surface after i-th reflection10599 DO 10600 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10601 surfoutsw_av(isurf) = surfoutsw_av(isurf) / REAL( average_count_3d, KIND =wp )10602 ENDIF10761 !-- array of sw radiation emitted from surface after i-th reflection 10762 DO isurf = dirstart(ids), dirend(ids) 10763 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10764 surfoutsw_av(isurf) = surfoutsw_av(isurf) / REAL( average_count_3d, kind=wp ) 10765 ENDIF 10603 10766 ENDDO 10604 10767 10605 10768 CASE ( 'rtm_rad_outlw' ) 10606 !-- Array of lw radiation emitted from surface after i-th reflection10607 DO 10608 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10609 surfoutlw_av(isurf) = surfoutlw_av(isurf) / REAL( average_count_3d, KIND =wp )10610 ENDIF10769 !-- array of lw radiation emitted from surface after i-th reflection 10770 DO isurf = dirstart(ids), dirend(ids) 10771 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10772 surfoutlw_av(isurf) = surfoutlw_av(isurf) / REAL( average_count_3d, kind=wp ) 10773 ENDIF 10611 10774 ENDDO 10612 10775 10613 10776 CASE ( 'rtm_rad_ressw' ) 10614 !-- Array of residua of sw radiation absorbed in surface after last reflection10615 DO 10616 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10617 surfins_av(isurf) = surfins_av(isurf) / REAL( average_count_3d, KIND =wp )10618 ENDIF10777 !-- array of residua of sw radiation absorbed in surface after last reflection 10778 DO isurf = dirstart(ids), dirend(ids) 10779 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10780 surfins_av(isurf) = surfins_av(isurf) / REAL( average_count_3d, kind=wp ) 10781 ENDIF 10619 10782 ENDDO 10620 10783 10621 10784 CASE ( 'rtm_rad_reslw' ) 10622 !-- Array of residua of lw radiation absorbed in surface after last reflection10623 DO 10624 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN10625 surfinl_av(isurf) = surfinl_av(isurf) / REAL( average_count_3d, KIND =wp )10626 ENDIF10785 !-- array of residua of lw radiation absorbed in surface after last reflection 10786 DO isurf = dirstart(ids), dirend(ids) 10787 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 10788 surfinl_av(isurf) = surfinl_av(isurf) / REAL( average_count_3d, kind=wp ) 10789 ENDIF 10627 10790 ENDDO 10628 10791 10629 10792 CASE ( 'rtm_rad_pc_inlw' ) 10630 DO 10631 pcbinlw_av(l) = pcbinlw_av(l) / REAL( average_count_3d, KIND =wp )10793 DO l = 1, npcbl 10794 pcbinlw_av(l) = pcbinlw_av(l) / REAL( average_count_3d, kind=wp ) 10632 10795 ENDDO 10633 10796 10634 10797 CASE ( 'rtm_rad_pc_insw' ) 10635 DO 10636 pcbinsw_av(l) = pcbinsw_av(l) / REAL( average_count_3d, KIND =wp )10798 DO l = 1, npcbl 10799 pcbinsw_av(l) = pcbinsw_av(l) / REAL( average_count_3d, kind=wp ) 10637 10800 ENDDO 10638 10801 10639 10802 CASE ( 'rtm_rad_pc_inswdir' ) 10640 DO 10641 pcbinswdir_av(l) = pcbinswdir_av(l) / REAL( average_count_3d, KIND =wp )10803 DO l = 1, npcbl 10804 pcbinswdir_av(l) = pcbinswdir_av(l) / REAL( average_count_3d, kind=wp ) 10642 10805 ENDDO 10643 10806 10644 10807 CASE ( 'rtm_rad_pc_inswdif' ) 10645 DO 10646 pcbinswdif_av(l) = pcbinswdif_av(l) / REAL( average_count_3d, KIND =wp )10808 DO l = 1, npcbl 10809 pcbinswdif_av(l) = pcbinswdif_av(l) / REAL( average_count_3d, kind=wp ) 10647 10810 ENDDO 10648 10811 10649 10812 CASE ( 'rtm_rad_pc_inswref' ) 10650 DO 10651 pcbinswref_av(l) = pcbinswref_av(l) / REAL( average_count_3d, KIND =wp )10813 DO l = 1, npcbl 10814 pcbinswref_av(l) = pcbinswref_av(l) / REAL( average_count_3d, kind=wp ) 10652 10815 ENDDO 10653 10816 10654 10817 CASE ( 'rtm_mrt_sw' ) 10655 10818 IF ( ALLOCATED( mrtinsw_av ) ) THEN 10656 DO 10657 mrtinsw_av(imrt) = mrtinsw_av(imrt) / REAL( average_count_3d, KIND =wp )10819 DO imrt = 1, nmrtbl 10820 mrtinsw_av(imrt) = mrtinsw_av(imrt) / REAL( average_count_3d, KIND=wp ) 10658 10821 ENDDO 10659 10822 ENDIF … … 10661 10824 CASE ( 'rtm_mrt_lw' ) 10662 10825 IF ( ALLOCATED( mrtinlw_av ) ) THEN 10663 DO 10664 mrtinlw_av(imrt) = mrtinlw_av(imrt) / REAL( average_count_3d, KIND =wp )10826 DO imrt = 1, nmrtbl 10827 mrtinlw_av(imrt) = mrtinlw_av(imrt) / REAL( average_count_3d, KIND=wp ) 10665 10828 ENDDO 10666 10829 ENDIF … … 10668 10831 CASE ( 'rtm_mrt' ) 10669 10832 IF ( ALLOCATED( mrt_av ) ) THEN 10670 DO 10671 mrt_av(imrt) = mrt_av(imrt) / REAL( average_count_3d, KIND =wp )10833 DO imrt = 1, nmrtbl 10834 mrt_av(imrt) = mrt_av(imrt) / REAL( average_count_3d, KIND=wp ) 10672 10835 ENDDO 10673 10836 ENDIF … … 10677 10840 ENDIF 10678 10841 10679 END SUBROUTINE radiation_3d_data_averaging 10680 10681 10682 !--------------------------------------------------------------------------------------------------! 10842 END SUBROUTINE radiation_3d_data_averaging 10843 10844 10845 !------------------------------------------------------------------------------! 10846 ! 10683 10847 ! Description: 10684 10848 ! ------------ 10685 !> Subroutine defining appropriate grid for netcdf variables. It is called out from subroutine10686 !> netcdf.10687 !------------------------------------------------------------------------------ --------------------!10688 10849 !> Subroutine defining appropriate grid for netcdf variables. 10850 !> It is called out from subroutine netcdf. 10851 !------------------------------------------------------------------------------! 10852 SUBROUTINE radiation_define_netcdf_grid( variable, found, grid_x, grid_y, grid_z ) 10689 10853 10690 10854 IMPLICIT NONE 10691 10855 10692 CHARACTER (LEN=*), INTENT(IN) :: variable!<10693 CHARACTER(LEN=*), INTENT(OUT) :: grid_x!<10694 CHARACTER (LEN=*), INTENT(OUT) :: grid_y!<10695 CHARACTER (LEN=*), INTENT(OUT) :: grid_z!<10696 CHARACTER (LEN=varnamelength) :: var!<10697 10698 LOGICAL, INTENT(OUT) :: found !<10856 CHARACTER (LEN=*), INTENT(IN) :: variable !< 10857 LOGICAL, INTENT(OUT) :: found !< 10858 CHARACTER (LEN=*), INTENT(OUT) :: grid_x !< 10859 CHARACTER (LEN=*), INTENT(OUT) :: grid_y !< 10860 CHARACTER (LEN=*), INTENT(OUT) :: grid_z !< 10861 10862 CHARACTER (len=varnamelength) :: var 10699 10863 10700 10864 found = .TRUE. … … 10702 10866 ! 10703 10867 !-- Check for the grid 10704 var = TRIM( variable)10868 var = TRIM(variable) 10705 10869 !-- RTM directional variables 10706 IF ( var(1:12) == 'rtm_rad_net_' .OR. var(1:13) == 'rtm_rad_insw_' .OR. 10707 var(1:13) == 'rtm_rad_inlw_' .OR. var(1:16) == 'rtm_rad_inswdir_' .OR. 10708 var(1:16) == 'rtm_rad_inswdif_' .OR. var(1:16) == 'rtm_rad_inswref_' .OR. 10709 var(1:16) == 'rtm_rad_inlwdif_' .OR. var(1:16) == 'rtm_rad_inlwref_' .OR. 10710 var(1:14) == 'rtm_rad_outsw_' .OR. var(1:14) == 'rtm_rad_outlw_' .OR. 10711 var(1:14) == 'rtm_rad_ressw_' .OR. var(1:14) == 'rtm_rad_reslw_' .OR. 10712 var == 'rtm_rad_pc_inlw' .OR. 10713 var == 'rtm_rad_pc_insw' .OR. var == 'rtm_rad_pc_inswdir' .OR. 10714 var == 'rtm_rad_pc_inswdif' .OR. var == 'rtm_rad_pc_inswref' .OR. 10715 var(1:7) == 'rtm_svf' .OR. var(1:7) == 'rtm_dif' .OR. 10716 var(1:9) == 'rtm_skyvf' .OR. var(1:10) == 'rtm_skyvft' .OR. 10717 var(1:12) == 'rtm_surfalb_' .OR. var(1:13) == 'rtm_surfemis_' .OR. 10870 IF ( var(1:12) == 'rtm_rad_net_' .OR. var(1:13) == 'rtm_rad_insw_' .OR. & 10871 var(1:13) == 'rtm_rad_inlw_' .OR. var(1:16) == 'rtm_rad_inswdir_' .OR. & 10872 var(1:16) == 'rtm_rad_inswdif_' .OR. var(1:16) == 'rtm_rad_inswref_' .OR. & 10873 var(1:16) == 'rtm_rad_inlwdif_' .OR. var(1:16) == 'rtm_rad_inlwref_' .OR. & 10874 var(1:14) == 'rtm_rad_outsw_' .OR. var(1:14) == 'rtm_rad_outlw_' .OR. & 10875 var(1:14) == 'rtm_rad_ressw_' .OR. var(1:14) == 'rtm_rad_reslw_' .OR. & 10876 var == 'rtm_rad_pc_inlw' .OR. & 10877 var == 'rtm_rad_pc_insw' .OR. var == 'rtm_rad_pc_inswdir' .OR. & 10878 var == 'rtm_rad_pc_inswdif' .OR. var == 'rtm_rad_pc_inswref' .OR. & 10879 var(1:7) == 'rtm_svf' .OR. var(1:7) == 'rtm_dif' .OR. & 10880 var(1:9) == 'rtm_skyvf' .OR. var(1:10) == 'rtm_skyvft' .OR. & 10881 var(1:12) == 'rtm_surfalb_' .OR. var(1:13) == 'rtm_surfemis_' .OR. & 10718 10882 var == 'rtm_mrt' .OR. var == 'rtm_mrt_sw' .OR. var == 'rtm_mrt_lw' ) THEN 10719 10883 … … 10726 10890 SELECT CASE ( TRIM( var ) ) 10727 10891 10728 CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_sw_cs_hr', 'rad_sw_hr', 'rad_lw_cs_hr_xy', & 10729 'rad_lw_hr_xy', 'rad_sw_cs_hr_xy', 'rad_sw_hr_xy', 'rad_lw_cs_hr_xz', & 10730 'rad_lw_hr_xz', 'rad_sw_cs_hr_xz', 'rad_sw_hr_xz', 'rad_lw_cs_hr_yz', & 10892 CASE ( 'rad_lw_cs_hr', 'rad_lw_hr', 'rad_sw_cs_hr', 'rad_sw_hr', & 10893 'rad_lw_cs_hr_xy', 'rad_lw_hr_xy', 'rad_sw_cs_hr_xy', & 10894 'rad_sw_hr_xy', 'rad_lw_cs_hr_xz', 'rad_lw_hr_xz', & 10895 'rad_sw_cs_hr_xz', 'rad_sw_hr_xz', 'rad_lw_cs_hr_yz', & 10731 10896 'rad_lw_hr_yz', 'rad_sw_cs_hr_yz', 'rad_sw_hr_yz' ) 10732 10897 grid_x = 'x' … … 10734 10899 grid_z = 'zu' 10735 10900 10736 CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out', 'rad_lw_in_xy',&10737 'rad_lw_ out_xy', 'rad_sw_in_xy','rad_sw_out_xy', 'rad_lw_in_xz', 'rad_lw_out_xz', &10738 'rad_ sw_in_xz','rad_sw_out_xz', 'rad_lw_in_yz', 'rad_lw_out_yz', 'rad_sw_in_yz',&10739 'rad_ sw_out_yz' )10901 CASE ( 'rad_lw_in', 'rad_lw_out', 'rad_sw_in', 'rad_sw_out', & 10902 'rad_lw_in_xy', 'rad_lw_out_xy', 'rad_sw_in_xy','rad_sw_out_xy', & 10903 'rad_lw_in_xz', 'rad_lw_out_xz', 'rad_sw_in_xz','rad_sw_out_xz', & 10904 'rad_lw_in_yz', 'rad_lw_out_yz', 'rad_sw_in_yz','rad_sw_out_yz' ) 10740 10905 grid_x = 'x' 10741 10906 grid_y = 'y' … … 10752 10917 ENDIF 10753 10918 10754 END SUBROUTINE radiation_define_netcdf_grid 10755 10756 !--------------------------------------------------------------------------------------------------! 10919 END SUBROUTINE radiation_define_netcdf_grid 10920 10921 !------------------------------------------------------------------------------! 10922 ! 10757 10923 ! Description: 10758 10924 ! ------------ 10759 10925 !> Subroutine defining 2D output variables 10760 !------------------------------------------------------------------------------ --------------------!10761 SUBROUTINE radiation_data_output_2d( av, variable, found, grid, mode, local_pf, two_d, nzb_do,&10762 nzt_do )10926 !------------------------------------------------------------------------------! 10927 SUBROUTINE radiation_data_output_2d( av, variable, found, grid, mode, & 10928 local_pf, two_d, nzb_do, nzt_do ) 10763 10929 10764 10930 USE indices … … 10769 10935 IMPLICIT NONE 10770 10936 10771 CHARACTER (LEN=*) :: grid!<10772 CHARACTER (LEN=*) :: mode!<10773 CHARACTER (LEN=*) :: variable!<10774 10775 INTEGER(iwp) :: av 10776 INTEGER(iwp) :: i 10777 INTEGER(iwp) :: j 10778 INTEGER(iwp) :: k 10779 INTEGER(iwp) :: m 10937 CHARACTER (LEN=*) :: grid !< 10938 CHARACTER (LEN=*) :: mode !< 10939 CHARACTER (LEN=*) :: variable !< 10940 10941 INTEGER(iwp) :: av !< 10942 INTEGER(iwp) :: i !< 10943 INTEGER(iwp) :: j !< 10944 INTEGER(iwp) :: k !< 10945 INTEGER(iwp) :: m !< index of surface element at grid point (j,i) 10780 10946 INTEGER(iwp) :: nzb_do !< 10781 10947 INTEGER(iwp) :: nzt_do !< 10782 10948 10783 LOGICAL :: found!<10784 LOGICAL :: two_d!< flag parameter that indicates 2D variables (horizontal cross sections)10785 10786 REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute10787 10788 REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf 10949 LOGICAL :: found !< 10950 LOGICAL :: two_d !< flag parameter that indicates 2D variables (horizontal cross sections) 10951 10952 REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute 10953 10954 REAL(wp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !< 10789 10955 10790 10956 found = .TRUE. … … 10799 10965 !-- Obtain rad_net from its respective surface type 10800 10966 !-- Natural-type surfaces 10801 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 10967 DO m = surf_lsm_h%start_index(j,i), & 10968 surf_lsm_h%end_index(j,i) 10802 10969 local_pf(i,j,nzb+1) = surf_lsm_h%rad_net(m) 10803 10970 ENDDO 10804 10971 ! 10805 10972 !-- Urban-type surfaces 10806 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 10973 DO m = surf_usm_h%start_index(j,i), & 10974 surf_usm_h%end_index(j,i) 10807 10975 local_pf(i,j,nzb+1) = surf_usm_h%rad_net(m) 10808 10976 ENDDO … … 10810 10978 ENDDO 10811 10979 ELSE 10812 IF ( .NOT. ALLOCATED( rad_net_av ) ) 10980 IF ( .NOT. ALLOCATED( rad_net_av ) ) THEN 10813 10981 ALLOCATE( rad_net_av(nysg:nyng,nxlg:nxrg) ) 10814 10982 rad_net_av = REAL( fill_value, KIND = wp ) … … 10830 10998 !-- Obtain rad_net from its respective surface type 10831 10999 !-- Natural-type surfaces 10832 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 11000 DO m = surf_lsm_h%start_index(j,i), & 11001 surf_lsm_h%end_index(j,i) 10833 11002 local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_in(m) 10834 11003 ENDDO 10835 11004 ! 10836 11005 !-- Urban-type surfaces 10837 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 11006 DO m = surf_usm_h%start_index(j,i), & 11007 surf_usm_h%end_index(j,i) 10838 11008 local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_in(m) 10839 11009 ENDDO … … 10841 11011 ENDDO 10842 11012 ELSE 10843 IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) 11013 IF ( .NOT. ALLOCATED( rad_lw_in_xy_av ) ) THEN 10844 11014 ALLOCATE( rad_lw_in_xy_av(nysg:nyng,nxlg:nxrg) ) 10845 11015 rad_lw_in_xy_av = REAL( fill_value, KIND = wp ) … … 10861 11031 !-- Obtain rad_net from its respective surface type 10862 11032 !-- Natural-type surfaces 10863 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 11033 DO m = surf_lsm_h%start_index(j,i), & 11034 surf_lsm_h%end_index(j,i) 10864 11035 local_pf(i,j,nzb+1) = surf_lsm_h%rad_lw_out(m) 10865 11036 ENDDO 10866 11037 ! 10867 11038 !-- Urban-type surfaces 10868 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 11039 DO m = surf_usm_h%start_index(j,i), & 11040 surf_usm_h%end_index(j,i) 10869 11041 local_pf(i,j,nzb+1) = surf_usm_h%rad_lw_out(m) 10870 11042 ENDDO … … 10872 11044 ENDDO 10873 11045 ELSE 10874 IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) 11046 IF ( .NOT. ALLOCATED( rad_lw_out_xy_av ) ) THEN 10875 11047 ALLOCATE( rad_lw_out_xy_av(nysg:nyng,nxlg:nxrg) ) 10876 11048 rad_lw_out_xy_av = REAL( fill_value, KIND = wp ) … … 10886 11058 10887 11059 CASE ( 'rad_sw_in*_xy' ) ! 2d-array 10888 IF ( av == 0 ) 11060 IF ( av == 0 ) THEN 10889 11061 DO i = nxl, nxr 10890 11062 DO j = nys, nyn … … 10892 11064 !-- Obtain rad_net from its respective surface type 10893 11065 !-- Natural-type surfaces 10894 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 11066 DO m = surf_lsm_h%start_index(j,i), & 11067 surf_lsm_h%end_index(j,i) 10895 11068 local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_in(m) 10896 11069 ENDDO 10897 11070 ! 10898 11071 !-- Urban-type surfaces 10899 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 11072 DO m = surf_usm_h%start_index(j,i), & 11073 surf_usm_h%end_index(j,i) 10900 11074 local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_in(m) 10901 11075 ENDDO … … 10903 11077 ENDDO 10904 11078 ELSE 10905 IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) 11079 IF ( .NOT. ALLOCATED( rad_sw_in_xy_av ) ) THEN 10906 11080 ALLOCATE( rad_sw_in_xy_av(nysg:nyng,nxlg:nxrg) ) 10907 11081 rad_sw_in_xy_av = REAL( fill_value, KIND = wp ) … … 10917 11091 10918 11092 CASE ( 'rad_sw_out*_xy' ) ! 2d-array 10919 IF ( av == 0 ) 11093 IF ( av == 0 ) THEN 10920 11094 DO i = nxl, nxr 10921 11095 DO j = nys, nyn … … 10923 11097 !-- Obtain rad_net from its respective surface type 10924 11098 !-- Natural-type surfaces 10925 DO m = surf_lsm_h%start_index(j,i), surf_lsm_h%end_index(j,i) 11099 DO m = surf_lsm_h%start_index(j,i), & 11100 surf_lsm_h%end_index(j,i) 10926 11101 local_pf(i,j,nzb+1) = surf_lsm_h%rad_sw_out(m) 10927 11102 ENDDO 10928 11103 ! 10929 11104 !-- Urban-type surfaces 10930 DO m = surf_usm_h%start_index(j,i), surf_usm_h%end_index(j,i) 11105 DO m = surf_usm_h%start_index(j,i), & 11106 surf_usm_h%end_index(j,i) 10931 11107 local_pf(i,j,nzb+1) = surf_usm_h%rad_sw_out(m) 10932 11108 ENDDO … … 10934 11110 ENDDO 10935 11111 ELSE 10936 IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) 11112 IF ( .NOT. ALLOCATED( rad_sw_out_xy_av ) ) THEN 10937 11113 ALLOCATE( rad_sw_out_xy_av(nysg:nyng,nxlg:nxrg) ) 10938 11114 rad_sw_out_xy_av = REAL( fill_value, KIND = wp ) … … 10957 11133 ENDDO 10958 11134 ELSE 10959 IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) 11135 IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN 10960 11136 ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 10961 11137 rad_lw_in_av = REAL( fill_value, KIND = wp ) … … 10972 11148 10973 11149 CASE ( 'rad_lw_out_xy', 'rad_lw_out_xz', 'rad_lw_out_yz' ) 10974 IF ( av == 0 ) 11150 IF ( av == 0 ) THEN 10975 11151 DO i = nxl, nxr 10976 11152 DO j = nys, nyn … … 10981 11157 ENDDO 10982 11158 ELSE 10983 IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) 11159 IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN 10984 11160 ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 10985 11161 rad_lw_out_av = REAL( fill_value, KIND = wp ) … … 11005 11181 ENDDO 11006 11182 ELSE 11007 IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) 11183 IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN 11008 11184 ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) 11009 11185 rad_lw_cs_hr_av = REAL( fill_value, KIND = wp ) … … 11020 11196 11021 11197 CASE ( 'rad_lw_hr_xy', 'rad_lw_hr_xz', 'rad_lw_hr_yz' ) 11022 IF ( av == 0 ) 11198 IF ( av == 0 ) THEN 11023 11199 DO i = nxl, nxr 11024 11200 DO j = nys, nyn … … 11029 11205 ENDDO 11030 11206 ELSE 11031 IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) 11207 IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN 11032 11208 ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) 11033 11209 rad_lw_hr_av= REAL( fill_value, KIND = wp ) … … 11044 11220 11045 11221 CASE ( 'rad_sw_in_xy', 'rad_sw_in_xz', 'rad_sw_in_yz' ) 11046 IF ( av == 0 ) 11222 IF ( av == 0 ) THEN 11047 11223 DO i = nxl, nxr 11048 11224 DO j = nys, nyn … … 11053 11229 ENDDO 11054 11230 ELSE 11055 IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) 11231 IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN 11056 11232 ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 11057 11233 rad_sw_in_av = REAL( fill_value, KIND = wp ) … … 11068 11244 11069 11245 CASE ( 'rad_sw_out_xy', 'rad_sw_out_xz', 'rad_sw_out_yz' ) 11070 IF ( av == 0 ) 11246 IF ( av == 0 ) THEN 11071 11247 DO i = nxl, nxr 11072 11248 DO j = nys, nyn … … 11077 11253 ENDDO 11078 11254 ELSE 11079 IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) 11255 IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN 11080 11256 ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 11081 11257 rad_sw_out_av = REAL( fill_value, KIND = wp ) … … 11092 11268 11093 11269 CASE ( 'rad_sw_cs_hr_xy', 'rad_sw_cs_hr_xz', 'rad_sw_cs_hr_yz' ) 11094 IF ( av == 0 ) 11270 IF ( av == 0 ) THEN 11095 11271 DO i = nxl, nxr 11096 11272 DO j = nys, nyn … … 11101 11277 ENDDO 11102 11278 ELSE 11103 IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) 11279 IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN 11104 11280 ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) 11105 11281 rad_sw_cs_hr_av = REAL( fill_value, KIND = wp ) … … 11116 11292 11117 11293 CASE ( 'rad_sw_hr_xy', 'rad_sw_hr_xz', 'rad_sw_hr_yz' ) 11118 IF ( av == 0 ) 11294 IF ( av == 0 ) THEN 11119 11295 DO i = nxl, nxr 11120 11296 DO j = nys, nyn … … 11125 11301 ENDDO 11126 11302 ELSE 11127 IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) 11303 IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN 11128 11304 ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) 11129 11305 rad_sw_hr_av = REAL( fill_value, KIND = wp ) … … 11148 11324 11149 11325 11150 !--------------------------------------------------------------------------------------------------! 11326 !------------------------------------------------------------------------------! 11327 ! 11151 11328 ! Description: 11152 11329 ! ------------ 11153 11330 !> Subroutine defining 3D output variables 11154 !------------------------------------------------------------------------------ --------------------!11331 !------------------------------------------------------------------------------! 11155 11332 SUBROUTINE radiation_data_output_3d( av, variable, found, local_pf, nzb_do, nzt_do ) 11156 11333 … … 11163 11340 IMPLICIT NONE 11164 11341 11165 CHARACTER(LEN=*) :: variable !< 11166 CHARACTER(LEN=varnamelength) :: var, surfid !< 11167 11168 INTEGER(iwp) :: av !< 11169 INTEGER(iwp) :: i, j, k, l !< 11170 INTEGER(iwp) :: nzb_do !< 11171 INTEGER(iwp) :: nzt_do !< 11172 INTEGER(iwp) :: ids,idsint_u,idsint_l,isurf,isvf,isurfs,isurflt,ipcgb !< 11173 INTEGER(iwp) :: is, js, ks, istat !< 11174 11175 LOGICAL :: found !< 11176 11177 REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute 11178 11179 REAL(sp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !< 11180 11181 11182 11183 11184 11342 CHARACTER (LEN=*) :: variable !< 11343 11344 INTEGER(iwp) :: av !< 11345 INTEGER(iwp) :: i, j, k, l !< 11346 INTEGER(iwp) :: nzb_do !< 11347 INTEGER(iwp) :: nzt_do !< 11348 11349 LOGICAL :: found !< 11350 11351 REAL(wp) :: fill_value = -999.0_wp !< value for the _FillValue attribute 11352 11353 REAL(sp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do) :: local_pf !< 11354 11355 CHARACTER (len=varnamelength) :: var, surfid 11356 INTEGER(iwp) :: ids,idsint_u,idsint_l,isurf,isvf,isurfs,isurflt,ipcgb 11357 INTEGER(iwp) :: is, js, ks, istat 11185 11358 11186 11359 found = .TRUE. 11187 11360 var = TRIM(variable) 11188 ! 11189 !-- Check if variable belongs to radiation related variables (starts with rad or rtm)11190 IF ( LEN( var) < 3_iwp ) THEN11361 11362 !-- check if variable belongs to radiation related variables (starts with rad or rtm) 11363 IF ( len(var) < 3_iwp ) THEN 11191 11364 found = .FALSE. 11192 11365 RETURN … … 11199 11372 11200 11373 ids = -1 11201 DO 11202 k = LEN( TRIM( var ))11203 j = LEN( TRIM( dirname(i) ))11204 IF ( k - j + 1 >= 1_iwp )THEN11205 IF ( TRIM( var(k-j+1:k) ) == TRIM( dirname(i)) ) THEN11206 ids = i11207 idsint_u = dirint_u(ids)11208 idsint_l = dirint_l(ids)11209 var = var(:k-j)11210 EXIT11211 ENDIF11212 ENDIF11374 DO i = 0, nd-1 11375 k = len(TRIM(var)) 11376 j = len(TRIM(dirname(i))) 11377 IF ( k-j+1 >= 1_iwp ) THEN 11378 IF ( TRIM(var(k-j+1:k)) == TRIM(dirname(i)) ) THEN 11379 ids = i 11380 idsint_u = dirint_u(ids) 11381 idsint_l = dirint_l(ids) 11382 var = var(:k-j) 11383 EXIT 11384 ENDIF 11385 ENDIF 11213 11386 ENDDO 11214 11387 IF ( ids == -1 ) THEN 11215 var = TRIM( variable)11388 var = TRIM(variable) 11216 11389 ENDIF 11217 11390 11218 IF ( (var(1:8) == 'rtm_svf_' .OR. var(1:8) == 'rtm_dif_') .AND. LEN( TRIM( var ) ) >= 13 ) & 11219 THEN 11391 IF ( (var(1:8) == 'rtm_svf_' .OR. var(1:8) == 'rtm_dif_') .AND. len(TRIM(var)) >= 13 ) THEN 11220 11392 !-- svf values to particular surface 11221 11393 surfid = var(9:) 11222 i = INDEX( surfid, '_')11223 j = INDEX( surfid(i+1:), '_')11224 READ( surfid(1:i-1), *, IOSTAT =istat ) is11394 i = index(surfid,'_') 11395 j = index(surfid(i+1:),'_') 11396 READ(surfid(1:i-1),*, iostat=istat ) is 11225 11397 IF ( istat == 0 ) THEN 11226 READ( surfid(i+1:i+j-1), *, IOSTAT =istat ) js11398 READ(surfid(i+1:i+j-1),*, iostat=istat ) js 11227 11399 ENDIF 11228 11400 IF ( istat == 0 ) THEN 11229 READ( surfid(i+j+1:), *, IOSTAT =istat ) ks11401 READ(surfid(i+j+1:),*, iostat=istat ) ks 11230 11402 ENDIF 11231 11403 IF ( istat == 0 ) THEN … … 11237 11409 11238 11410 SELECT CASE ( TRIM( var ) ) 11239 !-- Block of large scale radiation model (e.g. RRTMG) output variables11411 !-- block of large scale radiation model (e.g. RRTMG) output variables 11240 11412 CASE ( 'rad_sw_in' ) 11241 11413 IF ( av == 0 ) THEN … … 11248 11420 ENDDO 11249 11421 ELSE 11250 IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) 11422 IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN 11251 11423 ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 11252 11424 rad_sw_in_av = REAL( fill_value, KIND = wp ) … … 11271 11443 ENDDO 11272 11444 ELSE 11273 IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) 11445 IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN 11274 11446 ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 11275 11447 rad_sw_out_av = REAL( fill_value, KIND = wp ) … … 11294 11466 ENDDO 11295 11467 ELSE 11296 IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) 11468 IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) THEN 11297 11469 ALLOCATE( rad_sw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) 11298 11470 rad_sw_cs_hr_av = REAL( fill_value, KIND = wp ) … … 11317 11489 ENDDO 11318 11490 ELSE 11319 IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) 11491 IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) THEN 11320 11492 ALLOCATE( rad_sw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) 11321 11493 rad_sw_hr_av = REAL( fill_value, KIND = wp ) … … 11340 11512 ENDDO 11341 11513 ELSE 11342 IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) 11514 IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN 11343 11515 ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 11344 11516 rad_lw_in_av = REAL( fill_value, KIND = wp ) … … 11363 11535 ENDDO 11364 11536 ELSE 11365 IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) 11537 IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN 11366 11538 ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 11367 11539 rad_lw_out_av = REAL( fill_value, KIND = wp ) … … 11386 11558 ENDDO 11387 11559 ELSE 11388 IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) 11560 IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) THEN 11389 11561 ALLOCATE( rad_lw_cs_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) 11390 11562 rad_lw_cs_hr_av = REAL( fill_value, KIND = wp ) … … 11409 11581 ENDDO 11410 11582 ELSE 11411 IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) 11583 IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) THEN 11412 11584 ALLOCATE( rad_lw_hr_av(nzb+1:nzt+1,nysg:nyng,nxlg:nxrg) ) 11413 11585 rad_lw_hr_av = REAL( fill_value, KIND = wp ) … … 11423 11595 11424 11596 CASE ( 'rtm_rad_net' ) 11425 !-- Array of complete radiation balance11426 DO 11597 !-- array of complete radiation balance 11598 DO isurf = dirstart(ids), dirend(ids) 11427 11599 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 11428 11600 IF ( av == 0 ) THEN 11429 local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = 11430 surfinsw(isurf) - surfoutsw(isurf) + surfinlw(isurf) - surfoutlw(isurf)11601 local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = & 11602 surfinsw(isurf) - surfoutsw(isurf) + surfinlw(isurf) - surfoutlw(isurf) 11431 11603 ELSE 11432 11604 local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfradnet_av(isurf) … … 11436 11608 11437 11609 CASE ( 'rtm_rad_insw' ) 11438 !-- Array of sw radiation falling to surface after i-th reflection11439 DO 11610 !-- array of sw radiation falling to surface after i-th reflection 11611 DO isurf = dirstart(ids), dirend(ids) 11440 11612 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 11441 11613 IF ( av == 0 ) THEN … … 11448 11620 11449 11621 CASE ( 'rtm_rad_inlw' ) 11450 !-- Array of lw radiation falling to surface after i-th reflection11451 DO 11622 !-- array of lw radiation falling to surface after i-th reflection 11623 DO isurf = dirstart(ids), dirend(ids) 11452 11624 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 11453 11625 IF ( av == 0 ) THEN … … 11460 11632 11461 11633 CASE ( 'rtm_rad_inswdir' ) 11462 !-- Array of direct sw radiation falling to surface from sun11463 DO 11634 !-- array of direct sw radiation falling to surface from sun 11635 DO isurf = dirstart(ids), dirend(ids) 11464 11636 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 11465 11637 IF ( av == 0 ) THEN … … 11472 11644 11473 11645 CASE ( 'rtm_rad_inswdif' ) 11474 !-- Array of difusion sw radiation falling to surface from sky and borders of the domain11475 DO 11646 !-- array of difusion sw radiation falling to surface from sky and borders of the domain 11647 DO isurf = dirstart(ids), dirend(ids) 11476 11648 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 11477 11649 IF ( av == 0 ) THEN … … 11484 11656 11485 11657 CASE ( 'rtm_rad_inswref' ) 11486 !-- Array of sw radiation falling to surface from reflections11487 DO 11658 !-- array of sw radiation falling to surface from reflections 11659 DO isurf = dirstart(ids), dirend(ids) 11488 11660 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 11489 11661 IF ( av == 0 ) THEN 11490 local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = 11491 11662 local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = & 11663 surfinsw(isurf) - surfinswdir(isurf) - surfinswdif(isurf) 11492 11664 ELSE 11493 11665 local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinswref_av(isurf) … … 11497 11669 11498 11670 CASE ( 'rtm_rad_inlwdif' ) 11499 !-- Array of diffuselw radiation falling to surface from sky and borders of the domain11500 DO 11671 !-- array of difusion lw radiation falling to surface from sky and borders of the domain 11672 DO isurf = dirstart(ids), dirend(ids) 11501 11673 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 11502 11674 IF ( av == 0 ) THEN … … 11509 11681 11510 11682 CASE ( 'rtm_rad_inlwref' ) 11511 !-- Array of lw radiation falling to surface from reflections11512 DO 11683 !-- array of lw radiation falling to surface from reflections 11684 DO isurf = dirstart(ids), dirend(ids) 11513 11685 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 11514 11686 IF ( av == 0 ) THEN 11515 local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw(isurf) & 11516 - surfinlwdif(isurf) 11687 local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlw(isurf) - surfinlwdif(isurf) 11517 11688 ELSE 11518 11689 local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = surfinlwref_av(isurf) … … 11522 11693 11523 11694 CASE ( 'rtm_rad_outsw' ) 11524 !-- Array of sw radiation emitted from surface after i-th reflection11525 DO 11695 !-- array of sw radiation emitted from surface after i-th reflection 11696 DO isurf = dirstart(ids), dirend(ids) 11526 11697 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 11527 11698 IF ( av == 0 ) THEN … … 11534 11705 11535 11706 CASE ( 'rtm_rad_outlw' ) 11536 !-- Array of lw radiation emitted from surface after i-th reflection11537 DO 11707 !-- array of lw radiation emitted from surface after i-th reflection 11708 DO isurf = dirstart(ids), dirend(ids) 11538 11709 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 11539 11710 IF ( av == 0 ) THEN … … 11546 11717 11547 11718 CASE ( 'rtm_rad_ressw' ) 11548 !-- Average of array of residua of sw radiation absorbed in surface after last reflection11549 DO 11719 !-- average of array of residua of sw radiation absorbed in surface after last reflection 11720 DO isurf = dirstart(ids), dirend(ids) 11550 11721 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 11551 11722 IF ( av == 0 ) THEN … … 11558 11729 11559 11730 CASE ( 'rtm_rad_reslw' ) 11560 !-- Average of array of residua of lw radiation absorbed in surface after last reflection11561 DO 11731 !-- average of array of residua of lw radiation absorbed in surface after last reflection 11732 DO isurf = dirstart(ids), dirend(ids) 11562 11733 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 11563 11734 IF ( av == 0 ) THEN … … 11570 11741 11571 11742 CASE ( 'rtm_rad_pc_inlw' ) 11572 !-- Array of lw radiation absorbed by plant canopy11573 DO 11743 !-- array of lw radiation absorbed by plant canopy 11744 DO ipcgb = 1, npcbl 11574 11745 IF ( av == 0 ) THEN 11575 11746 local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinlw(ipcgb) … … 11580 11751 11581 11752 CASE ( 'rtm_rad_pc_insw' ) 11582 !-- Array of sw radiation absorbed by plant canopy11583 DO 11753 !-- array of sw radiation absorbed by plant canopy 11754 DO ipcgb = 1, npcbl 11584 11755 IF ( av == 0 ) THEN 11585 11756 local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinsw(ipcgb) … … 11590 11761 11591 11762 CASE ( 'rtm_rad_pc_inswdir' ) 11592 !-- Array of direct sw radiation absorbed by plant canopy11593 DO 11763 !-- array of direct sw radiation absorbed by plant canopy 11764 DO ipcgb = 1, npcbl 11594 11765 IF ( av == 0 ) THEN 11595 11766 local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdir(ipcgb) … … 11600 11771 11601 11772 CASE ( 'rtm_rad_pc_inswdif' ) 11602 !-- Array of diffuse sw radiation absorbed by plant canopy11603 DO 11773 !-- array of diffuse sw radiation absorbed by plant canopy 11774 DO ipcgb = 1, npcbl 11604 11775 IF ( av == 0 ) THEN 11605 11776 local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswdif(ipcgb) … … 11610 11781 11611 11782 CASE ( 'rtm_rad_pc_inswref' ) 11612 !-- Array of reflected sw radiation absorbed by plant canopy11613 DO 11783 !-- array of reflected sw radiation absorbed by plant canopy 11784 DO ipcgb = 1, npcbl 11614 11785 IF ( av == 0 ) THEN 11615 local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinsw(ipcgb) & 11616 - pcbinswdir(ipcgb) & 11617 - pcbinswdif(ipcgb) 11786 local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = & 11787 pcbinsw(ipcgb) - pcbinswdir(ipcgb) - pcbinswdif(ipcgb) 11618 11788 ELSE 11619 11789 local_pf(pcbl(ix,ipcgb),pcbl(iy,ipcgb),pcbl(iz,ipcgb)) = pcbinswref_av(ipcgb) … … 11628 11798 ENDDO 11629 11799 ELSE 11630 IF ( ALLOCATED( mrtinsw_av ) ) 11800 IF ( ALLOCATED( mrtinsw_av ) ) THEN 11631 11801 DO l = 1, nmrtbl 11632 11802 local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinsw_av(l) … … 11642 11812 ENDDO 11643 11813 ELSE 11644 IF ( ALLOCATED( mrtinlw_av ) ) 11814 IF ( ALLOCATED( mrtinlw_av ) ) THEN 11645 11815 DO l = 1, nmrtbl 11646 11816 local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrtinlw_av(l) … … 11656 11826 ENDDO 11657 11827 ELSE 11658 IF ( ALLOCATED( mrt_av ) ) 11828 IF ( ALLOCATED( mrt_av ) ) THEN 11659 11829 DO l = 1, nmrtbl 11660 11830 local_pf(mrtbl(ix,l),mrtbl(iy,l),mrtbl(iz,l)) = mrt_av(l) … … 11663 11833 ENDIF 11664 11834 ! 11665 !-- Block of RTM output variables11666 !-- Variables are intended mainly for debugging and detailed analyse purposes11835 !-- block of RTM output variables 11836 !-- variables are intended mainly for debugging and detailed analyse purposes 11667 11837 CASE ( 'rtm_skyvf' ) 11668 11838 ! 11669 !-- Sky view factor11670 DO 11839 !-- sky view factor 11840 DO isurf = dirstart(ids), dirend(ids) 11671 11841 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 11672 11842 local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = skyvf(isurf) … … 11676 11846 CASE ( 'rtm_skyvft' ) 11677 11847 ! 11678 !-- Sky view factor11679 DO 11848 !-- sky view factor 11849 DO isurf = dirstart(ids), dirend(ids) 11680 11850 IF ( surfl(id,isurf) == ids ) THEN 11681 11851 local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = skyvft(isurf) … … 11685 11855 CASE ( 'rtm_svf', 'rtm_dif' ) 11686 11856 ! 11687 !-- Shape view factors or irradiance factors to selected surface11688 IF ( TRIM( var)=='rtm_svf' ) THEN11857 !-- shape view factors or iradiance factors to selected surface 11858 IF ( TRIM(var)=='rtm_svf' ) THEN 11689 11859 k = 1 11690 11860 ELSE 11691 11861 k = 2 11692 11862 ENDIF 11693 DO 11863 DO isvf = 1, nsvfl 11694 11864 isurflt = svfsurf(1, isvf) 11695 11865 isurfs = svfsurf(2, isvf) 11696 11866 11697 IF ( surf(ix,isurfs) == is .AND. surf(iy,isurfs) == js .AND. surf(iz,isurfs) == ks&11698 .AND. (surfl(id,isurflt) == idsint_u .OR. surfl(id,isurflt) == idsint_l ) ) THEN11699 ! 11700 !-- Correct source surface11867 IF ( surf(ix,isurfs) == is .AND. surf(iy,isurfs) == js .AND. surf(iz,isurfs) == ks .AND. & 11868 (surfl(id,isurflt) == idsint_u .OR. surfl(id,isurflt) == idsint_l ) ) THEN 11869 ! 11870 !-- correct source surface 11701 11871 local_pf(surfl(ix,isurflt),surfl(iy,isurflt),surfl(iz,isurflt)) = svf(k,isvf) 11702 11872 ENDIF … … 11705 11875 CASE ( 'rtm_surfalb' ) 11706 11876 ! 11707 !-- Surface albedo11708 DO 11877 !-- surface albedo 11878 DO isurf = dirstart(ids), dirend(ids) 11709 11879 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 11710 11880 local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = albedo_surf(isurf) … … 11714 11884 CASE ( 'rtm_surfemis' ) 11715 11885 ! 11716 !-- Surface emissivity, weighted average11717 DO 11886 !-- surface emissivity, weighted average 11887 DO isurf = dirstart(ids), dirend(ids) 11718 11888 IF ( surfl(id,isurf) == idsint_u .OR. surfl(id,isurf) == idsint_l ) THEN 11719 11889 local_pf(surfl(ix,isurf),surfl(iy,isurf),surfl(iz,isurf)) = emiss_surf(isurf) … … 11729 11899 END SUBROUTINE radiation_data_output_3d 11730 11900 11731 !--------------------------------------------------------------------------------------------------! 11901 !------------------------------------------------------------------------------! 11902 ! 11732 11903 ! Description: 11733 11904 ! ------------ 11734 11905 !> Subroutine defining masked data output 11735 !------------------------------------------------------------------------------ --------------------!11906 !------------------------------------------------------------------------------! 11736 11907 SUBROUTINE radiation_data_output_mask( av, variable, found, local_pf, mid ) 11737 11908 … … 11745 11916 IMPLICIT NONE 11746 11917 11747 CHARACTER(LEN=*) :: variable !< 11748 CHARACTER(LEN=5) :: grid !< flag to distinguish between staggered grids 11918 CHARACTER (LEN=*) :: variable !< 11919 11920 CHARACTER(LEN=5) :: grid !< flag to distinquish between staggered grids 11749 11921 11750 11922 INTEGER(iwp) :: av !< … … 11755 11927 INTEGER(iwp) :: topo_top_index !< k index of highest horizontal surface 11756 11928 11757 LOGICAL :: found !< true if output array was found 11758 LOGICAL :: resorted !< true if array is resorted 11759 11760 11761 REAL(wp), DIMENSION(mask_size_l(mid,1),mask_size_l(mid,2),mask_size_l(mid,3)) :: local_pf !< 11929 LOGICAL :: found !< true if output array was found 11930 LOGICAL :: resorted !< true if array is resorted 11931 11932 11933 REAL(wp), & 11934 DIMENSION(mask_size_l(mid,1),mask_size_l(mid,2),mask_size_l(mid,3)) :: & 11935 local_pf !< 11936 11762 11937 REAL(wp), DIMENSION(:,:,:), POINTER :: to_be_resorted !< points to array which needs to be resorted for output 11763 11938 … … 11840 12015 DO j = 1, mask_size_l(mid,2) 11841 12016 DO k = 1, mask_size_l(mid,3) 11842 local_pf(i,j,k) = to_be_resorted(mask_k(mid,k),mask_j(mid,j),mask_i(mid,i)) 12017 local_pf(i,j,k) = to_be_resorted(mask_k(mid,k), & 12018 mask_j(mid,j),mask_i(mid,i)) 11843 12019 ENDDO 11844 12020 ENDDO … … 11852 12028 ! 11853 12029 !-- Get k index of highest horizontal surface 11854 topo_top_index = topo_top_ind(mask_j(mid,j),mask_i(mid,i),0) 12030 topo_top_index = topo_top_ind(mask_j(mid,j), & 12031 mask_i(mid,i), & 12032 0 ) 11855 12033 ! 11856 12034 !-- Save output array 11857 12035 DO k = 1, mask_size_l(mid,3) 11858 local_pf(i,j,k) = to_be_resorted(MIN( topo_top_index+mask_k(mid,k), nzt+1 ), & 11859 mask_j(mid,j),mask_i(mid,i)) 12036 local_pf(i,j,k) = to_be_resorted( & 12037 MIN( topo_top_index+mask_k(mid,k), & 12038 nzt+1 ), & 12039 mask_j(mid,j), & 12040 mask_i(mid,i) ) 11860 12041 ENDDO 11861 12042 ENDDO … … 11870 12051 11871 12052 11872 !------------------------------------------------------------------------------ --------------------!12053 !------------------------------------------------------------------------------! 11873 12054 ! Description: 11874 12055 ! ------------ 11875 12056 !> Subroutine writes local (subdomain) restart data 11876 !------------------------------------------------------------------------------ --------------------!12057 !------------------------------------------------------------------------------! 11877 12058 SUBROUTINE radiation_wrd_local 11878 12059 … … 12018 12199 12019 12200 12020 !------------------------------------------------------------------------------ --------------------!12201 !------------------------------------------------------------------------------! 12021 12202 ! Description: 12022 12203 ! ------------ 12023 12204 !> Read module-specific local restart data arrays (Fortran binary format). 12024 !------------------------------------------------------------------------------ --------------------!12025 SUBROUTINE radiation_rrd_local_ftn( k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, nxr_on_file, nynf,&12026 n ync, nyn_on_file, nysf, nysc, nys_on_file, tmp_2d, tmp_3d,&12027 found )12205 !------------------------------------------------------------------------------! 12206 SUBROUTINE radiation_rrd_local_ftn( k, nxlf, nxlc, nxl_on_file, nxrf, nxrc, & 12207 nxr_on_file, nynf, nync, nyn_on_file, nysf, & 12208 nysc, nys_on_file, tmp_2d, tmp_3d, found ) 12028 12209 12029 12210 … … 12039 12220 IMPLICIT NONE 12040 12221 12041 INTEGER(iwp) :: k !<12042 INTEGER(iwp) :: nxlc !<12043 INTEGER(iwp) :: nxlf !<12044 INTEGER(iwp) :: nxl_on_file !<12045 INTEGER(iwp) :: nxrc !<12046 INTEGER(iwp) :: nxrf !<12047 INTEGER(iwp) :: nxr_on_file !<12048 INTEGER(iwp) :: nync !<12049 INTEGER(iwp) :: nynf !<12050 INTEGER(iwp) :: nyn_on_file !<12051 INTEGER(iwp) :: nysc !<12052 INTEGER(iwp) :: nysf !<12053 INTEGER(iwp) :: nys_on_file !<12054 12055 LOGICAL, INTENT(OUT) :: found !<12056 12057 REAL(wp), DIMENSION(nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: 12058 12059 REAL(wp), DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: 12060 12061 REAL(wp), DIMENSION(0:0,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: 12222 INTEGER(iwp) :: k !< 12223 INTEGER(iwp) :: nxlc !< 12224 INTEGER(iwp) :: nxlf !< 12225 INTEGER(iwp) :: nxl_on_file !< 12226 INTEGER(iwp) :: nxrc !< 12227 INTEGER(iwp) :: nxrf !< 12228 INTEGER(iwp) :: nxr_on_file !< 12229 INTEGER(iwp) :: nync !< 12230 INTEGER(iwp) :: nynf !< 12231 INTEGER(iwp) :: nyn_on_file !< 12232 INTEGER(iwp) :: nysc !< 12233 INTEGER(iwp) :: nysf !< 12234 INTEGER(iwp) :: nys_on_file !< 12235 12236 LOGICAL, INTENT(OUT) :: found 12237 12238 REAL(wp), DIMENSION(nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_2d !< 12239 12240 REAL(wp), DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d !< 12241 12242 REAL(wp), DIMENSION(0:0,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp) :: tmp_3d2 !< 12062 12243 12063 12244 … … 12072 12253 ENDIF 12073 12254 IF ( k == 1 ) READ ( 13 ) tmp_2d 12074 rad_net_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&12075 tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12255 rad_net_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12256 tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12076 12257 12077 12258 CASE ( 'rad_lw_in_xy_av' ) … … 12080 12261 ENDIF 12081 12262 IF ( k == 1 ) READ ( 13 ) tmp_2d 12082 rad_lw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&12083 tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12263 rad_lw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12264 tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12084 12265 12085 12266 CASE ( 'rad_lw_out_xy_av' ) … … 12088 12269 ENDIF 12089 12270 IF ( k == 1 ) READ ( 13 ) tmp_2d 12090 rad_lw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&12091 tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12271 rad_lw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12272 tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12092 12273 12093 12274 CASE ( 'rad_sw_in_xy_av' ) … … 12096 12277 ENDIF 12097 12278 IF ( k == 1 ) READ ( 13 ) tmp_2d 12098 rad_sw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&12099 tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12279 rad_sw_in_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12280 tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12100 12281 12101 12282 CASE ( 'rad_sw_out_xy_av' ) … … 12104 12285 ENDIF 12105 12286 IF ( k == 1 ) READ ( 13 ) tmp_2d 12106 rad_sw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&12107 tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12287 rad_sw_out_xy_av(nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12288 tmp_2d(nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12108 12289 12109 12290 CASE ( 'rad_lw_in' ) 12110 12291 IF ( .NOT. ALLOCATED( rad_lw_in ) ) THEN 12111 IF ( radiation_scheme == 'clear-sky' .OR. 12112 radiation_scheme == 'constant' .OR. 12292 IF ( radiation_scheme == 'clear-sky' .OR. & 12293 radiation_scheme == 'constant' .OR. & 12113 12294 radiation_scheme == 'external' ) THEN 12114 12295 ALLOCATE( rad_lw_in(0:0,nysg:nyng,nxlg:nxrg) ) … … 12118 12299 ENDIF 12119 12300 IF ( k == 1 ) THEN 12120 IF ( radiation_scheme == 'clear-sky' .OR. 12121 radiation_scheme == 'constant' .OR. 12301 IF ( radiation_scheme == 'clear-sky' .OR. & 12302 radiation_scheme == 'constant' .OR. & 12122 12303 radiation_scheme == 'external' ) THEN 12123 12304 READ ( 13 ) tmp_3d2 12124 rad_lw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12305 rad_lw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12125 12306 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12126 12307 ELSE 12127 12308 READ ( 13 ) tmp_3d 12128 rad_lw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12309 rad_lw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12129 12310 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12130 12311 ENDIF … … 12133 12314 CASE ( 'rad_lw_in_av' ) 12134 12315 IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) THEN 12135 IF ( radiation_scheme == 'clear-sky' .OR. radiation_scheme == 'constant' .OR. & 12316 IF ( radiation_scheme == 'clear-sky' .OR. & 12317 radiation_scheme == 'constant' .OR. & 12136 12318 radiation_scheme == 'external' ) THEN 12137 12319 ALLOCATE( rad_lw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) … … 12141 12323 ENDIF 12142 12324 IF ( k == 1 ) THEN 12143 IF ( radiation_scheme == 'clear-sky' .OR. radiation_scheme == 'constant' .OR. & 12325 IF ( radiation_scheme == 'clear-sky' .OR. & 12326 radiation_scheme == 'constant' .OR. & 12144 12327 radiation_scheme == 'external' ) THEN 12145 12328 READ ( 13 ) tmp_3d2 12146 rad_lw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12329 rad_lw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& 12147 12330 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12148 12331 ELSE 12149 12332 READ ( 13 ) tmp_3d 12150 rad_lw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12333 rad_lw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12151 12334 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12152 12335 ENDIF … … 12155 12338 CASE ( 'rad_lw_out' ) 12156 12339 IF ( .NOT. ALLOCATED( rad_lw_out ) ) THEN 12157 IF ( radiation_scheme == 'clear-sky' .OR. radiation_scheme == 'constant' .OR. & 12340 IF ( radiation_scheme == 'clear-sky' .OR. & 12341 radiation_scheme == 'constant' .OR. & 12158 12342 radiation_scheme == 'external' ) THEN 12159 12343 ALLOCATE( rad_lw_out(0:0,nysg:nyng,nxlg:nxrg) ) … … 12163 12347 ENDIF 12164 12348 IF ( k == 1 ) THEN 12165 IF ( radiation_scheme == 'clear-sky' .OR. radiation_scheme == 'constant' .OR. & 12349 IF ( radiation_scheme == 'clear-sky' .OR. & 12350 radiation_scheme == 'constant' .OR. & 12166 12351 radiation_scheme == 'external' ) THEN 12167 12352 READ ( 13 ) tmp_3d2 12168 rad_lw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12353 rad_lw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12169 12354 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12170 12355 ELSE 12171 12356 READ ( 13 ) tmp_3d 12172 rad_lw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12357 rad_lw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12173 12358 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12174 12359 ENDIF … … 12177 12362 CASE ( 'rad_lw_out_av' ) 12178 12363 IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) THEN 12179 IF ( radiation_scheme == 'clear-sky' .OR. radiation_scheme == 'constant' .OR. & 12364 IF ( radiation_scheme == 'clear-sky' .OR. & 12365 radiation_scheme == 'constant' .OR. & 12180 12366 radiation_scheme == 'external' ) THEN 12181 12367 ALLOCATE( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) … … 12185 12371 ENDIF 12186 12372 IF ( k == 1 ) THEN 12187 IF ( radiation_scheme == 'clear-sky' .OR. radiation_scheme == 'constant' .OR. & 12373 IF ( radiation_scheme == 'clear-sky' .OR. & 12374 radiation_scheme == 'constant' .OR. & 12188 12375 radiation_scheme == 'external' ) THEN 12189 12376 READ ( 13 ) tmp_3d2 12190 rad_lw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&12191 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12377 rad_lw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) & 12378 = tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12192 12379 ELSE 12193 12380 READ ( 13 ) tmp_3d 12194 rad_lw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12381 rad_lw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12195 12382 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12196 12383 ENDIF … … 12202 12389 ENDIF 12203 12390 IF ( k == 1 ) READ ( 13 ) tmp_3d 12204 rad_lw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12205 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12391 rad_lw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12392 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12206 12393 12207 12394 CASE ( 'rad_lw_cs_hr_av' ) … … 12210 12397 ENDIF 12211 12398 IF ( k == 1 ) READ ( 13 ) tmp_3d 12212 rad_lw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12213 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12399 rad_lw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12400 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12214 12401 12215 12402 CASE ( 'rad_lw_hr' ) … … 12218 12405 ENDIF 12219 12406 IF ( k == 1 ) READ ( 13 ) tmp_3d 12220 rad_lw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12221 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12407 rad_lw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12408 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12222 12409 12223 12410 CASE ( 'rad_lw_hr_av' ) … … 12226 12413 ENDIF 12227 12414 IF ( k == 1 ) READ ( 13 ) tmp_3d 12228 rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12229 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12415 rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12416 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12230 12417 12231 12418 CASE ( 'rad_sw_in' ) 12232 12419 IF ( .NOT. ALLOCATED( rad_sw_in ) ) THEN 12233 IF ( radiation_scheme == 'clear-sky' .OR. radiation_scheme == 'constant' .OR. & 12420 IF ( radiation_scheme == 'clear-sky' .OR. & 12421 radiation_scheme == 'constant' .OR. & 12234 12422 radiation_scheme == 'external' ) THEN 12235 12423 ALLOCATE( rad_sw_in(0:0,nysg:nyng,nxlg:nxrg) ) … … 12239 12427 ENDIF 12240 12428 IF ( k == 1 ) THEN 12241 IF ( radiation_scheme == 'clear-sky' .OR. radiation_scheme == 'constant' .OR. & 12429 IF ( radiation_scheme == 'clear-sky' .OR. & 12430 radiation_scheme == 'constant' .OR. & 12242 12431 radiation_scheme == 'external' ) THEN 12243 12432 READ ( 13 ) tmp_3d2 12244 rad_sw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12433 rad_sw_in(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12245 12434 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12246 12435 ELSE 12247 12436 READ ( 13 ) tmp_3d 12248 rad_sw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12249 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12437 rad_sw_in(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12438 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12250 12439 ENDIF 12251 12440 ENDIF … … 12253 12442 CASE ( 'rad_sw_in_av' ) 12254 12443 IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) THEN 12255 IF ( radiation_scheme == 'clear-sky' .OR. radiation_scheme == 'constant' .OR. & 12444 IF ( radiation_scheme == 'clear-sky' .OR. & 12445 radiation_scheme == 'constant' .OR. & 12256 12446 radiation_scheme == 'external' ) THEN 12257 12447 ALLOCATE( rad_sw_in_av(0:0,nysg:nyng,nxlg:nxrg) ) … … 12261 12451 ENDIF 12262 12452 IF ( k == 1 ) THEN 12263 IF ( radiation_scheme == 'clear-sky' .OR. radiation_scheme == 'constant' .OR. & 12453 IF ( radiation_scheme == 'clear-sky' .OR. & 12454 radiation_scheme == 'constant' .OR. & 12264 12455 radiation_scheme == 'external' ) THEN 12265 12456 READ ( 13 ) tmp_3d2 12266 rad_sw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12267 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12457 rad_sw_in_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =& 12458 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12268 12459 ELSE 12269 12460 READ ( 13 ) tmp_3d 12270 rad_sw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12271 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12461 rad_sw_in_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12462 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12272 12463 ENDIF 12273 12464 ENDIF … … 12275 12466 CASE ( 'rad_sw_out' ) 12276 12467 IF ( .NOT. ALLOCATED( rad_sw_out ) ) THEN 12277 IF ( radiation_scheme == 'clear-sky' .OR. radiation_scheme == 'constant' .OR. & 12468 IF ( radiation_scheme == 'clear-sky' .OR. & 12469 radiation_scheme == 'constant' .OR. & 12278 12470 radiation_scheme == 'external' ) THEN 12279 12471 ALLOCATE( rad_sw_out(0:0,nysg:nyng,nxlg:nxrg) ) … … 12283 12475 ENDIF 12284 12476 IF ( k == 1 ) THEN 12285 IF ( radiation_scheme == 'clear-sky' .OR. radiation_scheme == 'constant' .OR. & 12477 IF ( radiation_scheme == 'clear-sky' .OR. & 12478 radiation_scheme == 'constant' .OR. & 12286 12479 radiation_scheme == 'external' ) THEN 12287 12480 READ ( 13 ) tmp_3d2 12288 rad_sw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12289 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12481 rad_sw_out(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12482 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12290 12483 ELSE 12291 12484 READ ( 13 ) tmp_3d 12292 rad_sw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12293 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12485 rad_sw_out(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12486 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12294 12487 ENDIF 12295 12488 ENDIF … … 12297 12490 CASE ( 'rad_sw_out_av' ) 12298 12491 IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) THEN 12299 IF ( radiation_scheme == 'clear-sky' .OR. radiation_scheme == 'constant' .OR. & 12492 IF ( radiation_scheme == 'clear-sky' .OR. & 12493 radiation_scheme == 'constant' .OR. & 12300 12494 radiation_scheme == 'external' ) THEN 12301 12495 ALLOCATE( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) … … 12305 12499 ENDIF 12306 12500 IF ( k == 1 ) THEN 12307 IF ( radiation_scheme == 'clear-sky' .OR. radiation_scheme == 'constant' .OR. & 12501 IF ( radiation_scheme == 'clear-sky' .OR. & 12502 radiation_scheme == 'constant' .OR. & 12308 12503 radiation_scheme == 'external' ) THEN 12309 12504 READ ( 13 ) tmp_3d2 12310 rad_sw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) =&12311 tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12505 rad_sw_out_av(0:0,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) & 12506 = tmp_3d2(0:0,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12312 12507 ELSE 12313 12508 READ ( 13 ) tmp_3d 12314 rad_sw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12315 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp)12509 rad_sw_out_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12510 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12316 12511 ENDIF 12317 12512 ENDIF … … 12322 12517 ENDIF 12323 12518 IF ( k == 1 ) READ ( 13 ) tmp_3d 12324 rad_sw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12519 rad_sw_cs_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12325 12520 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12326 12521 … … 12330 12525 ENDIF 12331 12526 IF ( k == 1 ) READ ( 13 ) tmp_3d 12332 rad_sw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12527 rad_sw_cs_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12333 12528 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12334 12529 … … 12338 12533 ENDIF 12339 12534 IF ( k == 1 ) READ ( 13 ) tmp_3d 12340 rad_sw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12535 rad_sw_hr(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12341 12536 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12342 12537 … … 12346 12541 ENDIF 12347 12542 IF ( k == 1 ) READ ( 13 ) tmp_3d 12348 rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = 12543 rad_lw_hr_av(:,nysc-nbgp:nync+nbgp,nxlc-nbgp:nxrc+nbgp) = & 12349 12544 tmp_3d(:,nysf-nbgp:nynf+nbgp,nxlf-nbgp:nxrf+nbgp) 12350 12545 … … 12358 12553 12359 12554 12360 !------------------------------------------------------------------------------ --------------------!12555 !------------------------------------------------------------------------------! 12361 12556 ! Description: 12362 12557 ! ------------ 12363 12558 !> Read module-specific local restart data arrays (MPI-IO). 12364 !------------------------------------------------------------------------------ --------------------!12559 !------------------------------------------------------------------------------! 12365 12560 SUBROUTINE radiation_rrd_local_mpi 12366 12561 … … 12374 12569 IMPLICIT NONE 12375 12570 12376 LOGICAL :: array_found !<12571 LOGICAL :: array_found !< 12377 12572 12378 12573 REAL(wp), DIMENSION(nysg:nyng,nxlg:nxrg) :: tmp !< temporary array for reading from file … … 12430 12625 rad_lw_in_av(0,:,:) = tmp 12431 12626 ELSE 12432 IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) & 12433 ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12627 IF ( .NOT. ALLOCATED( rad_lw_in_av ) ) ALLOCATE( rad_lw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12434 12628 CALL rrd_mpi_io( 'rad_lw_in_av', rad_lw_in_av ) 12435 12629 ENDIF … … 12444 12638 rad_lw_out(0,:,:) = tmp 12445 12639 ELSE 12446 IF ( .NOT. ALLOCATED( rad_lw_out ) ) & 12447 ALLOCATE( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12640 IF ( .NOT. ALLOCATED( rad_lw_out ) ) ALLOCATE( rad_lw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12448 12641 CALL rrd_mpi_io( 'rad_lw_out', rad_lw_out ) 12449 12642 ENDIF … … 12454 12647 IF ( radiation_scheme == 'clear-sky' .OR. radiation_scheme == 'constant' .OR. & 12455 12648 radiation_scheme == 'external' ) THEN 12456 IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) & 12457 ALLOCATE( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) 12649 IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) ALLOCATE( rad_lw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) 12458 12650 CALL rrd_mpi_io( 'rad_lw_out_av', tmp ) 12459 12651 rad_lw_out_av(0,:,:) = tmp 12460 12652 ELSE 12461 IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) & 12462 ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12653 IF ( .NOT. ALLOCATED( rad_lw_out_av ) ) ALLOCATE( rad_lw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12463 12654 CALL rrd_mpi_io( 'rad_lw_out_av', rad_lw_out_av ) 12464 12655 ENDIF … … 12467 12658 CALL rd_mpi_io_check_array( 'rad_lw_cs_hr' , found = array_found ) 12468 12659 IF ( array_found ) THEN 12469 IF ( .NOT. ALLOCATED( rad_lw_cs_hr ) ) & 12470 ALLOCATE( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12660 IF ( .NOT. ALLOCATED( rad_lw_cs_hr ) ) ALLOCATE( rad_lw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12471 12661 CALL rrd_mpi_io( 'rad_lw_cs_hr', rad_lw_cs_hr ) 12472 12662 ENDIF … … 12474 12664 CALL rd_mpi_io_check_array( 'rad_lw_cs_hr_av' , found = array_found ) 12475 12665 IF ( array_found ) THEN 12476 IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) & 12477 ALLOCATE( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12666 IF ( .NOT. ALLOCATED( rad_lw_cs_hr_av ) ) ALLOCATE( rad_lw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12478 12667 CALL rrd_mpi_io( 'rad_lw_cs_hr_av', rad_lw_cs_hr_av ) 12479 12668 ENDIF … … 12487 12676 CALL rd_mpi_io_check_array( 'rad_lw_hr_av' , found = array_found ) 12488 12677 IF ( array_found ) THEN 12489 IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) & 12490 ALLOCATE( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12678 IF ( .NOT. ALLOCATED( rad_lw_hr_av ) ) ALLOCATE( rad_lw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12491 12679 CALL rrd_mpi_io( 'rad_lw_hr_av', rad_lw_hr_av ) 12492 12680 ENDIF … … 12513 12701 rad_sw_in_av(0,:,:) = tmp 12514 12702 ELSE 12515 IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) & 12516 ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12703 IF ( .NOT. ALLOCATED( rad_sw_in_av ) ) ALLOCATE( rad_sw_in_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12517 12704 CALL rrd_mpi_io( 'rad_sw_in_av', rad_sw_in_av ) 12518 12705 ENDIF … … 12527 12714 rad_sw_out(0,:,:) = tmp 12528 12715 ELSE 12529 IF ( .NOT. ALLOCATED( rad_sw_out ) ) & 12530 ALLOCATE( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12716 IF ( .NOT. ALLOCATED( rad_sw_out ) ) ALLOCATE( rad_sw_out(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12531 12717 CALL rrd_mpi_io( 'rad_sw_out', rad_sw_out ) 12532 12718 ENDIF … … 12537 12723 IF ( radiation_scheme == 'clear-sky' .OR. radiation_scheme == 'constant' .OR. & 12538 12724 radiation_scheme == 'external' ) THEN 12539 IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) & 12540 ALLOCATE( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) 12725 IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) ALLOCATE( rad_sw_out_av(0:0,nysg:nyng,nxlg:nxrg) ) 12541 12726 CALL rrd_mpi_io( 'rad_sw_out_av', tmp ) 12542 12727 rad_sw_out_av(0,:,:) = tmp 12543 12728 ELSE 12544 IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) & 12545 ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12729 IF ( .NOT. ALLOCATED( rad_sw_out_av ) ) ALLOCATE( rad_sw_out_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12546 12730 CALL rrd_mpi_io( 'rad_sw_out_av', rad_sw_out_av ) 12547 12731 ENDIF … … 12550 12734 CALL rd_mpi_io_check_array( 'rad_sw_cs_hr' , found = array_found ) 12551 12735 IF ( array_found ) THEN 12552 IF ( .NOT. ALLOCATED( rad_sw_cs_hr ) ) & 12553 ALLOCATE( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12736 IF ( .NOT. ALLOCATED( rad_sw_cs_hr ) ) ALLOCATE( rad_sw_cs_hr(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12554 12737 CALL rrd_mpi_io( 'rad_sw_cs_hr', rad_sw_cs_hr ) 12555 12738 ENDIF … … 12557 12740 CALL rd_mpi_io_check_array( 'rad_sw_cs_hr_av' , found = array_found ) 12558 12741 IF ( array_found ) THEN 12559 IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) & 12560 ALLOCATE( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12742 IF ( .NOT. ALLOCATED( rad_sw_cs_hr_av ) ) ALLOCATE( rad_sw_cs_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12561 12743 CALL rrd_mpi_io( 'rad_sw_cs_hr_av', rad_sw_cs_hr_av ) 12562 12744 ENDIF … … 12570 12752 CALL rd_mpi_io_check_array( 'rad_sw_hr_av' , found = array_found ) 12571 12753 IF ( array_found ) THEN 12572 IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) & 12573 ALLOCATE( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12754 IF ( .NOT. ALLOCATED( rad_sw_hr_av ) ) ALLOCATE( rad_sw_hr_av(nzb:nzt+1,nysg:nyng,nxlg:nxrg) ) 12574 12755 CALL rrd_mpi_io( 'rad_sw_hr_av', rad_sw_hr_av ) 12575 12756 ENDIF
Note: See TracChangeset
for help on using the changeset viewer.
