File: RELATIVE:/../../../mfix.git/model/des/mpi_pack_des_mod.f

1     !----------------------------------------------------------------------!
2     !  Module: MPI_PACK_DES                                                !
3     !  Author: Pradeep Gopalakrishnan                                      !
4     !                                                                      !
5     !  Purpose: Contains routines for packing real and ghost particles     !
6     !     into the MPI send buffers.                                       !
7     !----------------------------------------------------------------------!
8           MODULE MPI_PACK_DES
9     
10           PRIVATE
11           PUBLIC :: DESMPI_PACK_PARCROSS, DESMPI_PACK_GHOSTPAR
12     
13           interface pack_dbuf
14             module procedure pack_db0
15             module procedure pack_db1
16             module procedure pack_i0
17             module procedure pack_i1
18             module procedure pack_l0
19           end interface pack_dbuf
20     
21           CONTAINS
22     
23     !----------------------------------------------------------------------!
24     !  Subroutine: DESMPI_PACK_GHOSTPAR                                    !
25     !  Author: Pradeep Gopalakrishnan                                      !
26     !                                                                      !
27     ! Purpose: Packs ghost particle in the send buffer.                    !
28     !----------------------------------------------------------------------!
29           SUBROUTINE DESMPI_PACK_GHOSTPAR(PFACE)
30     
31     ! Global Variables:
32     !---------------------------------------------------------------------//
33     ! Size of ghost particle packets
34           use desmpi, only: iGhostPacketSize
35     ! Flag indicating that the ghost particle was updated
36           use discretelement, only: iGHOST_UPDATED
37     ! The MPI send buffer
38           use desmpi, only: dSENDBUF
39     ! Buffer offset
40           use desmpi, only: iBUFOFFSET
41     ! Runtime flag for solving the energy equations
42           use run, only: ENERGY_EQ
43     ! The neighbor processor's rank
44           use desmpi, only: iNEIGHPROC
45     ! DES grid cell containing each particle: current/previous
46           use discretelement, only: DG_PIJKPRV
47     ! The global ID for each particle
48           use discretelement, only: iGLOBAL_ID
49     ! Particle positions: current/previous
50           use discretelement, only: DES_POS_NEW
51     ! Particle tangential velocities: current/previous
52           use discretelement, only: DES_VEL_NEW
53     ! Particle rotational velocities: current/previous
54           use discretelement, only: OMEGA_NEW
55     ! Particle tempertures. current/previous
56           use des_thermo, only: DES_T_s_NEW
57     ! Particle radius, volume
58           use discretelement, only: DES_RADIUS
59     ! Number of cells used in interpolation
60           use particle_filter, only: FILTER_SIZE
61     ! Cells and weights for interpolation
62           use particle_filter, only: FILTER_CELL, FILTER_WEIGHT
63     ! Map to fluid grid cells and solids phase (I,J,K,IJK,M)
64           use discretelement, only: PIJK
65     ! Number of particles on the process (max particle array size)
66           use discretelement, only: MAX_PIP
67     ! User-defined variables for each particle.
68           use discretelement, only: DES_USR_VAR, DES_USR_VAR_SIZE
69     ! Function to convert DES grid IJK to new proc value.
70           use desgrid, only: dg_ijkconv
71     ! Size of the send buffer
72           use desmpi, only: isendcnt
73     ! Offset for particles with cycle BCs (otherwise zero)
74           use desmpi, only: dcycl_offset
75     ! Map of particles to DES grid
76           use discretelement, only: DG_PIC
77     ! Cell number of ghost particles
78           use desmpi, only: iSENDINDICES
79     
80     ! Global Constants:
81     !---------------------------------------------------------------------//
82           use constant, only: PI
83     ! Dimension of particle spatial arrays.
84           use discretelement, only: DIMN
85           use functions, only: is_exiting
86           use functions, only: is_ghost, is_entering_ghost, is_exiting_ghost
87     
88           IMPLICIT NONE
89     
90     ! Dummy arguments:
91     !---------------------------------------------------------------------//
92     ! Processor boundary being packed (Top/Bottom/North/South/East/West)
93           INTEGER, INTENT(IN) :: PFACE
94     
95     ! Local variables
96     !---------------------------------------------------------------------//
97           integer :: lijk,lindx,ltot_ind,lpicloc,lpar_cnt,lcurpar
98           integer :: lbuf
99     !......................................................................!
100     
101           lpar_cnt = 0
102           ltot_ind = isendindices(1,pface)
103           do lindx = 2,ltot_ind+1
104              lijk = isendindices(lindx,pface)
105              do lpicloc =1,dg_pic(lijk)%isize
106                 lbuf = lpar_cnt*iGhostPacketSize + ibufoffset
107                 lcurpar = dg_pic(lijk)%p(lpicloc)
108     
109     ! Do not send particle data for a ghost particle whose owner has not yet
110     ! updated the particle's data on this processor.
111                 if((is_ghost(lcurpar) .or. &
112                     is_entering_ghost(lcurpar) .or. &
113                     is_exiting_ghost(lcurpar)) .and. &
114                     .not.ighost_updated(lcurpar)) cycle
115     
116     ! 1) Global ID
117                 call pack_dbuf(lbuf,iglobal_id(lcurpar),pface)
118     ! 2) DES grid IJK
119                 call pack_dbuf(lbuf,dg_ijkconv(lijk,pface,                 &
120                    ineighproc(pface)),pface)
121     ! 3) DES grid IJK - previous
122                 call pack_dbuf(lbuf,dg_ijkconv(dg_pijkprv(lcurpar),pface,  &
123                    ineighproc(pface)),pface)
124     ! 4) Radius
125                 call pack_dbuf(lbuf,des_radius(lcurpar),pface)
126     ! 5) Phase index
127                 call pack_dbuf(lbuf,pijk(lcurpar,5),pface)
128     ! 6) Position
129                 call pack_dbuf(lbuf,des_pos_new(:,lcurpar)+                &
130                    dcycl_offset(pface,:),pface)
131     ! 7) Translational Velocity
132                 call pack_dbuf(lbuf,des_vel_new(:,lcurpar),pface)
133     ! 8) Rotational Velocity
134                 call pack_dbuf(lbuf,omega_new(:,lcurpar),pface)
135     ! 9) Exiting particle flag
136                 call pack_dbuf(lbuf,merge(1,0,is_exiting(lcurpar).or.is_exiting_ghost(lcurpar)),pface)
137     ! 10) Temperature
138                 IF(ENERGY_EQ) &
139                    call pack_dbuf(lbuf,des_t_s_new(lcurpar),pface)
140     ! 11) User Variable
141                 IF(DES_USR_VAR_SIZE > 0) &
142                    call pack_dbuf(lbuf,des_usr_var(:,lcurpar),pface)
143     ! 12) Interpolation weights
144                 IF(FILTER_SIZE > 0) THEN
145                    call pack_dbuf(lbuf,filter_cell(:,lcurpar),pface)
146                    call pack_dbuf(lbuf,filter_weight(:,lcurpar),pface)
147                 ENDIF
148     
149                 lpar_cnt = lpar_cnt + 1
150              end do
151           end do
152           dsendbuf(1+mod(pface,2))%facebuf(1)=lpar_cnt
153           isendcnt(pface) = lpar_cnt*iGhostPacketSize + ibufoffset
154     
155           end subroutine desmpi_pack_ghostpar
156     
157     !----------------------------------------------------------------------!
158     !  Subroutine: DESMPI_PACK_PARCROSS                                    !
159     !  Author: Pradeep Gopalakrishnan                                      !
160     !                                                                      !
161     ! Purpose: Packs real particle in the send buffer.                     !
162     !----------------------------------------------------------------------!
163           SUBROUTINE DESMPI_PACK_PARCROSS(PFACE)
164     
165     ! Global Variables:
166     !---------------------------------------------------------------------//
167     ! The MPI send buffer
168           use desmpi, only: dSENDBUF
169     ! Buffer offset
170           use desmpi, only: iBUFOFFSET
171     ! Runtime flag for solving the energy equations
172           use run, only: ENERGY_EQ
173     ! Runtime flag for solving species equations
174           use run, only: ANY_SPECIES_EQ
175     ! Runtime flag for MPPIC solids
176           use mfix_pic, only: MPPIC
177     ! DES grid cell containing each particle: current/previous
178           use discretelement, only: DG_PIJKPRV
179     ! The neighbor processor's rank
180           use desmpi, only: iNEIGHPROC
181     ! The statistical weight of each particle.
182           use mfix_pic, only: DES_STAT_WT
183     ! The global ID for each particle
184           use discretelement, only: iGLOBAL_ID
185     ! Particle positions: current/previous
186           use discretelement, only: DES_POS_NEW, DES_POS_OLD
187     ! Particle tangential velocities: current/previous
188           use discretelement, only: DES_VEL_NEW, DES_VEL_OLD
189     ! Particle rotational velocities: current/previous
190           use discretelement, only: OMEGA_NEW, OMEGA_OLD
191     ! Particle orientation
192           use discretelement, only: PARTICLE_ORIENTATION,ORIENTATION
193     ! Particle radius, volume, density, mass
194           use discretelement, only: DES_RADIUS, PVOL, RO_SOL, PMASS
195     ! Previous value for particle acceleration (tangential/rotational)
196           use discretelement, only: DES_ACC_OLD, ROT_ACC_OLD
197     ! Particle species composition
198           use des_rxns, only: DES_X_s
199     ! Particle tempertures. current/previous
200           use des_thermo, only: DES_T_s_NEW, DES_T_s_OLD
201     ! Force arrays acting on the particle
202           use discretelement, only: FC, TOW
203     ! One of the moment of inertia
204           use discretelement, only: OMOI
205     ! Map to fluid grid cells and solids phase (I,J,K,IJK,M)
206           use discretelement, only: PIJK
207     ! Flag to send/recv old (previous) values
208           use discretelement, only: DO_OLD
209     ! Number of particles on the process (max particle array size)
210           use discretelement, only: PIP, MAX_PIP
211     ! Number of ghost particles on the current process
212           use discretelement, only: iGHOST_CNT
213     ! User-defined variables for each particle.
214           use discretelement, only: DES_USR_VAR, DES_USR_VAR_SIZE
215     ! Particle pair (neighborhood) arrays:
216           use discretelement, only: NEIGHBORS, NEIGHBOR_INDEX, NEIGH_NUM
217     ! Pair collision history information
218           use discretelement, only: PFT_NEIGHBOR
219     ! Dimension of particle spatial arrays.
220           use discretelement, only: DIMN
221     ! Flag indicating the the fluid-particle drag is explicitly coupled.
222           use discretelement, only: DES_EXPLICITLY_COUPLED
223     ! Explicit particle drag force
224           use discretelement, only: DRAG_FC
225     ! Cells and weights for interpolation
226           use particle_filter, only: FILTER_WEIGHT
227     
228           use desgrid, only: dg_ijkconv, icycoffset
229           use desmpi, only: dcycl_offset, isendcnt
230           use desmpi, only: irecvindices
231     
232           use desmpi, only: iParticlePacketSize
233           use desmpi, only: iPairPacketSize
234     
235           use functions
236     
237           implicit none
238     
239     ! Dummy arguments:
240     !---------------------------------------------------------------------//
241     ! Processor boundary being packed (Top/Bottom/North/South/East/West)
242           INTEGER, INTENT(IN) :: PFACE
243     
244     ! Local variables
245     !---------------------------------------------------------------------//
246           integer :: li, lj, lk
247           integer :: ltot_ind,lindx,cc
248           integer :: lneigh,lijk,&
249                      lpicloc,lparcnt,lcurpar
250           integer :: lbuf,num_neighborlists_to_send
251     
252           logical, allocatable, dimension(:) :: going_to_send
253     
254     ! Location in the buffer where the number of pair data is specified.
255           integer :: num_neighborlists_send_buf_loc
256     !......................................................................!
257     
258     ! pack the particle crossing the boundary
259           ltot_ind = irecvindices(1,pface)
260           lparcnt = 0
261     
262           allocate(going_to_send(max_pip))
263           going_to_send(:) = .false.
264     
265           do lindx = 2,ltot_ind+1
266              lijk = irecvindices(lindx,pface)
267              do lpicloc = 1,dg_pic(lijk)%isize
268                 lcurpar = dg_pic(lijk)%p(lpicloc)
269     
270     ! if ghost particle then cycle
271                 if(is_ghost(lcurpar) .or. &
272                    is_entering_ghost(lcurpar) .or. &
273                    is_exiting_ghost(lcurpar)) cycle
274     
275                 going_to_send(lcurpar) = .true.
276                 lbuf = lparcnt*iParticlePacketSize + ibufoffset
277     
278     ! 1) Global ID
279                 call pack_dbuf(lbuf,iglobal_id(lcurpar),pface)
280     ! 2) DES Grid IJK
281                 call pack_dbuf(lbuf,dg_ijkconv(lijk,pface,                 &
282                    ineighproc(pface)),pface)
283     ! 3) DES grid IJK - previous
284                 call pack_dbuf(lbuf,dg_ijkconv(dg_pijkprv(lcurpar),pface,  &
285                    ineighproc(pface)),pface)
286     ! 4) Radius
287                 call pack_dbuf(lbuf,des_radius(lcurpar),pface)
288     ! 5) Fluid cell I index with cycle offset
289                 li = pijk(lcurpar,1) + icycoffset(pface,1)
290                 call pack_dbuf(lbuf,li,pface)
291     ! 6) Fluid cell J index with cycle offset
292                 lj = pijk(lcurpar,2) + icycoffset(pface,2)
293                 call pack_dbuf(lbuf,lj,pface)
294     ! 7) Fluid cell K index with cycle offset
295                 lk = pijk(lcurpar,3) + icycoffset(pface,3)
296                 call pack_dbuf(lbuf,lk,pface)
297     ! 8) Fluid cell IJK on destination process
298                 call pack_dbuf(lbuf,funijk_proc(li,lj,lk,                  &
299                    ineighproc(pface)),pface)
300     ! 9) Particle solids phase index
301                 call pack_dbuf(lbuf,pijk(lcurpar,5),pface)
302     ! 10) Entering particle flag.
303                 call pack_dbuf(lbuf, is_entering(lcurpar).or.is_entering_ghost(lcurpar), pface)
304     ! 11) Exiting particle flag.
305                 call pack_dbuf(lbuf, is_exiting(lcurpar).or.is_exiting_ghost(lcurpar), pface)
306     ! 12) Density
307                 call pack_dbuf(lbuf,ro_sol(lcurpar),pface)
308     ! 13) Volume
309                 call pack_dbuf(lbuf,pvol(lcurpar),pface)
310     ! 14) Mass
311                 call pack_dbuf(lbuf,pmass(lcurpar),pface)
312     ! 15) 1/Moment of Inertia
313                 call pack_dbuf(lbuf,omoi(lcurpar),pface)
314     ! 16) Position with cyclic shift
315                 call pack_dbuf(lbuf,des_pos_new(:,lcurpar) +               &
316                    dcycl_offset(pface,:),pface)
317     ! 17) Translational velocity
318                 call pack_dbuf(lbuf,des_vel_new(:,lcurpar),pface)
319     ! 18) Rotational velocity
320                 call pack_dbuf(lbuf,omega_new(:,lcurpar),pface)
321     ! 19) Accumulated translational forces
322                 call pack_dbuf(lbuf,fc(:,lcurpar),pface)
323     ! 20) Accumulated torque forces
324                 call pack_dbuf(lbuf,tow(:,lcurpar),pface)
325     ! 21) Temperature
326                 IF(ENERGY_EQ) &
327                    call pack_dbuf(lbuf,des_t_s_new(lcurpar),pface)
328     ! 22) Species composition
329                 IF(ANY_SPECIES_EQ) &
330                    call pack_dbuf(lbuf,des_x_s(lcurpar,:),pface)
331     ! 23) Explicit drag force
332                 IF(DES_EXPLICITLY_COUPLED) &
333                    call pack_dbuf(lbuf, drag_fc(:,lcurpar),pface)
334     ! 24) User defined variable
335                 IF(DES_USR_VAR_SIZE > 0) &
336                    call pack_dbuf(lbuf, des_usr_var(:,lcurpar),pface)
337     ! 25) Particle orientation
338                 IF(PARTICLE_ORIENTATION) &
339                    call pack_dbuf(lbuf,orientation(:,lcurpar),pface)
340     
341     ! -- Higher order integration variables
342                 IF (DO_OLD) THEN
343     ! 26) Position (previous)
344                    call pack_dbuf(lbuf,des_pos_old(:,lcurpar) +            &
345                       dcycl_offset(pface,:),pface)
346     ! 27) Translational velocity (previous)
347                    call pack_dbuf(lbuf,des_vel_old(:,lcurpar),pface)
348     ! 28) Rotational velocity (previous)
349                    call pack_dbuf(lbuf,omega_old(:,lcurpar),pface)
350     ! 29) Translational acceleration (previous)
351                    call pack_dbuf(lbuf,des_acc_old(:,lcurpar),pface)
352     ! 30) Rotational acceleration (previous)
353                    call pack_dbuf(lbuf,rot_acc_old(:,lcurpar),pface)
354     ! 31) Temperature (previous)
355                    IF(ENERGY_EQ) &
356                       call pack_dbuf(lbuf,des_t_s_old(lcurpar),pface)
357                 ENDIF
358     
359     ! PIC particles are removed and the number of particles on the processor
360     ! is decremented.
361                 IF (MPPIC) THEN
362     ! 32) Statistical weight
363                    call pack_dbuf(lbuf,des_stat_wt(lcurpar),pface)
364                    call set_nonexistent(lcurpar)
365                    pip = pip - 1
366     
367     ! DEM particles are converted to ghost particles. This action does not
368     ! change the number of particles.
369                 ELSE
370                    if (is_entering(lcurpar)) then
371                       call set_entering_ghost(lcurpar)
372                    elseif (is_exiting(lcurpar)) then
373                       call set_exiting_ghost(lcurpar)
374                    else
375                       call set_ghost(lcurpar)
376                    endif
377                    ighost_cnt = ighost_cnt + 1
378                 END IF
379     
380     ! Clear out the force array.
381                 fc(:,lcurpar) = 0.
382                 lparcnt = lparcnt + 1
383              end do
384           end do
385     
386     ! Calculate the location in buffer where the number of pair data is
387     ! stored and skip specifying the entry. After all the pair data is
388     ! packed, then this value is set.
389           lbuf = lparcnt*iParticlePacketSize + ibufoffset
390           num_neighborlists_send_buf_loc = lbuf
391           lbuf = lbuf+1
392     
393            num_neighborlists_to_send = 0
394            lcurpar = 1
395            do cc = 1, NEIGH_NUM
396               IF (0 .eq. NEIGHBORS(cc)) EXIT
397     
398               IF (cc.eq.NEIGHBOR_INDEX(lcurpar)) THEN
399                  lcurpar = lcurpar + 1
400               ENDIF
401     
402     ! Only packup pairing data for particles being transfered.
403               if (.not. going_to_send(lcurpar)) cycle
404     
405     ! Do not send pairing data if the pair no longer exists or if the
406     ! particle is exiting as it may be locatable during unpacking.
407               lneigh = neighbors(lcurpar)
408               if(is_nonexistent(lneigh)) cycle
409               if(is_exiting(lneigh)) cycle
410     
411     ! 34) Global ID of particle being packed.
412               call pack_dbuf(lbuf,iglobal_id(lcurpar),pface)
413     ! 35) DES grid IJK of cell receiving the particle.
414               call pack_dbuf(lbuf,dg_ijkconv(dg_pijkprv(lcurpar),pface,    &
415                    ineighproc(pface)),pface)
416     ! 36) Global ID of neighbor particle.
417               call pack_dbuf(lbuf,iglobal_id(lneigh),pface)
418     ! 37) DES grid IJK of cell containing the neighbor particle.
419               call pack_dbuf(lbuf,dg_ijkconv(dg_pijkprv(lneigh),pface,     &
420                    ineighproc(pface)),pface)
421     ! 38) Tangential collision history.
422               call pack_dbuf(lbuf,PFT_NEIGHBOR(:,CC),pface) 
423     ! Increment the number of pairs being sent.
424               num_neighborlists_to_send = num_neighborlists_to_send + 1
425            enddo
426     
427     ! Store the number of pair datasets being sent. This information is
428     ! stored before the pairing data so the receiving process knows the
429     ! amount of data to 'unpack.'
430           lbuf = num_neighborlists_send_buf_loc
431     ! 33) Number of pair datasets.
432           call pack_dbuf(lbuf,num_neighborlists_to_send,pface)
433     
434           dsendbuf(1+mod(pface,2))%facebuf(1) = lparcnt
435           isendcnt(pface) = lparcnt*iParticlePacketSize +                  &
436              num_neighborlists_to_send*iPairPacketSize + ibufoffset + 3
437     
438           deallocate(going_to_send)
439     
440           RETURN
441           END SUBROUTINE DESMPI_PACK_PARCROSS
442     
443     !----------------------------------------------------------------------!
444     ! PACK SUBROUTINE FOR SINGLE REAL VARIABLES                            !
445     !----------------------------------------------------------------------!
446           subroutine pack_db0(lbuf,idata,pface)
447           use desmpi, only: dSENDBUF
448           integer, intent(inout) :: lbuf
449           integer, intent(in) :: pface
450           double precision, intent(in) :: idata
451     
452           dsendbuf(1+mod(pface,2))%facebuf(lbuf) = idata
453           lbuf = lbuf + 1
454     
455           return
456           end subroutine pack_db0
457     
458     !----------------------------------------------------------------------!
459     ! Pack subroutine for real arrays                                      !
460     !----------------------------------------------------------------------!
461           subroutine pack_db1(lbuf,idata,pface)
462           use desmpi, only: dSENDBUF
463           integer, intent(inout) :: lbuf
464           integer, intent(in) :: pface
465           double precision, intent(in) :: idata(:)
466     
467           integer :: lsize
468     
469           lsize = size(idata)
470     
471           dsendbuf(1+mod(pface,2))%facebuf(lbuf:lbuf+lsize-1) = idata
472           lbuf = lbuf + lsize
473     
474           return
475           end subroutine pack_db1
476     
477     !----------------------------------------------------------------------!
478     ! Pack subroutine for single integer variables                         !
479     !----------------------------------------------------------------------!
480           subroutine pack_i0(lbuf,idata,pface)
481           use desmpi, only: dSENDBUF
482           integer, intent(inout) :: lbuf
483           integer, intent(in) :: pface
484           integer, intent(in) :: idata
485     
486           dsendbuf(1+mod(pface,2))%facebuf(lbuf) = idata
487           lbuf = lbuf + 1
488     
489           return
490           end subroutine pack_i0
491     
492     !----------------------------------------------------------------------!
493     ! Pack subroutine for integer arrays                                   !
494     !----------------------------------------------------------------------!
495           subroutine pack_i1(lbuf,idata,pface)
496           use desmpi, only: dSENDBUF
497           integer, intent(inout) :: lbuf
498           integer, intent(in) :: pface
499           integer, intent(in) :: idata(:)
500     
501           integer :: lsize
502     
503           lsize = size(idata)
504     
505           dsendbuf(1+mod(pface,2))%facebuf(lbuf:lbuf+lsize-1) = idata
506           lbuf = lbuf + lsize
507     
508           return
509           end subroutine pack_i1
510     
511     !----------------------------------------------------------------------!
512     ! Pack subroutine for logical scalars                                  !
513     !----------------------------------------------------------------------!
514           subroutine pack_l0(lbuf,ldata,pface)
515           use desmpi, only: dSENDBUF
516     
517           integer, intent(inout) :: lbuf
518           integer, intent(in) :: pface
519           logical, intent(in) :: ldata
520     
521           dsendbuf(1+mod(pface,2))%facebuf(lbuf) = merge(1.0, 0.0, ldata)
522           lbuf = lbuf + 1
523     
524           return
525           end subroutine pack_l0
526     
527           end module mpi_pack_des
528