Changeset 4753 for palm/trunk/SOURCE/multi_agent_system_mod.f90
- Timestamp:
- Oct 21, 2020 2:55:41 PM (4 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
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.