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