File: N:\mfix\model\des\mpi_comm_des_mod.f

1     !------------------------------------------------------------------------
2     ! Module           : desmpi
3     ! Purpose          : Contains wrapper class for mpi communications- send,recv
4     !
5     ! Author           : Pradeep.G
6     !
7     ! Purpose          : Module contains subroutines and variables related to
8     !                    des mpi communication.
9     !
10     ! Comments         : do_nsearch flag should be set to true before calling
11     !                    des_par_exchange; when do_nsearch is true ghost particles of the
12     !                    system will be updated, which will be later used to generate
13     !                    neighbour list.
14     
15     !------------------------------------------------------------------------
16           module mpi_comm_des
17     
18     !-----------------------------------------------
19     ! Modules
20     !-----------------------------------------------
21           use parallel_mpi
22           use mpi_utility
23           use discretelement
24           use desgrid
25           use compar
26           use physprop
27           use sendrecv
28           use des_bc
29           use desmpi_wrapper
30           use sendrecvnode
31           use mfix_pic
32           use des_thermo
33           use run, only: ENERGY_EQ,ANY_SPECIES_EQ
34           use param, only: DIMENSION_N_s
35           use des_rxns
36     
37           use desmpi
38     
39     !-----------------------------------------------
40     
41     ! generic interface definition
42           interface des_gather
43              module procedure des_gather_l,des_gather_i,des_gather_d
44           end interface
45     
46           contains
47     
48     !------------------------------------------------------------------------
49     ! Subroutine       : desmpi_sendrecv_init
50     ! Purpose          : posts asynchronous send and recv and updates the request id
51     !
52     ! Parameters       : pface - face number (1to6)
53     !                    debug - for printing debug statments
54     !------------------------------------------------------------------------
55           subroutine desmpi_sendrecv_init(pface,pdebug)
56     !-----------------------------------------------
57           implicit none
58     !-----------------------------------------------
59     ! dummy variables
60     !-----------------------------------------------
61           integer,intent(in) :: pface
62           integer,intent(in),optional :: pdebug
63     !-----------------------------------------------
64     ! local variables
65     !-----------------------------------------------
66           character(len=80), parameter :: name = 'desmpi_sendrecv_init'
67           integer :: ldebug,ltag,lerr,lrecvface
68     !-----------------------------------------------
69     
70     ! set the debug flag
71           ldebug = 0
72           if (present(pdebug)) then
73             ldebug = pdebug
74           endif
75     
76     
77     
78     !direct copy in case of single processor
79           lrecvface = pface+mod(pface,2)-mod(pface+1,2)
80     
81     
82     
83     
84           if (ineighproc(pface).eq.mype) then
85              drecvbuf(1+mod(lrecvface,2))%facebuf(1:isendcnt(pface)) = &
86                 dsendbuf(1+mod(pface,2))%facebuf(1:isendcnt(pface))
87           else
88              ltag = message_tag(ineighproc(pface),mype,pface)
89              call des_mpi_irecv(drecvbuf(1+mod(pface,2))%facebuf(:),imaxbuf, &
90                                 ineighproc(pface),ltag,irecvreq(pface),lerr)
91              call mpi_check( name //':mpi_irecv ', lerr )
92     
93              ltag = message_tag(mype,ineighproc(pface),lrecvface)
94              call des_mpi_isend(dsendbuf(1+mod(pface,2))%facebuf(:),isendcnt(pface), &
95                             ineighproc(pface),ltag,isendreq(pface),lerr)
96              call mpi_check( name //':mpi_isend ', lerr )
97     
98           end if
99           return
100     
101         contains
102     
103           integer function message_tag(lsource,ldest,lrecvface)
104             implicit none
105             integer, intent(in) :: lsource,ldest,lrecvface
106             message_tag = lsource+numpes*ldest+numpes*numpes*lrecvface+100
107           end function message_tag
108     
109         end subroutine desmpi_sendrecv_init
110     
111     !------------------------------------------------------------------------
112     ! Subroutine       : desmpi_sendrecv_wait
113     ! Purpose          : waits for the communication for the specified interface
114     !
115     ! Parameters       : pface - face number (1to6)
116     !                    debug - for printing debug statments
117     !------------------------------------------------------------------------
118           subroutine desmpi_sendrecv_wait(pface,pdebug)
119     !-----------------------------------------------
120           implicit none
121     !-----------------------------------------------
122     ! dummy variables
123     !-----------------------------------------------
124           integer,intent(in) :: pface
125           integer,intent(in),optional :: pdebug
126     !-----------------------------------------------
127     ! local variables
128     !-----------------------------------------------
129           character(len=80), parameter :: name = 'desmpi_sendrecv_wait'
130           integer :: ldebug,lerr
131     !-----------------------------------------------
132     
133     ! set the debug flag
134           ldebug = 0
135           if (present(pdebug)) then
136             ldebug = pdebug
137           endif
138     
139     ! wait for both send and recv request completes
140           if (ineighproc(pface).ne.mype) then
141              call des_mpi_wait(isendreq(pface),lerr)
142              call mpi_check( name //':mpi_wait-send', lerr )
143              call des_mpi_wait(irecvreq(pface),lerr)
144              call mpi_check( name //':mpi_wait-recv', lerr )
145           end if
146           return
147           end subroutine desmpi_sendrecv_wait
148     
149     
150     !------------------------------------------------------------------------
151     ! Subroutine       : desmpi_scatterv
152     ! Purpose          : scatters the particle from PE_IO
153     ! Parameters       : ptype - flag for datatype integer (1) or double precision (2)
154     !                    pdebug - optional flag for debugging
155     !------------------------------------------------------------------------
156           subroutine desmpi_scatterv(ptype,pdebug)
157     !-----------------------------------------------
158           implicit none
159     !-----------------------------------------------
160     ! dummy variables
161     !-----------------------------------------------
162           integer, intent(in) :: ptype
163           integer, intent(in),optional :: pdebug
164     !-----------------------------------------------
165     ! local variables
166     !-----------------------------------------------
167           integer lroot,lidebug,lerr
168           character(len=80), parameter :: name = 'desmpi_scatterv'
169     !-----------------------------------------------
170     
171           lroot = pe_io
172           if (.not. present(pdebug)) then
173              lidebug = 0
174           else
175              lidebug = pdebug
176           endif
177     
178           if (ptype .eq. 1) then
179              call des_MPI_Scatterv(irootbuf,iscattercnts,idispls, &
180                                    iprocbuf,iscr_recvcnt,lroot,lerr)
181           else
182              call des_MPI_Scatterv(drootbuf,iscattercnts,idispls, &
183                                    dprocbuf,iscr_recvcnt,lroot,lerr)
184           end if
185           call MPI_Check( name //':MPI_Scatterv', lerr )
186     
187           return
188           end subroutine desmpi_scatterv
189     
190     
191     !------------------------------------------------------------------------
192     ! Subroutine       : desmpi_gatherv
193     ! Purpose          : gathers the particle from local proc to root proc
194     ! Parameters       : ptype - flag for datatype integer (1) or double precision (2)
195     !                    pdebug - optional flag for debugging
196     !------------------------------------------------------------------------
197           subroutine desmpi_gatherv(ptype,pdebug)
198     !-----------------------------------------------
199           implicit none
200     !-----------------------------------------------
201     ! dummy variables
202     !-----------------------------------------------
203           integer, intent(in) :: ptype
204           integer, intent(in),optional :: pdebug
205     !-----------------------------------------------
206     ! local variables
207     !-----------------------------------------------
208           integer lroot,lidebug,lerr
209           character(len=80), parameter :: name = 'des_gather'
210     !-----------------------------------------------
211     
212           lroot = pe_io
213           if (.not. present(pdebug)) then
214              lidebug = 0
215           else
216              lidebug = pdebug
217           endif
218           if(ptype.eq.1) then
219              call des_MPI_Gatherv(iprocbuf,igath_sendcnt,irootbuf, &
220                                   igathercnts,idispls,lroot,lerr)
221           else
222              call des_MPI_Gatherv(dprocbuf,igath_sendcnt,drootbuf, &
223                                   igathercnts,idispls,lroot,lerr)
224           end if
225           call MPI_Check( name //':MPI_Gatherv', lerr )
226     
227           return
228           end subroutine desmpi_gatherv
229     
230     
231     !------------------------------------------------------------------------
232     ! Subroutine       : des_gather_d
233     ! Purpose          : gathers double precision array from local to root
234     ! Parameters       :
235     !                    parray - array to be writen
236     !------------------------------------------------------------------------
237           subroutine des_gather_d(parray)
238     !-----------------------------------------------
239           implicit none
240     !-----------------------------------------------
241     ! dummy variables
242     !-----------------------------------------------
243           double precision, dimension(:) :: parray
244     !-----------------------------------------------
245     ! local variables
246     !-----------------------------------------------
247           integer :: lcurpar,lparcount,lcount
248     !-----------------------------------------------
249     
250     ! pack the variables in case of
251           lparcount = 1
252           lcount = 0
253           do lcurpar = 1, max_pip
254              if (lparcount.gt.pip) exit
255              if (is_nonexistent(lcurpar)) cycle
256              lparcount = lparcount +1
257              if(is_ghost(lcurpar) .or. is_entering_ghost(lcurpar) .or. is_exiting_ghost(lcurpar)) cycle
258              lcount = lcount + 1
259              dprocbuf(lcount) = parray(lcurpar)
260           end do
261           call desmpi_gatherv(ptype=2)
262           end subroutine des_gather_d
263     
264     !------------------------------------------------------------------------
265     ! Subroutine       : des_gather_l
266     ! Purpose          : gathers logical array from local to root
267     ! Parameters       :
268     !                    parray - array to be writen
269     !------------------------------------------------------------------------
270           subroutine des_gather_l(parray)
271     !-----------------------------------------------
272           implicit none
273     !-----------------------------------------------
274     ! dummy variables
275     !-----------------------------------------------
276           logical, dimension(:) :: parray
277     !-----------------------------------------------
278     ! local variables
279     !-----------------------------------------------
280           integer :: lcurpar,lparcount,lcount
281     !-----------------------------------------------
282     
283     ! pack the variables in proc buffer
284           lparcount = 1
285           lcount = 0
286           do lcurpar = 1, max_pip
287              if (lparcount.gt.pip) exit
288              if (is_nonexistent(lcurpar)) cycle
289              lparcount = lparcount +1
290              if(is_ghost(lcurpar) .or. is_entering_ghost(lcurpar) .or. is_exiting_ghost(lcurpar)) cycle
291              lcount = lcount + 1
292              if(parray(lcurpar)) then
293                 iprocbuf(lcount) = 1
294              else
295                 iprocbuf(lcount) = 0
296              end if
297           end do
298           call desmpi_gatherv(ptype=1)
299     
300           end subroutine des_gather_l
301     
302     !------------------------------------------------------------------------
303     ! Subroutine       : des_gather_i
304     ! Purpose          : gathers integer array from local to root
305     ! Parameters       :
306     !                    parray - array to be writen
307     !                    ploc2glb - this flag is used to conver local particle
308     !                    number into global particle number (used for history
309     !                    and neighbour terms)
310     !------------------------------------------------------------------------
311           subroutine des_gather_i(parray,ploc2glb)
312     !-----------------------------------------------
313           implicit none
314     !-----------------------------------------------
315     ! dummy variables
316     !-----------------------------------------------
317           integer, dimension(:) :: parray
318           logical,optional :: ploc2glb
319     !-----------------------------------------------
320     ! local variables
321     !-----------------------------------------------
322           integer :: lcurpar,lparcount,lcount
323           logical :: lloc2glb
324     !-----------------------------------------------
325     
326           if (present(ploc2glb)) then
327              lloc2glb = ploc2glb
328           else
329              lloc2glb = .false.
330           end if
331     ! pack the variables in proc buffer
332           lparcount = 1
333           lcount = 0
334           if (lloc2glb) then
335              do lcurpar = 1, max_pip
336                 if (lparcount.gt.pip) exit
337                 if (is_nonexistent(lcurpar)) cycle
338                 lparcount = lparcount +1
339                 if(is_ghost(lcurpar) .or. is_entering_ghost(lcurpar) .or. is_exiting_ghost(lcurpar)) cycle
340                 lcount = lcount + 1
341                 if(parray(lcurpar).gt.0) then
342                    iprocbuf(lcount) = iglobal_id(parray(lcurpar))
343                 else
344                    iprocbuf(lcount) = 0
345                 end if
346              end do
347           else
348              do lcurpar = 1, max_pip
349                 if (lparcount.gt.pip) exit
350                 if (is_nonexistent(lcurpar)) cycle
351                 lparcount = lparcount +1
352                 if(is_ghost(lcurpar) .or. is_entering_ghost(lcurpar) .or. is_exiting_ghost(lcurpar)) cycle
353                 lcount = lcount + 1
354                 iprocbuf(lcount) = parray(lcurpar)
355              end do
356           end if
357           call desmpi_gatherv(ptype=1)
358     
359           end subroutine des_gather_i
360     
361           end module mpi_comm_des
362