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