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