Branch data 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 [ - + - + : 5996 : 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 : 5996 : ier=0
384 : : #if defined HAVE_MPI
385 [ + - ]: 5996 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
386 : : call MPI_gatherV(xval,nelem,MPI_DOUBLE_PRECISION,recvbuf,recvcounts,displs,&
387 [ - + - - : 5996 : & 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 : 5996 : 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 [ - + - + : 110 : 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 : 110 : ier=0
718 : : #if defined HAVE_MPI
719 [ + - ]: 110 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
720 : : call MPI_gatherV(xval,nelem,MPI_DOUBLE_COMPLEX,recvbuf,recvcounts,displs,&
721 [ - + - - : 110 : & 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 : 110 : end subroutine xmpi_gatherv_dc
732 : : !!***
733 : :
|
