Line data Source code
1 : !!****m* ABINIT/m_paral_pert
2 : !! NAME
3 : !! m_paral_pert
4 : !!
5 : !! FUNCTION
6 : !! This module provides routines to manage the parallelisation/distribution
7 : !! over perturbations
8 : !!
9 : !! COPYRIGHT
10 : !! Copyright (C) 2013-2026 ABINIT group (MT,FJ,MD)
11 : !! This file is distributed under the terms of the
12 : !! GNU General Public License, see ~abinit/COPYING
13 : !! or http://www.gnu.org/copyleft/gpl.txt .
14 : !! For the initials of contributors, see ~abinit/doc/developers/contributors.txt.
15 : !!
16 : !! SOURCE
17 :
18 : #if defined HAVE_CONFIG_H
19 : #include "config.h"
20 : #endif
21 :
22 : #include "abi_common.h"
23 :
24 : MODULE m_paral_pert
25 :
26 : use defs_basis
27 : use m_abicore
28 : use m_errors
29 : use m_xmpi
30 : use m_dtset
31 :
32 : use defs_abitypes, only : MPI_type
33 : use m_time, only : timab
34 : use m_copy, only : deep_copy
35 : use m_paw_an, only : paw_an_type, paw_an_free, paw_an_redistribute
36 : use m_paw_ij, only : paw_ij_type, paw_ij_free, paw_ij_redistribute
37 : use m_pawfgrtab, only : pawfgrtab_type, pawfgrtab_free, pawfgrtab_redistribute
38 : use m_pawrhoij, only : pawrhoij_type, pawrhoij_free, pawrhoij_redistribute
39 : use m_paral_atom,only : get_atm_proc
40 : use m_mpinfo, only : initmpi_atom
41 :
42 : implicit none
43 :
44 : private
45 :
46 : !public procedures.
47 : public :: set_pert_comm
48 : public :: unset_pert_comm
49 : public :: set_pert_paw
50 : public :: unset_pert_paw
51 :
52 : !private procedures.
53 : private :: get_exchatom_list
54 : private :: get_exchatom_list1
55 : !!***
56 :
57 : CONTAINS
58 : !!***
59 :
60 : !----------------------------------------------------------------------
61 :
62 : !!****f* m_paral_pert/set_pert_comm
63 : !! NAME
64 : !! set_pert_comm
65 : !!
66 : !! FUNCTION
67 : !! Set the MPI communicators over the perturbed cell
68 : !!
69 : !! INPUTS
70 : !! nppert=number of processes for the parallelization over perturbations
71 : !!
72 : !! SIDE EFFECTS
73 : !! mpi_enreg=information about MPI parallelization
74 : !!
75 : !! SOURCE
76 :
77 716 : subroutine set_pert_comm(mpi_enreg,nppert)
78 :
79 : !Arguments ---------------------------------------------
80 : !scalars
81 : integer,intent(in) :: nppert
82 : type(MPI_type), intent(inout) :: mpi_enreg
83 :
84 : ! *************************************************************************
85 :
86 716 : if (mpi_enreg%paral_pert==0) return
87 :
88 : !New communicators for the perturbed cell
89 26 : mpi_enreg%comm_cell =mpi_enreg%comm_cell_pert
90 26 : mpi_enreg%me_cell =xmpi_comm_rank(mpi_enreg%comm_cell)
91 26 : mpi_enreg%nproc_cell=mpi_enreg%nproc/nppert
92 :
93 : !Adjust other communicators
94 26 : mpi_enreg%comm_kpt =mpi_enreg%comm_cell
95 26 : mpi_enreg%me_kpt =mpi_enreg%me_cell
96 26 : mpi_enreg%comm_kptband=mpi_enreg%comm_cell
97 26 : mpi_enreg%comm_wvl =mpi_enreg%comm_cell
98 :
99 : end subroutine set_pert_comm
100 : !!***
101 :
102 : !----------------------------------------------------------------------
103 :
104 : !!****f* m_paral_pert/unset_pert_comm
105 : !! NAME
106 : !! unset_pert_comm
107 : !!
108 : !! FUNCTION
109 : !! Unset the MPI communicators over the perturbed cell; restore the global communicators.
110 : !!
111 : !! SIDE EFFECTS
112 : !! mpi_enreg=information about MPI parallelization
113 : !!
114 : !! SOURCE
115 :
116 716 : subroutine unset_pert_comm(mpi_enreg)
117 :
118 : !Arguments ---------------------------------------------
119 : !scalars
120 : type(MPI_type), intent(inout) :: mpi_enreg
121 :
122 : ! *************************************************************************
123 :
124 716 : if (mpi_enreg%paral_pert==0) return
125 :
126 : !New communicators for the cell
127 26 : mpi_enreg%comm_cell =mpi_enreg%comm_world
128 26 : mpi_enreg%nproc_cell=mpi_enreg%nproc
129 26 : mpi_enreg%me_cell =mpi_enreg%me
130 :
131 : !Adjust other communicators
132 26 : mpi_enreg%comm_kpt =mpi_enreg%comm_cell
133 26 : mpi_enreg%me_kpt =mpi_enreg%me_cell
134 26 : mpi_enreg%comm_kptband=mpi_enreg%comm_cell
135 26 : mpi_enreg%comm_wvl =mpi_enreg%comm_cell
136 :
137 : end subroutine unset_pert_comm
138 : !!***
139 :
140 : !----------------------------------------------------------------------
141 :
142 : !!****f* m_paral_pert/set_pert_paw
143 : !! NAME
144 : !! set_pert_paw
145 : !!
146 : !! FUNCTION
147 : !! Set PAW data for the parallelization over perturbations:
148 : !! Set MPI communicator over atomic sites
149 : !! Redistribute PAW on-site data
150 : !!
151 : !! INPUTS
152 : !! dtset <type(dataset_type)>=all input variables for this dataset
153 : !!
154 : !! OUTPUT
155 : !! paw_an_out(my_natom)<type(paw_an_type)>= --optional--
156 : !! redistributed PAW arrays given on angular mesh
157 : !! if not present, paw_an is redistributed "in-place"
158 : !! paw__ij_out(my_natom)<type(paw_ij_type)>= --optional--
159 : !! redistributed PAW arrays given on (i,j) channels
160 : !! if not present, paw_ij is redistributed "in-place"
161 : !! pawfgrtab_out(my_natom)<type(pawfgrtab_type)>= --optional--
162 : !! redistributed PAW atomic data given on fine grid
163 : !! if not present, pawfgrtab is redistributed "in-place"
164 : !! pawrhoij_out(my_natom)<type(pawrhoij_type)>= --optional--
165 : !! redistributed PAW rhoij occupancies
166 : !! if not present, pawrhoij is redistributed "in-place"
167 : !! old_atmtab=save the indexes of the atoms treated by current proc
168 : !! old_comm_atom=save the identifier of the MPI communicator
169 : !!
170 : !! SIDE EFFECTS
171 : !! mpi_enreg=information about MPI parallelization
172 : !! my_natom=number of atoms treated by current processor
173 : !! paw_an(my_natom)<type(paw_an_type)>=PAW arrays given on angular mesh
174 : !! paw_ij(my_natom)<type(paw_ij_type)>=PAW arrays given on (i,j) channels
175 : !! pawfgrtab(my_natom)<type(pawfgrtab_type)>=PAW atomic data given on fine grid
176 : !! pawrhoij(my_natom)<type(pawrhoij_type)>=PAW rhoij occupancies
177 : !!
178 : !! SOURCE
179 :
180 716 : subroutine set_pert_paw(dtset,mpi_enreg,my_natom,old_atmtab,old_comm_atom,&
181 : & paw_an,paw_ij,pawfgrtab,pawrhoij,&
182 : & paw_an_out,paw_ij_out,pawfgrtab_out,pawrhoij_out)
183 :
184 : !Arguments ---------------------------------------------
185 : !scalars
186 : integer,intent(inout) :: my_natom
187 : integer,intent(inout) :: old_comm_atom
188 : type(dataset_type), intent(in) :: dtset
189 : type(MPI_type), intent(inout) :: mpi_enreg
190 : !arrays
191 : integer,pointer,intent(out) :: old_atmtab(:)
192 : type(paw_ij_type),allocatable,target,intent(inout) :: paw_ij(:)
193 : type(paw_ij_type),optional,pointer,intent(inout) :: paw_ij_out(:)
194 : type(paw_an_type),allocatable,target,intent(inout) :: paw_an(:)
195 : type(paw_an_type),optional,pointer,intent(inout) :: paw_an_out(:)
196 : type(pawfgrtab_type),allocatable,target,intent(inout) :: pawfgrtab(:)
197 : type(pawfgrtab_type),optional,pointer,intent(inout) :: pawfgrtab_out(:)
198 : type(pawrhoij_type),allocatable,target,intent(inout) :: pawrhoij(:)
199 : type(pawrhoij_type),optional,pointer,intent(inout) :: pawrhoij_out(:)
200 :
201 : !Local variables ---------------------------------------
202 : !scalars
203 : !Type of algo used for communications: 1-brute force, 2-asynchronous
204 : integer,parameter :: algo_option=2
205 : logical :: paral_atom
206 : !arrays
207 716 : integer,allocatable :: SendAtomProc(:), SendAtomList(:)
208 716 : integer,allocatable :: RecvAtomProc(:), RecvAtomList(:)
209 : real(dp) :: tsec(2)
210 :
211 : ! *************************************************************************
212 :
213 716 : call timab(593,1,tsec)
214 :
215 716 : paral_atom=(dtset%natom/=my_natom)
216 :
217 : !Default value when parallelization over atomic sites is not activated
218 716 : if ((mpi_enreg%paral_pert==0).or.(.not.paral_atom).or.(dtset%usepaw==0)) then
219 696 : old_comm_atom=mpi_enreg%comm_atom
220 696 : call deep_copy(mpi_enreg%my_atmtab,old_atmtab)
221 696 : if (present(pawrhoij_out)) pawrhoij_out=>pawrhoij
222 696 : if (present(paw_ij_out)) paw_ij_out=>paw_ij
223 696 : if (present(paw_an_out)) paw_an_out=>paw_an
224 696 : if (present(pawfgrtab_out)) pawfgrtab_out=>pawfgrtab
225 : return
226 : end if
227 :
228 : !Redefine communicator for atoms and store old communicator
229 :
230 20 : old_comm_atom=mpi_enreg%comm_atom
231 20 : call deep_copy(mpi_enreg%my_atmtab,old_atmtab)
232 20 : call initmpi_atom(dtset,mpi_enreg)
233 20 : my_natom=mpi_enreg%my_natom
234 :
235 : !If "asynchronous algo", determine lists of atoms to be exchanged
236 : ! between me and other processes
237 : if (algo_option==2) then
238 20 : call timab(594,1,tsec)
239 : call get_exchatom_list(old_comm_atom,mpi_enreg%comm_atom,old_atmtab,&
240 : & mpi_enreg%my_atmtab,dtset%natom,SendAtomProc,&
241 20 : & SendAtomList,RecvAtomProc,RecvAtomList)
242 20 : call timab(594,2,tsec)
243 : end if
244 :
245 : !Redistribute PAW on-site data
246 :
247 : !pawrhoij datastructure
248 20 : call timab(595,1,tsec)
249 20 : if (present(pawrhoij_out)) then
250 0 : nullify(pawrhoij_out)
251 : if (algo_option==1) then
252 : call pawrhoij_redistribute(pawrhoij,old_comm_atom,mpi_enreg%comm_atom,&
253 : & mpi_atmtab_in=old_atmtab,mpi_atmtab_out=mpi_enreg%my_atmtab,&
254 : & natom=dtset%natom,pawrhoij_out=pawrhoij_out)
255 : else if (algo_option==2) then
256 : call pawrhoij_redistribute(pawrhoij,old_comm_atom,mpi_enreg%comm_atom,&
257 : & mpi_atmtab_in=old_atmtab,mpi_atmtab_out=mpi_enreg%my_atmtab,&
258 : & natom=dtset%natom,pawrhoij_out=pawrhoij_out, &
259 : & SendAtomproc=SendAtomProc,SendAtomList=SendAtomList,&
260 0 : & RecvAtomProc=RecvAtomProc,RecvAtomList=RecvAtomList)
261 : end if
262 : else
263 : if (algo_option==1) then
264 : call pawrhoij_redistribute(pawrhoij,old_comm_atom,mpi_enreg%comm_atom,&
265 : & mpi_atmtab_in=old_atmtab,mpi_atmtab_out=mpi_enreg%my_atmtab,&
266 : & natom=dtset%natom)
267 20 : else if (algo_option==2) then
268 : call pawrhoij_redistribute(pawrhoij,old_comm_atom,mpi_enreg%comm_atom,&
269 : & mpi_atmtab_in=old_atmtab,mpi_atmtab_out=mpi_enreg%my_atmtab,&
270 : & natom=dtset%natom,&
271 : & SendAtomproc=SendAtomProc,SendAtomList=SendAtomList,&
272 : & RecvAtomProc=RecvAtomProc,RecvAtomList=RecvAtomList)
273 : end if
274 : end if
275 20 : call timab(595,2,tsec)
276 :
277 : !paw_ij datastructure
278 20 : call timab(596,1,tsec)
279 20 : if (present(paw_ij_out)) then
280 0 : nullify(paw_ij_out)
281 : if (algo_option==1) then
282 : call paw_ij_redistribute(paw_ij,old_comm_atom,mpi_enreg%comm_atom,&
283 : & mpi_atmtab_in=old_atmtab,mpi_atmtab_out=mpi_enreg%my_atmtab,&
284 : & natom=dtset%natom,paw_ij_out=paw_ij_out)
285 : else if (algo_option==2) then
286 : call paw_ij_redistribute(paw_ij,old_comm_atom,mpi_enreg%comm_atom,&
287 : & mpi_atmtab_in=old_atmtab,mpi_atmtab_out=mpi_enreg%my_atmtab,&
288 : & natom=dtset%natom,paw_ij_out=paw_ij_out,&
289 : & SendAtomproc=SendAtomProc,SendAtomList=SendAtomList,&
290 0 : & RecvAtomProc=RecvAtomProc,RecvAtomList=RecvAtomList)
291 : end if
292 : else
293 : if (algo_option==1) then
294 : call paw_ij_redistribute(paw_ij,old_comm_atom,mpi_enreg%comm_atom,&
295 : & mpi_atmtab_in=old_atmtab,mpi_atmtab_out=mpi_enreg%my_atmtab,&
296 : & natom=dtset%natom)
297 20 : else if (algo_option==2) then
298 : call paw_ij_redistribute(paw_ij,old_comm_atom,mpi_enreg%comm_atom,&
299 : & mpi_atmtab_in=old_atmtab,mpi_atmtab_out=mpi_enreg%my_atmtab,&
300 : & natom=dtset%natom,&
301 : & SendAtomproc=SendAtomProc,SendAtomList=SendAtomList,&
302 : & RecvAtomProc=RecvAtomProc,RecvAtomList=RecvAtomList)
303 : end if
304 : end if
305 20 : call timab(596,2,tsec)
306 :
307 : !paw_an datastructure
308 20 : call timab(597,1,tsec)
309 20 : if (present(paw_an_out)) then
310 0 : nullify(paw_an_out)
311 : if (algo_option==1) then
312 : call paw_an_redistribute(paw_an,old_comm_atom,mpi_enreg%comm_atom,&
313 : & mpi_atmtab_in=old_atmtab,mpi_atmtab_out=mpi_enreg%my_atmtab,&
314 : & natom=dtset%natom,paw_an_out=paw_an_out)
315 : else if (algo_option==2) then
316 : call paw_an_redistribute(paw_an,old_comm_atom,mpi_enreg%comm_atom,&
317 : & mpi_atmtab_in=old_atmtab,mpi_atmtab_out=mpi_enreg%my_atmtab,&
318 : & natom=dtset%natom,paw_an_out=paw_an_out,&
319 : & SendAtomproc=SendAtomProc,SendAtomList=SendAtomList,&
320 0 : & RecvAtomProc=RecvAtomProc,RecvAtomList=RecvAtomList)
321 : end if
322 : else
323 : if (algo_option==1) then
324 : call paw_an_redistribute(paw_an,old_comm_atom,mpi_enreg%comm_atom,&
325 : & mpi_atmtab_in=old_atmtab,mpi_atmtab_out=mpi_enreg%my_atmtab,&
326 : & natom=dtset%natom)
327 20 : else if (algo_option==2) then
328 : call paw_an_redistribute(paw_an,old_comm_atom,mpi_enreg%comm_atom,&
329 : & mpi_atmtab_in=old_atmtab,mpi_atmtab_out=mpi_enreg%my_atmtab,&
330 : & natom=dtset%natom,&
331 : & SendAtomproc=SendAtomProc,SendAtomList=SendAtomList,&
332 : & RecvAtomProc=RecvAtomProc,RecvAtomList=RecvAtomList)
333 : end if
334 : end if
335 20 : call timab(597,2,tsec)
336 :
337 : !pawfgrtab datastructure
338 20 : call timab(598,1,tsec)
339 20 : if (present(pawfgrtab_out)) then
340 0 : nullify(pawfgrtab_out)
341 : if (algo_option==1) then
342 : call pawfgrtab_redistribute(pawfgrtab,old_comm_atom,mpi_enreg%comm_atom,&
343 : & mpi_atmtab_in=old_atmtab,mpi_atmtab_out=mpi_enreg%my_atmtab,&
344 : & natom=dtset%natom,pawfgrtab_out=pawfgrtab_out)
345 : else if (algo_option==2) then
346 : call pawfgrtab_redistribute(pawfgrtab,old_comm_atom,mpi_enreg%comm_atom,&
347 : & mpi_atmtab_in=old_atmtab,mpi_atmtab_out=mpi_enreg%my_atmtab,&
348 : & natom=dtset%natom,pawfgrtab_out=pawfgrtab_out,&
349 : & SendAtomproc=SendAtomProc,SendAtomList=SendAtomList,&
350 0 : & RecvAtomProc=RecvAtomProc,RecvAtomList=RecvAtomList)
351 : end if
352 : else
353 : if (algo_option==1) then
354 : call pawfgrtab_redistribute(pawfgrtab,old_comm_atom,mpi_enreg%comm_atom,&
355 : & mpi_atmtab_in=old_atmtab,mpi_atmtab_out=mpi_enreg%my_atmtab,&
356 : & natom=dtset%natom)
357 20 : else if (algo_option==2) then
358 : call pawfgrtab_redistribute(pawfgrtab,old_comm_atom,mpi_enreg%comm_atom,&
359 : & mpi_atmtab_in=old_atmtab,mpi_atmtab_out=mpi_enreg%my_atmtab,&
360 : & natom=dtset%natom,&
361 : & SendAtomproc=SendAtomProc,SendAtomList=SendAtomList,&
362 : & RecvAtomProc=RecvAtomProc,RecvAtomList=RecvAtomList)
363 : end if
364 : end if
365 20 : call timab(598,2,tsec)
366 :
367 : if (algo_option==2) then
368 20 : ABI_FREE(SendAtomProc)
369 20 : ABI_FREE(SendAtomList)
370 20 : ABI_FREE(RecvAtomProc)
371 20 : ABI_FREE(RecvAtomList)
372 : end if
373 :
374 20 : call timab(593,2,tsec)
375 :
376 : end subroutine set_pert_paw
377 : !!***
378 :
379 : !----------------------------------------------------------------------
380 :
381 : !!****f* m_paral_pert/unset_pert_paw
382 : !! NAME
383 : !! unset_pert_paw
384 : !!
385 : !! FUNCTION
386 : !! Unset PAW data after the parallelization over perturbations:
387 : !! Restore MPI communicator over atomic sites
388 : !! Restore PAW on-site data
389 : !!
390 : !! INPUTS
391 : !! dtset <type(dataset_type)>=all input variables for this dataset
392 : !! old_atmtab=index of atoms to restore
393 : !! old_comm_atom=MPI communicator to restore
394 : !! mpi_enreg=information about MPI parallelization
395 : !! my_natom=number of atoms treated by current processor
396 : !!
397 : !! OUTPUT
398 : !! paw_an_out(my_natom)<type(paw_an_type)>= --optional--
399 : !! redistributed PAW arrays given on angular mesh
400 : !! if not present, paw_an is restored "in-place"
401 : !! paw__ij_out(my_natom)<type(paw_ij_type)>= --optional--
402 : !! redistributed PAW arrays given on (i,j) channels
403 : !! if not present, paw_ij is restored "in-place"
404 : !! pawfgrtab_out(my_natom)<type(pawfgrtab_type)>= --optional--
405 : !! redistributed PAW atomic data given on fine grid
406 : !! if not present, pawfgrtab is restored "in-place"
407 : !! pawrhoij_out(my_natom)<type(pawrhoij_type)>= --optional--
408 : !! redistributed PAW rhoij occupancies
409 : !! if not present, pawrhoij is restored "in-place"
410 : !! old_atmtab=save the indexes of atoms treated by current proc
411 : !! old_comm_atom=save the identifier of the MPI communicator
412 : !!
413 : !! SIDE EFFECTS
414 : !! mpi_enreg=information about MPI parallelization
415 : !! my_natom=number of atoms treated by current processor
416 : !! paw_an(my_natom)<type(paw_an_type)>=PAW arrays given on angular mesh
417 : !! paw_ij(my_natom)<type(paw_ij_type)>=PAW arrays given on (i,j) channels
418 : !! pawfgrtab(my_natom)<type(pawfgrtab_type)>=PAW atomic data given on fine grid
419 : !! pawrhoij(my_natom)<type(pawrhoij_type)>=PAW rhoij occupancies
420 : !!
421 : !! SOURCE
422 :
423 716 : subroutine unset_pert_paw(dtset,mpi_enreg,my_natom,old_atmtab,old_comm_atom,&
424 : & paw_an,paw_ij,pawfgrtab,pawrhoij,&
425 : & paw_an_out,paw_ij_out,pawfgrtab_out,pawrhoij_out)
426 :
427 : !Arguments ---------------------------------------------
428 : !scalars
429 : integer,intent(inout) :: my_natom
430 : integer,intent(inout) :: old_comm_atom
431 : type(dataset_type), intent(in) :: dtset
432 : type(MPI_type), intent(inout) :: mpi_enreg
433 : !arrays
434 : integer,pointer,intent(inout) :: old_atmtab(:)
435 : type(paw_ij_type),allocatable,target,intent(inout) :: paw_ij(:)
436 : type(paw_ij_type),optional,pointer,intent(inout) :: paw_ij_out(:)
437 : type(paw_an_type),allocatable,target,intent(inout) :: paw_an(:)
438 : type(paw_an_type),optional,pointer,intent(inout) :: paw_an_out(:)
439 : type(pawfgrtab_type),allocatable,target,intent(inout) :: pawfgrtab(:)
440 : type(pawfgrtab_type),optional,pointer,intent(inout) :: pawfgrtab_out(:)
441 : type(pawrhoij_type),allocatable,target,intent(inout) :: pawrhoij(:)
442 : type(pawrhoij_type),optional,pointer,intent(inout) :: pawrhoij_out(:)
443 :
444 : !Local variables ---------------------------------------
445 : !scalars
446 : !Type of algo used for communications: 1-brute force, 2-asynchronous
447 : integer,parameter :: algo_option=2
448 : integer :: my_natom_old
449 : logical :: exchange,paral_atom
450 : !arrays
451 716 : integer,allocatable :: SendAtomProc(:), SendAtomList(:)
452 716 : integer,allocatable :: RecvAtomProc(:), RecvAtomList(:)
453 : real(dp) :: tsec(2)
454 :
455 : ! *************************************************************************
456 :
457 : !Nothing to do when parallelization over atomic sites is not activated
458 716 : if ((mpi_enreg%paral_pert==0).or.(dtset%usepaw==0)) return
459 20 : if (.not.associated(old_atmtab)) return
460 20 : paral_atom=(dtset%natom/=size(old_atmtab))
461 20 : if (.not.paral_atom) return
462 :
463 : !If "asynchronous algo", determine lists of atoms to be exchanged
464 : ! between me and other processes
465 20 : exchange=.true.
466 : if (present(pawrhoij_out).and.present(paw_ij_out).and. &
467 20 : & present(paw_an_out) .and.present(pawfgrtab_out)) exchange=.false.
468 : if (algo_option==2.and.exchange) then
469 20 : call timab(594,1,tsec)
470 20 : my_natom_old=size(old_atmtab)
471 : call get_exchatom_list1(mpi_enreg%comm_atom,old_comm_atom,mpi_enreg%my_atmtab,&
472 : & old_atmtab,dtset%natom,SendAtomProc,&
473 20 : & SendAtomList,RecvAtomProc,RecvAtomList)
474 20 : call timab(594,2,tsec)
475 : end if
476 :
477 : !Redistribute PAW on-site data (if in-place storage)
478 : !or destroy them (out-of-place storage)
479 :
480 : !pawrhoij datastructure
481 20 : call timab(595,1,tsec)
482 20 : if (present(pawrhoij_out)) then
483 0 : call pawrhoij_free(pawrhoij_out)
484 0 : ABI_FREE(pawrhoij_out)
485 : else
486 : if (algo_option==1) then
487 : call pawrhoij_redistribute(pawrhoij,mpi_enreg%comm_atom,old_comm_atom,&
488 : & mpi_atmtab_in=mpi_enreg%my_atmtab,mpi_atmtab_out=old_atmtab,&
489 : & natom=dtset%natom)
490 20 : else if (algo_option==2) then
491 : call pawrhoij_redistribute(pawrhoij,mpi_enreg%comm_atom,old_comm_atom,&
492 : & mpi_atmtab_in=mpi_enreg%my_atmtab,mpi_atmtab_out=old_atmtab,&
493 : & natom=dtset%natom,&
494 : & SendAtomproc=SendAtomProc,SendAtomList=SendAtomList,&
495 : & RecvAtomProc=RecvAtomProc,RecvAtomList=RecvAtomList)
496 : end if
497 : end if
498 20 : call timab(595,2,tsec)
499 :
500 : !paw_ij datastructure
501 20 : call timab(596,1,tsec)
502 20 : if (present(paw_ij_out)) then
503 0 : call paw_ij_free(paw_ij_out)
504 0 : ABI_FREE(paw_ij_out)
505 : else
506 : if (algo_option==1) then
507 : call paw_ij_redistribute(paw_ij,mpi_enreg%comm_atom,old_comm_atom,&
508 : & mpi_atmtab_in=mpi_enreg%my_atmtab,mpi_atmtab_out=old_atmtab,&
509 : & natom=dtset%natom)
510 20 : else if (algo_option==2) then
511 : call paw_ij_redistribute(paw_ij,mpi_enreg%comm_atom,old_comm_atom,&
512 : & mpi_atmtab_in=mpi_enreg%my_atmtab,mpi_atmtab_out=old_atmtab,&
513 : & natom=dtset%natom,&
514 : & SendAtomproc=SendAtomProc,SendAtomList=SendAtomList,&
515 : & RecvAtomProc=RecvAtomProc,RecvAtomList=RecvAtomList)
516 : end if
517 : end if
518 20 : call timab(596,2,tsec)
519 :
520 : !paw_an datastructure
521 20 : call timab(597,1,tsec)
522 20 : if (present(paw_an_out)) then
523 0 : call paw_an_free(paw_an_out)
524 0 : ABI_FREE(paw_an_out)
525 : else
526 : if (algo_option==1) then
527 : call paw_an_redistribute(paw_an,mpi_enreg%comm_atom,old_comm_atom,&
528 : & mpi_atmtab_in=mpi_enreg%my_atmtab,mpi_atmtab_out=old_atmtab,&
529 : & natom=dtset%natom)
530 20 : else if (algo_option==2) then
531 : call paw_an_redistribute(paw_an,mpi_enreg%comm_atom,old_comm_atom,&
532 : & mpi_atmtab_in=mpi_enreg%my_atmtab,mpi_atmtab_out=old_atmtab,&
533 : & natom=dtset%natom,&
534 : & SendAtomproc=SendAtomProc,SendAtomList=SendAtomList,&
535 : & RecvAtomProc=RecvAtomProc,RecvAtomList=RecvAtomList)
536 : end if
537 : end if
538 20 : call timab(597,2,tsec)
539 :
540 : !pawfgrtab datastructure
541 20 : call timab(598,1,tsec)
542 20 : if (present(pawfgrtab_out)) then
543 0 : call pawfgrtab_free(pawfgrtab_out)
544 0 : ABI_FREE(pawfgrtab_out)
545 : else
546 : if (algo_option==1) then
547 : call pawfgrtab_redistribute(pawfgrtab,mpi_enreg%comm_atom,old_comm_atom,&
548 : & mpi_atmtab_in=mpi_enreg%my_atmtab,mpi_atmtab_out=old_atmtab,&
549 : & natom=dtset%natom)
550 20 : else if (algo_option==2) then
551 : call pawfgrtab_redistribute(pawfgrtab,mpi_enreg%comm_atom,old_comm_atom,&
552 : & mpi_atmtab_in=mpi_enreg%my_atmtab,mpi_atmtab_out=old_atmtab,&
553 : & natom=dtset%natom,&
554 : & SendAtomproc=SendAtomProc,SendAtomList=SendAtomList,&
555 : & RecvAtomProc=RecvAtomProc,RecvAtomList=RecvAtomList)
556 : end if
557 : end if
558 20 : call timab(598,2,tsec)
559 :
560 : !Release some memory
561 20 : if (algo_option==2.and.exchange) then
562 20 : ABI_FREE(SendAtomProc)
563 20 : ABI_FREE(SendAtomList)
564 20 : ABI_FREE(RecvAtomProc)
565 20 : ABI_FREE(RecvAtomList)
566 : end if
567 :
568 : !Restore communicator for atoms
569 20 : ABI_FREE(old_atmtab)
570 20 : old_comm_atom=mpi_enreg%comm_atom
571 20 : call deep_copy(mpi_enreg%my_atmtab,old_atmtab)
572 20 : call initmpi_atom(dtset,mpi_enreg)
573 20 : my_natom=mpi_enreg%my_natom
574 :
575 20 : end subroutine unset_pert_paw
576 : !!***
577 :
578 : !----------------------------------------------------------------------
579 :
580 : !!****f* m_paral_atom/get_exchatom_list
581 : !! NAME
582 : !! get_exchatom_list
583 : !!
584 : !! FUNCTION
585 : !! This routine determine the list of atoms to be exchanged by current process and other processes.
586 : !! The initial communicator (mpicomm_in) should be a common ancestor of (mpicomm_in and mpicomm_out);
587 : !! It is splitted in "nbgroup" final communicators (mpicomm_out).
588 : !!
589 : !! INPUTS
590 : !! mpicomm_in=input MPI communicator (over atoms) among which atoms are initially distributed
591 : !! mpicomm_out=MPI communicator (over atoms) among which we want to distribute atoms
592 : !! my_atmtab_in= Index of atoms initially treated by current proc (communicator mpicomm_in)
593 : !! my_atmtab_out= Index of atoms finally treated by current proc (communicator mpicomm_out)
594 : !! natom = total number of atoms
595 : !! nbgroup = # of mpicomm_out communicators included in mpicomm_in
596 : !!
597 : !! OUTPUT
598 : !! For current proc :
599 : !! RecvAtomProc(:)= rank of processor from which I expect atom (in mpicomm_in)
600 : !! RecvAtomList(:)= indexes of atoms to be received by me
601 : !! RecvAtomList(irecv) are the atoms I expect from RecvAtomProc(irecv)
602 : !! SendAtomProc(:)= ranks of process destination of atom (in mpicomm_in)
603 : !! SendAtomList(:)= indexes of atoms to be sent by me
604 : !! SendAtomList(isend) are the atoms sent to SendAtomProc(isend)
605 : !!
606 : !! SOURCE
607 :
608 :
609 20 : subroutine get_exchatom_list(mpicomm_in,mpicomm_out,my_atmtab_in,my_atmtab_out,natom, &
610 : & SendAtomProc,SendAtomList,RecvAtomProc,RecvAtomList)
611 :
612 : !Arguments ---------------------------------------------
613 : !scalars
614 : integer,intent(in) :: mpicomm_in,mpicomm_out,natom
615 : !arrays
616 : integer,intent(in) :: my_atmtab_in(:),my_atmtab_out(:)
617 : integer,allocatable,intent(out) :: RecvAtomProc(:),RecvAtomList(:)
618 : integer,allocatable,intent(out) :: SendAtomList(:),SendAtomProc(:)
619 :
620 : !Local variables ---------------------------------------
621 : !scalars
622 : integer :: igroup,i1,ierr,ii,me_in,me_in_out,me_out,me_out0_in
623 : integer :: my_natom_in,my_natom_out,nbgroup,nbsend,nproc_in,nproc_max,nproc_out
624 : !arrays
625 : integer :: buf_int(3),rank0(1),ranks0_out_in(1)
626 20 : integer, allocatable :: buf_int_all(:),group(:),master_commout(:),procs(:),ranks(:)
627 20 : integer, allocatable :: ranks1(:,:),sizecomm(:)
628 :
629 : ! *************************************************************************
630 :
631 20 : nproc_in=xmpi_comm_size(mpicomm_in)
632 20 : me_in=xmpi_comm_rank(mpicomm_in)
633 20 : my_natom_in=size(my_atmtab_in)
634 20 : nproc_out=xmpi_comm_size(mpicomm_out)
635 20 : me_out=xmpi_comm_rank(mpicomm_out)
636 20 : my_natom_out=size(my_atmtab_out)
637 :
638 20 : rank0(1)=0
639 20 : call xmpi_comm_translate_ranks(mpicomm_out,1,rank0(1),mpicomm_in,ranks0_out_in(1))
640 20 : me_out0_in=ranks0_out_in(1)
641 :
642 60 : ABI_MALLOC(ranks,(1:nproc_in))
643 40 : ABI_MALLOC(sizecomm,(1:nproc_in))
644 40 : ABI_MALLOC(master_commout,(1:nproc_in))
645 60 : ABI_MALLOC(group,(0:nproc_in-1))
646 20 : buf_int(1)=me_out; buf_int(2)=me_out0_in; buf_int(3)=nproc_out;
647 :
648 60 : ABI_MALLOC(buf_int_all,(3*nproc_in))
649 20 : call xmpi_allgather(buf_int,3,buf_int_all,mpicomm_in,ierr)
650 20 : nbgroup=0;
651 20 : nproc_max=0
652 400 : ranks(:)=-1;group(:)=-1;sizecomm(:)=-1;master_commout(:)=-1
653 :
654 100 : do ii=1,nproc_in
655 80 : ranks(ii)=buf_int_all(3*ii-2) !me_out
656 80 : master_commout(ii)=buf_int_all(3*ii-1) !rank of me_out=0 of mpicomm_out expressed in mpicomm_in
657 :
658 100 : if (ranks(ii)==0) then
659 36 : nbgroup=nbgroup+1
660 36 : sizecomm(nbgroup)=buf_int_all(3*ii) !nproc_out
661 36 : group(master_commout(ii))=nbgroup
662 36 : if (sizecomm(nbgroup)>nproc_max) nproc_max=sizecomm(nbgroup)
663 : end if
664 :
665 : enddo
666 20 : ABI_FREE(buf_int_all)
667 :
668 :
669 80 : ABI_MALLOC(ranks1,(nbgroup,0:nproc_max-1))
670 148 : ranks1(:,:)=-1
671 100 : do ii=1,nproc_in
672 80 : me_in_out=ranks(ii)
673 80 : igroup=group(master_commout(ii))
674 100 : ranks1(igroup,me_in_out)=ii-1 !numbering of procs
675 : enddo
676 :
677 : !Send
678 20 : nbsend=0
679 20 : if (my_natom_in>0) then
680 30 : ABI_MALLOC(SendAtomList,(my_natom_in*nbgroup))
681 20 : ABI_MALLOC(SendAtomProc,(my_natom_in*nbgroup))
682 30 : ABI_MALLOC(procs,(my_natom_in))
683 28 : do igroup=1,nbgroup
684 18 : call get_atm_proc(my_atmtab_in,natom,sizecomm(igroup),procs)
685 46 : do i1=1,my_natom_in
686 18 : nbsend=nbsend+1
687 18 : SendAtomProc(nbsend)=ranks1(igroup,procs(i1))
688 36 : SendAtomList(nbsend)=my_atmtab_in(i1)
689 : end do
690 : end do
691 10 : ABI_FREE(procs)
692 : else
693 10 : ABI_MALLOC(SendAtomList,(0))
694 10 : ABI_MALLOC(SendAtomProc,(0))
695 : end if
696 :
697 : !recv
698 20 : if (my_natom_out>0) then !no return before because of xmpi_allgather and of the sending operation
699 54 : ABI_MALLOC(RecvAtomProc,(my_natom_out))
700 36 : ABI_MALLOC(RecvAtomList,(my_natom_out))
701 36 : RecvAtomList(:)=my_atmtab_out(:)
702 : !the atoms are put in increasing order,see get_my_atmtab so the procs are sorted by growing process
703 18 : call get_atm_proc(RecvAtomList,natom,nproc_in,RecvAtomProc)
704 : else
705 2 : ABI_MALLOC(RecvAtomList,(0))
706 2 : ABI_MALLOC(RecvAtomProc,(0))
707 : end if
708 :
709 20 : ABI_FREE(master_commout)
710 20 : ABI_FREE(ranks1)
711 20 : ABI_FREE(group)
712 20 : ABI_FREE(ranks)
713 20 : ABI_FREE(sizecomm)
714 :
715 20 : end subroutine get_exchatom_list
716 : !!***
717 :
718 : !----------------------------------------------------------------------
719 :
720 : !!****f* m_paral_atom/get_exchatom_list1
721 : !! NAME
722 : !! get_exchatom_list1
723 : !!
724 : !! FUNCTION
725 : !! This routine determine the list of atoms to be exchanged by current process and other processes.
726 : !! this function redistribute the atoms of one mpicomm_in among mpicomm_out
727 : !!
728 : !! INPUTS
729 : !! mpicomm_in=input MPI communicator (over atoms) among which atoms are initially distributed
730 : !! mpicomm_out=MPI communicator (over atoms) among which we want to distribute atoms
731 : !! my_atmtab_in= Index of atoms initially treated by current proc (communicator mpicomm_in)
732 : !! my_atmtab_out= Index of atoms finally treated by current proc (communicator mpicomm_out)
733 : !! natom = total number of atoms
734 : !!
735 : !! OUTPUT
736 : !! For current proc:
737 : !! RecvAtomProc(:)= rank of processor from which I expect atom (in mpicomm_out)
738 : !! RecvAtomList(:)= indexes of atoms to be received by me
739 : !! RecvAtomList(irecv) are the atoms I expect from RecvAtomProc(irecv)
740 : !! SendAtomProc(:)= ranks of process destination of atom (in mpicomm_out)
741 : !! SendAtomList(:)= indexes of atoms to be sent by me
742 : !! SendAtomList(isend) are the atoms sent to SendAtomProc(isend)
743 : !!
744 : !! NOTES
745 : !! Previously mpicomm_out has be split in several mpicomm_in.
746 : !! In our purpose, we only need to redistribute the atoms of one mpicomm_in among mpicomm_out
747 : !! because all structures of atoms we have to exchange have the same value in each mpicomm_in.
748 : !! The mpicomm_in we choose is the one in which the processor 0 of mpicomm_out belong
749 : !!
750 : !! SOURCE
751 :
752 20 : subroutine get_exchatom_list1(mpicomm_in,mpicomm_out,my_atmtab_in,my_atmtab_out,natom, &
753 : & SendAtomProc,SendAtomList,RecvAtomProc,RecvAtomList)
754 :
755 : !Arguments ---------------------------------------------
756 : !scalars
757 : integer,intent(in) :: mpicomm_in,mpicomm_out,natom
758 : !arrays
759 : integer,intent(in) :: my_atmtab_in(:),my_atmtab_out(:)
760 : integer,allocatable,intent(out) :: RecvAtomProc(:),RecvAtomList(:)
761 : integer,allocatable,intent(out) :: SendAtomList(:),SendAtomProc(:)
762 :
763 : !Local variables ---------------------------------------
764 : !scalars
765 : integer :: i1,ier,me_out,my_natom_in,my_natom_out,nproc_in,nproc_out
766 : logical :: sender
767 : !arrays
768 20 : integer,allocatable :: ranks_in(:),ranks_in_out(:)
769 :
770 : ! *************************************************************************
771 :
772 20 : me_out=xmpi_comm_rank(mpicomm_out)
773 20 : my_natom_in=size(my_atmtab_in)
774 20 : nproc_out=xmpi_comm_size(mpicomm_out)
775 20 : my_natom_out=size(my_atmtab_out)
776 20 : nproc_in=xmpi_comm_size(mpicomm_in)
777 :
778 20 : call xmpi_bcast(nproc_in,0,mpicomm_out,ier)
779 60 : ABI_MALLOC(ranks_in_out,(0:nproc_in-1))
780 :
781 : !All atoms are distributed among each mpicomm_in
782 : !redistribute the atoms of one mpicomm_in among mpicomm_out
783 :
784 : !Look for the communicator mpicomm_in from which me_out=0 belong
785 : !Get ranks of all processors of mpicomm_in expressed in mpicomm_out
786 20 : if (me_out==0) then
787 10 : ABI_MALLOC(ranks_in,(0:nproc_in-1))
788 51 : ranks_in=(/ (i1,i1=0,nproc_in-1 )/)
789 5 : call xmpi_comm_translate_ranks(mpicomm_in,nproc_in,ranks_in,mpicomm_out,ranks_in_out)
790 5 : ABI_FREE(ranks_in)
791 : end if
792 20 : call xmpi_bcast(ranks_in_out,0,mpicomm_out,ier)
793 :
794 : !Check if me_out is one of the sending proc.
795 : !(ie belongs to the mpicomm_in from which me_out belong)
796 20 : sender = .false.
797 46 : do i1=0,nproc_in-1
798 46 : if (me_out==ranks_in_out(i1)) then
799 : sender = .true.
800 : exit
801 : end if
802 : end do
803 :
804 : !Send
805 20 : if (my_natom_in>0.and.sender) then
806 30 : ABI_MALLOC(SendAtomList,(my_natom_in))
807 20 : ABI_MALLOC(SendAtomProc,(my_natom_in))
808 20 : SendAtomList(:)=my_atmtab_in(:)
809 : ! The atoms are put in increasing order,see get_my_atmtab
810 : ! so the procs are sorted by growing process
811 10 : call get_atm_proc(SendAtomList,natom,nproc_out,SendAtomProc)
812 : else
813 10 : ABI_MALLOC(SendAtomList,(0))
814 10 : ABI_MALLOC(SendAtomProc,(0))
815 : end if
816 :
817 : !Recv
818 20 : if (my_natom_out>0) then
819 30 : ABI_MALLOC(RecvAtomProc,(my_natom_out))
820 20 : ABI_MALLOC(RecvAtomList,(my_natom_out))
821 20 : RecvAtomList(:)=my_atmtab_out(:)
822 : ! The atoms are put in increasing order,see get_my_atmtab
823 : ! so the procs are sorted by growing process
824 10 : call get_atm_proc(RecvAtomList,natom,nproc_in,RecvAtomProc)
825 20 : RecvAtomProc(:)=ranks_in_out(RecvAtomProc(:))
826 : else
827 10 : ABI_MALLOC(RecvAtomList,(0))
828 10 : ABI_MALLOC(RecvAtomProc,(0))
829 : end if
830 :
831 20 : ABI_FREE(ranks_in_out)
832 :
833 20 : end subroutine get_exchatom_list1
834 : !!***
835 :
836 : !----------------------------------------------------------------------
837 :
838 : END MODULE m_paral_pert
839 : !!***
|
