File: /nfs/home/0/users/jenkins/mfix.git/model/des/mpi_unpack_des_mod.f

1     !----------------------------------------------------------------------!
2     !  Module: MPI_UNPACK_DES                                              !
3     !  Author: Pradeep Gopalakrishnan                                      !
4     !                                                                      !
5     !  Purpose: Contains routines for unpacking real and ghost particles   !
6     !     from the MPI recv buffers.                                       !
7     !----------------------------------------------------------------------!
8           MODULE MPI_UNPACK_DES
9     
10           PRIVATE
11           PUBLIC :: DESMPI_UNPACK_PARCROSS, DESMPI_UNPACK_GHOSTPAR
12     
13           interface unpack_dbuf
14              module procedure unpack_db0 ! real scalars
15              module procedure unpack_db1 ! real arrays
16              module procedure unpack_i0  ! integer scalars
17              module procedure unpack_i1  ! integer arrays
18              module procedure unpack_l0  ! logical scalars
19           end interface unpack_dbuf
20     
21     
22           CONTAINS
23     
24     
25     !----------------------------------------------------------------------!
26     !  Subroutine: DESMPI_UNPACK_GHOSTPAR                                  !
27     !  Author: Pradeep Gopalakrishnan                                      !
28     !                                                                      !
29     ! Purpose: Unpacks ghost particle from the recv buffer.                !
30     !----------------------------------------------------------------------!
31           SUBROUTINE DESMPI_UNPACK_GHOSTPAR(pface)
32     
33     
34     ! Global Variables:
35     !---------------------------------------------------------------------//
36     ! Size of Particle data packet
37           use desmpi, only: iGhostPacketSize
38     ! Index of last particle added to this process.
39           use desmpi, only: iSPOT
40     ! Flag indicating that the ghost particle was updated
41           use discretelement, only: iGHOST_UPDATED
42     ! The MPI receive buffer
43           use desmpi, only: dRECVBUF
44     ! Buffer offset
45           use desmpi, only: iBUFOFFSET
46     ! Runtime flag for solving the energy equations
47           use run, only: ENERGY_EQ
48     ! Runtime flag for solving species equations
49           use run, only: ANY_SPECIES_EQ
50     ! Runtime flag for MPPIC solids
51           use mfix_pic, only: MPPIC
52     ! Dimenions of DES grid
53           use desgrid, only: DG_IJKSIZE2
54     ! DES grid cell containing each particle: current/previous
55           use discretelement, only: DG_PIJK, DG_PIJKPRV
56     ! The global ID for each particle
57           use discretelement, only: iGLOBAL_ID
58     ! Particle positions: current/previous
59           use discretelement, only: DES_POS_NEW, DES_POS_OLD
60     ! Particle tangential velocities: current/previous
61           use discretelement, only: DES_VEL_NEW, DES_VEL_OLD
62     ! Particle rotational velocities: current/previous
63           use discretelement, only: OMEGA_NEW, OMEGA_OLD
64     ! Particle species composition
65           use des_rxns, only: DES_X_s
66     ! Particle tempertures. current/previous
67           use des_thermo, only: DES_T_s_NEW, DES_T_s_OLD
68     ! Particle radius, volume
69           use discretelement, only: DES_RADIUS, PVOL
70     ! Number of cells used in interpolation
71           use particle_filter, only: FILTER_SIZE
72     ! Cells and weights for interpolation
73           use particle_filter, only: FILTER_CELL, FILTER_WEIGHT
74     ! Flags indicate the state of the particle
75           use discretelement, only: PEA
76     ! Map to fluid grid cells and solids phase (I,J,K,IJK,M)
77           use discretelement, only: PIJK
78     ! Flag to send/recv old (previous) values
79           use discretelement, only: DO_OLD
80     ! Flag to conduct a new neighbor search.
81           use discretelement, only: DO_NSEARCH
82     ! Number of particles on the process (max particle array size)
83           use discretelement, only: PIP, MAX_PIP
84     ! Number of ghost particles on the current process
85           use discretelement, only: iGHOST_CNT
86     ! User-defined variables for each particle.
87           use discretelement, only: DES_USR_VAR, DES_USR_VAR_SIZE
88     
89           use des_allocate
90     
91     ! Global Constants:
92     !---------------------------------------------------------------------//
93           use constant, only: PI
94     ! Dimension of particle spatial arrays.
95           use discretelement, only: DIMN
96     
97           IMPLICIT NONE
98     
99     ! Dummy arguments:
100     !---------------------------------------------------------------------//
101     ! Processor boundary being packed (Top/Bottom/North/South/East/West)
102           INTEGER, INTENT(IN) :: PFACE
103     
104     ! Local variables
105     !---------------------------------------------------------------------//
106           integer :: lcurpar,lparid,lprvijk,lijk,lparijk,lparcnt,ltot_ind
107           integer :: lbuf,lindx,llocpar,lnewcnt,lpicloc
108           logical,dimension(:),allocatable :: lfound
109           integer,dimension(:),allocatable :: lnewspot,lnewpic
110     !......................................................................!
111     
112     ! unpack the particles:
113     ! if it already exists update the position
114     ! if not and do_nsearch is true then add to the particle array
115     
116           lparcnt = drecvbuf(1,pface)
117           lnewcnt = lparcnt
118           allocate (lfound(lparcnt),lnewspot(lparcnt),lnewpic(dg_ijksize2))
119           lfound(:) = .false.
120           lnewspot(:) =0
121           lnewpic = 0
122     
123           do lcurpar = 1,lparcnt
124              lbuf = (lcurpar-1)*iGhostPacketSize+ibufoffset
125     
126     ! 1) Global ID
127              call unpack_dbuf(lbuf,lparid,pface)
128     ! 2) DES Grid IJK
129              call unpack_dbuf(lbuf,lparijk,pface)
130     ! 3) DES Grid IJK - Previous
131              call unpack_dbuf(lbuf,lprvijk,pface)
132     
133     ! Determine if this particle already exists on this process as a
134     ! ghost particle. If so, (lfound), then the current infomration is
135     ! updated on the current process. Otherwise (.NOT.lfound) a new
136     ! ghost particle is created on this process.
137              lfound(lcurpar) = locate_par(lparid,lprvijk,llocpar)
138              if (lparijk .ne. lprvijk .and. .not.lfound(lcurpar)) then
139                 lfound(lcurpar) = locate_par(lparid,lparijk,llocpar)
140              endif
141     
142              if(lfound(lcurpar)) then
143     ! Store the local variables
144                 dg_pijk(llocpar) = lparijk
145                 dg_pijkprv(llocpar) = lprvijk
146     
147     ! 4) Radious
148                 call unpack_dbuf(lbuf,des_radius(llocpar),pface)
149     ! 5) Phase index
150                 call unpack_dbuf(lbuf,pijk(llocpar,5),pface)
151     ! 6) Position
152                 call unpack_dbuf(lbuf,des_pos_new(1:dimn,llocpar),pface)
153     ! 7) Translational Velocity
154                 call unpack_dbuf(lbuf,des_vel_new(1:dimn,llocpar),pface)
155     ! 8) Rotational Velocity
156                 call unpack_dbuf(lbuf,omega_new(1:3,llocpar),pface)
157     ! 9) Exiting particle flag
158                 call unpack_dbuf(lbuf,pea(llocpar,3),pface)
159     ! 10) Temperature
160                 IF(ENERGY_EQ) &
161                    call unpack_dbuf(lbuf,des_t_s_new(llocpar),pface)
162     ! 11) User Variables
163                 IF(DES_USR_VAR_SIZE > 0) &
164                    call unpack_dbuf(lbuf,des_usr_var(1:3,llocpar),pface)
165     ! 12) Interpolation verights
166                 IF(FILTER_SIZE > 0) THEN
167                    call unpack_dbuf(lbuf,filter_cell(:,llocpar),pface)
168                    call unpack_dbuf(lbuf,filter_weight(:,llocpar),pface)
169                 ENDIF
170     
171     
172     ! Calculate the volume of the ghost particle.
173                 PVOL(llocpar) = (4.0D0/3.0D0)*PI*DES_RADIUS(llocpar)**3
174     ! Flag that the ghost particle was updated.
175                 ighost_updated(llocpar) = .true.
176                 lnewcnt = lnewcnt-1
177     
178     ! Copy the current value to the previous value if needed.
179                 IF (DO_OLD) THEN
180                    des_pos_old(:,llocpar)= des_pos_new(:,llocpar)
181                    des_vel_old(:,llocpar)= des_vel_new(:,llocpar)
182                    if(ENERGY_EQ)des_t_s_old(llocpar)= des_t_s_new(llocpar)
183                    omega_old(:,llocpar)= omega_new(:,llocpar)
184                 ENDIF
185     
186              else
187                 lnewpic(lparijk) = lnewpic(lparijk) + 1
188              endif
189           enddo
190     
191     ! iAdd new ghost particles
192           if(lnewcnt > 0) then
193              call PARTICLE_GROW(pip+lnewcnt)
194              ighost_cnt = ighost_cnt + lnewcnt
195              pip = pip + lnewcnt
196              do lcurpar = 1,lparcnt
197                 if(lfound(lcurpar)) cycle
198                 lbuf = (lcurpar-1)*iGhostPacketSize+ibufoffset
199     
200     !  1) Global particle ID
201                 call unpack_dbuf(lbuf,lparid,pface)
202     !  2) DES grid IJK
203                 call unpack_dbuf(lbuf,lparijk,pface)
204     !  3) DES grid IJK - Previous
205                 call unpack_dbuf(lbuf,lprvijk,pface)
206     ! Locate the first open space in the particle array.
207                 do while(pea(ispot,1))
208                    ispot = ispot + 1
209                 enddo
210     ! Set the flags for the ghost particle and store the local variables.
211                 pea(ispot,1) = .true.
212                 pea(ispot,2) = .false.
213                 pea(ispot,3) = .false.
214                 pea(ispot,4) = .true.
215                 iglobal_id(ispot)  = lparid
216                 dg_pijk(ispot) = lparijk
217                 dg_pijkprv(ispot) = lprvijk
218     !  4) Radius
219                 call unpack_dbuf(lbuf,des_radius(ispot),pface)
220     !  5) Phase index
221                 call unpack_dbuf(lbuf,pijk(ispot,5),pface)
222     !  6) Position
223                 call unpack_dbuf(lbuf,des_pos_new(1:dimn,ispot),pface)
224     !  7) Translational velocity
225                 call unpack_dbuf(lbuf,des_vel_new(1:dimn,ispot),pface)
226     !  8) Rotational velocity
227                 call unpack_dbuf(lbuf,omega_new(1:dimn,ispot),pface)
228     !  9) Exiting particle flag
229                 call unpack_dbuf(lbuf,pea(ispot,3),pface)
230     ! 10) Temperature.
231                 IF(ENERGY_EQ) &
232                    call unpack_dbuf(lbuf,des_t_s_new(ispot),pface)
233     ! 11) User varaible
234                 IF(DES_USR_VAR_SIZE > 0)&
235                    call unpack_dbuf(lbuf,des_usr_var(:,ispot),pface)
236     ! 12) Interpolation verights
237                 IF(FILTER_SIZE > 0) THEN
238                    call unpack_dbuf(lbuf,filter_cell(:,ispot),pface)
239                    call unpack_dbuf(lbuf,filter_weight(:,ispot),pface)
240                 ENDIF
241     
242                 ighost_updated(ispot) = .true.
243                 lnewspot(lcurpar) = ispot
244     
245                 PVOL(ispot) = (4.0D0/3.0D0)*PI*DES_RADIUS(ispot)**3
246     
247                 IF (DO_OLD) THEN
248                    des_pos_old(1:dimn,ispot) = des_pos_new(1:dimn,ispot)
249                    des_vel_old(1:dimn,ispot) = des_vel_new(1:dimn,ispot)
250                    omega_old(1:3,ispot) = omega_new(1:3,ispot)
251                    if(ENERGY_EQ) des_t_s_old(ispot) = des_t_s_new(ispot)
252                 ENDIF
253              enddo
254           endif
255     
256     !deallocate temporary variablies
257           deallocate (lfound,lnewspot,lnewpic)
258     
259           end subroutine desmpi_unpack_ghostpar
260     
261     
262     !----------------------------------------------------------------------!
263     !  Subroutine: DESMPI_UNPACK_PARCROSS                                  !
264     !  Author: Pradeep Gopalakrishnan                                      !
265     !                                                                      !
266     ! Purpose: Unpacks real particle from the recv buffer.                 !
267     !----------------------------------------------------------------------!
268           SUBROUTINE DESMPI_UNPACK_PARCROSS(pface)
269     
270     ! Global Variables:
271     !---------------------------------------------------------------------//
272     ! Size of ghost particle data packet
273           use desmpi, only: iParticlePacketSize
274     ! Index of last particle added to this process.
275           use desmpi, only: iSPOT
276     ! Flag indicating that the ghost particle was updated
277           use discretelement, only: iGHOST_UPDATED
278     ! The MPI receive buffer
279           use desmpi, only: dRECVBUF
280     ! Buffer offset
281           use desmpi, only: iBUFOFFSET
282     ! Runtime flag for solving the energy equations
283           use run, only: ENERGY_EQ
284     ! Runtime flag for solving species equations
285           use run, only: ANY_SPECIES_EQ
286     ! Runtime flag for MPPIC solids
287           use mfix_pic, only: MPPIC
288     ! Dimenions of DES grid
289           use desgrid, only: DG_IJKSIZE2
290     ! DES grid cell containing each particle: current/previous
291           use discretelement, only: DG_PIJK, DG_PIJKPRV
292     ! The neighbor processor's rank
293           use desmpi, only: iNEIGHPROC
294     ! The statistical weight of each particle.
295           use mfix_pic, only: DES_STAT_WT
296     ! The global ID for each particle
297           use discretelement, only: iGLOBAL_ID
298     ! Particle positions: current/previous
299           use discretelement, only: DES_POS_NEW, DES_POS_OLD
300     ! Particle tangential velocities: current/previous
301           use discretelement, only: DES_VEL_NEW, DES_VEL_OLD
302     ! Particle rotational velocities: current/previous
303           use discretelement, only: OMEGA_NEW, OMEGA_OLD
304     !Particle orientation
305           use discretelement, only: PARTICLE_ORIENTATION,ORIENTATION
306     ! Particle radius, volume, density, mass
307           use discretelement, only: DES_RADIUS, PVOL, RO_SOL, PMASS
308     ! Previous value for particle acceleration (tangential/rotational)
309           use discretelement, only: DES_ACC_OLD, ROT_ACC_OLD
310     ! Particle species composition
311           use des_rxns, only: DES_X_s
312     ! Particle tempertures. current/previous
313           use des_thermo, only: DES_T_s_NEW, DES_T_s_OLD
314     ! Number of cells used in interpolation
315           use particle_filter, only: FILTER_SIZE
316     ! Cells and weights for interpolation
317           use particle_filter, only: FILTER_CELL, FILTER_WEIGHT
318     ! Force arrays acting on the particle
319           use discretelement, only: FC, TOW
320     ! One of the moment of inertia
321           use discretelement, only: OMOI
322     ! Flags indicate the state of the particle
323           use discretelement, only: PEA
324     ! Map to fluid grid cells and solids phase (I,J,K,IJK,M)
325           use discretelement, only: PIJK
326     ! Flag to send/recv old (previous) values
327           use discretelement, only: DO_OLD
328     ! Flag to conduct a new neighbor search.
329           use discretelement, only: DO_NSEARCH
330     ! Number of particles on the process (max particle array size)
331           use discretelement, only: PIP, MAX_PIP
332     ! Number of ghost particles on the current process
333           use discretelement, only: iGHOST_CNT
334     ! Flag indicating the the fluid-particle drag is explictly coupled.
335           use discretelement, only: DES_EXPLICITLY_COUPLED
336     ! Explict fluid-particle drag force
337           use discretelement, only: DRAG_FC
338     ! User-defined variables for each particle.
339           use discretelement, only: DES_USR_VAR, DES_USR_VAR_SIZE
340     ! Particle pair (neighborhood) arrays:
341           use discretelement, only: PAIR_NUM, PAIRS
342     ! Pair collision history information
343           use discretelement, only: PV_PAIR, PFN_PAIR, PFT_PAIR
344     ! Dimension of particle spatial arrays.
345           use discretelement, only: DIMN
346     ! The ID of the current process
347           use compar, only: myPE
348     
349     ! Module Procedures:
350     !---------------------------------------------------------------------//
351           use des_allocate
352           use desmpi_wrapper, only: DES_MPI_STOP
353     
354           implicit none
355     
356     ! Dummy arguments:
357     !---------------------------------------------------------------------//
358     ! Processor boundary being packed (Top/Bottom/North/South/East/West)
359           INTEGER, INTENT(IN) :: PFACE
360     
361     ! Local variables
362     !---------------------------------------------------------------------//
363           integer :: lijk,lcurpar,lparcnt,llocpar,lparid,lparijk,lprvijk
364           integer :: lneighindx,lneigh,lcontactindx,lcontactid,lcontact,&
365                      lneighid,lneighijk,lneighprvijk
366           logical :: lfound
367           integer :: lbuf,ltmpbuf,lcount
368           logical :: lcontactfound,lneighfound
369           integer :: cc,ii,kk,num_pairs_sent
370     
371           integer :: pair_match
372           logical :: do_add_pair
373     !......................................................................!
374     
375     ! loop through particles and locate them and make changes
376           lparcnt = drecvbuf(1,pface)
377     
378     ! if mppic make sure enough space available
379           call PARTICLE_GROW(pip+lparcnt)
380     
381           do lcurpar =1,lparcnt
382     
383              lfound = .false.
384              lbuf = (lcurpar-1)*iParticlePacketSize + ibufoffset
385     ! 1) Global ID
386              call unpack_dbuf(lbuf,lparid,pface)
387     ! 2) DES Grid IJK
388              call unpack_dbuf(lbuf,lparijk,pface)
389     ! 3) DES grid IJK - previous
390              call unpack_dbuf(lbuf,lprvijk,pface)
391     
392     ! PIC particles are always 'new' to the receiving process. Find the
393     ! first available array position and store the global ID. Increment
394     ! the PIP counter to include the new particle.
395              IF(MPPIC) THEN
396                 DO WHILE(PEA(ISPOT,1))
397                    ISPOT = ISPOT + 1
398                 ENDDO
399                 lLOCPAR = iSPOT
400                 iGLOBAL_ID(lLOCPAR) = lPARID
401                 PIP = PIP + 1
402     
403     ! A DEM particle should already exist on the current processor as a
404     ! ghost particle. Match the sent particle to the local ghost particle
405     ! by matching the global IDs. Decrement the iGHOST_CNT counter to
406     ! account for the switch from ghost to real particle.
407              ELSE
408                 lFOUND  = LOCATE_PAR(lPARID,lPRVIJK,lLOCPAR)
409                 IF (.NOT. lFOUND) THEN
410                    lFOUND = exten_locate_par(lPARID, lPARIJK, lLOCPAR)
411                    IF(.NOT.lFOUND) THEN
412                       WRITE(*,1000) iNEIGHPROC(PFACE), MYPE, lPARID
413                       CALL DES_MPI_STOP
414                    ENDIF
415                 ENDIF
416                 iGHOST_CNT = iGHOST_CNT - 1
417              ENDIF
418     
419      1000 FORMAT(2/1X,72('*'),/1x,'From: DESMPI_UNPACK_PARCROSS: ',/       &
420              ' Error 1000: Unable to match particles crossing processor ', &
421              'boundaries.',/3x,'Source Proc: ',I9,' ---> Destination ',    &
422              'Proc: ', I9,/3x,'Global Particle ID: ',I12,/1x,72('*'))
423     
424     ! convert the local particle from ghost to existing and update its position
425              pea(llocpar,1) = .TRUE.
426              pea(llocpar,4) = .FALSE.
427              dg_pijk(llocpar) = lparijk
428              dg_pijkprv(llocpar) = lprvijk
429     ! 4) Radius
430              call unpack_dbuf(lbuf,des_radius(llocpar),pface)
431     ! 5-9) Fluid cell I,J,K,IJK, and solids phase index
432              call unpack_dbuf(lbuf,pijk(llocpar,:),pface)
433     ! 10) Entering particle flag.
434              call unpack_dbuf(lbuf,pea(llocpar,2),pface)
435     ! 11) Exiting particle flag.
436              call unpack_dbuf(lbuf,pea(llocpar,3),pface)
437     ! 12) Density
438              call unpack_dbuf(lbuf,ro_sol(llocpar),pface)
439     ! 13) Volume
440              call unpack_dbuf(lbuf,pvol(llocpar),pface)
441     ! 14) Mass
442              call unpack_dbuf(lbuf,pmass(llocpar),pface)
443     ! 15) 1/Moment of Inertia
444              call unpack_dbuf(lbuf,omoi(llocpar),pface)
445     ! 16) Position with cyclic shift
446              call unpack_dbuf(lbuf,des_pos_new(:,llocpar),pface)
447     ! 17) Translational velocity
448              call unpack_dbuf(lbuf,des_vel_new(:,llocpar),pface)
449     ! 18) Rotational velocity
450              call unpack_dbuf(lbuf,omega_new(:,llocpar),pface)
451     ! 19) Accumulated translational forces
452              call unpack_dbuf(lbuf,fc(:,llocpar),pface)
453     ! 20) Accumulated torque forces
454              call unpack_dbuf(lbuf,tow(:,llocpar),pface)
455     ! 21) Temperature
456              IF(ENERGY_EQ) &
457                 call unpack_dbuf(lbuf,des_t_s_new(llocpar),pface)
458     ! 22) Species composition
459              IF(ANY_SPECIES_EQ) &
460                 call unpack_dbuf(lbuf,des_x_s(llocpar,:),pface)
461     ! 23) Explict drag force
462              IF(DES_EXPLICITLY_COUPLED) &
463                 call unpack_dbuf(lbuf,drag_fc(:,llocpar),pface)
464     ! 24) User defined variable
465              IF(DES_USR_VAR_SIZE > 0) &
466                 call unpack_dbuf(lbuf,des_usr_var(:,llocpar),pface)
467     ! 25) Particle orientation
468              IF(PARTICLE_ORIENTATION) &
469                 call unpack_dbuf(lbuf,orientation(:,llocpar),pface)
470     
471     ! -- Higher order integration variables
472              IF (DO_OLD) THEN
473     ! 26) Position (previous)
474                 call unpack_dbuf(lbuf,des_pos_old(:,llocpar),pface)
475     ! 27) Translational velocity (previous)
476                 call unpack_dbuf(lbuf,des_vel_old(:,llocpar),pface)
477     ! 28) Rotational velocity (previous)
478                 call unpack_dbuf(lbuf,omega_old(:,llocpar),pface)
479     ! 29) Translational acceleration (previous)
480                 call unpack_dbuf(lbuf,des_acc_old(:,llocpar),pface)
481     ! 30) Rotational acceleration (previous)
482                 call unpack_dbuf(lbuf,rot_acc_old(:,llocpar),pface)
483     ! 31) Temperature (previous)
484                 IF(ENERGY_EQ) &
485                    call unpack_dbuf(lbuf,des_t_s_old(llocpar),pface)
486              ENDIF
487     ! 32) Statistical weight
488              IF(MPPIC) call unpack_dbuf(lbuf,des_stat_wt(llocpar),pface)
489     
490           end do
491     
492     ! 33) Number of pair datasets
493           lbuf = lparcnt*iParticlePacketSize + ibufoffset
494           call unpack_dbuf(lbuf,num_pairs_sent,pface)
495     
496           do cc = 1, num_pairs_sent
497     ! 34) Global ID of packed particle.
498              call unpack_dbuf(lbuf,lparid,pface)
499     ! 35) DES grid IJK of cell receiving the particle.
500              call unpack_dbuf(lbuf,lparijk,pface)
501     
502     ! Locate the particle on the current process.
503              if (.not. locate_par(lparid,lparijk,llocpar)) then
504                 if (.not. exten_locate_par(lparid,lparijk,llocpar)) then
505                    print *,"at buffer location",lbuf," pface = ",pface
506                    print *,"COULD NOT FIND PARTICLE ",lparid," IN IJK ",lparijk
507                    call des_mpi_stop
508                 endif
509              endif
510     ! 36) Global ID of neighbor particle.
511              call unpack_dbuf(lbuf,lneighid,pface)
512     ! 37) DES grid IJK of cell containing the neighbor particle.
513              call unpack_dbuf(lbuf,lneighijk,pface)
514     
515     ! Locate the neighbor particle on the current process.
516              if (.not. locate_par(lneighid,lneighijk,lneigh)) then
517                 if (.not. exten_locate_par(lneighid,lparijk,lneigh)) then
518                    print *,"  "
519                    print *,"  "
520                    print *," fail on  ", myPE
521                    print *,"at buffer location",lbuf," pface = ",pface
522                    print *,"COULD NOT FIND NEIGHBOR ",lneighid," IN IJK ",lneighijk
523                    call des_mpi_stop
524                 endif
525              endif
526     
527     ! If the neighbor particle is a 'real' particle on this processor, then
528     ! the pair data may already exist. Check before addeding it.
529              do_add_pair = .TRUE.
530              if(pea(lneigh,1) .and. .not.pea(lneigh,4)) then
531                 do ii=1,pair_num
532                    if(PAIRS(1,II) == lneigh) then
533                       if(PAIRS(2,II) == llocpar) then
534                          do_add_pair = .FALSE.
535                          pair_match = II
536                          exit
537                       endif
538                    endif
539                 enddo
540              endif
541     ! Create a new neighbor pair if it was not matched to an exiting pair.
542              if(do_add_pair) then
543                 call add_pair(llocpar,lneigh)
544                 pair_match = pair_num
545              endif
546     ! 38) Flag indicating induring contact for the pair.
547              call unpack_dbuf(lbuf,pv_pair(pair_num),pface)
548     ! 39) Normal collision history.
549              call unpack_dbuf(lbuf,pfn_pair(:,pair_num),pface)
550     ! 40) Tangential collision history.
551              call unpack_dbuf(lbuf,pft_pair(:,pair_num),pface)
552           enddo
553     
554           END SUBROUTINE desmpi_unpack_parcross
555     
556     !----------------------------------------------------------------------!
557     ! Function: LOCATE_PAR                                                 !
558     ! Author: Pradeep Gopalakrishnan                                       !
559     !                                                                      !
560     ! Purpose: Return the local index of the particle matching the passed  !
561     !    global ID. The function returns TRUE if the particle is matched,  !
562     !    otherwise it returns FALSE.                                       !
563     !----------------------------------------------------------------------!
564           LOGICAL FUNCTION LOCATE_PAR(pGLOBALID, pIJK, pLOCALNO)
565     
566           use discretelement, only: iGLOBAL_ID
567           use desgrid, only: DG_IJKStart2, DG_IJKEnd2
568           use discretelement, only: dg_pic
569     
570           implicit none
571     
572     ! Dummy arguments:
573     !---------------------------------------------------------------------//
574     ! Global ID of the particle
575           INTEGER, INTENT(IN) :: pGlobalID
576     ! IJK of DES grid cell containing the particle
577           INTEGER, INTENT(IN) :: pIJK
578     ! Local ID for the particle.
579           INTEGER, INTENT(OUT) :: pLocalNO
580     
581     ! Local variables
582     !---------------------------------------------------------------------//
583           INTEGER :: lpicloc, lcurpar
584     
585     ! Initialize the result.
586           locate_par = .false.
587     
588     ! Verify that the passied IJK value is within a valid range.
589           if(pIJK < dg_ijkstart2 .or. pIJK > dg_ijkend2)  RETURN
590     
591     ! Loop the the particles in DES grid cell pIJK. Return to the calling
592     ! routine if the passed global ID matches the global ID of one of
593     ! the local particles.
594           DO lpicloc = 1,dg_pic(pijk)%isize
595              lcurpar = dg_pic(pijk)%p(lpicloc)
596              IF(iGLOBAL_ID(lcurpar) == pGlobalID) THEN
597                 plocalno = lcurpar
598                 locate_par = .true.
599                 RETURN
600              ENDIF
601           ENDDO
602     
603           RETURN
604           end function locate_par
605     
606     !----------------------------------------------------------------------!
607     ! Function: EXTEN_LOCATE_PAR                                           !
608     ! Author: Pradeep Gopalakrishnan                                       !
609     !                                                                      !
610     ! Purpose: Return the local index of the particle matching the passed  !
611     !    global ID. The function returns TRUE if the particle is matched,  !
612     !    otherwise it returns FALSE.                                       !
613     !------------------------------------------------------------------------
614           LOGICAL FUNCTION EXTEN_LOCATE_PAR(pGlobalID, pIJK, pLocalNO)
615     
616           use discretelement, only: iGLOBAL_ID, dg_pic
617           use desgrid, only: DG_IJKStart2, DG_IJKEnd2
618           use desgrid, only: dg_Iof_LO, DG_Jof_LO, DG_Kof_LO
619           use geometry, only: NO_K
620     
621           use desgrid, only: dg_funijk
622     
623           implicit none
624     
625     ! Dummy variables:
626     !---------------------------------------------------------------------//
627     ! The global ID of the particle to be matched locally
628           INTEGER, INTENT(IN) :: pGlobalId
629     ! The DES grid cell index expected to contain the particle.
630           INTEGER, INTENT(IN) :: pIJK
631     ! The local ID of the matching particle.
632           INTEGER, INTENT(OUT) :: pLocalNo
633     
634     ! Local variables:
635     !---------------------------------------------------------------------//
636     ! Loop counters.
637           INTEGER :: lijk, li, lj, lk, lic, ljc, lkc, lkoffset
638           INTEGER :: lpicloc,lcurpar
639     
640           exten_locate_par = .false.
641     
642           lic = dg_iof_lo(pijk)
643           ljc = dg_jof_lo(pijk)
644           lkc = dg_kof_lo(pijk)
645           lkoffset = merge(0, 1, NO_K)
646           DO  lk = lkc-lkoffset,lkc+lkoffset
647           DO  lj = ljc-1,ljc+1
648           DO  li = lic-1,lic+1
649              lijk = dg_funijk(li,lj,lk)
650              IF (lijk .lt. dg_ijkstart2 .or. lijk .gt. dg_ijkend2) CYCLE
651              DO lpicloc = 1, dg_pic(lijk)%isize
652                 lcurpar = dg_pic(lijk)%p(lpicloc)
653                 IF (iglobal_id(lcurpar) .eq. pglobalid) THEN
654                    plocalno = lcurpar
655                    exten_locate_par = .true.
656                    RETURN
657                 END IF
658              END DO
659           END DO
660           END DO
661           END DO
662     
663           RETURN
664           END FUNCTION EXTEN_LOCATE_PAR
665     
666     
667     !----------------------------------------------------------------------!
668     ! Unpack subroutine for single real variables                          !
669     !----------------------------------------------------------------------!
670           subroutine unpack_db0(lbuf,idata,pface)
671           use desmpi, only: dRECVBUF
672           integer, intent(inout) :: lbuf
673           integer, intent(in) :: pface
674           double precision, intent(inout) :: idata
675     
676           idata = drecvbuf(lbuf,pface)
677           lbuf = lbuf + 1
678     
679           return
680           end subroutine unpack_db0
681     
682     !----------------------------------------------------------------------!
683     ! Unpack subroutine for real arrays                                    !
684     !----------------------------------------------------------------------!
685           subroutine unpack_db1(lbuf,idata,pface)
686           use desmpi, only: dRECVBUF
687           integer, intent(inout) :: lbuf
688           integer, intent(in) :: pface
689           double precision, intent(inout) :: idata(:)
690     
691           integer :: lsize
692     
693           lsize = size(idata)
694     
695           idata = drecvbuf(lbuf:lbuf+lsize-1,pface)
696           lbuf = lbuf + lsize
697     
698           return
699           end subroutine unpack_db1
700     
701     
702     !----------------------------------------------------------------------!
703     ! Unpack subroutine for single integer variables                       !
704     !----------------------------------------------------------------------!
705           subroutine unpack_i0(lbuf,idata,pface)
706           use desmpi, only: dRECVBUF
707           integer, intent(inout) :: lbuf
708           integer, intent(in) :: pface
709           integer, intent(inout) :: idata
710     
711           idata = drecvbuf(lbuf,pface)
712           lbuf = lbuf + 1
713     
714           return
715           end subroutine unpack_i0
716     
717     !----------------------------------------------------------------------!
718     ! Unpack subroutine for integer arrays                                 !
719     !----------------------------------------------------------------------!
720           subroutine unpack_i1(lbuf,idata,pface)
721           use desmpi, only: dRECVBUF
722           integer, intent(inout) :: lbuf
723           integer, intent(in) :: pface
724           integer, intent(inout) :: idata(:)
725     
726           integer :: lsize
727     
728           lsize = size(idata)
729     
730           idata = drecvbuf(lbuf:lbuf+lsize-1,pface)
731           lbuf = lbuf + lsize
732     
733           return
734           end subroutine unpack_i1
735     
736     !----------------------------------------------------------------------!
737     ! Unpack subroutine for logical variables                              !
738     !----------------------------------------------------------------------!
739           subroutine unpack_l0(lbuf,idata,pface)
740           use desmpi, only: dRECVBUF
741           integer, intent(inout) :: lbuf
742           integer, intent(in) :: pface
743           logical, intent(inout) :: idata
744     
745           idata = merge(.true.,.false.,0.5<drecvbuf(lbuf,pface))
746           lbuf = lbuf + 1
747     
748           return
749           end subroutine unpack_l0
750     
751     
752           end module mpi_unpack_des
753