Changeset 4753
- Timestamp:
- Oct 21, 2020 2:55:41 PM (5 years ago)
- Location:
- palm/trunk/SOURCE
- Files:
-
- 3 edited
-
module_interface.f90 (modified) (54 diffs)
-
modules.f90 (modified) (63 diffs)
-
multi_agent_system_mod.f90 (modified) (38 diffs)
Legend:
- Unmodified
- Added
- Removed
-
TabularUnified palm/trunk/SOURCE/module_interface.f90 ¶
r4731 r4753 1 1 !> @file module_interface.f90 2 !------------------------------------------------------------------------------! 3 ! This file is part of PALM. 4 ! 5 ! PALM is free software: you can redistribute it and/or modify it under the 6 ! terms of the GNU General Public License as published by the Free Software 7 ! Foundation, either version 3 of the License, or (at your option) any later 8 ! version. 9 ! 10 ! PALM is distributed in the hope that it will be useful, but WITHOUT ANY 11 ! WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR 12 ! A PARTICULAR PURPOSE. See the GNU General Public License for more details. 13 ! 14 ! You should have received a copy of the GNU General Public License along with 15 ! PALM. If not, see <http://www.gnu.org/licenses/>. 2 !--------------------------------------------------------------------------------------------------! 3 ! This file is part of the PALM model system. 4 ! 5 ! PALM is free software: you can redistribute it and/or modify it under the 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/>. 16 15 ! 17 16 ! Copyright 1997-2020 Leibniz Universitaet Hannover 18 !------------------------------------------------------------------------------ !17 !--------------------------------------------------------------------------------------------------! 19 18 ! 20 19 ! Current revisions: … … 25 24 ! ----------------- 26 25 ! $Id$ 26 ! file re-formatted to follow the PALM coding standard 27 ! 28 ! 4731 2020-10-07 13:25:11Z schwenkel 27 29 ! Move exchange_horiz from time_integration to modules 28 30 ! … … 32 34 ! 4590 2020-07-06 14:34:59Z suehring 33 35 ! Enable mpi-io for biomet 34 ! 36 ! 35 37 ! 4525 2020-05-10 17:05:07Z raasch 36 38 ! added restart I/O for global salsa data, 37 39 ! added restart with MPI-IO for salsa 38 ! 40 ! 39 41 ! 4518 2020-05-04 15:44:28Z suehring 40 42 ! Call of doq_rrd_local enabled 41 ! 43 ! 42 44 ! 4517 2020-05-03 14:29:30Z raasch 43 45 ! added restart with MPI-IO for reading local arrays 44 ! 46 ! 45 47 ! 4514 2020-04-30 16:29:59Z suehring 46 48 ! Added global restart routines for plant-canopy model 47 ! 49 ! 48 50 ! 4495 2020-04-13 20:11:20Z raasch 49 51 ! restart data handling with MPI-IO added 50 ! 52 ! 51 53 ! 4414 2020-02-19 20:16:04Z suehring 52 54 ! Add module interface for basic initialization of numerics. 53 ! 55 ! 54 56 ! 4411 2020-02-18 14:28:02Z maronga 55 57 ! Added output routines for WTM 56 ! 58 ! 57 59 ! 4407 2020-02-13 20:31:44Z knoop 58 60 ! Changed program_debug_output_unit to 9 in dom_init call 59 ! 61 ! 60 62 ! 4400 2020-02-10 20:32:41Z suehring 61 63 ! - Use data-output module for virtual measurement output 62 64 ! - Remove deprecated routines for virtual measurement module 63 ! 65 ! 64 66 ! 4361 2020-01-07 12:22:38Z suehring 65 67 ! Remove unused arrays in pmc_rrd_local 66 ! 68 ! 67 69 ! 4360 2020-01-07 11:25:50Z suehring 68 70 ! Add pcm_rrd_local and pcm_wrd_local 69 ! 71 ! 70 72 ! 4331 2019-12-10 18:25:02Z suehring 71 ! Change interface for doq_check_data_output, in order to perform further 72 ! output checks. 73 ! 73 ! Change interface for doq_check_data_output, in order to perform further output checks. 74 ! 74 75 ! 4281 2019-10-29 15:15:39Z schwenkel 75 76 ! Added dynamics boundary conditions 76 ! 77 ! 77 78 ! 4272 2019-10-23 15:18:57Z schwenkel 78 ! Further modularization of boundary conditions: moved boundary conditions to 79 ! respective modules 79 ! Further modularization of boundary conditions: moved boundary conditions to respective modules 80 80 ! 81 81 ! 4268 2019-10-17 11:29:38Z schwenkel 82 82 ! Introduction of module_interface_boundary_conditions 83 ! 83 ! 84 84 ! 4182 2019-08-22 15:20:23Z scharf 85 85 ! Corrected "Former revisions" section 86 ! 86 ! 87 87 ! 4173 2019-08-20 12:04:06Z gronemeier 88 88 ! add vdi_internal_controls 89 ! 89 ! 90 90 ! 4157 2019-08-14 09:19:12Z suehring 91 91 ! Call doq_init from module interface 92 ! 92 ! 93 93 ! 4132 2019-08-02 12:34:17Z suehring 94 94 ! Bugfix in masked data output for diagnostic quantities 95 ! 95 ! 96 96 ! 4131 2019-08-02 11:06:18Z monakurppa 97 97 ! Add output of 3D plant-canopy outputs (merge from branch resler) 98 ! 98 ! 99 99 ! 4048 2019-06-21 21:00:21Z knoop 100 100 ! Moved turbulence_closure_mod calls into this module_interface 101 ! 101 ! 102 102 ! 4047 2019-06-21 18:58:09Z knoop 103 103 ! Introduction of the dynamics module … … 110 110 ! 111 111 ! 4017 2019-06-06 12:16:46Z schwenkel 112 ! local_pf need INTENT(INOUT) attribute rather than INTENT(OUT). This is 113 ! because INTENT(OUT) sets the array to not-defined. Especially for outputs that 114 ! are not defined everywhere, e.g. land-surface outputs, this will be 115 ! problematic as NaN will be output. 112 ! local_pf need INTENT(INOUT) attribute rather than INTENT(OUT). This is because INTENT(OUT) sets 113 ! the array to not-defined. Especially for outputs that are not defined everywhere, e.g. 114 ! land-surface outputs, this will be problematic as NaN will be output. 116 115 ! 117 116 ! 3987 2019-05-22 09:52:13Z kanani … … 119 118 ! 120 119 ! 3956 2019-05-07 12:32:52Z monakurppa 121 ! - Added calls for salsa_non_advective_processes and 122 ! salsa_exchange_horiz_bounds 123 ! - Moved the call for salsa_data_output_2d/3d before that of 124 ! radiation_data_output_2d/3d. radiation_data_output_2d/3d tries to read a 125 ! salsa output variable and encounters a segmentation fault for "Ntot" due 126 ! to the shortoutput name 120 ! - Added calls for salsa_non_advective_processes and salsa_exchange_horiz_bounds 121 ! - Moved the call for salsa_data_output_2d/3d before that of radiation_data_output_2d/3d. 122 ! radiation_data_output_2d/3d tries to read a salsa output variable and encounters a segmentation 123 ! fault for "Ntot" due to the shortoutput name 127 124 ! 128 125 ! 3931 2019-04-24 16:34:28Z schwenkel … … 133 130 ! 134 131 ! 3887 2019 -04-12 08:47:41Z schwenkel 135 ! Changes related to global restructuring of location messages and introduction 136 ! of additional debugmessages132 ! Changes related to global restructuring of location messages and introduction of additional debug 133 ! messages 137 134 ! 138 135 ! 3880 2019 -04-08 21:43:02Z knoop … … 149 146 ! 150 147 ! 3766 2019-02-26 16:23:41Z raasch 151 ! first argument removed from module_interface_rrd_*, statement added to avoid 152 ! compiler warning about unused variable, file reformatted with respect to coding 153 ! standards 148 ! first argument removed from module_interface_rrd_*, statement added to avoid compiler warning 149 ! about unused variable, file reformatted with respect to coding standards 154 150 ! 155 151 ! 3762 2019-02-25 16:54:16Z suehring … … 166 162 ! 167 163 ! 3735 2019-02-12 09:52:40Z dom_dwd_user 168 ! Accepting variable j from check_parameters and passing it to 169 ! bio_check_data_output 164 ! Accepting variable j from check_parameters and passing it to bio_check_data_output 170 165 ! Add required restart data for surface output module 171 166 ! … … 189 184 ! 190 185 ! 3649 2019-01-02 16:52:21Z suehring 191 ! Initialize strings, in order to avoid compiler warnings for non-initialized 192 ! characters withintent(out) attribute186 ! Initialize strings, in order to avoid compiler warnings for non-initialized characters with 187 ! intent(out) attribute 193 188 ! 194 189 ! 3648 2019-01-02 16:35:46Z suehring … … 202 197 !> 203 198 !> @todo Re-format module to be consistent with coding standard 204 !------------------------------------------------------------------------------ !199 !--------------------------------------------------------------------------------------------------! 205 200 MODULE module_interface 206 201 207 USE indices, &202 USE indices, & 208 203 ONLY: nbgp, nxl, nxlg, nxr, nxrg, nys, nysg, nyn, nyng, nzb, nzt 209 204 210 205 USE kinds 211 206 212 USE pegrid, &207 USE pegrid, & 213 208 ONLY: comm2d 214 209 … … 216 211 !-- load module-specific control parameters. 217 212 !-- ToDo: move all of them to respective module or a dedicated central module 218 USE data_output_module, &219 ONLY: dom_def_end, &220 dom_finalize_output, &213 USE data_output_module, & 214 ONLY: dom_def_end, & 215 dom_finalize_output, & 221 216 dom_init 222 217 223 USE dynamics_mod, &224 ONLY: dynamics_ parin,&225 dynamics_ check_parameters,&226 dynamics_ check_data_output_ts,&227 dynamics_check_data_output _pr,&228 dynamics_check_data_output ,&229 dynamics_ init_masks,&230 dynamics_ define_netcdf_grid,&231 dynamics_ init_arrays,&232 dynamics_ init,&233 dynamics_ init_checks,&234 dynamics_ header,&235 dynamics_ actions,&236 dynamics_ non_advective_processes,&237 dynamics_ exchange_horiz,&238 dynamics_ prognostic_equations,&239 dynamics_ boundary_conditions,&240 dynamics_ swap_timelevel,&241 dynamics_ 3d_data_averaging,&242 dynamics_ data_output_2d,&243 dynamics_ data_output_3d,&244 dynamics_ statistics,&245 dynamics_rrd_ global,&246 dynamics_ rrd_local,&247 dynamics_ wrd_global,&248 dynamics_wrd_ local,&249 dynamics_ last_actions250 251 USE turbulence_closure_mod, &252 ONLY: tcm_ check_parameters,&253 tcm_ check_data_output,&254 tcm_ init_arrays,&255 tcm_ init,&256 tcm_ actions,&257 tcm_ prognostic_equations,&258 tcm_ boundary_conds,&259 tcm_ swap_timelevel,&260 tcm_ 3d_data_averaging,&261 tcm_ data_output_2d,&262 tcm_ data_output_3d263 264 USE control_parameters, &265 ONLY: air_chemistry, &266 biometeorology, &267 coupling_char, &268 debug_output, &269 debug_output_timestep, &270 indoor_model, &271 land_surface, &272 large_scale_forcing, &273 nesting_offline, &274 nudging, &275 ocean_mode, &276 plant_canopy, &277 salsa, &278 surface_output, &279 syn_turb_gen, &280 urban_surface, &281 vdi_checks, &282 virtual_flight, &283 virtual_measurement, &218 USE dynamics_mod, & 219 ONLY: dynamics_3d_data_averaging, & 220 dynamics_actions, & 221 dynamics_boundary_conditions, & 222 dynamics_check_data_output, & 223 dynamics_check_data_output_pr, & 224 dynamics_check_data_output_ts, & 225 dynamics_check_parameters, & 226 dynamics_data_output_2d, & 227 dynamics_data_output_3d, & 228 dynamics_define_netcdf_grid, & 229 dynamics_exchange_horiz, & 230 dynamics_header, & 231 dynamics_init, & 232 dynamics_init_arrays, & 233 dynamics_init_checks, & 234 dynamics_init_masks, & 235 dynamics_last_actions, & 236 dynamics_non_advective_processes, & 237 dynamics_parin, & 238 dynamics_prognostic_equations, & 239 dynamics_rrd_global, & 240 dynamics_rrd_local, & 241 dynamics_statistics, & 242 dynamics_swap_timelevel, & 243 dynamics_wrd_global, & 244 dynamics_wrd_local 245 246 USE turbulence_closure_mod, & 247 ONLY: tcm_3d_data_averaging, & 248 tcm_actions, & 249 tcm_boundary_conds, & 250 tcm_check_data_output, & 251 tcm_check_parameters, & 252 tcm_data_output_2d, & 253 tcm_data_output_3d, & 254 tcm_init, & 255 tcm_init_arrays, & 256 tcm_prognostic_equations, & 257 tcm_swap_timelevel 258 259 USE control_parameters, & 260 ONLY: air_chemistry, & 261 biometeorology, & 262 coupling_char, & 263 debug_output, & 264 debug_output_timestep, & 265 indoor_model, & 266 land_surface, & 267 large_scale_forcing, & 268 nesting_offline, & 269 nudging, & 270 ocean_mode, & 271 plant_canopy, & 272 salsa, & 273 surface_output, & 274 syn_turb_gen, & 275 urban_surface, & 276 vdi_checks, & 277 virtual_flight, & 278 virtual_measurement, & 284 279 wind_turbine 285 280 286 281 ! 287 !-- load interface routines of all PALM modules288 USE biometeorology_mod, &289 ONLY: bio_ parin,&290 bio_check_data_output, &291 bio_ init,&292 bio_ init_checks,&293 bio_ header,&294 bio_ 3d_data_averaging,&295 bio_ data_output_2d,&296 bio_ data_output_3d,&297 bio_rrd_global, &298 bio_rrd_local, &299 bio_wrd_global, &282 !-- Load interface routines of all PALM modules 283 USE biometeorology_mod, & 284 ONLY: bio_3d_data_averaging, & 285 bio_check_data_output, & 286 bio_data_output_2d, & 287 bio_data_output_3d, & 288 bio_init, & 289 bio_init_checks, & 290 bio_header, & 291 bio_parin, & 292 bio_rrd_global, & 293 bio_rrd_local, & 294 bio_wrd_global, & 300 295 bio_wrd_local 301 296 302 USE bulk_cloud_model_mod, &303 ONLY: b ulk_cloud_model,&304 bcm_ parin,&305 bcm_ check_parameters,&306 bcm_check_data_output_pr, &307 bcm_check_data_output, &308 bcm_ init_arrays,&309 bcm_ init,&310 bcm_ header,&311 bcm_ actions,&312 bcm_ non_advective_processes,&313 bcm_ exchange_horiz,&314 bcm_ prognostic_equations,&315 bcm_ boundary_conditions,&316 bcm_ swap_timelevel,&317 bcm_ 3d_data_averaging,&318 bcm_ data_output_2d,&319 bcm_ data_output_3d,&320 bcm_ rrd_global,&321 bcm_wrd_global, &322 bcm_ rrd_local,&323 b cm_wrd_local324 325 USE chemistry_model_mod, &326 ONLY: chem_ parin,&327 chem_ check_parameters,&328 chem_ check_data_output_pr,&329 chem_check_data_output, &330 chem_ exchange_horiz_bounds,&331 chem_ init_arrays,&332 chem_ init,&333 chem_ header,&334 chem_ actions,&335 chem_ non_advective_processes,&336 chem_ prognostic_equations,&337 chem_ boundary_conditions,&338 chem_ swap_timelevel,&339 chem_ 3d_data_averaging,&340 chem_ data_output_2d,&341 chem_ data_output_3d,&342 chem_statistics, &343 chem_ rrd_local,&297 USE bulk_cloud_model_mod, & 298 ONLY: bcm_3d_data_averaging, & 299 bcm_actions, & 300 bcm_boundary_conditions, & 301 bcm_check_data_output_pr, & 302 bcm_check_data_output, & 303 bcm_check_parameters, & 304 bcm_data_output_2d, & 305 bcm_data_output_3d, & 306 bcm_exchange_horiz, & 307 bcm_header, & 308 bcm_init_arrays, & 309 bcm_init, & 310 bcm_non_advective_processes, & 311 bcm_parin, & 312 bcm_prognostic_equations, & 313 bcm_rrd_global, & 314 bcm_rrd_local, & 315 bcm_swap_timelevel, & 316 bcm_wrd_global, & 317 bcm_wrd_local, & 318 bulk_cloud_model 319 320 USE chemistry_model_mod, & 321 ONLY: chem_3d_data_averaging, & 322 chem_actions, & 323 chem_boundary_conditions, & 324 chem_check_data_output, & 325 chem_check_data_output_pr, & 326 chem_check_parameters, & 327 chem_data_output_2d, & 328 chem_data_output_3d, & 329 chem_exchange_horiz_bounds, & 330 chem_header, & 331 chem_init, & 332 chem_init_arrays, & 333 chem_non_advective_processes, & 334 chem_parin, & 335 chem_prognostic_equations, & 336 chem_rrd_local, & 337 chem_statistics, & 338 chem_swap_timelevel, & 344 339 chem_wrd_local 345 340 346 USE diagnostic_output_quantities_mod, &347 ONLY: doq_3d_data_averaging, &348 doq_check_data_output, &349 doq_define_netcdf_grid, &350 doq_init, &351 doq_output_2d, &352 doq_output_3d, &353 doq_rrd_local, &341 USE diagnostic_output_quantities_mod, & 342 ONLY: doq_3d_data_averaging, & 343 doq_check_data_output, & 344 doq_define_netcdf_grid, & 345 doq_init, & 346 doq_output_2d, & 347 doq_output_3d, & 348 doq_rrd_local, & 354 349 doq_wrd_local 355 350 356 USE flight_mod, &357 ONLY: flight_ parin,&358 flight_ header,&359 flight_ init,&360 flight_rrd_global, &351 USE flight_mod, & 352 ONLY: flight_header, & 353 flight_init, & 354 flight_parin, & 355 flight_rrd_global, & 361 356 flight_wrd_global 362 357 363 USE gust_mod, &364 ONLY: gust_ module_enabled,&365 gust_ parin,&366 gust_check_parameters, &367 gust_check_data_output _pr,&368 gust_check_data_output ,&369 gust_ init_arrays,&370 gust_ init,&371 gust_header, &372 gust_ actions,&373 gust_ prognostic_equations,&374 gust_ swap_timelevel,&375 gust_ 3d_data_averaging,&376 gust_ data_output_2d,&377 gust_ data_output_3d,&378 gust_ statistics,&379 gust_ rrd_global,&380 gust_ wrd_global,&381 gust_ rrd_local,&358 USE gust_mod, & 359 ONLY: gust_3d_data_averaging, & 360 gust_actions, & 361 gust_check_parameters, & 362 gust_check_data_output, & 363 gust_check_data_output_pr, & 364 gust_data_output_2d, & 365 gust_data_output_3d, & 366 gust_header, & 367 gust_init, & 368 gust_init_arrays, & 369 gust_module_enabled, & 370 gust_parin, & 371 gust_prognostic_equations, & 372 gust_rrd_global, & 373 gust_rrd_local, & 374 gust_statistics, & 375 gust_swap_timelevel, & 376 gust_wrd_global, & 382 377 gust_wrd_local 383 378 384 USE indoor_model_mod, &385 ONLY: im_ parin,&386 im_check_ data_output,&387 im_ check_parameters,&388 im_ data_output_3d,&389 im_ init390 391 USE lagrangian_particle_model_mod, &392 ONLY: lpm_ parin,&393 lpm_ header,&394 lpm_ check_parameters,&395 lpm_ exchange_horiz_bounds,&396 lpm_init _arrays,&397 lpm_init ,&398 lpm_ actions,&399 lpm_rrd_global, &400 lpm_rrd_local, &401 lpm_wrd_local, &379 USE indoor_model_mod, & 380 ONLY: im_check_data_output, & 381 im_check_parameters, & 382 im_data_output_3d, & 383 im_init, & 384 im_parin 385 386 USE lagrangian_particle_model_mod, & 387 ONLY: lpm_actions, & 388 lpm_check_parameters, & 389 lpm_exchange_horiz_bounds, & 390 lpm_header, & 391 lpm_init, & 392 lpm_init_arrays, & 393 lpm_parin, & 394 lpm_rrd_global, & 395 lpm_rrd_local, & 396 lpm_wrd_local, & 402 397 lpm_wrd_global 403 398 404 USE land_surface_model_mod, &405 ONLY: lsm_ parin,&406 lsm_check_parameters, &407 lsm_check_data_output _pr,&408 lsm_check_data_output ,&409 lsm_ init_arrays,&410 lsm_ init,&411 lsm_ header,&412 lsm_ swap_timelevel,&413 lsm_ 3d_data_averaging,&414 lsm_ data_output_2d,&415 lsm_ rrd_local,&399 USE land_surface_model_mod, & 400 ONLY: lsm_3d_data_averaging, & 401 lsm_check_parameters, & 402 lsm_check_data_output, & 403 lsm_check_data_output_pr, & 404 lsm_data_output_2d, & 405 lsm_header, & 406 lsm_init, & 407 lsm_init_arrays, & 408 lsm_parin, & 409 lsm_rrd_local, & 410 lsm_swap_timelevel, & 416 411 lsm_wrd_local 417 412 418 USE lsf_nudging_mod, &419 ONLY: lsf_nudging_check_parameters, &420 lsf_nudging_check_data_output_pr, &421 lsf_ init,&422 nudge_init,&423 lsf_nudging_header424 425 USE multi_agent_system_mod, &413 USE lsf_nudging_mod, & 414 ONLY: lsf_nudging_check_parameters, & 415 lsf_nudging_check_data_output_pr, & 416 lsf_nudging_header, & 417 lsf_init, & 418 nudge_init 419 420 USE multi_agent_system_mod, & 426 421 ONLY: mas_parin 427 422 428 USE nesting_offl_mod, &429 ONLY: nesting_offl_ parin,&430 nesting_offl_ check_parameters,&431 nesting_offl_ header432 433 USE ocean_mod, &434 ONLY: ocean_ parin,&435 ocean_ check_parameters,&436 ocean_ check_data_output_pr,&437 ocean_check_ data_output,&438 ocean_ exchange_horiz,&439 ocean_ init_arrays,&440 ocean_ init,&441 ocean_ header,&442 ocean_ actions,&443 ocean_ prognostic_equations,&444 ocean_ boundary_conditions,&445 ocean_ swap_timelevel,&446 ocean_ 3d_data_averaging,&447 ocean_ data_output_2d,&448 ocean_ data_output_3d,&449 ocean_rrd_ global,&450 ocean_ wrd_global,&451 ocean_ rrd_local,&423 USE nesting_offl_mod, & 424 ONLY: nesting_offl_check_parameters, & 425 nesting_offl_header, & 426 nesting_offl_parin 427 428 USE ocean_mod, & 429 ONLY: ocean_3d_data_averaging, & 430 ocean_actions, & 431 ocean_boundary_conditions, & 432 ocean_check_parameters, & 433 ocean_check_data_output, & 434 ocean_check_data_output_pr, & 435 ocean_data_output_2d, & 436 ocean_data_output_3d, & 437 ocean_exchange_horiz, & 438 ocean_init_arrays, & 439 ocean_init, & 440 ocean_header, & 441 ocean_parin, & 442 ocean_prognostic_equations, & 443 ocean_rrd_global, & 444 ocean_rrd_local, & 445 ocean_swap_timelevel, & 446 ocean_wrd_global, & 452 447 ocean_wrd_local 453 448 454 USE particle_attributes, &449 USE particle_attributes, & 455 450 ONLY: particle_advection 456 451 457 USE poismg_noopt_mod, &452 USE poismg_noopt_mod, & 458 453 ONLY: poismg_noopt_init 459 454 460 USE plant_canopy_model_mod, &461 ONLY: pcm_ parin,&462 pcm_check_parameters, &463 pcm_check_data_output, &464 pcm_ init,&465 pcm_header, &466 pcm_ 3d_data_averaging,&467 pcm_ data_output_3d,&468 pcm_rrd_global, &469 pcm_rrd_local, &470 pcm_wrd_global, &455 USE plant_canopy_model_mod, & 456 ONLY: pcm_3d_data_averaging, & 457 pcm_check_parameters, & 458 pcm_check_data_output, & 459 pcm_data_output_3d, & 460 pcm_header, & 461 pcm_init, & 462 pcm_parin, & 463 pcm_rrd_global, & 464 pcm_rrd_local, & 465 pcm_wrd_global, & 471 466 pcm_wrd_local 472 467 473 USE radiation_model_mod, &474 ONLY: radiation, &475 radiation_ parin,&476 radiation_check_parameters, &477 radiation_check_data_output _ts,&478 radiation_check_data_output_pr, &479 radiation_check_data_output ,&480 radiation_ init,&481 radiation_ header,&482 radiation_ 3d_data_averaging,&483 radiation_ data_output_2d,&484 radiation_ data_output_3d,&485 radiation_rrd_local, &468 USE radiation_model_mod, & 469 ONLY: radiation, & 470 radiation_3d_data_averaging, & 471 radiation_check_parameters, & 472 radiation_check_data_output, & 473 radiation_check_data_output_pr, & 474 radiation_check_data_output_ts, & 475 radiation_data_output_2d, & 476 radiation_data_output_3d, & 477 radiation_header, & 478 radiation_init, & 479 radiation_parin, & 480 radiation_rrd_local, & 486 481 radiation_wrd_local 487 482 488 USE salsa_mod, &489 ONLY: salsa_ parin,&490 salsa_ check_parameters,&491 salsa_ check_data_output_pr,&492 salsa_check_data_output, &493 salsa_ init_arrays,&494 salsa_ init,&495 salsa_ header,&496 salsa_ actions,&497 salsa_ non_advective_processes,&498 salsa_ exchange_horiz_bounds,&499 salsa_ prognostic_equations,&500 salsa_ boundary_conditions,&501 salsa_ swap_timelevel,&502 salsa_ 3d_data_averaging,&503 salsa_ data_output_2d,&504 salsa_ data_output_3d,&505 salsa_ statistics,&506 salsa_ rrd_global,&507 salsa_ rrd_local,&508 salsa_wrd_global, &483 USE salsa_mod, & 484 ONLY: salsa_3d_data_averaging, & 485 salsa_actions, & 486 salsa_boundary_conditions, & 487 salsa_check_data_output, & 488 salsa_check_data_output_pr, & 489 salsa_check_parameters, & 490 salsa_data_output_2d, & 491 salsa_data_output_3d, & 492 salsa_exchange_horiz_bounds, & 493 salsa_header, & 494 salsa_init, & 495 salsa_init_arrays, & 496 salsa_non_advective_processes, & 497 salsa_parin, & 498 salsa_prognostic_equations, & 499 salsa_rrd_global, & 500 salsa_rrd_local, & 501 salsa_statistics, & 502 salsa_swap_timelevel, & 503 salsa_wrd_global, & 509 504 salsa_wrd_local 510 505 511 USE spectra_mod, &512 ONLY: calculate_spectra, &513 spectra_ parin,&514 spectra_ check_parameters,&515 spectra_ header516 517 USE surface_data_output_mod, &518 ONLY: surface_data_output_ parin,&519 surface_data_output_ check_parameters,&520 surface_data_output_ init_arrays,&521 surface_data_output_rrd_ local,&522 surface_data_output_rrd_ global,&523 surface_data_output_wrd_ local,&524 surface_data_output_wrd_ global525 526 USE surface_mod, &506 USE spectra_mod, & 507 ONLY: calculate_spectra, & 508 spectra_check_parameters, & 509 spectra_header, & 510 spectra_parin 511 512 USE surface_data_output_mod, & 513 ONLY: surface_data_output_check_parameters, & 514 surface_data_output_init_arrays, & 515 surface_data_output_parin, & 516 surface_data_output_rrd_global, & 517 surface_data_output_rrd_local, & 518 surface_data_output_wrd_global, & 519 surface_data_output_wrd_local 520 521 USE surface_mod, & 527 522 ONLY: init_bc 528 523 529 USE synthetic_turbulence_generator_mod, &530 ONLY: stg_ parin,&531 stg_ check_parameters,&532 stg_ header,&533 stg_rrd_global, &524 USE synthetic_turbulence_generator_mod, & 525 ONLY: stg_check_parameters, & 526 stg_header, & 527 stg_parin, & 528 stg_rrd_global, & 534 529 stg_wrd_global 535 530 536 USE urban_surface_mod, &537 ONLY: usm_ parin,&538 usm_check_ parameters,&539 usm_check_ data_output,&540 usm_init _arrays,&541 usm_init ,&542 usm_ swap_timelevel,&543 usm_ 3d_data_averaging,&544 usm_rrd_local, &531 USE urban_surface_mod, & 532 ONLY: usm_3d_data_averaging, & 533 usm_check_data_output, & 534 usm_check_parameters, & 535 usm_init, & 536 usm_init_arrays, & 537 usm_parin, & 538 usm_swap_timelevel, & 539 usm_rrd_local, & 545 540 usm_wrd_local 546 541 547 USE vdi_internal_controls, &542 USE vdi_internal_controls, & 548 543 ONLY: vdi_actions 549 550 USE virtual_measurement_mod, &551 ONLY: vm_check_parameters, &552 vm_init, &553 vm_init_output, &544 545 USE virtual_measurement_mod, & 546 ONLY: vm_check_parameters, & 547 vm_init, & 548 vm_init_output, & 554 549 vm_parin 555 550 556 USE wind_turbine_model_mod, &557 ONLY: wtm_ parin,&558 wtm_check_parameters, &559 wtm_init, &560 wtm_init_arrays, &561 wtm_init_output, &562 wtm_ actions,&563 wtm_rrd_global, &551 USE wind_turbine_model_mod, & 552 ONLY: wtm_actions, & 553 wtm_check_parameters, & 554 wtm_init, & 555 wtm_init_arrays, & 556 wtm_init_output, & 557 wtm_parin, & 558 wtm_rrd_global, & 564 559 wtm_wrd_global 565 560 566 USE user, &567 ONLY: user_ module_enabled,&568 user_ parin,&569 user_check_ parameters,&570 user_check_data_output_ ts,&571 user_check_data_output_ pr,&572 user_check_ data_output,&573 user_ init,&574 user_ init_arrays,&575 user_header, &576 user_ actions,&577 user_ 3d_data_averaging,&578 user_ data_output_2d,&579 user_ data_output_3d,&580 user_ statistics,&581 user_ rrd_global,&582 user_rrd_ local,&583 user_ wrd_global,&584 user_wrd_ local,&585 user_ last_actions561 USE user, & 562 ONLY: user_3d_data_averaging, & 563 user_actions, & 564 user_check_data_output, & 565 user_check_data_output_pr, & 566 user_check_data_output_ts, & 567 user_check_parameters, & 568 user_data_output_2d, & 569 user_data_output_3d, & 570 user_header, & 571 user_init, & 572 user_init_arrays, & 573 user_last_actions, & 574 user_module_enabled, & 575 user_parin, & 576 user_statistics, & 577 user_rrd_global, & 578 user_rrd_local, & 579 user_wrd_global, & 580 user_wrd_local 586 581 587 582 IMPLICIT NONE … … 591 586 ! 592 587 !-- Public functions 593 PUBLIC &594 module_interface_parin, &595 module_interface_check_parameters, &596 module_interface_check_data_output_ts, &597 module_interface_check_data_output_pr, &598 module_interface_check_data_output, &599 module_interface_init_masks, &600 module_interface_define_netcdf_grid, &601 module_interface_init_arrays, &602 module_interface_init, &603 module_interface_init_checks, &604 module_interface_init_numerics, &605 module_interface_init_output, &606 module_interface_header, &607 module_interface_actions, &608 module_interface_non_advective_processes, &609 module_interface_exchange_horiz, &610 module_interface_prognostic_equations, &611 module_interface_boundary_conditions, &612 module_interface_swap_timelevel, &613 module_interface_3d_data_averaging, &614 module_interface_data_output_2d, &615 module_interface_data_output_3d, &616 module_interface_statistics, &617 module_interface_rrd_global, &618 module_interface_wrd_global, &619 module_interface_rrd_local, &620 module_interface_wrd_local, &588 PUBLIC & 589 module_interface_parin, & 590 module_interface_check_parameters, & 591 module_interface_check_data_output_ts, & 592 module_interface_check_data_output_pr, & 593 module_interface_check_data_output, & 594 module_interface_init_masks, & 595 module_interface_define_netcdf_grid, & 596 module_interface_init_arrays, & 597 module_interface_init, & 598 module_interface_init_checks, & 599 module_interface_init_numerics, & 600 module_interface_init_output, & 601 module_interface_header, & 602 module_interface_actions, & 603 module_interface_non_advective_processes, & 604 module_interface_exchange_horiz, & 605 module_interface_prognostic_equations, & 606 module_interface_boundary_conditions, & 607 module_interface_swap_timelevel, & 608 module_interface_3d_data_averaging, & 609 module_interface_data_output_2d, & 610 module_interface_data_output_3d, & 611 module_interface_statistics, & 612 module_interface_rrd_global, & 613 module_interface_wrd_global, & 614 module_interface_rrd_local, & 615 module_interface_wrd_local, & 621 616 module_interface_last_actions 622 617 … … 743 738 744 739 745 !------------------------------------------------------------------------------ !740 !--------------------------------------------------------------------------------------------------! 746 741 ! Description: 747 742 ! ------------ 748 743 !> Read module-specific parameter namelists 749 !------------------------------------------------------------------------------ !744 !------------------------------------------------------------------------------ ! 750 745 SUBROUTINE module_interface_parin 751 746 … … 785 780 786 781 787 !------------------------------------------------------------------------------ !782 !--------------------------------------------------------------------------------------------------! 788 783 ! Description: 789 784 ! ------------ 790 785 !> Perform module-specific initialization checks 791 !------------------------------------------------------------------------------ !786 !--------------------------------------------------------------------------------------------------! 792 787 SUBROUTINE module_interface_check_parameters 793 788 … … 825 820 826 821 827 !------------------------------------------------------------------------------ !822 !--------------------------------------------------------------------------------------------------! 828 823 ! Description: 829 824 ! ------------ 830 825 !> Check module-specific data output of timeseries 831 !------------------------------------------------------------------------------ !826 !--------------------------------------------------------------------------------------------------! 832 827 SUBROUTINE module_interface_check_data_output_ts( dots_max, dots_num, dots_label, dots_unit ) 833 828 834 835 INTEGER(iwp), INTENT(IN) :: dots_max !< variable output array index 829 INTEGER(iwp), INTENT(IN) :: dots_max !< variable output array index 836 830 INTEGER(iwp), INTENT(INOUT) :: dots_num !< variable output array index 831 837 832 CHARACTER (LEN=*), DIMENSION(dots_max), INTENT(INOUT) :: dots_label 838 833 CHARACTER (LEN=*), DIMENSION(dots_max), INTENT(INOUT) :: dots_unit … … 857 852 858 853 859 !------------------------------------------------------------------------------ !854 !--------------------------------------------------------------------------------------------------! 860 855 ! Description: 861 856 ! ------------ 862 857 !> Check module-specific data output of profiles 863 !------------------------------------------------------------------------------! 864 SUBROUTINE module_interface_check_data_output_pr( variable, var_count, unit, & 865 dopr_unit ) 858 !--------------------------------------------------------------------------------------------------! 859 SUBROUTINE module_interface_check_data_output_pr( variable, var_count, unit, dopr_unit ) 866 860 867 861 868 862 CHARACTER (LEN=*), INTENT(IN) :: variable !< variable name 869 INTEGER(iwp), INTENT(IN) :: var_count !< variable output array index870 863 CHARACTER (LEN=*), INTENT(INOUT) :: unit !< physical unit of variable 871 864 CHARACTER (LEN=*), INTENT(OUT) :: dopr_unit !< local value of dopr_unit 872 865 866 INTEGER(iwp), INTENT(IN) :: var_count !< variable output array index 867 873 868 874 869 IF ( debug_output ) CALL debug_message( 'checking module-specific data output pr', 'start' ) … … 876 871 CALL dynamics_check_data_output_pr( variable, var_count, unit, dopr_unit ) 877 872 878 IF ( unit == 'illegal' .AND. bulk_cloud_model ) THEN873 IF ( unit == 'illegal' .AND. bulk_cloud_model ) THEN 879 874 CALL bcm_check_data_output_pr( variable, var_count, unit, dopr_unit ) 880 875 ENDIF 881 876 882 IF ( unit == 'illegal' .AND. air_chemistry ) THEN877 IF ( unit == 'illegal' .AND. air_chemistry ) THEN 883 878 CALL chem_check_data_output_pr( variable, var_count, unit, dopr_unit ) 884 879 ENDIF … … 918 913 END SUBROUTINE module_interface_check_data_output_pr 919 914 920 !------------------------------------------------------------------------------ !915 !--------------------------------------------------------------------------------------------------! 921 916 ! Description: 922 917 ! ------------ 923 918 !> Check module-specific 2D and 3D data output 924 !------------------------------------------------------------------------------ !919 !--------------------------------------------------------------------------------------------------! 925 920 SUBROUTINE module_interface_check_data_output( variable, unit, i, j, ilen, k ) 926 921 … … 949 944 ENDIF 950 945 951 IF ( unit == 'illegal' .AND. air_chemistry 952 .AND. (variable(1:3) == 'kc_' .OR.variable(1:3) == 'em_') ) THEN ! ToDo: remove aditional conditions946 IF ( unit == 'illegal' .AND. air_chemistry .AND. (variable(1:3) == 'kc_' .OR. & 947 variable(1:3) == 'em_') ) THEN ! ToDo: remove aditional conditions 953 948 CALL chem_check_data_output( variable, unit, i, ilen, k ) 954 949 ENDIF … … 970 965 ENDIF 971 966 972 IF ( unit == 'illegal' .AND. plant_canopy & 973 .AND. variable(1:4) == 'pcm_' ) THEN ! ToDo: remove aditional conditions 967 IF ( unit == 'illegal' .AND. plant_canopy .AND. variable(1:4) == 'pcm_' ) THEN ! ToDo: remove aditional conditions 974 968 CALL pcm_check_data_output( variable, unit ) 975 969 ENDIF … … 987 981 ENDIF 988 982 989 IF ( unit == 'illegal' .AND. urban_surface & 990 .AND. variable(1:4) == 'usm_' ) THEN ! ToDo: remove aditional conditions 983 IF ( unit == 'illegal' .AND. urban_surface .AND. variable(1:4) == 'usm_' ) THEN ! ToDo: remove aditional conditions 991 984 CALL usm_check_data_output( variable, unit ) 992 985 ENDIF … … 1003 996 1004 997 1005 !------------------------------------------------------------------------------ !998 !--------------------------------------------------------------------------------------------------! 1006 999 ! 1007 1000 ! Description: 1008 1001 ! ------------ 1009 1002 !> Interface for init_masks. ToDo: get rid of these redundant calls! 1010 !------------------------------------------------------------------------------ !1003 !--------------------------------------------------------------------------------------------------! 1011 1004 SUBROUTINE module_interface_init_masks( variable, unit ) 1012 1005 … … 1020 1013 CALL dynamics_init_masks( variable, unit ) 1021 1014 1022 IF ( unit == 'illegal' .AND. air_chemistry 1023 .AND. (variable(1:3) == 'kc_' .OR.variable(1:3) == 'em_') ) THEN ! ToDo: remove aditional conditions1015 IF ( unit == 'illegal' .AND. air_chemistry .AND. (variable(1:3) == 'kc_' .OR. & 1016 variable(1:3) == 'em_') ) THEN ! ToDo: remove aditional conditions 1024 1017 CALL chem_check_data_output( variable, unit, 0, 0, 0 ) 1025 1018 ENDIF 1026 1019 1027 1020 IF ( unit == 'illegal' ) THEN 1028 1021 CALL doq_check_data_output( variable, unit ) … … 1048 1041 1049 1042 1050 !------------------------------------------------------------------------------ !1043 !--------------------------------------------------------------------------------------------------! 1051 1044 ! 1052 1045 ! Description: 1053 1046 ! ------------ 1054 1047 !> Define appropriate grid for module-specific netcdf output variables. 1055 !------------------------------------------------------------------------------! 1056 SUBROUTINE module_interface_define_netcdf_grid( var, found, & 1057 grid_x, grid_y, grid_z ) 1048 !--------------------------------------------------------------------------------------------------! 1049 SUBROUTINE module_interface_define_netcdf_grid( var, found, grid_x, grid_y, grid_z ) 1058 1050 1059 1051 1060 1052 CHARACTER (LEN=*), INTENT(IN) :: var !< variable name 1061 LOGICAL, INTENT(OUT) :: found !< indicates if variable was found1062 1053 CHARACTER (LEN=*), INTENT(OUT) :: grid_x !< netcdf dimension in x-direction 1063 1054 CHARACTER (LEN=*), INTENT(OUT) :: grid_y !< netcdf dimension in y-direction 1064 1055 CHARACTER (LEN=*), INTENT(OUT) :: grid_z !< netcdf dimension in z-direction 1065 1056 1057 LOGICAL, INTENT(OUT) :: found !< indicates if variable was found 1058 1066 1059 1067 1060 IF ( debug_output ) CALL debug_message( 'defining module-specific netcdf grids', 'start' ) 1068 1061 ! 1069 !-- As long as no action is done in this subroutine, initialize strings with 1070 !-- in tent(out) attribute, inorder to avoid compiler warnings.1062 !-- As long as no action is done in this subroutine, initialize strings with intent(out) attribute, 1063 !-- in order to avoid compiler warnings. 1071 1064 found = .FALSE. 1072 1065 grid_x = 'none' … … 1083 1076 1084 1077 1085 !------------------------------------------------------------------------------ !1078 !--------------------------------------------------------------------------------------------------! 1086 1079 ! Description: 1087 1080 ! ------------ 1088 1081 !> Allocate module-specific arrays and pointers 1089 !------------------------------------------------------------------------------ !1082 !--------------------------------------------------------------------------------------------------! 1090 1083 SUBROUTINE module_interface_init_arrays 1091 1084 … … 1115 1108 1116 1109 1117 !------------------------------------------------------------------------------ !1110 !--------------------------------------------------------------------------------------------------! 1118 1111 ! Description: 1119 1112 ! ------------ 1120 1113 !> Perform module-specific initialization 1121 !------------------------------------------------------------------------------ !1114 !--------------------------------------------------------------------------------------------------! 1122 1115 SUBROUTINE module_interface_init 1123 1116 … … 1154 1147 END SUBROUTINE module_interface_init 1155 1148 1156 !------------------------------------------------------------------------------ !1149 !--------------------------------------------------------------------------------------------------! 1157 1150 ! Description: 1158 1151 ! ------------ 1159 1152 !> Initialize boundary conditions and numerical schemes. 1160 !------------------------------------------------------------------------------ !1153 !--------------------------------------------------------------------------------------------------! 1161 1154 SUBROUTINE module_interface_init_numerics 1162 1155 … … 1168 1161 !-- Please note, wall flags are only applied in the non-optimized version. 1169 1162 CALL poismg_noopt_init 1170 1163 1171 1164 END SUBROUTINE module_interface_init_numerics 1172 1165 1173 1174 !------------------------------------------------------------------------------ !1166 1167 !--------------------------------------------------------------------------------------------------! 1175 1168 ! Description: 1176 1169 ! ------------ 1177 1170 !> Initialize data output 1178 !------------------------------------------------------------------------------ !1171 !--------------------------------------------------------------------------------------------------! 1179 1172 SUBROUTINE module_interface_init_output 1180 1173 … … 1183 1176 ! 1184 1177 !-- Initialize data-output module 1185 CALL dom_init( file_suffix_of_output_group=coupling_char, &1186 mpi_comm_of_output_group=comm2d, &1187 program_debug_output_unit=9, &1178 CALL dom_init( file_suffix_of_output_group=coupling_char, & 1179 mpi_comm_of_output_group=comm2d, & 1180 program_debug_output_unit=9, & 1188 1181 debug_output=debug_output ) 1189 1182 ! … … 1197 1190 END SUBROUTINE module_interface_init_output 1198 1191 1199 !------------------------------------------------------------------------------ !1192 !--------------------------------------------------------------------------------------------------! 1200 1193 ! Description: 1201 1194 ! ------------ 1202 1195 !> Perform module-specific post-initialization checks 1203 !------------------------------------------------------------------------------ !1196 !--------------------------------------------------------------------------------------------------! 1204 1197 SUBROUTINE module_interface_init_checks 1205 1198 … … 1209 1202 CALL dynamics_init_checks 1210 1203 1211 IF ( biometeorology 1204 IF ( biometeorology ) CALL bio_init_checks 1212 1205 1213 1206 IF ( debug_output ) CALL debug_message( 'module-specific post-initialization checks', 'end' ) … … 1217 1210 1218 1211 1219 !------------------------------------------------------------------------------ !1212 !--------------------------------------------------------------------------------------------------! 1220 1213 ! Description: 1221 1214 ! ------------ 1222 1215 !> Gather module-specific header output 1223 !------------------------------------------------------------------------------ !1216 !--------------------------------------------------------------------------------------------------! 1224 1217 SUBROUTINE module_interface_header( io ) 1225 1218 … … 1256 1249 1257 1250 1258 !------------------------------------------------------------------------------ !1251 !--------------------------------------------------------------------------------------------------! 1259 1252 ! Description: 1260 1253 ! ------------ 1261 1254 !> Perform module-specific actions while in time-integration (vector-optimized) 1262 !------------------------------------------------------------------------------ !1255 !--------------------------------------------------------------------------------------------------! 1263 1256 SUBROUTINE module_interface_actions( location ) 1264 1257 … … 1284 1277 1285 1278 1286 !------------------------------------------------------------------------------ !1279 !--------------------------------------------------------------------------------------------------! 1287 1280 ! Description: 1288 1281 ! ------------ 1289 1282 !> Perform module-specific actions while in time-integration (cache-optimized) 1290 !------------------------------------------------------------------------------ !1283 !--------------------------------------------------------------------------------------------------! 1291 1284 SUBROUTINE module_interface_actions_ij( i, j, location ) 1292 1285 1286 CHARACTER (LEN=*), INTENT(IN) :: location !< call location string 1293 1287 1294 1288 INTEGER(iwp), INTENT(IN) :: i !< grid index in x-direction 1295 1289 INTEGER(iwp), INTENT(IN) :: j !< grid index in y-direction 1296 CHARACTER (LEN=*), INTENT(IN) :: location !< call location string1297 1290 1298 1291 CALL dynamics_actions( i, j, location ) … … 1312 1305 1313 1306 1314 !------------------------------------------------------------------------------ !1307 !--------------------------------------------------------------------------------------------------! 1315 1308 ! Description: 1316 1309 ! ------------ 1317 1310 !> Compute module-specific non_advective_processes (vector-optimized) 1318 !------------------------------------------------------------------------------ !1311 !--------------------------------------------------------------------------------------------------! 1319 1312 SUBROUTINE module_interface_non_advective_processes 1320 1313 … … 1330 1323 1331 1324 1332 !------------------------------------------------------------------------------ !1325 !--------------------------------------------------------------------------------------------------! 1333 1326 ! Description: 1334 1327 ! ------------ 1335 1328 !> Compute module-specific non_advective_processes (cache-optimized) 1336 !------------------------------------------------------------------------------ !1329 !--------------------------------------------------------------------------------------------------! 1337 1330 SUBROUTINE module_interface_non_advective_processes_ij( i, j ) 1338 1331 … … 1350 1343 END SUBROUTINE module_interface_non_advective_processes_ij 1351 1344 1352 !------------------------------------------------------------------------------ !1345 !--------------------------------------------------------------------------------------------------! 1353 1346 ! Description: 1354 1347 ! ------------ 1355 1348 !> Exchange horiz for module-specific quantities 1356 !------------------------------------------------------------------------------ !1349 !--------------------------------------------------------------------------------------------------! 1357 1350 SUBROUTINE module_interface_exchange_horiz( location ) 1358 1351 1359 1352 CHARACTER (LEN=*), INTENT(IN) :: location !< call location string 1353 1360 1354 1361 1355 IF ( debug_output_timestep ) CALL debug_message( 'module-specific exchange_horiz', 'start' ) … … 1366 1360 IF ( air_chemistry ) CALL chem_exchange_horiz_bounds( location ) 1367 1361 IF ( ocean_mode ) CALL ocean_exchange_horiz( location ) 1368 IF ( particle_advection ) CALL lpm_exchange_horiz_bounds 1362 IF ( particle_advection ) CALL lpm_exchange_horiz_bounds( location ) 1369 1363 IF ( salsa ) CALL salsa_exchange_horiz_bounds( location ) 1370 1364 … … 1375 1369 1376 1370 1377 !------------------------------------------------------------------------------ !1371 !--------------------------------------------------------------------------------------------------! 1378 1372 ! Description: 1379 1373 ! ------------ 1380 1374 !> Compute module-specific prognostic_equations (vector-optimized) 1381 !------------------------------------------------------------------------------ !1375 !--------------------------------------------------------------------------------------------------! 1382 1376 SUBROUTINE module_interface_prognostic_equations 1383 1377 … … 1396 1390 1397 1391 1398 !------------------------------------------------------------------------------ !1392 !--------------------------------------------------------------------------------------------------! 1399 1393 ! Description: 1400 1394 ! ------------ 1401 1395 !> Compute module-specific prognostic_equations (cache-optimized) 1402 !------------------------------------------------------------------------------ !1396 !--------------------------------------------------------------------------------------------------! 1403 1397 SUBROUTINE module_interface_prognostic_equations_ij( i, j, i_omp_start, tn ) 1404 1398 … … 1421 1415 END SUBROUTINE module_interface_prognostic_equations_ij 1422 1416 1423 !------------------------------------------------------------------------------ !1417 !--------------------------------------------------------------------------------------------------! 1424 1418 ! Description: 1425 1419 ! ------------ 1426 1420 !> Compute module-specific boundary conditions 1427 !------------------------------------------------------------------------------ !1421 !--------------------------------------------------------------------------------------------------! 1428 1422 SUBROUTINE module_interface_boundary_conditions 1429 1423 … … 1444 1438 END SUBROUTINE module_interface_boundary_conditions 1445 1439 1446 !------------------------------------------------------------------------------ !1440 !--------------------------------------------------------------------------------------------------! 1447 1441 ! Description: 1448 1442 ! ------------ 1449 1443 !> Swap the timelevel pointers for module-specific arrays 1450 !------------------------------------------------------------------------------ !1444 !--------------------------------------------------------------------------------------------------! 1451 1445 SUBROUTINE module_interface_swap_timelevel ( swap_mode ) 1452 1446 … … 1474 1468 1475 1469 1476 !------------------------------------------------------------------------------ !1470 !--------------------------------------------------------------------------------------------------! 1477 1471 ! 1478 1472 ! Description: 1479 1473 ! ------------ 1480 1474 !> Perform module-specific averaging of 3D data 1481 !------------------------------------------------------------------------------ !1475 !--------------------------------------------------------------------------------------------------! 1482 1476 SUBROUTINE module_interface_3d_data_averaging( mode, variable ) 1483 1477 … … 1511 1505 END SUBROUTINE module_interface_3d_data_averaging 1512 1506 1513 !------------------------------------------------------------------------------ !1507 !--------------------------------------------------------------------------------------------------! 1514 1508 ! 1515 1509 ! Description: 1516 1510 ! ------------ 1517 1511 !> Define module-specific 2D output variables 1518 !------------------------------------------------------------------------------! 1519 SUBROUTINE module_interface_data_output_2d( av, variable, found, grid, mode, & 1520 local_pf, two_d, nzb_do, nzt_do, & 1521 fill_value ) 1512 !--------------------------------------------------------------------------------------------------! 1513 SUBROUTINE module_interface_data_output_2d( av, variable, found, grid, mode, local_pf, two_d, & 1514 nzb_do, nzt_do, fill_value ) 1515 1516 CHARACTER (LEN=*), INTENT(IN) :: mode !< either 'xy', 'xz' or 'yz' 1517 CHARACTER (LEN=*), INTENT(IN) :: variable !< variable name 1518 CHARACTER (LEN=*), INTENT(INOUT) :: grid !< name of vertical grid 1522 1519 1523 1520 INTEGER(iwp), INTENT(IN) :: av !< flag for (non-)average output 1524 CHARACTER (LEN=*), INTENT(IN) :: variable !< variable name1525 LOGICAL, INTENT(INOUT) :: found !< flag if output variable is found1526 CHARACTER (LEN=*), INTENT(INOUT) :: grid !< name of vertical grid1527 CHARACTER (LEN=*), INTENT(IN) :: mode !< either 'xy', 'xz' or 'yz'1528 LOGICAL, INTENT(OUT) :: two_d !< flag for 2D variables1529 1521 INTEGER(iwp), INTENT(IN) :: nzb_do !< vertical output index (bottom) (usually 0) 1530 1522 INTEGER(iwp), INTENT(IN) :: nzt_do !< vertical output index (top) (usually nz_do3d) 1523 1524 LOGICAL, INTENT(INOUT) :: found !< flag if output variable is found 1525 LOGICAL, INTENT(OUT) :: two_d !< flag for 2D variables 1526 1531 1527 REAL(wp), INTENT(IN) :: fill_value !< to be removed 1532 1528 … … 1536 1532 IF ( debug_output_timestep ) CALL debug_message( 'module-specific 2d data output', 'start' ) 1537 1533 1538 CALL dynamics_data_output_2d( & 1539 av, variable, found, grid, mode, local_pf, two_d, nzb_do, nzt_do, fill_value & 1540 ) 1534 CALL dynamics_data_output_2d( av, variable, found, grid, mode, local_pf, two_d, nzb_do, nzt_do,& 1535 fill_value ) 1541 1536 1542 1537 IF ( .NOT. found ) THEN 1543 CALL tcm_data_output_2d( & 1544 av, variable, found, grid, mode, local_pf, nzb_do, nzt_do & 1545 ) 1538 CALL tcm_data_output_2d( av, variable, found, grid, mode, local_pf, nzb_do, nzt_do ) 1546 1539 ENDIF 1547 1540 1548 1541 IF ( .NOT. found .AND. biometeorology ) THEN 1549 CALL bio_data_output_2d( & 1550 av, variable, found, grid, local_pf, two_d, nzb_do, nzt_do & 1551 ) 1542 CALL bio_data_output_2d( av, variable, found, grid, local_pf, two_d, nzb_do, nzt_do ) 1552 1543 ENDIF 1553 1544 1554 1545 IF ( .NOT. found .AND. bulk_cloud_model ) THEN 1555 CALL bcm_data_output_2d( & 1556 av, variable, found, grid, mode, local_pf, two_d, nzb_do, nzt_do& 1557 ) 1546 CALL bcm_data_output_2d( av, variable, found, grid, mode, local_pf, two_d, nzb_do, nzt_do ) 1558 1547 ENDIF 1559 1548 1560 1549 IF ( .NOT. found .AND. air_chemistry ) THEN 1561 CALL chem_data_output_2d( & 1562 av, variable, found, grid, mode, local_pf, two_d, nzb_do, nzt_do, fill_value & 1563 ) 1550 CALL chem_data_output_2d( av, variable, found, grid, mode, local_pf, two_d, nzb_do, nzt_do, & 1551 fill_value ) 1564 1552 ENDIF 1565 1553 1566 1554 IF ( .NOT. found ) THEN 1567 CALL doq_output_2d( & 1568 av, variable, found, grid, mode, local_pf, two_d, & 1569 nzb_do, nzt_do, fill_value ) 1555 CALL doq_output_2d( av, variable, found, grid, mode, local_pf, two_d, nzb_do, nzt_do, & 1556 fill_value ) 1570 1557 ENDIF 1571 1558 1572 1559 IF ( .NOT. found .AND. gust_module_enabled ) THEN 1573 CALL gust_data_output_2d( & 1574 av, variable, found, grid, mode, local_pf, two_d, nzb_do, nzt_do, fill_value & 1575 ) 1560 CALL gust_data_output_2d( av, variable, found, grid, mode, local_pf, two_d, nzb_do, nzt_do, & 1561 fill_value ) 1576 1562 ENDIF 1577 1563 1578 1564 IF ( .NOT. found .AND. land_surface ) THEN 1579 CALL lsm_data_output_2d( & 1580 av, variable, found, grid, mode, local_pf, two_d, nzb_do, nzt_do& 1581 ) 1565 CALL lsm_data_output_2d( av, variable, found, grid, mode, local_pf, two_d, nzb_do, nzt_do ) 1582 1566 ENDIF 1583 1567 1584 1568 IF ( .NOT. found .AND. ocean_mode ) THEN 1585 CALL ocean_data_output_2d( & 1586 av, variable, found, grid, mode, local_pf, nzb_do, nzt_do & 1587 ) 1569 CALL ocean_data_output_2d( av, variable, found, grid, mode, local_pf, nzb_do, nzt_do ) 1588 1570 ENDIF 1589 1571 1590 1572 IF ( .NOT. found .AND. radiation ) THEN 1591 CALL radiation_data_output_2d( & 1592 av, variable, found, grid, mode, local_pf, two_d, nzb_do, nzt_do, fill_value & 1593 ) 1573 CALL radiation_data_output_2d( av, variable, found, grid, mode, local_pf, two_d, nzb_do, & 1574 nzt_do, fill_value ) 1594 1575 ENDIF 1595 1576 1596 1577 IF ( .NOT. found .AND. salsa ) THEN 1597 CALL salsa_data_output_2d( & 1598 av, variable, found, grid, mode, local_pf, two_d, nzb_do, nzt_do& 1599 ) 1578 CALL salsa_data_output_2d( av, variable, found, grid, mode, local_pf, two_d, nzb_do, nzt_do ) 1600 1579 ENDIF 1601 1580 1602 1581 IF ( .NOT. found .AND. user_module_enabled ) THEN 1603 CALL user_data_output_2d( & 1604 av, variable, found, grid, local_pf, two_d, nzb_do, nzt_do & 1605 ) 1582 CALL user_data_output_2d( av, variable, found, grid, local_pf, two_d, nzb_do, nzt_do ) 1606 1583 ENDIF 1607 1584 … … 1612 1589 1613 1590 1614 !------------------------------------------------------------------------------ !1591 !--------------------------------------------------------------------------------------------------! 1615 1592 ! 1616 1593 ! Description: 1617 1594 ! ------------ 1618 1595 !> Define module-specific 3D output variables 1619 !------------------------------------------------------------------------------! 1620 SUBROUTINE module_interface_data_output_3d( av, variable, found, local_pf, & 1621 fill_value, resorted, nzb_do, nzt_do ) 1622 1596 !--------------------------------------------------------------------------------------------------! 1597 SUBROUTINE module_interface_data_output_3d( av, variable, found, local_pf, fill_value, resorted, & 1598 nzb_do, nzt_do ) 1599 1600 CHARACTER (LEN=*), INTENT(IN) :: variable !< variable name 1623 1601 1624 1602 INTEGER(iwp), INTENT(IN) :: av !< flag for (non-)average output 1625 CHARACTER (LEN=*), INTENT(IN) :: variable !< variable name1626 LOGICAL, INTENT(INOUT) :: found !< flag if output variable is found1627 REAL(wp), INTENT(IN) :: fill_value !< ToDo: refactor1628 LOGICAL, INTENT(OUT) :: resorted !< flag if output has been resorted1629 1603 INTEGER(iwp), INTENT(IN) :: nzb_do !< vertical output index (bottom) (usually 0) 1630 1604 INTEGER(iwp), INTENT(IN) :: nzt_do !< vertical output index (top) (usually nz_do3d) 1605 1606 LOGICAL, INTENT(INOUT) :: found !< flag if output variable is found 1607 LOGICAL, INTENT(OUT) :: resorted !< flag if output has been resorted 1608 1609 REAL(wp), INTENT(IN) :: fill_value !< ToDo: refactor 1631 1610 1632 1611 REAL(sp), DIMENSION(nxl:nxr,nys:nyn,nzb_do:nzt_do), INTENT(INOUT) :: local_pf … … 1704 1683 1705 1684 1706 !------------------------------------------------------------------------------ !1685 !--------------------------------------------------------------------------------------------------! 1707 1686 ! Description: 1708 1687 ! ------------ 1709 1688 !> Compute module-specific profile and timeseries data 1710 !------------------------------------------------------------------------------ !1689 !--------------------------------------------------------------------------------------------------! 1711 1690 SUBROUTINE module_interface_statistics( mode, sr, tn, dots_max ) 1712 1691 1713 1692 1714 1693 CHARACTER (LEN=*), INTENT(IN) :: mode !< statistical analysis mode 1694 1695 INTEGER(iwp), INTENT(IN) :: dots_max !< maximum number of timeseries 1715 1696 INTEGER(iwp), INTENT(IN) :: sr !< 1716 1697 INTEGER(iwp), INTENT(IN) :: tn !< 1717 INTEGER(iwp), INTENT(IN) :: dots_max !< maximum number of timeseries1718 1698 1719 1699 … … 1801 1781 1802 1782 1803 !------------------------------------------------------------------------------ !1783 !--------------------------------------------------------------------------------------------------! 1804 1784 ! Description: 1805 1785 ! ------------ 1806 1786 !> Write module-specific restart data globaly shared by all MPI ranks 1807 !------------------------------------------------------------------------------ !1787 !--------------------------------------------------------------------------------------------------! 1808 1788 SUBROUTINE module_interface_wrd_global 1809 1789 … … 1833 1813 1834 1814 1835 !------------------------------------------------------------------------------ !1815 !--------------------------------------------------------------------------------------------------! 1836 1816 ! Description: 1837 1817 ! ------------ 1838 1818 !> Read module-specific local restart data arrays (Fortran binary format). 1839 !------------------------------------------------------------------------------ !1840 SUBROUTINE module_interface_rrd_local_ftn( map_index, &1841 nxlf, nxlc, nxl_on_file,&1842 nxrf, nxrc, nxr_on_file,&1843 nynf, nync, nyn_on_file,&1844 nysf, nysc, nys_on_file,&1845 tmp_2d, tmp_3d, found )1819 !--------------------------------------------------------------------------------------------------! 1820 SUBROUTINE module_interface_rrd_local_ftn( map_index, & 1821 nxlf, nxlc, nxl_on_file, & 1822 nxrf, nxrc, nxr_on_file, & 1823 nynf, nync, nyn_on_file, & 1824 nysf, nysc, nys_on_file, & 1825 tmp_2d, tmp_3d, found ) 1846 1826 1847 1827 … … 1859 1839 INTEGER(iwp), INTENT(IN) :: nysf !< 1860 1840 INTEGER(iwp), INTENT(IN) :: nys_on_file !< 1841 1861 1842 LOGICAL, INTENT(INOUT) :: found !< flag if variable was found 1862 1843 1863 REAL(wp), &1864 DIMENSION(nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp), &1844 REAL(wp), & 1845 DIMENSION(nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp), & 1865 1846 INTENT(OUT) :: tmp_2d !< 1866 REAL(wp), &1867 DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp), &1847 REAL(wp), & 1848 DIMENSION(nzb:nzt+1,nys_on_file-nbgp:nyn_on_file+nbgp,nxl_on_file-nbgp:nxr_on_file+nbgp), & 1868 1849 INTENT(OUT) :: tmp_3d !< 1869 1850 … … 1873 1854 ENDIF 1874 1855 1875 CALL dynamics_rrd_local( & 1876 map_index, & 1877 nxlf, nxlc, nxl_on_file, & 1878 nxrf, nxrc, nxr_on_file, & 1879 nynf, nync, nyn_on_file, & 1880 nysf, nysc, nys_on_file, & 1881 tmp_2d, tmp_3d, found & 1882 ) ! ToDo: change interface to pass variable 1883 1884 IF ( .NOT. found ) CALL bio_rrd_local( & 1885 found & 1886 ) 1887 1888 IF ( .NOT. found ) CALL bcm_rrd_local( & 1889 map_index, & 1890 nxlf, nxlc, nxl_on_file, & 1891 nxrf, nxrc, nxr_on_file, & 1892 nynf, nync, nyn_on_file, & 1893 nysf, nysc, nys_on_file, & 1894 tmp_2d, tmp_3d, found & 1895 ) ! ToDo: change interface to pass variable 1896 1897 IF ( .NOT. found ) CALL chem_rrd_local( & 1898 map_index, & 1899 nxlf, nxlc, nxl_on_file, & 1900 nxrf, nxrc, nxr_on_file, & 1901 nynf, nync, nyn_on_file, & 1902 nysf, nysc, nys_on_file, & 1903 tmp_3d, found & 1904 ) ! ToDo: change interface to pass variable 1905 1906 IF ( .NOT. found ) CALL doq_rrd_local( & 1907 map_index, & 1908 nxlf, nxlc, nxl_on_file, & 1909 nxrf, nxrc, nxr_on_file, & 1910 nynf, nync, nyn_on_file, & 1911 nysf, nysc, nys_on_file, & 1912 tmp_2d, tmp_3d, found & 1913 ) ! ToDo: change interface to pass variable 1914 1915 IF ( .NOT. found ) CALL gust_rrd_local( & 1916 map_index, & 1917 nxlf, nxlc, nxl_on_file, & 1918 nxrf, nxrc, nxr_on_file, & 1919 nynf, nync, nyn_on_file, & 1920 nysf, nysc, nys_on_file, & 1921 tmp_2d, tmp_3d, found & 1922 ) ! ToDo: change interface to pass variable 1923 1924 IF ( .NOT. found ) CALL lpm_rrd_local( & 1925 map_index, & 1926 nxlf, nxlc, nxl_on_file, & 1927 nxrf, nxrc, nxr_on_file, & 1928 nynf, nync, nyn_on_file, & 1929 nysf, nysc, nys_on_file, & 1930 tmp_3d, found & 1931 ) ! ToDo: change interface to pass variable 1932 1933 IF ( .NOT. found ) CALL lsm_rrd_local( & 1934 map_index, & 1935 nxlf, nxlc, nxl_on_file, & 1936 nxrf, nxrc, nxr_on_file, & 1937 nynf, nync, nyn_on_file, & 1938 nysf, nysc, nys_on_file, & 1939 tmp_2d, found & 1940 ) ! ToDo: change interface to pass variable 1941 1942 IF ( .NOT. found ) CALL pcm_rrd_local( & 1943 map_index, & 1944 nxlf, nxlc, nxl_on_file, & 1945 nxrf, nxrc, nxr_on_file, & 1946 nynf, nync, nyn_on_file, & 1947 nysf, nysc, nys_on_file, & 1948 found & 1856 CALL dynamics_rrd_local( map_index, & 1857 nxlf, nxlc, nxl_on_file, & 1858 nxrf, nxrc, nxr_on_file, & 1859 nynf, nync, nyn_on_file, & 1860 nysf, nysc, nys_on_file, & 1861 tmp_2d, tmp_3d, found & 1862 ) ! ToDo: change interface to pass variable 1863 1864 IF ( .NOT. found ) CALL bio_rrd_local( found ) 1865 1866 IF ( .NOT. found ) CALL bcm_rrd_local( map_index, & 1867 nxlf, nxlc, nxl_on_file, & 1868 nxrf, nxrc, nxr_on_file, & 1869 nynf, nync, nyn_on_file, & 1870 nysf, nysc, nys_on_file, & 1871 tmp_2d, tmp_3d, found & 1872 ) ! ToDo: change interface to pass variable 1873 1874 IF ( .NOT. found ) CALL chem_rrd_local( map_index, & 1875 nxlf, nxlc, nxl_on_file, & 1876 nxrf, nxrc, nxr_on_file, & 1877 nynf, nync, nyn_on_file, & 1878 nysf, nysc, nys_on_file, & 1879 tmp_3d, found & 1880 ) ! ToDo: change interface to pass variable 1881 1882 IF ( .NOT. found ) CALL doq_rrd_local( map_index, & 1883 nxlf, nxlc, nxl_on_file, & 1884 nxrf, nxrc, nxr_on_file, & 1885 nynf, nync, nyn_on_file, & 1886 nysf, nysc, nys_on_file, & 1887 tmp_2d, tmp_3d, found & 1888 ) ! ToDo: change interface to pass variable 1889 1890 IF ( .NOT. found ) CALL gust_rrd_local( map_index, & 1891 nxlf, nxlc, nxl_on_file, & 1892 nxrf, nxrc, nxr_on_file, & 1893 nynf, nync, nyn_on_file, & 1894 nysf, nysc, nys_on_file, & 1895 tmp_2d, tmp_3d, found & 1896 ) ! ToDo: change interface to pass variable 1897 1898 IF ( .NOT. found ) CALL lpm_rrd_local( map_index, & 1899 nxlf, nxlc, nxl_on_file, & 1900 nxrf, nxrc, nxr_on_file, & 1901 nynf, nync, nyn_on_file, & 1902 nysf, nysc, nys_on_file, & 1903 tmp_3d, found & 1904 ) ! ToDo: change interface to pass variable 1905 1906 IF ( .NOT. found ) CALL lsm_rrd_local( map_index, & 1907 nxlf, nxlc, nxl_on_file, & 1908 nxrf, nxrc, nxr_on_file, & 1909 nynf, nync, nyn_on_file, & 1910 nysf, nysc, nys_on_file, & 1911 tmp_2d, found & 1912 ) ! ToDo: change interface to pass variable 1913 1914 IF ( .NOT. found ) CALL pcm_rrd_local( map_index, & 1915 nxlf, nxlc, nxl_on_file, & 1916 nxrf, nxrc, nxr_on_file, & 1917 nynf, nync, nyn_on_file, & 1918 nysf, nysc, nys_on_file, & 1919 found & 1949 1920 ) 1950 1921 1951 IF ( .NOT. found ) CALL ocean_rrd_local( & 1952 map_index, & 1953 nxlf, nxlc, nxl_on_file, & 1954 nxrf, nxrc, nxr_on_file, & 1955 nynf, nync, nyn_on_file, & 1956 nysf, nysc, nys_on_file, & 1957 tmp_3d, found & 1958 ) ! ToDo: change interface to pass variable 1959 1960 IF ( .NOT. found ) CALL radiation_rrd_local( & 1961 map_index, & 1962 nxlf, nxlc, nxl_on_file, & 1963 nxrf, nxrc, nxr_on_file, & 1964 nynf, nync, nyn_on_file, & 1965 nysf, nysc, nys_on_file, & 1966 tmp_2d, tmp_3d, found & 1967 ) ! ToDo: change interface to pass variable 1968 1969 IF ( .NOT. found ) CALL salsa_rrd_local( & 1970 map_index, & 1971 nxlf, nxlc, nxl_on_file, & 1972 nxrf, nxrc, nxr_on_file, & 1973 nynf, nync, nyn_on_file, & 1974 nysf, nysc, nys_on_file, & 1975 tmp_3d, found & 1976 ) ! ToDo: change interface to pass variable 1977 1978 IF ( .NOT. found ) CALL usm_rrd_local( & 1979 map_index, & 1980 nxlf, nxlc, nxl_on_file, & 1981 nxrf, nxr_on_file, & 1982 nynf, nyn_on_file, & 1983 nysf, nysc, nys_on_file, & 1984 found & 1985 ) ! ToDo: change interface to pass variable 1922 IF ( .NOT. found ) CALL ocean_rrd_local( map_index, & 1923 nxlf, nxlc, nxl_on_file, & 1924 nxrf, nxrc, nxr_on_file, & 1925 nynf, nync, nyn_on_file, & 1926 nysf, nysc, nys_on_file, & 1927 tmp_3d, found & 1928 ) ! ToDo: change interface to pass variable 1929 1930 IF ( .NOT. found ) CALL radiation_rrd_local( map_index, & 1931 nxlf, nxlc, nxl_on_file, & 1932 nxrf, nxrc, nxr_on_file, & 1933 nynf, nync, nyn_on_file, & 1934 nysf, nysc, nys_on_file, & 1935 tmp_2d, tmp_3d, found & 1936 ) ! ToDo: change interface to pass variable 1937 1938 IF ( .NOT. found ) CALL salsa_rrd_local( map_index, & 1939 nxlf, nxlc, nxl_on_file, & 1940 nxrf, nxrc, nxr_on_file, & 1941 nynf, nync, nyn_on_file, & 1942 nysf, nysc, nys_on_file, & 1943 tmp_3d, found & 1944 ) ! ToDo: change interface to pass variable 1945 1946 IF ( .NOT. found ) CALL usm_rrd_local( map_index, & 1947 nxlf, nxlc, nxl_on_file, & 1948 nxrf, nxr_on_file, & 1949 nynf, nyn_on_file, & 1950 nysf, nysc, nys_on_file, & 1951 found & 1952 ) ! ToDo: change interface to pass variable 1986 1953 ! 1987 1954 !-- Surface data do not need overlap data, so do not pass these information. 1988 1955 IF ( .NOT. found ) CALL surface_data_output_rrd_local( found ) 1989 1956 1990 IF ( .NOT. found ) CALL user_rrd_local( & 1991 map_index, & 1992 nxlf, nxlc, nxl_on_file, & 1993 nxrf, nxrc, nxr_on_file, & 1994 nynf, nync, nyn_on_file, & 1995 nysf, nysc, nys_on_file, & 1996 tmp_3d, found & 1997 ) ! ToDo: change interface to pass variable 1957 IF ( .NOT. found ) CALL user_rrd_local( map_index, & 1958 nxlf, nxlc, nxl_on_file, & 1959 nxrf, nxrc, nxr_on_file, & 1960 nynf, nync, nyn_on_file, & 1961 nysf, nysc, nys_on_file, & 1962 tmp_3d, found & 1963 ) ! ToDo: change interface to pass variable 1998 1964 1999 1965 IF ( debug_output ) THEN … … 2004 1970 2005 1971 2006 !------------------------------------------------------------------------------ !1972 !--------------------------------------------------------------------------------------------------! 2007 1973 ! Description: 2008 1974 ! ------------ 2009 1975 !> Read module-specific local restart data arrays (MPI-IO). 2010 !------------------------------------------------------------------------------ !1976 !--------------------------------------------------------------------------------------------------! 2011 1977 SUBROUTINE module_interface_rrd_local_mpi 2012 1978 … … 2040 2006 2041 2007 2042 !------------------------------------------------------------------------------ !2008 !--------------------------------------------------------------------------------------------------! 2043 2009 ! Description: 2044 2010 ! ------------ 2045 2011 !> Write module-specific restart data specific to local MPI ranks 2046 !------------------------------------------------------------------------------ !2012 !--------------------------------------------------------------------------------------------------! 2047 2013 SUBROUTINE module_interface_wrd_local 2048 2014 … … 2074 2040 2075 2041 2076 !------------------------------------------------------------------------------ !2042 !--------------------------------------------------------------------------------------------------! 2077 2043 ! Description: 2078 2044 ! ------------ 2079 2045 !> Perform module-specific last actions before the program terminates 2080 !------------------------------------------------------------------------------ !2046 !--------------------------------------------------------------------------------------------------! 2081 2047 SUBROUTINE module_interface_last_actions 2082 2048 -
TabularUnified palm/trunk/SOURCE/modules.f90 ¶
r4742 r4753 1 1 !> @file modules.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 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/>. 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/>. 16 15 ! 17 16 ! Copyright 1997-2020 Leibniz Universitaet Hannover 18 !------------------------------------------------------------------------------ !17 !--------------------------------------------------------------------------------------------------! 19 18 ! 20 19 ! Current revisions: … … 25 24 ! ----------------- 26 25 ! $Id$ 26 ! file re-formatted to follow the PALM coding standard 27 ! 28 ! 4742 2020-10-14 15:11:02Z schwenkel 27 29 ! Implement snow and graupel (bulk microphysics) 28 30 ! … … 69 71 ! 70 72 ! 4472 2020-03-24 12:21:00Z Giersch 71 ! Additional switch added to activate calculations in flow_statistics for the 72 ! kolmogorov lengthscale73 ! Additional switch added to activate calculations in flow_statistics for the kolmogorov length 74 ! scale 73 75 ! 74 76 ! 4461 2020-03-12 16:51:59Z raasch … … 76 78 ! 77 79 ! 4414 2020-02-19 20:16:04Z suehring 78 ! - nzb_diff_s_inner, nzb_diff_s_outer, nzb_inner,nzb_outer, nzb_s_inner, 79 ! nzb_s_outer, nzb_u_inner, nzb_u_outer, nzb_v_inner, nzb_v_outer, 80 ! nzb_w_inner, nzb_w_outer 80 ! - nzb_diff_s_inner, nzb_diff_s_outer, nzb_inner,nzb_outer, nzb_s_inner, nzb_s_outer, nzb_u_inner, 81 ! nzb_u_outer, nzb_v_inner, nzb_v_outer, nzb_w_inner, nzb_w_outer 81 82 ! 82 83 ! 83 84 ! 4360 2020-01-07 11:25:50Z suehring 84 ! Introduction of wall_flags_total_0, which currently sets bits based on static 85 ! topographyinformation used in wall_flags_static_085 ! Introduction of wall_flags_total_0, which currently sets bits based on static topography 86 ! information used in wall_flags_static_0 86 87 ! 87 88 ! 4340 2019-12-16 08:17:03Z Giersch … … 107 108 ! 108 109 ! 4184 2019-08-23 08:07:40Z oliver.maas 109 ! changed allocated length of recycling_method_for_thermodynamic_quantities 110 ! from 20 to 80 characters 110 ! changed allocated length of recycling_method_for_thermodynamic_quantities from 20 to 80 characters 111 111 ! 112 112 ! 4183 2019-08-23 07:33:16Z oliver.maas … … 127 127 ! 128 128 ! 4131 2019-08-02 11:06:18Z monakurppa 129 ! Add max_pr_salsa to control_parameters. Used in creating profile output for 130 ! salsa. 129 ! Add max_pr_salsa to control_parameters. Used in creating profile output for salsa. 131 130 ! 132 131 ! 4110 2019-07-22 17:05:21Z suehring … … 141 140 ! 142 141 ! 4069 2019-07-01 14:05:51Z Giersch 143 ! Masked output running index mid has been introduced as a local variable to 144 ! avoid runtime error(Loop variable has been modified) in time_integration142 ! Masked output running index mid has been introduced as a local variable to avoid runtime error 143 ! (Loop variable has been modified) in time_integration 145 144 ! 146 145 ! 4017 2019-06-06 12:16:46Z schwenkel … … 151 150 ! 152 151 ! 3885 2019-04-11 11:29:34Z kanani 153 ! Changes related to global restructuring of location messages and introduction 154 ! of additional debugmessages152 ! Changes related to global restructuring of location messages and introduction of additional debug 153 ! messages 155 154 ! 156 155 ! 3871 2019-04-08 14:38:39Z knoop … … 163 162 ! -surface_data_output +surface_output 164 163 ! 165 !------------------------------------------------------------------------------ !164 !--------------------------------------------------------------------------------------------------! 166 165 ! Description: 167 166 ! ------------ 168 167 !> Definition of global variables 169 !------------------------------------------------------------------------------ !170 171 172 !------------------------------------------------------------------------------ !168 !--------------------------------------------------------------------------------------------------! 169 170 171 !--------------------------------------------------------------------------------------------------! 173 172 ! Description: 174 173 ! ------------ 175 174 !> Definition of variables for special advection schemes. 176 !------------------------------------------------------------------------------ !175 !--------------------------------------------------------------------------------------------------! 177 176 MODULE advection 178 177 … … 190 189 191 190 192 !------------------------------------------------------------------------------ !191 !--------------------------------------------------------------------------------------------------! 193 192 ! Description: 194 193 ! ------------ 195 !> The variable in this module is used by multi_agent_system_mod AND 196 !> netcdf_interface_mod. It mustbe here to avoid circular dependency.194 !> The variable in this module is used by multi_agent_system_mod AND netcdf_interface_mod. It must 195 !> be here to avoid circular dependency. 197 196 !> This is a workaround. 198 !------------------------------------------------------------------------------ !197 !--------------------------------------------------------------------------------------------------! 199 198 MODULE mas_global_attributes 200 199 … … 208 207 209 208 210 !------------------------------------------------------------------------------ !209 !--------------------------------------------------------------------------------------------------! 211 210 ! Description: 212 211 ! ------------ 213 212 !> Definition of all arrays defined on the computational grid. 214 !------------------------------------------------------------------------------ !213 !--------------------------------------------------------------------------------------------------! 215 214 MODULE arrays_3d 216 215 217 216 USE kinds 218 217 219 REAL(wp), DIMENSION(:), ALLOCATABLE :: c_u_m !< mean phase velocity at outflow for u-component used in radiation boundary condition 220 REAL(wp), DIMENSION(:), ALLOCATABLE :: c_u_m_l !< mean phase velocity at outflow for u-component used in radiation boundary condition (local subdomain value) 221 REAL(wp), DIMENSION(:), ALLOCATABLE :: c_v_m !< mean phase velocity at outflow for v-component used in radiation boundary condition 222 REAL(wp), DIMENSION(:), ALLOCATABLE :: c_v_m_l !< mean phase velocity at outflow for v-component used in radiation boundary condition (local subdomain value) 223 REAL(wp), DIMENSION(:), ALLOCATABLE :: c_w_m !< mean phase velocity at outflow for w-component used in radiation boundary condition 224 REAL(wp), DIMENSION(:), ALLOCATABLE :: c_w_m_l !< mean phase velocity at outflow for w-component used in radiation boundary condition (local subdomain value) 225 REAL(wp), DIMENSION(:), ALLOCATABLE :: ddzu !< 1/dzu 226 REAL(wp), DIMENSION(:), ALLOCATABLE :: ddzu_pres !< modified ddzu for pressure solver 227 REAL(wp), DIMENSION(:), ALLOCATABLE :: dd2zu !< 1/(dzu(k)+dzu(k+1)) 228 REAL(wp), DIMENSION(:), ALLOCATABLE :: dzu !< vertical grid size (u-grid) 229 REAL(wp), DIMENSION(:), ALLOCATABLE :: ddzw !< 1/dzw 230 REAL(wp), DIMENSION(:), ALLOCATABLE :: dzw !< vertical grid size (w-grid) 231 REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp !< hydrostatic pressure 232 REAL(wp), DIMENSION(:), ALLOCATABLE :: inflow_damping_factor !< used for turbulent inflow (non-cyclic boundary conditions) 233 REAL(wp), DIMENSION(:), ALLOCATABLE :: ptdf_x !< damping factor for potential temperature in x-direction 234 REAL(wp), DIMENSION(:), ALLOCATABLE :: ptdf_y !< damping factor for potential temperature in y-direction 235 REAL(wp), DIMENSION(:), ALLOCATABLE :: pt_init !< initial profile of potential temperature 236 REAL(wp), DIMENSION(:), ALLOCATABLE :: q_init !< initial profile of total water mixing ratio 237 !< (or total water content with active cloud physics) 238 REAL(wp), DIMENSION(:), ALLOCATABLE :: rdf !< rayleigh damping factor for velocity components 239 REAL(wp), DIMENSION(:), ALLOCATABLE :: rdf_sc !< rayleigh damping factor for scalar quantities 240 REAL(wp), DIMENSION(:), ALLOCATABLE :: ref_state !< reference state of potential temperature 241 !< (and density in case of ocean simulation) 242 REAL(wp), DIMENSION(:), ALLOCATABLE :: s_init !< initial profile of passive scalar concentration 243 REAL(wp), DIMENSION(:), ALLOCATABLE :: sa_init !< initial profile of salinity (ocean) 244 REAL(wp), DIMENSION(:), ALLOCATABLE :: ug !< geostrophic wind component in x-direction 245 REAL(wp), DIMENSION(:), ALLOCATABLE :: u_init !< initial profile of horizontal velocity component u 246 REAL(wp), DIMENSION(:), ALLOCATABLE :: u_stokes_zu !< u-component of Stokes drift velocity at zu levels 247 REAL(wp), DIMENSION(:), ALLOCATABLE :: u_stokes_zw !< u-component of Stokes drift velocity at zw levels 248 REAL(wp), DIMENSION(:), ALLOCATABLE :: vg !< geostrophic wind component in y-direction 249 REAL(wp), DIMENSION(:), ALLOCATABLE :: v_init !< initial profile of horizontal velocity component v 250 REAL(wp), DIMENSION(:), ALLOCATABLE :: v_stokes_zu !< v-component of Stokes drift velocity at zu levels 251 REAL(wp), DIMENSION(:), ALLOCATABLE :: v_stokes_zw !< v-component of Stokes drift velocity at zw levels 252 REAL(wp), DIMENSION(:), ALLOCATABLE :: w_subs !< subsidence/ascent velocity 253 REAL(wp), DIMENSION(:), ALLOCATABLE :: x !< horizontal grid coordinate of v-grid (in m) 254 REAL(wp), DIMENSION(:), ALLOCATABLE :: xu !< horizontal grid coordinate of u-grid (in m) 255 REAL(wp), DIMENSION(:), ALLOCATABLE :: y !< horizontal grid coordinate of u-grid (in m) 256 REAL(wp), DIMENSION(:), ALLOCATABLE :: yv !< horizontal grid coordinate of v-grid (in m) 257 REAL(wp), DIMENSION(:), ALLOCATABLE :: zu !< vertical grid coordinate of u-grid (in m) 258 REAL(wp), DIMENSION(:), ALLOCATABLE :: zw !< vertical grid coordinate of w-grid (in m) 218 REAL(wp), DIMENSION(:), ALLOCATABLE :: c_u_m !< mean phase velocity at outflow for u-component used 219 !< in radiation boundary condition 220 REAL(wp), DIMENSION(:), ALLOCATABLE :: c_u_m_l !< mean phase velocity at outflow for u-component used 221 !< in radiation boundary condition (local subdomain value) 222 REAL(wp), DIMENSION(:), ALLOCATABLE :: c_v_m !< mean phase velocity at outflow for v-component used 223 !< in radiation boundary condition 224 REAL(wp), DIMENSION(:), ALLOCATABLE :: c_v_m_l !< mean phase velocity at outflow for v-component used 225 !< in radiation boundary condition (local subdomain value) 226 REAL(wp), DIMENSION(:), ALLOCATABLE :: c_w_m !< mean phase velocity at outflow for w-component used 227 !< in radiation boundary condition 228 REAL(wp), DIMENSION(:), ALLOCATABLE :: c_w_m_l !< mean phase velocity at outflow for w-component used 229 !< in radiation boundary condition (local subdomain value) 230 REAL(wp), DIMENSION(:), ALLOCATABLE :: d_exner !< ratio of potential and actual temperature 231 REAL(wp), DIMENSION(:), ALLOCATABLE :: ddzu !< 1/dzu 232 REAL(wp), DIMENSION(:), ALLOCATABLE :: ddzu_pres !< modified ddzu for pressure solver 233 REAL(wp), DIMENSION(:), ALLOCATABLE :: dd2zu !< 1/(dzu(k)+dzu(k+1)) 234 REAL(wp), DIMENSION(:), ALLOCATABLE :: drho_air !< inverse air density profile on the uv grid 235 REAL(wp), DIMENSION(:), ALLOCATABLE :: drho_air_zw !< inverse air density profile on the w grid 236 REAL(wp), DIMENSION(:), ALLOCATABLE :: dzu !< vertical grid size (u-grid) 237 REAL(wp), DIMENSION(:), ALLOCATABLE :: ddzw !< 1/dzw 238 REAL(wp), DIMENSION(:), ALLOCATABLE :: dzw !< vertical grid size (w-grid) 239 REAL(wp), DIMENSION(:), ALLOCATABLE :: exner !< ratio of actual and potential temperature 240 REAL(wp), DIMENSION(:), ALLOCATABLE :: heatflux_input_conversion !< conversion factor array for heatflux input 241 REAL(wp), DIMENSION(:), ALLOCATABLE :: heatflux_output_conversion !< conversion factor array for heatflux output 242 REAL(wp), DIMENSION(:), ALLOCATABLE :: hyp !< hydrostatic pressure 243 REAL(wp), DIMENSION(:), ALLOCATABLE :: hyrho !< density of air calculated with hydrostatic pressure 244 REAL(wp), DIMENSION(:), ALLOCATABLE :: inflow_damping_factor !< used for turbulent inflow 245 !< (non-cyclic boundary conditions) 246 REAL(wp), DIMENSION(:), ALLOCATABLE :: momentumflux_input_conversion !< conversion factor array for momentumflux input 247 REAL(wp), DIMENSION(:), ALLOCATABLE :: momentumflux_output_conversion !< conversion factor array for momentumflux output 248 REAL(wp), DIMENSION(:), ALLOCATABLE :: ptdf_x !< damping factor for potential temperature in 249 !< x-direction 250 REAL(wp), DIMENSION(:), ALLOCATABLE :: ptdf_y !< damping factor for potential temperature in 251 !< y-direction 252 REAL(wp), DIMENSION(:), ALLOCATABLE :: pt_init !< initial profile of potential temperature 253 REAL(wp), DIMENSION(:), ALLOCATABLE :: q_init !< initial profile of total water mixing ratio 254 !< (or total water content with active cloud physics) 255 REAL(wp), DIMENSION(:), ALLOCATABLE :: rdf !< rayleigh damping factor for velocity components 256 REAL(wp), DIMENSION(:), ALLOCATABLE :: rdf_sc !< rayleigh damping factor for scalar quantities 257 REAL(wp), DIMENSION(:), ALLOCATABLE :: ref_state !< reference state of potential temperature 258 !< (and density in case of ocean simulation) 259 REAL(wp), DIMENSION(:), ALLOCATABLE :: rho_air !< air density profile on the uv grid 260 REAL(wp), DIMENSION(:), ALLOCATABLE :: rho_air_zw !< air density profile on the w grid 261 REAL(wp), DIMENSION(:), ALLOCATABLE :: s_init !< initial profile of passive scalar concentration 262 REAL(wp), DIMENSION(:), ALLOCATABLE :: sa_init !< initial profile of salinity (ocean) 263 REAL(wp), DIMENSION(:), ALLOCATABLE :: ug !< geostrophic wind component in x-direction 264 REAL(wp), DIMENSION(:), ALLOCATABLE :: u_init !< initial profile of horizontal velocity component u 265 REAL(wp), DIMENSION(:), ALLOCATABLE :: u_stokes_zu !< u-component of Stokes drift velocity at zu levels 266 REAL(wp), DIMENSION(:), ALLOCATABLE :: u_stokes_zw !< u-component of Stokes drift velocity at zw levels 267 REAL(wp), DIMENSION(:), ALLOCATABLE :: vg !< geostrophic wind component in y-direction 268 REAL(wp), DIMENSION(:), ALLOCATABLE :: v_init !< initial profile of horizontal velocity component v 269 REAL(wp), DIMENSION(:), ALLOCATABLE :: v_stokes_zu !< v-component of Stokes drift velocity at zu levels 270 REAL(wp), DIMENSION(:), ALLOCATABLE :: v_stokes_zw !< v-component of Stokes drift velocity at zw levels 271 REAL(wp), DIMENSION(:), ALLOCATABLE :: waterflux_input_conversion !< conversion factor array for waterflux input 272 REAL(wp), DIMENSION(:), ALLOCATABLE :: waterflux_output_conversion !< conversion factor array for waterflux output 273 REAL(wp), DIMENSION(:), ALLOCATABLE :: w_subs !< subsidence/ascent velocity 274 REAL(wp), DIMENSION(:), ALLOCATABLE :: x !< horizontal grid coordinate of v-grid (in m) 275 REAL(wp), DIMENSION(:), ALLOCATABLE :: xu !< horizontal grid coordinate of u-grid (in m) 276 REAL(wp), DIMENSION(:), ALLOCATABLE :: y !< horizontal grid coordinate of u-grid (in m) 277 REAL(wp), DIMENSION(:), ALLOCATABLE :: yv !< horizontal grid coordinate of v-grid (in m) 278 REAL(wp), DIMENSION(:), ALLOCATABLE :: zu !< vertical grid coordinate of u-grid (in m) 279 REAL(wp), DIMENSION(:), ALLOCATABLE :: zw !< vertical grid coordinate of w-grid (in m) 280 259 281 260 282 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: c_u !< phase speed of u-velocity component 261 283 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: c_v !< phase speed of v-velocity component 262 284 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: c_w !< phase speed of w-velocity component 263 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_diss !< artificial numerical dissipation flux at south face of grid box - TKE dissipation 264 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_e !< artificial numerical dissipation flux at south face of grid box - subgrid-scale TKE 265 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_nc !< artificial numerical dissipation flux at south face of grid box - clouddrop-number concentration 266 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_ng !< artificial numerical dissipation flux at south face of grid box - graupel number concentration 267 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_ni !< artificial numerical dissipation flux at south face of grid box - ice crystal-number concentration 268 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_nr !< artificial numerical dissipation flux at south face of grid box - raindrop-number concentration 269 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_ns !< artificial numerical dissipation flux at south face of grid box - snow-number concentration 270 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_pt !< artificial numerical dissipation flux at south face of grid box - potential temperature 271 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_q !< artificial numerical dissipation flux at south face of grid box - total water mixing ratio 272 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_qc !< artificial numerical dissipation flux at south face of grid box - cloudwater mixing ratio 273 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_qg !< artificial numerical dissipation flux at south face of grid box - graupel mixing ratio 274 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_qi !< artificial numerical dissipation flux at south face of grid box - ice crystal mixing ratio 275 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_qr !< artificial numerical dissipation flux at south face of grid box - rainwater mixing ratio 276 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_qs !< artificial numerical dissipation flux at south face of grid box - snow mixing ratio 277 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_s !< artificial numerical dissipation flux at south face of grid box - passive scalar 278 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_sa !< artificial numerical dissipation flux at south face of grid box - salinity 279 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_u !< artificial numerical dissipation flux at south face of grid box - u-component 280 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_v !< artificial numerical dissipation flux at south face of grid box - v-component 281 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_w !< artificial numerical dissipation flux at south face of grid box - w-component 285 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_diss !< artificial numerical dissipation flux at south face of grid 286 !< box - TKE dissipation 287 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_e !< artificial numerical dissipation flux at south face of grid 288 !< box - subgrid-scale TKE 289 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_nc !< artificial numerical dissipation flux at south face of grid 290 !< box - clouddrop-number concentration 291 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_ng !< artificial numerical dissipation flux at south face of grid 292 !< box - graupel number concentration 293 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_ni !< artificial numerical dissipation flux at south face of grid 294 !< box - ice crystal-number concentration 295 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_nr !< artificial numerical dissipation flux at south face of grid 296 !< box - raindrop-number concentration 297 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_ns !< artificial numerical dissipation flux at south face of grid 298 !< box - snow-number concentration 299 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_pt !< artificial numerical dissipation flux at south face of grid 300 !< box - potential temperature 301 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_q !< artificial numerical dissipation flux at south face of grid 302 !< box - total water mixing ratio 303 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_qc !< artificial numerical dissipation flux at south face of grid 304 !< box - cloudwater mixing ratio 305 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_qg !< artificial numerical dissipation flux at south face of grid 306 !< box - graupel mixing ratio 307 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_qi !< artificial numerical dissipation flux at south face of grid 308 !< box - ice crystal mixing ratio 309 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_qr !< artificial numerical dissipation flux at south face of grid 310 !< box - rainwater mixing ratio 311 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_qs !< artificial numerical dissipation flux at south face of grid 312 !< box - snow mixing ratio 313 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_s !< artificial numerical dissipation flux at south face of grid 314 !< box - passive scalar 315 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_sa !< artificial numerical dissipation flux at south face of grid 316 !< box - salinity 317 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_u !< artificial numerical dissipation flux at south face of grid 318 !< box - u-component 319 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_v !< artificial numerical dissipation flux at south face of grid 320 !< box - v-component 321 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: diss_s_w !< artificial numerical dissipation flux at south face of grid 322 !< box - w-component 282 323 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dzu_mg !< vertical grid size (u-grid) for multigrid pressure solver 283 324 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: dzw_mg !< vertical grid size (w-grid) for multigrid pressure solver 284 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_diss !< 6th-order advective flux at south face of grid box - TKE dissipation 285 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_e !< 6th-order advective flux at south face of grid box - subgrid-scale TKE 286 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_nc !< 6th-order advective flux at south face of grid box - clouddrop-number concentration 287 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_ng !< 6th-order advective flux at south face of grid box - graupel-number concentration 288 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_ni !< 6th-order advective flux at south face of grid box - icecrystal-number concentration 289 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_nr !< 6th-order advective flux at south face of grid box - raindrop-number concentration 290 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_ns !< 6th-order advective flux at south face of grid box - graupel-number concentration 291 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_pt !< 6th-order advective flux at south face of grid box - potential temperature 292 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_q !< 6th-order advective flux at south face of grid box - total water mixing ratio 293 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_qc !< 6th-order advective flux at south face of grid box - cloudwater mixing ratio 294 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_qg !< 6th-order advective flux at south face of grid box - graupel mixing ratio 295 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_qi !< 6th-order advective flux at south face of grid box - ice crystal mixing ratio 296 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_qr !< 6th-order advective flux at south face of grid box - rainwater mixing ratio 297 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_qs !< 6th-order advective flux at south face of grid box - snow mixing ratio 298 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_s !< 6th-order advective flux at south face of grid box - passive scalar 299 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_sa !< 6th-order advective flux at south face of grid box - salinity 300 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_u !< 6th-order advective flux at south face of grid box - u-component 301 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_v !< 6th-order advective flux at south face of grid box - v-component 302 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_w !< 6th-order advective flux at south face of grid box - w-component 303 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: f1_mg !< grid factor used in right hand side of Gauss-Seidel equation (multigrid) 304 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: f2_mg !< grid factor used in right hand side of Gauss-Seidel equation (multigrid) 305 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: f3_mg !< grid factor used in right hand side of Gauss-Seidel equation (multigrid) 325 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_diss !< 6th-order advective flux at south face of grid box - 326 !< TKE dissipation 327 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_e !< 6th-order advective flux at south face of grid box - 328 !< subgrid-scale TKE 329 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_nc !< 6th-order advective flux at south face of grid box - 330 !< clouddrop-number concentration 331 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_ng !< 6th-order advective flux at south face of grid box - 332 !< graupel-number concentration 333 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_ni !< 6th-order advective flux at south face of grid box - 334 !< icecrystal-number concentration 335 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_nr !< 6th-order advective flux at south face of grid box - 336 !< raindrop-number concentration 337 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_ns !< 6th-order advective flux at south face of grid box - 338 !< graupel-number concentration 339 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_pt !< 6th-order advective flux at south face of grid box - 340 !< potential temperature 341 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_q !< 6th-order advective flux at south face of grid box - 342 !< total water mixing ratio 343 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_qc !< 6th-order advective flux at south face of grid box - 344 !< cloudwater mixing ratio 345 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_qg !< 6th-order advective flux at south face of grid box - 346 !< graupel mixing ratio 347 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_qi !< 6th-order advective flux at south face of grid box - 348 !< ice crystal mixing ratio 349 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_qr !< 6th-order advective flux at south face of grid box - 350 !< rainwater mixing ratio 351 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_qs !< 6th-order advective flux at south face of grid box - 352 !< snow mixing ratio 353 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_s !< 6th-order advective flux at south face of grid box - 354 !< passive scalar 355 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_sa !< 6th-order advective flux at south face of grid box - 356 !< salinity 357 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_u !< 6th-order advective flux at south face of grid box - 358 !< u-component 359 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_v !< 6th-order advective flux at south face of grid box - 360 !< v-component 361 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: flux_s_w !< 6th-order advective flux at south face of grid box - 362 !< w-component 363 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: f1_mg !< grid factor used in right hand side of Gauss-Seidel equation 364 !< (multigrid) 365 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: f2_mg !< grid factor used in right hand side of Gauss-Seidel equation 366 !< (multigrid) 367 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: f3_mg !< grid factor used in right hand side of Gauss-Seidel equation 368 !< (multigrid) 306 369 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: mean_inflow_profiles !< used for turbulent inflow (non-cyclic boundary conditions) 307 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: precipitation_amount !< precipitation amount due to gravitational settling (bulk microphysics) 370 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: precipitation_amount !< precipitation amount due to gravitational settling 371 !< (bulk microphysics) 308 372 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: pt_slope_ref !< potential temperature in rotated coordinate system 309 373 !< (in case of sloped surface) 310 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: total_2d_a !< horizontal array to store the total domain data, used for atmosphere-ocean coupling (atmosphere data) 311 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: total_2d_o !< horizontal array to store the total domain data, used for atmosphere-ocean coupling (ocean data) 374 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rho_air_mg !< air density profiles on the uv grid for multigrid 375 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rho_air_zw_mg !< air density profiles on the w grid for multigrid 376 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: total_2d_a !< horizontal array to store the total domain data, used for 377 !< atmosphere-ocean coupling (atmosphere data) 378 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: total_2d_o !< horizontal array to store the total domain data, used for 379 !< atmosphere-ocean coupling (ocean data) 312 380 313 381 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: d !< divergence … … 315 383 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: de_dy !< gradient of sgs tke in y-direction (lpm) 316 384 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: de_dz !< gradient of sgs tke in z-direction (lpm) 317 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_diss !< artificial numerical dissipation flux at left face of grid box - TKE dissipation 318 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_e !< artificial numerical dissipation flux at left face of grid box - subgrid-scale TKE 319 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_nc !< artificial numerical dissipation flux at left face of grid box - clouddrop-number concentration 320 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_ng !< artificial numerical dissipation flux at left face of grid box - graupel-number concentration 321 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_ni !< artificial numerical dissipation flux at left face of grid box - ice crystal-number concentration 322 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_nr !< artificial numerical dissipation flux at left face of grid box - raindrop-number concentration 323 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_ns !< artificial numerical dissipation flux at left face of grid box - snow-number concentration 324 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_pt !< artificial numerical dissipation flux at left face of grid box - potential temperature 325 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_q !< artificial numerical dissipation flux at left face of grid box - total water mixing ratio 326 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_qc !< artificial numerical dissipation flux at left face of grid box - cloudwater 327 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_qg !< artificial numerical dissipation flux at left face of grid box - graupel 328 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_qi !< artificial numerical dissipation flux at left face of grid box - ice crystal 329 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_qr !< artificial numerical dissipation flux at left face of grid box - rainwater 330 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_qs !< artificial numerical dissipation flux at left face of grid box - snow 331 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_s !< artificial numerical dissipation flux at left face of grid box - passive scalar 332 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_sa !< artificial numerical dissipation flux at left face of grid box - salinity 333 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_u !< artificial numerical dissipation flux at left face of grid box - u-component 334 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_v !< artificial numerical dissipation flux at left face of grid box - v-component 335 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_w !< artificial numerical dissipation flux at left face of grid box - w-component 385 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_diss !< artificial numerical dissipation flux at left face of grid box - 386 !< TKE dissipation 387 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_e !< artificial numerical dissipation flux at left face of grid box - 388 !< subgrid-scale TKE 389 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_nc !< artificial numerical dissipation flux at left face of grid box - 390 !< clouddrop-number concentration 391 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_ng !< artificial numerical dissipation flux at left face of grid box - 392 !< graupel-number concentration 393 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_ni !< artificial numerical dissipation flux at left face of grid box - 394 !< ice crystal-number concentration 395 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_nr !< artificial numerical dissipation flux at left face of grid box - 396 !< raindrop-number concentration 397 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_ns !< artificial numerical dissipation flux at left face of grid box - 398 !< snow-number concentration 399 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_pt !< artificial numerical dissipation flux at left face of grid box - 400 !< potential temperature 401 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_q !< artificial numerical dissipation flux at left face of grid box - 402 !< total water mixing ratio 403 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_qc !< artificial numerical dissipation flux at left face of grid box - 404 !< cloudwater 405 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_qg !< artificial numerical dissipation flux at left face of grid box - 406 !< graupel 407 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_qi !< artificial numerical dissipation flux at left face of grid box - 408 !< ice crystal 409 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_qr !< artificial numerical dissipation flux at left face of grid box - 410 !< rainwater 411 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_qs !< artificial numerical dissipation flux at left face of grid box - 412 !< snow 413 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_s !< artificial numerical dissipation flux at left face of grid box - 414 !< passive scalar 415 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_sa !< artificial numerical dissipation flux at left face of grid box - 416 !< salinity 417 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_u !< artificial numerical dissipation flux at left face of grid box - 418 !< u-component 419 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_v !< artificial numerical dissipation flux at left face of grid box - 420 !< v-component 421 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: diss_l_w !< artificial numerical dissipation flux at left face of grid box - 422 !< w-component 336 423 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: flux_l_diss !< 6th-order advective flux at south face of grid box - TKE dissipation 337 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: flux_l_e !< 6th-order advective flux at south face of grid box - subgrid-scale TKE 338 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: flux_l_nc !< 6th-order advective flux at south face of grid box - clouddrop-number concentration 339 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: flux_l_ng !< 6th-order advective flux at south face of grid box - graupel-number concentration 340 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: flux_l_ni !< 6th-order advective flux at south face of grid box - ice crystal-number concentration 341 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: flux_l_nr !< 6th-order advective flux at south face of grid box - raindrop-number concentration 424 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: flux_l_e !< 6th-order advective flux at south face of grid box - subgrid-scale 425 !< TKE 426 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: flux_l_nc !< 6th-order advective flux at south face of grid box - clouddrop-number 427 !< concentration 428 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: flux_l_ng !< 6th-order advective flux at south face of grid box - 429 !< graupel-number concentration 430 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: flux_l_ni !< 6th-order advective flux at south face of grid box - 431 !< ice crystal-number concentration 432 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: flux_l_nr !< 6th-order advective flux at south face of grid box - raindrop-number 433 !< concentration 342 434 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: flux_l_ns !< 6th-order advective flux at south face of grid box - snow-number concentration 343 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: flux_l_pt !< 6th-order advective flux at south face of grid box - potential temperature 435 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: flux_l_pt !< 6th-order advective flux at south face of grid box - potential 436 !< temperature 344 437 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: flux_l_q !< 6th-order advective flux at south face of grid box - mixing ratio 345 438 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: flux_l_qc !< 6th-order advective flux at south face of grid box - cloudwater … … 356 449 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: km !< eddy diffusivity for momentum 357 450 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: prr !< rain rate 358 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: p_loc !< local array in multigrid/sor solver containing the pressure which is iteratively advanced in each iteration step 451 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: p_loc !< local array in multigrid/sor solver containing the pressure which is 452 !< iteratively advanced in each iteration step 359 453 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tend !< tendency field (time integration) 360 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tric !< coefficients of the tridiagonal matrix for solution of the Poisson equation in Fourier space 361 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: u_m_l !< velocity data (u at left boundary) from time level t-dt required for radiation boundary condition 362 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: u_m_n !< velocity data (u at north boundary) from time level t-dt required for radiation boundary condition 363 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: u_m_r !< velocity data (u at right boundary) from time level t-dt required for radiation boundary condition 364 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: u_m_s !< velocity data (u at south boundary) from time level t-dt required for radiation boundary condition 365 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: v_m_l !< velocity data (v at left boundary) from time level t-dt required for radiation boundary condition 366 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: v_m_n !< velocity data (v at north boundary) from time level t-dt required for radiation boundary condition 367 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: v_m_r !< velocity data (v at right boundary) from time level t-dt required for radiation boundary condition 368 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: v_m_s !< velocity data (v at south boundary) from time level t-dt required for radiation boundary condition 369 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: w_m_l !< velocity data (w at left boundary) from time level t-dt required for radiation boundary condition 370 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: w_m_n !< velocity data (w at north boundary) from time level t-dt required for radiation boundary condition 371 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: w_m_r !< velocity data (w at right boundary) from time level t-dt required for radiation boundary condition 372 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: w_m_s !< velocity data (w at south boundary) from time level t-dt required for radiation boundary condition 454 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: tric !< coefficients of the tridiagonal matrix for solution of the Poisson 455 !< equation in Fourier space 456 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: u_m_l !< velocity data (u at left boundary) from time level t-dt required for 457 !< radiation boundary condition 458 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: u_m_n !< velocity data (u at north boundary) from time level t-dt required for 459 !< radiation boundary condition 460 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: u_m_r !< velocity data (u at right boundary) from time level t-dt required for 461 !< radiation boundary condition 462 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: u_m_s !< velocity data (u at south boundary) from time level t-dt required for 463 !< radiation boundary condition 464 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: v_m_l !< velocity data (v at left boundary) from time level t-dt required for 465 !< radiation boundary condition 466 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: v_m_n !< velocity data (v at north boundary) from time level t-dt required for 467 !< radiation boundary condition 468 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: v_m_r !< velocity data (v at right boundary) from time level t-dt required for 469 !< radiation boundary condition 470 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: v_m_s !< velocity data (v at south boundary) from time level t-dt required for 471 !< radiation boundary condition 472 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: w_m_l !< velocity data (w at left boundary) from time level t-dt required for 473 !< radiation boundary condition 474 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: w_m_n !< velocity data (w at north boundary) from time level t-dt required for 475 !< radiation boundary condition 476 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: w_m_r !< velocity data (w at right boundary) from time level t-dt required for 477 !< radiation boundary condition 478 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: w_m_s !< velocity data (w at south boundary) from time level t-dt required for 479 !< radiation boundary condition 373 480 374 481 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: diss_1 !< pointer for swapping of timelevels for respective quantity … … 404 511 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: qc_2 !< pointer for swapping of timelevels for respective quantity 405 512 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: qc_3 !< pointer for swapping of timelevels for respective quantity 513 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: qf_1 !< pointer for swapping of timelevels for respective quantity 406 514 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: qg_1 !< pointer for swapping of timelevels for respective quantity 407 515 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: qg_2 !< pointer for swapping of timelevels for respective quantity … … 412 520 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: ql_v !< pointer: volume of liquid water 413 521 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: ql_vp !< pointer: liquid water weighting factor 414 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: qf_1 !< pointer for swapping of timelevels for respective quantity415 522 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: ql_1 !< pointer for swapping of timelevels for respective quantity 416 523 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: ql_2 !< pointer for swapping of timelevels for respective quantity … … 460 567 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: qc !< pointer: cloud water content 461 568 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: qc_p !< pointer: prognostic value cloud water content 569 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: qf !< pointer: frozen water content 462 570 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: qg !< pointer: graupel water content 463 571 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: qg_p !< pointer: prognostic value graupel water content 464 572 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: qi !< pointer: ice crystal content 465 573 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: qi_p !< pointer: prognostic value ice crystal content 466 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: qf !< pointer: frozen water content467 574 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ql !< pointer: liquid water content 468 575 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ql_c !< pointer: change in liquid water content due to … … 477 584 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: sa !< pointer: ocean salinity 478 585 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: sa_p !< pointer: prognostic value of ocean salinity 479 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tdiss_m !< pointer: weighted tendency of diss for previous sub-timestep (Runge-Kutta) 480 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: te_m !< pointer: weighted tendency of e for previous sub-timestep (Runge-Kutta) 481 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tnc_m !< pointer: weighted tendency of nc for previous sub-timestep (Runge-Kutta) 586 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tdiss_m !< pointer: weighted tendency of diss for previous sub-timestep 587 !< (Runge-Kutta) 588 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: te_m !< pointer: weighted tendency of e for previous sub-timestep 589 !< (Runge-Kutta) 590 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tnc_m !< pointer: weighted tendency of nc for previous sub-timestep 591 !< (Runge-Kutta) 482 592 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tng_m !< pointer: weighted tendency of ng for previous sub-timestep (Runge-Kutta) 483 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tni_m !< pointer: weighted tendency of ni for previous sub-timestep (Runge-Kutta) 484 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tnr_m !< pointer: weighted tendency of nr for previous sub-timestep (Runge-Kutta) 593 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tni_m !< pointer: weighted tendency of ni for previous sub-timestep 594 !< (Runge-Kutta) 595 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tnr_m !< pointer: weighted tendency of nr for previous sub-timestep 596 !< (Runge-Kutta) 485 597 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tns_m !< pointer: weighted tendency of ns for previous sub-timestep (Runge-Kutta) 486 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tpt_m !< pointer: weighted tendency of pt for previous sub-timestep (Runge-Kutta) 487 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tq_m !< pointer: weighted tendency of q for previous sub-timestep (Runge-Kutta) 488 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tqc_m !< pointer: weighted tendency of qc for previous sub-timestep (Runge-Kutta) 598 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tpt_m !< pointer: weighted tendency of pt for previous sub-timestep 599 !< (Runge-Kutta) 600 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tq_m !< pointer: weighted tendency of q for previous sub-timestep 601 !< (Runge-Kutta) 602 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tqc_m !< pointer: weighted tendency of qc for previous sub-timestep 603 !< (Runge-Kutta) 489 604 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tqg_m !< pointer: weighted tendency of qg for previous sub-timestep (Runge-Kutta) 490 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tqi_m !< pointer: weighted tendency of qi for previous sub-timestep (Runge-Kutta) 491 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tqr_m !< pointer: weighted tendency of qr for previous sub-timestep (Runge-Kutta) 605 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tqi_m !< pointer: weighted tendency of qi for previous sub-timestep 606 !< (Runge-Kutta) 607 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tqr_m !< pointer: weighted tendency of qr for previous sub-timestep 608 !< (Runge-Kutta) 492 609 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tqs_m !< pointer: weighted tendency of qs for previous sub-timestep (Runge-Kutta) 493 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ts_m !< pointer: weighted tendency of s for previous sub-timestep (Runge-Kutta) 494 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tsa_m !< pointer: weighted tendency of sa for previous sub-timestep (Runge-Kutta) 495 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tu_m !< pointer: weighted tendency of u for previous sub-timestep (Runge-Kutta) 496 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tv_m !< pointer: weighted tendency of v for previous sub-timestep (Runge-Kutta) 497 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tw_m !< pointer: weighted tendency of w for previous sub-timestep (Runge-Kutta) 610 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: ts_m !< pointer: weighted tendency of s for previous sub-timestep 611 !< (Runge-Kutta) 612 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tsa_m !< pointer: weighted tendency of sa for previous sub-timestep 613 !< (Runge-Kutta) 614 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tu_m !< pointer: weighted tendency of u for previous sub-timestep 615 !< (Runge-Kutta) 616 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tv_m !< pointer: weighted tendency of v for previous sub-timestep 617 !< (Runge-Kutta) 618 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: tw_m !< pointer: weighted tendency of w for previous sub-timestep 619 !< (Runge-Kutta) 498 620 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: u !< pointer: horizontal velocity component u (x-direction) 499 621 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: u_p !< pointer: prognostic value of u … … 504 626 REAL(wp), DIMENSION(:,:,:), POINTER, CONTIGUOUS :: w_p !< pointer: prognostic value of w 505 627 506 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tri !< array to hold the tridiagonal matrix for solution of the Poisson equation in Fourier space (4th dimension for threads) 507 508 REAL(wp), DIMENSION(:), ALLOCATABLE :: rho_air !< air density profile on the uv grid 509 REAL(wp), DIMENSION(:), ALLOCATABLE :: rho_air_zw !< air density profile on the w grid 510 REAL(wp), DIMENSION(:), ALLOCATABLE :: drho_air !< inverse air density profile on the uv grid 511 REAL(wp), DIMENSION(:), ALLOCATABLE :: drho_air_zw !< inverse air density profile on the w grid 512 513 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rho_air_mg !< air density profiles on the uv grid for multigrid 514 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: rho_air_zw_mg !< air density profiles on the w grid for multigrid 515 516 REAL(wp), DIMENSION(:), ALLOCATABLE :: heatflux_input_conversion !< conversion factor array for heatflux input 517 REAL(wp), DIMENSION(:), ALLOCATABLE :: waterflux_input_conversion !< conversion factor array for waterflux input 518 REAL(wp), DIMENSION(:), ALLOCATABLE :: momentumflux_input_conversion !< conversion factor array for momentumflux input 519 REAL(wp), DIMENSION(:), ALLOCATABLE :: heatflux_output_conversion !< conversion factor array for heatflux output 520 REAL(wp), DIMENSION(:), ALLOCATABLE :: waterflux_output_conversion !< conversion factor array for waterflux output 521 REAL(wp), DIMENSION(:), ALLOCATABLE :: momentumflux_output_conversion !< conversion factor array for momentumflux output 522 523 REAL(wp), DIMENSION(:), ALLOCATABLE :: hyrho !< density of air calculated with hydrostatic pressure 524 REAL(wp), DIMENSION(:), ALLOCATABLE :: exner !< ratio of actual and potential temperature 525 REAL(wp), DIMENSION(:), ALLOCATABLE :: d_exner !< ratio of potential and actual temperature 628 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: tri !< array to hold the tridiagonal matrix for solution of the Poisson 629 !< equation in Fourier space (4th dimension for threads) 526 630 527 631 SAVE … … 530 634 531 635 532 !------------------------------------------------------------------------------ !636 !--------------------------------------------------------------------------------------------------! 533 637 ! Description: 534 638 ! ------------ 535 639 !> Definition of variables needed for time-averaging of 2d/3d data. 536 !------------------------------------------------------------------------------ !640 !--------------------------------------------------------------------------------------------------! 537 641 MODULE averaging 538 642 … … 594 698 595 699 596 !------------------------------------------------------------------------------ !700 !--------------------------------------------------------------------------------------------------! 597 701 ! Description: 598 702 ! ------------ 599 703 !> Definition of parameters for program control 600 !------------------------------------------------------------------------------ !704 !--------------------------------------------------------------------------------------------------! 601 705 MODULE control_parameters 602 706 … … 608 712 END TYPE file_status 609 713 610 INTEGER, PARAMETER :: mask_xyz_dimension = 100 !< limit of mask dimensions (100 points in each direction) 611 INTEGER, PARAMETER :: max_masks = 50 !< maximum number of masks 714 INTEGER(iwp), PARAMETER :: fl_max = 500 !< maximum number of virtual-flight measurements 715 INTEGER, PARAMETER :: mask_xyz_dimension = 100 !< limit of mask dimensions (100 points in each direction) 716 INTEGER, PARAMETER :: max_masks = 50 !< maximum number of masks 717 INTEGER(iwp), PARAMETER :: var_fl_max = 20 !< maximum number of different sampling variables in virtual flight 718 !< measurements 612 719 INTEGER(iwp), PARAMETER :: varnamelength = 30 !< length of output variable names 613 720 … … 616 723 617 724 CHARACTER (LEN=1) :: cycle_mg = 'w' !< namelist parameter (see documentation) 618 CHARACTER (LEN=1) :: timestep_reason = ' ' !< 'A'dvection or 'D'iffusion criterion, written to RUN_CONTROL file 619 CHARACTER (LEN=8) :: coupling_char = '' !< appended to filenames in coupled or nested runs ('_O': ocean PE, 620 !< '_NV': vertically nested atmosphere PE, '_N##': PE of nested domain ## 621 CHARACTER (LEN=23) :: origin_date_time = '2019-06-21 12:00:00 +00' !< date and time to be simulated 725 CHARACTER (LEN=1) :: timestep_reason = ' ' !< 'A'dvection or 'D'iffusion criterion, written to 726 !< RUN_CONTROL file 727 CHARACTER (LEN=5) :: run_zone = ' ' !< time zone of simulation run 728 CHARACTER (LEN=8) :: coupling_char = '' !< appended to filenames in coupled or nested runs 729 !< ('_O': ocean PE, 730 !< '_NV': vertically nested atmosphere PE, '_N##': PE of 731 !< nested domain ## 732 CHARACTER (LEN=8) :: run_time = ' ' !< time of simulation run 733 CHARACTER (LEN=9) :: simulated_time_chr !< simulated time, printed to RUN_CONTROL file 622 734 CHARACTER (LEN=10) :: run_date = ' ' !< date of simulation run 623 CHARACTER (LEN=8) :: run_time = ' ' !< time of simulation run624 CHARACTER (LEN=5) :: run_zone = ' ' !< time zone of simulation run625 CHARACTER (LEN=9) :: simulated_time_chr !< simulated time, printed to RUN_CONTROL file626 735 CHARACTER (LEN=11) :: topography_grid_convention = ' ' !< namelist parameter 736 CHARACTER (LEN=12) :: revision = ' ' !< PALM revision number 627 737 CHARACTER (LEN=12) :: version = ' ' !< PALM version number 628 CHARACTER (LEN=12) :: revision = ' ' !< PALM revision number629 CHARACTER (LEN=12) :: user_interface_current_revision = ' ' !< revision number of the currently used user-interface(must match user_interface_required_revision)738 CHARACTER (LEN=12) :: user_interface_current_revision = ' ' !< revision number of the currently used user-interface 739 !< (must match user_interface_required_revision) 630 740 CHARACTER (LEN=12) :: user_interface_required_revision = ' ' !< required user-interface revision number 631 741 CHARACTER (LEN=16) :: conserve_volume_flow_mode = 'default' !< namelist parameter … … 635 745 CHARACTER (LEN=16) :: scalar_advec = 'ws-scheme' !< namelist parameter 636 746 CHARACTER (LEN=20) :: approximation = 'boussinesq' !< namelist parameter 637 CHARACTER (LEN=40) :: flux_input_mode = 'approximation-specific' !< type of flux input: dynamic or kinematic638 CHARACTER (LEN=40) :: flux_output_mode = 'approximation-specific' !< type of flux output: dynamic or kinematic639 747 CHARACTER (LEN=20) :: bc_e_b = 'neumann' !< namelist parameter 640 748 CHARACTER (LEN=20) :: bc_lr = 'cyclic' !< namelist parameter … … 651 759 CHARACTER (LEN=20) :: bc_uv_t = 'dirichlet' !< namelist parameter 652 760 CHARACTER (LEN=20) :: coupling_mode = 'uncoupled' !< coupling mode for atmosphere-ocean coupling 653 CHARACTER (LEN=20) :: coupling_mode_remote = 'uncoupled' !< coupling mode of the remote process in case of coupled atmosphere-ocean runs 761 CHARACTER (LEN=20) :: coupling_mode_remote = 'uncoupled' !< coupling mode of the remote process in case of coupled 762 !< atmosphere-ocean runs 654 763 CHARACTER (LEN=20) :: dissipation_1d = 'detering' !< namelist parameter 655 764 CHARACTER (LEN=20) :: fft_method = 'temperton-algorithm' !< namelist parameter 656 765 CHARACTER (LEN=20) :: mixing_length_1d = 'blackadar' !< namelist parameter 657 766 CHARACTER (LEN=20) :: random_generator = 'random-parallel' !< namelist parameter 658 CHARACTER (LEN=80) :: recycling_method_for_thermodynamic_quantities = 'turbulent_fluctuation' !< namelist parameter659 767 CHARACTER (LEN=20) :: reference_state = 'initial_profile' !< namelist parameter 660 768 CHARACTER (LEN=20) :: restart_data_format = 'fortran_binary' !< namelist parameter … … 663 771 CHARACTER (LEN=20) :: timestep_scheme = 'runge-kutta-3' !< namelist parameter 664 772 CHARACTER (LEN=20) :: turbulence_closure = '1.5-order' !< namelist parameter 773 CHARACTER (LEN=23) :: origin_date_time = '2019-06-21 12:00:00 +00' !< date and time to be simulated 774 CHARACTER (LEN=40) :: flux_input_mode = 'approximation-specific' !< type of flux input: dynamic or kinematic 775 CHARACTER (LEN=40) :: flux_output_mode = 'approximation-specific' !< type of flux output: dynamic or kinematic 665 776 CHARACTER (LEN=40) :: topography = 'flat' !< namelist parameter 666 CHARACTER (LEN=64) :: host = '????' !< configuration identifier as given by palmrun option -c, ENVPAR namelist parameter provided by palmrun 777 CHARACTER (LEN=64) :: host = '????' !< configuration identifier as given by palmrun option -c, 778 !< ENVPAR namelist parameter provided by palmrun 667 779 CHARACTER (LEN=80) :: log_message !< user-defined message for debugging (sse data_log.f90) 668 CHARACTER (LEN=80) :: run_identifier !< run identifier as given by palmrun option -r, ENVPAR namelist parameter provided by palmrun 780 CHARACTER (LEN=80) :: recycling_method_for_thermodynamic_quantities = 'turbulent_fluctuation' !< namelist parameter 781 CHARACTER (LEN=80) :: run_identifier !< run identifier as given by palmrun option -r, ENVPAR 782 !< namelist parameter provided by palmrun 669 783 CHARACTER (LEN=100) :: initializing_actions = ' ' !< namelist parameter 670 CHARACTER (LEN=100) :: restart_string = ' ' !< for storing strings in case of writing/reading restart data 671 CHARACTER (LEN=210) :: run_description_header !< string containing diverse run informations as run identifier, coupling mode, host, ensemble number, run date and time 784 CHARACTER (LEN=100) :: restart_string = ' ' !< for storing strings in case of writing/reading restart 785 !< data 786 CHARACTER (LEN=210) :: run_description_header !< string containing diverse run informations as run 787 !< identifier, coupling mode, host, ensemble number, run 788 !< date and time 672 789 CHARACTER (LEN=1000) :: debug_string = ' ' !<..... 673 790 CHARACTER (LEN=1000) :: message_string = ' ' !< dynamic string for error message output 674 791 675 CHARACTER (LEN=varnamelength), DIMENSION(500) :: data_output = ' ' !< namelist parameter 676 CHARACTER (LEN=varnamelength), DIMENSION(500) :: data_output_user = ' ' !< namelist parameter 677 CHARACTER (LEN=varnamelength), DIMENSION(500) :: doav = ' ' !< label array for multi-dimensional, 678 !< averaged output quantities 792 CHARACTER (LEN=varnamelength), DIMENSION(200) :: data_output_pr_user = ' ' !< namelist parameter 793 CHARACTER (LEN=varnamelength), DIMENSION(300) :: data_output_pr = ' ' !< namelist parameter 794 CHARACTER (LEN=varnamelength), DIMENSION(500) :: data_output = ' ' !< namelist parameter 795 CHARACTER (LEN=varnamelength), DIMENSION(500) :: data_output_user = ' ' !< namelist parameter 796 CHARACTER (LEN=varnamelength), DIMENSION(500) :: doav = ' ' !< label array for multi-dimensional, 797 !< averaged output quantities 679 798 680 799 CHARACTER (LEN=varnamelength), DIMENSION(max_masks,100) :: data_output_masks = ' ' !< namelist parameter 681 800 CHARACTER (LEN=varnamelength), DIMENSION(max_masks,100) :: data_output_masks_user = ' ' !< namelist parameter 682 683 CHARACTER (LEN=varnamelength), DIMENSION(300) :: data_output_pr = ' ' !< namelist parameter684 685 CHARACTER (LEN=varnamelength), DIMENSION(200) :: data_output_pr_user = ' ' !< namelist parameter801 CHARACTER (LEN=varnamelength), DIMENSION(0:1,500) :: do2d = ' ' !< label array for 2d output 802 !< quantities 803 CHARACTER (LEN=varnamelength), DIMENSION(0:1,500) :: do3d = ' ' !< label array for 3d output 804 !< quantities 686 805 687 806 CHARACTER (LEN=varnamelength), DIMENSION(max_masks,0:1,100) :: domask = ' ' !< label array for multi-dimensional, 688 807 !< masked output quantities 689 690 CHARACTER (LEN=varnamelength), DIMENSION(0:1,500) :: do2d = ' ' !< label array for 2d output quantities691 CHARACTER (LEN=varnamelength), DIMENSION(0:1,500) :: do3d = ' ' !< label array for 3d output quantities692 693 INTEGER(iwp), PARAMETER :: fl_max = 500 !< maximum number of virtual-flight measurements694 INTEGER(iwp), PARAMETER :: var_fl_max = 20 !< maximum number of different sampling variables in virtual flight measurements695 808 696 809 INTEGER(iwp) :: abort_mode = 1 !< abort condition (nested runs) … … 699 812 INTEGER(iwp) :: average_count_3d = 0 !< number of samples in 3d output 700 813 INTEGER(iwp) :: current_timestep_number = 0 !< current timestep number, printed to RUN_CONTROL file 701 INTEGER(iwp) :: coupling_topology = 0 !< switch for atmosphere-ocean-coupling: 0: same number of grid points and PEs along x and y in atmosphere and ocean, otherwise 1 702 INTEGER(iwp) :: dist_range = 0 !< switch for steering the horizontal disturbance range, 1: inflow disturbances in case of non-cyclic horizontal BC, 0: otherwise 814 INTEGER(iwp) :: coupling_topology = 0 !< switch for atmosphere-ocean-coupling: 0: same number of grid points and 815 !< PEs along x and y in atmosphere and ocean, otherwise 1 816 INTEGER(iwp) :: dist_range = 0 !< switch for steering the horizontal disturbance range, 1: inflow 817 !< disturbances in case of non-cyclic horizontal BC, 0: otherwise 703 818 INTEGER(iwp) :: disturbance_level_ind_b !< lowest grid index where flow disturbance is applied 704 819 INTEGER(iwp) :: disturbance_level_ind_t !< highest grid index where flow disturbance is applied … … 711 826 INTEGER(iwp) :: ensemble_member_nr = 0 !< namelist parameter 712 827 INTEGER(iwp) :: gamma_mg !< switch for steering the multigrid cycle: 1: v-cycle, 2: w-cycle 713 INTEGER(iwp) :: gathered_size !< number of total domain grid points of the grid level which is gathered on PE0 (multigrid solver) 828 INTEGER(iwp) :: gathered_size !< number of total domain grid points of the grid level which is gathered on 829 !< PE0 (multigrid solver) 714 830 INTEGER(iwp) :: grid_level !< current grid level handled in the multigrid solver 715 831 INTEGER(iwp) :: ibc_e_b !< integer flag for bc_e_b … … 729 845 INTEGER(iwp) :: intermediate_timestep_count_max !< maximum number of Runge-Kutta substeps 730 846 INTEGER(iwp) :: io_group = 0 !< I/O group to which the PE belongs (= #PE / io_blocks) 731 INTEGER(iwp) :: io_blocks = 1 !< number of blocks for which I/O is done in sequence (total number of PEs / maximum_parallel_io_streams) 847 INTEGER(iwp) :: io_blocks = 1 !< number of blocks for which I/O is done in sequence (total number of PEs / 848 !< maximum_parallel_io_streams) 732 849 INTEGER(iwp) :: iran = -1234567 !< integer random number used for flow disturbances 733 INTEGER(iwp) :: length = 0 !< integer that specifies the length of a string in case of writing/reading restart data 850 INTEGER(iwp) :: length = 0 !< integer that specifies the length of a string in case of writing/reading 851 !< restart data 734 852 INTEGER(iwp) :: masks = 0 !< counter for number of masked output quantities 735 853 INTEGER(iwp) :: maximum_grid_level !< number of grid levels that the multigrid solver is using 736 INTEGER(iwp) :: maximum_parallel_io_streams = -1 !< maximum number of parallel io streams that the underlying parallel file system allows, set with palmrun option -w, ENVPAR namelist parameter, provided by palmrun 854 INTEGER(iwp) :: maximum_parallel_io_streams = -1 !< maximum number of parallel io streams that the underlying parallel file 855 !< system allows, set with palmrun option -w, ENVPAR namelist parameter, provided by palmrun 737 856 INTEGER(iwp) :: max_pr_salsa = 0 !< number of salsa profiles (must not change within a job chain) 738 857 INTEGER(iwp) :: max_pr_user = 0 !< number of user-defined profiles (must not change within a job chain) 739 INTEGER(iwp) :: max_pr_user_tmp = 0 !< number of user-defined profiles that is temporary stored to check it against max_pr_user in case of restarts 740 INTEGER(iwp) :: mgcycles = 0 !< number of multigrid cycles that the multigrid solver has actually carried out 858 INTEGER(iwp) :: max_pr_user_tmp = 0 !< number of user-defined profiles that is temporary stored to check it 859 !< against max_pr_user in case of restarts 860 INTEGER(iwp) :: mgcycles = 0 !< number of multigrid cycles that the multigrid solver has actually carried 861 !< out 741 862 INTEGER(iwp) :: mg_cycles = 4 !< namelist parameter 742 863 INTEGER(iwp) :: mg_switch_to_pe0_level = -1 !< namelist parameter … … 750 871 INTEGER(iwp) :: num_leg=0 !< number of different legs in virtual flight measurements 751 872 INTEGER(iwp) :: num_var_fl !< number of sampling/output variables in virtual flight measurements 752 INTEGER(iwp) :: num_var_fl_user=0 !< number of user-defined sampling/output variables in virtual flight measurements 873 INTEGER(iwp) :: num_var_fl_user=0 !< number of user-defined sampling/output variables in virtual flight 874 !< measurements 753 875 INTEGER(iwp) :: number_stretch_level_start !< number of user-specified start levels for stretching 754 876 INTEGER(iwp) :: number_stretch_level_end !< number of user-specified end levels for stretching 755 877 INTEGER(iwp) :: nz_do3d = -9999 !< namelist parameter 756 878 INTEGER(iwp) :: prt_time_count = 0 !< number of output intervals for particle data output 757 INTEGER(iwp) :: recycling_plane !< position of recycling plane along x (in grid points) in case of turbulence recycling 879 INTEGER(iwp) :: recycling_plane !< position of recycling plane along x (in grid points) in case of turbulence 880 !< recycling 758 881 INTEGER(iwp) :: runnr = 0 !< number of run in job chain 759 882 INTEGER(iwp) :: subdomain_size !< number of grid points in (3d) subdomain including ghost points 760 883 INTEGER(iwp) :: symmetry_flag = 0 !< flag for sterring the symmetric behavior of the bottom and top boundary 761 884 INTEGER(iwp) :: terminate_coupled = 0 !< switch for steering termination in case of coupled runs 762 INTEGER(iwp) :: terminate_coupled_remote = 0 !< switch for steering termination in case of coupled runs (condition of the remote model) 885 INTEGER(iwp) :: terminate_coupled_remote = 0 !< switch for steering termination in case of coupled runs (condition of the 886 !< remote model) 763 887 INTEGER(iwp) :: timestep_count = 0 !< number of timesteps carried out since the beginning of the initial run 764 888 INTEGER(iwp) :: y_shift = 0 !< namelist parameter … … 776 900 INTEGER(iwp) :: domask_no(max_masks,0:1) = 0 !< number of masked output quantities 777 901 INTEGER(iwp) :: domask_time_count(max_masks,0:1) !< number of output intervals for masked data 778 INTEGER(iwp) :: dz_stretch_level_end_index(9) !< vertical grid level index until which the vertical grid spacing is stretched 779 INTEGER(iwp) :: dz_stretch_level_start_index(9) !< vertical grid level index above which the vertical grid spacing is stretched 902 INTEGER(iwp) :: dz_stretch_level_end_index(9) !< vertical grid level index until which the vertical grid spacing 903 !< is stretched 904 INTEGER(iwp) :: dz_stretch_level_start_index(9) !< vertical grid level index above which the vertical grid spacing 905 !< is stretched 780 906 INTEGER(iwp) :: mask_size(max_masks,3) = -1 !< size of mask array per mask and dimension (for netcdf output) 781 INTEGER(iwp) :: mask_size_l(max_masks,3) = -1 !< subdomain size of mask array per mask and dimension (for netcdf output) 907 INTEGER(iwp) :: mask_size_l(max_masks,3) = -1 !< subdomain size of mask array per mask and dimension 908 !< (for netcdf output) 782 909 INTEGER(iwp) :: mask_start_l(max_masks,3) = -1 !< subdomain start index of mask array (for netcdf output) 783 910 INTEGER(iwp) :: pt_vertical_gradient_level_ind(10) = -9999 !< grid index values of pt_vertical_gradient_level(s) … … 796 923 INTEGER(iwp), DIMENSION(0:1) :: ntdim_3d !< number of output intervals for 3d data 797 924 925 INTEGER(iwp), DIMENSION(max_masks,mask_xyz_dimension) :: mask_k_over_surface = -1 !< namelist parameter, k index of height 926 !<over surface 927 798 928 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: grid_level_count !< internal switch for steering the multigrid v- and w-cycles 799 929 … … 805 935 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mask_k_global !< global grid index of masked output point on z-dimension 806 936 807 INTEGER(iwp), DIMENSION(max_masks,mask_xyz_dimension) :: mask_k_over_surface = -1 !< namelist parameter, k index of height over surface808 937 809 938 LOGICAL :: agent_time_unlimited = .FALSE. !< namelist parameter 810 939 LOGICAL :: air_chemistry = .FALSE. !< chemistry model switch 811 LOGICAL :: bc_dirichlet_l = .FALSE. !< flag indicating dirichlet boundary condition on left model boundary 812 LOGICAL :: bc_dirichlet_n = .FALSE. !< flag indicating dirichlet boundary condition on north model boundary 813 LOGICAL :: bc_dirichlet_r = .FALSE. !< flag indicating dirichlet boundary condition on right model boundary 814 LOGICAL :: bc_dirichlet_s = .FALSE. !< flag indicating dirichlet boundary condition on south model boundary 940 LOGICAL :: bc_dirichlet_l = .FALSE. !< flag indicating dirichlet boundary condition on left model 941 !< boundary 942 LOGICAL :: bc_dirichlet_n = .FALSE. !< flag indicating dirichlet boundary condition on north model 943 !< boundary 944 LOGICAL :: bc_dirichlet_r = .FALSE. !< flag indicating dirichlet boundary condition on right model 945 !< boundary 946 LOGICAL :: bc_dirichlet_s = .FALSE. !< flag indicating dirichlet boundary condition on south model 947 !< boundary 815 948 LOGICAL :: bc_lr_cyc =.TRUE. !< left-right boundary condition cyclic? 816 949 LOGICAL :: bc_lr_dirrad = .FALSE. !< left-right boundary condition dirichlet/radiation? … … 820 953 LOGICAL :: bc_ns_raddir = .FALSE. !< north-south boundary condition radiation/dirichlet? 821 954 LOGICAL :: bc_radiation_l = .FALSE. !< radiation boundary condition for outflow at left domain boundary 822 LOGICAL :: bc_radiation_n = .FALSE. !< radiation boundary condition for outflow at north domain boundary 823 LOGICAL :: bc_radiation_r = .FALSE. !< radiation boundary condition for outflow at right domain boundary 824 LOGICAL :: bc_radiation_s = .FALSE. !< radiation boundary condition for outflow at south domain boundary 955 LOGICAL :: bc_radiation_n = .FALSE. !< radiation boundary condition for outflow at north domain 956 !< boundary 957 LOGICAL :: bc_radiation_r = .FALSE. !< radiation boundary condition for outflow at right domain 958 !< boundary 959 LOGICAL :: bc_radiation_s = .FALSE. !< radiation boundary condition for outflow at south domain 960 !< boundary 825 961 LOGICAL :: biometeorology = .FALSE. !< biometeorology module switch 826 962 LOGICAL :: calc_soil_moisture_during_spinup = .FALSE. !< namelist parameter … … 859 995 LOGICAL :: galilei_transformation = .FALSE. !< namelist parameter 860 996 LOGICAL :: humidity = .FALSE. !< namelist parameter 861 LOGICAL :: humidity_remote = .FALSE. !< switch for receiving near-surface humidity flux (atmosphere-ocean coupling) 997 LOGICAL :: humidity_remote = .FALSE. !< switch for receiving near-surface humidity flux 998 !< (atmosphere-ocean coupling) 862 999 LOGICAL :: include_total_domain_boundaries = .FALSE. !< store outer boundaries in restart file (MPI-IO) 863 1000 LOGICAL :: indoor_model = .FALSE. !< switch for indoor-climate and energy-demand model 864 LOGICAL :: kolmogorov_length_scale = .FALSE. !< switch to activate calculations in flow_statistics for the kolmogorov length scale 1001 LOGICAL :: kolmogorov_length_scale = .FALSE. !< switch to activate calculations in flow_statistics for the 1002 !< kolmogorov length scale 865 1003 LOGICAL :: large_scale_forcing = .FALSE. !< namelist parameter 866 1004 LOGICAL :: large_scale_subsidence = .FALSE. !< namelist parameter 867 1005 LOGICAL :: land_surface = .FALSE. !< use land surface model? 868 LOGICAL :: les_dai = .FALSE. !< use Dai et al. turbulence closure (modified 1.5-order closure) for LES mode. Shall replace the default 1.5-order closure 1006 LOGICAL :: les_dai = .FALSE. !< use Dai et al. turbulence closure (modified 1.5-order closure) 1007 !< for LES mode. Shall replace the default 1.5-order closure 869 1008 LOGICAL :: les_dynamic = .FALSE. !< use dynamic subgrid model as turbulence closure for LES mode 870 1009 LOGICAL :: les_default = .FALSE. !< use 1.5-order default turbulence closure for LES mode … … 873 1012 LOGICAL :: lsf_vert = .TRUE. !< use atmospheric forcing (large scale forcing)? 874 1013 LOGICAL :: masking_method = .FALSE. !< namelist parameter 875 LOGICAL :: mg_switch_to_pe0 = .FALSE. !< internal multigrid switch for steering the ghost point exchange in case that data has been collected on PE0 1014 LOGICAL :: mg_switch_to_pe0 = .FALSE. !< internal multigrid switch for steering the ghost point exchange 1015 !< in case that data has been collected on PE0 876 1016 LOGICAL :: monotonic_limiter_z = .FALSE. !< use monotonic flux limiter for vertical scalar advection 877 1017 LOGICAL :: nesting_offline = .FALSE. !< flag controlling offline nesting in COSMO model … … 885 1025 LOGICAL :: rans_tke_e = .FALSE. !< use TKE-e turbulence closure for RANS mode 886 1026 LOGICAL :: rans_tke_l = .FALSE. !< use TKE-l turbulence closure for RANS mode 887 LOGICAL :: read_svf = .FALSE. !< ENVPAR namelist parameter to steer input of svf (ENVPAR is provided by palmrun) 1027 LOGICAL :: read_svf = .FALSE. !< ENVPAR namelist parameter to steer input of svf 1028 !< (ENVPAR is provided by palmrun) 888 1029 LOGICAL :: run_control_header = .FALSE. !< onetime output of RUN_CONTROL header 889 LOGICAL :: run_coupled = .TRUE. !< internal switch telling PALM to run in coupled mode (i.e. to exchange surface data) in case of atmosphere-ocean coupling 1030 LOGICAL :: run_coupled = .TRUE. !< internal switch telling PALM to run in coupled mode 1031 !< (i.e. to exchange surface data) in case of atmosphere-ocean coupling 890 1032 LOGICAL :: salsa = .FALSE. !< switch for the sectional aerosol module salsa 891 1033 LOGICAL :: scalar_rayleigh_damping = .TRUE. !< namelist parameter … … 905 1047 LOGICAL :: use_fixed_date = .FALSE. !< date of simulation does not change (namelist parameter) 906 1048 LOGICAL :: use_fixed_time = .FALSE. !< time of simulation does not change (namelist parameter) 907 LOGICAL :: use_free_convection_scaling = .FALSE. !< namelist parameter to switch on free convection velocity scale in calculation of horizontal wind speed (surface_layer_fluxes) 1049 LOGICAL :: use_free_convection_scaling = .FALSE. !< namelist parameter to switch on free convection velocity scale 1050 !< in calculation of horizontal wind speed (surface_layer_fluxes) 908 1051 LOGICAL :: use_initial_profile_as_reference = .FALSE. !< use of initial profiles as reference state? 909 1052 LOGICAL :: use_prescribed_profile_data = .FALSE. !< use of prescribed wind profiles? … … 920 1063 LOGICAL :: wall_adjustment = .TRUE. !< namelist parameter 921 1064 LOGICAL :: wind_turbine = .FALSE. !< flag for use of wind turbine model 922 LOGICAL :: write_binary = .FALSE. !< ENVPAR namelist parameter to steer restart I/O (ENVPAR is provided by palmrun) 923 LOGICAL :: write_svf = .FALSE. !< ENVPAR namelist parameter to steer output of svf (ENVPAR is provided by palmrun) 1065 LOGICAL :: write_binary = .FALSE. !< ENVPAR namelist parameter to steer restart I/O 1066 !< (ENVPAR is provided by palmrun) 1067 LOGICAL :: write_svf = .FALSE. !< ENVPAR namelist parameter to steer output of svf 1068 !< (ENVPAR is provided by palmrun) 924 1069 LOGICAL :: ws_scheme_sca = .FALSE. !< use Wicker-Skamarock scheme (scalar advection)? 925 1070 LOGICAL :: ws_scheme_mom = .FALSE. !< use Wicker-Skamarock scheme (momentum advection)? … … 1067 1212 REAL(wp) :: time_restart = 9999999.9_wp !< time at which run shall be terminated and restarted 1068 1213 REAL(wp) :: time_run_control = 0.0_wp !< time since last RUN_CONTROL output 1069 REAL(wp) :: time_since_reference_point = 0.0_wp !< time after atmosphere-ocean coupling has been activated, or time after spinup phase of LSM has been finished 1214 REAL(wp) :: time_since_reference_point = 0.0_wp !< time after atmosphere-ocean coupling has been activated, or time 1215 !< after spinup phase of LSM has been finished 1070 1216 REAL(wp) :: top_heatflux = 9999999.9_wp !< namelist parameter 1071 1217 REAL(wp) :: top_momentumflux_u = 9999999.9_wp !< namelist parameter … … 1100 1246 REAL(wp) :: mask_scale(3) !< collective array for mask_scale_x/y/z 1101 1247 REAL(wp) :: pt_vertical_gradient(10) = 0.0_wp !< namelist parameter 1102 REAL(wp) :: pt_vertical_gradient_level(10) = -999999.9_wp !< namelist parameter1248 REAL(wp) :: pt_vertical_gradient_level(10) = -999999.9_wp !< namelist parameter 1103 1249 REAL(wp) :: q_vertical_gradient(10) = 0.0_wp !< namelist parameter 1104 REAL(wp) :: q_vertical_gradient_level(10) = -999999.9_wp !< namelist parameter1250 REAL(wp) :: q_vertical_gradient_level(10) = -999999.9_wp !< namelist parameter 1105 1251 REAL(wp) :: s_vertical_gradient(10) = 0.0_wp !< namelist parameter 1106 REAL(wp) :: s_vertical_gradient_level(10) = -999999.9_wp !< namelist parameter1252 REAL(wp) :: s_vertical_gradient_level(10) = -999999.9_wp !< namelist parameter 1107 1253 REAL(wp) :: skip_time_domask(max_masks) = 9999999.9_wp !< namelist parameter 1108 1254 REAL(wp) :: threshold(20) = 0.0_wp !< namelist parameter … … 1117 1263 REAL(wp) :: vg_vertical_gradient(10) = 0.0_wp !< namelist parameter 1118 1264 REAL(wp) :: vg_vertical_gradient_level(10) = -9999999.9_wp !< namelist parameter 1119 REAL(wp) :: volume_flow(1:3) = 0.0_wp !< volume flow through 1:yz-plane, 2: xz-plane, 3: xy-plane (nest childs only) 1265 REAL(wp) :: volume_flow(1:3) = 0.0_wp !< volume flow through 1:yz-plane, 2: xz-plane, 3: xy-plane 1266 !< (nest childs only) 1120 1267 REAL(wp) :: volume_flow_area(1:3) = 0.0_wp !< area of the respective volume flow planes 1121 REAL(wp) :: volume_flow_initial(1:3) = 0.0_wp !< initial volume flow (t=0) through the respective volume flow planes 1268 REAL(wp) :: volume_flow_initial(1:3) = 0.0_wp !< initial volume flow (t=0) through the respective volume flow 1269 !< planes 1122 1270 REAL(wp) :: wall_heatflux(0:5) = 0.0_wp !< namelist parameter 1123 1271 REAL(wp) :: wall_humidityflux(0:5) = 0.0_wp !< namelist parameter … … 1138 1286 1139 1287 ! 1140 !-- internal mask arrays ("mask,dimension,selection")1288 !-- Internal mask arrays ("mask,dimension,selection") 1141 1289 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: mask !< collective array for mask_x/y/z 1142 1290 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: mask_loop !< collective array for mask_x/y/z_loop … … 1147 1295 1148 1296 1149 !------------------------------------------------------------------------------ !1297 !--------------------------------------------------------------------------------------------------! 1150 1298 ! Description: 1151 1299 ! ------------ 1152 1300 !> Definition of grid spacings. 1153 !------------------------------------------------------------------------------ !1301 !--------------------------------------------------------------------------------------------------! 1154 1302 MODULE grid_variables 1155 1303 … … 1176 1324 1177 1325 1178 !------------------------------------------------------------------------------ !1326 !--------------------------------------------------------------------------------------------------! 1179 1327 ! Description: 1180 1328 ! ------------ 1181 1329 !> Definition of array bounds, number of gridpoints, and wall flag arrays. 1182 !------------------------------------------------------------------------------ !1330 !--------------------------------------------------------------------------------------------------! 1183 1331 MODULE indices 1184 1332 … … 1186 1334 1187 1335 INTEGER(iwp) :: nbgp = 3 !< number of boundary ghost points 1188 INTEGER(iwp) :: ngp_sums !< number of vertical profile grid points time number of output profiles - used for allreduce statements in MPI calls 1189 INTEGER(iwp) :: ngp_sums_ls !< number of vertical profile grid points time number of large-scale forcing profiles - used for allreduce statements in MPI calls 1336 INTEGER(iwp) :: ngp_sums !< number of vertical profile grid points time number of output profiles - used for allreduce 1337 !< statements in MPI calls 1338 INTEGER(iwp) :: ngp_sums_ls !< number of vertical profile grid points time number of large-scale forcing profiles - used for 1339 !< allreduce statements in MPI calls 1190 1340 INTEGER(iwp) :: nnx !< number of subdomain grid points in x-direction 1191 1341 INTEGER(iwp) :: nx = 0 !< nx+1 = total number of grid points in x-direction … … 1194 1344 INTEGER(iwp) :: nxl !< left-most grid index of subdomain (excluding ghost points) 1195 1345 INTEGER(iwp) :: nxlg !< left-most grid index of subdomain (including ghost points) 1196 INTEGER(iwp) :: nxlu !< =nxl+1 (at left domain boundary with inflow from left), else =nxl (used for u-velocity component) 1346 INTEGER(iwp) :: nxlu !< =nxl+1 (at left domain boundary with inflow from left), else =nxl 1347 !< (used for u-velocity component) 1197 1348 INTEGER(iwp) :: nxr !< right-most grid index of subdomain (excluding ghost points) 1198 1349 INTEGER(iwp) :: nxrg !< right-most grid index of subdomain (including ghost points) … … 1206 1357 INTEGER(iwp) :: nys !< south-most grid index of subdomain (excluding ghost points) 1207 1358 INTEGER(iwp) :: nysg !< south-most grid index of subdomain (including ghost points) 1208 INTEGER(iwp) :: nysv !< =nys+1 (at south domain boundary with inflow from south), else =nys (used for v-velocity component) 1359 INTEGER(iwp) :: nysv !< =nys+1 (at south domain boundary with inflow from south), else =nys 1360 !< (used for v-velocity component) 1209 1361 INTEGER(iwp) :: ny_on_file !< ny of previous run in job chain 1210 1362 INTEGER(iwp) :: nnz !< number of subdomain grid points in z-direction … … 1216 1368 INTEGER(iwp) :: topo_min_level !< minimum topography-top index (usually equal to nzb) 1217 1369 1370 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: ngp_2dh !< number of grid points of a horizontal cross section through the 1371 !< total domain 1218 1372 INTEGER(idp), DIMENSION(:), ALLOCATABLE :: ngp_3d !< number of grid points of the total domain 1219 1373 INTEGER(idp), DIMENSION(:), ALLOCATABLE :: ngp_3d_inner !< ! need to have 64 bit for grids > 2E9 1220 1221 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: ngp_2dh !< number of grid points of a horizontal cross section through the total domain 1222 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nxl_mg !< left-most grid index of subdomain on different multigrid level 1223 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nxr_mg !< right-most grid index of subdomain on different multigrid level 1224 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nyn_mg !< north-most grid index of subdomain on different multigrid level 1225 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nys_mg !< south-most grid index of subdomain on different multigrid level 1226 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nzt_mg !< top-most grid index of subdomain on different multigrid level 1227 1228 1229 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: ngp_2dh_outer !< number of horizontal grid points which are non-topography and non-surface-bounded 1374 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nxl_mg !< left-most grid index of subdomain on different multigrid level 1375 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nxr_mg !< right-most grid index of subdomain on different multigrid level 1376 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nyn_mg !< north-most grid index of subdomain on different multigrid level 1377 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nys_mg !< south-most grid index of subdomain on different multigrid level 1378 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: nzt_mg !< top-most grid index of subdomain on different multigrid level 1379 1380 1381 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mg_loc_ind !< internal array to store index bounds of all PEs of that 1382 !< multigrid level where data is collected to PE0 1383 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: ngp_2dh_outer !< number of horizontal grid points which are non-topography and 1384 !< non-surface-bounded 1230 1385 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: ngp_2dh_s_inner !< number of horizontal grid points which are non-topography 1231 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: mg_loc_ind !< internal array to store index bounds of all PEs of that multigrid level where data is collected to PE01232 1233 INTEGER(iwp), DIMENSION(:,:,:), POINTER :: flags !< pointer to wall_flags_1-101234 1386 1235 1387 INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: wall_flags_1 !< topograpyh masking flag on multigrid level 1 … … 1244 1396 INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE, TARGET :: wall_flags_10 !< topograpyh masking flag on multigrid level 10 1245 1397 1246 INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: advc_flags_m !< flags used to degrade order of advection scheme for momentum 1247 INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: advc_flags_s !< flags used to degrade order of advection scheme for scalar quantities 1398 INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: advc_flags_m !< flags used to degrade order of advection scheme for 1399 !< momentum 1400 INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: advc_flags_s !< flags used to degrade order of advection scheme for 1401 !< scalar quantities 1248 1402 INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: topo_top_ind !< precalculated topography top indices 1249 INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: wall_flags_static_0 !< flags to mask topography and surface-bounded grid points 1250 INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: wall_flags_total_0 !< merged array, which contains the static and dynamic flags 1403 INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: wall_flags_static_0 !< flags to mask topography and surface-bounded grid 1404 !< points 1405 INTEGER(iwp), DIMENSION(:,:,:), ALLOCATABLE :: wall_flags_total_0 !< merged array, which contains the static and dynamic 1406 !< flags 1407 1408 INTEGER(iwp), DIMENSION(:,:,:), POINTER :: flags !< pointer to wall_flags_1-10 1251 1409 1252 1410 SAVE … … 1255 1413 1256 1414 1257 !------------------------------------------------------------------------------ !1415 !--------------------------------------------------------------------------------------------------! 1258 1416 ! Description: 1259 1417 ! ------------ 1260 1418 !> Interfaces for special subroutines which use optional parameters. 1261 !------------------------------------------------------------------------------ !1419 !--------------------------------------------------------------------------------------------------! 1262 1420 MODULE interfaces 1263 1421 1264 1422 INTERFACE 1265 1423 1266 !------------------------------------------------------------------------------ !1424 !--------------------------------------------------------------------------------------------------! 1267 1425 ! Description: 1268 1426 ! ------------ 1269 1427 !> @todo Missing subroutine description. 1270 !------------------------------------------------------------------------------ !1271 SUBROUTINE global_min_max ( i1, i2, j1, j2, k1, k2, array, mode, offset, &1272 result , result_ijk, result1, result1_ijk )1428 !--------------------------------------------------------------------------------------------------! 1429 SUBROUTINE global_min_max ( i1, i2, j1, j2, k1, k2, array, mode, offset, result, result_ijk,& 1430 result1, result1_ijk ) 1273 1431 1274 1432 USE kinds 1275 1433 1276 CHARACTER (LEN=*), INTENT(IN) :: mode !< mode of global min/max function: can be 'min', 'max', 'minmax', 'abs', or 'absoff' 1434 CHARACTER (LEN=*), INTENT(IN) :: mode !< mode of global min/max function: can be 'min', 'max', 1435 !< 'minmax', 'abs', or 'absoff' 1436 1277 1437 INTEGER(iwp), INTENT(IN) :: i1 !< internal index of min/max function 1278 1438 INTEGER(iwp), INTENT(IN) :: i2 !< internal index of min/max function … … 1281 1441 INTEGER(iwp), INTENT(IN) :: k1 !< internal index of min/max function 1282 1442 INTEGER(iwp), INTENT(IN) :: k2 !< internal index of min/max function 1443 1283 1444 INTEGER(iwp) :: result_ijk(3) !< grid index result of min/max function 1284 1445 INTEGER(iwp), OPTIONAL :: result1_ijk(3) !< optional grid index result of min/max function 1285 REAL(wp) :: offset !< min/max function calculates absolute value with respect to an offset 1446 1447 REAL(wp) :: offset !< min/max function calculates absolute value with respect to 1448 !< an offset 1286 1449 REAL(wp) :: result !< result of min/max function 1287 1450 REAL(wp), OPTIONAL :: result1 !< optional result of min/max function 1451 1288 1452 REAL(wp), INTENT(IN) :: array(i1:i2,j1:j2,k1:k2) !< input array of min/max function 1289 1453 … … 1297 1461 1298 1462 1299 !------------------------------------------------------------------------------ !1463 !--------------------------------------------------------------------------------------------------! 1300 1464 ! Description: 1301 1465 ! ------------ 1302 !> Interfaces for subroutines with pointer arguments called in 1303 !> prognostic_equations. 1304 !------------------------------------------------------------------------------! 1466 !> Interfaces for subroutines with pointer arguments called in prognostic_equations. 1467 !--------------------------------------------------------------------------------------------------! 1305 1468 MODULE pointer_interfaces 1306 1469 1307 1470 INTERFACE 1308 1471 1309 !------------------------------------------------------------------------------ !1472 !--------------------------------------------------------------------------------------------------! 1310 1473 ! Description: 1311 1474 ! ------------ 1312 1475 !> @todo Missing subroutine description. 1313 !------------------------------------------------------------------------------ !1476 !--------------------------------------------------------------------------------------------------! 1314 1477 SUBROUTINE advec_s_bc( sk, sk_char ) 1315 1478 … … 1329 1492 1330 1493 1331 !------------------------------------------------------------------------------ !1494 !--------------------------------------------------------------------------------------------------! 1332 1495 ! Description: 1333 1496 ! ------------ 1334 !> Definition of variables which define processor topology and the exchange of 1335 !> ghost point layers. This module must be placed in all routines containing 1336 !> MPI-calls. 1337 !------------------------------------------------------------------------------! 1497 !> Definition of variables which define processor topology and the exchange of ghost point layers. 1498 !> This module must be placed in all routines containing MPI-calls. 1499 !--------------------------------------------------------------------------------------------------! 1338 1500 MODULE pegrid 1339 1501 … … 1349 1511 INTEGER(iwp) :: comm1dx !< communicator for domain decomposition along x 1350 1512 INTEGER(iwp) :: comm1dy !< communicator for domain decomposition along y 1351 INTEGER(iwp) :: comm2d !< standard 2d (xy) communicator used in PALM for the process group the PE belongs to 1513 INTEGER(iwp) :: comm2d !< standard 2d (xy) communicator used in PALM for the process group the PE belongs 1514 !< to 1352 1515 INTEGER(iwp) :: comm_inter !< intercommunicator that connects atmosphere/ocean process groups 1353 1516 INTEGER(iwp) :: comm_palm !< internal communicator used during the MPI setup at the beginning of a run … … 1361 1524 INTEGER(iwp) :: myidy = 0 !< id number of processor elements with same position along y-direction 1362 1525 INTEGER(iwp) :: ndim = 2 !< dimension of the virtual PE grid 1363 INTEGER(iwp) :: ngp_a !< used in atmosphere/ocean coupling: total number of horizontal grid points (atmosphere) 1364 INTEGER(iwp) :: ngp_o !< used in atmosphere/ocean coupling: total number of horizontal grid points (ocean) 1526 INTEGER(iwp) :: ngp_a !< used in atmosphere/ocean coupling: total number of horizontal grid points 1527 !< (atmosphere) 1528 INTEGER(iwp) :: ngp_o !< used in atmosphere/ocean coupling: total number of horizontal grid points 1529 !< (ocean) 1365 1530 INTEGER(iwp) :: ngp_xy !< used in atmosphere/ocean coupling: number of grid points of the subdomain 1366 1531 INTEGER(iwp) :: ngp_y !< number of subdomain grid points along y including ghost points … … 1374 1539 INTEGER(iwp) :: psouth !< MPI id of north neigbour pe 1375 1540 INTEGER(iwp) :: req_count = 0 !< MPI return variable - checks if Send-Receive operation is already finished 1376 INTEGER(iwp) :: sendrecvcount_xy !< number of subdomain gridpoints to be exchanged in direct transpositions (y --> x, or x --> y) or second (2d) transposition x --> y 1377 INTEGER(iwp) :: sendrecvcount_yz !< number of subdomain gridpoints to be exchanged in third (2d) transposition y --> z 1378 INTEGER(iwp) :: sendrecvcount_zx !< number of subdomain gridpoints to be exchanged in first (2d) transposition z --> x 1541 INTEGER(iwp) :: sendrecvcount_xy !< number of subdomain gridpoints to be exchanged in direct transpositions 1542 !< (y --> x, or x --> y) or second (2d) transposition x --> y 1543 INTEGER(iwp) :: sendrecvcount_yz !< number of subdomain gridpoints to be exchanged in third (2d) transposition 1544 !< y --> z 1545 INTEGER(iwp) :: sendrecvcount_zx !< number of subdomain gridpoints to be exchanged in first (2d) transposition 1546 !< z --> x 1379 1547 INTEGER(iwp) :: sendrecvcount_zyd !< number of subdomain gridpoints to be exchanged in direct transpositions z --> y (used for calculating spectra) 1380 INTEGER(iwp) :: target_id !< in atmosphere/ocean coupling: id of the ocean/atmosphere counterpart PE with whom the atmosphere/ocean PE exchanges data 1548 INTEGER(iwp) :: target_id !< in atmosphere/ocean coupling: id of the ocean/atmosphere counterpart PE with 1549 !< whom the atmosphere/ocean PE exchanges data 1381 1550 INTEGER(iwp) :: tasks_per_node = -9999 !< MPI tasks per compute node 1382 1551 INTEGER(iwp) :: threads_per_task = 1 !< number of OPENMP threads per MPI task … … 1408 1577 INTEGER(iwp) :: pcoord(2) !< PE coordinates along x and y 1409 1578 INTEGER(iwp) :: status(MPI_STATUS_SIZE) !< MPI status variable used in various MPI calls 1579 INTEGER(iwp) :: type_x_byte !< derived MPI datatype for 2-D 8-bit integer ghost-point exchange - north / south 1580 INTEGER(iwp) :: type_y_byte !< derived MPI datatype for 2-D integer ghost-point exchange - left / right 1410 1581 1411 1582 INTEGER(iwp), DIMENSION(MPI_STATUS_SIZE,100) :: wait_stat !< MPI status variable used in various MPI calls 1412 1413 INTEGER(iwp) :: type_x_byte !< derived MPI datatype for 2-D 8-bit integer ghost-point exchange - north / south1414 INTEGER(iwp) :: type_y_byte !< derived MPI datatype for 2-D integer ghost-point exchange - left / right1415 1583 1416 1584 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: ngp_xz !< number of ghost points in xz-plane on different multigrid level … … 1418 1586 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: ngp_yz !< number of ghost points in yz-plane on different multigrid level 1419 1587 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: ngp_yz_int !< number of ghost points in yz-plane on different multigrid level 1420 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: type_x_int !< derived MPI datatype for 2-D integer ghost-point exchange - north / south 1421 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: type_xz !< derived MPI datatype for 3-D integer ghost-point exchange - north / south 1422 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: type_xz_int !< derived MPI datatype for 3-D integer ghost-point exchange - north / south 1423 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: type_y_int !< derived MPI datatype for 2-D integer ghost-point exchange - left / right 1424 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: type_yz !< derived MPI datatype for 3-D integer ghost-point exchange - left / right 1425 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: type_yz_int !< derived MPI datatype for 3-D integer ghost-point exchange - left / right 1588 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: type_x_int !< derived MPI datatype for 2-D integer ghost-point exchange - north / 1589 !< south 1590 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: type_xz !< derived MPI datatype for 3-D integer ghost-point exchange - north / 1591 !< south 1592 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: type_xz_int !< derived MPI datatype for 3-D integer ghost-point exchange - north / 1593 !< south 1594 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: type_y_int !< derived MPI datatype for 2-D integer ghost-point exchange - left / 1595 !< right 1596 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: type_yz !< derived MPI datatype for 3-D integer ghost-point exchange - left / 1597 !< right 1598 INTEGER(iwp), DIMENSION(:), ALLOCATABLE :: type_yz_int !< derived MPI datatype for 3-D integer ghost-point exchange - left / 1599 !< right 1426 1600 1427 1601 LOGICAL :: left_border_pe = .FALSE. !< = .TRUE. if PE is on left border of computational domain … … 1440 1614 1441 1615 1442 !------------------------------------------------------------------------------ !1616 !--------------------------------------------------------------------------------------------------! 1443 1617 ! Description: 1444 1618 ! ------------ 1445 1619 !> Definition of variables which control PROFIL-output. 1446 !------------------------------------------------------------------------------ !1620 !--------------------------------------------------------------------------------------------------! 1447 1621 MODULE profil_parameter 1448 1622 … … 1452 1626 1453 1627 CHARACTER (LEN=27), DIMENSION(20) :: cross_ts_profiles = & !< time series to be plotted into one coordinate system, respectively 1454 (/ ' E E* ',&1455 ' dt ',&1456 ' u* w* ',&1457 ' th* ',&1458 ' umax vmax wmax ',&1459 ' div_old div_new ',&1460 ' zi_wtheta zi_theta ',&1461 ' w"theta"0 w"theta" wtheta ',&1462 ' theta(0) theta(zp) ',&1463 ' splux spluy spluz ',&1464 ' L ',&1465 ( ' ', i9 = 1, 9 ) /)1628 (/ ' E E* ', & 1629 ' dt ', & 1630 ' u* w* ', & 1631 ' th* ', & 1632 ' umax vmax wmax ', & 1633 ' div_old div_new ', & 1634 ' zi_wtheta zi_theta ', & 1635 ' w"theta"0 w"theta" wtheta ', & 1636 ' theta(0) theta(zp) ', & 1637 ' splux spluy spluz ', & 1638 ' L ', & 1639 ( ' ', i9 = 1, 9 ) /) 1466 1640 1467 1641 CHARACTER (LEN=100), DIMENSION(crmax) :: cross_profiles = & !< quantities to be plotted into one coordinate system, respectively 1468 (/ ' u v ', &1469 ' pt ', &1470 ' w"theta" w*theta* w*theta*BC wtheta wthetaBC ', &1471 ' w"u" w*u* wu w"v" w*v* wv ', &1472 ' km kh ', &1473 ' l ', &1474 ( ' ', i9 = 1, 94 ) /)1642 (/ ' u v ', & 1643 ' pt ', & 1644 ' w"theta" w*theta* w*theta*BC wtheta wthetaBC ', & 1645 ' w"u" w*u* wu w"v" w*v* wv ', & 1646 ' km kh ', & 1647 ' l ', & 1648 ( ' ', i9 = 1, 94 ) /) 1475 1649 1476 1650 INTEGER(iwp) :: profile_columns = 2 !< number of coordinate systems on a profile plot per column … … 1484 1658 END MODULE profil_parameter 1485 1659 1486 !------------------------------------------------------------------------------ !1660 !--------------------------------------------------------------------------------------------------! 1487 1661 ! Description: 1488 1662 ! ------------ 1489 1663 !> Definition of statistical quantities, e.g. global sums. 1490 !------------------------------------------------------------------------------ !1664 !--------------------------------------------------------------------------------------------------! 1491 1665 MODULE statistics 1492 1666 1493 1667 USE kinds 1494 1668 1495 CHARACTER (LEN=40) :: region(0:9) = & !< label for statistic region 1496 'total domain ' 1669 CHARACTER (LEN=40) :: region(0:9) = 'total domain ' !< label for statistic region 1497 1670 1498 1671 INTEGER(iwp) :: pr_palm = 200 !< maximum number of output profiles … … 1512 1685 REAL(wp), DIMENSION(2) :: z_i !< inversion height 1513 1686 1514 REAL(wp), DIMENSION(:), ALLOCATABLE :: mean_surface_level_height !< mean surface level height for the different statistic regions 1687 REAL(wp), DIMENSION(:), ALLOCATABLE :: mean_surface_level_height !< mean surface level height for the different statistic 1688 !< regions 1515 1689 REAL(wp), DIMENSION(:), ALLOCATABLE :: sums_divnew_l !< subdomain sum (_l) of divergence after pressure 1516 1690 !< solver call (new) 1517 1691 REAL(wp), DIMENSION(:), ALLOCATABLE :: sums_divold_l !< subdomain sum (_l) of divergence before pressure 1518 1692 !< solver call (old) 1693 REAL(wp), DIMENSION(:), ALLOCATABLE :: weight_pres !< substep weighting factor for pressure solver 1519 1694 REAL(wp), DIMENSION(:), ALLOCATABLE :: weight_substep !< weighting factor for substeps in timestepping 1520 REAL(wp), DIMENSION(:), ALLOCATABLE :: weight_pres !< substep weighting factor for pressure solver1521 1695 1522 1696 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums !< global sum array for the various output quantities 1523 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_salsa_ws_l !< subdomain sum of vertical salsa flux w's' (5th-order advection scheme only) 1697 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_ls_l !< subdomain sum of large scale forcing and nudging tendencies 1698 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_salsa_ws_l !< subdomain sum of vertical salsa flux w's' 1699 !< (5th-order advection scheme only) 1700 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_us2_ws_l !< subdomain sum of horizontal momentum flux u'u' 1701 !< (5th-order advection scheme only) 1702 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_vs2_ws_l !< subdomain sum of horizontal momentum flux v'v' 1703 !< (5th-order advection scheme only) 1704 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_ws2_ws_l !< subdomain sum of vertical momentum flux w'w' 1705 !< (5th-order advection scheme only) 1706 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsncs_ws_l !< subdomain sum of vertical clouddrop-number concentration flux 1707 !< w'nc' (5th-order advection scheme only) 1708 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsngs_ws_l !< subdomain sum of vertical graupel-number concentration flux w'nc' (5th-order advection scheme only) 1709 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsnis_ws_l !< subdomain sum of vertical ice crystal concentration flux w'ni' 1710 !< (5th-order advection scheme only) 1711 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsnrs_ws_l !< subdomain sum of vertical raindrop-number concentration flux w'nr' 1712 !< (5th-order advection scheme only) 1713 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsnss_ws_l !< subdomain sum of vertical snow-number concentration flux w'ns' (5th-order advection scheme only) 1714 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wssas_ws_l !< subdomain sum of vertical salinity flux w'sa' 1715 !< (5th-order advection scheme only) 1716 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsss_ws_l !< subdomain sum of vertical passive scalar flux w's' 1717 !< (5th-order advection scheme only) 1718 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wspts_ws_l !< subdomain sum of vertical sensible heat flux w'pt' 1719 !< (5th-order advection scheme only) 1720 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsqcs_ws_l !< subdomain sum of vertical cloudwater flux w'qc' 1721 !< (5th-order advection scheme only) 1722 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsqgs_ws_l !< subdomain sum of vertical graupel flux w'qg' (5th-order advection scheme only) 1723 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsqis_ws_l !< subdomain sum of vertical ice crystal flux w'qi' 1724 !< (5th-order advection scheme only) 1725 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsqrs_ws_l !< subdomain sum of vertical rainwater flux w'qr' 1726 !< (5th-order advection scheme only) 1727 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsqss_ws_l !< subdomain sum of vertical snow flux w'qs' (5th-order advection scheme only) 1728 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsqs_ws_l !< subdomain sum of vertical latent heat flux w'q' 1729 !< (5th-order advection scheme only) 1524 1730 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsts_bc_l !< subdomain sum of sensible heat flux in Bott-Chlond scheme 1731 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsus_ws_l !< subdomain sum of vertical momentum flux w'u' 1732 !< (5th-order advection scheme only) 1733 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsvs_ws_l !< subdomain sum of vertical momentum flux w'v' 1734 !< (5th-order advection scheme only) 1525 1735 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: ts_value !< timeseries output array for the various output quantities 1526 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsus_ws_l !< subdomain sum of vertical momentum flux w'u' (5th-order advection scheme only)1527 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsvs_ws_l !< subdomain sum of vertical momentum flux w'v' (5th-order advection scheme only)1528 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_us2_ws_l !< subdomain sum of horizontal momentum flux u'u' (5th-order advection scheme only)1529 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_vs2_ws_l !< subdomain sum of horizontal momentum flux v'v' (5th-order advection scheme only)1530 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_ws2_ws_l !< subdomain sum of vertical momentum flux w'w' (5th-order advection scheme only)1531 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsncs_ws_l !< subdomain sum of vertical clouddrop-number concentration flux w'nc' (5th-order advection scheme only)1532 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsngs_ws_l !< subdomain sum of vertical graupel-number concentration flux w'nc' (5th-order advection scheme only)1533 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsnis_ws_l !< subdomain sum of vertical ice crystal concentration flux w'ni' (5th-order advection scheme only)1534 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsnrs_ws_l !< subdomain sum of vertical raindrop-number concentration flux w'nr' (5th-order advection scheme only)1535 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsnss_ws_l !< subdomain sum of vertical snow-number concentration flux w'ns' (5th-order advection scheme only)1536 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wspts_ws_l !< subdomain sum of vertical sensible heat flux w'pt' (5th-order advection scheme only)1537 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsqs_ws_l !< subdomain sum of vertical latent heat flux w'q' (5th-order advection scheme only)1538 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsqcs_ws_l !< subdomain sum of vertical cloudwater flux w'qc' (5th-order advection scheme only)1539 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsqgs_ws_l !< subdomain sum of vertical graupel flux w'qg' (5th-order advection scheme only)1540 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsqis_ws_l !< subdomain sum of vertical ice crystal flux w'qi' (5th-order advection scheme only)1541 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsqrs_ws_l !< subdomain sum of vertical rainwater flux w'qr' (5th-order advection scheme only)1542 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsqss_ws_l !< subdomain sum of vertical snow flux w'qs' (5th-order advection scheme only)1543 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wssas_ws_l !< subdomain sum of vertical salinity flux w'sa' (5th-order advection scheme only)1544 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_wsss_ws_l !< subdomain sum of vertical passive scalar flux w's' (5th-order advection scheme only)1545 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: sums_ls_l !< subdomain sum of large scale forcing and nudging tendencies1546 1736 1547 1737 REAL(wp), DIMENSION(:,:), POINTER :: sums_wschs_ws_l !< subdomain sum of vertical chemistry flux w'ch' … … 1560 1750 1561 1751 1562 !------------------------------------------------------------------------------ !1752 !--------------------------------------------------------------------------------------------------! 1563 1753 ! Description: 1564 1754 ! ------------ 1565 1755 !> Definition of indices for transposed arrays. 1566 !------------------------------------------------------------------------------ !1756 !--------------------------------------------------------------------------------------------------! 1567 1757 MODULE transpose_indices 1568 1758 -
TabularUnified palm/trunk/SOURCE/multi_agent_system_mod.f90 ¶
r4623 r4753 1 1 !> @file multi_agent_system_mod.f90 2 !--------------------------------------------------------------------------------! 3 ! This file is part of PALM-4U. 4 ! 5 ! PALM-4U 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-4U 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/>. 2 !--------------------------------------------------------------------------------------------------! 3 ! This file is part of the PALM model system. 4 ! 5 ! PALM is free software: you can redistribute it and/or modify it under the 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/>. 16 15 ! 17 16 ! Copyright 2016-2020 Leibniz Universitaet Hannover 18 !------------------------------------------------------------------------------ !17 !--------------------------------------------------------------------------------------------------! 19 18 ! 20 19 ! Current revisions: … … 25 24 ! ----------------- 26 25 ! $Id$ 26 ! file re-formatted to follow the PALM coding standard 27 ! 28 ! 4623 2020-07-24 08:42:02Z raasch 27 29 ! some switches calculated explicitly to avoid compiler warnings 28 ! 30 ! 29 31 ! 4481 2020-03-31 18:55:54Z maronga 30 32 ! bugfix: cpp-directives for serial mode added 31 ! 33 ! 32 34 ! 4346 2019-12-18 11:55:56Z motisi 33 ! Removed wall_flags_static_0 from USE statements as it's not used within 34 ! the module 35 ! 35 ! Removed wall_flags_static_0 from USE statements as it's not used within the module 36 ! 36 37 ! 4329 2019-12-10 15:46:36Z motisi 37 38 ! Renamed wall_flags_0 to wall_flags_static_0 38 ! 39 ! 39 40 ! 4307 2019-11-26 14:12:36Z maronga 40 41 ! Activated output of iPT 41 ! 42 ! 42 43 ! 4182 2019-08-22 15:20:23Z scharf 43 44 ! Corrected "Former revisions" section 44 ! 45 ! 45 46 ! 4168 2019-08-16 13:50:17Z suehring 46 47 ! Replace function get_topography_top_index by topo_top_ind 47 ! 48 ! 48 49 ! 3987 2019-05-22 09:52:13Z kanani 49 50 ! Introduce alternative switch for debug output during timestepping 50 ! 51 ! 51 52 ! 3885 2019-04-11 11:29:34Z kanani 52 ! Changes related to global restructuring of location messages and introduction 53 ! of additional debugmessages54 ! 53 ! Changes related to global restructuring of location messages and introduction of additional debug 54 ! messages 55 ! 55 56 ! 3876 2019-04-08 18:41:49Z knoop 56 ! replaced nspec by nvar: only variable species should bconsidered, fixed species are not relevant 57 ! 57 ! replaced nspec by nvar: only variable species should bconsidered, fixed species are not relevant 58 ! 58 59 ! 3766 2019-02-26 16:23:41Z raasch 59 60 ! save attribute added to local targets to avoid outlive pointer target warning 60 ! 61 ! 61 62 ! 3665 2019-01-10 08:28:24Z raasch 62 63 ! unused variables removed 63 ! 64 ! 64 65 ! 3159 2018-07-20 11:20:01Z sward 65 66 ! Initial revision 66 67 ! 67 ! 68 ! 68 69 ! 69 70 ! Authors: … … 74 75 ! Description: 75 76 ! ------------ 76 !> Multi Agent System for the simulation of pedestrian movement in urban 77 !> environments 78 !------------------------------------------------------------------------------! 77 !> Multi Agent System for the simulation of pedestrian movement in urban environments 78 !--------------------------------------------------------------------------------------------------! 79 79 MODULE multi_agent_system_mod 80 80 81 81 USE, INTRINSIC :: ISO_C_BINDING 82 82 83 USE basic_constants_and_equations_mod, &83 USE basic_constants_and_equations_mod, & 84 84 ONLY: pi 85 85 86 USE control_parameters, &87 ONLY: biometeorology, &88 debug_output_timestep, &89 dt_3d, &90 dt_write_agent_data, &91 message_string, &86 USE control_parameters, & 87 ONLY: biometeorology, & 88 debug_output_timestep, & 89 dt_3d, & 90 dt_write_agent_data, & 91 message_string, & 92 92 time_since_reference_point 93 93 94 USE cpulog, &94 USE cpulog, & 95 95 ONLY: cpu_log, log_point, log_point_s 96 96 97 USE grid_variables, &97 USE grid_variables, & 98 98 ONLY: ddx, ddy, dx, dy 99 99 100 USE indices, & 101 ONLY: nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, nzb, & 102 topo_top_ind 103 104 USE random_function_mod, & 100 USE indices, & 101 ONLY: nx, nxl, nxlg, nxr, nxrg, ny, nyn, nyng, nys, nysg, nzb, topo_top_ind 102 103 USE random_function_mod, & 105 104 ONLY: random_function 106 105 … … 108 107 109 108 USE pegrid 109 110 INTEGER(iwp), PARAMETER :: max_number_of_agent_groups = 100 !< maximum allowed number of agent groups 111 INTEGER(iwp), PARAMETER :: nr_2_direction_move = 10000 !< parameter for agent exchange 112 INTEGER(iwp), PARAMETER :: phase_init = 1 !< phase parameter 113 INTEGER(iwp), PARAMETER :: phase_release = 2 !< phase parameter 110 114 111 115 CHARACTER(LEN=15) :: bc_mas_lr = 'absorb' !< left/right boundary condition 112 116 CHARACTER(LEN=15) :: bc_mas_ns = 'absorb' !< north/south boundary condition 113 117 118 INTEGER(iwp) :: agt_path_size = 15 !< size of agent path array 114 119 INTEGER(iwp) :: deleted_agents = 0 !< number of deleted agents per time step 115 120 INTEGER(iwp) :: dim_size_agtnum_manual = 9999999 !< namelist parameter (see documentation) … … 133 138 INTEGER(iwp) :: number_of_agent_groups = 1 !< namelist parameter (see documentation) 134 139 INTEGER(iwp) :: sort_count_mas = 0 !< counter for sorting agents 135 INTEGER(iwp) :: agt_path_size = 15 !< size of agent path array136 140 INTEGER(iwp) :: step_dealloc_mas = 100 !< namelist parameter (see documentation) 137 141 INTEGER(iwp) :: total_number_of_agents !< total number of agents in the whole model domain 138 139 INTEGER(iwp), PARAMETER :: NR_2_direction_move = 10000 !< parameter for agent exchange140 INTEGER(iwp), PARAMETER :: PHASE_INIT = 1 !< phase parameter141 INTEGER(iwp), PARAMETER :: PHASE_RELEASE = 2 !< phase parameter142 143 INTEGER(iwp), PARAMETER :: max_number_of_agent_groups = 100 !< maximum allowed number of agent groups144 142 145 143 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: agt_count !< 3d array of number of agents of every grid box … … 147 145 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: top_top_s !< k-index of first s-gridpoint above topography 148 146 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: top_top_w !< k-index of first v-gridpoint above topography 149 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: obstacle_flags !< flags to identify corners and edges of topography that cannot be crossed by agents 147 INTEGER(iwp), DIMENSION(:,:), ALLOCATABLE :: obstacle_flags !< flags to identify corners and edges of topography that cannot 148 !< be crossed by agents 150 149 151 150 LOGICAL :: deallocate_memory_mas = .TRUE. !< namelist parameter (see documentation) … … 245 244 END TYPE agent_type 246 245 246 TYPE(agent_type) :: zero_agent !< zero agent to avoid weird thing 247 247 248 TYPE(agent_type), DIMENSION(:), POINTER :: agents !< Agent array for this grid cell 248 TYPE(agent_type) :: zero_agent !< zero agent to avoid weird thing249 249 #if defined( __parallel ) 250 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: move_also_north !< for agent exchange between PEs251 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: move_also_south !< for agent exchange between PEs252 250 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: agt_gh_l !< ghost layer left of pe domain 253 251 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: agt_gh_n !< ghost layer north of pe domain 254 252 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: agt_gh_r !< ghost layer right of pe domain 255 253 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: agt_gh_s !< ghost layer south of pe domain 254 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: move_also_north !< for agent exchange between PEs 255 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: move_also_south !< for agent exchange between PEs 256 256 #endif 257 257 ! … … 338 338 339 339 340 !------------------------------------------------------------------------------ !340 !--------------------------------------------------------------------------------------------------! 341 341 ! Description: 342 342 ! ------------ 343 343 !> Multi Agent System: 344 344 !> executes a number of agents sub-timesteps until the model timestep is reached. 345 !> The agent timestep is usually smaller than the model timestep 346 !------------------------------------------------------------------------------ !345 !> The agent timestep is usually smaller than the model timestep. 346 !--------------------------------------------------------------------------------------------------! 347 347 SUBROUTINE multi_agent_system 348 348 349 USE biometeorology_mod, &350 ONLY: bio_calc_ipt, &351 bio_calculate_mrt_grid, &349 USE biometeorology_mod, & 350 ONLY: bio_calc_ipt, & 351 bio_calculate_mrt_grid, & 352 352 bio_get_thermal_index_input_ij 353 353 … … 362 362 INTEGER(iwp) :: js !< counter 363 363 INTEGER(iwp), SAVE :: mas_count = 0 !< counts the mas-calls 364 INTEGER(iwp) :: a !< agent iterator 365 !-- local meteorological conditions 366 REAL(wp) :: tmrt !< mean radiant temperature (degree_C) 367 REAL(wp) :: ta !< air temperature (degree_C) 368 REAL(wp) :: vp !< vapour pressure (hPa) 369 REAL(wp) :: v !< wind speed (local level) (m/s) 370 REAL(wp) :: pair !< air pressure (hPa) 364 INTEGER(iwp) :: a !< agent iterator 365 ! 366 !-- local meteorological conditions 367 REAL(wp) :: pair !< air pressure (hPa) 368 REAL(wp) :: ta !< air temperature (degree_C) 369 REAL(wp) :: tmrt !< mean radiant temperature (degree_C) 370 REAL(wp) :: v !< wind speed (local level) (m/s) 371 REAL(wp) :: vp !< vapour pressure (hPa) 371 372 372 373 … … 379 380 CALL cpu_log( log_point(9), 'mas', 'start' ) 380 381 ! 381 !-- Initialize variables for the next (sub-) timestep, i.e., for marking 382 !-- those agents to be deletedafter the timestep382 !-- Initialize variables for the next (sub-) timestep, i.e., for marking those agents to be deleted 383 !-- after the timestep 383 384 deleted_agents = 0 384 385 agent_substep_time = 0.0_wp … … 387 388 IF ( time_arel >= dt_arel .AND. end_time_arel > time_since_reference_point ) THEN 388 389 389 CALL mas_create_agent(PHASE_RELEASE) 390 ! 391 !-- The MOD function allows for changes in the output interval with 392 !-- restart runs. 390 CALL mas_create_agent( phase_release ) 391 ! 392 !-- The MOD function allows for changes in the output interval with restart runs. 393 393 time_arel = MOD( time_arel, MAX( dt_arel, dt_3d ) ) 394 394 … … 402 402 ! 403 403 !-- Timestep loop for agent transport. 404 !-- This loop has to be repeated until the transport time of every agent 405 !-- (within the total domain!)has reached the LES timestep (dt_3d).406 !-- Timestep scheme is Euler-forward 404 !-- This loop has to be repeated until the transport time of every agent (within the total domain!) 405 !-- has reached the LES timestep (dt_3d). 406 !-- Timestep scheme is Euler-forward. 407 407 DO 408 408 ! … … 415 415 CALL mas_data_output_agents ( first_call ) 416 416 #else 417 WRITE( message_string, * ) 'NetCDF is needed for agent output. ', &417 WRITE( message_string, * ) 'NetCDF is needed for agent output. ', & 418 418 'Set __netcdf in compiler options' 419 419 CALL message( 'multi_agent_system', 'PA0071', 1, 2, 0, 6, 0 ) … … 423 423 ENDIF 424 424 ! 425 !-- Flag is true by default, will be set to false if an agent has not yet 426 !-- reached the model timestep425 !-- Flag is true by default, will be set to false if an agent has not yet reached the model 426 !-- timestep. 427 427 grid_agents(:,:)%time_loop_done = .TRUE. 428 428 … … 466 466 agents(1:number_of_agents)%agent_mask = .TRUE. 467 467 ! 468 !-- Initialize the variable storing the total time that an agent 469 !-- has advanced within the timestep procedure468 !-- Initialize the variable storing the total time that an agent has advanced within the 469 !-- timestep procedure. 470 470 IF ( first_loop_stride ) THEN 471 471 agents(1:number_of_agents)%dt_sum = 0.0_wp 472 472 ENDIF 473 473 ! 474 !-- Initialize the switch used for the loop exit condition checked 475 !-- at the end of this loop. If at least one agent has failed to 476 !-- reach the LES timestep, this switch will be set false in 477 !-- mas_transport. 474 !-- Initialize the switch used for the loop exit condition checked at the end of this loop. 475 !-- If at least one agent has failed to reach the LES timestep, this switch will be set 476 !-- false in mas_transport. 478 477 dt_3d_reached_l_mas = .TRUE. 479 478 ! … … 481 480 CALL mas_timestep 482 481 ! 483 !-- Delete agents that have been simulated longer than allowed 482 !-- Delete agents that have been simulated longer than allowed. 484 483 CALL mas_boundary_conds( 'max_sim_time' ) 485 484 ! 486 !-- Delete agents that have reached target area 485 !-- Delete agents that have reached target area. 487 486 CALL mas_boundary_conds( 'target_area' ) 488 487 ! 489 !--- If not all agents of the actual grid cell have reached the 490 !-- LES timestep, this cell has to to another loop iteration. Due to 491 !-- the fact that agents can move into neighboring grid cell, 492 !-- these neighbor cells also have to perform another loop iteration 488 !-- If not all agents of the actual grid cell have reached the LES timestep, this cell has 489 !-- to do another loop iteration. Due to the fact that agents can move into neighboring 490 !-- grid cell, these neighbor cells also have to perform another loop iteration. 493 491 IF ( .NOT. dt_3d_reached_l_mas ) THEN 494 492 js = MAX(nys,j-1) … … 504 502 505 503 ! 506 !-- Find out, if all agents on e very PE have completed the LES timestep507 !-- and set the switch corespondingly504 !-- Find out, if all agents on each PE have completed the LES timestep and set the switch 505 !-- corespondingly. 508 506 dt_3d_reached_l_mas = ALL(grid_agents(:,:)%time_loop_done) 509 507 #if defined( __parallel ) 510 508 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 511 CALL MPI_ALLREDUCE( dt_3d_reached_l_mas, dt_3d_reached_mas, 1, MPI_LOGICAL, &512 MPI_LAND,comm2d, ierr )509 CALL MPI_ALLREDUCE( dt_3d_reached_l_mas, dt_3d_reached_mas, 1, MPI_LOGICAL, MPI_LAND, & 510 comm2d, ierr ) 513 511 #else 514 512 dt_3d_reached_mas = dt_3d_reached_l_mas … … 527 525 CALL mas_eh_exchange_horiz 528 526 ! 529 !-- Pack agents (eliminate those marked for deletion), 530 !-- determine new number of agents 527 !-- Pack agents (eliminate those marked for deletion), determine new number of agents 531 528 CALL mas_ps_sort_in_subboxes 532 529 CALL cpu_log( log_point_s(18), 'mas_move_exch_sort', 'stop' ) 533 530 ! 534 !-- Initialize variables for the next (sub-) timestep, i.e., for marking 535 !-- those agents to bedeleted after the timestep531 !-- Initialize variables for the next (sub-) timestep, i.e., for marking those agents to be 532 !-- deleted after the timestep 536 533 deleted_agents = 0 537 534 … … 556 553 ! 557 554 !-- Determine local meteorological conditions 558 CALL bio_get_thermal_index_input_ij ( .FALSE., i, j, ta, vp, & 559 v, pair, tmrt ) 555 CALL bio_get_thermal_index_input_ij ( .FALSE., i, j, ta, vp, v, pair, tmrt ) 560 556 561 557 DO a = 1, number_of_agents … … 563 559 !-- Calculate instationary thermal indices based on local tmrt 564 560 565 CALL bio_calc_ipt ( ta, vp, v, pair, tmrt, &566 agents(a)%dt_sum, &567 agents(a)%energy_storage, &568 agents(a)%clothing_temp, &569 agents(a)%clo, &570 agents(a)%actlev, &571 agents(a)%age_years, &572 agents(a)%weight, &573 agents(a)%height, &574 agents(a)%work, &575 agents(a)%sex, &561 CALL bio_calc_ipt ( ta, vp, v, pair, tmrt, & 562 agents(a)%dt_sum, & 563 agents(a)%energy_storage, & 564 agents(a)%clothing_temp, & 565 agents(a)%clo, & 566 agents(a)%actlev, & 567 agents(a)%age_years, & 568 agents(a)%weight, & 569 agents(a)%height, & 570 agents(a)%work, & 571 agents(a)%sex, & 576 572 agents(a)%ipt ) 577 573 END DO … … 602 598 END SUBROUTINE multi_agent_system 603 599 604 !------------------------------------------------------------------------------ !600 !--------------------------------------------------------------------------------------------------! 605 601 ! Description: 606 602 ! ------------ 607 !> Calculation of the direction vector from each agent to its current 608 !> intermittent target 609 !------------------------------------------------------------------------------! 610 SUBROUTINE mas_agent_direction 611 612 IMPLICIT NONE 613 614 LOGICAL :: path_flag !< true if new path must be calculated 615 616 INTEGER(iwp) :: n !< loop variable over all agents in a grid box 617 INTEGER(iwp) :: pc !< agent path counter 618 619 REAL(wp) :: abs_dir !< length of direction vector (for normalization) 620 ! REAL(wp) :: d_curr_target !< rounding influence expressed as x speed component 621 ! REAL(wp) :: d_prev_target !< rounding influence expressed as x speed component 622 REAL(wp) :: dir_x !< direction of agent (x) 623 REAL(wp) :: dir_y !< direction of agent (y) 624 ! REAL(wp) :: dist_round = 3. !< distance at which agents start rounding a corner 625 REAL(wp) :: dtit !< distance to intermittent target 626 ! REAL(wp) :: round_fac = 0.2 !< factor for rounding influence 627 ! REAL(wp) :: speed_round_x !< rounding influence expressed as x speed component 628 ! REAL(wp) :: speed_round_y !< rounding influence expressed as x speed component 629 630 ! 631 !-- loop over all agents in the current grid box 632 DO n = 1, number_of_agents 633 path_flag = .FALSE. 603 !> Calculation of the direction vector from each agent to its current intermittent target. 604 !--------------------------------------------------------------------------------------------------! 605 SUBROUTINE mas_agent_direction 606 607 IMPLICIT NONE 608 609 LOGICAL :: path_flag !< true if new path must be calculated 610 611 INTEGER(iwp) :: n !< loop variable over all agents in a grid box 612 INTEGER(iwp) :: pc !< agent path counter 613 614 REAL(wp) :: abs_dir !< length of direction vector (for normalization) 615 ! REAL(wp) :: d_curr_target !< rounding influence expressed as x speed component 616 ! REAL(wp) :: d_prev_target !< rounding influence expressed as x speed component 617 REAL(wp) :: dir_x !< direction of agent (x) 618 REAL(wp) :: dir_y !< direction of agent (y) 619 ! REAL(wp) :: dist_round = 3. !< distance at which agents start rounding a corner 620 REAL(wp) :: dtit !< distance to intermittent target 621 ! REAL(wp) :: round_fac = 0.2 !< factor for rounding influence 622 ! REAL(wp) :: speed_round_x !< rounding influence expressed as x speed component 623 ! REAL(wp) :: speed_round_y !< rounding influence expressed as x speed component 624 625 ! 626 !-- Loop over all agents in the current grid box 627 DO n = 1, number_of_agents 628 path_flag = .FALSE. 629 pc = agents(n)%path_counter 630 ! 631 !-- If no path was calculated for agent yet, do it. 632 IF ( pc >= 999 ) THEN 633 CALL mas_nav_find_path(n) 634 634 pc = agents(n)%path_counter 635 635 ! 636 !-- If no path was calculated for agent yet, do it 637 IF ( pc >= 999 ) THEN 636 !-- Check if new path must be calculated and if so, do it. 637 ELSE 638 ! 639 !-- Case one: Agent has come close enough to intermittent target. 640 !-- -> chose new int target and calculate rest of path if no 641 !-- new intermittent targets are left 642 dtit = SQRT( ( agents(n)%x - agents(n)%path_x(pc) )**2 & 643 + ( agents(n)%y - agents(n)%path_y(pc) )**2 ) 644 IF ( dtit < dist_to_int_target ) THEN 645 agents(n)%path_counter = agents(n)%path_counter + 1 646 pc = agents(n)%path_counter 647 ! 648 !-- Path counter out of scope (each agent can store a maximum of 15 intermittent targets on 649 !-- the way to its final target); new path must be calculated. 650 IF ( pc >= SIZE( agents(n)%path_x) ) THEN 651 path_flag = .TRUE. 652 ENDIF 653 ! 654 !-- Case two: Agent too far from path 655 !-- -> set flag for new path to be calculated 656 ELSEIF ( dist_point_to_edge(agents(n)%path_x(pc-1), & 657 agents(n)%path_y(pc-1), & 658 agents(n)%path_x(pc), & 659 agents(n)%path_y(pc), & 660 agents(n)%x, agents(n)%y) & 661 > max_dist_from_path ) & 662 THEN 663 path_flag = .TRUE. 664 ENDIF 665 ! 666 !-- If one of the above two cases was true, calculate new path and reset 0th path point. 667 !-- This point (the last target the agent had) is needed for the agent's rounding of corners 668 !-- and the calculation of its deviation from its current path. 669 IF ( path_flag ) THEN 638 670 CALL mas_nav_find_path(n) 639 671 pc = agents(n)%path_counter 640 !641 !-- Check if new path must be calculated and if so, do it642 ELSE643 !644 !-- Case one: Agent has come close enough to intermittent target.645 !-- -> chose new int target and calculate rest of path if no646 !-- new intermittent targets are left647 dtit = SQRT((agents(n)%x - agents(n)%path_x(pc))**2 &648 + (agents(n)%y - agents(n)%path_y(pc))**2)649 IF ( dtit < dist_to_int_target ) THEN650 agents(n)%path_counter = agents(n)%path_counter + 1651 pc = agents(n)%path_counter652 !653 !-- Path counter out of scope (each agent can store a maximum of 15654 !-- intermittent targets on the way to her final target); new path655 !-- must be calculated656 IF ( pc >= SIZE(agents(n)%path_x) ) THEN657 path_flag = .TRUE.658 ENDIF659 !660 !-- Case two: Agent too far from path661 !-- -> set flag for new path to be calculated662 ELSEIF ( dist_point_to_edge(agents(n)%path_x(pc-1), &663 agents(n)%path_y(pc-1), &664 agents(n)%path_x(pc), &665 agents(n)%path_y(pc), &666 agents(n)%x, agents(n)%y) &667 > max_dist_from_path ) &668 THEN669 path_flag = .TRUE.670 ENDIF671 !672 !-- If either of the above two cases was true, calculate new path and673 !-- reset 0th path point. This point (the last target the agent had)674 !-- is needed for the agents rounding of corners and the calculation675 !-- of her deviation from her current path676 IF ( path_flag ) THEN677 CALL mas_nav_find_path(n)678 pc = agents(n)%path_counter679 ENDIF680 672 ENDIF 681 ! 682 !-- Normalize direction vector 683 abs_dir = 1.0d-12 684 dir_x = agents(n)%path_x(pc) - agents(n)%x 685 dir_y = agents(n)%path_y(pc) - agents(n)%y 686 abs_dir = SQRT(dir_x**2 + dir_y**2)+1.0d-12 687 !-- needed later for corner rounding 688 ! dir_x = dir_x/abs_dir 689 ! dir_y = dir_y/abs_dir 690 ! dir_x = dir_x + speed_round_x 691 ! dir_y = dir_y + speed_round_y 692 ! abs_dir = SQRT(dir_x**2 + dir_y**2)+1.0d-12 693 agents(n)%speed_e_x = dir_x/abs_dir 694 agents(n)%speed_e_y = dir_y/abs_dir 695 ENDDO 673 ENDIF 674 ! 675 !-- Normalize direction vector 676 abs_dir = 1.0d-12 677 dir_x = agents(n)%path_x(pc) - agents(n)%x 678 dir_y = agents(n)%path_y(pc) - agents(n)%y 679 abs_dir = SQRT( dir_x**2 + dir_y**2 )+1.0d-12 680 !-- needed later for corner rounding 681 ! dir_x = dir_x/abs_dir 682 ! dir_y = dir_y/abs_dir 683 ! dir_x = dir_x + speed_round_x 684 ! dir_y = dir_y + speed_round_y 685 ! abs_dir = SQRT(dir_x**2 + dir_y**2)+1.0d-12 686 agents(n)%speed_e_x = dir_x/abs_dir 687 agents(n)%speed_e_y = dir_y/abs_dir 688 ENDDO 696 689 697 690 ! … … 702 695 ! speed_round_x = 0. 703 696 ! speed_round_y = 0. 704 ! 697 ! 705 698 ! d_curr_target = SQRT( (agents(n)%path_x(pc) - agents(n)%x)**2 + & 706 699 ! (agents(n)%path_y(pc) - agents(n)%y)**2 ) … … 722 715 ! SIN( pi/dist_round*d_curr_target ) 723 716 ! ENDIF 724 ! 725 ! IF ( d_prev_target < dist_round ) THEN726 ! IF ( agents(n)%path_x(pc) /= agents(n)%path_x(pc+1) ) THEN717 ! 718 ! IF ( d_prev_target < dist_round ) THEN 719 ! IF ( agents(n)%path_x(pc) /= agents(n)%path_x(pc+1) ) THEN 727 720 ! speed_round_x = speed_round_x + & 728 721 ! (agents(n)%path_x(pc) - agents(n)%path_x(pc+1)) / & … … 731 724 ! SIN( pi/dist_round*d_prev_target ) 732 725 ! ENDIF 733 ! 734 ! IF ( agents(n)%path_y(pc) /= agents(n)%path_y(pc+1) ) THEN726 ! 727 ! IF ( agents(n)%path_y(pc) /= agents(n)%path_y(pc+1) ) THEN 735 728 ! speed_round_y = speed_round_y + & 736 729 ! (agents(n)%path_y(pc) - agents(n)%path_y(pc+1)) / & … … 739 732 ! SIN( pi/dist_round*d_prev_target ) 740 733 ! ENDIF 741 734 742 735 ! ENDIF 743 736 744 737 745 746 747 !------------------------------------------------------------------------------ !738 END SUBROUTINE mas_agent_direction 739 740 !--------------------------------------------------------------------------------------------------! 748 741 ! Description: 749 742 ! ------------ 750 743 !> Boundary conditions for maximum time, target reached and out of domain 751 !------------------------------------------------------------------------------! 752 SUBROUTINE mas_boundary_conds( location ) 753 754 IMPLICIT NONE 755 756 CHARACTER (LEN=*) :: location !< Identifier 757 758 INTEGER(iwp) :: n !< agent number 759 INTEGER(iwp) :: grp !< agent group 760 761 REAL(wp) :: dist_to_target !< distance to target 762 763 IF ( location == 'max_sim_time' ) THEN 764 765 ! 766 !-- Delete agents that have been simulated longer than allowed 767 DO n = 1, number_of_agents 768 769 IF ( agents(n)%age > agent_maximum_age .AND. & 770 agents(n)%agent_mask ) & 771 THEN 772 agents(n)%agent_mask = .FALSE. 773 deleted_agents = deleted_agents + 1 774 ENDIF 775 776 ENDDO 777 ENDIF 778 779 IF ( location == 'target_area' ) THEN 780 781 ! 782 !-- Delete agents that entered target region 783 DO n = 1, number_of_agents 784 grp = agents(n)%group 785 dist_to_target = SQRT((agents(n)%x-at_x(grp))**2 & 786 + (agents(n)%y-at_y(grp))**2) 787 IF ( dist_to_target < dist_target_reached ) THEN 788 agents(n)%agent_mask = .FALSE. 789 deleted_agents = deleted_agents + 1 790 ENDIF 791 792 ENDDO 793 ENDIF 794 795 END SUBROUTINE mas_boundary_conds 796 797 !------------------------------------------------------------------------------! 744 !--------------------------------------------------------------------------------------------------! 745 SUBROUTINE mas_boundary_conds( location ) 746 747 IMPLICIT NONE 748 749 CHARACTER (LEN=*) :: location !< Identifier 750 751 INTEGER(iwp) :: grp !< agent group 752 INTEGER(iwp) :: n !< agent number 753 754 REAL(wp) :: dist_to_target !< distance to target 755 756 IF ( location == 'max_sim_time' ) THEN 757 758 ! 759 !-- Delete agents that have been simulated longer than allowed 760 DO n = 1, number_of_agents 761 762 IF ( agents(n)%age > agent_maximum_age .AND. agents(n)%agent_mask ) THEN 763 agents(n)%agent_mask = .FALSE. 764 deleted_agents = deleted_agents + 1 765 ENDIF 766 767 ENDDO 768 ENDIF 769 770 IF ( location == 'target_area' ) THEN 771 772 ! 773 !-- Delete agents that entered target region 774 DO n = 1, number_of_agents 775 grp = agents(n)%group 776 dist_to_target = SQRT( ( agents(n)%x - at_x(grp) )**2 + ( agents(n)%y - at_y(grp) )**2 ) 777 IF ( dist_to_target < dist_target_reached ) THEN 778 agents(n)%agent_mask = .FALSE. 779 deleted_agents = deleted_agents + 1 780 ENDIF 781 782 ENDDO 783 ENDIF 784 785 END SUBROUTINE mas_boundary_conds 786 787 !--------------------------------------------------------------------------------------------------! 798 788 ! Description: 799 789 ! ------------ 800 790 !> Release new agents at their respective sources 801 !------------------------------------------------------------------------------! 802 SUBROUTINE mas_create_agent (phase) 803 804 IMPLICIT NONE 805 806 INTEGER(iwp) :: alloc_size !< relative increase of allocated memory for agents 807 INTEGER(iwp) :: i !< loop variable ( agent groups ) 808 INTEGER(iwp) :: ip !< index variable along x 809 INTEGER(iwp) :: jp !< index variable along y 810 INTEGER(iwp) :: loop_stride !< loop variable for initialization 811 INTEGER(iwp) :: n !< loop variable ( number of agents ) 812 INTEGER(iwp) :: new_size !< new size of allocated memory for agents 813 INTEGER(iwp) :: rn_side !< index of agent path 814 815 INTEGER(iwp), INTENT(IN) :: phase !< mode of inititialization 816 817 INTEGER(iwp), DIMENSION(nysg:nyng,nxlg:nxrg) :: local_count !< start address of new agent 818 INTEGER(iwp), DIMENSION(nysg:nyng,nxlg:nxrg) :: local_start !< start address of new agent 819 820 LOGICAL :: first_stride !< flag for initialization 821 822 REAL(wp) :: pos_x !< increment for agent position in x 823 REAL(wp) :: pos_y !< increment for agent position in y 824 REAL(wp) :: rand_contr !< dummy argument for random position 825 REAL(wp) :: rn_side_dum !< index of agent path 826 827 TYPE(agent_type),TARGET :: tmp_agent !< temporary agent used for initialization 828 829 ! 830 !-- Calculate agent positions and store agent attributes, if 831 !-- agent is situated on this PE 832 DO loop_stride = 1, 2 833 first_stride = (loop_stride == 1) 834 IF ( first_stride ) THEN 835 local_count = 0 ! count number of agents 836 ELSE 837 local_count = agt_count ! Start address of new agents 838 ENDIF 839 840 DO i = 1, number_of_agent_groups 841 842 pos_y = ass(i) 843 844 DO WHILE ( pos_y <= asn(i) ) 845 846 IF ( pos_y >= nys * dy .AND. & 847 pos_y < ( nyn + 1 ) * dy ) & 848 THEN 849 850 pos_x = asl(i) 851 852 xloop: DO WHILE ( pos_x <= asr(i) ) 853 854 IF ( pos_x >= nxl * dx .AND. & 855 pos_x < ( nxr + 1) * dx ) & 856 THEN 857 858 tmp_agent%agent_mask = .TRUE. 859 tmp_agent%group = i 860 tmp_agent%id = 0_idp 861 tmp_agent%block_nr = -1 862 tmp_agent%path_counter = 999 !SIZE(tmp_agent%path_x) 863 tmp_agent%age = 0.0_wp 864 tmp_agent%age_m = 0.0_wp 865 tmp_agent%dt_sum = 0.0_wp 866 tmp_agent%clo = -999.0_wp 867 tmp_agent%energy_storage= 0.0_wp 868 tmp_agent%ipt = 99999.0_wp 869 tmp_agent%clothing_temp = -999._wp !< energy stored by agent (W) 870 tmp_agent%actlev = 134.6862_wp !< metabolic + work energy of the person 871 tmp_agent%age_years = 35._wp !< physical age of the person 872 tmp_agent%weight = 75._wp !< total weight of the person (kg) 873 tmp_agent%height = 1.75_wp !< height of the person (m) 874 tmp_agent%work = 134.6862_wp !< workload of the agent (W) 875 tmp_agent%sex = 1 !< agents gender: 1 = male, 2 = female 876 tmp_agent%force_x = 0.0_wp 877 tmp_agent%force_y = 0.0_wp 878 tmp_agent%origin_x = pos_x 879 tmp_agent%origin_y = pos_y 880 tmp_agent%speed_abs = 0.0_wp 881 tmp_agent%speed_e_x = 0.0_wp 882 tmp_agent%speed_e_y = 0.0_wp 883 tmp_agent%speed_des = random_normal(desired_speed,& 884 des_sp_sig) 885 tmp_agent%speed_x = 0.0_wp 886 tmp_agent%speed_y = 0.0_wp 887 tmp_agent%x = pos_x 888 tmp_agent%y = pos_y 889 tmp_agent%path_x = -1.0_wp 890 tmp_agent%path_y = -1.0_wp 891 tmp_agent%t_x = - pi 892 tmp_agent%t_y = - pi 893 ! 894 !-- Determine the grid indices of the agent position 895 ip = tmp_agent%x * ddx 896 jp = tmp_agent%y * ddy 897 ! 898 !-- Give each agent its target 899 IF ( a_rand_target(i) ) THEN 900 ! 901 !-- Agent shall receive random target just outside 902 !-- simulated area 903 rn_side_dum = random_function(iran_agent) 904 rn_side = FLOOR(4.*rn_side_dum) 905 IF ( rn_side < 2 ) THEN 906 IF ( rn_side == 0 ) THEN 907 tmp_agent%t_y = -2*dy 908 ELSE 909 tmp_agent%t_y = (ny+3)*dy 910 ENDIF 911 tmp_agent%t_x = random_function(iran_agent) * & 912 (nx+1)*dx 791 !--------------------------------------------------------------------------------------------------! 792 SUBROUTINE mas_create_agent ( phase ) 793 794 IMPLICIT NONE 795 796 INTEGER(iwp) :: alloc_size !< relative increase of allocated memory for agents 797 INTEGER(iwp) :: i !< loop variable ( agent groups ) 798 INTEGER(iwp) :: ip !< index variable along x 799 INTEGER(iwp) :: jp !< index variable along y 800 INTEGER(iwp) :: loop_stride !< loop variable for initialization 801 INTEGER(iwp) :: n !< loop variable ( number of agents ) 802 INTEGER(iwp) :: new_size !< new size of allocated memory for agents 803 INTEGER(iwp) :: rn_side !< index of agent path 804 805 INTEGER(iwp), INTENT(IN) :: phase !< mode of inititialization 806 807 INTEGER(iwp), DIMENSION(nysg:nyng,nxlg:nxrg) :: local_count !< start address of new agent 808 INTEGER(iwp), DIMENSION(nysg:nyng,nxlg:nxrg) :: local_start !< start address of new agent 809 810 LOGICAL :: first_stride !< flag for initialization 811 812 REAL(wp) :: pos_x !< increment for agent position in x 813 REAL(wp) :: pos_y !< increment for agent position in y 814 REAL(wp) :: rand_contr !< dummy argument for random position 815 REAL(wp) :: rn_side_dum !< index of agent path 816 817 TYPE(agent_type),TARGET :: tmp_agent !< temporary agent used for initialization 818 819 ! 820 !-- Calculate agent positions and store agent attributes, if agent is situated on this PE. 821 DO loop_stride = 1, 2 822 first_stride = (loop_stride == 1) 823 IF ( first_stride ) THEN 824 local_count = 0 ! count number of agents 825 ELSE 826 local_count = agt_count ! Start address of new agents 827 ENDIF 828 829 DO i = 1, number_of_agent_groups 830 831 pos_y = ass(i) 832 833 DO WHILE ( pos_y <= asn(i) ) 834 835 IF ( pos_y >= nys * dy .AND. pos_y < ( nyn + 1 ) * dy ) THEN 836 837 pos_x = asl(i) 838 839 xloop: DO WHILE ( pos_x <= asr(i) ) 840 841 IF ( pos_x >= nxl * dx .AND. pos_x < ( nxr + 1) * dx ) THEN 842 843 tmp_agent%agent_mask = .TRUE. 844 tmp_agent%group = i 845 tmp_agent%id = 0_idp 846 tmp_agent%block_nr = -1 847 tmp_agent%path_counter = 999 !SIZE(tmp_agent%path_x) 848 tmp_agent%age = 0.0_wp 849 tmp_agent%age_m = 0.0_wp 850 tmp_agent%dt_sum = 0.0_wp 851 tmp_agent%clo = -999.0_wp 852 tmp_agent%energy_storage= 0.0_wp 853 tmp_agent%ipt = 99999.0_wp 854 tmp_agent%clothing_temp = -999._wp !< energy stored by agent (W) 855 tmp_agent%actlev = 134.6862_wp !< metabolic + work energy of the person 856 tmp_agent%age_years = 35._wp !< physical age of the person 857 tmp_agent%weight = 75._wp !< total weight of the person (kg) 858 tmp_agent%height = 1.75_wp !< height of the person (m) 859 tmp_agent%work = 134.6862_wp !< workload of the agent (W) 860 tmp_agent%sex = 1 !< agents gender: 1 = male, 2 = female 861 tmp_agent%force_x = 0.0_wp 862 tmp_agent%force_y = 0.0_wp 863 tmp_agent%origin_x = pos_x 864 tmp_agent%origin_y = pos_y 865 tmp_agent%speed_abs = 0.0_wp 866 tmp_agent%speed_e_x = 0.0_wp 867 tmp_agent%speed_e_y = 0.0_wp 868 tmp_agent%speed_des = random_normal(desired_speed,des_sp_sig) 869 tmp_agent%speed_x = 0.0_wp 870 tmp_agent%speed_y = 0.0_wp 871 tmp_agent%x = pos_x 872 tmp_agent%y = pos_y 873 tmp_agent%path_x = -1.0_wp 874 tmp_agent%path_y = -1.0_wp 875 tmp_agent%t_x = - pi 876 tmp_agent%t_y = - pi 877 ! 878 !-- Determine the grid indices of the agent position 879 ip = tmp_agent%x * ddx 880 jp = tmp_agent%y * ddy 881 ! 882 !-- Give each agent its target 883 IF ( a_rand_target(i) ) THEN 884 ! 885 !-- Agent shall receive random target just outside simulated area 886 rn_side_dum = random_function(iran_agent) 887 rn_side = FLOOR( 4.*rn_side_dum ) 888 IF ( rn_side < 2 ) THEN 889 IF ( rn_side == 0 ) THEN 890 tmp_agent%t_y = -2 * dy 913 891 ELSE 914 IF ( rn_side == 2 ) THEN 915 tmp_agent%t_x = -2*dx 916 ELSE 917 tmp_agent%t_x = (nx+3)*dx 918 ENDIF 919 tmp_agent%t_y = random_function(iran_agent) * & 920 (ny+1)*dy 892 tmp_agent%t_y = ( ny + 3 ) * dy 921 893 ENDIF 922 ! 923 !-- Agent gets target of her group 894 tmp_agent%t_x = random_function(iran_agent) * ( nx + 1 ) * dx 924 895 ELSE 925 tmp_agent%t_x = at_x(i) 926 tmp_agent%t_y = at_y(i) 896 IF ( rn_side == 2 ) THEN 897 tmp_agent%t_x = -2 * dx 898 ELSE 899 tmp_agent%t_x = ( nx + 3 ) * dx 900 ENDIF 901 tmp_agent%t_y = random_function(iran_agent) * ( ny + 1 ) * dy 927 902 ENDIF 928 929 local_count(jp,ip) = local_count(jp,ip) + 1 930 931 IF ( .NOT. first_stride ) THEN 932 grid_agents(jp,ip)%agents(local_count(jp,ip)) & 933 = tmp_agent 934 ENDIF 935 903 ! 904 !-- Agent gets target of her group 905 ELSE 906 tmp_agent%t_x = at_x(i) 907 tmp_agent%t_y = at_y(i) 936 908 ENDIF 937 909 938 pos_x = pos_x + adx(i) 939 940 ENDDO xloop 941 942 ENDIF 943 944 pos_y = pos_y + ady(i) 945 946 ENDDO 910 local_count(jp,ip) = local_count(jp,ip) + 1 911 912 IF ( .NOT. first_stride ) THEN 913 grid_agents(jp,ip)%agents(local_count(jp,ip)) = tmp_agent 914 ENDIF 915 916 ENDIF 917 918 pos_x = pos_x + adx(i) 919 920 ENDDO xloop 921 922 ENDIF 923 924 pos_y = pos_y + ady(i) 947 925 948 926 ENDDO 949 927 950 ! 951 !-- Allocate or reallocate agents array to new size 952 IF ( first_stride ) THEN 953 DO ip = nxlg, nxrg 954 DO jp = nysg, nyng 955 IF ( phase == PHASE_INIT ) THEN 956 IF ( local_count(jp,ip) > 0 ) THEN 957 alloc_size = MAX( INT( local_count(jp,ip) * & 958 ( 1.0_wp + alloc_factor_mas / 100.0_wp ) ), & 959 min_nr_agent ) 960 ELSE 961 alloc_size = min_nr_agent 962 ENDIF 963 ALLOCATE(grid_agents(jp,ip)%agents(1:alloc_size)) 964 DO n = 1, alloc_size 965 grid_agents(jp,ip)%agents(n) = zero_agent 966 ENDDO 967 ELSEIF ( phase == PHASE_RELEASE ) THEN 968 IF ( local_count(jp,ip) > 0 ) THEN 969 new_size = local_count(jp,ip) + agt_count(jp,ip) 970 alloc_size = MAX( INT( new_size * ( 1.0_wp + & 971 alloc_factor_mas / 100.0_wp ) ), min_nr_agent ) 972 IF( alloc_size > SIZE( grid_agents(jp,ip)%agents) ) & 973 THEN 974 CALL mas_eh_realloc_agents_array(ip,jp,alloc_size) 975 ENDIF 928 ENDDO 929 930 ! 931 !-- Allocate or reallocate agents array to new size 932 IF ( first_stride ) THEN 933 DO ip = nxlg, nxrg 934 DO jp = nysg, nyng 935 IF ( phase == phase_init ) THEN 936 IF ( local_count(jp,ip) > 0 ) THEN 937 alloc_size = MAX( INT( local_count(jp,ip) * & 938 ( 1.0_wp + alloc_factor_mas / 100.0_wp ) ), & 939 min_nr_agent ) 940 ELSE 941 alloc_size = min_nr_agent 942 ENDIF 943 ALLOCATE( grid_agents(jp,ip)%agents(1:alloc_size) ) 944 DO n = 1, alloc_size 945 grid_agents(jp,ip)%agents(n) = zero_agent 946 ENDDO 947 ELSEIF ( phase == phase_release ) THEN 948 IF ( local_count(jp,ip) > 0 ) THEN 949 new_size = local_count(jp,ip) + agt_count(jp,ip) 950 alloc_size = MAX( INT( new_size * & 951 ( 1.0_wp + alloc_factor_mas / 100.0_wp ) ), & 952 min_nr_agent ) 953 IF( alloc_size > SIZE( grid_agents(jp,ip)%agents) ) THEN 954 CALL mas_eh_realloc_agents_array(ip,jp,alloc_size) 976 955 ENDIF 977 956 ENDIF 978 END DO957 ENDIF 979 958 ENDDO 980 ENDIF 959 ENDDO 960 ENDIF 961 962 ENDDO 963 964 local_start = agt_count+1 965 agt_count = local_count 966 967 ! 968 !-- Calculate agent IDs 969 DO ip = nxl, nxr 970 DO jp = nys, nyn 971 number_of_agents = agt_count(jp,ip) 972 IF ( number_of_agents <= 0 ) CYCLE 973 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 974 975 DO n = local_start(jp,ip), number_of_agents !only new agents 976 977 agents(n)%id = 10000_idp**2 * grid_agents(jp,ip)%id_counter + 10000_idp * jp + ip 978 ! 979 !-- Count the number of agents that have been released before 980 grid_agents(jp,ip)%id_counter = grid_agents(jp,ip)%id_counter + 1 981 982 ENDDO 981 983 982 984 ENDDO 983 984 local_start = agt_count+1 985 agt_count = local_count 986 987 ! 988 !-- Calculate agent IDs 985 ENDDO 986 987 ! 988 !-- Add random fluctuation to agent positions. 989 IF ( random_start_position_agents ) THEN 989 990 DO ip = nxl, nxr 990 991 DO jp = nys, nyn … … 992 993 IF ( number_of_agents <= 0 ) CYCLE 993 994 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 994 995 DO n = local_start(jp,ip), number_of_agents !only new agents 996 997 agents(n)%id = 10000_idp**2 * grid_agents(jp,ip)%id_counter + & 998 10000_idp * jp + ip 999 ! 1000 !-- Count the number of agents that have been released before 1001 grid_agents(jp,ip)%id_counter = grid_agents(jp,ip)%id_counter & 1002 + 1 1003 995 ! 996 !-- Move only new agents. Moreover, limit random fluctuation in order to prevent that 997 !-- agents move more than one grid box, which would lead to problems concerning agent 998 !-- exchange between processors in case adx/ady are larger than dx/dy, respectively. 999 DO n = local_start(jp,ip), number_of_agents 1000 IF ( asl(agents(n)%group) /= asr(agents(n)%group) ) THEN 1001 rand_contr = ( random_function( iran_agent ) - 0.5_wp ) * adx(agents(n)%group) 1002 agents(n)%x = agents(n)%x + MERGE( rand_contr, SIGN( dx, rand_contr ), & 1003 ABS( rand_contr ) < dx & 1004 ) 1005 ENDIF 1006 IF ( ass(agents(n)%group) /= asn(agents(n)%group) ) THEN 1007 rand_contr = ( random_function( iran_agent ) - 0.5_wp ) * ady(agents(n)%group) 1008 agents(n)%y = agents(n)%y + & 1009 MERGE( rand_contr, SIGN( dy, rand_contr ), ABS( rand_contr ) < dy ) 1010 ENDIF 1004 1011 ENDDO 1012 ! 1013 !-- Delete agents that have been simulated longer than allowed 1014 CALL mas_boundary_conds( 'max_sim_time' ) 1015 ! 1016 !-- Delete agents that have reached target area 1017 CALL mas_boundary_conds( 'target_area' ) 1005 1018 1006 1019 ENDDO 1007 1020 ENDDO 1008 1009 ! 1010 !-- Add random fluctuation to agent positions. 1011 IF ( random_start_position_agents ) THEN 1012 DO ip = nxl, nxr 1013 DO jp = nys, nyn 1014 number_of_agents = agt_count(jp,ip) 1015 IF ( number_of_agents <= 0 ) CYCLE 1016 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 1017 ! 1018 !-- Move only new agents. Moreover, limit random fluctuation 1019 !-- in order to prevent that agents move more than one grid box, 1020 !-- which would lead to problems concerning agent exchange 1021 !-- between processors in case adx/ady are larger than dx/dy, 1022 !-- respectively. 1023 DO n = local_start(jp,ip), number_of_agents 1024 IF ( asl(agents(n)%group) /= asr(agents(n)%group) ) THEN 1025 rand_contr = ( random_function( iran_agent ) - 0.5_wp ) *& 1026 adx(agents(n)%group) 1027 agents(n)%x = agents(n)%x + & 1028 MERGE( rand_contr, SIGN( dx, rand_contr ), & 1029 ABS( rand_contr ) < dx & 1030 ) 1031 ENDIF 1032 IF ( ass(agents(n)%group) /= asn(agents(n)%group) ) THEN 1033 rand_contr = ( random_function( iran_agent ) - 0.5_wp ) *& 1034 ady(agents(n)%group) 1035 agents(n)%y = agents(n)%y + & 1036 MERGE( rand_contr, SIGN( dy, rand_contr ), & 1037 ABS( rand_contr ) < dy ) 1038 ENDIF 1039 ENDDO 1040 ! 1041 !-- Delete agents that have been simulated longer than allowed 1042 CALL mas_boundary_conds( 'max_sim_time' ) 1043 ! 1044 !-- Delete agents that have reached target area 1045 CALL mas_boundary_conds( 'target_area' ) 1046 1047 ENDDO 1048 ENDDO 1049 ! 1050 !-- Exchange agents between grid cells and processors 1051 CALL mas_eh_move_agent 1052 CALL mas_eh_exchange_horiz 1053 1054 ENDIF 1055 ! 1056 !-- In case of random_start_position_agents, delete agents identified by 1057 !-- mas_eh_exchange_horiz and mas_boundary_conds. Then sort agents into 1058 !-- blocks, which is needed for a fast interpolation of the LES fields 1059 !-- on the agent position. 1060 CALL mas_ps_sort_in_subboxes 1061 1062 ! 1063 !-- Determine the current number of agents 1064 number_of_agents = 0 1021 ! 1022 !-- Exchange agents between grid cells and processors 1023 CALL mas_eh_move_agent 1024 CALL mas_eh_exchange_horiz 1025 1026 ENDIF 1027 ! 1028 !-- In case of random_start_position_agents, delete agents identified by mas_eh_exchange_horiz and 1029 !-- mas_boundary_conds. Then sort agents into blocks, which is needed for a fast interpolation of 1030 !-- the LES fields on the agent position. 1031 CALL mas_ps_sort_in_subboxes 1032 1033 ! 1034 !-- Determine the current number of agents 1035 number_of_agents = 0 1036 DO ip = nxl, nxr 1037 DO jp = nys, nyn 1038 number_of_agents = number_of_agents + agt_count(jp,ip) 1039 ENDDO 1040 ENDDO 1041 ! 1042 !-- Calculate the number of agents of the total domain 1043 #if defined( __parallel ) 1044 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 1045 CALL MPI_ALLREDUCE( number_of_agents, total_number_of_agents, 1, MPI_INTEGER, MPI_SUM, comm2d, & 1046 ierr ) 1047 #else 1048 total_number_of_agents = number_of_agents 1049 #endif 1050 1051 RETURN 1052 1053 END SUBROUTINE mas_create_agent 1054 1055 !--------------------------------------------------------------------------------------------------! 1056 ! Description: 1057 ! ------------ 1058 !> Creates flags that indicate if a gridbox contains edges or corners. These flags are used for 1059 !> agents to check if obstacles are close to them. 1060 !--------------------------------------------------------------------------------------------------! 1061 SUBROUTINE mas_create_obstacle_flags 1062 1063 USE arrays_3d, & 1064 ONLY: zw 1065 1066 IMPLICIT NONE 1067 1068 INTEGER(iwp) :: il 1069 INTEGER(iwp) :: jl 1070 1071 ALLOCATE( obstacle_flags(nysg:nyng,nxlg:nxrg) ) 1072 1073 obstacle_flags = 0 1074 1075 DO il = nxlg, nxrg 1076 DO jl = nysg, nyng 1077 ! 1078 !-- Exclude cyclic topography boundary 1079 IF ( il < 0 .OR. il > nx .OR. jl < 0 .OR. jl > ny ) CYCLE 1080 ! 1081 !-- North edge 1082 IF ( jl < nyng ) THEN 1083 IF ( ( top_top_s(jl,il) - top_top_s(jl+1,il) ) > 1 .AND. & 1084 ( zw( top_top_w(jl,il) ) - zw( top_top_w(jl+1,il) ) ) > 0.51_wp ) & 1085 THEN 1086 obstacle_flags(jl,il) = IBSET( obstacle_flags(jl,il), 0 ) 1087 ENDIF 1088 ENDIF 1089 ! 1090 !-- North right corner 1091 IF ( jl < nyng .AND. il < nxrg ) THEN 1092 IF ( ( top_top_s(jl,il) - top_top_s(jl+1,il) ) > 1 .AND. & 1093 ( top_top_s(jl,il) - top_top_s(jl+1,il+1) ) > 1 .AND. & 1094 ( top_top_s(jl,il) - top_top_s(jl,il+1) ) > 1 .AND. & 1095 ( zw( top_top_w(jl,il) ) - zw( top_top_w(jl+1,il+1) ) ) > 0.51_wp ) & 1096 THEN 1097 obstacle_flags(jl,il) = IBSET( obstacle_flags(jl,il), 1 ) 1098 ENDIF 1099 ENDIF 1100 ! 1101 !-- Right edge 1102 IF ( il < nxrg ) THEN 1103 IF ( ( top_top_s(jl,il) - top_top_s(jl,il+1) ) > 1 .AND. & 1104 ( zw( top_top_w(jl,il) ) - zw( top_top_w(jl,il+1) ) ) > 0.51_wp ) & 1105 THEN 1106 obstacle_flags(jl,il) = IBSET( obstacle_flags(jl,il), 2 ) 1107 ENDIF 1108 ENDIF 1109 ! 1110 !-- South right corner 1111 IF ( jl > nysg .AND. il < nxrg ) THEN 1112 IF ( ( top_top_s(jl,il) - top_top_s(jl,il+1) ) > 1 .AND. & 1113 ( top_top_s(jl,il) - top_top_s(jl-1,il+1) ) > 1 .AND. & 1114 ( top_top_s(jl,il) - top_top_s(jl-1,il) ) > 1 .AND. & 1115 ( zw(top_top_w(jl,il) ) - zw( top_top_w(jl-1,il+1) ) ) > 0.51_wp ) & 1116 THEN 1117 obstacle_flags(jl,il) = IBSET( obstacle_flags(jl,il), 3 ) 1118 ENDIF 1119 ENDIF 1120 ! 1121 !-- South edge 1122 IF ( jl > nysg ) THEN 1123 IF ( ( top_top_s(jl,il) - top_top_s(jl-1,il) ) > 1 .AND. & 1124 ( zw( top_top_w(jl,il) ) - zw( top_top_w(jl-1,il) ) ) > 0.51_wp ) & 1125 THEN 1126 obstacle_flags(jl,il) = IBSET( obstacle_flags(jl,il), 4 ) 1127 ENDIF 1128 ENDIF 1129 ! 1130 !-- South left corner 1131 IF ( jl > nysg .AND. il > nxlg ) THEN 1132 IF ( ( top_top_s(jl,il) - top_top_s(jl-1,il) ) > 1 .AND. & 1133 ( top_top_s(jl,il) - top_top_s(jl-1,il-1) ) > 1 .AND. & 1134 ( top_top_s(jl,il) - top_top_s(jl,il-1) ) > 1 .AND. & 1135 ( zw( top_top_w(jl,il) ) - zw(top_top_w(jl-1,il-1) ) ) > 0.51_wp ) & 1136 THEN 1137 obstacle_flags(jl,il) = IBSET( obstacle_flags(jl,il), 5 ) 1138 ENDIF 1139 ENDIF 1140 ! 1141 !-- Left edge 1142 IF ( il > nxlg ) THEN 1143 IF ( ( top_top_s(jl,il) - top_top_s(jl,il-1) ) > 1 .AND. & 1144 ( zw(top_top_w(jl,il) ) - zw(top_top_w(jl,il-1) ) ) > 0.51_wp ) & 1145 THEN 1146 obstacle_flags(jl,il) = IBSET( obstacle_flags(jl,il), 6 ) 1147 ENDIF 1148 ENDIF 1149 ! 1150 !-- North left corner 1151 IF ( jl < nyng .AND. il > nxlg ) THEN 1152 IF ( ( top_top_s(jl,il) - top_top_s(jl,il-1) ) > 1 .AND. & 1153 ( top_top_s(jl,il) - top_top_s(jl+1,il-1) ) > 1 .AND. & 1154 ( top_top_s(jl,il) - top_top_s(jl+1,il) ) > 1 .AND. & 1155 ( zw( top_top_w(jl,il) ) - zw( top_top_w(jl+1,il-1) ) ) > 0.51_wp ) & 1156 THEN 1157 obstacle_flags(jl,il) = IBSET( obstacle_flags(jl,il), 7 ) 1158 ENDIF 1159 ENDIF 1160 1161 ENDDO 1162 ENDDO 1163 1164 END SUBROUTINE mas_create_obstacle_flags 1165 1166 !--------------------------------------------------------------------------------------------------! 1167 ! Description: 1168 ! ------------ 1169 !> Write agent data in netCDF format 1170 !--------------------------------------------------------------------------------------------------! 1171 SUBROUTINE mas_data_output_agents( ftest ) 1172 1173 USE control_parameters, & 1174 ONLY: agt_time_count, biometeorology, end_time, message_string, multi_agent_system_end, & 1175 multi_agent_system_start 1176 1177 USE netcdf_interface, & 1178 ONLY: nc_stat, id_set_agt, id_var_time_agt, id_var_agt, netcdf_handle_error 1179 1180 USE pegrid 1181 1182 #if defined( __netcdf ) 1183 USE NETCDF 1184 #endif 1185 USE mas_global_attributes, & 1186 ONLY: dim_size_agtnum 1187 1188 IMPLICIT NONE 1189 1190 #if defined( __parallel ) 1191 INTEGER(iwp) :: agt_size !< Agent size in bytes 1192 INTEGER(iwp) :: n !< counter (number of PEs) 1193 INTEGER(iwp) :: noa_rcv !< received number of agents 1194 #endif 1195 INTEGER(iwp) :: dummy !< dummy 1196 INTEGER(iwp) :: ii !< counter (x) 1197 INTEGER(iwp) :: ip !< counter (x) 1198 INTEGER(iwp) :: jp !< counter (y) 1199 INTEGER(iwp) :: noa !< number of agents 1200 INTEGER(iwp) :: out_noa !< number of agents for output 1201 1202 #if defined( __parallel ) 1203 INTEGER(iwp), DIMENSION(0:numprocs-1) :: noa_arr !< number of agents on each PE 1204 #endif 1205 ! 1206 !-- SAVE attribute required to avoid compiler warning about pointer outlive the pointer target 1207 TYPE(agent_type), DIMENSION(:), ALLOCATABLE, TARGET, SAVE :: trf_agents !< all agents on current PE 1208 #if defined( __parallel ) 1209 TYPE(agent_type), DIMENSION(:), ALLOCATABLE, TARGET, SAVE :: out_agents !< all agents in entire domain 1210 #endif 1211 1212 LOGICAL, INTENT (INOUT) :: ftest 1213 1214 LOGICAL, SAVE :: agt_dimension_exceeded = .FALSE. 1215 1216 1217 CALL cpu_log( log_point_s(17), 'mas_data_output', 'start' ) 1218 ! 1219 !-- Get total number of agents and put all agents on one PE in one array 1220 noa = 0 1221 DO ip = nxl, nxr 1222 DO jp = nys, nyn 1223 noa = noa + agt_count(jp,ip) 1224 ENDDO 1225 ENDDO 1226 IF ( noa > 0 ) THEN 1227 ALLOCATE( trf_agents(1:noa) ) 1228 dummy = 1 1065 1229 DO ip = nxl, nxr 1066 1230 DO jp = nys, nyn 1067 number_of_agents = number_of_agents + agt_count(jp,ip) 1231 IF ( agt_count(jp,ip) == 0 ) CYCLE 1232 agents => grid_agents(jp,ip)%agents(1:agt_count(jp,ip)) 1233 trf_agents(dummy:(dummy-1+agt_count(jp,ip))) = agents 1234 dummy = dummy + agt_count(jp,ip) 1068 1235 ENDDO 1069 1236 ENDDO 1070 ! 1071 !-- Calculate the number of agents of the total domain 1237 ENDIF 1072 1238 #if defined( __parallel ) 1073 IF ( collective_wait ) CALL MPI_BARRIER( comm2d, ierr ) 1074 CALL MPI_ALLREDUCE( number_of_agents, total_number_of_agents, 1, & 1075 MPI_INTEGER, MPI_SUM, comm2d, ierr ) 1239 ! 1240 !-- Gather all agents on PE0 for output 1241 IF ( myid == 0 ) THEN 1242 noa_arr(0) = noa 1243 ! 1244 !-- Receive data from all other PEs. 1245 DO n = 1, numprocs-1 1246 CALL MPI_RECV( noa_arr(n), 1, MPI_INTEGER, n, 0, comm2d, status, ierr ) 1247 ENDDO 1248 ELSE 1249 CALL MPI_SEND( noa, 1, MPI_INTEGER, 0, 0, comm2d, ierr ) 1250 ENDIF 1251 CALL MPI_BARRIER( comm2d, ierr ) 1252 agt_size = STORAGE_SIZE( zero_agent ) / 8 1253 IF ( myid == 0 ) THEN 1254 ! 1255 !-- Receive data from all other PEs. 1256 out_noa = SUM( noa_arr ) 1257 IF ( out_noa > 0 ) THEN 1258 ALLOCATE( out_agents(1:out_noa) ) 1259 IF ( noa > 0 ) THEN 1260 out_agents(1:noa) = trf_agents 1261 ENDIF 1262 noa_rcv = noa 1263 DO n = 1, numprocs-1 1264 IF ( noa_arr(n) > 0 ) THEN 1265 CALL MPI_RECV( out_agents(noa_rcv+1), noa_arr(n) * agt_size, MPI_BYTE, n, 0, & 1266 comm2d, status, ierr ) 1267 noa_rcv = noa_rcv + noa_arr(n) 1268 ENDIF 1269 ENDDO 1270 ELSE 1271 ALLOCATE( out_agents(1:2) ) 1272 out_agents = zero_agent 1273 out_noa = 2 1274 ENDIF 1275 ELSE 1276 IF ( noa > 0 ) THEN 1277 CALL MPI_SEND( trf_agents(1), noa*agt_size, MPI_BYTE, 0, 0, comm2d, ierr ) 1278 ENDIF 1279 ENDIF 1280 ! 1281 !-- A barrier has to be set, because otherwise some PEs may proceed too fast so that PE0 may receive 1282 !-- wrong data on tag 0. 1283 CALL MPI_BARRIER( comm2d, ierr ) 1284 #endif 1285 IF ( myid == 0 ) THEN 1286 #if defined( __parallel ) 1287 agents => out_agents 1076 1288 #else 1077 total_number_of_agents = number_of_agents1289 agents => trf_agents 1078 1290 #endif 1079 1291 1080 RETURN 1081 1082 END SUBROUTINE mas_create_agent 1083 1084 !------------------------------------------------------------------------------! 1292 #if defined( __netcdf ) 1293 ! 1294 !-- Update maximum number of agents 1295 maximum_number_of_agents = MAX(maximum_number_of_agents, out_noa) 1296 ! 1297 !-- Output in netCDF format 1298 IF ( ftest ) THEN 1299 ! 1300 !-- First, define size of agent number dimension from amount of agents released, release 1301 !-- interval, time of agent simulation and max age of agents. 1302 dim_size_agtnum = MIN( MIN( multi_agent_system_end, end_time ) & 1303 - multi_agent_system_start, & 1304 agent_maximum_age) 1305 1306 DO ii = 1, number_of_agent_groups 1307 dim_size_agtnum = dim_size_agtnum & 1308 + ( FLOOR( ( asr(ii)-asl(ii) ) / adx(ii) ) + 1 ) & 1309 * ( FLOOR( ( asn(ii)-ass(ii) ) / ady(ii) ) + 1 ) & 1310 * ( FLOOR( dim_size_agtnum / dt_arel ) + 1 ) & 1311 * dim_size_factor_agtnum 1312 dim_size_agtnum = MIN( dim_size_agtnum, dim_size_agtnum_manual ) 1313 ENDDO 1314 CALL check_open( 118 ) 1315 ENDIF 1316 1317 ! 1318 !-- Update the NetCDF time axis 1319 agt_time_count = agt_time_count + 1 1320 1321 IF ( .NOT. agt_dimension_exceeded ) THEN 1322 ! 1323 !-- If number of agents to be output exceeds dimension, set flag and print warning. 1324 IF ( out_noa > dim_size_agtnum ) THEN 1325 1326 agt_dimension_exceeded = .TRUE. 1327 WRITE( message_string, '(A,F11.1,2(A,I8))' ) & 1328 'Number of agents exceeds agent dimension.' // & 1329 '&Starting at time_since_reference_point = ', & 1330 time_since_reference_point, & 1331 ' s, &data may be missing.'// & 1332 '&Number of agents: ', out_noa, & 1333 '&Agent dimension size: ', dim_size_agtnum 1334 1335 CALL message( 'mas_data_output_agents', 'PA0420', 0, 1, 0, 6, 0 ) 1336 1337 ENDIF 1338 ENDIF 1339 1340 ! 1341 !-- Reduce number of output agents to dimension size, if necessary. 1342 IF ( agt_dimension_exceeded ) THEN 1343 1344 out_noa = MIN( out_noa, dim_size_agtnum ) 1345 1346 ENDIF 1347 1348 nc_stat = NF90_PUT_VAR( id_set_agt, id_var_time_agt, & 1349 (/ time_since_reference_point + agent_substep_time /), & 1350 start = (/ agt_time_count /), & 1351 count = (/ 1 /) ) 1352 CALL netcdf_handle_error( 'mas_data_output_agents', 1 ) 1353 1354 ! 1355 !-- Output agent attributes 1356 1357 nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(1), agents%id, & 1358 start = (/ 1, agt_time_count /), & 1359 count = (/ out_noa /) ) 1360 CALL netcdf_handle_error( 'mas_data_output_agents', 2 ) 1361 1362 nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(2), agents%x, & 1363 start = (/ 1, agt_time_count /), & 1364 count = (/ out_noa /) ) 1365 CALL netcdf_handle_error( 'mas_data_output_agents', 3 ) 1366 1367 nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(3), agents%y, & 1368 start = (/ 1, agt_time_count /), & 1369 count = (/ out_noa /) ) 1370 CALL netcdf_handle_error( 'mas_data_output_agents', 4 ) 1371 1372 nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(4), agents%windspeed, & 1373 start = (/ 1, agt_time_count /), & 1374 count = (/ out_noa /) ) 1375 CALL netcdf_handle_error( 'mas_data_output_agents', 5 ) 1376 1377 nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(5), agents%t, & 1378 start = (/ 1, agt_time_count /), & 1379 count = (/ out_noa /) ) 1380 CALL netcdf_handle_error( 'mas_data_output_agents', 6 ) 1381 1382 nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(6), agents%group, & 1383 start = (/ 1, agt_time_count /), & 1384 count = (/ out_noa /) ) 1385 CALL netcdf_handle_error( 'mas_data_output_agents', 7 ) 1386 1387 1388 IF ( biometeorology ) THEN 1389 nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(7), agents%ipt, & 1390 start = (/ 1, agt_time_count /), & 1391 count = (/ out_noa /) ) 1392 CALL netcdf_handle_error( 'mas_data_output_agents', 8 ) 1393 ENDIF 1394 1395 1396 1397 ! nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(8), agents%pm10, & 1398 ! start = (/ 1, agt_time_count /), & 1399 ! count = (/ out_noa /) ) 1400 ! CALL netcdf_handle_error( 'mas_data_output_agents', 9 ) 1401 ! 1402 ! nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(9), agents%pm25, & 1403 ! start = (/ 1, agt_time_count /), & 1404 ! count = (/ out_noa /) ) 1405 ! CALL netcdf_handle_error( 'mas_data_output_agents', 10 ) 1406 ! 1407 ! 1408 ! nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(9), agents%uv, & 1409 ! start = (/ 1, agt_time_count /), & 1410 ! count = (/ out_noa /) ) 1411 ! CALL netcdf_handle_error( 'mas_data_output_agents', 10 ) 1412 1413 CALL cpu_log( log_point_s(17), 'mas_data_output', 'stop' ) 1414 1415 1416 #endif 1417 1418 #if defined( __parallel ) 1419 IF ( ALLOCATED( out_agents ) ) DEALLOCATE( out_agents ) 1420 #endif 1421 ELSE 1422 CALL cpu_log( log_point_s(17), 'mas_data_output', 'stop' ) 1423 ENDIF 1424 1425 IF ( ALLOCATED( trf_agents ) ) DEALLOCATE( trf_agents ) 1426 1427 END SUBROUTINE mas_data_output_agents 1428 1429 #if defined( __parallel ) 1430 !--------------------------------------------------------------------------------------------------! 1085 1431 ! Description: 1086 1432 ! ------------ 1087 !> Creates flags that indicate if a gridbox contains edges or corners. These 1088 !> flags are used for agents to check if obstacles are close to them. 1089 !------------------------------------------------------------------------------! 1090 SUBROUTINE mas_create_obstacle_flags 1091 1092 USE arrays_3d, & 1093 ONLY: zw 1094 1095 IMPLICIT NONE 1096 1097 INTEGER(iwp) :: il 1098 INTEGER(iwp) :: jl 1099 1100 ALLOCATE(obstacle_flags(nysg:nyng,nxlg:nxrg)) 1101 1102 obstacle_flags = 0 1103 1104 DO il = nxlg, nxrg 1105 DO jl = nysg, nyng 1106 ! 1107 !-- Exclude cyclic topography boundary 1108 IF ( il < 0 .OR. il > nx .OR. jl < 0 .OR. jl > ny ) CYCLE 1109 ! 1110 !-- North edge 1111 IF ( jl < nyng ) THEN 1112 IF ( ( top_top_s(jl,il) - top_top_s(jl+1,il) ) > 1 .AND. & 1113 ( zw( top_top_w(jl,il) ) - & 1114 zw( top_top_w(jl+1,il) ) ) > .51_wp ) & 1115 THEN 1116 obstacle_flags(jl,il) = IBSET( obstacle_flags(jl,il), 0 ) 1433 !> If an agent moves from one processor to another, this subroutine moves the corresponding elements 1434 !> from the agent arrays of the old grid cells to the agent arrays of the new grid cells. 1435 !--------------------------------------------------------------------------------------------------! 1436 SUBROUTINE mas_eh_add_agents_to_gridcell (agent_array) 1437 1438 IMPLICIT NONE 1439 1440 INTEGER(iwp) :: aindex !< dummy argument for new number of agents per grid box 1441 INTEGER(iwp) :: ip !< grid index (x) of agent 1442 INTEGER(iwp) :: jp !< grid index (x) of agent 1443 INTEGER(iwp) :: n !< index variable of agent 1444 1445 LOGICAL :: pack_done !< flag to indicate that packing is done 1446 1447 TYPE(agent_type), DIMENSION(:), INTENT(IN) :: agent_array !< new agents in a grid box 1448 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: temp_ns !< temporary agent array for reallocation 1449 1450 pack_done = .FALSE. 1451 1452 DO n = 1, SIZE(agent_array) 1453 1454 IF ( .NOT. agent_array(n)%agent_mask ) CYCLE 1455 1456 ip = agent_array(n)%x * ddx 1457 jp = agent_array(n)%y * ddy 1458 1459 IF ( ip >= nxl .AND. ip <= nxr .AND. jp >= nys .AND. jp <= nyn ) THEN ! agent stays on processor 1460 number_of_agents = agt_count(jp,ip) 1461 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 1462 1463 aindex = agt_count(jp,ip)+1 1464 IF( aindex > SIZE( grid_agents(jp,ip)%agents ) ) THEN 1465 IF ( pack_done ) THEN 1466 CALL mas_eh_realloc_agents_array (ip,jp) 1467 ELSE 1468 CALL mas_ps_pack 1469 agt_count(jp,ip) = number_of_agents 1470 aindex = agt_count(jp,ip)+1 1471 IF ( aindex > SIZE( grid_agents(jp,ip)%agents ) ) THEN 1472 CALL mas_eh_realloc_agents_array (ip,jp) 1473 ENDIF 1474 pack_done = .TRUE. 1475 ENDIF 1476 ENDIF 1477 grid_agents(jp,ip)%agents(aindex) = agent_array(n) 1478 agt_count(jp,ip) = aindex 1479 ELSE 1480 IF ( jp <= nys - 1 ) THEN 1481 nr_move_south = nr_move_south+1 1482 ! 1483 !-- Before agent information is swapped to exchange-array, check if enough memory is 1484 !-- allocated. If required, reallocate exchange array. 1485 IF ( nr_move_south > SIZE( move_also_south ) ) THEN 1486 ! 1487 !-- At first, allocate further temporary array to swap agent information. 1488 ALLOCATE( temp_ns( SIZE( move_also_south ) + nr_2_direction_move ) ) 1489 temp_ns(1:nr_move_south-1) = move_also_south(1:nr_move_south-1) 1490 DEALLOCATE( move_also_south ) 1491 ALLOCATE( move_also_south( SIZE(temp_ns) ) ) 1492 move_also_south(1:nr_move_south-1) = temp_ns(1:nr_move_south-1) 1493 DEALLOCATE( temp_ns ) 1494 1495 ENDIF 1496 1497 move_also_south(nr_move_south) = agent_array(n) 1498 1499 IF ( jp == -1 ) THEN 1500 ! 1501 !-- Apply boundary condition along y 1502 IF ( ibc_mas_ns == 0 ) THEN 1503 move_also_south(nr_move_south)%y = move_also_south(nr_move_south)%y & 1504 + ( ny + 1 ) * dy 1505 move_also_south(nr_move_south)%origin_y = & 1506 move_also_south(nr_move_south)%origin_y & 1507 + ( ny + 1 ) * dy 1508 ELSEIF ( ibc_mas_ns == 1 ) THEN 1509 ! 1510 !-- Agent absorption 1511 move_also_south(nr_move_south)%agent_mask = .FALSE. 1512 deleted_agents = deleted_agents + 1 1513 1117 1514 ENDIF 1118 1515 ENDIF 1119 ! 1120 !-- North right corner 1121 IF ( jl < nyng .AND. il < nxrg ) THEN 1122 IF ( ( top_top_s(jl,il) - top_top_s(jl+1,il) ) > 1 .AND. & 1123 ( top_top_s(jl,il) - top_top_s(jl+1,il+1) ) > 1 .AND. & 1124 ( top_top_s(jl,il) - top_top_s(jl,il+1) ) > 1 .AND. & 1125 ( zw( top_top_w(jl,il) ) - & 1126 zw( top_top_w(jl+1,il+1) ) ) > .51_wp ) & 1127 THEN 1128 obstacle_flags(jl,il) = IBSET( obstacle_flags(jl,il), 1 ) 1129 ENDIF 1516 ELSEIF ( jp >= nyn+1 ) THEN 1517 nr_move_north = nr_move_north+1 1518 ! 1519 !-- Before agent information is swapped to exchange-array, check if enough memory is 1520 !-- allocated. If required, reallocate exchange array. 1521 IF ( nr_move_north > SIZE( move_also_north ) ) THEN 1522 ! 1523 !-- At first, allocate further temporary array to swap agent information. 1524 ALLOCATE( temp_ns( SIZE( move_also_north ) + nr_2_direction_move ) ) 1525 temp_ns(1:nr_move_north-1) = move_also_south(1:nr_move_north-1) 1526 DEALLOCATE( move_also_north ) 1527 ALLOCATE( move_also_north(SIZE(temp_ns)) ) 1528 move_also_north(1:nr_move_north-1) = temp_ns(1:nr_move_north-1) 1529 DEALLOCATE( temp_ns ) 1530 1130 1531 ENDIF 1131 ! 1132 !-- Right edge 1133 IF ( il < nxrg ) THEN 1134 IF ( ( top_top_s(jl,il) - top_top_s(jl,il+1) ) > 1 .AND. & 1135 ( zw( top_top_w(jl,il) ) - & 1136 zw( top_top_w(jl,il+1) ) ) > .51_wp ) & 1137 THEN 1138 obstacle_flags(jl,il) = IBSET( obstacle_flags(jl,il), 2 ) 1139 ENDIF 1140 ENDIF 1141 ! 1142 !-- South right corner 1143 IF ( jl > nysg .AND. il < nxrg ) THEN 1144 IF ( ( top_top_s(jl,il) - top_top_s(jl,il+1) ) > 1 .AND. & 1145 ( top_top_s(jl,il) - top_top_s(jl-1,il+1) ) > 1 .AND. & 1146 ( top_top_s(jl,il) - top_top_s(jl-1,il) ) > 1 .AND. & 1147 ( zw(top_top_w(jl,il)) - & 1148 zw( top_top_w(jl-1,il+1) ) ) > .51_wp ) & 1149 THEN 1150 obstacle_flags(jl,il) = IBSET( obstacle_flags(jl,il), 3 ) 1151 ENDIF 1152 ENDIF 1153 ! 1154 !-- South edge 1155 IF ( jl > nysg ) THEN 1156 IF ( ( top_top_s(jl,il) - top_top_s(jl-1,il) ) > 1 .AND. & 1157 ( zw( top_top_w(jl,il) ) - & 1158 zw( top_top_w(jl-1,il) ) ) > .51_wp ) & 1159 THEN 1160 obstacle_flags(jl,il) = IBSET( obstacle_flags(jl,il), 4 ) 1161 ENDIF 1162 ENDIF 1163 ! 1164 !-- South left corner 1165 IF ( jl > nysg .AND. il > nxlg ) THEN 1166 IF ( ( top_top_s(jl,il) - top_top_s(jl-1,il) ) > 1 .AND. & 1167 ( top_top_s(jl,il) - top_top_s(jl-1,il-1) ) > 1 .AND. & 1168 ( top_top_s(jl,il) - top_top_s(jl,il-1) ) > 1 .AND. & 1169 ( zw( top_top_w(jl,il) ) - & 1170 zw(top_top_w(jl-1,il-1) ) ) > .51_wp ) & 1171 THEN 1172 obstacle_flags(jl,il) = IBSET( obstacle_flags(jl,il), 5 ) 1173 ENDIF 1174 ENDIF 1175 ! 1176 !-- Left edge 1177 IF ( il > nxlg ) THEN 1178 IF ( ( top_top_s(jl,il) - top_top_s(jl,il-1) ) > 1 .AND. & 1179 ( zw(top_top_w(jl,il) ) - & 1180 zw(top_top_w(jl,il-1) ) ) > .51_wp ) & 1181 THEN 1182 obstacle_flags(jl,il) = IBSET( obstacle_flags(jl,il), 6 ) 1183 ENDIF 1184 ENDIF 1185 ! 1186 !-- North left corner 1187 IF ( jl < nyng .AND. il > nxlg ) THEN 1188 IF ( ( top_top_s(jl,il) - top_top_s(jl,il-1) ) > 1 .AND. & 1189 ( top_top_s(jl,il) - top_top_s(jl+1,il-1) ) > 1 .AND. & 1190 ( top_top_s(jl,il) - top_top_s(jl+1,il) ) > 1 .AND. & 1191 ( zw( top_top_w(jl,il) ) - & 1192 zw( top_top_w(jl+1,il-1) ) ) > .51_wp ) & 1193 THEN 1194 obstacle_flags(jl,il) = IBSET( obstacle_flags(jl,il), 7 ) 1195 ENDIF 1196 ENDIF 1197 1198 ENDDO 1199 ENDDO 1200 1201 END SUBROUTINE mas_create_obstacle_flags 1202 1203 !------------------------------------------------------------------------------! 1204 ! Description: 1205 ! ------------ 1206 !> Write agent data in netCDF format 1207 !------------------------------------------------------------------------------! 1208 SUBROUTINE mas_data_output_agents( ftest ) 1209 1210 USE control_parameters, & 1211 ONLY: agt_time_count, biometeorology, end_time, message_string, & 1212 multi_agent_system_end, multi_agent_system_start 1213 1214 USE netcdf_interface, & 1215 ONLY: nc_stat, id_set_agt, id_var_time_agt, & 1216 id_var_agt, netcdf_handle_error 1217 1218 USE pegrid 1219 1220 #if defined( __netcdf ) 1221 USE NETCDF 1222 #endif 1223 USE mas_global_attributes, & 1224 ONLY: dim_size_agtnum 1225 1226 IMPLICIT NONE 1227 1228 #if defined( __parallel ) 1229 INTEGER(iwp) :: agt_size !< Agent size in bytes 1230 INTEGER(iwp) :: n !< counter (number of PEs) 1231 INTEGER(iwp) :: noa_rcv !< received number of agents 1232 #endif 1233 INTEGER(iwp) :: dummy !< dummy 1234 INTEGER(iwp) :: ii !< counter (x) 1235 INTEGER(iwp) :: ip !< counter (x) 1236 INTEGER(iwp) :: jp !< counter (y) 1237 INTEGER(iwp) :: noa !< number of agents 1238 INTEGER(iwp) :: out_noa !< number of agents for output 1239 1240 #if defined( __parallel ) 1241 INTEGER(iwp), DIMENSION(0:numprocs-1) :: noa_arr !< number of agents on each PE 1242 #endif 1243 ! 1244 !-- SAVE attribute required to avoid compiler warning about pointer outlive the pointer target 1245 TYPE(agent_type), DIMENSION(:), ALLOCATABLE, TARGET, SAVE :: trf_agents !< all agents on current PE 1246 #if defined( __parallel ) 1247 TYPE(agent_type), DIMENSION(:), ALLOCATABLE, TARGET, SAVE :: out_agents !< all agents in entire domain 1248 #endif 1249 1250 LOGICAL, INTENT (INOUT) :: ftest 1251 1252 LOGICAL, SAVE :: agt_dimension_exceeded = .FALSE. 1253 1254 CALL cpu_log( log_point_s(17), 'mas_data_output', 'start' ) 1255 ! 1256 !-- Get total number of agents and put all agents on one PE in one array 1257 noa = 0 1258 DO ip = nxl, nxr 1259 DO jp = nys, nyn 1260 noa = noa + agt_count(jp,ip) 1261 ENDDO 1262 ENDDO 1263 IF(noa > 0) THEN 1264 ALLOCATE(trf_agents(1:noa)) 1265 dummy = 1 1266 DO ip = nxl, nxr 1267 DO jp = nys, nyn 1268 IF ( agt_count(jp,ip) == 0 ) CYCLE 1269 agents => grid_agents(jp,ip)%agents(1:agt_count(jp,ip)) 1270 trf_agents(dummy:(dummy-1+agt_count(jp,ip))) = agents 1271 dummy = dummy + agt_count(jp,ip) 1272 ENDDO 1273 ENDDO 1274 ENDIF 1275 #if defined( __parallel ) 1276 ! 1277 !-- Gather all agents on PE0 for output 1278 IF ( myid == 0 ) THEN 1279 noa_arr(0) = noa 1280 ! 1281 !-- Receive data from all other PEs. 1282 DO n = 1, numprocs-1 1283 CALL MPI_RECV( noa_arr(n), 1, MPI_INTEGER, & 1284 n, 0, comm2d, status, ierr ) 1285 ENDDO 1286 ELSE 1287 CALL MPI_SEND( noa, 1, MPI_INTEGER, 0, 0, comm2d, ierr ) 1288 ENDIF 1289 CALL MPI_BARRIER( comm2d, ierr ) 1290 agt_size = STORAGE_SIZE(zero_agent)/8 1291 IF ( myid == 0 ) THEN 1292 ! 1293 !-- Receive data from all other PEs. 1294 out_noa = SUM(noa_arr) 1295 IF ( out_noa > 0 ) THEN 1296 ALLOCATE( out_agents(1:out_noa) ) 1297 IF ( noa > 0 ) THEN 1298 out_agents(1:noa) = trf_agents 1299 ENDIF 1300 noa_rcv = noa 1301 DO n = 1, numprocs-1 1302 IF ( noa_arr(n) > 0 ) THEN 1303 CALL MPI_RECV( out_agents(noa_rcv+1), noa_arr(n)*agt_size, & 1304 MPI_BYTE, n, 0, comm2d, status, ierr ) 1305 noa_rcv = noa_rcv + noa_arr(n) 1306 ENDIF 1307 ENDDO 1308 ELSE 1309 ALLOCATE( out_agents(1:2) ) 1310 out_agents = zero_agent 1311 out_noa = 2 1312 ENDIF 1313 ELSE 1314 IF ( noa > 0 ) THEN 1315 CALL MPI_SEND( trf_agents(1), noa*agt_size, MPI_BYTE, 0, 0, & 1316 comm2d, ierr ) 1317 ENDIF 1318 ENDIF 1319 ! 1320 !-- A barrier has to be set, because otherwise some PEs may 1321 !-- proceed too fast so that PE0 may receive wrong data on 1322 !-- tag 0 1323 CALL MPI_BARRIER( comm2d, ierr ) 1324 #endif 1325 IF ( myid == 0 ) THEN 1326 #if defined( __parallel ) 1327 agents => out_agents 1328 #else 1329 agents => trf_agents 1330 #endif 1331 1332 #if defined( __netcdf ) 1333 ! 1334 !-- Update maximum number of agents 1335 maximum_number_of_agents = MAX(maximum_number_of_agents, out_noa) 1336 ! 1337 !-- Output in netCDF format 1338 IF ( ftest ) THEN 1339 ! 1340 !-- First, define size of agent number dimension from amount of agents 1341 !-- released, release interval, time of agent simulation and max 1342 !-- age of agents 1343 dim_size_agtnum = MIN( MIN( multi_agent_system_end, end_time ) & 1344 - multi_agent_system_start, & 1345 agent_maximum_age) 1346 1347 DO ii = 1, number_of_agent_groups 1348 dim_size_agtnum = dim_size_agtnum & 1349 + (FLOOR( ( asr(ii)-asl(ii) ) / adx(ii) ) + 1) & 1350 * (FLOOR( ( asn(ii)-ass(ii) ) / ady(ii) ) + 1) & 1351 * (FLOOR( dim_size_agtnum / dt_arel ) + 1) & 1352 * dim_size_factor_agtnum 1353 dim_size_agtnum = MIN( dim_size_agtnum, dim_size_agtnum_manual ) 1354 ENDDO 1355 CALL check_open( 118 ) 1356 ENDIF 1357 1358 ! 1359 !-- Update the NetCDF time axis 1360 agt_time_count = agt_time_count + 1 1361 1362 IF ( .NOT. agt_dimension_exceeded ) THEN 1363 ! 1364 !-- if number of agents to be output exceeds dimension, set flag and 1365 !-- print warning 1366 IF ( out_noa > dim_size_agtnum ) THEN 1367 1368 agt_dimension_exceeded = .TRUE. 1369 WRITE(message_string,'(A,F11.1,2(A,I8))') & 1370 'Number of agents exceeds agent dimension.' // & 1371 '&Starting at time_since_reference_point = ', & 1372 time_since_reference_point, & 1373 ' s, &data may be missing.'// & 1374 '&Number of agents: ', out_noa, & 1375 '&Agent dimension size: ', dim_size_agtnum 1376 1377 CALL message( 'mas_data_output_agents', & 1378 'PA0420', 0, 1, 0, 6, 0 ) 1379 1380 ENDIF 1381 ENDIF 1382 1383 ! 1384 !-- reduce number of output agents to dimension size, if necessary 1385 IF ( agt_dimension_exceeded ) THEN 1386 1387 out_noa = MIN( out_noa, dim_size_agtnum ) 1388 1389 ENDIF 1390 1391 nc_stat = NF90_PUT_VAR( id_set_agt, id_var_time_agt, & 1392 (/ time_since_reference_point + agent_substep_time /), & 1393 start = (/ agt_time_count /), & 1394 count = (/ 1 /) ) 1395 CALL netcdf_handle_error( 'mas_data_output_agents', 1 ) 1396 1397 ! 1398 !-- Output agent attributes 1399 1400 nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(1), agents%id, & 1401 start = (/ 1, agt_time_count /), & 1402 count = (/ out_noa /) ) 1403 CALL netcdf_handle_error( 'mas_data_output_agents', 2 ) 1404 1405 nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(2), agents%x, & 1406 start = (/ 1, agt_time_count /), & 1407 count = (/ out_noa /) ) 1408 CALL netcdf_handle_error( 'mas_data_output_agents', 3 ) 1409 1410 nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(3), agents%y, & 1411 start = (/ 1, agt_time_count /), & 1412 count = (/ out_noa /) ) 1413 CALL netcdf_handle_error( 'mas_data_output_agents', 4 ) 1414 1415 nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(4), agents%windspeed, & 1416 start = (/ 1, agt_time_count /), & 1417 count = (/ out_noa /) ) 1418 CALL netcdf_handle_error( 'mas_data_output_agents', 5 ) 1419 1420 nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(5), agents%t, & 1421 start = (/ 1, agt_time_count /), & 1422 count = (/ out_noa /) ) 1423 CALL netcdf_handle_error( 'mas_data_output_agents', 6 ) 1424 1425 nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(6), agents%group, & 1426 start = (/ 1, agt_time_count /), & 1427 count = (/ out_noa /) ) 1428 CALL netcdf_handle_error( 'mas_data_output_agents', 7 ) 1429 1430 1431 IF ( biometeorology ) THEN 1432 nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(7), agents%ipt, & 1433 start = (/ 1, agt_time_count /), & 1434 count = (/ out_noa /) ) 1435 CALL netcdf_handle_error( 'mas_data_output_agents', 8 ) 1436 ENDIF 1437 1438 1439 1440 ! nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(8), agents%pm10, & 1441 ! start = (/ 1, agt_time_count /), & 1442 ! count = (/ out_noa /) ) 1443 ! CALL netcdf_handle_error( 'mas_data_output_agents', 9 ) 1444 ! 1445 ! nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(9), agents%pm25, & 1446 ! start = (/ 1, agt_time_count /), & 1447 ! count = (/ out_noa /) ) 1448 ! CALL netcdf_handle_error( 'mas_data_output_agents', 10 ) 1449 ! 1450 ! 1451 ! nc_stat = NF90_PUT_VAR( id_set_agt, id_var_agt(9), agents%uv, & 1452 ! start = (/ 1, agt_time_count /), & 1453 ! count = (/ out_noa /) ) 1454 ! CALL netcdf_handle_error( 'mas_data_output_agents', 10 ) 1455 1456 CALL cpu_log( log_point_s(17), 'mas_data_output', 'stop' ) 1457 1458 1459 #endif 1460 1461 #if defined( __parallel ) 1462 IF ( ALLOCATED( out_agents ) ) DEALLOCATE( out_agents ) 1463 #endif 1464 ELSE 1465 CALL cpu_log( log_point_s(17), 'mas_data_output', 'stop' ) 1466 ENDIF 1467 1468 IF ( ALLOCATED( trf_agents ) ) DEALLOCATE( trf_agents ) 1469 1470 END SUBROUTINE mas_data_output_agents 1471 1472 #if defined( __parallel ) 1473 !------------------------------------------------------------------------------! 1474 ! Description: 1475 ! ------------ 1476 !> If an agent moves from one processor to another, this subroutine moves 1477 !> the corresponding elements from the agent arrays of the old grid cells 1478 !> to the agent arrays of the new grid cells. 1479 !------------------------------------------------------------------------------! 1480 SUBROUTINE mas_eh_add_agents_to_gridcell (agent_array) 1481 1482 IMPLICIT NONE 1483 1484 INTEGER(iwp) :: aindex !< dummy argument for new number of agents per grid box 1485 INTEGER(iwp) :: ip !< grid index (x) of agent 1486 INTEGER(iwp) :: jp !< grid index (x) of agent 1487 INTEGER(iwp) :: n !< index variable of agent 1488 1489 LOGICAL :: pack_done !< flag to indicate that packing is done 1490 1491 TYPE(agent_type), DIMENSION(:), INTENT(IN) :: agent_array !< new agents in a grid box 1492 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: temp_ns !< temporary agent array for reallocation 1493 1494 pack_done = .FALSE. 1495 1496 DO n = 1, SIZE(agent_array) 1497 1498 IF ( .NOT. agent_array(n)%agent_mask ) CYCLE 1499 1500 ip = agent_array(n)%x * ddx 1501 jp = agent_array(n)%y * ddy 1502 1503 IF ( ip >= nxl .AND. ip <= nxr .AND. & 1504 jp >= nys .AND. jp <= nyn ) & 1505 THEN ! agent stays on processor 1506 number_of_agents = agt_count(jp,ip) 1507 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 1508 1509 aindex = agt_count(jp,ip)+1 1510 IF( aindex > SIZE(grid_agents(jp,ip)%agents) ) THEN 1511 IF ( pack_done ) THEN 1512 CALL mas_eh_realloc_agents_array (ip,jp) 1513 ELSE 1514 CALL mas_ps_pack 1515 agt_count(jp,ip) = number_of_agents 1516 aindex = agt_count(jp,ip)+1 1517 IF ( aindex > SIZE(grid_agents(jp,ip)%agents) ) THEN 1518 CALL mas_eh_realloc_agents_array (ip,jp) 1519 ENDIF 1520 pack_done = .TRUE. 1521 ENDIF 1522 ENDIF 1523 grid_agents(jp,ip)%agents(aindex) = agent_array(n) 1524 agt_count(jp,ip) = aindex 1525 ELSE 1526 IF ( jp <= nys - 1 ) THEN 1527 nr_move_south = nr_move_south+1 1528 ! 1529 !-- Before agent information is swapped to exchange-array, check 1530 !-- if enough memory is allocated. If required, reallocate exchange 1531 !-- array. 1532 IF ( nr_move_south > SIZE(move_also_south) ) THEN 1533 ! 1534 !-- At first, allocate further temporary array to swap agent 1535 !-- information. 1536 ALLOCATE( temp_ns(SIZE(move_also_south)+NR_2_direction_move)) 1537 temp_ns(1:nr_move_south-1) = move_also_south & 1538 (1:nr_move_south-1) 1539 DEALLOCATE( move_also_south ) 1540 ALLOCATE( move_also_south(SIZE(temp_ns)) ) 1541 move_also_south(1:nr_move_south-1) = temp_ns & 1542 (1:nr_move_south-1) 1543 DEALLOCATE( temp_ns ) 1544 1545 ENDIF 1546 1547 move_also_south(nr_move_south) = agent_array(n) 1548 1549 IF ( jp == -1 ) THEN 1550 ! 1551 !-- Apply boundary condition along y 1552 IF ( ibc_mas_ns == 0 ) THEN 1553 move_also_south(nr_move_south)%y = & 1554 move_also_south(nr_move_south)%y & 1555 + ( ny + 1 ) * dy 1556 move_also_south(nr_move_south)%origin_y = & 1557 move_also_south(nr_move_south)%origin_y & 1558 + ( ny + 1 ) * dy 1559 ELSEIF ( ibc_mas_ns == 1 ) THEN 1560 ! 1561 !-- Agent absorption 1562 move_also_south(nr_move_south)%agent_mask = .FALSE. 1563 deleted_agents = deleted_agents + 1 1564 1565 ENDIF 1566 ENDIF 1567 ELSEIF ( jp >= nyn+1 ) THEN 1568 nr_move_north = nr_move_north+1 1569 ! 1570 !-- Before agent information is swapped to exchange-array, check 1571 !-- if enough memory is allocated. If required, reallocate exchange 1572 !-- array. 1573 IF ( nr_move_north > SIZE(move_also_north) ) THEN 1574 ! 1575 !-- At first, allocate further temporary array to swap agent 1576 !-- information. 1577 ALLOCATE( temp_ns(SIZE(move_also_north)+NR_2_direction_move)) 1578 temp_ns(1:nr_move_north-1) = & 1579 move_also_south(1:nr_move_north-1) 1580 DEALLOCATE( move_also_north ) 1581 ALLOCATE( move_also_north(SIZE(temp_ns)) ) 1582 move_also_north(1:nr_move_north-1) = & 1583 temp_ns(1:nr_move_north-1) 1584 DEALLOCATE( temp_ns ) 1585 1586 ENDIF 1587 1588 move_also_north(nr_move_north) = agent_array(n) 1589 IF ( jp == ny+1 ) THEN 1590 ! 1591 !-- Apply boundary condition along y 1592 IF ( ibc_mas_ns == 0 ) THEN 1593 1594 move_also_north(nr_move_north)%y = & 1595 move_also_north(nr_move_north)%y & 1596 - ( ny + 1 ) * dy 1597 move_also_north(nr_move_north)%origin_y = & 1598 move_also_north(nr_move_north)%origin_y & 1599 - ( ny + 1 ) * dy 1600 ELSEIF ( ibc_mas_ns == 1 ) THEN 1601 ! 1602 !-- Agent absorption 1603 move_also_north(nr_move_north)%agent_mask = .FALSE. 1604 deleted_agents = deleted_agents + 1 1605 1606 ENDIF 1532 1533 move_also_north(nr_move_north) = agent_array(n) 1534 IF ( jp == ny+1 ) THEN 1535 ! 1536 !-- Apply boundary condition along y 1537 IF ( ibc_mas_ns == 0 ) THEN 1538 1539 move_also_north(nr_move_north)%y = move_also_north(nr_move_north)%y & 1540 - ( ny + 1 ) * dy 1541 move_also_north(nr_move_north)%origin_y = & 1542 move_also_north(nr_move_north)%origin_y & 1543 - ( ny + 1 ) * dy 1544 ELSEIF ( ibc_mas_ns == 1 ) THEN 1545 ! 1546 !-- Agent absorption 1547 move_also_north(nr_move_north)%agent_mask = .FALSE. 1548 deleted_agents = deleted_agents + 1 1549 1607 1550 ENDIF 1608 1551 ENDIF 1609 1552 ENDIF 1610 ENDDO 1611 1612 RETURN 1613 1614 END SUBROUTINE mas_eh_add_agents_to_gridcell 1553 ENDIF 1554 ENDDO 1555 1556 RETURN 1557 1558 END SUBROUTINE mas_eh_add_agents_to_gridcell 1615 1559 #endif 1616 1560 1617 1561 1618 1562 #if defined( __parallel ) 1619 !------------------------------------------------------------------------------ !1563 !--------------------------------------------------------------------------------------------------! 1620 1564 ! Description: 1621 1565 ! ------------ 1622 !> After ghost layer agents have been received from neighboring PEs, this 1623 !> subroutine sorts them into the corresponding grid cells 1624 !------------------------------------------------------------------------------! 1625 SUBROUTINE mas_eh_add_ghost_agents_to_gridcell (agent_array) 1626 1627 IMPLICIT NONE 1628 1629 INTEGER(iwp) :: ip !< grid index (x) of agent 1630 INTEGER(iwp) :: jp !< grid index (x) of agent 1631 INTEGER(iwp) :: n !< index variable of agent 1632 INTEGER(iwp) :: aindex !< dummy argument for new number of agents per grid box 1633 1634 LOGICAL :: pack_done !< flag to indicate that packing is done 1635 1636 TYPE(agent_type), DIMENSION(:), INTENT(IN) :: agent_array !< new agents in a grid box 1637 1638 pack_done = .FALSE. 1639 1640 DO n = 1, SIZE(agent_array) 1641 1642 IF ( .NOT. agent_array(n)%agent_mask ) CYCLE 1643 1644 ip = agent_array(n)%x * ddx 1645 jp = agent_array(n)%y * ddy 1646 1647 IF ( ip < nxl .OR. ip > nxr .OR. jp < nys .OR. jp > nyn ) THEN 1648 number_of_agents = agt_count(jp,ip) 1649 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 1650 1651 aindex = agt_count(jp,ip)+1 1652 IF( aindex > SIZE(grid_agents(jp,ip)%agents) ) THEN 1653 IF ( pack_done ) THEN 1566 !> After ghost layer agents have been received from neighboring PEs, this subroutine sorts them into 1567 !> the corresponding grid cells 1568 !--------------------------------------------------------------------------------------------------! 1569 SUBROUTINE mas_eh_add_ghost_agents_to_gridcell (agent_array) 1570 1571 IMPLICIT NONE 1572 1573 INTEGER(iwp) :: aindex !< dummy argument for new number of agents per grid box 1574 INTEGER(iwp) :: ip !< grid index (x) of agent 1575 INTEGER(iwp) :: jp !< grid index (x) of agent 1576 INTEGER(iwp) :: n !< index variable of agent 1577 1578 LOGICAL :: pack_done !< flag to indicate that packing is done 1579 1580 TYPE(agent_type), DIMENSION(:), INTENT(IN) :: agent_array !< new agents in a grid box 1581 1582 pack_done = .FALSE. 1583 1584 DO n = 1, SIZE(agent_array) 1585 1586 IF ( .NOT. agent_array(n)%agent_mask ) CYCLE 1587 1588 ip = agent_array(n)%x * ddx 1589 jp = agent_array(n)%y * ddy 1590 1591 IF ( ip < nxl .OR. ip > nxr .OR. jp < nys .OR. jp > nyn ) THEN 1592 number_of_agents = agt_count(jp,ip) 1593 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 1594 1595 aindex = agt_count(jp,ip)+1 1596 IF( aindex > SIZE( grid_agents(jp,ip)%agents ) ) THEN 1597 IF ( pack_done ) THEN 1598 CALL mas_eh_realloc_agents_array (ip,jp) 1599 ELSE 1600 CALL mas_ps_pack 1601 agt_count(jp,ip) = number_of_agents 1602 aindex = agt_count(jp,ip)+1 1603 IF ( aindex > SIZE( grid_agents(jp,ip)%agents ) ) THEN 1654 1604 CALL mas_eh_realloc_agents_array (ip,jp) 1655 ELSE1656 CALL mas_ps_pack1657 agt_count(jp,ip) = number_of_agents1658 aindex = agt_count(jp,ip)+11659 IF ( aindex > SIZE(grid_agents(jp,ip)%agents) ) THEN1660 CALL mas_eh_realloc_agents_array (ip,jp)1661 ENDIF1662 pack_done = .TRUE.1663 1605 ENDIF 1606 pack_done = .TRUE. 1664 1607 ENDIF 1665 grid_agents(jp,ip)%agents(aindex) = agent_array(n)1666 agt_count(jp,ip) = aindex1667 1608 ENDIF 1668 ENDDO 1669 END SUBROUTINE mas_eh_add_ghost_agents_to_gridcell 1609 grid_agents(jp,ip)%agents(aindex) = agent_array(n) 1610 agt_count(jp,ip) = aindex 1611 ENDIF 1612 ENDDO 1613 END SUBROUTINE mas_eh_add_ghost_agents_to_gridcell 1670 1614 #endif 1671 1615 1672 !------------------------------------------------------------------------------ !1616 !--------------------------------------------------------------------------------------------------! 1673 1617 ! Description: 1674 1618 ! ------------ 1675 1619 !> Resizing of agent arrays 1676 !------------------------------------------------------------------------------! 1677 SUBROUTINE mas_eh_dealloc_agents_array 1678 1679 IMPLICIT NONE 1680 1681 INTEGER(iwp) :: i !< grid index (x) of agent 1682 INTEGER(iwp) :: j !< grid index (y) of agent 1683 INTEGER(iwp) :: old_size !< old array size 1684 INTEGER(iwp) :: new_size !< new array size 1685 INTEGER(iwp) :: noa !< number of agents 1686 1687 LOGICAL :: dealloc !< flag that indicates if reallocation is necessary 1688 1689 TYPE(agent_type), DIMENSION(10) :: tmp_agents_s !< temporary static agent array 1690 1691 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: tmp_agents_d !< temporary dynamic agent array 1692 1693 DO i = nxlg, nxrg 1694 DO j = nysg, nyng 1695 ! 1696 !-- Determine number of active agents 1697 noa = agt_count(j,i) 1698 ! 1699 !-- Determine allocated memory size 1700 old_size = SIZE( grid_agents(j,i)%agents ) 1701 ! 1702 !-- Check for large unused memory 1703 dealloc = ( ( noa < min_nr_agent .AND. old_size > min_nr_agent ) & 1704 .OR. ( noa > min_nr_agent .AND. old_size - noa * & 1705 ( 1.0_wp + 0.01_wp * alloc_factor_mas ) > 0.0_wp ) ) 1706 ! 1707 !-- If large unused memory was found, resize the corresponding array 1708 IF ( dealloc ) THEN 1709 IF ( noa < min_nr_agent ) THEN 1710 new_size = min_nr_agent 1711 ELSE 1712 new_size = INT( noa * ( 1.0_wp + & 1713 0.01_wp * alloc_factor_mas ) ) 1714 ENDIF 1715 1716 IF ( noa <= 10 ) THEN 1717 1718 tmp_agents_s(1:noa) = grid_agents(j,i)%agents(1:noa) 1719 1720 DEALLOCATE(grid_agents(j,i)%agents) 1721 ALLOCATE(grid_agents(j,i)%agents(1:new_size)) 1722 1723 grid_agents(j,i)%agents(1:noa) = tmp_agents_s(1:noa) 1724 grid_agents(j,i)%agents(noa+1:new_size) = zero_agent 1725 1726 ELSE 1727 1728 ALLOCATE(tmp_agents_d(noa)) 1729 tmp_agents_d(1:noa) = grid_agents(j,i)%agents(1:noa) 1730 1731 DEALLOCATE(grid_agents(j,i)%agents) 1732 ALLOCATE(grid_agents(j,i)%agents(new_size)) 1733 1734 grid_agents(j,i)%agents(1:noa) = tmp_agents_d(1:noa) 1735 grid_agents(j,i)%agents(noa+1:new_size) = zero_agent 1736 1737 DEALLOCATE(tmp_agents_d) 1738 1739 ENDIF 1740 1620 !--------------------------------------------------------------------------------------------------! 1621 SUBROUTINE mas_eh_dealloc_agents_array 1622 1623 IMPLICIT NONE 1624 1625 INTEGER(iwp) :: i !< grid index (x) of agent 1626 INTEGER(iwp) :: j !< grid index (y) of agent 1627 INTEGER(iwp) :: new_size !< new array size 1628 INTEGER(iwp) :: noa !< number of agents 1629 INTEGER(iwp) :: old_size !< old array size 1630 1631 LOGICAL :: dealloc !< flag that indicates if reallocation is necessary 1632 1633 TYPE(agent_type), DIMENSION(10) :: tmp_agents_s !< temporary static agent array 1634 1635 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: tmp_agents_d !< temporary dynamic agent array 1636 1637 DO i = nxlg, nxrg 1638 DO j = nysg, nyng 1639 ! 1640 !-- Determine number of active agents 1641 noa = agt_count(j,i) 1642 ! 1643 !-- Determine allocated memory size 1644 old_size = SIZE( grid_agents(j,i)%agents ) 1645 ! 1646 !-- Check for large unused memory 1647 dealloc = ( ( noa < min_nr_agent .AND. old_size > min_nr_agent ) .OR. & 1648 ( noa > min_nr_agent .AND. & 1649 old_size - noa * ( 1.0_wp + 0.01_wp * alloc_factor_mas ) > 0.0_wp ) & 1650 ) 1651 ! 1652 !-- If large unused memory was found, resize the corresponding array 1653 IF ( dealloc ) THEN 1654 IF ( noa < min_nr_agent ) THEN 1655 new_size = min_nr_agent 1656 ELSE 1657 new_size = INT( noa * ( 1.0_wp + 0.01_wp * alloc_factor_mas ) ) 1741 1658 ENDIF 1742 ENDDO 1659 1660 IF ( noa <= 10 ) THEN 1661 1662 tmp_agents_s(1:noa) = grid_agents(j,i)%agents(1:noa) 1663 1664 DEALLOCATE(grid_agents(j,i)%agents) 1665 ALLOCATE(grid_agents(j,i)%agents(1:new_size)) 1666 1667 grid_agents(j,i)%agents(1:noa) = tmp_agents_s(1:noa) 1668 grid_agents(j,i)%agents(noa+1:new_size) = zero_agent 1669 1670 ELSE 1671 1672 ALLOCATE(tmp_agents_d(noa)) 1673 tmp_agents_d(1:noa) = grid_agents(j,i)%agents(1:noa) 1674 1675 DEALLOCATE(grid_agents(j,i)%agents) 1676 ALLOCATE(grid_agents(j,i)%agents(new_size)) 1677 1678 grid_agents(j,i)%agents(1:noa) = tmp_agents_d(1:noa) 1679 grid_agents(j,i)%agents(noa+1:new_size) = zero_agent 1680 1681 DEALLOCATE(tmp_agents_d) 1682 1683 ENDIF 1684 1685 ENDIF 1743 1686 ENDDO 1744 1745 END SUBROUTINE mas_eh_dealloc_agents_array 1746 1747 !------------------------------------------------------------------------------! 1687 ENDDO 1688 1689 END SUBROUTINE mas_eh_dealloc_agents_array 1690 1691 !--------------------------------------------------------------------------------------------------! 1748 1692 ! Description: 1749 1693 ! ------------ 1750 1694 !> Exchange between subdomains. 1751 !> As soon as one agent has moved beyond the boundary of the domain, it 1752 !> is included in the relevant transfer arrays and marked for subsequent 1753 !> deletion on this PE. 1754 !> First sweep for crossings in x direction. Find out first the number of 1755 !> agents to be transferred and allocate temporary arrays needed to store 1756 !> them. 1757 !> For a one-dimensional decomposition along y, no transfer is necessary, 1758 !> because the agent remains on the PE, but the agent coordinate has to 1759 !> be adjusted. 1760 !------------------------------------------------------------------------------! 1761 SUBROUTINE mas_eh_exchange_horiz 1762 1763 IMPLICIT NONE 1764 1765 INTEGER(iwp) :: ip !< index variable along x 1766 INTEGER(iwp) :: jp !< index variable along y 1767 INTEGER(iwp) :: n !< agent index variable 1695 !> As soon as one agent has moved beyond the boundary of the domain, it is included in the relevant 1696 !> transfer arrays and marked for subsequent deletion on this PE. 1697 !> First sweep for crossings in x direction. Find out first the number of agents to be transferred 1698 !> and allocate temporary arrays needed to store them. 1699 !> For a one-dimensional decomposition along y, no transfer is necessary, because the agent remains 1700 !> on the PE, but the agent coordinate has to be adjusted. 1701 !--------------------------------------------------------------------------------------------------! 1702 SUBROUTINE mas_eh_exchange_horiz 1703 1704 IMPLICIT NONE 1705 1706 INTEGER(iwp) :: ip !< index variable along x 1707 INTEGER(iwp) :: jp !< index variable along y 1708 INTEGER(iwp) :: n !< agent index variable 1768 1709 1769 1710 #if defined( __parallel ) 1770 1711 1771 INTEGER(iwp) :: i !< grid index (x) of agent positition 1772 INTEGER(iwp) :: j !< grid index (y) of agent positition 1773 INTEGER(iwp) :: par_size !< Agent size in bytes 1774 1775 INTEGER(iwp) :: trla_count !< number of agents send to left PE 1776 INTEGER(iwp) :: trla_count_recv !< number of agents receive from right PE 1777 INTEGER(iwp) :: trna_count !< number of agents send to north PE 1778 INTEGER(iwp) :: trna_count_recv !< number of agents receive from south PE 1779 INTEGER(iwp) :: trra_count !< number of agents send to right PE 1780 INTEGER(iwp) :: trra_count_recv !< number of agents receive from left PE 1781 INTEGER(iwp) :: trsa_count !< number of agents send to south PE 1782 INTEGER(iwp) :: trsa_count_recv !< number of agents receive from north PE 1783 1784 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: rvla !< agents received from right PE 1785 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: rvna !< agents received from south PE 1786 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: rvra !< agents received from left PE 1787 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: rvsa !< agents received from north PE 1788 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: trla !< agents send to left PE 1789 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: trna !< agents send to north PE 1790 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: trra !< agents send to right PE 1791 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: trsa !< agents send to south PE 1792 1793 ! 1794 !-- Exchange between subdomains. 1795 !-- As soon as one agent has moved beyond the boundary of the domain, it 1796 !-- is included in the relevant transfer arrays and marked for subsequent 1797 !-- deletion on this PE. 1798 !-- First sweep for crossings in x direction. Find out first the number of 1799 !-- agents to be transferred and allocate temporary arrays needed to store 1800 !-- them. 1801 !-- For a one-dimensional decomposition along y, no transfer is necessary, 1802 !-- because the agent remains on the PE, but the agent coordinate has to 1803 !-- be adjusted. 1804 trla_count = 0 1805 trra_count = 0 1806 1807 trla_count_recv = 0 1808 trra_count_recv = 0 1809 1810 IF ( pdims(1) /= 1 ) THEN 1811 ! 1812 !-- First calculate the storage necessary for sending and receiving the data. 1813 !-- Compute only first (nxl) and last (nxr) loop iterration. 1814 DO ip = nxl, nxr, nxr - nxl 1815 DO jp = nys, nyn 1816 1817 number_of_agents = agt_count(jp,ip) 1818 IF ( number_of_agents <= 0 ) CYCLE 1819 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 1820 DO n = 1, number_of_agents 1821 IF ( agents(n)%agent_mask ) THEN 1822 i = agents(n)%x * ddx 1823 ! 1824 !-- Above calculation does not work for indices less than zero 1825 IF ( agents(n)%x < 0.0_wp ) i = -1 1826 1827 IF ( i < nxl ) THEN 1828 trla_count = trla_count + 1 1829 ELSEIF ( i > nxr ) THEN 1830 trra_count = trra_count + 1 1831 ENDIF 1832 ENDIF 1833 ENDDO 1834 1835 ENDDO 1836 ENDDO 1837 1838 IF ( trla_count == 0 ) trla_count = 1 1839 IF ( trra_count == 0 ) trra_count = 1 1840 1841 ALLOCATE( trla(trla_count), trra(trra_count) ) 1842 1843 trla = zero_agent 1844 trra = zero_agent 1845 1846 trla_count = 0 1847 trra_count = 0 1848 1849 ENDIF 1850 ! 1851 !-- Compute only first (nxl) and last (nxr) loop iterration 1852 DO ip = nxl, nxr, nxr-nxl 1712 INTEGER(iwp) :: i !< grid index (x) of agent positition 1713 INTEGER(iwp) :: j !< grid index (y) of agent positition 1714 INTEGER(iwp) :: par_size !< Agent size in bytes 1715 1716 INTEGER(iwp) :: trla_count !< number of agents send to left PE 1717 INTEGER(iwp) :: trla_count_recv !< number of agents receive from right PE 1718 INTEGER(iwp) :: trna_count !< number of agents send to north PE 1719 INTEGER(iwp) :: trna_count_recv !< number of agents receive from south PE 1720 INTEGER(iwp) :: trra_count !< number of agents send to right PE 1721 INTEGER(iwp) :: trra_count_recv !< number of agents receive from left PE 1722 INTEGER(iwp) :: trsa_count !< number of agents send to south PE 1723 INTEGER(iwp) :: trsa_count_recv !< number of agents receive from north PE 1724 1725 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: rvla !< agents received from right PE 1726 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: rvna !< agents received from south PE 1727 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: rvra !< agents received from left PE 1728 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: rvsa !< agents received from north PE 1729 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: trla !< agents send to left PE 1730 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: trna !< agents send to north PE 1731 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: trra !< agents send to right PE 1732 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: trsa !< agents send to south PE 1733 1734 ! 1735 !-- Exchange between subdomains. 1736 !-- As soon as one agent has moved beyond the boundary of the domain, it is included in the relevant 1737 !-- transfer arrays and marked for subsequent deletion on this PE. 1738 !-- First sweep for crossings in x direction. Find out first the number of agents to be transferred 1739 !-- and allocate temporary arrays needed to store them. 1740 !-- For a one-dimensional decomposition along y, no transfer is necessary, because the agent remains 1741 !-- on the PE, but the agent coordinate has to be adjusted. 1742 trla_count = 0 1743 trra_count = 0 1744 1745 trla_count_recv = 0 1746 trra_count_recv = 0 1747 1748 IF ( pdims(1) /= 1 ) THEN 1749 ! 1750 !-- First calculate the storage necessary for sending and receiving the data. 1751 !-- Compute only first (nxl) and last (nxr) loop iterration. 1752 DO ip = nxl, nxr, nxr - nxl 1853 1753 DO jp = nys, nyn 1854 number_of_agents = agt_count(jp,ip) 1855 IF ( number_of_agents <= 0 ) CYCLE 1856 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 1857 DO n = 1, number_of_agents 1858 ! 1859 !-- Only those agents that have not been marked as 'deleted' may 1860 !-- be moved. 1861 IF ( agents(n)%agent_mask ) THEN 1862 1863 i = agents(n)%x * ddx 1864 ! 1865 !-- Above calculation does not work for indices less than zero 1866 IF ( agents(n)%x < 0.0_wp ) i = -1 1867 1868 IF ( i < nxl ) THEN 1869 IF ( i < 0 ) THEN 1870 ! 1871 !-- Apply boundary condition along x 1872 IF ( ibc_mas_lr == 0 ) THEN 1873 ! 1874 !-- Cyclic condition 1875 IF ( pdims(1) == 1 ) THEN 1876 agents(n)%x = ( nx + 1 ) * dx + & 1877 agents(n)%x 1878 agents(n)%origin_x = ( nx + 1 ) * dx + & 1879 agents(n)%origin_x 1880 ELSE 1881 trla_count = trla_count + 1 1882 trla(trla_count) = agents(n) 1883 trla(trla_count)%x = ( nx + 1 ) * dx + & 1884 trla(trla_count)%x 1885 trla(trla_count)%origin_x = & 1886 trla(trla_count)%origin_x + & 1887 ( nx + 1 ) * dx 1888 agents(n)%agent_mask = .FALSE. 1889 deleted_agents = deleted_agents + 1 1890 1891 IF ( trla(trla_count)%x >= & 1892 (nx + 1)* dx - 1.0E-12_wp ) & 1893 THEN 1894 trla(trla_count)%x = trla(trla_count)%x - & 1895 1.0E-10_wp 1896 trla(trla_count)%origin_x = & 1897 trla(trla_count)%origin_x - 1 1898 ENDIF 1899 1900 ENDIF 1901 1902 ELSEIF ( ibc_mas_lr == 1 ) THEN 1903 ! 1904 !-- Agent absorption 1905 agents(n)%agent_mask = .FALSE. 1906 deleted_agents = deleted_agents + 1 1907 1908 ENDIF 1909 ELSE 1910 ! 1911 !-- Store agent data in the transfer array, which will be 1912 !-- send to the neighbouring PE 1913 trla_count = trla_count + 1 1914 trla(trla_count) = agents(n) 1915 agents(n)%agent_mask = .FALSE. 1916 deleted_agents = deleted_agents + 1 1917 1918 ENDIF 1919 1920 ELSEIF ( i > nxr ) THEN 1921 IF ( i > nx ) THEN 1922 ! 1923 !-- Apply boundary condition along x 1924 IF ( ibc_mas_lr == 0 ) THEN 1925 ! 1926 !-- Cyclic condition 1927 IF ( pdims(1) == 1 ) THEN 1928 agents(n)%x = agents(n)%x - ( nx + 1 ) * dx 1929 agents(n)%origin_x = agents(n)%origin_x - & 1930 ( nx + 1 ) * dx 1931 ELSE 1932 trra_count = trra_count + 1 1933 trra(trra_count) = agents(n) 1934 trra(trra_count)%x = trra(trra_count)%x - & 1935 ( nx + 1 ) * dx 1936 trra(trra_count)%origin_x = & 1937 trra(trra_count)%origin_x - & 1938 ( nx + 1 ) * dx 1939 agents(n)%agent_mask = .FALSE. 1940 deleted_agents = deleted_agents + 1 1941 1942 ENDIF 1943 1944 ELSEIF ( ibc_mas_lr == 1 ) THEN 1945 ! 1946 !-- Agent absorption 1947 agents(n)%agent_mask = .FALSE. 1948 deleted_agents = deleted_agents + 1 1949 1950 ENDIF 1951 ELSE 1952 ! 1953 !-- Store agent data in the transfer array, which will be send 1954 !-- to the neighbouring PE 1955 trra_count = trra_count + 1 1956 trra(trra_count) = agents(n) 1957 agents(n)%agent_mask = .FALSE. 1958 deleted_agents = deleted_agents + 1 1959 1960 ENDIF 1961 1962 ENDIF 1963 ENDIF 1964 1965 ENDDO 1966 ENDDO 1967 ENDDO 1968 1969 ! 1970 !-- Allocate arrays required for north-south exchange, as these 1971 !-- are used directly after agents are exchange along x-direction. 1972 ALLOCATE( move_also_north(1:NR_2_direction_move) ) 1973 ALLOCATE( move_also_south(1:NR_2_direction_move) ) 1974 1975 nr_move_north = 0 1976 nr_move_south = 0 1977 ! 1978 !-- Send left boundary, receive right boundary (but first exchange how many 1979 !-- and chec if agent storage must be extended) 1980 IF ( pdims(1) /= 1 ) THEN 1981 1982 CALL MPI_SENDRECV( trla_count, 1, MPI_INTEGER, pleft, 0, & 1983 trra_count_recv, 1, MPI_INTEGER, pright, 0, & 1984 comm2d, status, ierr ) 1985 1986 ALLOCATE(rvra(MAX(1,trra_count_recv))) 1987 ! 1988 !-- This MPI_SENDRECV should work even with odd mixture on 32 and 64 Bit 1989 !-- variables in structure agent_type (due to the calculation of par_size) 1990 par_size = STORAGE_SIZE(trla(1))/8 1991 CALL MPI_SENDRECV( trla, max(1,trla_count)*par_size, MPI_BYTE, pleft,& 1992 1, rvra, max(1,trra_count_recv)*par_size, MPI_BYTE, pright,& 1993 1, comm2d, status, ierr ) 1994 1995 IF ( trra_count_recv > 0 ) THEN 1996 CALL mas_eh_add_agents_to_gridcell(rvra(1:trra_count_recv)) 1997 ENDIF 1998 1999 DEALLOCATE(rvra) 2000 2001 ! 2002 !-- Send right boundary, receive left boundary 2003 CALL MPI_SENDRECV( trra_count, 1, MPI_INTEGER, pright, 0, & 2004 trla_count_recv, 1, MPI_INTEGER, pleft, 0, & 2005 comm2d, status, ierr ) 2006 2007 ALLOCATE(rvla(MAX(1,trla_count_recv))) 2008 ! 2009 !-- This MPI_SENDRECV should work even with odd mixture on 32 and 64 Bit 2010 !-- variables in structure agent_type (due to the calculation of par_size) 2011 par_size = STORAGE_SIZE(trra(1))/8 2012 CALL MPI_SENDRECV( trra, max(1,trra_count)*par_size, MPI_BYTE, & 2013 pright, 1, rvla, & 2014 max(1,trla_count_recv)*par_size, MPI_BYTE, & 2015 pleft, 1, comm2d, status, ierr ) 2016 2017 IF ( trla_count_recv > 0 ) THEN 2018 CALL mas_eh_add_agents_to_gridcell(rvla(1:trla_count_recv)) 2019 ENDIF 2020 2021 DEALLOCATE( rvla ) 2022 DEALLOCATE( trla, trra ) 2023 2024 ENDIF 2025 2026 ! 2027 !-- Check whether agents have crossed the boundaries in y direction. Note 2028 !-- that this case can also apply to agents that have just been received 2029 !-- from the adjacent right or left PE. 2030 !-- Find out first the number of agents to be transferred and allocate 2031 !-- temporary arrays needed to store them. 2032 !-- For a one-dimensional decomposition along y, no transfer is necessary, 2033 !-- because the agent remains on the PE. 2034 trsa_count = nr_move_south 2035 trna_count = nr_move_north 2036 2037 trsa_count_recv = 0 2038 trna_count_recv = 0 2039 2040 IF ( pdims(2) /= 1 ) THEN 2041 ! 2042 !-- First calculate the storage necessary for sending and receiving the 2043 !-- data 2044 DO ip = nxl, nxr 2045 DO jp = nys, nyn, nyn-nys !compute only first (nys) and last (nyn) loop iterration 2046 number_of_agents = agt_count(jp,ip) 2047 IF ( number_of_agents <= 0 ) CYCLE 2048 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 2049 DO n = 1, number_of_agents 2050 IF ( agents(n)%agent_mask ) THEN 2051 j = agents(n)%y * ddy 2052 ! 2053 !-- Above calculation does not work for indices less than zero 2054 IF ( agents(n)%y < 0.0_wp ) j = -1 2055 2056 IF ( j < nys ) THEN 2057 trsa_count = trsa_count + 1 2058 ELSEIF ( j > nyn ) THEN 2059 trna_count = trna_count + 1 2060 ENDIF 2061 ENDIF 2062 ENDDO 2063 ENDDO 2064 ENDDO 2065 2066 IF ( trsa_count == 0 ) trsa_count = 1 2067 IF ( trna_count == 0 ) trna_count = 1 2068 2069 ALLOCATE( trsa(trsa_count), trna(trna_count) ) 2070 2071 trsa = zero_agent 2072 trna = zero_agent 2073 2074 trsa_count = nr_move_south 2075 trna_count = nr_move_north 2076 2077 trsa(1:nr_move_south) = move_also_south(1:nr_move_south) 2078 trna(1:nr_move_north) = move_also_north(1:nr_move_north) 2079 2080 ENDIF 2081 2082 DO ip = nxl, nxr 2083 DO jp = nys, nyn, nyn-nys ! compute only first (nys) and last (nyn) loop iterration 1754 2084 1755 number_of_agents = agt_count(jp,ip) 2085 1756 IF ( number_of_agents <= 0 ) CYCLE 2086 1757 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 2087 1758 DO n = 1, number_of_agents 2088 !2089 !-- Only those agents that have not been marked as 'deleted' may2090 !-- be moved.2091 1759 IF ( agents(n)%agent_mask ) THEN 2092 2093 j = agents(n)%y * ddy 1760 i = agents(n)%x * ddx 2094 1761 ! 2095 1762 !-- Above calculation does not work for indices less than zero 2096 IF ( agents(n)%y < 0.0_wp * dy ) j = -1 2097 2098 IF ( j < nys ) THEN 2099 IF ( j < 0 ) THEN 2100 ! 2101 !-- Apply boundary condition along y 2102 IF ( ibc_mas_ns == 0 ) THEN 2103 ! 2104 !-- Cyclic condition 2105 IF ( pdims(2) == 1 ) THEN 2106 agents(n)%y = ( ny + 1 ) * dy + agents(n)%y 2107 agents(n)%origin_y = ( ny + 1 ) * dy + & 2108 agents(n)%origin_y 2109 ELSE 2110 trsa_count = trsa_count + 1 2111 trsa(trsa_count) = agents(n) 2112 trsa(trsa_count)%y = ( ny + 1 ) * dy + & 2113 trsa(trsa_count)%y 2114 trsa(trsa_count)%origin_y = & 2115 trsa(trsa_count)%origin_y & 2116 + ( ny + 1 ) * dy 2117 agents(n)%agent_mask = .FALSE. 2118 deleted_agents = deleted_agents + 1 2119 2120 IF ( trsa(trsa_count)%y >= & 2121 (ny+1)* dy - 1.0E-12_wp ) & 2122 THEN 2123 trsa(trsa_count)%y = trsa(trsa_count)%y - & 2124 1.0E-10_wp 2125 trsa(trsa_count)%origin_y = & 2126 trsa(trsa_count)%origin_y - 1 2127 ENDIF 2128 1763 IF ( agents(n)%x < 0.0_wp ) i = -1 1764 1765 IF ( i < nxl ) THEN 1766 trla_count = trla_count + 1 1767 ELSEIF ( i > nxr ) THEN 1768 trra_count = trra_count + 1 1769 ENDIF 1770 ENDIF 1771 ENDDO 1772 1773 ENDDO 1774 ENDDO 1775 1776 IF ( trla_count == 0 ) trla_count = 1 1777 IF ( trra_count == 0 ) trra_count = 1 1778 1779 ALLOCATE( trla(trla_count), trra(trra_count) ) 1780 1781 trla = zero_agent 1782 trra = zero_agent 1783 1784 trla_count = 0 1785 trra_count = 0 1786 1787 ENDIF 1788 ! 1789 !-- Compute only first (nxl) and last (nxr) loop iterration 1790 DO ip = nxl, nxr, nxr-nxl 1791 DO jp = nys, nyn 1792 number_of_agents = agt_count(jp,ip) 1793 IF ( number_of_agents <= 0 ) CYCLE 1794 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 1795 DO n = 1, number_of_agents 1796 ! 1797 !-- Only those agents that have not been marked as 'deleted' may be moved. 1798 IF ( agents(n)%agent_mask ) THEN 1799 1800 i = agents(n)%x * ddx 1801 ! 1802 !-- Above calculation does not work for indices less than zero 1803 IF ( agents(n)%x < 0.0_wp ) i = -1 1804 1805 IF ( i < nxl ) THEN 1806 IF ( i < 0 ) THEN 1807 ! 1808 !-- Apply boundary condition along x 1809 IF ( ibc_mas_lr == 0 ) THEN 1810 ! 1811 !-- Cyclic condition 1812 IF ( pdims(1) == 1 ) THEN 1813 agents(n)%x = ( nx + 1 ) * dx + agents(n)%x 1814 agents(n)%origin_x = ( nx + 1 ) * dx + agents(n)%origin_x 1815 ELSE 1816 trla_count = trla_count + 1 1817 trla(trla_count) = agents(n) 1818 trla(trla_count)%x = ( nx + 1 ) * dx + trla(trla_count)%x 1819 trla(trla_count)%origin_x = trla(trla_count)%origin_x + ( nx + 1 ) * dx 1820 agents(n)%agent_mask = .FALSE. 1821 deleted_agents = deleted_agents + 1 1822 1823 IF ( trla(trla_count)%x >= (nx + 1)* dx - 1.0E-12_wp ) THEN 1824 trla(trla_count)%x = trla(trla_count)%x - 1.0E-10_wp 1825 trla(trla_count)%origin_x = trla(trla_count)%origin_x - 1 2129 1826 ENDIF 2130 1827 2131 ELSEIF ( ibc_mas_ns == 1 ) THEN2132 !2133 !-- Agent absorption2134 agents(n)%agent_mask = .FALSE.2135 deleted_agents = deleted_agents + 12136 2137 1828 ENDIF 2138 ELSE 2139 ! 2140 !-- Store agent data in the transfer array, which will 2141 !-- be send to the neighbouring PE 2142 trsa_count = trsa_count + 1 2143 trsa(trsa_count) = agents(n) 1829 1830 ELSEIF ( ibc_mas_lr == 1 ) THEN 1831 ! 1832 !-- Agent absorption 2144 1833 agents(n)%agent_mask = .FALSE. 2145 1834 deleted_agents = deleted_agents + 1 2146 1835 2147 1836 ENDIF 2148 2149 ELSEIF ( j > nyn ) THEN 2150 IF ( j > ny ) THEN 2151 ! 2152 !-- Apply boundary condition along y 2153 IF ( ibc_mas_ns == 0 ) THEN 2154 ! 2155 !-- Cyclic condition 2156 IF ( pdims(2) == 1 ) THEN 2157 agents(n)%y = agents(n)%y - & 2158 ( ny + 1 ) * dy 2159 agents(n)%origin_y = agents(n)%origin_y - & 2160 ( ny + 1 ) * dy 2161 ELSE 2162 trna_count = trna_count + 1 2163 trna(trna_count) = agents(n) 2164 trna(trna_count)%y = & 2165 trna(trna_count)%y - ( ny + 1 ) * dy 2166 trna(trna_count)%origin_y = & 2167 trna(trna_count)%origin_y - & 2168 ( ny + 1 ) * dy 2169 agents(n)%agent_mask = .FALSE. 2170 deleted_agents = deleted_agents + 1 2171 ENDIF 2172 2173 ELSEIF ( ibc_mas_ns == 1 ) THEN 2174 ! 2175 !-- Agent absorption 1837 ELSE 1838 ! 1839 !-- Store agent data in the transfer array, which will be send to the neighbouring 1840 !-- PE. 1841 trla_count = trla_count + 1 1842 trla(trla_count) = agents(n) 1843 agents(n)%agent_mask = .FALSE. 1844 deleted_agents = deleted_agents + 1 1845 1846 ENDIF 1847 1848 ELSEIF ( i > nxr ) THEN 1849 IF ( i > nx ) THEN 1850 ! 1851 !-- Apply boundary condition along x 1852 IF ( ibc_mas_lr == 0 ) THEN 1853 ! 1854 !-- Cyclic condition 1855 IF ( pdims(1) == 1 ) THEN 1856 agents(n)%x = agents(n)%x - ( nx + 1 ) * dx 1857 agents(n)%origin_x = agents(n)%origin_x - ( nx + 1 ) * dx 1858 ELSE 1859 trra_count = trra_count + 1 1860 trra(trra_count) = agents(n) 1861 trra(trra_count)%x = trra(trra_count)%x - ( nx + 1 ) * dx 1862 trra(trra_count)%origin_x = trra(trra_count)%origin_x - ( nx + 1 ) * dx 2176 1863 agents(n)%agent_mask = .FALSE. 2177 1864 deleted_agents = deleted_agents + 1 2178 1865 2179 1866 ENDIF 2180 ELSE 2181 ! 2182 !-- Store agent data in the transfer array, which will 2183 !-- be send to the neighbouring PE 2184 trna_count = trna_count + 1 2185 trna(trna_count) = agents(n) 1867 1868 ELSEIF ( ibc_mas_lr == 1 ) THEN 1869 ! 1870 !-- Agent absorption 2186 1871 agents(n)%agent_mask = .FALSE. 2187 1872 deleted_agents = deleted_agents + 1 2188 1873 2189 1874 ENDIF 2190 1875 ELSE 1876 ! 1877 !-- Store agent data in the transfer array, which will be send to the neighbouring 1878 !-- PE. 1879 trra_count = trra_count + 1 1880 trra(trra_count) = agents(n) 1881 agents(n)%agent_mask = .FALSE. 1882 deleted_agents = deleted_agents + 1 1883 1884 ENDIF 1885 1886 ENDIF 1887 ENDIF 1888 1889 ENDDO 1890 ENDDO 1891 ENDDO 1892 1893 ! 1894 !-- Allocate arrays required for north-south exchange, as these are used directly after agents are 1895 !-- exchange along x-direction. 1896 ALLOCATE( move_also_north(1:nr_2_direction_move) ) 1897 ALLOCATE( move_also_south(1:nr_2_direction_move) ) 1898 1899 nr_move_north = 0 1900 nr_move_south = 0 1901 ! 1902 !-- Send left boundary, receive right boundary (but first exchange how many and check if agent 1903 !-- storage must be extended). 1904 IF ( pdims(1) /= 1 ) THEN 1905 1906 CALL MPI_SENDRECV( trla_count, 1, MPI_INTEGER, pleft, 0, & 1907 trra_count_recv, 1, MPI_INTEGER, pright, 0, & 1908 comm2d, status, ierr ) 1909 1910 ALLOCATE( rvra(MAX( 1,trra_count_recv )) ) 1911 ! 1912 !-- This MPI_SENDRECV should work even with odd mixture on 32 and 64 Bit variables in structure 1913 !-- agent_type (due to the calculation of par_size) 1914 par_size = STORAGE_SIZE( trla(1) ) / 8 1915 CALL MPI_SENDRECV( trla, MAX( 1, trla_count ) * par_size, MPI_BYTE, pleft, 1, & 1916 rvra, MAX( 1, trra_count_recv )* par_size, MPI_BYTE, pright, 1, & 1917 comm2d, status, ierr ) 1918 1919 IF ( trra_count_recv > 0 ) THEN 1920 CALL mas_eh_add_agents_to_gridcell(rvra(1:trra_count_recv)) 1921 ENDIF 1922 1923 DEALLOCATE(rvra) 1924 1925 ! 1926 !-- Send right boundary, receive left boundary 1927 CALL MPI_SENDRECV( trra_count, 1, MPI_INTEGER, pright, 0, & 1928 trla_count_recv, 1, MPI_INTEGER, pleft, 0, & 1929 comm2d, status, ierr ) 1930 1931 ALLOCATE(rvla(MAX(1,trla_count_recv))) 1932 ! 1933 !-- This MPI_SENDRECV should work even with odd mixture on 32 and 64 Bit variables in structure 1934 !-- agent_type (due to the calculation of par_size) 1935 par_size = STORAGE_SIZE(trra(1))/8 1936 CALL MPI_SENDRECV( trra, MAX( 1, trra_count ) * par_size, MPI_BYTE, pright, 1, & 1937 rvla, MAX(1,trla_count_recv) * par_size, MPI_BYTE, pleft, 1, & 1938 comm2d, status, ierr ) 1939 1940 IF ( trla_count_recv > 0 ) THEN 1941 CALL mas_eh_add_agents_to_gridcell(rvla(1:trla_count_recv)) 1942 ENDIF 1943 1944 DEALLOCATE( rvla ) 1945 DEALLOCATE( trla, trra ) 1946 1947 ENDIF 1948 1949 ! 1950 !-- Check whether agents have crossed the boundaries in y direction. Note that this case can also 1951 !-- apply to agents that have just been received from the adjacent right or left PE. 1952 !-- Find out first the number of agents to be transferred and allocate temporary arrays needed to 1953 !-- store them. 1954 !-- For a one-dimensional decomposition along y, no transfer is necessary, because the agent remains 1955 !-- on the PE. 1956 trsa_count = nr_move_south 1957 trna_count = nr_move_north 1958 1959 trsa_count_recv = 0 1960 trna_count_recv = 0 1961 1962 IF ( pdims(2) /= 1 ) THEN 1963 ! 1964 !-- First calculate the storage necessary for sending and receiving the data. 1965 DO ip = nxl, nxr 1966 DO jp = nys, nyn, nyn-nys ! compute only first (nys) and last (nyn) loop iterration 1967 number_of_agents = agt_count(jp,ip) 1968 IF ( number_of_agents <= 0 ) CYCLE 1969 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 1970 DO n = 1, number_of_agents 1971 IF ( agents(n)%agent_mask ) THEN 1972 j = agents(n)%y * ddy 1973 ! 1974 !-- Above calculation does not work for indices less than zero 1975 IF ( agents(n)%y < 0.0_wp ) j = -1 1976 1977 IF ( j < nys ) THEN 1978 trsa_count = trsa_count + 1 1979 ELSEIF ( j > nyn ) THEN 1980 trna_count = trna_count + 1 2191 1981 ENDIF 2192 1982 ENDIF … … 2195 1985 ENDDO 2196 1986 2197 ! 2198 !-- Send front boundary, receive back boundary (but first exchange how many 2199 !-- and chec if agent storage must be extended) 2200 IF ( pdims(2) /= 1 ) THEN 2201 2202 CALL MPI_SENDRECV( trsa_count, 1, MPI_INTEGER, psouth, 0, & 2203 trna_count_recv, 1, MPI_INTEGER, pnorth, 0, & 2204 comm2d, status, ierr ) 2205 2206 ALLOCATE(rvna(MAX(1,trna_count_recv))) 2207 ! 2208 !-- This MPI_SENDRECV should work even with odd mixture on 32 and 64 Bit 2209 !-- variables in structure agent_type (due to the calculation of par_size) 2210 par_size = STORAGE_SIZE(trsa(1))/8 2211 CALL MPI_SENDRECV( trsa, trsa_count*par_size, MPI_BYTE, & 2212 psouth, 1, rvna, & 2213 trna_count_recv*par_size, MPI_BYTE, pnorth, 1, & 2214 comm2d, status, ierr ) 2215 2216 IF ( trna_count_recv > 0 ) THEN 2217 CALL mas_eh_add_agents_to_gridcell(rvna(1:trna_count_recv)) 2218 ENDIF 2219 2220 DEALLOCATE(rvna) 2221 2222 ! 2223 !-- Send back boundary, receive front boundary 2224 CALL MPI_SENDRECV( trna_count, 1, MPI_INTEGER, pnorth, 0, & 2225 trsa_count_recv, 1, MPI_INTEGER, psouth, 0, & 2226 comm2d, status, ierr ) 2227 2228 ALLOCATE(rvsa(MAX(1,trsa_count_recv))) 2229 ! 2230 !-- This MPI_SENDRECV should work even with odd mixture on 32 and 64 Bit 2231 !-- variables in structure agent_type (due to the calculation of par_size) 2232 par_size = STORAGE_SIZE(trna(1))/8 2233 CALL MPI_SENDRECV( trna, trna_count*par_size, MPI_BYTE, & 2234 pnorth, 1, rvsa, & 2235 trsa_count_recv*par_size, MPI_BYTE, psouth, 1, & 2236 comm2d, status, ierr ) 2237 2238 IF ( trsa_count_recv > 0 ) THEN 2239 CALL mas_eh_add_agents_to_gridcell(rvsa(1:trsa_count_recv)) 2240 ENDIF 2241 2242 DEALLOCATE(rvsa) 2243 2244 number_of_agents = number_of_agents + trsa_count_recv 2245 2246 DEALLOCATE( trsa, trna ) 2247 2248 ENDIF 2249 2250 DEALLOCATE( move_also_north ) 2251 DEALLOCATE( move_also_south ) 2252 2253 ! 2254 !-- Accumulate the number of agents transferred between the subdomains) 2255 CALL mas_eh_ghost_exchange 2256 2257 #else 2258 2259 DO ip = nxl, nxr, nxr-nxl 2260 DO jp = nys, nyn 2261 number_of_agents = agt_count(jp,ip) 2262 IF ( number_of_agents <= 0 ) CYCLE 2263 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 2264 DO n = 1, number_of_agents 2265 ! 2266 !-- Apply boundary conditions 2267 IF ( agents(n)%x < 0.0_wp ) THEN 2268 2269 IF ( ibc_mas_lr == 0 ) THEN 2270 ! 2271 !-- Cyclic boundary. Relevant coordinate has to be changed. 2272 agents(n)%x = ( nx + 1 ) * dx + agents(n)%x 2273 agents(n)%origin_x = ( nx + 1 ) * dx + & 2274 agents(n)%origin_x 2275 ELSEIF ( ibc_mas_lr == 1 ) THEN 2276 ! 2277 !-- Agent absorption 1987 IF ( trsa_count == 0 ) trsa_count = 1 1988 IF ( trna_count == 0 ) trna_count = 1 1989 1990 ALLOCATE( trsa(trsa_count), trna(trna_count) ) 1991 1992 trsa = zero_agent 1993 trna = zero_agent 1994 1995 trsa_count = nr_move_south 1996 trna_count = nr_move_north 1997 1998 trsa(1:nr_move_south) = move_also_south(1:nr_move_south) 1999 trna(1:nr_move_north) = move_also_north(1:nr_move_north) 2000 2001 ENDIF 2002 2003 DO ip = nxl, nxr 2004 DO jp = nys, nyn, nyn-nys ! compute only first (nys) and last (nyn) loop iterration 2005 number_of_agents = agt_count(jp,ip) 2006 IF ( number_of_agents <= 0 ) CYCLE 2007 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 2008 DO n = 1, number_of_agents 2009 ! 2010 !-- Only those agents that have not been marked as 'deleted' may be moved. 2011 IF ( agents(n)%agent_mask ) THEN 2012 2013 j = agents(n)%y * ddy 2014 ! 2015 !-- Above calculation does not work for indices less than zero 2016 IF ( agents(n)%y < 0.0_wp * dy ) j = -1 2017 2018 IF ( j < nys ) THEN 2019 IF ( j < 0 ) THEN 2020 ! 2021 !-- Apply boundary condition along y 2022 IF ( ibc_mas_ns == 0 ) THEN 2023 ! 2024 !-- Cyclic condition 2025 IF ( pdims(2) == 1 ) THEN 2026 agents(n)%y = ( ny + 1 ) * dy + agents(n)%y 2027 agents(n)%origin_y = ( ny + 1 ) * dy + agents(n)%origin_y 2028 ELSE 2029 trsa_count = trsa_count + 1 2030 trsa(trsa_count) = agents(n) 2031 trsa(trsa_count)%y = ( ny + 1 ) * dy + trsa(trsa_count)%y 2032 trsa(trsa_count)%origin_y = trsa(trsa_count)%origin_y + ( ny + 1 ) * dy 2033 agents(n)%agent_mask = .FALSE. 2034 deleted_agents = deleted_agents + 1 2035 2036 IF ( trsa(trsa_count)%y >= (ny+1)* dy - 1.0E-12_wp ) THEN 2037 trsa(trsa_count)%y = trsa(trsa_count)%y - 1.0E-10_wp 2038 trsa(trsa_count)%origin_y = trsa(trsa_count)%origin_y - 1 2039 ENDIF 2040 2041 ENDIF 2042 2043 ELSEIF ( ibc_mas_ns == 1 ) THEN 2044 ! 2045 !-- Agent absorption 2046 agents(n)%agent_mask = .FALSE. 2047 deleted_agents = deleted_agents + 1 2048 2049 ENDIF 2050 ELSE 2051 ! 2052 !-- Store agent data in the transfer array, which will be send to the neighbouring 2053 !-- PE. 2054 trsa_count = trsa_count + 1 2055 trsa(trsa_count) = agents(n) 2278 2056 agents(n)%agent_mask = .FALSE. 2279 2057 deleted_agents = deleted_agents + 1 2058 2280 2059 ENDIF 2281 2060 2282 ELSEIF ( agents(n)%x >= ( nx + 1 ) * dx ) THEN 2283 2284 IF ( ibc_mas_lr == 0 ) THEN 2285 ! 2286 !-- Cyclic boundary. Relevant coordinate has to be changed. 2287 agents(n)%x = agents(n)%x - ( nx + 1 ) * dx 2288 2289 ELSEIF ( ibc_mas_lr == 1 ) THEN 2290 ! 2291 !-- Agent absorption 2061 ELSEIF ( j > nyn ) THEN 2062 IF ( j > ny ) THEN 2063 ! 2064 !-- Apply boundary condition along y 2065 IF ( ibc_mas_ns == 0 ) THEN 2066 ! 2067 !-- Cyclic condition 2068 IF ( pdims(2) == 1 ) THEN 2069 agents(n)%y = agents(n)%y - ( ny + 1 ) * dy 2070 agents(n)%origin_y = agents(n)%origin_y - ( ny + 1 ) * dy 2071 ELSE 2072 trna_count = trna_count + 1 2073 trna(trna_count) = agents(n) 2074 trna(trna_count)%y = trna(trna_count)%y - ( ny + 1 ) * dy 2075 trna(trna_count)%origin_y = trna(trna_count)%origin_y - ( ny + 1 ) * dy 2076 agents(n)%agent_mask = .FALSE. 2077 deleted_agents = deleted_agents + 1 2078 ENDIF 2079 2080 ELSEIF ( ibc_mas_ns == 1 ) THEN 2081 ! 2082 !-- Agent absorption 2083 agents(n)%agent_mask = .FALSE. 2084 deleted_agents = deleted_agents + 1 2085 2086 ENDIF 2087 ELSE 2088 ! 2089 !-- Store agent data in the transfer array, which will be send to the neighbouring 2090 !-- PE 2091 trna_count = trna_count + 1 2092 trna(trna_count) = agents(n) 2292 2093 agents(n)%agent_mask = .FALSE. 2293 2094 deleted_agents = deleted_agents + 1 2095 2294 2096 ENDIF 2295 2097 2098 ENDIF 2099 ENDIF 2100 ENDDO 2101 ENDDO 2102 ENDDO 2103 2104 ! 2105 !-- Send front boundary, receive back boundary (but first exchange how many and check if agent 2106 !-- storage must be extended). 2107 IF ( pdims(2) /= 1 ) THEN 2108 2109 CALL MPI_SENDRECV( trsa_count, 1, MPI_INTEGER, psouth, 0, & 2110 trna_count_recv, 1, MPI_INTEGER, pnorth, 0, & 2111 comm2d, status, ierr ) 2112 2113 ALLOCATE( rvna( MAX( 1, trna_count_recv )) ) 2114 ! 2115 !-- This MPI_SENDRECV should work even with odd mixture on 32 and 64 Bit variables in structure 2116 !-- agent_type (due to the calculation of par_size) 2117 par_size = STORAGE_SIZE(trsa(1))/8 2118 CALL MPI_SENDRECV( trsa, trsa_count * par_size, MPI_BYTE, psouth, 1, & 2119 rvna, trna_count_recv * par_size, MPI_BYTE, pnorth, 1, & 2120 comm2d, status, ierr ) 2121 2122 IF ( trna_count_recv > 0 ) THEN 2123 CALL mas_eh_add_agents_to_gridcell(rvna(1:trna_count_recv)) 2124 ENDIF 2125 2126 DEALLOCATE( rvna ) 2127 2128 ! 2129 !-- Send back boundary, receive front boundary 2130 CALL MPI_SENDRECV( trna_count, 1, MPI_INTEGER, pnorth, 0, & 2131 trsa_count_recv, 1, MPI_INTEGER, psouth, 0, & 2132 comm2d, status, ierr ) 2133 2134 ALLOCATE( rvsa( MAX( 1, trsa_count_recv )) ) 2135 ! 2136 !-- This MPI_SENDRECV should work even with odd mixture on 32 and 64 Bit variables in structure 2137 !-- agent_type (due to the calculation of par_size) 2138 par_size = STORAGE_SIZE( trna(1) ) / 8 2139 CALL MPI_SENDRECV( trna, trna_count * par_size, MPI_BYTE, pnorth, 1, & 2140 rvsa, trsa_count_recv * par_size, MPI_BYTE, psouth, 1, & 2141 comm2d, status, ierr ) 2142 2143 IF ( trsa_count_recv > 0 ) THEN 2144 CALL mas_eh_add_agents_to_gridcell(rvsa(1:trsa_count_recv)) 2145 ENDIF 2146 2147 DEALLOCATE( rvsa ) 2148 2149 number_of_agents = number_of_agents + trsa_count_recv 2150 2151 DEALLOCATE( trsa, trna ) 2152 2153 ENDIF 2154 2155 DEALLOCATE( move_also_north ) 2156 DEALLOCATE( move_also_south ) 2157 2158 ! 2159 !-- Accumulate the number of agents transferred between the subdomains) 2160 CALL mas_eh_ghost_exchange 2161 2162 #else 2163 2164 DO ip = nxl, nxr, nxr-nxl 2165 DO jp = nys, nyn 2166 number_of_agents = agt_count(jp,ip) 2167 IF ( number_of_agents <= 0 ) CYCLE 2168 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 2169 DO n = 1, number_of_agents 2170 ! 2171 !-- Apply boundary conditions 2172 IF ( agents(n)%x < 0.0_wp ) THEN 2173 2174 IF ( ibc_mas_lr == 0 ) THEN 2175 ! 2176 !-- Cyclic boundary. Relevant coordinate has to be changed. 2177 agents(n)%x = ( nx + 1 ) * dx + agents(n)%x 2178 agents(n)%origin_x = ( nx + 1 ) * dx + agents(n)%origin_x 2179 ELSEIF ( ibc_mas_lr == 1 ) THEN 2180 ! 2181 !-- Agent absorption 2182 agents(n)%agent_mask = .FALSE. 2183 deleted_agents = deleted_agents + 1 2184 ENDIF 2185 2186 ELSEIF ( agents(n)%x >= ( nx + 1 ) * dx ) THEN 2187 2188 IF ( ibc_mas_lr == 0 ) THEN 2189 ! 2190 !-- Cyclic boundary. Relevant coordinate has to be changed. 2191 agents(n)%x = agents(n)%x - ( nx + 1 ) * dx 2192 2193 ELSEIF ( ibc_mas_lr == 1 ) THEN 2194 ! 2195 !-- Agent absorption 2196 agents(n)%agent_mask = .FALSE. 2197 deleted_agents = deleted_agents + 1 2198 ENDIF 2199 2200 ENDIF 2201 ENDDO 2202 ENDDO 2203 ENDDO 2204 2205 DO ip = nxl, nxr 2206 DO jp = nys, nyn, nyn-nys 2207 number_of_agents = agt_count(jp,ip) 2208 IF ( number_of_agents <= 0 ) CYCLE 2209 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 2210 DO n = 1, number_of_agents 2211 2212 IF ( agents(n)%y < 0.0_wp ) THEN 2213 2214 IF ( ibc_mas_ns == 0 ) THEN 2215 ! 2216 !-- Cyclic boundary. Relevant coordinate has to be changed. 2217 agents(n)%y = ( ny + 1 ) * dy + agents(n)%y 2218 agents(n)%origin_y = ( ny + 1 ) * dy + & 2219 agents(n)%origin_y 2220 2221 ELSEIF ( ibc_mas_ns == 1 ) THEN 2222 ! 2223 !-- Agent absorption 2224 agents(n)%agent_mask = .FALSE. 2225 deleted_agents = deleted_agents + 1 2226 ENDIF 2227 2228 ELSEIF ( agents(n)%y >= ( ny + 0.5_wp ) * dy ) THEN 2229 2230 IF ( ibc_mas_ns == 0 ) THEN 2231 ! 2232 !-- Cyclic boundary. Relevant coordinate has to be changed. 2233 agents(n)%y = agents(n)%y - ( ny + 1 ) * dy 2234 2235 ELSEIF ( ibc_mas_ns == 1 ) THEN 2236 ! 2237 !-- Agent absorption 2238 agents(n)%agent_mask = .FALSE. 2239 deleted_agents = deleted_agents + 1 2240 ENDIF 2241 2242 ENDIF 2243 2244 ENDDO 2245 ENDDO 2246 ENDDO 2247 #endif 2248 2249 END SUBROUTINE mas_eh_exchange_horiz 2250 2251 2252 #if defined( __parallel ) 2253 !--------------------------------------------------------------------------------------------------! 2254 ! Description: 2255 ! ------------ 2256 !> Sends the agents from the three gridcells closest to the north/south/left/right border of a PE to 2257 !> the corresponding neighbors ghost layer (which is three grid boxes deep) 2258 !--------------------------------------------------------------------------------------------------! 2259 SUBROUTINE mas_eh_ghost_exchange 2260 2261 IMPLICIT NONE 2262 2263 INTEGER(iwp) :: agt_size !< Bit size of agent datatype 2264 INTEGER(iwp) :: ghla_count !< ghost points left agent 2265 INTEGER(iwp) :: ghna_count !< ghost points north agent 2266 INTEGER(iwp) :: ghra_count !< ghost points right agent 2267 INTEGER(iwp) :: ghsa_count !< ghost points south agent 2268 INTEGER(iwp) :: ip !< index variable along x 2269 INTEGER(iwp) :: jp !< index variable along y 2270 2271 LOGICAL :: ghla_empty !< ghost points left agent 2272 LOGICAL :: ghla_empty_rcv !< ghost points left agent 2273 LOGICAL :: ghna_empty !< ghost points north agent 2274 LOGICAL :: ghna_empty_rcv !< ghost points north agent 2275 LOGICAL :: ghra_empty !< ghost points right agent 2276 LOGICAL :: ghra_empty_rcv !< ghost points right agent 2277 LOGICAL :: ghsa_empty !< ghost points south agent 2278 LOGICAL :: ghsa_empty_rcv !< ghost points south agent 2279 2280 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: ghla !< agents received from right PE 2281 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: ghna !< agents received from south PE 2282 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: ghra !< agents received from left PE 2283 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: ghsa !< agents received from north PE 2284 2285 ghla_empty = .TRUE. 2286 ghna_empty = .TRUE. 2287 ghra_empty = .TRUE. 2288 ghsa_empty = .TRUE. 2289 ! 2290 !-- Reset ghost layer 2291 DO ip = nxlg, nxl-1 2292 DO jp = nysg, nyng 2293 agt_count(jp,ip) = 0 2294 ENDDO 2295 ENDDO 2296 DO ip = nxr+1, nxrg 2297 DO jp = nysg, nyng 2298 agt_count(jp,ip) = 0 2299 ENDDO 2300 ENDDO 2301 DO ip = nxl, nxr 2302 DO jp = nysg, nys-1 2303 agt_count(jp,ip) = 0 2304 ENDDO 2305 ENDDO 2306 DO ip = nxl, nxr 2307 DO jp = nyn+1, nyng 2308 agt_count(jp,ip) = 0 2309 ENDDO 2310 ENDDO 2311 ! 2312 !-- Transfer of agents from left to right and vice versa 2313 IF ( pdims(1) /= 1 ) THEN 2314 ! 2315 !-- Reset left and right ghost layers 2316 ghla_count = 0 2317 ghra_count = 0 2318 ! 2319 !-- First calculate the storage necessary for sending and receiving the data. 2320 ghla_count = SUM(agt_count(nys:nyn,nxl:nxl+2)) 2321 ghra_count = SUM(agt_count(nys:nyn,nxr-2:nxr)) 2322 ! 2323 !-- No cyclic boundaries for agents 2324 IF ( nxl == 0 .OR. ghla_count == 0 ) THEN 2325 ghla_count = 1 2326 ELSE 2327 ghla_empty = .FALSE. 2328 ENDIF 2329 IF ( nxr == nx .OR. ghra_count == 0 ) THEN 2330 ghra_count = 1 2331 ELSE 2332 ghra_empty = .FALSE. 2333 ENDIF 2334 ALLOCATE( ghla(1:ghla_count), ghra(1:ghra_count) ) 2335 ghla = zero_agent 2336 ghra = zero_agent 2337 ! 2338 !-- Get all agents that will be sent left into one array 2339 ghla_count = 0 2340 IF ( nxl /= 0 ) THEN 2341 DO ip = nxl, nxl+2 2342 DO jp = nys, nyn 2343 2344 number_of_agents = agt_count(jp,ip) 2345 IF ( number_of_agents <= 0 ) CYCLE 2346 ghla(ghla_count+1:ghla_count+number_of_agents) & 2347 = grid_agents(jp,ip)%agents(1:number_of_agents) 2348 ghla_count = ghla_count + number_of_agents 2349 2350 ENDDO 2351 ENDDO 2352 ENDIF 2353 IF ( ghla_count == 0 ) ghla_count = 1 2354 ! 2355 !-- Get all agents that will be sent right into one array 2356 ghra_count = 0 2357 IF ( nxr /= nx ) THEN 2358 DO ip = nxr-2, nxr 2359 DO jp = nys, nyn 2360 2361 number_of_agents = agt_count(jp,ip) 2362 IF ( number_of_agents <= 0 ) CYCLE 2363 ghra(ghra_count+1:ghra_count+number_of_agents) & 2364 = grid_agents(jp,ip)%agents(1:number_of_agents) 2365 ghra_count = ghra_count + number_of_agents 2366 2367 ENDDO 2368 ENDDO 2369 ENDIF 2370 IF ( ghra_count == 0 ) ghra_count = 1 2371 ! 2372 !-- Send/receive number of agents that will be transferred to/from left/right neighbor. 2373 CALL MPI_SENDRECV( ghla_count, 1, MPI_INTEGER, pleft, 0, & 2374 ghra_count_recv, 1, MPI_INTEGER, pright, 0, & 2375 comm2d, status, ierr ) 2376 ALLOCATE ( agt_gh_r(1:ghra_count_recv) ) 2377 ! 2378 !-- Send/receive number of agents that will be transferred to/from right/left neighbor 2379 CALL MPI_SENDRECV( ghra_count, 1, MPI_INTEGER, pright, 0, & 2380 ghla_count_recv, 1, MPI_INTEGER, pleft, 0, & 2381 comm2d, status, ierr ) 2382 ! 2383 !-- Send/receive flag that indicates if there are actually any agents in ghost layer 2384 CALL MPI_SENDRECV( ghla_empty, 1, MPI_LOGICAL, pleft, 1, & 2385 ghra_empty_rcv, 1, MPI_LOGICAL, pright,1, & 2386 comm2d, status, ierr ) 2387 CALL MPI_SENDRECV( ghra_empty, 1, MPI_LOGICAL, pright,1, & 2388 ghla_empty_rcv, 1, MPI_LOGICAL, pleft, 1, & 2389 comm2d, status, ierr ) 2390 2391 2392 ALLOCATE ( agt_gh_l(1:ghla_count_recv) ) 2393 ! 2394 !-- Get bit size of one agent 2395 agt_size = STORAGE_SIZE(zero_agent)/8 2396 ! 2397 !-- Send/receive agents to/from left/right neighbor 2398 CALL MPI_SENDRECV( ghla, ghla_count * agt_size, MPI_BYTE, pleft, 1, & 2399 agt_gh_r, ghra_count_recv * agt_size, MPI_BYTE, pright,1, & 2400 comm2d, status, ierr ) 2401 ! 2402 !-- Send/receive agents to/from left/right neighbor 2403 CALL MPI_SENDRECV( ghra, ghra_count * agt_size, MPI_BYTE, pright,1, & 2404 agt_gh_l, ghla_count_recv * agt_size, MPI_BYTE, pleft, 1, & 2405 comm2d, status, ierr ) 2406 ! 2407 !-- If agents were received, add them to the respective ghost layer cells 2408 IF ( .NOT. ghra_empty_rcv ) THEN 2409 CALL mas_eh_add_ghost_agents_to_gridcell(agt_gh_r) 2410 ENDIF 2411 2412 IF ( .NOT. ghla_empty_rcv ) THEN 2413 CALL mas_eh_add_ghost_agents_to_gridcell(agt_gh_l) 2414 ENDIF 2415 2416 DEALLOCATE( ghla, ghra, agt_gh_l, agt_gh_r ) 2417 2418 ENDIF 2419 2420 ! 2421 !-- Transfer of agents from south to north and vice versa 2422 IF ( pdims(2) /= 1 ) THEN 2423 ! 2424 !-- Reset south and north ghost layers 2425 ghsa_count = 0 2426 ghna_count = 0 2427 ! 2428 !-- First calculate the storage necessary for sending and receiving the data. 2429 ghsa_count = SUM( agt_count(nys:nys+2,nxlg:nxrg) ) 2430 ghna_count = SUM( agt_count(nyn-2:nyn,nxlg:nxrg) ) 2431 ! 2432 !-- No cyclic boundaries for agents 2433 IF ( nys == 0 .OR. ghsa_count == 0 ) THEN 2434 ghsa_count = 1 2435 ELSE 2436 ghsa_empty = .FALSE. 2437 ENDIF 2438 IF ( nyn == ny .OR. ghna_count == 0 ) THEN 2439 ghna_count = 1 2440 ELSE 2441 ghna_empty = .FALSE. 2442 ENDIF 2443 ALLOCATE( ghsa(1:ghsa_count), ghna(1:ghna_count) ) 2444 ghsa = zero_agent 2445 ghna = zero_agent 2446 ! 2447 !-- Get all agents that will be sent south into one array 2448 ghsa_count = 0 2449 IF ( nys /= 0 ) THEN 2450 DO ip = nxlg, nxrg 2451 DO jp = nys, nys+2 2452 2453 number_of_agents = agt_count(jp,ip) 2454 IF ( number_of_agents <= 0 ) CYCLE 2455 ghsa(ghsa_count+1:ghsa_count+number_of_agents) & 2456 = grid_agents(jp,ip)%agents(1:number_of_agents) 2457 ghsa_count = ghsa_count + number_of_agents 2458 2459 ENDDO 2460 ENDDO 2461 ENDIF 2462 IF ( ghsa_count == 0 ) ghsa_count = 1 2463 ! 2464 !-- Get all agents that will be sent north into one array 2465 ghna_count = 0 2466 IF ( nyn /= ny ) THEN 2467 DO ip = nxlg, nxrg 2468 DO jp = nyn-2, nyn 2469 2470 number_of_agents = agt_count(jp,ip) 2471 IF ( number_of_agents <= 0 ) CYCLE 2472 ghna(ghna_count+1:ghna_count+number_of_agents) & 2473 = grid_agents(jp,ip)%agents(1:number_of_agents) 2474 ghna_count = ghna_count + number_of_agents 2475 2476 ENDDO 2477 ENDDO 2478 ENDIF 2479 IF ( ghna_count == 0 ) ghna_count = 1 2480 ! 2481 !-- Send/receive number of agents that will be transferred to/from south/north neighbor 2482 CALL MPI_SENDRECV( ghsa_count, 1, MPI_INTEGER, psouth, 0, & 2483 ghna_count_recv, 1, MPI_INTEGER, pnorth, 0, & 2484 comm2d, status, ierr ) 2485 ALLOCATE ( agt_gh_n(1:ghna_count_recv) ) 2486 ! 2487 !-- Send/receive number of agents that will be transferred to/from north/south neighbor 2488 CALL MPI_SENDRECV( ghna_count, 1, MPI_INTEGER, pnorth, 0, & 2489 ghsa_count_recv, 1, MPI_INTEGER, psouth, 0, & 2490 comm2d, status, ierr ) 2491 ! 2492 !-- Send/receive flag that indicates if there are actually any agents in ghost layer 2493 CALL MPI_SENDRECV( ghsa_empty, 1, MPI_LOGICAL, psouth, 1, & 2494 ghna_empty_rcv, 1, MPI_LOGICAL, pnorth, 1, & 2495 comm2d, status, ierr ) 2496 CALL MPI_SENDRECV( ghna_empty, 1, MPI_LOGICAL, pnorth, 1, & 2497 ghsa_empty_rcv, 1, MPI_LOGICAL, psouth, 1, & 2498 comm2d, status, ierr ) 2499 2500 2501 ALLOCATE ( agt_gh_s(1:ghsa_count_recv) ) 2502 ! 2503 !-- Get bit size of one agent 2504 agt_size = STORAGE_SIZE(zero_agent)/8 2505 ! 2506 !-- Send/receive agents to/from south/north neighbor 2507 CALL MPI_SENDRECV( ghsa, ghsa_count * agt_size, MPI_BYTE, psouth,1, & 2508 agt_gh_n, ghna_count_recv * agt_size, MPI_BYTE, pnorth,1, & 2509 comm2d, status, ierr ) 2510 ! 2511 !-- Send/receive agents to/from south/north neighbor 2512 CALL MPI_SENDRECV( ghna, ghna_count * agt_size, MPI_BYTE, pnorth,1, & 2513 agt_gh_s, ghsa_count_recv * agt_size, MPI_BYTE, psouth,1, & 2514 comm2d, status, ierr ) 2515 ! 2516 !-- If agents were received, add them to the respective ghost layer cells 2517 IF ( .NOT. ghna_empty_rcv ) THEN 2518 CALL mas_eh_add_ghost_agents_to_gridcell(agt_gh_n) 2519 ENDIF 2520 2521 IF ( .NOT. ghsa_empty_rcv ) THEN 2522 CALL mas_eh_add_ghost_agents_to_gridcell(agt_gh_s) 2523 ENDIF 2524 2525 DEALLOCATE( ghna, ghsa, agt_gh_n, agt_gh_s ) 2526 2527 ENDIF 2528 2529 END SUBROUTINE mas_eh_ghost_exchange 2530 #endif 2531 2532 !--------------------------------------------------------------------------------------------------! 2533 ! Description: 2534 ! ------------ 2535 !> If an agent moves from one grid cell to another (on the current processor!), this subroutine 2536 !> moves the corresponding element from the agent array of the old grid cell to the agent array of 2537 !> the new grid cell. 2538 !--------------------------------------------------------------------------------------------------! 2539 SUBROUTINE mas_eh_move_agent 2540 2541 IMPLICIT NONE 2542 2543 INTEGER(iwp) :: aindex !< dummy argument for number of new agent per grid box 2544 INTEGER(iwp) :: i !< grid index (x) of agent position 2545 INTEGER(iwp) :: ip !< index variable along x 2546 INTEGER(iwp) :: j !< grid index (y) of agent position 2547 INTEGER(iwp) :: jp !< index variable along y 2548 INTEGER(iwp) :: n !< index variable for agent array 2549 INTEGER(iwp) :: na_before_move !< number of agents per grid box before moving 2550 2551 TYPE(agent_type), DIMENSION(:), POINTER :: agents_before_move !< agents before moving 2552 2553 DO ip = nxl, nxr 2554 DO jp = nys, nyn 2555 2556 na_before_move = agt_count(jp,ip) 2557 IF ( na_before_move <= 0 ) CYCLE 2558 agents_before_move => grid_agents(jp,ip)%agents(1:na_before_move) 2559 2560 DO n = 1, na_before_move 2561 i = agents_before_move(n)%x * ddx 2562 j = agents_before_move(n)%y * ddy 2563 2564 !-- For mas_eh_exchange_horiz to work properly agents need to be moved to the outermost 2565 !-- gridboxes of the respective processor. 2566 !-- If the agent index is inside the processor the following lines will not change the 2567 !-- index. 2568 i = MIN ( i , nxr ) 2569 i = MAX ( i , nxl ) 2570 j = MIN ( j , nyn ) 2571 j = MAX ( j , nys ) 2572 2573 ! 2574 !-- Check if agent has moved to another grid cell. 2575 IF ( i /= ip .OR. j /= jp ) THEN 2576 ! 2577 !-- If the agent stays on the same processor, the agent will be added to the agent 2578 !-- array of the new processor. 2579 number_of_agents = agt_count(j,i) 2580 agents => grid_agents(j,i)%agents(1:number_of_agents) 2581 2582 aindex = number_of_agents+1 2583 IF ( aindex > SIZE(grid_agents(j,i)%agents) ) THEN 2584 CALL mas_eh_realloc_agents_array(i,j) 2585 ENDIF 2586 2587 grid_agents(j,i)%agents(aindex) = agents_before_move(n) 2588 agt_count(j,i) = aindex 2589 2590 agents_before_move(n)%agent_mask = .FALSE. 2296 2591 ENDIF 2297 2592 ENDDO 2298 ENDDO 2593 2299 2594 ENDDO 2300 2301 DO ip = nxl, nxr 2302 DO jp = nys, nyn, nyn-nys 2303 number_of_agents = agt_count(jp,ip) 2304 IF ( number_of_agents <= 0 ) CYCLE 2305 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 2306 DO n = 1, number_of_agents 2307 2308 IF ( agents(n)%y < 0.0_wp ) THEN 2309 2310 IF ( ibc_mas_ns == 0 ) THEN 2311 ! 2312 !-- Cyclic boundary. Relevant coordinate has to be changed. 2313 agents(n)%y = ( ny + 1 ) * dy + agents(n)%y 2314 agents(n)%origin_y = ( ny + 1 ) * dy + & 2315 agents(n)%origin_y 2316 2317 ELSEIF ( ibc_mas_ns == 1 ) THEN 2318 ! 2319 !-- Agent absorption 2320 agents(n)%agent_mask = .FALSE. 2321 deleted_agents = deleted_agents + 1 2322 ENDIF 2323 2324 ELSEIF ( agents(n)%y >= ( ny + 0.5_wp ) * dy ) THEN 2325 2326 IF ( ibc_mas_ns == 0 ) THEN 2327 ! 2328 !-- Cyclic boundary. Relevant coordinate has to be changed. 2329 agents(n)%y = agents(n)%y - ( ny + 1 ) * dy 2330 2331 ELSEIF ( ibc_mas_ns == 1 ) THEN 2332 ! 2333 !-- Agent absorption 2334 agents(n)%agent_mask = .FALSE. 2335 deleted_agents = deleted_agents + 1 2336 ENDIF 2337 2338 ENDIF 2339 2340 ENDDO 2341 ENDDO 2342 ENDDO 2343 #endif 2344 2345 END SUBROUTINE mas_eh_exchange_horiz 2346 2347 2348 #if defined( __parallel ) 2349 !------------------------------------------------------------------------------! 2595 ENDDO 2596 2597 RETURN 2598 2599 END SUBROUTINE mas_eh_move_agent 2600 2601 !--------------------------------------------------------------------------------------------------! 2350 2602 ! Description: 2351 2603 ! ------------ 2352 !> Sends the agents from the three gridcells closest to the2353 !> n orth/south/left/right border of a PE to the corresponding neighbors ghost2354 !> layer (which is three grid boxes deep)2355 !------------------------------------------------------------------------------ !2356 SUBROUTINE mas_eh_ ghost_exchange2604 !> If the allocated memory for the agent array does not suffice to add arriving agents from 2605 !> neighbour grid cells, this subrouting reallocates the agent array to assure enough memory is 2606 !> available. 2607 !--------------------------------------------------------------------------------------------------! 2608 SUBROUTINE mas_eh_realloc_agents_array (i,j,size_in) 2357 2609 2358 2610 IMPLICIT NONE 2359 2611 2360 INTEGER(iwp) :: ip !< index variable along x 2361 INTEGER(iwp) :: jp !< index variable along y 2362 INTEGER(iwp) :: agt_size !< Bit size of agent datatype 2363 INTEGER(iwp) :: ghla_count !< ghost points left agent 2364 INTEGER(iwp) :: ghna_count !< ghost points north agent 2365 INTEGER(iwp) :: ghra_count !< ghost points right agent 2366 INTEGER(iwp) :: ghsa_count !< ghost points south agent 2367 2368 LOGICAL :: ghla_empty !< ghost points left agent 2369 LOGICAL :: ghla_empty_rcv !< ghost points left agent 2370 LOGICAL :: ghna_empty !< ghost points north agent 2371 LOGICAL :: ghna_empty_rcv !< ghost points north agent 2372 LOGICAL :: ghra_empty !< ghost points right agent 2373 LOGICAL :: ghra_empty_rcv !< ghost points right agent 2374 LOGICAL :: ghsa_empty !< ghost points south agent 2375 LOGICAL :: ghsa_empty_rcv !< ghost points south agent 2376 2377 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: ghla !< agents received from right PE 2378 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: ghna !< agents received from south PE 2379 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: ghra !< agents received from left PE 2380 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: ghsa !< agents received from north PE 2381 2382 ghla_empty = .TRUE. 2383 ghna_empty = .TRUE. 2384 ghra_empty = .TRUE. 2385 ghsa_empty = .TRUE. 2386 ! 2387 !-- reset ghost layer 2388 DO ip = nxlg, nxl-1 2389 DO jp = nysg, nyng 2390 agt_count(jp,ip) = 0 2391 ENDDO 2392 ENDDO 2393 DO ip = nxr+1, nxrg 2394 DO jp = nysg, nyng 2395 agt_count(jp,ip) = 0 2396 ENDDO 2397 ENDDO 2398 DO ip = nxl, nxr 2399 DO jp = nysg, nys-1 2400 agt_count(jp,ip) = 0 2401 ENDDO 2402 ENDDO 2403 DO ip = nxl, nxr 2404 DO jp = nyn+1, nyng 2405 agt_count(jp,ip) = 0 2406 ENDDO 2407 ENDDO 2408 ! 2409 !-- Transfer of agents from left to right and vice versa 2410 IF ( pdims(1) /= 1 ) THEN 2411 ! 2412 !-- Reset left and right ghost layers 2413 ghla_count = 0 2414 ghra_count = 0 2415 ! 2416 !-- First calculate the storage necessary for sending 2417 !-- and receiving the data. 2418 ghla_count = SUM(agt_count(nys:nyn,nxl:nxl+2)) 2419 ghra_count = SUM(agt_count(nys:nyn,nxr-2:nxr)) 2420 ! 2421 !-- No cyclic boundaries for agents 2422 IF ( nxl == 0 .OR. ghla_count == 0 ) THEN 2423 ghla_count = 1 2424 ELSE 2425 ghla_empty = .FALSE. 2426 ENDIF 2427 IF ( nxr == nx .OR. ghra_count == 0 ) THEN 2428 ghra_count = 1 2429 ELSE 2430 ghra_empty = .FALSE. 2431 ENDIF 2432 ALLOCATE( ghla(1:ghla_count), ghra(1:ghra_count) ) 2433 ghla = zero_agent 2434 ghra = zero_agent 2435 ! 2436 !-- Get all agents that will be sent left into one array 2437 ghla_count = 0 2438 IF ( nxl /= 0 ) THEN 2439 DO ip = nxl, nxl+2 2440 DO jp = nys, nyn 2441 2442 number_of_agents = agt_count(jp,ip) 2443 IF ( number_of_agents <= 0 ) CYCLE 2444 ghla(ghla_count+1:ghla_count+number_of_agents) & 2445 = grid_agents(jp,ip)%agents(1:number_of_agents) 2446 ghla_count = ghla_count + number_of_agents 2447 2448 ENDDO 2449 ENDDO 2450 ENDIF 2451 IF ( ghla_count == 0 ) ghla_count = 1 2452 ! 2453 !-- Get all agents that will be sent right into one array 2454 ghra_count = 0 2455 IF ( nxr /= nx ) THEN 2456 DO ip = nxr-2, nxr 2457 DO jp = nys, nyn 2458 2459 number_of_agents = agt_count(jp,ip) 2460 IF ( number_of_agents <= 0 ) CYCLE 2461 ghra(ghra_count+1:ghra_count+number_of_agents) & 2462 = grid_agents(jp,ip)%agents(1:number_of_agents) 2463 ghra_count = ghra_count + number_of_agents 2464 2465 ENDDO 2466 ENDDO 2467 ENDIF 2468 IF ( ghra_count == 0 ) ghra_count = 1 2469 ! 2470 !-- Send/receive number of agents that 2471 !-- will be transferred to/from left/right neighbor 2472 CALL MPI_SENDRECV( ghla_count, 1, MPI_INTEGER, pleft, 0, & 2473 ghra_count_recv, 1, MPI_INTEGER, pright, 0, & 2474 comm2d, status, ierr ) 2475 ALLOCATE ( agt_gh_r(1:ghra_count_recv) ) 2476 ! 2477 !-- Send/receive number of agents that 2478 !-- will be transferred to/from right/left neighbor 2479 CALL MPI_SENDRECV( ghra_count, 1, MPI_INTEGER, pright, 0, & 2480 ghla_count_recv, 1, MPI_INTEGER, pleft, 0, & 2481 comm2d, status, ierr ) 2482 ! 2483 !-- Send/receive flag that indicates if there are actually any agents 2484 !-- in ghost layer 2485 CALL MPI_SENDRECV( ghla_empty, 1, MPI_LOGICAL, pleft, 1, & 2486 ghra_empty_rcv, 1, MPI_LOGICAL, pright,1, & 2487 comm2d, status, ierr ) 2488 CALL MPI_SENDRECV( ghra_empty, 1, MPI_LOGICAL, pright,1, & 2489 ghla_empty_rcv, 1, MPI_LOGICAL, pleft, 1, & 2490 comm2d, status, ierr ) 2491 2492 2493 ALLOCATE ( agt_gh_l(1:ghla_count_recv) ) 2494 ! 2495 !-- Get bit size of one agent 2496 agt_size = STORAGE_SIZE(zero_agent)/8 2497 ! 2498 !-- Send/receive agents to/from left/right neighbor 2499 CALL MPI_SENDRECV( ghla, ghla_count * agt_size, MPI_BYTE, & 2500 pleft, 1, & 2501 agt_gh_r, ghra_count_recv * agt_size, MPI_BYTE, & 2502 pright,1, & 2503 comm2d, status, ierr ) 2504 ! 2505 !-- Send/receive agents to/from left/right neighbor 2506 CALL MPI_SENDRECV( ghra, ghra_count * agt_size, MPI_BYTE, & 2507 pright,1, & 2508 agt_gh_l, ghla_count_recv * agt_size, MPI_BYTE, & 2509 pleft, 1, & 2510 comm2d, status, ierr ) 2511 ! 2512 !-- If agents were received, add them to the respective ghost layer cells 2513 IF ( .NOT. ghra_empty_rcv ) THEN 2514 CALL mas_eh_add_ghost_agents_to_gridcell(agt_gh_r) 2515 ENDIF 2516 2517 IF ( .NOT. ghla_empty_rcv ) THEN 2518 CALL mas_eh_add_ghost_agents_to_gridcell(agt_gh_l) 2519 ENDIF 2520 2521 DEALLOCATE( ghla, ghra, agt_gh_l, agt_gh_r ) 2522 2523 ENDIF 2524 2525 ! 2526 !-- Transfer of agents from south to north and vice versa 2527 IF ( pdims(2) /= 1 ) THEN 2528 ! 2529 !-- Reset south and north ghost layers 2530 ghsa_count = 0 2531 ghna_count = 0 2532 ! 2533 !-- First calculate the storage necessary for sending 2534 !-- and receiving the data. 2535 ghsa_count = SUM(agt_count(nys:nys+2,nxlg:nxrg)) 2536 ghna_count = SUM(agt_count(nyn-2:nyn,nxlg:nxrg)) 2537 ! 2538 !-- No cyclic boundaries for agents 2539 IF ( nys == 0 .OR. ghsa_count == 0 ) THEN 2540 ghsa_count = 1 2541 ELSE 2542 ghsa_empty = .FALSE. 2543 ENDIF 2544 IF ( nyn == ny .OR. ghna_count == 0 ) THEN 2545 ghna_count = 1 2546 ELSE 2547 ghna_empty = .FALSE. 2548 ENDIF 2549 ALLOCATE( ghsa(1:ghsa_count), ghna(1:ghna_count) ) 2550 ghsa = zero_agent 2551 ghna = zero_agent 2552 ! 2553 !-- Get all agents that will be sent south into one array 2554 ghsa_count = 0 2555 IF ( nys /= 0 ) THEN 2556 DO ip = nxlg, nxrg 2557 DO jp = nys, nys+2 2558 2559 number_of_agents = agt_count(jp,ip) 2560 IF ( number_of_agents <= 0 ) CYCLE 2561 ghsa(ghsa_count+1:ghsa_count+number_of_agents) & 2562 = grid_agents(jp,ip)%agents(1:number_of_agents) 2563 ghsa_count = ghsa_count + number_of_agents 2564 2565 ENDDO 2566 ENDDO 2567 ENDIF 2568 IF ( ghsa_count == 0 ) ghsa_count = 1 2569 ! 2570 !-- Get all agents that will be sent north into one array 2571 ghna_count = 0 2572 IF ( nyn /= ny ) THEN 2573 DO ip = nxlg, nxrg 2574 DO jp = nyn-2, nyn 2575 2576 number_of_agents = agt_count(jp,ip) 2577 IF ( number_of_agents <= 0 ) CYCLE 2578 ghna(ghna_count+1:ghna_count+number_of_agents) & 2579 = grid_agents(jp,ip)%agents(1:number_of_agents) 2580 ghna_count = ghna_count + number_of_agents 2581 2582 ENDDO 2583 ENDDO 2584 ENDIF 2585 IF ( ghna_count == 0 ) ghna_count = 1 2586 ! 2587 !-- Send/receive number of agents that 2588 !-- will be transferred to/from south/north neighbor 2589 CALL MPI_SENDRECV( ghsa_count, 1, MPI_INTEGER, psouth, 0, & 2590 ghna_count_recv, 1, MPI_INTEGER, pnorth, 0, & 2591 comm2d, status, ierr ) 2592 ALLOCATE ( agt_gh_n(1:ghna_count_recv) ) 2593 ! 2594 !-- Send/receive number of agents that 2595 !-- will be transferred to/from north/south neighbor 2596 CALL MPI_SENDRECV( ghna_count, 1, MPI_INTEGER, pnorth, 0, & 2597 ghsa_count_recv, 1, MPI_INTEGER, psouth, 0, & 2598 comm2d, status, ierr ) 2599 ! 2600 !-- Send/receive flag that indicates if there are actually any agents 2601 !-- in ghost layer 2602 CALL MPI_SENDRECV( ghsa_empty, 1, MPI_LOGICAL, psouth, 1, & 2603 ghna_empty_rcv, 1, MPI_LOGICAL, pnorth, 1, & 2604 comm2d, status, ierr ) 2605 CALL MPI_SENDRECV( ghna_empty, 1, MPI_LOGICAL, pnorth, 1, & 2606 ghsa_empty_rcv, 1, MPI_LOGICAL, psouth, 1, & 2607 comm2d, status, ierr ) 2608 2609 2610 ALLOCATE ( agt_gh_s(1:ghsa_count_recv) ) 2611 ! 2612 !-- Get bit size of one agent 2613 agt_size = STORAGE_SIZE(zero_agent)/8 2614 ! 2615 !-- Send/receive agents to/from south/north neighbor 2616 CALL MPI_SENDRECV( ghsa, ghsa_count * agt_size, MPI_BYTE, & 2617 psouth,1, & 2618 agt_gh_n, ghna_count_recv * agt_size, MPI_BYTE, & 2619 pnorth,1, & 2620 comm2d, status, ierr ) 2621 ! 2622 !-- Send/receive agents to/from south/north neighbor 2623 CALL MPI_SENDRECV( ghna, ghna_count * agt_size, MPI_BYTE, & 2624 pnorth,1, & 2625 agt_gh_s, ghsa_count_recv * agt_size, MPI_BYTE, & 2626 psouth,1, & 2627 comm2d, status, ierr ) 2628 ! 2629 !-- If agents were received, add them to the respective ghost layer cells 2630 IF ( .NOT. ghna_empty_rcv ) THEN 2631 CALL mas_eh_add_ghost_agents_to_gridcell(agt_gh_n) 2632 ENDIF 2633 2634 IF ( .NOT. ghsa_empty_rcv ) THEN 2635 CALL mas_eh_add_ghost_agents_to_gridcell(agt_gh_s) 2636 ENDIF 2637 2638 DEALLOCATE( ghna, ghsa, agt_gh_n, agt_gh_s ) 2639 2640 ENDIF 2641 2642 END SUBROUTINE mas_eh_ghost_exchange 2643 #endif 2644 2645 !------------------------------------------------------------------------------! 2646 ! Description: 2647 ! ------------ 2648 !> If an agent moves from one grid cell to another (on the current 2649 !> processor!), this subroutine moves the corresponding element from the 2650 !> agent array of the old grid cell to the agent array of the new grid 2651 !> cell. 2652 !------------------------------------------------------------------------------! 2653 SUBROUTINE mas_eh_move_agent 2654 2655 IMPLICIT NONE 2656 2657 INTEGER(iwp) :: i !< grid index (x) of agent position 2658 INTEGER(iwp) :: ip !< index variable along x 2659 INTEGER(iwp) :: j !< grid index (y) of agent position 2660 INTEGER(iwp) :: jp !< index variable along y 2661 INTEGER(iwp) :: n !< index variable for agent array 2662 INTEGER(iwp) :: na_before_move !< number of agents per grid box before moving 2663 INTEGER(iwp) :: aindex !< dummy argument for number of new agent per grid box 2664 2665 TYPE(agent_type), DIMENSION(:), POINTER :: agents_before_move !< agents before moving 2666 2667 DO ip = nxl, nxr 2668 DO jp = nys, nyn 2669 2670 na_before_move = agt_count(jp,ip) 2671 IF ( na_before_move <= 0 ) CYCLE 2672 agents_before_move => grid_agents(jp,ip)%agents(1:na_before_move) 2673 2674 DO n = 1, na_before_move 2675 i = agents_before_move(n)%x * ddx 2676 j = agents_before_move(n)%y * ddy 2677 2678 !-- For mas_eh_exchange_horiz to work properly agents need to be 2679 !-- moved to the outermost gridboxes of the respective processor. 2680 !-- If the agent index is inside the processor the following 2681 !-- lines will not change the index 2682 i = MIN ( i , nxr ) 2683 i = MAX ( i , nxl ) 2684 j = MIN ( j , nyn ) 2685 j = MAX ( j , nys ) 2686 2687 ! 2688 !-- Check if agent has moved to another grid cell. 2689 IF ( i /= ip .OR. j /= jp ) THEN 2690 ! 2691 !-- If the agent stays on the same processor, the agent 2692 !-- will be added to the agent array of the new processor. 2693 number_of_agents = agt_count(j,i) 2694 agents => grid_agents(j,i)%agents(1:number_of_agents) 2695 2696 aindex = number_of_agents+1 2697 IF ( aindex > SIZE(grid_agents(j,i)%agents) ) & 2698 THEN 2699 CALL mas_eh_realloc_agents_array(i,j) 2700 ENDIF 2701 2702 grid_agents(j,i)%agents(aindex) = agents_before_move(n) 2703 agt_count(j,i) = aindex 2704 2705 agents_before_move(n)%agent_mask = .FALSE. 2706 ENDIF 2707 ENDDO 2708 2709 ENDDO 2710 ENDDO 2711 2712 RETURN 2713 2714 END SUBROUTINE mas_eh_move_agent 2715 2716 !------------------------------------------------------------------------------! 2717 ! Description: 2718 ! ------------ 2719 !> If the allocated memory for the agent array do not suffice to add arriving 2720 !> agents from neighbour grid cells, this subrouting reallocates the 2721 !> agent array to assure enough memory is available. 2722 !------------------------------------------------------------------------------! 2723 SUBROUTINE mas_eh_realloc_agents_array (i,j,size_in) 2724 2725 IMPLICIT NONE 2726 2612 INTEGER(iwp) :: new_size !< new array size 2727 2613 INTEGER(iwp) :: old_size !< old array size 2728 INTEGER(iwp) :: new_size !< new array size2729 2614 2730 2615 INTEGER(iwp), INTENT(in) :: i !< grid index (y) … … 2733 2618 INTEGER(iwp), INTENT(in), OPTIONAL :: size_in !< size of input array 2734 2619 2735 TYPE(agent_type), DIMENSION(10) :: tmp_agents_s !< temporary static agent array2736 2737 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: tmp_agents_d !< temporary dynamic agent array2620 TYPE(agent_type), DIMENSION(10) :: tmp_agents_s !< temporary static agent array 2621 2622 TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: tmp_agents_d !< temporary dynamic agent array 2738 2623 2739 2624 old_size = SIZE(grid_agents(j,i)%agents) 2740 2625 2741 IF ( PRESENT( size_in) )THEN2626 IF ( PRESENT( size_in ) ) THEN 2742 2627 new_size = size_in 2743 2628 ELSE … … 2751 2636 tmp_agents_s(1:old_size) = grid_agents(j,i)%agents(1:old_size) 2752 2637 2753 DEALLOCATE( grid_agents(j,i)%agents)2754 ALLOCATE( grid_agents(j,i)%agents(new_size))2638 DEALLOCATE( grid_agents(j,i)%agents ) 2639 ALLOCATE( grid_agents(j,i)%agents(new_size) ) 2755 2640 2756 2641 grid_agents(j,i)%agents(1:old_size) = tmp_agents_s(1:old_size) … … 2759 2644 ELSE 2760 2645 2761 ALLOCATE( tmp_agents_d(new_size))2646 ALLOCATE( tmp_agents_d(new_size) ) 2762 2647 tmp_agents_d(1:old_size) = grid_agents(j,i)%agents 2763 2648 2764 DEALLOCATE( grid_agents(j,i)%agents)2765 ALLOCATE( grid_agents(j,i)%agents(new_size))2649 DEALLOCATE( grid_agents(j,i)%agents ) 2650 ALLOCATE( grid_agents(j,i)%agents(new_size) ) 2766 2651 2767 2652 grid_agents(j,i)%agents(1:old_size) = tmp_agents_d(1:old_size) 2768 2653 grid_agents(j,i)%agents(old_size+1:new_size) = zero_agent 2769 2654 2770 DEALLOCATE( tmp_agents_d)2655 DEALLOCATE( tmp_agents_d ) 2771 2656 2772 2657 ENDIF … … 2776 2661 END SUBROUTINE mas_eh_realloc_agents_array 2777 2662 2778 !------------------------------------------------------------------------------ !2663 !--------------------------------------------------------------------------------------------------! 2779 2664 ! Description: 2780 2665 ! ------------ 2781 !> Inquires prognostic model quantities at the position of each agent and 2782 !> stores them in that agent for later output 2783 !------------------------------------------------------------------------------! 2784 SUBROUTINE mas_get_prognostic_quantities 2785 2786 USE arrays_3d, & 2787 ONLY: u, v, pt, exner 2788 2789 IMPLICIT NONE 2790 2791 INTEGER(iwp) :: i_offset !< index offset for windspeed measurement 2792 INTEGER(iwp) :: il !< x-index 2793 INTEGER(iwp) :: is !< subgrid box counter 2794 INTEGER(iwp) :: j_offset !< index offset for windspeed measurement 2795 INTEGER(iwp) :: jl !< y-index 2796 INTEGER(iwp) :: kl !< z-index 2797 INTEGER(iwp) :: nl !< agent counter 2798 INTEGER(iwp) :: se !< subgrid box end index 2799 INTEGER(iwp) :: si !< subgrid box start index 2800 2801 REAL(wp) :: u_a !< windspeed at agent position (x) 2802 REAL(wp) :: v_a !< windspeed at agent position (y) 2803 2804 DO il = nxl, nxr 2805 DO jl = nys, nyn 2806 2807 number_of_agents = agt_count(jl,il) 2808 ! 2809 !-- If grid cell is empty, cycle 2810 IF ( number_of_agents <= 0 ) CYCLE 2811 kl = s_measure_height(jl,il) 2812 2813 agents => grid_agents(jl,il)%agents(1:number_of_agents) 2814 ! 2815 !-- loop over the four subgrid boxes 2816 DO is = 0,3 2817 ! 2818 !-- Set indices 2819 si = grid_agents(jl,il)%start_index(is) 2820 se = grid_agents(jl,il)%end_index(is) 2821 DO nl = si, se 2822 ! 2823 !-- Calculate index offset in x-direction: 2824 !-- Left value if wall right of grid box 2825 !-- Right value if wall left of grid box 2826 !-- Else the one that is closer to the agent 2827 IF ( BTEST( obstacle_flags( jl, il+1 ), 6 ) ) THEN 2828 i_offset = 0 2829 ELSEIF ( BTEST( obstacle_flags( jl, il-1 ), 2 ) ) THEN 2830 i_offset = 1 2831 ELSE 2832 i_offset = MERGE( 0, 1, BTEST(is,1) ) 2833 ENDIF 2834 u_a = u( kl, jl, il + i_offset ) 2835 ! 2836 !-- Calculate index offset in y-direction: 2837 !-- South value if wall north of grid box 2838 !-- North value if wall south of grid box 2839 !-- Else the one that is closer to the agent 2840 IF ( BTEST( obstacle_flags( jl+1, il ), 4 ) ) THEN 2841 j_offset = 0 2842 ELSEIF ( BTEST( obstacle_flags( jl-1, il ), 0 ) ) THEN 2843 j_offset = 1 2844 ELSE 2845 j_offset = MERGE( 0, 1, BTEST(is,0) ) 2846 ENDIF 2847 v_a = v( kl, jl + j_offset, il ) 2848 ! 2849 !-- Calculate windspeed at agent postion 2850 agents(nl)%windspeed = SQRT(u_a**2 + v_a**2) 2851 ! 2852 !-- Calculate temperature at agent position 2853 agents(nl)%t = pt(kl,jl,il) * exner(kl) 2854 2855 ENDDO 2666 !> Inquires prognostic model quantities at the position of each agent and stores them in that agent 2667 !> for later output 2668 !--------------------------------------------------------------------------------------------------! 2669 SUBROUTINE mas_get_prognostic_quantities 2670 2671 USE arrays_3d, & 2672 ONLY: exner, pt, u, v 2673 2674 IMPLICIT NONE 2675 2676 INTEGER(iwp) :: i_offset !< index offset for windspeed measurement 2677 INTEGER(iwp) :: il !< x-index 2678 INTEGER(iwp) :: is !< subgrid box counter 2679 INTEGER(iwp) :: j_offset !< index offset for windspeed measurement 2680 INTEGER(iwp) :: jl !< y-index 2681 INTEGER(iwp) :: kl !< z-index 2682 INTEGER(iwp) :: nl !< agent counter 2683 INTEGER(iwp) :: se !< subgrid box end index 2684 INTEGER(iwp) :: si !< subgrid box start index 2685 2686 REAL(wp) :: u_a !< windspeed at agent position (x) 2687 REAL(wp) :: v_a !< windspeed at agent position (y) 2688 2689 DO il = nxl, nxr 2690 DO jl = nys, nyn 2691 2692 number_of_agents = agt_count(jl,il) 2693 ! 2694 !-- If grid cell is empty, cycle 2695 IF ( number_of_agents <= 0 ) CYCLE 2696 kl = s_measure_height(jl,il) 2697 2698 agents => grid_agents(jl,il)%agents(1:number_of_agents) 2699 ! 2700 !-- Loop over the four subgrid boxes 2701 DO is = 0,3 2702 ! 2703 !-- Set indices 2704 si = grid_agents(jl,il)%start_index(is) 2705 se = grid_agents(jl,il)%end_index(is) 2706 DO nl = si, se 2707 ! 2708 !-- Calculate index offset in x-direction: 2709 !-- Left value if wall right of grid box 2710 !-- Right value if wall left of grid box 2711 !-- Else the one that is closer to the agent 2712 IF ( BTEST( obstacle_flags( jl, il+1 ), 6 ) ) THEN 2713 i_offset = 0 2714 ELSEIF ( BTEST( obstacle_flags( jl, il-1 ), 2 ) ) THEN 2715 i_offset = 1 2716 ELSE 2717 i_offset = MERGE( 0, 1, BTEST(is,1) ) 2718 ENDIF 2719 u_a = u( kl, jl, il + i_offset ) 2720 ! 2721 !-- Calculate index offset in y-direction: 2722 !-- South value if wall north of grid box 2723 !-- North value if wall south of grid box 2724 !-- Else the one that is closer to the agent 2725 IF ( BTEST( obstacle_flags( jl+1, il ), 4 ) ) THEN 2726 j_offset = 0 2727 ELSEIF ( BTEST( obstacle_flags( jl-1, il ), 0 ) ) THEN 2728 j_offset = 1 2729 ELSE 2730 j_offset = MERGE( 0, 1, BTEST(is,0) ) 2731 ENDIF 2732 v_a = v( kl, jl + j_offset, il ) 2733 ! 2734 !-- Calculate windspeed at agent postion 2735 agents(nl)%windspeed = SQRT(u_a**2 + v_a**2) 2736 ! 2737 !-- Calculate temperature at agent position 2738 agents(nl)%t = pt(kl,jl,il) * exner(kl) 2856 2739 2857 2740 ENDDO 2858 2741 2859 2742 ENDDO 2743 2860 2744 ENDDO 2861 2862 END SUBROUTINE mas_get_prognostic_quantities 2863 2864 !------------------------------------------------------------------------------! 2745 ENDDO 2746 2747 END SUBROUTINE mas_get_prognostic_quantities 2748 2749 !--------------------------------------------------------------------------------------------------! 2865 2750 ! Description: 2866 2751 ! ------------ 2867 2752 !> Adds an item to the priority queue (binary heap) at the correct position 2868 !------------------------------------------------------------------------------ !2869 2870 2871 2872 2873 INTEGER(iwp) :: cur_pos!< current position2874 INTEGER(iwp) :: id!< mesh ID of item2875 2876 REAL(wp) :: priority!< item priority2877 2878 TYPE(heap_item) :: item!< heap item2879 2880 2881 2753 !--------------------------------------------------------------------------------------------------! 2754 SUBROUTINE mas_heap_insert_item( id, priority ) 2755 2756 IMPLICIT NONE 2757 2758 INTEGER(iwp) :: cur_pos !< current position 2759 INTEGER(iwp) :: id !< mesh ID of item 2760 2761 REAL(wp) :: priority !< item priority 2762 2763 TYPE(heap_item) :: item !< heap item 2764 2765 item%mesh_id = id 2766 item%priority = priority 2882 2767 ! 2883 2768 !-- Extend heap, if necessary 2884 IF ( heap_count + 1 > SIZE(queue) ) THEN 2885 CALL mas_heap_extend 2769 IF ( heap_count + 1 > SIZE( queue ) ) THEN 2770 CALL mas_heap_extend 2771 ENDIF 2772 ! 2773 !-- Insert item at first unoccupied postion (highest index) of heap 2774 cur_pos = heap_count 2775 queue(cur_pos) = item 2776 ! 2777 !-- Sort while inserted item is not at top of heap 2778 DO WHILE ( cur_pos /= 0 ) 2779 ! 2780 !-- If priority < its parent's priority, swap them. 2781 !-- Else, sorting is done. 2782 IF ( queue(cur_pos)%priority < queue(FLOOR( (cur_pos) / 2.0_wp ))%priority ) THEN 2783 item = queue(cur_pos) 2784 queue(cur_pos) = queue(FLOOR( ( cur_pos ) / 2.0_wp )) 2785 queue(FLOOR( ( cur_pos ) / 2.0_wp )) = item 2786 cur_pos = FLOOR( ( cur_pos ) / 2.0_wp ) 2787 ELSE 2788 EXIT 2886 2789 ENDIF 2887 ! 2888 !-- Insert item at first unoccupied postion (highest index) of heap 2889 cur_pos = heap_count 2890 queue(cur_pos) = item 2891 ! 2892 !-- Sort while inserted item is not at top of heap 2893 DO WHILE ( cur_pos /= 0 ) 2894 ! 2895 !-- If priority < its parent's priority, swap them. 2896 !-- Else, sorting is done. 2897 IF ( queue(cur_pos)%priority & 2898 < queue(FLOOR((cur_pos)/2.))%priority ) & 2899 THEN 2900 item = queue(cur_pos) 2901 queue(cur_pos) = queue(FLOOR((cur_pos)/2.)) 2902 queue(FLOOR((cur_pos)/2.)) = item 2903 cur_pos = FLOOR((cur_pos)/2.) 2790 ENDDO 2791 ! 2792 !-- Item was added to heap, so the heap count increases 2793 heap_count = heap_count + 1 2794 2795 END SUBROUTINE mas_heap_insert_item 2796 2797 !--------------------------------------------------------------------------------------------------! 2798 ! Description: 2799 ! ------------ 2800 !> Extends the size of the priority queue (binary heap) 2801 !--------------------------------------------------------------------------------------------------! 2802 SUBROUTINE mas_heap_extend 2803 2804 IMPLICIT NONE 2805 2806 INTEGER(iwp) :: soh !< size of heap 2807 2808 TYPE(heap_item), DIMENSION(:), ALLOCATABLE :: dummy_heap !< dummy heap 2809 2810 soh = SIZE( queue ) - 1 2811 ALLOCATE( dummy_heap(0:soh) ) 2812 dummy_heap = queue 2813 DEALLOCATE( queue ) 2814 ALLOCATE( queue(0:2*soh+1) ) 2815 queue(0:soh) = dummy_heap(0:soh) 2816 2817 END SUBROUTINE mas_heap_extend 2818 2819 !--------------------------------------------------------------------------------------------------! 2820 ! Description: 2821 ! ------------ 2822 !> Removes first (smallest) element from the priority queue, reorders the rest and returns the ID of 2823 !> the removed mesh point 2824 !--------------------------------------------------------------------------------------------------! 2825 SUBROUTINE mas_heap_extract_item ( id ) 2826 2827 IMPLICIT NONE 2828 2829 INTEGER(iwp) :: child !< child of item in heap 2830 INTEGER(iwp) :: cur_pos !< current position of item in heap 2831 INTEGER(iwp) :: id !< ID of item extracted item 2832 2833 TYPE(heap_item) :: dummy 2834 ! 2835 !-- Get ID of mesh point with lowest priority (extracted item: top of heap) 2836 id = queue(0)%mesh_id 2837 ! 2838 !-- Put last item in heap at first position 2839 queue(0) = queue(heap_count-1) 2840 cur_pos = 0 2841 DO 2842 ! 2843 !-- If current item has no children, sorting is done 2844 IF( 2*cur_pos+1 > heap_count - 1 ) THEN 2845 EXIT 2846 ! 2847 !-- If current item has only one child, check if item and its child are ordered correctly. Else, 2848 !-- swap them. 2849 ELSEIF ( 2*cur_pos+2 > heap_count - 1 ) THEN 2850 IF ( queue(cur_pos)%priority > queue(2*cur_pos+1)%priority ) THEN 2851 dummy = queue(cur_pos) 2852 queue(cur_pos) = queue(2*cur_pos+1) 2853 queue(2*cur_pos+1) = dummy 2854 cur_pos = 2*cur_pos+1 2904 2855 ELSE 2905 2856 EXIT 2906 2857 ENDIF 2907 ENDDO 2908 ! 2909 !-- Item was added to heap, so the heap count increases 2910 heap_count = heap_count + 1 2911 2912 END SUBROUTINE mas_heap_insert_item 2913 2914 !------------------------------------------------------------------------------! 2915 ! Description: 2916 ! ------------ 2917 !> Extends the size of the priority queue (binary heap) 2918 !------------------------------------------------------------------------------! 2919 SUBROUTINE mas_heap_extend 2920 2921 IMPLICIT NONE 2922 2923 INTEGER(iwp) :: soh !< size of heap 2924 2925 TYPE(heap_item), DIMENSION(:), ALLOCATABLE :: dummy_heap !< dummy heap 2926 2927 soh = SIZE(queue)-1 2928 ALLOCATE(dummy_heap(0:soh)) 2929 dummy_heap = queue 2930 DEALLOCATE(queue) 2931 ALLOCATE(queue(0:2*soh+1)) 2932 queue(0:soh) = dummy_heap(0:soh) 2933 2934 END SUBROUTINE mas_heap_extend 2935 2936 !------------------------------------------------------------------------------! 2937 ! Description: 2938 ! ------------ 2939 !> Removes first (smallest) element from the priority queue, reorders the rest 2940 !> and returns the ID of the removed mesh point 2941 !------------------------------------------------------------------------------! 2942 SUBROUTINE mas_heap_extract_item ( id ) 2943 2944 IMPLICIT NONE 2945 2946 INTEGER(iwp) :: id !< ID of item extracted item 2947 INTEGER(iwp) :: child !< child of item in heap 2948 INTEGER(iwp) :: cur_pos !< current position of item in heap 2949 2950 TYPE(heap_item) :: dummy 2951 ! 2952 !-- Get ID of mesh point with lowest priority (extracted item: top of heap) 2953 id = queue(0)%mesh_id 2954 ! 2955 !-- Put last item in heap at first position 2956 queue(0) = queue(heap_count-1) 2957 cur_pos = 0 2958 DO 2959 ! 2960 !-- If current item has no children, sorting is done 2961 IF( 2*cur_pos+1 > heap_count - 1 ) THEN 2858 ELSE 2859 ! 2860 !-- Determine the smaller child 2861 IF ( queue(2*cur_pos+1)%priority >= queue(2*cur_pos+2)%priority ) THEN 2862 child = 2 2863 ELSE 2864 child = 1 2865 ENDIF 2866 ! 2867 !-- Check if item and its smaller child are ordered falsely. If so, swap them. Else, sorting 2868 !-- is done. 2869 IF ( queue(cur_pos)%priority > queue(2*cur_pos+child )%priority ) THEN 2870 dummy = queue(cur_pos) 2871 queue(cur_pos) = queue(2*cur_pos+child) 2872 queue(2*cur_pos+child) = dummy 2873 cur_pos = 2*cur_pos+child 2874 ELSE 2962 2875 EXIT 2963 !2964 !-- If current item has only one child, check if item and its child are2965 !-- ordered correctly. Else, swap them.2966 ELSEIF ( 2*cur_pos+2 > heap_count - 1 ) THEN2967 IF ( queue(cur_pos)%priority > queue(2*cur_pos+1)%priority ) THEN2968 dummy = queue(cur_pos)2969 queue(cur_pos) = queue(2*cur_pos+1)2970 queue(2*cur_pos+1) = dummy2971 cur_pos = 2*cur_pos+12972 ELSE2973 EXIT2974 ENDIF2975 ELSE2976 !2977 !-- determine the smaller child2978 IF ( queue(2*cur_pos+1)%priority &2979 >= queue(2*cur_pos+2)%priority ) &2980 THEN2981 child = 22982 ELSE2983 child = 12984 ENDIF2985 !2986 !-- Check if item and its smaller child are ordered falsely. If so,2987 !-- swap them. Else, sorting is done.2988 IF ( queue(cur_pos)%priority > queue(2*cur_pos+child )%priority ) &2989 THEN2990 dummy = queue(cur_pos)2991 queue(cur_pos) = queue(2*cur_pos+child)2992 queue(2*cur_pos+child) = dummy2993 cur_pos = 2*cur_pos+child2994 ELSE2995 EXIT2996 ENDIF2997 2876 ENDIF 2998 ENDDO 2999 ! 3000 !-- Top item was removed from heap, thus, heap_cout decreases by one 3001 heap_count = heap_count-1 3002 3003 END SUBROUTINE mas_heap_extract_item 3004 3005 !------------------------------------------------------------------------------! 2877 ENDIF 2878 ENDDO 2879 ! 2880 !-- Top item was removed from heap, thus, heap_cout decreases by one 2881 heap_count = heap_count-1 2882 2883 END SUBROUTINE mas_heap_extract_item 2884 2885 !--------------------------------------------------------------------------------------------------! 3006 2886 ! Description: 3007 2887 ! ------------ 3008 2888 !> Initialization of Multi Agent System 3009 !------------------------------------------------------------------------------! 3010 SUBROUTINE mas_init 3011 3012 USE control_parameters, & 3013 ONLY: coupling_char, initializing_actions, io_blocks, io_group 3014 3015 USE arrays_3d, & 3016 ONLY: zu, zw 3017 3018 USE indices, & 3019 ONLY: nzt 3020 3021 IMPLICIT NONE 3022 3023 INTEGER(iwp) :: i !< grid cell (x) 3024 INTEGER(iwp) :: ii !< io-block counter 3025 INTEGER(iwp) :: il !< io-block counter 3026 INTEGER(iwp) :: jl !< io-block counter 3027 INTEGER(iwp) :: kl !< io-block counter 3028 INTEGER(iwp) :: kdum !< io-block counter 3029 INTEGER(iwp) :: locdum !< io-block counter 3030 INTEGER(iwp) :: j !< grid cell (y) 3031 INTEGER(iwp) :: size_of_mesh !< temporary value for read 3032 INTEGER(iwp) :: size_of_pols !< temporary value for read 3033 INTEGER(iwp) :: ioerr !< IOSTAT flag for IO-commands ( 0 = no error ) 3034 3035 LOGICAL :: navigation_data_present !< Flag: check for input file 3036 3037 REAL(wp) :: zdum !< dummy for measurement height 3038 REAL(wp) :: avg_agt_height = 1.8_wp 3039 3040 3041 ! 3042 !-- Check the number of agent groups. 3043 IF ( number_of_agent_groups > max_number_of_agent_groups ) THEN 3044 WRITE( message_string, * ) 'max_number_of_agent_groups =', & 3045 max_number_of_agent_groups , & 3046 '&number_of_agent_groups reset to ', & 3047 max_number_of_agent_groups 3048 CALL message( 'mas_init', 'PA0072', 0, 1, 0, 6, 0 ) 3049 number_of_agent_groups = max_number_of_agent_groups 3050 ENDIF 3051 3052 ! 3053 !-- Set some parameters 3054 d_sigma_rep_agent = 1.0_wp/sigma_rep_agent 3055 d_sigma_rep_wall = 1.0_wp/sigma_rep_wall 3056 d_tau_accel_agent = 1.0_wp/tau_accel_agent 3057 IF ( dt_agent /= 999.0_wp ) THEN 3058 agent_own_timestep = .TRUE. 3059 ENDIF 3060 3061 ! 3062 !-- Get index of first grid box above topography 3063 ALLOCATE( top_top_s(nysg:nyng,nxlg:nxrg), & 3064 top_top_w(nysg:nyng,nxlg:nxrg), & 3065 s_measure_height(nys:nyn,nxl:nxr) ) 3066 ! 3067 !-- Get first index above topography for scalar grid and last index in 3068 !-- topography for z-component of wind 3069 DO il = nxlg, nxrg 3070 DO jl = nysg, nyng 3071 top_top_s(jl,il) = topo_top_ind(jl,il,0) + 1 3072 top_top_w(jl,il) = topo_top_ind(jl,il,3) 2889 !--------------------------------------------------------------------------------------------------! 2890 SUBROUTINE mas_init 2891 2892 USE control_parameters, & 2893 ONLY: coupling_char, initializing_actions, io_blocks, io_group 2894 2895 USE arrays_3d, & 2896 ONLY: zu, zw 2897 2898 USE indices, & 2899 ONLY: nzt 2900 2901 IMPLICIT NONE 2902 2903 INTEGER(iwp) :: i !< grid cell (x) 2904 INTEGER(iwp) :: ii !< io-block counter 2905 INTEGER(iwp) :: il !< io-block counter 2906 INTEGER(iwp) :: ioerr !< IOSTAT flag for IO-commands ( 0 = no error ) 2907 INTEGER(iwp) :: j !< grid cell (y) 2908 INTEGER(iwp) :: jl !< io-block counter 2909 INTEGER(iwp) :: kl !< io-block counter 2910 INTEGER(iwp) :: kdum !< io-block counter 2911 INTEGER(iwp) :: locdum !< io-block counter 2912 INTEGER(iwp) :: size_of_mesh !< temporary value for read 2913 INTEGER(iwp) :: size_of_pols !< temporary value for read 2914 2915 LOGICAL :: navigation_data_present !< Flag: check for input file 2916 2917 REAL(wp) :: zdum !< dummy for measurement height 2918 REAL(wp) :: avg_agt_height = 1.8_wp 2919 2920 2921 ! 2922 !-- Check the number of agent groups. 2923 IF ( number_of_agent_groups > max_number_of_agent_groups ) THEN 2924 WRITE( message_string, * ) 'max_number_of_agent_groups =', max_number_of_agent_groups , & 2925 '&number_of_agent_groups reset to ', max_number_of_agent_groups 2926 CALL message( 'mas_init', 'PA0072', 0, 1, 0, 6, 0 ) 2927 number_of_agent_groups = max_number_of_agent_groups 2928 ENDIF 2929 2930 ! 2931 !-- Set some parameters 2932 d_sigma_rep_agent = 1.0_wp/sigma_rep_agent 2933 d_sigma_rep_wall = 1.0_wp/sigma_rep_wall 2934 d_tau_accel_agent = 1.0_wp/tau_accel_agent 2935 IF ( dt_agent /= 999.0_wp ) THEN 2936 agent_own_timestep = .TRUE. 2937 ENDIF 2938 2939 ! 2940 !-- Get index of first grid box above topography 2941 ALLOCATE( top_top_s(nysg:nyng,nxlg:nxrg), & 2942 top_top_w(nysg:nyng,nxlg:nxrg), & 2943 s_measure_height(nys:nyn,nxl:nxr) ) 2944 ! 2945 !-- Get first index above topography for scalar grid and last index in topography for z-component of 2946 !-- wind. 2947 DO il = nxlg, nxrg 2948 DO jl = nysg, nyng 2949 top_top_s(jl,il) = topo_top_ind(jl,il,0) + 1 2950 top_top_w(jl,il) = topo_top_ind(jl,il,3) 2951 ENDDO 2952 ENDDO 2953 ! 2954 !-- Create 2D array containing the index at which measurements are done by agents. The height of 2955 !-- this measurement is given by avg_agt_height. 2956 DO il = nxl, nxr 2957 DO jl = nys, nyn 2958 2959 kdum = top_top_w(jl,il) 2960 zdum = zw(kdum) 2961 zdum = zdum + avg_agt_height 2962 locdum = 0 2963 ! 2964 !-- Locate minimum distance from u-grid to measurement height (zdum) 2965 DO kl = 1, nzt 2966 IF ( ABS(zu(kl)-zdum) < ABS(zu(locdum)-zdum) ) locdum = kl 3073 2967 ENDDO 2968 s_measure_height(jl,il) = locdum 2969 3074 2970 ENDDO 3075 ! 3076 !-- Create 2D array containing the index at which measurements are done by 3077 !-- agents. The height of this measurement is given by avg_agt_height. 3078 DO il = nxl, nxr 3079 DO jl = nys, nyn 3080 3081 kdum = top_top_w(jl,il) 3082 zdum = zw(kdum) 3083 zdum = zdum + avg_agt_height 3084 locdum = 0 3085 ! 3086 !-- Locate minimum distance from u-grid to measurement height (zdum) 3087 DO kl = 1, nzt 3088 IF ( ABS(zu(kl)-zdum) < ABS(zu(locdum)-zdum) ) locdum = kl 2971 ENDDO 2972 2973 CALL mas_create_obstacle_flags 2974 2975 ! 2976 !-- Set default start positions, if necessary 2977 IF ( asl(1) == 9999999.9_wp ) asl(1) = 0.0_wp 2978 IF ( asr(1) == 9999999.9_wp ) asr(1) = ( nx + 1 ) * dx 2979 IF ( ass(1) == 9999999.9_wp ) ass(1) = 0.0_wp 2980 IF ( asn(1) == 9999999.9_wp ) asn(1) = ( ny + 1 ) * dy 2981 IF ( adx(1) == 9999999.9_wp .OR. adx(1) == 0.0_wp ) adx(1) = dx 2982 IF ( ady(1) == 9999999.9_wp .OR. ady(1) == 0.0_wp ) ady(1) = dy 2983 2984 DO j = 2, number_of_agent_groups 2985 IF ( asl(j) == 9999999.9_wp ) asl(j) = asl(j-1) 2986 IF ( asr(j) == 9999999.9_wp ) asr(j) = asr(j-1) 2987 IF ( ass(j) == 9999999.9_wp ) ass(j) = ass(j-1) 2988 IF ( asn(j) == 9999999.9_wp ) asn(j) = asn(j-1) 2989 IF ( adx(j) == 9999999.9_wp .OR. adx(j) == 0.0_wp ) adx(j) = adx(j-1) 2990 IF ( ady(j) == 9999999.9_wp .OR. ady(j) == 0.0_wp ) ady(j) = ady(j-1) 2991 ENDDO 2992 2993 ! 2994 !-- Check boundary condition and set internal variables 2995 SELECT CASE ( bc_mas_lr ) 2996 2997 CASE ( 'cyclic' ) 2998 ibc_mas_lr = 0 2999 3000 CASE ( 'absorb' ) 3001 ibc_mas_lr = 1 3002 3003 CASE DEFAULT 3004 WRITE( message_string, * ) 'unknown boundary condition ', & 3005 'bc_mas_lr = "', TRIM( bc_mas_lr ), '"' 3006 CALL message( 'mas_init', 'PA0073', 1, 2, 0, 6, 0 ) 3007 3008 END SELECT 3009 SELECT CASE ( bc_mas_ns ) 3010 3011 CASE ( 'cyclic' ) 3012 ibc_mas_ns = 0 3013 3014 CASE ( 'absorb' ) 3015 ibc_mas_ns = 1 3016 3017 CASE DEFAULT 3018 WRITE( message_string, * ) 'unknown boundary condition ', & 3019 'bc_mas_ns = "', TRIM( bc_mas_ns ), '"' 3020 CALL message( 'mas_init', 'PA0074', 1, 2, 0, 6, 0 ) 3021 3022 END SELECT 3023 3024 ! 3025 !-- For the first model run of a possible job chain initialize the agents, otherwise read the agent 3026 !-- data from restart file. 3027 IF ( TRIM( initializing_actions ) == 'read_restart_data' .AND. read_agents_from_restartfile )& 3028 THEN 3029 3030 ! CALL mas_read_restart_file 3031 3032 ELSE 3033 ! 3034 !-- Read preprocessed data of navigation mesh and building polygons for agent pathfinding 3035 DO ii = 0, io_blocks-1 3036 IF ( ii == io_group ) THEN 3037 ! 3038 !-- Check for naviation input file and open it 3039 INQUIRE( FILE='NAVIGATION_DATA' // TRIM( coupling_char ), & 3040 EXIST=navigation_data_present ) 3041 IF ( .NOT. navigation_data_present ) THEN 3042 message_string = 'Input file NAVIGATION_DATA' // & 3043 TRIM( coupling_char ) // ' for MAS missing. ' // & 3044 '&Please run agent_preprocessing before the job to create it.' 3045 CALL message( 'mas_init', 'PA0525', 1, 2, 0, 6, 0 ) 3046 ENDIF 3047 OPEN ( 119, FILE='NAVIGATION_DATA'//TRIM( coupling_char ), FORM='UNFORMATTED', & 3048 IOSTAT=ioerr ) 3049 ! 3050 !-- Read mesh data 3051 READ( 119 ) size_of_mesh 3052 ALLOCATE( mesh(1:size_of_mesh) ) 3053 DO i = 1, size_of_mesh 3054 READ( 119 ) mesh(i)%polygon_id, mesh(i)%vertex_id, & 3055 mesh(i)%noc, mesh(i)%origin_id, & 3056 mesh(i)%cost_so_far, mesh(i)%x, & 3057 mesh(i)%y, mesh(i)%x_s, mesh(i)%y_s 3058 ALLOCATE( mesh(i)%connected_vertices(1:mesh(i)%noc), & 3059 mesh(i)%distance_to_vertex(1:mesh(i)%noc) ) 3060 DO j = 1, mesh(i)%noc 3061 READ( 119 ) mesh(i)%connected_vertices(j), & 3062 mesh(i)%distance_to_vertex(j) 3063 ENDDO 3089 3064 ENDDO 3090 s_measure_height(jl,il) = locdum 3091 3092 ENDDO 3065 ! 3066 !-- Read polygon data 3067 READ( 119 ) size_of_pols 3068 ALLOCATE( polygons(1:size_of_pols) ) 3069 DO i = 1, size_of_pols 3070 READ( 119 ) polygons(i)%nov 3071 ALLOCATE( polygons(i)%vertices(0:polygons(i)%nov+1) ) 3072 DO j = 0, polygons(i)%nov+1 3073 READ( 119 ) polygons(i)%vertices(j)%delete, & 3074 polygons(i)%vertices(j)%x, & 3075 polygons(i)%vertices(j)%y 3076 ENDDO 3077 ENDDO 3078 CLOSE(119) 3079 3080 ENDIF 3081 #if defined( __parallel ) && ! defined ( __check ) 3082 CALL MPI_BARRIER( comm2d, ierr ) 3083 #endif 3093 3084 ENDDO 3094 3085 3095 CALL mas_create_obstacle_flags 3096 3097 ! 3098 !-- Set default start positions, if necessary 3099 IF ( asl(1) == 9999999.9_wp ) asl(1) = 0.0_wp 3100 IF ( asr(1) == 9999999.9_wp ) asr(1) = ( nx + 1 ) * dx 3101 IF ( ass(1) == 9999999.9_wp ) ass(1) = 0.0_wp 3102 IF ( asn(1) == 9999999.9_wp ) asn(1) = ( ny + 1 ) * dy 3103 IF ( adx(1) == 9999999.9_wp .OR. adx(1) == 0.0_wp ) adx(1) = dx 3104 IF ( ady(1) == 9999999.9_wp .OR. ady(1) == 0.0_wp ) ady(1) = dy 3105 3106 DO j = 2, number_of_agent_groups 3107 IF ( asl(j) == 9999999.9_wp ) asl(j) = asl(j-1) 3108 IF ( asr(j) == 9999999.9_wp ) asr(j) = asr(j-1) 3109 IF ( ass(j) == 9999999.9_wp ) ass(j) = ass(j-1) 3110 IF ( asn(j) == 9999999.9_wp ) asn(j) = asn(j-1) 3111 IF ( adx(j) == 9999999.9_wp .OR. adx(j) == 0.0_wp ) adx(j) = adx(j-1) 3112 IF ( ady(j) == 9999999.9_wp .OR. ady(j) == 0.0_wp ) ady(j) = ady(j-1) 3113 ENDDO 3114 3115 ! 3116 !-- Check boundary condition and set internal variables 3117 SELECT CASE ( bc_mas_lr ) 3118 3119 CASE ( 'cyclic' ) 3120 ibc_mas_lr = 0 3121 3122 CASE ( 'absorb' ) 3123 ibc_mas_lr = 1 3124 3125 CASE DEFAULT 3126 WRITE( message_string, * ) 'unknown boundary condition ', & 3127 'bc_mas_lr = "', TRIM( bc_mas_lr ), '"' 3128 CALL message( 'mas_init', 'PA0073', 1, 2, 0, 6, 0 ) 3129 3130 END SELECT 3131 SELECT CASE ( bc_mas_ns ) 3132 3133 CASE ( 'cyclic' ) 3134 ibc_mas_ns = 0 3135 3136 CASE ( 'absorb' ) 3137 ibc_mas_ns = 1 3138 3139 CASE DEFAULT 3140 WRITE( message_string, * ) 'unknown boundary condition ', & 3141 'bc_mas_ns = "', TRIM( bc_mas_ns ), '"' 3142 CALL message( 'mas_init', 'PA0074', 1, 2, 0, 6, 0 ) 3143 3144 END SELECT 3145 3146 ! 3147 !-- For the first model run of a possible job chain initialize the 3148 !-- agents, otherwise read the agent data from restart file. 3149 IF ( TRIM( initializing_actions ) == 'read_restart_data' & 3150 .AND. read_agents_from_restartfile ) THEN 3151 3152 ! CALL mas_read_restart_file 3153 3154 ELSE 3155 ! 3156 !-- Read preprocessed data of navigation mesh and building polygons 3157 !-- for agent pathfinding 3158 DO ii = 0, io_blocks-1 3159 IF ( ii == io_group ) THEN 3160 ! 3161 !-- Check for naviation input file and open it 3162 INQUIRE( FILE='NAVIGATION_DATA' // TRIM( coupling_char ), EXIST=navigation_data_present ) 3163 IF ( .NOT. navigation_data_present ) THEN 3164 message_string = 'Input file NAVIGATION_DATA' // & 3165 TRIM( coupling_char ) // ' for MAS missing. ' // & 3166 '&Please run agent_preprocessing before the job to create it.' 3167 CALL message( 'mas_init', 'PA0525', 1, 2, 0, 6, 0 ) 3168 ENDIF 3169 OPEN ( 119, FILE='NAVIGATION_DATA'//TRIM( coupling_char ), & 3170 FORM='UNFORMATTED', IOSTAT=ioerr ) 3171 ! 3172 !-- Read mesh data 3173 READ(119) size_of_mesh 3174 ALLOCATE( mesh(1:size_of_mesh)) 3175 DO i = 1, size_of_mesh 3176 READ(119) mesh(i)%polygon_id, mesh(i)%vertex_id, & 3177 mesh(i)%noc, mesh(i)%origin_id, & 3178 mesh(i)%cost_so_far, mesh(i)%x, & 3179 mesh(i)%y, mesh(i)%x_s, mesh(i)%y_s 3180 ALLOCATE( mesh(i)%connected_vertices(1:mesh(i)%noc), & 3181 mesh(i)%distance_to_vertex(1:mesh(i)%noc) ) 3182 DO j = 1, mesh(i)%noc 3183 READ(119) mesh(i)%connected_vertices(j), & 3184 mesh(i)%distance_to_vertex(j) 3185 ENDDO 3186 ENDDO 3187 ! 3188 !-- Read polygon data 3189 READ(119) size_of_pols 3190 ALLOCATE( polygons(1:size_of_pols) ) 3191 DO i = 1, size_of_pols 3192 READ(119) polygons(i)%nov 3193 ALLOCATE( polygons(i)%vertices(0:polygons(i)%nov+1) ) 3194 DO j = 0, polygons(i)%nov+1 3195 READ(119) polygons(i)%vertices(j)%delete, & 3196 polygons(i)%vertices(j)%x, & 3197 polygons(i)%vertices(j)%y 3198 ENDDO 3199 ENDDO 3200 CLOSE(119) 3201 3202 ENDIF 3203 #if defined( __parallel ) && ! defined ( __check ) 3204 CALL MPI_BARRIER( comm2d, ierr ) 3205 #endif 3206 ENDDO 3207 3208 ! 3209 !-- Allocate agent arrays and set attributes of the initial set of 3210 !-- agents, which can be also periodically released at later times. 3211 ALLOCATE( agt_count (nysg:nyng,nxlg:nxrg), & 3212 grid_agents(nysg:nyng,nxlg:nxrg) ) 3213 ! 3214 !-- Allocate dummy arrays for pathfinding 3215 ALLOCATE( dummy_path_x(0:agt_path_size), & 3216 dummy_path_y(0:agt_path_size) ) 3217 3218 number_of_agents = 0 3219 sort_count_mas = 0 3220 agt_count = 0 3221 3222 ! 3223 !-- initialize counter for agent IDs 3224 grid_agents%id_counter = 1 3225 3226 ! 3227 !-- Initialize all agents with dummy values (otherwise errors may 3228 !-- occur within restart runs). The reason for this is still not clear 3229 !-- and may be presumably caused by errors in the respective user-interface. 3230 zero_agent%agent_mask = .FALSE. 3231 zero_agent%block_nr = -1 3232 zero_agent%group = 0 3233 zero_agent%id = 0_idp 3234 zero_agent%path_counter = agt_path_size 3235 zero_agent%age = 0.0_wp 3236 zero_agent%age_m = 0.0_wp 3237 zero_agent%dt_sum = 0.0_wp 3238 zero_agent%clo = 0.0_wp 3239 zero_agent%energy_storage= 0.0_wp 3240 zero_agent%force_x = 0.0_wp 3241 zero_agent%force_y = 0.0_wp 3242 zero_agent%origin_x = 0.0_wp 3243 zero_agent%origin_y = 0.0_wp 3244 zero_agent%speed_abs = 0.0_wp 3245 zero_agent%speed_e_x = 0.0_wp 3246 zero_agent%speed_e_y = 0.0_wp 3247 zero_agent%speed_des = random_normal(desired_speed, des_sp_sig) 3248 zero_agent%speed_x = 0.0_wp 3249 zero_agent%speed_y = 0.0_wp 3250 zero_agent%ipt = 0.0_wp 3251 zero_agent%x = 0.0_wp 3252 zero_agent%y = 0.0_wp 3253 zero_agent%path_x = 0.0_wp 3254 zero_agent%path_y = 0.0_wp 3255 zero_agent%t_x = 0.0_wp 3256 zero_agent%t_y = 0.0_wp 3257 3258 ! 3259 !-- Set a seed value for the random number generator to be exclusively 3260 !-- used for the agent code. The generated random numbers should be 3261 !-- different on the different PEs. 3262 iran_agent = iran_agent + myid 3263 3264 CALL mas_create_agent (PHASE_INIT) 3265 3266 ENDIF 3267 3268 ! 3269 !-- To avoid programm abort, assign agents array to the local version of 3270 !-- first grid cell 3271 number_of_agents = agt_count(nys,nxl) 3272 agents => grid_agents(nys,nxl)%agents(1:number_of_agents) 3273 3274 END SUBROUTINE mas_init 3275 3276 !------------------------------------------------------------------------------! 3086 ! 3087 !-- Allocate agent arrays and set attributes of the initial set of agents, which can be also 3088 !-- periodically released at later times. 3089 ALLOCATE( agt_count (nysg:nyng,nxlg:nxrg), & 3090 grid_agents(nysg:nyng,nxlg:nxrg) ) 3091 ! 3092 !-- Allocate dummy arrays for pathfinding 3093 ALLOCATE( dummy_path_x(0:agt_path_size), & 3094 dummy_path_y(0:agt_path_size) ) 3095 3096 number_of_agents = 0 3097 sort_count_mas = 0 3098 agt_count = 0 3099 3100 ! 3101 !-- Initialize counter for agent IDs 3102 grid_agents%id_counter = 1 3103 3104 ! 3105 !-- Initialize all agents with dummy values (otherwise errors may occur within restart runs). 3106 !-- The reason for this is still not clear and may be presumably caused by errors in the 3107 !-- respective user-interface. 3108 zero_agent%agent_mask = .FALSE. 3109 zero_agent%block_nr = -1 3110 zero_agent%group = 0 3111 zero_agent%id = 0_idp 3112 zero_agent%path_counter = agt_path_size 3113 zero_agent%age = 0.0_wp 3114 zero_agent%age_m = 0.0_wp 3115 zero_agent%dt_sum = 0.0_wp 3116 zero_agent%clo = 0.0_wp 3117 zero_agent%energy_storage= 0.0_wp 3118 zero_agent%force_x = 0.0_wp 3119 zero_agent%force_y = 0.0_wp 3120 zero_agent%origin_x = 0.0_wp 3121 zero_agent%origin_y = 0.0_wp 3122 zero_agent%speed_abs = 0.0_wp 3123 zero_agent%speed_e_x = 0.0_wp 3124 zero_agent%speed_e_y = 0.0_wp 3125 zero_agent%speed_des = random_normal(desired_speed, des_sp_sig) 3126 zero_agent%speed_x = 0.0_wp 3127 zero_agent%speed_y = 0.0_wp 3128 zero_agent%ipt = 0.0_wp 3129 zero_agent%x = 0.0_wp 3130 zero_agent%y = 0.0_wp 3131 zero_agent%path_x = 0.0_wp 3132 zero_agent%path_y = 0.0_wp 3133 zero_agent%t_x = 0.0_wp 3134 zero_agent%t_y = 0.0_wp 3135 3136 ! 3137 !-- Set a seed value for the random number generator to be exclusively used for the agent code. 3138 !-- The generated random numbers should be different on the different PEs. 3139 iran_agent = iran_agent + myid 3140 3141 CALL mas_create_agent( phase_init ) 3142 3143 ENDIF 3144 3145 ! 3146 !-- To avoid programm abort, assign agents array to the local version of first grid cell. 3147 number_of_agents = agt_count(nys,nxl) 3148 agents => grid_agents(nys,nxl)%agents(1:number_of_agents) 3149 3150 END SUBROUTINE mas_init 3151 3152 !--------------------------------------------------------------------------------------------------! 3277 3153 ! Description: 3278 3154 ! ------------ 3279 3155 !> Output of informative message about maximum agent number 3280 !------------------------------------------------------------------------------! 3281 SUBROUTINE mas_last_actions 3282 3283 USE control_parameters, & 3284 ONLY: message_string 3285 3286 IMPLICIT NONE 3287 3288 WRITE(message_string,'(A,I8,A)') & 3289 'The maximumn number of agents during this run was', & 3290 maximum_number_of_agents, & 3291 '&Consider adjusting the INPUT parameter'// & 3292 '&dim_size_agtnum_manual accordingly for the next run.' 3293 3294 CALL message( 'mas_data_output_agents', 'PA0457', 0, 0, 0, 6, 0 ) 3295 3296 END SUBROUTINE mas_last_actions 3297 3298 !------------------------------------------------------------------------------! 3156 !--------------------------------------------------------------------------------------------------! 3157 SUBROUTINE mas_last_actions 3158 3159 USE control_parameters, & 3160 ONLY: message_string 3161 3162 IMPLICIT NONE 3163 3164 WRITE(message_string,'(A,I8,A)') 'The maximumn number of agents during this run was', & 3165 maximum_number_of_agents, & 3166 '&Consider adjusting the INPUT parameter'// & 3167 '&dim_size_agtnum_manual accordingly for the next run.' 3168 3169 CALL message( 'mas_data_output_agents', 'PA0457', 0, 0, 0, 6, 0 ) 3170 3171 END SUBROUTINE mas_last_actions 3172 3173 !--------------------------------------------------------------------------------------------------! 3299 3174 ! Description: 3300 3175 ! ------------ 3301 !> Finds the shortest path from a start position to a target position using the 3302 !> A*-algorithm 3303 !------------------------------------------------------------------------------! 3304 SUBROUTINE mas_nav_a_star( start_x, start_y, target_x, target_y, nsteps ) 3305 3306 IMPLICIT NONE 3307 3308 LOGICAL :: target_reached !< flag 3309 3310 INTEGER(iwp) :: cur_node !< current node of binary heap 3311 INTEGER(iwp) :: il !< counter (x) 3312 INTEGER(iwp) :: neigh_node !< neighbor node 3313 INTEGER(iwp) :: node_counter !< binary heap node counter 3314 INTEGER(iwp) :: path_ag !< index of agent path 3315 INTEGER(iwp) :: som !< size of mesh 3316 INTEGER(iwp) :: steps !< steps along the path 3317 INTEGER(iwp) :: nsteps !< number of steps 3318 3319 REAL(wp) :: start_x !< x-coordinate agent 3320 REAL(wp) :: start_y !< y-coordinate agent 3321 REAL(wp) :: new_cost !< updated cost to reach node 3322 REAL(wp) :: new_priority !< priority of node to be added to queue 3323 REAL(wp) :: rn_gate !< random number for corner gate 3324 REAL(wp) :: target_x !< x-coordinate target 3325 REAL(wp) :: target_y !< y-coordinate target 3326 ! 3327 !-- Coordinate Type 3328 TYPE coord 3329 REAL(wp) :: x !< x-coordinate 3330 REAL(wp) :: x_s !< x-coordinate (shifted) 3331 REAL(wp) :: y !< y-coordinate 3332 REAL(wp) :: y_s !< y-coordinate (shifted) 3333 END TYPE coord 3334 3335 TYPE(coord), DIMENSION(:), ALLOCATABLE, TARGET :: path !< path array 3336 TYPE(coord), DIMENSION(:), ALLOCATABLE, TARGET :: tmp_path !< temporary path for resizing 3337 3338 node_counter = 0 3339 ! 3340 !-- Create temporary navigation mesh including agent and target positions 3341 CALL mas_nav_create_tmp_mesh( start_x, start_y, target_x, target_y, som ) 3342 tmp_mesh(som)%cost_so_far = 0.0_wp 3343 ! 3344 !-- Initialize priority queue 3345 heap_count = 0_iwp 3346 ALLOCATE(queue(0:100)) 3347 target_reached = .FALSE. 3348 ! 3349 !-- Add starting point (agent position) to frontier (the frontier consists 3350 !-- of all the nodes that are to be visited. The node with the smallest 3351 !-- priority will be visited first. The priority consists of the distance 3352 !-- from the start node to this node plus a minimal guess (direct distance) 3353 !-- from this node to the goal). For the starting node, the priority is set 3354 !-- to 0, as it's the only node thus far 3355 CALL mas_heap_insert_item(som,0.0_wp) 3356 cur_node = som 3357 DO WHILE ( heap_count > 0 ) 3358 ! 3359 !-- Step one: Pick lowest priority item from queue 3360 node_counter = node_counter + 1 3361 CALL mas_heap_extract_item(cur_node) 3362 ! 3363 !-- Node 0 is the goal node 3364 IF ( cur_node == 0 ) THEN 3365 EXIT 3176 !> Finds the shortest path from a start position to a target position using the A*-algorithm 3177 !--------------------------------------------------------------------------------------------------! 3178 SUBROUTINE mas_nav_a_star( start_x, start_y, target_x, target_y, nsteps ) 3179 3180 IMPLICIT NONE 3181 3182 INTEGER(iwp) :: cur_node !< current node of binary heap 3183 INTEGER(iwp) :: il !< counter (x) 3184 INTEGER(iwp) :: neigh_node !< neighbor node 3185 INTEGER(iwp) :: node_counter !< binary heap node counter 3186 INTEGER(iwp) :: nsteps !< number of steps 3187 INTEGER(iwp) :: path_ag !< index of agent path 3188 INTEGER(iwp) :: som !< size of mesh 3189 INTEGER(iwp) :: steps !< steps along the path 3190 3191 LOGICAL :: target_reached !< flag 3192 3193 REAL(wp) :: new_cost !< updated cost to reach node 3194 REAL(wp) :: new_priority !< priority of node to be added to queue 3195 REAL(wp) :: start_x !< x-coordinate agent 3196 REAL(wp) :: start_y !< y-coordinate agent 3197 REAL(wp) :: rn_gate !< random number for corner gate 3198 REAL(wp) :: target_x !< x-coordinate target 3199 REAL(wp) :: target_y !< y-coordinate target 3200 ! 3201 !-- Coordinate Type 3202 TYPE coord 3203 REAL(wp) :: x !< x-coordinate 3204 REAL(wp) :: x_s !< x-coordinate (shifted) 3205 REAL(wp) :: y !< y-coordinate 3206 REAL(wp) :: y_s !< y-coordinate (shifted) 3207 END TYPE coord 3208 3209 TYPE(coord), DIMENSION(:), ALLOCATABLE, TARGET :: path !< path array 3210 TYPE(coord), DIMENSION(:), ALLOCATABLE, TARGET :: tmp_path !< temporary path for resizing 3211 3212 node_counter = 0 3213 ! 3214 !-- Create temporary navigation mesh including agent and target positions 3215 CALL mas_nav_create_tmp_mesh( start_x, start_y, target_x, target_y, som ) 3216 tmp_mesh(som)%cost_so_far = 0.0_wp 3217 ! 3218 !-- Initialize priority queue 3219 heap_count = 0_iwp 3220 ALLOCATE( queue(0:100) ) 3221 target_reached = .FALSE. 3222 ! 3223 !-- Add starting point (agent position) to frontier (the frontier consists of all the nodes that 3224 !-- are to be visited. The node with the smallest priority will be visited first. The priority 3225 !-- consists of the distance from the start node to this node plus a minimal guess (direct 3226 !-- distance) from this node to the goal). For the starting node, the priority is set to 0, as it's 3227 !-- the only node thus far. 3228 CALL mas_heap_insert_item( som, 0.0_wp ) 3229 cur_node = som 3230 DO WHILE ( heap_count > 0 ) 3231 ! 3232 !-- Step one: Pick lowest priority item from queue 3233 node_counter = node_counter + 1 3234 CALL mas_heap_extract_item(cur_node) 3235 ! 3236 !-- Node 0 is the goal node 3237 IF ( cur_node == 0 ) THEN 3238 EXIT 3239 ENDIF 3240 ! 3241 !-- Loop over all of cur_node's neighbors 3242 DO il = 1, tmp_mesh(cur_node)%noc 3243 neigh_node = tmp_mesh(cur_node)%connected_vertices(il) 3244 ! 3245 !-- Check, if the way from the start node to this neigh_node via cur_node is shorter than the 3246 !-- previously found shortest path to it. 3247 !-- If so, replace said cost and add neigh_node to the frontier. 3248 !-- cost_so_far is initialized as 1.d12 so that all found distances should be smaller. 3249 new_cost = tmp_mesh(cur_node)%cost_so_far + tmp_mesh(cur_node)%distance_to_vertex(il) 3250 IF ( new_cost < tmp_mesh(neigh_node)%cost_so_far ) THEN 3251 tmp_mesh(neigh_node)%cost_so_far = new_cost 3252 tmp_mesh(neigh_node)%origin_id = cur_node 3253 ! 3254 !-- Priority in the queue is cost_so_far + heuristic to goal 3255 new_priority = new_cost & 3256 + heuristic(tmp_mesh(neigh_node)%x, & 3257 tmp_mesh(neigh_node)%y, tmp_mesh(0)%x, & 3258 tmp_mesh(0)%y) 3259 CALL mas_heap_insert_item(neigh_node,new_priority) 3366 3260 ENDIF 3367 !3368 !-- Loop over all of cur_node's neighbors3369 DO il = 1, tmp_mesh(cur_node)%noc3370 neigh_node = tmp_mesh(cur_node)%connected_vertices(il)3371 !3372 !-- Check, if the way from the start node to this neigh_node via3373 !-- cur_node is shorter than the previously found shortest path to it.3374 !-- If so, replace said cost and add neigh_node to the frontier.3375 !-- cost_so_far is initialized as 1.d12 so that all found distances3376 !-- should be smaller.3377 new_cost = tmp_mesh(cur_node)%cost_so_far &3378 + tmp_mesh(cur_node)%distance_to_vertex(il)3379 IF ( new_cost < tmp_mesh(neigh_node)%cost_so_far ) THEN3380 tmp_mesh(neigh_node)%cost_so_far = new_cost3381 tmp_mesh(neigh_node)%origin_id = cur_node3382 !3383 !-- Priority in the queue is cost_so_far + heuristic to goal3384 new_priority = new_cost &3385 + heuristic(tmp_mesh(neigh_node)%x, &3386 tmp_mesh(neigh_node)%y, tmp_mesh(0)%x, &3387 tmp_mesh(0)%y)3388 CALL mas_heap_insert_item(neigh_node,new_priority)3389 ENDIF3390 ENDDO3391 3261 ENDDO 3392 ! 3393 !-- Add nodes to a path array. To do this, we must backtrack from the target 3394 !-- node to its origin to its origin and so on until an node is reached that 3395 !-- has no origin (%origin_id == -1). This is the starting node. 3396 DEALLOCATE(queue) 3397 cur_node = 0 3398 steps = 0 3399 ALLOCATE(path(1:100)) 3400 DO WHILE ( cur_node /= -1 ) 3401 steps = steps + 1 3402 ! 3403 !-- Resize path array if necessary 3404 IF ( steps > SIZE(path) ) THEN 3405 ALLOCATE(tmp_path(1:steps-1)) 3406 tmp_path(1:steps-1) = path(1:steps-1) 3407 DEALLOCATE(path) 3408 ALLOCATE(path(1:2*(steps-1))) 3409 path(1:steps-1) = tmp_path(1:steps-1) 3410 DEALLOCATE(tmp_path) 3411 ENDIF 3412 path(steps)%x = tmp_mesh(cur_node)%x 3413 path(steps)%y = tmp_mesh(cur_node)%y 3414 path(steps)%x_s = tmp_mesh(cur_node)%x_s 3415 path(steps)%y_s = tmp_mesh(cur_node)%y_s 3416 cur_node = tmp_mesh(cur_node)%origin_id 3417 ENDDO 3418 ! 3419 !-- Add calculated intermittent targets to the path until either the 3420 !-- target or the maximum number of intermittent targets is reached. 3421 !-- Ignore starting point (reduce index by one), it is agent position. 3422 dummy_path_x = -1 3423 dummy_path_y = -1 3424 path_ag = 1 3262 ENDDO 3263 ! 3264 !-- Add nodes to a path array. To do this, we must backtrack from the target node to its origin and 3265 !-- so on until a node is reached that has no origin (%origin_id == -1). This is the starting node. 3266 DEALLOCATE( queue ) 3267 cur_node = 0 3268 steps = 0 3269 ALLOCATE( path(1:100) ) 3270 DO WHILE ( cur_node /= -1 ) 3271 steps = steps + 1 3272 ! 3273 !-- Resize path array if necessary 3274 IF ( steps > SIZE(path) ) THEN 3275 ALLOCATE( tmp_path(1:steps-1) ) 3276 tmp_path(1:steps-1) = path(1:steps-1) 3277 DEALLOCATE( path ) 3278 ALLOCATE( path(1:2*(steps-1)) ) 3279 path(1:steps-1) = tmp_path(1:steps-1) 3280 DEALLOCATE( tmp_path ) 3281 ENDIF 3282 path(steps)%x = tmp_mesh(cur_node)%x 3283 path(steps)%y = tmp_mesh(cur_node)%y 3284 path(steps)%x_s = tmp_mesh(cur_node)%x_s 3285 path(steps)%y_s = tmp_mesh(cur_node)%y_s 3286 cur_node = tmp_mesh(cur_node)%origin_id 3287 ENDDO 3288 ! 3289 !-- Add calculated intermittent targets to the path until either the target or the maximum number of 3290 !-- intermittent targets is reached. 3291 !-- Ignore starting point (reduce index by one), it is agent position. 3292 dummy_path_x = -1 3293 dummy_path_y = -1 3294 path_ag = 1 3295 steps = steps - 1 3296 nsteps = 0 3297 DO WHILE( steps > 0 .AND. path_ag <= agt_path_size ) 3298 ! 3299 !-- Each target point is randomly chosen along a line target along the bisector of the building 3300 !-- corner that starts at corner_gate_start and has a width of corner_gate_width. This is to 3301 !-- avoid clustering when opposing agent groups try to reach the same corner target. 3302 rn_gate = random_function(iran_agent) * corner_gate_width + corner_gate_start 3303 dummy_path_x(path_ag) = path(steps)%x + rn_gate * (path(steps)%x_s - path(steps)%x) 3304 dummy_path_y(path_ag) = path(steps)%y + rn_gate * (path(steps)%y_s - path(steps)%y) 3425 3305 steps = steps - 1 3426 nsteps = 0 3427 DO WHILE( steps > 0 .AND. path_ag <= agt_path_size ) 3428 ! 3429 !-- Each target point is randomly chosen along a line target along the 3430 !-- bisector of the building corner that starts at corner_gate_start 3431 !-- and has a width of corner_gate_width. This is to avoid clustering 3432 !-- when opposing agent groups try to reach the same corner target. 3433 rn_gate = random_function(iran_agent) * corner_gate_width & 3434 + corner_gate_start 3435 dummy_path_x(path_ag) = path(steps)%x + rn_gate & 3436 * (path(steps)%x_s - path(steps)%x) 3437 dummy_path_y(path_ag) = path(steps)%y + rn_gate & 3438 * (path(steps)%y_s - path(steps)%y) 3439 steps = steps - 1 3440 path_ag = path_ag + 1 3441 nsteps = nsteps + 1 3442 ENDDO 3443 ! 3444 !-- Set current intermittent target of this agent 3445 DEALLOCATE(tmp_mesh, path) 3446 3447 END SUBROUTINE mas_nav_a_star 3448 3449 !------------------------------------------------------------------------------! 3306 path_ag = path_ag + 1 3307 nsteps = nsteps + 1 3308 ENDDO 3309 ! 3310 !-- Set current intermittent target of this agent 3311 DEALLOCATE( tmp_mesh, path ) 3312 3313 END SUBROUTINE mas_nav_a_star 3314 3315 !--------------------------------------------------------------------------------------------------! 3450 3316 ! Description: 3451 3317 ! ------------ 3452 !> Adds a connection between two points of the navigation mesh 3453 !> (one-way: in_mp1 to in_mp2) 3454 !------------------------------------------------------------------------------! 3455 SUBROUTINE mas_nav_add_connection ( in_mp1, id2, in_mp2 ) 3456 3457 IMPLICIT NONE 3458 3459 LOGICAL :: connection_established !< Flag to indicate if connection has already been established 3460 3461 INTEGER(iwp) :: id2 !< ID of in_mp2 3462 INTEGER(iwp) :: il !< local counter 3463 INTEGER(iwp) :: noc1 !< number of connections in in_mp1 3464 3465 INTEGER, DIMENSION(:), ALLOCATABLE :: dum_cv !< dummy array for connected_vertices 3466 3467 REAL(wp) :: dist !< Distance between the two points 3468 3469 REAL(wp), DIMENSION(:), ALLOCATABLE :: dum_dtv 3470 3471 TYPE(mesh_point) :: in_mp1 !< mesh point that gets a new connection 3472 TYPE(mesh_point) :: in_mp2 !< mesh point in_mp1 will be connected to 3473 3474 connection_established = .FALSE. 3475 ! 3476 !-- Check if connection has already been established 3477 noc1 = SIZE(in_mp1%connected_vertices) 3478 DO il = 1, in_mp1%noc 3479 IF ( in_mp1%connected_vertices(il) == id2 ) THEN 3480 connection_established = .TRUE. 3481 EXIT 3482 ENDIF 3483 ENDDO 3484 3485 IF ( .NOT. connection_established ) THEN 3486 ! 3487 !-- Resize arrays, if necessary 3488 IF ( in_mp1%noc >= noc1 ) THEN 3489 ALLOCATE( dum_cv(1:noc1),dum_dtv(1:noc1) ) 3490 dum_cv = in_mp1%connected_vertices 3491 dum_dtv = in_mp1%distance_to_vertex 3492 DEALLOCATE( in_mp1%connected_vertices, in_mp1%distance_to_vertex ) 3493 ALLOCATE( in_mp1%connected_vertices(1:2*noc1), & 3494 in_mp1%distance_to_vertex(1:2*noc1) ) 3495 in_mp1%connected_vertices = -999 3496 in_mp1%distance_to_vertex = -999. 3497 in_mp1%connected_vertices(1:noc1) = dum_cv 3498 in_mp1%distance_to_vertex(1:noc1) = dum_dtv 3499 ENDIF 3500 3501 ! 3502 !-- Add connection 3503 in_mp1%noc = in_mp1%noc+1 3504 dist = SQRT( (in_mp1%x - in_mp2%x)**2 + (in_mp1%y - in_mp2%y)**2 ) 3505 in_mp1%connected_vertices(in_mp1%noc) = id2 3506 in_mp1%distance_to_vertex(in_mp1%noc) = dist 3318 !> Adds a connection between two points of the navigation mesh (one-way: in_mp1 to in_mp2) 3319 !--------------------------------------------------------------------------------------------------! 3320 SUBROUTINE mas_nav_add_connection ( in_mp1, id2, in_mp2 ) 3321 3322 IMPLICIT NONE 3323 3324 LOGICAL :: connection_established !< Flag to indicate if connection has already been established 3325 3326 INTEGER(iwp) :: id2 !< ID of in_mp2 3327 INTEGER(iwp) :: il !< local counter 3328 INTEGER(iwp) :: noc1 !< number of connections in in_mp1 3329 3330 INTEGER, DIMENSION(:), ALLOCATABLE :: dum_cv !< dummy array for connected_vertices 3331 3332 REAL(wp) :: dist !< Distance between the two points 3333 3334 REAL(wp), DIMENSION(:), ALLOCATABLE :: dum_dtv 3335 3336 TYPE(mesh_point) :: in_mp1 !< mesh point that gets a new connection 3337 TYPE(mesh_point) :: in_mp2 !< mesh point in_mp1 will be connected to 3338 3339 connection_established = .FALSE. 3340 ! 3341 !-- Check if connection has already been established 3342 noc1 = SIZE( in_mp1%connected_vertices ) 3343 DO il = 1, in_mp1%noc 3344 IF ( in_mp1%connected_vertices(il) == id2 ) THEN 3345 connection_established = .TRUE. 3346 EXIT 3507 3347 ENDIF 3508 3509 END SUBROUTINE mas_nav_add_connection 3510 3511 !------------------------------------------------------------------------------! 3348 ENDDO 3349 3350 IF ( .NOT. connection_established ) THEN 3351 ! 3352 !-- Resize arrays, if necessary 3353 IF ( in_mp1%noc >= noc1 ) THEN 3354 ALLOCATE( dum_cv(1:noc1),dum_dtv(1:noc1) ) 3355 dum_cv = in_mp1%connected_vertices 3356 dum_dtv = in_mp1%distance_to_vertex 3357 DEALLOCATE( in_mp1%connected_vertices, in_mp1%distance_to_vertex ) 3358 ALLOCATE( in_mp1%connected_vertices(1:2*noc1), & 3359 in_mp1%distance_to_vertex(1:2*noc1) ) 3360 in_mp1%connected_vertices = -999 3361 in_mp1%distance_to_vertex = -999. 3362 in_mp1%connected_vertices(1:noc1) = dum_cv 3363 in_mp1%distance_to_vertex(1:noc1) = dum_dtv 3364 ENDIF 3365 3366 ! 3367 !-- Add connection 3368 in_mp1%noc = in_mp1%noc+1 3369 dist = SQRT( (in_mp1%x - in_mp2%x)**2 + (in_mp1%y - in_mp2%y)**2 ) 3370 in_mp1%connected_vertices(in_mp1%noc) = id2 3371 in_mp1%distance_to_vertex(in_mp1%noc) = dist 3372 ENDIF 3373 3374 END SUBROUTINE mas_nav_add_connection 3375 3376 !--------------------------------------------------------------------------------------------------! 3512 3377 ! Description: 3513 3378 ! ------------ 3514 3379 !> Adds a vertex (curren position of agent or target) to the existing tmp_mesh 3515 !------------------------------------------------------------------------------ !3516 3517 3518 3519 3520 LOGICAL :: intersection_found !< flag 3521 3522 INTEGER(iwp) :: jl!< mesh point counter3523 INTEGER(iwp) :: pl!< polygon counter3524 INTEGER(iwp) :: vl!< vertex counter3525 INTEGER(iwp) :: pid_t!< polygon id of tested mesh point3526 INTEGER(iwp) :: vid_t!< vertex id of tested mesh point3527 INTEGER(iwp) :: in_id !< vertex id of tested mesh point 3528 3529 LOGICAL :: is_left_n!< local switch3530 LOGICAL :: is_left_p!< local switch3531 LOGICAL :: is_right_n!< local switch3532 LOGICAL :: is_right_p!< local switch3533 3534 REAL(wp) :: v1x!< x-coordinate of test vertex 1 for intersection test3535 REAL(wp) :: v1y!< y-coordinate of test vertex 1 for intersection test3536 REAL(wp) :: v2x!< x-coordinate of test vertex 2 for intersection test3537 REAL(wp) :: v2y!< y-coordinate of test vertex 2 for intersection test3538 REAL(wp) :: x!< x-coordinate of current mesh point3539 REAL(wp) :: x_t!< x-coordinate of tested mesh point3540 REAL(wp) :: y!< y-coordinate of current mesh point3541 REAL(wp) :: y_t!< y-coordinate of tested mesh point3542 3543 TYPE(mesh_point) :: in_mp!< Input mesh point3380 !--------------------------------------------------------------------------------------------------! 3381 SUBROUTINE mas_nav_add_vertex_to_mesh ( in_mp, in_id ) 3382 3383 IMPLICIT NONE 3384 3385 3386 INTEGER(iwp) :: in_id !< vertex id of tested mesh point 3387 INTEGER(iwp) :: jl !< mesh point counter 3388 INTEGER(iwp) :: pl !< polygon counter 3389 INTEGER(iwp) :: vl !< vertex counter 3390 INTEGER(iwp) :: pid_t !< polygon id of tested mesh point 3391 INTEGER(iwp) :: vid_t !< vertex id of tested mesh point 3392 3393 LOGICAL :: intersection_found !< flag 3394 LOGICAL :: is_left_n !< local switch 3395 LOGICAL :: is_left_p !< local switch 3396 LOGICAL :: is_right_n !< local switch 3397 LOGICAL :: is_right_p !< local switch 3398 3399 REAL(wp) :: v1x !< x-coordinate of test vertex 1 for intersection test 3400 REAL(wp) :: v1y !< y-coordinate of test vertex 1 for intersection test 3401 REAL(wp) :: v2x !< x-coordinate of test vertex 2 for intersection test 3402 REAL(wp) :: v2y !< y-coordinate of test vertex 2 for intersection test 3403 REAL(wp) :: x !< x-coordinate of current mesh point 3404 REAL(wp) :: x_t !< x-coordinate of tested mesh point 3405 REAL(wp) :: y !< y-coordinate of current mesh point 3406 REAL(wp) :: y_t !< y-coordinate of tested mesh point 3407 3408 TYPE(mesh_point) :: in_mp !< Input mesh point 3544 3409 ! 3545 3410 !-- 3546 x = in_mp%x 3547 y = in_mp%y 3548 DO jl = 0, SIZE(tmp_mesh)-2 3549 IF ( in_id == jl ) CYCLE 3550 ! 3551 !-- Ignore mesh points with 0 connections 3552 IF ( tmp_mesh(jl)%polygon_id /= -1 ) THEN 3553 IF ( tmp_mesh(jl)%noc == 0 ) CYCLE 3554 ENDIF 3555 x_t = tmp_mesh(jl)%x 3556 y_t = tmp_mesh(jl)%y 3557 pid_t = tmp_mesh(jl)%polygon_id 3558 vid_t = tmp_mesh(jl)%vertex_id 3559 ! 3560 !-- If the connecting line between the target and a mesh point points 3561 !-- into the mesh point's polygon, no connection will be 3562 !-- established between the two points. This is the case if the 3563 !-- previous (next, n) vertex of the polygon is right of the connecting 3564 !-- line and the next (previous, p) vertex of the polygon is left of the 3565 !-- connecting line. 3566 IF ( pid_t > 0 .AND. pid_t <= SIZE( polygons ) ) THEN 3567 is_left_p = is_left( x, y, x_t, y_t, polygons(pid_t)%vertices(vid_t-1)%x, & 3568 polygons(pid_t)%vertices(vid_t-1)%y ) 3569 is_left_n = is_left( x, y, x_t, y_t, polygons(pid_t)%vertices(vid_t+1)%x, & 3570 polygons(pid_t)%vertices(vid_t+1)%y ) 3571 is_right_p = is_right( x, y, x_t, y_t, polygons(pid_t)%vertices(vid_t-1)%x, & 3572 polygons(pid_t)%vertices(vid_t-1)%y ) 3573 is_right_n = is_right( x, y, x_t, y_t, polygons(pid_t)%vertices(vid_t+1)%x, & 3574 polygons(pid_t)%vertices(vid_t+1)%y ) 3575 IF ( ( is_left_p .AND. is_right_n ) .OR. ( is_right_p .AND. is_left_n ) ) CYCLE 3576 ENDIF 3577 ! 3578 !-- For each edge of each polygon, check if it intersects with the 3579 !-- potential connection. If at least one intersection is found, 3580 !-- no connection can be made 3581 intersection_found = .FALSE. 3582 DO pl = 1, SIZE(polygons) 3583 DO vl = 1, polygons(pl)%nov 3584 v1x = polygons(pl)%vertices(vl)%x 3585 v1y = polygons(pl)%vertices(vl)%y 3586 v2x = polygons(pl)%vertices(vl+1)%x 3587 v2y = polygons(pl)%vertices(vl+1)%y 3588 intersection_found = intersect(x,y,x_t,y_t,v1x,v1y,v2x,v2y) 3589 IF ( intersection_found ) THEN 3590 EXIT 3591 ENDIF 3592 ENDDO 3593 IF ( intersection_found ) EXIT 3411 x = in_mp%x 3412 y = in_mp%y 3413 DO jl = 0, SIZE( tmp_mesh )-2 3414 IF ( in_id == jl ) CYCLE 3415 ! 3416 !-- Ignore mesh points with 0 connections 3417 IF ( tmp_mesh(jl)%polygon_id /= -1 ) THEN 3418 IF ( tmp_mesh(jl)%noc == 0 ) CYCLE 3419 ENDIF 3420 x_t = tmp_mesh(jl)%x 3421 y_t = tmp_mesh(jl)%y 3422 pid_t = tmp_mesh(jl)%polygon_id 3423 vid_t = tmp_mesh(jl)%vertex_id 3424 ! 3425 !-- If the connecting line between the target and a mesh point points into the mesh point's 3426 !-- polygon, no connection will be established between the two points. This is the case if the 3427 !-- previous (next, n) vertex of the polygon is right of the connecting line and the next 3428 !-- (previous, p) vertex of the polygon is left of the connecting line. 3429 IF ( pid_t > 0 .AND. pid_t <= SIZE( polygons ) ) THEN 3430 is_left_p = is_left( x, y, x_t, y_t, polygons(pid_t)%vertices(vid_t-1)%x, & 3431 polygons(pid_t)%vertices(vid_t-1)%y ) 3432 is_left_n = is_left( x, y, x_t, y_t, polygons(pid_t)%vertices(vid_t+1)%x, & 3433 polygons(pid_t)%vertices(vid_t+1)%y ) 3434 is_right_p = is_right( x, y, x_t, y_t, polygons(pid_t)%vertices(vid_t-1)%x, & 3435 polygons(pid_t)%vertices(vid_t-1)%y ) 3436 is_right_n = is_right( x, y, x_t, y_t, polygons(pid_t)%vertices(vid_t+1)%x, & 3437 polygons(pid_t)%vertices(vid_t+1)%y ) 3438 IF ( ( is_left_p .AND. is_right_n ) .OR. ( is_right_p .AND. is_left_n ) ) CYCLE 3439 ENDIF 3440 ! 3441 !-- For each edge of each polygon, check if it intersects with the potential connection. If at 3442 !-- least one intersection is found, no connection can be made. 3443 intersection_found = .FALSE. 3444 DO pl = 1, SIZE( polygons ) 3445 DO vl = 1, polygons(pl)%nov 3446 v1x = polygons(pl)%vertices(vl)%x 3447 v1y = polygons(pl)%vertices(vl)%y 3448 v2x = polygons(pl)%vertices(vl+1)%x 3449 v2y = polygons(pl)%vertices(vl+1)%y 3450 intersection_found = intersect(x,y,x_t,y_t,v1x,v1y,v2x,v2y) 3451 IF ( intersection_found ) THEN 3452 EXIT 3453 ENDIF 3594 3454 ENDDO 3595 IF ( intersection_found ) CYCLE 3596 ! 3597 !-- If neither of the above two test was true, a connection will be 3598 !-- established between the two mesh points. 3599 CALL mas_nav_add_connection(in_mp,jl, tmp_mesh(jl)) 3600 CALL mas_nav_add_connection(tmp_mesh(jl),in_id, in_mp) 3455 IF ( intersection_found ) EXIT 3601 3456 ENDDO 3602 CALL mas_nav_reduce_connections(in_mp) 3603 3604 END SUBROUTINE mas_nav_add_vertex_to_mesh 3605 3606 !------------------------------------------------------------------------------! 3457 IF ( intersection_found ) CYCLE 3458 ! 3459 !-- If neither of the above two tests was true, a connection will be established between the two 3460 !-- mesh points. 3461 CALL mas_nav_add_connection(in_mp,jl, tmp_mesh(jl)) 3462 CALL mas_nav_add_connection(tmp_mesh(jl),in_id, in_mp) 3463 ENDDO 3464 CALL mas_nav_reduce_connections(in_mp) 3465 3466 END SUBROUTINE mas_nav_add_vertex_to_mesh 3467 3468 !--------------------------------------------------------------------------------------------------! 3607 3469 ! Description: 3608 3470 ! ------------ 3609 3471 !> Creates a temporary copy of the navigation mesh to be used for pathfinding 3610 !------------------------------------------------------------------------------ !3611 3612 3613 3614 3615 INTEGER(iwp) :: som !< size of mesh3616 INTEGER(iwp) :: noc!< number of connetions3617 INTEGER(iwp) :: im !< local mesh point counter3618 3619 REAL(wp) :: a_x!< x-coordinate agent3620 REAL(wp) :: a_y!< y-coordinate agent3621 REAL(wp) :: t_x!< x-coordinate target3622 REAL(wp) :: t_y!< y-coordinate target3623 ! 3624 !-- give tmp_mesh the size of mesh3625 som = SIZE(mesh)+13626 ALLOCATE(tmp_mesh(0:som))3627 ! 3628 !-- give the allocatable variables in tmp_mesh their respctive sizes3629 DOim = 1, som-13630 3631 ALLOCATE(tmp_mesh(im)%connected_vertices(1:noc))3632 ALLOCATE(tmp_mesh(im)%distance_to_vertex(1:noc))3633 3634 ! 3635 !-- copy mesh to tmp_mesh3636 3637 ! 3638 !-- 3639 3640 3641 ! 3642 !-- 3643 3644 3645 3646 3647 3648 3649 !------------------------------------------------------------------------------ !3472 !--------------------------------------------------------------------------------------------------! 3473 SUBROUTINE mas_nav_create_tmp_mesh( a_x, a_y, t_x, t_y, som ) 3474 3475 IMPLICIT NONE 3476 3477 INTEGER(iwp) :: im !< local mesh point counter 3478 INTEGER(iwp) :: noc !< number of connetions 3479 INTEGER(iwp) :: som !< size of mesh 3480 3481 REAL(wp) :: a_x !< x-coordinate agent 3482 REAL(wp) :: a_y !< y-coordinate agent 3483 REAL(wp) :: t_x !< x-coordinate target 3484 REAL(wp) :: t_y !< y-coordinate target 3485 ! 3486 !-- Give tmp_mesh the size of mesh 3487 som = SIZE( mesh ) + 1 3488 ALLOCATE( tmp_mesh(0:som) ) 3489 ! 3490 !-- Give the allocatable variables in tmp_mesh their respctive sizes 3491 DO im = 1, som-1 3492 noc = mesh(im)%noc 3493 ALLOCATE( tmp_mesh(im)%connected_vertices(1:noc) ) 3494 ALLOCATE( tmp_mesh(im)%distance_to_vertex(1:noc) ) 3495 ENDDO 3496 ! 3497 !-- Copy mesh to tmp_mesh 3498 tmp_mesh(1:som-1) = mesh(1:som-1) 3499 ! 3500 !-- Add target point ... 3501 CALL mas_nav_init_mesh_point(tmp_mesh(0),-1_iwp,-1_iwp,t_x, t_y) 3502 CALL mas_nav_add_vertex_to_mesh(tmp_mesh(0),0_iwp) 3503 ! 3504 !-- ... and start point to temp mesh 3505 CALL mas_nav_init_mesh_point(tmp_mesh(som),-1_iwp,-1_iwp,a_x, a_y) 3506 CALL mas_nav_add_vertex_to_mesh(tmp_mesh(som),som) 3507 3508 END SUBROUTINE mas_nav_create_tmp_mesh 3509 3510 3511 !--------------------------------------------------------------------------------------------------! 3650 3512 ! Description: 3651 3513 ! ------------ 3652 !> Finds the shortest path from an agents' position to her target. As the 3653 !> actual pathfinding algorithm uses the obstacle corners and then shifts them 3654 !> outward after pathfinding, cases can uccur in which the connection between 3655 !> these intermittent targets then intersect with obstacles. To remedy this 3656 !> the pathfinding algorithm is then run on every two subsequent intermittent 3657 !> targets iteratively and new intermittent targets may be added to the path 3658 !> this way. 3659 !------------------------------------------------------------------------------! 3660 SUBROUTINE mas_nav_find_path( nl ) 3661 3662 IMPLICIT NONE 3663 3664 INTEGER(iwp) :: nl !< local agent counter 3665 INTEGER(iwp) :: il !< local counter 3666 INTEGER(iwp) :: jl !< local counter 3667 INTEGER(iwp) :: kl !< local counter 3668 INTEGER(iwp) :: nsteps_total !< number of steps on path 3669 INTEGER(iwp) :: nsteps_dummy !< number of steps on path 3670 3671 REAL(wp), DIMENSION(0:30) :: ld_path_x !< local dummy agent path to target (x) 3672 REAL(wp), DIMENSION(0:30) :: ld_path_y !< local dummy agent path to target (y) 3673 ! 3674 !-- Initialize agent path arrays 3675 agents(nl)%path_x = -1 3676 agents(nl)%path_y = -1 3677 agents(nl)%path_x(0) = agents(nl)%x 3678 agents(nl)%path_y(0) = agents(nl)%y 3679 ! 3680 !-- Calculate initial path 3681 CALL mas_nav_a_star( agents(nl)%x, agents(nl)%y, & 3682 agents(nl)%t_x, agents(nl)%t_y, nsteps_total ) 3683 ! 3684 !-- Set the rest of the agent path that was just calculated 3685 agents(nl)%path_x(1:nsteps_total) = dummy_path_x(1:nsteps_total) 3686 agents(nl)%path_y(1:nsteps_total) = dummy_path_y(1:nsteps_total) 3687 ! 3688 !-- Iterate through found path and check more intermittent targets need 3689 !-- to be added. For this, run pathfinding between every two consecutive 3690 !-- intermittent targets. 3691 DO il = 0, MIN(agt_path_size-1, nsteps_total-1) 3692 ! 3693 !-- pathfinding between two consecutive intermittent targets 3694 CALL mas_nav_a_star( agents(nl)%path_x(il), agents(nl)%path_y(il), & 3695 agents(nl)%path_x(il+1), agents(nl)%path_y(il+1),& 3696 nsteps_dummy ) 3697 nsteps_dummy = nsteps_dummy - 1 3698 ! 3699 !-- If additional intermittent targets are found, add them to the path 3700 IF ( nsteps_dummy > 0 ) THEN 3701 ld_path_x = -1 3702 ld_path_y = -1 3703 ld_path_x(il+1:il+nsteps_dummy) = dummy_path_x(1:nsteps_dummy) 3704 ld_path_y(il+1:il+nsteps_dummy) = dummy_path_y(1:nsteps_dummy) 3705 kl = 1 3706 DO jl = il+1,nsteps_total 3707 ld_path_x( il+nsteps_dummy+kl ) = agents(nl)%path_x(jl) 3708 ld_path_y( il+nsteps_dummy+kl ) = agents(nl)%path_y(jl) 3709 kl = kl + 1 3710 IF ( kl > agt_path_size ) EXIT 3711 ENDDO 3712 nsteps_total = MIN(nsteps_total + nsteps_dummy, agt_path_size) 3713 agents(nl)%path_x(il+1:nsteps_total) = ld_path_x(il+1:nsteps_total) 3714 agents(nl)%path_y(il+1:nsteps_total) = ld_path_y(il+1:nsteps_total) 3715 ENDIF 3716 3717 ENDDO 3718 ! 3719 !-- reset path counter to first intermittent target 3720 agents(nl)%path_counter = 1 3721 3722 END SUBROUTINE mas_nav_find_path 3723 3724 !------------------------------------------------------------------------------! 3514 !> Finds the shortest path from an agents' position to her target. As the actual pathfinding 3515 !> algorithm uses the obstacle corners and then shifts them outward after pathfinding, cases can 3516 !> occur in which the connection between these intermittent targets then intersect with obstacles. 3517 !> To remedy this the pathfinding algorithm is then run on every two subsequent intermittent targets 3518 !> iteratively and new intermittent targets may be added to the path this way. 3519 !--------------------------------------------------------------------------------------------------! 3520 SUBROUTINE mas_nav_find_path( nl ) 3521 3522 IMPLICIT NONE 3523 3524 INTEGER(iwp) :: il !< local counter 3525 INTEGER(iwp) :: jl !< local counter 3526 INTEGER(iwp) :: kl !< local counter 3527 INTEGER(iwp) :: nl !< local agent counter 3528 INTEGER(iwp) :: nsteps_dummy !< number of steps on path 3529 INTEGER(iwp) :: nsteps_total !< number of steps on path 3530 3531 REAL(wp), DIMENSION(0:30) :: ld_path_x !< local dummy agent path to target (x) 3532 REAL(wp), DIMENSION(0:30) :: ld_path_y !< local dummy agent path to target (y) 3533 ! 3534 !-- Initialize agent path arrays 3535 agents(nl)%path_x = -1 3536 agents(nl)%path_y = -1 3537 agents(nl)%path_x(0) = agents(nl)%x 3538 agents(nl)%path_y(0) = agents(nl)%y 3539 ! 3540 !-- Calculate initial path 3541 CALL mas_nav_a_star( agents(nl)%x, agents(nl)%y, agents(nl)%t_x, agents(nl)%t_y, nsteps_total ) 3542 ! 3543 !-- Set the rest of the agent path that was just calculated 3544 agents(nl)%path_x(1:nsteps_total) = dummy_path_x(1:nsteps_total) 3545 agents(nl)%path_y(1:nsteps_total) = dummy_path_y(1:nsteps_total) 3546 ! 3547 !-- Iterate through found path and check more intermittent targets need to be added. For this, run 3548 !-- pathfinding between every two consecutive intermittent targets. 3549 DO il = 0, MIN( agt_path_size-1, nsteps_total-1 ) 3550 ! 3551 !-- Pathfinding between two consecutive intermittent targets 3552 CALL mas_nav_a_star( agents(nl)%path_x(il), agents(nl)%path_y(il), & 3553 agents(nl)%path_x(il+1), agents(nl)%path_y(il+1), & 3554 nsteps_dummy ) 3555 nsteps_dummy = nsteps_dummy - 1 3556 ! 3557 !-- If additional intermittent targets are found, add them to the path 3558 IF ( nsteps_dummy > 0 ) THEN 3559 ld_path_x = -1 3560 ld_path_y = -1 3561 ld_path_x(il+1:il+nsteps_dummy) = dummy_path_x(1:nsteps_dummy) 3562 ld_path_y(il+1:il+nsteps_dummy) = dummy_path_y(1:nsteps_dummy) 3563 kl = 1 3564 DO jl = il+1,nsteps_total 3565 ld_path_x( il+nsteps_dummy+kl ) = agents(nl)%path_x(jl) 3566 ld_path_y( il+nsteps_dummy+kl ) = agents(nl)%path_y(jl) 3567 kl = kl + 1 3568 IF ( kl > agt_path_size ) EXIT 3569 ENDDO 3570 nsteps_total = MIN( nsteps_total + nsteps_dummy, agt_path_size ) 3571 agents(nl)%path_x(il+1:nsteps_total) = ld_path_x(il+1:nsteps_total) 3572 agents(nl)%path_y(il+1:nsteps_total) = ld_path_y(il+1:nsteps_total) 3573 ENDIF 3574 3575 ENDDO 3576 ! 3577 !-- Reset path counter to first intermittent target 3578 agents(nl)%path_counter = 1 3579 3580 END SUBROUTINE mas_nav_find_path 3581 3582 !--------------------------------------------------------------------------------------------------! 3725 3583 ! Description: 3726 3584 ! ------------ 3727 !> Reduces the size of connection array to the amount of actual connections 3728 !> after all connetionswere added to a mesh point3729 !------------------------------------------------------------------------------ !3730 3731 3732 3733 3734 3735 3736 INTEGER, DIMENSION(:), ALLOCATABLE :: dum_cv!< dummy connected_vertices3737 3738 REAL(wp), DIMENSION(:), ALLOCATABLE :: dum_dtv!< dummy distance_to_vertex3739 3740 3741 3742 3743 3744 3745 3746 3747 ALLOCATE( in_mp%connected_vertices(1:noc),&3748 3749 3750 3751 3752 3753 3754 !------------------------------------------------------------------------------ !3585 !> Reduces the size of connection array to the amount of actual connections after all connetions 3586 !> were added to a mesh point 3587 !--------------------------------------------------------------------------------------------------! 3588 SUBROUTINE mas_nav_reduce_connections ( in_mp ) 3589 3590 IMPLICIT NONE 3591 3592 INTEGER(iwp) :: noc !< number of connections 3593 3594 INTEGER, DIMENSION(:), ALLOCATABLE :: dum_cv !< dummy connected_vertices 3595 3596 REAL(wp), DIMENSION(:), ALLOCATABLE :: dum_dtv !< dummy distance_to_vertex 3597 3598 TYPE(mesh_point) :: in_mp 3599 3600 noc = in_mp%noc 3601 ALLOCATE( dum_cv(1:noc),dum_dtv(1:noc) ) 3602 dum_cv = in_mp%connected_vertices(1:noc) 3603 dum_dtv = in_mp%distance_to_vertex(1:noc) 3604 DEALLOCATE( in_mp%connected_vertices, in_mp%distance_to_vertex ) 3605 ALLOCATE( in_mp%connected_vertices(1:noc), & 3606 in_mp%distance_to_vertex(1:noc) ) 3607 in_mp%connected_vertices(1:noc) = dum_cv(1:noc) 3608 in_mp%distance_to_vertex(1:noc) = dum_dtv(1:noc) 3609 3610 END SUBROUTINE mas_nav_reduce_connections 3611 3612 !--------------------------------------------------------------------------------------------------! 3755 3613 ! Description: 3756 3614 ! ------------ 3757 3615 !> Initializes a point of the navigation mesh 3758 !------------------------------------------------------------------------------ !3759 3760 3761 3762 3763 INTEGER(iwp) :: pid!< polygon ID3764 INTEGER(iwp) :: vid!< vertex ID3765 3766 REAL(wp) :: x!< x-coordinate3767 REAL(wp) :: y!< y-coordinate3768 3769 TYPE(mesh_point) :: in_mp!< mesh point to be initialized3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 ALLOCATE(in_mp%connected_vertices(1:100),&3780 in_mp%distance_to_vertex(1:100))3781 3782 3783 3784 3785 3786 3787 !------------------------------------------------------------------------------ !3616 !--------------------------------------------------------------------------------------------------! 3617 SUBROUTINE mas_nav_init_mesh_point ( in_mp, pid, vid, x, y ) 3618 3619 IMPLICIT NONE 3620 3621 INTEGER(iwp) :: pid !< polygon ID 3622 INTEGER(iwp) :: vid !< vertex ID 3623 3624 REAL(wp) :: x !< x-coordinate 3625 REAL(wp) :: y !< y-coordinate 3626 3627 TYPE(mesh_point) :: in_mp !< mesh point to be initialized 3628 3629 in_mp%origin_id = -1 3630 in_mp%polygon_id = pid 3631 in_mp%vertex_id = vid 3632 in_mp%cost_so_far = 1.d12 3633 in_mp%x = x 3634 in_mp%y = y 3635 in_mp%x_s = x 3636 in_mp%y_s = y 3637 ALLOCATE( in_mp%connected_vertices(1:100), & 3638 in_mp%distance_to_vertex(1:100) ) 3639 in_mp%connected_vertices = -999 3640 in_mp%distance_to_vertex = -999. 3641 in_mp%noc = 0 3642 3643 END SUBROUTINE mas_nav_init_mesh_point 3644 3645 !--------------------------------------------------------------------------------------------------! 3788 3646 ! Description: 3789 3647 ! ------------ 3790 3648 !> Reading of namlist from parin file 3791 !------------------------------------------------------------------------------! 3792 SUBROUTINE mas_parin 3793 3794 USE control_parameters, & 3795 ONLY: agent_time_unlimited, multi_agent_system_end, & 3796 multi_agent_system_start 3797 3798 IMPLICIT NONE 3799 3800 CHARACTER (LEN=80) :: line !< 3801 3802 NAMELIST /agent_parameters/ a_rand_target, & 3803 adx, & 3804 ady, & 3805 agent_maximum_age, & 3806 agent_time_unlimited, & 3807 alloc_factor_mas, & 3808 asl, & 3809 asn, & 3810 asr, & 3811 ass, & 3812 at_x, & 3813 at_y, & 3814 bc_mas_lr, & 3815 bc_mas_ns, & 3816 coll_t_0, & 3817 corner_gate_start, & 3818 corner_gate_width, & 3819 dim_size_agtnum_manual, & 3820 dim_size_factor_agtnum, & 3821 deallocate_memory_mas, & 3822 dist_to_int_target, & 3823 dt_agent, & 3824 dt_arel, & 3825 dt_write_agent_data, & 3826 end_time_arel, & 3827 max_dist_from_path, & 3828 min_nr_agent, & 3829 multi_agent_system_end, & 3830 multi_agent_system_start, & 3831 number_of_agent_groups, & 3832 radius_agent, & 3833 random_start_position_agents, & 3834 read_agents_from_restartfile, & 3835 repuls_agent, & 3836 repuls_wall, & 3837 scan_radius_agent, & 3838 sigma_rep_agent, & 3839 sigma_rep_wall, & 3840 step_dealloc_mas, & 3841 tau_accel_agent 3842 3843 ! 3844 !-- Try to find agent package 3845 REWIND ( 11 ) 3846 line = ' ' 3847 DO WHILE ( INDEX( line, '&agent_parameters' ) == 0 ) 3848 READ ( 11, '(A)', END=20 ) line 3849 ENDDO 3850 BACKSPACE ( 11 ) 3851 3852 ! 3853 !-- Read user-defined namelist 3854 READ ( 11, agent_parameters, ERR = 10, END = 20 ) 3855 3856 ! 3857 !-- Set flag that indicates that agents are switched on 3858 agents_active = .TRUE. 3859 GOTO 20 3860 3861 10 BACKSPACE( 11 ) 3862 READ( 11 , '(A)') line 3863 CALL parin_fail_message( 'agent_parameters', line ) 3864 3865 20 CONTINUE 3866 3867 END SUBROUTINE mas_parin 3868 3869 !------------------------------------------------------------------------------! 3649 !--------------------------------------------------------------------------------------------------! 3650 SUBROUTINE mas_parin 3651 3652 USE control_parameters, & 3653 ONLY: agent_time_unlimited, multi_agent_system_end, multi_agent_system_start 3654 3655 IMPLICIT NONE 3656 3657 CHARACTER (LEN=80) :: line !< 3658 3659 NAMELIST /agent_parameters/ a_rand_target, & 3660 adx, & 3661 ady, & 3662 agent_maximum_age, & 3663 agent_time_unlimited, & 3664 alloc_factor_mas, & 3665 asl, & 3666 asn, & 3667 asr, & 3668 ass, & 3669 at_x, & 3670 at_y, & 3671 bc_mas_lr, & 3672 bc_mas_ns, & 3673 coll_t_0, & 3674 corner_gate_start, & 3675 corner_gate_width, & 3676 deallocate_memory_mas, & 3677 dim_size_agtnum_manual, & 3678 dim_size_factor_agtnum, & 3679 dist_to_int_target, & 3680 dt_agent, & 3681 dt_arel, & 3682 dt_write_agent_data, & 3683 end_time_arel, & 3684 max_dist_from_path, & 3685 min_nr_agent, & 3686 multi_agent_system_end, & 3687 multi_agent_system_start, & 3688 number_of_agent_groups, & 3689 radius_agent, & 3690 random_start_position_agents, & 3691 read_agents_from_restartfile, & 3692 repuls_agent, & 3693 repuls_wall, & 3694 scan_radius_agent, & 3695 sigma_rep_agent, & 3696 sigma_rep_wall, & 3697 step_dealloc_mas, & 3698 tau_accel_agent 3699 3700 ! 3701 !-- Try to find agent package 3702 REWIND ( 11 ) 3703 line = ' ' 3704 DO WHILE ( INDEX( line, '&agent_parameters' ) == 0 ) 3705 READ ( 11, '(A)', END=20 ) line 3706 ENDDO 3707 BACKSPACE ( 11 ) 3708 3709 ! 3710 !-- Read user-defined namelist 3711 READ ( 11, agent_parameters, ERR = 10, END = 20 ) 3712 3713 ! 3714 !-- Set flag that indicates that agents are switched on 3715 agents_active = .TRUE. 3716 GOTO 20 3717 3718 10 BACKSPACE( 11 ) 3719 READ( 11 , '(A)') line 3720 CALL parin_fail_message( 'agent_parameters', line ) 3721 3722 20 CONTINUE 3723 3724 END SUBROUTINE mas_parin 3725 3726 !--------------------------------------------------------------------------------------------------! 3870 3727 ! Description: 3871 3728 ! ------------ 3872 3729 !> Routine for the whole processor 3873 3730 !> Sort all agents into the 4 respective subgrid boxes 3874 !------------------------------------------------------------------------------! 3875 SUBROUTINE mas_ps_sort_in_subboxes 3876 3877 IMPLICIT NONE 3878 3879 INTEGER(iwp) :: i !< grid box (x) 3880 INTEGER(iwp) :: ip !< counter (x) 3881 INTEGER(iwp) :: is !< box counter 3882 INTEGER(iwp) :: j !< grid box (y) 3883 INTEGER(iwp) :: jp !< counter (y) 3884 INTEGER(iwp) :: m !< sorting index 3885 INTEGER(iwp) :: n !< agent index 3886 INTEGER(iwp) :: nn !< agent counter 3887 INTEGER(iwp) :: sort_index !< sorting index 3888 3889 INTEGER(iwp), DIMENSION(0:3) :: sort_count !< number of agents in one subbox 3890 3891 TYPE(agent_type), DIMENSION(:,:), ALLOCATABLE :: sort_agents !< sorted agent array 3892 3893 DO ip = nxl, nxr 3894 DO jp = nys, nyn 3895 number_of_agents = agt_count(jp,ip) 3896 IF ( number_of_agents <= 0 ) CYCLE 3897 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 3898 3899 nn = 0 3900 sort_count = 0 3901 ALLOCATE( sort_agents(number_of_agents, 0:3) ) 3902 3903 DO n = 1, number_of_agents 3904 sort_index = 0 3905 3906 IF ( agents(n)%agent_mask ) THEN 3907 nn = nn + 1 3908 ! 3909 !-- Sorting agents with a binary scheme 3910 !-- sort_index=11_2=3_10 -> agent at the left,south subgridbox 3911 !-- sort_index=10_2=2_10 -> agent at the left,north subgridbox 3912 !-- sort_index=01_2=1_10 -> agent at the right,south subgridbox 3913 !-- sort_index=00_2=0_10 -> agent at the right,north subgridbox 3914 !-- For this the center of the gridbox is calculated 3915 i = (agents(n)%x + 0.5_wp * dx) * ddx 3916 j = (agents(n)%y + 0.5_wp * dy) * ddy 3917 3918 IF ( i == ip ) sort_index = sort_index + 2 3919 IF ( j == jp ) sort_index = sort_index + 1 3920 3921 sort_count(sort_index) = sort_count(sort_index) + 1 3922 m = sort_count(sort_index) 3923 sort_agents(m,sort_index) = agents(n) 3924 sort_agents(m,sort_index)%block_nr = sort_index 3925 ENDIF 3731 !--------------------------------------------------------------------------------------------------! 3732 SUBROUTINE mas_ps_sort_in_subboxes 3733 3734 IMPLICIT NONE 3735 3736 INTEGER(iwp) :: i !< grid box (x) 3737 INTEGER(iwp) :: ip !< counter (x) 3738 INTEGER(iwp) :: is !< box counter 3739 INTEGER(iwp) :: j !< grid box (y) 3740 INTEGER(iwp) :: jp !< counter (y) 3741 INTEGER(iwp) :: m !< sorting index 3742 INTEGER(iwp) :: n !< agent index 3743 INTEGER(iwp) :: nn !< agent counter 3744 INTEGER(iwp) :: sort_index !< sorting index 3745 3746 INTEGER(iwp), DIMENSION(0:3) :: sort_count !< number of agents in one subbox 3747 3748 TYPE(agent_type), DIMENSION(:,:), ALLOCATABLE :: sort_agents !< sorted agent array 3749 3750 DO ip = nxl, nxr 3751 DO jp = nys, nyn 3752 number_of_agents = agt_count(jp,ip) 3753 IF ( number_of_agents <= 0 ) CYCLE 3754 agents => grid_agents(jp,ip)%agents(1:number_of_agents) 3755 3756 nn = 0 3757 sort_count = 0 3758 ALLOCATE( sort_agents(number_of_agents, 0:3) ) 3759 3760 DO n = 1, number_of_agents 3761 sort_index = 0 3762 3763 IF ( agents(n)%agent_mask ) THEN 3764 nn = nn + 1 3765 ! 3766 !-- Sorting agents with a binary scheme 3767 !-- sort_index=11_2=3_10 -> agent at the left,south subgridbox 3768 !-- sort_index=10_2=2_10 -> agent at the left,north subgridbox 3769 !-- sort_index=01_2=1_10 -> agent at the right,south subgridbox 3770 !-- sort_index=00_2=0_10 -> agent at the right,north subgridbox 3771 !-- For this the center of the gridbox is calculated 3772 i = (agents(n)%x + 0.5_wp * dx) * ddx 3773 j = (agents(n)%y + 0.5_wp * dy) * ddy 3774 3775 IF ( i == ip ) sort_index = sort_index + 2 3776 IF ( j == jp ) sort_index = sort_index + 1 3777 3778 sort_count(sort_index) = sort_count(sort_index) + 1 3779 m = sort_count(sort_index) 3780 sort_agents(m,sort_index) = agents(n) 3781 sort_agents(m,sort_index)%block_nr = sort_index 3782 ENDIF 3783 ENDDO 3784 3785 nn = 0 3786 DO is = 0,3 3787 grid_agents(jp,ip)%start_index(is) = nn + 1 3788 DO n = 1,sort_count(is) 3789 nn = nn + 1 3790 agents(nn) = sort_agents(n,is) 3926 3791 ENDDO 3927 3928 nn = 0 3929 DO is = 0,3 3930 grid_agents(jp,ip)%start_index(is) = nn + 1 3931 DO n = 1,sort_count(is) 3932 nn = nn + 1 3933 agents(nn) = sort_agents(n,is) 3934 ENDDO 3935 grid_agents(jp,ip)%end_index(is) = nn 3936 ENDDO 3937 3938 number_of_agents = nn 3939 agt_count(jp,ip) = number_of_agents 3940 DEALLOCATE(sort_agents) 3792 grid_agents(jp,ip)%end_index(is) = nn 3941 3793 ENDDO 3794 3795 number_of_agents = nn 3796 agt_count(jp,ip) = number_of_agents 3797 DEALLOCATE( sort_agents ) 3942 3798 ENDDO 3943 3944 END SUBROUTINE mas_ps_sort_in_subboxes 3799 ENDDO 3800 3801 END SUBROUTINE mas_ps_sort_in_subboxes 3945 3802 3946 3803 #if defined( __parallel ) 3947 !------------------------------------------------------------------------------ !3804 !--------------------------------------------------------------------------------------------------! 3948 3805 ! Description: 3949 3806 ! ------------ 3950 3807 !> Move all agents not marked for deletion to lowest indices (packing) 3951 !------------------------------------------------------------------------------! 3952 SUBROUTINE mas_ps_pack 3953 3954 IMPLICIT NONE 3955 3956 INTEGER(iwp) :: n !< agent counter 3957 INTEGER(iwp) :: nn !< number of agents 3958 ! 3959 !-- Find out elements marked for deletion and move data from highest index 3960 !-- values to these free indices 3961 nn = number_of_agents 3962 3963 DO WHILE ( .NOT. agents(nn)%agent_mask ) 3964 nn = nn-1 3965 IF ( nn == 0 ) EXIT 3808 !--------------------------------------------------------------------------------------------------! 3809 SUBROUTINE mas_ps_pack 3810 3811 IMPLICIT NONE 3812 3813 INTEGER(iwp) :: n !< agent counter 3814 INTEGER(iwp) :: nn !< number of agents 3815 ! 3816 !-- Find out elements marked for deletion and move data from highest index values to these free 3817 !-- indices. 3818 nn = number_of_agents 3819 3820 DO WHILE ( .NOT. agents(nn)%agent_mask ) 3821 nn = nn-1 3822 IF ( nn == 0 ) EXIT 3823 ENDDO 3824 3825 IF ( nn > 0 ) THEN 3826 DO n = 1, number_of_agents 3827 IF ( .NOT. agents(n)%agent_mask ) THEN 3828 agents(n) = agents(nn) 3829 nn = nn - 1 3830 DO WHILE ( .NOT. agents(nn)%agent_mask ) 3831 nn = nn-1 3832 IF ( n == nn ) EXIT 3833 ENDDO 3834 ENDIF 3835 IF ( n == nn ) EXIT 3966 3836 ENDDO 3967 3968 IF ( nn > 0 ) THEN 3969 DO n = 1, number_of_agents 3970 IF ( .NOT. agents(n)%agent_mask ) THEN 3971 agents(n) = agents(nn) 3972 nn = nn - 1 3973 DO WHILE ( .NOT. agents(nn)%agent_mask ) 3974 nn = nn-1 3975 IF ( n == nn ) EXIT 3976 ENDDO 3977 ENDIF 3978 IF ( n == nn ) EXIT 3979 ENDDO 3980 ENDIF 3981 3982 ! 3983 !-- The number of deleted agents has been determined in routines 3984 !-- mas_boundary_conds, mas_droplet_collision, and mas_eh_exchange_horiz 3985 number_of_agents = nn 3986 3987 END SUBROUTINE mas_ps_pack 3837 ENDIF 3838 3839 ! 3840 !-- The number of deleted agents has been determined in routines mas_boundary_conds, 3841 !-- mas_droplet_collision, and mas_eh_exchange_horiz. 3842 number_of_agents = nn 3843 3844 END SUBROUTINE mas_ps_pack 3988 3845 #endif 3989 3846 3990 !------------------------------------------------------------------------------ !3847 !--------------------------------------------------------------------------------------------------! 3991 3848 ! Description: 3992 3849 ! ------------ 3993 !> Sort agents in each sub-grid box into two groups: agents that already 3994 !> completed the LES timestep, and agents that need further timestepping to 3995 !> complete the LES timestep. 3996 !------------------------------------------------------------------------------! 3850 !> Sort agents in each sub-grid box into two groups: agents that already completed the LES 3851 !> timestep, and agents that need further timestepping to complete the LES timestep. 3852 !--------------------------------------------------------------------------------------------------! 3997 3853 ! SUBROUTINE mas_ps_sort_timeloop_done 3998 3854 ! 3999 3855 ! IMPLICIT NONE 4000 3856 ! 4001 ! INTEGER(iwp) :: end_index !< agent end index for each sub-box4002 ! INTEGER(iwp) :: i !< index of agent grid box in x-direction4003 ! INTEGER(iwp) :: j !< index of agent grid box in y-direction4004 ! INTEGER(iwp) :: n !< running index for number of agents4005 ! INTEGER(iwp) :: nb !< index of subgrid boux4006 ! INTEGER(iwp) :: nf !< indices for agents in each sub-box that already finalized their substeps4007 ! INTEGER(iwp) :: nnf !< indices for agents in each sub-box that need further treatment4008 ! INTEGER(iwp) :: num_finalized !< number of agents in each sub-box that already finalized their substeps4009 ! INTEGER(iwp) :: start_index !< agent start index for each sub-box3857 ! INTEGER(iwp) :: end_index !< agent end index for each sub-box 3858 ! INTEGER(iwp) :: i !< index of agent grid box in x-direction 3859 ! INTEGER(iwp) :: j !< index of agent grid box in y-direction 3860 ! INTEGER(iwp) :: n !< running index for number of agents 3861 ! INTEGER(iwp) :: nb !< index of subgrid boux 3862 ! INTEGER(iwp) :: nf !< indices for agents in each sub-box that already finalized their substeps 3863 ! INTEGER(iwp) :: nnf !< indices for agents in each sub-box that need further treatment 3864 ! INTEGER(iwp) :: num_finalized !< number of agents in each sub-box that already finalized their substeps 3865 ! INTEGER(iwp) :: start_index !< agent start index for each sub-box 4010 3866 ! 4011 3867 ! TYPE(agent_type), DIMENSION(:), ALLOCATABLE :: sort_agents !< temporary agent array … … 4028 3884 ! ALLOCATE( sort_agents(start_index:end_index) ) 4029 3885 ! 4030 !-- Determine number of agents already completed the LES 3886 !-- Determine number of agents already completed the LES 4031 3887 !-- timestep, and write them into a temporary array 4032 3888 ! nf = start_index … … 4040 3896 ! ENDDO 4041 3897 ! 4042 !-- Determine number of agents that not completed the LES 3898 !-- Determine number of agents that not completed the LES 4043 3899 !-- timestep, and write them into a temporary array 4044 3900 ! nnf = nf … … 4054 3910 ! sort_agents(start_index:end_index) 4055 3911 ! 4056 !-- Determine updated start_index, used to masked already 4057 !-- completed agents. 3912 !-- Determine updated start_index, used to masked already 3913 !-- completed agents. 4058 3914 ! grid_agents(j,i)%start_index(nb) = & 4059 3915 ! grid_agents(j,i)%start_index(nb) & … … 4063 3919 ! DEALLOCATE ( sort_agents ) 4064 3920 ! 4065 !-- Finally, if number of non-completed agents is non zero 4066 !-- in any of the sub-boxes, set control flag appropriately. 3921 !-- Finally, if number of non-completed agents is non zero 3922 !-- in any of the sub-boxes, set control flag appropriately. 4067 3923 ! IF ( nnf > nf ) & 4068 3924 ! grid_agents(j,i)%time_loop_done = .FALSE. … … 4074 3930 ! END SUBROUTINE mas_ps_sort_timeloop_done 4075 3931 4076 !------------------------------------------------------------------------------ !3932 !--------------------------------------------------------------------------------------------------! 4077 3933 ! Description: 4078 3934 ! ------------ 4079 3935 !> Calls social forces calculations 4080 !------------------------------------------------------------------------------ !4081 4082 4083 4084 4085 4086 4087 4088 4089 ! 4090 !-- 4091 4092 4093 DOn = 1, number_of_agents4094 4095 4096 4097 4098 4099 4100 4101 4102 4103 ! 4104 !-- 4105 4106 4107 4108 4109 4110 4111 !------------------------------------------------------------------------------ !3936 !--------------------------------------------------------------------------------------------------! 3937 SUBROUTINE mas_timestep_forces_call ( ip, jp ) 3938 3939 IMPLICIT NONE 3940 3941 INTEGER(iwp) :: ip !< counter, x-direction 3942 INTEGER(iwp) :: jp !< counter, y-direction 3943 INTEGER(iwp) :: n !< loop variable over all agents in a grid box 3944 3945 ! 3946 !-- Get direction for all agents in current grid cell 3947 CALL mas_agent_direction 3948 3949 DO n = 1, number_of_agents 3950 3951 force_x = 0.0_wp 3952 force_y = 0.0_wp 3953 3954 CALL mas_timestep_social_forces ( 'acceleration', n, ip, jp ) 3955 3956 CALL mas_timestep_social_forces ( 'other_agents', n, ip, jp ) 3957 3958 CALL mas_timestep_social_forces ( 'walls', n, ip, jp ) 3959 ! 3960 !-- Update forces 3961 agents(n)%force_x = force_x 3962 agents(n)%force_y = force_y 3963 ENDDO 3964 3965 END SUBROUTINE mas_timestep_forces_call 3966 3967 !--------------------------------------------------------------------------------------------------! 4112 3968 ! Description: 4113 3969 ! ------------ 4114 3970 !> Euler timestep of agent transport 4115 !------------------------------------------------------------------------------! 4116 SUBROUTINE mas_timestep 4117 4118 IMPLICIT NONE 4119 4120 INTEGER(iwp) :: n !< loop variable over all agents in a grid box 4121 4122 REAL(wp) :: abs_v !< absolute value of velocity 4123 REAL(wp) :: abs_f !< absolute value of force 4124 4125 DO n = 1, number_of_agents 4126 ! 4127 !-- Limit absolute force to a maximum to prevent unrealistic acceleration 4128 abs_f = SQRT((agents(n)%force_x)**2 + (agents(n)%force_y)**2) 4129 IF ( abs_f > 20. ) THEN 4130 agents(n)%force_x = agents(n)%force_x * 20. / abs_f 4131 agents(n)%force_y = agents(n)%force_y * 20. / abs_f 4132 ENDIF 4133 ! 4134 !-- Update agent speed 4135 agents(n)%speed_x = agents(n)%speed_x + agents(n)%force_x * dt_agent 4136 agents(n)%speed_y = agents(n)%speed_y + agents(n)%force_y * dt_agent 4137 ! 4138 !-- Reduction of agent speed to maximum agent speed 4139 abs_v = SQRT((agents(n)%speed_x)**2 + (agents(n)%speed_y)**2) 4140 IF ( abs_v > v_max_agent ) THEN 4141 agents(n)%speed_x = agents(n)%speed_x * v_max_agent / abs_v 4142 agents(n)%speed_y = agents(n)%speed_y * v_max_agent / abs_v 4143 ENDIF 4144 ! 4145 !-- Update agent position 4146 agents(n)%x = agents(n)%x + agents(n)%speed_x * dt_agent 4147 agents(n)%y = agents(n)%y + agents(n)%speed_y * dt_agent 4148 ! 4149 !-- Update absolute value of agent speed 4150 agents(n)%speed_abs = abs_v 4151 ! 4152 !-- Increment the agent age and the total time that the agent 4153 !-- has advanced within the agent timestep procedure 4154 agents(n)%age_m = agents(n)%age 4155 agents(n)%age = agents(n)%age + dt_agent 4156 agents(n)%dt_sum = agents(n)%dt_sum + dt_agent 4157 ! 4158 !-- Check whether there is still an agent that has not yet completed 4159 !-- the total LES timestep 4160 IF ( ( dt_3d - agents(n)%dt_sum ) > 1E-8_wp ) THEN 4161 dt_3d_reached_l_mas = .FALSE. 4162 ENDIF 4163 4164 ENDDO 4165 4166 END SUBROUTINE mas_timestep 4167 4168 !------------------------------------------------------------------------------! 3971 !--------------------------------------------------------------------------------------------------! 3972 SUBROUTINE mas_timestep 3973 3974 IMPLICIT NONE 3975 3976 INTEGER(iwp) :: n !< loop variable over all agents in a grid box 3977 3978 REAL(wp) :: abs_v !< absolute value of velocity 3979 REAL(wp) :: abs_f !< absolute value of force 3980 3981 DO n = 1, number_of_agents 3982 ! 3983 !-- Limit absolute force to a maximum to prevent unrealistic acceleration 3984 abs_f = SQRT( ( agents(n)%force_x )**2 + ( agents(n)%force_y )**2 ) 3985 IF ( abs_f > 20. ) THEN 3986 agents(n)%force_x = agents(n)%force_x * 20. / abs_f 3987 agents(n)%force_y = agents(n)%force_y * 20. / abs_f 3988 ENDIF 3989 ! 3990 !-- Update agent speed 3991 agents(n)%speed_x = agents(n)%speed_x + agents(n)%force_x * dt_agent 3992 agents(n)%speed_y = agents(n)%speed_y + agents(n)%force_y * dt_agent 3993 ! 3994 !-- Reduction of agent speed to maximum agent speed 3995 abs_v = SQRT( ( agents(n)%speed_x )**2 + ( agents(n)%speed_y )**2 ) 3996 IF ( abs_v > v_max_agent ) THEN 3997 agents(n)%speed_x = agents(n)%speed_x * v_max_agent / abs_v 3998 agents(n)%speed_y = agents(n)%speed_y * v_max_agent / abs_v 3999 ENDIF 4000 ! 4001 !-- Update agent position 4002 agents(n)%x = agents(n)%x + agents(n)%speed_x * dt_agent 4003 agents(n)%y = agents(n)%y + agents(n)%speed_y * dt_agent 4004 ! 4005 !-- Update absolute value of agent speed 4006 agents(n)%speed_abs = abs_v 4007 ! 4008 !-- Increment the agent age and the total time that the agent has advanced within the agent 4009 !-- timestep procedure 4010 agents(n)%age_m = agents(n)%age 4011 agents(n)%age = agents(n)%age + dt_agent 4012 agents(n)%dt_sum = agents(n)%dt_sum + dt_agent 4013 ! 4014 !-- Check whether there is still an agent that has not yet completed the total LES timestep 4015 IF ( ( dt_3d - agents(n)%dt_sum ) > 1E-8_wp ) THEN 4016 dt_3d_reached_l_mas = .FALSE. 4017 ENDIF 4018 4019 ENDDO 4020 4021 END SUBROUTINE mas_timestep 4022 4023 !--------------------------------------------------------------------------------------------------! 4169 4024 ! Description: 4170 4025 ! ------------ 4171 !> Calculates the Social Forces (Helbing and Molnar, 1995) that the agent 4172 !> experiences due to acceleration towards target and repulsion by obstacles 4173 !------------------------------------------------------------------------------! 4174 SUBROUTINE mas_timestep_social_forces ( mode, nl, ip, jp ) 4175 4176 IMPLICIT NONE 4177 4178 CHARACTER (LEN=*) :: mode !< identifier for the mode of calculation 4179 4180 INTEGER(iwp) :: ij_dum !< index of nearest wall 4181 INTEGER(iwp) :: il !< index variable along x 4182 INTEGER(iwp) :: ip !< index variable along x 4183 INTEGER(iwp) :: jl !< index variable along y 4184 INTEGER(iwp) :: jp !< index variable along y 4185 INTEGER(iwp) :: nl !< loop variable over all agents in a grid box 4186 INTEGER(iwp) :: no !< loop variable over all agents in a grid box 4187 INTEGER(iwp) :: noa !< amount of agents in a grid box 4188 INTEGER(iwp) :: sc_x_end !< index for scan for topography/other agents 4189 INTEGER(iwp) :: sc_x_start !< index for scan for topography/other agents 4190 INTEGER(iwp) :: sc_y_end !< index for scan for topography/other agents 4191 INTEGER(iwp) :: sc_y_start !< index for scan for topography/other agents 4192 4193 LOGICAL :: corner_found !< flag that indicates a corner has been found near agent 4194 4195 REAL(wp) :: a_pl !< factor for collision avoidance 4196 REAL(wp) :: ax_semimaj !< semiminor axis of repulsive ellipse 4197 REAL(wp) :: b_pl !< factor for collision avoidance 4198 REAL(wp) :: c_pl !< factor for collision avoidance 4199 REAL(wp) :: coll_t !< time at which the next collision would happen 4200 REAL(wp) :: d_coll_t_0 !< inverse of collision cutoff time 4201 REAL(wp) :: d_pl !< factor for collision avoidance 4202 REAL(wp) :: ddum_f !< dummy devisor collision avoidance 4203 REAL(wp) :: dist !< distance to obstacle 4204 REAL(wp) :: dist_sq !< distance to obstacle squared 4205 REAL(wp) :: pos_rel_x !< relative position of two agents (x) 4206 REAL(wp) :: pos_rel_y !< relative position of two agents (y) 4207 REAL(wp) :: r_sq !< y-position 4208 REAL(wp) :: sra !< scan radius (agents) 4209 REAL(wp) :: srw !< local variable for scan radius (walls) 4210 REAL(wp) :: v_rel_x !< relative velocity (x); collision avoidance 4211 REAL(wp) :: v_rel_y !< relative velocity (y); collision avoidance 4212 REAL(wp) :: x_a !< x-position 4213 REAL(wp) :: x_wall !< x-position of wall 4214 REAL(wp) :: y_a !< y-position 4215 REAL(wp) :: y_wall !< y-position of wall 4216 4217 REAL(wp), PARAMETER :: k_pl = 1.5 !< factor for collision avoidance 4218 4219 TYPE(agent_type), DIMENSION(:), POINTER :: l_agts !< agents that repulse current agent 4220 4221 ! 4222 !-- Initialization 4223 x_a = agents(nl)%x 4224 y_a = agents(nl)%y 4225 4226 SELECT CASE ( TRIM( mode ) ) 4227 ! 4228 !-- Calculation of force due to agent trying to approach desired velocity 4229 CASE ( 'acceleration' ) 4230 4231 force_x = force_x + d_tau_accel_agent & 4232 * ( agents(nl)%speed_des*agents(nl)%speed_e_x & 4233 -agents(nl)%speed_x ) 4234 4235 force_y = force_y + d_tau_accel_agent & 4236 * ( agents(nl)%speed_des*agents(nl)%speed_e_y & 4237 -agents(nl)%speed_y ) 4238 4239 ! 4240 !-- Calculation of repulsive forces by other agents in a radius around the 4241 !-- current one 4242 CASE ( 'other_agents' ) 4243 4244 sra = scan_radius_agent 4245 d_coll_t_0 = 1./coll_t_0 4246 ! 4247 !-- Find relevant gridboxes (those that could contain agents within 4248 !-- scan radius) 4249 sc_x_start = FLOOR( (x_a - sra) * ddx ) 4250 sc_x_end = FLOOR( (x_a + sra) * ddx ) 4251 sc_y_start = FLOOR( (y_a - sra) * ddx ) 4252 sc_y_end = FLOOR( (y_a + sra) * ddx ) 4253 IF ( sc_x_start < nxlg ) sc_x_start = nxlg 4254 IF ( sc_x_end > nxrg ) sc_x_end = nxrg 4255 IF ( sc_y_start < nysg ) sc_y_start = nysg 4256 IF ( sc_y_end > nyng ) sc_y_end = nyng 4257 4258 sra = sra**2 4259 ! 4260 !-- Loop over all previously found relevant gridboxes 4261 DO il = sc_x_start, sc_x_end 4262 DO jl = sc_y_start, sc_y_end 4263 noa = agt_count(jl,il) 4264 IF ( noa <= 0 ) CYCLE 4265 l_agts => grid_agents(jl,il)%agents(1:noa) 4266 DO no = 1, noa 4267 ! 4268 !-- Skip self 4269 IF ( jl == jp .AND. il == ip .AND. no == nl ) CYCLE 4270 pos_rel_x = l_agts(no)%x - x_a 4271 pos_rel_y = l_agts(no)%y - y_a 4272 dist_sq = pos_rel_x**2 + pos_rel_y**2 4273 IF ( dist_sq > sra ) CYCLE 4274 r_sq = (2*radius_agent)**2 4275 v_rel_x = agents(nl)%speed_x - l_agts(no)%speed_x 4276 v_rel_y = agents(nl)%speed_y - l_agts(no)%speed_y 4277 ! 4278 !-- Collision is already occuring, default to standard 4279 !-- social forces 4280 IF ( dist_sq <= r_sq ) THEN 4281 dist = SQRT(dist_sq) + 1.0d-12 4282 ax_semimaj = .5_wp*SQRT( dist ) 4283 4284 force_x = force_x - 0.125_wp * repuls_agent & 4285 * d_sigma_rep_agent / ax_semimaj & 4286 * EXP( -ax_semimaj*d_sigma_rep_agent ) & 4287 * (pos_rel_x/dist) 4288 4289 force_y = force_y - 0.125_wp * repuls_agent & 4290 * d_sigma_rep_agent / ax_semimaj & 4291 * EXP( -ax_semimaj*d_sigma_rep_agent ) & 4292 * (pos_rel_y/dist) 4293 ! 4294 !-- Currently no collision, calculate collision avoidance 4295 !-- force according to Karamouzas et al (2014, PRL 113,238701) 4296 ELSE 4297 ! 4298 !-- factors 4299 a_pl = v_rel_x**2 + v_rel_y**2 4300 b_pl = pos_rel_x*v_rel_x + pos_rel_y*v_rel_y 4301 c_pl = dist_sq - r_sq 4302 d_pl = b_pl**2 - a_pl*c_pl 4303 ! 4304 !-- If the two agents are moving non-parallel, calculate 4305 !-- collision avoidance social force 4306 IF ( d_pl > 0.0_wp .AND. & 4307 ( a_pl < -0.00001 .OR. a_pl > 0.00001 ) ) & 4308 THEN 4309 4310 d_pl = SQRT(d_pl) 4311 coll_t = (b_pl - d_pl)/a_pl 4312 IF ( coll_t > 0.0_wp ) THEN 4313 ! 4314 !-- Dummy factor 4315 ddum_f = 1. / ( a_pl * coll_t**2 ) & 4316 * ( 2. / coll_t + 1.0 * d_coll_t_0 ) 4317 ! 4318 !-- x-component of social force 4319 force_x = force_x - k_pl * & 4320 EXP( -coll_t * d_coll_t_0 ) * & 4321 ( v_rel_x - & 4322 ( b_pl * v_rel_x - & 4323 a_pl * pos_rel_x ) / d_pl ) * & 4324 ddum_f 4325 ! 4326 !-- y-component of social force 4327 force_y = force_y - k_pl * & 4328 EXP( -coll_t * d_coll_t_0 ) * & 4329 ( v_rel_y - & 4330 ( b_pl * v_rel_y - & 4331 a_pl * pos_rel_y ) / d_pl ) * & 4332 ddum_f 4333 4334 ENDIF 4335 ENDIF 4336 ENDIF 4337 ENDDO 4338 ENDDO 4339 ENDDO 4340 4341 CASE ( 'walls' ) 4342 4343 srw = scan_radius_wall 4344 corner_found = .FALSE. 4345 ! 4346 !-- find relevant grid boxes (those that could contain topography 4347 !-- within radius) 4348 sc_x_start = (x_a - srw) * ddx 4349 sc_x_end = (x_a + srw) * ddx 4350 sc_y_start = (y_a - srw) * ddx 4351 sc_y_end = (y_a + srw) * ddx 4352 IF ( sc_x_start < nxlg ) sc_x_start = nxlg 4353 IF ( sc_x_end > nxrg ) sc_x_end = nxrg 4354 IF ( sc_y_start < nysg ) sc_y_start = nysg 4355 IF ( sc_y_end > nyng ) sc_y_end = nyng 4356 ! 4357 !-- Find "walls" ( i.e. topography steps (up or down) higher than one 4358 !-- grid box ) that are perpendicular to the agent within the defined 4359 !-- search radius. Such obstacles cannot be passed and a social force 4360 !-- to that effect is applied. 4361 !-- Walls only apply a force perpendicular to the wall to the agent. 4362 !-- There is therefore a search for walls directly right, left, south 4363 !-- and north of the agent. All other walls are ignored. 4364 !-- 4365 !-- Check for wall left of current agent 4366 ij_dum = 0 4367 IF ( sc_x_start < ip ) THEN 4368 DO il = ip - 1, sc_x_start, -1 4369 ! 4370 !-- Going left from the agent, check for a right wall 4371 IF ( BTEST( obstacle_flags(jp,il), 2 ) ) THEN 4372 ! 4373 !-- obstacle found in grid box il, wall at right side 4374 x_wall = (il+1)*dx 4375 ! 4376 !-- Calculate force of found wall on agent 4377 CALL mas_timestep_wall_corner_force( x_a, x_wall, y_a, & 4378 y_a ) 4379 ! 4380 !-- calculate new x starting index for later scan for corners 4381 ij_dum = il + 1 4382 EXIT 4383 ENDIF 4384 ENDDO 4385 ENDIF 4386 IF ( ij_dum /= 0 ) sc_x_start = ij_dum 4387 4388 ! 4389 !-- Check for wall right of current agent 4390 ij_dum = 0 4391 IF ( sc_x_end > ip ) THEN 4392 DO il = ip + 1, sc_x_end 4393 ! 4394 !-- Going right from the agent, check for a left wall 4395 IF ( BTEST( obstacle_flags(jp,il), 6 ) ) THEN 4396 ! 4397 !-- obstacle found in grid box il, wall at left side 4398 x_wall = il*dx 4399 ! 4400 !-- Calculate force of found wall on agent 4401 CALL mas_timestep_wall_corner_force( x_a, x_wall, y_a, & 4402 y_a ) 4403 ! 4404 !-- calculate new x end index for later scan for corners 4405 ij_dum = il - 1 4406 EXIT 4407 ENDIF 4408 ENDDO 4409 ENDIF 4410 IF ( ij_dum /= 0 ) sc_x_end = ij_dum 4411 4412 ! 4413 !-- Check for wall south of current agent 4414 ij_dum = 0 4415 IF ( sc_y_start < jp ) THEN 4416 DO jl = jp - 1, sc_y_start, -1 4417 ! 4418 !-- Going south from the agent, check for a north wall 4419 IF ( BTEST( obstacle_flags(jl,ip), 0 ) ) THEN 4420 ! 4421 !-- obstacle found in grid box jl, wall at left side 4422 y_wall = (jl+1)*dy 4423 4424 CALL mas_timestep_wall_corner_force( x_a, x_a, y_a, & 4425 y_wall ) 4426 ! 4427 !-- calculate new y starting index for later scan for corners 4428 ij_dum = jl + 1 4429 EXIT 4430 ENDIF 4431 ENDDO 4432 ENDIF 4433 IF ( ij_dum /= 0 ) sc_y_start = ij_dum 4434 4435 ! 4436 !-- Check for wall north of current agent 4437 ij_dum = 0 4438 IF ( sc_y_end > jp ) THEN 4439 DO jl = jp + 1, sc_y_end 4440 ! 4441 !-- Going north from the agent, check for a south wall 4442 IF ( BTEST( obstacle_flags(jl,ip), 4 ) ) THEN 4443 ! 4444 !-- obstacle found in grid box jl, wall at left side 4445 y_wall = jl*dy 4446 4447 CALL mas_timestep_wall_corner_force( x_a, x_a, y_a, & 4448 y_wall ) 4449 ! 4450 !-- calculate new y end index for later scan for corners 4451 ij_dum = jl - 1 4452 ENDIF 4453 ENDDO 4454 ENDIF 4455 IF ( ij_dum /= 0 ) sc_y_end = ij_dum 4456 4457 ! 4458 !-- Scan for corners surrounding current agent. 4459 !-- Only gridcells that are closer than the closest wall in each 4460 !-- direction (n,s,r,l) are considered in the search since those 4461 !-- further away would have a significantly smaller resulting force 4462 !-- than the closer wall. 4463 DO il = sc_x_start, sc_x_end 4464 DO jl = sc_y_start, sc_y_end 4465 IF ( il == ip .OR. jl == jp ) CYCLE 4466 ! 4467 !-- corners left of agent 4468 IF ( il < ip ) THEN 4469 ! 4470 !-- south left quadrant: look for north right corner 4471 IF ( jl < jp ) THEN 4472 IF ( BTEST( obstacle_flags(jl,il), 1 ) ) THEN 4473 ! 4474 !-- calculate coordinates of the found corner 4475 x_wall = (il+1)*dx 4476 y_wall = (jl+1)*dy 4477 4478 CALL mas_timestep_wall_corner_force( x_a, x_wall, & 4479 y_a, y_wall ) 4480 4481 ENDIF 4482 ! 4483 !-- north left quadrant: look for south right corner 4484 ELSEIF ( jl > jp ) THEN 4485 IF ( BTEST( obstacle_flags(jl,il), 3 ) ) THEN 4486 ! 4487 !-- calculate coordinates of the corner of said gridcell 4488 !-- that is closest to the current agent 4489 x_wall = (il+1)*dx 4490 y_wall = jl*dy 4491 4492 CALL mas_timestep_wall_corner_force( x_a, x_wall, & 4493 y_a, y_wall ) 4494 4495 ENDIF 4496 ENDIF 4497 ELSEIF ( il > ip ) THEN 4498 ! 4499 !-- south right quadrant: look for north left corner 4500 IF ( jl < jp ) THEN 4501 IF ( BTEST( obstacle_flags(jl,il), 7 ) ) THEN 4502 ! 4503 !-- calculate coordinates of the corner of said gridcell 4504 !-- that is closest to the current agent 4505 x_wall = il*dx 4506 y_wall = (jl+1)*dy 4507 4508 CALL mas_timestep_wall_corner_force( x_a, x_wall, & 4509 y_a, y_wall ) 4510 4511 ENDIF 4512 ! 4513 !-- north right quadrant: look for south left corner 4514 ELSEIF ( jl > jp ) THEN 4515 IF ( BTEST( obstacle_flags(jl,il), 5 ) ) THEN 4516 ! 4517 !-- calculate coordinates of the corner of said gridcell 4518 !-- that is closest to the current agent 4519 x_wall = il*dx 4520 y_wall = jl*dy 4521 4522 CALL mas_timestep_wall_corner_force( x_a, x_wall, & 4523 y_a, y_wall ) 4026 !> Calculates the Social Forces (Helbing and Molnar, 1995) that the agent experiences due to 4027 !> acceleration towards target and repulsion by obstacles 4028 !--------------------------------------------------------------------------------------------------! 4029 SUBROUTINE mas_timestep_social_forces ( mode, nl, ip, jp ) 4030 4031 IMPLICIT NONE 4032 4033 REAL(wp), PARAMETER :: k_pl = 1.5 !< factor for collision avoidance 4034 4035 CHARACTER (LEN=*) :: mode !< identifier for the mode of calculation 4036 4037 INTEGER(iwp) :: ij_dum !< index of nearest wall 4038 INTEGER(iwp) :: il !< index variable along x 4039 INTEGER(iwp) :: ip !< index variable along x 4040 INTEGER(iwp) :: jl !< index variable along y 4041 INTEGER(iwp) :: jp !< index variable along y 4042 INTEGER(iwp) :: nl !< loop variable over all agents in a grid box 4043 INTEGER(iwp) :: no !< loop variable over all agents in a grid box 4044 INTEGER(iwp) :: noa !< amount of agents in a grid box 4045 INTEGER(iwp) :: sc_x_end !< index for scan for topography/other agents 4046 INTEGER(iwp) :: sc_x_start !< index for scan for topography/other agents 4047 INTEGER(iwp) :: sc_y_end !< index for scan for topography/other agents 4048 INTEGER(iwp) :: sc_y_start !< index for scan for topography/other agents 4049 4050 LOGICAL :: corner_found !< flag that indicates a corner has been found near agent 4051 4052 REAL(wp) :: a_pl !< factor for collision avoidance 4053 REAL(wp) :: ax_semimaj !< semiminor axis of repulsive ellipse 4054 REAL(wp) :: b_pl !< factor for collision avoidance 4055 REAL(wp) :: c_pl !< factor for collision avoidance 4056 REAL(wp) :: coll_t !< time at which the next collision would happen 4057 REAL(wp) :: d_coll_t_0 !< inverse of collision cutoff time 4058 REAL(wp) :: d_pl !< factor for collision avoidance 4059 REAL(wp) :: ddum_f !< dummy devisor collision avoidance 4060 REAL(wp) :: dist !< distance to obstacle 4061 REAL(wp) :: dist_sq !< distance to obstacle squared 4062 REAL(wp) :: pos_rel_x !< relative position of two agents (x) 4063 REAL(wp) :: pos_rel_y !< relative position of two agents (y) 4064 REAL(wp) :: r_sq !< y-position 4065 REAL(wp) :: sra !< scan radius (agents) 4066 REAL(wp) :: srw !< local variable for scan radius (walls) 4067 REAL(wp) :: v_rel_x !< relative velocity (x); collision avoidance 4068 REAL(wp) :: v_rel_y !< relative velocity (y); collision avoidance 4069 REAL(wp) :: x_a !< x-position 4070 REAL(wp) :: x_wall !< x-position of wall 4071 REAL(wp) :: y_a !< y-position 4072 REAL(wp) :: y_wall !< y-position of wall 4073 4074 TYPE(agent_type), DIMENSION(:), POINTER :: l_agts !< agents that repulse current agent 4075 4076 ! 4077 !-- Initialization 4078 x_a = agents(nl)%x 4079 y_a = agents(nl)%y 4080 4081 SELECT CASE ( TRIM( mode ) ) 4082 ! 4083 !-- Calculation of force due to agent trying to approach desired velocity 4084 CASE ( 'acceleration' ) 4085 4086 force_x = force_x + d_tau_accel_agent & 4087 * ( agents(nl)%speed_des*agents(nl)%speed_e_x - agents(nl)%speed_x ) 4088 4089 force_y = force_y + d_tau_accel_agent & 4090 * ( agents(nl)%speed_des*agents(nl)%speed_e_y - agents(nl)%speed_y ) 4091 4092 ! 4093 !-- Calculation of repulsive forces by other agents in a radius around the current one 4094 CASE ( 'other_agents' ) 4095 4096 sra = scan_radius_agent 4097 d_coll_t_0 = 1./coll_t_0 4098 ! 4099 !-- Find relevant gridboxes (those that could contain agents within scan radius) 4100 sc_x_start = FLOOR( (x_a - sra) * ddx ) 4101 sc_x_end = FLOOR( (x_a + sra) * ddx ) 4102 sc_y_start = FLOOR( (y_a - sra) * ddx ) 4103 sc_y_end = FLOOR( (y_a + sra) * ddx ) 4104 IF ( sc_x_start < nxlg ) sc_x_start = nxlg 4105 IF ( sc_x_end > nxrg ) sc_x_end = nxrg 4106 IF ( sc_y_start < nysg ) sc_y_start = nysg 4107 IF ( sc_y_end > nyng ) sc_y_end = nyng 4108 4109 sra = sra**2 4110 ! 4111 !-- Loop over all previously found relevant gridboxes 4112 DO il = sc_x_start, sc_x_end 4113 DO jl = sc_y_start, sc_y_end 4114 noa = agt_count(jl,il) 4115 IF ( noa <= 0 ) CYCLE 4116 l_agts => grid_agents(jl,il)%agents(1:noa) 4117 DO no = 1, noa 4118 ! 4119 !-- Skip self 4120 IF ( jl == jp .AND. il == ip .AND. no == nl ) CYCLE 4121 pos_rel_x = l_agts(no)%x - x_a 4122 pos_rel_y = l_agts(no)%y - y_a 4123 dist_sq = pos_rel_x**2 + pos_rel_y**2 4124 IF ( dist_sq > sra ) CYCLE 4125 r_sq = (2*radius_agent)**2 4126 v_rel_x = agents(nl)%speed_x - l_agts(no)%speed_x 4127 v_rel_y = agents(nl)%speed_y - l_agts(no)%speed_y 4128 ! 4129 !-- Collision is already occuring, default to standard social forces. 4130 IF ( dist_sq <= r_sq ) THEN 4131 dist = SQRT( dist_sq ) + 1.0d-12 4132 ax_semimaj = 0.5_wp * SQRT( dist ) 4133 4134 force_x = force_x - 0.125_wp * repuls_agent & 4135 * d_sigma_rep_agent / ax_semimaj & 4136 * EXP( - ax_semimaj * d_sigma_rep_agent ) & 4137 * ( pos_rel_x / dist ) 4138 4139 force_y = force_y - 0.125_wp * repuls_agent & 4140 * d_sigma_rep_agent / ax_semimaj & 4141 * EXP( - ax_semimaj * d_sigma_rep_agent ) & 4142 * ( pos_rel_y / dist ) 4143 ! 4144 !-- Currently no collision, calculate collision avoidance force according to 4145 !-- Karamouzas et al (2014, PRL 113,238701) 4146 ELSE 4147 ! 4148 !-- Factors 4149 a_pl = v_rel_x**2 + v_rel_y**2 4150 b_pl = pos_rel_x*v_rel_x + pos_rel_y*v_rel_y 4151 c_pl = dist_sq - r_sq 4152 d_pl = b_pl**2 - a_pl*c_pl 4153 ! 4154 !-- If the two agents are moving non-parallel, calculate collision avoidance 4155 !-- social force 4156 IF ( d_pl > 0.0_wp .AND. ( a_pl < -0.00001 .OR. a_pl > 0.00001 ) ) THEN 4157 4158 d_pl = SQRT( d_pl ) 4159 coll_t = ( b_pl - d_pl ) / a_pl 4160 IF ( coll_t > 0.0_wp ) THEN 4161 ! 4162 !-- Dummy factor 4163 ddum_f = 1. / ( a_pl * coll_t**2 ) * ( 2. / coll_t + 1.0 * d_coll_t_0 ) 4164 ! 4165 !-- x-component of social force 4166 force_x = force_x - k_pl * EXP( -coll_t * d_coll_t_0 ) * & 4167 ( v_rel_x - ( b_pl * v_rel_x - a_pl * pos_rel_x ) / d_pl ) * & 4168 ddum_f 4169 ! 4170 !-- y-component of social force 4171 force_y = force_y - k_pl * EXP( -coll_t * d_coll_t_0 ) * & 4172 ( v_rel_y - ( b_pl * v_rel_y - a_pl * pos_rel_y ) / d_pl ) * & 4173 ddum_f 4524 4174 4525 4175 ENDIF … … 4528 4178 ENDDO 4529 4179 ENDDO 4530 4531 CASE DEFAULT 4532 4533 END SELECT 4534 4535 END SUBROUTINE mas_timestep_social_forces 4536 4537 !------------------------------------------------------------------------------! 4180 ENDDO 4181 4182 CASE ( 'walls' ) 4183 4184 srw = scan_radius_wall 4185 corner_found = .FALSE. 4186 ! 4187 !-- Find relevant grid boxes (those that could contain topography within radius) 4188 sc_x_start = (x_a - srw) * ddx 4189 sc_x_end = (x_a + srw) * ddx 4190 sc_y_start = (y_a - srw) * ddx 4191 sc_y_end = (y_a + srw) * ddx 4192 IF ( sc_x_start < nxlg ) sc_x_start = nxlg 4193 IF ( sc_x_end > nxrg ) sc_x_end = nxrg 4194 IF ( sc_y_start < nysg ) sc_y_start = nysg 4195 IF ( sc_y_end > nyng ) sc_y_end = nyng 4196 ! 4197 !-- Find "walls" ( i.e. topography steps (up or down) higher than one grid box ) that are 4198 !-- perpendicular to the agent within the defined search radius. Such obstacles cannot be 4199 !-- passed and a social force to that effect is applied. 4200 !-- Walls only apply a force perpendicular to the wall to the agent. 4201 !-- There is therefore a search for walls directly right, left, south and north of the agent. 4202 !-- All other walls are ignored. 4203 !-- 4204 !-- Check for wall left of current agent 4205 ij_dum = 0 4206 IF ( sc_x_start < ip ) THEN 4207 DO il = ip - 1, sc_x_start, -1 4208 ! 4209 !-- Going left from the agent, check for a right wall 4210 IF ( BTEST( obstacle_flags(jp,il), 2 ) ) THEN 4211 ! 4212 !-- Obstacle found in grid box il, wall at right side 4213 x_wall = (il+1)*dx 4214 ! 4215 !-- Calculate force of found wall on agent 4216 CALL mas_timestep_wall_corner_force( x_a, x_wall, y_a, y_a ) 4217 ! 4218 !-- Calculate new x starting index for later scan for corners 4219 ij_dum = il + 1 4220 EXIT 4221 ENDIF 4222 ENDDO 4223 ENDIF 4224 IF ( ij_dum /= 0 ) sc_x_start = ij_dum 4225 4226 ! 4227 !-- Check for wall right of current agent 4228 ij_dum = 0 4229 IF ( sc_x_end > ip ) THEN 4230 DO il = ip + 1, sc_x_end 4231 ! 4232 !-- Going right from the agent, check for a left wall 4233 IF ( BTEST( obstacle_flags(jp,il), 6 ) ) THEN 4234 ! 4235 !-- Obstacle found in grid box il, wall at left side 4236 x_wall = il*dx 4237 ! 4238 !-- Calculate force of found wall on agent 4239 CALL mas_timestep_wall_corner_force( x_a, x_wall, y_a, y_a ) 4240 ! 4241 !-- Calculate new x end index for later scan for corners 4242 ij_dum = il - 1 4243 EXIT 4244 ENDIF 4245 ENDDO 4246 ENDIF 4247 IF ( ij_dum /= 0 ) sc_x_end = ij_dum 4248 4249 ! 4250 !-- Check for wall south of current agent 4251 ij_dum = 0 4252 IF ( sc_y_start < jp ) THEN 4253 DO jl = jp - 1, sc_y_start, -1 4254 ! 4255 !-- Going south from the agent, check for a north wall 4256 IF ( BTEST( obstacle_flags(jl,ip), 0 ) ) THEN 4257 ! 4258 !-- Obstacle found in grid box jl, wall at left side 4259 y_wall = ( jl + 1 ) * dy 4260 4261 CALL mas_timestep_wall_corner_force( x_a, x_a, y_a, y_wall ) 4262 ! 4263 !-- Calculate new y starting index for later scan for corners 4264 ij_dum = jl + 1 4265 EXIT 4266 ENDIF 4267 ENDDO 4268 ENDIF 4269 IF ( ij_dum /= 0 ) sc_y_start = ij_dum 4270 4271 ! 4272 !-- Check for wall north of current agent 4273 ij_dum = 0 4274 IF ( sc_y_end > jp ) THEN 4275 DO jl = jp + 1, sc_y_end 4276 ! 4277 !-- Going north from the agent, check for a south wall 4278 IF ( BTEST( obstacle_flags(jl,ip), 4 ) ) THEN 4279 ! 4280 !-- obstacle found in grid box jl, wall at left side 4281 y_wall = jl * dy 4282 4283 CALL mas_timestep_wall_corner_force( x_a, x_a, y_a, y_wall ) 4284 ! 4285 !-- Calculate new y end index for later scan for corners 4286 ij_dum = jl - 1 4287 ENDIF 4288 ENDDO 4289 ENDIF 4290 IF ( ij_dum /= 0 ) sc_y_end = ij_dum 4291 4292 ! 4293 !-- Scan for corners surrounding current agent. 4294 !-- Only gridcells that are closer than the closest wall in each direction (n,s,r,l) are 4295 !-- considered in the search since those further away would have a significantly smaller 4296 !-- resulting force than the closer wall. 4297 DO il = sc_x_start, sc_x_end 4298 DO jl = sc_y_start, sc_y_end 4299 IF ( il == ip .OR. jl == jp ) CYCLE 4300 ! 4301 !-- Corners left of agent 4302 IF ( il < ip ) THEN 4303 ! 4304 !-- South left quadrant: look for north right corner 4305 IF ( jl < jp ) THEN 4306 IF ( BTEST( obstacle_flags(jl,il), 1 ) ) THEN 4307 ! 4308 !-- Calculate coordinates of the found corner 4309 x_wall = ( il + 1 ) * dx 4310 y_wall = ( jl + 1 ) * dy 4311 4312 CALL mas_timestep_wall_corner_force( x_a, x_wall, y_a, y_wall ) 4313 4314 ENDIF 4315 ! 4316 !-- North left quadrant: look for south right corner 4317 ELSEIF ( jl > jp ) THEN 4318 IF ( BTEST( obstacle_flags(jl,il), 3 ) ) THEN 4319 ! 4320 !-- Calculate coordinates of the corner of mentioned gridcell that is closest 4321 !-- to the current agent. 4322 x_wall = ( il + 1 ) * dx 4323 y_wall = jl * dy 4324 4325 CALL mas_timestep_wall_corner_force( x_a, x_wall, y_a, y_wall ) 4326 4327 ENDIF 4328 ENDIF 4329 ELSEIF ( il > ip ) THEN 4330 ! 4331 !-- South right quadrant: look for north left corner 4332 IF ( jl < jp ) THEN 4333 IF ( BTEST( obstacle_flags(jl,il), 7 ) ) THEN 4334 ! 4335 !-- Calculate coordinates of the corner of mentioned gridcell that is closest 4336 !-- to the current agent. 4337 x_wall = il * dx 4338 y_wall = ( jl + 1 ) * dy 4339 4340 CALL mas_timestep_wall_corner_force( x_a, x_wall, y_a, y_wall ) 4341 4342 ENDIF 4343 ! 4344 !-- North right quadrant: look for south left corner 4345 ELSEIF ( jl > jp ) THEN 4346 IF ( BTEST( obstacle_flags(jl,il), 5 ) ) THEN 4347 ! 4348 !-- Calculate coordinates of the corner of mentioned gridcell that is closest 4349 !-- to the current agent. 4350 x_wall = il * dx 4351 y_wall = jl * dy 4352 4353 CALL mas_timestep_wall_corner_force( x_a, x_wall, y_a, y_wall ) 4354 4355 ENDIF 4356 ENDIF 4357 ENDIF 4358 ENDDO 4359 ENDDO 4360 4361 CASE DEFAULT 4362 4363 END SELECT 4364 4365 END SUBROUTINE mas_timestep_social_forces 4366 4367 !--------------------------------------------------------------------------------------------------! 4538 4368 ! Description: 4539 4369 ! ------------ 4540 !> Given a distance to the current agent, calculates the force a found corner 4541 !> or wall exerts on that agent 4542 !------------------------------------------------------------------------------! 4543 SUBROUTINE mas_timestep_wall_corner_force( xa, xw, ya, yw ) 4544 4545 IMPLICIT NONE 4546 4547 REAL(wp) :: dist_l !< distance to obstacle 4548 REAL(wp) :: force_d_x !< increment of social force, x-direction 4549 REAL(wp) :: force_d_y !< increment of social force, x-direction 4550 REAL(wp) :: xa !< x-position of agent 4551 REAL(wp) :: xw !< x-position of wall 4552 REAL(wp) :: ya !< x-position of agent 4553 REAL(wp) :: yw !< y-position of wall 4554 4555 force_d_x = 0.0_wp 4556 force_d_y = 0.0_wp 4557 ! 4558 !-- calculate coordinates of corner relative to agent 4559 !-- postion and distance between corner and agent 4560 xw = xa - xw 4561 yw = ya - yw 4562 dist_l = SQRT( (xw)**2 + (yw)**2 ) 4563 ! 4564 !-- calculate x and y component of repulsive force 4565 !-- induced by previously found corner 4566 IF ( dist_l > 0 ) THEN 4567 force_d_x = repuls_wall * d_sigma_rep_wall & 4568 * EXP( -dist_l * d_sigma_rep_wall ) & 4569 * xw / (dist_l) 4570 force_d_y = repuls_wall * d_sigma_rep_wall & 4571 * EXP( -dist_l * d_sigma_rep_wall ) & 4572 * yw / (dist_l) 4573 ENDIF 4574 4575 ! !-- forces that are located outside of a sight radius of 4370 !> Given a distance to the current agent, calculates the force a found corner or wall exerts on that 4371 !> agent 4372 !--------------------------------------------------------------------------------------------------! 4373 SUBROUTINE mas_timestep_wall_corner_force( xa, xw, ya, yw ) 4374 4375 IMPLICIT NONE 4376 4377 REAL(wp) :: dist_l !< distance to obstacle 4378 REAL(wp) :: force_d_x !< increment of social force, x-direction 4379 REAL(wp) :: force_d_y !< increment of social force, x-direction 4380 REAL(wp) :: xa !< x-position of agent 4381 REAL(wp) :: xw !< x-position of wall 4382 REAL(wp) :: ya !< x-position of agent 4383 REAL(wp) :: yw !< y-position of wall 4384 4385 force_d_x = 0.0_wp 4386 force_d_y = 0.0_wp 4387 ! 4388 !-- Calculate coordinates of corner relative to agent postion and distance between corner and agent. 4389 xw = xa - xw 4390 yw = ya - yw 4391 dist_l = SQRT( ( xw )**2 + ( yw )**2 ) 4392 ! 4393 !-- Calculate x and y component of repulsive force induced by previously found corner 4394 IF ( dist_l > 0 ) THEN 4395 force_d_x = repuls_wall * d_sigma_rep_wall & 4396 * EXP( -dist_l * d_sigma_rep_wall ) & 4397 * xw / (dist_l) 4398 force_d_y = repuls_wall * d_sigma_rep_wall & 4399 * EXP( -dist_l * d_sigma_rep_wall ) & 4400 * yw / (dist_l) 4401 ENDIF 4402 4403 ! !-- forces that are located outside of a sight radius of 4576 4404 ! !-- 200 degrees (-> COS(100./180.*pi) = COS(.555*pi)) of 4577 4405 ! !-- current agent are considered to have an effect of 50% … … 4586 4414 4587 4415 ! 4588 !-- add force increment to total force of current agent 4589 force_x = force_x + force_d_x 4590 force_y = force_y + force_d_y 4591 4592 END SUBROUTINE mas_timestep_wall_corner_force 4593 4594 ! 4595 !-- Calculates distance of point P to edge (A,B). If A = B, calculates 4596 !-- point-to-point distance from A/B to P 4597 FUNCTION dist_point_to_edge ( a_x, a_y, b_x, b_y, p_x, p_y ) 4598 4599 IMPLICIT NONE 4600 4601 REAL(wp) :: ab_x !< x-coordinate of vector from A to B 4602 REAL(wp) :: ab_y !< y-coordinate of vector from A to B 4603 REAL(wp) :: ab_d !< inverse length of vector from A to B 4604 REAL(wp) :: ab_u_x !< x-coordinate of vector with direction of ab and length 1 4605 REAL(wp) :: ab_u_y !< y-coordinate of vector with direction of ab and length 1 4606 REAL(wp) :: ba_x !< x-coordinate of vector from B to A 4607 REAL(wp) :: ba_y !< y-coordinate of vector from B to A 4608 REAL(wp) :: ap_x !< x-coordinate of vector from A to P 4609 REAL(wp) :: ap_y !< y-coordinate of vector from A to P 4610 REAL(wp) :: bp_x !< x-coordinate of vector from B to P 4611 REAL(wp) :: bp_y !< y-coordinate of vector from B to P 4612 REAL(wp) :: a_x !< x-coordinate of point A of edge 4613 REAL(wp) :: a_y !< y-coordinate of point A of edge 4614 REAL(wp) :: b_x !< x-coordinate of point B of edge 4615 REAL(wp) :: b_y !< y-coordinate of point B of edge 4616 REAL(wp) :: p_x !< x-coordinate of point P 4617 REAL(wp) :: p_y !< y-coordinate of point P 4618 REAL(wp) :: dist_x !< x-coordinate of point P 4619 REAL(wp) :: dist_y !< y-coordinate of point P 4620 REAL(wp) :: dist_point_to_edge !< y-coordinate of point P 4621 4622 ab_x = - a_x + b_x 4623 ab_y = - a_y + b_y 4624 ba_x = - b_x + a_x 4625 ba_y = - b_y + a_y 4626 ap_x = - a_x + p_x 4627 ap_y = - a_y + p_y 4628 bp_x = - b_x + p_x 4629 bp_y = - b_y + p_y 4630 4631 IF ( ab_x * ap_x + ab_y * ap_y <= 0. ) THEN 4632 dist_point_to_edge = SQRT((a_x - p_x)**2 + (a_y - p_y)**2) 4633 ELSEIF ( ba_x * bp_x + ba_y * bp_y <= 0. ) THEN 4634 dist_point_to_edge = SQRT((b_x - p_x)**2 + (b_y - p_y)**2) 4635 ELSE 4636 ab_d = 1./SQRT((ab_x)**2+(ab_y)**2) 4637 ab_u_x = ab_x*ab_d 4638 ab_u_y = ab_y*ab_d 4639 dist_x = ap_x - (ap_x*ab_u_x+ap_y*ab_u_y)*ab_u_x 4640 dist_y = ap_y - (ap_x*ab_u_x+ap_y*ab_u_y)*ab_u_y 4641 dist_point_to_edge = SQRT( dist_x**2 + dist_y**2 ) 4416 !-- Add force increment to total force of current agent 4417 force_x = force_x + force_d_x 4418 force_y = force_y + force_d_y 4419 4420 END SUBROUTINE mas_timestep_wall_corner_force 4421 4422 4423 ! 4424 !-- Calculates distance of point P to edge (A,B). If A = B, calculates point-to-point distance from 4425 !-- A/B to P. 4426 FUNCTION dist_point_to_edge( a_x, a_y, b_x, b_y, p_x, p_y ) 4427 4428 IMPLICIT NONE 4429 4430 REAL(wp) :: a_x !< x-coordinate of point A of edge 4431 REAL(wp) :: a_y !< y-coordinate of point A of edge 4432 REAL(wp) :: ab_x !< x-coordinate of vector from A to B 4433 REAL(wp) :: ab_y !< y-coordinate of vector from A to B 4434 REAL(wp) :: ab_d !< inverse length of vector from A to B 4435 REAL(wp) :: ab_u_x !< x-coordinate of vector with direction of ab and length 1 4436 REAL(wp) :: ab_u_y !< y-coordinate of vector with direction of ab and length 1 4437 REAL(wp) :: ap_x !< x-coordinate of vector from A to P 4438 REAL(wp) :: ap_y !< y-coordinate of vector from A to P 4439 REAL(wp) :: b_x !< x-coordinate of point B of edge 4440 REAL(wp) :: b_y !< y-coordinate of point B of edge 4441 REAL(wp) :: ba_x !< x-coordinate of vector from B to A 4442 REAL(wp) :: ba_y !< y-coordinate of vector from B to A 4443 REAL(wp) :: bp_x !< x-coordinate of vector from B to P 4444 REAL(wp) :: bp_y !< y-coordinate of vector from B to P 4445 REAL(wp) :: dist_x !< x-coordinate of point P 4446 REAL(wp) :: dist_y !< y-coordinate of point P 4447 REAL(wp) :: dist_point_to_edge !< y-coordinate of point P 4448 REAL(wp) :: p_x !< x-coordinate of point P 4449 REAL(wp) :: p_y !< y-coordinate of point P 4450 4451 ab_x = - a_x + b_x 4452 ab_y = - a_y + b_y 4453 ba_x = - b_x + a_x 4454 ba_y = - b_y + a_y 4455 ap_x = - a_x + p_x 4456 ap_y = - a_y + p_y 4457 bp_x = - b_x + p_x 4458 bp_y = - b_y + p_y 4459 4460 IF ( ab_x * ap_x + ab_y * ap_y <= 0. ) THEN 4461 dist_point_to_edge = SQRT( ( a_x - p_x )**2 + ( a_y - p_y )**2 ) 4462 ELSEIF ( ba_x * bp_x + ba_y * bp_y <= 0. ) THEN 4463 dist_point_to_edge = SQRT( ( b_x - p_x )**2 + ( b_y - p_y )**2) 4464 ELSE 4465 ab_d = 1.0_wp / SQRT( ( ab_x )**2 + ( ab_y )**2 ) 4466 ab_u_x = ab_x * ab_d 4467 ab_u_y = ab_y * ab_d 4468 dist_x = ap_x - ( ap_x * ab_u_x + ap_y * ab_u_y ) * ab_u_x 4469 dist_y = ap_y - ( ap_x * ab_u_x + ap_y * ab_u_y ) * ab_u_y 4470 dist_point_to_edge = SQRT( dist_x**2 + dist_y**2 ) 4471 ENDIF 4472 4473 END FUNCTION dist_point_to_edge 4474 4475 ! 4476 !-- Returns the heuristic between points A and B (currently the straight distance) 4477 FUNCTION heuristic( ax, ay, bx, by ) 4478 4479 IMPLICIT NONE 4480 4481 REAL(wp) :: ax !< x-coordinate of point A 4482 REAL(wp) :: ay !< y-coordinate of point A 4483 REAL(wp) :: bx !< x-coordinate of point B 4484 REAL(wp) :: by !< y-coordinate of point B 4485 REAL(wp) :: heuristic !< return value 4486 4487 heuristic = SQRT( ( ax - bx )**2 + ( ay - by )**2 ) 4488 4489 END FUNCTION heuristic 4490 4491 ! 4492 !-- Calculates if point P is left of the infinite line that contains A and B (direction: A to B). 4493 !-- Concept: 2D rotation of two vectors 4494 FUNCTION is_left( ax, ay, bx, by, px, py ) 4495 4496 IMPLICIT NONE 4497 4498 LOGICAL :: is_left !< return value; TRUE if P is left of AB 4499 4500 REAL(wp) :: ax !< x-coordinate of point A 4501 REAL(wp) :: ay !< y-coordinate of point A 4502 REAL(wp) :: bx !< x-coordinate of point B 4503 REAL(wp) :: by !< y-coordinate of point B 4504 REAL(wp) :: px !< x-coordinate of point P 4505 REAL(wp) :: py !< y-coordinate of point P 4506 4507 is_left = (bx-ax)*(py-ay)-(px-ax)*(by-ay) > 0 4508 IF ( ( ABS( ax - px ) < .001 .AND. ABS( ay - py ) < .001 ) .OR. & 4509 ( ABS( bx - px ) < .001 .AND. ABS( by - py ) < .001) ) & 4510 THEN 4511 is_left = .FALSE. 4512 ENDIF 4513 4514 END FUNCTION is_left 4515 4516 ! 4517 !-- Calculates if point P is right of the infinite line that contains A and B (direction: A to B) 4518 !-- Concept: 2D rotation of two vectors 4519 FUNCTION is_right( ax, ay, bx, by, px, py ) 4520 4521 IMPLICIT NONE 4522 4523 LOGICAL :: is_right !< return value; TRUE if P is right of AB 4524 4525 REAL(wp), INTENT(IN) :: ax !< x-coordinate of point A 4526 REAL(wp), INTENT(IN) :: ay !< y-coordinate of point A 4527 REAL(wp), INTENT(IN) :: bx !< x-coordinate of point B 4528 REAL(wp), INTENT(IN) :: by !< y-coordinate of point B 4529 REAL(wp), INTENT(IN) :: px !< x-coordinate of point P 4530 REAL(wp), INTENT(IN) :: py !< y-coordinate of point P 4531 4532 is_right = (bx-ax)*(py-ay)-(px-ax)*(by-ay) < 0 4533 IF ( ( ABS( ax - px ) < 0.001_wp .AND. ABS( ay - py ) < 0.001_wp ) .OR. & 4534 ( ABS( bx - px ) < 0.001_wp .AND. ABS( by - py ) < 0.001_wp ) ) & 4535 THEN 4536 is_right = .FALSE. 4537 ENDIF 4538 4539 END FUNCTION is_right 4540 4541 ! 4542 !-- Returns true if the line segments AB and PQ share an intersection 4543 FUNCTION intersect( ax, ay, bx, by, px, py, qx, qy ) 4544 4545 IMPLICIT NONE 4546 4547 LOGICAL :: intersect !< return value; TRUE if intersection was found 4548 LOGICAL :: la !< T if a is left of PQ 4549 LOGICAL :: lb !< T if b is left of PQ 4550 LOGICAL :: lp !< T if p is left of AB 4551 LOGICAL :: lq !< T if q is left of AB 4552 LOGICAL :: poss !< flag that indicates if an intersection is still possible 4553 LOGICAL :: ra !< T if a is right of PQ 4554 LOGICAL :: rb !< T if b is right of PQ 4555 LOGICAL :: rp !< T if p is right of AB 4556 LOGICAL :: rq !< T if q is right of AB 4557 4558 REAL(wp) :: ax !< x-coordinate of point A 4559 REAL(wp) :: ay !< y-coordinate of point A 4560 REAL(wp) :: bx !< x-coordinate of point B 4561 REAL(wp) :: by !< y-coordinate of point B 4562 REAL(wp) :: px !< x-coordinate of point P 4563 REAL(wp) :: py !< y-coordinate of point P 4564 REAL(wp) :: qx !< x-coordinate of point Q 4565 REAL(wp) :: qy !< y-coordinate of point Q 4566 4567 intersect = .FALSE. 4568 poss = .FALSE. 4569 ! 4570 !-- Intersection is possible only if P and Q are on opposing sides of AB 4571 lp = is_left(ax,ay,bx,by,px,py) 4572 rq = is_right(ax,ay,bx,by,qx,qy) 4573 IF ( lp .AND. rq ) poss = .TRUE. 4574 IF ( .NOT. poss ) THEN 4575 lq = is_left(ax,ay,bx,by,qx,qy) 4576 rp = is_right(ax,ay,bx,by,px,py) 4577 IF ( lq .AND. rp ) poss = .TRUE. 4578 ENDIF 4579 ! 4580 !-- Intersection occurs only if above test (poss) was true AND A and B are on opposing sides of PQ. 4581 IF ( poss ) THEN 4582 la = is_left(px,py,qx,qy,ax,ay) 4583 rb = is_right(px,py,qx,qy,bx,by) 4584 IF ( la .AND. rb ) intersect = .TRUE. 4585 IF ( .NOT. intersect ) THEN 4586 lb = is_left(px,py,qx,qy,bx,by) 4587 ra = is_right(px,py,qx,qy,ax,ay) 4588 IF ( lb .AND. ra ) intersect = .TRUE. 4642 4589 ENDIF 4643 4644 END FUNCTION dist_point_to_edge 4645 4646 ! 4647 !-- Returns the heuristic between points A and B (currently the straight 4648 !-- distance) 4649 FUNCTION heuristic ( ax, ay, bx, by ) 4650 4651 IMPLICIT NONE 4652 4653 REAL(wp) :: ax !< x-coordinate of point A 4654 REAL(wp) :: ay !< y-coordinate of point A 4655 REAL(wp) :: bx !< x-coordinate of point B 4656 REAL(wp) :: by !< y-coordinate of point B 4657 REAL(wp) :: heuristic !< return value 4658 4659 heuristic = SQRT(( ax - bx )**2 + ( ay - by )**2) 4660 4661 END FUNCTION heuristic 4662 4663 ! 4664 !-- Calculates if point P is left of the infinite 4665 !-- line that contains A and B (direction: A to B) 4666 !-- Concept: 2D rotation of two vectors 4667 FUNCTION is_left ( ax, ay, bx, by, px, py ) 4668 4669 IMPLICIT NONE 4670 4671 LOGICAL :: is_left !< return value; TRUE if P is left of AB 4672 4673 REAL(wp) :: ax !< x-coordinate of point A 4674 REAL(wp) :: ay !< y-coordinate of point A 4675 REAL(wp) :: bx !< x-coordinate of point B 4676 REAL(wp) :: by !< y-coordinate of point B 4677 REAL(wp) :: px !< x-coordinate of point P 4678 REAL(wp) :: py !< y-coordinate of point P 4679 4680 is_left = (bx-ax)*(py-ay)-(px-ax)*(by-ay) > 0 4681 IF ( (ABS(ax-px) < .001 .AND. ABS(ay-py) < .001) .OR. & 4682 (ABS(bx-px) < .001 .AND. ABS(by-py) < .001) ) & 4683 THEN 4684 is_left = .FALSE. 4685 ENDIF 4686 4687 RETURN 4688 4689 END FUNCTION is_left 4690 4691 ! 4692 !-- Calculates if point P is right of the infinite 4693 !-- line that contains A and B (direction: A to B) 4694 !-- Concept: 2D rotation of two vectors 4695 FUNCTION is_right ( ax, ay, bx, by, px, py ) 4696 4697 IMPLICIT NONE 4698 4699 LOGICAL :: is_right !< return value; TRUE if P is right of AB 4700 4701 REAL(wp), INTENT(IN) :: ax !< x-coordinate of point A 4702 REAL(wp), INTENT(IN) :: ay !< y-coordinate of point A 4703 REAL(wp), INTENT(IN) :: bx !< x-coordinate of point B 4704 REAL(wp), INTENT(IN) :: by !< y-coordinate of point B 4705 REAL(wp), INTENT(IN) :: px !< x-coordinate of point P 4706 REAL(wp), INTENT(IN) :: py !< y-coordinate of point P 4707 4708 is_right = (bx-ax)*(py-ay)-(px-ax)*(by-ay) < 0 4709 IF ( (ABS(ax-px) < .001 .AND. ABS(ay-py) < .001) .OR. & 4710 (ABS(bx-px) < .001 .AND. ABS(by-py) < .001) ) & 4711 THEN 4712 is_right = .FALSE. 4713 ENDIF 4714 4715 RETURN 4716 4717 END FUNCTION is_right 4718 4719 ! 4720 !-- Returns true if the line segments AB and PQ share an intersection 4721 FUNCTION intersect ( ax, ay, bx, by, px, py, qx, qy ) 4722 4723 IMPLICIT NONE 4724 4725 LOGICAL :: intersect !< return value; TRUE if intersection was found 4726 LOGICAL :: la !< T if a is left of PQ 4727 LOGICAL :: lb !< T if b is left of PQ 4728 LOGICAL :: lp !< T if p is left of AB 4729 LOGICAL :: lq !< T if q is left of AB 4730 LOGICAL :: poss !< flag that indicates if an intersection is still possible 4731 LOGICAL :: ra !< T if a is right of PQ 4732 LOGICAL :: rb !< T if b is right of PQ 4733 LOGICAL :: rp !< T if p is right of AB 4734 LOGICAL :: rq !< T if q is right of AB 4735 4736 REAL(wp) :: ax !< x-coordinate of point A 4737 REAL(wp) :: ay !< y-coordinate of point A 4738 REAL(wp) :: bx !< x-coordinate of point B 4739 REAL(wp) :: by !< y-coordinate of point B 4740 REAL(wp) :: px !< x-coordinate of point P 4741 REAL(wp) :: py !< y-coordinate of point P 4742 REAL(wp) :: qx !< x-coordinate of point Q 4743 REAL(wp) :: qy !< y-coordinate of point Q 4744 4745 intersect = .FALSE. 4746 poss = .FALSE. 4747 ! 4748 !-- Intersection is possible only if P and Q are on opposing sides of AB 4749 lp = is_left(ax,ay,bx,by,px,py) 4750 rq = is_right(ax,ay,bx,by,qx,qy) 4751 IF ( lp .AND. rq ) poss = .TRUE. 4752 IF ( .NOT. poss ) THEN 4753 lq = is_left(ax,ay,bx,by,qx,qy) 4754 rp = is_right(ax,ay,bx,by,px,py) 4755 IF ( lq .AND. rp ) poss = .TRUE. 4756 ENDIF 4757 ! 4758 !-- Intersection occurs only if above test (poss) was true AND 4759 !-- A and B are on opposing sides of PQ 4760 IF ( poss ) THEN 4761 la = is_left(px,py,qx,qy,ax,ay) 4762 rb = is_right(px,py,qx,qy,bx,by) 4763 IF ( la .AND. rb ) intersect = .TRUE. 4764 IF ( .NOT. intersect ) THEN 4765 lb = is_left(px,py,qx,qy,bx,by) 4766 ra = is_right(px,py,qx,qy,ax,ay) 4767 IF ( lb .AND. ra ) intersect = .TRUE. 4768 ENDIF 4769 ENDIF 4770 4771 RETURN 4772 4773 END FUNCTION intersect 4590 ENDIF 4591 4592 END FUNCTION intersect 4774 4593 4775 4594 ! 4776 4595 !-- Gives a nuber randomly distributed around an average 4777 FUNCTION random_normal( avg, variation )4778 4779 4780 4781 4782 REAL(wp) :: variation!< y-coordinate of vector from A to B4783 REAL(wp) :: random_normal!< y-coordinate of vector from A to B4784 4785 4786 4787 CALL RANDOM_NUMBER(random_arr)4788 random_normal = avg + variation*(SUM(random_arr)-6.)4789 4790 4596 FUNCTION random_normal( avg, variation ) 4597 4598 IMPLICIT NONE 4599 4600 REAL(wp) :: avg !< x-coordinate of vector from A to B 4601 REAL(wp) :: random_normal !< y-coordinate of vector from A to B 4602 REAL(wp) :: variation !< y-coordinate of vector from A to B 4603 4604 REAL(wp), DIMENSION(12) :: random_arr !< inverse length of vector from A to B 4605 4606 CALL RANDOM_NUMBER( random_arr ) 4607 random_normal = avg + variation * ( SUM( random_arr ) - 6.0_wp ) 4608 4609 END FUNCTION random_normal 4791 4610 4792 4611
Note: See TracChangeset
for help on using the changeset viewer.
