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 12694 : 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 12694 : ier=0
33 : #if defined HAVE_MPI
34 12694 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
35 : call MPI_ALLGATHERV(xval,nelem,MPI_INTEGER,recvbuf,recvcounts,displs,&
36 12660 : & 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 12694 : 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 15314 : 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 15314 : ier=0
335 : #if defined HAVE_MPI
336 15314 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
337 : call MPI_ALLGATHERV(xval,nelem,MPI_DOUBLE_PRECISION,recvbuf,recvcounts,displs,&
338 15270 : & MPI_DOUBLE_PRECISION,comm,ier)
339 44 : else if (comm == MPI_COMM_SELF) then
340 : #endif
341 44 : dd=0;if (size(displs)>0) dd=displs(1)
342 44 : cc=size(xval);if (size(recvcounts)>0) cc=recvcounts(1)
343 136641 : recvbuf(dd+1:dd+cc)=xval(1:cc)
344 : #if defined HAVE_MPI
345 : end if
346 : #endif
347 15314 : 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 19798 : 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 19798 : integer, DEV_CONTARRD pointer :: my_recvcounts(:),my_displs(:)
484 :
485 : ! *************************************************************************
486 :
487 19798 : ier=0
488 : #if defined HAVE_MPI
489 19798 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
490 19720 : n1 = size(recvbuf,dim=1)
491 19720 : n2 = size(recvbuf,dim=2)
492 19720 : 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 19720 : ntot=int(n1,kind=int64)*n2*n3
498 19720 : if (ntot<=xmpi_maxint32_64) then
499 19720 : nn=nelem ; my_dt=MPI_DOUBLE_PRECISION
500 19720 : 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 19720 : & my_dt,comm,ier)
514 19720 : 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 78 : else if (comm == MPI_COMM_SELF) then
519 : #endif
520 78 : sz12=size(xval,1)*size(xval,2)
521 78 : dd=0;if (size(displs)>0) dd=displs(1)/sz12
522 78 : cc=size(xval,3);if (size(recvcounts)>0) cc=recvcounts(1)/sz12
523 6771276 : recvbuf(:,:,dd+1:dd+cc)=xval(:,:,1:cc)
524 : #if defined HAVE_MPI
525 : end if
526 : #endif
527 19798 : 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 19798 : 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 19798 : ier=0
568 : #if defined HAVE_MPI
569 19798 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
570 : call MPI_ALLGATHERV(xval,nelem,MPI_DOUBLE_PRECISION,recvbuf,recvcounts,displs,&
571 19720 : & MPI_DOUBLE_PRECISION,comm,ier)
572 78 : else if (comm == MPI_COMM_SELF) then
573 : #endif
574 78 : sz123=size(xval,1)*size(xval,2)*size(xval,3)
575 78 : dd=0;if (size(displs)>0) dd=displs(1)/sz123
576 78 : cc=size(xval,4);if (size(recvcounts)>0) cc=recvcounts(1)/sz123
577 23873700 : recvbuf(:,:,:,dd+1:dd+cc)=xval(:,:,:,1:cc)
578 : #if defined HAVE_MPI
579 : end if
580 : #endif
581 19798 : 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 8277 : 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 8277 : ier=0
1006 : #if defined HAVE_MPI
1007 8277 : if (comm /= MPI_COMM_SELF .and. comm /= MPI_COMM_NULL) then
1008 : call MPI_ALLGATHERV(xval,nelem,MPI_DOUBLE_COMPLEX,recvbuf,recvcounts,displs,&
1009 8277 : & 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 8277 : end subroutine xmpi_allgatherv_dc
1019 : !!***
|
