Line data Source code
1 : !!****m* ABINIT/m_mpinfo
2 : !! NAME
3 : !! m_mpinfo
4 : !!
5 : !! FUNCTION
6 : !!
7 : !! COPYRIGHT
8 : !! Copyright (C) 2008-2026 ABINIT group (MT, GG, XG, FJ, AR, MB, CMartins)
9 : !! This file is distributed under the terms of the
10 : !! GNU General Public License, see ~abinit/COPYING
11 : !! or http://www.gnu.org/copyleft/gpl.txt .
12 : !!
13 : !! TODO
14 : !! Change the name of the datatype: (MPI_|mpi_) is a reserved keyword
15 : !! and should not be used in client code!
16 : !!
17 : !! SOURCE
18 :
19 : #if defined HAVE_CONFIG_H
20 : #include "config.h"
21 : #endif
22 :
23 : #include "abi_common.h"
24 :
25 : MODULE m_mpinfo
26 :
27 : use defs_basis
28 : use m_errors
29 : use m_abicore
30 : USE_MPI
31 : use m_xmpi
32 : use m_sort
33 : use m_distribfft
34 : use m_dtset
35 :
36 : use defs_abitypes, only : MPI_type
37 : use m_fstrings, only : sjoin, ltoa
38 : use m_io_tools, only : file_exists, open_file
39 : use m_libpaw_tools, only : libpaw_write_comm_set
40 : use m_paral_atom, only : get_my_natom, get_my_atmtab
41 :
42 : implicit none
43 :
44 : private
45 :
46 : #if defined HAVE_MPI1
47 : include 'mpif.h'
48 : #endif
49 :
50 : !type, extends(mpi_type_base_t), public :: mpi_type
51 : !contains
52 : !end type mpi_type
53 : !!***
54 :
55 : public :: init_mpi_enreg ! Initialise a mpi_enreg structure with dataset independent values.
56 : public :: nullify_mpi_enreg ! nullify a mpi_enreg datastructure
57 : public :: destroy_mpi_enreg ! Free memory
58 : public :: copy_mpi_enreg ! Copy a mpi_enreg datastructure into another.
59 : public :: set_mpi_enreg_fft ! Set the content of a MPI datastructure in order to call fourwf/fourdp
60 : public :: unset_mpi_enreg_fft ! Unset the content of a MPI datastructure used to call fourwf/fourdp
61 : public :: ptabs_fourdp ! Return *pointers* to the internal MPI-FFT tables used in fourdp
62 : public :: ptabs_fourwf ! Return *pointers* to the internal MPI-FFT tables used in fourwf
63 : public :: mpi_distrib_is_ok ! Check if a MPI datastructure contains number of processors
64 : ! compatible (in terms of efficiency) with the number of spins/kpts/bands
65 : public :: proc_distrb_cycle ! Test a condition to cycle
66 : public :: proc_distrb_nband ! Return number of bands present on this cpu
67 : public :: proc_distrb_cycle_bands ! Return array of logicals for bands to cycle at this k and spin
68 : public :: proc_distrb_band ! Return array of me indices for bands at this k and spin
69 :
70 : public :: initmpi_seq ! Initializes the MPI information for sequential use.
71 : public :: initmpi_world ! %comm_world is redefined for the number of processors on which ABINIT is launched
72 :
73 : public :: initmpi_atom ! Initializes the mpi information for parallelism over atoms (PAW).
74 : public :: clnmpi_atom ! Cleans-up the mpi information for the parallelism over atoms (PAW).
75 :
76 : public :: initmpi_grid ! Initializes the MPI information for the grid
77 : public :: clnmpi_grid ! Cleans-up the mpi information for parallelism over grid (kpt/band/fft).
78 :
79 : public :: initmpi_img ! Initializes the mpi information for parallelism over images of the cell (npimage>1).
80 : public :: clnmpi_img ! Cleans-up the mpi information for parallelism over images of the cell (npimage>1).
81 :
82 : public :: initmpi_pert ! Creates group for Parallelization over Perturbations.
83 : public :: clnmpi_pert ! Cleans-up the mpi information for parallelization over perturbations.
84 :
85 : public :: initmpi_band ! Initializes the mpi information for band parallelism (paralbd=1).
86 :
87 : ! Helper functions.
88 : public :: pre_gather
89 : public :: pre_scatter
90 : public :: iwrite_fftdatar ! Select the subset of processors that will write density/potential files.
91 :
92 : public :: distrb2 ! Creates the tabs of repartition of processors for sharing the jobs on k-points, spins and bands.
93 : public :: distrb2_hf ! Creates the tabs of repartition for Hartree-Fock calculations.
94 : !!***
95 :
96 : CONTAINS !========================================================================================
97 : !!***
98 :
99 : !!****f* m_mpinfo/init_mpi_enreg
100 : !! NAME
101 : !! init_mpi_enreg
102 : !!
103 : !! FUNCTION
104 : !! Initialise a mpi_enreg structure with dataset independent values.
105 : !! Other values of mpi_enreg are dataset dependent, and should NOT be initialized
106 : !! inside abinit.F90.
107 : !! XG 071118: At present several other values are
108 : !! initialized temporarily inside invars1.F90, FROM THE DTSET
109 : !! VALUES. In order to relieve the present constraint of having mpi_enreg
110 : !! equal for all datasets, they should be reinitialized from the dtset values
111 : !! inside invars2m.F90 (where there is a loop over datasets, and finally,
112 : !! reinitialized from the dataset values inside each big routine called by driver,
113 : !! according to the kind of parallelisation that is needed there.
114 : !! One should have one init_mpi_dtset routine (or another name) per big routine (well, there is also
115 : !! the problem of TDDFT ...). Also, one should have a clean_mpi_dtset called at the end
116 : !! of each big routine, as well as invars1.F90 or invars2m.F90 .
117 : !!
118 : !! SIDE EFFECTS
119 : !! MPI_enreg<MPI_type>=All pointer set to null().
120 : !!
121 : !! SOURCE
122 :
123 8392 : subroutine init_mpi_enreg(mpi_enreg)
124 :
125 : !Arguments ------------------------------------
126 : class(MPI_type),intent(inout) :: MPI_enreg
127 : ! *********************************************************************
128 :
129 : !Default for sequential use
130 8392 : call initmpi_seq(mpi_enreg)
131 :
132 : !Initialize MPI
133 : #if defined HAVE_MPI
134 8392 : mpi_enreg%comm_world=xmpi_world
135 8392 : mpi_enreg%me = xmpi_comm_rank(xmpi_world)
136 8392 : mpi_enreg%nproc = xmpi_comm_size(xmpi_world)
137 : #endif
138 :
139 8392 : end subroutine init_mpi_enreg
140 : !!***
141 :
142 : !----------------------------------------------------------------------
143 :
144 : !!****f* m_mpinfo/nullify_mpi_enreg
145 : !! NAME
146 : !! nullify_mpi_enreg
147 : !!
148 : !! FUNCTION
149 : !! nullify a mpi_enreg datastructure
150 : !!
151 : !! SOURCE
152 :
153 525259 : subroutine nullify_mpi_enreg(MPI_enreg)
154 :
155 : !Arguments ------------------------------------
156 : class(MPI_type),intent(inout) :: MPI_enreg
157 : ! *********************************************************************
158 :
159 525259 : nullify(mpi_enreg%nscatterarr)
160 525259 : nullify(mpi_enreg%ngatherarr)
161 525259 : nullify(mpi_enreg%my_atmtab)
162 525259 : nullify(mpi_enreg%distribfft)
163 :
164 98 : end subroutine nullify_mpi_enreg
165 : !!***
166 :
167 : !----------------------------------------------------------------------
168 :
169 : !!****f* m_mpinfo/destroy_mpi_enreg
170 : !! NAME
171 : !! destroy_mpi_enreg
172 : !!
173 : !! FUNCTION
174 : !! Destroy a mpi_enreg datastructure
175 : !!
176 : !! SOURCE
177 :
178 522788 : subroutine destroy_mpi_enreg(MPI_enreg)
179 :
180 : !Arguments ------------------------------------
181 : class(MPI_type),intent(inout) :: MPI_enreg
182 : ! *********************************************************************
183 :
184 522788 : if (associated(mpi_enreg%distribfft)) then
185 519342 : call mpi_enreg%distribfft%free()
186 519342 : ABI_FREE(mpi_enreg%distribfft)
187 : nullify(mpi_enreg%distribfft)
188 : end if
189 :
190 522788 : ABI_SFREE(mpi_enreg%proc_distrb)
191 522788 : ABI_SFREE(mpi_enreg%kptdstrb)
192 522788 : ABI_SFREE(mpi_enreg%kpt_loc2fbz_sp)
193 522788 : ABI_SFREE(mpi_enreg%kpt_loc2ibz_sp)
194 522788 : ABI_SFREE(mpi_enreg%mkmem)
195 522788 : ABI_SFREE(mpi_enreg%my_kpttab)
196 522788 : if (associated(mpi_enreg%my_atmtab)) then
197 0 : ABI_FREE(mpi_enreg%my_atmtab)
198 : nullify(mpi_enreg%my_atmtab)
199 : end if
200 522788 : ABI_SFREE(mpi_enreg%distrb_pert)
201 522788 : ABI_SFREE(mpi_enreg%distrb_img)
202 522788 : ABI_SFREE(mpi_enreg%my_imgtab)
203 522788 : ABI_SFREE(mpi_enreg%my_kgtab)
204 522788 : ABI_SFREE(mpi_enreg%distrb_hf)
205 :
206 : !Do not deallocate wavelet denspot distribution arrays, they are handled by BigDFT.
207 :
208 522788 : end subroutine destroy_mpi_enreg
209 : !!***
210 :
211 : !----------------------------------------------------------------------
212 :
213 : !!****f* m_mpinfo/copy_mpi_enreg
214 : !! NAME
215 : !! copy_mpi_enreg
216 : !!
217 : !! FUNCTION
218 : !! Copy a mpi_enreg datastructure into another
219 : !!
220 : !! SOURCE
221 :
222 2270 : subroutine copy_mpi_enreg(MPI_enreg1, MPI_enreg2)
223 :
224 : !Arguments ------------------------------------
225 : class(MPI_type),intent(in) :: mpi_enreg1
226 : class(MPI_type),intent(out) :: MPI_enreg2
227 :
228 : !Local variables-------------------------------
229 : integer :: sz1,sz2,sz3
230 : ! *********************************************************************
231 :
232 : !scalars
233 2270 : mpi_enreg2%comm_world=mpi_enreg1%comm_world
234 2270 : mpi_enreg2%me=mpi_enreg1%me
235 2270 : mpi_enreg2%nproc=mpi_enreg1%nproc
236 2270 : mpi_enreg2%paral_spinor=mpi_enreg1%paral_spinor
237 2270 : mpi_enreg2%paralbd=mpi_enreg1%paralbd
238 2270 : mpi_enreg2%me_fft=mpi_enreg1%me_fft
239 2270 : mpi_enreg2%me_band=mpi_enreg1%me_band
240 2270 : mpi_enreg2%nproc_fft=mpi_enreg1%nproc_fft
241 2270 : mpi_enreg2%paral_kgb=mpi_enreg1%paral_kgb
242 2270 : mpi_enreg2%me_g0=mpi_enreg1%me_g0
243 2270 : mpi_enreg2%me_g0_fft=mpi_enreg1%me_g0_fft
244 2270 : mpi_enreg2%paral_pert=mpi_enreg1%paral_pert
245 2270 : mpi_enreg2%me_pert=mpi_enreg1%me_pert
246 2270 : mpi_enreg2%nproc_pert=mpi_enreg1%nproc_pert
247 2270 : mpi_enreg2%comm_pert=mpi_enreg1%comm_pert
248 2270 : mpi_enreg2%comm_bandfft=mpi_enreg1%comm_bandfft
249 2270 : mpi_enreg2%comm_band=mpi_enreg1%comm_band
250 2270 : mpi_enreg2%comm_fft=mpi_enreg1%comm_fft
251 2270 : mpi_enreg2%nproc_band=mpi_enreg1%nproc_band
252 2270 : mpi_enreg2%comm_bandspinorfft=mpi_enreg1%comm_bandspinorfft
253 2270 : mpi_enreg2%comm_kpt=mpi_enreg1%comm_kpt
254 2270 : mpi_enreg2%me_kpt=mpi_enreg1%me_kpt
255 2270 : mpi_enreg2%nproc_spkpt=mpi_enreg1%nproc_spkpt
256 6810 : mpi_enreg2%my_isppoltab=mpi_enreg1%my_isppoltab
257 2270 : mpi_enreg2%my_natom=mpi_enreg1%my_natom
258 2270 : mpi_enreg2%comm_atom=mpi_enreg1%comm_atom
259 2270 : mpi_enreg2%nproc_atom=mpi_enreg1%nproc_atom
260 2270 : mpi_enreg2%comm_kptband=mpi_enreg1%comm_kptband
261 2270 : mpi_enreg2%bandpp=mpi_enreg1%bandpp
262 2270 : mpi_enreg2%paral_img=mpi_enreg1%paral_img
263 2270 : mpi_enreg2%comm_img=mpi_enreg1%comm_img
264 2270 : mpi_enreg2%me_img=mpi_enreg1%me_img
265 2270 : mpi_enreg2%nproc_img=mpi_enreg1%nproc_img
266 2270 : mpi_enreg2%comm_cell=mpi_enreg1%comm_cell
267 2270 : mpi_enreg2%comm_cell_pert=mpi_enreg1%comm_cell_pert
268 2270 : mpi_enreg2%me_cell=mpi_enreg1%me_cell
269 2270 : mpi_enreg2%nproc_cell=mpi_enreg1%nproc_cell
270 2270 : mpi_enreg2%nproc_spinor=mpi_enreg1%nproc_spinor
271 2270 : mpi_enreg2%me_spinor=mpi_enreg1%me_spinor
272 2270 : mpi_enreg2%comm_spinorfft=mpi_enreg1%comm_spinorfft
273 2270 : mpi_enreg2%me_wvl =mpi_enreg1%me_wvl
274 2270 : mpi_enreg2%nproc_wvl =mpi_enreg1%nproc_wvl
275 2270 : mpi_enreg2%comm_wvl =mpi_enreg1%comm_wvl
276 2270 : mpi_enreg2%me_hf =mpi_enreg1%me_hf
277 2270 : mpi_enreg2%nproc_hf =mpi_enreg1%nproc_hf
278 2270 : mpi_enreg2%comm_hf =mpi_enreg1%comm_hf
279 2270 : mpi_enreg2%paral_hf=mpi_enreg1%paral_hf
280 2270 : mpi_enreg2%pw_unbal_thresh=mpi_enreg1%pw_unbal_thresh
281 :
282 : !pointers
283 2270 : if (associated(mpi_enreg1%distribfft)) then
284 2270 : if (.not.associated(mpi_enreg2%distribfft)) then
285 2270 : ABI_MALLOC(mpi_enreg2%distribfft,)
286 : end if
287 2270 : call mpi_enreg1%distribfft%copy(mpi_enreg2%distribfft)
288 : end if
289 :
290 2270 : if (allocated(mpi_enreg1%proc_distrb)) then
291 132 : sz1=size(mpi_enreg1%proc_distrb,1)
292 132 : sz2=size(mpi_enreg1%proc_distrb,2)
293 132 : sz3=size(mpi_enreg1%proc_distrb,3)
294 660 : ABI_MALLOC(mpi_enreg2%proc_distrb,(sz1,sz2,sz3))
295 5375 : mpi_enreg2%proc_distrb=mpi_enreg1%proc_distrb
296 : end if
297 2270 : if (allocated(mpi_enreg1%kptdstrb)) then
298 0 : sz1=size(mpi_enreg1%kptdstrb,1)
299 0 : sz2=size(mpi_enreg1%kptdstrb,2)
300 0 : sz3=size(mpi_enreg1%kptdstrb,3)
301 0 : ABI_MALLOC(mpi_enreg2%kptdstrb,(sz1,sz2,sz3))
302 0 : mpi_enreg2%kptdstrb=mpi_enreg1%kptdstrb
303 : end if
304 2270 : if (allocated(mpi_enreg1%kpt_loc2fbz_sp)) then
305 0 : sz1=size(mpi_enreg1%kpt_loc2fbz_sp,1)-1
306 0 : sz2=size(mpi_enreg1%kpt_loc2fbz_sp,2)
307 0 : sz3=size(mpi_enreg1%kpt_loc2fbz_sp,3)
308 0 : ABI_MALLOC(mpi_enreg2%kpt_loc2fbz_sp,(0:sz1,1:sz2,1:sz3))
309 0 : mpi_enreg2%kpt_loc2fbz_sp=mpi_enreg1%kpt_loc2fbz_sp
310 : end if
311 2270 : if (allocated(mpi_enreg1%kpt_loc2ibz_sp)) then
312 0 : sz1=size(mpi_enreg1%kpt_loc2ibz_sp,1)-1
313 0 : sz2=size(mpi_enreg1%kpt_loc2ibz_sp,2)
314 0 : sz3=size(mpi_enreg1%kpt_loc2ibz_sp,3)
315 0 : ABI_MALLOC(mpi_enreg2%kpt_loc2ibz_sp,(0:sz1,1:sz2,1:sz3))
316 0 : mpi_enreg2%kpt_loc2ibz_sp=mpi_enreg1%kpt_loc2ibz_sp
317 : end if
318 2270 : if (allocated(mpi_enreg1%mkmem)) then
319 0 : ABI_MALLOC(mpi_enreg2%mkmem,(0:size(mpi_enreg1%mkmem,1)-1))
320 0 : mpi_enreg2%mkmem=mpi_enreg1%mkmem
321 : end if
322 2270 : if (associated(mpi_enreg1%my_atmtab)) then
323 0 : ABI_MALLOC(mpi_enreg2%my_atmtab,(size(mpi_enreg1%my_atmtab)))
324 0 : mpi_enreg2%my_atmtab=mpi_enreg1%my_atmtab
325 : else
326 2270 : nullify(mpi_enreg2%my_atmtab)
327 : end if
328 2270 : if (allocated(mpi_enreg1%my_kgtab)) then
329 4 : sz1=size(mpi_enreg1%my_kgtab,1)
330 4 : sz2=size(mpi_enreg1%my_kgtab,2)
331 16 : ABI_MALLOC(mpi_enreg2%my_kgtab,(sz1,sz2))
332 269 : mpi_enreg2%my_kgtab=mpi_enreg1%my_kgtab
333 : end if
334 2270 : if (allocated(mpi_enreg1%distrb_pert)) then
335 0 : ABI_MALLOC(mpi_enreg2%distrb_pert,(size(mpi_enreg1%distrb_pert)))
336 0 : mpi_enreg2%distrb_pert=mpi_enreg1%distrb_pert
337 : end if
338 2270 : if (allocated(mpi_enreg1%distrb_img)) then
339 396 : ABI_MALLOC(mpi_enreg2%distrb_img,(size(mpi_enreg1%distrb_img)))
340 396 : mpi_enreg2%distrb_img=mpi_enreg1%distrb_img
341 : end if
342 2270 : if (allocated(mpi_enreg1%my_imgtab)) then
343 396 : ABI_MALLOC(mpi_enreg2%my_imgtab,(size(mpi_enreg1%my_imgtab)))
344 396 : mpi_enreg2%my_imgtab=mpi_enreg1%my_imgtab
345 : end if
346 2270 : if (allocated(mpi_enreg1%distrb_hf)) then
347 123 : sz1=size(mpi_enreg1%distrb_hf,1)
348 123 : sz2=size(mpi_enreg1%distrb_hf,2)
349 123 : sz3=size(mpi_enreg1%distrb_hf,3)
350 615 : ABI_MALLOC(mpi_enreg2%distrb_hf,(sz1,sz2,sz3))
351 4039 : mpi_enreg2%distrb_hf=mpi_enreg1%distrb_hf
352 : end if
353 :
354 : !Optional pointers
355 2270 : if (allocated(mpi_enreg1%my_kpttab)) then
356 396 : ABI_MALLOC(mpi_enreg2%my_kpttab,(size(mpi_enreg1%my_kpttab)))
357 954 : mpi_enreg2%my_kpttab=mpi_enreg1%my_kpttab
358 : end if
359 :
360 : !Do not copy wavelet pointers, just associate.
361 2270 : mpi_enreg2%nscatterarr => mpi_enreg1%nscatterarr
362 2270 : mpi_enreg2%ngatherarr => mpi_enreg1%ngatherarr
363 :
364 2270 : end subroutine copy_mpi_enreg
365 : !!***
366 :
367 : !----------------------------------------------------------------------
368 :
369 : !!****f* m_mpinfo/set_mpi_enreg_fft
370 : !! NAME
371 : !! set_mpi_enreg_fft
372 : !!
373 : !! FUNCTION
374 : !! Set the content of a MPI datastructure in order to call fourwf/fourdp
375 : !! (in view of a wrapper for these routines)
376 : !!
377 : !! INPUTS
378 : !! me_g0=1 if the current process treat the g=0 plane-wave
379 : !! comm_fft= MPI communicator over FFT components
380 : !! paral_kgb= flag used to activate "band-FFT" parallelism
381 : !!
382 : !! SIDE EFFECTS
383 : !! MPI_enreg<MPI_type>=FFT pointer/flags initialized
384 : !!
385 : !! SOURCE
386 :
387 3698 : subroutine set_mpi_enreg_fft(MPI_enreg,comm_fft,distribfft,me_g0,paral_kgb)
388 :
389 : !Arguments ------------------------------------
390 : class(MPI_type),intent(inout) :: MPI_enreg
391 : integer,intent(in) :: me_g0,comm_fft,paral_kgb
392 : type(distribfft_type),intent(in),target :: distribfft
393 : ! *********************************************************************
394 :
395 3698 : mpi_enreg%comm_fft=comm_fft
396 3698 : mpi_enreg%paral_kgb=paral_kgb
397 3698 : mpi_enreg%me_g0=me_g0
398 3698 : mpi_enreg%nproc_fft=xmpi_comm_size(comm_fft)
399 3698 : mpi_enreg%me_fft=xmpi_comm_rank(comm_fft)
400 3698 : mpi_enreg%me_g0_fft=0
401 3698 : if (mpi_enreg%me_fft==0) then
402 3480 : mpi_enreg%me_g0_fft=1
403 : end if
404 3698 : if (associated(mpi_enreg%distribfft)) then
405 3 : call mpi_enreg%distribfft%free()
406 3 : ABI_FREE(mpi_enreg%distribfft)
407 : end if
408 3698 : mpi_enreg%distribfft => distribfft
409 :
410 3698 : end subroutine set_mpi_enreg_fft
411 : !!***
412 :
413 : !----------------------------------------------------------------------
414 :
415 : !!****f* m_mpinfo/unset_mpi_enreg_fft
416 : !! NAME
417 : !! unset_mpi_enreg_fft
418 : !!
419 : !! FUNCTION
420 : !! Unset the content of a MPI datastructure used to call fourwf/fourdp
421 : !! (in view of a wrapper for these routines)
422 : !!
423 : !! SIDE EFFECTS
424 : !! MPI_enreg<MPI_type>=FFT pointer/flags initialized
425 : !!
426 : !! SOURCE
427 :
428 8082 : subroutine unset_mpi_enreg_fft(MPI_enreg)
429 :
430 : !Arguments ------------------------------------
431 : class(MPI_type),intent(inout) :: MPI_enreg
432 : ! *********************************************************************
433 :
434 8082 : mpi_enreg%me_g0=1
435 8082 : mpi_enreg%comm_fft=xmpi_comm_self
436 8082 : mpi_enreg%nproc_fft=1
437 8082 : mpi_enreg%me_fft=0
438 8082 : mpi_enreg%me_g0_fft=1
439 8082 : mpi_enreg%paral_kgb=0
440 8082 : nullify(mpi_enreg%distribfft)
441 :
442 8082 : end subroutine unset_mpi_enreg_fft
443 : !!***
444 :
445 : !----------------------------------------------------------------------
446 :
447 : !!****f* m_mpinfo/ptabs_fourdp
448 : !! NAME
449 : !! ptabs_fourdp
450 : !!
451 : !! FUNCTION
452 : !! Returns pointers to the tables used for the MPI FFT of densities and potentials (fourdp routine).
453 : !!
454 : !! NOTES
455 : !! 1) These pointers are references to the internal tables stored in MPI_enreg hence
456 : !! *** DO NOT DEALLOCATE THE POINTERS YOU HAVE RECEIVED! ***
457 : !!
458 : !! INPUTS
459 : !! MPI_enreg<MPI_type>=Datatype gathering information on the parallelism.
460 : !! n2,n3=Number of FFT divisions along y and z
461 : !!
462 : !! OUTPUT
463 : !! fftn2_distrib(:)= rank of the processor which own fft planes in 2nd dimension for fourdp
464 : !! ffti2_local(:) = local i2 indices in fourdp
465 : !! fftn3_distrib(:) = rank of the processor which own fft planes in 3rd dimension for fourdp
466 : !! ffti3_local(:) = local i3 indices in fourdp
467 : !!
468 : !! SOURCE
469 :
470 2797294 : subroutine ptabs_fourdp(MPI_enreg,n2,n3,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local)
471 :
472 : !Arguments ------------------------------------
473 : class(MPI_type),intent(in) :: MPI_enreg
474 : integer,intent(in) :: n2,n3
475 : integer, contiguous, pointer :: fftn2_distrib(:),ffti2_local(:)
476 : integer, contiguous, pointer :: fftn3_distrib(:),ffti3_local(:)
477 :
478 : !Local variables-------------------------------
479 : !scalars
480 : logical :: grid_found
481 : ! *********************************************************************
482 :
483 : grid_found=.false.
484 :
485 : ! Get the distrib associated with this fft_grid => for i2 and i3 planes
486 2797294 : grid_found=.false.
487 2797294 : if (n2== mpi_enreg%distribfft%n2_coarse) then
488 2434687 : if( n3 == size(mpi_enreg%distribfft%tab_fftdp3_distrib) )then
489 2433231 : fftn2_distrib => mpi_enreg%distribfft%tab_fftdp2_distrib
490 2433231 : ffti2_local => mpi_enreg%distribfft%tab_fftdp2_local
491 2433231 : fftn3_distrib => mpi_enreg%distribfft%tab_fftdp3_distrib
492 2433231 : ffti3_local => mpi_enreg%distribfft%tab_fftdp3_local
493 2433231 : grid_found=.true.
494 : end if
495 : end if
496 :
497 2797294 : if((n2 == mpi_enreg%distribfft%n2_fine).and.(.not.(grid_found))) then
498 364063 : if( n3 == size(mpi_enreg%distribfft%tab_fftdp3dg_distrib) )then
499 364063 : fftn2_distrib => mpi_enreg%distribfft%tab_fftdp2dg_distrib
500 364063 : ffti2_local => mpi_enreg%distribfft%tab_fftdp2dg_local
501 364063 : fftn3_distrib => mpi_enreg%distribfft%tab_fftdp3dg_distrib
502 364063 : ffti3_local => mpi_enreg%distribfft%tab_fftdp3dg_local
503 : grid_found=.true.
504 : end if
505 : end if
506 :
507 1955571 : if (.not. grid_found) then
508 0 : ABI_BUG(sjoin("Unable to find an allocated distrib for this fft grid with n2, n3 = ", ltoa([n2, n3])))
509 : end if
510 :
511 2797294 : end subroutine ptabs_fourdp
512 : !!***
513 :
514 : !----------------------------------------------------------------------
515 :
516 : !!****f* m_mpinfo/ptabs_fourwf
517 : !! NAME
518 : !! ptabs_fourwf
519 : !!
520 : !! FUNCTION
521 : !! Returns pointers to the tables used for the MPI FFT of the wavefunctions (fourwf routine).
522 : !!
523 : !! NOTES
524 : !! 1) These pointers are references to the internal tables stored in MPI_enreg hence
525 : !! *** DO NOT DEALLOCATE THE POINTERS YOU HAVE RECEIVED! ***
526 : !!
527 : !! INPUTS
528 : !! MPI_enreg<MPI_type>=Datatype gathering information on the parallelism.
529 : !! n2,n3=Number of FFT divisions along y and z
530 : !!
531 : !! OUTPUT
532 : !! fftn2_distrib(:)= rank of the processors which own fft planes in 2nd dimension for fourwf
533 : !! ffti2_local(:) = local i2 indices in fourwf
534 : !! fftn3_distrib(:) = rank of the processors which own fft planes in 3rd dimension for fourwf
535 : !! ffti3_local(:) = local i3 indices in fourwf
536 : !!
537 : !! SOURCE
538 :
539 61023503 : subroutine ptabs_fourwf(MPI_enreg,n2,n3,fftn2_distrib,ffti2_local,fftn3_distrib,ffti3_local)
540 :
541 : !Arguments ------------------------------------
542 : !scalars
543 : class(MPI_type),intent(in) :: MPI_enreg
544 : integer,intent(in) :: n2,n3
545 : integer, contiguous, pointer :: fftn2_distrib(:),ffti2_local(:)
546 : integer, contiguous, pointer :: fftn3_distrib(:),ffti3_local(:)
547 :
548 : !Local variables-------------------------------
549 : !scalars
550 : logical :: grid_found
551 : ! *********************************************************************
552 :
553 61023503 : grid_found=.false.
554 :
555 : ! Get the distrib associated with this fft_grid => for i2 and i3 planes
556 61023503 : if (n2 == mpi_enreg%distribfft%n2_coarse) then
557 61008824 : if (n3 == size(mpi_enreg%distribfft%tab_fftdp3_distrib))then
558 61008824 : fftn2_distrib => mpi_enreg%distribfft%tab_fftwf2_distrib
559 61008824 : ffti2_local => mpi_enreg%distribfft%tab_fftwf2_local
560 61008824 : fftn3_distrib => mpi_enreg%distribfft%tab_fftdp3_distrib
561 61008824 : ffti3_local => mpi_enreg%distribfft%tab_fftdp3_local
562 61008824 : grid_found=.true.
563 : end if
564 : end if
565 :
566 61023503 : if((n2 == mpi_enreg%distribfft%n2_fine).and.(.not.(grid_found))) then
567 14679 : if (n3 == size(mpi_enreg%distribfft%tab_fftdp3dg_distrib) )then
568 14679 : fftn2_distrib => mpi_enreg%distribfft%tab_fftwf2dg_distrib
569 14679 : ffti2_local => mpi_enreg%distribfft%tab_fftwf2dg_local
570 14679 : fftn3_distrib => mpi_enreg%distribfft%tab_fftdp3dg_distrib
571 14679 : ffti3_local => mpi_enreg%distribfft%tab_fftdp3dg_local
572 : grid_found=.true.
573 : end if
574 : end if
575 :
576 57820828 : if(.not. grid_found) then
577 0 : ABI_BUG(sjoin("Unable to find an allocated distrib for this fft grid", ltoa([n2, n3])))
578 : end if
579 :
580 61023503 : end subroutine ptabs_fourwf
581 : !!***
582 :
583 : !----------------------------------------------------------------------
584 :
585 : !!****f* m_mpinfo/mpi_distrib_is_ok
586 : !! NAME
587 : !! mpi_distrib_is_ok
588 : !!
589 : !! FUNCTION
590 : !! Check if a MPI datastructure contains number of processors
591 : !! compatible (in terms of efficiency) with the number of spins/k-points/bands
592 : !!
593 : !! INPUTS
594 : !! MPI_enreg<MPI_type>=Datatype gathering information on the parallelism
595 : !! nband=number of bands
596 : !! nkpt=number of k-points
597 : !! nptk_current_proc=number of k-points handled by current MPI process
598 : !! nsppol= number of spins (1 or 2)
599 : !!
600 : !! OUTPUT
601 : !! mpi_distrib_is_ok (current function)=TRUE if the current MPI distribution is optimal
602 : !! FALSE otherwise
603 : !! [msg]= -optional- warning message to be printed out
604 : !!
605 : !! SOURCE
606 :
607 10438 : logical function mpi_distrib_is_ok(MPI_enreg,nband,nkpt,nkpt_current_proc,nsppol,msg)
608 :
609 : !Arguments ------------------------------------
610 : !scalars
611 : class(MPI_type),intent(in) :: MPI_enreg
612 : integer,intent(in) :: nband,nkpt,nkpt_current_proc,nsppol
613 : character(len=*),optional,intent(out) :: msg
614 : ! *********************************************************************
615 :
616 10438 : mpi_distrib_is_ok=.true.
617 :
618 10438 : if (MPI_enreg%paralbd==0) then
619 9737 : if (MPI_enreg%nproc_spkpt-floor(nsppol*nkpt*one/nkpt_current_proc)>=nkpt_current_proc) then
620 148 : mpi_distrib_is_ok=.false.
621 148 : if (present(msg)) then
622 : write(msg,'(a,i0,4a,i0,3a)') &
623 74 : 'Your number of spins*k-points (=',nsppol*nkpt,') ',&
624 74 : 'will not distribute correctly',ch10, &
625 74 : 'with the current number of processors (=',MPI_enreg%nproc_spkpt,').',ch10,&
626 148 : 'You will leave some empty.'
627 : end if
628 : end if
629 : else
630 701 : if (mod(nband,max(1,MPI_enreg%nproc_spkpt/(nsppol*nkpt)))/=0) then
631 0 : mpi_distrib_is_ok=.false.
632 0 : if (present(msg)) then
633 : write(msg,'(a,i0,2a,i0,4a,i0,7a)')&
634 0 : 'Your number of spins*k-points (=',nsppol*nkpt,') ',&
635 0 : 'and bands (=',nband,') ',&
636 0 : 'will not distribute correctly',ch10,&
637 0 : 'with the current number of processors (=',MPI_enreg%nproc_spkpt,').',ch10,&
638 0 : 'You will leave some empty.'
639 : end if
640 : end if
641 : end if
642 :
643 10438 : end function mpi_distrib_is_ok
644 : !!***
645 :
646 : !!****f* ABINIT/proc_distrb_cycle
647 : !! NAME
648 : !! proc_distrb_cycle
649 : !!
650 : !! FUNCTION
651 : !! test a condition to cycle over bands and k-points which do not belong to the present processor
652 : !! if return value is true, you can cycle over the given range of bands for this k and sppol
653 : !!
654 : !! INPUTS
655 : !!
656 : !! SOURCE
657 :
658 6258407 : logical function proc_distrb_cycle(distrb,ikpt,iband1,iband2,isppol,me)
659 :
660 : !Arguments ------------------------------------
661 : !scalars
662 : integer,intent(in) :: ikpt,iband1,iband2,isppol,me
663 : integer,allocatable,intent(in) :: distrb(:,:,:)
664 : ! *************************************************************************
665 :
666 6258407 : proc_distrb_cycle=.false.
667 6258407 : if (allocated(distrb)) then
668 6254717 : if (isppol==-1) then
669 : ! in this condition, if one of the distrb is for me, then the minval will be == 0, so it returns false
670 5245522 : proc_distrb_cycle=(minval(abs(distrb(ikpt,iband1:iband2,:)-me))/=0)
671 : else
672 31621695 : proc_distrb_cycle=(minval(abs(distrb(ikpt,iband1:iband2,isppol)-me))/=0)
673 : end if
674 : end if
675 :
676 6258407 : end function proc_distrb_cycle
677 : !!***
678 :
679 : !!****f* ABINIT/proc_distrb_nband
680 : !! NAME
681 : !! proc_distrb_nband
682 : !!
683 : !! FUNCTION
684 : !! return number of bands at this k and spin which are on current proc "me"
685 : !! NB: could replace proc_distrb_cycle with "proc_distrb_nband > 0"
686 : !! isppol -1 means for all spin channels, I think...
687 : !!
688 : !! INPUTS
689 : !!
690 : !! SOURCE
691 :
692 5858066 : integer function proc_distrb_nband(distrb,ikpt,nband_k,isppol,me)
693 :
694 : !Arguments ------------------------------------
695 : !scalars
696 : integer,intent(in) :: ikpt,isppol,me,nband_k
697 : integer,allocatable,intent(in) :: distrb(:,:,:)
698 : ! *************************************************************************
699 :
700 5858066 : proc_distrb_nband=0
701 5858066 : if (allocated(distrb)) then
702 5858066 : if (isppol==-1) then
703 : !TODO: check this is used correctly : in nsppol 2 case you could end up with 2*nband
704 0 : proc_distrb_nband=(count(distrb(ikpt,1:nband_k,:)==me))
705 : else
706 48356284 : proc_distrb_nband=(count(distrb(ikpt,1:nband_k,isppol)==me))
707 : end if
708 : end if
709 :
710 5858066 : end function proc_distrb_nband
711 : !!***
712 :
713 : !!****f* ABINIT/proc_distrb_cycle_bands
714 : !! NAME
715 : !! proc_distrb_cycle_bands
716 : !!
717 : !! FUNCTION
718 : !! return vector of logicals for each band being on present proc
719 : !!
720 : !! INPUTS
721 : !!
722 : !! SOURCE
723 :
724 4465167 : subroutine proc_distrb_cycle_bands(cycle_bands,distrb,ikpt,isppol,me)
725 :
726 : !Arguments ------------------------------------
727 : !scalars
728 : integer,intent(in) :: ikpt,isppol,me
729 : integer,allocatable,intent(in) :: distrb(:,:,:)
730 : logical,allocatable,intent(out) :: cycle_bands(:)
731 : character(len=500) :: msg
732 : ! *************************************************************************
733 :
734 13395501 : ABI_REMALLOC (cycle_bands, (size(distrb, 2)))
735 39528765 : cycle_bands=.false.
736 4465167 : if (allocated(distrb)) then
737 4465167 : if (isppol==-1) then
738 : ! TODO : should raise error here - the output rank will be all wrong
739 : ! could return an OR of the two spin channels, if appropriate
740 0 : cycle_bands=(distrb(ikpt,:,1)/=me)
741 0 : write (msg, "(a)") " for the moment proc_distrb_cycle_bands does not handle the 'any spin' option nsppol -1"
742 0 : ABI_ERROR(msg)
743 : else
744 43993932 : cycle_bands=(distrb(ikpt,:,isppol)/=me)
745 : end if
746 : end if
747 :
748 4465167 : end subroutine proc_distrb_cycle_bands
749 : !!***
750 :
751 : !!****f* ABINIT/proc_distrb_kptband
752 : !! NAME
753 : !! proc_distrb_kptband
754 : !!
755 : !! FUNCTION
756 : !! return vector of processor indices for each band, within the full kpt communicator
757 : !!
758 : !! INPUTS
759 : !!
760 : !! SOURCE
761 :
762 : subroutine proc_distrb_kptband(kpt_band_procs,distrb,ikpt,isppol)
763 :
764 : !Arguments ------------------------------------
765 : !scalars
766 : integer,intent(in) :: ikpt,isppol
767 : integer,allocatable,intent(in) :: distrb(:,:,:)
768 : integer,allocatable,intent(out) :: kpt_band_procs(:)
769 : character(len=500) :: msg
770 : ! *************************************************************************
771 :
772 : ABI_REMALLOC(kpt_band_procs, (size(distrb, 2)))
773 : kpt_band_procs=-1
774 : if (allocated(distrb)) then
775 : if (isppol==-1) then
776 : ! TODO : should raise error here - the output rank will be all wrong for isppol 2!
777 : kpt_band_procs=distrb(ikpt,:,1)
778 : write (msg, "(a)") " for the moment proc_distrb_kptband does not handle the 'any spin' option nsppol -1"
779 : ABI_ERROR(msg)
780 : else
781 : kpt_band_procs=distrb(ikpt,:,isppol)
782 : end if
783 : end if
784 :
785 : end subroutine proc_distrb_kptband
786 : !!***
787 :
788 : !!****f* ABINIT/proc_distrb_band
789 : !! NAME
790 : !! proc_distrb_band
791 : !!
792 : !! FUNCTION
793 : !! return `rank_band` array with the rank of the processor in comm_band treating `band`
794 : !!
795 : !! INPUTS
796 : !!
797 : !! SOURCE
798 :
799 1011524 : subroutine proc_distrb_band(rank_band,distrib,ikpt,isppol,nband,me_band,me_kpt,comm_band)
800 :
801 : !Arguments ------------------------------------
802 : !scalars
803 : integer,intent(in) :: nband, ikpt, isppol
804 : integer,intent(in) :: me_band,me_kpt,comm_band
805 : integer,allocatable,intent(in) :: distrib(:,:,:)
806 : integer,intent(out) :: rank_band(nband)
807 :
808 : integer :: ierr, iband
809 : ! *************************************************************************
810 :
811 6410546 : rank_band = 0
812 :
813 1011524 : if (allocated(distrib)) then
814 6410546 : do iband=1, nband
815 : ! is this (k, band, spin) on current proc?
816 5399022 : if (distrib(ikpt,iband,isppol)/=me_kpt) cycle
817 : ! if so save rank in band subcommunicator
818 6410546 : rank_band(iband) = me_band+1
819 : end do
820 1011524 : call xmpi_sum(rank_band,comm_band,ierr)
821 : end if
822 :
823 6410546 : rank_band = rank_band-1
824 :
825 1011524 : end subroutine proc_distrb_band
826 : !!***
827 :
828 : !!****f* ABINIT/initmpi_world
829 : !! NAME
830 : !! initmpi_world
831 : !!
832 : !! FUNCTION
833 : !! %comm_world is redefined for the number of processors on which ABINIT is launched
834 : !!
835 : !! SOURCE
836 :
837 94 : subroutine initmpi_world(mpi_enreg,nproc)
838 :
839 : !Arguments ------------------------------------
840 : class(MPI_type),intent(inout) :: mpi_enreg
841 : integer, intent(in)::nproc
842 :
843 : !Local variables-------------------------------
844 : !scalars
845 : integer :: ii
846 : !arrays
847 94 : integer,allocatable :: ranks(:)
848 : ! ***********************************************************************
849 :
850 : DBG_ENTER("COLL")
851 :
852 94 : if(nproc==mpi_enreg%nproc) return
853 :
854 0 : ABI_MALLOC(ranks,(0:nproc-1))
855 0 : ranks(0:nproc-1)=(/((ii),ii=0,nproc-1)/)
856 0 : mpi_enreg%comm_world=xmpi_subcomm(xmpi_world,nproc,ranks)
857 0 : ABI_FREE(ranks)
858 :
859 0 : if(mpi_enreg%me<nproc) then
860 0 : mpi_enreg%me=xmpi_comm_rank(mpi_enreg%comm_world)
861 0 : mpi_enreg%nproc=xmpi_comm_size(mpi_enreg%comm_world)
862 0 : call abi_io_redirect(new_io_comm=mpi_enreg%comm_world)
863 0 : call libpaw_write_comm_set(mpi_enreg%comm_world)
864 : else
865 0 : mpi_enreg%me=-1
866 : end if
867 :
868 : DBG_EXIT("COLL")
869 :
870 : end subroutine initmpi_world
871 : !!***
872 :
873 : !!****f* ABINIT/initmpi_seq
874 : !! NAME
875 : !! initmpi_seq
876 : !!
877 : !! FUNCTION
878 : !! Initializes the MPI information for sequential use.
879 : !!
880 : !! INPUTS
881 : !!
882 : !! OUTPUT
883 : !! mpi_enreg=information about MPI parallelization
884 : !!
885 : !! SOURCE
886 :
887 525161 : subroutine initmpi_seq(mpi_enreg)
888 :
889 : !Arguments ------------------------------------
890 : class(MPI_type),intent(out) :: mpi_enreg
891 : ! ***********************************************************************
892 :
893 : DBG_ENTER("COLL")
894 :
895 : !Set default seq values for scalars
896 525161 : mpi_enreg%bandpp=1
897 525161 : mpi_enreg%me=0
898 525161 : mpi_enreg%me_band=0
899 525161 : mpi_enreg%me_cell=0
900 525161 : mpi_enreg%me_fft=0
901 525161 : mpi_enreg%me_g0=1
902 525161 : mpi_enreg%me_g0_fft=1
903 525161 : mpi_enreg%me_img=0
904 525161 : mpi_enreg%me_hf=0
905 525161 : mpi_enreg%me_kpt=0
906 525161 : mpi_enreg%me_pert=0
907 525161 : mpi_enreg%me_spinor=0
908 525161 : mpi_enreg%me_wvl=0
909 525161 : mpi_enreg%my_natom=0 ! Should be natom
910 1575483 : mpi_enreg%my_isppoltab=0 ! Should be (1,0) if nsppol=1 or (1,1) if nsppol=2
911 525161 : mpi_enreg%ngfft3_ionic=1
912 525161 : mpi_enreg%my_nimage=1
913 525161 : mpi_enreg%nproc=1
914 525161 : mpi_enreg%nproc_atom=1
915 525161 : mpi_enreg%nproc_band=1
916 525161 : mpi_enreg%nproc_cell=1
917 525161 : mpi_enreg%nproc_fft=1
918 525161 : mpi_enreg%nproc_img=1
919 525161 : mpi_enreg%nproc_hf=1
920 525161 : mpi_enreg%nproc_spkpt=1
921 525161 : mpi_enreg%nproc_pert=1
922 525161 : mpi_enreg%nproc_spinor=1
923 525161 : mpi_enreg%nproc_wvl=1
924 525161 : mpi_enreg%paralbd=0
925 525161 : mpi_enreg%paral_img=0
926 525161 : mpi_enreg%paral_hf=0
927 525161 : mpi_enreg%paral_kgb=0
928 525161 : mpi_enreg%paral_pert=0
929 525161 : mpi_enreg%paral_spinor=0
930 525161 : mpi_enreg%pw_unbal_thresh=-1._dp
931 :
932 : !Set default seq values for communicators
933 525161 : mpi_enreg%comm_world = xmpi_world
934 525161 : mpi_enreg%comm_atom = xmpi_comm_self
935 525161 : mpi_enreg%comm_band = xmpi_comm_self
936 525161 : mpi_enreg%comm_bandspinor = xmpi_comm_self
937 525161 : mpi_enreg%comm_bandfft = xmpi_comm_self
938 525161 : mpi_enreg%comm_bandspinorfft = xmpi_comm_self
939 525161 : mpi_enreg%comm_cell = xmpi_comm_self
940 525161 : mpi_enreg%comm_cell_pert = xmpi_comm_self
941 525161 : mpi_enreg%comm_fft = xmpi_comm_self
942 525161 : mpi_enreg%comm_hf = xmpi_comm_self
943 525161 : mpi_enreg%comm_img = xmpi_comm_self
944 525161 : mpi_enreg%comm_kpt = xmpi_comm_self
945 525161 : mpi_enreg%comm_kptband = xmpi_comm_self
946 525161 : mpi_enreg%comm_pert = xmpi_comm_self
947 525161 : mpi_enreg%comm_spinor = xmpi_comm_self
948 525161 : mpi_enreg%comm_spinorfft = xmpi_comm_self
949 525161 : mpi_enreg%comm_wvl = xmpi_comm_self
950 :
951 : !Nullify all pointers
952 525161 : call nullify_mpi_enreg(mpi_enreg)
953 :
954 : !Allocate and nullify distribfft datastructure
955 : ! This is not good since distribfft is not initialized here (even with 0s).
956 : ! It can be dangerous if use with no care (Valgrind might complain)
957 525161 : ABI_MALLOC(mpi_enreg%distribfft,)
958 :
959 : DBG_EXIT("COLL")
960 :
961 525161 : end subroutine initmpi_seq
962 : !!***
963 :
964 : !!****f* ABINIT/initmpi_atom
965 : !! NAME
966 : !! initmpi_atom
967 : !!
968 : !! FUNCTION
969 : !! Initializes the mpi information for parallelism over atoms (PAW).
970 : !!
971 : !! INPUTS
972 : !! dtset <type(dataset_type)>=all input variables for this dataset
973 : !! mpi_enreg= information about MPI parallelization
974 : !!
975 : !! OUTPUT
976 : !! mpi_enreg= information about MPI parallelization
977 : !! comm_atom =communicator over atoms
978 : !! nproc_atom =size of the communicator over atoms
979 : !! my_natom =number of atoms treated by current proc
980 : !! my_atmtab(mpi_enreg%natom)=indexes of the atoms treated by current processor
981 : !!
982 : !! SOURCE
983 :
984 6998 : subroutine initmpi_atom(dtset,mpi_enreg)
985 :
986 : !Arguments ------------------------------------
987 : !scalars
988 : type(dataset_type),intent(in) :: dtset
989 : class(MPI_type),intent(inout) :: mpi_enreg
990 :
991 : !Local variables-------------------------------
992 : !scalars
993 : logical :: my_atmtab_allocated,paral_atom
994 : character(len=500) :: msg
995 : integer :: iatom
996 : ! ***********************************************************************
997 :
998 : DBG_ENTER("COLL")
999 :
1000 6998 : mpi_enreg%nproc_atom=1
1001 6998 : mpi_enreg%comm_atom=xmpi_comm_self
1002 6998 : mpi_enreg%my_natom=dtset%natom
1003 6998 : if (associated(mpi_enreg%my_atmtab))then
1004 40 : ABI_FREE(mpi_enreg%my_atmtab)
1005 : end if
1006 6998 : nullify(mpi_enreg%my_atmtab)
1007 :
1008 : if (xmpi_paral==0) then
1009 : mpi_enreg%nproc_atom=0
1010 : ABI_MALLOC(mpi_enreg%my_atmtab,(0))
1011 : return
1012 : end if
1013 :
1014 : !Check compatibility
1015 6998 : if (dtset%paral_atom>0) then
1016 514 : msg=''
1017 514 : if (dtset%usepaw==0) msg= 'Parallelisation over atoms not compatible with usepaw=0 !'
1018 514 : if (dtset%usedmft==1) msg=' Parallelisation over atoms not compatible with usedmft=1 !'
1019 514 : if (dtset%usedmft==10) msg=' Parallelisation over atoms not compatible with usedmft=10 !'
1020 514 : if (dtset%usewvl==1) msg= 'Parallelisation over atoms not compatible with usewvl=1 !'
1021 514 : if (dtset%prtden>1.and.dtset%paral_kgb<=0) &
1022 0 : & msg= 'Parallelisation over atoms not compatible with prtden>1 (PAW AE densities) !'
1023 514 : if (dtset%optdriver/=RUNL_GSTATE.and.dtset%optdriver/=RUNL_RESPFN) &
1024 0 : & msg=' Parallelisation over atoms only compatible with GS or RF !'
1025 514 : if (dtset%macro_uj/=0)msg=' Parallelisation over atoms not compatible with macro_uj!=0 !'
1026 514 : if (msg/='') then
1027 0 : ABI_ERROR(msg)
1028 : end if
1029 : end if
1030 :
1031 6998 : if (mpi_enreg%comm_atom==xmpi_comm_null) then
1032 0 : mpi_enreg%nproc_atom=0;mpi_enreg%my_natom=0
1033 0 : ABI_MALLOC(mpi_enreg%my_atmtab,(0))
1034 0 : return
1035 : end if
1036 :
1037 6998 : if (dtset%paral_atom>0) then
1038 :
1039 : ! Build correct atom communicator
1040 514 : if (dtset%optdriver==RUNL_GSTATE.and.dtset%paral_kgb==1) then
1041 396 : mpi_enreg%comm_atom=mpi_enreg%comm_kptband
1042 : else
1043 118 : mpi_enreg%comm_atom=mpi_enreg%comm_cell
1044 : end if
1045 :
1046 : ! Get number of processors sharing the atomic data distribution
1047 514 : mpi_enreg%nproc_atom=xmpi_comm_size(mpi_enreg%comm_atom)
1048 :
1049 : ! Get local number of atoms
1050 514 : call get_my_natom(mpi_enreg%comm_atom,mpi_enreg%my_natom,dtset%natom)
1051 514 : paral_atom=(mpi_enreg%my_natom/=dtset%natom)
1052 :
1053 : ! Build atom table
1054 514 : if (mpi_enreg%my_natom>0.and.paral_atom) then
1055 348 : my_atmtab_allocated=.false.
1056 : call get_my_atmtab(mpi_enreg%comm_atom,mpi_enreg%my_atmtab,my_atmtab_allocated, &
1057 348 : & paral_atom,dtset%natom)
1058 166 : else if (.not.paral_atom) then
1059 36 : ABI_MALLOC(mpi_enreg%my_atmtab,(dtset%natom))
1060 60 : mpi_enreg%my_atmtab(1:dtset%natom)=(/(iatom, iatom=1,dtset%natom)/)
1061 154 : else if (mpi_enreg%my_natom==0) then
1062 154 : ABI_MALLOC(mpi_enreg%my_atmtab,(0))
1063 : end if
1064 :
1065 : end if
1066 :
1067 : DBG_EXIT("COLL")
1068 :
1069 : end subroutine initmpi_atom
1070 : !!***
1071 :
1072 : !----------------------------------------------------------------------
1073 :
1074 : !!****f* m_mpinfo/clnmpi_atom
1075 : !! NAME
1076 : !! clnmpi_atom
1077 : !!
1078 : !! FUNCTION
1079 : !! Cleans-up the mpi information for the parallelism over atoms (PAW).
1080 : !!
1081 : !! SIDE EFFECTS
1082 : !! mpi_enreg=information about MPI parallelization
1083 : !!
1084 : !! SOURCE
1085 :
1086 6954 : subroutine clnmpi_atom(mpi_enreg)
1087 :
1088 : !Arguments ------------------------------------
1089 : class(MPI_type), intent(inout) :: mpi_enreg
1090 : ! ***********************************************************************
1091 :
1092 : DBG_ENTER("COLL")
1093 :
1094 : if (xmpi_paral==0) return
1095 :
1096 6954 : if (mpi_enreg%comm_atom/=mpi_enreg%comm_world) then
1097 6876 : call xmpi_comm_free(mpi_enreg%comm_atom)
1098 6876 : mpi_enreg%comm_atom=xmpi_comm_null
1099 : end if
1100 :
1101 6954 : if(associated(mpi_enreg%my_atmtab)) then
1102 474 : ABI_FREE(mpi_enreg%my_atmtab)
1103 : end if
1104 :
1105 6954 : mpi_enreg%nproc_atom=1
1106 6954 : mpi_enreg%my_natom=0 ! should be natom
1107 :
1108 : DBG_EXIT("COLL")
1109 :
1110 6954 : end subroutine clnmpi_atom
1111 : !!***
1112 :
1113 : !!****f* ABINIT/initmpi_grid
1114 : !! NAME
1115 : !! initmpi_grid
1116 : !!
1117 : !! FUNCTION
1118 : !! Initializes the MPI information for the grid:
1119 : !! * 2D if parallelization KPT/FFT (paral_kgb == 0 & MPI)
1120 : !! * 3D if parallelization KPT/FFT/BAND (paral_kgb == 1 & MPI)
1121 : !! * 2D in case of an Hartree-Fock calculation
1122 : !!
1123 : !! INPUTS
1124 : !!
1125 : !! OUTPUT
1126 : !!
1127 : !! SOURCE
1128 :
1129 6958 : subroutine initmpi_grid(mpi_enreg)
1130 :
1131 : !Arguments ------------------------------------
1132 : class(MPI_type),intent(inout) :: mpi_enreg
1133 :
1134 : !Local variables-------------------------------
1135 : !scalars
1136 : integer :: nproc,nproc_eff,spacecomm
1137 : character(len=500) :: msg
1138 : #if defined HAVE_MPI
1139 : integer :: commcart_4d,dimcart,ierr,me_cart_4d
1140 : integer :: commcart_2d,me_cart_2d
1141 : logical :: reorder
1142 : !arrays
1143 6958 : integer,allocatable :: coords(:),sizecart(:)
1144 6958 : logical,allocatable :: period(:), keepdim(:)
1145 : #endif
1146 : ! *********************************************************************
1147 :
1148 : DBG_ENTER("COLL")
1149 :
1150 : !Select the correct "world" communicator"
1151 6958 : nproc=mpi_enreg%nproc_cell
1152 : if(mpi_enreg%paral_pert==1) nproc=mpi_enreg%nproc_cell
1153 6958 : spacecomm=mpi_enreg%comm_cell
1154 :
1155 : !Fake values for null communicator
1156 6958 : if (nproc==0) then
1157 0 : mpi_enreg%nproc_fft = 0
1158 0 : mpi_enreg%nproc_band = 0
1159 0 : mpi_enreg%nproc_hf = 0
1160 0 : mpi_enreg%nproc_spkpt = 0
1161 0 : mpi_enreg%nproc_spinor = 0
1162 0 : mpi_enreg%comm_fft = xmpi_comm_null
1163 0 : mpi_enreg%comm_band = xmpi_comm_null
1164 0 : mpi_enreg%comm_hf = xmpi_comm_null
1165 0 : mpi_enreg%comm_kpt = xmpi_comm_null
1166 0 : mpi_enreg%comm_kptband = xmpi_comm_null
1167 0 : mpi_enreg%comm_spinor = xmpi_comm_null
1168 0 : mpi_enreg%comm_bandspinor = xmpi_comm_null
1169 0 : mpi_enreg%comm_spinorfft = xmpi_comm_null
1170 0 : mpi_enreg%comm_bandfft = xmpi_comm_null
1171 0 : mpi_enreg%comm_bandspinorfft = xmpi_comm_null
1172 0 : mpi_enreg%bandpp = 1
1173 0 : return
1174 : end if
1175 :
1176 : #if defined HAVE_MPI
1177 6958 : if (mpi_enreg%paral_hf==0) then
1178 : ! either the option Fock exchange is not active or there is no parallelization on Fock exchange calculation.
1179 :
1180 6958 : if (mpi_enreg%nproc_spinor>1) mpi_enreg%paral_spinor=1
1181 :
1182 : !Effective number of processors used for the grid
1183 6958 : nproc_eff=mpi_enreg%nproc_fft*mpi_enreg%nproc_band *mpi_enreg%nproc_spkpt*mpi_enreg%nproc_spinor
1184 6958 : if(nproc_eff/=nproc) then
1185 : write(msg,'(4a,5(a,i0,a))') &
1186 0 : ' The number of band*FFT*spin*kpt*spinor processors, npband*npfft*np_spkpt*npspinor should be',ch10,&
1187 0 : ' equal to the total number of processors, nproc.',ch10,&
1188 0 : ' However, npband =',mpi_enreg%nproc_band, ch10, &
1189 0 : ' npfft =',mpi_enreg%nproc_fft, ch10, &
1190 0 : ' np_spkpt =',mpi_enreg%nproc_spkpt, ch10, &
1191 0 : ' npspinor =',mpi_enreg%nproc_spinor, ch10, &
1192 0 : ' nproc =',nproc,ch10
1193 0 : ABI_WARNING(msg)
1194 : end if
1195 :
1196 : ! Nothing to do if only 1 proc
1197 6958 : if (nproc_eff==1) return
1198 :
1199 : ! Initialize the communicator for Hartree-Fock to xmpi_comm_self
1200 1226 : mpi_enreg%me_hf =0
1201 1226 : mpi_enreg%comm_hf=xmpi_comm_self
1202 :
1203 1226 : if(mpi_enreg%paral_kgb==0) then
1204 608 : mpi_enreg%me_fft =0
1205 608 : mpi_enreg%me_band=0
1206 608 : mpi_enreg%me_kpt =mpi_enreg%me_cell
1207 608 : mpi_enreg%me_spinor=0
1208 608 : mpi_enreg%comm_fft=xmpi_comm_self
1209 608 : mpi_enreg%comm_band=xmpi_comm_self
1210 608 : mpi_enreg%comm_kpt=mpi_enreg%comm_cell
1211 608 : mpi_enreg%comm_spinor=xmpi_comm_self
1212 608 : mpi_enreg%comm_bandspinor=xmpi_comm_self
1213 608 : mpi_enreg%comm_kptband=mpi_enreg%comm_cell
1214 608 : mpi_enreg%comm_spinorfft=xmpi_comm_self
1215 608 : mpi_enreg%comm_bandfft=xmpi_comm_self
1216 608 : mpi_enreg%comm_bandspinorfft=xmpi_comm_self
1217 : else
1218 : ! CREATE THE 4D GRID
1219 : ! ==================================================
1220 :
1221 : ! Create the global cartesian 4D- communicator
1222 : ! valgrind claims this is not deallocated in test v5/72
1223 : ! Can someone knowledgeble check?
1224 618 : dimcart=4
1225 618 : ABI_MALLOC(sizecart,(dimcart))
1226 618 : ABI_MALLOC(period,(dimcart))
1227 : ! MT 2012-june: change the order of the indexes; not sure this is efficient
1228 : ! (not efficient on TGCC-Curie).
1229 618 : sizecart(1)=mpi_enreg%nproc_spkpt ! mpi_enreg%nproc_spkpt
1230 618 : sizecart(2)=mpi_enreg%nproc_band ! mpi_enreg%nproc_band
1231 618 : sizecart(3)=mpi_enreg%nproc_spinor ! mpi_enreg%nproc_spinor
1232 618 : sizecart(4)=mpi_enreg%nproc_fft ! mpi_enreg%nproc_fft
1233 3090 : period(:)=.false.;reorder=.false.
1234 618 : call MPI_CART_CREATE(spacecomm,dimcart,sizecart,period,reorder,commcart_4d,ierr)
1235 618 : ABI_FREE(period)
1236 618 : ABI_FREE(sizecart)
1237 :
1238 : ! Find the index and coordinates of the current processor
1239 618 : call MPI_COMM_RANK(commcart_4d, me_cart_4d, ierr)
1240 1854 : ABI_MALLOC(coords,(dimcart))
1241 618 : call MPI_CART_COORDS(commcart_4d, me_cart_4d,dimcart,coords,ierr)
1242 618 : mpi_enreg%me_kpt =coords(1)
1243 618 : mpi_enreg%me_band=coords(2)
1244 618 : mpi_enreg%me_spinor=coords(3)
1245 618 : mpi_enreg%me_fft =coords(4)
1246 618 : ABI_FREE(coords)
1247 :
1248 1854 : ABI_MALLOC(keepdim,(dimcart))
1249 :
1250 : ! Create the communicator for fft distribution
1251 618 : keepdim(1)=.false.
1252 618 : keepdim(2)=.false.
1253 618 : keepdim(3)=.false.
1254 618 : keepdim(4)=.true.
1255 618 : call MPI_CART_SUB(commcart_4d, keepdim, mpi_enreg%comm_fft,ierr)
1256 :
1257 : ! Create the communicator for band distribution
1258 618 : keepdim(1)=.false.
1259 618 : keepdim(2)=.true.
1260 618 : keepdim(3)=.false.
1261 618 : keepdim(4)=.false.
1262 618 : call MPI_CART_SUB(commcart_4d, keepdim, mpi_enreg%comm_band,ierr)
1263 :
1264 : ! Create the communicator for kpt distribution
1265 618 : keepdim(1)=.true.
1266 618 : keepdim(2)=.false.
1267 618 : keepdim(3)=.false.
1268 618 : keepdim(4)=.false.
1269 618 : call MPI_CART_SUB(commcart_4d, keepdim, mpi_enreg%comm_kpt,ierr)
1270 :
1271 : ! Create the communicator for spinor distribution
1272 618 : keepdim(1)=.false.
1273 618 : keepdim(2)=.false.
1274 618 : keepdim(3)=.true.
1275 618 : keepdim(4)=.false.
1276 618 : call MPI_CART_SUB(commcart_4d, keepdim, mpi_enreg%comm_spinor,ierr)
1277 :
1278 : ! Create the communicator for band-spinor distribution
1279 618 : keepdim(1)=.false.
1280 618 : keepdim(2)=.true.
1281 618 : keepdim(3)=.true.
1282 618 : keepdim(4)=.false.
1283 618 : call MPI_CART_SUB(commcart_4d, keepdim, mpi_enreg%comm_bandspinor,ierr)
1284 618 : if (ierr /= MPI_SUCCESS ) then
1285 0 : call xmpi_abort(mpi_enreg%comm_world,ierr)
1286 : end if
1287 :
1288 : ! Create the communicator for kpt-band distribution
1289 618 : keepdim(1)=.true.
1290 618 : keepdim(2)=.true.
1291 618 : keepdim(3)=.false.
1292 618 : keepdim(4)=.false.
1293 618 : call MPI_CART_SUB(commcart_4d, keepdim, mpi_enreg%comm_kptband,ierr)
1294 :
1295 : ! Create the communicator for fft-spinor distribution
1296 618 : keepdim(1)=.false.
1297 618 : keepdim(2)=.false.
1298 618 : keepdim(3)=.true.
1299 618 : keepdim(4)=.true.
1300 618 : call MPI_CART_SUB(commcart_4d, keepdim, mpi_enreg%comm_spinorfft,ierr)
1301 :
1302 : ! Create the communicator for fft-band distribution
1303 618 : keepdim(1)=.false.
1304 618 : keepdim(2)=.true.
1305 618 : keepdim(3)=.false.
1306 618 : keepdim(4)=.true.
1307 618 : call MPI_CART_SUB(commcart_4d, keepdim, mpi_enreg%comm_bandfft,ierr)
1308 :
1309 : ! Create the communicator for fft-band-spinor distribution
1310 618 : keepdim(1)=.false.
1311 618 : keepdim(2)=.true.
1312 618 : keepdim(3)=.true.
1313 618 : keepdim(4)=.true.
1314 618 : call MPI_CART_SUB(commcart_4d, keepdim, mpi_enreg%comm_bandspinorfft,ierr)
1315 :
1316 618 : ABI_FREE(keepdim)
1317 618 : call xmpi_comm_free(commcart_4d)
1318 : end if
1319 :
1320 : !Write some data
1321 : !write(msg,'(a,4i5)') 'npfft, npband, npspinor and np_spkpt: ',&
1322 : !mpi_enreg%nproc_fft,mpi_enreg%nproc_band, mpi_enreg%nproc_spinor,mpi_enreg%nproc_spkpt
1323 : !call wrtout(std_out,msg,'COLL')
1324 : !write(msg,'(a,4i5)') 'me_fft, me_band, me_spinor , me_kpt: ',&
1325 : !mpi_enreg%me_fft,mpi_enreg%me_band,mpi_enreg%me_spinor, mpi_enreg%me_kpt
1326 : !call wrtout(std_out,msg,'COLL')
1327 :
1328 : else ! paral_hf==1
1329 : !* Option Hartree-Fock is active and more than 1 processor is dedicated to the parallelization over occupied states.
1330 :
1331 : !* Initialize the values of fft, band and spinor communicators, as in the case paral_kgb==0.
1332 0 : mpi_enreg%me_fft =0
1333 0 : mpi_enreg%me_band=0
1334 0 : mpi_enreg%me_spinor=0
1335 0 : mpi_enreg%comm_fft=xmpi_comm_self
1336 0 : mpi_enreg%comm_band=xmpi_comm_self
1337 0 : mpi_enreg%comm_spinor=xmpi_comm_self
1338 0 : mpi_enreg%comm_bandspinor=xmpi_comm_self
1339 0 : mpi_enreg%comm_kptband=mpi_enreg%comm_cell
1340 0 : mpi_enreg%comm_spinorfft=xmpi_comm_self
1341 0 : mpi_enreg%comm_bandfft=xmpi_comm_self
1342 0 : mpi_enreg%comm_bandspinorfft=xmpi_comm_self
1343 :
1344 : !* Create the global cartesian 2D- communicator
1345 0 : dimcart=2
1346 0 : ABI_MALLOC(sizecart,(dimcart))
1347 0 : ABI_MALLOC(period,(dimcart))
1348 0 : sizecart(1)=mpi_enreg%nproc_spkpt ! mpi_enreg%nproc_spkpt
1349 0 : sizecart(2)=mpi_enreg%nproc_hf ! mpi_enreg%nproc_hf
1350 0 : period(:)=.false.;reorder=.false.
1351 0 : call MPI_CART_CREATE(spacecomm,dimcart,sizecart,period,reorder,commcart_2d,ierr)
1352 0 : ABI_FREE(period)
1353 0 : ABI_FREE(sizecart)
1354 :
1355 : !* Find the index and coordinates of the current processor
1356 0 : call MPI_COMM_RANK(commcart_2d, me_cart_2d, ierr)
1357 0 : ABI_MALLOC(coords,(dimcart))
1358 0 : call MPI_CART_COORDS(commcart_2d, me_cart_2d,dimcart,coords,ierr)
1359 0 : mpi_enreg%me_kpt =coords(1)
1360 0 : mpi_enreg%me_hf=coords(2)
1361 0 : ABI_FREE(coords)
1362 :
1363 0 : ABI_MALLOC(keepdim,(dimcart))
1364 :
1365 : !* Create the communicator for kpt distribution
1366 0 : keepdim(1)=.true.
1367 0 : keepdim(2)=.false.
1368 0 : call MPI_CART_SUB(commcart_2d, keepdim, mpi_enreg%comm_kpt,ierr)
1369 :
1370 : !* Create the communicator for hf distribution
1371 0 : keepdim(1)=.false.
1372 0 : keepdim(2)=.true.
1373 0 : call MPI_CART_SUB(commcart_2d, keepdim, mpi_enreg%comm_hf,ierr)
1374 :
1375 0 : ABI_FREE(keepdim)
1376 0 : call xmpi_comm_free(commcart_2d)
1377 :
1378 : !* Write some data
1379 0 : write(msg,'(a,2(1x,i0))') 'nphf and np_spkpt: ',mpi_enreg%nproc_hf, mpi_enreg%nproc_spkpt
1380 0 : call wrtout(std_out,msg)
1381 0 : write(msg,'(a,2(1x,i0))') 'me_hf, me_kpt: ',mpi_enreg%me_hf, mpi_enreg%me_kpt
1382 0 : call wrtout(std_out,msg)
1383 : end if
1384 : #endif
1385 :
1386 : DBG_EXIT("COLL")
1387 :
1388 : end subroutine initmpi_grid
1389 : !!***
1390 :
1391 : !----------------------------------------------------------------------
1392 :
1393 : !!****f* m_mpinfo/clnmpi_grid
1394 : !! NAME
1395 : !! clnmpi_grid
1396 : !!
1397 : !! FUNCTION
1398 : !! Cleans-up the mpi information for parallelism over grid (kpt/band/fft).
1399 : !!
1400 : !! SIDE EFFECTS
1401 : !! mpi_enreg=information about MPI parallelization
1402 : !!
1403 : !! SOURCE
1404 :
1405 6954 : subroutine clnmpi_grid(mpi_enreg)
1406 :
1407 : !Arguments ------------------------------------
1408 : class(MPI_type), intent(inout) :: mpi_enreg
1409 : ! ***********************************************************************
1410 :
1411 : DBG_ENTER("COLL")
1412 :
1413 : if (xmpi_paral==0) return
1414 :
1415 6954 : if (mpi_enreg%comm_bandspinorfft/=mpi_enreg%comm_world) then
1416 6954 : call xmpi_comm_free(mpi_enreg%comm_bandspinorfft)
1417 6954 : mpi_enreg%comm_bandspinorfft=xmpi_comm_null
1418 : end if
1419 :
1420 6954 : if (mpi_enreg%comm_bandfft/=mpi_enreg%comm_world) then
1421 6954 : call xmpi_comm_free(mpi_enreg%comm_bandfft)
1422 6954 : mpi_enreg%comm_bandfft=xmpi_comm_null
1423 : end if
1424 :
1425 6954 : if (mpi_enreg%comm_spinorfft/=mpi_enreg%comm_world) then
1426 6954 : call xmpi_comm_free(mpi_enreg%comm_spinorfft)
1427 6954 : mpi_enreg%comm_spinorfft=xmpi_comm_null
1428 : end if
1429 :
1430 6954 : if (mpi_enreg%comm_bandspinor/=mpi_enreg%comm_world) then
1431 6954 : call xmpi_comm_free(mpi_enreg%comm_bandspinor)
1432 6954 : mpi_enreg%comm_bandspinor=xmpi_comm_null
1433 : end if
1434 :
1435 6954 : if (mpi_enreg%comm_kptband/=mpi_enreg%comm_world) then
1436 6346 : call xmpi_comm_free(mpi_enreg%comm_kptband)
1437 6346 : mpi_enreg%comm_kptband=xmpi_comm_null
1438 : end if
1439 :
1440 6954 : if (mpi_enreg%comm_fft/=mpi_enreg%comm_world) then
1441 6954 : call xmpi_comm_free(mpi_enreg%comm_fft)
1442 6954 : mpi_enreg%comm_fft=xmpi_comm_null
1443 : end if
1444 :
1445 6954 : if (mpi_enreg%comm_band/=mpi_enreg%comm_world) then
1446 6954 : call xmpi_comm_free(mpi_enreg%comm_band)
1447 6954 : mpi_enreg%comm_band=xmpi_comm_null
1448 : end if
1449 :
1450 6954 : if (mpi_enreg%comm_spinor/=mpi_enreg%comm_world) then
1451 6954 : call xmpi_comm_free(mpi_enreg%comm_spinor)
1452 6954 : mpi_enreg%comm_spinor=xmpi_comm_null
1453 : end if
1454 :
1455 6954 : if (mpi_enreg%comm_kpt/=mpi_enreg%comm_world) then
1456 6346 : call xmpi_comm_free(mpi_enreg%comm_kpt)
1457 6346 : mpi_enreg%comm_kpt=xmpi_comm_null
1458 : end if
1459 :
1460 : DBG_EXIT("COLL")
1461 :
1462 6954 : end subroutine clnmpi_grid
1463 : !!***
1464 :
1465 : !!****f* ABINIT/initmpi_img
1466 : !! NAME
1467 : !! initmpi_img
1468 : !!
1469 : !! FUNCTION
1470 : !! Initializes the mpi information for parallelism over images of the cell (npimage>1).
1471 : !!
1472 : !! INPUTS
1473 : !! dtset <type(dataset_type)>=all input variables in this dataset
1474 : !! mpi_enreg= information about MPI parallelization
1475 : !! option= see below
1476 : !!
1477 : !! OUTPUT
1478 : !! mpi_enreg%my_nimage= number of images of the cell treated by current proc
1479 : !! ===== if option==1 or option==-1
1480 : !! mpi_enreg%my_imgtab= indexes of images of the cell treated by current proc
1481 : !! ===== if option==2 or option==3 or option==-1
1482 : !! mpi_enreg%comm_cell=Communicator over all processors treating the same image
1483 : !! mpi_enreg%nproc_cell=size of comm_cell
1484 : !! mpi_enreg%me_cell=my rank in comm_cell
1485 : !! ===== if option==3 or option==-1
1486 : !! mpi_enreg%comm_img=Communicator over all images
1487 : !! mpi_enreg%nproc_img=size of comm_img
1488 : !! mpi_enreg%me_img=my rank in comm_img
1489 : !! mpi_enreg%distrb_img(:)=index of processor treating each image (in comm_img communicator)
1490 : !!
1491 : !! SOURCE
1492 :
1493 8387 : subroutine initmpi_img(dtset,mpi_enreg,option)
1494 :
1495 : !Arguments ------------------------------------
1496 : integer,intent(in) :: option
1497 : type(dataset_type),intent(in) :: dtset
1498 : class(MPI_type),intent(inout) :: mpi_enreg
1499 :
1500 : !Local variables-------------------------------
1501 : integer :: imod,irank,iprocmax,iprocmin,jrank
1502 : integer :: ndynimage_eff,nimage_eff,nproc_per_image,nrank
1503 : logical,parameter :: debug=.false.
1504 8387 : integer,allocatable :: ranks(:)
1505 : character(len=500) :: msg
1506 :
1507 : !integer :: group_cell,ierr
1508 : ! ***********************************************************************
1509 :
1510 : DBG_ENTER("COLL")
1511 8387 : if (option/=0) then
1512 8387 : mpi_enreg%comm_img=xmpi_comm_self
1513 8387 : mpi_enreg%comm_cell=mpi_enreg%comm_world
1514 : end if
1515 :
1516 8387 : if (xmpi_paral==1.and.dtset%npimage>1.and.dtset%npimage<=mpi_enreg%nproc.and. dtset%optdriver==RUNL_GSTATE) then
1517 :
1518 : ! Activate flag for parallelization over images
1519 0 : mpi_enreg%paral_img=1
1520 :
1521 0 : ndynimage_eff=dtset%ndynimage;if (dtset%ntimimage<=1) ndynimage_eff=0
1522 :
1523 : ! Print several warnings
1524 0 : if (option==0) then
1525 0 : nimage_eff=max(ndynimage_eff,dtset%nimage-ndynimage_eff)
1526 0 : if (dtset%npimage>nimage_eff) then
1527 : write(unit=msg,fmt='(3a,i4,a,i4,4a)') &
1528 0 : 'The number of processors used for the parallelization',ch10,&
1529 0 : ' over images (npimage=',dtset%npimage,&
1530 0 : ') is greater than the number of dynamic (or static) images (',nimage_eff,') !',ch10,&
1531 0 : ' This is inefficient.',ch10
1532 0 : ABI_WARNING(msg)
1533 : end if
1534 0 : if (dtset%npimage>mpi_enreg%nproc) then
1535 : write(unit=msg,fmt='(3a,i6,a,i4,4a)') &
1536 0 : 'The number of processors used for the parallelization',ch10,&
1537 0 : ' over images (nproc=',mpi_enreg%nproc,&
1538 0 : ') is smaller than npimage in input file (',dtset%npimage,&
1539 0 : ')!',ch10,' This is inconsistent.',ch10
1540 0 : ABI_ERROR(msg)
1541 : end if
1542 0 : if (mod(nimage_eff,dtset%npimage)/=0) then
1543 : write(unit=msg,fmt='(3a,i4,a,i4,4a)') &
1544 0 : 'The number of processors used for the parallelization',ch10,&
1545 0 : ' over images (npimage=',dtset%npimage,&
1546 0 : ') does not divide the number of dynamic images (',nimage_eff,&
1547 0 : ') !',ch10,' This is inefficient (charge unbalancing).',ch10
1548 0 : ABI_WARNING(msg)
1549 : end if
1550 : end if
1551 :
1552 : ! # of images treated by current proc
1553 0 : nproc_per_image=mpi_enreg%nproc/dtset%npimage
1554 0 : iprocmax=nproc_per_image*dtset%npimage-1
1555 0 : if (mpi_enreg%me<=iprocmax) then
1556 0 : mpi_enreg%my_nimage=(ndynimage_eff/dtset%npimage)+((dtset%nimage-ndynimage_eff)/dtset%npimage)
1557 0 : imod=mod(ndynimage_eff,dtset%npimage)-1
1558 0 : if (mpi_enreg%me/nproc_per_image<=imod) mpi_enreg%my_nimage=mpi_enreg%my_nimage+1
1559 0 : imod=mod((dtset%nimage-ndynimage_eff),dtset%npimage)-1
1560 0 : if (mpi_enreg%me/nproc_per_image<=imod) mpi_enreg%my_nimage=mpi_enreg%my_nimage+1
1561 : else
1562 0 : mpi_enreg%my_nimage=0
1563 : end if
1564 0 : if (option==1.or.option==-1) then
1565 : ! Indexes of images treated by current proc
1566 0 : if (mpi_enreg%me<=iprocmax) then
1567 0 : ABI_MALLOC(mpi_enreg%my_imgtab,(mpi_enreg%my_nimage))
1568 0 : nrank=0
1569 0 : imod=mpi_enreg%me/nproc_per_image+1;imod=mod(imod,dtset%npimage)
1570 : ! Dynamic images
1571 0 : irank=0
1572 0 : do jrank=1,dtset%nimage
1573 0 : if (dtset%dynimage(jrank)/=0.and.dtset%ntimimage>1) then
1574 0 : irank=irank+1
1575 0 : if (mod(irank,dtset%npimage)==imod) then
1576 0 : nrank=nrank+1
1577 0 : mpi_enreg%my_imgtab(nrank)=jrank
1578 : end if
1579 : end if
1580 : end do
1581 : ! Static images
1582 : irank=0
1583 0 : do jrank=1,dtset%nimage
1584 0 : if (dtset%dynimage(jrank)==0.or.dtset%ntimimage<=1) then
1585 0 : irank=irank+1
1586 0 : if (mod(irank,dtset%npimage)==imod) then
1587 0 : nrank=nrank+1
1588 0 : mpi_enreg%my_imgtab(nrank)=jrank
1589 : end if
1590 : end if
1591 : end do
1592 0 : if (nrank/=mpi_enreg%my_nimage) then
1593 0 : ABI_BUG('Error on nrank !')
1594 : end if
1595 : ! Sort images by increasing index (this step is MANDATORY !!)
1596 0 : if (nrank>0) then
1597 0 : ABI_MALLOC(ranks,(nrank))
1598 0 : call sort_int(nrank,mpi_enreg%my_imgtab,ranks)
1599 0 : ABI_FREE(ranks)
1600 : end if
1601 : else
1602 0 : ABI_MALLOC(mpi_enreg%my_imgtab,(0))
1603 : end if
1604 : end if
1605 0 : if (option==2.or.option==3.or.option==-1) then
1606 : ! Communicator over one image
1607 0 : if (mpi_enreg%me<=iprocmax) then
1608 0 : ABI_MALLOC(ranks,(nproc_per_image))
1609 0 : iprocmin=(mpi_enreg%me/nproc_per_image)*nproc_per_image
1610 0 : ranks=(/((iprocmin+irank-1),irank=1,nproc_per_image)/)
1611 0 : mpi_enreg%comm_cell=xmpi_subcomm(mpi_enreg%comm_world,nproc_per_image,ranks)
1612 0 : ABI_FREE(ranks)
1613 0 : mpi_enreg%me_cell=xmpi_comm_rank(mpi_enreg%comm_cell)
1614 0 : mpi_enreg%nproc_cell=nproc_per_image
1615 0 : if (mpi_enreg%me_cell==0.and.mod(mpi_enreg%me,nproc_per_image)/=0) then
1616 0 : ABI_BUG('Error on me_cell !')
1617 : end if
1618 : else
1619 0 : mpi_enreg%comm_img=xmpi_comm_null
1620 0 : mpi_enreg%nproc_cell=0
1621 0 : mpi_enreg%me_cell=-1
1622 : end if
1623 : end if
1624 0 : if (option==3.or.option==-1) then
1625 : ! Communicator over all images
1626 0 : if (mpi_enreg%me<=iprocmax) then
1627 0 : ABI_MALLOC(ranks,(dtset%npimage))
1628 0 : iprocmin=mod(mpi_enreg%me,nproc_per_image)
1629 0 : ranks=(/((iprocmin+(irank-1)*nproc_per_image),irank=1,dtset%npimage)/)
1630 0 : mpi_enreg%comm_img=xmpi_subcomm(mpi_enreg%comm_world,dtset%npimage,ranks)
1631 0 : ABI_FREE(ranks)
1632 0 : mpi_enreg%me_img=xmpi_comm_rank(mpi_enreg%comm_img)
1633 0 : mpi_enreg%nproc_img=dtset%npimage
1634 0 : if (iprocmin==0.and.mpi_enreg%me_img==0.and.mpi_enreg%me/=0) then
1635 0 : ABI_BUG('Error on me_img!')
1636 : end if
1637 0 : ABI_MALLOC(mpi_enreg%distrb_img,(dtset%nimage))
1638 : ! Dynamic images
1639 0 : nrank=0
1640 0 : do irank=1,dtset%nimage
1641 0 : if (dtset%dynimage(irank)/=0.and.dtset%ntimimage>1) then
1642 0 : nrank=nrank+1
1643 0 : mpi_enreg%distrb_img(irank)=mod(nrank,dtset%npimage)-1
1644 0 : if (mpi_enreg%distrb_img(irank)==-1) mpi_enreg%distrb_img(irank)=dtset%npimage-1
1645 : end if
1646 : end do
1647 : ! Static images
1648 0 : nrank=0
1649 0 : do irank=1,dtset%nimage
1650 0 : if (dtset%dynimage(irank)==0.or.dtset%ntimimage<=1) then
1651 0 : nrank=nrank+1
1652 0 : mpi_enreg%distrb_img(irank)=mod(nrank,dtset%npimage)-1
1653 0 : if (mpi_enreg%distrb_img(irank)==-1) mpi_enreg%distrb_img(irank)=dtset%npimage-1
1654 : end if
1655 : end do
1656 : else
1657 0 : mpi_enreg%comm_img=xmpi_comm_null
1658 0 : mpi_enreg%nproc_img=0
1659 0 : mpi_enreg%me_img=-1
1660 0 : ABI_MALLOC(mpi_enreg%distrb_img,(0))
1661 : end if
1662 : end if
1663 :
1664 : ! if (debug) then
1665 : ! write(200+mpi_enreg%me,*) "=================================="
1666 : ! write(200+mpi_enreg%me,*) "DEBUGGING STATEMENTS IN INITMPI_IMG"
1667 : ! write(200+mpi_enreg%me,*) "=================================="
1668 : ! write(200+mpi_enreg%me,*) "option =",option
1669 : ! write(200+mpi_enreg%me,*) "MPI_UNDEFINED =",MPI_UNDEFINED
1670 : ! write(200+mpi_enreg%me,*) "MPI_IDENT =",MPI_IDENT
1671 : ! write(200+mpi_enreg%me,*) "MPI_CONGRUENT =",MPI_CONGRUENT
1672 : ! write(200+mpi_enreg%me,*) "MPI_SIMILAR =",MPI_SIMILAR
1673 : ! write(200+mpi_enreg%me,*) "MPI_UNEQUAL =",MPI_UNEQUAL
1674 : ! write(200+mpi_enreg%me,*) "null_comm =",MPI_COMM_NULL
1675 : ! write(200+mpi_enreg%me,*) "self_comm =",xmpi_comm_self
1676 : ! write(200+mpi_enreg%me,*) "world_comm =",mpi_enreg%comm_world
1677 : ! write(200+mpi_enreg%me,*) "empty_group =",MPI_GROUP_EMPTY
1678 : ! write(200+mpi_enreg%me,*) "nimage =",mpi_enreg%my_nimage
1679 : ! write(200+mpi_enreg%me,*) "nproc_per_image=",nproc_per_image
1680 : ! call MPI_COMM_SIZE(mpi_enreg%comm_world,irank,ierr)
1681 : ! write(200+mpi_enreg%me,*) "Size of world_comm =",irank
1682 : ! call MPI_COMM_RANK(mpi_enreg%comm_world,irank,ierr)
1683 : ! write(200+mpi_enreg%me,*) "My rank in world_comm =",irank
1684 : ! if (option==1.or.option==-1) then
1685 : ! write(200+mpi_enreg%me,*) "index_img=",mpi_enreg%my_imgtab(:)
1686 : ! end if
1687 : ! if (option==2.or.option==3.or.option==-1) then
1688 : ! write(200+mpi_enreg%me,*) "nproc_cell =",mpi_enreg%nproc_cell
1689 : ! write(200+mpi_enreg%me,*) "me_cell =",mpi_enreg%me_cell
1690 : ! call xmpi_comm_group(mpi_enreg%comm_cell,group_cell,ierr)
1691 : ! write(200+mpi_enreg%me,*) "group_cell =",group_cell
1692 : ! write(200+mpi_enreg%me,*) "comm_cell =",mpi_enreg%comm_cell
1693 : ! if (group_cell/=MPI_GROUP_EMPTY) then
1694 : ! call MPI_GROUP_SIZE(group_cell,irank,ierr)
1695 : ! write(200+mpi_enreg%me,*) "Size of group_cell =",irank
1696 : ! call MPI_GROUP_RANK(group_cell,irank,ierr)
1697 : ! write(200+mpi_enreg%me,*) "My rank in group_cell=",irank
1698 : ! else
1699 : ! write(200+mpi_enreg%me,*) "Size of group_cell =",0
1700 : ! write(200+mpi_enreg%me,*) "My rank in group_cell=",-1
1701 : ! end if
1702 : ! if (mpi_enreg%comm_cell/=MPI_COMM_NULL) then
1703 : ! call MPI_COMM_SIZE(mpi_enreg%comm_cell,irank,ierr)
1704 : ! write(200+mpi_enreg%me,*) "Size of comm_cell =",irank
1705 : ! call MPI_COMM_RANK(mpi_enreg%comm_cell,irank,ierr)
1706 : ! write(200+mpi_enreg%me,*) "My rank in comm_cell=",irank
1707 : ! call MPI_COMM_COMPARE(mpi_enreg%comm_world,mpi_enreg%comm_cell,irank,ierr)
1708 : ! write(200+mpi_enreg%me,*) "Comparison world_comm/comm_cell=",irank
1709 : ! call MPI_COMM_COMPARE(xmpi_comm_self,mpi_enreg%comm_cell,irank,ierr)
1710 : ! write(200+mpi_enreg%me,*) "Comparison self_comm/comm_cell =",irank
1711 : ! else
1712 : ! write(200+mpi_enreg%me,*) "Size of comm_cell =",0
1713 : ! write(200+mpi_enreg%me,*) "My rank in comm_cell=",-1
1714 : ! write(200+mpi_enreg%me,*) "Comparison world_comm/comm_cell=",MPI_UNEQUAL
1715 : ! write(200+mpi_enreg%me,*) "Comparison self_comm/comm_cell =",MPI_UNEQUAL
1716 : ! end if
1717 : ! end if
1718 : ! if (option==3.or.option==-1) then
1719 : ! write(200+mpi_enreg%me,*) "nproc_img =",mpi_enreg%nproc_img
1720 : ! write(200+mpi_enreg%me,*) "me_img =",mpi_enreg%me_img
1721 : ! write(200+mpi_enreg%me,*) "img_comm =",mpi_enreg%comm_img
1722 : ! if (mpi_enreg%comm_img/=MPI_COMM_NULL) then
1723 : ! call MPI_COMM_SIZE(mpi_enreg%comm_img,irank,ierr)
1724 : ! write(200+mpi_enreg%me,*) "Size of img_comm =",irank
1725 : ! call MPI_COMM_RANK(mpi_enreg%comm_img,irank,ierr)
1726 : ! write(200+mpi_enreg%me,*) "My rank in img_comm=",irank
1727 : ! call MPI_COMM_COMPARE(mpi_enreg%comm_world,mpi_enreg%comm_img,irank,ierr)
1728 : ! write(200+mpi_enreg%me,*) "Comparison world_comm/img_comm=",irank
1729 : ! call MPI_COMM_COMPARE(xmpi_comm_self,mpi_enreg%comm_img,irank,ierr)
1730 : ! write(200+mpi_enreg%me,*) "Comparison self_comm/img_comm =",irank
1731 : ! else
1732 : ! write(200+mpi_enreg%me,*) "Size of img_comm =",0
1733 : ! write(200+mpi_enreg%me,*) "My rank in img_comm=",-1
1734 : ! write(200+mpi_enreg%me,*) "Comparison world_comm/img_comm=",MPI_UNEQUAL
1735 : ! write(200+mpi_enreg%me,*) "Comparison self_comm/img_comm =",MPI_UNEQUAL
1736 : ! end if
1737 : ! write(200+mpi_enreg%me,*) "distrb_img=",mpi_enreg%distrb_img(:)
1738 : ! end if
1739 : ! write(200+mpi_enreg%me,*)
1740 : ! call flush_unit(200+mpi_enreg%me)
1741 : ! if (option==-1) stop
1742 : ! end if
1743 :
1744 : else
1745 :
1746 : ! Do not activate flag for parallelization over images
1747 8387 : mpi_enreg%paral_img=0
1748 : ! # of images treated by current proc
1749 8387 : if (dtset%optdriver==RUNL_GSTATE) then
1750 7069 : mpi_enreg%my_nimage=dtset%nimage
1751 : else
1752 1318 : mpi_enreg%my_nimage=1
1753 : end if
1754 : ! Indexes of images treated by current proc
1755 8387 : if (option==1.or.option==-1) then
1756 25161 : ABI_MALLOC(mpi_enreg%my_imgtab,(mpi_enreg%my_nimage))
1757 51102 : mpi_enreg%my_imgtab=(/(irank,irank=1,mpi_enreg%my_nimage)/)
1758 : end if
1759 : ! Communicator over all images
1760 8387 : if (option==2.or.option==3.or.option==-1) then
1761 : ! Communicator for one image
1762 8387 : mpi_enreg%nproc_cell=mpi_enreg%nproc
1763 8387 : mpi_enreg%me_cell=mpi_enreg%me
1764 : end if
1765 8387 : if (option==3.or.option==-1) then
1766 : ! Communicator over all images
1767 8387 : mpi_enreg%nproc_img=1
1768 8387 : mpi_enreg%comm_img=xmpi_comm_self
1769 8387 : mpi_enreg%me_img=0
1770 25161 : ABI_MALLOC(mpi_enreg%distrb_img,(dtset%nimage))
1771 17034 : mpi_enreg%distrb_img(:)=0
1772 : end if
1773 : end if
1774 :
1775 : DBG_EXIT("COLL")
1776 :
1777 8387 : end subroutine initmpi_img
1778 : !!***
1779 :
1780 : !----------------------------------------------------------------------
1781 :
1782 : !!****f* m_mpinfo/clnmpi_img
1783 : !! NAME
1784 : !! clnmpi_img
1785 : !!
1786 : !! FUNCTION
1787 : !! Cleans-up the mpi information for parallelism over images of the cell (npimage>1).
1788 : !!
1789 : !! SOURCE
1790 :
1791 8380 : subroutine clnmpi_img(mpi_enreg)
1792 :
1793 : !Arguments ------------------------------------
1794 : class(MPI_type), intent(inout) :: mpi_enreg
1795 : ! ***********************************************************************
1796 :
1797 : DBG_ENTER("COLL")
1798 :
1799 : if (xmpi_paral==0) return
1800 :
1801 8380 : if (mpi_enreg%comm_cell/=mpi_enreg%comm_world) then
1802 0 : call xmpi_comm_free(mpi_enreg%comm_cell)
1803 0 : mpi_enreg%comm_cell=xmpi_comm_null
1804 : end if
1805 :
1806 8380 : if (mpi_enreg%comm_img/=mpi_enreg%comm_world) then
1807 8380 : call xmpi_comm_free(mpi_enreg%comm_img)
1808 8380 : mpi_enreg%comm_img=xmpi_comm_null
1809 : end if
1810 :
1811 8380 : ABI_SFREE(mpi_enreg%my_imgtab)
1812 8380 : ABI_SFREE(mpi_enreg%distrb_img)
1813 :
1814 8380 : mpi_enreg%paral_img=0
1815 8380 : mpi_enreg%my_nimage=1
1816 8380 : mpi_enreg%me_img=0
1817 8380 : mpi_enreg%me_cell=0
1818 8380 : mpi_enreg%nproc_img=1
1819 8380 : mpi_enreg%nproc_cell=1
1820 :
1821 : DBG_EXIT("COLL")
1822 :
1823 8380 : end subroutine clnmpi_img
1824 : !!***
1825 :
1826 : !!****f* ABINIT/initmpi_pert
1827 : !! NAME
1828 : !! initmpi_pert
1829 : !!
1830 : !! FUNCTION
1831 : !! Creates group for Parallelization over Perturbations.
1832 : !!
1833 : !! INPUTS
1834 : !! dtset <type(dataset_type)>=all input variables in this dataset
1835 : !!
1836 : !! OUTPUT
1837 : !!
1838 : !! SIDE EFFECTS
1839 : !! mpi_enreg=information about MPI parallelization
1840 : !!
1841 : !! SOURCE
1842 :
1843 26 : subroutine initmpi_pert(dtset,mpi_enreg)
1844 :
1845 : !Arguments ------------------------------------
1846 : !scalars
1847 : class(MPI_type),intent(inout) :: mpi_enreg
1848 : type(dataset_type),intent(in) :: dtset
1849 :
1850 : !Local variables-------------------------------
1851 : !scalars
1852 : integer:: iprocmin,irank,npert,nproc_per_cell,nrank,numproc
1853 26 : integer,allocatable :: ranks(:)
1854 : !character(len=500) :: msg
1855 : !arrays
1856 26 : integer,pointer :: nkpt_rbz(:)
1857 26 : real(dp),pointer :: nband_rbz(:,:)
1858 : ! ***********************************************************************
1859 :
1860 26 : if (mpi_enreg%me_pert<0) then
1861 0 : ABI_ERROR('Error in MPI distribution! Change your proc(s) distribution or use autoparal>0.')
1862 : end if
1863 :
1864 26 : call dtset%get_npert_rbz(nband_rbz, nkpt_rbz, npert)
1865 :
1866 26 : if (dtset%nppert>=1) then
1867 26 : if (mpi_enreg%comm_cell/=mpi_enreg%comm_world) then
1868 0 : call xmpi_comm_free(mpi_enreg%comm_cell)
1869 : end if
1870 26 : mpi_enreg%comm_cell=mpi_enreg%comm_world
1871 :
1872 : ! These values will be properly set in set_pert_comm
1873 26 : mpi_enreg%me_cell=mpi_enreg%me
1874 26 : mpi_enreg%nproc_cell=mpi_enreg%nproc
1875 :
1876 26 : if (mpi_enreg%me>=0) then
1877 26 : nproc_per_cell=mpi_enreg%nproc/dtset%nppert
1878 78 : ABI_MALLOC(ranks,(dtset%nppert))
1879 26 : iprocmin=mod(mpi_enreg%me,nproc_per_cell)
1880 222 : ranks=(/((iprocmin+(irank-1)*nproc_per_cell),irank=1,dtset%nppert)/)
1881 26 : mpi_enreg%comm_pert=xmpi_subcomm(mpi_enreg%comm_world,dtset%nppert,ranks)
1882 26 : ABI_FREE(ranks)
1883 26 : mpi_enreg%me_pert=xmpi_comm_rank(mpi_enreg%comm_pert)
1884 26 : mpi_enreg%nproc_pert=dtset%nppert
1885 26 : if (iprocmin==0.and.mpi_enreg%me_pert==0.and.mpi_enreg%me/=0) then
1886 0 : ABI_BUG('Error on me_pert!')
1887 : end if
1888 : ! Define mpi_enreg%distrb_pert
1889 78 : ABI_MALLOC(mpi_enreg%distrb_pert,(npert))
1890 26 : nrank=0
1891 100 : do irank=1,npert
1892 74 : nrank=nrank+1
1893 74 : mpi_enreg%distrb_pert(irank)=mod(nrank,dtset%nppert)-1
1894 100 : if (mpi_enreg%distrb_pert(irank)==-1) mpi_enreg%distrb_pert(irank)=dtset%nppert-1
1895 : end do
1896 : ! Make sure that subrank 0 is working on the last perturbation
1897 : ! Swap the ranks if necessary
1898 26 : numproc=mpi_enreg%distrb_pert(npert)
1899 26 : if(numproc/=0) then
1900 52 : do irank=1,npert
1901 40 : if (mpi_enreg%distrb_pert(irank)==numproc) mpi_enreg%distrb_pert(irank)=-2
1902 52 : if (mpi_enreg%distrb_pert(irank)==0) mpi_enreg%distrb_pert(irank)=-3
1903 : end do
1904 52 : do irank=1,npert
1905 40 : if (mpi_enreg%distrb_pert(irank)==-2) mpi_enreg%distrb_pert(irank)=0
1906 52 : if (mpi_enreg%distrb_pert(irank)==-3) mpi_enreg%distrb_pert(irank)=numproc
1907 : end do
1908 : end if
1909 : ! Communicator over one cell
1910 78 : ABI_MALLOC(ranks,(nproc_per_cell))
1911 26 : iprocmin=(mpi_enreg%me/nproc_per_cell)*nproc_per_cell
1912 252 : ranks=(/((iprocmin+irank-1),irank=1,nproc_per_cell)/)
1913 26 : mpi_enreg%comm_cell_pert=xmpi_subcomm(mpi_enreg%comm_world,nproc_per_cell,ranks)
1914 26 : ABI_FREE(ranks)
1915 : end if
1916 :
1917 : else !nppert<=1
1918 0 : mpi_enreg%nproc_pert=1
1919 0 : mpi_enreg%comm_pert=xmpi_comm_self
1920 0 : mpi_enreg%me_pert=0
1921 0 : ABI_MALLOC(mpi_enreg%distrb_pert,(npert))
1922 0 : mpi_enreg%distrb_pert(:)=0
1923 : end if
1924 :
1925 26 : ABI_FREE(nband_rbz)
1926 26 : ABI_FREE(nkpt_rbz)
1927 :
1928 26 : end subroutine initmpi_pert
1929 : !!***
1930 :
1931 : !----------------------------------------------------------------------
1932 :
1933 : !!****f* m_mpinfo/clnmpi_pert
1934 : !! NAME
1935 : !! clnmpi_pert
1936 : !!
1937 : !! FUNCTION
1938 : !! Cleans-up the mpi information for parallelization over perturbations.
1939 : !!
1940 : !! SOURCE
1941 :
1942 6954 : subroutine clnmpi_pert(mpi_enreg)
1943 :
1944 : !Arguments ------------------------------------
1945 : class(MPI_type),intent(inout) :: mpi_enreg
1946 : ! ***********************************************************************
1947 :
1948 : DBG_ENTER("COLL")
1949 :
1950 : if (xmpi_paral==0) return
1951 :
1952 6954 : if(mpi_enreg%paral_pert == 1) then
1953 :
1954 : ! Reset communicators
1955 26 : if (mpi_enreg%comm_pert/=mpi_enreg%comm_world) then
1956 26 : call xmpi_comm_free(mpi_enreg%comm_pert)
1957 26 : mpi_enreg%comm_pert=xmpi_comm_null
1958 : end if
1959 :
1960 26 : ABI_SFREE(mpi_enreg%distrb_pert)
1961 :
1962 26 : mpi_enreg%me_pert=0
1963 26 : mpi_enreg%me_cell=0
1964 26 : mpi_enreg%nproc_pert=1
1965 26 : mpi_enreg%nproc_cell=1
1966 : end if
1967 :
1968 : DBG_EXIT("COLL")
1969 :
1970 6954 : end subroutine clnmpi_pert
1971 : !!***
1972 :
1973 : !!****f* ABINIT/initmpi_band
1974 : !! NAME
1975 : !! initmpi_band
1976 : !!
1977 : !! FUNCTION
1978 : !! Initializes the mpi information for band parallelism (paralbd=1).
1979 : !!
1980 : !! INPUTS
1981 : !! mpi_enreg= information about MPI parallelization
1982 : !! nband(nkpt*nsppol)= number of bands per k point, for each spin
1983 : !! nkpt= number of k-points
1984 : !! nsppol= 1 for unpolarized, 2 for polarized
1985 : !!
1986 : !! OUTPUT
1987 : !! mpi_enreg=information about MPI parallelization
1988 : !! mpi_enreg%comm_band=communicator of BAND set
1989 : !!
1990 : !! SOURCE
1991 :
1992 2347 : subroutine initmpi_band(mkmem,mpi_enreg,nband,nkpt,nsppol)
1993 :
1994 : !Arguments ------------------------------------
1995 : !scalars
1996 : integer,intent(in) :: mkmem
1997 : integer,intent(in) :: nkpt,nsppol
1998 : integer,intent(in) :: nband(nkpt*nsppol)
1999 : class(MPI_type),intent(inout) :: mpi_enreg
2000 :
2001 : !Local variables-------------------------------
2002 : !scalars
2003 : integer :: ii,ikpt,iproc_min,iproc_max,irank,isppol
2004 : integer :: me,nband_k,nproc,nb_per_proc,nrank,nstates,spacecomm
2005 : integer :: maxproc_bandpool, mband
2006 : character(len=500) :: msg
2007 : !arrays
2008 2347 : integer,allocatable :: ranks(:)
2009 : ! ***********************************************************************
2010 :
2011 : ! reinstate default just to be sure - can be switched inside a previous part of the same dtset!
2012 2347 : mpi_enreg%comm_band=xmpi_comm_self
2013 2347 : mpi_enreg%nproc_band=1
2014 :
2015 151802 : mband = maxval(nband)
2016 :
2017 : ABI_UNUSED(mkmem)
2018 :
2019 : ! Comm_kpt is supposed to treat spins, k-points and bands
2020 : !MJV: I think we need to make a proper subcomm here, not treat bands inside the same comm...
2021 2347 : spacecomm=mpi_enreg%comm_kpt
2022 2347 : nproc=mpi_enreg%nproc_spkpt
2023 :
2024 : ! make sure we have saturated kpt parallelization
2025 2347 : if (mpi_enreg%paralbd==1 .and. xmpi_paral==1 .and. nproc >= 2*nkpt*nsppol) then
2026 :
2027 : ! number of procs per kpt/spin, on which we can distribute bands
2028 24 : maxproc_bandpool=floor(nproc*one/(nkpt*nsppol))
2029 24 : me=mpi_enreg%me_kpt
2030 :
2031 : !! total number of states/bands, over all k and spin
2032 : nstates=sum(nband(1:nkpt*nsppol))
2033 : ! number of bands per proc in the band pool
2034 : ! nb_per_proc=nstates/maxproc_bandpool
2035 :
2036 24 : do nb_per_proc = mband / maxproc_bandpool, mband
2037 24 : if (mod(mband,nb_per_proc)==0) exit
2038 : end do
2039 :
2040 24 : nrank=0
2041 :
2042 : ! NB: do this for all procs even if mkmem == 0, otherwise the subcomm call below fails
2043 24 : if (nb_per_proc<mband) then
2044 48 : do isppol=1,nsppol
2045 72 : do ikpt=1,nkpt
2046 24 : ii=ikpt+(isppol-1)*nkpt
2047 24 : nband_k=nband(ii)
2048 48 : if (nb_per_proc<nband_k) then
2049 600 : iproc_min=minval(mpi_enreg%proc_distrb(ikpt,:,isppol))
2050 600 : iproc_max=maxval(mpi_enreg%proc_distrb(ikpt,:,isppol))
2051 24 : if ((me>=iproc_min).and.(me<=iproc_max)) then
2052 24 : nrank=iproc_max-iproc_min+1
2053 24 : if (.not.allocated(ranks)) then
2054 72 : ABI_MALLOC(ranks,(nrank))
2055 360 : if (nrank>0) ranks=(/((iproc_min+irank-1),irank=1,nrank)/)
2056 0 : else if (nrank/=size(ranks)) then
2057 : ! TODO MJV: still can not lift this restriction...
2058 0 : ABI_BUG('Number of bands per proc should be the same for all k-points!')
2059 : end if
2060 : end if
2061 : end if
2062 : end do
2063 : end do
2064 :
2065 24 : if (.not.allocated(ranks)) then
2066 0 : nrank = 0
2067 0 : ABI_MALLOC(ranks,(0))
2068 : end if
2069 :
2070 : ! ABI_CHECK(nrank*nkpt==nproc, ' band and k-point distribution should be rectangular: make sure nproc=nkpt*integer')
2071 :
2072 24 : if (nrank*nkpt*nsppol < nproc) then
2073 : write(unit=msg,fmt='(a,i6,2a,i6,a,i6,4a)') &
2074 0 : 'The number of processors nproc = ', nproc, ch10,&
2075 0 : ' is not equal to nrank (=',nrank,&
2076 0 : ') times nkpt*nsppol (',nkpt*nsppol,&
2077 0 : ' , which may change with perturbation) !',ch10,&
2078 0 : ' This is inefficient (load unbalancing). Adjust nband to have a divisor <= nproc/nkpt/nsppol',ch10
2079 0 : ABI_WARNING(msg)
2080 : end if
2081 : ! NB: everyone in spacecomm has to call subcomm, even if it is a trivial call with self_comm for the subcomm
2082 24 : mpi_enreg%comm_band=xmpi_subcomm(spacecomm,nrank,ranks, my_rank_in_group=mpi_enreg%me_band)
2083 24 : mpi_enreg%nproc_band=nrank
2084 : ! mpi_enreg%me_band=mod(me, nrank)
2085 :
2086 24 : write(msg,'(4(a,i0))') 'P Present parallel dimensions: nkpt= ',nkpt,' nsppol ',nsppol,&
2087 48 : ' nband per processor= ', nb_per_proc, ' npband= ',nrank
2088 24 : call wrtout(std_out,msg)
2089 :
2090 24 : ABI_FREE(ranks)
2091 : end if
2092 :
2093 : end if
2094 :
2095 2347 : end subroutine initmpi_band
2096 : !!***
2097 :
2098 : !----------------------------------------------------------------------
2099 :
2100 : !!****f* m_mpinfo/pre_gather
2101 : !!
2102 : !! NAME
2103 : !! pre_gather
2104 : !!
2105 : !! FUNCTION
2106 : !! Gathers data from FFT processors.
2107 : !!
2108 : !! INPUTS
2109 : !! n1,n2,n3= FFT grid dimensions
2110 : !! n4= n3/mpi_enreg%nproc_fft
2111 : !! array= data to gather among procs
2112 : !!
2113 : !! OUTPUT
2114 : !! None
2115 : !!
2116 : !! SIDE EFFECTS
2117 : !! array_allgather= gathered data
2118 : !!
2119 : !! SOURCE
2120 :
2121 0 : subroutine pre_gather(array,array_allgather,n1,n2,n3,n4,mpi_enreg)
2122 :
2123 : !Arguments ------------------------------------
2124 : integer,intent(in) :: n1,n2,n3,n4
2125 : real(dp),intent(in) :: array(n1,n2,n4,1)
2126 : real(dp),intent(inout) :: array_allgather(n1,n2,n3,1)
2127 : class(mpi_type),intent(in) :: mpi_enreg
2128 :
2129 : !Local variables-------------------------------
2130 : integer :: ier
2131 : ! *********************************************************************
2132 :
2133 : !Gather the array on all procs
2134 0 : call xmpi_allgather(array,n1*n2*n3/mpi_enreg%nproc_fft,array_allgather,mpi_enreg%comm_fft,ier)
2135 :
2136 0 : end subroutine pre_gather
2137 : !!***
2138 :
2139 : !----------------------------------------------------------------------
2140 :
2141 : !!****f* m_mpinfo/pre_scatter
2142 : !!
2143 : !! NAME
2144 : !! pre_scatter
2145 : !!
2146 : !! FUNCTION
2147 : !! Scatters data among FFT processors.
2148 : !!
2149 : !! INPUTS
2150 : !! n1,n2,n3= FFT grid dimensions
2151 : !! n4= n3/mpi_enreg%nproc_fft
2152 : !! array_allgather= data to scatter among FFT procs
2153 : !!
2154 : !! OUTPUT
2155 : !! array= scattered data
2156 : !!
2157 : !! SOURCE
2158 :
2159 0 : subroutine pre_scatter(array,array_allgather,n1,n2,n3,n4,mpi_enreg)
2160 :
2161 : !Arguments ------------------------------------
2162 : integer,intent(in) :: n1,n2,n3,n4
2163 : real(dp),intent(out) :: array(n1,n2,n4,1)
2164 : real(dp),intent(in) :: array_allgather(n1,n2,n3,1)
2165 : class(mpi_type),intent(in) :: mpi_enreg
2166 : ! *********************************************************************
2167 :
2168 : !Perform the reverse operation
2169 : array(:,:,:,:) = &
2170 0 : & array_allgather(:,:,n3/mpi_enreg%nproc_fft*mpi_enreg%me_fft+1:n3/mpi_enreg%nproc_fft*(mpi_enreg%me_fft+1),:)
2171 :
2172 0 : end subroutine pre_scatter
2173 : !!***
2174 :
2175 : !!****f* m_mpinfo/iwrite_fftdatar
2176 : !! NAME
2177 : !! iwrite_fftdatar
2178 : !!
2179 : !! FUNCTION
2180 : !! This function selects the subset of processors that should write density/potential
2181 : !! Return True if the processors should do IO.
2182 : !!
2183 : !! INPUTS
2184 : !! mpi_enreg<MPI_type>=Datatype gathering information on the parallelism
2185 : !!
2186 : !! SOURCE
2187 :
2188 57413 : logical function iwrite_fftdatar(mpi_enreg) result(ans)
2189 :
2190 : !Arguments ------------------------------------
2191 : !scalars
2192 : class(MPI_type),intent(in) :: mpi_enreg
2193 : ! *********************************************************************
2194 :
2195 : ans = (xmpi_paral==0 .or. & ! No MPI
2196 : (mpi_enreg%paral_kgb==0 .and. mpi_enreg%me==0) .or. & ! paral_kgb=0 does not use MPI-FFT and cartesian communicators.
2197 : (mpi_enreg%paral_kgb==1 .and. mpi_enreg%me_band==0 .and. & ! select procs in one FFT communicator.
2198 : mpi_enreg%me_kpt==0 .and. mpi_enreg%me_spinor==0) .or. &
2199 : (mpi_enreg%paral_pert==1 .and. mpi_enreg%me_cell==0) & ! Group master in perturbation communicator.
2200 57413 : )
2201 :
2202 57413 : end function iwrite_fftdatar
2203 : !!***
2204 :
2205 : !----------------------------------------------------------------------
2206 :
2207 : !!****f* ABINIT/distrb2
2208 : !! NAME
2209 : !! distrb2
2210 : !!
2211 : !! FUNCTION
2212 : !! Creates the tabs of repartition of processors for sharing the jobs on k-points, spins and bands.
2213 : !!
2214 : !! INPUTS
2215 : !! mband = maximum number of bands
2216 : !! nband(nkpt*nsppol) = number of bands per k point, for each spin
2217 : !! nkpt = number of k-points
2218 : !! nproc= number of processors available for this distribution
2219 : !! nsppol = 1 for unpolarized, 2 for polarized
2220 : !!
2221 : !! SIDE EFFECTS
2222 : !! mpi_enreg%proc_distrb(nkpt,mband,nsppol)=number of the processor
2223 : !! that will treat each band in each k point.
2224 : !! mpi_enreg%nproc_spkpt is set
2225 : !!
2226 : !! NOTES
2227 : !! For the time being, the band parallelisation works only
2228 : !! when the number of bands is identical for spin up and spin down
2229 : !! at the same k point. The problem is the most clearly seen
2230 : !! in the kpgio routine, where a different parallel repartition
2231 : !! of k points for spin up and spin down would conflict with the
2232 : !! present computation of k+G sphere, independent of the spin.
2233 : !!
2234 : !! SOURCE
2235 :
2236 9443 : subroutine distrb2(mband,mband_mem_out,nband,nkpt,nproc,nsppol,mpi_enreg)
2237 :
2238 : !Arguments ------------------------------------
2239 : integer,intent(in) :: mband,nkpt,nproc,nsppol
2240 : integer,intent(in) :: nband(nkpt*nsppol)
2241 : integer,intent(out) :: mband_mem_out
2242 : class(MPI_type),intent(inout) :: mpi_enreg
2243 :
2244 : !Local variables-------------------------------
2245 : integer :: maxproc_bandpool
2246 : integer :: nproc_band
2247 : integer :: inb1,ind,ind0,nband_k,proc_max,proc_min
2248 : integer :: nband_k_sp2,minb_per_proc
2249 : integer :: iiband,iikpt,iisppol,ikpt_this_proc,nb_per_proc,nproc_spkpt,temp_unit
2250 9443 : integer :: kpt_distrb(nkpt)
2251 : logical,save :: first=.true.,has_file
2252 : character(len=500) :: msg
2253 : !******************************************************************
2254 :
2255 9443 : nproc_spkpt=mpi_enreg%nproc_spkpt
2256 9443 : if (mpi_enreg%paral_pert==1) nproc_spkpt=nproc
2257 : ! if (mpi_enreg%paral_pert==1) nproc_spkpt=nproc/mpi_enreg%nproc_pert
2258 :
2259 9443 : mband_mem_out = 0
2260 :
2261 : !Initialization of proc_distrb
2262 1946087 : mpi_enreg%proc_distrb = nproc+1
2263 20807 : do iisppol=1,nsppol
2264 290188 : do iikpt=1,nkpt
2265 2074382 : do iiband=1,nband(iikpt+(iisppol-1)*nkpt)
2266 2063018 : mpi_enreg%proc_distrb(iikpt,iiband,iisppol)=nproc_spkpt-1
2267 : end do
2268 : end do
2269 : end do
2270 : !That s all for an empty communication space
2271 9443 : if (nproc==0) return
2272 :
2273 : !Some checks
2274 : !if (mpi_enreg%paralbd==0 .and. any(dtset%optdriver == [RUNL_GSTATE, RUNL_RESPFN])) then
2275 9443 : if (mpi_enreg%paralbd==0) then
2276 : ! Check if nkpt and nproc_spkpt match
2277 6308 : if(nproc_spkpt>nkpt*nsppol) then
2278 : ! Too many proc. with respect to nkpt
2279 : write(msg,'(a,i0,a,i0,a,i0,4a)')&
2280 96 : 'nproc_spkpt= ',nproc_spkpt,' >= nkpt= ',nkpt,'* nsppol= ',nsppol,ch10,&
2281 96 : 'The number of processors is larger than nkpt*nsppol. This is a WASTE.',ch10,&
2282 192 : ' Ignore this warning if this is not a GS run'
2283 96 : ABI_WARNING(msg)
2284 6212 : else if (mod(nkpt*nsppol,nproc_spkpt) /= 0) then
2285 : ! nkpt not a multiple of nproc_spkpt
2286 : write(msg,'(a,i0,a,i0,5a)')&
2287 114 : 'nkpt*nsppol (', nkpt*nsppol, ') is not a multiple of nproc_spkpt (',nproc_spkpt, ')', ch10,&
2288 114 : 'The k-point parallelisation is INEFFICIENT. ',ch10,&
2289 228 : 'Ignore this warning if this is not a GS run.'
2290 114 : ABI_WARNING(msg)
2291 : end if
2292 : end if
2293 :
2294 : !Inquire whether there exist a file containing the processor distribution
2295 9443 : if (first) then
2296 : ! Case first time: test file to do
2297 : ! Open the file containing the k-point distribution
2298 1431 : first=.false.; has_file = file_exists("kpt_distrb")
2299 : end if
2300 :
2301 : !---------------------------------------------------------------------------
2302 : !Initialize the processor distribution, either from a file, or from an algorithm
2303 9443 : if (has_file) then
2304 0 : if (open_file('kpt_distrb',msg,newunit=temp_unit,form='formatted',status='old') /= 0) then
2305 0 : ABI_ERROR(msg)
2306 : end if
2307 0 : rewind(unit=temp_unit)
2308 0 : if (mpi_enreg%paralbd == 1) then
2309 : ! -> read bands distribution
2310 0 : read(temp_unit,*) mpi_enreg%proc_distrb
2311 : else
2312 0 : read(temp_unit,*) kpt_distrb
2313 : end if
2314 0 : close(temp_unit)
2315 0 : proc_max=0
2316 0 : proc_min=nproc_spkpt
2317 : ! -> determine the range of proc. requested
2318 0 : if (mpi_enreg%paralbd == 1) then
2319 0 : do iisppol=1,nsppol
2320 0 : do iikpt=1,nkpt
2321 0 : nband_k = nband(iikpt+(iisppol-1)*nkpt)
2322 0 : proc_max=maxval(mpi_enreg%proc_distrb(iikpt,1:nband_k,iisppol))
2323 0 : proc_min=minval(mpi_enreg%proc_distrb(iikpt,1:nband_k,iisppol))
2324 : end do
2325 : end do
2326 : else
2327 0 : proc_max=maxval(kpt_distrb(1:nkpt))
2328 0 : proc_min=minval(kpt_distrb(1:nkpt))
2329 : ! -> fill the tab proc_distrb with kpt_distrb
2330 0 : do iisppol=1,nsppol
2331 0 : do iikpt=1,nkpt
2332 0 : nband_k = nband(iikpt+(iisppol-1)*nkpt)
2333 0 : do iiband=1,nband_k
2334 0 : mpi_enreg%proc_distrb(iikpt,iiband,iisppol)=kpt_distrb(iikpt)
2335 : end do
2336 : end do
2337 : end do
2338 : end if ! mpi_enreg%paralbd
2339 :
2340 0 : if(proc_max>(nproc_spkpt-1)) then
2341 : ! Too much proc. requested
2342 : write(msg, '(a,a,a,i0,a,a,a)' )&
2343 0 : 'The number of processors mentioned in the kpt_distrb file',ch10,&
2344 0 : 'must be lower or equal to the actual number of processors =',nproc_spkpt-1,ch10,&
2345 0 : 'Action: change the kpt_distrb file, or increase the',' number of processors.'
2346 0 : ABI_ERROR(msg)
2347 : end if
2348 :
2349 0 : if(proc_max/=(nproc_spkpt-1)) then
2350 : ! Too few proc. used
2351 : write(msg, '(a,i0,a,a,a,i0,a,a,a)' )&
2352 0 : 'Only ',proc_max+1,' processors are used (from kpt_distrb file),',ch10,&
2353 0 : 'when',nproc_spkpt,' processors are available.',ch10,&
2354 0 : 'Action: adjust number of processors and kpt_distrb file.'
2355 0 : ABI_ERROR(msg)
2356 : end if
2357 :
2358 0 : if(proc_min<0) then
2359 : write(msg, '(a,a,a)' )&
2360 0 : 'The number of processors must be bigger than 0 in kpt_distrb file.',ch10,&
2361 0 : 'Action: modify kpt_distrb file.'
2362 0 : ABI_ERROR(msg)
2363 : end if
2364 :
2365 : !---------------------------------------------------------------------------
2366 : else
2367 : ! 'kpt_distrb' file does not exist
2368 :
2369 9443 : if (mpi_enreg%paralbd==1) then
2370 :
2371 : ! No possible band parallelization
2372 3135 : if (nproc<(nkpt*nsppol)) then
2373 :
2374 : ! Does not allow a processor to treat different spins
2375 : ! NB: for odd nproc this will happen anyway for the middle proc - will this not unbalance things?
2376 2971 : ind0=0
2377 2971 : inb1=(nkpt*nsppol)/nproc
2378 : if (mod((nkpt*nsppol),nproc)/=0) inb1=inb1+1
2379 208453 : do iikpt=1,nkpt
2380 205482 : nband_k=nband(iikpt)
2381 205482 : nband_k_sp2=nband(iikpt+nkpt*(nsppol-1))
2382 : !ind=ind0/inb1
2383 205482 : ind=mod(ind0,nproc)
2384 1374451 : do iiband=1,nband_k
2385 1168969 : mpi_enreg%proc_distrb(iikpt,iiband,1)=ind
2386 1374451 : if (nsppol==2 .and. iiband <= nband_k_sp2) then
2387 30837 : mpi_enreg%proc_distrb(iikpt,iiband,2)=ind
2388 : end if
2389 : !if (nsppol==2) mpi_enreg%proc_distrb(iikpt,iiband,2)=nproc-ind-1
2390 : end do
2391 208453 : ind0=ind0+1
2392 : end do
2393 :
2394 : ! MT130831 : OLD CODING
2395 : ! do iisppol=1,nsppol;do iikpt=1,nkpt
2396 : ! ind=(iikpt+(iisppol-1)*nkpt-1)/inb1
2397 : ! nband_k=nband(iikpt+(iisppol-1)*nkpt)
2398 : ! do iiband=1,nband_k
2399 : ! mpi_enreg%proc_distrb(iikpt,iiband,iisppol)=ind
2400 : ! end do;end do;end do
2401 : ! MT130831 : END OF OLD CODING
2402 :
2403 : ! Possible band parallelization
2404 : else
2405 : ! Does not allow a processor to treat different spins
2406 164 : ind0=0
2407 164 : maxproc_bandpool=floor(nproc*one/(nkpt*nsppol))
2408 364 : do iikpt=1,nkpt
2409 200 : nband_k=nband(iikpt)
2410 200 : nband_k_sp2=nband(iikpt+nkpt*(nsppol-1))
2411 200 : minb_per_proc=floor(nband_k*one/maxproc_bandpool)
2412 200 : if (mod(nband_k,maxproc_bandpool)/=0) minb_per_proc=minb_per_proc+1
2413 200 : do nb_per_proc = minb_per_proc, nband_k
2414 200 : if (mod(nband_k,nb_per_proc)==0) exit
2415 : end do
2416 200 : nproc_band = nband_k / nb_per_proc
2417 :
2418 200 : mband_mem_out = max(mband_mem_out,nb_per_proc)
2419 3107 : do iiband=1,nband_k
2420 2907 : ind=mod((iiband-1)/nb_per_proc+ind0, nproc)
2421 : !ind = mod( mod((iiband-1),nproc_band) + ind0, nproc )
2422 2907 : mpi_enreg%proc_distrb(iikpt,iiband,1)=ind
2423 : !TODO : could end up with 0 bands on certain procs with this configuration and nband(k) /= constant
2424 3107 : if (nsppol==2 .and. iiband <= nband_k_sp2) then
2425 0 : mpi_enreg%proc_distrb(iikpt,iiband,2)=ind+nkpt*nproc_band
2426 : end if
2427 : !if (nsppol==2) mpi_enreg%proc_distrb(iikpt,iiband,2)=nproc-ind-1
2428 : end do
2429 364 : ind0=ind+1 ! take last proc associated to the bands at iikpt, and increment
2430 : !ind0 = ind0 + nproc_band
2431 : end do
2432 :
2433 : ! MT130831 : OLD CODING
2434 : ! ind0=0;maxproc_bandpool=nproc/(nkpt*nsppol)
2435 : ! do iisppol=1,nsppol;do iikpt=1,nkpt
2436 : ! nband_k=nband(iikpt+(iisppol-1)*nkpt)
2437 : ! nb_per_proc=nband_k/maxproc_bandpool;if (mod(nband_k,maxproc_bandpool)/=0) nb_per_proc=nb_per_proc+1
2438 : ! do iiband=1,nband_k
2439 : ! ind=(iiband-1)/nb_per_proc+ind0
2440 : ! mpi_enreg%proc_distrb(iikpt,iiband,iisppol)=ind
2441 : ! end do
2442 : ! ind0=ind+1
2443 : ! end do;end do
2444 : ! MT130831 : END OF OLD CODING
2445 :
2446 : end if
2447 :
2448 : ! XG060807 : OLD CODING
2449 : ! ind=0
2450 : ! do iisppol=1,nsppol;do iikpt=1,nkpt
2451 : ! nband_k=nband(iikpt+(iisppol-1)*nkpt)
2452 : ! do iiband=1,nband_k
2453 : ! mpi_enreg%proc_distrb(iikpt,iiband,iisppol)=ind/nb_per_proc
2454 : ! ind=ind+1
2455 : ! end do;end do;end do
2456 : ! XG060807 : END OF OLD CODING
2457 :
2458 6308 : elseif (mpi_enreg%paralbd==0) then
2459 :
2460 : ! Does not allow a processor to treat different spins
2461 6308 : ind0=0
2462 6308 : nb_per_proc=(nsppol*nkpt)/nproc_spkpt
2463 6308 : if (mod((nsppol*nkpt),nproc_spkpt)/=0) nb_per_proc=nb_per_proc+1
2464 64147 : do iikpt=1,nkpt
2465 57839 : nband_k=nband(iikpt)
2466 57839 : ind=ind0/nb_per_proc
2467 600373 : do iiband=1,nband_k
2468 542534 : mpi_enreg%proc_distrb(iikpt,iiband,1)=ind
2469 600373 : if (nsppol==2) then
2470 : !TODO: why are these bands ordered in the opposite direction wrt spin 1??
2471 48467 : mpi_enreg%proc_distrb(iikpt,iiband,2)=nproc_spkpt-ind-1
2472 : end if
2473 : end do
2474 64147 : ind0=ind0+1
2475 : end do
2476 :
2477 : ! XG060807 : OLD CODING
2478 : ! ind=0
2479 : ! do iisppol=1,nsppol;do iikpt=1,nkpt
2480 : ! nband_k = nband(iikpt+(iisppol-1)*nkpt)
2481 : ! do iiband=1,nband_k
2482 : ! Distribute k-points homogeneously
2483 : ! proc_distrb(iikpt,iiband,iisppol)=mod(iikpt-1,nproc_spkpt)
2484 : ! mpi_enreg%proc_distrb(iikpt,iiband,iisppol)=ind/nb_per_proc
2485 : ! end do
2486 : ! ind=ind + 1
2487 : ! end do;end do
2488 : ! XG060807 : END OF OLD CODING
2489 :
2490 : end if ! mpi_enreg%paralbd
2491 :
2492 : end if ! has_file
2493 :
2494 : ! local indices on cpus, for each sppol kpt band
2495 272964 : mpi_enreg%my_kpttab(:)=0
2496 28329 : mpi_enreg%my_isppoltab(:)=0
2497 20807 : do iisppol=1,nsppol
2498 11364 : ikpt_this_proc=0
2499 290188 : do iikpt=1,nkpt
2500 269381 : nband_k=nband(iikpt+(iisppol-1)*nkpt)
2501 269381 : if(proc_distrb_cycle(mpi_enreg%proc_distrb,iikpt,1,nband_k,iisppol,mpi_enreg%me_kpt)) cycle
2502 224833 : ikpt_this_proc=ikpt_this_proc+1
2503 224833 : mpi_enreg%my_kpttab(iikpt)=ikpt_this_proc
2504 280745 : mpi_enreg%my_isppoltab(iisppol)=1
2505 : end do
2506 : end do
2507 :
2508 9443 : if (mband_mem_out == 0) mband_mem_out = mband
2509 :
2510 : end subroutine distrb2
2511 : !!***
2512 :
2513 : !!****f* ABINIT/distrb2_hf
2514 : !! NAME
2515 : !! distrb2_hf
2516 : !!
2517 : !! FUNCTION
2518 : !! Create the tabs of repartition of processors for sharing the jobs
2519 : !! on occupied states (labeled by k-points, bands and spin indices) for Hartree-Fock calculation.
2520 : !!
2521 : !! INPUTS
2522 : !! nbandhf = maximum number of occupied bands
2523 : !! nkpthf = number of k-points in full BZ
2524 : !! nproc= number of processors available for this distribution
2525 : !! nsppol = 1 for unpolarized, 2 for polarized
2526 : !!
2527 : !! SIDE EFFECTS
2528 : !! mpi_enreg%proc_distrb(nkpthf,nbandhf,nsppol)=number of the processor
2529 : !! that will treat each band in each k point.
2530 : !! mpi_enreg%nproc_spkpt is set
2531 : !!
2532 : !! NOTES
2533 : !! For the time being, the band parallelisation works only
2534 : !! when the number of bands is identical for spin up and spin down
2535 : !! at the same k point. The problem is the most clearly seen
2536 : !! in the kpgio routine, where a different parallel repartition
2537 : !! of k points for spin up and spin down would conflict with the
2538 : !! present computation of k+G sphere, independent of the spin.
2539 : !!
2540 : !! SOURCE
2541 :
2542 146 : subroutine distrb2_hf(nbandhf,nkpthf, nproc, nsppol, mpi_enreg)
2543 :
2544 : !Arguments ------------------------------------
2545 : integer,intent(in) :: nbandhf,nkpthf,nproc,nsppol
2546 : class(MPI_type),intent(inout) :: mpi_enreg
2547 :
2548 : !Local variables-------------------------------
2549 : integer :: ind,iiband,iikpt,iistep,nproc_hf
2550 : character(len=500) :: msg
2551 : !******************************************************************
2552 :
2553 146 : nproc_hf=mpi_enreg%nproc_hf
2554 :
2555 : !* Initialize distrb_hf (the array exists necessarily)
2556 807 : do iiband=1,nbandhf
2557 12530 : do iikpt=1,nkpthf
2558 12384 : mpi_enreg%distrb_hf(iikpt,iiband,1)=nproc_hf-1
2559 : end do
2560 : end do
2561 :
2562 : !* End of the routine for an empty communication space
2563 146 : if (nproc==0) return
2564 :
2565 : !*** Testing section ***
2566 :
2567 146 : if (nsppol==2) then
2568 : !* Check that the distribution over (spin,k point) allow to consider spin up and spin dn independently.
2569 7 : if (mpi_enreg%nproc_spkpt/=1.and.mod(mpi_enreg%nproc_spkpt,2)/=0) then
2570 0 : ABI_ERROR( 'The variable nproc_spkpt is not even but nsppol= 2')
2571 : !* In this case, one processor will carry both spin. (this will create pbms for the calculation)
2572 : end if
2573 : !* Check that the number of band is the same for each spin, at each k-point. (It should be)
2574 : !* do iikpt=1,nkpthf
2575 : !* if (nband(iikpt)/=nband(iikpt+nkpthf)) then
2576 : !* msg = ' WARNING - the number of bands is different for spin up or spin down. '
2577 : !* ABI_ERROR(msg)
2578 : !* end if
2579 : !* end do
2580 : !* If one of this test is not good for one proc then other procs fall in deadlock, according to distrb2.
2581 : !* What does it mean ???
2582 : end if
2583 :
2584 :
2585 : !* Check if nkpthf and nproc_hf match
2586 146 : if (nproc_hf>nkpthf*nbandhf) then
2587 : !* There are too many processors with respect to nkpthf*nbandhf
2588 0 : write(msg, '(a,a,i4,a,i4,a,i4,a,a)' ) ch10,&
2589 0 : & 'nproc_hf=',nproc_hf,' >= nkpthf=',nkpthf,'* nbandhf=',nbandhf,ch10,&
2590 0 : & 'The number of processors is larger than nkpthf*nbandhf. This is a waste.'
2591 0 : ABI_WARNING(msg)
2592 :
2593 146 : else if(mod(nkpthf*nbandhf,nproc_hf)/=0) then
2594 : !* nkpthf*nbandhf is not a multiple of nproc_hf
2595 0 : write(msg, '(2a,i5,a,i5,3a)' ) ch10,&
2596 0 : & 'nkpthf*nbandhf (', nkpthf*nbandhf, ') is not a multiple of nproc_hf (',nproc_hf, ')', ch10,&
2597 0 : & 'The parallelisation may not be efficient.'
2598 0 : ABI_WARNING(msg)
2599 : end if
2600 :
2601 : !*** End of testing section ***
2602 :
2603 : !*** Initialize the processor distribution from a simple algorithm ***
2604 :
2605 146 : if (nproc_hf<nkpthf) then
2606 : !* In this case, a parallelization over kpts only.
2607 123 : iistep=nkpthf/nproc_hf
2608 123 : if (mod(nkpthf,nproc_hf) /=0) iistep=iistep+1
2609 123 : ind=0
2610 2858 : do iikpt=1,nkpthf
2611 : !*** Only the first "nbandhf" bands are considered (they are assumed to be the only occupied ones)
2612 14337 : do iiband=1,nbandhf
2613 14337 : mpi_enreg%distrb_hf(iikpt,iiband,1)=ind/iistep
2614 : end do
2615 2858 : ind=ind+1
2616 : end do
2617 :
2618 : else
2619 : !* In this case, a parallelization over all the occupied states is possible.
2620 23 : if (nproc_hf < nbandhf*nkpthf) then
2621 20 : iistep=(nbandhf*nkpthf)/nproc_hf;
2622 20 : if (mod((nbandhf*nkpthf),nproc_hf) /=0) iistep=iistep+1
2623 : else
2624 : iistep=1
2625 : end if
2626 23 : ind=0
2627 46 : do iikpt=1,nkpthf
2628 : !*** Only the first "nbandhf" bands are considered (they are assumed to be the only occupied ones)
2629 167 : do iiband=1,nbandhf
2630 121 : mpi_enreg%distrb_hf(iikpt,iiband,1)=ind/iistep
2631 144 : ind=ind+1
2632 : end do
2633 : end do
2634 : end if
2635 :
2636 : !*** Initialization of processor distribution from a file (simple copy from distrb2, not yet implemented) ***
2637 :
2638 : ! !* Inquire whether there exist a file containing the processor distribution
2639 : ! if (first) then
2640 : ! ! Case first time : test file to do
2641 : ! ! Open the file containing the (k-points,bands) distribution
2642 : ! open(unit=temp_unit,file='kpt_distrb_hf',form='formatted',status='old',iostat=ios)
2643 : ! if(ios==0) then
2644 : ! ! 'kpt_distrb_hf' file exists
2645 : ! file_exist=1
2646 : ! close(temp_unit)
2647 : ! else
2648 : ! file_exist=0
2649 : ! end if
2650 : ! first=.false.
2651 : ! end if
2652 : !
2653 : ! !* Initialize the processor distribution, either from a file, or from an algorithm
2654 : ! if (file_exist == 1) then
2655 : ! !* Read (k-points,bands) distribution out of the file
2656 : ! open(unit=temp_unit,file='kpt_distrb_hf',form='formatted',status='old',iostat=ios)
2657 : ! rewind(unit=temp_unit)
2658 : ! read(temp_unit,*) mpi_enreg%distrb_hf
2659 : ! close(temp_unit)
2660 : ! !* Determine the range of processors requested
2661 : ! proc_max=0
2662 : ! proc_min=nproc_hf
2663 : ! do iikpt=1,nkpthf
2664 : ! mband_occ_k = mband_occ(iikpt+(iisppol-1)*nkpthf)
2665 : ! proc_max=maxval(mpi_enreg%distrb_hf(iikpt,1:mband_occ_k,1))
2666 : ! proc_min=minval(mpi_enreg%distrb_hf(iikpt,1:mband_occ_k,1))
2667 : ! end do
2668 : !
2669 : ! if(proc_max>(nproc_hf-1)) then
2670 : ! !* Too much proc. requested
2671 : ! write(msg, '(a,a,a,i4,a,a,a)' )&
2672 : ! & ' The number of processors mentioned in the kpt_distrb file',ch10,&
2673 : ! & ' must be lower or equal to the actual number of processors =',&
2674 : ! & nproc_hf-1,ch10,&
2675 : ! & ' Action: change the kpt_distrb file, or increase the',&
2676 : ! & ' number of processors.'
2677 : ! ABI_ERROR(msg)
2678 : ! end if
2679 : !
2680 : ! if(proc_max/=(nproc_hf-1)) then
2681 : ! !* Too few proc. used
2682 : ! write(msg, '(a,i4,a,a,a,i4,a,a,a)' )&
2683 : ! & ' Only ',proc_max+1,' processors are used (from kpt_distrb file),',ch10,&
2684 : ! & ' when',nproc_hf,' processors are available.',ch10,&
2685 : ! & ' Action: adjust number of processors and kpt_distrb file.'
2686 : ! ABI_ERROR(msg)
2687 : ! end if
2688 : !
2689 : ! if(proc_min<0) then
2690 : ! write(msg, '(a,a,a)' )&
2691 : ! & ' The number of processors must be bigger than 0 in kpt_distrb file.',ch10,&
2692 : ! & ' Action: modify kpt_distrb file.'
2693 : ! ABI_ERROR(msg)
2694 : ! end if
2695 : ! else
2696 : ! !* The file does not exist...
2697 : ! end if ! file_exist
2698 :
2699 : !DEBUG
2700 : !write(std_out,*)' distrb2_hf: exit '
2701 : !ENDDEBUG
2702 :
2703 : end subroutine distrb2_hf
2704 : !!***
2705 :
2706 : end module m_mpinfo
2707 : !!***
|
