1!/*****************************************************************************/ 2! * 3! * Elmer, A Finite Element Software for Multiphysical Problems 4! * 5! * Copyright 1st April 1995 - , CSC - IT Center for Science Ltd., Finland 6! * 7! * This library is free software; you can redistribute it and/or 8! * modify it under the terms of the GNU Lesser General Public 9! * License as published by the Free Software Foundation; either 10! * version 2.1 of the License, or (at your option) any later version. 11! * 12! * This library is distributed in the hope that it will be useful, 13! * but WITHOUT ANY WARRANTY; without even the implied warranty of 14! * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 15! * Lesser General Public License for more details. 16! * 17! * You should have received a copy of the GNU Lesser General Public 18! * License along with this library (in file ../LGPL-2.1); if not, write 19! * to the Free Software Foundation, Inc., 51 Franklin Street, 20! * Fifth Floor, Boston, MA 02110-1301 USA 21! * 22! *****************************************************************************/ 23! 24!/****************************************************************************** 25! * 26! * Authors: Peter Råback & Juha Ruokolainen 27! * Email: Peter.Raback@csc.fi & Juha.Ruokolainen@csc.fi 28! * Web: http://www.csc.fi/elmer 29! * Address: CSC - IT Center for Science Ltd. 30! * Keilaranta 14 31! * 02101 Espoo, Finland 32! * 33! * Original Date: 16.6.2011 34! * 35! *****************************************************************************/ 36 37 38 39!> \ingroup ElmerLib 40!> \{ 41 42!----------------------------------------------------------------------------- 43!> Module including generic utilities for particle dynamics and tracking. 44!----------------------------------------------------------------------------- 45 46MODULE ParticleUtils 47 48 USE DefUtils 49 USE Lists 50 USE MeshUtils 51 USE GeneralUtils 52 53 IMPLICIT NONE 54 55 TYPE Particle_t 56 INTEGER :: Dim, NumberOfParticles=0, MaxNumberOfParticles=0, & 57 NumberOfMovingParticles = 0, & 58 TimeOrder = 0, FirstGhost = 0, NumberOfGroups = 0 59 TYPE(Variable_t), POINTER :: Variables => NULL() 60 61 REAL(KIND=dp) :: time, dtime 62 LOGICAL :: DtConstant = .TRUE., RK2 = .FALSE. 63 INTEGER :: DtSign = 1 64 65 REAL(KIND=dp), POINTER :: Coordinate(:,:) => NULL() 66 REAL(KIND=dp), POINTER :: PrevCoordinate(:,:) => NULL() 67 REAL(KIND=dp), POINTER :: Velocity(:,:) => NULL() 68 REAL(KIND=dp), POINTER :: PrevVelocity(:,:) => NULL() 69 REAL(KIND=dp), POINTER :: Force(:,:) => NULL() 70 REAL(KIND=dp), POINTER :: uvw(:,:) => NULL() 71 72 INTEGER, POINTER :: FaceIndex(:) => NULL() 73 INTEGER, POINTER :: Status(:) => NULL() 74 INTEGER, POINTER :: ElementIndex(:) => NULL() 75 INTEGER, POINTER :: NodeIndex(:) => NULL() 76 INTEGER, POINTER :: Partition(:) => NULL() 77 INTEGER, POINTER :: Group(:) => NULL() 78 79 ! Data structure for the particle-particle interaction 80 INTEGER :: MaxClosestParticles 81 LOGICAL :: NeighbourTable = .FALSE. 82 INTEGER, POINTER :: ClosestNode(:) => NULL() 83 INTEGER, POINTER :: ClosestParticle(:) => NULL() 84 INTEGER, POINTER :: NoClosestParticle(:) => NULL() 85 INTEGER, POINTER :: CumClosestParticle(:) => NULL() 86 87 ! Mark the internal elements without any interface nodes 88 LOGICAL, POINTER :: InternalElements(:) => NULL() 89 90 ! Local and global bounding boxes 91 REAL(KIND=dp) :: LocalMinCoord(3), LocalMaxCoord(3) 92 REAL(KIND=dp) :: GlobalMinCoord(3), GlobalMaxCoord(3) 93 94 END TYPE Particle_t 95 96 97 INTEGER, PARAMETER :: & 98 PARTICLE_ALLOCATED = 1, & 99 PARTICLE_WAITING = 2, & 100 PARTICLE_INITIATED = 3, & 101 PARTICLE_LOCATED = 4, & 102 PARTICLE_MOVING = 5, & 103 PARTICLE_FACEBOUNDARY = 6, & 104 PARTICLE_PARTBOUNDARY = 7, & 105 PARTICLE_HIT = 8, & 106 PARTICLE_READY = 9, & 107 PARTICLE_FIXEDCOORD = 10, & 108 PARTICLE_FIXEDVELO = 11, & 109 PARTICLE_WALLBOUNDARY = 12, & 110 PARTICLE_LOST = 13, & 111 PARTICLE_GHOST = 14 112 113 114 TYPE(Particle_t), TARGET, SAVE :: GlobalParticles 115 116 117 118CONTAINS 119 120 121!---------------------------------------------------------------------------- 122!> Counts particles in different categories. 123!---------------------------------------------------------------------------- 124 SUBROUTINE ParticleStatusCount(Particles) 125 126 TYPE(Particle_t), POINTER :: Particles 127 INTEGER :: i,j,k,NoParticles 128 INTEGER :: StatusCount(PARTICLE_GHOST) 129 CHARACTER (len=12), PARAMETER :: StatusString(14) = [ & 130 "Allocated ", & 131 "Waiting ", & 132 "Initiated ", & 133 "Located ", & 134 "Moving ", & 135 "FaceBoundary", & 136 "PartBoundary", & 137 "Hit ", & 138 "Ready ", & 139 "FixedCoord ", & 140 "FixedVelo ", & 141 "WallBoundary", & 142 "Lost ", & 143 "Ghost "] 144 145 StatusCount = 0 146 NoParticles = Particles % NumberOfParticles 147 DO i=1,NoParticles 148 j = Particles % Status(i) 149 StatusCount( j ) = StatusCount( j ) + 1 150 END DO 151 152 CALL Info('ParticleStatusCount','Information on particle status:') 153 k = NINT( ParallelReduction( 1.0_dp * NoParticles ) ) 154 WRITE(Message,'(A,T18,I0)') 'Total: ',k 155 CALL Info('ParticleStatusCount',Message,Level=8) 156 DO i=1,PARTICLE_GHOST 157 j = StatusCount(i) 158 k = NINT( ParallelReduction( 1.0_dp * j ) ) 159 IF( k == 0 ) CYCLE 160 WRITE(Message,'(A,T18,I0)') TRIM(StatusString(i))//': ',k 161 CALL Info('ParticleStatusCount',Message,Level=8) 162 END DO 163 164 END SUBROUTINE ParticleStatusCount 165 166 167 168 !--------------------------------------------------------- 169 ! The following subroutines make the data structure 170 ! transparent in the user subrouines and thereby make 171 ! them more recilient to time. 172 !> Returns coordinates of the particle. 173 !--------------------------------------------------------- 174 FUNCTION GetParticleCoord(Particles,No) RESULT ( Coord ) 175 TYPE(Particle_t), POINTER :: Particles 176 INTEGER :: No 177 REAL(KIND=dp) :: Coord(3) 178 179 INTEGER :: dim 180 181 Coord(3) = 0.0_dp 182 dim = Particles % dim 183 Coord(1:dim) = Particles % Coordinate(no,1:dim) 184 END FUNCTION GetParticleCoord 185 186 !> Returns velocity of the particle. 187 !--------------------------------------------------------- 188 FUNCTION GetParticleVelo(Particles,No) RESULT ( Coord ) 189 TYPE(Particle_t), POINTER :: Particles 190 INTEGER :: No 191 REAL(KIND=dp) :: Coord(3) 192 193 INTEGER :: dim 194 195 Coord(3) = 0.0_dp 196 dim = Particles % dim 197 Coord(1:dim) = Particles % Velocity(no,1:dim) 198 END FUNCTION GetParticleVelo 199 200 !> Returns force acting on the particle. 201 !------------------------------------------------------- 202 FUNCTION GetParticleForce(Particles,No) RESULT ( Coord ) 203 TYPE(Particle_t), POINTER :: Particles 204 INTEGER :: No 205 REAL(KIND=dp) :: Coord(3) 206 207 INTEGER :: dim 208 209 Coord(3) = 0.0_dp 210 dim = Particles % dim 211 Coord(1:dim) = Particles % Force(no,1:dim) 212 END FUNCTION GetParticleForce 213 214 !> Sets the particle coordinates. 215 !-------------------------------------------------------- 216 SUBROUTINE SetParticleCoord(Particles,No,Coord) 217 TYPE(Particle_t), POINTER :: Particles 218 INTEGER :: No 219 REAL(KIND=dp) :: Coord(3) 220 INTEGER :: dim 221 222 dim = Particles % dim 223 Particles % Coordinate(no,1:dim) = Coord(1:dim) 224 END SUBROUTINE SetParticleCoord 225 226 !> Sets the particle velocity. 227 !------------------------------------------------------- 228 SUBROUTINE SetParticleVelo(Particles,No,Velo) 229 TYPE(Particle_t), POINTER :: Particles 230 INTEGER :: No 231 REAL(KIND=dp) :: Velo(3) 232 INTEGER :: dim 233 234 dim = Particles % dim 235 Particles % Velocity(no,1:dim) = Velo(1:dim) 236 END SUBROUTINE SetParticleVelo 237 238 !> Sets the particle force. 239 !------------------------------------------------------- 240 SUBROUTINE SetParticleForce(Particles,No,Force) 241 TYPE(Particle_t), POINTER :: Particles 242 INTEGER :: No 243 REAL(KIND=dp) :: Force(3) 244 INTEGER :: dim 245 246 dim = Particles % dim 247 Particles % Force(no,1:dim) = Force(1:dim) 248 END SUBROUTINE SetParticleForce 249 250 251 !> Gets the previous particle coordinate. 252 !----------------------------------------------------------- 253 FUNCTION GetParticlePrevCoord(Particles,No) RESULT ( Coord ) 254 TYPE(Particle_t), POINTER :: Particles 255 INTEGER :: No 256 REAL(KIND=dp) :: Coord(3) 257 258 INTEGER :: dim 259 260 Coord(3) = 0.0_dp 261 dim = Particles % dim 262 263 Coord(1:dim) = Particles % PrevCoordinate(no,1:dim) 264 265 END FUNCTION GetParticlePrevCoord 266 267 !> Gets the local coordinates of the element of the given particle. 268 !------------------------------------------------------------------- 269 SUBROUTINE GetParticleUVW(Particles,No, u, v, w ) 270 TYPE(Particle_t), POINTER :: Particles 271 INTEGER :: No 272 REAL(KIND=dp) :: u,v 273 REAL(KIND=dp), OPTIONAL :: w 274 INTEGER :: dim 275 276 dim = Particles % dim 277 278 u = Particles % UVW(no,1) 279 v = Particles % UVW(no,2) 280 IF( PRESENT( w ) ) THEN 281 IF( dim == 3 ) THEN 282 w = Particles % UVW(no,3) 283 ELSE 284 w = 0.0_dp 285 END IF 286 END IF 287 END SUBROUTINE GetParticleUVW 288 289 !> Sets the local coordinates of the element of the given particle. 290 !------------------------------------------------------------------ 291 SUBROUTINE SetParticleUVW(Particles,No,u,v,w) 292 TYPE(Particle_t), POINTER :: Particles 293 INTEGER :: No 294 REAL(KIND=dp) :: u,v 295 REAL(KIND=dp), OPTIONAL :: w 296 297 INTEGER :: dim 298 299 dim = Particles % dim 300 301 Particles % UVW(no,1) = u 302 Particles % UVW(no,2) = v 303 IF( PRESENT( w ) ) THEN 304 IF( dim == 3 ) THEN 305 Particles % UVW(no,3) = w 306 END IF 307 END IF 308 END SUBROUTINE SetParticleUVW 309 310 !> Adds a displacement to the particle coordinates. 311 !------------------------------------------------------------------ 312 SUBROUTINE AddParticleCoord(Particles,No,Coord) 313 TYPE(Particle_t), POINTER :: Particles 314 INTEGER :: No, DerOrder 315 REAL(KIND=dp) :: Coord(3) 316 INTEGER :: dim 317 dim = Particles % dim 318 Particles % Coordinate(no,1:dim) = & 319 Particles % Coordinate(no,1:dim) + Coord(1:dim) 320 END SUBROUTINE AddParticleCoord 321 322 !> Adds a velocity difference to the particle velocity. 323 !------------------------------------------------------------------- 324 SUBROUTINE AddParticleVelo(Particles,No,Coord) 325 TYPE(Particle_t), POINTER :: Particles 326 INTEGER :: No, DerOrder 327 REAL(KIND=dp) :: Coord(3) 328 INTEGER :: dim 329 dim = Particles % dim 330 Particles % Velocity(no,1:dim) = & 331 Particles % Velocity(no,1:dim) + Coord(1:dim) 332 END SUBROUTINE AddParticleVelo 333 334 !> Adds to the force acting on the particle. 335 !------------------------------------------------------------------- 336 SUBROUTINE AddParticleForce(Particles,No,Force) 337 TYPE(Particle_t), POINTER :: Particles 338 INTEGER :: No, DerOrder 339 REAL(KIND=dp) :: Force(3) 340 INTEGER :: dim 341 dim = Particles % dim 342 Particles % Force(no,1:dim) = & 343 Particles % Force(no,1:dim) + Force(1:dim) 344 END SUBROUTINE AddParticleForce 345 346 !> Gets the status of the particle. 347 !------------------------------------------------------------------- 348 FUNCTION GetParticleStatus(Particles,No) RESULT ( Status ) 349 TYPE(Particle_t), POINTER :: Particles 350 INTEGER :: No 351 INTEGER :: Status 352 353 Status = Particles % Status(No) 354 END FUNCTION GetParticleStatus 355 356 !> Sets the status of the particle. 357 !------------------------------------------------------------------- 358 SUBROUTINE SetParticleStatus(Particles,No,Status ) 359 TYPE(Particle_t), POINTER :: Particles 360 INTEGER :: No 361 INTEGER :: Status 362 363 Particles % Status(No) = Status 364 END SUBROUTINE SetParticleStatus 365 366 !> Gets the elements where the particle is located in, or was located last time. 367 !------------------------------------------------------------------------------- 368 FUNCTION GetParticleElement(Particles,No) RESULT ( Index ) 369 TYPE(Particle_t), POINTER :: Particles 370 INTEGER :: No 371 INTEGER :: Index 372 373 Index = Particles % ElementIndex(No) 374 END FUNCTION GetParticleElement 375 376 !> Sets the element where the particle is located. 377 !------------------------------------------------------------------------------- 378 SUBROUTINE SetParticleElement(Particles,No,Index ) 379 TYPE(Particle_t), POINTER :: Particles 380 INTEGER :: No 381 INTEGER :: Index 382 383 Particles % ElementIndex(No) = Index 384 END SUBROUTINE SetParticleElement 385 386 !> Gets the closest node related to the particle. 387 !------------------------------------------------------------------------------- 388 FUNCTION GetParticleNode(Particles,No) RESULT ( Index ) 389 TYPE(Particle_t), POINTER :: Particles 390 INTEGER :: No 391 INTEGER :: Index 392 393 Index = Particles % NodeIndex(No) 394 END FUNCTION GetParticleNode 395 396 !> Sets the closest node related to the particle. 397 !-------------------------------------------------------------------------------- 398 SUBROUTINE SetParticleNode(Particles,No,Index ) 399 TYPE(Particle_t), POINTER :: Particles 400 INTEGER :: No 401 INTEGER :: Index 402 403 Particles % NodeIndex(No) = Index 404 END SUBROUTINE SetParticleNode 405 406 !> Get the group in which the particle belongs to 407 !-------------------------------------------------------------------------------- 408 FUNCTION GetParticleGroup(Particles,No) RESULT ( Index ) 409 TYPE(Particle_t), POINTER :: Particles 410 INTEGER :: No 411 INTEGER :: Index 412 413 IF( Particles % NumberOfGroups > 0 ) THEN 414 Index = Particles % Group(No) 415 ELSE 416 Index = 0 417 END IF 418 419 END FUNCTION GetParticleGroup 420 421 !> Sets the group in which the particle belongs to 422 !-------------------------------------------------------------------------------- 423 SUBROUTINE SetParticleGroup(Particles,No,Index ) 424 TYPE(Particle_t), POINTER :: Particles 425 INTEGER :: No 426 INTEGER :: Index 427 428 IF( Particles % NumberOfGroups > 0 ) THEN 429 Particles % Group(No) = Index 430 ELSE 431 CALL Warn('SetParticleGroup','Cannot set particle because there is only one group!') 432 END IF 433 434 END SUBROUTINE SetParticleGroup 435 436 !--------------------------------------------------------- 437 !> The subroutine marks the elements which are not on the 438 !> boundary, either internal or external one. 439 !> This information may be used to speed up different 440 !> loops where particle-boundary interaction is needed. 441 !--------------------------------------------------------- 442 SUBROUTINE MarkInternalElements( Particles ) 443 444 TYPE(Particle_t), POINTER :: Particles 445 TYPE(Element_t), POINTER :: BulkElement, BulkElement2, BoundaryElement 446 TYPE(Mesh_t), POINTER :: Mesh 447 TYPE(ValueList_t), POINTER :: Body, Body2 448 INTEGER :: t,i,j,imax,body_id,body_id2,mat_id,mat_id2,bf_id,bf_id2,dim,istat 449 INTEGER :: NumberOfElements 450 LOGICAL, POINTER :: InternalElements(:) 451 LOGICAL :: Found,Hit 452 453 Mesh => GetMesh() 454 Dim = Mesh % MeshDim 455 NumberOfElements = Mesh % NumberOfBulkElements 456 457 IF(.NOT. ASSOCIATED( Particles % InternalElements )) THEN 458 ALLOCATE( Particles % InternalElements(NumberOfElements),STAT=istat ) 459 IF( istat /= 0 ) THEN 460 CALL Fatal('MarkInternalElements','Allocation error 1') 461 END IF 462 END IF 463 464 InternalElements => Particles % InternalElements 465 InternalElements = .TRUE. 466 467 DO t=1,NumberOfElements 468 469 BulkElement => Mesh % Elements(t) 470 471 body_id = BulkElement % BodyId 472 473 IF(.FALSE.) THEN 474 Body => CurrentModel % Bodies(body_id) % Values 475 mat_id = ListGetInteger( Body,'Material',Found) 476 bf_id = ListGetInteger( Body,'Body Force',Found) 477 END IF 478 479 IF( dim == 3 ) THEN 480 imax = BulkElement % TYPE % NumberOfFaces 481 ELSE 482 imax = BulkElement % TYPE % NumberOfEdges 483 END IF 484 485 Hit = .FALSE. 486 487 DO i=1, imax 488 IF( dim == 3 ) THEN 489 j = BulkElement % FaceIndexes(i) 490 BoundaryElement => Mesh % Faces( j ) 491 ELSE 492 j = BulkElement % EdgeIndexes(i) 493 BoundaryElement => Mesh % Edges(j) 494 END IF 495 496 IF( .NOT. ASSOCIATED( BoundaryElement % BoundaryInfo ) ) CYCLE 497 498 IF( ASSOCIATED( BulkElement, BoundaryElement % BoundaryInfo % Right ) ) THEN 499 BulkElement2 => BoundaryElement % BoundaryInfo % Left 500 ELSE 501 BulkElement2 => BoundaryElement % BoundaryInfo % Right 502 END IF 503 504 ! A true boundary element 505 IF( .NOT. ASSOCIATED( BulkElement2 )) THEN 506 Hit = .TRUE. 507 EXIT 508 END IF 509 510 body_id2 = BulkElement2 % BodyId 511 IF( body_id2 == body_id ) CYCLE 512 513 ! If the bodies are the same then there is no boundary 514 IF(.TRUE.) THEN 515 IF( body_id2 /= body_id ) THEN 516 Hit = .TRUE. 517 EXIT 518 END IF 519 ELSE 520 Body2 => CurrentModel % Bodies(body_id2) % Values 521 522 mat_id2 = ListGetInteger( Body2,'Material') 523 IF( mat_id2 /= mat_id ) THEN 524 Hit = .TRUE. 525 EXIT 526 END IF 527 528 bf_id2 = ListGetInteger( Body2,'Body Force',Found) 529 IF( bf_id2 /= bf_id ) THEN 530 Hit = .TRUE. 531 EXIT 532 END IF 533 END IF 534 END DO 535 536 IF( Hit ) InternalElements(t) = .FALSE. 537 END DO 538 539 i = COUNT( InternalElements ) 540 j = NumberOfElements - i 541 542 i = NINT( ParallelReduction( 1.0_dp * i ) ) 543 j = NINT( ParallelReduction( 1.0_dp * j ) ) 544 545 CALL Info('MarkInternalElements','Internal Elements: '//TRIM(I2S(i)),Level=8 ) 546 CALL Info('MarkInternalElements','Interface Elements: '//TRIM(I2S(j)),Level=8 ) 547 548 END SUBROUTINE MarkInternalElements 549 550 551 552 553 !--------------------------------------------------------- 554 !> Subroutine sets up some preliminary information needed for the 555 !> particler tracker: timeorder, space dimension, 556 !> bounding box, and mesh edges/faces. 557 !--------------------------------------------------------- 558 SUBROUTINE SetParticlePreliminaries(Particles,dim,TimeOrder) 559 560 TYPE(Particle_t), POINTER :: Particles 561 INTEGER, OPTIONAL :: dim 562 INTEGER, OPTIONAL :: TimeOrder 563 564 TYPE(Mesh_t), POINTER :: Mesh 565 REAL(KIND=dp) :: MinCoord(3), MaxCoord(3), s(3) 566 INTEGER :: ierr 567 568 Mesh => GetMesh() 569 IF( .NOT. ASSOCIATED( Mesh ) ) THEN 570 CALL Fatal('SetParticleDimensions','No Mesh associated') 571 END IF 572 573 IF(PRESENT(TimeOrder)) THEN 574 Particles % TimeOrder = TimeOrder 575 ELSE 576 Particles % TimeOrder = 2 577 END IF 578 579 IF( PRESENT( dim ) ) THEN 580 IF( dim == 2 .OR. dim == 3 ) THEN 581 Particles % dim = dim 582 ELSE 583 CALL Fatal('SetParticleDimensions','Invalid dimension') 584 END IF 585 ELSE 586 Particles % dim = Mesh % Meshdim 587 END IF 588 589 MinCoord(1) = MINVAL(Mesh % Nodes % x ) 590 MinCoord(2) = MINVAL(Mesh % Nodes % y ) 591 MinCoord(3) = MINVAL(Mesh % Nodes % z ) 592 593 MaxCoord(1) = MAXVAL(Mesh % Nodes % x ) 594 MaxCoord(2) = MAXVAL(Mesh % Nodes % y ) 595 MaxCoord(3) = MAXVAL(Mesh % Nodes % z ) 596 597 Particles % LocalMinCoord = MinCoord 598 Particles % LocalMaxCoord = MaxCoord 599 600 601 ! Make a parallel reduction 602 IF( ParEnv % PEs > 1 ) THEN 603 s = MinCoord 604 CALL MPI_ALLREDUCE( s, mincoord, 3, MPI_DOUBLE_PRECISION, & 605 MPI_MIN, ELMER_COMM_WORLD, ierr ) 606 607 s = MaxCoord 608 CALL MPI_ALLREDUCE( s, maxcoord, 3, MPI_DOUBLE_PRECISION, & 609 MPI_MAX, ELMER_COMM_WORLD, ierr ) 610 END IF 611 612 Particles % GlobalMinCoord = MinCoord 613 Particles % GlobalMaxCoord = MaxCoord 614 615 ! Create list of faces / edges 616 !------------------------------------------------------------------------- 617 Mesh => GetMesh() 618 CALL FindMeshEdges( Mesh ) 619 IF ( ParEnv % PEs > 1 ) THEN 620 CALL SParEdgeNumbering(Mesh,Allmesh=.TRUE.) 621 CALL SParFaceNumbering(Mesh,Allmesh=.TRUE.) 622 END IF 623 624 ! Mark elements that are not on boundary to make life faster in the future 625 !------------------------------------------------------------------------- 626 CALL MarkInternalElements( Particles ) 627 628 END SUBROUTINE SetParticlePreliminaries 629 630 631 !--------------------------------------------------------- 632 !> Subroutine allocate particles before launching them. 633 !--------------------------------------------------------- 634 SUBROUTINE AllocateParticles(Particles,NoParticles) 635 636 TYPE(Particle_t), POINTER :: Particles 637 INTEGER :: NoParticles 638 639 REAL(KIND=dp), POINTER :: Velocity(:,:), Force(:,:), & 640 Coordinate(:,:), PrevCoordinate(:,:), PrevVelocity(:,:) 641 INTEGER, POINTER :: Status(:), ElementIndex(:), FaceIndex(:), NodeIndex(:), & 642 Closest(:),Partition(:),Group(:) 643 INTEGER :: PrevNoParticles, dofs, No, n, dim, TimeOrder, n1, n2, AllocParticles 644 INTEGER, ALLOCATABLE :: Perm(:) 645 646 IF( NoParticles <= Particles % MaxNumberOfParticles ) THEN 647 CALL Info('AllocateParticles','There are already enough particles',Level=20) 648 RETURN 649 END IF 650 651 PrevNoParticles = Particles % NumberOfParticles 652 653 AllocParticles = NoParticles 654 IF( PrevNoParticles > 0 ) THEN 655 ! In parallel have a small buffer so that we are not next step here again! 656 IF( ParEnv % PEs > 0 ) THEN 657 AllocParticles = 1.02 * AllocParticles 658 END IF 659 END IF 660 661 WRITE(Message,'(A,I0)') 'Allocating number of particles: ',AllocParticles 662 CALL Info('AllocateParticles',Message,Level=12) 663 664 TimeOrder = Particles % TimeOrder 665 dim = Particles % dim 666 dofs = dim 667 668 ! Set pointers to the old stuff, these are needed 669 ! if growing an already existing list of particles. 670 Coordinate => Particles % Coordinate 671 PrevCoordinate => Particles % PrevCoordinate 672 PrevVelocity => Particles % PrevVelocity 673 Velocity => Particles % Velocity 674 Force => Particles % Force 675 Status => Particles % Status 676 FaceIndex => Particles % FaceIndex 677 ElementIndex => Particles % ElementIndex 678 NodeIndex => Particles % NodeIndex 679 Partition => Particles % Partition 680 Group => Particles % Group 681 682 ! Allocate the desired number of particles 683 ALLOCATE( Particles % Coordinate(AllocParticles,dofs)) 684 ALLOCATE( Particles % Velocity(AllocParticles,dofs)) 685 ALLOCATE( Particles % Force(AllocParticles,dofs) ) 686 ALLOCATE( Particles % PrevCoordinate(AllocParticles,dofs) ) 687 688 ALLOCATE( Particles % Status(AllocParticles)) 689 ALLOCATE( Particles % ElementIndex(AllocParticles)) 690 ALLOCATE( Particles % FaceIndex(AllocParticles)) 691 692 IF( ASSOCIATED( PrevVelocity ) ) THEN 693 ALLOCATE( Particles % PrevVelocity(AllocParticles,dofs) ) 694 END IF 695 696 IF( Particles % NeighbourTable ) THEN 697 Closest => Particles % ClosestNode 698 ALLOCATE( Particles % ClosestNode(AllocParticles) ) 699 END IF 700 701 IF( Particles % NumberOfGroups > 0 ) THEN 702 ALLOCATE( Particles % Group( AllocParticles ) ) 703 END IF 704 705 IF( ASSOCIATED( NodeIndex ) ) THEN 706 ALLOCATE( Particles % NodeIndex(AllocParticles) ) 707 END IF 708 709 IF( ASSOCIATED( Partition ) ) THEN 710 ALLOCATE( Particles % Partition(AllocParticles) ) 711 Particles % Partition = -1 712 END IF 713 714 ! Delete lost particles and move the remaining ones so that each 715 ! empty slot is used. Perm is the reordering of the particles, 716 ! not the reordering of field values as normally. 717 ! --------------------------------------------------------------- 718 IF( PrevNoParticles > 0 ) THEN 719 n = 0 720 ALLOCATE( Perm( PrevNoParticles ) ) 721 Perm = 0 722 723 DO No=1,PrevNoParticles 724 IF ( Status(No) == PARTICLE_LOST ) CYCLE 725 n = n+1 726 Perm(n) = No 727 END DO 728 729 WRITE(Message,'(A,I0)') 'Number of old active particles: ',n 730 CALL Info('AllocateParticles',Message,Level=8) 731 732 IF( n < PrevNoParticles ) THEN 733 WRITE(Message,'(A,I0)') 'Number of deleted particles: ',PrevNoParticles-n 734 CALL Info('AllocateParticles',Message,Level=10) 735 END IF 736 737 n1 = 1 738 n2 = n 739 740 Particles % Coordinate(n1:n2,:) = Coordinate(Perm(n1:n2),:) 741 Particles % Velocity(n1:n2,:) = Velocity(Perm(n1:n2),:) 742 Particles % Force(n1:n2,:) = Force(Perm(n1:n2),:) 743 Particles % PrevCoordinate(n1:n2,:) = PrevCoordinate(Perm(n1:n2),:) 744 745 Particles % Status(n1:n2) = Status(Perm(n1:n2)) 746 Particles % FaceIndex(n1:n2) = FaceIndex(Perm(n1:n2)) 747 Particles % ElementIndex(n1:n2) = ElementIndex(Perm(n1:n2)) 748 749 IF( ASSOCIATED( PrevVelocity ) ) & 750 Particles % PrevVelocity(n1:n2,:) = PrevVelocity(Perm(n1:n2),:) 751 IF( Particles % NeighbourTable ) & 752 Particles % ClosestNode(n1:n2) = Closest(Perm(n1:n2)) 753 IF ( ASSOCIATED(NodeIndex) ) & 754 Particles % NodeIndex(n1:n2) = NodeIndex(Perm(n1:n2)) 755 IF ( ASSOCIATED(Partition) ) & 756 Particles % Partition(n1:n2) = Partition(Perm(n1:n2)) 757 758 IF ( ASSOCIATED(Group) ) & 759 Particles % Group(n1:n2) = Group(Perm(n1:n2)) 760 761 PrevNoParticles = n 762 Particles % NumberOfParticles = n 763 764 ! Deallocate the old stuff 765 DEALLOCATE( Coordinate, Velocity, Force, PrevCoordinate ) 766 DEALLOCATE( Status, FaceIndex, ElementIndex ) 767 768 IF( ASSOCIATED( PrevVelocity ) ) DEALLOCATE( PrevVelocity ) 769 IF( Particles % NeighbourTable ) DEALLOCATE(Closest) 770 IF ( ASSOCIATED(NodeIndex) ) DEALLOCATE(NodeIndex) 771 IF ( ASSOCIATED(Partition) ) DEALLOCATE(Partition) 772 IF( ASSOCIATED( Group ) ) DEALLOCATE( Group ) 773 END IF 774 775 ! Initialize the newly allocated particles with default values 776 !------------------------------------------------------------- 777 n1 = PrevNoParticles+1 778 n2 = AllocParticles 779 780 Particles % Coordinate(n1:n2,:) = 0.0_dp 781 Particles % Velocity(n1:n2,:) = 0.0_dp 782 Particles % Force(n1:n2,:) = 0.0_dp 783 Particles % PrevCoordinate(n1:n2,:) = 0.0_dp 784 785 Particles % Status(n1:n2) = PARTICLE_ALLOCATED 786 Particles % ElementIndex(n1:n2) = 0 787 Particles % FaceIndex(n1:n2) = 0 788 789 IF( ASSOCIATED( Particles % PrevVelocity ) ) & 790 Particles % PrevVelocity(n1:n2,:) = 0.0_dp 791 792 IF( Particles % NeighbourTable ) & 793 Particles % ClosestNode(n1:n2) = 0 794 795 IF( ASSOCIATED( Particles % NodeIndex) ) & 796 Particles % NodeIndex(n1:n2) = 0 797 798 IF( ASSOCIATED( Particles % Partition) ) & 799 Particles % Partition(n1:n2) = ParEnv % MyPe + 1 800 801 IF( ASSOCIATED( Particles % Group ) ) & 802 Particles % Group(n1:n2) = 0 803 804 805 Particles % MaxNumberOfParticles = AllocParticles 806 807 ! Finally resize the generic variables related to the particles 808 !-------------------------------------------------------------- 809 CALL ParticleVariablesResize( Particles, PrevNoParticles, AllocParticles, Perm ) 810 811 IF( PrevNoParticles > 0 ) THEN 812 CALL Info('AllocateParticles','Deallocating particle permutation',Level=20) 813 DEALLOCATE( Perm ) 814 END IF 815 816 END SUBROUTINE AllocateParticles 817 818 !---------------------------------------------------- 819 !> Subroutine deletes lost particles. The reason for losing 820 !> particles may be that they go to a neighbouring partition. 821 !---------------------------------------------------- 822 SUBROUTINE DeleteLostParticles(Particles) 823 TYPE(Particle_t), POINTER :: Particles 824 825 INTEGER :: No, n, PrevNoParticles, n1, n2 826 INTEGER, ALLOCATABLE :: Perm(:) 827 828 PrevNoParticles = Particles % NumberOfParticles 829 IF( PrevNoParticles == 0 ) RETURN 830 831 ALLOCATE( Perm( PrevNoParticles ) ) 832 Perm = 0 833 834 n = 0 835 n1 = 0 836 DO No=1,PrevNoParticles 837 IF ( Particles % Status(No) == PARTICLE_LOST ) CYCLE 838 n = n + 1 839 IF( n1 == 0 .AND. n /= No ) n1 = n 840 Perm(n) = No 841 END DO 842 843 n2 = n 844 CALL Info('DeleteLostParticles','Number of active particles: '& 845 //TRIM(I2S(n2)),Level=12) 846 847 IF(n1 == 0 ) THEN 848 CALL Info('DeleteLostParticles','No particles need to be deleted',Level=12) 849 RETURN 850 ELSE 851 CALL Info('DeleteLostParticles','First particle with changed permutation: '& 852 //TRIM(I2S(n1)),Level=12) 853 END IF 854 855 Particles % Coordinate(n1:n2,:) = & 856 Particles % Coordinate(Perm(n1:n2),:) 857 Particles % Velocity(n1:n2,:) = Particles % Velocity(Perm(n1:n2),:) 858 Particles % Force(n1:n2,:) = Particles % Force(Perm(n1:n2),:) 859 Particles % PrevCoordinate(n1:n2,:) = & 860 Particles % PrevCoordinate(Perm(n1:n2),:) 861 862 Particles % Status(n1:n2) = Particles % Status(Perm(n1:n2)) 863 Particles % FaceIndex(n1:n2) = Particles % FaceIndex(Perm(n1:n2)) 864 Particles % ElementIndex(n1:n2) = Particles % ElementIndex(Perm(n1:n2)) 865 866 IF( ASSOCIATED( Particles % PrevVelocity ) ) & 867 Particles % PrevVelocity(n1:n2,:) = Particles % PrevVelocity(Perm(n1:n2),:) 868 IF( Particles % NeighbourTable ) & 869 Particles % ClosestNode(n1:n2) = Particles % ClosestNode(Perm(n1:n2)) 870 IF ( ASSOCIATED(Particles % NodeIndex) ) & 871 Particles % NodeIndex(n1:n2) = Particles % NodeIndex(Perm(n1:n2)) 872 IF ( ASSOCIATED(Particles % Partition) ) & 873 Particles % Partition(n1:n2) = Particles % Partition(Perm(n1:n2)) 874 875 IF( Particles % NumberOfGroups > 0 ) & 876 Particles % Group(n1:n2) = Particles % Group(Perm(n1:n2)) 877 878 Particles % NumberOfParticles = n2 879 880 IF ( n2 < PrevNoParticles ) THEN 881 Particles % Coordinate(n2+1:PrevNoParticles,:) = 0._dp 882 Particles % Velocity(n2+1:PrevNoParticles,:) = 0.0_dp 883 Particles % Force(n2+1:PrevNoParticles,:) = 0._dp 884 Particles % PrevCoordinate(n2+1:PrevNoParticles,:) = 0._dp 885 886 Particles % Status(n2+1:PrevNoParticles) = PARTICLE_ALLOCATED 887 Particles % FaceIndex(n2+1:PrevNoParticles) = 0 888 Particles % ElementIndex(n2+1:PrevNoParticles) = 0 889 890 IF( ASSOCIATED( Particles % PrevVelocity ) ) & 891 Particles % PrevVelocity(n2+1:PrevNoParticles,:) = 0._dp 892 IF( Particles % NeighbourTable ) & 893 Particles % ClosestNode(n2+1:PrevNoParticles) = 0 894 IF ( ASSOCIATED(Particles % NodeIndex) ) & 895 Particles % NodeIndex(n2+1:PrevNoParticles) = 0 896 IF ( ASSOCIATED(Particles % Partition) ) & 897 Particles % Partition(n2+1:PrevNoParticles) = 0 898 IF ( Particles % NumberOfGroups > 0 ) & 899 Particles % Group(n2+1:PrevNoParticles) = 0 900 END IF 901 902 ! Rorders the variables accordingly to Perm, no resize is needed since number of 903 ! particles is not changed. 904 CALL ParticleVariablesResize( Particles, PrevNoParticles, PrevNoParticles, Perm ) 905 906 907 END SUBROUTINE DeleteLostParticles 908 909 910 911 !---------------------------------------------------- 912 !> Subroutine sets particles that are still sitting on boundary to 913 !> leave the premises and call for their deletion. 914 !---------------------------------------------------- 915 SUBROUTINE EliminateExitingParticles( Particles ) 916 917 TYPE(Particle_t), POINTER :: Particles 918 INTEGER :: NoParticles, No, DeletedParticles, dim, CumDeleted = 0, LimDeleted 919 TYPE(Mesh_t), POINTER :: Mesh 920 TYPE(Element_t), POINTER :: BoundaryElement 921 REAL(KIND=dp) :: Dist, Coord(3), Normal(3), SqrtElementMetric 922 REAL(KIND=dp), POINTER :: Basis(:) 923 TYPE(Nodes_t) :: BoundaryNodes 924 INTEGER :: n 925 LOGICAL :: Stat, Visited = .FALSE. 926 927 SAVE Visited, CumDeleted, BoundaryNodes, Basis 928 929RETURN 930 931 NoParticles = Particles % NumberOfParticles 932 dim = Particles % dim 933 Mesh => GetMesh() 934 935 IF(.NOT. Visited ) THEN 936 Visited = .TRUE. 937 n = Mesh % MaxElementNodes 938 ALLOCATE( Basis(n) ) 939 END IF 940 941 ! Just set the wall particles to lost elements for now 942 IF(.TRUE.) THEN 943 DO No=1, NoParticles 944 IF( Particles % Status(No) == PARTICLE_WALLBOUNDARY ) THEN 945 Particles % Status(No) = PARTICLE_LOST 946 END IF 947 END DO 948 ELSE 949 950 ! Some heuristics is used when to activate the deleting of particles 951 ! Check for co-operation with parallel stuff. 952 !------------------------------------------------------------------- 953 LimDeleted = MAX( NINT( SQRT( 1.0_dp * NoParticles ) ), 20 ) 954 ! LimDeleted = 0 955 956 DeletedParticles = 0 957 DO No=1, NoParticles 958 IF( Particles % Status(No) == PARTICLE_WALLBOUNDARY ) THEN 959 DeletedParticles = DeletedParticles + 1 960 Particles % Status(No) = PARTICLE_LOST 961 END IF 962 END DO 963 964 CumDeleted = CumDeleted + DeletedParticles 965 966 IF( CumDeleted > LimDeleted ) THEN 967 !PRINT *,'Number of deleted particles:',CumDeleted, DeletedParticles, LimDeleted 968 CALL DeleteLostParticles( Particles ) 969 CumDeleted = 0 970 END IF 971 END IF 972 973 END SUBROUTINE EliminateExitingParticles 974 975 976 !---------------------------------------------------- 977 !> Increase particle array size by given amount. 978 !---------------------------------------------------- 979 SUBROUTINE IncreaseParticles(Particles,NoParticles) 980 981 TYPE(Particle_t), POINTER :: Particles 982 INTEGER :: NoParticles 983 984 INTEGER :: Maxn 985 986 ! Garbage collection: 987 ! ------------------- 988 CALL DeleteLostParticles(Particles) 989 990 ! Check if really need to allocate more space: 991 ! -------------------------------------------- 992 Maxn = Particles % NumberOfParticles+NoParticles 993 IF ( Maxn > Particles % MaxNumberOfParticles ) & 994 CALL AllocateParticles( Particles, Maxn ) 995 996 END SUBROUTINE IncreaseParticles 997 998 999 1000 SUBROUTINE DestroyParticles(Particles) 1001 TYPE(Particle_t), POINTER :: Particles 1002 1003 CALL Info('DestroyParticles','Destrying the particle structures',Level=10) 1004 1005 1006 IF ( ASSOCIATED(Particles % Velocity) ) & 1007 DEALLOCATE( Particles % Velocity ) 1008 1009 IF ( ASSOCIATED(Particles % Force) ) & 1010 DEALLOCATE( Particles % Force ) 1011 1012 IF ( ASSOCIATED(Particles % PrevCoordinate) ) & 1013 DEALLOCATE( Particles % PrevCoordinate ) 1014 1015 IF ( ASSOCIATED(Particles % PrevVelocity) ) & 1016 DEALLOCATE( Particles % PrevVelocity ) 1017 1018 IF ( ASSOCIATED(Particles % NodeIndex) ) & 1019 DEALLOCATE( Particles % NodeIndex ) 1020 1021 IF ( ASSOCIATED(Particles % Partition) ) & 1022 DEALLOCATE( Particles % Partition ) 1023 1024 IF ( Particles % NumberOfGroups > 0 ) & 1025 DEALLOCATE( Particles % Group ) 1026 1027 IF( ASSOCIATED( Particles % Coordinate ) ) & 1028 DEALLOCATE( Particles % Coordinate ) 1029 1030 IF( ASSOCIATED( Particles % Status ) ) & 1031 DEALLOCATE( Particles % Status ) 1032 1033 IF( ASSOCIATED( Particles % FaceIndex ) ) & 1034 DEALLOCATE( Particles % FaceIndex ) 1035 1036 IF( ASSOCIATED( Particles % ElementIndex ) ) & 1037 DEALLOCATE( Particles % ElementIndex ) 1038 1039 IF( ASSOCIATED( Particles % UVW ) ) & 1040 DEALLOCATE( Particles % UVW ) 1041 1042 Particles % NumberOfParticles = 0 1043 Particles % MaxNumberOfParticles = 0 1044 1045 END SUBROUTINE DestroyParticles 1046 1047 1048 1049 !--------------------------------------------------------- 1050 !> Subroutine for releaseing initiated but waiting particles. 1051 !--------------------------------------------------------- 1052 SUBROUTINE ReleaseWaitingParticles(Particles) 1053 TYPE(Particle_t), POINTER :: Particles 1054 1055 TYPE(ValueList_t), POINTER :: Params 1056 INTEGER, POINTER :: Status(:) 1057 INTEGER :: i,j,NoParticles,ReleaseCount=0,ReleaseSet 1058 REAL(KIND=dp) :: ReleaseFraction 1059 LOGICAL :: Found,Visited = .FALSE. 1060 1061 SAVE Visited, ReleaseCount 1062 1063 ! Check whether all particles have already been released 1064 !------------------------------------------------------- 1065 NoParticles = Particles % NumberOfParticles 1066 IF( ReleaseCount >= NoParticles ) RETURN 1067 1068 1069 ! Get the size of the current release set 1070 !------------------------------------------------------- 1071 Params => ListGetSolverParams() 1072 ReleaseSet = GetInteger( Params,'Particle Release Number',Found) 1073 IF( .NOT. Found ) THEN 1074 ReleaseFraction = GetCReal( Params,'Particle Release Fraction',Found ) 1075 IF(.NOT. Found ) THEN 1076 RETURN 1077 ELSE 1078 ReleaseSet = NINT( ReleaseFraction * NoParticles ) 1079 END IF 1080 END IF 1081 CALL Info('ReleaseWaitingParticles','Releasing number of particles: '& 1082 //TRIM(I2S(ReleaseCount)),Level=10) 1083 1084 IF( ReleaseSet <= 0 ) RETURN 1085 1086 ! Release some waiting particles 1087 !------------------------------------------------------- 1088 Status => Particles % Status 1089 j = 0 1090 DO i=1,NoParticles 1091 IF( Status(i) == PARTICLE_WAITING ) THEN 1092 Status(i) = PARTICLE_INITIATED 1093 j = j + 1 1094 IF( j == ReleaseSet ) EXIT 1095 END IF 1096 END DO 1097 ReleaseCount = ReleaseCount + j 1098 1099 1100 END SUBROUTINE ReleaseWaitingParticles 1101 1102 1103 !--------------------------------------------------------- 1104 !> Subroutine for chanching the partition of particles that 1105 !> cross the partition boundary. 1106 !--------------------------------------------------------- 1107 FUNCTION ChangeParticlePartition(Particles) RESULT(nReceived) 1108 !--------------------------------------------------------- 1109 TYPE(Particle_t), POINTER :: Particles 1110 !--------------------------------------------------------- 1111 TYPE(Element_t), POINTER :: Face, Parent, Faces(:) 1112 1113 INTEGER i,j,k,l,m,n,dim,NoPartitions, nextPart, nFaces, & 1114 Proc, ierr, status(MPI_STATUS_SIZE), n_part, nReceived, nSent, & 1115 ncomp, ncompInt 1116 1117 INTEGER, ALLOCATABLE :: Perm(:), Indexes(:), Neigh(:), & 1118 Recv_parts(:), Requests(:) 1119 TYPE(Mesh_t), POINTER :: Mesh 1120 TYPE(Variable_t), POINTER :: Var 1121 1122 INTEGER, POINTER :: Neighbours(:) 1123 LOGICAL, POINTER :: FaceInterface(:), IsNeighbour(:) 1124 1125 INTEGER :: q 1126 LOGICAL, ALLOCATABLE :: Failed(:) 1127 1128 TYPE ExchgInfo_t 1129 INTEGER :: n=0 1130 INTEGER, ALLOCATABLE :: Gindex(:), Particles(:) 1131 END TYPE ExchgInfo_t 1132 1133 REAL(KIND=dp), ALLOCATABLE :: Buf(:) 1134 INTEGER, ALLOCATABLE :: BufInt(:) 1135 TYPE(ExchgInfo_t), ALLOCATABLE :: ExcInfo(:) 1136 !--------------------------------------------------------- 1137 1138 nReceived = 0 1139 IF( ParEnv% PEs == 1 ) RETURN 1140 1141 CALL Info('ChangeParticlePartition','Sending particles among partitions',Level=10) 1142 1143 Mesh => GetMesh() 1144 dim = Particles % dim 1145 1146 ! Count & Identify neighbouring partitions: 1147 ! ----------------------------------------- 1148 ALLOCATE(IsNeighbour(ParEnv % PEs)) 1149 NoPartitions = MeshNeighbours(Mesh,IsNeighbour) 1150 ALLOCATE(Perm(ParEnv % PEs), Neigh(NoPartitions) ) 1151 Perm = 0 1152 1153 NoPartitions=0 1154 DO i=1,ParEnv % PEs 1155 IF ( i-1==ParEnv % Mype ) CYCLE 1156 IF ( IsNeighbour(i) ) THEN 1157 NoPartitions=NoPartitions+1 1158 Perm(i) = NoPartitions 1159 Neigh(NoPartitions) = i-1 1160 END IF 1161 END DO 1162 DEALLOCATE(IsNeighbour) 1163 1164 CALL Info('ChangeParticlePartition','Number of active partitions: '& 1165 //TRIM(I2S(NoPartitions)),Level=12) 1166 1167 ! 1168 ! Count particles to be sent to neighbours: 1169 ! ----------------------------------------- 1170 ALLOCATE(ExcInfo(NoPartitions)) 1171 ExcInfo % n = 0 1172 1173 DO i=1,Particles % NumberOfParticles 1174 IF( Particles % Status(i) /= PARTICLE_WALLBOUNDARY ) CYCLE 1175 1176 IF ( dim==2 ) THEN 1177 Face => Mesh % Edges(Particles % FaceIndex(i)) 1178 FaceInterface => Mesh % ParallelInfo % EdgeInterface 1179 Neighbours => Mesh % ParallelInfo % & 1180 EdgeNeighbourList(Face % ElementIndex) % Neighbours 1181 ELSE 1182 Face => Mesh % Faces(Particles % FaceIndex(i)) 1183 FaceInterface => Mesh % ParallelInfo % FaceInterface 1184 Neighbours => Mesh % ParallelInfo % & 1185 FaceNeighbourList(Face % ElementIndex) % Neighbours 1186 END IF 1187 1188 IF ( FaceInterface(Face % ElementIndex) ) THEN 1189 IF ( Face % BoundaryInfo % Constraint > 0 ) & 1190 CALL Warn("ChangeParticlePartition", "is this a BC after all?") 1191 1192 nextPart = ParEnv % MyPE 1193 DO j=1,SIZE(Neighbours) 1194 IF ( ParEnv % Mype /= Neighbours(j) ) THEN 1195 nextPart = Neighbours(j) 1196 k = Perm(nextPart+1) 1197 IF ( k>0 ) THEN 1198 ExcInfo(k) % n = ExcInfo(k) % n+1 1199 Particles % Status(i) = PARTICLE_PARTBOUNDARY 1200 ELSE 1201 Particles % Status(i) = PARTICLE_LOST 1202 END IF 1203 EXIT 1204 END IF 1205 END DO 1206 END IF 1207 END DO 1208 1209 n = SUM( ExcInfo(1:NoPartitions) % n ) 1210 CALL Info('ChangeParticlePartition','Number of particles to send: '& 1211 //TRIM(I2S(n)),Level=10) 1212 1213 CALL MPI_ALLREDUCE( n, nSent, 1, MPI_INTEGER, & 1214 MPI_SUM, ELMER_COMM_WORLD, ierr ) 1215 IF ( nSent == 0 ) THEN 1216 CALL Info('ChangeParticlePartition','No particles needs to be sent',Level=10) 1217 DEALLOCATE(ExcInfo, Perm, Neigh) 1218 RETURN 1219 ELSE 1220 CALL Info('ChangeParticlePartition','Global number of particles to sent: '& 1221 //TRIM(I2S(nSent)),Level=10) 1222 END IF 1223 1224 ! 1225 ! Receive interface sizes: 1226 !-------------------------- 1227 ALLOCATE( Recv_Parts(NoPartitions), Requests(NoPartitions) ) 1228 DO i=1,NoPartitions 1229 CALL MPI_iRECV( Recv_Parts(i),1, MPI_INTEGER, Neigh(i), & 1230 1000, ELMER_COMM_WORLD, requests(i), ierr ) 1231 END DO 1232 1233 DO i=1,NoPartitions 1234 CALL MPI_BSEND( ExcInfo(i) % n, 1, MPI_INTEGER, Neigh(i), & 1235 1000, ELMER_COMM_WORLD, ierr ) 1236 END DO 1237 CALL MPI_WaitAll( NoPartitions, Requests, MPI_STATUSES_IGNORE, ierr ) 1238 1239 n = SUM(Recv_Parts) 1240 CALL Info('ChangeParticlePartition','Number of particles to receive: '& 1241 //TRIM(I2S(n)),Level=10) 1242 1243 CALL MPI_ALLREDUCE( n, nReceived, 1, MPI_INTEGER, & 1244 MPI_SUM, ELMER_COMM_WORLD, ierr ) 1245 IF ( nReceived==0 ) THEN 1246 CALL Info('ChangeParticlePartition','No particles needs to be received',Level=10) 1247 DEALLOCATE(Recv_Parts, Requests, ExcInfo, Perm, Neigh) 1248 RETURN 1249 ELSE 1250 CALL Info('ChangeParticlePartition','Global number of particles to receive: '& 1251 //TRIM(I2S(nReceived)),Level=10) 1252 END IF 1253 1254 n = SUM( ExcInfo(1:NoPartitions) % n ) 1255 CALL Info('ChangeParticlePartition','Total number of particles to sent: '& 1256 //TRIM(I2S(n)),Level=10) 1257 1258 1259 ! 1260 ! Collect particles to be sent to neighbours: 1261 ! ------------------------------------------- 1262 DO i=1,NoPartitions 1263 ALLOCATE( ExcInfo(i) % Gindex(ExcInfo(i) % n), & 1264 ExcInfo(i) % Particles(ExcInfo(i) % n) ) 1265 ExcInfo(i) % n = 0 1266 END DO 1267 1268 DO i=1,Particles % NumberOfParticles 1269 IF( Particles % Status(i) /= PARTICLE_PARTBOUNDARY ) CYCLE 1270 1271 IF ( dim==2 ) THEN 1272 Face => Mesh % Edges(Particles % FaceIndex(i)) 1273 FaceInterface => Mesh % ParallelInfo % EdgeInterface 1274 Neighbours => Mesh % ParallelInfo % & 1275 EdgeNeighbourList(Face % ElementIndex) % Neighbours 1276 ELSE 1277 Face => Mesh % Faces(Particles % FaceIndex(i)) 1278 FaceInterface => Mesh % ParallelInfo % FaceInterface 1279 Neighbours => Mesh % ParallelInfo % & 1280 FaceNeighbourList(Face % ElementIndex) % Neighbours 1281 END IF 1282 1283 IF ( FaceInterface(Face % ElementIndex) ) THEN 1284 nextPart = ParEnv % MyPE 1285 DO j=1,SIZE(Neighbours) 1286 IF ( ParEnv % Mype /= Neighbours(j) ) THEN 1287 nextPart = Neighbours(j); 1288 EXIT 1289 END IF 1290 END DO 1291 Particles % Status(i) = PARTICLE_LOST 1292 j = Perm(nextPart+1) 1293 IF ( j==0 ) THEN 1294 CALL Warn( 'ChangeParticlePartition', 'Neighbouring partition not found?') 1295 CYCLE 1296 END IF 1297 ExcInfo(j) % n = ExcInfo(j) % n+1 1298 n = ExcInfo(j) % n 1299 ExcInfo(j) % Particles(n) = i 1300 ExcInfo(j) % Gindex(n) = Face % GElementIndex 1301 END IF 1302 END DO 1303 1304 n = 0 1305 DO i=1,NoPartitions 1306 n = n + ExcInfo(i) % n 1307 END DO 1308 1309 CALL Info('ChangeParticlePartition','Collected particles from partitions: '& 1310 //TRIM(I2S(n)),Level=12) 1311 1312 ncomp = dim ! coordinate 1313 IF( ASSOCIATED( Particles % Velocity ) ) ncomp = ncomp + dim 1314 IF( ASSOCIATED( Particles % PrevCoordinate ) ) ncomp = ncomp + dim 1315 IF( ASSOCIATED( Particles % PrevVelocity ) ) ncomp = ncomp + dim 1316 IF( ASSOCIATED( Particles % Force ) ) ncomp = ncomp + dim 1317 Var => Particles % Variables 1318 DO WHILE( ASSOCIATED(Var) ) 1319 ncomp = ncomp + Var % Dofs 1320 IF( Var % Dofs /= 1 ) CALL Warn('ChangeParticlePartition','Implement for vectors!') 1321 Var => Var % Next 1322 END DO 1323 1324 ncompInt = 0 1325 IF ( ASSOCIATED(Particles % NodeIndex) ) ncompInt = ncompInt + 1 1326 IF ( ASSOCIATED(Particles % Partition) ) ncompInt = ncompInt + 1 1327 ! status, elementindex & closestnode are recomputed, and hence not communicated 1328 1329 CALL Info('ChangeParticlePartition','Transferring real entries between particles: '& 1330 //TRIM(I2S(ncomp)),Level=12) 1331 CALL Info('ChangeParticlePartition','Transferring integer entries between particles: '& 1332 //TRIM(I2S(ncompInt)),Level=12) 1333 1334 1335 n = 2*(n + 2*ncomp + MPI_BSEND_OVERHEAD*2*NoPartitions) 1336 CALL CheckBuffer(n) 1337 1338 CALL Info('ChangeParticlePartition','Size of data buffer: ' & 1339 //TRIM(I2S(n)),Level=12) 1340 1341 ! Send particles: 1342 ! --------------- 1343 CALL Info('ChangeParticlePartition','Now sending particle data',Level=14) 1344 DO j=1,NoPartitions 1345 n = ExcInfo(j) % n 1346 IF ( n<=0 ) CYCLE 1347 1348 CALL MPI_BSEND( ExcInfo(j) % Gindex, n, MPI_INTEGER, Neigh(j), & 1349 1001, ELMER_COMM_WORLD, ierr ) 1350 1351 ALLOCATE(Buf(dim*n*ncomp)) 1352 m = 0 1353 DO k=1,dim 1354 DO l=1,n 1355 m = m + 1 1356 Buf(m) = Particles % Coordinate(ExcInfo(j) % Particles(l),k) 1357 END DO 1358 END DO 1359 1360 IF ( ASSOCIATED(Particles % Velocity) ) THEN 1361 DO k=1,dim 1362 DO l=1,n 1363 m = m + 1 1364 Buf(m) = Particles % Velocity(ExcInfo(j) % Particles(l),k) 1365 END DO 1366 END DO 1367 END IF 1368 1369 IF ( ASSOCIATED(Particles % Force) ) THEN 1370 DO k=1,dim 1371 DO l=1,n 1372 m = m + 1 1373 Buf(m) = Particles % Force(ExcInfo(j) % Particles(l),k) 1374 END DO 1375 END DO 1376 END IF 1377 1378 IF ( ASSOCIATED(Particles % PrevCoordinate) ) THEN 1379 DO k=1,dim 1380 DO l=1,n 1381 m = m + 1 1382 Buf(m) = Particles % PrevCoordinate(ExcInfo(j) % Particles(l),k) 1383 END DO 1384 END DO 1385 END IF 1386 1387 IF ( ASSOCIATED(Particles % PrevVelocity) ) THEN 1388 DO k=1,dim 1389 DO l=1,n 1390 m = m + 1 1391 Buf(m) = Particles % PrevVelocity(ExcInfo(j) % Particles(l),k) 1392 END DO 1393 END DO 1394 END IF 1395 1396 Var => Particles % Variables 1397 DO WHILE( ASSOCIATED(Var) ) 1398 IF( Var % Dofs == 1 ) THEN 1399 DO l=1,n 1400 m = m + 1 1401 Buf(m) = Var % Values(ExcInfo(j) % Particles(l)) 1402 END DO 1403 END IF 1404 Var => Var % Next 1405 END DO 1406 1407 CALL MPI_BSEND( Buf, m, MPI_DOUBLE_PRECISION, & 1408 Neigh(j), 1002, ELMER_COMM_WORLD, ierr ) 1409 1410 DEALLOCATE(Buf) 1411 1412 IF( ncompInt > 0 ) THEN 1413 ! Sent integers also 1414 ALLOCATE(BufInt(n*ncompInt)) 1415 1416 m = 0 1417 IF ( ASSOCIATED(Particles % NodeIndex) ) THEN 1418 DO l=1,n 1419 m = m + 1 1420 BufInt(m) = Particles % NodeIndex(ExcInfo(j) % Particles(l)) 1421 END DO 1422 END IF 1423 1424 IF ( ASSOCIATED(Particles % Partition) ) THEN 1425 DO l=1,n 1426 m = m + 1 1427 BufInt(m) = Particles % Partition(ExcInfo(j) % Particles(l)) 1428 END DO 1429 END IF 1430 CALL MPI_BSEND( BufInt, m, MPI_INTEGER, Neigh(j), 1003, ELMER_COMM_WORLD, ierr ) 1431 1432 DEALLOCATE(BufInt) 1433 END IF 1434 END DO 1435 1436 1437 DEALLOCATE(Perm) 1438 DO i=1,NoPartitions 1439 DEALLOCATE( ExcInfo(i) % Gindex, ExcInfo(i) % Particles ) 1440 END DO 1441 DEALLOCATE(ExcInfo) 1442 1443 ! Recv particles: 1444 ! --------------- 1445 CALL Info('ChangeParticlePartition','Now receiving particle data',Level=14) 1446 1447 n = SUM(Recv_Parts) 1448 1449 CALL DeleteLostParticles(Particles) 1450 IF ( Particles % NumberOfParticles+n > Particles % MaxNumberOfParticles ) THEN 1451 CALL IncreaseParticles( Particles, Particles % NumberOfParticles + 2*n - & 1452 Particles % MaxNumberOfParticles ) 1453 ELSE 1454 END IF 1455 1456 IF(Particles % dim==2 ) THEN 1457 nFaces = Mesh % NumberOfEdges 1458 Faces => Mesh % Edges 1459 ELSE 1460 Faces => Mesh % Faces 1461 nFaces = Mesh % NumberOfFaces 1462 END IF 1463 1464 DO i=1,NoPartitions 1465 n = Recv_Parts(i) 1466 IF ( n<=0 ) CYCLE 1467 1468 proc = Neigh(i) 1469 ALLOCATE(Indexes(n)) 1470 1471 CALL MPI_RECV( Indexes, n, MPI_INTEGER, proc, & 1472 1001, ELMER_COMM_WORLD, status, ierr ) 1473 1474 ALLOCATE(Failed(n)) 1475 Failed = .FALSE. 1476 1477 n_part=Particles % NumberOfParticles 1478 DO j=1,n 1479 k=SearchElement( nFaces, Faces, Indexes(j) ) 1480 IF ( k <= 0 ) THEN 1481 Failed(j) = .TRUE. 1482 CYCLE 1483 END IF 1484 1485 Face => Faces(k) 1486 Parent => Face % BoundaryInfo % Left 1487 IF ( .NOT.ASSOCIATED(Parent) ) & 1488 Parent => Face % BoundaryInfo % Right 1489 1490 n_part = n_part+1 1491 Particles % Status(n_part) = PARTICLE_PARTBOUNDARY 1492 Particles % ElementIndex(n_part) = Parent % ElementIndex 1493 END DO 1494 1495 m = n*ncomp*dim 1496 IF ( ASSOCIATED(Particles % Velocity) ) m=m+n*dim 1497 ALLOCATE(Buf(m)) 1498 CALL MPI_RECV( Buf, m, MPI_DOUBLE_PRECISION, proc, & 1499 1002, ELMER_COMM_WORLD, status, ierr ) 1500 1501 n_part=Particles % NumberOfParticles 1502 m = 0 1503 DO k=1,dim 1504 q = 0 1505 DO l=1,n 1506 m = m + 1 1507 IF(Failed(l)) CYCLE 1508 q = q + 1 1509 Particles % Coordinate(n_part+q,k) = Buf(m) 1510 END DO 1511 END DO 1512 1513 IF ( ASSOCIATED(Particles % Velocity) ) THEN 1514 DO k=1,dim 1515 q = 0 1516 DO l=1,n 1517 m = m + 1 1518 IF(Failed(l)) CYCLE 1519 q = q + 1 1520 Particles % Velocity(n_part+q,k) = Buf(m) 1521 END DO 1522 END DO 1523 END IF 1524 1525 IF ( ASSOCIATED(Particles % Force) ) THEN 1526 DO k=1,dim 1527 q = 0 1528 DO l=1,n 1529 m = m + 1 1530 IF(Failed(l)) CYCLE 1531 q = q + 1 1532 Particles % Force(n_part+q,k) = Buf(m) 1533 END DO 1534 END DO 1535 END IF 1536 1537 IF ( ASSOCIATED(Particles % PrevCoordinate) ) THEN 1538 DO k=1,dim 1539 q = 0 1540 DO l=1,n 1541 m = m + 1 1542 IF (Failed(l)) CYCLE 1543 q = q + 1 1544 Particles % PrevCoordinate(n_part+q,k) = Buf(m) 1545 END DO 1546 END DO 1547 END IF 1548 1549 IF ( ASSOCIATED(Particles % PrevVelocity) ) THEN 1550 DO k=1,dim 1551 q = 0 1552 DO l=1,n 1553 m = m + 1 1554 IF (Failed(l)) CYCLE 1555 q = q + 1 1556 Particles % PrevVelocity(n_part+q,k) = Buf(m) 1557 END DO 1558 END DO 1559 END IF 1560 1561 Var => Particles % Variables 1562 DO WHILE( ASSOCIATED(Var) ) 1563 IF( Var % Dofs == 1 ) THEN 1564 q = 0 1565 DO l=1,n 1566 m = m + 1 1567 IF(Failed(l)) CYCLE 1568 q = q + 1 1569 Var % Values(n_part+q) = Buf(m) 1570 END DO 1571 END IF 1572 Var => Var % Next 1573 END DO 1574 1575 DEALLOCATE(Buf) 1576 1577 IF( ncompInt > 0 ) THEN 1578 1579 ALLOCATE(BufInt(n*ncompInt)) 1580 m = n*ncompInt 1581 1582 CALL MPI_RECV( BufInt, m, MPI_INTEGER, proc, 1003, ELMER_COMM_WORLD, status, ierr ) 1583 1584 m = 0 1585 IF( ASSOCIATED( Particles % NodeIndex ) ) THEN 1586 q = 0 1587 DO l=1,n 1588 m = m + 1 1589 IF(Failed(l)) CYCLE 1590 q = q + 1 1591 Particles % NodeIndex(n_part+q) = BufInt(m) 1592 END DO 1593 END IF 1594 1595 IF( ASSOCIATED( Particles % Partition ) ) THEN 1596 q = 0 1597 DO l=1,n 1598 m = m + 1 1599 IF(Failed(l)) CYCLE 1600 q = q + 1 1601 Particles % Partition(n_part+q) = BufInt(m) 1602 END DO 1603 END IF 1604 1605 DEALLOCATE(BufInt) 1606 END IF 1607 1608 Particles % NumberOfParticles = Particles % NumberOfParticles + COUNT(.NOT.Failed) 1609 DEALLOCATE(Indexes, Failed) 1610 END DO 1611 1612 DEALLOCATE(Recv_Parts, Neigh, Requests) 1613 CALL MPI_BARRIER( ELMER_COMM_WORLD, ierr ) 1614 1615 CALL Info('ChangeParticlePartition','Information exchange done',Level=10) 1616 1617 1618 CONTAINS 1619 1620 ! 1621 ! Search an element Item from an ordered Element_t array(N) and return 1622 ! Index to that array element. Return value -1 means Item was not found. 1623 ! 1624 FUNCTION SearchElement( N, IArray, Item ) RESULT(Indx) 1625 IMPLICIT NONE 1626 1627 INTEGER :: Item, Indx, i 1628 INTEGER :: N 1629 TYPE(Element_t) :: Iarray(:) 1630 1631 ! Local variables 1632 1633 INTEGER :: Lower, Upper, lou 1634 1635 !********************************************************************* 1636 1637 Indx = -1 1638 Upper = N 1639 Lower = 1 1640 1641 ! Handle the special case 1642 1643 IF ( Upper < Lower ) RETURN 1644 1645 DO WHILE( .TRUE. ) 1646 IF ( IArray(Lower) % GelementIndex == Item ) THEN 1647 Indx = Lower 1648 EXIT 1649 ELSE IF ( IArray(Upper) % GelementIndex == Item ) THEN 1650 Indx = Upper 1651 EXIT 1652 END IF 1653 1654 IF ( (Upper - Lower) > 1 ) THEN 1655 Lou = ISHFT((Upper + Lower), -1) 1656 IF ( IArray(lou) % GelementIndex < Item ) THEN 1657 Lower = Lou 1658 ELSE 1659 Upper = Lou 1660 END IF 1661 ELSE 1662 EXIT 1663 END IF 1664 END DO 1665 END FUNCTION SearchElement 1666 END FUNCTION ChangeParticlePartition 1667 1668 1669 !--------------------------------------------------------- 1670 !> Subroutine for advecting back to given partition and 1671 !> node index. 1672 !--------------------------------------------------------- 1673 SUBROUTINE ParticleAdvectParallel(Particles, SentField, RecvField, dofs ) 1674 !--------------------------------------------------------- 1675 TYPE(Particle_t), POINTER :: Particles 1676 REAL(KIND=dp), POINTER :: SentField(:), RecvField(:) 1677 INTEGER :: Dofs 1678 !--------------------------------------------------------- 1679 INTEGER i,j,k,l,m,n,dim,NoPartitions,NoParticles,part, & 1680 ierr, status(MPI_STATUS_SIZE), nReceived, nSent, nerr 1681 INTEGER, ALLOCATABLE :: RecvParts(:), SentParts(:), Requests(:) 1682 TYPE(Mesh_t), POINTER :: Mesh 1683 REAL(KIND=dp), ALLOCATABLE :: SentReal(:),RecvReal(:) 1684 INTEGER, ALLOCATABLE :: SentInt(:),RecvInt(:) 1685 !--------------------------------------------------------- 1686 1687 CALL Info('ParticleAdvectParallel',& 1688 'Returning particle info to their initiating partition',Level=15) 1689 1690 nReceived = 0 1691 IF( ParEnv% PEs == 1 ) RETURN 1692 1693 Mesh => GetMesh() 1694 dim = Particles % dim 1695 1696!debug = particles % partition(no) == 2 .and. particles % nodeindex(no) == 325 1697 NoPartitions = ParEnv % PEs 1698 NoParticles = Particles % NumberOfParticles 1699 1700 IF( .NOT. ASSOCIATED( Particles % Partition ) ) THEN 1701 CALL Fatal('ParticleAdvectParallel','Partition must be present!') 1702 END IF 1703 IF( .NOT. ASSOCIATED( Particles % NodeIndex ) ) THEN 1704 CALL Fatal('ParticleAdvectParallel','NodeIndex must be present!') 1705 END IF 1706 IF( Dofs /= 1 ) THEN 1707 CALL Fatal('ParticleAdvectParallel','Implement for more than one dof!') 1708 END IF 1709 1710 ! First take the components of the field that lie in the present partition. 1711 !------------------------------------------------------------------------- 1712 DO i=1,Particles % NumberOfParticles 1713 Part = Particles % Partition(i) 1714 IF( Part-1 == ParEnv % MyPe ) THEN 1715 j = Particles % NodeIndex(i) 1716 IF ( j==0 ) CYCLE 1717 RecvField(j) = SentField(i) 1718 END IF 1719 END DO 1720 1721 ! Count particles to be sent to neighbours: 1722 ! ----------------------------------------- 1723 ALLOCATE(SentParts(NoPartitions), RecvParts(NoPartitions), & 1724 Requests(NoPartitions)) 1725 SentParts = 0 1726 RecvParts = 0 1727 Requests = 0 1728 1729 nerr = 0 1730 DO i=1,Particles % NumberOfParticles 1731 Part = Particles % Partition(i) 1732 IF( Part-1 == ParEnv % MyPe ) CYCLE 1733 IF( Part < 1 .OR. Part > ParEnv % PEs ) THEN 1734 nerr = nerr + 1 1735 CYCLE 1736 END IF 1737 SentParts(Part) = SentParts(Part) + 1 1738 END DO 1739 IF( nerr > 0 ) THEN 1740 CALL Info('ParticleAdvectParallel','Invalid partition in particles: '//TRIM(I2S(nerr))) 1741 END IF 1742 1743 n = SUM( SentParts ) 1744 CALL Info('ParticleAdvectParallel','Local particles to be sent: '//TRIM(I2S(n)),Level=12) 1745 1746 CALL MPI_ALLREDUCE( n, nSent, 1, MPI_INTEGER, & 1747 MPI_SUM, ELMER_COMM_WORLD, ierr ) 1748 1749 IF( nSent > 0 ) THEN 1750 CALL Info('ParticleAdvectParallel','Global particles to be sent: '& 1751 //TRIM(I2S(nSent)),Level=12) 1752 ELSE 1753 ! If nobody is sending any particles then there can be no need to receive particles either 1754 ! Thus we can make an early exit. 1755 DEALLOCATE(SentParts, RecvParts, Requests ) 1756 CALL Info('ParticleAdvectParallel','Nothing to do in parallel!',Level=15) 1757 RETURN 1758 END IF 1759 1760 ! Receive interface sizes: 1761 !-------------------------- 1762 DO i=1,NoPartitions 1763 IF( i-1 == ParEnv % MyPe ) CYCLE 1764 CALL MPI_BSEND( SentParts(i), 1, MPI_INTEGER, i-1, & 1765 1000, ELMER_COMM_WORLD, ierr ) 1766 END DO 1767 1768 DO i=1,NoPartitions 1769 IF( i-1 == ParEnv % MyPe ) CYCLE 1770 CALL MPI_RECV( RecvParts(i), 1, MPI_INTEGER, i-1, & 1771 1000, ELMER_COMM_WORLD, Status, ierr ) 1772 END DO 1773 1774 n = SUM(RecvParts) 1775 CALL Info('ParticleAdvectParallel','Particles to be received: '//TRIM(I2S(n)),Level=12) 1776 1777 CALL MPI_ALLREDUCE( n, nReceived, 1, MPI_INTEGER, & 1778 MPI_SUM, ELMER_COMM_WORLD, ierr ) 1779 1780 IF ( nReceived==0 ) THEN 1781 DEALLOCATE(RecvParts, SentParts, Requests ) 1782 RETURN 1783 END IF 1784 1785 CALL Info('ParticleAdvectParallel','Total number of particles to be received: '& 1786 //TRIM(I2S(nReceived)),Level=12) 1787 1788 n = 2*(n + MPI_BSEND_OVERHEAD*2*NoPartitions) 1789 CALL CheckBuffer(n) 1790 1791 CALL Info('ParticleAdvectParallel','Buffer size for sending and receiving: ' & 1792 //TRIM(I2S(n)),Level=14) 1793 1794 1795 ! Allocate sent and receive buffers based on the maximum needed size. 1796 !-------------------------------------------------------------------- 1797 n = MAXVAL( SentParts ) 1798 ALLOCATE( SentReal(n), SentInt(n) ) 1799 CALL Info('ParticleAdvectParallel','Allocating sent buffer of size: '& 1800 //TRIM(I2S(n)),Level=18) 1801 1802 n = MAXVAL( RecvParts ) 1803 ALLOCATE( RecvReal(n), RecvInt(n) ) 1804 CALL Info('ParticleAdvectParallel','Allocating receive buffer of size: '& 1805 //TRIM(I2S(n)),Level=18) 1806 1807 ! Send particles: 1808 ! --------------- 1809 CALL Info('ParticleAdvectParallel','Now sending field',Level=14) 1810 1811 DO j=1,NoPartitions 1812 1813 IF( j-1 == ParEnv % MyPe ) CYCLE 1814 IF( SentParts(j) == 0 ) CYCLE 1815 1816 m = 0 1817 DO l=1,NoParticles 1818 IF( Particles % Partition(l) == j ) THEN 1819 m = m + 1 1820 SentReal(m) = SentField(l) 1821 SentInt(m) = Particles % NodeIndex(l) 1822 END IF 1823 END DO 1824 1825 CALL MPI_BSEND( SentInt, m, MPI_INTEGER, j-1, & 1826 1001, ELMER_COMM_WORLD, ierr ) 1827 1828 CALL MPI_BSEND( SentReal, m, MPI_DOUBLE_PRECISION, j-1, & 1829 1002, ELMER_COMM_WORLD, ierr ) 1830 END DO 1831 1832 1833 ! Recv particles: 1834 ! --------------- 1835 CALL Info('ParticleAdvectParallel','Now receiving field',Level=14) 1836 1837 nerr = 0 1838 DO j=1,NoPartitions 1839 1840 IF( j-1 == ParEnv % MyPe ) CYCLE 1841 1842 m = RecvParts(j) 1843 IF ( m == 0 ) CYCLE 1844 1845 CALL MPI_RECV( RecvInt, m, MPI_INTEGER, j-1, & 1846 1001, ELMER_COMM_WORLD, status, ierr ) 1847 1848 CALL MPI_RECV( RecvReal, m, MPI_DOUBLE_PRECISION, j-1, & 1849 1002, ELMER_COMM_WORLD, status, ierr ) 1850 1851 DO l=1,m 1852 k = RecvInt(l) 1853 IF( k <=0 .OR. k > SIZE( RecvField ) ) THEN 1854 nerr = nerr + 1 1855 CYCLE 1856 END IF 1857 RecvField(k) = RecvReal(l) 1858 END DO 1859 END DO 1860 1861 IF( nerr > 0 ) THEN 1862 CALL Info('ParticleAdvectParallel','Invalid received index in particles: '//TRIM(I2S(nerr))) 1863 END IF 1864 1865 CALL MPI_BARRIER( ELMER_COMM_WORLD, ierr ) 1866 1867 DEALLOCATE(SentParts, RecvParts, Requests, SentInt, SentReal, RecvInt, RecvReal ) 1868 1869 CALL Info('ParticleAdvectParallel','Particle field communication done',Level=14) 1870 1871 END SUBROUTINE ParticleAdvectParallel 1872 1873 1874 1875 1876 !--------------------------------------------------------- 1877 !> Subroutine computes the means of coordinates / velocities / force. 1878 ! The statistics could be made more detailed... 1879 !--------------------------------------------------------- 1880 SUBROUTINE ParticleStatistics( Particles, DerOrder ) 1881 TYPE(Particle_t), POINTER :: Particles 1882 INTEGER :: DerOrder 1883 1884 REAL(KIND=dp) :: Coord(3),MeanCoord(3),AbsCoord(3),VarCoord(3), & 1885 MinCoord(3), MaxCoord(3),val 1886 INTEGER :: i,j,Cnt,NoParticles,TotParticles,dim 1887 REAL(KIND=dp), POINTER :: TargetVector(:,:) 1888 INTEGER, POINTER :: Status(:) 1889 CHARACTER(LEN=MAX_NAME_LEN) :: DataName 1890 1891 1892 MeanCoord = 0.0_dp 1893 AbsCoord = 0.0_dp 1894 VarCoord = 0.0_dp 1895 MinCoord = HUGE( MinCoord ) 1896 MaxCoord = -HUGE( MaxCoord ) 1897 1898 Cnt = 0 1899 NoParticles = Particles % NumberOfParticles 1900 dim = Particles % dim 1901 Coord = 0.0_dp 1902 1903 IF( DerOrder == -1 ) THEN 1904 TargetVector => Particles % PrevCoordinate 1905 DataName = 'previous coordinate values' 1906 ELSE IF( DerOrder == 0 ) THEN 1907 TargetVector => Particles % Coordinate 1908 DataName = 'current coordinate values' 1909 ELSE IF( DerOrder == 1 ) THEN 1910 TargetVector => Particles % Velocity 1911 DataName = 'current velocity values' 1912 ELSE IF( DerOrder == 2 ) THEN 1913 TargetVector => Particles % Force 1914 DataName = 'current force values' 1915 ELSE 1916 CALL Fatal('ParticleStatistics','Unknown value for DerOrder!') 1917 END IF 1918 1919 Status => Particles % Status 1920 1921 DO i=1,NoParticles 1922 IF( Status(i) >= PARTICLE_LOST ) CYCLE 1923 IF( Status(i) < PARTICLE_INITIATED ) CYCLE 1924 1925 Coord(1:dim) = TargetVector(i,1:dim) 1926 1927 MeanCoord = MeanCoord + Coord 1928 AbsCoord = AbsCoord + ABS( Coord ) 1929 VarCoord = VarCoord + Coord**2 1930 DO j=1,dim 1931 MinCoord(j) = MIN( MinCoord(j), Coord(j) ) 1932 MaxCoord(j) = MAX( MaxCoord(j), Coord(j) ) 1933 END DO 1934 Cnt = Cnt + 1 1935 END DO 1936 1937 TotParticles = NINT( ParallelReduction( 1.0_dp * Cnt ) ) 1938 IF( TotParticles == 0 ) THEN 1939 CALL Warn('MeanParticleCoordinate','No active particles!') 1940 RETURN 1941 END IF 1942 1943 1944 IF( TotParticles > Cnt ) THEN 1945 ! Compute parallel sums 1946 DO j=1,dim 1947 MeanCoord(j) = ParallelReduction( MeanCoord(j) ) 1948 AbsCoord(j) = ParallelReduction( AbsCoord(j) ) 1949 VarCoord(j) = ParallelReduction( varCoord(j) ) 1950 MinCoord(j) = ParallelReduction( MinCoord(j),1 ) 1951 MaxCoord(j) = ParallelReduction( MaxCoord(j),2 ) 1952 END DO 1953 END IF 1954 1955 IF( TotParticles == 1 ) THEN 1956 IF( ParEnv % myPE == 0 ) THEN 1957 PRINT *,'Particle info on '//TRIM(DataName) 1958 PRINT *,'Val: ',MinCoord(1:dim),& 1959 ' Abs: ',SQRT(SUM( MinCoord(1:dim)**2 )) 1960 END IF 1961 1962 ELSE 1963 MeanCoord = MeanCoord / TotParticles 1964 AbsCoord = AbsCoord / TotParticles 1965 1966 ! If unlucky with rounding error this could be negative even though it really can't 1967 DO j=1,dim 1968 val = VarCoord(j) / TotParticles - MeanCoord(j)**2 1969 IF( val <= TINY(val) ) THEN 1970 VarCoord(j) = 0.0_dp 1971 ELSE 1972 VarCoord(j) = SQRT( val ) 1973 END IF 1974 END DO 1975 1976 IF( ParEnv % myPE == 0 ) THEN 1977 PRINT *,'Statistical info on '//TRIM(DataName) 1978 PRINT *,'Mean:',MeanCoord(1:dim) 1979 PRINT *,'Abs: ',AbsCoord(1:dim) 1980 PRINT *,'Var: ',VarCoord(1:dim) 1981 PRINT *,'Min: ',MinCoord(1:dim) 1982 PRINT *,'Max: ',MaxCoord(1:dim) 1983 END IF 1984 END IF 1985 1986 END SUBROUTINE ParticleStatistics 1987 1988 1989 !--------------------------------------------------------- 1990 !> Echos some information on particle amounts to standard output. 1991 !--------------------------------------------------------- 1992 SUBROUTINE ParticleInformation( Particles, ParticleStepsTaken, TimestepsTaken, tottime ) 1993 TYPE(Particle_t), POINTER :: Particles 1994 INTEGER :: ParticleStepsTaken, TimestepsTaken 1995 REAL(KIND=dp) :: tottime 1996 1997 INTEGER :: TotParticleStepsTaken, TotNoParticles 1998 1999 CALL ParticleStatusCount( Particles ) 2000 2001 IF( ParEnv % PEs > 1 ) THEN 2002 TotNoParticles = NINT( ParallelReduction( 1.0_dp * Particles % NumberOfParticles ) ) 2003 TotParticleStepsTaken = NINT( ParallelReduction( 1.0_dp * ParticleStepsTaken) ) 2004 ELSE 2005 TotNoParticles = Particles % NumberOfParticles 2006 TotParticleStepsTaken = ParticleStepsTaken 2007 END IF 2008 2009 WRITE (Message,'(A,T22,I12)') 'Active particles:',TotNoParticles 2010 CALL Info('ParticleInformation',Message,Level=6) 2011 WRITE (Message,'(A,T22,ES12.2)') 'Elapsed time:',tottime 2012 CALL Info('ParticleInformation',Message,Level=6) 2013 WRITE (Message,'(A,T22,I12)') 'Time steps taken:',TimeStepsTaken 2014 CALL Info('ParticleInformation',Message,Level=8) 2015 WRITE (Message,'(A,T22,I12)') 'Particle steps taken:',TotParticleStepsTaken 2016 CALL Info('ParticleInformation',Message,Level=8) 2017 2018 END SUBROUTINE ParticleInformation 2019 2020 2021 2022 !--------------------------------------------------------- 2023 !> Computes the characterestic speed for time integration. 2024 !> The speed may be either computed for the whole set or 2025 !> alternatively to just one particle. 2026 !--------------------------------------------------------- 2027 FUNCTION CharacteristicSpeed( Particles, No ) RESULT ( CharSpeed ) 2028 TYPE(Particle_t), POINTER :: Particles 2029 INTEGER, OPTIONAL :: No 2030 REAL(KIND=dp) :: CharSpeed 2031 2032 REAL(KIND=dp) :: Velo(3),Speed,SumSpeed,MaxSpeed 2033 INTEGER :: i,j,Cnt,NoParticles,dim,ParallelParticles 2034 REAL(KIND=dp), POINTER :: Velocity(:,:) 2035 INTEGER, POINTER :: Status(:) 2036 TYPE(ValueList_t), POINTER :: Params 2037 LOGICAL :: Found, UseMaxSpeed, Visited = .FALSE. 2038 2039 SAVE Visited, MaxSpeed 2040 2041 IF(.NOT. Visited ) THEN 2042 Params => ListGetSolverParams() 2043 UseMaxSpeed = GetLogical( Params,'Characteristic Max Speed',Found) 2044 Visited = .TRUE. 2045 END IF 2046 2047 dim = Particles % dim 2048 Velocity => Particles % Velocity 2049 2050 IF( PRESENT(No)) THEN 2051 Velo(1:dim) = Velocity(No,1:dim) 2052 CharSpeed = SQRT( SUM( Velo(1:dim) ** 2 ) ) 2053 RETURN 2054 END IF 2055 2056 NoParticles = Particles % NumberOfParticles 2057 Status => Particles % Status 2058 CharSpeed = 0.0_dp 2059 Velo = 0.0_dp 2060 Cnt = 0 2061 2062 ! Compute characteristic speed for square since it avoids taking the sqrt 2063 DO i=1,NoParticles 2064 IF( Status(i) >= PARTICLE_LOST ) CYCLE 2065 IF( Status(i) < PARTICLE_INITIATED ) CYCLE 2066 2067 Cnt = Cnt + 1 2068 Velo(1:dim) = Velocity(i,1:dim) 2069 2070 Speed = SUM( Velo(1:dim) ** 2 ) 2071 IF( UseMaxSpeed ) THEN 2072 MaxSpeed = MAX( MaxSpeed, Speed ) 2073 ELSE 2074 SumSpeed = SumSpeed + Speed 2075 END IF 2076 END DO 2077 2078 IF( Cnt == 0 ) RETURN 2079 2080 IF( UseMaxSpeed ) THEN 2081 CharSpeed = ParallelReduction( MaxSpeed, 2 ) 2082 ELSE 2083 ParallelParticles = NINT( ParallelReduction( 1.0_dp * Cnt ) ) 2084 CharSpeed = ParallelReduction( SumSpeed ) / ParallelParticles 2085 END IF 2086 CharSpeed = SQRT( CharSpeed ) 2087 CharSpeed = MAX( Charspeed, TINY( CharSpeed ) ) 2088 2089 WRITE( Message,'(A,E13.6)') 'Speed for timestep control:',CharSpeed 2090 CALL Info('CharacteristicSpeed',Message,Level=12) 2091 2092 END FUNCTION CharacteristicSpeed 2093 2094 2095 2096 !--------------------------------------------------------- 2097 !> Computes the characterestic time spent in an element 2098 !> Currently computed just for one element as computing the 2099 !> size of element is a timeconsuming operation. 2100 !--------------------------------------------------------- 2101 FUNCTION CharacteristicElementSize( Particles, No ) RESULT ( ElementSize ) 2102 2103 TYPE(Particle_t), POINTER :: Particles 2104 REAL(KIND=dp) :: CharTime 2105 INTEGER, OPTIONAL :: No 2106 2107 REAL(KIND=dp) :: ElementSize, u, v, w, DetJ, h0, h 2108 REAL(KIND=dp) :: ElementSizeMin, ElementSizeMax, ElementSizeAve 2109 REAL(KIND=dp), POINTER :: Basis(:), SizeValues(:) 2110 LOGICAL :: Stat, ConstantDt, UseMinSize, Found, Visited = .FALSE. 2111 TYPE(Element_t), POINTER :: Element 2112 TYPE(Nodes_t) :: Nodes 2113 TYPE(Mesh_t), POINTER :: Mesh 2114 INTEGER :: i, t, n, NoElems, dim 2115 TYPE(GaussIntegrationPoints_t) :: IP 2116 TYPE(Variable_t), POINTER :: ElementSizeVar 2117 TYPE(ValueList_t), POINTER :: Params 2118 2119 SAVE Visited, Mesh, dim, Nodes, Basis, h0, SizeValues 2120 2121 ConstantDt = .NOT. PRESENT( No ) 2122 2123 2124 IF( Visited ) THEN 2125 IF( ConstantDt ) THEN 2126 ElementSize = h0 2127 ELSE 2128 i = Particles % ElementIndex(No) 2129 IF( i > 0 ) THEN 2130 ElementSize = SizeValues(i) 2131 ELSE 2132 ElementSize = 0._dp 2133 END IF 2134 END IF 2135 RETURN 2136 END IF 2137 2138 Mesh => GetMesh() 2139 n = Mesh % MaxElementNodes 2140 dim = Mesh % MeshDim 2141 ALLOCATE( Basis(n) ) 2142 NoElems = Mesh % NumberOfBulkElements 2143 2144 IF( .NOT. ConstantDt ) THEN 2145 ! Use existing variable only if it is of correct size! 2146 ElementSizeVar => VariableGet( Mesh % Variables,'Element Size' ) 2147 NULLIFY( SizeValues ) 2148 2149 IF( ASSOCIATED( ElementSizeVar ) ) THEN 2150 SizeValues => ElementSizeVar % Values 2151 IF( ASSOCIATED( SizeValues ) ) THEN 2152 IF( SIZE( SizeValues ) /= NoElems ) NULLIFY( SizeValues ) 2153 END IF 2154 END IF 2155 IF( .NOT. ASSOCIATED( SizeValues ) ) THEN 2156 ALLOCATE( SizeValues( NoElems ) ) 2157 END IF 2158 SizeValues = 0.0_dp 2159 END IF 2160 2161 ElementSizeMin = HUGE( ElementSizeMin ) 2162 ElementSizeMax = 0.0_dp 2163 ElementSizeAve = 0.0_dp 2164 NoElems = Mesh % NumberOfBulkElements 2165 2166 DO t=1,NoElems 2167 Element => Mesh % Elements(t) 2168 CALL GetElementNodes( Nodes, Element ) 2169 n = GetElementNOFNodes() 2170 2171 IP = GaussPoints( Element ) 2172 u = SUM( IP % u ) / IP % n 2173 v = SUM( IP % v ) / IP % n 2174 w = SUM( IP % w ) / IP % n 2175 2176 stat = ElementInfo( Element, Nodes, U, V, W, detJ, Basis ) 2177 h = detJ ** (1.0_dp / dim ) 2178 ElementSizeMin = MIN( ElementSizeMin, h ) 2179 ElementSizeMax = MAX( ElementSizeMax, h ) 2180 ElementSizeAve = ElementSizeAve + h 2181 2182 IF( .NOT. ConstantDt ) SizeValues(t) = h 2183 END DO 2184 2185 ElementSizeMin = ParallelReduction( ElementSizeMin, 1 ) 2186 ElementSizeMax = ParallelReduction( ElementSizeMax, 2 ) 2187 ElementSizeAve = ParallelReduction( ElementSizeAve ) 2188 NoElems = NINT( ParallelReduction( 1.0_dp * NoElems ) ) 2189 2190 ElementSizeAve = ElementSizeAve / NoElems 2191 2192 WRITE(Message,'(A,ES12.3)') 'Minimum element size:',ElementSizeMin 2193 CALL Info('CharacteristicElementSize', Message,Level=12) 2194 2195 WRITE(Message,'(A,ES12.3)') 'Maximum element size:',ElementSizeMax 2196 CALL Info('CharacteristicElementSize', Message,Level=12) 2197 2198 WRITE(Message,'(A,ES12.3)') 'Average element size:',ElementSizeAve 2199 CALL Info('CharacteristicElementSize', Message,Level=12) 2200 2201 Params => ListGetSolverParams() 2202 UseMinSize = GetLogical( Params,'Characteristic Minimum Size',Found) 2203 IF( UseMinSize ) THEN 2204 h0 = ElementSizeMin 2205 ELSE 2206 h0 = ElementSizeAve 2207 END IF 2208 2209 IF(ConstantDt) THEN 2210 ElementSize = h0 2211 ELSE 2212 ElementSize = SizeValues(No) 2213 END IF 2214 2215 Visited = .TRUE. 2216 2217 END FUNCTION CharacteristicElementSize 2218 2219 2220 2221 !----------------------------------------------------------------------- 2222 !> Computes the characterestic time spent for each direction separately. 2223 !> Currently can only be computed for one particle at a time. 2224 !----------------------------------------------------------------------- 2225 FUNCTION CharacteristicUnisoTime( Particles, No ) RESULT ( CharTime ) 2226 2227 TYPE(Particle_t), POINTER :: Particles 2228 REAL(KIND=dp) :: CharTime 2229 INTEGER, OPTIONAL :: No 2230 2231 REAL(KIND=dp) :: Center(3),CartSize(3),Velo(3) 2232 TYPE(Element_t), POINTER :: Element 2233 TYPE(Nodes_t) :: Nodes 2234 TYPE(Mesh_t), POINTER :: Mesh 2235 INTEGER :: i, t, n, dim 2236 LOGICAL :: Visited = .FALSE. 2237 2238 SAVE Visited, Mesh, dim, Nodes 2239 2240 IF(.NOT. Visited ) THEN 2241 Mesh => GetMesh() 2242 dim = Mesh % MeshDim 2243 Visited = .TRUE. 2244 END IF 2245 2246 ! Absolute of velocity in each direction 2247 Velo(1:dim) = ABS( Particles % Velocity(No,1:dim) ) 2248 2249 t = Particles % ElementIndex(No) 2250 Element => Mesh % Elements(t) 2251 CALL GetElementNodes( Nodes, Element ) 2252 n = Element % TYPE % NumberOfNodes 2253 2254 ! Center point of element 2255 Center(1) = SUM( Nodes % x(1:n) ) / n 2256 Center(2) = SUM( Nodes % y(1:n) ) / n 2257 Center(3) = SUM( Nodes % z(1:n) ) / n 2258 2259 ! Average distance from center multiplied by two in eadh direction 2260 CartSize(1) = 2 * SUM( ABS( Nodes % x(1:n) - Center(1) ) ) / n 2261 CartSize(2) = 2 * SUM( ABS( Nodes % y(1:n) - Center(2) ) ) / n 2262 CartSize(3) = 2 * SUM( ABS( Nodes % z(1:n) - Center(3) ) ) / n 2263 2264 CharTime = HUGE( CharTime ) 2265 DO i=1,dim 2266 IF( CharTime * Velo(i) > CartSize(i) ) THEN 2267 CharTime = CartSize(i) / Velo(i) 2268 END IF 2269 END DO 2270 2271 END FUNCTION CharacteristicUnisoTime 2272 2273 2274 2275 !--------------------------------------------------------- 2276 !> Computes the characterestic time spent in an element 2277 !> Currently computed just for one element as computing the 2278 !> size of element is a timeconsuming operation. 2279 !--------------------------------------------------------- 2280 FUNCTION CharacteristicElementTime( Particles, No ) RESULT ( CharTime ) 2281 2282 TYPE(Particle_t), POINTER :: Particles 2283 REAL(KIND=dp) :: CharTime 2284 INTEGER, OPTIONAL :: No 2285 2286 REAL(KIND=dp) :: CharSpeed, CharSize 2287 2288 CharSpeed = CharacteristicSpeed( Particles, No ) 2289 CharSize = CharacteristicElementSize( Particles, No ) 2290 CharTime = CharSize / CharSpeed 2291 2292 IF( .NOT. PRESENT( No ) ) THEN 2293 WRITE(Message,'(A,ES12.3)') 'Characteristic time of particle:',CharTime 2294 CALL Info('CharacteristicElementTime', Message,Level=10) 2295 END IF 2296 2297 END FUNCTION CharacteristicElementTime 2298 2299 2300 !------------------------------------------------------------------------ 2301 !> Finds a random point that is guaranteed within the element 2302 !------------------------------------------------------------------------- 2303 FUNCTION RandomPointInElement( Element, Nodes ) RESULT ( Coord ) 2304 2305 TYPE(Element_t) :: Element 2306 TYPE(Nodes_t) :: Nodes 2307 REAL(KIND=dp) :: Coord(3) 2308 2309 REAL(KIND=dp) :: u,v,w,DetJ 2310 REAL(KIND=dp), ALLOCATABLE :: Basis(:) 2311 INTEGER :: family,n 2312 LOGICAL :: Stat 2313 2314 family = Element % TYPE % ElementCode / 100 2315 n = Element % TYPE % NumberOfNodes 2316 2317 ALLOCATE( Basis(n) ) 2318 2319 2320100 SELECT CASE ( family ) 2321 2322 CASE ( 2 ) 2323 u = 2*EvenRandom() - 1.0 2324 2325 CASE ( 3 ) 2326 u = EvenRandom() 2327 v = EvenRandom() 2328 IF( u + v > 1.0_dp ) GOTO 100 2329 2330 CASE ( 4 ) 2331 u = 2*EvenRandom() - 1.0 2332 v = 2*EvenRandom() - 1.0 2333 2334 CASE ( 5 ) 2335 u = EvenRandom() 2336 v = EvenRandom() 2337 w = EvenRandom() 2338 IF( u + v + w > 1.0_dp ) GOTO 100 2339 2340 CASE ( 8 ) 2341 u = 2*EvenRandom() - 1.0 2342 v = 2*EvenRandom() - 1.0 2343 w = 2*EvenRandom() - 1.0 2344 2345 CASE DEFAULT 2346 CALL Fatal('RandomPointInElement','Not implemented for elementtype') 2347 2348 END SELECT 2349 2350 Stat = ElementInfo( Element, Nodes, u, v, w, detJ, Basis ) 2351 2352 Coord(1) = SUM( Basis(1:n) * Nodes % x(1:n) ) 2353 Coord(2) = SUM( Basis(1:n) * Nodes % y(1:n) ) 2354 Coord(3) = SUM( Basis(1:n) * Nodes % z(1:n) ) 2355 2356 END FUNCTION RandomPointInElement 2357 2358 2359 !------------------------------------------------------------------------ 2360 !> Initialize particle positions and velocities with a number of different 2361 !> methods, both random and uniform. 2362 !------------------------------------------------------------------------- 2363 SUBROUTINE InitializeParticles( Particles, InitParticles, AppendParticles, Group, SaveOrigin ) 2364 2365 TYPE(Particle_t), POINTER :: Particles 2366 INTEGER, OPTIONAL :: InitParticles 2367 LOGICAL, OPTIONAL :: AppendParticles 2368 INTEGER, OPTIONAL :: Group 2369 LOGICAL, OPTIONAL :: SaveOrigin 2370 2371 TYPE(ValueList_t), POINTER :: Params, BodyForce 2372 TYPE(Variable_t), POINTER :: Var, AdvVar 2373 TYPE(Element_t), POINTER :: CurrentElement 2374 TYPE(Mesh_t), POINTER :: Mesh 2375 TYPE(Nodes_t) :: Nodes 2376 INTEGER :: Offset, NewParticles,LastParticle,NoElements 2377 INTEGER :: dim, ElementIndex, body_id, bf_id 2378 REAL(KIND=dp), POINTER :: rWork(:,:),Coordinate(:,:), Velocity(:,:) 2379 REAL(KIND=dp) :: Velo(3), Coord(3), Center(3), CenterVelo(3), time0, dist 2380 CHARACTER(LEN=MAX_NAME_LEN) :: InitMethod 2381 INTEGER :: i,j,k,l,n,vdofs,nonodes, InitStatus, TotParticles, No 2382 INTEGER, POINTER :: MaskPerm(:), InvPerm(:), NodeIndexes(:) 2383 LOGICAL :: Found, GotIt, GotMask, RequirePositivity, GotWeight 2384 REAL(KIND=dp), POINTER :: InitialValues(:,:) 2385 REAL(KIND=dp) :: mass,boltz,temp,coeff,eps,frac,meanval 2386 REAL(KIND=dp) :: MinCoord(3), MaxCoord(3), Diam, DetJ, MinDetJ, MaxDetJ, & 2387 MinWeight, MaxWeight, MeanWeight, Phi 2388 REAL(KIND=dp), POINTER :: MaskVal(:) 2389 REAL(KIND=dp), ALLOCATABLE :: Weight(:) 2390 INTEGER :: nx,ny,nz,nmax,ix,iy,iz,ind 2391 LOGICAL :: CheckForSize, Parallel, SaveParticleOrigin 2392 LOGICAL, POINTER :: DoneParticle(:) 2393 CHARACTER(LEN=MAX_NAME_LEN) :: VariableName, str 2394 2395 SAVE Nodes 2396 2397 2398 Mesh => GetMesh() 2399 Params => ListGetSolverParams() 2400 dim = Particles % Dim 2401 Parallel = ( ParEnv % PEs > 1 ) 2402 2403 IF( PRESENT( SaveOrigin ) ) THEN 2404 SaveParticleOrigin = SaveOrigin 2405 ELSE 2406 SaveParticleOrigin = .FALSE. 2407 END IF 2408 2409 !------------------------------------------------------------------------ 2410 ! Initialize the timestepping strategy stuff 2411 !------------------------------------------------------------------------- 2412 2413 InitMethod = ListGetString( Params,'Coordinate Initialization Method',gotIt ) 2414 Particles % RK2 = ListGetLogical( Params,'Runge Kutta', GotIt ) 2415 IF( Particles % RK2 .AND. ParEnv % PEs > 1 ) THEN 2416 CALL Warn('InitializeParticles','> Runge Kutta < integration might not work in parallel') 2417 END IF 2418 2419 Particles % DtConstant = ListGetLogical( Params,'Particle Dt Constant',GotIt ) 2420 IF(.NOT. GotIt) Particles % DtConstant = .TRUE. 2421 2422 IF( ListGetLogical( Params,'Particle Dt Negative',GotIt ) ) THEN 2423 Particles % DtSign = -1 2424 END IF 2425 2426 2427 !------------------------------------------------------------------------ 2428 ! The user may use a mask to initialize the particles only at a part of the 2429 ! domain, or to utilize the ordeing of the permutation vector. 2430 ! Create the mask before deciding on the number which may be relative 2431 !------------------------------------------------------------------------- 2432 GotMask = .FALSE. 2433 VariableName = ListGetString( Params,'Initialization Condition Variable',GotIt ) 2434 IF(GotIt) THEN 2435 RequirePositivity = .TRUE. 2436 ELSE 2437 VariableName = ListGetString( Params,'Initialization Mask Variable',GotIt ) 2438 RequirePositivity = .FALSE. 2439 END IF 2440 2441 IF(GotIt) THEN 2442 Var => VariableGet( Mesh % Variables, TRIM(VariableName) ) 2443 IF( .NOT. ASSOCIATED( Var ) ) THEN 2444 CALL Fatal('InitializeParticles','Mask / Condition variable does not exist!') 2445 END IF 2446 2447 MaskPerm => Var % Perm 2448 MaskVal => Var % Values 2449 2450 IF(.NOT. ( ASSOCIATED( MaskPerm ) .AND. ASSOCIATED(MaskVal)) ) THEN 2451 CALL Warn('InitializeParticles','Initialization variable does not exist?') 2452 ELSE IF( MAXVAL( MaskPerm ) == 0 ) THEN 2453 CALL Warn('InitializeParticles','Initialization variable of size zero?') 2454 nonodes = 0 2455 noelements = 0 2456 InvPerm => NULL() 2457 ELSE 2458 GotMask = .TRUE. 2459 IF( InitMethod == 'nodal') THEN 2460 ALLOCATE( InvPerm(SIZE(MaskPerm)) ) 2461 InvPerm = 0 2462 j = 0 2463 DO i=1,SIZE(MaskPerm) 2464 k = MaskPerm(i) 2465 IF( k == 0 ) CYCLE 2466 IF( RequirePositivity ) THEN 2467 IF( MaskVal( k ) < 0.0_dp ) CYCLE 2468 END IF 2469 j = j + 1 2470 InvPerm(j) = i 2471 END DO 2472 nonodes = j 2473 2474 PRINT *,'Total nodes vs. masked',Mesh % NumberOfNodes,nonodes 2475 ELSE IF( InitMethod == 'elemental') THEN 2476 ALLOCATE( InvPerm( MAX( Mesh % NumberOfBulkElements, Mesh % NumberOfBoundaryElements ) ) ) 2477 InvPerm = 0 2478 2479 j = 0 2480 DO i=1,Mesh % NumberOfBulkElements + Mesh % NumberOfBoundaryElements 2481 CurrentElement => Mesh % Elements(i) 2482 NodeIndexes => CurrentElement % NodeIndexes 2483 n = CurrentElement % TYPE % NumberOfNodes 2484 2485 IF( i == Mesh % NumberOfBulkElements ) THEN 2486 IF( j > 0 ) EXIT 2487 END IF 2488 2489 IF( ANY( MaskPerm( NodeIndexes ) == 0 ) ) CYCLE 2490 2491 IF( RequirePositivity ) THEN 2492 meanval = SUM( MaskVal( MaskPerm( NodeIndexes ) ) ) 2493 IF( meanval < 0.0_dp ) CYCLE 2494 END IF 2495 2496 ! If some of bulk elements have been found active 2497 j = j + 1 2498 InvPerm(j) = i 2499 2500 END DO 2501 noelements = j 2502 2503 PRINT *,'Total elements vs. masked',Mesh % NumberOfBulkElements,noelements 2504 END IF 2505 END IF 2506 ELSE 2507 nonodes = Mesh % NumberOfNodes 2508 noelements = Mesh % NumberOfBulkElements 2509 END IF 2510 2511 GotWeight = ListCheckPresentAnyBodyForce(CurrentModel, & 2512 'Particle Initialization Weight') 2513 IF( GotWeight ) THEN 2514 CALL Info('InitializeParticles','Using weight when creating particles',Level=8) 2515 ALLOCATE( Weight( Mesh % MaxElementNodes ) ) 2516 Weight = 0.0_dp 2517 END IF 2518 2519 2520 !------------------------------------------------------------------------ 2521 ! Use a simple bounding box for initializatin 2522 ! By default a local bounding box is used... 2523 !------------------------------------------------------------------------- 2524 IF( InitMethod(1:3) == 'box') THEN 2525 Eps = GetCReal( Params,'Wall Particle Radius',GotIt) 2526 IF(.NOT. GotIt) eps = 1.0d-8 2527 2528 MinCoord(1) = GetCReal( Params,'Min Initial Coordinate 1',GotIt) 2529 IF(.NOT. GotIt) MinCoord(1) = Particles % LocalMinCoord(1) + eps 2530 2531 MaxCoord(1) = GetCReal( Params,'Max Initial Coordinate 1',GotIt) 2532 IF(.NOT. GotIt) MaxCoord(1) = Particles % LocalMaxCoord(1) - eps 2533 2534 MinCoord(2) = GetCReal( Params,'Min Initial Coordinate 2',GotIt) 2535 IF(.NOT. GotIt) MinCoord(2) = Particles % LocalMinCoord(2) + eps 2536 2537 MaxCoord(2) = GetCReal( Params,'Max Initial Coordinate 2',GotIt) 2538 IF(.NOT. GotIt) MaxCoord(2) = Particles % LocalMaxCoord(2) - eps 2539 2540 MinCoord(3) = GetCReal( Params,'Min Initial Coordinate 3',GotIt) 2541 IF(.NOT. GotIt) MinCoord(3) = Particles % LocalMinCoord(3) 2542 2543 MaxCoord(3) = GetCReal( Params,'Max Initial Coordinate 3',GotIt) 2544 IF(.NOT. GotIt) MaxCoord(3) = Particles % LocalMaxCoord(3) - eps 2545 END IF 2546 2547 2548 IF( InitMethod == 'box random cubic' .OR. InitMethod == 'box uniform cubic') THEN 2549 Diam = 2 * GetCReal( Params,'Particle Cell Radius',GotIt) 2550 IF(.NOT. GotIt ) THEN 2551 Diam = GetCReal( Params,'Particle Cell Size',GotIt) 2552 END IF 2553 IF(.NOT. GotIt ) THEN 2554 Diam = 2 * GetCReal( Params,'Particle Radius',GotIt) 2555 END IF 2556 IF(.NOT. GotIt ) THEN 2557 CALL Fatal('InitializeParticles','Size of unit cell not given') 2558 END IF 2559 2560 nx = NINT ( ( MaxCoord(1) - MinCoord(1) ) / Diam ) 2561 ny = NINT( ( MaxCoord(2) - MinCoord(2) ) / Diam ) 2562 IF( dim == 3 ) THEN 2563 nz = NINT( ( MaxCoord(3) - MinCoord(3) ) / Diam ) 2564 ELSE 2565 nz = 1 2566 END IF 2567 END IF 2568 2569 AdvVar => VariableGet( Mesh % Variables,'AdvectorData') 2570 2571 !------------------------------------------------------------------------ 2572 ! Now decide on the number of particles. 2573 !------------------------------------------------------------------------- 2574 IF( PRESENT( AppendParticles ) ) THEN 2575 Offset = Particles % NumberOfParticles 2576 ELSE 2577 Offset = 0 2578 END IF 2579 2580 2581 IF( PRESENT( InitParticles ) ) THEN 2582 NewParticles = InitParticles 2583 ELSE IF( ASSOCIATED( AdvVar ) ) THEN 2584 NewParticles = SIZE( AdvVar % Values ) 2585 CALL Info('InitializeParticles','Using pre-existing ParticleData variable to define particles!') 2586 ELSE 2587 IF( InitMethod == 'box uniform cubic') THEN 2588 NewParticles = nx * ny * nz 2589 ELSE 2590 NewParticles = GetInteger( Params,'Number of Particles',GotIt) 2591 END IF 2592 IF(.NOT. GotIt ) THEN 2593 frac = GetCReal( Params,'Particle Node Fraction',GotIt) 2594 IF( GotIt ) THEN 2595 NewParticles = NINT( frac * nonodes ) 2596 ELSE 2597 frac = GetCReal( Params,'Particle Element Fraction',GotIt) 2598 IF( GotIt ) THEN 2599 NewParticles = NINT( frac * noelements ) 2600 ELSE 2601 frac = GetCReal( Params,'Particle Cell Fraction',GotIt) 2602 IF( GotIt ) THEN 2603 NewParticles = NINT( frac * nx * ny * nz ) 2604 ELSE 2605 CALL Fatal('InitializeParticles','Could not determine the number of new particles!') 2606 END IF 2607 END IF 2608 END IF 2609 END IF 2610 END IF 2611 2612 IF( ParEnv% PEs == 1 ) THEN 2613 TotParticles = NewParticles 2614 ELSE 2615 TotParticles = NINT( ParallelReduction( 1.0_dp * NewParticles ) ) 2616 END IF 2617 2618 IF( TotParticles == 0 ) THEN 2619 CALL Fatal('InitializeParticles','No Particles to Initialize') 2620 ELSE 2621 WRITE( Message,'(A,I0)') 'Number of Particles: ',TotParticles 2622 CALL Info('InitializeParticles',Message,Level=6) 2623 END IF 2624 2625 !------------------------------------------------------------------------ 2626 ! If there are no particles in this partition, nothing to do 2627 !------------------------------------------------------------------------- 2628 IF( NewParticles == 0 ) RETURN 2629 2630 2631 !------------------------------------------------------------------------ 2632 ! Interval of particles 2633 !------------------------------------------------------------------------- 2634 IF( PRESENT( AppendParticles ) ) THEN 2635 Offset = Particles % NumberOfParticles 2636 ELSE 2637 Offset = 0 2638 END IF 2639 LastParticle = Offset + NewParticles 2640 2641 2642 !------------------------------------------------------------------------ 2643 ! Allocate particles 2644 !------------------------------------------------------------------------- 2645 CALL AllocateParticles( Particles, LastParticle ) 2646 2647 IF( SaveParticleOrigin ) THEN 2648 IF(.NOT. ASSOCIATED( Particles % NodeIndex ) ) THEN 2649 ALLOCATE( Particles % NodeIndex( NewParticles ) ) 2650 Particles % NodeIndex = 0 2651 END IF 2652 2653 IF( Parallel ) THEN 2654 IF(.NOT. ASSOCIATED( Particles % Partition ) ) THEN 2655 ALLOCATE( Particles % Partition( NewParticles ) ) 2656 END IF 2657 Particles % Partition = ParEnv % MyPe + 1 2658 END IF 2659 END IF 2660 2661 2662 IF( Particles % NumberOfGroups > 0 ) THEN 2663 IF( .NOT. PRESENT( Group ) ) THEN 2664 CALL Fatal('InitializeParticles','Group used inconsistently!') 2665 END IF 2666 Particles % Group(Offset+1:LastParticle) = Group 2667 END IF 2668 2669 Particles % NumberOfParticles = LastParticle 2670 2671 Velocity => Particles % Velocity 2672 Coordinate => Particles % Coordinate 2673 2674 2675 SELECT CASE ( InitMethod ) 2676 2677 CASE ('nodal ordered') 2678 CALL Info('InitializeParticles',& 2679 'Initializing particles evenly among nodes',Level=10) 2680 2681 Particles % NumberOfParticles = NewParticles 2682 DO i=1,NewParticles 2683 k = Offset + i 2684 j = (nonodes-1)*(i-1)/(NewParticles-1)+1 2685 IF( GotMask ) j = InvPerm(j) 2686 Coordinate(k,1) = Mesh % Nodes % x(j) 2687 Coordinate(k,2) = Mesh % Nodes % y(j) 2688 IF( dim == 3 ) Coordinate(k,3) = Mesh % Nodes % z(j) 2689 END DO 2690 2691 2692 IF( SaveParticleOrigin ) THEN 2693 DO i=1,Mesh % NumberOfBulkElements 2694 CurrentElement => Mesh % Elements(i) 2695 NodeIndexes => CurrentElement % NodeIndexes 2696 n = CurrentElement % TYPE % NumberOfNodes 2697 DO j=1,n 2698 k = NodeIndexes(j) 2699 IF( GotMask ) THEN 2700 k = MaskPerm(k) 2701 IF( k == 0 ) CYCLE 2702 END IF 2703 Particles % ElementIndex(k) = i 2704 Particles % NodeIndex(k) = NodeIndexes(j) 2705 END DO 2706 END DO 2707 END IF 2708 2709 2710 CASE ('elemental random') 2711 CALL Info('InitializeParticles',& 2712 'Initializing particles randomly within elements',Level=10) 2713 2714 n = Mesh % MaxElementNodes 2715 ALLOCATE( Nodes % x(n), Nodes % y(n),Nodes % z(n) ) 2716 2717 Particles % NumberOfParticles = NewParticles 2718 2719 MaxDetJ = 0.0_dp 2720 MinDetJ = HUGE( MinDetJ ) 2721 MaxWeight = -HUGE( MaxWeight ) 2722 MinWeight = HUGE( MinWeight ) 2723 2724 DO i = 1, NoElements 2725 2726 j = i 2727 IF( GotMask ) j = InvPerm(j) 2728 2729 CurrentElement => Mesh % Elements(j) 2730 NodeIndexes => CurrentElement % NodeIndexes 2731 n = CurrentElement % TYPE % NumberOfNodes 2732 2733 ! If weight is used see that we have a weight, and that it is positive 2734 IF( GotWeight ) THEN 2735 IF( j > Mesh % NumberOfBulkElements ) CYCLE 2736 2737 body_id = CurrentElement % BodyId 2738 bf_id = ListGetInteger( CurrentModel % Bodies(body_id) % Values,& 2739 'Body Force',minv=1) 2740 BodyForce => CurrentModel % BodyForces(bf_id) % Values 2741 Weight(1:n) = ListGetReal( BodyForce,'Particle Initialization Weight',& 2742 n, NodeIndexes, GotIt) 2743 IF(.NOT. GotIt) CYCLE 2744 2745 MeanWeight = SUM( Weight(1:n) ) / n 2746 MaxWeight = MAX( MaxWeight, MeanWeight ) 2747 MinWeight = MIN( MinWeight, MeanWeight ) 2748 IF( MeanWeight <= 0.0_dp ) CYCLE 2749 END IF 2750 2751 ! Compute the size of the element if this is an active element. 2752 Nodes % x(1:n) = Mesh % Nodes % x(NodeIndexes) 2753 Nodes % y(1:n) = Mesh % Nodes % y(NodeIndexes) 2754 Nodes % z(1:n) = Mesh % Nodes % z(NodeIndexes) 2755 2756 DetJ = ElementSize( CurrentElement, Nodes ) 2757 MaxDetJ = MAX( MaxDetJ, DetJ ) 2758 MinDetJ = MIN( MinDetJ, DetJ ) 2759 END DO 2760 2761 WRITE( Message,'(A,ES12.3)') 'Maximum size of elements:',MaxDetJ 2762 CALL Info('InitializeParticle',Message,Level=8) 2763 WRITE( Message,'(A,ES12.3)') 'Minimum size of elements:',MinDetJ 2764 CALL Info('InitializeParticle',Message,Level=8) 2765 IF( GotWeight ) THEN 2766 WRITE( Message,'(A,ES12.3)') 'Maximum weight in elements:',MaxWeight 2767 CALL Info('InitializeParticle',Message,Level=8) 2768 WRITE( Message,'(A,ES12.3)') 'Minimum weight in elements:',MinWeight 2769 CALL Info('InitializeParticle',Message,Level=8) 2770 END IF 2771 2772 IF( MaxWeight < 0.0 ) THEN 2773 CALL Info('InitializeParticle','No positive weight!') 2774 RETURN 2775 END IF 2776 2777 ! If all elements are of same size then no need to check for size 2778 CheckForSize = ( MinDetJ < (1-EPSILON(MaxDetJ))*MaxDetJ ) 2779 IF( GotWeight ) THEN 2780 CheckForSize = CheckForSize .OR. & 2781 ( MinWeight < (1-EPSILON(MaxWeight))*MaxWeight ) 2782 END IF 2783 2784 i = 0 2785 DO WHILE(.TRUE.) 2786 2787 j = CEILING( NoElements * EvenRandom() ) 2788 IF( GotMask ) j = InvPerm(j) 2789 2790 CurrentElement => Mesh % Elements(j) 2791 NodeIndexes => CurrentElement % NodeIndexes 2792 n = CurrentElement % TYPE % NumberOfNodes 2793 2794 Nodes % x(1:n) = Mesh % Nodes % x(NodeIndexes) 2795 Nodes % y(1:n) = Mesh % Nodes % y(NodeIndexes) 2796 Nodes % z(1:n) = Mesh % Nodes % z(NodeIndexes) 2797 2798 IF( CheckForSize ) THEN 2799 DetJ = ElementSize( CurrentElement, Nodes ) 2800 2801 ! The weight could be computed really using the integration point 2802 ! Here we assumes constant weight within the whole element. 2803 IF( GotWeight ) THEN 2804 IF( j > Mesh % NumberOfBulkElements ) CYCLE 2805 2806 body_id = CurrentElement % BodyId 2807 bf_id = ListGetInteger( CurrentModel % Bodies(body_id) % Values,& 2808 'Body Force',minv=1) 2809 BodyForce => CurrentModel % BodyForces(bf_id) % Values 2810 Weight(1:n) = ListGetReal( BodyForce,'Particle Initialization Weight',& 2811 n, NodeIndexes, GotIt) 2812 IF(.NOT. GotIt ) CYCLE 2813 2814 MeanWeight = SUM( Weight(1:n) ) / n 2815 IF( MeanWeight <= 0.0_dp ) CYCLE 2816 2817 ! Do importance samping for the particles 2818 IF( EvenRandom() * MaxDetJ * MaxWeight > DetJ * MeanWeight ) CYCLE 2819 ELSE 2820 IF( EvenRandom() * MaxDetJ > DetJ ) CYCLE 2821 END IF 2822 END IF 2823 2824 ! Create a random particle within the element 2825 Coord = RandomPointInElement( CurrentElement, Nodes ) 2826 2827 i = i + 1 2828 k = Offset + i 2829 Coordinate(k,1:dim) = Coord(1:dim) 2830 2831 ! Only a bulk element may own a particle 2832 IF( j <= Mesh % NumberOfBulkElements ) THEN 2833 Particles % ElementIndex(k) = j 2834 END IF 2835 2836 IF( i == NewParticles ) EXIT 2837 END DO 2838 DEALLOCATE(Nodes % x, Nodes % y, Nodes % z) 2839 2840 CASE ('elemental ordered') 2841 CALL Info('InitializeParticles',& 2842 'Initializing particles evenly among elements',Level=10) 2843 2844 NewParticles = MIN(NoElements,NewParticles) 2845 Particles % NumberOfParticles = NewParticles 2846 2847 DO i=1,NewParticles 2848 k = Offset + i 2849 j = (NoElements-1)*(i-1)/(NewParticles-1)+1 2850 IF( GotMask ) j = InvPerm(j) 2851 2852 IF( j > Mesh % NumberOfBulkElements ) THEN 2853 PRINT *,'j too large',j,i,k,(NoElements-1)*(i-1)/(NewParticles-1)+1 2854 END IF 2855 2856 CurrentElement => Mesh % Elements(j) 2857 NodeIndexes => CurrentElement % NodeIndexes 2858 n = CurrentElement % TYPE % NumberOfNodes 2859 Coord(1) = SUM( Mesh % Nodes % x(NodeIndexes ) ) / n 2860 Coord(2) = SUM( Mesh % Nodes % y(NodeIndexes ) ) / n 2861 IF( dim == 3 ) Coord(3) = SUM( Mesh % Nodes % z(NodeIndexes ) ) / n 2862 2863 Coordinate(k,1:dim) = Coord(1:dim) 2864 2865 ! Only a bulk element may own a particle 2866 IF( j <= Mesh % NumberOfBulkElements ) THEN 2867 Particles % ElementIndex(i) = j 2868 END IF 2869 END DO 2870 2871 IF( SaveParticleOrigin ) THEN 2872 ! For now the initial index is confusingly named always "NodeIndex" 2873 Particles % NodeIndex = Particles % ElementIndex 2874 END IF 2875 2876 CASE ('advector') 2877 CALL Info('InitializeParticles',& 2878 'Initializing particles evenly on scaled dg points',Level=10) 2879 2880 AdvVar => VariableGet( Mesh % Variables,'AdvectorData' ) 2881 IF( .NOT. ASSOCIATED( AdvVar ) ) THEN 2882 CALL Fatal('InitializeParticles','Variable >AdvectorData< should exist!') 2883 END IF 2884 2885 VariableName = ListGetString( Params,'Velocity Variable Name',GotIt ) 2886 IF(.NOT. GotIt) VariableName = 'Flow Solution' 2887 Var => VariableGet( Mesh % Variables, TRIM(VariableName) ) 2888 IF( .NOT. ASSOCIATED( Var ) ) THEN 2889 CALL Fatal('InitializeParticles','Velocity variable needed to initialize advector') 2890 END IF 2891 vdofs = Var % Dofs 2892 2893 NewParticles = SIZE( AdvVar % Values ) 2894 2895 DO i=1,NoElements 2896 CurrentElement => Mesh % Elements(i) 2897 NodeIndexes => CurrentElement % NodeIndexes 2898 n = CurrentElement % TYPE % NumberOfNodes 2899 2900 IF( AdvVar % TYPE /= Variable_on_gauss_points ) THEN 2901 Center(1) = SUM( Mesh % Nodes % x(NodeIndexes ) ) / n 2902 Center(2) = SUM( Mesh % Nodes % y(NodeIndexes ) ) / n 2903 IF( dim == 3 ) Center(3) = SUM( Mesh % Nodes % z(NodeIndexes ) ) / n 2904 DO j=1,dim 2905 CenterVelo(j) = SUM( Var % Values(vdofs*(Var % Perm(NodeIndexes)-1)+j) ) / n 2906 END DO 2907 END IF 2908 2909 IF( AdvVar % TYPE == Variable_on_elements ) THEN 2910 No = AdvVar % Perm( i ) 2911 IF( No == 0 ) CYCLE 2912 Coordinate(No,1:dim) = Center(1:dim) 2913 2914 Velocity(No,1:dim) = CenterVelo(1:dim) 2915 2916 Particles % ElementIndex(No) = i 2917 IF( SaveParticleOrigin ) THEN 2918 Particles % NodeIndex(No) = No 2919 END IF 2920 2921 2922 ELSE IF( AdvVar % Type == Variable_on_nodes_on_elements ) THEN 2923 2924 BLOCK 2925 REAL(KIND=dp) :: DgScale 2926 LOGICAL :: GotScale 2927 2928 DGScale = ListGetCReal( Params,'DG Nodes Scale',GotScale ) 2929 IF(.NOT. GotScale ) DgScale = 1.0 / SQRT( 3.0_dp ) 2930 GotScale = ( ABS( DGScale - 1.0_dp ) > TINY( DgScale ) ) 2931 2932 DO j = 1, n 2933 No = AdvVar % Perm( CurrentElement % DgIndexes(j) ) 2934 IF( No == 0 ) CYCLE 2935 k = NodeIndexes(j) 2936 Coord(1) = Mesh % Nodes % x(k) 2937 Coord(2) = Mesh % Nodes % y(k) 2938 IF( dim == 3 ) Coord(3) = Mesh % Nodes % z(k) 2939 2940 DO l=1,dim 2941 Velo(l) = Var % Values(vdofs*(Var % Perm(k)-1)+l) 2942 END DO 2943 2944 IF( GotScale ) THEN 2945 Coord(1:dim) = Center(1:dim) + ( Coord(1:dim) - Center(1:dim) ) * DgScale 2946 Velo(1:dim) = CenterVelo(1:dim) + (Velo(1:dim) - CenterVelo(1:dim)) * DgScale 2947 END IF 2948 2949 Coordinate(No,1:dim) = Coord(1:dim) 2950 Velocity(No,1:dim) = Velo(1:dim) 2951 2952 Particles % ElementIndex(No) = i 2953 2954 IF( SaveParticleOrigin ) THEN 2955 Particles % NodeIndex(No) = No 2956 END IF 2957 END DO 2958 END BLOCK 2959 2960 2961 ELSE IF( AdvVar % TYPE == Variable_on_gauss_points ) THEN 2962 2963 BLOCK 2964 TYPE(GaussIntegrationPoints_t) :: IP 2965 REAL(KIND=dp) :: detJ, Basis(27) 2966 LOGICAL :: stat 2967 TYPE(Nodes_t), SAVE :: Nodes 2968 INTEGER :: m 2969 LOGICAL :: Debug 2970 2971 Debug = ( i == 0 ) 2972 2973 IF( i == 1 ) THEN 2974 m = 27 2975 ALLOCATE( Nodes % x(m), Nodes % y(m), Nodes % z(m)) 2976 END IF 2977 2978 Nodes % x(1:n) = Mesh % Nodes % x(NodeIndexes) 2979 Nodes % y(1:n) = Mesh % Nodes % y(NodeIndexes) 2980 Nodes % z(1:n) = Mesh % Nodes % z(NodeIndexes) 2981 2982 2983 IF( debug ) THEN 2984 PRINT *,'x:',nodes % x(1:n) 2985 PRINT *,'y:',nodes % y(1:n) 2986 PRINT *,'z:',nodes % z(1:n) 2987 END IF 2988 2989 m = AdvVar % Perm(i+1) - AdvVar % Perm(i) 2990 IF( m == 0 ) CYCLE 2991 2992 IP = GaussPoints(CurrentElement, m ) 2993 2994 DO j = 1, IP % n 2995 stat = ElementInfo( CurrentElement, Nodes, IP % v(j), IP % u(j), IP % w(j), detJ, Basis ) 2996 No = AdvVar % Perm(i) + j 2997 2998 Coord(1) = SUM( Basis(1:n) * Nodes % x(1:n) ) 2999 Coord(2) = SUM( Basis(1:n) * Nodes % y(1:n) ) 3000 IF( dim == 3 ) Coord(3) = SUM( Basis(1:n) * Nodes % z(1:n) ) 3001 3002 DO l=1,dim 3003 Velo(l) = SUM( Basis(1:n) * Var % Values(vdofs*(Var % Perm(NodeIndexes)-1)+l ) ) 3004 END DO 3005 3006 IF( Debug ) THEN 3007 PRINT *,'j:',j,m,No,Coord(1:dim),Velo(1:dim) 3008 END IF 3009 3010 Coordinate(No,1:dim) = Coord(1:dim) 3011 Velocity(No,1:dim) = Velo(1:dim) 3012 3013 Particles % ElementIndex(No) = i 3014 IF( SaveParticleOrigin ) THEN 3015 Particles % NodeIndex(No) = No 3016 END IF 3017 END DO 3018 END BLOCK 3019 3020 END IF 3021 END DO 3022 3023 3024 CASE ('sphere random') 3025 CALL Info('InitializeParticles',& 3026 'Initializing particles randomly within a sphere',Level=10) 3027 3028 Diam = GetCReal( Params,'Initial Sphere Radius') 3029 rWork => ListGetConstRealArray( Params,'Initial Sphere Center') 3030 IF ( ASSOCIATED(rwork) ) THEN 3031 Center = rWork(1:3,1) 3032 ELSE 3033 Center = 0.0_dp 3034 END IF 3035 3036 i = 0 3037 DO WHILE (.TRUE.) 3038 DO j=1,dim 3039 Coord(j) = Diam*(2*EvenRandom()-1) 3040 END DO 3041 ! Is the point within sphere (or circle in 2d) 3042 IF( SUM( Coord(1:dim)**2 ) > Diam*Diam ) CYCLE 3043 3044 i = i + 1 3045 k = Offset + i 3046 Coordinate(k,:) = Center + Coord(1:dim) 3047 IF( i == NewParticles ) EXIT 3048 END DO 3049 3050 CASE ('box random') 3051 DO i=1,NewParticles 3052 k = Offset + i 3053 DO j=1,dim 3054 Coord(j) = MinCoord(j) + (MaxCoord(j)-MinCoord(j)) * EvenRandom() 3055 END DO 3056 Coordinate(k,:) = Coord(1:dim) 3057 END DO 3058 3059 CASE ('box random cubic') 3060 CALL Info('InitializeParticles',& 3061 'Initializing particles randomly in a grid',Level=10) 3062 3063 nmax = nx * ny * nz 3064 IF( nmax < NewParticles ) THEN 3065 CALL Fatal('InitializeParticles','More particles than places in unit cell') 3066 END IF 3067 3068 ALLOCATE( DoneParticle(nx*ny*nz) ) 3069 3070 IF( NewParticles == nmax ) THEN 3071 ! if the list is full just set all true 3072 DoneParticle = .TRUE. 3073 ELSE IF( NewParticles < nmax / 2 ) THEN 3074 ! If there are few particles start from an empty list and count upwards 3075 DoneParticle = .FALSE. 3076 i = 0 3077 DO WHILE(.TRUE.) 3078 ind = NINT( NewParticles * EvenRandom() + 0.5 ) 3079 IF( .NOT. DoneParticle(i) ) THEN 3080 DoneParticle(ind) = .TRUE. 3081 i = i + 1 3082 IF( i == NewParticles ) EXIT 3083 END IF 3084 END DO 3085 ELSE 3086 ! if there are many particles start from a full list and count downwards 3087 DoneParticle = .TRUE. 3088 i = nmax 3089 DO WHILE(.TRUE.) 3090 ind = NINT( NewParticles * EvenRandom() + 0.5 ) 3091 IF( DoneParticle(i) ) THEN 3092 DoneParticle(ind) = .FALSE. 3093 i = i - 1 3094 IF( i == NewParticles ) EXIT 3095 END IF 3096 END DO 3097 END IF 3098 3099 ! set the coordinates 3100 i = 0 3101 DO ix = 1, nx 3102 DO iy = 1, ny 3103 DO iz = 1, nz 3104 ind = nx*ny*(iz-1) + nx*(iy-1) + ix 3105 IF( DoneParticle(ind) ) THEN 3106 i = i + 1 3107 k = Offset + i 3108 Coordinate(k,1) = MinCoord(1) + ( 1.0_dp*ix - 0.5) * Diam 3109 Coordinate(k,2) = MinCoord(2) + ( 1.0_dp*iy - 0.5) * Diam 3110 IF( dim == 3 ) THEN 3111 Coordinate(k,3) = MinCoord(3) + ( 1.0_dp*iz - 0.5) * Diam 3112 END IF 3113 END IF 3114 END DO 3115 END DO 3116 END DO 3117 DEALLOCATE( DoneParticle ) 3118 3119 CASE ('box uniform cubic') 3120 CALL Info('InitializeParticles',& 3121 'Initializing particles in a grid',Level=10) 3122 3123 nmax = nx * ny * nz 3124 IF( nmax /= NewParticles ) THEN 3125 CALL Fatal('InitializeParticles','Wrong number of particles') 3126 END IF 3127 3128 ! set the coordinates 3129 i = 0 3130 DO ix = 1, nx 3131 DO iy = 1, ny 3132 DO iz = 1, nz 3133 ind = nx*ny*(iz-1) + nx*(iy-1) + ix 3134 i = i + 1 3135 k = Offset + i 3136 Coordinate(k,1) = MinCoord(1) + ( 1.0_dp*ix - 0.5) * Diam 3137 Coordinate(k,2) = MinCoord(2) + ( 1.0_dp*iy - 0.5) * Diam 3138 IF( dim == 3 ) THEN 3139 Coordinate(k,3) = MinCoord(3) + ( 1.0_dp*iz - 0.5) * Diam 3140 END IF 3141 END DO 3142 END DO 3143 END DO 3144 3145 CASE DEFAULT 3146 CALL Info('InitializeParticles',& 3147 'Initializing particles using given coordinates',Level=10) 3148 3149 InitialValues => ListGetConstRealArray(Params,'Initial Coordinate',gotIt) 3150 IF(gotIt) THEN 3151 IF( SIZE(InitialValues,2) /= dim ) THEN 3152 CALL Fatal('ParticleTracker','Wrong dimension in > Initial Coordinate <') 3153 ELSE IF( SIZE(InitialValues,1) == 1 ) THEN 3154 DO i=1,NewParticles 3155 k = offset + i 3156 Coordinate(k,1:dim) = InitialValues(1,1:dim) 3157 END DO 3158 ELSE IF( SIZE(InitialValues,1) /= NewParticles ) THEN 3159 CALL Fatal('ParticleTracker','Wrong number of particles in > Initial Coordinate <') 3160 ELSE 3161 DO i=1,NewParticles 3162 k = Offset + i 3163 Coordinate(k,1:dim) = InitialValues(i,1:dim) 3164 END DO 3165 END IF 3166 ELSE 3167 CALL Fatal('ParticleTracker','> Initial Coordinate < not given') 3168 END IF 3169 END SELECT 3170 3171 3172 IF( GotMask ) THEN 3173 IF ( ASSOCIATED(InvPerm) ) DEALLOCATE( InvPerm ) 3174 END IF 3175 3176 !------------------------------------------------------------------------ 3177 ! Velocities may be initialized using a given list, or obtaining them 3178 ! from random even or maxwell boltzmann distributions. These are additive to 3179 ! allow bulk velocities with the random one. 3180 !------------------------------------------------------------------------- 3181 3182 InitialValues => ListGetConstRealArray(Params,'Initial Velocity',gotIt) 3183 IF(gotIt) THEN 3184 IF( SIZE(InitialValues,2) /= DIM ) THEN 3185 CALL Fatal('ParticleTracker','Wrong dimension in Initial Velocity') 3186 ELSE IF( SIZE(InitialValues,1) == 1 ) THEN 3187 DO i=1,NewParticles 3188 k = Offset + i 3189 Velocity(k,1:dim) = InitialValues(1,1:DIM) 3190 END DO 3191 ELSE IF( SIZE(InitialValues,1) /= NewParticles ) THEN 3192 CALL Fatal('ParticleTracker','Wrong number of particles in Initial Velocity') 3193 ELSE 3194 DO i=1,NewParticles 3195 k = Offset + i 3196 Velocity(k,1:dim) = InitialValues(i,1:dim) 3197 END DO 3198 END IF 3199 END IF 3200 3201 3202 InitMethod = ListGetString( Params,'Velocity Initialization Method',gotIt ) 3203 coeff = ListGetCReal( Params,'Initial Velocity Amplitude',GotIt) 3204 3205 3206 SELECT CASE ( InitMethod ) 3207 3208 CASE ('nodal velocity') 3209 CALL Info('InitializeParticles',& 3210 'Initializing velocities from the corresponding nodal velocity',Level=10) 3211 3212 VariableName = ListGetString( Params,'Velocity Variable Name',GotIt ) 3213 IF(.NOT. GotIt) VariableName = 'Flow Solution' 3214 Var => VariableGet( Mesh % Variables, TRIM(VariableName) ) 3215 IF( .NOT. ASSOCIATED( Var ) ) THEN 3216 CALL Fatal('InitializeParticles','Velocity variable needed for method >nodal velocity<') 3217 END IF 3218 3219 vdofs = Var % Dofs 3220 DO i=1,NewParticles 3221 k = Offset + i 3222 l = Particles % NodeIndex(i) 3223 l = Var % Perm(l) 3224 DO j=1,dim 3225 Velocity(k,j) = Var % Values(vdofs*(l-1)+j) 3226 END DO 3227 END DO 3228 3229 CASE ('elemental velocity') 3230 CALL Info('InitializeParticles',& 3231 'Initializing velocities from the corresponding elemental velocity',Level=10) 3232 3233 VariableName = ListGetString( Params,'Velocity Variable Name',GotIt ) 3234 IF(.NOT. GotIt) VariableName = 'Flow Solution' 3235 Var => VariableGet( Mesh % Variables, TRIM(VariableName) ) 3236 IF( .NOT. ASSOCIATED( Var ) ) THEN 3237 CALL Fatal('InitializeParticles','Velocity variable needed for method >elemental velocity<') 3238 END IF 3239 vdofs = Var % Dofs 3240 3241 DO i=1,NewParticles 3242 k = Offset + i 3243 l = Particles % NodeIndex(i) ! now an elemental index 3244 NodeIndexes => Mesh % Elements(l) % NodeIndexes 3245 DO j=1,dim 3246 Velocity(k,j) = SUM( Var % Values(vdofs*(Var % Perm(NodeIndexes)-1)+j) ) / SIZE( NodeIndexes ) 3247 END DO 3248 END DO 3249 3250 CASE ('advector') 3251 CALL Info('InitializeParticles',& 3252 'Velocities have been initialized together with the position',Level=10) 3253 3254 CASE ('thermal random') 3255 CALL Info('InitializeParticles',& 3256 'Initializing velocities from a thermal distribution',Level=10) 3257 3258 IF(.NOT. GotIt) THEN 3259 mass = ListGetConstReal( Params,'Particle Mass') 3260 temp = ListGetConstReal( Params,'Particle Temperature') 3261 boltz = ListGetConstReal( CurrentModel % Constants,'Boltzmann constant') 3262 coeff = SQRT(boltz * temp / mass ) 3263 END IF 3264 3265 DO i=1,NewParticles 3266 k = Offset + i 3267 DO j=1,dim 3268 Velo(j) = NormalRandom() 3269 END DO 3270 Velocity(k,:) = Velocity(k,:) + coeff * Velo(1:dim) 3271 END DO 3272 3273 CASE ('even random') 3274 CALL Info('InitializeParticles',& 3275 'Initializing velocities from a even distribution',Level=10) 3276 3277 DO i=1,NewParticles 3278 k = Offset + i 3279 DO j=1,dim 3280 Velo(j) = (2*EvenRandom()-1) 3281 END DO 3282 Velocity(k,:) = Velocity(k,:) + coeff * Velo(1:dim) 3283 END DO 3284 3285 CASE ('constant random') 3286 CALL Info('InitializeParticles',& 3287 'Initializing constant velocities with random direction',Level=10) 3288 3289 DO i=1,NewParticles 3290 k = Offset + i 3291 DO j=1,dim 3292 Velo(j) = (2*EvenRandom()-1) 3293 END DO 3294 Velo(1:dim) = Velo(1:dim) / SQRT(SUM(Velo(1:dim)**2)) 3295 Velocity(k,:) = Velocity(k,:) + coeff * Velo(1:dim) 3296 END DO 3297 3298 CASE ('constant 2d') 3299 CALL Info('InitializeParticles',& 3300 'Initializing constant velocities evenly to space',Level=10) 3301 3302 DO i=1,NewParticles 3303 k = Offset + i 3304 Phi = 2.0_dp * PI * i / NewParticles 3305 Velo(1) = coeff * COS( Phi ) 3306 Velo(2) = coeff * SIN( Phi ) 3307 Velocity(k,:) = Velocity(k,:) + Velo(1:dim) 3308 END DO 3309 3310 CASE DEFAULT 3311 3312 END SELECT 3313 3314 3315 ! There may be a timestep related to initial velocity, 3316 ! which may be used to have the initial status developed 3317 ! from the initial coordinates. 3318 !------------------------------------------------------- 3319 time0 = ListGetCReal(Params,'Initial Velocity Time',gotIt) 3320 IF( GotIt ) THEN 3321 DO i=1,NewParticles 3322 k = Offset + i 3323 Coord(1:dim) = time0 * Velocity(k,:) 3324 Coordinate(k,:) = Coordinate(k,:) + Coord(1:dim) 3325 3326 dist = SQRT( SUM( Coord(1:dim)**2 ) ) 3327! Particles % Distance(k) = dist 3328 END DO 3329 END IF 3330 3331 ! Initialize coordinate with octree if requested 3332 !------------------------------------------------------- 3333 IF( ListGetLogical(Params,'Initial Coordinate Search',gotIt) ) THEN 3334 Coord = 0.0_dp 3335 DO i=1,NewParticles 3336 k = Offset + i 3337 ElementIndex = Particles % ElementIndex(k) 3338 IF( ElementIndex > 0 ) CYCLE 3339 Coord(1:dim) = Coordinate(k,:) 3340 CALL LocateParticleInMeshOctree( ElementIndex, Coord ) 3341 Particles % ElementIndex(k) = ElementIndex 3342 END DO 3343 END IF 3344 3345 !------------------------------------------------------ 3346 ! The initial status of particles is different if using 3347 ! gradual release strategy. 3348 !------------------------------------------------------- 3349 IF( ListCheckPresent( Params,'Particle Release Number') .OR. & 3350 ListCheckPresent( Params,'Particle Release Fraction') ) THEN 3351 InitStatus = PARTICLE_WAITING 3352 ELSE 3353 InitStatus = PARTICLE_INITIATED 3354 END IF 3355 3356 DO i=1,NewParticles 3357 k = Offset + i 3358 Particles % Status(k) = InitStatus 3359 END DO 3360 3361 Particles % PrevCoordinate = Coordinate 3362 IF( ASSOCIATED( Particles % PrevVelocity ) ) THEN 3363 Particles % PrevVelocity = Velocity 3364 END IF 3365 3366 ! Finally, add additional particle variables that are used for path integrals 3367 IF( ListCheckPresentAnyBodyForce( CurrentModel,& 3368 'Particle Distance Integral Source') ) THEN 3369 CALL ParticleVariableCreate( Particles,'Particle Distance Integral' ) 3370 END IF 3371 IF( ListCheckPresentAnyBodyForce( CurrentModel,& 3372 'Particle Time Integral Source') ) THEN 3373 CALL ParticleVariableCreate( Particles,'Particle Time Integral' ) 3374 END IF 3375 3376 END SUBROUTINE InitializeParticles 3377 3378 3379 3380 !--------------------------------------------------------------------------- 3381 !> This subroutine finds the possible intersection between elementfaces 3382 !> and a line segment defined by two coordinates. 3383 !--------------------------------------------------------------------------- 3384 SUBROUTINE SegmentElementIntersection(Mesh,BulkElement,& 3385 Rinit,Rfin,MinLambda,FaceElement) 3386 !--------------------------------------------------------------------------- 3387 TYPE(Mesh_t), POINTER :: Mesh 3388 TYPE(Element_t), POINTER :: BulkElement 3389 REAL(KIND=dp) :: Rinit(3), Rfin(3), MinLambda 3390 TYPE(Element_t), POINTER :: FaceElement 3391 3392 TYPE(Element_t), POINTER :: FaceElement2 3393 TYPE(Element_t), POINTER :: BoundaryElement 3394 TYPE(Nodes_t), SAVE :: BoundaryNodes 3395 REAL(KIND=dp) :: Lambda(6), PosEps, NegEps, Dist 3396 INTEGER :: ElemDim, NoFaces, FaceIndex(6), i,j,n 3397 INTEGER, POINTER :: NodeIndexes(:) 3398 LOGICAL :: Success, AtBoundary, AtFace, Visited = .FALSE. 3399 3400 3401 PosEps = 1.0e-10 3402 NegEps = -1.0e-7 3403 3404 ElemDim = BulkElement % TYPE % DIMENSION 3405 3406 IF( ElemDim == 3 ) THEN 3407 NoFaces = BulkElement % TYPE % NumberOfFaces 3408 ELSE 3409 NoFaces = BulkElement % TYPE % NumberOfEdges 3410 END IF 3411 3412 DO i=1, NoFaces 3413 IF( ElemDim == 3 ) THEN 3414 j = BulkElement % FaceIndexes(i) 3415 BoundaryElement => Mesh % Faces( j ) 3416 ELSE 3417 j = BulkElement % EdgeIndexes(i) 3418 BoundaryElement => Mesh % Edges(j) 3419 END IF 3420 3421 CALL GetElementNodes(BoundaryNodes,BoundaryElement) 3422 3423 Lambda(i) = LineFaceIntersection(BoundaryElement,BoundaryNodes,& 3424 Rinit,Rfin) 3425 FaceIndex(i) = j 3426 END DO 3427 3428 ! Sort the lambdas so that the best intersection is easily found 3429 !----------------------------------------------------------------------- 3430 CALL SortR( NoFaces, FaceIndex, Lambda ) 3431 3432 ! Either there must be a positive lambda, or then the initial node must 3433 ! already sit on the face. 3434 !------------------------------------------------------------------------ 3435 j = 0 3436 DO i=1,NoFaces 3437 IF( Lambda(i) >= PosEps ) THEN 3438 j = i 3439 ELSE 3440 IF( j > 0 ) THEN 3441 MinLambda = Lambda( j ) 3442 EXIT 3443 ELSE IF( Lambda(i) >= NegEps ) THEN 3444 MinLambda = MAX( Lambda( i ), 0.0_dp ) 3445 j = i 3446 END IF 3447 EXIT 3448 END IF 3449 END DO 3450 3451 IF( j > 0 ) THEN 3452 IF( ElemDim == 3 ) THEN 3453 FaceElement => Mesh % Faces( FaceIndex(j) ) 3454 ELSE 3455 FaceElement => Mesh % Edges( FaceIndex(j) ) 3456 END IF 3457 ELSE 3458 MinLambda = HUGE( MinLambda ) 3459 FaceElement => NULL() 3460 3461 CALL Warn('SegmentElementIntersection','Could not find any intersection') 3462 PRINT *,'Lambda: ',NoFaces,Lambda(1:NoFaces) 3463 END IF 3464 3465!PRINT *,'Lambda:',Lambda(1:NoFaces) 3466!PRINT *,'MinLambda',MinLambda 3467 3468 END SUBROUTINE SegmentElementIntersection 3469 3470 3471 !--------------------------------------------------------------------------- 3472 !> This subroutine finds the possible intersection between elementfaces 3473 !> and a line segment defined by two coordinates. 3474 !--------------------------------------------------------------------------- 3475 SUBROUTINE SegmentElementIntersection2(Mesh,BulkElement,& 3476 Rinit,Rfin,MinLambda,FaceElement) 3477 !--------------------------------------------------------------------------- 3478 TYPE(Mesh_t), POINTER :: Mesh 3479 TYPE(Element_t), POINTER :: BulkElement 3480 REAL(KIND=dp) :: Rinit(3), Rfin(3), MinLambda 3481 TYPE(Element_t), POINTER :: FaceElement 3482 3483 TYPE(Element_t), POINTER :: FaceElement2 3484 TYPE(Element_t), POINTER :: BoundaryElement 3485 TYPE(Nodes_t), SAVE :: BoundaryNodes 3486 REAL(KIND=dp) :: Lambda, PosEps, NegEps, Dist 3487 INTEGER :: ElemDim, NoFaces, i,j,n 3488 INTEGER, POINTER :: NodeIndexes(:) 3489 LOGICAL :: Success, AtBoundary, AtFace, Visited = .FALSE. 3490 3491 3492 PosEps = 1.0e-10 3493 NegEps = -1.0e-7 3494 3495 ElemDim = BulkElement % TYPE % DIMENSION 3496 MinLambda = -HUGE( MinLambda ) 3497 3498 IF( ElemDim == 3 ) THEN 3499 NoFaces = BulkElement % TYPE % NumberOfFaces 3500 ELSE 3501 NoFaces = BulkElement % TYPE % NumberOfEdges 3502 END IF 3503 3504 DO i=1, NoFaces 3505 IF( ElemDim == 3 ) THEN 3506 j = BulkElement % FaceIndexes(i) 3507 BoundaryElement => Mesh % Faces( j ) 3508 ELSE 3509 j = BulkElement % EdgeIndexes(i) 3510 BoundaryElement => Mesh % Edges(j) 3511 END IF 3512 3513 CALL GetElementNodes(BoundaryNodes,BoundaryElement) 3514 3515 Lambda = LineFaceIntersection2(BoundaryElement,BoundaryNodes,& 3516 Rinit,Rfin,Success) 3517 IF(.NOT. Success ) CYCLE 3518 3519 IF( Lambda > MinLambda ) THEN 3520 MinLambda = Lambda 3521 FaceElement => BoundaryElement 3522 IF( MinLambda > PosEps ) EXIT 3523 END IF 3524 END DO 3525 3526 IF( MinLambda < NegEps ) THEN 3527 FaceElement => NULL() 3528! CALL Warn('SegmentElementIntersection','Could not find any intersection') 3529! PRINT *,'Lambda: ',NoFaces,MinLambda 3530 ELSE 3531 MinLambda = MAX( MinLambda, 0.0_dp ) 3532 END IF 3533 3534 END SUBROUTINE SegmentElementIntersection2 3535 3536 3537 !--------------------------------------------------------------------------- 3538 !> This subroutine tests whether a particle is within element using the 3539 !> consistent strategy with the above algorithm. 3540 !--------------------------------------------------------------------------- 3541 FUNCTION SegmentElementInside(Mesh,BulkElement,Rfin,Debug) RESULT ( Inside ) 3542 !--------------------------------------------------------------------------- 3543 TYPE(Mesh_t), POINTER :: Mesh 3544 TYPE(Element_t), POINTER :: BulkElement 3545 REAL(KIND=dp) :: Rfin(3) 3546 LOGICAL :: Debug 3547 LOGICAL :: Inside 3548 !--------------------------------------------------------------------------- 3549 REAL(KIND=dp) :: Rinit(3), MinLambda 3550 TYPE(Element_t), POINTER :: BoundaryElement 3551 TYPE(Nodes_t), SAVE :: Nodes 3552 REAL(KIND=dp) :: Lambda, Eps, Lambdas(6) 3553 INTEGER :: ElemDim, NoFaces, i,j,n,Hits 3554 INTEGER, POINTER :: NodeIndexes(:) 3555 LOGICAL :: Success, AtBoundary, AtFace, Visited = .FALSE., Outside 3556 REAL(KIND=dp) :: minx,maxx,dx,mindist,dist 3557 3558 3559 Inside = .FALSE. 3560 3561 MinLambda = HUGE(MinLambda) 3562 Eps = EPSILON(Eps) !Eps =1.0e-12 3563 3564 n = GetElementNOFNOdes(BulkElement) 3565 CALL GetElementNodes(Nodes,BulkElement) 3566 ElemDim = BulkElement % TYPE % DIMENSION 3567 3568 ! First make a quick and dirty test to save time 3569 !-------------------------------------------------------------------------- 3570 DO i=1,ElemDim 3571 IF( i == 1 ) THEN 3572 maxx = MAXVAL( Nodes % x(1:n) ) 3573 minx = MINVAL( Nodes % x(1:n) ) 3574 ELSE IF( i == 2 ) THEN 3575 maxx = MAXVAL( Nodes % y(1:n) ) 3576 minx = MINVAL( Nodes % y(1:n) ) 3577 ELSE 3578 maxx = MAXVAL( Nodes % z(1:n) ) 3579 minx = MINVAL( Nodes % z(1:n) ) 3580 END IF 3581 3582 dx = Eps * (maxx-minx) 3583 Outside = ( Rfin(i) < minx - dx .OR. Rfin(i) > maxx + dx ) 3584 3585 IF( Debug ) THEN 3586 PRINT *,'Rough test: ',Outside,i,dx,minx,maxx,Rfin(i),MAX(minx-Rfin(i),Rfin(i)-maxx) 3587 END IF 3588 3589 IF( Outside ) RETURN 3590 END DO 3591 3592 3593 ! Then the more laborious test where intersections with the faces are determined 3594 !------------------------------------------------------------------------------- 3595 Rinit(1) = SUM( Nodes % x(1:n) ) / n 3596 Rinit(2) = SUM( Nodes % y(1:n) ) / n 3597 Rinit(3) = SUM( Nodes % z(1:n) ) / n 3598 3599 Hits = 0 3600 3601 IF( ElemDim == 3 ) THEN 3602 NoFaces = BulkElement % TYPE % NumberOfFaces 3603 ELSE 3604 NoFaces = BulkElement % TYPE % NumberOfEdges 3605 END IF 3606 3607 DO i=1, NoFaces 3608 IF( ElemDim == 3 ) THEN 3609 j = BulkElement % FaceIndexes(i) 3610 BoundaryElement => Mesh % Faces( j ) 3611 ELSE 3612 j = BulkElement % EdgeIndexes(i) 3613 BoundaryElement => Mesh % Edges(j) 3614 END IF 3615 3616 CALL GetElementNodes(Nodes,BoundaryElement) 3617 3618 Lambda = LineFaceIntersection2(BoundaryElement,Nodes,& 3619 Rinit,Rfin,Success) 3620 IF(.NOT. Success ) CYCLE 3621 3622 Hits = Hits + 1 3623 Lambdas(Hits) = Lambda 3624 IF (Lambda > 0.0_dp .AND. MinLambda > Lambda) MinLambda = Lambda 3625 END DO 3626 3627 IF( Debug ) THEN 3628 PRINT *,'Intersecting faces:',Hits 3629 PRINT *,'Lambdas:',Lambdas(1:Hits) 3630 END IF 3631 3632 3633 IF( Hits == 0 ) THEN 3634 Inside = .FALSE. 3635 ELSE 3636 Inside = MinLambda > 1.0 - Eps .AND. MinLambda > -Eps 3637 3638 IF( Debug ) THEN 3639 MinDist = HUGE(MinDist) 3640 DO i=1,n 3641 Dist = SQRT( (Rfin(1)-Nodes % x(i))**2 + & 3642 (Rfin(2)-Nodes % y(i))**2 + & 3643 (Rfin(3)-Nodes % z(i))**2 ) 3644 MinDist = MIN( Dist, MinDist ) 3645 END DO 3646 3647 PRINT *,'Dist: ', Inside,MinDist 3648 END IF 3649 END IF 3650 3651 END FUNCTION SegmentElementInside 3652 3653 3654 3655 !------------------------------------------------------------------------ 3656 !> Find the particle in the mesh using actree based search. 3657 !> This could be preferred in the initial finding of the correct elements. 3658 !> The major downside of the method is that there is no controlled face 3659 !> detection needed for wall interaction, for example. 3660 !------------------------------------------------------------------------ 3661 SUBROUTINE LocateParticleInMeshOctree( ElementIndex, GlobalCoords, & 3662 LocalCoords ) 3663 3664 USE Lists 3665 3666 INTEGER :: ElementIndex 3667 REAL(KIND=dp) :: GlobalCoords(3) 3668 REAL(KIND=dp), OPTIONAL :: LocalCoords(3) 3669 3670 TYPE(ValueList_t), POINTER :: Params 3671 TYPE(Mesh_t), POINTER :: Mesh 3672 LOGICAL :: Hit, Stat 3673 INTEGER :: i,j,k,n 3674 TYPE(Nodes_t), SAVE :: ElementNodes 3675 INTEGER, POINTER :: NodeIndexes(:) 3676 TYPE(Element_t), POINTER :: Element 3677 TYPE(Quadrant_t), POINTER, SAVE :: RootQuadrant =>NULL(), LeafQuadrant 3678 REAL(kind=dp) :: BoundingBox(6), eps2, eps1, uvw(3) 3679 3680 3681 Mesh => GetMesh() 3682 3683 ! Check that the previous hit is not hit even now 3684 !------------------------------------------------- 3685 IF( ElementIndex > 0 ) THEN 3686 Element => Mesh % Elements( ElementIndex ) 3687 n = GetElementNOFNodes(Element) 3688 CALL GetElementNodes(ElementNodes,Element) 3689 3690 IF ( PointInElement( Element, ElementNodes, & 3691 GlobalCoords, LocalCoords ) ) RETURN 3692 END IF 3693 3694 !----------------------------------------------------------- 3695 ! Find the right element using an octree search 3696 ! This is optimal when the particles are searched only once. 3697 !----------------------------------------------------------- 3698 IF ( .NOT.ASSOCIATED(Mesh % RootQuadrant) ) THEN 3699 BoundingBox(1) = MINVAL( Mesh % Nodes % x ) 3700 BoundingBox(2) = MINVAL( Mesh % Nodes % y ) 3701 BoundingBox(3) = MINVAL( Mesh % Nodes % z ) 3702 BoundingBox(4) = MAXVAL( Mesh % Nodes % x ) 3703 BoundingBox(5) = MAXVAL( Mesh % Nodes % y ) 3704 BoundingBox(6) = MAXVAL( Mesh % Nodes % z ) 3705 3706 eps1 = 1.0e-3 3707 eps2 = eps1 * MAXVAL( BoundingBox(4:6) - BoundingBox(1:3) ) 3708 BoundingBox(1:3) = BoundingBox(1:3) - eps2 3709 BoundingBox(4:6) = BoundingBox(4:6) + eps2 3710 3711 CALL BuildQuadrantTree( Mesh,BoundingBox,Mesh % RootQuadrant) 3712 END IF 3713 RootQuadrant => Mesh % RootQuadrant 3714 3715 Element => NULL() 3716 ElementIndex = 0 3717 CALL FindLeafElements(GlobalCoords, Mesh % MeshDim, RootQuadrant, LeafQuadrant) 3718 IF ( ASSOCIATED(LeafQuadrant) ) THEN 3719 DO i = 1, LeafQuadrant % NElemsInQuadrant 3720 j = LeafQuadrant % Elements(i) 3721 Element => Mesh % Elements(j) 3722 3723 n = GetElementNOFNodes( Element ) 3724 CALL GetElementNodes( ElementNodes, Element) 3725 3726 IF ( PointInElement( Element, ElementNodes, GlobalCoords, uvw ) ) THEN 3727 IF( PRESENT( LocalCoords) ) LocalCoords = uvw 3728 ElementIndex = j 3729 RETURN 3730 END IF 3731 END DO 3732 END IF 3733 3734 IF( ElementIndex == 0 ) THEN 3735 CALL Warn('LocateParticleInMeshOctree','Could not locate particle in the mesh!') 3736 END IF 3737 3738 END SUBROUTINE LocateParticleInMeshOctree 3739 3740 3741 !------------------------------------------------------------------------ 3742 !> Locate the particle using controlled marching from element to element. 3743 !> The crossing point between given trajectory and all face elements is 3744 !> computed. The one that is passed at first is associated to the next 3745 !> bulk element. 3746 !------------------------------------------------------------------------- 3747 SUBROUTINE LocateParticleInMeshMarch( ElementIndex, Rinit, Rfin, Init, & 3748 ParticleStatus, AccurateAtFace, StopFaceIndex, Lambda, Velo, & 3749 No, ParticleWallKernel, Particles ) 3750 3751 TYPE(Particle_t), POINTER :: Particles 3752 INTEGER :: ElementIndex 3753 REAL(KIND=dp) :: Rinit(3), Rfin(3) 3754 LOGICAL :: Init 3755 LOGICAL :: AccurateAtFace 3756 INTEGER :: ParticleStatus 3757 REAL(KIND=dp) :: Lambda 3758 INTEGER :: StopFaceIndex 3759 REAL(KIND=dp) :: Velo(3) 3760 3761 INTEGER, OPTIONAL :: No 3762 OPTIONAL :: ParticleWallKernel 3763 3764 INTERFACE 3765 SUBROUTINE ParticleWallKernel( No, r, r2, v, v2, Lambda, & 3766 FaceIndex, ParticleStatus ) 3767 INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12) 3768 INTEGER :: No 3769 REAL(KIND=dp) :: r(3),r2(3),v(3),v2(3),Lambda 3770 INTEGER :: FaceIndex, ParticleStatus 3771 END SUBROUTINE ParticleWallKernel 3772 END INTERFACE 3773 3774 !------------------------------------------------------------------------- 3775 TYPE(ValueList_t), POINTER :: Params, BC 3776 TYPE(Mesh_t), POINTER :: Mesh 3777 REAL(KIND=dp) :: Rtmp(3), Normal(3), MinLambda, eps, UnitVector(3), ds2, & 3778 LocalCoord(3),Velo0(3) 3779 LOGICAL :: Hit, DoInit, Stat, StopAtFace, AtWall, Visited = .FALSE.,& 3780 Debug,UseCenter,GotBC,GotBC2,ParticleBounce, Robust, Inside 3781 INTEGER :: i,j,k,n,FaceIndex,MaxTrials,bc_id,cons_id,ElementIndex0,ParticleStatus0, & 3782 DebugNo, DebugPart 3783 INTEGER :: Problems(3), PrevNo 3784 TYPE(Nodes_t), SAVE :: ElementNodes 3785 INTEGER, POINTER :: NodeIndexes(:) 3786 TYPE(Element_t), POINTER :: Element, FaceElement, LeftElement, RightElement, & 3787 NextElement, PrevElement 3788 3789 INTEGER, POINTER :: Neighbours(:) 3790 INTEGER :: NextPartition, Counter = 0 3791 LOGICAL, POINTER :: FaceInterface(:) 3792 3793 SAVE :: Mesh, StopAtFace, Debug, MaxTrials, Counter, PrevNo, Eps, Robust, Problems, & 3794 DebugNo, DebugPart 3795 3796 Mesh => GetMesh() 3797 Counter = Counter + 1 3798 3799 IF( .NOT. Visited ) THEN 3800 Params => ListGetSolverParams() 3801 Robust = ListGetLogical( Params,'Particle Locate Robust',stat) 3802 IF(.NOT. Stat) Robust = .TRUE. 3803 StopAtFace = ListGetLogical( Params,'Particle Stop At Face',Stat) 3804 MaxTrials = ListGetInteger( Params,'Max Particle Search Trials',Stat) 3805 IF(.NOT. Stat) MaxTrials = Mesh % NumberOfBulkElements 3806 3807 DebugNo = ListGetInteger( Params,'Debug particle index',Stat) 3808 DebugPart = ListGetInteger( Params,'Debug particle partition',Stat) 3809 3810 Eps = ListGetConstReal( Params,'Particle Hit Tolerance',Stat) 3811 IF(.NOT. Stat) Eps = 1.0e-10 3812 Problems = 0 3813 Visited = .TRUE. 3814 END IF 3815 3816 Debug = ( No == DebugNo .AND. ParEnv % MyPe == DebugPart ) 3817 3818 3819 !-------------------------------------------------------------------- 3820 ! This is a recursive algorithm that checks the intersections 3821 ! of line segments and points until correct element is found. 3822 ! This is optimal when the stepsize is small and there are many steps. 3823 !-------------------------------------------------------------------- 3824 DoInit = Init 3825 IF( ElementIndex == 0 ) THEN 3826 DoInit = .TRUE. 3827 ElementIndex = 1 3828 UseCenter = .TRUE. 3829 ELSE 3830 UseCenter = .NOT. AccurateAtFace 3831 END IF 3832 ElementIndex0 = ElementIndex 3833 3834 IF(.NOT. UseCenter ) THEN 3835 ds2 = SUM( (Rinit - Rfin)**2 ) 3836 IF( ds2 < EPSILON( ds2 ) ) RETURN 3837 END IF 3838 3839 IF( Debug ) THEN 3840 PRINT *,'Starting' 3841 PRINT *,'Rinit:',Rinit 3842 PRINT *,'Rfin:',Rfin 3843 PRINT *,'Velo:',Velo 3844 PRINT *,'ds2:',ds2 3845 END IF 3846 3847 NULLIFY( PrevElement ) 3848 3849 ParticleStatus = PARTICLE_LOST 3850 StopFaceIndex = 0 3851 Lambda = 1.0_dp 3852 3853 Element => Mesh % Elements( ElementIndex ) 3854 3855 3856 DO i=1,MaxTrials 3857 3858 ! Use the previous element center if the true path is of no importance 3859 !--------------------------------------------------------------------- 3860 IF( UseCenter ) THEN 3861 n = GetElementNOFNOdes(Element) 3862 CALL GetElementNodes(ElementNodes,Element) 3863 Rtmp(1) = SUM( ElementNodes % x(1:n) ) / n 3864 Rtmp(2) = SUM( ElementNodes % y(1:n) ) / n 3865 Rtmp(3) = SUM( ElementNodes % z(1:n) ) / n 3866 ELSE 3867 IF( i == 1 ) THEN 3868 Rtmp = Rinit 3869 ELSE IF( .NOT. ParticleBounce ) THEN 3870 Rtmp = Rtmp + MinLambda * (Rfin - Rtmp) 3871 END IF 3872 END IF 3873 3874 IF( Debug ) THEN 3875 PRINT *,'Center:',i, UseCenter, Rtmp, MinLambda 3876 END IF 3877 3878 3879 IF( Robust ) THEN 3880 CALL SegmentElementIntersection2(Mesh,Element,& 3881 Rtmp,Rfin,MinLambda,FaceElement ) 3882 ELSE 3883 CALL SegmentElementIntersection(Mesh,Element,& 3884 Rtmp,Rfin,MinLambda,FaceElement ) 3885 END IF 3886 3887 ParticleBounce = .FALSE. 3888 3889 3890 IF( .NOT. ASSOCIATED( FaceElement ) ) THEN 3891 ! One likely cause for unsuccessful operation is that the 3892 ! initial node and target node are the same 3893 3894 ds2 = SUM ( ( Rtmp - Rfin )**2 ) 3895 IF( Debug ) THEN 3896 PRINT *,'NoFace:',ds2 3897 END IF 3898 3899 IF( ds2 < EPSILON( ds2 ) ) THEN 3900 ParticleStatus = PARTICLE_HIT 3901 EXIT 3902 ELSE 3903! IF( .NOT. AccurateAtFace ) THEN 3904! CALL Warn('LocateParticleInMesh','No intersection found?') 3905! PRINT *,'Rinit:',Rtmp 3906! PRINT *,'Rfin: ',Rfin 3907! END IF 3908 EXIT 3909 END IF 3910 ELSE IF( MinLambda > 1.0_dp - eps ) THEN 3911 ParticleStatus = PARTICLE_HIT 3912 EXIT 3913 ELSE 3914 3915 cons_id = FaceElement % BoundaryInfo % Constraint 3916 GotBC = .FALSE. 3917 IF ( cons_id > 0 ) THEN 3918 DO bc_id=1,CurrentModel % NumberOfBCs 3919 IF ( cons_id == CurrentModel % BCs(bc_id) % Tag ) THEN 3920 BC => CurrentModel % BCs(bc_id) % Values 3921 GotBC = .TRUE. 3922 EXIT 3923 END IF 3924 END DO 3925 END IF 3926 3927 IF( Debug ) THEN 3928 PRINT *,'BC:',cons_id,GotBC 3929 END IF 3930 3931 3932 ! Reflect particle from face and continue the search in the same element 3933 !----------------------------------------------------------------------- 3934 GotBC2 = GotBC 3935 3936 IF( GotBC ) THEN 3937 IF( ListGetLogical( BC,'Particle Outlet',Stat ) ) THEN 3938 ParticleStatus = PARTICLE_LOST 3939 EXIT 3940 3941 ELSE IF( ListGetLogical( BC,'Particle Wall',Stat ) ) THEN 3942 ParticleStatus = PARTICLE_WALLBOUNDARY 3943 3944 ELSE IF( ListGetLogical( BC,'Particle Reflect',Stat ) ) THEN 3945 ! First advance the particle to the point of collision 3946 Rtmp = Rtmp + MinLambda * (Rfin - Rtmp) 3947 3948 ! Then reflect the rest assuming fully elastic collision where the 3949 ! normal component switches sign. 3950 CALL GetElementNodes(ElementNodes, FaceElement ) 3951 Normal = NormalVector( FaceElement, ElementNodes ) 3952 Rfin = Rfin - 2*SUM((Rfin-Rtmp)*Normal)*Normal 3953 3954 ! Reorient the velocity vector 3955 UnitVector = Rfin - Rtmp 3956 UnitVector = UnitVector / SQRT( SUM( UnitVector** 2 ) ) 3957 Velo = UnitVector * SQRT( SUM( Velo**2) ) 3958 3959 IF( Debug ) THEN 3960 PRINT *,'Reflected',i,MinLambda,EPSILON(MinLambda) 3961 PRINT *,'Normal:',Normal 3962 PRINT *,'Rtmp:',Rtmp 3963 PRINT *,'Rfin:',Rfin 3964 PRINT *,'Abs(Velo):',SQRT(SUM(Velo**2)) 3965 PRINT *,'Velo:',Velo 3966 END IF 3967 ParticleBounce = .TRUE. 3968 3969 CYCLE 3970 ELSE IF( ListGetLogical( BC,'Particle Interact',Stat ) ) THEN 3971 ParticleStatus0 = ParticleStatus 3972 Velo0 = Velo 3973 3974 CurrentModel % CurrentElement => FaceElement 3975 CALL ParticleWallKernel(No,Rtmp,Rfin,Velo0,Velo,MinLambda,& 3976 FaceElement % ElementIndex,ParticleStatus) 3977 3978 ! if the particle status stays the same we are still in the same element 3979 IF(ParticleStatus == ParticleStatus0 ) THEN 3980 ParticleBounce = .TRUE. 3981 CYCLE 3982 END IF 3983 ELSE 3984 GotBC2 = .FALSE. 3985 END IF 3986 END IF 3987 3988 IF( .NOT. GotBC2 ) THEN 3989 LeftElement => FaceElement % BoundaryInfo % Left 3990 RightElement => FaceElement % BoundaryInfo % Right 3991 3992 3993 IF( Debug ) THEN 3994 PRINT *,'Left and Right:',& 3995 ASSOCIATED(LeftElement),ASSOCIATED(RightElement) 3996 END IF 3997 3998 3999 IF( ASSOCIATED( LeftElement) .AND. ASSOCIATED(RightElement)) THEN 4000 IF( ASSOCIATED(Element, LeftElement)) THEN 4001 NextElement => RightElement 4002 ELSE 4003 NextElement => LeftElement 4004 END IF 4005 IF( StopAtFace .AND. .NOT. DoInit ) ParticleStatus = PARTICLE_FACEBOUNDARY 4006 ELSE 4007 ParticleStatus = PARTICLE_WALLBOUNDARY 4008 END IF 4009 END IF 4010 4011 ! There are different reasons why the particle is only integrated until the face 4012 IF( ParticleStatus == PARTICLE_WALLBOUNDARY .OR. & 4013 ParticleStatus == PARTICLE_FACEBOUNDARY ) THEN 4014 4015 Lambda = MinLambda 4016 StopFaceIndex = FaceElement % ElementIndex 4017 4018 Rfin = Rtmp + MinLambda * (Rfin - Rtmp) 4019 Velo = 0.0_dp 4020 4021 IF( Debug ) THEN 4022 PRINT *,'WallBC:',Rfin, MinLambda 4023 END IF 4024 4025 4026 EXIT 4027 END IF 4028 END IF 4029 4030 IF( Debug ) THEN 4031 PRINT *,'Same Elements:', ASSOCIATED( NextElement ), & 4032 ASSOCIATED( NextElement, Element), ASSOCIATED( NextElement, PrevElement ) 4033 END IF 4034 4035 4036 4037 ! continue the search to new elements 4038 IF( .NOT. ASSOCIATED( NextElement ) ) THEN 4039 CALL Warn('LocateParticleInMeshMarch','Element not associated!') 4040 END IF 4041 4042 IF( ASSOCIATED( NextElement, Element ) ) THEN 4043 CALL Warn('LocateParticleInMeshMarch','Elements are the same!') 4044 END IF 4045 4046 4047 IF( ASSOCIATED( NextElement, PrevElement ) ) THEN 4048 CALL GetElementNodes(ElementNodes,NextElement) 4049 IF( Robust ) THEN 4050 Inside = SegmentElementInside(Mesh,NextElement,Rfin,Debug) 4051 ELSE 4052 Inside = PointInElement( NextElement, ElementNodes, Rfin, LocalCoord ) 4053 END IF 4054 4055 IF( Debug ) THEN 4056 PRINT *,'NextElement',Inside,Robust,NextElement % ElementIndex,LocalCoord 4057 END IF 4058 4059 IF( Inside ) THEN 4060 Problems(1) = Problems(1) + 1 4061 CALL Warn('LocateParticleInMeshMarch','Elements are same, found in NextElement!') 4062 Element => NextElement 4063 ParticleStatus = PARTICLE_HIT 4064 EXIT 4065 END IF 4066 4067 CALL GetElementNodes(ElementNodes,Element) 4068 IF( Robust ) THEN 4069 Inside = SegmentElementInside(Mesh,Element,Rfin,Debug) 4070 ELSE 4071 Inside = PointInElement( Element, ElementNodes, Rfin, LocalCoord ) 4072 END IF 4073 4074 IF( Debug ) THEN 4075 PRINT *,'ThisElement',Inside,Robust,Element % ElementIndex,LocalCoord 4076 END IF 4077 4078 IF( Inside ) THEN 4079 Problems(2) = Problems(2) + 1 4080 CALL Warn('LocateParticleInMeshMarch','Elements are same, found in Element!') 4081 ParticleStatus = PARTICLE_HIT 4082 EXIT 4083 END IF 4084 4085 4086 4087 Problems(3) = Problems(3) + 1 4088 WRITE(Message,'(A,3ES10.3)') 'Losing particle '//TRIM(I2S(No))//' in: ',Rfin(1:3) 4089 CALL Info('LocateParticlesInMesh',Message,Level=15) 4090 4091 ParticleStatus = PARTICLE_LOST 4092 EXIT 4093 END IF 4094 4095 PrevElement => Element 4096 Element => NextElement 4097 END DO 4098 4099 IF( i >= MaxTrials ) THEN 4100 PRINT *,'Used maximum number of trials',MaxTrials,No 4101 END IF 4102 4103 IF( ParticleStatus == PARTICLE_LOST ) THEN 4104 ElementIndex = 0 4105 ELSE 4106 ElementIndex = Element % ElementIndex 4107 END IF 4108 4109100 CONTINUE 4110 4111 ! This is just for debugging 4112 IF( No < PrevNo .AND. Problems(3) > 0 ) THEN 4113 WRITE( Message,'(A,3I0)') 'Problems in locating particles:',Problems 4114 CALL Info('LocateParticleInMeshMarch',Message,Level=10) 4115 END IF 4116 Problems = 0 4117 PrevNo = No 4118 4119 END SUBROUTINE LocateParticleInMeshMarch 4120 4121 4122 4123 !------------------------------------------------------------------------ 4124 !> Locate the particles in their new positions in the mesh. 4125 !------------------------------------------------------------------------- 4126 SUBROUTINE LocateParticles( Particles, ParticleWallKernel ) 4127 4128 USE Lists 4129 4130 TYPE(Particle_t), POINTER :: Particles 4131 OPTIONAL :: ParticleWallKernel 4132 4133 INTERFACE 4134 SUBROUTINE ParticleWallKernel( No, r, r2, v, v2, Lambda, & 4135 FaceIndex, ParticleStatus ) 4136 INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12) 4137 INTEGER :: No 4138 REAL(KIND=dp) :: r(3),r2(3),v(3),v2(3),Lambda 4139 INTEGER :: FaceIndex, ParticleStatus 4140 END SUBROUTINE ParticleWallKernel 4141 END INTERFACE 4142 4143 4144 !----------------------------------------------------------------------- 4145 LOGICAL :: PartitionChangesOnly 4146 INTEGER :: PartitionChanges, Status, ElementIndex, No, & 4147 NoParticles, dim, ElementIndex0 4148 REAL(KIND=dp) :: Rinit(3), Rfin(3),Rfin0(3),Velo(3), Velo0(3), dtime 4149 LOGICAL :: Stat, InitLocation, AccurateAtFace, AccurateAlways, AccurateNow, debug 4150 INTEGER :: FaceIndex, FaceIndex0, Status0, InitStatus 4151 REAL(KIND=dp) :: Lambda 4152 TYPE(Mesh_t), POINTER :: Mesh 4153 TYPE(ValueList_t), POINTER :: Params 4154 TYPE(Variable_t), POINTER :: DtVar 4155 4156 CALL Info('LocateParticles','Locating particles in mesh',Level=10) 4157 4158 Params => ListGetSolverParams() 4159 Mesh => GetMesh() 4160 dim = Particles % dim 4161 PartitionChangesOnly = .FALSE. 4162 Velo = 0.0_dp 4163 Debug = .FALSE. 4164 4165 ! Particles may be located either using the mid-point of the current element as the 4166 ! reference point for finding face intersections, or using the true starting 4167 ! point which is more prone to epsilon-errors. 4168 !--------------------------------------------------------------------------- 4169 AccurateAlways = ListGetLogical( Params,'Particle Accurate Always',Stat) 4170 AccurateAtFace = ListGetLogical( Params,'Particle Accurate At Face',Stat) 4171 4172 4173 IF( .NOT. Particles % DtConstant ) THEN 4174 DtVar => ParticleVariableGet( Particles,'particle dt') 4175 IF(.NOT. ASSOCIATED( DtVar ) ) THEN 4176 CALL Fatal('ParticleAdvanceTimesteo','Variable timestep, > particle dt < should exist!') 4177 END IF 4178 END IF 4179 4180 4181100 NoParticles = Particles % NumberOfParticles 4182 4183 DO No = 1, NoParticles 4184 4185 Status = Particles % Status( No ) 4186 InitStatus = Status 4187 4188 IF( Status >= PARTICLE_LOST ) CYCLE 4189 IF( Status < PARTICLE_INITIATED ) CYCLE 4190 IF( Status == PARTICLE_WALLBOUNDARY ) CYCLE 4191 IF( Status == PARTICLE_FIXEDCOORD ) CYCLE 4192 4193 IF( .NOT. Particles % DtConstant ) THEN 4194 IF( ABS( DtVar % Values(No) ) < TINY( dtime ) ) CYCLE 4195 END IF 4196 4197 IF ( PartitionChangesOnly .AND. Status /= PARTICLE_PARTBOUNDARY ) CYCLE 4198 4199 InitLocation = ( Status < PARTICLE_LOCATED ) 4200 Velo = GetParticleVelo( Particles, No ) 4201 IF( Status == PARTICLE_INITIATED ) THEN 4202 AccurateNow = .FALSE. 4203 ELSE 4204 AccurateNow = AccurateAlways 4205 END IF 4206 FaceIndex0 = 0 4207 4208200 ElementIndex = GetParticleElement( Particles, No ) 4209 Rfin = GetParticleCoord( Particles, No ) 4210 Velo = GetParticleVelo( Particles, No ) 4211 IF( AccurateNow ) Rinit = GetParticlePrevCoord( Particles, No ) 4212 Rinit = GetParticlePrevCoord( Particles, No ) 4213 4214 IF( debug ) THEN 4215 PRINT *,parenv % mype, 'going No',No,'Element',ElementIndex,'Face',FaceIndex,'Status',Status 4216 PRINT *,parenv % mype, 'going Init: ',Rinit(1:dim),Rfin(1:dim) 4217 PRINT *,parenv % mype, 'going Velo:',GetParticleVelo(Particles,No), Velo(1:dim) 4218 END IF 4219 4220 CALL LocateParticleInMeshMarch(ElementIndex, Rinit, Rfin, InitLocation, & 4221 Status,AccurateNow, FaceIndex, Lambda, Velo, No, ParticleWallKernel, Particles ) 4222 4223 IF( debug ) THEN 4224 PRINT *,parenv % mype, 'leving No',No,'Element',ElementIndex,'Face',FaceIndex,'Status',Status 4225 PRINT *,parenv % mype, 'leving Init: ',Rinit(1:dim),Rfin(1:dim) 4226 PRINT *,parenv % mype, 'Velo:',GetParticleVelo(Particles,No), Velo(1:dim) 4227 END IF 4228 4229 ! If a boundary face is passed then repeat the process more diligently. 4230 ! Note that if we want proper collisions they should be implemented below 4231 !---------------------------------------------------------------------------- 4232 IF( .NOT. AccurateNow ) THEN 4233 AccurateNow = AccurateAtFace .AND. FaceIndex > 0 4234 4235 IF ( debug ) PRINT*,accuratenow, accurateatface, faceindex > 0 4236 4237 IF( AccurateNow ) THEN 4238 FaceIndex0 = FaceIndex 4239 ElementIndex0 = ElementIndex 4240 Status0 = Status 4241 Rfin0 = Rfin 4242 Velo0 = Velo 4243 ElementIndex = GetParticleElement( Particles, No ) 4244 Rfin = GetParticleCoord( Particles, No ) 4245 Velo = GetParticleVelo( Particles, No ) 4246 IF ( debug ) PRINT*,parenv % mype, 'go 200 '; FLUSH(6) 4247 GOTO 200 4248 END IF 4249 END IF 4250 4251 IF( FaceIndex0 > 0 .AND. FaceIndex == 0 ) THEN 4252 ! Currently it is assumed that if success with the second method is not obtained then 4253 ! the particle is already sitting on the face observed by the more robust method. 4254 !------------------------------------------------------------------------------------- 4255 IF( .FALSE. ) THEN 4256 CALL Warn('LocateParticles','Difference between robust and accurate?') 4257 END IF 4258 4259 Status = Status0 4260 Rfin = Rfin0 4261 Velo = Velo0 4262 ElementIndex = ElementIndex0 4263 FaceIndex = FaceIndex0 4264 END IF 4265 4266 IF( debug ) THEN 4267 PRINT *,parenv % mype, 'No',No,'Element',ElementIndex,'Face',FaceIndex,'Status',Status 4268 PRINT *,parenv % mype, 'Init: ',Rinit(1:dim),Rfin(1:dim) 4269 PRINT *,parenv % mype, 'Velo:',GetParticleVelo(Particles,No), Velo(1:dim) 4270 END IF 4271 4272 Particles % ElementIndex(No) = ElementIndex 4273 Particles % Status(No) = Status 4274 Particles % FaceIndex(No) = FaceIndex 4275 4276 CALL SetParticleCoord( Particles, No, Rfin ) 4277 IF( ElementIndex == 0 ) Velo = 0.0_dp 4278 4279 CALL SetParticleVelo( Particles, No, Velo ) 4280 END DO 4281 4282 ! Change the partition in where the particles are located 4283 ! Only applies to parallel cases. 4284 !------------------------------------------------------------------------ 4285 PartitionChanges = ChangeParticlePartition( Particles ) 4286 IF( PartitionChanges > 0 ) THEN 4287 PartitionChangesOnly = .TRUE. 4288 GOTO 100 4289 END IF 4290 4291 END SUBROUTINE LocateParticles 4292 4293 4294 4295 !-------------------------------------------------------------------------- 4296 !> Given the element & global coordinates returns the local coordinates. 4297 !> The idea of this routine is to transparently block the local coordinate 4298 !> search from the user by directly giving the basis function values related 4299 !> to a global coordinate. Sloppy tolerances are used since we *should* 4300 !> have already located the element. 4301 !-------------------------------------------------------------------------- 4302 FUNCTION ParticleElementInfo( CurrentElement, GlobalCoord, & 4303 SqrtElementMetric, Basis, dBasisdx ) RESULT ( stat ) 4304 4305 TYPE(Element_t), POINTER :: CurrentElement 4306 REAL(KIND=dp) :: GlobalCoord(:), SqrtElementMetric, LocalDistance 4307 REAL(KIND=dp) :: Basis(:) 4308 REAL(KIND=dp), OPTIONAL :: dBasisdx(:,:) 4309 LOGICAL :: Stat, Debug 4310 INTEGER :: Misses(2) = 0 4311 4312 SAVE Misses 4313 4314 4315 TYPE(Nodes_t) :: ElementNodes 4316 REAL(KIND=dp) :: LocalCoord(3),u,v,w 4317 INTEGER :: n 4318 4319 SAVE ElementNodes 4320 4321 n = CurrentElement % TYPE % NumberOfNodes 4322 CALL GetElementNodes(ElementNodes,CurrentElement) 4323 4324 Stat = PointInElement( CurrentElement, ElementNodes, & 4325 GlobalCoord, LocalCoord, GlobalEps = -1.0_dp, LocalEps = 1.0e3_dp, & 4326 LocalDistance = LocalDistance ) 4327 4328 IF( .NOT. Stat ) THEN 4329 Misses(1) = Misses(1) + 1 4330 4331 IF( MODULO( SUM( Misses ), 101 ) == 100 ) PRINT *,'Misses:',Misses 4332 4333 IF( .FALSE.) THEN 4334 IF( .NOT. Stat ) THEN 4335 CALL Warn('ParticleElementInfo','Should have found the node!') 4336 ELSE 4337 CALL Warn('ParticleElementInfo','Distance from element higher than expected!') 4338 END IF 4339 PRINT *,'LocalDistance:',LocalDistance,'Element:',CurrentElement % ElementIndex 4340 PRINT *,'Nodes X:',ElementNodes % x(1:n) - GlobalCoord(1) 4341 PRINT *,'Nodes Y:',ElementNodes % y(1:n) - GlobalCoord(2) 4342 PRINT *,'Nodes Z:',ElementNodes % z(1:n) - GlobalCoord(3) 4343 END IF 4344 RETURN 4345 END IF 4346 4347 u = LocalCoord(1) 4348 v = LocalCoord(2) 4349 w = LocalCoord(3) 4350 4351 stat = ElementInfo( CurrentElement, ElementNodes, U, V, W, SqrtElementMetric, & 4352 Basis, dBasisdx ) 4353 IF(.NOT. Stat) Misses(2) = Misses(2) + 1 4354 4355 END FUNCTION ParticleElementInfo 4356 4357 4358 4359 !------------------------------------------------------------------------- 4360 !> The routine returns velocity and optionally a gradient of velocity. 4361 !> These kind of functions are needed repeated and therefore to reduced the 4362 !> size of individual solvers it has been hard coded here. 4363 !-------------------------------------------------------------------------- 4364 4365 SUBROUTINE GetVectorFieldInMesh(Var, CurrentElement, Basis, Velo, dBasisdx, GradVelo ) 4366 4367 TYPE(Variable_t), POINTER :: Var 4368 TYPE(Element_t) :: CurrentElement 4369 REAL(KIND=dp) :: Basis(:), Velo(:) 4370 REAL(KIND=dp), OPTIONAL :: dBasisdx(:,:), GradVelo(:,:) 4371 4372 TYPE(Valuelist_t), POINTER :: Params 4373 INTEGER, POINTER :: LocalPerm(:) 4374 REAL(KIND=dp), POINTER :: LocalVelo(:,:) 4375 INTEGER, POINTER :: NodeIndexes(:) 4376 TYPE(Mesh_t), POINTER :: Mesh 4377 INTEGER :: VeloFieldDofs 4378 REAL(KIND=dp) :: SumBasis 4379 INTEGER :: i,j,k,n,npos,ind,dim 4380 LOGICAL :: GotIt, InterfaceNodes 4381 LOGICAL :: Visited 4382 4383 4384 SAVE :: Visited, Dim, LocalVelo, LocalPerm, InterfaceNodes 4385 4386 IF(.NOT. Visited ) THEN 4387 Mesh => GetMesh() 4388 Params => ListGetSolverParams() 4389 n = Mesh % MaxElementNodes 4390 ALLOCATE( LocalPerm(n), LocalVelo(n,3) ) 4391 4392 InterfaceNodes = GetLogical( Params,'Interface Nodes',GotIt) 4393 4394 LocalPerm = 0 4395 LocalVelo = 0.0_dp 4396 Dim = Mesh % MeshDim 4397 Visited = .TRUE. 4398 END IF 4399 4400 Velo = 0.0_dp 4401 IF( PRESENT( GradVelo ) ) GradVelo = 0.0_dp 4402 4403 n = CurrentElement % TYPE % NumberOfNodes 4404 LocalPerm(1:n) = Var % Perm( CurrentElement % NodeIndexes ) 4405 npos = COUNT ( LocalPerm(1:n) > 0 ) 4406 4407 4408 IF( npos == 0 ) RETURN 4409 4410 !----------------------------------------------------------------- 4411 ! compute the velocity also for case when the particle 4412 ! has just crossed the boundary. For example, its floating on the 4413 ! fluid boundary. This is a little bit fishy and could perhaps 4414 ! only be done conditionally.... 4415 ! Can't really determine the gradient here 4416 !----------------------------------------------------------------- 4417 VeloFieldDofs = Var % Dofs 4418 IF( npos == n ) THEN 4419 DO i=1,n 4420 j = LocalPerm(i) 4421 DO k=1,dim 4422 LocalVelo(i,k) = Var % Values( VeloFieldDofs*(j-1)+k) 4423 END DO 4424 END DO 4425 ELSE 4426 IF(.NOT. InterfaceNodes ) RETURN 4427 4428 SumBasis = 0.0_dp 4429 DO i=1,n 4430 j = LocalPerm(i) 4431 IF( j > 0 ) THEN 4432 SumBasis = SumBasis + Basis(i) 4433 DO k=1,dim 4434 LocalVelo(i,k) = Var % Values( VeloFieldDofs*(j-1)+k) 4435 END DO 4436 ELSE 4437 Basis(i) = 0.0_dp 4438 LocalVelo(i,1:dim) = 0.0_dp 4439 END IF 4440 END DO 4441 END IF 4442 4443 4444 DO i=1,dim 4445 Velo(i) = SUM( Basis(1:n) * LocalVelo(1:n,i) ) 4446 IF( PRESENT( GradVelo ) ) THEN 4447 DO j=1,dim 4448 GradVelo(i,j) = SUM( dBasisdx(1:n,j) * LocalVelo(1:n,i) ) 4449 END DO 4450 END IF 4451 END DO 4452 4453 IF( npos < n ) THEN 4454 Velo(1:dim) = Velo(1:dim) / SumBasis 4455 IF( PRESENT( GradVelo ) ) THEN 4456 GradVelo(:,1:dim) = GradVelo(:,1:dim) / SumBasis 4457 END IF 4458 END IF 4459 4460 END SUBROUTINE GetVectorFieldInMesh 4461 4462 4463 !------------------------------------------------------------------------- 4464 !> The routine returns a potential and its gradient. 4465 !-------------------------------------------------------------------------- 4466 4467 SUBROUTINE GetScalarFieldInMesh(Var, CurrentElement, Basis, Pot, dBasisdx, GradPot ) 4468 4469 TYPE(Variable_t), POINTER :: Var 4470 TYPE(Element_t) :: CurrentElement 4471 REAL(KIND=dp) :: Basis(:), Pot 4472 REAL(KIND=dp), OPTIONAL :: dBasisdx(:,:), GradPot(:) 4473 4474 TYPE(Mesh_t), POINTER :: Mesh 4475 INTEGER, POINTER :: LocalPerm(:) 4476 REAL(KIND=dp), POINTER :: LocalField(:) 4477 INTEGER :: i,j,n,dim 4478 LOGICAL :: Visited 4479 4480 4481 SAVE :: Visited, Mesh, Dim, LocalPerm, LocalField 4482 4483 IF(.NOT. Visited ) THEN 4484 Mesh => GetMesh() 4485 n = Mesh % MaxElementNodes 4486 ALLOCATE( LocalPerm(n), LocalField(n) ) 4487 LocalPerm = 0 4488 LocalField = 0.0_dp 4489 Dim = Mesh % MeshDim 4490 Visited = .TRUE. 4491 END IF 4492 4493 Pot = 0.0_dp 4494 IF( PRESENT( GradPot ) ) GradPot = 0.0_dp 4495 4496 IF(.NOT. ASSOCIATED( Var ) ) RETURN 4497 4498 n = CurrentElement % TYPE % NumberOfNodes 4499 IF( ASSOCIATED( Var % Perm ) ) THEN 4500 LocalPerm(1:n) = Var % Perm( CurrentElement % NodeIndexes ) 4501 IF( .NOT. ALL ( LocalPerm(1:n) > 0 )) RETURN 4502 LocalField(1:n) = Var % Values( LocalPerm(1:n) ) 4503 ELSE 4504 ! Some variables do not have permutation, most importantly the node coordinates 4505 LocalField(1:n) = Var % Values( CurrentElement % NodeIndexes ) 4506 END IF 4507 4508 Pot = SUM( Basis(1:n) * LocalField(1:n) ) 4509 4510 IF( PRESENT( GradPot ) ) THEN 4511 DO i=1,dim 4512 GradPot(i) = SUM( dBasisdx(1:n,i) * LocalField(1:n) ) 4513 END DO 4514 END IF 4515 4516 END SUBROUTINE GetScalarFieldInMesh 4517 4518 4519 4520 !------------------------------------------------------------------------- 4521 !> The routine returns the possible intersection of a secondary element 4522 !> with a different material property and the circle / sphere. 4523 !> For example, the buoyancy at the interface will depend on the weighted 4524 !> sum of the densities of the two materials. 4525 !-------------------------------------------------------------------------- 4526 4527 FUNCTION GetParticleElementIntersection(Particles,BulkElement, Basis, Coord, & 4528 Radius, BulkElement2, VolumeFraction, AreaFraction ) RESULT ( Intersect ) 4529 4530 TYPE(Particle_t), POINTER :: Particles 4531 TYPE(Element_t), POINTER :: BulkElement, BulkElement2 4532 REAL(KIND=dp) :: Basis(:) 4533 REAL(KIND=dp) :: Coord(3), Radius, VolumeFraction 4534 REAL(KIND=dp), OPTIONAL :: AreaFraction 4535 LOGICAL :: Intersect 4536 4537 INTEGER, POINTER :: NodeIndexes(:) 4538 TYPE(Mesh_t), POINTER :: Mesh 4539 REAL(KIND=dp) :: Dist, Normal(3), SumBasis 4540 TYPE(ValueList_t), POINTER :: Material, Material2, BC 4541 TYPE(Element_t), POINTER :: BoundaryElement, Left, Right 4542 TYPE(Nodes_t) :: BoundaryNodes 4543 INTEGER :: i,j,k,n,imax,body_id,body_id2,mat_id,mat_id2,dim,ind 4544 LOGICAL :: Visited 4545 4546 4547 SAVE :: Visited, Mesh, Dim 4548 4549 IF(.NOT. Visited ) THEN 4550 Mesh => GetMesh() 4551 Dim = Mesh % MeshDim 4552 Visited = .TRUE. 4553 END IF 4554 4555 Intersect = .FALSE. 4556 VolumeFraction = 0.0_dp 4557 4558 ! This element has no boundary / material interface 4559 IF( Particles % InternalElements( BulkElement % ElementIndex ) ) RETURN 4560 4561 ! If the radius of the particle is zero then it sees only the properties of one point 4562 IF( Radius < TINY( Radius ) ) RETURN 4563 4564 n = BulkElement % TYPE % NumberOfNodes 4565 body_id = BulkElement % BodyId 4566 mat_id = ListGetInteger( CurrentModel % Bodies(body_id) % Values,'Material' ) 4567 4568 IF( dim == 3 ) THEN 4569 imax = BulkElement % TYPE % NumberOfFaces 4570 ELSE 4571 imax = BulkElement % TYPE % NumberOfEdges 4572 END IF 4573 4574 DO i=1, imax 4575 4576 IF( dim == 3 ) THEN 4577 j = BulkElement % FaceIndexes(i) 4578 BoundaryElement => Mesh % Faces( j ) 4579 ELSE 4580 j = BulkElement % EdgeIndexes(i) 4581 BoundaryElement => Mesh % Edges(j) 4582 END IF 4583 4584 IF( .NOT. ASSOCIATED( BoundaryElement % BoundaryInfo ) ) CYCLE 4585 4586 Left => BoundaryElement % BoundaryInfo % Left 4587 Right => BoundaryElement % BoundaryInfo % Right 4588 4589 IF(.NOT. (ASSOCIATED( Left ) .AND. ASSOCIATED( Right ) ) ) CYCLE 4590 4591 IF( ASSOCIATED( BulkElement, Right ) ) THEN 4592 BulkElement2 => Left 4593 ELSE 4594 BulkElement2 => Right 4595 END IF 4596 4597 IF( .NOT. ASSOCIATED( BulkElement2 ) ) CYCLE 4598 4599 body_id2 = BulkElement2 % BodyId 4600 4601 IF( body_id2 > CurrentModel % NumberOfBodies ) THEN 4602 PRINT *,'BodyIds:',body_id,body_id2,CurrentModel % NumberOfBodies 4603 PRINT *,'ElemIds:',BulkElement % ElementIndex, BulkElement2 % ElementIndex 4604 PRINT *,'Types:',BulkElement % TYPE % NumberOfNodes, & 4605 BulkElement2 % TYPE % NumberOfNodes 4606 body_id2 = 0 4607 END IF 4608 4609 IF( body_id2 == 0 ) CYCLE 4610 4611 mat_id2 = ListGetInteger( CurrentModel % Bodies(body_id2) % Values,'Material' ) 4612 4613 ! If the materials are the same the density is ok 4614 IF( mat_id2 == mat_id ) CYCLE 4615 4616 ! If there is an material interface, check for distance 4617 CALL GetElementNodes(BoundaryNodes,BoundaryElement) 4618 Dist = PointFaceDistance(BoundaryElement,BoundaryNodes,Coord,Normal) 4619 Dist = ABS( Dist ) 4620 4621 ! Is is assumed that each element may only have one density interface 4622 IF( Dist > Radius ) RETURN 4623 4624 IF( dim == 3 ) THEN 4625 ! based on the formula of sphere-sphere intersection as in Wolfram MathWorld 4626 VolumeFraction = (Radius + Dist / 2 ) * (Radius - Dist)**2 / Radius**3 4627 IF( PRESENT( AreaFraction ) ) THEN 4628 AreaFraction = ( 1.0_dp - Dist/Radius )/2.0_dp 4629 END IF 4630 ELSE 4631 ! based on the formula of circle-circle intersection as in Wolfram MathWorld 4632 VolumeFraction = ( ( Radius ** 2) * ACOS( Dist / Radius ) & 4633 - Dist * SQRT( Radius ** 2 - Dist ** 2 ) ) / (PI * Radius**2) 4634 IF( PRESENT( AreaFraction ) ) THEN 4635 AreaFraction = ACOS( Dist / Radius ) / PI 4636 END IF 4637 END IF 4638 4639 ! PRINT *,'VolumeFraction:',VolumeFraction, Density 4640 RETURN 4641 END DO 4642 4643 END FUNCTION GetParticleElementIntersection 4644 4645 4646 !------------------------------------------------------------- 4647 !> This subroutine may be used to enquire position dependent material data. 4648 !> Also if the particle is split between two elements then this 4649 !> routine can assess the data on the secondary mesh. 4650 !------------------------------------------------------------- 4651 FUNCTION GetMaterialPropertyInMesh(PropertyName, BulkElement, Basis, & 4652 BulkElement2, VolumeFraction ) RESULT ( Property ) 4653 4654 CHARACTER(LEN=MAX_NAME_LEN) :: PropertyName 4655 TYPE(Element_t), POINTER :: BulkElement 4656 REAL(KIND=dp) :: Basis(:) 4657 TYPE(Element_t), POINTER, OPTIONAL :: BulkElement2 4658 REAL(KIND=dp), OPTIONAL :: VolumeFraction 4659 REAL(KIND=dp) :: Property 4660 4661 INTEGER, POINTER :: NodeIndexes(:) 4662 TYPE(Mesh_t), POINTER :: Mesh 4663 REAL(KIND=dp), POINTER :: ElemProperty(:) 4664 REAL(KIND=dp) :: Property2 4665 TYPE(ValueList_t), POINTER :: Material, Material2 4666 INTEGER :: i,j,k,n,mat_id,mat_id2 4667 LOGICAL :: Visited 4668 4669 4670 SAVE :: Visited, Mesh, ElemProperty 4671 4672 IF(.NOT. Visited ) THEN 4673 Mesh => GetMesh() 4674 n = Mesh % MaxElementNodes 4675 ALLOCATE( ElemProperty( n ) ) 4676 ElemProperty = 0.0_dp 4677 Visited = .TRUE. 4678 END IF 4679 4680 NodeIndexes => BulkElement % NodeIndexes 4681 n = BulkElement % TYPE % NumberOfNodes 4682 mat_id = ListGetInteger( CurrentModel % Bodies(BulkElement % BodyId) % Values,'Material' ) 4683 Material => CurrentModel % Materials(mat_id) % Values 4684 4685 ElemProperty(1:n) = ListGetReal( Material,PropertyName,n,NodeIndexes) 4686 Property = SUM( Basis(1:n) * ElemProperty(1:n) ) 4687 4688 IF( .NOT. PRESENT ( VolumeFraction ) ) RETURN 4689 IF( .NOT. PRESENT ( BulkElement2 ) ) RETURN 4690 IF( VolumeFraction < TINY( VolumeFraction) ) RETURN 4691 4692 IF( ASSOCIATED( BulkElement2 ) ) THEN 4693 mat_id2 = ListGetInteger( CurrentModel % Bodies(BulkElement2 % BodyId) % Values,'Material' ) 4694 ELSE 4695 mat_id2 = 0 4696 END IF 4697 4698 ! If the materials are the same the density is ok 4699 IF( mat_id2 == mat_id ) RETURN 4700 4701 ! If there is an material interface, check for distance 4702 IF( mat_id2 == 0 ) THEN 4703 Property2 = 0.0_dp 4704 ELSE 4705 NodeIndexes => BulkElement2 % NodeIndexes 4706 n = BulkElement2 % TYPE % NumberOfNodes 4707 Material2 => CurrentModel % Materials(mat_id2) % Values 4708 4709 ElemProperty(1:n) = ListGetReal( Material,PropertyName,n,NodeIndexes) 4710 4711 ! One cannot use the basis functions of the primary element. 4712 ! and this is valid for cases with constant material parameters. 4713 !------------------------------------------------------------------ 4714 Property2 = SUM( ElemProperty(1:n) ) / n 4715 END IF 4716 4717 Property = VolumeFraction * Property2 + (1-VolumeFraction) * Property 4718 4719 END FUNCTION GetMaterialPropertyInMesh 4720 4721 4722 !------------------------------------------------------------- 4723 !> This routine creates the nearest neighbours for all nodes. 4724 !> The particle-particle connections may then be found by going 4725 !> through all the nodes of elements. 4726 !------------------------------------------------------------- 4727 SUBROUTINE CreateNeighbourList( Particles ) 4728 4729 TYPE(Particle_t), POINTER :: Particles 4730 4731 INTEGER :: ElementIndex, dim 4732 REAL(KIND=dp) :: Coord(3), dist, mindist 4733 TYPE(ValueList_t), POINTER :: Params 4734 TYPE(Mesh_t), POINTER :: Mesh 4735 INTEGER :: i,j,k,n,node 4736 TYPE(Nodes_t), SAVE :: ElementNodes 4737 INTEGER, POINTER :: NodeIndexes(:) 4738 TYPE(Element_t), POINTER :: Element 4739 INTEGER :: NoNodes, NoParticles, MaxClosest 4740 4741 Mesh => GetMesh() 4742 NoNodes = Mesh % NumberOfNodes 4743 NoParticles = Particles % NumberOfParticles 4744 dim = Particles % dim 4745 4746 IF( .NOT. Particles % NeighbourTable ) THEN 4747 ALLOCATE( Particles % NoClosestParticle( NoNodes ) ) 4748 ALLOCATE( Particles % CumClosestParticle( NoNodes+1 ) ) 4749 ALLOCATE( Particles % ClosestNode(NoParticles) ) 4750 Particles % NeighbourTable = .TRUE. 4751 END IF 4752 4753 IF( SIZE( Particles % ClosestNode ) < NoParticles ) THEN 4754 CALL Fatal('CreateNeighbourList','ClosestNode vector of wrong size') 4755 END IF 4756 4757 ! First find the closest node to each particle 4758 !----------------------------------------------- 4759 Particles % ClosestNode = 0 4760 Particles % NoClosestParticle = 0 4761 DO i=1,NoParticles 4762 IF( Particles % Status(i) >= PARTICLE_LOST ) CYCLE 4763 IF( Particles % Status(i) < PARTICLE_INITIATED ) CYCLE 4764 4765 ElementIndex = Particles % ElementIndex(i) 4766 Element => Mesh % Elements( ElementIndex ) 4767 n = GetElementNOFNodes(Element) 4768 CALL GetElementNodes(ElementNodes,Element) 4769 Coord(1:dim) = Particles % Coordinate(i,1:dim) 4770 4771 ! Find the minimum distance node (using squares is faster) 4772 mindist = HUGE( mindist ) 4773 DO j=1,n 4774 dist = ( ElementNodes % x(j) - Coord(1) )**2 4775 dist = dist + ( ElementNodes % y(j) - Coord(2) )**2 4776 IF( dim == 3 ) THEN 4777 dist = dist + ( ElementNodes % z(j) - Coord(3) )**2 4778 END IF 4779 IF( dist < mindist ) THEN 4780 mindist = dist 4781 k = j 4782 END IF 4783 END DO 4784 node = Element % NodeIndexes(k) 4785 Particles % ClosestNode(i) = node 4786 Particles % NoClosestParticle(node) = Particles % NoClosestParticle(node) + 1 4787 END DO 4788 4789 4790 ! For parallel computation create a secondary copy of the neighbouring particles 4791 ! marked as ghost particle and update the total number. 4792 !------------------------------------------------------------------------------- 4793 CALL CreateGhostParticles( Particles ) 4794 4795 Particles % FirstGhost = NoParticles + 1 4796 IF( Particles % NumberOfParticles > NoParticles ) THEN 4797 Particles % FirstGhost = NoParticles + 1 4798 NoParticles = Particles % NumberOfParticles 4799 END IF 4800 4801 ! Count the cumulative number of closest particles for given node 4802 !----------------------------------------------------------------- 4803 Particles % CumClosestParticle(1) = 1 4804 MaxClosest = 0 4805 DO i=1,NoNodes 4806 j = Particles % NoClosestParticle(i) 4807 MaxClosest = MAX( MaxClosest, j ) 4808 Particles % CumClosestParticle(i+1) = Particles % CumClosestParticle(i)+j 4809 END DO 4810 Particles % MaxClosestParticles = MaxClosest 4811 4812 ! And finally, add the closest neighbors to the table 4813 !---------------------------------------------------------------- 4814 IF ( ASSOCIATED(Particles % ClosestParticle) ) & 4815 DEALLOCATE(Particles % ClosestParticle ) 4816 ALLOCATE( Particles % ClosestParticle(Particles % CumClosestParticle(NoNodes+1)) ) 4817 4818 Particles % NoClosestParticle = 0 4819 Particles % ClosestParticle = 0 4820 DO i=1,NoParticles 4821 IF ( Particles % Status(i) == PARTICLE_LOST ) CYCLE 4822 IF ( Particles % Status(i) < PARTICLE_INITIATED ) CYCLE 4823 node = Particles % ClosestNode(i) 4824 j = Particles % NoClosestParticle(node) 4825 k = Particles % CumClosestParticle(node) 4826 Particles % ClosestParticle(k+j) = i 4827 Particles % NoClosestParticle(node) = j + 1 4828 END DO 4829 4830 END SUBROUTINE CreateNeighbourList 4831 4832 4833 SUBROUTINE CreateGhostParticles(Particles) 4834 TYPE(Particle_t), POINTER :: Particles 4835 !--------------------------------------------------------- 4836 INTEGER i,j,k,l,m,n,dim,NoPartitions, node, & 4837 Proc, ierr, status(MPI_STATUS_SIZE), n_part, nReceived 4838 4839 INTEGER, ALLOCATABLE :: Perm(:), Indexes(:), Neigh(:), & 4840 Recv_parts(:), Requests(:) 4841 TYPE(Mesh_t), POINTER :: Mesh 4842 4843 TYPE(ParallelInfo_t), POINTER :: PI 4844 4845 LOGICAL, ALLOCATABLE :: IsNeighbour(:) 4846 INTEGER, POINTER :: Neighbours(:), Closest(:) 4847 4848 TYPE ExchgInfo_t 4849 INTEGER :: n=0 4850 INTEGER, ALLOCATABLE :: Gindex(:), Particles(:) 4851 END TYPE ExchgInfo_t 4852 4853 REAL(KIND=dp), ALLOCATABLE :: Buf(:) 4854 TYPE(ExchgInfo_t), POINTER :: Info(:) 4855 !-------------------------------------------------------- 4856 4857 nReceived = 0 4858 IF( ParEnv% PEs == 1 ) RETURN 4859 4860 Mesh => GetMesh() 4861 dim = Particles % dim 4862 4863 ! Count & Identify neighbouring partitions: 4864 ! ----------------------------------------- 4865 ALLOCATE(IsNeighbour(ParEnv % PEs)) 4866 NoPartitions = MeshNeighbours(Mesh,IsNeighbour) 4867 ALLOCATE(Perm(ParEnv % PEs), Neigh(NoPartitions) ) 4868 Perm = 0 4869 4870 NoPartitions=0 4871 DO i=1,ParEnv % PEs 4872 IF ( i-1==ParEnv % Mype ) CYCLE 4873 IF ( IsNeighbour(i) ) THEN 4874 NoPartitions=NoPartitions+1 4875 Perm(i) = NoPartitions 4876 Neigh(NoPartitions) = i-1 4877 END IF 4878 END DO 4879 DEALLOCATE(IsNeighbour) 4880 4881 ! Receive interface sizes: 4882 !-------------------------- 4883 ALLOCATE( Recv_Parts(NoPartitions), Requests(NoPartitions) ) 4884 DO i=1,NoPartitions 4885 CALL MPI_iRECV( Recv_Parts(i),1, MPI_INTEGER, Neigh(i), & 4886 2000, ELMER_COMM_WORLD, requests(i), ierr ) 4887 END DO 4888 4889 PI => Mesh % ParallelInfo 4890 4891 ! Exchange interface particles 4892 ! ---------------------------- 4893 ALLOCATE(Info(NoPartitions)) 4894 DO i=1,NoPartitions 4895 Info(i) % n = 0 4896 END DO 4897 4898 DO i=1,Particles % NumberOfParticles 4899 IF ( Particles % Status(i) == PARTICLE_LOST ) CYCLE 4900 4901 node = Particles % ClosestNode(i) 4902 IF ( .NOT. PI % INTERFACE(node) ) CYCLE 4903 Neighbours => PI % NeighbourList(node) % Neighbours 4904 DO j=1,SIZE(Neighbours) 4905 proc = Neighbours(j) 4906 IF ( Proc==Parenv % mype ) CYCLE 4907 proc = Perm(proc+1) 4908 IF ( Proc<=0 ) CYCLE 4909 Info(proc) % n = Info(proc) % n+1 4910 END DO 4911 END DO 4912 4913 DO i=1,NoPartitions 4914 CALL MPI_BSEND( Info(i) % n, 1, MPI_INTEGER, Neigh(i), & 4915 2000, ELMER_COMM_WORLD, ierr ) 4916 END DO 4917 4918 ! 4919 ! Collect particles to be sent to neighbours: 4920 ! ------------------------------------------- 4921 DO i=1,NoPartitions 4922 IF ( Info(i) % n==0 ) CYCLE 4923 ALLOCATE( Info(i) % Gindex(Info(i) % n), Info(i) % Particles(Info(i) % n) ) 4924 Info(i) % n = 0 4925 END DO 4926 4927 DO i=1,Particles % NumberOfParticles 4928 IF ( Particles % Status(i) == PARTICLE_LOST ) CYCLE 4929 4930 node = Particles % ClosestNode(i) 4931 IF ( .NOT. PI % INTERFACE(node) ) CYCLE 4932 Neighbours => PI % NeighbourList(node) % Neighbours 4933 DO j=1,SIZE(Neighbours) 4934 proc = Neighbours(j) 4935 IF ( Proc==Parenv % mype ) CYCLE 4936 proc = Perm(proc+1) 4937 IF ( Proc<=0 ) CYCLE 4938 Info(proc) % n = Info(proc) % n+1 4939 Info(proc) % Particles(Info(proc) % n) = i 4940 Info(proc) % Gindex(Info(proc) % n) = PI % GlobalDOFs(node) 4941 END DO 4942 END DO 4943 4944 n = 0 4945 DO i=1,NoPartitions 4946 n = n + Info(i) % n 4947 END DO 4948 n = 2*(n+2*(2*n*dim+n) + MPI_BSEND_OVERHEAD*2*NoPartitions) 4949 CALL CheckBuffer(n) 4950 4951 ! Send particles: 4952 ! --------------- 4953 DO j=1,NoPartitions 4954 n = Info(j) % n 4955 IF ( n<=0 ) CYCLE 4956 4957 CALL MPI_BSEND( Info(j) % Gindex, n, MPI_INTEGER, & 4958 Neigh(j), 2001, ELMER_COMM_WORLD, ierr ) 4959 4960 ALLOCATE(Buf(2*n*dim+n)) 4961 m = 0 4962 DO k=1,dim 4963 DO l=1,n 4964 m = m + 1 4965 Buf(m) = Particles % Coordinate(Info(j) % Particles(l),k) 4966 END DO 4967 END DO 4968! DO l=1,n 4969! m = m + 1 4970! Buf(m) = Particles % Dt(Info(j) % Particles(l)) 4971! END DO 4972 IF ( ASSOCIATED(Particles % Velocity) ) THEN 4973 DO k=1,dim 4974 DO l=1,n 4975 m = m + 1 4976 Buf(m) = Particles % Velocity(Info(j) % Particles(l),k) 4977 END DO 4978 END DO 4979 END IF 4980 CALL MPI_BSEND( Buf, m, MPI_DOUBLE_PRECISION, & 4981 Neigh(j), 2002, ELMER_COMM_WORLD, ierr ) 4982 DEALLOCATE(Buf) 4983 END DO 4984 4985 CALL MPI_WaitAll( NoPartitions, Requests, MPI_STATUSES_IGNORE, ierr ) 4986 n = SUM(Recv_Parts) 4987 IF ( Particles % NumberOfParticles+n > Particles % MaxNumberOfParticles ) THEN 4988 CALL IncreaseParticles( Particles, Particles % NumberOfParticles+2*n - & 4989 Particles % MaxNumberOfParticles ) 4990 END IF 4991 4992 4993 ! Recv particles: 4994 ! --------------- 4995 DO i=1,NoPartitions 4996 n = Recv_Parts(i) 4997 IF ( n<=0 ) CYCLE 4998 4999 proc = Neigh(i) 5000 5001 ALLOCATE(Indexes(n)) 5002 CALL MPI_RECV( Indexes, n, MPI_INTEGER, proc, & 5003 2001, ELMER_COMM_WORLD, status, ierr ) 5004 5005 n_part=Particles % NumberOfParticles 5006 DO j=1,n 5007 n_part = n_part+1 5008 Particles % Status(n_part) = PARTICLE_GHOST 5009 node = SearchNode(PI,Indexes(j)) 5010 IF ( node<=0 ) STOP 'a' 5011 Particles % ClosestNode(n_part) = node 5012 Particles % NoClosestParticle(node) = & 5013 Particles % NoClosestParticle(node) + 1 5014 END DO 5015 DEALLOCATE(Indexes) 5016 5017 m = n+n*dim 5018 IF ( ASSOCIATED(Particles % Velocity) ) m=m+n*dim 5019 5020 ALLOCATE(Buf(m)) 5021 CALL MPI_RECV( Buf, m, MPI_DOUBLE_PRECISION, proc, & 5022 2002, ELMER_COMM_WORLD, status, ierr ) 5023 5024 n_part=Particles % NumberOfParticles 5025 m = 0 5026 DO k=1,dim 5027 DO l=1,n 5028 m = m + 1 5029 Particles % Coordinate(n_part+l,k)=Buf(m) 5030 END DO 5031 END DO 5032 5033 IF ( ASSOCIATED(Particles % Velocity) ) THEN 5034 DO k=1,dim 5035 DO l=1,n 5036 m = m + 1 5037 Particles % Velocity(n_part+l,k)=Buf(m) 5038 END DO 5039 END DO 5040 END IF 5041 DEALLOCATE(Buf) 5042 Particles % NumberOfParticles = Particles % NumberOfParticles+n 5043 END DO 5044 5045 DEALLOCATE(Perm) 5046 DO i=1,NoPartitions 5047 IF ( Info(i) % n==0 ) CYCLE 5048 DEALLOCATE( Info(i) % Gindex, Info(i) % Particles ) 5049 END DO 5050 DEALLOCATE(Info, Recv_Parts, Neigh, Requests) 5051 5052 END SUBROUTINE CreateGhostParticles 5053 !------------------------------------------------------------ 5054 5055 5056 !--------------------------------------------------------------- 5057 !> This assumes that the real particles are followed by ghost particles. 5058 !> which are destroyed before leaving this configuration. 5059 !--------------------------------------------------------------- 5060 SUBROUTINE DestroyGhostParticles( Particles ) 5061 5062 TYPE(Particle_t), POINTER :: Particles 5063 INTEGER :: No, NumberOfParticles, FirstGhost 5064 5065 NumberOfParticles = Particles % NumberOfParticles 5066 FirstGhost = Particles % FirstGhost 5067 5068 IF ( FirstGhost <= NumberOfParticles ) THEN 5069 DO No = FirstGhost, NumberOfParticles 5070 Particles % Status(No) = PARTICLE_LOST 5071 END DO 5072 Particles % NumberOfParticles = FirstGhost - 1 5073 END IF 5074 5075 END SUBROUTINE DestroyGhostParticles 5076 5077 5078 5079 !------------------------------------------------------------ 5080 !> For the first call of given node do the list, thereafter 5081 !> Return the index until the list is finished. 5082 !------------------------------------------------------------ 5083 FUNCTION GetNextNeighbour( Particles, No ) RESULT ( No2 ) 5084 IMPLICIT NONE 5085 5086 TYPE(Particle_t), POINTER :: Particles 5087 INTEGER :: No, No2 5088 5089 INTEGER :: PrevNo = 0 5090 INTEGER, POINTER :: NodeIndexes(:), NeighbourList(:) => NULL(), TmpList(:) => NULL() 5091 INTEGER :: i,j,k,n,ListSize,NoNeighbours,ElementIndex,Cnt 5092 LOGICAL :: Visited = .FALSE. 5093 TYPE(Mesh_t), POINTER :: Mesh 5094 TYPE(Element_t), POINTER :: Element 5095 5096 SAVE Visited,PrevNo,NeighbourList,ListSize,NoNeighbours,Cnt 5097 5098 IF( PrevNo /= No ) THEN 5099 PrevNo = No 5100 IF( .NOT. Visited ) THEN 5101 Visited = .TRUE. 5102 Mesh => GetMesh() 5103 n = Mesh % MaxElementNodes 5104 ListSize = n * Particles % MaxClosestParticles + 10 5105 ALLOCATE( NeighbourList( ListSize ) ) 5106 NeighbourList = 0 5107 Mesh => GetMesh() 5108 END IF 5109 5110 Mesh => GetMesh() 5111 ElementIndex = Particles % ElementIndex(No) 5112 Element => Mesh % Elements( ElementIndex ) 5113 n = GetElementNOFNodes(Element) 5114 NodeIndexes => Element % NodeIndexes 5115 5116 NoNeighbours = 0 5117 DO i=1,n 5118 j = NodeIndexes(i) 5119 5120 DO k=Particles % CumClosestParticle(j),Particles % CumClosestParticle(j+1)-1 5121 No2 = Particles % ClosestParticle(k) 5122 5123 ! No self coupling in this list 5124 IF( No2 == No ) CYCLE 5125 5126 ! Set symmetric forces Fij=-Fij so no need to go through twice 5127 IF ( No2 < No ) CYCLE 5128 5129 NoNeighbours = NoNeighbours + 1 5130 5131 IF( NoNeighbours > ListSize ) THEN 5132 ALLOCATE( TmpList( ListSize + 20 ) ) 5133 TmpList(1:ListSize) = NeighbourList 5134 DEALLOCATE( NeighbourList ) 5135 NeighbourList => TmpList 5136 ListSize = ListSize + 20 5137 NULLIFY( TmpList ) 5138 CALL Info('GetNextNeighbour','Allocating more space: '//TRIM(I2S(ListSize))) 5139 END IF 5140 5141 NeighbourList(NoNeighbours) = No2 5142 END DO 5143 END DO 5144 Cnt = 0 5145 END IF 5146 5147 Cnt = Cnt + 1 5148 IF( Cnt > NoNeighbours ) THEN 5149 No2 = 0 5150 ELSE 5151 No2 = NeighbourList( Cnt ) 5152 END IF 5153 5154 END FUNCTION GetNextNeighbour 5155 5156 5157!------------------------------------------------------------ 5158!> Computes interaction between particles given an interaction 5159!> kernel that that is the pointer to the function that computes 5160!> the effect of the interaction in terms of forces or new coordinate 5161!> values (for collision models). 5162!------------------------------------------------------------ 5163 SUBROUTINE ParticleParticleInteraction( Particles, dtime, Collision, InteractionKernel ) 5164 5165 IMPLICIT NONE 5166 5167 TYPE(Particle_t), POINTER :: Particles 5168 REAL(KIND=dP) :: dtime 5169 LOGICAL :: Collision 5170 5171 INTERFACE 5172 SUBROUTINE InteractionKernel( t, r, r2, v, v2, f, f2, Hit ) 5173 INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12) 5174 REAL(KIND=dp) :: t,r(3),r2(3),v(3),v2(3),f(3),f2(3) 5175 LOGICAL :: Hit 5176 END SUBROUTINE InteractionKernel 5177 END INTERFACE 5178 5179 5180 INTEGER :: No, No2 5181 REAL(KIND=dp) :: Coord(3), Velo(3), Coord2(3), Velo2(3), Force(3), Force2(3) 5182 LOGICAL :: Interact 5183 5184 Coord = 0.0_dp 5185 Velo = 0.0_dp 5186 Force = 0.0_dp 5187 Coord2 = 0.0_dp 5188 Velo2 = 0.0_dp 5189 Force2 = 0.0_dp 5190 5191 5192 DO No=1,Particles % NumberOfParticles 5193 IF ( Particles % Status(no) == PARTICLE_GHOST ) EXIT 5194 IF ( Particles % Status(no) == PARTICLE_LOST ) CYCLE 5195 5196 Coord = GetParticleCoord( Particles, No ) 5197 Velo = GetParticleVelo( Particles, No ) 5198 5199 DO WHILE(.TRUE.) 5200 No2 = GetNextNeighbour( Particles, No ) 5201 IF( No2 == 0 ) EXIT 5202 Coord2 = GetParticleCoord( Particles, No2 ) 5203 Velo2 = GetParticleVelo( Particles, No2 ) 5204 5205 CALL InteractionKernel(dtime,Coord,Coord2,Velo,Velo2,& 5206 Force,Force2, Interact) 5207 IF(.NOT. Interact ) CYCLE 5208 5209 IF( Collision ) THEN 5210 CALL SetParticleCoord( Particles, No, Coord ) 5211 CALL SetParticleCoord( Particles, No2, Coord2 ) 5212 CALL AddParticleForce( Particles, No, Force ) 5213 CALL AddParticleForce( Particles, No2, Force2 ) 5214 ELSE 5215 CALL AddParticleForce( Particles, No, Force ) 5216 CALL AddParticleForce( Particles, No2, Force2 ) 5217 END IF 5218 5219 END DO 5220 END DO 5221 END SUBROUTINE ParticleParticleInteraction 5222 5223 5224 !--------------------------------------------------------- 5225 !> Initialize the time for next time integration step 5226 !--------------------------------------------------------- 5227 SUBROUTINE ParticleInitializeTime( Particles, No ) 5228 TYPE(Particle_t), POINTER :: Particles 5229 INTEGER, OPTIONAL :: No 5230 5231 IF( PRESENT( No ) ) THEN 5232 Particles % Force( No, : ) = 0.0_dp 5233 ELSE 5234 Particles % Force = 0.0_dp 5235 END IF 5236 5237 END SUBROUTINE ParticleInitializeTime 5238 5239 5240 5241 !--------------------------------------------------------- 5242 !> Advance the particles with a time step. The timestep may 5243 !> also be an intermediate Runge-Kutta step. 5244 !--------------------------------------------------------- 5245 SUBROUTINE ParticleAdvanceTimestep( Particles, RKstepInput ) 5246 TYPE(Particle_t), POINTER :: Particles 5247 INTEGER, OPTIONAL :: RKStepInput 5248 5249 REAL(KIND=dp) :: dtime 5250 TYPE(Variable_t), POINTER :: Var, TimeVar, DistVar, DtVar 5251 LOGICAL :: GotVar, GotTimeVar, GotDistVar, MovingMesh 5252 REAL(KIND=dp) :: ds, dCoord(3),Coord(3),Velo(3),Speed0,Speed 5253 INTEGER :: dim, Status, TimeOrder, No, NoMoving 5254 TYPE(ValueList_t), POINTER :: Params 5255 INTEGER :: NoParticles, RKStep 5256 LOGICAL :: Found, Visited = .FALSE.,RK2,HaveSpeed0 5257 5258 REAL(KIND=dp) :: mass, drag 5259 REAL(KIND=dp), POINTER :: massv(:), dragv(:) 5260 LOGICAL :: GotMass, GotDrag 5261 INTEGER :: CurrGroup, PrevGroup, NoGroups 5262 5263 SAVE TimeOrder, dim, Mass, Drag, Visited, dCoord, Coord, GotTimeVar, & 5264 GotDistVar, TimeVar, DtVar, DistVar, MovingMesh,Speed0,HaveSpeed0, Params 5265 5266 5267 IF(.NOT. Visited ) THEN 5268 Params => ListGetSolverParams() 5269 TimeOrder = Particles % TimeOrder 5270 dim = Particles % dim 5271 5272 dCoord = 0.0_dp 5273 Coord = 0.0_dp 5274 Visited = .TRUE. 5275 MovingMesh = .FALSE. 5276 5277 TimeVar => ParticleVariableGet( Particles,'particle time') 5278 GotTimeVar = ASSOCIATED( TimeVar ) 5279 5280 IF( GotTimeVar ) THEN 5281 IF( .NOT. Particles % DtConstant ) THEN 5282 DtVar => ParticleVariableGet( Particles,'particle dt') 5283 IF(.NOT. ASSOCIATED( DtVar ) ) THEN 5284 CALL Fatal('ParticleAdvanceTimesteo','Variable timestep, > particle dt < should exist!') 5285 END IF 5286 END IF 5287 END IF 5288 5289 DistVar => ParticleVariableGet( Particles,'particle distance') 5290 GotDistVar = ASSOCIATED( DistVar ) 5291 5292 Speed0 = GetCReal( Params,'Particle Speed Constant',HaveSpeed0 ) 5293 END IF 5294 5295 NoParticles = Particles % NumberOfParticles 5296 NoGroups = Particles % NumberOfGroups 5297 NoMoving = 0 5298 RK2 = Particles % RK2 5299 RKStep = 0 5300 IF(PRESENT(RKStepInput)) RKStep=RKStepInput 5301 5302 IF( RK2 .AND. .NOT. ASSOCIATED( Particles % PrevVelocity ) ) THEN 5303 ALLOCATE( Particles % PrevVelocity( & 5304 SIZE( Particles % Velocity,1 ),SIZE( Particles % Velocity,2) ) ) 5305 Particles % PrevVelocity = Particles % Velocity 5306 END IF 5307 5308 IF( Particles % DtConstant ) THEN 5309 dtime = Particles % DtSign * Particles % dTime 5310 END IF 5311 5312 GotMass = .FALSE. 5313 GotDrag = .FALSE. 5314 IF( TimeOrder == 2 ) THEN 5315 IF( NoGroups > 1 ) THEN 5316 massv => ListGetConstRealArray1( Params,'Particle Mass',GotMass) 5317 Mass = 0.0_dp 5318 ELSE 5319 Mass = ListGetConstReal( Params,'Particle Mass',GotMass) 5320 END IF 5321 IF(.NOT. GotMass) CALL Fatal('ParticleAdvanceTime',& 5322 '> Particle Mass < should be given!') 5323 ELSE IF( TimeOrder == 1 ) THEN 5324 IF( NoGroups > 1 ) THEN 5325 dragv => ListGetConstRealArray1( Params,'Particle Drag Coefficient',GotDrag) 5326 Drag = 0.0_dp 5327 ELSE 5328 Drag = ListGetConstReal( Params,'Particle Drag Coefficient',GotDrag) 5329 END IF 5330 IF(.NOT. GotDrag) CALL Fatal('ParticleAdvanceTime',& 5331 '> Particle Drag Coefficient < should be given!') 5332 END IF 5333 PrevGroup = -1 5334 5335 5336 5337 ! Now move the particles 5338 !--------------------------- 5339 DO No=1, NoParticles 5340 5341 Status = Particles % Status(No) 5342 5343 IF ( Status >= PARTICLE_LOST ) CYCLE 5344 IF ( Status <= PARTICLE_INITIATED ) CYCLE 5345 IF ( Status == PARTICLE_WALLBOUNDARY ) CYCLE 5346 5347 ! Cumulate the time 5348 !----------------------------------------------------------------- 5349 IF( .NOT. Particles % DtConstant ) THEN 5350 dtime = Particles % DtSign * DtVar % Values(No) 5351 TimeVar % Values(No) = TimeVar % Values(No) + DtVar % Values(No) 5352 IF( ABS( dtime ) < TINY( dtime ) ) CYCLE 5353 ELSE IF( GotTimeVar ) THEN 5354 TimeVar % Values(No) = TimeVar % Values(No) + Particles % dTime 5355 END IF 5356 5357 IF( NoGroups > 1 ) THEN 5358 CurrGroup = GetParticleGroup(Particles,No) 5359 IF( CurrGroup /= PrevGroup ) THEN 5360 IF(GotMass) THEN 5361 mass = massv(MIN(SIZE(massv),CurrGroup)) 5362 END IF 5363 IF(GotDrag) drag = dragv(MIN(SIZE(dragv),CurrGroup)) 5364 END IF 5365 PrevGroup = CurrGroup 5366 END IF 5367 5368 IF ( Status == PARTICLE_FIXEDCOORD ) THEN 5369 Particles % Velocity(No,:) = 0.0_dp 5370 CYCLE 5371 ELSE IF( Status == PARTICLE_FIXEDVELO ) THEN 5372 CONTINUE 5373 ELSE IF( TimeOrder == 2 ) THEN 5374 Particles % Velocity(No,:) = Particles % Velocity(No,:) + & 5375 dtime * Particles % Force(No,:) / Mass 5376 ELSE IF( TimeOrder == 1 ) THEN 5377 Particles % Velocity(No,:) = Particles % Force(No,:) / Drag 5378 ELSE IF( TimeOrder == 0 ) THEN 5379 ! Velocity stays fixed 5380 CONTINUE 5381 ELSE 5382 CALL Fatal('ParticleAdvanceTimestep','Unknown time order') 5383 END IF 5384 5385 5386 IF( RK2 .AND. RKStep == 2 ) THEN 5387 Velo(1:dim) = & 5388 ( 2 * Particles % Velocity(No,:) - Particles % PrevVelocity(No,:) ) 5389 ELSE 5390 Velo(1:dim) = Particles % Velocity(No,:) 5391 END IF 5392 5393 IF( HaveSpeed0 ) THEN 5394 Speed = SQRT( SUM( Velo(1:dim)**2 ) ) 5395 IF( Speed > TINY( Speed ) ) THEN 5396 dCoord(1:dim) = dtime * Speed0 * Velo(1:dim) / Speed 5397 ELSE 5398 dCoord(1:dim) = 0.0_dp 5399 END IF 5400 ELSE 5401 dCoord(1:dim) = dtime * Velo(1:dim) 5402 END IF 5403 5404 Particles % PrevCoordinate(No,:) = Particles % Coordinate(No,:) 5405 IF( ASSOCIATED( Particles % PrevVelocity ) ) THEN 5406 Particles % PrevVelocity(No,:) = Particles % Velocity(No,:) 5407 END IF 5408 Particles % Force(No,:)= 0.0_dp 5409 5410 NoMoving = NoMoving + 1 5411 5412 Particles % Status(No) = PARTICLE_READY 5413 Particles % Coordinate(No,:) = Particles % Coordinate(No,:) + dCoord(1:dim) 5414 5415 IF( GotDistVar ) THEN 5416 ds = SQRT( SUM( dCoord(1:dim)**2 ) ) 5417 DistVar % Values(No) = DistVar % Values(No) + ds 5418 END IF 5419 END DO 5420 5421 IF( Particles % DtConstant ) THEN 5422 Particles % Time = Particles % Time + Particles % dTime 5423 END IF 5424 5425 Particles % NumberOfMovingParticles = NoMoving 5426 5427 END SUBROUTINE ParticleAdvanceTimestep 5428 5429 5430 !--------------------------------------------------------- 5431 !> Advance some tracer quantities related to the particles. 5432 !--------------------------------------------------------- 5433 SUBROUTINE ParticlePathIntegral( Particles, RKstepInput ) 5434 TYPE(Particle_t), POINTER :: Particles 5435 INTEGER, OPTIONAL :: RKstepInput 5436 5437 TYPE(Variable_t), POINTER :: TimeIntegVar, DistIntegVar, DtVar 5438 LOGICAL :: GotVar, RK2 5439 REAL(KIND=dp) :: ds,dtime,Coord(3),PrevCoord(3),LocalCoord(3),Velo(3),u,v,w,& 5440 SourceAtPath,detJ,RKCoeff 5441 INTEGER :: dim, Status, RKStep 5442 TYPE(ValueList_t), POINTER :: Params 5443 INTEGER :: NoParticles, No, n, NoVar, i, j, bf_id 5444 LOGICAL :: Found, Stat, Visited = .FALSE. 5445 TYPE(Nodes_t) :: Nodes 5446 REAL(KIND=dp), POINTER :: Basis(:), Source(:), dBasisdx(:,:) 5447 INTEGER, POINTER :: Indexes(:) 5448 TYPE(ValueList_t), POINTER :: BodyForce 5449 TYPE(Element_t), POINTER :: Element 5450 TYPE(Mesh_t), POINTER :: Mesh 5451 CHARACTER(LEN=MAX_NAME_LEN) :: str, VariableName 5452 LOGICAL :: TimeInteg, DistInteg, UseGradSource 5453 5454 5455 SAVE TimeInteg, DistInteg, dim, Visited, Mesh, DtVar, Basis, Source, Nodes, Params, & 5456 TimeIntegVar, DistIntegVar, UseGradSource, dBasisdx 5457 5458 CALL Info('ParticlePathIntegral','Integrating variables over the path',Level=12) 5459 5460 5461 ! If Runge-Kutta is used take the mid-point rule. 5462 RKSTep = 0 5463 IF( PRESENT( RKStepInput ) ) RKStep = RKStepInput 5464 5465 IF( RKStep > 1 ) RETURN 5466 5467 IF(.NOT. Visited ) THEN 5468 Visited = .TRUE. 5469 5470 Params => ListGetSolverParams() 5471 Mesh => CurrentModel % Solver % Mesh 5472 dim = Particles % dim 5473 5474 n = Mesh % MaxElementNodes 5475 ALLOCATE( Basis(n), Source(n), Nodes % x(n), Nodes % y(n), Nodes % z(n), & 5476 dBasisdx(n,3) ) 5477 Basis = 0.0_dp 5478 Source = 0.0_dp 5479 Nodes % x = 0.0_dp 5480 Nodes % y = 0.0_dp 5481 Nodes % z = 0.0_dp 5482 dBasisdx = 0.0_dp 5483 5484 UseGradSource = GetLogical( Params,'Source Gradient Correction',Found) 5485 ! If the correction is not given follow the logic of velocity estimation 5486 IF(UseGradSource .AND. Particles % RK2 ) THEN 5487 CALL Warn('ParticlePathIntegral','Quadratic source correction incompatibe with Runge-Kutta') 5488 UseGradSource = .FALSE. 5489 END IF 5490 5491 IF( .NOT. Particles % DtConstant ) THEN 5492 DtVar => ParticleVariableGet( Particles,'particle dt') 5493 IF(.NOT. ASSOCIATED( DtVar ) ) THEN 5494 CALL Fatal('ParticleAdvanceTimesteo','Variable timestep, > particle dt < should exist!') 5495 END IF 5496 END IF 5497 5498 TimeIntegVar => ParticleVariableGet( Particles,'particle time integral') 5499 TimeInteg = ASSOCIATED( TimeIntegVar ) 5500 5501 DistIntegVar => ParticleVariableGet( Particles,'particle distance integral') 5502 DistInteg = ASSOCIATED( DistIntegVar ) 5503 END IF 5504 5505 ! Nothing to integrate over 5506 IF( .NOT. (TimeInteg .OR. DistInteg ) ) RETURN 5507 5508 NoParticles = Particles % NumberOfParticles 5509 RK2 = Particles % RK2 5510 IF( RK2 ) THEN 5511 RKCoeff = 2.0 5512 ELSE 5513 RKCoeff = 1.0 5514 END IF 5515 5516 IF( dim < 3 ) w = 0.0_dp 5517 5518 IF( Particles % DtConstant ) THEN 5519 dtime = RKCoeff * Particles % dTime 5520 END IF 5521 5522 DO No=1, NoParticles 5523 Status = Particles % Status(No) 5524 5525 IF ( Status >= PARTICLE_LOST ) CYCLE 5526 IF ( Status <= PARTICLE_INITIATED ) CYCLE 5527 IF ( Status == PARTICLE_WALLBOUNDARY ) CYCLE 5528 IF ( Status == PARTICLE_FIXEDCOORD ) CYCLE 5529 5530 ! Local timestep size 5531 !----------------------------------------------------------------- 5532 IF( .NOT. Particles % DtConstant ) THEN 5533 dtime = RKCoeff * DtVar % Values(No) 5534 END IF 5535 5536 Coord = 0._dp 5537 Coord(1:dim) = Particles % Coordinate(No,:) 5538 Velo = 0._dp 5539 Velo(1:dim) = Particles % Velocity(No,:) 5540 5541 Element => Mesh % Elements( Particles % ElementIndex(No) ) 5542 n = Element % TYPE % NumberOfNodes 5543 Indexes => Element % NodeIndexes 5544 5545 Nodes % x(1:n) = Mesh % Nodes % x( Indexes ) 5546 Nodes % y(1:n) = Mesh % Nodes % y( Indexes ) 5547 Nodes % z(1:n) = Mesh % Nodes % z( Indexes ) 5548 5549 bf_id = ListGetInteger( CurrentModel % Bodies(Element % BodyId) % Values, & 5550 'Body Force', Found ) 5551 IF( .NOT. Found ) CYCLE 5552 BodyForce => CurrentModel % BodyForces(bf_id) % Values 5553 5554 IF( ASSOCIATED( Particles % uvw ) ) THEN 5555 u = Particles % uvw(No,1) 5556 v = Particles % uvw(No,2) 5557 IF( dim == 3 ) w = Particles % uvw(No,3) 5558 ELSE 5559 IF(.NOT. PointInElement( Element, Nodes, & 5560 Coord, LocalCoord ) ) CYCLE 5561 u = LocalCoord(1) 5562 v = LocalCoord(2) 5563 w = LocalCoord(3) 5564 END IF 5565 5566 ! Make the integral more accurate by including a correction term based on the 5567 ! elemental derivate of the source term. 5568 IF( UseGradSource ) THEN 5569 stat = ElementInfo( Element,Nodes,u,v,w,detJ,Basis,dBasisdx) 5570 ELSE 5571 stat = ElementInfo( Element,Nodes,u,v,w,detJ,Basis) 5572 END IF 5573 5574 PrevCoord(1:dim) = Particles % PrevCoordinate(No,:) 5575 5576 ! Path integral over time 5577 IF( TimeInteg ) THEN 5578 Source(1:n) = ListGetReal( BodyForce,'Particle Time Integral Source', & 5579 n, Indexes, Found ) 5580 IF( Found ) THEN 5581 SourceAtPath = SUM( Basis(1:n) * Source(1:n) ) 5582 IF( UseGradSource ) THEN 5583 DO i=1,dim 5584 SourceAtPath = SourceAtPath + 0.5*SUM( dBasisdx(1:n,i) * Source(1:n) ) * & 5585 ( PrevCoord(i) - Coord(i) ) 5586 END DO 5587 END IF 5588 TimeIntegVar % Values(No) = TimeIntegVar % Values(No) + dtime * SourceAtPath 5589 END IF 5590 END IF 5591 5592 ! Path integral over distance 5593 IF( DistInteg ) THEN 5594 IF( RK2 ) THEN 5595 ! for R-K the velocity has been updated to the midpoint and this is used 5596 ! to determine the differential path. 5597 ds = dtime * SQRT( SUM( Velo(1:dim)**2) ) 5598 ELSE 5599 ! If we have used quadtatic velocity correction at the previous point 5600 ! the current (or previous) velocity alone does not give the correct 5601 ! ds, but this does. 5602 ds = SQRT(SUM((PrevCoord(1:dim) - Coord(1:dim))**2)) 5603 END IF 5604 5605 Source(1:n) = ListGetReal( BodyForce,'Particle Distance Integral Source', & 5606 n, Indexes, Found ) 5607 IF( Found ) THEN 5608 SourceAtPath = SUM( Basis(1:n) * Source(1:n) ) 5609 IF( UseGradSource ) THEN 5610 DO i=1,dim 5611 SourceAtPath = SourceAtPath + 0.5*SUM( dBasisdx(1:n,i) * Source(1:n) ) * & 5612 ( PrevCoord(i) - Coord(i) ) 5613 END DO 5614 END IF 5615 DistIntegVar % Values(No) = DistIntegVar % Values(No) + ds * SourceAtPath 5616 END IF 5617 END IF 5618 5619 END DO 5620 5621 END SUBROUTINE ParticlePathIntegral 5622 5623 5624 5625 !--------------------------------------------------------------- 5626 !> Checks the boundaries for rectangular and hexahedral shapes and 5627 !> enforces periodic BCs. Currently the only supported way 5628 !> for setting periodic BCs. 5629 !--------------------------------------------------------------- 5630 SUBROUTINE ParticleBoxPeriodic( Particles ) 5631 5632 TYPE(Particle_t), POINTER :: Particles 5633 5634 TYPE(Solver_t), POINTER :: Solver 5635 REAL(KIND=dp) :: Coord, Rad 5636 TYPE(Mesh_t), POINTER :: Mesh 5637 TYPE(ValueList_t), POINTER :: Params 5638 REAL(KIND=dP) :: MinCoord(3), MaxCoord(3), EpsCoord 5639 INTEGER :: i,j,k,dim, ierr, PeriodicDir(3),NoPeriodic 5640 LOGICAL :: Mapped,Reflect,Found,SaveCount,Visited = .FALSE. 5641 INTEGER :: Operations, No, NoParticles, Status, NoCount(6), NoStep 5642 INTEGER, POINTER :: TmpInteger(:) 5643 CHARACTER(LEN=MAX_NAME_LEN) :: Filename 5644 5645 SAVE Visited, Reflect, PeriodicDir, NoPeriodic, MinCoord, MaxCoord, dim, & 5646 SaveCount, NoCount, Filename, NoStep 5647 5648 IF( .NOT. Visited ) THEN 5649 Visited = .TRUE. 5650 Mesh => GetMesh() 5651 Params => ListGetSolverParams() 5652 dim = Mesh % Meshdim 5653 5654 NoPeriodic = 0 5655 PeriodicDir = 0 5656 5657 TmpInteger => ListGetIntegerArray( & 5658 Params,'Box Periodic Directions',Found ) 5659 IF( Found ) THEN 5660 NoPeriodic = SIZE( TmpInteger ) 5661 DO i=1,NoPeriodic 5662 PeriodicDir(i) = TmpInteger(i) 5663 END DO 5664 ELSE IF( ListGetLogical( Params,'Box Particle Periodic',Found)) THEN 5665 NoPeriodic = dim 5666 DO i=1,dim 5667 PeriodicDir(i) = i 5668 END DO 5669 END IF 5670 5671 MinCoord = Particles % GlobalMinCoord 5672 MaxCoord = Particles % GlobalMaxCoord 5673 EpsCoord = EPSILON( EpsCoord ) * MAXVAL( MaxCoord - MinCoord ) 5674 MinCoord = MinCoord + EpsCoord 5675 MaxCoord = MaxCoord - EpsCoord 5676 5677 Filename = ListGetString( Params,'Box Periodic Filename', SaveCount ) 5678 NoCount = 0 5679 NoStep = 0 5680 END IF 5681 5682 IF( NoPeriodic == 0 ) RETURN 5683 5684 NoParticles = Particles % NumberOfParticles 5685 5686 5687 DO No = 1, NoParticles 5688 Status = Particles % Status(No) 5689 IF( Status >= PARTICLE_LOST ) CYCLE 5690 IF( Status < PARTICLE_INITIATED ) CYCLE 5691 5692 ! Boundary conditions for periodic BCs 5693 !------------------------------------------ 5694 DO i=1,NoPeriodic 5695 Mapped = .FALSE. 5696 DO j=1,NoPeriodic 5697 k = PeriodicDir(j) 5698 coord = Particles % Coordinate(No,k) 5699 IF( coord < MinCoord(k) ) THEN 5700 IF( SaveCount ) NoCount(2*k-1) = NoCount(2*k-1) + 1 5701 coord = MaxCoord(k) - MinCoord(k) + coord 5702 Particles % Coordinate(No,k) = coord 5703 Mapped = .TRUE. 5704 ELSE IF ( coord > MaxCoord(k) ) THEN 5705 IF( SaveCount ) NoCount(2*k) = NoCount(2*k) + 1 5706 Coord = MinCoord(k) - MaxCoord(k) + Coord 5707 Particles % Coordinate(No,k) = coord 5708 Mapped = .TRUE. 5709 END IF 5710 END DO 5711 5712 IF(.NOT. Mapped ) EXIT 5713 END DO 5714 END DO 5715 5716 IF( SaveCount ) THEN 5717 IF( NoStep == 0 ) THEN 5718 OPEN (10, FILE=FileName ) 5719 ELSE 5720 OPEN (10, FILE=FileName, POSITION='append') 5721 END IF 5722 NoStep = NoStep + 1 5723 WRITE( 10, * ) NoStep, NoCount(1:2*NoPeriodic) 5724 CLOSE( 10 ) 5725 END IF 5726 5727 END SUBROUTINE ParticleBoxPeriodic 5728 5729 5730 !--------------------------------------------------------------- 5731 !> Checks the boundaries for rectangular and hexahedral shapes and 5732 !> enforces elastic reflection. This is alternative and 5733 !> computationally more economic way and is ideal for testing 5734 !> purposes, at least. 5735 !--------------------------------------------------------------- 5736 SUBROUTINE ParticleBoxContact(Particles) 5737 5738 TYPE(Particle_t), POINTER :: Particles 5739 5740 TYPE(Solver_t), POINTER :: Solver 5741 REAL(KIND=dp) :: Coord, Velo, Rad, Spring 5742 TYPE(Mesh_t), POINTER :: Mesh 5743 TYPE(ValueList_t), POINTER :: Params 5744 REAL(KIND=dP) :: MinCoord(3), MaxCoord(3), eta 5745 INTEGER :: i,j,k,dim, ierr,ContactDir(3) 5746 LOGICAL :: Mapped,Found,CollisionBC,ContactBC,Visited = .FALSE. 5747 INTEGER :: No, NoParticles, Status, NoContact 5748 INTEGER, POINTER :: TmpInteger(:) 5749 5750 SAVE Visited, NoContact, ContactDir, MinCoord, MaxCoord, dim, & 5751 CollisionBC, ContactBC, Spring 5752 5753 IF( .NOT. Visited ) THEN 5754 Visited = .TRUE. 5755 Mesh => GetMesh() 5756 Params => ListGetSolverParams() 5757 dim = Mesh % Meshdim 5758 5759 NoContact = 0 5760 ContactDir = 0 5761 5762 ContactBC = ListGetLogical(Params,'Box Particle Contact',Found) 5763 CollisionBC = ListGetLogical( Params,'Box Particle Collision',Found) 5764 5765 IF( ContactBC .OR. CollisionBC ) THEN 5766 TmpInteger => ListGetIntegerArray( & 5767 Params,'Box Contact Directions',Found ) 5768 IF( Found ) THEN 5769 NoContact = SIZE( TmpInteger ) 5770 DO i=1,NoContact 5771 ContactDir(i) = TmpInteger(i) 5772 END DO 5773 ELSE 5774 DO i=1,dim 5775 ContactDir(i) = i 5776 END DO 5777 NoContact = dim 5778 END IF 5779 ELSE 5780 NoContact = 0 5781 END IF 5782 IF( NoContact == 0 ) RETURN 5783 5784 MinCoord = Particles % GlobalMinCoord 5785 MaxCoord = Particles % GlobalMaxCoord 5786 5787 ! Particles of finite size collide before their center 5788 ! hits the wall. 5789 Rad = GetCReal( Params,'Wall Particle Radius',Found) 5790 IF( Found ) THEN 5791 MaxCoord = MaxCoord - Rad 5792 MinCoord = MinCoord + Rad 5793 END IF 5794 5795 IF( ContactBC ) THEN 5796 Spring = GetCReal(Params,'Wall Particle Spring',Found) 5797 IF(.NOT. Found) CALL Fatal('ParticleBoxContact',& 5798 '> Wall Particle Spring < needed!') 5799 END IF 5800 5801 END IF 5802 5803 IF( NoContact == 0) RETURN 5804 5805 NoParticles = Particles % NumberOfParticles 5806 5807 DO No = 1, NoParticles 5808 Status = Particles % Status(No) 5809 IF( Status >= PARTICLE_LOST ) CYCLE 5810 IF( Status < PARTICLE_INITIATED ) CYCLE 5811 5812 ! Boundary conditions for reflection. 5813 ! Multiple reflections may be carried out. 5814 !------------------------------------------ 5815 DO i=1,NoContact 5816 5817 IF( CollisionBC ) THEN 5818 Mapped = .FALSE. 5819 DO j=1,NoContact 5820 k = ContactDir(j) 5821 Coord = Particles % Coordinate(No,k) 5822 5823 IF( Coord < MinCoord(k) ) THEN 5824 Coord = 2 * MinCoord(k) - Coord 5825 Particles % Coordinate(No,k) = Coord 5826 Particles % Velocity(No,k) = -Particles % Velocity(No,k) 5827 Mapped = .TRUE. 5828 ELSE IF ( Coord > MaxCoord(k) ) THEN 5829 Coord = 2 * MaxCoord(k) - Coord 5830 Particles % Coordinate(No,k) = Coord 5831 Particles % Velocity(No,k) = -Particles % Velocity(No,k) 5832 Mapped = .TRUE. 5833 END IF 5834 END DO 5835 IF(.NOT. Mapped ) EXIT 5836 ELSE 5837 k = ContactDir(i) 5838 Coord = Particles % Coordinate(No,k) 5839 5840 IF( MinCoord(k) - Coord > 0.0_dp ) THEN 5841 eta = MinCoord(k) - Coord 5842 Particles % Force(No,k) = Particles % Force(No,k) + eta * Spring 5843 ELSE IF( Coord - MaxCoord(k) > 0.0_dp ) THEN 5844 eta = Coord - MaxCoord(k) 5845 Particles % Force(No,k) = Particles % Force(No,k) - eta * Spring 5846 END IF 5847 END IF 5848 END DO 5849 5850 END DO 5851 5852 END SUBROUTINE ParticleBoxContact 5853 5854 5855 5856!-------------------------------------------------------------------------- 5857!> Set a the timestep for the particles. 5858!> Depending on the definitions the timestep may be the same for all 5859!> particles, or may be defined independently for each particle. 5860!------------------------------------------------------------------------- 5861 FUNCTION GetParticleTimeStep(Particles, InitInterval, tinit ) RESULT ( dtout ) 5862 5863 TYPE(Particle_t), POINTER :: Particles 5864 LOGICAL :: InitInterval 5865 REAL(KIND=dp), OPTIONAL :: tinit 5866 REAL(KIND=dp) :: dtout 5867 5868 INTEGER :: No, Status 5869 REAL(KIND=dp) :: dt,dt0,tfin,tprev,dsgoal,hgoal,dtmax,dtmin,dtup,dtlow, & 5870 CharSpeed, CharTime, dtave 5871 LOGICAL :: GotIt,TfinIs,NStepIs,DsGoalIs,HgoalIs,HgoalIsUniso,DtIs 5872 INTEGER :: nstep, TimeStep, PrevTimeStep = -1 5873 TYPE(ValueList_t), POINTER :: Params 5874 TYPE(Variable_t), POINTER :: TimeVar, DtVar 5875 5876 SAVE dt0,dsgoal,hgoal,dtmax,dtmin,DtIs,Nstep,& 5877 tprev,Tfin,TfinIs,DsGoalIs,HgoalIs,HgoalIsUniso,PrevTimeStep, & 5878 DtVar,TimeVar 5879 5880 dtout = 0.0_dp; dtave = 0._dp 5881 5882 IF( InitInterval ) THEN 5883 Params => ListGetSolverParams() 5884 5885 ! directly defined timestep 5886 dt0 = GetCReal(Params,'Timestep Size',DtIs) 5887 5888 ! Constraint by absolute step size taken (in length units) 5889 dsgoal = GetCReal( Params,'Timestep Distance',DsGoalIs) 5890 5891 ! Constraint by relative step size taken (1 means size of the element) 5892 hgoal = GetCReal( Params,'Timestep Courant Number',HGoalIs) 5893 5894 ! Constraint by relative step size taken (each cartesian direction of element) 5895 HGoalIsUniso = .FALSE. 5896 IF(.NOT. HGoalIs ) THEN 5897 hgoal = GetCReal( Params,'Timestep Unisotropic Courant Number',HGoalIsUniso) 5898 END IF 5899 5900 Nstep = GetInteger( Params,'Max Timestep Intervals',GotIt) 5901 IF(.NOT. GotIt) Nstep = 1 5902 5903 ! Constraint timestep directly 5904 dtmax = GetCReal( Params,'Max Timestep Size',GotIt) 5905 IF(.NOT. GotIt ) dtmax = HUGE( dtmax ) 5906 dtmin = GetCReal( Params,'Min Timestep Size',GotIt) 5907 IF(.NOT. GotIt ) dtmin = 0.0 5908 5909 TfinIs = .FALSE. 5910 IF( GetLogical(Params,'Simulation Timestep Sizes',GotIt) ) THEN 5911 tfin = GetTimeStepsize() 5912 TfinIs = .TRUE. 5913 ELSE 5914 tfin = GetCReal(Params,'Max Cumulative Time',TfinIs) 5915 END IF 5916 5917 IF( .NOT. Particles % DtConstant ) THEN 5918 DtVar => ParticleVariableGet( Particles,'particle dt') 5919 IF( .NOT. ASSOCIATED( DtVar ) ) THEN 5920 CALL ParticleVariableCreate( Particles,'particle dt') 5921 DtVar => ParticleVariableGet( Particles,'particle dt') 5922 END IF 5923 5924 TimeVar => ParticleVariableGet( Particles,'particle time') 5925 IF( .NOT. ASSOCIATED( TimeVar ) ) THEN 5926 CALL Fatal('GetParticleTimestep','Variable > Particle time < does not exist!') 5927 END IF 5928 END IF 5929 5930 tprev = 0.0_dp 5931 END IF 5932 5933 5934 ! Get upper and lower constraints for timestep size 5935 ! These generally depend on the velocity field and mesh 5936 !-------------------------------------------------------------------- 5937 IF( Particles % DtConstant ) THEN 5938 IF( DtIs ) THEN 5939 dt = dt0 5940 ELSE IF( DsGoalIs ) THEN 5941 CharSpeed = CharacteristicSpeed( Particles ) 5942 dt = dsgoal / CharSpeed 5943 ELSE IF( HgoalIs ) THEN 5944 CharTime = CharacteristicElementTime( Particles ) 5945 dt = Hgoal * CharTime ! ElementH / Speed 5946 !PRINT *,'ratio of timesteps:',tfin/dt 5947 ELSE IF( tfinIs ) THEN 5948 dt = tfin / Nstep 5949 ELSE IF( HgoalIsUniso ) THEN 5950 CALL Fatal('GetParticleTimesStep','Cannot use unisotropic courant number with constant dt!') 5951 ELSE 5952 CALL Fatal('GetParticleTimeStep','Cannot determine timestep size!') 5953 END IF 5954 5955 ! Constrain the timestep 5956 !------------------------------------------------------------------ 5957! dt = MAX( MIN( dt, dtmax ), dtmin ) 5958 5959 ! Do not exceed the total integration time 5960 !------------------------------------------- 5961 IF( PRESENT( tinit ) ) tprev = tinit 5962 IF( TfinIs .AND. dt + tprev > tfin ) THEN 5963 dt = tfin - tprev 5964 END IF 5965 tprev = tprev + dt 5966 Particles % dtime = dt 5967 dtout = dt 5968 ELSE 5969 DtVar % Values = 0.0_dp 5970 dtave = 0.0_dp 5971 5972 DO No = 1, Particles % NumberOfParticles 5973 5974 Status = Particles % Status( No ) 5975 IF ( Status >= PARTICLE_LOST ) CYCLE 5976 IF ( Status <= PARTICLE_INITIATED ) CYCLE 5977 IF ( Status == PARTICLE_WALLBOUNDARY ) CYCLE 5978 IF ( Status == PARTICLE_FIXEDCOORD ) CYCLE 5979 5980 tprev = TimeVar % Values(No) 5981 5982 IF( DtIs ) THEN 5983 dt = dt0 5984 ELSE IF( DsGoalIs ) THEN 5985 CharSpeed = CharacteristicSpeed( Particles, No ) 5986 dt = dsgoal / CharSpeed 5987 ELSE IF( HgoalIs ) THEN 5988 CharTime = CharacteristicElementTime( Particles, No ) 5989 dt = Hgoal * CharTime ! ElementH / Speed 5990 ELSE IF( tfinIs ) THEN 5991 dt = tfin / Nstep 5992 ELSE IF( HgoalIsUniso ) THEN 5993 CharTime = CharacteristicUnisoTime( Particles, No ) 5994 dt = Hgoal * CharTime ! ElementH / Speed 5995 ELSE 5996 CALL Fatal('GetParticlesTimeStep','Cannot determine timestep size!') 5997 END IF 5998 5999 ! Constrain the timestep 6000 !------------------------------------------------------------------ 6001 dt = MAX( MIN( dt, dtmax ), dtmin ) 6002 6003 ! Do not exceed the total integration time 6004 !------------------------------------------- 6005 IF( PRESENT( tinit ) ) tprev = tinit 6006 6007 IF( TfinIs .AND. dt + tprev > tfin ) THEN 6008 dt = tfin - tprev 6009 END IF 6010 DtVar % Values(No) = dt 6011 6012 dtout = MAX( dtout, dt ) 6013 dtave = dtave + dt 6014 END DO 6015 6016 dtave = dtave / Particles % NumberOfParticles 6017 6018 WRITE(Message,'(A,ES12.3)') 'Average particle timestep:',dtave 6019 CALL Info('GetParticleTimestep', Message,Level=12) 6020 END IF 6021 6022 dtout = ParallelReduction( dtout, 2 ) 6023 6024 WRITE(Message,'(A,ES12.3)') 'Maximum particle timestep:',dtout 6025 CALL Info('GetParticleTimestep', Message,Level=12) 6026 6027 6028 IF( Particles % Rk2 ) THEN 6029 IF( Particles % DtConstant ) THEN 6030 Particles % Dtime = 0.5_dp * Particles % Dtime 6031 ELSE 6032 DtVar % Values = 0.5_dp * DtVar % Values 6033 END IF 6034 END IF 6035 6036 END FUNCTION GetParticleTimeStep 6037 6038 6039 6040!------------------------------------------------------------------------------ 6041!> Creates a variable related to the particles. The normal variabletype without 6042!> the permutation vector is used. 6043!------------------------------------------------------------------------------ 6044 SUBROUTINE ParticleVariableCreate( Particles, Name, DOFs, Output, & 6045 Secondary, TYPE ) 6046!------------------------------------------------------------------------------ 6047 TYPE(Particle_t), POINTER :: Particles 6048 CHARACTER(LEN=*) :: Name 6049 INTEGER, OPTIONAL :: DOFs 6050 INTEGER, OPTIONAL :: TYPE 6051 LOGICAL, OPTIONAL :: Output 6052 LOGICAL, OPTIONAL :: Secondary 6053!------------------------------------------------------------------------------ 6054 TYPE(Variable_t), POINTER :: Variables, Var 6055 REAL(KIND=dp), POINTER :: Values(:) 6056 INTEGER :: Dofs2 6057 LOGICAL :: stat 6058 INTEGER :: NoParticles 6059 TYPE(Mesh_t),POINTER :: Mesh 6060 TYPE(Solver_t),POINTER :: Solver 6061!------------------------------------------------------------------------------ 6062 6063 ! If already created don't do it again 6064 Var => VariableGet( Particles % Variables, Name ) 6065 IF(ASSOCIATED(Var)) RETURN 6066 6067 CALL Info('ParticleVariableCreate','Creating variable: '//TRIM(Name)) 6068 6069 NoParticles = Particles % MaxNumberOfParticles 6070 IF( NoParticles == 0 ) THEN 6071 CALL Warn('ParticleVariableCreate','No particles present!') 6072 END IF 6073 6074 IF( PRESENT( Dofs ) ) THEN 6075 Dofs2 = Dofs 6076 ELSE 6077 Dofs2 = 1 6078 END IF 6079 6080 NULLIFY( Values ) 6081 ALLOCATE( Values( NoParticles * Dofs2 ) ) 6082 Values = 0.0_dp 6083 6084 Solver => CurrentModel % Solver 6085 Mesh => CurrentModel % Solver % Mesh 6086 6087 CALL VariableAdd( Particles % Variables,Mesh,Solver,Name,DOFs2,Values,& 6088 Output=Output, Secondary=Secondary, TYPE=TYPE ) 6089 6090!------------------------------------------------------------------------------ 6091 END SUBROUTINE ParticleVariableCreate 6092!------------------------------------------------------------------------------ 6093 6094 6095!------------------------------------------------------------------------------ 6096!> Given a variable name, get a handle to it. 6097!------------------------------------------------------------------------------ 6098 FUNCTION ParticleVariableGet( Particles, Name ) RESULT ( Var ) 6099 6100 TYPE(Particle_t), POINTER :: Particles 6101 CHARACTER(LEN=*) :: Name 6102 TYPE(Variable_t), POINTER :: Var 6103!------------------------------------------------------------------------------ 6104 Var => VariableGet( Particles % Variables, Name ) 6105 6106 END FUNCTION ParticleVariableGet 6107!------------------------------------------------------------------------------ 6108 6109 6110!------------------------------------------------------------------------------ 6111!> Given a variable name, get a handle to its values. 6112!------------------------------------------------------------------------------ 6113 FUNCTION ParticleVariableValues( Particles, Name ) RESULT ( Values ) 6114 6115 TYPE(Particle_t), POINTER :: Particles 6116 CHARACTER(LEN=*) :: Name 6117 REAL(KIND=dp), POINTER :: Values(:) 6118!------------------------------------------------------------------------------ 6119 TYPE(Variable_t), POINTER :: Var 6120 Var => VariableGet( Particles % Variables, Name ) 6121 Values => Var % Values 6122 6123 END FUNCTION ParticleVariableValues 6124!------------------------------------------------------------------------------ 6125 6126 6127!------------------------------------------------------------------------------ 6128!> Resize the existing variables and optionally repack the old variables 6129!> so that they lost ones are eliminated. This is controlled by the Perm 6130!> vector that includes only the indexes of the particles to be saved. 6131!------------------------------------------------------------------------------ 6132 SUBROUTINE ParticleVariablesResize( Particles, Prevsize, Newsize, Perm) 6133!------------------------------------------------------------------------------ 6134 TYPE(Particle_t), POINTER :: Particles 6135 INTEGER :: Newsize, Prevsize 6136 INTEGER, OPTIONAL :: Perm(:) 6137!------------------------------------------------------------------------------ 6138 TYPE(Variable_t), POINTER :: Var 6139 REAL(KIND=dp), POINTER :: Values(:) 6140 INTEGER :: i,j,k,OldSize 6141!------------------------------------------------------------------------------ 6142 6143 oldsize = prevsize 6144 IF( PRESENT( Perm ) ) THEN 6145 oldsize = SIZE(Perm) 6146 DO i=1,SIZE(Perm) 6147 IF( Perm(i) == 0 ) THEN 6148 oldsize = i-1 6149 EXIT 6150 END IF 6151 END DO 6152 IF( oldsize < 1 ) oldsize = 1 6153 CALL Info('ParticleVariablesResize','Using compact size of: '//TRIM(I2S(oldsize)),Level=12) 6154 END IF 6155 6156 Var => Particles % Variables 6157 DO WHILE( ASSOCIATED(Var) ) 6158 k = Var % NameLen 6159 IF( k > 0 ) THEN 6160 IF( Var % Dofs > 1 ) THEN 6161 CALL Fatal('ParticleVariableResize','Implement size increase for vectors!') 6162 END IF 6163 Values => Var % Values 6164 IF( SIZE( Var % Values ) < newsize ) THEN 6165 CALL Info('ParticleVariableResize','Increasing size of variable: '// & 6166 Var % name(1:k),Level=12) 6167 ALLOCATE( Var % Values(newsize) ) 6168 IF( PRESENT( Perm ) ) THEN 6169 Var % Values(1:oldsize) = Values(Perm(1:oldsize)) 6170 ELSE 6171 OldSize = SIZE( Values ) 6172 Var % Values(1:oldsize) = Values(1:oldsize) 6173 END IF 6174 Var % Values(oldsize+1:newsize) = 0.0_dp 6175 DEALLOCATE( Values ) 6176 ELSE IF( PRESENT( Perm ) ) THEN 6177 CALL Info('ParticleVariableResize','Reorder dofs in variable: '// & 6178 Var % name(1:k),Level=15) 6179 Var % Values(1:oldsize) = Values(Perm(1:oldsize)) 6180 Var % Values(oldsize+1:newsize) = 0.0_dp 6181 END IF 6182 END IF 6183 Var => Var % Next 6184 END DO 6185 6186!------------------------------------------------------------------------------ 6187 END SUBROUTINE ParticleVariablesResize 6188!------------------------------------------------------------------------------ 6189 6190 6191 6192 !------------------------------------------------------------------------ 6193 !> Write particles to an external file in simple ascii format matrix. 6194 !------------------------------------------------------------------------- 6195 SUBROUTINE ParticleOutputTable( Particles ) 6196 6197 TYPE(Particle_t), POINTER :: Particles 6198 6199 TYPE(Variable_t), POINTER :: TimeVar 6200 TYPE(ValueList_t), POINTER :: Params 6201 CHARACTER(LEN=MAX_NAME_LEN) :: FilePrefix, FileName 6202 LOGICAL :: Found, NumberFilesByParticles, NumberFilesBySteps, ParticleMode 6203 REAL(KIND=dp), POINTER :: Coord(:,:), Velo(:,:), Dist(:) 6204 REAL(KIND=dp) :: time 6205 TYPE(Mesh_t), POINTER :: Mesh 6206 INTEGER, POINTER :: Status(:) 6207 INTEGER :: i,j,n,dofs,Vari,Rank,dim, NoParticles, MinSaveStatus, MaxSaveStatus 6208 INTEGER :: VisitedTimes = 0 6209 INTEGER, POINTER :: Indexes(:),Perm(:) 6210 LOGICAL :: GotTimeVar, GotDistVar 6211 TYPE(Variable_t), POINTER :: PartTimeVar, PartDistVar 6212 REAL(KIND=dp), POINTER :: Basis(:) 6213 TYPE(Nodes_t) :: Nodes 6214 INTEGER, PARAMETER :: TableUnit = 10 6215 6216 6217 SAVE :: VisitedTimes, Params, FilePrefix, NumberFilesByParticles, NumberFilesBySteps, & 6218 MinSaveStatus, MaxSaveStatus, TimeVar, Basis, Nodes 6219 6220 CALL Info('ParticleOutputTable','Saving particle data into simple ascii table',Level=8) 6221 6222 VisitedTimes = VisitedTimes + 1 6223 6224 Mesh => GetMesh() 6225 dim = Particles % dim 6226 6227 Coord => Particles % Coordinate 6228 Velo => Particles % Velocity 6229 Status => Particles % Status 6230 6231 PartDistVar => ParticleVariableGet( Particles,'particle distance') 6232 GotDistVar = ASSOCIATED( PartDistVar ) 6233 6234 PartTimeVar => ParticleVariableGet( Particles,'particle time') 6235 GotTimeVar = ASSOCIATED( PartTimeVar ) 6236 6237 ParticleMode = .NOT. ASSOCIATED( Particles % UVW ) 6238 IF(.NOT. ParticleMode ) THEN 6239 n = Mesh % MaxElementNodes 6240 ALLOCATE( Basis(n), Nodes % x(n), Nodes % y(n), Nodes % z(n) ) 6241 END IF 6242 6243 6244 IF( VisitedTimes == 1 ) THEN 6245 Params => ListGetSolverParams() 6246 FilePrefix = ListGetString(Params,'Filename Prefix') 6247 CALL WriteParticleFileNames(FilePrefix, dim) 6248 6249 NumberFilesByParticles = ListGetLogical( Params,'Filename Particle Numbering',Found) 6250 NumberFilesBySteps = ListGetLogical( Params,'Filename Timestep Numbering',Found) 6251 IF( NumberFilesByParticles .AND. NumberFilesBySteps ) THEN 6252 CALL Fatal('ParticleOutputTable','Files may be numbered either by steps or particles') 6253 END IF 6254 6255 MinSaveStatus = ListGetInteger( Params,'Min Status for Saving',Found) 6256 IF(.NOT. Found ) MinSaveStatus = PARTICLE_INITIATED 6257 6258 MaxSaveStatus = ListGetInteger( Params,'Max Status for Saving',Found) 6259 IF(.NOT. Found ) MaxSaveStatus = PARTICLE_LOST-1 6260 6261 TimeVar => VariableGet( Mesh % Variables,'time') 6262 6263 IF( ParEnv % PEs > 1 ) THEN 6264 WRITE( FilePrefix,'(A,A,I4.4)' ) TRIM(FilePrefix),'par',ParEnv % MyPe + 1 6265 END IF 6266 END IF 6267 6268 time = TimeVar % Values(1) 6269 NoParticles = Particles % NumberOfParticles 6270 6271 CALL Info('ParticleOutputTable','Saving at maximum '//TRIM(I2S(NoParticles))//' particles',Level=6) 6272 6273 IF( NumberFilesByParticles ) THEN 6274 DO i = 1, NoParticles 6275 CALL OpenParticleFile(FilePrefix, i) 6276 IF ( Particles % Status(i) > MaxSaveStatus .OR. & 6277 Particles % Status(i) < MinSaveStatus ) CYCLE 6278 CALL WriteParticleLine( dim, i ) 6279 CALL CloseParticleFile() 6280 END DO 6281 ELSE 6282 IF( NumberFilesBySteps ) THEN 6283 CALL OpenParticleFile(FilePrefix, VisitedTimes ) 6284 ELSE 6285 CALL OpenParticleFile(FilePrefix, 0 ) 6286 END IF 6287 DO i = 1, NoParticles 6288 IF ( Particles % Status(i) > MaxSaveStatus .OR. & 6289 Particles % Status(i) < MinSaveStatus ) CYCLE 6290 CALL WriteParticleLine( dim, i ) 6291 END DO 6292 CALL CloseParticleFile() 6293 END IF 6294 6295 IF( .NOT. ParticleMode ) THEN 6296 DEALLOCATE( Basis, Nodes % x, Nodes % y, Nodes % z ) 6297 END IF 6298 6299 6300 CONTAINS 6301 6302 !------------------------------------------------------------------------ 6303 !> Write the names file for user information. Remember to update this if 6304 !> SaveParticleStep is modified. 6305 !------------------------------------------------------------------------- 6306 SUBROUTINE WriteParticleFileNames( Prefix, Dim ) 6307 6308 CHARACTER(LEN=MAX_NAME_LEN) :: Prefix 6309 INTEGER :: dim 6310 6311 CHARACTER(LEN=MAX_NAME_LEN) :: FileName 6312 INTEGER :: i,j,dofs 6313 TYPE(Variable_t), POINTER :: Solution 6314 LOGICAL :: ComponentVector, ThisOnly = .TRUE. 6315 CHARACTER(LEN=1024) :: Txt, FieldName 6316 6317 6318 WRITE( FileName,'(A,A)') TRIM(FilePrefix),'.dat.names' 6319 6320 OPEN (TableUnit, FILE=FileName ) 6321 6322 WRITE( TableUnit, '(A)' ) 'Variables in file: '//TRIM(FilePrefix)//'*.dat' 6323 WRITE( TableUnit, '(A,I2)' ) 'Dimension of particle set is',dim 6324 i = 1 6325 WRITE( TableUnit, '(I2,A)' ) i,': time' 6326 6327 IF( NumberFilesBySteps ) THEN 6328 WRITE( TableUnit,'(I2, A)' ) i+1, ': particle id' 6329 i = i + 1 6330 ELSE IF( NumberFilesByParticles ) THEN 6331 WRITE( TableUnit,'(I2, A)' ) i+1, ': visited time' 6332 i = i + 1 6333 ELSE 6334 WRITE( TableUnit,'(I2, A)' ) i+1, ': visited time' 6335 WRITE( TableUnit,'(I2, A)' ) i+2, ': particle id' 6336 i = i + 2 6337 END IF 6338 6339 WRITE( TableUnit, '(I2,A)' ) i+1,': Coordinate_1' 6340 WRITE( TableUnit, '(I2,A)' ) i+2,': Coordinate_2' 6341 IF(dim == 3) WRITE( TableUnit, '(I2,A)' ) i+3,': Coordinate_3' 6342 i = i + DIM 6343 6344 IF( ParticleMode ) THEN 6345 WRITE( TableUnit, '(I2,A)' ) i+1,': Velocity_1' 6346 WRITE( TableUnit, '(I2,A)' ) i+2,': Velocity_2' 6347 IF(dim == 3) WRITE( TableUnit, '(I2,A)' ) i+3,': Velocity_3' 6348 i = i + DIM 6349 IF( GotDistVar ) THEN 6350 WRITE( TableUnit, '(I2,A)' ) i+1,': Particle Distance' 6351 i = i + 1 6352 END IF 6353 IF( GotTimeVar ) THEN 6354 WRITE( TableUnit, '(I2,A)' ) i+1,': Particle Time' 6355 i = i + 1 6356 END IF 6357 ELSE 6358 6359 DO Rank = 1,2 6360 6361 DO Vari = 1, 99 6362 6363 IF( Rank == 1 ) THEN 6364 WRITE(Txt,'(A,I0)') 'Scalar Field ',Vari 6365 ELSE 6366 WRITE(Txt,'(A,I0)') 'Vector Field ',Vari 6367 END IF 6368 6369 FieldName = ListGetString( Params, TRIM(Txt), Found ) 6370 IF(.NOT. Found) EXIT 6371 6372 Solution => VariableGet( Mesh % Variables, & 6373 TRIM(FieldName),ThisOnly ) 6374 ComponentVector = .FALSE. 6375 IF( Rank == 2 ) THEN 6376 IF(.NOT. ASSOCIATED(Solution)) THEN 6377 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 1', ThisOnly ) 6378 IF( ASSOCIATED(Solution)) THEN 6379 ComponentVector = .TRUE. 6380 ELSE 6381 WRITE(Txt, '(A,A)') 'Nonexistent variable: ',TRIM(FieldName) 6382 CALL Warn('WriteParticleLine', Txt) 6383 CYCLE 6384 END IF 6385 END IF 6386 ELSE 6387 IF(.NOT. ASSOCIATED(Solution)) THEN 6388 WRITE(Txt, '(A,A)') 'Nonexistent variable: ',TRIM(FieldName) 6389 CALL Warn('WriteParticleLine', Txt) 6390 CYCLE 6391 END IF 6392 END IF 6393 6394 IF( ASSOCIATED(Solution % EigenVectors)) THEN 6395 CALL Warn('WriteParticleLine','Do the eigen values') 6396 END IF 6397 6398 dofs = Solution % DOFs 6399 6400 IF( ComponentVector ) THEN 6401 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 2',ThisOnly ) 6402 IF( ASSOCIATED(Solution)) THEN 6403 dofs = 2 6404 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 3',ThisOnly ) 6405 IF( ASSOCIATED(Solution)) THEN 6406 dofs = 3 6407 END IF 6408 END IF 6409 END IF 6410 6411 IF( dofs == 1 ) THEN 6412 WRITE( TableUnit, '(I2,A)' ) i+1,': '//TRIM(FieldName) 6413 i = i + 1 6414 ELSE 6415 DO j=1,dofs 6416 WRITE( TableUnit, '(I2,A)' ) i+j,': '//TRIM(FieldName)//'_'//TRIM(I2S(j)) 6417 END DO 6418 i = i + dofs 6419 END IF 6420 6421 END DO 6422 END DO 6423 END IF 6424 6425 CLOSE( TableUnit ) 6426 6427 END SUBROUTINE WriteParticleFileNames 6428 6429 6430 6431 !------------------------------------------------------------------------ 6432 !> Open a numbered file for each particle. These must be separate since the 6433 !> number of steps for each particle may vary greatly 6434 !------------------------------------------------------------------------- 6435 SUBROUTINE OpenParticleFile( Prefix, FileNo ) 6436 6437 CHARACTER(LEN=MAX_NAME_LEN) :: Prefix 6438 INTEGER :: FileNo 6439 LOGICAL, SAVE :: Visited = .FALSE. 6440 6441 6442 CHARACTER(LEN=MAX_NAME_LEN) :: FileName 6443 6444 IF( FileNo == 0 ) THEN 6445 WRITE( FileName,'(A,A)') TRIM(FilePrefix),'.dat' 6446 IF( .NOT. Visited ) THEN 6447 CALL Info( 'ParticleOutputTable', 'Saving particle data to file: '//TRIM(FileName), Level=4 ) 6448 END IF 6449 ELSE 6450 IF ( FileNo==1 .AND. .NOT. Visited ) THEN 6451 WRITE( Message, * ) 'Saving particle data to files: ', TRIM(FilePrefix)//'_*.dat' 6452 CALL Info( 'ParticleOutputTable', Message, Level=4 ) 6453 END IF 6454 FileName=TRIM(FilePrefix)//'_'//TRIM(i2s(fileno))//'.dat' 6455 END IF 6456 6457 IF( VisitedTimes == 1 .OR. NumberFilesBySteps ) THEN 6458 OPEN (TableUnit, FILE=FileName ) 6459 WRITE( TableUnit, '(A)', ADVANCE='no' ) ' ' ! delete old contents 6460 ELSE 6461 OPEN (TableUnit, FILE=FileName,POSITION='APPEND' ) 6462 END IF 6463 6464 Visited = .TRUE. 6465 6466 END SUBROUTINE OpenParticleFile 6467 6468 6469 !------------------------------------------------------------------------ 6470 !> Save one line in the particle file 6471 !------------------------------------------------------------------------- 6472 SUBROUTINE WriteParticleLine( Dim, No ) 6473 INTEGER :: Dim, No 6474 TYPE(Variable_t), POINTER :: Solution 6475 REAL(KIND=dp), POINTER :: Values(:) 6476 REAL(KIND=dp) :: u,v,w,val,detJ,r(3) 6477 LOGICAL :: stat, ThisOnly=.TRUE., ComponentVector 6478 CHARACTER(LEN=1024) :: Txt, FieldName 6479 TYPE(Element_t), POINTER :: Element 6480 6481 INTEGER, ALLOCATABLE :: ElemInd(:) 6482 6483 WRITE( TableUnit,'(ES12.4)', ADVANCE = 'NO' ) time 6484 6485 IF( NumberFilesBySteps ) THEN 6486 WRITE( TableUnit,'(I9)', ADVANCE = 'NO' ) No 6487 ELSE IF( NumberFilesByParticles ) THEN 6488 WRITE( TableUnit,'(I9)', ADVANCE = 'NO' ) VisitedTimes 6489 ELSE 6490 WRITE( TableUnit,'(2I9)', ADVANCE = 'NO' ) VisitedTimes, No 6491 END IF 6492 6493 IF( ParticleMode ) THEN 6494 6495 IF( dim == 3 ) THEN 6496 WRITE(TableUnit,'(6ES16.7E3)',ADVANCE='NO') Coord(No,1:3), Velo(No,1:3) 6497 ELSE 6498 WRITE(TableUnit,'(4ES16.7E3)',ADVANCE='NO') Coord(No,1:2), Velo(No,1:2) 6499 END IF 6500 6501 IF( GotDistVar ) WRITE (TableUnit,'(ES12.4)',ADVANCE='NO') PartDistVar % Values(No) 6502 IF( GotTimeVar ) WRITE (TableUnit,'(ES12.4)',ADVANCE='NO') PartTimeVar % Values(No) 6503 6504 ELSE 6505 6506 Element => Mesh % Elements( Particles % ElementIndex(No) ) 6507 n = Element % TYPE % NumberOfNodes 6508 Indexes => Element % NodeIndexes 6509 6510 Nodes % x(1:n) = Mesh % Nodes % x( Indexes ) 6511 Nodes % y(1:n) = Mesh % Nodes % y( Indexes ) 6512 Nodes % z(1:n) = Mesh % Nodes % z( Indexes ) 6513 6514 ALLOCATE(ElemInd(Mesh % MaxElementDOFs)) 6515 6516 u = Particles % uvw(No,1) 6517 v = Particles % uvw(No,2) 6518 IF( dim == 3 ) THEN 6519 w = Particles % uvw(No,3) 6520 ELSE 6521 w = 0.0_dp 6522 END IF 6523 6524 stat = ElementInfo( Element,Nodes,u,v,w,detJ,Basis) 6525 6526 r(1) = SUM( Basis(1:n) * Nodes % x(1:n) ) 6527 r(2) = SUM( Basis(1:n) * Nodes % y(1:n) ) 6528 r(3) = SUM( Basis(1:n) * Nodes % z(1:n) ) 6529 6530 WRITE( TableUnit,'(2ES16.7E3)', ADVANCE='no') r(1:2) 6531 IF( dim == 3 ) THEN 6532 WRITE( TableUnit,'(ES16.7E3)', ADVANCE='no') r(3) 6533 END IF 6534 6535 6536 DO Rank = 1,2 6537 6538 DO Vari = 1, 99 6539 6540 IF( Rank == 1 ) THEN 6541 WRITE(Txt,'(A,I0)') 'Scalar Field ',Vari 6542 ELSE 6543 WRITE(Txt,'(A,I0)') 'Vector Field ',Vari 6544 END IF 6545 6546 FieldName = ListGetString( Params, TRIM(Txt), Found ) 6547 IF(.NOT. Found) EXIT 6548 6549 Solution => VariableGet( Mesh % Variables, & 6550 TRIM(FieldName),ThisOnly ) 6551 ComponentVector = .FALSE. 6552 IF( Rank == 2 ) THEN 6553 IF(.NOT. ASSOCIATED(Solution)) THEN 6554 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 1', ThisOnly ) 6555 IF( ASSOCIATED(Solution)) THEN 6556 ComponentVector = .TRUE. 6557 ELSE 6558 WRITE(Txt, '(A,A)') 'Nonexistent variable: ',TRIM(FieldName) 6559 CALL Warn('WriteParticleLine', Txt) 6560 CYCLE 6561 END IF 6562 END IF 6563 ELSE 6564 IF(.NOT. ASSOCIATED(Solution)) THEN 6565 WRITE(Txt, '(A,A)') 'Nonexistent variable: ',TRIM(FieldName) 6566 CALL Warn('WriteParticleLine', Txt) 6567 CYCLE 6568 END IF 6569 END IF 6570 6571 IF( ASSOCIATED(Solution % EigenVectors)) THEN 6572 CALL Warn('WriteParticleLine','Do the eigen values') 6573 END IF 6574 6575 Perm => Solution % Perm 6576 dofs = Solution % DOFs 6577 Values => Solution % Values 6578 val = 0.0_dp 6579 6580 IF( Solution % TYPE == Variable_on_nodes_on_elements ) THEN 6581 ElemInd(1:n) = Perm(Element % DGIndexes(1:n)) 6582 ELSE 6583 ElemInd(1:n) = Perm(Indexes(1:n)) 6584 END IF 6585 6586 IF( ComponentVector ) THEN 6587 IF( ALL(ElemInd(1:n) > 0 ) ) THEN 6588 val = SUM( Basis(1:n) * Values(ElemInd(1:n)) ) 6589 END IF 6590 WRITE( TableUnit,'(ES16.7E3)', ADVANCE='no') val 6591 6592 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 2',ThisOnly ) 6593 IF( ASSOCIATED(Solution)) THEN 6594 Values => Solution % Values 6595 IF( ALL( ElemInd(1:n) > 0 ) ) THEN 6596 val = SUM( Basis(1:n) * Values(ElemInd(1:n)) ) 6597 END IF 6598 WRITE( TableUnit,'(ES16.7E3)', ADVANCE='no') val 6599 6600 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 3',ThisOnly ) 6601 IF( ASSOCIATED(Solution)) THEN 6602 Values => Solution % Values 6603 IF( ALL( ElemInd(1:n) > 0 ) ) THEN 6604 val = SUM( Basis(1:n) * Values(ElemInd(1:n)) ) 6605 END IF 6606 WRITE( TableUnit,'(ES16.7E3)', ADVANCE='no') val 6607 END IF 6608 END IF 6609 ELSE IF( Dofs == 1 ) THEN 6610 IF( ALL( ElemInd(1:n) > 0 ) ) THEN 6611 val = SUM( Basis(1:n) * Values(ElemInd(1:n)) ) 6612 END IF 6613 WRITE( TableUnit,'(ES16.7E3)', ADVANCE='no') val 6614 ELSE 6615 DO j = 1, Dofs 6616 IF( ALL( ElemInd(1:n) > 0 ) ) THEN 6617 val = SUM( Basis(1:n) * Values(Dofs*(ElemInd(1:n)-1)+j) ) 6618 END IF 6619 WRITE( TableUnit,'(ES16.7E3)', ADVANCE='no') val 6620 END DO 6621 END IF 6622 END DO 6623 END DO 6624 WRITE(TableUnit,'(A)') ' ' 6625 END IF 6626 6627 END SUBROUTINE WriteParticleLine 6628 6629 6630 !------------------------------------------------------------------------ 6631 ! Close the particle file 6632 !------------------------------------------------------------------------- 6633 SUBROUTINE CloseParticleFile( ) 6634 6635 CLOSE( TableUnit ) 6636 6637 END SUBROUTINE CloseParticleFile 6638 6639 END SUBROUTINE ParticleOutputTable 6640 6641 6642 6643 !------------------------------------------------------------------------ 6644 !> Write particles to an external file in Gmsh format as vector points. 6645 ! Subroutine contributed by Emilie Marchandise. 6646 !------------------------------------------------------------------------- 6647 SUBROUTINE ParticleOutputGmsh( Particles ) 6648 6649 TYPE(Particle_t), POINTER :: Particles 6650 6651 TYPE(Variable_t), POINTER :: TimeVar 6652 TYPE(ValueList_t), POINTER :: Params 6653 CHARACTER(LEN=MAX_NAME_LEN) :: FilePrefix, FileNameGmsh, FileNameOut 6654 LOGICAL :: Found 6655 REAL(KIND=dp), POINTER :: Coord(:,:), Velo(:,:), Dist(:) 6656 REAL(KIND=dp), POINTER :: CoordInit(:,:) 6657 REAL(KIND=dp) :: time 6658 TYPE(Mesh_t), POINTER :: Mesh 6659 INTEGER, POINTER :: Status(:) 6660 INTEGER :: i,j,k, dim, NoParticles, nStep 6661 INTEGER :: VisitedTimes = 0 6662 INTEGER, POINTER :: TimeSteps(:) 6663 LOGICAL :: GotTimeVar, GotDistVar 6664 TYPE(Variable_t), POINTER :: PartTimeVar, PartDistVar 6665 6666 SAVE :: VisitedTimes, Params, FilePrefix, TimeVar, FileNameGmsh, CoordInit 6667 6668 Params => ListGetSolverParams() 6669 FilePrefix = ListGetString(Params,'Filename Prefix') 6670 6671 WRITE( FileNameGmsh,'(A,A)') TRIM(FilePrefix),'.pos' 6672 6673 Mesh => GetMesh() 6674 dim = Particles % dim 6675 6676 Coord => Particles % Coordinate 6677 Velo => Particles % Velocity 6678 Status => Particles % Status 6679 6680 NoParticles = Particles % NumberOfParticles 6681 6682 VisitedTimes = VisitedTimes + 1 6683 IF (VisitedTimes==1) THEN 6684 6685 OPEN (10, FILE=FileNameGmsh ) 6686 WRITE( 10, '(A)') 'View[0].VectorType=5; //for displacement type' 6687 WRITE( 10, '(A)') 'View[0].PointType=1; // for spheres' 6688 WRITE( 10, '(A)') 'View[0].PointSize=5; // for spheres' 6689 WRITE( 10, '(A)') 'View[0].IntervalsType = 1; //for iso-values interval' 6690 WRITE( 10, '(A)') 'View[0].NbIso = 1; //for one color' 6691 WRITE( 10, '(A)') 'View[0].ShowScale = 0; ' 6692 CLOSE( 10 ) 6693 6694 ALLOCATE( CoordInit(NoParticles,dim) ) 6695 CoordInit = Particles % Coordinate 6696 6697 TimeVar => VariableGet( Mesh % Variables,'time') 6698 END IF 6699 6700 time = TimeVar % Values(1) 6701 CALL Info( 'ParticleTracker', 'Saving particle paths to file: '//TRIM(FileNameGmsh), Level=4 ) 6702 6703 OPEN (10, FILE=FileNameGmsh, POSITION='APPEND' ) 6704 WRITE( 10, '(A)') 'View "particles" {' 6705 WRITE( 10, '(A)', ADVANCE='NO') 'TIME{' 6706 WRITE( 10, '(ES16.7E3)', ADVANCE='NO') time 6707 WRITE( 10, '(A)') '};' 6708 6709 DO i = 1, NoParticles 6710 WRITE( 10, '(A)', ADVANCE='NO') 'VP(' 6711 DO k=1,dim 6712 WRITE( 10, '(ES16.7E3)', ADVANCE='NO') CoordInit(i,k) 6713 IF(k < dim) WRITE( 10, '(A)', ADVANCE='NO') ',' 6714 END DO 6715 IF (dim ==2) WRITE( 10, '(A)', ADVANCE='NO') ', 0.0' 6716 WRITE( 10, '(A)', ADVANCE='NO') '){' 6717 DO k=1,dim 6718 WRITE( 10, '(ES16.7E3)', ADVANCE='NO') Coord(i,k)-CoordInit(i,k) 6719 IF(k < dim) WRITE( 10, '(A)', ADVANCE='NO') ',' 6720 END DO 6721 IF (dim ==2) WRITE( 10, '(A)', ADVANCE='NO') ', 0.0' 6722 WRITE( 10, '(A)') '};' 6723 END DO 6724 WRITE( 10, '(A)') '};' 6725 6726 6727 ! Save for last timestep, this is a conservative estimate assuming 6728 ! savig after each timestep. 6729 !----------------------------------------------------------------- 6730 Timesteps => ListGetIntegerArray( CurrentModel % Simulation, & 6731 'Timestep Intervals', Found ) 6732 nStep = SUM( TimeSteps ) 6733 6734 IF (VisitedTimes == nStep) THEN 6735 WRITE( FileNameOut,'(A,A)') TRIM(FilePrefix),'_combined.pos";' 6736 WRITE( 10, '(A)') 'Combine TimeStepsByViewName;' 6737 WRITE( 10, '(A)', ADVANCE='NO') 'Save View [0] "' 6738 WRITE( 10, '(A)') FileNameOut 6739 WRITE( 10, '(A)') 'Printf("View[0].VectorType=5;' 6740 WRITE( 10, '(A)') 'View[0].PointType=1; // for spheres' 6741 WRITE( 10, '(A)') 'View[0].PointSize=5; // for spheres' 6742 WRITE( 10, '(A)') 'View[0].IntervalsType = 1; //for iso-values interval' 6743 WRITE( 10, '(A)') 'View[0].NbIso = 1; //for one color' 6744 WRITE( 10, '(A)', ADVANCE='NO') 'View[0].ShowScale = 0; ") >> "' 6745 WRITE( 10, '(A)') FileNameOut 6746 END IF 6747 6748 CLOSE( 10 ) 6749 6750 6751 END SUBROUTINE ParticleOutputGmsh 6752 6753 6754!------------------------------------------------------------------------------ 6755!> Saves particles in unstructured XML VTK format (VTU) to an external file. 6756!------------------------------------------------------------------------------ 6757 SUBROUTINE ParticleOutputVtu( Particles ) 6758!------------------------------------------------------------------------------ 6759 6760 USE DefUtils 6761 USE MeshUtils 6762 USE ElementDescription 6763 USE AscBinOutputUtils 6764 6765 IMPLICIT NONE 6766 TYPE(Particle_t), POINTER :: Particles 6767 6768 TYPE(ValueList_t),POINTER :: Params 6769 INTEGER, SAVE :: nTime = 0 6770 LOGICAL :: GotIt, Parallel, FixedMeshend,SinglePrec 6771 6772 CHARACTER(MAX_NAME_LEN), SAVE :: FilePrefix 6773 CHARACTER(MAX_NAME_LEN) :: VtuFile, PvtuFile 6774 TYPE(Mesh_t), POINTER :: Mesh 6775 TYPE(Variable_t), POINTER :: Var 6776 INTEGER :: i, j, k, Partitions, Part, ExtCount, FileindexOffSet, & 6777 Status, MinSaveStatus, MaxSaveStatus, PrecBits, PrecSize, IntSize, & 6778 iTime 6779 CHARACTER(MAX_NAME_LEN) :: Dir 6780 REAL(KIND=dp) :: SaveNodeFraction, LocalVal(3) 6781 LOGICAL :: BinaryOutput,AsciiOutput,Found,Visited = .FALSE.,SaveFields 6782 REAL(KIND=dp) :: DoubleWrk 6783 REAL :: SingleWrk 6784 6785 CHARACTER(MAX_NAME_LEN) :: Str 6786 INTEGER :: NumberOfNodes, ParallelNodes, Dim 6787 6788 SAVE :: MinSaveStatus, MaxSaveStatus 6789 6790 Params => ListGetSolverParams() 6791 Mesh => GetMesh() 6792 6793 ExtCount = ListGetInteger( Params,'Output Count',GotIt) 6794 IF( GotIt ) THEN 6795 nTime = ExtCount 6796 ELSE 6797 nTime = nTime + 1 6798 END IF 6799 FileIndexOffset = ListGetInteger( Params,'Fileindex offset',GotIt) 6800 iTime = nTime + FileIndexOffset 6801 6802 IF ( nTime == 1 ) THEN 6803 FilePrefix = ListGetString( Params,'Filename Prefix') 6804 CALL Info('ParticleOutputVtu','Saving in VTK XML unstructured format to file: ' & 6805 //TRIM(FilePrefix)//'.vtu') 6806 6807 MinSaveStatus = ListGetInteger( Params,'Min Status for Saving',Found) 6808 IF(.NOT. Found ) MinSaveStatus = PARTICLE_INITIATED 6809 6810 MaxSaveStatus = ListGetInteger( Params,'Max Status for Saving',Found) 6811 IF(.NOT. Found ) MaxSaveStatus = PARTICLE_LOST-1 6812 END IF 6813 6814 BinaryOutput = GetLogical( Params,'Binary Output',GotIt) 6815 IF( GotIt ) THEN 6816 AsciiOutput = .NOT. BinaryOutput 6817 ELSE 6818 AsciiOutput = GetLogical( Params,'Ascii Output',GotIt) 6819 BinaryOutput = .NOT. AsciiOutput 6820 END IF 6821 6822 SaveFields = GetLogical( Params,'Save Fields',GotIt) 6823 IF(.NOT. GotIt) SaveFields = .TRUE. 6824 6825 SinglePrec = GetLogical( Params,'Single Precision',GotIt) 6826 IF( SinglePrec ) THEN 6827 CALL Info('VtuOutputSolver','Using single precision arithmetics in output!',Level=7) 6828 END IF 6829 6830 IF( SinglePrec ) THEN 6831 PrecBits = 32 6832 PrecSize = KIND( SingleWrk ) 6833 ELSE 6834 PrecBits = 64 6835 PrecSize = KIND( DoubleWrk ) 6836 END IF 6837 IntSize = KIND(i) 6838 6839 Partitions = ParEnv % PEs 6840 Part = ParEnv % MyPE 6841 Parallel = (Partitions > 1) .OR. GetLogical(Params,'Enforce Parallel format',GotIt) 6842 6843 Dim = Particles % dim 6844 6845 NumberOfNodes = 0 6846 DO i=1,Particles % NumberOfParticles 6847 IF ( Particles % Status(i) > MaxSaveStatus .OR. & 6848 Particles % Status(i) < MinSaveStatus ) CYCLE 6849 NumberOfNodes = NumberOfNodes + 1 6850 END DO 6851 6852 SaveNodeFraction = ListGetCReal( Params,'Particle Save Fraction',GotIt) 6853 IF(GotIt) THEN 6854 NumberOfNodes = NINT( SaveNodeFraction * NumberOfNodes ) 6855 ELSE 6856 i = ListGetInteger( Params,'Particle Save Number',GotIt) 6857 IF( GotIt ) THEN 6858 NumberOfNodes = MIN(i,NumberOfNodes) 6859 END IF 6860 END IF 6861 6862 6863 IF (LEN_TRIM(Mesh % Name) > 0 ) THEN 6864 Dir = TRIM(Mesh % Name) // "/" 6865 ELSE 6866 Dir = "./" 6867 END IF 6868 6869 IF(Parallel .AND. Part == 0) THEN 6870 IF( iTime < 10000 ) THEN 6871 WRITE( PvtuFile,'(A,A,I4.4,".pvtu")' ) TRIM(Dir),TRIM(FilePrefix),iTime 6872 ELSE 6873 WRITE( PvtuFile,'(A,A,I0,".pvtu")' ) TRIM(Dir),TRIM(FilePrefix),iTime 6874 END IF 6875 CALL WritePvtuFile( PvtuFile ) 6876 END IF 6877 6878 IF ( Parallel ) THEN 6879 IF( iTime < 10000 ) THEN 6880 WRITE( VtuFile,'(A,A,I4.4,A,I4.4,".vtu")' ) TRIM(Dir),TRIM(FilePrefix),Part+1,"par",& 6881 iTime 6882 ELSE 6883 WRITE( VtuFile,'(A,A,I4.4,A,I0,".vtu")' ) TRIM(Dir),TRIM(FilePrefix),Part+1,"par",& 6884 iTime 6885 END IF 6886 ELSE 6887 IF( iTime < 10000 ) THEN 6888 WRITE( VtuFile,'(A,A,I4.4,".vtu")' ) TRIM(Dir),TRIM(FilePrefix),iTime 6889 ELSE 6890 WRITE( VtuFile,'(A,A,I0,".vtu")' ) TRIM(Dir),TRIM(FilePrefix),iTime 6891 END IF 6892 END IF 6893 6894 CALL Info('ParticleOutputVtu','Saving particles to file: '//TRIM(VtuFile),Level=8) 6895 CALL WriteVtuFile( VtuFile ) 6896 6897 6898 CONTAINS 6899 6900 6901 SUBROUTINE WriteVtuFile( VtuFile ) 6902 CHARACTER(LEN=*), INTENT(IN) :: VtuFile 6903 INTEGER, PARAMETER :: VtuUnit = 58 6904 TYPE(Variable_t), POINTER :: Var, Solution 6905 CHARACTER(LEN=512) :: str 6906 INTEGER :: i,j,k,dofs,Rank,cumn,n,vari,sdofs,IsVector,Offset,PartDim 6907 CHARACTER(LEN=1024) :: Txt, ScalarFieldName, VectorFieldName, FieldName, & 6908 FieldName2, BaseString, OutStr 6909 CHARACTER :: lf 6910 LOGICAL :: ScalarsExist, VectorsExist, Found, ParticleMode, ComponentVector, & 6911 ComplementExists, ThisOnly, Stat 6912 LOGICAL :: WriteData, WriteXML, Buffered, IsDG 6913 INTEGER, POINTER :: Perm(:), Perm2(:), Indexes(:) 6914 INTEGER, ALLOCATABLE :: ElemInd(:),ElemInd2(:) 6915 REAL(KIND=dp), POINTER :: Values(:),Values2(:),& 6916 Values3(:),VecValues(:,:),Basis(:) 6917 REAL(KIND=dp) :: x,y,z,u,v,w,DetJ,val 6918 TYPE(Nodes_t) :: Nodes 6919 TYPE(Element_t), POINTER :: Element 6920 TYPE(Variable_t), POINTER :: ParticleVar 6921 6922 ! Initialize the auxiliary module for buffered writing 6923 !-------------------------------------------------------------- 6924 CALL AscBinWriteInit( AsciiOutput, SinglePrec, VtuUnit, NumberOfNodes ) 6925 6926 n = Mesh % MaxElementNodes 6927 ALLOCATE( Basis(n), Nodes % x(n), Nodes % y(n), Nodes % z(n) ) 6928 6929 n = Mesh % MaxElementDOFS 6930 ALLOCATE( ElemInd(n), ElemInd2(n) ) 6931 6932 ThisOnly = .TRUE. 6933 6934 ParticleMode = .NOT. ASSOCIATED( Particles % UVW ) 6935 6936 ! Linefeed character 6937 !----------------------------------- 6938 lf = CHAR(10) 6939 dim = 3 6940 6941 PartDim = Particles % Dim 6942 6943 WriteXML = .TRUE. 6944 WriteData = AsciiOutput 6945 Params => ListGetSolverParams() 6946 Buffered = .TRUE. 6947 6948 ! This is a hack to ensure that the streamed saving will cover the whole file 6949 !---------------------------------------------------------------------------- 6950 IF(.TRUE.) THEN 6951 OPEN( UNIT=VtuUnit, FILE=VtuFile, FORM = 'formatted', STATUS='unknown' ) 6952 WRITE( VtuUnit,'(A)') ' ' 6953 CLOSE( VtuUnit ) 6954 END IF 6955 6956 ! This format works both for ascii and binary output 6957 !------------------------------------------------------------------------- 6958 OPEN( UNIT=VtuUnit, FILE=VtuFile, FORM = 'unformatted', ACCESS = 'stream', STATUS='unknown' ) 6959 6960 WRITE( OutStr,'(A)') '<?xml version="1.0"?>'//lf 6961 CALL AscBinStrWrite( OutStr ) 6962 6963 IF ( LittleEndian() ) THEN 6964 OutStr = '<VTKFile type="UnstructuredGrid" version="0.1" byte_order="LittleEndian">'//lf 6965 ELSE 6966 OutStr = '<VTKFile type="UnstructuredGrid" version="0.1" byte_order="BigEndian">'//lf 6967 END IF 6968 CALL AscBinStrWrite( OutStr ) 6969 WRITE( OutStr,'(A)') ' <UnstructuredGrid>'//lf 6970 CALL AscBinStrWrite( OutStr ) 6971 WRITE( OutStr,'(A,I0,A,I0,A)') ' <Piece NumberOfPoints="',NumberOfNodes,& 6972 '" NumberOfCells="',NumberOfNodes,'">'//lf 6973 CALL AscBinStrWrite( OutStr ) 6974 6975 !--------------------------------------------------------------------- 6976 ! Header information for nodewise data 6977 !--------------------------------------------------------------------- 6978 ScalarFieldName = ListGetString( Params,'Scalar Field 1',ScalarsExist) 6979 VectorFieldName = ListGetString( Params,'Vector Field 1',VectorsExist) 6980 IF( .NOT. ( ScalarsExist .OR. VectorsExist) ) THEN 6981 CALL Warn('WriteVtuFile','Are there really no scalars or vectors?') 6982 END IF 6983 6984 WRITE( OutStr,'(A)') ' <PointData>'//lf 6985 CALL AscBinStrWrite( OutStr ) 6986 6987 !--------------------------------------------------------------------- 6988 ! do the scalars & vectors 6989 !--------------------------------- ----------------------------------- 6990100 Offset = 0 6991 6992 IF( SaveFields ) THEN 6993 6994 DO IsVector = 0, 1 6995 6996 DO Vari = 1, 999 6997 6998 IF( IsVector == 0 ) THEN 6999 BaseString = 'Scalar Field' 7000 ELSE 7001 BaseString = 'Vector Field' 7002 END IF 7003 7004 WRITE(Txt,'(A)') TRIM(BaseString)//' '//TRIM(I2S(Vari)) 7005 FieldName = ListGetString( Params, TRIM(Txt), Found ) 7006 IF(.NOT. Found) EXIT 7007 7008 !--------------------------------------------------------------------- 7009 ! Find the variable with the given name in the normal manner 7010 !--------------------------------------------------------------------- 7011 IF( .NOT. ParticleMode ) THEN 7012 Solution => VariableGet( Mesh % Variables,TRIM(FieldName),ThisOnly ) 7013 IF( ASSOCIATED( Solution ) ) THEN 7014 IF( IsVector == 1 .AND. Solution % Dofs <= 1 ) NULLIFY( Solution ) 7015 END IF 7016 7017 ComponentVector = .FALSE. 7018 IF( IsVector == 1 ) THEN 7019 IF(.NOT. ASSOCIATED(Solution)) THEN 7020 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 1', ThisOnly ) 7021 ComponentVector = ASSOCIATED( Solution ) 7022 END IF 7023 END IF 7024 IF( .NOT. ASSOCIATED( Solution ) ) THEN 7025 WRITE(Txt, '(A,A)') 'Nonexistent variable: ',TRIM(FieldName) 7026 CALL Warn('WriteVtuXMLFile', Txt) 7027 CYCLE 7028 END IF 7029 7030 IF( ASSOCIATED(Solution % EigenVectors)) THEN 7031 CALL Warn('WriteVtuXMLFile','Do the eigen values') 7032 END IF 7033 7034 Perm => Solution % Perm 7035 dofs = Solution % DOFs 7036 Values => Solution % Values 7037 7038 !--------------------------------------------------------------------- 7039 ! Some vectors are defined by a set of components (either 2 or 3) 7040 !--------------------------------------------------------------------- 7041 IF( ComponentVector ) THEN 7042 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 2',ThisOnly ) 7043 IF( ASSOCIATED(Solution)) THEN 7044 Values2 => Solution % Values 7045 dofs = 2 7046 END IF 7047 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 3',ThisOnly ) 7048 IF( ASSOCIATED(Solution)) THEN 7049 Values3 => Solution % Values 7050 dofs = 3 7051 END IF 7052 END IF 7053 7054 !--------------------------------------------------------------------- 7055 ! There may be special complementary variables such as 7056 ! displacement & mesh update 7057 !--------------------------------------------------------------------- 7058 ComplementExists = .FALSE. 7059 WRITE(Txt,'(A,I0,A)') TRIM(BaseString)//' ',Vari,' Complement' 7060 7061 FieldName2 = ListGetString( Params, TRIM(Txt), Found ) 7062 IF( Found ) THEN 7063 Solution => VariableGet( Mesh % Variables, & 7064 TRIM(FieldName2), ThisOnly ) 7065 IF( ASSOCIATED(Solution)) THEN 7066 Values2 => Solution % Values 7067 Perm2 => Solution % Perm 7068 ComplementExists = .TRUE. 7069 ELSE 7070 CALL Warn('WriteVTUFile','Complement does not exist:'//TRIM(FieldName2)) 7071 END IF 7072 END IF 7073 END IF 7074 7075 !--------------------------------------------------------------------- 7076 ! Get the values assuming particle mode 7077 !--------------------------------------------------------------------- 7078 IF( ParticleMode ) THEN 7079 IF( IsVector == 1) THEN 7080 dofs = PartDim 7081 IF( FieldName == 'velocity' ) THEN 7082 VecValues => Particles % Velocity 7083 ELSE IF( FieldName == 'force') THEN 7084 VecValues => Particles % Force 7085 ELSE 7086 WRITE(Txt, '(A,A)') 'Nonexistent variable: ',TRIM(FieldName) 7087 CALL Warn('WriteVtuXMLFile', Txt) 7088 CYCLE 7089 END IF 7090 ELSE 7091 dofs = 1 7092 IF( FieldName == 'particle distance') THEN 7093 ParticleVar => ParticleVariableGet( Particles,'particle distance' ) 7094 IF( .NOT. ASSOCIATED( ParticleVar ) ) THEN 7095 CALL Fatal('WriteVTUFile','> Particle Distance < does not exist!') 7096 END IF 7097 Values => ParticleVar % Values 7098 ELSE IF( FieldName == 'particle time') THEN 7099 ParticleVar => ParticleVariableGet( Particles,'particle time' ) 7100 IF( .NOT. ASSOCIATED( ParticleVar ) ) THEN 7101 CALL Fatal('WriteVTUFile','> Particle Time < does not exist!') 7102 END IF 7103 Values => ParticleVar % Values 7104 ELSE IF( FieldName == 'particle dt') THEN 7105 ParticleVar => ParticleVariableGet( Particles,'particle dt' ) 7106 IF( .NOT. ASSOCIATED( ParticleVar ) ) THEN 7107 CALL Fatal('WriteVTUFile','> Particle Dt < does not exist!') 7108 END IF 7109 Values => ParticleVar % Values 7110 ELSE 7111 WRITE(Txt, '(A,A)') 'Nonexistent variable: ',TRIM(FieldName) 7112 CALL Warn('WriteVtuXMLFile', Txt) 7113 CYCLE 7114 END IF 7115 END IF 7116 END IF 7117 7118 !--------------------------------------------------------------------- 7119 ! Finally save the field values for scalars 7120 !--------------------------------------------------------------------- 7121 IF( dofs == 1 ) THEN 7122 sdofs = 1 7123 ELSE 7124 sdofs = MAX(dofs,3) 7125 END IF 7126 7127 7128 IF( WriteXML ) THEN 7129 WRITE( OutStr,'(A,I0,A)') ' <DataArray type="Float',PrecBits,'" Name="'//TRIM(FieldName) 7130 CALL AscBinStrWrite( OutStr ) 7131 7132 WRITE( OutStr,'(A,I0,A)') '" NumberOfComponents="',sdofs,'"' 7133 CALL AscBinStrWrite( OutStr ) 7134 7135 IF( AsciiOutput ) THEN 7136 WRITE( OutStr,'(A)') ' format="ascii">'//lf 7137 CALL AscBinStrWrite( OutStr ) 7138 ELSE 7139 WRITE( OutStr,'(A,I0,A)') ' format="appended" offset="',Offset,'"/>'//lf 7140 CALL AscBinStrWrite( OutStr ) 7141 END IF 7142 END IF 7143 7144 7145 IF( BinaryOutput ) THEN 7146 k = NumberOfNodes * PrecSize * sdofs 7147 Offset = Offset + IntSize + k 7148 END IF 7149 7150 j = 0 7151 IF( WriteData ) THEN 7152 IF( BinaryOutput ) WRITE( VtuUnit ) k 7153 7154 DO i = 1, Particles % NumberOfParticles 7155 7156 IF ( Particles % Status(i) > MaxSaveStatus .OR. & 7157 Particles % Status(i) < MinSaveStatus ) CYCLE 7158 j = j + 1 7159 7160 LocalVal = 0.0_dp 7161 7162 IF( ParticleMode ) THEN 7163 IF( IsVector == 1) THEN 7164 dofs = dim 7165 LocalVal(1:dofs) = VecValues(i,1:dim) 7166 ELSE 7167 dofs = 1 7168 LocalVal(1) = Values(i) 7169 END IF 7170 ELSE 7171 Element => Mesh % Elements( Particles % ElementIndex(i) ) 7172 n = Element % TYPE % NumberOfNodes 7173 Indexes => Element % NodeIndexes 7174 7175 Nodes % x(1:n) = Mesh % Nodes % x( Indexes ) 7176 Nodes % y(1:n) = Mesh % Nodes % y( Indexes ) 7177 Nodes % z(1:n) = Mesh % Nodes % z( Indexes ) 7178 7179 u = Particles % uvw(i,1) 7180 v = Particles % uvw(i,2) 7181 IF( dim == 3 ) THEN 7182 w = Particles % uvw(i,3) 7183 ELSE 7184 w = 0.0_dp 7185 END IF 7186 7187 stat = ElementInfo( Element,Nodes,u,v,w,detJ,Basis) 7188 7189 IsDG = .FALSE. 7190 IF( ASSOCIATED( Solution ) ) THEN 7191 IsDG = ( Solution % TYPE == Variable_on_nodes_on_elements ) 7192 END IF 7193 7194 IF( IsDG ) THEN 7195 ElemInd(1:n) = Perm( Element % DGIndexes(1:n) ) 7196 IF( ComplementExists ) THEN 7197 ElemInd2(1:n) = Perm2( Element % DGIndexes(1:n) ) 7198 END IF 7199 ELSE 7200 ElemInd(1:n) = Perm( Indexes(1:n) ) 7201 IF( ComplementExists ) THEN 7202 ElemInd2(1:n) = Perm2( Indexes(1:n) ) 7203 END IF 7204 END IF 7205 7206 DO k=1,sdofs 7207 val = 0.0_dp 7208 IF( k <= dofs ) THEN 7209 IF( ComponentVector ) THEN 7210 IF( ALL( Perm( Indexes ) > 0 ) ) THEN 7211 IF( k == 1 ) THEN 7212 LocalVal(1) = SUM( Basis(1:n) * Values(ElemInd(1:n)) ) 7213 ELSE IF( k == 2 ) THEN 7214 LocalVal(2) = SUM( Basis(1:n) * Values2(ElemInd(1:n)) ) 7215 ELSE 7216 LocalVal(3) = SUM( Basis(1:n) * Values3(ElemInd(1:n)) ) 7217 END IF 7218 END IF 7219 ELSE 7220 IF( ALL( ElemInd(1:n) > 0 ) ) THEN 7221 LocalVal(k) = SUM( Basis(1:n) * Values(dofs*(ElemInd(1:n)-1)+k) ) 7222 ELSE IF ( ComplementExists ) THEN 7223 IF( ALL( ElemInd2(1:n) > 0 ) ) THEN 7224 LocalVal(k) = SUM( Basis(1:n) * Values2(dofs*(ElemInd2(1:n)-1)+k) ) 7225 END IF 7226 END IF 7227 END IF 7228 END IF 7229 END DO 7230 END IF 7231 7232 DO k=1,sdofs 7233 CALL AscBinRealWrite( LocalVal(k) ) 7234 END DO 7235 7236 IF( j == NumberOfNodes ) EXIT 7237 END DO 7238 CALL AscBinRealWrite( 0.0_dp, .TRUE.) 7239 END IF 7240 7241 IF( AsciiOutput ) THEN 7242 WRITE( OutStr,'(A)') lf//' </DataArray>'//lf 7243 CALL AscBinStrWrite( OutStr ) 7244 END IF 7245 END DO 7246 END DO 7247 END IF 7248 7249 7250 7251 IF( WriteXML ) THEN 7252 WRITE( OutStr,'(A)') ' </PointData>'//lf 7253 CALL AscBinStrWrite( OutStr ) 7254 7255 WRITE( OutStr,'(A)') ' <CellData>'//lf 7256 CALL AscBinStrWrite( OutStr ) 7257 WRITE( OutStr,'(A)') ' </CellData>'//lf 7258 CALL AscBinStrWrite( OutStr ) 7259 END IF 7260 7261 7262 ! Coordinates of each point 7263 !------------------------------------- 7264 IF( WriteXML ) THEN 7265 WRITE( OutStr,'(A)') ' <Points>'//lf 7266 CALL AscBinStrWrite( OutStr ) 7267 7268 WRITE( OutStr,'(A,I0,A,I0,A)') ' <DataArray type="Float',PrecBits,'" NumberOfComponents="',dim,'"' 7269 CALL AscBinStrWrite( OutStr ) 7270 7271 IF( AsciiOutput ) THEN 7272 WRITE( OutStr,'(A)') ' format="ascii">'//lf 7273 CALL AscBinStrWrite( OutStr ) 7274 ELSE 7275 WRITE( OutStr,'(A,I0,A)') ' format="appended" offset="',Offset,'"/>'//lf 7276 CALL AscBinStrWrite( OutStr ) 7277 END IF 7278 END IF 7279 7280 7281 IF( BinaryOutput ) THEN 7282 k = dim * NumberOfNodes * PrecSize 7283 Offset = Offset + IntSize + k 7284 END IF 7285 7286 IF( WriteData ) THEN 7287 IF( BinaryOutput ) WRITE( VtuUnit ) k 7288 7289 LocalVal = 0.0_dp 7290 j = 0 7291 DO i = 1, Particles % NumberOfParticles 7292 7293 IF ( Particles % Status(i) > MaxSaveStatus .OR. & 7294 Particles % Status(i) < MinSaveStatus ) CYCLE 7295 j = j + 1 7296 7297 IF( ParticleMode ) THEN 7298 DO k=1,PartDim 7299 LocalVal(k) = Particles % Coordinate(i,k) 7300 END DO 7301 ELSE 7302 Element => Mesh % Elements( Particles % ElementIndex(i) ) 7303 Indexes => Element % NodeIndexes 7304 n = Element % TYPE % NumberOfNodes 7305 7306 Nodes % x(1:n) = Mesh % Nodes % x( Indexes ) 7307 Nodes % y(1:n) = Mesh % Nodes % y( Indexes ) 7308 Nodes % z(1:n) = Mesh % Nodes % z( Indexes ) 7309 7310 u = Particles % uvw(i,1) 7311 v = Particles % uvw(i,2) 7312 IF( dim == 3 ) THEN 7313 w = Particles % uvw(i,3) 7314 ELSE 7315 w = 0.0_dp 7316 END IF 7317 7318 stat = ElementInfo( Element,Nodes,u,v,w,detJ,Basis) 7319 7320 LocalVal(1) = SUM( Basis(1:n) * Nodes % x(1:n) ) 7321 LocalVal(2) = SUM( Basis(1:n) * Nodes % y(1:n) ) 7322 LocalVal(3) = SUM( Basis(1:n) * Nodes % z(1:n) ) 7323 END IF 7324 7325 !PRINT *,'ParticleMode:',ParticleMode,j,dim,LocalVal 7326 7327 CALL AscBinRealWrite( LocalVal(1) ) 7328 CALL AscBinRealWrite( LocalVal(2) ) 7329 CALL AscBinRealWrite( LocalVal(3) ) 7330 7331 IF( j == NumberOfNodes ) EXIT 7332 END DO 7333 7334 CALL AscBinRealWrite( 0.0_dp, .TRUE.) 7335 END IF 7336 7337 IF( AsciiOutput ) THEN 7338 WRITE( OutStr,'(A)') lf//' </DataArray>'//lf 7339 CALL AscBinStrWrite( OutStr ) 7340 END IF 7341 IF( WriteXML ) THEN 7342 WRITE( OutStr,'(A)') ' </Points>'//lf 7343 CALL AscBinStrWrite( OutStr ) 7344 END IF 7345 7346 7347 ! Write out the mesh 7348 !------------------------------------- 7349 IF( WriteXML ) THEN 7350 WRITE( OutStr,'(A)') ' <Cells>'//lf 7351 CALL AscBinStrWrite( OutStr ) 7352 7353 WRITE( OutStr,'(A)') ' <DataArray type="Int32" Name="connectivity"' 7354 CALL AscBinStrWrite( OutStr ) 7355 7356 IF( AsciiOutput ) THEN 7357 WRITE( OutStr,'(A)') ' format="ascii">'//lf 7358 CALL AscBinStrWrite( OutStr ) 7359 ELSE 7360 WRITE( OutStr,'(A,I0,A)') ' format="appended" offset="',Offset,'"/>'//lf 7361 CALL AscBinStrWrite( OutStr ) 7362 END IF 7363 END IF 7364 7365 IF( BinaryOutput ) THEN 7366 ! The offset needs to be summed over all nodes 7367 k = NumberOfNodes * IntSize 7368 Offset = Offset + k + IntSize 7369 END IF 7370 7371 IF( WriteData ) THEN 7372 IF( BinaryOutput ) WRITE( VtuUnit ) k 7373 DO i = 1, NumberOfNodes 7374 CALL AscBinIntegerWrite( i - 1) 7375 END DO 7376 CALL AscBinIntegerWrite( 0, .TRUE. ) 7377 END IF 7378 7379 IF( AsciiOutput ) THEN 7380 WRITE( OutStr,'(A)') lf//' </DataArray>'//lf 7381 CALL AscBinStrWrite( OutStr ) 7382 END IF 7383 7384 ! Offsets for element indexes 7385 !------------------------------------------------------------------- 7386 IF( WriteXML ) THEN 7387 WRITE( OutStr,'(A)') ' <DataArray type="Int32" Name="offsets"' 7388 CALL AscBinStrWrite( OutStr ) 7389 7390 IF( AsciiOutput ) THEN 7391 WRITE( OutStr,'(A)') ' format="ascii">'//lf 7392 CALL AscBinStrWrite( OutStr ) 7393 ELSE 7394 WRITE( OutStr,'(A,I0,A)') ' format="appended" offset="',Offset,'"/>'//lf 7395 CALL AscBinStrWrite( OutStr ) 7396 END IF 7397 END IF 7398 7399 IF( BinaryOutput ) THEN 7400 k = NumberOfNodes * IntSize 7401 Offset = Offset + IntSize + k 7402 END IF 7403 7404 IF( WriteData ) THEN 7405 IF( BinaryOutput ) WRITE( VtuUnit ) k 7406 DO i = 1, NumberOfNodes 7407 CALL AscBinIntegerWrite( i ) 7408 END DO 7409 CALL AscBinIntegerWrite( 0, .TRUE.) 7410 END IF 7411 7412 IF( AsciiOutput ) THEN 7413 WRITE( OutStr,'(A)') lf//' </DataArray>'//lf 7414 CALL AscBinStrWrite( OutStr ) 7415 END IF 7416 IF( WriteXML ) THEN 7417 WRITE( OutStr,'(A)') ' <DataArray type="Int32" Name="types"' 7418 CALL AscBinStrWrite( OutStr ) 7419 7420 IF( AsciiOutput ) THEN 7421 WRITE( OutStr,'(A)') ' FORMAT="ascii">'//lf 7422 CALL AscBinStrWrite( OutStr ) 7423 ELSE 7424 WRITE( OutStr,'(A,I0,A)') ' format="appended" offset="',Offset,'"/>'//lf 7425 CALL AscBinStrWrite( OutStr ) 7426 END IF 7427 END IF 7428 7429 IF( BinaryOutput ) THEN 7430 k = NumberOfNodes * IntSize 7431 Offset = Offset + IntSize + k 7432 END IF 7433 7434 IF( WriteData ) THEN 7435 IF( BinaryOutput ) WRITE( VtuUnit ) k 7436 ! elementtype is fixed to single nodes (==1) 7437 DO i = 1, NumberOfNodes 7438 CALL AscBinIntegerWrite( 1 ) 7439 END DO 7440 CALL AscBinIntegerWrite( 0, .TRUE. ) 7441 END IF 7442 7443 IF( AsciiOutput ) THEN 7444 WRITE( OutStr,'(A)') lf//' </DataArray>'//lf 7445 CALL AscBinStrWrite( OutStr ) 7446 END IF 7447 IF( WriteXml ) THEN 7448 WRITE( OutStr,'(A)') ' </Cells>'//lf 7449 CALL AscBinStrWrite( OutStr ) 7450 WRITE( OutStr,'(A)') ' </Piece>'//lf 7451 CALL AscBinStrWrite( OutStr ) 7452 WRITE( OutStr,'(A)') ' </UnstructuredGrid>'//lf 7453 CALL AscBinStrWrite( OutStr ) 7454 END IF 7455 7456 7457 IF( BinaryOutput ) THEN 7458 IF( WriteXML ) THEN 7459 WRITE( OutStr,'(A)') '<AppendedData encoding="raw">'//lf 7460 CALL AscBinStrWrite( OutStr ) 7461 WRITE( VtuUnit ) '_' 7462 7463 WriteXML = .FALSE. 7464 WriteData = .TRUE. 7465 GOTO 100 7466 ELSE 7467 WRITE( OutStr,'(A)') lf//'</AppendedData>'//lf 7468 CALL AscBinStrWrite( OutStr ) 7469 END IF 7470 END IF 7471 7472 WRITE( OutStr,'(A)') '</VTKFile>'//lf 7473 CALL AscBinStrWrite( OutStr ) 7474 7475 WRITE( OutStr,'(A)') ' ' 7476 CALL AscBinStrWrite( OutStr ) 7477 7478 CLOSE( VtuUnit ) 7479 7480 DEALLOCATE( Basis, Nodes % x, Nodes % y, Nodes % z ) 7481 7482 CALL AscBinWriteFree() 7483 7484 END SUBROUTINE WriteVtuFile 7485 7486 7487 7488 SUBROUTINE WritePvtuFile( VtuFile ) 7489 CHARACTER(LEN=*), INTENT(IN) :: VtuFile 7490 INTEGER, PARAMETER :: VtuUnit = 58 7491 TYPE(Variable_t), POINTER :: Var, Solution 7492 CHARACTER(LEN=512) :: str 7493 INTEGER :: i,j,k,dofs,Rank,cumn,n,vari,sdofs 7494 CHARACTER(LEN=1024) :: Txt, ScalarFieldName, VectorFieldName, FieldName, & 7495 FieldName2 7496 LOGICAL :: ScalarsExist, VectorsExist, Found, ComponentVector, ThisOnly 7497 REAL(KIND=dp), POINTER :: ScalarValues(:), VectorValues(:,:) 7498 7499 7500 OPEN( UNIT=VtuUnit, FILE=VtuFile, STATUS='UNKNOWN' ) 7501 7502 IF ( LittleEndian() ) THEN 7503 WRITE( VtuUnit,'(A)') '<VTKFile type="PUnstructuredGrid" version="0.1" byte_order="LittleEndian">' 7504 ELSE 7505 WRITE( VtuUnit,'(A)') '<VTKFile type="PUnstructuredGrid" version="0.1" byte_order="BigEndian">' 7506 END IF 7507 WRITE( VtuUnit,'(A)') ' <PUnstructuredGrid>' 7508 7509 ! nodewise information 7510 !------------------------------------- 7511 ScalarFieldName = ListGetString( Params,'Scalar Field 1',ScalarsExist) 7512 VectorFieldName = ListGetString( Params,'Vector Field 1',VectorsExist) 7513 IF( ScalarsExist .AND. VectorsExist) THEN 7514 WRITE( VtuUnit,'(A)') ' <PPointData Scalars="'//TRIM(ScalarFieldName)& 7515 //'" Vectors="'//TRIM(VectorFieldName)//'">' 7516 ELSE IF( ScalarsExist ) THEN 7517 WRITE( VtuUnit,'(A)') ' <PPointData Scalars="'//TRIM(ScalarFieldName)//'">' 7518 ELSE IF( VectorsExist ) THEN 7519 WRITE( VtuUnit,'(A)') ' <PPointData Vectors="'//TRIM(VectorFieldName)//'">' 7520 END IF 7521 7522 7523 !------------------------------------------------------- 7524 ! Do the scalars 7525 !------------------------------------------------------- 7526 DO Vari = 1, 99 7527 WRITE(Txt,'(A,I0)') 'Scalar Field ',Vari 7528 FieldName = ListGetString( Params, TRIM(Txt), Found ) 7529 IF(.NOT. Found) EXIT 7530 7531 IF( ASSOCIATED( Particles % uvw ) ) THEN 7532 Solution => VariableGet( Mesh % Variables, TRIM(FieldName), ThisOnly ) 7533 7534 IF( .NOT. ASSOCIATED(Solution ) ) THEN 7535 CALL Warn('WritePvtuFile','Solution not associated!') 7536 END IF 7537 ELSE 7538 IF( FieldName /= 'particle distance' .OR. & 7539 FieldName /= 'particle time' .OR. & 7540 FieldName /= 'particle dt' ) THEN 7541 WRITE(Txt, '(A,A)') 'Nonexistent variable: ',TRIM(FieldName) 7542 CALL Warn('WriteVtuXMLFile', Txt) 7543 CYCLE 7544 END IF 7545 END IF 7546 7547 IF( AsciiOutput ) THEN 7548 WRITE( VtuUnit,'(A)') ' <PDataArray type="Float'//TRIM(I2S(PrecBits))//& 7549 '" Name="'//TRIM(FieldName)//'" NumberOfComponents="1" format="ascii"/>' 7550 ELSE 7551 WRITE( VtuUnit,'(A)') ' <PDataArray type="Float'//TRIM(I2S(PrecBits))//& 7552 '" Name="'//TRIM(FieldName)//'" NumberOfComponents="1" format="appended"/>' 7553 END IF 7554 7555 END DO 7556 7557 7558 !------------------------------------------------------- 7559 ! Do the vectors 7560 !------------------------------------------------------- 7561 7562 DO Vari = 1, 99 7563 WRITE(Txt,'(A,I0)') 'Vector Field ',Vari 7564 FieldName = ListGetString( Params, TRIM(Txt), Found ) 7565 IF(.NOT. Found) EXIT 7566 7567 IF( ASSOCIATED( Particles % uvw ) ) THEN 7568 Solution => VariableGet( Mesh % Variables, TRIM(FieldName), ThisOnly ) 7569 ComponentVector = .FALSE. 7570 7571 IF(.NOT. ASSOCIATED(Solution)) THEN 7572 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 1',ThisOnly ) 7573 IF( ASSOCIATED(Solution)) THEN 7574 ComponentVector = .TRUE. 7575 ELSE 7576 WRITE(Txt, '(A,A)') 'Nonexistent variable: ',TRIM(FieldName) 7577 CALL Warn('WriteVtuXMLFile', Txt) 7578 CYCLE 7579 END IF 7580 END IF 7581 7582 IF( ASSOCIATED(Solution % EigenVectors)) THEN 7583 CALL Warn('WritePvtuFile','Do the eigen values') 7584 END IF 7585 7586 dofs = Solution % DOFs 7587 IF( ComponentVector ) THEN 7588 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 2',ThisOnly ) 7589 IF( ASSOCIATED(Solution)) dofs = 2 7590 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 3',ThisOnly ) 7591 IF( ASSOCIATED(Solution)) dofs = 3 7592 END IF 7593 ELSE 7594 dofs = 3 7595 IF( FieldName /= 'velocity' .AND. FieldName /= 'force') THEN 7596 WRITE(Txt, '(A,A)') 'Nonexistent variable: ',TRIM(FieldName) 7597 CALL Warn('WriteVtuXMLFile', Txt) 7598 CYCLE 7599 END IF 7600 END IF 7601 7602 sdofs = dofs 7603 IF( AsciiOutput ) THEN 7604 WRITE( VtuUnit,'(A,I1,A)') ' <PDataArray type="Float'//TRIM(I2S(PrecBits))//'" Name="& 7605 '//TRIM(FieldName)//'" NumberOfComponents="',sdofs,'" format="ascii"/>' 7606 ELSE 7607 WRITE( VtuUnit,'(A,I1,A)') ' <PDataArray type="Float'//TRIM(I2S(PrecBits))//'" Name="& 7608 '//TRIM(FieldName)//'" NumberOfComponents="',sdofs,'" format="appended"/>' 7609 END IF 7610 END DO 7611 7612 IF ( ScalarsExist .OR. VectorsExist) THEN 7613 WRITE( VtuUnit,'(A)') ' </PPointData>' 7614 END IF 7615 7616 ! Coordinates of each point 7617 !------------------------------------- 7618 WRITE( VtuUnit,'(A)') ' <PPoints>' 7619 IF( AsciiOutput ) THEN 7620 WRITE( VtuUnit,'(A)') ' <DataArray type="Float'//TRIM(I2S(PrecBits))//& 7621 '" NumberOfComponents="3" format="ascii"/>' 7622 ELSE 7623 WRITE( VtuUnit,'(A)') ' <DataArray type="Float'//TRIM(I2S(PrecBits))//& 7624 '" NumberOfComponents="3" format="appended"/>' 7625 END IF 7626 WRITE( VtuUnit,'(A)') ' </PPoints>' 7627 7628 DO i=1,Partitions 7629 IF( iTime < 10000 ) THEN 7630 WRITE( VtuUnit,'(A,I4.4,A,I4.4,A)' ) ' <Piece Source="'//& 7631 TRIM(FilePrefix),i,"par",iTime,'.vtu"/>' 7632 ELSE 7633 WRITE( VtuUnit,'(A,I4.4,A,I0,A)' ) ' <Piece Source="'//& 7634 TRIM(FilePrefix),i,"par",iTime,'.vtu"/>' 7635 END IF 7636 END DO 7637 7638 WRITE( VtuUnit,'(A)') ' </PUnstructuredGrid>' 7639 WRITE( VtuUnit,'(A)') '</VTKFile>' 7640 7641 CLOSE( VtuUnit ) 7642 7643 END SUBROUTINE WritePvtuFile 7644 7645 7646!------------------------------------------------------------------------------ 7647 END SUBROUTINE ParticleOutputVtu 7648!------------------------------------------------------------------------------ 7649 7650 7651 7652!------------------------------------------------------------------------------ 7653!> Writes data out in XML VTK ImageData format (VTI) which assumes a uniform grid where 7654!> the position of each point is defined by the origin and the grid density. 7655!> Also binary output and single precision therein is supported. 7656!------------------------------------------------------------------------------ 7657 SUBROUTINE ParticleOutputVti( Particles, GridExtent, GridOrigin, GridDx, GridIndex ) 7658!------------------------------------------------------------------------------ 7659 7660! USE DefUtils 7661! USE MeshUtils 7662! USE ElementDescription 7663 USE AscBinOutputUtils 7664 7665 IMPLICIT NONE 7666 TYPE(Particle_t), POINTER :: Particles 7667 INTEGER :: GridExtent(6) 7668 REAL(KIND=dp) :: GridOrigin(3), GridDx(3) 7669 INTEGER, POINTER :: GridIndex(:,:,:) 7670 7671 TYPE(ValueList_t),POINTER :: Params 7672 INTEGER, SAVE :: nTime = 0 7673 LOGICAL :: GotIt, Parallel, FixedMeshend 7674 7675 CHARACTER(MAX_NAME_LEN), SAVE :: FilePrefix 7676 CHARACTER(MAX_NAME_LEN) :: VtiFile, PvtiFile 7677 TYPE(Mesh_t), POINTER :: Mesh 7678 TYPE(Variable_t), POINTER :: Var 7679 INTEGER :: i, j, k, Partitions, Part, ExtCount, FileindexOffSet, iTime 7680 CHARACTER(MAX_NAME_LEN) :: Dir 7681 REAL(KIND=dp) :: SaveNodeFraction 7682 LOGICAL :: Found,BinaryOutput,AsciiOutput,SinglePrec,NoFileIndex, & 7683 Visited = .FALSE. 7684 7685 CHARACTER(MAX_NAME_LEN) :: Str 7686 INTEGER :: NumberOfNodes, ParallelNodes, Dim 7687 7688 7689 Params => ListGetSolverParams() 7690 Mesh => GetMesh() 7691 7692 ExtCount = ListGetInteger( Params,'Output Count',GotIt) 7693 IF( GotIt ) THEN 7694 nTime = ExtCount 7695 ELSE 7696 nTime = nTime + 1 7697 END IF 7698 FileIndexOffset = ListGetInteger( Params,'Fileindex offset',GotIt) 7699 iTime = nTime + FileIndexOffset 7700 7701 BinaryOutput = GetLogical( Params,'Binary Output',GotIt) 7702 AsciiOutput = .NOT. BinaryOutput 7703 SinglePrec = GetLogical( Params,'Single Precision',GotIt) 7704 NoFileindex = GetLogical( Params,'No Fileindex',GotIt) 7705 7706 IF ( nTime == 1 ) THEN 7707 FilePrefix = ListGetString( Params,'Filename Prefix') 7708 CALL Info('ParticleOutputVti','Saving in ImageData VTK XML format to file: ' & 7709 //TRIM(FilePrefix)//'.vti') 7710 END IF 7711 7712 Partitions = ParEnv % PEs 7713 Part = ParEnv % MyPE 7714 Parallel = (Partitions > 1) .OR. ListGetLogical(Params,'Enforce Parallel format',GotIt) 7715 7716 Dim = Particles % dim 7717 7718 NumberOfNodes = Particles % NumberOfParticles 7719 7720 7721 IF (LEN_TRIM(Mesh % Name) > 0 ) THEN 7722 Dir = TRIM(Mesh % Name) // "/" 7723 ELSE 7724 Dir = "./" 7725 END IF 7726 7727 IF(Parallel .AND. Part == 0) THEN 7728 CALL Warn('WriteVtiFile','VTK ImageFile not yet in parallel') 7729 IF(.FALSE.) THEN 7730 WRITE( PvtiFile,'(A,A,I4.4,".pvti")' ) TRIM(Dir),TRIM(FilePrefix),iTime 7731 CALL WritePvtiFile( PvtiFile ) 7732 END IF 7733 END IF 7734 7735 IF ( Parallel ) THEN 7736 IF( NoFileindex ) THEN 7737 WRITE( VtiFile,'(A,A,I4.4,A,".vti")' ) TRIM(Dir),TRIM(FilePrefix),Part+1,"par" 7738 ELSE 7739 WRITE( VtiFile,'(A,A,I4.4,A,I4.4,".vti")' ) TRIM(Dir),TRIM(FilePrefix),Part+1,"par",& 7740 iTime 7741 END IF 7742 ELSE 7743 IF( NoFileIndex ) THEN 7744 WRITE( VtiFile,'(A,A,".vti")' ) TRIM(Dir),TRIM(FilePrefix) 7745 ELSE 7746 WRITE( VtiFile,'(A,A,I4.4,".vti")' ) TRIM(Dir),TRIM(FilePrefix),iTime 7747 END IF 7748 END IF 7749 7750 CALL WriteVtiFile( VtiFile ) 7751 7752 7753 CONTAINS 7754 7755 7756 SUBROUTINE WriteVtiFile( VtiFile ) 7757 CHARACTER(LEN=*), INTENT(IN) :: VtiFile 7758 INTEGER, PARAMETER :: VtiUnit = 58 7759 TYPE(Variable_t), POINTER :: Var, Solution 7760 CHARACTER(LEN=512) :: str 7761 INTEGER :: i,j,k,l,dofs,Rank,cumn,n,vari,sdofs,ind,IsVector,IsAppend,GridPoints,Offset 7762 CHARACTER(LEN=1024) :: Txt, ScalarFieldName, VectorFieldName, FieldName, & 7763 FieldName2, BaseString, OutStr 7764 CHARACTER :: lf 7765 LOGICAL :: ScalarsExist, VectorsExist, Found, ParticleMode, ComponentVector, & 7766 ComplementExists, ThisOnly, Stat, WriteData, WriteXML 7767 INTEGER, POINTER :: Perm(:), Perm2(:), Indexes(:) 7768 INTEGER, ALLOCATABLE :: ElemInd(:),ElemInd2(:) 7769 REAL(KIND=dp), POINTER :: ScalarValues(:), VectorValues(:,:),Values(:),Values2(:),& 7770 Values3(:),Basis(:) 7771 REAL(KIND=dp) :: x,y,z,u,v,w,DetJ,val 7772 REAL :: fvalue 7773 TYPE(Nodes_t) :: Nodes 7774 TYPE(Element_t), POINTER :: Element 7775 7776 7777 ! Initialize the auxiliary module for buffered writing 7778 !-------------------------------------------------------------- 7779 CALL AscBinWriteInit( AsciiOutput, SinglePrec, VtiUnit, NumberOfNodes ) 7780 7781 n = Mesh % MaxElementNodes 7782 ALLOCATE( Basis(n), Nodes % x(n), Nodes % y(n), Nodes % z(n) ) 7783 7784 n = Mesh % MaxElementDOFS 7785 ALLOCATE( ElemInd(n), ElemInd2(n) ) 7786 ThisOnly = .TRUE. 7787 7788 ! Linefeed character 7789 !----------------------------------- 7790 lf = CHAR(10) 7791 7792 7793 ! This format works both for ascii and binary output 7794 !------------------------------------------------------------------------- 7795 OPEN( UNIT=VtiUnit, FILE=VtiFile, FORM = 'unformatted', ACCESS = 'stream' ) 7796 7797 7798 WRITE( OutStr,'(A)') '<?xml version="1.0"?>'//lf 7799 CALL AscBinStrWrite( OutStr ) 7800 7801 IF ( LittleEndian() ) THEN 7802 WRITE( OutStr,'(A)') '<VTKFile type="ImageData" version="0.1" byte_order="LittleEndian">'//lf 7803 ELSE 7804 WRITE( OutStr,'(A)') '<VTKFile type="ImageData" version="0.1" byte_order="BigEndian">'//lf 7805 END IF 7806 CALL AscBinStrWrite( OutStr ) 7807 7808 WRITE( OutStr,'(A,6I4,A,3ES16.7E3,A,3ES16.7E3,A)') & 7809 '<ImageData WholeExtent = "',GridExtent,& 7810 '" Origin = "',GridOrigin(1:3), & 7811 '" Spacing = "',GridDx(1:3),'">'//lf 7812 CALL AscBinStrWrite( OutStr ) 7813 7814 WRITE( OutStr,'(A,6I4,A)') ' <Piece Extent="',GridExtent,'">'//lf 7815 CALL AscBinStrWrite( OutStr ) 7816 7817 7818 !--------------------------------------------------------------------- 7819 ! Header information for nodewise data 7820 !--------------------------------------------------------------------- 7821 ScalarFieldName = ListGetString( Params,'Scalar Field 1',ScalarsExist) 7822 VectorFieldName = ListGetString( Params,'Vector Field 1',VectorsExist) 7823 IF( ScalarsExist .AND. VectorsExist) THEN 7824 WRITE( OutStr,'(A)') ' <PointData Scalars="'//TRIM(ScalarFieldName)& 7825 //'" Vectors="'//TRIM(VectorFieldName)//'">'//lf 7826 ELSE IF( ScalarsExist ) THEN 7827 WRITE( OutStr,'(A)') ' <PointData Scalars="'//TRIM(ScalarFieldName)//'">'//lf 7828 ELSE IF( VectorsExist ) THEN 7829 WRITE( OutStr,'(A)') ' <PointData Vectors="'//TRIM(VectorFieldName)//'">'//lf 7830 ELSE 7831 CALL Warn('WriteVtiFile','Are there really no scalars or vectors?') 7832 END IF 7833 IF( ScalarsExist .OR. VectorsExist ) THEN 7834 CALL AscBinStrWrite( OutStr ) 7835 END IF 7836 7837 Offset = 0 7838 WriteXML = .TRUE. 7839 WriteData = AsciiOutput 7840 GridPoints = 1 7841 DO i = 1,3 7842 GridPoints = GridPoints * ( GridExtent(2*i)-GridExtent(2*i-1)+1 ) 7843 END DO 7844 7845 7846 7847100 DO IsVector = 0, 1 7848 7849 DO Vari = 1, 99 7850 7851 !--------------------------------------------------------------------- 7852 ! do the scalars 7853 !--------------------------------- ----------------------------------- 7854 IF( IsVector == 0 ) THEN 7855 BaseString = 'Scalar Field' 7856 ELSE 7857 BaseString = 'Vector Field' 7858 END IF 7859 7860 WRITE(Txt,'(A)') TRIM(BaseString)//' '//TRIM(I2S(Vari)) 7861 FieldName = ListGetString( Params, TRIM(Txt), Found ) 7862 IF(.NOT. Found) EXIT 7863 7864 !--------------------------------------------------------------------- 7865 ! Find the variable with the given name in the normal manner 7866 !--------------------------------------------------------------------- 7867 Solution => VariableGet( Mesh % Variables,TRIM(FieldName),ThisOnly ) 7868 IF( ASSOCIATED( Solution ) ) THEN 7869 IF( IsVector == 1 .AND. Solution % Dofs <= 1 ) NULLIFY( Solution ) 7870 END IF 7871 7872 ComponentVector = .FALSE. 7873 IF( IsVector == 1 ) THEN 7874 IF(.NOT. ASSOCIATED(Solution)) THEN 7875 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 1', ThisOnly ) 7876 ComponentVector = ASSOCIATED( Solution ) 7877 END IF 7878 END IF 7879 IF( .NOT. ASSOCIATED( Solution ) ) THEN 7880 WRITE(Txt, '(A,A)') 'Nonexistent variable: ',TRIM(FieldName) 7881 CALL Warn('WriteVtiXMLFile', Txt) 7882 CYCLE 7883 END IF 7884 7885 Perm => Solution % Perm 7886 dofs = Solution % DOFs 7887 Values => Solution % Values 7888 7889 !--------------------------------------------------------------------- 7890 ! Eigenmodes have not yet been implemented 7891 !--------------------------------------------------------------------- 7892 IF( ASSOCIATED(Solution % EigenVectors)) THEN 7893 CALL Warn('WriteVtiXMLFile','Do the eigen values') 7894 END IF 7895 7896 !--------------------------------------------------------------------- 7897 ! Some vectors are defined by a set of components (either 2 or 3) 7898 !--------------------------------------------------------------------- 7899 IF( ComponentVector ) THEN 7900 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 2',ThisOnly ) 7901 IF( ASSOCIATED(Solution)) THEN 7902 Values2 => Solution % Values 7903 dofs = 2 7904 END IF 7905 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 3',ThisOnly ) 7906 IF( ASSOCIATED(Solution)) THEN 7907 Values3 => Solution % Values 7908 dofs = 3 7909 END IF 7910 END IF 7911 7912 !--------------------------------------------------------------------- 7913 ! There may be special complementary variables such as 7914 ! displacement & mesh update 7915 !--------------------------------------------------------------------- 7916 ComplementExists = .FALSE. 7917 WRITE(Txt,'(A,I0,A)') TRIM(BaseString),Vari,' Complement' 7918 7919 FieldName2 = ListGetString( Params, TRIM(Txt), Found ) 7920 IF( Found ) THEN 7921 Solution => VariableGet( Mesh % Variables, & 7922 TRIM(FieldName2), ThisOnly ) 7923 IF( ASSOCIATED(Solution)) THEN 7924 Values2 => Solution % Values 7925 Perm2 => Solution % Perm 7926 ComplementExists = .TRUE. 7927 ELSE 7928 CALL Warn('WriteVTIFile','Complement does not exist:'//TRIM(FieldName2)) 7929 END IF 7930 END IF 7931 7932 7933 !--------------------------------------------------------------------- 7934 ! Finally save the field values for scalars and vectors 7935 !--------------------------------------------------------------------- 7936 j = 0 7937 7938 IF( dofs == 1 ) THEN 7939 sdofs = 1 7940 ELSE 7941 sdofs = MAX(dofs,3) 7942 END IF 7943 7944 IF( WriteXML ) THEN 7945 WRITE( OutStr,'(A)') ' <DataArray type="Float64" Name="'//TRIM(FieldName)//'"' 7946 CALL AscBinStrWrite( OutStr ) 7947 7948 WRITE( OutStr,'(A,I1,A)') ' NumberOfComponents="',sdofs,'"' 7949 CALL AscBinStrWrite( OutStr ) 7950 7951 IF( AsciiOutput ) THEN 7952 WRITE( OutStr,'(A)') ' format="ascii">'//lf 7953 CALL AscBinStrWrite( OutStr ) 7954 ELSE 7955 WRITE( OutStr,'(A)') ' format="appended"' 7956 CALL AscBinStrWrite( OutStr ) 7957 WRITE( OutStr,'(A,I8,A)') ' offset="',Offset,'"/>'//lf 7958 CALL AscBinStrWrite( OutStr ) 7959 END IF 7960 END IF 7961 7962 IF( BinaryOutput ) THEN 7963 IF( SinglePrec ) THEN 7964 k = GridPoints * KIND( fvalue ) * sdofs 7965 ELSE 7966 k = GridPoints * KIND( val ) * sdofs 7967 END IF 7968 Offset = Offset + KIND(i) + k 7969 IF( WriteData ) WRITE( VtiUnit ) k 7970 END IF 7971 7972 7973 IF( WriteData ) THEN 7974 DO k = 1,GridExtent(6)-GridExtent(5)+1 7975 DO j = 1,GridExtent(4)-GridExtent(3)+1 7976 DO i = 1,GridExtent(2)-GridExtent(1)+1 7977 7978 ind = GridIndex( i, j, k ) 7979 7980 IF( ind == 0 ) THEN 7981 DO l=1,sdofs 7982 IF( AsciiOutput ) THEN 7983 WRITE( OutStr,'(A)') ' 0.0' 7984 CALL AscBinStrWrite( OutStr ) 7985 ELSE IF( SinglePrec ) THEN 7986 fvalue = 0.0 7987 WRITE( VtiUnit ) fvalue 7988 ELSE 7989 val = 0.0_dp 7990 WRITE( VtiUnit ) val 7991 END IF 7992 END DO 7993 ELSE 7994 Element => Mesh % Elements( Particles % ElementIndex(ind) ) 7995 Indexes => Element % NodeIndexes 7996 n = Element % TYPE % NumberOfNodes 7997 7998 Nodes % x(1:n) = Mesh % Nodes % x( Indexes ) 7999 Nodes % y(1:n) = Mesh % Nodes % y( Indexes ) 8000 Nodes % z(1:n) = Mesh % Nodes % z( Indexes ) 8001 8002 u = Particles % uvw(ind,1) 8003 v = Particles % uvw(ind,2) 8004 IF( dim == 3 ) THEN 8005 w = Particles % uvw(ind,3) 8006 ELSE 8007 w = 0.0_dp 8008 END IF 8009 8010 stat = ElementInfo( Element,Nodes,u,v,w,detJ,Basis) 8011 8012 IF( Solution % TYPE == Variable_on_nodes_on_elements ) THEN 8013 ElemInd(1:n) = Perm( Element % DGIndexes(1:n) ) 8014 IF( ComplementExists ) THEN 8015 ElemInd2(1:n) = Perm2( Element % DGIndexes(1:n) ) 8016 END IF 8017 ELSE 8018 ElemInd(1:n) = Perm( Indexes(1:n) ) 8019 IF( ComplementExists ) THEN 8020 ElemInd2(1:n) = Perm2( Indexes(1:n) ) 8021 END IF 8022 END IF 8023 8024 DO l=1,sdofs 8025 val = 0.0_dp 8026 IF( l <= dofs ) THEN 8027 IF( ALL( ElemInd(1:n) > 0 ) ) THEN 8028 IF( ComponentVector ) THEN 8029 IF( l == 1 ) THEN 8030 val = SUM( Basis(1:n) * Values(ElemInd(1:n)) ) 8031 ELSE IF( l == 2 ) THEN 8032 val = SUM( Basis(1:n) * Values2(ElemInd(1:n)) ) 8033 ELSE 8034 val = SUM( Basis(1:n) * Values3(ElemInd(1:n)) ) 8035 END IF 8036 ELSE 8037 val = SUM( Basis(1:n) * Values(dofs*(ElemInd(1:n)-1)+l) ) 8038 END IF 8039 ELSE IF( ComplementExists ) THEN 8040 IF( ALL( ElemInd2(1:n) > 0 ) ) THEN 8041 val = SUM( Basis(1:n) * Values2(dofs*(ElemInd2(1:n)-1)+l) ) 8042 END IF 8043 END IF 8044 END IF 8045 8046 IF( AsciiOutput ) THEN 8047 IF( ABS( val ) < TINY( val ) ) THEN 8048 WRITE( OutStr,'(A)') ' 0.0' 8049 ELSE 8050 WRITE( OutStr,'(ES16.7E3)') val 8051 END IF 8052 CALL AscBinStrWrite( OutStr ) 8053 ELSE IF( SinglePrec ) THEN 8054 fvalue = val 8055 WRITE( VtiUnit ) fvalue 8056 ELSE 8057 WRITE( VtiUnit ) val 8058 END IF 8059 8060 END DO 8061 END IF 8062 8063 END DO ! i 8064 END DO ! j 8065 END DO ! k 8066 END IF 8067 8068 IF( AsciiOutput ) THEN 8069 WRITE( OutStr,'(A)') lf//' </DataArray>'//lf 8070 CALL AscBinStrWrite( OutStr ) 8071 END IF 8072 8073 END DO 8074 END DO 8075 8076 8077 IF( WriteXML ) THEN 8078 IF( ScalarsExist .OR. VectorsExist) THEN 8079 WRITE( OutStr,'(A)') ' </PointData>'//lf 8080 CALL AscBinStrWrite( OutStr ) 8081 END IF 8082 8083 WRITE( OutStr,'(A)') ' <CellData>'//lf 8084 CALL AscBinStrWrite( OutStr ) 8085 8086 WRITE( OutStr,'(A)') ' </CellData>'//lf 8087 CALL AscBinStrWrite( OutStr ) 8088 8089 WRITE( OutStr,'(A)') ' </Piece>'//lf 8090 CALL AscBinStrWrite( OutStr ) 8091 8092 WRITE( OutStr,'(A)') '</ImageData>'//lf 8093 CALL AscBinStrWrite( OutStr ) 8094 END IF 8095 8096 IF( BinaryOutput ) THEN 8097 IF( WriteXML ) THEN 8098 WRITE( OutStr,'(A)') '<AppendedData encoding="raw">'//lf 8099 CALL AscBinStrWrite( OutStr ) 8100 WRITE( VtiUnit ) '_' 8101 8102 WriteXML = .FALSE. 8103 WriteData = .TRUE. 8104 GOTO 100 8105 ELSE 8106 WRITE( OutStr,'(A)') lf//'</AppendedData>'//lf 8107 CALL AscBinStrWrite( OutStr ) 8108 END IF 8109 END IF 8110 8111 8112 WRITE( OutStr,'(A)') '</VTKFile>'//lf 8113 CALL AscBinStrWrite( OutStr ) 8114 8115 CLOSE( VtiUnit ) 8116 8117 DEALLOCATE( Basis, Nodes % x, Nodes % y, Nodes % z, ElemInd, ElemInd2 ) 8118 8119 CALL AscBinWriteFree() 8120 8121 8122 END SUBROUTINE WriteVtiFile 8123 8124 8125 8126 SUBROUTINE WritePvtiFile( VtiFile ) 8127 CHARACTER(LEN=*), INTENT(IN) :: VtiFile 8128 INTEGER, PARAMETER :: VtiUnit = 58 8129 TYPE(Variable_t), POINTER :: Var, Solution 8130 CHARACTER(LEN=512) :: str 8131 INTEGER :: i,j,k,dofs,Rank,cumn,n,vari,sdofs 8132 CHARACTER(LEN=1024) :: Txt, ScalarFieldName, VectorFieldName, FieldName, & 8133 FieldName2 8134 LOGICAL :: ScalarsExist, VectorsExist, Found, ComponentVector, ThisOnly 8135 REAL(KIND=dp), POINTER :: ScalarValues(:), VectorValues(:,:) 8136 8137 8138 OPEN( UNIT=VtiUnit, FILE=VtiFile, STATUS='UNKNOWN' ) 8139 8140 IF ( LittleEndian() ) THEN 8141 WRITE( VtiUnit,'(A)') '<VTKFile type="PImageData" version="0.1" byte_order="LittleEndian">' 8142 ELSE 8143 WRITE( VtiUnit,'(A)') '<VTKFile type="PImageData" version="0.1" byte_order="BigEndian">' 8144 END IF 8145 WRITE( VtiUnit,'(A)') ' <PImageData>' 8146 8147 ! nodewise information 8148 !------------------------------------- 8149 ScalarFieldName = ListGetString( Params,'Scalar Field 1',ScalarsExist) 8150 VectorFieldName = ListGetString( Params,'Vector Field 1',VectorsExist) 8151 IF( ScalarsExist .AND. VectorsExist) THEN 8152 WRITE( VtiUnit,'(A)') ' <PPointData Scalars="'//TRIM(ScalarFieldName)& 8153 //'" Vectors="'//TRIM(VectorFieldName)//'">' 8154 ELSE IF( ScalarsExist ) THEN 8155 WRITE( VtiUnit,'(A)') ' <PPointData Scalars="'//TRIM(ScalarFieldName)//'">' 8156 ELSE IF( VectorsExist ) THEN 8157 WRITE( VtiUnit,'(A)') ' <PPointData Vectors="'//TRIM(VectorFieldName)//'">' 8158 END IF 8159 8160 8161 !------------------------------------------------------- 8162 ! Do the scalars 8163 !------------------------------------------------------- 8164 DO Vari = 1, 99 8165 WRITE(Txt,'(A,I0)') 'Scalar Field ',Vari 8166 FieldName = ListGetString( Params, TRIM(Txt), Found ) 8167 IF(.NOT. Found) EXIT 8168 8169 Solution => VariableGet( Mesh % Variables, TRIM(FieldName), ThisOnly ) 8170 8171 IF( .NOT. ASSOCIATED(Solution ) ) THEN 8172 CALL Warn('WritePvtiFile','Solution not associated!') 8173 END IF 8174 8175 WRITE( VtiUnit,'(A)') ' <PDataArray type="Float64" Name="'//TRIM(FieldName)& 8176 //'" NumberOfComponents="1" format="ascii"/>' 8177 END DO 8178 8179 8180 !------------------------------------------------------- 8181 ! Do the vectors 8182 !------------------------------------------------------- 8183 8184 DO Vari = 1, 99 8185 WRITE(Txt,'(A,I0)') 'Vector Field ',Vari 8186 FieldName = ListGetString( Params, TRIM(Txt), Found ) 8187 IF(.NOT. Found) EXIT 8188 8189 Solution => VariableGet( Mesh % Variables, TRIM(FieldName), ThisOnly ) 8190 ComponentVector = .FALSE. 8191 8192 IF(.NOT. ASSOCIATED(Solution)) THEN 8193 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 1',ThisOnly ) 8194 IF( ASSOCIATED(Solution)) THEN 8195 ComponentVector = .TRUE. 8196 ELSE 8197 WRITE(Txt, '(A,A)') 'Nonexistent variable: ',TRIM(FieldName) 8198 CALL Warn('WriteVtiXMLFile', Txt) 8199 CYCLE 8200 END IF 8201 END IF 8202 8203 IF( ASSOCIATED(Solution % EigenVectors)) THEN 8204 CALL Warn('WritePvtiFile','Do the eigen values') 8205 END IF 8206 8207 dofs = Solution % DOFs 8208 IF( ComponentVector ) THEN 8209 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 2',ThisOnly ) 8210 IF( ASSOCIATED(Solution)) dofs = 2 8211 Solution => VariableGet( Mesh % Variables, TRIM(FieldName)//' 3',ThisOnly ) 8212 IF( ASSOCIATED(Solution)) dofs = 3 8213 END IF 8214 8215 sdofs = dofs 8216 WRITE( VtiUnit,'(A,I1,A)') ' <PDataArray type="Float64" Name="'//TRIM(FieldName)& 8217 //'" NumberOfComponents="',sdofs,'" format="ascii"/>' 8218 END DO 8219 8220 WRITE( VtiUnit,'(A)') ' </PPointData>' 8221 8222 ! Coordinates of each point 8223 !------------------------------------- 8224 WRITE( VtiUnit,'(A)') ' <PPoints>' 8225 WRITE( VtiUnit,'(A)') ' <DataArray type="Float64" NumberOfComponents="3" format="ascii"/>' 8226 WRITE( VtiUnit,'(A)') ' </PPoints>' 8227 8228 DO i=1,Partitions 8229 IF( NoFileindex ) THEN 8230 WRITE( VtiUnit,'(A,I4.4,A,A)' ) ' <Piece Source="'//& 8231 TRIM(FilePrefix),i,"par",'.vti"/>' 8232 ELSE 8233 WRITE( VtiUnit,'(A,I4.4,A,I4.4,A)' ) ' <Piece Source="'//& 8234 TRIM(FilePrefix),i,"par",iTime,'.vti"/>' 8235 END IF 8236 END DO 8237 8238 WRITE( VtiUnit,'(A)') ' </PImageData>' 8239 WRITE( VtiUnit,'(A)') '</VTKFile>' 8240 8241 CLOSE( VtiUnit ) 8242 8243 END SUBROUTINE WritePvtiFile 8244 8245 8246!------------------------------------------------------------------------------ 8247 END SUBROUTINE ParticleOutputVti 8248!------------------------------------------------------------------------------ 8249 8250 8251 !------------------------------------------------------------------------ 8252 !> Write particles to an external file in various formats. 8253 !------------------------------------------------------------------------- 8254 8255 SUBROUTINE SaveParticleData( Model,Solver,dt,TransientSimulation ) 8256 8257 8258 IMPLICIT NONE 8259 !------------------------------------------------------------------------------ 8260 TYPE(Solver_t), TARGET :: Solver 8261 TYPE(Model_t) :: Model 8262 REAL(KIND=dp) :: dt 8263 LOGICAL :: TransientSimulation 8264 8265 TYPE(Particle_t), POINTER :: Particles 8266 LOGICAL :: Visited = .FALSE. 8267 TYPE(ValueList_t), POINTER :: Params 8268 CHARACTER(LEN=MAX_NAME_LEN) :: FileFormat 8269 LOGICAL :: VtuFormat, TableFormat, GmshFormat, AnyFormat, Found 8270 8271 SAVE :: TableFormat, VtuFormat, Visited 8272 8273 8274 Particles => GlobalParticles 8275 Params => ListGetSolverParams() 8276 8277 TableFormat = ListGetLogical( Params,'Table Format',Found) 8278 GmshFormat = ListGetLogical( Params,'Gmsh Format',Found) 8279 VtuFormat = ListGetLogical( Params,'Vtu Format',Found) 8280 FileFormat = ListGetString( Params,'Output Format',Found) 8281 IF( Found ) THEN 8282 IF( FileFormat == 'gmsh') GmshFormat = .TRUE. 8283 IF( FileFormat == 'vtu') VtuFormat = .TRUE. 8284 IF( FileFormat == 'table') TableFormat = .TRUE. 8285 END IF 8286 8287 AnyFormat = TableFormat .OR. VtuFormat .OR. GmshFormat 8288 IF( .NOT. AnyFormat ) THEN 8289 CALL Warn('SaveParticleData','No active file format given!') 8290 RETURN 8291 END IF 8292 8293 IF(.NOT. ListCheckPresent( Params,'Filename Prefix') ) THEN 8294 CALL ListAddString( Params,'Filename Prefix','particles') 8295 END IF 8296 8297 IF( TableFormat ) CALL ParticleOutputTable( Particles ) 8298 IF( GmshFormat ) CALL ParticleOutputGmsh( Particles ) 8299 IF( VtuFormat ) CALL ParticleOutputVtu( Particles ) 8300 8301 8302 END SUBROUTINE SaveParticleData 8303 8304 8305!------------------------------------------------------------------------------ 8306END MODULE ParticleUtils 8307!------------------------------------------------------------------------------ 8308 8309!> \} 8310 8311