Branch data Line data Source code
1 : : !{\src2tex{textfont=tt}}
2 : : !!****f* ABINIT/xmpi_allgatherv_int2d
3 : : !! NAME
4 : : !! xmpi_allgatherv_int2d
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_allgatherv is the generic function.
10 : : !!
11 : : !! COPYRIGHT
12 : : !! Copyright (C) 2001-2026 ABINIT group (AR,XG)
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 [ - + - + : 12706 : subroutine xmpi_allgatherv_int2d(xval,nelem,recvbuf,recvcounts,displs,comm,ier)
- + - + ]
20 : :
21 : : !Arguments-------------------------
22 : : integer, DEV_CONTARRD intent(in) :: xval(:,:)
23 : : integer, DEV_CONTARRD intent(inout) :: recvbuf(:,:)
24 : : integer, DEV_CONTARRD intent(in) :: recvcounts(:),displs(:)
25 : : integer,intent(in) :: nelem,comm
26 : : integer,intent(out) :: ier
27 : :
28 : : !Local variables--------------
29 : : integer :: cc,dd,sz1
30 : : ! *************************************************************************
31 : :
32 : 12706 : ier=0
33 : : #if defined HAVE_MPI
34 [ + + ]: 12706 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
35 : : call MPI_ALLGATHERV(xval,nelem,MPI_INTEGER,recvbuf,recvcounts,displs,&
36 [ - + - - : 12672 : & MPI_INTEGER,comm,ier)
- - - + -
- - - - +
- + - + -
- - + -
- ]
37 [ + - ]: 34 : else if (comm == MPI_COMM_SELF) then
38 : : #endif
39 : 34 : sz1=size(xval,1)
40 [ + - ]: 34 : dd=0;if (size(displs)>0) dd=displs(1)/sz1
41 [ + - ]: 34 : cc=size(xval,2);if (size(recvcounts)>0) cc=recvcounts(1)/sz1
42 [ + + + + ]: 626754 : recvbuf(:,dd+1:dd+cc)=xval(:,1:cc)
43 : : #if defined HAVE_MPI
44 : : end if
45 : : #endif
46 : 12706 : end subroutine xmpi_allgatherv_int2d
47 : : !!***
48 : :
49 : : !!****f* ABINIT/xmpi_allgatherv_int
50 : : !! NAME
51 : : !! xmpi_allgatherv_int
52 : : !!
53 : : !! FUNCTION
54 : : !! Gathers data from all tasks and delivers it to all.
55 : : !! Target: one-dimensional integer arrays.
56 : : !!
57 : : !! INPUTS
58 : : !! xval= buffer array
59 : : !! recvcounts= number of received elements
60 : : !! displs= relative offsets for incoming data
61 : : !! nelem= number of elements
62 : : !! comm= MPI communicator
63 : : !!
64 : : !! OUTPUT
65 : : !! ier= exit status, a non-zero value meaning there is an error
66 : : !!
67 : : !! SIDE EFFECTS
68 : : !! recvbuf= received buffer
69 : : !!
70 : : !! SOURCE
71 : :
72 [ - + - + : 5905 : subroutine xmpi_allgatherv_int(xval,nelem,recvbuf,recvcounts,displs,comm,ier)
- + - + ]
73 : :
74 : : !Arguments-------------------------
75 : : integer, DEV_CONTARRD intent(in) :: xval(:)
76 : : integer, DEV_CONTARRD intent(inout) :: recvbuf(:)
77 : : integer, DEV_CONTARRD intent(in) :: recvcounts(:),displs(:)
78 : : integer,intent(in) :: nelem,comm
79 : : integer,intent(out) :: ier
80 : :
81 : : !Local variables-------------------
82 : : integer :: cc,dd
83 : : ! *************************************************************************
84 : :
85 : 5905 : ier=0
86 : : #if defined HAVE_MPI
87 [ + + ]: 5905 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
88 : : call MPI_ALLGATHERV(xval,nelem,MPI_INTEGER,recvbuf,recvcounts,displs,&
89 [ - + - - : 5889 : & MPI_INTEGER,comm,ier)
- - - + -
- - - - +
- + - + -
- - + -
- ]
90 [ + - ]: 16 : else if (comm == MPI_COMM_SELF) then
91 : : #endif
92 [ + - ]: 16 : dd=0;if (size(displs)>0) dd=displs(1)
93 [ + - ]: 16 : cc=size(xval);if (size(recvcounts)>0) cc=recvcounts(1)
94 [ + + ]: 32 : recvbuf(dd+1:dd+cc)=xval(1:cc)
95 : : #if defined HAVE_MPI
96 : : end if
97 : : #endif
98 : 5905 : end subroutine xmpi_allgatherv_int
99 : : !!***
100 : :
101 : : !!****f* ABINIT/xmpi_allgatherv_int1_dp1
102 : : !! NAME
103 : : !! xmpi_allgatherv_int1_dp1
104 : : !!
105 : : !! FUNCTION
106 : : !! Gathers data from all tasks and delivers it to all.
107 : : !! Target : one-dimensional integer arrray and one-dimensionnal dp array
108 : : !!
109 : : !! INPUTS
110 : : !! buf_int=buffer integer array that is going to be gathered
111 : : !! buf_int_size=size of buf_int array
112 : : !! buf_dp=buffer dp array that is going to be gathered
113 : : !! buf_dp_size=size of buf_dp array
114 : : !! comm=MPI communicator
115 : : !!
116 : : !! OUTPUT
117 : : !! buf_int_all=buffer integer array gathered
118 : : !! buf_int_size_all=size of buffer integer array gathered
119 : : !! buf_dp_all=buffer dp array gathered
120 : : !! buf_dp_size_all=size of buffer dp array gathered
121 : : !! ier=exit status, a non-zero value meaning there is an error
122 : : !!
123 : : !! SOURCE
124 : :
125 [ # # # # ]: 0 : subroutine xmpi_allgatherv_int1_dp1(buf_int,buf_int_size,buf_dp,buf_dp_size,&
126 : : & buf_int_all,buf_int_size_all,buf_dp_all,buf_dp_size_all,comm,ier)
127 : :
128 : : !Arguments-------------------------
129 : : !scalars
130 : : integer,intent(in) :: buf_dp_size,buf_int_size,comm
131 : : integer,intent(out) :: buf_dp_size_all,buf_int_size_all,ier
132 : : !arrays
133 : : integer, intent(in) :: buf_int(:)
134 : : integer,allocatable,target,intent(out) :: buf_int_all(:)
135 : : real(dp),intent(in) :: buf_dp(:)
136 : : real(dp),allocatable,target,intent(out) :: buf_dp_all(:)
137 : :
138 : : !Local variables--------------
139 : : !scalars
140 : : integer :: buf_pack_size,ierr,ii,iproc,istart_dp,istart_int,lg,lg1,lg2,lg_dp,lg_int
141 : : integer :: nproc,position,totalbufcount
142 : : logical,parameter :: use_pack=.false.
143 : : !arrays
144 : : integer :: buf_size(2),pos(3)
145 : 0 : integer ,allocatable :: buf_int_size1(:),buf_dp_size1(:)
146 : 0 : integer,allocatable :: count_dp(:),count_int(:),count_size(:),counts(:)
147 : 0 : integer,allocatable :: disp_dp(:),disp_int(:),displ(:),displ_dp(:),displ_int(:)
148 : 0 : integer,allocatable :: pos_all(:)
149 : 0 : integer,pointer :: outbuf_int(:)
150 : 0 : real(dp),pointer:: outbuf_dp(:)
151 : 0 : character,allocatable :: buf_pack(:),buf_pack_tot(:)
152 : : ! *************************************************************************
153 : :
154 : 0 : ier=0
155 : :
156 : : #if defined HAVE_MPI
157 : 0 : if (comm/=MPI_COMM_SELF.and.comm/=MPI_COMM_NULL) then
158 : :
159 : 0 : nproc=xmpi_comm_size(comm)
160 : :
161 : : !First version: using 2 allgather (one for ints, another for reals)
162 : : !------------------------------------------------------------------
163 : : if (.not.use_pack) then
164 : :
165 : : ! Prepare communications
166 [ # # # # : 0 : ABI_MALLOC(count_int,(nproc))
# # # # #
# # # ]
167 [ # # # # : 0 : ABI_MALLOC(disp_int,(nproc))
# # # # ]
168 [ # # # # : 0 : ABI_MALLOC(count_dp,(nproc))
# # # # ]
169 [ # # # # : 0 : ABI_MALLOC(disp_dp,(nproc))
# # # # ]
170 [ # # # # : 0 : ABI_MALLOC(count_size,(2*nproc))
# # # # #
# # # #
# ]
171 : 0 : buf_size(1)=buf_int_size; buf_size(2)=buf_dp_size
172 : 0 : call xmpi_allgather(buf_size,2,count_size,comm,ier)
173 [ # # ]: 0 : do iproc=1,nproc
174 : 0 : count_int(iproc)=count_size(2*iproc-1)
175 : 0 : count_dp(iproc)=count_size(2*iproc)
176 : : end do
177 : 0 : disp_int(1)=0;disp_dp(1)=0
178 [ # # ]: 0 : do ii=2,nproc
179 : 0 : disp_int(ii)=disp_int(ii-1)+count_int(ii-1)
180 : 0 : disp_dp (ii)=disp_dp (ii-1)+count_dp (ii-1)
181 : : end do
182 [ # # ]: 0 : buf_int_size_all=sum(count_int)
183 [ # # ]: 0 : buf_dp_size_all =sum(count_dp)
184 : :
185 [ # # # # : 0 : ABI_STAT_MALLOC(buf_int_all,(buf_int_size_all), ier)
# # # # #
# # # # #
# # ]
186 [ # # ]: 0 : if (ier/=0) call xmpi_abort(msg='error allocating buf_int_all in xmpi_allgatherv')
187 [ # # # # : 0 : ABI_STAT_MALLOC(buf_dp_all ,(buf_dp_size_all), ierr)
# # # # #
# # # # #
# # ]
188 : : if (ier/=0) call xmpi_abort(msg='error allocating buf_dp_all in xmpi_allgatherv')
189 : :
190 : : ! Communicate (one call for integers, one call for reals)
191 : 0 : call xmpi_allgatherv(buf_int,buf_int_size,buf_int_all,count_int,disp_int,comm,ierr)
192 : 0 : call xmpi_allgatherv(buf_dp,buf_dp_size,buf_dp_all,count_dp,disp_dp,comm,ierr)
193 : :
194 : : ! Release the memory
195 [ # # ]: 0 : ABI_FREE(count_int)
196 : 0 : ABI_FREE(disp_int)
197 [ # # ]: 0 : ABI_FREE(count_dp)
198 : 0 : ABI_FREE(disp_dp)
199 [ # # ]: 0 : ABI_FREE(count_size)
200 : :
201 : : !2nd version: using 1 allgather (with MPI_PACK)
202 : : !-----------------------------------------------------------------
203 : : else
204 : :
205 : : ! Compute size of message
206 : : call MPI_PACK_SIZE(buf_int_size,MPI_INTEGER,comm,lg1,ier)
207 : : call MPI_PACK_SIZE(buf_dp_size,MPI_DOUBLE_PRECISION,comm,lg2,ier)
208 : : lg=lg1+lg2
209 : :
210 : : ! Pack data to be sent
211 : : position=0 ; buf_pack_size=lg1+lg2
212 : : ABI_MALLOC(buf_pack,(buf_pack_size))
213 : : call MPI_PACK(buf_int,buf_int_size,MPI_INTEGER,buf_pack,buf_pack_size,position,comm,ier)
214 : : call MPI_PACK(buf_dp,buf_dp_size,MPI_DOUBLE_PRECISION,buf_pack,buf_pack_size,position,comm,ier)
215 : :
216 : : ! Gather size of all packed messages
217 : : ABI_MALLOC(pos_all,(nproc*3))
218 : : ABI_MALLOC(counts,(nproc))
219 : : ABI_MALLOC(buf_int_size1,(nproc))
220 : : ABI_MALLOC(buf_dp_size1,(nproc))
221 : : ABI_MALLOC(displ,(nproc))
222 : : ABI_MALLOC(displ_int,(nproc))
223 : : ABI_MALLOC(displ_dp,(nproc))
224 : : pos(1)=position;pos(2)=buf_int_size;pos(3)=buf_dp_size
225 : : call MPI_ALLGATHER(pos,3,MPI_INTEGER,pos_all,3,MPI_INTEGER,comm,ier)
226 : : ii=1
227 : : do iproc=1,nproc
228 : : counts(iproc)=pos_all(ii);ii=ii+1
229 : : buf_int_size1(iproc)=pos_all(ii);ii=ii+1
230 : : buf_dp_size1(iproc)=pos_all(ii);ii=ii+1
231 : : end do
232 : :
233 : : displ(1)=0 ; displ_int(1)=0 ; displ_dp(1)=0
234 : : do iproc=2,nproc
235 : : displ(iproc)=displ(iproc-1)+counts(iproc-1)
236 : : displ_int(iproc)=displ_int(iproc-1)+buf_int_size1(iproc-1)
237 : : displ_dp(iproc)=displ_dp(iproc-1)+buf_dp_size1(iproc-1)
238 : : end do
239 : :
240 : : totalbufcount=displ(nproc)+counts(nproc)
241 : : ABI_STAT_MALLOC(buf_pack_tot,(totalbufcount), ier)
242 : : if (ier/= 0) call xmpi_abort(msg='error allocating totalbufcount in xmpi_allgatherv')
243 : : buf_int_size_all=sum(buf_int_size1)
244 : : buf_dp_size_all=sum(buf_dp_size1)
245 : : ABI_STAT_MALLOC(buf_int_all,(buf_int_size_all), ier)
246 : : if (ier/=0) call xmpi_abort(msg='error allocating buf_int_all in xmpi_allgatherv')
247 : : ABI_STAT_MALLOC(buf_dp_all,(buf_dp_size_all), ier)
248 : : if (ier/=0) call xmpi_abort(msg='error allocating buf_dp_size_all in xmpi_allgatherv')
249 : :
250 : : ! Gather all packed messages
251 : : call MPI_ALLGATHERV(buf_pack,position,MPI_PACKED,buf_pack_tot,counts,displ,MPI_PACKED,comm,ier)
252 : : position=0
253 : : do iproc=1,nproc
254 : : lg_int=buf_int_size1(iproc); lg_dp=buf_dp_size1(iproc)
255 : : istart_int=displ_int(iproc); istart_dp=displ_dp(iproc)
256 : : outbuf_int=>buf_int_all(istart_int+1:istart_int+lg_int)
257 : : call MPI_UNPACK(buf_pack_tot,totalbufcount,position, outbuf_int,&
258 : : & lg_int,MPI_INTEGER,comm,ier)
259 : : outbuf_dp=>buf_dp_all(istart_dp+1:istart_dp+lg_dp)
260 : : call MPI_UNPACK(buf_pack_tot,totalbufcount,position,outbuf_dp,&
261 : : & lg_dp,MPI_DOUBLE_PRECISION,comm,ier)
262 : : end do
263 : :
264 : : ! Release the memory
265 : : ABI_FREE(pos_all)
266 : : ABI_FREE(counts)
267 : : ABI_FREE(buf_int_size1)
268 : : ABI_FREE(buf_dp_size1)
269 : : ABI_FREE(displ)
270 : : ABI_FREE(displ_int)
271 : : ABI_FREE(displ_dp)
272 : : ABI_FREE(buf_pack_tot)
273 : : ABI_FREE(buf_pack)
274 : :
275 : : end if
276 [ # # ]: 0 : else if (comm==MPI_COMM_SELF) then
277 : : #endif
278 : :
279 : : !Sequential version
280 [ # # # # : 0 : ABI_STAT_MALLOC(buf_int_all,(buf_int_size), ier)
# # # # #
# # # # #
# # ]
281 [ # # ]: 0 : if (ier/=0) call xmpi_abort(msg='error allocating buf_int_all in xmpi_allgatherv')
282 [ # # # # : 0 : ABI_STAT_MALLOC(buf_dp_all,(buf_dp_size), ier)
# # # # #
# # # # #
# # ]
283 [ # # ]: 0 : if (ier/=0) call xmpi_abort(msg='error allocating buf_dp_all in xmpi_allgatherv')
284 : :
285 [ # # ]: 0 : buf_int_all(:)=buf_int(:)
286 [ # # ]: 0 : buf_dp_all(:)=buf_dp(:)
287 : 0 : buf_int_size_all=buf_int_size
288 : 0 : buf_dp_size_all=buf_dp_size
289 : :
290 : : #if defined HAVE_MPI
291 : : end if
292 : : #endif
293 : :
294 [ # # # # : 0 : end subroutine xmpi_allgatherv_int1_dp1
# # # # #
# # # ]
295 : : !!***
296 : :
297 : : !!****f* ABINIT/xmpi_allgatherv_dp
298 : : !! NAME
299 : : !! xmpi_allgatherv_dp
300 : : !!
301 : : !! FUNCTION
302 : : !! Gathers data from all tasks and delivers it to all.
303 : : !! Target: one-dimensional double precision arrays.
304 : : !!
305 : : !! INPUTS
306 : : !! xval= buffer array
307 : : !! recvcounts= number of received elements
308 : : !! displs= relative offsets for incoming data
309 : : !! nelem= number of elements
310 : : !! comm= MPI communicator
311 : : !!
312 : : !! OUTPUT
313 : : !! ier= exit status, a non-zero value meaning there is an error
314 : : !!
315 : : !! SIDE EFFECTS
316 : : !! recvbuf= received buffer
317 : : !!
318 : : !! SOURCE
319 : :
320 [ - + - + : 25514 : subroutine xmpi_allgatherv_dp(xval,nelem,recvbuf,recvcounts,displs,comm,ier)
- + - + ]
321 : :
322 : : !Arguments-------------------------
323 : : real(dp), DEV_CONTARRD intent(in) :: xval(:)
324 : : real(dp), DEV_CONTARRD intent(inout) :: recvbuf(:)
325 : : integer,intent(in) :: recvcounts(:),displs(:)
326 : : integer,intent(in) :: nelem,comm
327 : : integer,intent(out) :: ier
328 : :
329 : : !Local variables--------------
330 : : integer :: cc,dd
331 : :
332 : : ! *************************************************************************
333 : :
334 : 25514 : ier=0
335 : : #if defined HAVE_MPI
336 [ + + ]: 25514 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
337 : : call MPI_ALLGATHERV(xval,nelem,MPI_DOUBLE_PRECISION,recvbuf,recvcounts,displs,&
338 [ - + - - : 25430 : & MPI_DOUBLE_PRECISION,comm,ier)
- - - + -
- - - - +
- + - + -
- - + -
- ]
339 [ + - ]: 84 : else if (comm == MPI_COMM_SELF) then
340 : : #endif
341 [ + - ]: 84 : dd=0;if (size(displs)>0) dd=displs(1)
342 [ + - ]: 84 : cc=size(xval);if (size(recvcounts)>0) cc=recvcounts(1)
343 [ + + ]: 273170 : recvbuf(dd+1:dd+cc)=xval(1:cc)
344 : : #if defined HAVE_MPI
345 : : end if
346 : : #endif
347 : 25514 : end subroutine xmpi_allgatherv_dp
348 : : !!***
349 : :
350 : : !!****f* ABINIT/xmpi_allgatherv_dp2d
351 : : !! NAME
352 : : !! xmpi_allgatherv_dp2d
353 : : !!
354 : : !! FUNCTION
355 : : !! Gathers data from all tasks and delivers it to all.
356 : : !! Target: double precision two-dimensional arrays.
357 : : !!
358 : : !! INPUTS
359 : : !! xval= buffer array
360 : : !! recvcounts= number of received elements
361 : : !! displs= relative offsets for incoming data
362 : : !! nelem= number of elements
363 : : !! comm= MPI communicator
364 : : !!
365 : : !! OUTPUT
366 : : !! ier= exit status, a non-zero value meaning there is an error
367 : : !!
368 : : !! SIDE EFFECTS
369 : : !! recvbuf= received buffer
370 : : !!
371 : : !! SOURCE
372 : :
373 [ - + - + : 4052 : subroutine xmpi_allgatherv_dp2d(xval,nelem,recvbuf,recvcounts,displs,comm,ier)
- + - + ]
374 : :
375 : : !Arguments-------------------------
376 : : real(dp), DEV_CONTARRD intent(in) :: xval(:,:)
377 : : real(dp), DEV_CONTARRD intent(inout) :: recvbuf(:,:)
378 : : integer, DEV_CONTARRD intent(in) :: recvcounts(:),displs(:)
379 : : integer,intent(in) :: nelem,comm
380 : : integer,intent(out) :: ier
381 : :
382 : : !Local variables--------------
383 : : integer :: cc,dd,sz1
384 : :
385 : : ! *************************************************************************
386 : :
387 : 4052 : ier=0
388 : : #if defined HAVE_MPI
389 [ + - ]: 4052 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
390 : : call MPI_ALLGATHERV(xval,nelem,MPI_DOUBLE_PRECISION,recvbuf,recvcounts,displs,&
391 [ - + - - : 4052 : & MPI_DOUBLE_PRECISION,comm,ier)
- - - + -
- - - - +
- + - + -
- - + -
- ]
392 [ # # ]: 0 : else if (comm == MPI_COMM_SELF) then
393 : : #endif
394 : 0 : sz1=size(xval,1)
395 [ # # ]: 0 : dd=0;if (size(displs)>0) dd=displs(1)/sz1
396 [ # # ]: 0 : cc=size(xval,2);if (size(recvcounts)>0) cc=recvcounts(1)/sz1
397 [ # # # # ]: 0 : recvbuf(:,dd+1:dd+cc)=xval(:,1:cc)
398 : : #if defined HAVE_MPI
399 : : end if
400 : : #endif
401 : 4052 : end subroutine xmpi_allgatherv_dp2d
402 : : !!***
403 : :
404 : : !!****f* ABINIT/get_gcd_of_array
405 : : !! NAME
406 : : !! get_gcd_of_array
407 : : !!
408 : : !! FUNCTION
409 : : !! Returns the GCD (Greatest Common Divider, or PGCD in French)
410 : : !! of an integer array.
411 : : !!
412 : : !! INPUTS
413 : : !! tab= integer array
414 : : !!
415 : : !! OUTPUT
416 : : !! r= GCD
417 : : !!
418 : : !! SOURCE
419 : :
420 [ # # ]: 0 : function get_gcd_of_array(array) result(r)
421 : :
422 : : !Arguments-------------------------
423 : : integer, intent(in) :: array(:)
424 : :
425 : : !Local variables--------------
426 : : integer :: r, i, a, b, temp
427 : :
428 : : ! *************************************************************************
429 : :
430 : 0 : r = array(1)
431 [ # # ]: 0 : do i = 2, size(array)
432 : 0 : a = r
433 : 0 : b = array(i)
434 [ # # ]: 0 : do while (b /= 0)
435 : 0 : temp = b
436 : 0 : b = mod(a, b)
437 : 0 : a = temp
438 : : end do
439 : 0 : r = a
440 [ # # ]: 0 : if (r == 1) then
441 : : return
442 : : end if
443 : : end do
444 : 0 : end function get_gcd_of_array
445 : : !!***
446 : :
447 : : !!****f* ABINIT/xmpi_allgatherv_dp3d
448 : : !! NAME
449 : : !! xmpi_allgatherv_dp3d
450 : : !!
451 : : !! FUNCTION
452 : : !! Gathers data from all tasks and delivers it to all.
453 : : !! Target: double precision three-dimensional arrays.
454 : : !!
455 : : !! INPUTS
456 : : !! xval= buffer array
457 : : !! recvcounts= number of received elements
458 : : !! displs= relative offsets for incoming data
459 : : !! nelem= number of elements
460 : : !! comm= MPI communicator
461 : : !!
462 : : !! OUTPUT
463 : : !! ier= exit status, a non-zero value meaning there is an error
464 : : !!
465 : : !! SIDE EFFECTS
466 : : !! recvbuf= received buffer
467 : : !!
468 : : !! SOURCE
469 : :
470 [ - + - + : 32952 : subroutine xmpi_allgatherv_dp3d(xval,nelem,recvbuf,recvcounts,displs,comm,ier)
- + - + ]
471 : :
472 : : !Arguments-------------------------
473 : : real(dp), DEV_CONTARRD intent(in) :: xval(:,:,:)
474 : : real(dp), DEV_CONTARRD intent(inout) :: recvbuf(:,:,:)
475 : : integer, target, DEV_CONTARRD intent(in) :: recvcounts(:),displs(:)
476 : : integer,intent(in) :: nelem,comm
477 : : integer,intent(out) :: ier
478 : :
479 : : !Local variables--------------
480 : : integer :: cc,dd,sz12
481 : : integer :: my_dt,my_op,n1,n2,n3,nn,r,i
482 : : integer(kind=int64) :: ntot
483 : 32952 : integer, DEV_CONTARRD pointer :: my_recvcounts(:),my_displs(:)
484 : :
485 : : ! *************************************************************************
486 : :
487 : 32952 : ier=0
488 : : #if defined HAVE_MPI
489 : 32952 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
490 : 32796 : n1 = size(recvbuf,dim=1)
491 : 32796 : n2 = size(recvbuf,dim=2)
492 : 32796 : n3 = size(recvbuf,dim=3)
493 : :
494 : : !This product of dimensions can be greater than a 32bit integer
495 : : !We use a INT64 to store it. If it is too large, we switch to an
496 : : !alternate routine because MPI<4 doesnt handle 64 bit counts.
497 : 32796 : ntot=int(n1,kind=int64)*n2*n3
498 [ + - ]: 32796 : if (ntot<=xmpi_maxint32_64) then
499 : 32796 : nn=nelem ; my_dt=MPI_DOUBLE_PRECISION
500 : 32796 : my_recvcounts => recvcounts; my_displs => displs
501 : : else
502 : 0 : r=get_gcd_of_array(recvcounts)
503 : 0 : nn=nelem/r ; call xmpi_largetype_create(int(r,int64),MPI_DOUBLE_PRECISION,my_dt,my_op,MPI_OP_NULL)
504 [ # # # # : 0 : ABI_MALLOC(my_recvcounts, (size(recvcounts)))
# # # # #
# # # ]
505 [ # # # # : 0 : my_recvcounts(:)=recvcounts(:)/r
# # ]
506 [ # # # # : 0 : ABI_MALLOC(my_displs, (size(displs)))
# # # # #
# # # ]
507 : 0 : my_displs(1)=0
508 [ # # ]: 0 : do i=2,size(displs)
509 : 0 : my_displs(i)=my_displs(i-1)+my_recvcounts(i-1)
510 : : end do
511 : : end if
512 : : call MPI_ALLGATHERV(xval,nn,my_dt,recvbuf,my_recvcounts,my_displs,&
513 [ - + - + : 32796 : & my_dt,comm,ier)
- + - + ]
514 [ - + ]: 32796 : if (ntot>xmpi_maxint32_64) then
515 : 0 : call xmpi_largetype_free(my_dt,my_op)
516 [ # # # # ]: 0 : ABI_FREE(my_recvcounts); ABI_FREE(my_displs)
517 : : end if
518 [ + - ]: 156 : else if (comm == MPI_COMM_SELF) then
519 : : #endif
520 : 156 : sz12=size(xval,1)*size(xval,2)
521 [ + - ]: 156 : dd=0;if (size(displs)>0) dd=displs(1)/sz12
522 [ + - ]: 156 : cc=size(xval,3);if (size(recvcounts)>0) cc=recvcounts(1)/sz12
523 [ + + + + : 13542552 : recvbuf(:,:,dd+1:dd+cc)=xval(:,:,1:cc)
+ + ]
524 : : #if defined HAVE_MPI
525 : : end if
526 : : #endif
527 [ + + ]: 32952 : end subroutine xmpi_allgatherv_dp3d
528 : : !!***
529 : :
530 : : !!****f* ABINIT/xmpi_allgatherv_dp4d
531 : : !! NAME
532 : : !! xmpi_allgatherv_dp4d
533 : : !!
534 : : !! FUNCTION
535 : : !! Gathers data from all tasks and delivers it to all.
536 : : !! Target: double precision four-dimensional arrays.
537 : : !!
538 : : !! INPUTS
539 : : !! xval= buffer array
540 : : !! recvcounts= number of received elements
541 : : !! displs= relative offsets for incoming data
542 : : !! nelem= number of elements
543 : : !! comm= MPI communicator
544 : : !!
545 : : !! OUTPUT
546 : : !! ier= exit status, a non-zero value meaning there is an error
547 : : !!
548 : : !! SIDE EFFECTS
549 : : !! recvbuf= received buffer
550 : : !!
551 : : !! SOURCE
552 : :
553 [ - + - + : 32952 : subroutine xmpi_allgatherv_dp4d(xval,nelem,recvbuf,recvcounts,displs,comm,ier)
- + - + ]
554 : :
555 : : !Arguments-------------------------
556 : : real(dp), DEV_CONTARRD intent(in) :: xval(:,:,:,:)
557 : : real(dp), DEV_CONTARRD intent(inout) :: recvbuf(:,:,:,:)
558 : : integer, DEV_CONTARRD intent(in) :: recvcounts(:),displs(:)
559 : : integer,intent(in) :: nelem,comm
560 : : integer,intent(out) :: ier
561 : :
562 : : !Local variables-------------------
563 : : integer :: cc,dd,sz123
564 : :
565 : : ! *************************************************************************
566 : :
567 : 32952 : ier=0
568 : : #if defined HAVE_MPI
569 [ + + ]: 32952 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
570 : : call MPI_ALLGATHERV(xval,nelem,MPI_DOUBLE_PRECISION,recvbuf,recvcounts,displs,&
571 [ - + - - : 32796 : & MPI_DOUBLE_PRECISION,comm,ier)
- - - + -
- - - - +
- + - + -
- - + -
- ]
572 [ + - ]: 156 : else if (comm == MPI_COMM_SELF) then
573 : : #endif
574 : 156 : sz123=size(xval,1)*size(xval,2)*size(xval,3)
575 [ + - ]: 156 : dd=0;if (size(displs)>0) dd=displs(1)/sz123
576 [ + - ]: 156 : cc=size(xval,4);if (size(recvcounts)>0) cc=recvcounts(1)/sz123
577 [ + + + + : 47747400 : recvbuf(:,:,:,dd+1:dd+cc)=xval(:,:,:,1:cc)
+ + + + ]
578 : : #if defined HAVE_MPI
579 : : end if
580 : : #endif
581 : 32952 : end subroutine xmpi_allgatherv_dp4d
582 : : !!***
583 : :
584 : : !!****f* ABINIT/xmpi_allgatherv_dp5d
585 : : !! NAME
586 : : !! xmpi_allgatherv_dp5d
587 : : !!
588 : : !! FUNCTION
589 : : !! Gathers data from all tasks and delivers it to all.
590 : : !! Target: double precision six-dimensional arrays.
591 : : !!
592 : : !! INPUTS
593 : : !! xval= buffer array
594 : : !! recvcounts= number of received elements
595 : : !! displs= relative offsets for incoming data
596 : : !! nelem= number of elements
597 : : !! comm= MPI communicator
598 : : !!
599 : : !! OUTPUT
600 : : !! ier= exit status, a non-zero value meaning there is an error
601 : : !!
602 : : !! SIDE EFFECTS
603 : : !! recvbuf= received buffer
604 : : !!
605 : : !! SOURCE
606 : :
607 [ - + - + : 39 : subroutine xmpi_allgatherv_dp5d(xval,nelem,recvbuf,recvcounts,displs,comm,ier)
- + - + ]
608 : :
609 : : !Arguments-------------------------
610 : : real(dp), DEV_CONTARRD intent(in) :: xval(:,:,:,:,:)
611 : : real(dp), DEV_CONTARRD intent(inout) :: recvbuf(:,:,:,:,:)
612 : : integer, DEV_CONTARRD intent(in) :: recvcounts(:),displs(:)
613 : : integer,intent(in) :: nelem,comm
614 : : integer,intent(out) :: ier
615 : :
616 : : !Local variables-------------------
617 : : integer :: cc,dd,sz1234
618 : :
619 : : ! *************************************************************************
620 : :
621 : 39 : ier=0
622 : : #if defined HAVE_MPI
623 [ + - ]: 39 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
624 : : call MPI_ALLGATHERV(xval,nelem,MPI_DOUBLE_PRECISION,recvbuf,recvcounts,displs,&
625 [ - + - - : 39 : & MPI_DOUBLE_PRECISION,comm,ier)
- - - + -
- - - + +
- + - + -
- - + -
- ]
626 [ # # ]: 0 : else if (comm == MPI_COMM_SELF) then
627 : : #endif
628 : 0 : sz1234=size(xval,1)*size(xval,2)*size(xval,3)*size(xval,4)
629 [ # # ]: 0 : dd=0;if (size(displs)>0) dd=displs(1)/sz1234
630 [ # # ]: 0 : cc=size(xval,5);if (size(recvcounts)>0) cc=recvcounts(1)/sz1234
631 [ # # # # : 0 : recvbuf(:,:,:,:,dd+1:dd+cc)=xval(:,:,:,:,1:cc)
# # # # #
# ]
632 : : #if defined HAVE_MPI
633 : : end if
634 : : #endif
635 : 39 : end subroutine xmpi_allgatherv_dp5d
636 : : !!***
637 : :
638 : :
639 : : !!****f* ABINIT/xmpi_allgatherv_dp6d
640 : : !! NAME
641 : : !! xmpi_allgatherv_dp6d
642 : : !!
643 : : !! FUNCTION
644 : : !! Gathers data from all tasks and delivers it to all.
645 : : !! Target: double precision six-dimensional arrays.
646 : : !!
647 : : !! INPUTS
648 : : !! xval= buffer array
649 : : !! recvcounts= number of received elements
650 : : !! displs= relative offsets for incoming data
651 : : !! nelem= number of elements
652 : : !! comm= MPI communicator
653 : : !!
654 : : !! OUTPUT
655 : : !! ier= exit status, a non-zero value meaning there is an error
656 : : !!
657 : : !! SIDE EFFECTS
658 : : !! recvbuf= received buffer
659 : : !!
660 : : !! SOURCE
661 : :
662 [ # # # # : 0 : subroutine xmpi_allgatherv_dp6d(xval,nelem,recvbuf,recvcounts,displs,comm,ier)
# # # # ]
663 : :
664 : : !Arguments-------------------------
665 : : real(dp), DEV_CONTARRD intent(in) :: xval(:,:,:,:,:,:)
666 : : real(dp), DEV_CONTARRD intent(inout) :: recvbuf(:,:,:,:,:,:)
667 : : integer, DEV_CONTARRD intent(in) :: recvcounts(:),displs(:)
668 : : integer,intent(in) :: nelem,comm
669 : : integer,intent(out) :: ier
670 : :
671 : : !Local variables-------------------
672 : : integer :: cc,dd,sz12345
673 : :
674 : : ! *************************************************************************
675 : :
676 : 0 : ier=0
677 : : #if defined HAVE_MPI
678 [ # # ]: 0 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
679 : : call MPI_ALLGATHERV(xval,nelem,MPI_DOUBLE_PRECISION,recvbuf,recvcounts,displs,&
680 [ # # # # : 0 : & MPI_DOUBLE_PRECISION,comm,ier)
# # # # #
# # # # #
# # # # #
# # # #
# ]
681 [ # # ]: 0 : else if (comm == MPI_COMM_SELF) then
682 : : #endif
683 : 0 : sz12345=size(xval,1)*size(xval,2)*size(xval,3)*size(xval,4)*size(xval,5)
684 [ # # ]: 0 : dd=0;if (size(displs)>0) dd=displs(1)/sz12345
685 [ # # ]: 0 : cc=size(xval,6);if (size(recvcounts)>0) cc=recvcounts(1)/sz12345
686 [ # # # # : 0 : recvbuf(:,:,:,:,:,dd+1:dd+cc)=xval(:,:,:,:,:,1:cc)
# # # # #
# # # ]
687 : : #if defined HAVE_MPI
688 : : end if
689 : : #endif
690 : 0 : end subroutine xmpi_allgatherv_dp6d
691 : : !!***
692 : :
693 : : !!****f* ABINIT/xmpi_allgatherv_coeff2d
694 : : !! NAME
695 : : !! xmpi_allgatherv_coeff2d
696 : : !!
697 : : !! FUNCTION
698 : : !! Gathers data from all tasks and delivers it to all.
699 : : !! Target: coeff2_type 1D-structure
700 : : !!
701 : : !! INPUTS
702 : : !! xval_in = coeff2d_type array structure
703 : : !! comm= MPI communicator
704 : : !!
705 : : !! OUTPUT
706 : : !! xval_out = coeff2d_type array structure
707 : : !! ier= exit status, a non-zero value meaning there is an error
708 : : !!
709 : : !! SIDE EFFECTS
710 : : !!
711 : : !! SOURCE
712 : :
713 [ # # # # : 0 : subroutine xmpi_allgatherv_coeff2d(xval_in,xval_out,comm,ierr)
# # # # #
# # # ]
714 : :
715 : : !Arguments ------------------------------------
716 : : !scalars
717 : : integer,intent(in) :: comm
718 : : integer,intent(out) :: ierr
719 : : !arrays
720 : : type(coeff2_type),intent(in) :: xval_in(:)
721 : : type(coeff2_type),intent(out) :: xval_out(:)
722 : :
723 : : !Local variables-------------------------------
724 : : !scalars
725 : : integer :: ii,n1,n2
726 : : #if defined HAVE_MPI
727 : : integer :: buf_int_size,buf_int_size_all,buf_dp_size,buf_dp_size_all
728 : : integer :: i2,indx_int,indx_dp,nb,nb_out,nproc
729 : : #endif
730 : : !arrays
731 : : #if defined HAVE_MPI
732 : 0 : integer, allocatable :: buf_int(:),buf_int_all(:)
733 : 0 : integer, allocatable :: dimxval(:,:)
734 : 0 : real(dp),allocatable :: buf_dp(:),buf_dp_all(:)
735 : : #endif
736 : :
737 : : ! *************************************************************************
738 : :
739 : 0 : ierr=0
740 : : #if defined HAVE_MPI
741 [ # # ]: 0 : if (comm /= MPI_COMM_NULL) then
742 : :
743 : 0 : nproc=xmpi_comm_size(comm)
744 : 0 : nb = size(xval_in,1)
745 : :
746 [ # # # # ]: 0 : if (comm==MPI_COMM_SELF.or.nproc==1) then
747 [ # # ]: 0 : do ii=1,nb
748 : 0 : n1=size(xval_in(ii)%value,1)
749 : 0 : n2=size(xval_in(ii)%value,2)
750 [ # # ]: 0 : if (allocated(xval_out(ii)%value)) then
751 : 0 : ABI_FREE(xval_out(ii)%value)
752 : : end if
753 [ # # # # : 0 : ABI_STAT_MALLOC(xval_out(ii)%value,(n1,n2), ierr)
# # # # #
# # # # #
# # # # #
# ]
754 [ # # ]: 0 : if (ierr/= 0) call xmpi_abort(msg='error allocating xval_out%value in xmpi_allgatherv')
755 [ # # # # : 0 : xval_out(ii)%value=xval_in(ii)%value
# # # # #
# # # # #
# # ]
756 : : end do
757 : : return
758 : : end if
759 : :
760 : 0 : buf_dp_size=0
761 [ # # # # : 0 : ABI_MALLOC(dimxval,(nb,2))
# # # # #
# # # ]
762 [ # # ]: 0 : do ii=1,nb
763 : 0 : dimxval(ii,1)=size(xval_in(ii)%value,dim=1)
764 : 0 : dimxval(ii,2)=size(xval_in(ii)%value,dim=2)
765 : 0 : buf_dp_size=buf_dp_size+dimxval(ii,1)*dimxval(ii,2)
766 : : end do
767 : :
768 : 0 : buf_int_size=2*nb;
769 [ # # # # : 0 : ABI_STAT_MALLOC(buf_int,(buf_int_size), ierr)
# # # # #
# # # ]
770 [ # # ]: 0 : if (ierr/= 0) call xmpi_abort(msg='error allocating buf_int in xmpi_allgatherv')
771 : : indx_int=1
772 [ # # ]: 0 : do ii=1,nb
773 : 0 : buf_int(indx_int )=dimxval(ii,1)
774 : 0 : buf_int(indx_int+1)=dimxval(ii,2)
775 : 0 : indx_int=indx_int+2
776 : : end do
777 : :
778 [ # # # # : 0 : ABI_STAT_MALLOC(buf_dp,(buf_dp_size) ,ierr)
# # # # #
# # # ]
779 [ # # ]: 0 : if (ierr/= 0) call xmpi_abort(msg='error allocating buf_dp_size in xmpi_allgatherv')
780 : : indx_dp=1
781 [ # # ]: 0 : do ii=1,nb
782 : 0 : n1=dimxval(ii,1); n2=dimxval(ii,2)
783 [ # # ]: 0 : do i2=1,n2
784 [ # # ]: 0 : buf_dp(indx_dp:indx_dp+n1-1)=xval_in(ii)%value(1:n1,i2)
785 : 0 : indx_dp=indx_dp+n1
786 : : end do
787 : : end do
788 : :
789 : : call xmpi_allgatherv(buf_int,buf_int_size,buf_dp,buf_dp_size,buf_int_all, &
790 : 0 : & buf_int_size_all,buf_dp_all,buf_dp_size_all,comm,ierr)
791 : :
792 : :
793 : 0 : nb_out=buf_int_size_all/2
794 : :
795 : 0 : indx_int=1;indx_dp=1
796 [ # # ]: 0 : do ii=1,nb_out
797 : 0 : n1=buf_int_all(indx_int)
798 : 0 : n2=buf_int_all(indx_int+1)
799 : 0 : indx_int=indx_int+2
800 [ # # ]: 0 : if (allocated(xval_out(ii)%value)) then
801 : 0 : ABI_FREE(xval_out(ii)%value)
802 : : end if
803 [ # # # # : 0 : ABI_STAT_MALLOC(xval_out(ii)%value,(n1,n2), ierr)
# # # # #
# # # # #
# # # # #
# ]
804 [ # # ]: 0 : if (ierr/= 0) call xmpi_abort(msg='error allocating xval_out%value in xmpi_allgatherv')
805 [ # # ]: 0 : do i2=1,n2
806 [ # # ]: 0 : xval_out(ii)%value(1:n1,i2)=buf_dp_all(indx_dp:indx_dp+n1-1)
807 : 0 : indx_dp=indx_dp+n1
808 : : end do
809 : : end do
810 : :
811 : :
812 [ # # ]: 0 : ABI_FREE(buf_dp_all)
813 [ # # ]: 0 : ABI_FREE(buf_int_all)
814 [ # # ]: 0 : ABI_FREE(buf_int)
815 [ # # ]: 0 : ABI_FREE(buf_dp)
816 [ # # ]: 0 : ABI_FREE(dimxval)
817 : :
818 : : end if
819 : :
820 : : #else
821 : : do ii=1,size(xval_in,1)
822 : : n1=size(xval_in(ii)%value,1)
823 : : n2=size(xval_in(ii)%value,2)
824 : : if (allocated(xval_out(ii)%value)) then
825 : : ABI_FREE(xval_out(ii)%value)
826 : : end if
827 : : ABI_STAT_MALLOC(xval_out(ii)%value,(n1,n2), ierr)
828 : : if (ierr/= 0) call xmpi_abort(msg='error allocating xval_out%value in xmpi_allgatherv')
829 : : xval_out(ii)%value=xval_in(ii)%value
830 : : end do
831 : : #endif
832 : :
833 [ # # # # : 0 : end subroutine xmpi_allgatherv_coeff2d
# # # # ]
834 : : !!***
835 : :
836 : : !!****f* ABINIT/xmpi_allgatherv_coeff2d_indx
837 : : !! NAME
838 : : !! xmpi_allgatherv_coeff2d_indx
839 : : !!
840 : : !! FUNCTION
841 : : !! Gathers data from all tasks and delivers it to all.
842 : : !! Target: coeff2_type 1D-structure
843 : : !! use of an indirect index to sort data
844 : : !!
845 : : !! INPUTS
846 : : !! xval_in = coeff2d_type array structure
847 : : !! comm= MPI communicator
848 : : !! indx= gives the indexes of xval_in in xval_out.
849 : : !! xval_in(i) will be transfered in xval_out(indx(i))
850 : : !!
851 : : !! OUTPUT
852 : : !! xval_out = coeff2d_type array structure
853 : : !! ierr= exit status, a non-zero value meaning there is an error
854 : : !!
855 : : !! SOURCE
856 : :
857 [ # # # # : 0 : subroutine xmpi_allgatherv_coeff2d_indx(xval_in,xval_out,comm,indx,ierr)
# # # # #
# # # #
# ]
858 : :
859 : : !Arguments ------------------------------------
860 : : !scalars
861 : : integer,intent(in) :: comm
862 : : integer,intent(out) :: ierr
863 : : !arrays
864 : : integer,intent(in) :: indx(:)
865 : : type(coeff2_type),intent(in) :: xval_in(:)
866 : : type(coeff2_type),intent(out) :: xval_out(:)
867 : :
868 : : !Local variables-------------------------------
869 : : !scalars
870 : : integer :: ii,ival,n1,n2,nb
871 : : #if defined HAVE_MPI
872 : : integer :: buf_int_size,buf_int_size_all,buf_dp_size,buf_dp_size_all
873 : : integer :: i2,indx_int,indx_dp,nb_out,nproc
874 : : #endif
875 : : !arrays
876 : : #if defined HAVE_MPI
877 : 0 : integer, allocatable :: buf_int(:),buf_int_all(:)
878 : 0 : integer, allocatable :: dimxval(:,:)
879 : 0 : real(dp),allocatable :: buf_dp(:),buf_dp_all(:)
880 : : #endif
881 : :
882 : : ! *************************************************************************
883 : :
884 : 0 : ierr=0 ; nb = size(xval_in,1)
885 : :
886 : : #if defined HAVE_MPI
887 [ # # ]: 0 : if (comm == MPI_COMM_NULL) return
888 : 0 : nproc=xmpi_comm_size(comm)
889 [ # # # # ]: 0 : if (comm==MPI_COMM_SELF.or.nproc==1) then
890 : : #endif
891 [ # # ]: 0 : do ii=1,nb
892 : 0 : n1=size(xval_in(ii)%value,1)
893 : 0 : n2=size(xval_in(ii)%value,2)
894 : 0 : ival=indx(ii)
895 [ # # ]: 0 : if (allocated(xval_out(ival)%value)) then
896 : 0 : ABI_FREE(xval_out(ival)%value)
897 : : end if
898 [ # # # # : 0 : ABI_STAT_MALLOC(xval_out(ival)%value,(n1,n2), ierr)
# # # # #
# # # # #
# # # # #
# ]
899 [ # # ]: 0 : if (ierr/= 0) call xmpi_abort(msg='error allocating xval_out%value in xmpi_allgatherv')
900 [ # # # # : 0 : xval_out(ii)%value=xval_in(ival)%value
# # # # #
# # # # #
# # ]
901 : : end do
902 : : return
903 : :
904 : : #if defined HAVE_MPI
905 : : end if
906 : :
907 : 0 : buf_dp_size=0
908 [ # # # # : 0 : ABI_STAT_MALLOC(dimxval,(nb,2), ierr)
# # # # #
# # # ]
909 [ # # ]: 0 : if (ierr/= 0) call xmpi_abort(msg='error allocating dimxval in xmpi_allgatherv')
910 [ # # ]: 0 : do ii=1,nb
911 : 0 : dimxval(ii,1)=size(xval_in(ii)%value,dim=1)
912 : 0 : dimxval(ii,2)=size(xval_in(ii)%value,dim=2)
913 : 0 : buf_dp_size=buf_dp_size+dimxval(ii,1)*dimxval(ii,2)
914 : : end do
915 : :
916 : 0 : buf_int_size=3*nb
917 [ # # # # : 0 : ABI_STAT_MALLOC(buf_int,(buf_int_size), ierr)
# # # # #
# # # ]
918 [ # # ]: 0 : if (ierr/= 0) call xmpi_abort(msg='error allocating buf_int in xmpi_allgatherv')
919 : : indx_int=1
920 [ # # ]: 0 : do ii=1,nb
921 : 0 : buf_int(indx_int )=dimxval(ii,1)
922 : 0 : buf_int(indx_int+1)=dimxval(ii,2)
923 : 0 : buf_int(indx_int+2)=indx(ii)
924 : 0 : indx_int=indx_int+3
925 : : end do
926 : :
927 [ # # # # : 0 : ABI_STAT_MALLOC(buf_dp,(buf_dp_size), ierr)
# # # # #
# # # ]
928 [ # # ]: 0 : if (ierr/= 0) call xmpi_abort(msg='error allocating buf_dp in xmpi_allgatherv')
929 : : indx_dp=1
930 [ # # ]: 0 : do ii=1,nb
931 : 0 : n1=dimxval(ii,1); n2=dimxval(ii,2)
932 [ # # ]: 0 : do i2=1,n2
933 [ # # ]: 0 : buf_dp(indx_dp:indx_dp+n1-1)=xval_in(ii)%value(1:n1,i2)
934 : 0 : indx_dp=indx_dp+n1
935 : : end do
936 : : end do
937 : :
938 : : call xmpi_allgatherv(buf_int,buf_int_size,buf_dp,buf_dp_size,buf_int_all, &
939 : 0 : & buf_int_size_all,buf_dp_all,buf_dp_size_all,comm,ierr)
940 : :
941 : 0 : nb_out=buf_int_size_all/3
942 : 0 : indx_int=1;indx_dp=1
943 [ # # ]: 0 : do ii=1,nb_out
944 : 0 : n1=buf_int_all(indx_int)
945 : 0 : n2=buf_int_all(indx_int+1)
946 : 0 : ival=buf_int_all(indx_int+2)
947 : 0 : indx_int=indx_int+3
948 [ # # ]: 0 : if (allocated(xval_out(ival)%value)) then
949 : 0 : ABI_FREE(xval_out(ival)%value)
950 : : end if
951 [ # # # # : 0 : ABI_STAT_MALLOC(xval_out(ival)%value,(n1,n2), ierr)
# # # # #
# # # # #
# # # # #
# ]
952 [ # # ]: 0 : if (ierr/= 0) call xmpi_abort(msg='error allocating xval_out%value in xmpi_allgatherv')
953 [ # # ]: 0 : do i2=1,n2
954 [ # # ]: 0 : xval_out(ival)%value(1:n1,i2)=buf_dp_all(indx_dp:indx_dp+n1-1)
955 : 0 : indx_dp=indx_dp+n1
956 : : end do
957 : : end do
958 : :
959 [ # # ]: 0 : ABI_FREE(buf_dp_all)
960 [ # # ]: 0 : ABI_FREE(buf_int_all)
961 [ # # ]: 0 : ABI_FREE(buf_int)
962 [ # # ]: 0 : ABI_FREE(buf_dp)
963 [ # # ]: 0 : ABI_FREE(dimxval)
964 : : #endif
965 : :
966 : : end subroutine xmpi_allgatherv_coeff2d_indx
967 : : !!***
968 : :
969 : : !!****f* ABINIT/xmpi_allgatherv_dc
970 : : !! NAME
971 : : !! xmpi_allgatherv_dc
972 : : !!
973 : : !! FUNCTION
974 : : !! Gathers data from all tasks and delivers it to all.
975 : : !! Target: one-dimensional double complex arrays.
976 : : !!
977 : : !! INPUTS
978 : : !! xval= buffer array
979 : : !! recvcounts= number of received elements
980 : : !! displs= relative offsets for incoming data
981 : : !! nelem= number of elements
982 : : !! comm= MPI communicator
983 : : !!
984 : : !! OUTPUT
985 : : !! ier= exit status, a non-zero value meaning there is an error
986 : : !!
987 : : !! SIDE EFFECTS
988 : : !! recvbuf= received buffer
989 : : !!
990 : : !! SOURCE
991 : :
992 [ - + - + : 8369 : subroutine xmpi_allgatherv_dc(xval,nelem,recvbuf,recvcounts,displs,comm,ier)
- + - + ]
993 : :
994 : : !Arguments-------------------------
995 : : complex(dp), DEV_CONTARRD intent(in) :: xval(:)
996 : : complex(dp), DEV_CONTARRD intent(inout) :: recvbuf(:)
997 : : integer,intent(in) :: recvcounts(:),displs(:)
998 : : integer,intent(in) :: nelem,comm
999 : : integer,intent(out) :: ier
1000 : :
1001 : : !Local variables--------------
1002 : : integer :: cc,dd
1003 : : ! *************************************************************************
1004 : :
1005 : 8369 : ier=0
1006 : : #if defined HAVE_MPI
1007 [ + - ]: 8369 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
1008 : : call MPI_ALLGATHERV(xval,nelem,MPI_DOUBLE_COMPLEX,recvbuf,recvcounts,displs,&
1009 [ - + - - : 8369 : & MPI_DOUBLE_COMPLEX,comm,ier)
- - - + -
- - - - +
- + - + -
- - + -
- ]
1010 [ # # ]: 0 : else if (comm == MPI_COMM_SELF) then
1011 : : #endif
1012 [ # # ]: 0 : dd=0;if (size(displs)>0) dd=displs(1)
1013 [ # # ]: 0 : cc=size(xval);if (size(recvcounts)>0) cc=recvcounts(1)
1014 [ # # ]: 0 : recvbuf(dd+1:dd+cc)=xval(1:cc)
1015 : : #if defined HAVE_MPI
1016 : : end if
1017 : : #endif
1018 : 8369 : end subroutine xmpi_allgatherv_dc
1019 : : !!***
|
