Line data Source code
1 : !{\src2tex{textfont=tt}}
2 : !!****f* ABINIT/xmpi_gatherv
3 : !! NAME
4 : !! xmpi_gatherv
5 : !!
6 : !! FUNCTION
7 : !! This module contains functions that calls MPI routine,
8 : !! if we compile the code using the MPI CPP flags.
9 : !! xmpi_gatherv is the generic function.
10 : !!
11 : !! COPYRIGHT
12 : !! Copyright (C) 2001-2026 ABINIT group (MT,GG)
13 : !! This file is distributed under the terms of the
14 : !! GNU General Public License, see ~ABINIT/COPYING
15 : !! or http://www.gnu.org/copyleft/gpl.txt .
16 : !!
17 : !! SOURCE
18 :
19 : !!***
20 :
21 : !!****f* ABINIT/xmpi_gatherv_int
22 : !! NAME
23 : !! xmpi_gatherv_int
24 : !!
25 : !! FUNCTION
26 : !! Gathers data from all tasks and delivers it to all.
27 : !! Target: one-dimensional integer arrays.
28 : !!
29 : !! INPUTS
30 : !! xval= buffer array
31 : !! recvcounts= number of received elements
32 : !! displs= relative offsets for incoming data
33 : !! nelem= number of elements
34 : !! root= rank of receiving process
35 : !! comm= MPI communicator
36 : !!
37 : !! OUTPUT
38 : !! ier= exit status, a non-zero value meaning there is an error
39 : !!
40 : !! SIDE EFFECTS
41 : !! recvbuf= received buffer
42 : !!
43 : !! SOURCE
44 :
45 884 : subroutine xmpi_gatherv_int(xval,nelem,recvbuf,recvcounts,displs,root,comm,ier)
46 :
47 : !Arguments-------------------------
48 : integer, DEV_CONTARRD intent(in) :: xval(:)
49 : integer, DEV_CONTARRD intent(inout) :: recvbuf(:)
50 : integer, DEV_CONTARRD intent(in) :: recvcounts(:),displs(:)
51 : integer,intent(in) :: nelem,root,comm
52 : integer,intent(out) :: ier
53 :
54 : !Local variables-------------------
55 : integer :: cc,dd
56 :
57 : ! *************************************************************************
58 :
59 884 : ier=0
60 : #if defined HAVE_MPI
61 884 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
62 : call MPI_gatherV(xval,nelem,MPI_INTEGER,recvbuf,recvcounts,displs,&
63 884 : & MPI_INTEGER,root,comm,ier)
64 0 : else if (comm == MPI_COMM_SELF) then
65 : #endif
66 0 : dd=0;if (size(displs)>0) dd=displs(1)
67 0 : cc=size(xval);if (size(recvcounts)>0) cc=recvcounts(1)
68 0 : recvbuf(dd+1:dd+cc)=xval(1:cc)
69 : #if defined HAVE_MPI
70 : end if
71 : #endif
72 :
73 884 : end subroutine xmpi_gatherv_int
74 : !!***
75 :
76 : !!****f* ABINIT/xmpi_gatherv_int1_dp1
77 : !! NAME
78 : !! xmpi_gatherv_int1_dp1
79 : !!
80 : !! FUNCTION
81 : !! Gathers data from all tasks and delivers it to all.
82 : !! Target : one-dimensional integer arrray and one-dimensionnal dp array
83 : !!
84 : !! INPUTS
85 : !! buf_int=buffer integer array that is going to be gathered
86 : !! buf_int_size=size of buf_int array
87 : !! buf_dp=buffer dp array that is going to be gathered
88 : !! buf_dp_size=size of buf_dp array
89 : !! comm=MPI communicator to be gathered on it
90 : !! root=rank of receiving process
91 : !! comm=MPI communicator
92 : !!
93 : !! OUTPUT
94 : !! buf_int_all=buffer integer array gathered
95 : !! buf_int_size_all=size of buffer integer array gathered
96 : !! buf_dp_all=buffer dp array gathered
97 : !! buf_dp_size_all=size of buffer dp array gathered
98 : !! ier=exit status, a non-zero value meaning there is an error
99 : !!
100 : !! SOURCE
101 :
102 0 : subroutine xmpi_gatherv_int1_dp1(buf_int,buf_int_size,buf_dp,buf_dp_size, &
103 : & buf_int_all,buf_int_size_all,buf_dp_all,buf_dp_size_all,root,&
104 : & comm,ier)
105 :
106 : !Arguments-------------------------
107 : !scalars
108 : integer,intent(in) :: buf_int_size,buf_dp_size,root,comm
109 : integer,intent(out) :: buf_int_size_all,buf_dp_size_all,ier
110 : !arrays
111 : integer,intent(in) :: buf_int(:)
112 : integer,allocatable,target,intent(out) :: buf_int_all(:)
113 : real(dp),intent(in) :: buf_dp(:)
114 : real(dp),allocatable,target, intent(out) :: buf_dp_all(:)
115 :
116 : !Local variables--------------
117 : !scalars
118 : integer :: buf_pack_size,ierr,ii,iproc,istart_dp,istart_int
119 : integer :: lg,lg1,lg2,lg_int,lg_dp,me,nproc,position
120 : integer :: totalbufcount
121 : logical,parameter :: use_pack=.false.
122 : !arrays
123 : integer :: buf_size(2),pos(3)
124 0 : integer,allocatable :: buf_dp_size1(:),buf_int_size1(:)
125 0 : integer,allocatable :: count_dp(:),count_int(:),count_size(:),counts(:)
126 0 : integer,allocatable :: disp_dp(:),disp_int(:),displ(:),displ_dp(:),displ_int(:)
127 0 : integer,allocatable :: pos_all(:)
128 0 : integer,pointer:: outbuf_int(:)
129 0 : real(dp),pointer :: outbuf_dp(:)
130 0 : character,allocatable :: buf_pack(:),buf_pack_tot(:)
131 :
132 : ! *************************************************************************
133 :
134 0 : ier=0
135 :
136 : #if defined HAVE_MPI
137 0 : if (comm/=MPI_COMM_SELF.and.comm/=MPI_COMM_NULL) then
138 :
139 0 : nproc=xmpi_comm_size(comm)
140 :
141 : !First version: using 2 allgather (one for ints, another for reals)
142 : !------------------------------------------------------------------
143 : if (.not.use_pack) then
144 :
145 : ! Prepare communications
146 0 : ABI_MALLOC(count_int,(nproc))
147 0 : ABI_MALLOC(disp_int,(nproc))
148 0 : ABI_MALLOC(count_dp,(nproc))
149 0 : ABI_MALLOC(disp_dp,(nproc))
150 0 : ABI_MALLOC(count_size,(2*nproc))
151 0 : buf_size(1)=buf_int_size;buf_size(2)=buf_dp_size
152 0 : call xmpi_allgather(buf_size,2, count_size,comm,ier)
153 0 : do iproc=1,nproc
154 0 : count_int(iproc)=count_size(2*iproc-1)
155 0 : count_dp(iproc)=count_size(2*iproc)
156 : end do
157 0 : disp_int(1)=0;disp_dp(1)=0
158 0 : do ii=2,nproc
159 0 : disp_int(ii)=disp_int(ii-1)+count_int(ii-1)
160 0 : disp_dp (ii)=disp_dp (ii-1)+count_dp (ii-1)
161 : end do
162 0 : buf_int_size_all=sum(count_int)
163 0 : buf_dp_size_all =sum(count_dp)
164 0 : ABI_STAT_MALLOC(buf_int_all,(buf_int_size_all), ier)
165 0 : if (ier/= 0) call xmpi_abort(msg='error allocating buf_int_all in xmpi_gatherv')
166 0 : ABI_STAT_MALLOC(buf_dp_all ,(buf_dp_size_all), ier)
167 0 : if (ier/= 0) call xmpi_abort(msg='error allocating buf_dp_all in xmpi_gatherv')
168 :
169 : ! Communicate (one call for integers, one call for reals)
170 0 : call xmpi_gatherv(buf_int,buf_int_size,buf_int_all,count_int,disp_int,root,comm,ierr)
171 0 : call xmpi_gatherv(buf_dp,buf_dp_size,buf_dp_all,count_dp,disp_dp,root,comm,ierr)
172 :
173 : ! Release the memory
174 0 : ABI_FREE(count_int)
175 0 : ABI_FREE(disp_int)
176 0 : ABI_FREE(count_dp)
177 0 : ABI_FREE(disp_dp)
178 0 : ABI_FREE(count_size)
179 :
180 : !2nd version: using 1 allgather (with MPI_PACK)
181 : !-----------------------------------------------------------------
182 : else
183 :
184 : me=xmpi_comm_rank(comm)
185 :
186 : ! Compute size of message
187 : call MPI_PACK_SIZE(buf_int_size,MPI_INTEGER,comm,lg1,ier)
188 : call MPI_PACK_SIZE(buf_dp_size,MPI_DOUBLE_PRECISION,comm,lg2,ier)
189 : lg=lg1+lg2
190 :
191 : ! Pack data to be sent
192 : position=0;buf_pack_size=lg1+lg2
193 : ABI_STAT_MALLOC(buf_pack,(buf_pack_size), ier)
194 : if (ier/= 0) call xmpi_abort(msg='error allocating buf_pack xmpi_gatherv')
195 : call MPI_PACK(buf_int,buf_int_size,MPI_INTEGER,buf_pack,buf_pack_size,position,comm,ier)
196 : call MPI_PACK(buf_dp,buf_dp_size,MPI_DOUBLE_PRECISION,buf_pack,buf_pack_size,position,comm,ier)
197 :
198 : ! Gather size of all packed messages
199 : ABI_MALLOC(pos_all,(nproc*3))
200 : ABI_MALLOC(counts,(nproc))
201 : ABI_MALLOC(buf_int_size1,(nproc))
202 : ABI_MALLOC(buf_dp_size1,(nproc))
203 : ABI_MALLOC(displ,(nproc))
204 : ABI_MALLOC(displ_int,(nproc))
205 : ABI_MALLOC(displ_dp,(nproc))
206 : pos(1)=position;pos(2)=buf_int_size;pos(3)=buf_dp_size
207 : call MPI_ALLGATHER(pos,3,MPI_INTEGER,pos_all,3,MPI_INTEGER,comm,ier)
208 : ii=1
209 : do iproc=1,nproc
210 : counts(iproc)=pos_all(ii);ii=ii+1
211 : buf_int_size1(iproc)=pos_all(ii);ii=ii+1
212 : buf_dp_size1(iproc)=pos_all(ii);ii=ii+1
213 : end do
214 :
215 : displ(1)=0 ; displ_int(1)=0 ; displ_dp(1)=0
216 : do iproc=2,nproc
217 : displ(iproc)=displ(iproc-1)+counts(iproc-1)
218 : displ_int(iproc)=displ_int(iproc-1)+buf_int_size1(iproc-1)
219 : displ_dp(iproc)=displ_dp(iproc-1)+buf_dp_size1(iproc-1)
220 : end do
221 :
222 : totalbufcount=displ(nproc)+counts(nproc)
223 : ABI_STAT_MALLOC(buf_pack_tot,(totalbufcount), ier)
224 : if (ier/= 0) call xmpi_abort(msg='error allocating buf_pack_tot in xmpi_gatherv')
225 : buf_int_size_all=sum(buf_int_size1)
226 : buf_dp_size_all=sum(buf_dp_size1)
227 :
228 : if (me==root) then
229 : ABI_STAT_MALLOC(buf_int_all,(buf_int_size_all), ier)
230 : if (ier/= 0) call xmpi_abort(msg='error allocating buf_int_all in xmpi_gatherv')
231 : ABI_STAT_MALLOC(buf_dp_all,(buf_dp_size_all), ier)
232 : if (ier/= 0) call xmpi_abort(msg='error allocating buf_int_all in xmpi_gatherv')
233 : else
234 : ABI_STAT_MALLOC(buf_int_all,(1), ier)
235 : if (ier/= 0) call xmpi_abort(msg='error allocating buf_int_all in xmpi_gatherv')
236 : ABI_STAT_MALLOC(buf_dp_all,(1), ier)
237 : if (ier/= 0) call xmpi_abort(msg='error allocating buf_int_all in xmpi_gatherv')
238 : end if
239 :
240 : ! Gather all packed messages
241 : call MPI_GATHERV(buf_pack,position,MPI_PACKED,buf_pack_tot,counts,displ,MPI_PACKED,root,comm,ier)
242 : if (me==root) then
243 : position=0
244 : do iproc=1,nproc
245 : lg_int=buf_int_size1(iproc); lg_dp=buf_dp_size1(iproc)
246 : istart_int=displ_int(iproc); istart_dp=displ_dp(iproc)
247 : outbuf_int=>buf_int_all(istart_int+1:istart_int+lg_int)
248 : call MPI_UNPACK(buf_pack_tot,totalbufcount,position, outbuf_int, &
249 : & lg_int, MPI_INTEGER,comm,ier)
250 : outbuf_dp=>buf_dp_all(istart_dp+1:istart_dp+lg_dp)
251 : call MPI_UNPACK(buf_pack_tot,totalbufcount,position,outbuf_dp, &
252 : & lg_dp, MPI_DOUBLE_PRECISION,comm,ier)
253 : end do
254 : end if
255 :
256 : ! Release the memory
257 : ABI_FREE(pos_all)
258 : ABI_FREE(counts)
259 : ABI_FREE(buf_int_size1)
260 : ABI_FREE(buf_dp_size1)
261 : ABI_FREE(displ)
262 : ABI_FREE(displ_int)
263 : ABI_FREE(displ_dp)
264 : ABI_FREE(buf_pack_tot)
265 : ABI_FREE(buf_pack)
266 :
267 : end if
268 0 : else if (comm == MPI_COMM_SELF) then
269 : #endif
270 :
271 : !Sequential version
272 0 : ABI_STAT_MALLOC(buf_int_all,(buf_int_size), ier)
273 0 : if (ier/= 0) call xmpi_abort(msg='error allocating buf_int_all in xmpi_gatherv')
274 0 : ABI_STAT_MALLOC(buf_dp_all,(buf_dp_size), ier)
275 0 : if (ier/= 0) call xmpi_abort(msg='error allocating buf_dp_all in xmpi_gatherv')
276 0 : buf_int_all(:)=buf_int(:)
277 0 : buf_dp_all(:)=buf_dp(:)
278 0 : buf_int_size_all=buf_int_size
279 0 : buf_dp_size_all=buf_dp_size
280 :
281 : #if defined HAVE_MPI
282 : end if
283 : #endif
284 :
285 0 : end subroutine xmpi_gatherv_int1_dp1
286 : !!***
287 :
288 : !!****f* ABINIT/xmpi_gatherv_int2d
289 : !! NAME
290 : !! xmpi_gatherv_int2d
291 : !!
292 : !! FUNCTION
293 : !! This module contains functions that calls MPI routine,
294 : !! if we compile the code using the MPI CPP flags.
295 : !! xmpi_gatherv is the generic function.
296 : !!
297 : !! INPUTS
298 : !! xval= buffer array
299 : !! recvcounts= number of received elements
300 : !! displs= relative offsets for incoming data
301 : !! nelem= number of elements
302 : !! root= rank of receiving process
303 : !! comm= MPI communicator
304 : !!
305 : !! OUTPUT
306 : !! ier= exit status, a non-zero value meaning there is an error
307 : !!
308 : !! SIDE EFFECTS
309 : !! recvbuf= received buffer
310 : !!
311 : !! SOURCE
312 :
313 44 : subroutine xmpi_gatherv_int2d(xval,nelem,recvbuf,recvcounts,displs,root,comm,ier)
314 :
315 : !Arguments-------------------------
316 : integer, DEV_CONTARRD intent(in) :: xval(:,:)
317 : integer, DEV_CONTARRD intent(inout) :: recvbuf(:,:)
318 : integer, DEV_CONTARRD intent(in) :: recvcounts(:),displs(:)
319 : integer,intent(in) :: nelem,root,comm
320 : integer,intent(out) :: ier
321 :
322 : !Local variables--------------
323 : integer :: cc,dd,sz1
324 :
325 : ! *************************************************************************
326 :
327 44 : ier=0
328 : #if defined HAVE_MPI
329 44 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
330 : call MPI_gatherV(xval,nelem,MPI_INTEGER,recvbuf,recvcounts,displs,&
331 44 : & MPI_INTEGER,root,comm,ier)
332 0 : else if (comm == MPI_COMM_SELF) then
333 : #endif
334 0 : sz1=size(xval,1)
335 0 : dd=0;if (size(displs)>0) dd=displs(1)/sz1
336 0 : cc=size(xval,2);if (size(recvcounts)>0) cc=recvcounts(1)/sz1
337 0 : recvbuf(:,dd+1:dd+cc)=xval(:,1:cc)
338 : #if defined HAVE_MPI
339 : end if
340 : #endif
341 :
342 44 : end subroutine xmpi_gatherv_int2d
343 : !!***
344 :
345 : !!****f* ABINIT/xmpi_gatherv_dp
346 : !! NAME
347 : !! xmpi_gatherv_dp
348 : !!
349 : !! FUNCTION
350 : !! Gathers data from all tasks and delivers it to all.
351 : !! Target: one-dimensional double precision arrays.
352 : !!
353 : !! INPUTS
354 : !! xval= buffer array
355 : !! recvcounts= number of received elements
356 : !! displs= relative offsets for incoming data
357 : !! nelem= number of elements
358 : !! root= rank of receiving process
359 : !! comm= MPI communicator
360 : !!
361 : !! OUTPUT
362 : !! ier= exit status, a non-zero value meaning there is an error
363 : !!
364 : !! SIDE EFFECTS
365 : !! recvbuf= received buffer
366 : !!
367 : !! SOURCE
368 :
369 5990 : subroutine xmpi_gatherv_dp(xval,nelem,recvbuf,recvcounts,displs,root,comm,ier)
370 :
371 : !Arguments-------------------------
372 : real(dp), DEV_CONTARRD intent(in) :: xval(:)
373 : real(dp), DEV_CONTARRD intent(inout) :: recvbuf(:)
374 : integer, DEV_CONTARRD intent(in) :: recvcounts(:),displs(:)
375 : integer,intent(in) :: nelem,root,comm
376 : integer,intent(out) :: ier
377 :
378 : !Local variables--------------
379 : integer :: cc,dd
380 :
381 : ! *************************************************************************
382 :
383 5990 : ier=0
384 : #if defined HAVE_MPI
385 5990 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
386 : call MPI_gatherV(xval,nelem,MPI_DOUBLE_PRECISION,recvbuf,recvcounts,displs,&
387 5990 : & MPI_DOUBLE_PRECISION,root,comm,ier)
388 0 : else if (comm == MPI_COMM_SELF) then
389 : #endif
390 0 : dd=0;if (size(displs)>0) dd=displs(1)
391 0 : cc=size(xval);if (size(recvcounts)>0) cc=recvcounts(1)
392 0 : recvbuf(dd+1:dd+cc)=xval(1:cc)
393 : #if defined HAVE_MPI
394 : end if
395 : #endif
396 :
397 5990 : end subroutine xmpi_gatherv_dp
398 : !!***
399 :
400 : !!****f* ABINIT/xmpi_gatherv_dp2d
401 : !! NAME
402 : !! xmpi_gatherv_dp2d
403 : !!
404 : !! FUNCTION
405 : !! Gathers data from all tasks and delivers it to all.
406 : !! Target: double precision two-dimensional arrays.
407 : !!
408 : !! INPUTS
409 : !! xval= buffer array
410 : !! recvcounts= number of received elements
411 : !! displs= relative offsets for incoming data
412 : !! nelem= number of elements
413 : !! root= rank of receiving process
414 : !! comm= MPI communicator
415 : !!
416 : !! OUTPUT
417 : !! ier= exit status, a non-zero value meaning there is an error
418 : !!
419 : !! SIDE EFFECTS
420 : !! recvbuf= received buffer
421 : !!
422 : !! SOURCE
423 :
424 0 : subroutine xmpi_gatherv_dp2d(xval,nelem,recvbuf,recvcounts,displs,root,comm,ier)
425 :
426 : !Arguments-------------------------
427 : real(dp), DEV_CONTARRD intent(in) :: xval(:,:)
428 : real(dp), DEV_CONTARRD intent(inout) :: recvbuf(:,:)
429 : integer, DEV_CONTARRD intent(in) :: recvcounts(:),displs(:)
430 : integer,intent(in) :: nelem,root,comm
431 : integer,intent(out) :: ier
432 :
433 : !Local variables--------------
434 : integer :: cc,dd,sz1
435 :
436 : ! *************************************************************************
437 :
438 0 : ier=0
439 : #if defined HAVE_MPI
440 0 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
441 : call MPI_gatherV(xval,nelem,MPI_DOUBLE_PRECISION,recvbuf,recvcounts,displs,&
442 0 : & MPI_DOUBLE_PRECISION,root,comm,ier)
443 0 : else if (comm == MPI_COMM_SELF) then
444 : #endif
445 0 : sz1=size(xval,1)
446 0 : dd=0;if (size(displs)>0) dd=displs(1)/sz1
447 0 : cc=size(xval,2);if (size(recvcounts)>0) cc=recvcounts(1)/sz1
448 0 : recvbuf(:,dd+1:dd+cc)=xval(:,1:cc)
449 : #if defined HAVE_MPI
450 : end if
451 : #endif
452 :
453 0 : end subroutine xmpi_gatherv_dp2d
454 : !!***
455 :
456 : !!****f* ABINIT/xmpi_gatherv_dp3d
457 : !! NAME
458 : !! xmpi_gatherv_dp3d
459 : !!
460 : !! FUNCTION
461 : !! Gathers data from all tasks and delivers it to all.
462 : !! Target: double precision three-dimensional arrays.
463 : !!
464 : !! INPUTS
465 : !! xval= buffer array
466 : !! recvcounts= number of received elements
467 : !! displs= relative offsets for incoming data
468 : !! nelem= number of elements
469 : !! root= rank of receiving process
470 : !! comm= MPI communicator
471 : !!
472 : !! OUTPUT
473 : !! ier= exit status, a non-zero value meaning there is an error
474 : !!
475 : !! SIDE EFFECTS
476 : !! recvbuf= received buffer
477 : !!
478 : !! SOURCE
479 :
480 0 : subroutine xmpi_gatherv_dp3d(xval,nelem,recvbuf,recvcounts,displs,root,comm,ier)
481 :
482 : !Arguments-------------------------
483 : real(dp), DEV_CONTARRD intent(in) :: xval(:,:,:)
484 : real(dp), DEV_CONTARRD intent(inout) :: recvbuf(:,:,:)
485 : integer, DEV_CONTARRD intent(in) :: recvcounts(:),displs(:)
486 : integer,intent(in) :: nelem,root,comm
487 : integer,intent(out) :: ier
488 :
489 : !Local variables--------------
490 : integer :: cc,dd,sz12
491 :
492 : ! *************************************************************************
493 :
494 0 : ier=0
495 : #if defined HAVE_MPI
496 0 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
497 : call MPI_gatherV(xval,nelem,MPI_DOUBLE_PRECISION,recvbuf,recvcounts,displs,&
498 0 : & MPI_DOUBLE_PRECISION,root,comm,ier)
499 0 : else if (comm == MPI_COMM_SELF) then
500 : #endif
501 0 : sz12=size(xval,1)*size(xval,2)
502 0 : dd=0;if (size(displs)>0) dd=displs(1)/sz12
503 0 : cc=size(xval,3);if (size(recvcounts)>0) cc=recvcounts(1)/sz12
504 0 : recvbuf(:,:,dd+1:dd+cc)=xval(:,:,1:cc)
505 : #if defined HAVE_MPI
506 : end if
507 : #endif
508 :
509 0 : end subroutine xmpi_gatherv_dp3d
510 : !!***
511 :
512 : !!****f* ABINIT/xmpi_gatherv_dp4d
513 : !! NAME
514 : !! xmpi_gatherv_dp4d
515 : !!
516 : !! FUNCTION
517 : !! Gathers data from all tasks and delivers it to all.
518 : !! Target: double precision four-dimensional arrays.
519 : !!
520 : !! INPUTS
521 : !! xval= buffer array
522 : !! recvcounts= number of received elements
523 : !! displs= relative offsets for incoming data
524 : !! nelem= number of elements
525 : !! root= rank of receiving process
526 : !! comm= MPI communicator
527 : !!
528 : !! OUTPUT
529 : !! ier= exit status, a non-zero value meaning there is an error
530 : !!
531 : !! SIDE EFFECTS
532 : !! recvbuf= received buffer
533 : !!
534 : !! SOURCE
535 :
536 6 : subroutine xmpi_gatherv_dp4d(xval,nelem,recvbuf,recvcounts,displs,root,comm,ier)
537 :
538 : !Arguments-------------------------
539 : real(dp), DEV_CONTARRD intent(in) :: xval(:,:,:,:)
540 : real(dp), DEV_CONTARRD intent(inout) :: recvbuf(:,:,:,:)
541 : integer, DEV_CONTARRD intent(in) :: recvcounts(:),displs(:)
542 : integer,intent(in) :: nelem,root,comm
543 : integer,intent(out) :: ier
544 :
545 : !Local variables-------------------
546 : integer :: cc,dd,sz123
547 :
548 : ! *************************************************************************
549 :
550 6 : ier=0
551 : #if defined HAVE_MPI
552 6 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
553 : call MPI_gatherV(xval,nelem,MPI_DOUBLE_PRECISION,recvbuf,recvcounts,displs,&
554 6 : & MPI_DOUBLE_PRECISION,root,comm,ier)
555 0 : else if (comm == MPI_COMM_SELF) then
556 : #endif
557 0 : sz123=size(xval,1)*size(xval,2)*size(xval,3)
558 0 : dd=0;if (size(displs)>0) dd=displs(1)/sz123
559 0 : cc=size(xval,4);if (size(recvcounts)>0) cc=recvcounts(1)/sz123
560 0 : recvbuf(:,:,:,dd+1:dd+cc)=xval(:,:,:,1:cc)
561 : #if defined HAVE_MPI
562 : end if
563 : #endif
564 :
565 6 : end subroutine xmpi_gatherv_dp4d
566 : !!***
567 :
568 : !!****f* ABINIT/xmpi_gatherv_dp5d
569 : !! NAME
570 : !! xmpi_gatherv_dp5d
571 : !!
572 : !! FUNCTION
573 : !! Gathers data from all tasks and delivers it to all.
574 : !! Target: double precision four-dimensional arrays.
575 : !!
576 : !! INPUTS
577 : !! xval= buffer array
578 : !! recvcounts= number of received elements
579 : !! displs= relative offsets for incoming data
580 : !! nelem= number of elements
581 : !! root= rank of receiving process
582 : !! comm= MPI communicator
583 : !!
584 : !! OUTPUT
585 : !! ier= exit status, a non-zero value meaning there is an error
586 : !!
587 : !! SIDE EFFECTS
588 : !! recvbuf= received buffer
589 : !!
590 : !! SOURCE
591 :
592 0 : subroutine xmpi_gatherv_dp5d(xval,nelem,recvbuf,recvcounts,displs,root,comm,ier)
593 :
594 : !Arguments-------------------------
595 : real(dp), DEV_CONTARRD intent(in) :: xval(:,:,:,:,:)
596 : real(dp), DEV_CONTARRD intent(inout) :: recvbuf(:,:,:,:,:)
597 : integer, DEV_CONTARRD intent(in) :: recvcounts(:),displs(:)
598 : integer,intent(in) :: nelem,root,comm
599 : integer,intent(out) :: ier
600 :
601 : !Local variables-------------------
602 : integer :: cc,dd,sz1234
603 :
604 : ! *************************************************************************
605 :
606 0 : ier=0
607 : #if defined HAVE_MPI
608 0 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
609 : call MPI_gatherV(xval,nelem,MPI_DOUBLE_PRECISION,recvbuf,recvcounts,displs,&
610 0 : & MPI_DOUBLE_PRECISION,root,comm,ier)
611 0 : else if (comm == MPI_COMM_SELF) then
612 : #endif
613 0 : sz1234=size(xval,1)*size(xval,2)*size(xval,3)*size(xval,4)
614 0 : dd=0;if (size(displs)>0) dd=displs(1)/sz1234
615 0 : cc=size(xval,5);if (size(recvcounts)>0) cc=recvcounts(1)/sz1234
616 0 : recvbuf(:,:,:,:,dd+1:dd+cc)=xval(:,:,:,:,1:cc)
617 : #if defined HAVE_MPI
618 : end if
619 : #endif
620 : !!***
621 :
622 0 : end subroutine xmpi_gatherv_dp5d
623 :
624 : !!****f* ABINIT/xmpi_gatherv_dp6d
625 : !! NAME
626 : !! xmpi_gatherv_dp6d
627 : !!
628 : !! FUNCTION
629 : !! Gathers data from all tasks and delivers it to all.
630 : !! Target: double precision four-dimensional arrays.
631 : !!
632 : !! INPUTS
633 : !! xval= buffer array
634 : !! recvcounts= number of received elements
635 : !! displs= relative offsets for incoming data
636 : !! nelem= number of elements
637 : !! root= rank of receiving process
638 : !! comm= MPI communicator
639 : !!
640 : !! OUTPUT
641 : !! ier= exit status, a non-zero value meaning there is an error
642 : !!
643 : !! SIDE EFFECTS
644 : !! recvbuf= received buffer
645 : !!
646 : !! SOURCE
647 :
648 0 : subroutine xmpi_gatherv_dp6d(xval,nelem,recvbuf,recvcounts,displs,root,comm,ier)
649 :
650 : !Arguments-------------------------
651 : real(dp), DEV_CONTARRD intent(in) :: xval(:,:,:,:,:,:)
652 : real(dp), DEV_CONTARRD intent(inout) :: recvbuf(:,:,:,:,:,:)
653 : integer, DEV_CONTARRD intent(in) :: recvcounts(:),displs(:)
654 : integer,intent(in) :: nelem,root,comm
655 : integer,intent(out) :: ier
656 :
657 : !Local variables-------------------
658 : integer :: cc,dd,sz12345
659 :
660 : ! *************************************************************************
661 :
662 0 : ier=0
663 : #if defined HAVE_MPI
664 0 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
665 : call MPI_gatherV(xval,nelem,MPI_DOUBLE_PRECISION,recvbuf,recvcounts,displs,&
666 0 : & MPI_DOUBLE_PRECISION,root,comm,ier)
667 0 : else if (comm == MPI_COMM_SELF) then
668 : #endif
669 0 : sz12345=size(xval,1)*size(xval,2)*size(xval,3)*size(xval,4)*size(xval,5)
670 0 : dd=0;if (size(displs)>0) dd=displs(1)/sz12345
671 0 : cc=size(xval,6);if (size(recvcounts)>0) cc=recvcounts(1)/sz12345
672 0 : recvbuf(:,:,:,:,:,dd+1:dd+cc)=xval(:,:,:,:,:,1:cc)
673 : #if defined HAVE_MPI
674 : end if
675 : #endif
676 :
677 0 : end subroutine xmpi_gatherv_dp6d
678 : !!***
679 :
680 : !!****f* ABINIT/xmpi_gatherv_dc
681 : !! NAME
682 : !! xmpi_gatherv_dc
683 : !!
684 : !! FUNCTION
685 : !! Gathers data from all tasks and delivers it to all.
686 : !! Target: one-dimensional double complex arrays.
687 : !!
688 : !! INPUTS
689 : !! xval= buffer array
690 : !! recvcounts= number of received elements
691 : !! displs= relative offsets for incoming data
692 : !! nelem= number of elements
693 : !! root= rank of receiving process
694 : !! comm= MPI communicator
695 : !!
696 : !! OUTPUT
697 : !! ier= exit status, a non-zero value meaning there is an error
698 : !!
699 : !! SIDE EFFECTS
700 : !! recvbuf= received buffer
701 : !!
702 : !! SOURCE
703 :
704 106 : subroutine xmpi_gatherv_dc(xval,nelem,recvbuf,recvcounts,displs,root,comm,ier)
705 :
706 : !Arguments-------------------------
707 : complex(dp), DEV_CONTARRD intent(in) :: xval(:)
708 : complex(dp), DEV_CONTARRD intent(inout) :: recvbuf(:)
709 : integer, DEV_CONTARRD intent(in) :: recvcounts(:),displs(:)
710 : integer,intent(in) :: nelem,root,comm
711 : integer,intent(out) :: ier
712 :
713 : !Local variables--------------
714 : integer :: cc,dd
715 : ! *************************************************************************
716 :
717 106 : ier=0
718 : #if defined HAVE_MPI
719 106 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
720 : call MPI_gatherV(xval,nelem,MPI_DOUBLE_COMPLEX,recvbuf,recvcounts,displs,&
721 106 : & MPI_DOUBLE_COMPLEX,root,comm,ier)
722 0 : else if (comm == MPI_COMM_SELF) then
723 : #endif
724 0 : dd=0;if (size(displs)>0) dd=displs(1)
725 0 : cc=size(xval);if (size(recvcounts)>0) cc=recvcounts(1)
726 0 : recvbuf(dd+1:dd+cc)=xval(1:cc)
727 : #if defined HAVE_MPI
728 : end if
729 : #endif
730 :
731 106 : end subroutine xmpi_gatherv_dc
732 : !!***
733 :
|
