Line data Source code
1 : !!****m* ABINIT/m_bandfft_kpt
2 : !! NAME
3 : !! m_bandfft_kpt
4 : !!
5 : !! FUNCTION
6 : !! This module provides the definition of the bandfft_kpt_type
7 : !! used for kgb parallelization.
8 : !!
9 : !! COPYRIGHT
10 : !! Copyright (C) 2011-2026 ABINIT group (FJ, FB, MT)
11 : !! This file is distributed under the terms of the
12 : !! GNU General Public License, see ~abinit/COPYING
13 : !! or http://www.gnu.org/copyleft/gpl.txt .
14 : !!
15 : !! SOURCE
16 :
17 : #if defined HAVE_CONFIG_H
18 : #include "config.h"
19 : #endif
20 :
21 : #include "abi_common.h"
22 :
23 : MODULE m_bandfft_kpt
24 :
25 : use, intrinsic :: iso_c_binding, only : c_int32_t, c_double
26 :
27 : use defs_basis
28 : use m_abicore
29 : use m_errors
30 : use m_xmpi
31 :
32 : use defs_abitypes, only : MPI_type
33 : use m_time, only : timab
34 : use m_kg, only : mkkpg
35 : use m_fftcore, only : sphereboundary
36 : use m_mpinfo, only : proc_distrb_cycle
37 : use m_hamiltonian, only : gs_hamiltonian_type
38 :
39 : #if defined HAVE_YAKL
40 : use gator_mod
41 : #endif
42 :
43 : implicit none
44 :
45 : private
46 : public :: bandfft_kpt_init1
47 : public :: bandfft_kpt_init2
48 : public :: bandfft_kpt_reset
49 : public :: bandfft_kpt_destroy
50 : public :: bandfft_kpt_destroy_array
51 : public :: bandfft_kpt_copy
52 : public :: bandfft_kpt_mpi_send
53 : public :: bandfft_kpt_mpi_recv
54 : public :: bandfft_kpt_savetabs
55 : public :: bandfft_kpt_restoretabs
56 : public :: bandfft_kpt_set_ikpt
57 : public :: bandfft_kpt_get_ikpt
58 : public :: prep_bandfft_tabs
59 : !!***
60 :
61 : !!****t* m_bandfft_kpt/bandfft_kpt_type
62 : !! NAME
63 : !! bandfft_kpt_type
64 : !!
65 : !! FUNCTION
66 : !! The bandfft_kpt_type structured datatype gather different information
67 : !! about the triple band-fft-kpt parallelisation:
68 : !! tabs which are distributed over all the three dimensions and stored during
69 : !! the calculation, dimensions of messages exchange during the calculations...
70 : !! i.e.: all the information which were spread over the entire code before and
71 : !! recomputed at each iline, istep or itime STEP with a large probability to
72 : !! make a mistake.
73 : !!
74 : !! SOURCE
75 :
76 : type, public :: bandfft_kpt_type
77 :
78 : ! WARNING : if you modify this datatype, please check whether there might be creation/destruction/copy routines,
79 : ! declared in another part of ABINIT, that might need to take into account your modification.
80 :
81 : integer :: flag1_is_allocated ! determine if the following data are allocated or not
82 : integer :: npw_tot ! array holding the total number of plane waves for each k point
83 : integer :: ndatarecv ! total number of values received by the processor and sent
84 : ! by the other processors band
85 :
86 : #if defined HAVE_GPU && defined HAVE_YAKL
87 : integer(c_int32_t), contiguous, pointer :: kg_k_gather(:,:) => null()
88 : #else
89 : integer, allocatable :: kg_k_gather(:,:) ! planewave coordinates
90 : ! (of the processor + sent by other processors band)
91 : #endif
92 :
93 : integer, allocatable :: recvcounts(:) ! number of values received by the processor from each processor band
94 : integer, allocatable :: sendcounts(:) ! number of values sent by the processor to each processor band
95 : integer, allocatable :: rdispls (:) ! positions of values received by the processor from each processor band
96 : integer, allocatable :: sdispls (:) ! postions of values sent by the processor to each processor band
97 : integer, allocatable :: gbound(:,:) ! sphere boundary info: gbound(2*mgfft+8,2)
98 :
99 : integer :: flag2_is_allocated ! determine if the following data are allocated or not
100 : real(dp), allocatable :: ffnl_gather(:,:,:,:) ! ffnl tab (of the processor + sent by other processors band)
101 :
102 : #if defined HAVE_GPU && defined HAVE_YAKL
103 : real(c_double), contiguous, pointer :: kinpw_gather(:) => null() ! kinpw tab (of the processor + sent by other processors band)
104 : #else
105 : real(dp), allocatable :: kinpw_gather(:) ! kinpw tab (of the processor + sent by other processors band)
106 : #endif
107 :
108 : real(dp), allocatable :: ph3d_gather(:,:,:) ! ph3d tab (of the processor + sent by other processors band)
109 : real(dp), allocatable :: kpg_k_gather(:,:) ! kpg_k tab (of the processor + sent by other processors band)
110 :
111 :
112 : integer :: flag3_is_allocated ! determine if the following data are allocated or not
113 : integer :: istwf_k ! input option parameter that describes the storage of wfs
114 : integer :: idatarecv0 ! position of the planewave coordinates (0,0,0)
115 : integer :: ndatarecv_tot ! total number of received values by the processor
116 : ! (ndatarecv + number of received opposited planewave coordinates)
117 : integer :: ndatasend_sym ! number of sent values to the processors fft to create opposited
118 : ! planewave coordinates
119 : integer, allocatable :: kg_k_gather_sym(:,:) ! planewave coordinates
120 : ! (kg_k_gather + opposited planewave coordinates sent by the processors fft)
121 : integer, allocatable :: rdispls_sym(:) ! positions of values received by the processor from each processor fft
122 : integer, allocatable :: recvcounts_sym(:) ! number of values received by the processor from each processor fft
123 : integer, allocatable :: recvcounts_sym_tot(:) ! number of values received by each processor from the other processors fft
124 : integer, allocatable :: sdispls_sym(:) ! postions of values sent by the processor to each processor fft
125 : integer, allocatable :: sendcounts_sym(:) ! number of values sent by the processor to each processor fft
126 : integer, allocatable :: sendcounts_sym_all(:) ! number of values sent by each processor to the other processors fft
127 : integer, allocatable :: tab_proc(:) ! positions of opposited planewave coordinates in the list of the processors fft
128 :
129 : logical :: have_to_reequilibrate ! indicates weather we will have to reequilibrate and allocate all these stuff
130 : integer :: npw_fft ! Number of plane waves during fft step
131 : integer, allocatable :: indices_pw_fft(:) ! Indices for sorting pw like pw
132 : integer, allocatable :: sendcount_fft (:) ! Number of pw to send to others proc fft
133 : integer, allocatable :: senddisp_fft(:) ! Positions for sending
134 : integer, allocatable :: recvcount_fft(:) ! Number of pw to receive from others proc fft
135 : integer, allocatable :: recvdisp_fft(:) ! Positions for receiving
136 : integer, allocatable :: kg_k_fft(:,:) ! planewaves coordinates
137 : integer :: gpu_option ! if this structure will be used with GPU
138 :
139 : end type bandfft_kpt_type
140 : !!***
141 :
142 : type(bandfft_kpt_type),save,public,pointer :: bandfft_kpt(:) => null()
143 : ! Contains all the information related to the band/FFT parallelism
144 : ! which depends on kpt exists only if mpi_enreg%paral_kgb==1
145 :
146 : integer,save,private :: bandfft_kpt_current_ikpt=-1
147 : ! Index of current k point processed by current proc,
148 : ! i.e. current index of bandfft_kpt loaded in memory
149 : ! => bandfft_kpt_current_ikpt=my_kpttab(ikpt)
150 : ! Please, use bandfft_kpt_set_ikpt method to change the value
151 : ! and bandfft_kpt_get_ikpt to get it.
152 :
153 : CONTAINS
154 :
155 : !===========================================================
156 : !!***
157 :
158 : !!****f* m_bandfft_kpt/bandfft_kpt_init1
159 : !! NAME
160 : !! bandfft_kpt_init1
161 : !!
162 : !! FUNCTION
163 : !! Init all (or part of) scalars and pointers in a bandfft_kpt datastructure
164 : !!
165 : !! INPUTS
166 : !! istwfk(nkpt) = input option parameter that describes the storage of wfs
167 : !! kg(3,mpw*mkmem) = dimensionless coords of G vecs in basis sphere at k point
168 : !! mgfft = maximum single fft dimension (IN)
169 : !! mkmem = number of k points which can fit in memory; set to 0 if use disk
170 : !! mpi_enreg = information about MPI parallelization
171 : !! mpw = maximum number of planewaves as dimensioned in calling routine
172 : !! nband(nkpt*nsppol) = number of bands at each k point
173 : !! nkpt = number of k points
174 : !! npwarr(nkpt) = array holding npw for each k point, taking into account
175 : !! the effect of istwfk, and the spreading over processors
176 : !! nsppol = 1 for unpolarized, 2 for polarized
177 : !!
178 : !! OUTPUT
179 : !!
180 : !!---------------------------------------------------------------------
181 : !! within the bandfft_kpt data_type : Initialize and compute
182 : !!---------------------------------------------------------------------
183 : !! gbound = sphere boundary info
184 : !! idatarecv0 = position of the planewave coordinates (0,0,0)
185 : !! istwf_k = input option parameter that describes the storage of wfs
186 : !! kg_k_gather = planewave coordinates
187 : !! (of the processor + sended by other processors band)
188 : !! kg_k_gather_sym = planewave coordinates
189 : !! (kg_k_gather + opposited planewave coordinates sended by the processors fft)
190 : !! ndatarecv = total number of values received by the processor and sended
191 : !! by the other processors band
192 : !! ndatasend_sym = number of sended values to the processors fft to create opposited
193 : !! planewave coordinates
194 : !! ndatarecv_tot = total number of received values by the processor
195 : !! (ndatarecv + number of received opposited planewave coordinates)
196 : !! recvcounts = number of values received by the processor from each processor band
197 : !! recvcounts_sym = number of values received by the processor from each processor fft
198 : !! recvcounts_sym_tot = number of values received by each processor from the other processors fft
199 : !! rdispls = positions of values received by the processor from each processor band
200 : !! rdispls_sym = positions of values received by the processor from each processor fft
201 : !! sendcounts = number of values sended by the processor to each processor band
202 : !! sendcounts_sym = number of values sended by the processor to each processor fft
203 : !! sendcounts_sym_all = number of values sended by each processor to the other processors fft
204 : !! sdispls = postions of values sended by the processor to each processor band
205 : !! sdispls_sym = postions of values sended by the processor to each processor fft
206 : !! tab_proc = positions of opposited planewave coordinates in the list of the
207 : !! processors fft
208 : !! SIDE EFFECTS
209 : !! bandfft_kpt_in=<type(bandfft_kpt)>=bandfft_kpt datastructure
210 : !!
211 : !! SOURCE
212 :
213 5669 : subroutine bandfft_kpt_init1(bandfft_kpt_in,istwfk,kg,mgfft,mkmem,mpi_enreg,mpw,nband,nkpt,npwarr,nsppol,gpu_option)
214 :
215 : !Arguments ------------------------------------
216 : !scalars
217 : integer,intent(in) :: mgfft,mkmem,mpw,nkpt,nsppol
218 : type(bandfft_kpt_type),pointer :: bandfft_kpt_in(:)
219 : type(MPI_type),intent(inout) :: mpi_enreg
220 : integer,intent(in),optional :: gpu_option
221 : !arrays
222 : integer,intent(in) :: istwfk(nkpt),nband(nkpt*nsppol)
223 : integer,intent(in) :: kg(3,mpw*mkmem),npwarr(nkpt)
224 :
225 : !Local variables-------------------------------
226 : !scalars
227 : integer :: comm_band,comm_fft,idatarecv,idatarecv0,ierr,ikg,ikpt,ikpt_this_proc,iproc,isppol,istwf_k,itest,jsendloc
228 : integer :: me_fft,me_kpt,n2,nband_k,ndatarecv,ndatarecv_tot,ndatasend_sym,nproc_band,nproc_fft,npw_fft,npw_k,npw_tot
229 : logical :: reequilibrate_allocated
230 : character(len=500) :: message
231 : !arrays
232 5669 : integer,allocatable :: buff_kg(:,:),gbound(:,:),indices_pw_fft(:),kg_k(:,:),kg_k_fft(:,:),kg_k_gather(:,:)
233 5669 : integer,allocatable :: kg_k_gather_all(:,:),kg_k_gather_send(:,:),kg_k_gather_sym(:,:)
234 5669 : integer,allocatable :: npw_per_proc(:)
235 5669 : integer,allocatable :: rdispls(:),rdispls_all(:),rdispls_sym(:),rdispls_sym_loc(:)
236 5669 : integer,allocatable :: recvcounts(:),recvcounts_sym(:),recvcounts_fft(:),recvcounts_sym_loc(:),recvcounts_sym_tot(:)
237 5669 : integer,allocatable :: recvdisp_fft(:),sdispls(:),sdispls_sym_loc(:),sdispls_sym(:)
238 5669 : integer,allocatable :: sendcounts(:),sendcounts_fft(:),sendcounts_sym(:),sendcounts_sym_all(:),sendcounts_sym_loc(:)
239 5669 : integer,allocatable :: senddisp_fft(:),sum_kg(:),tab_proc(:)
240 :
241 : ! *********************************************************************
242 :
243 5669 : If(mpi_enreg%paral_kgb/=1) then
244 5038 : nullify(bandfft_kpt_in)
245 5038 : return
246 : end if
247 :
248 : !---------------------------------------------
249 : !Initialisation
250 : !---------------------------------------------
251 631 : nproc_fft = mpi_enreg%nproc_fft
252 631 : nproc_band = mpi_enreg%nproc_band
253 :
254 631 : me_fft = mpi_enreg%me_fft
255 631 : me_kpt = mpi_enreg%me_kpt
256 :
257 631 : comm_band = mpi_enreg%comm_band
258 631 : comm_fft = mpi_enreg%comm_fft
259 :
260 : !=============================================================================
261 : !Compute and store various tabs in bandfft_kpt(ikpt) data_struc
262 : !These ones will be used in following subroutines:
263 : !vtorho, mkrho, prep_nonlop, prep_fourwf, prep_getghc...
264 : !=============================================================================
265 :
266 4896 : ABI_MALLOC(bandfft_kpt_in,(mkmem))
267 :
268 1893 : ABI_MALLOC(sdispls ,(nproc_band))
269 1262 : ABI_MALLOC(sendcounts ,(nproc_band))
270 1262 : ABI_MALLOC(rdispls ,(nproc_band))
271 1262 : ABI_MALLOC(recvcounts ,(nproc_band))
272 1893 : ABI_MALLOC(sendcounts_fft,(nproc_fft))
273 1262 : ABI_MALLOC(senddisp_fft ,(nproc_fft))
274 1262 : ABI_MALLOC(recvcounts_fft,(nproc_fft))
275 1262 : ABI_MALLOC(recvdisp_fft ,(nproc_fft))
276 :
277 3634 : bandfft_kpt_in(:)%flag1_is_allocated=0
278 3634 : bandfft_kpt_in(:)%flag2_is_allocated=0
279 3634 : bandfft_kpt_in(:)%flag3_is_allocated=0
280 3634 : bandfft_kpt_in(:)%gpu_option=ABI_GPU_DISABLED
281 3490 : if(present(gpu_option)) bandfft_kpt_in(:)%gpu_option=gpu_option
282 :
283 1290 : do isppol=1,nsppol
284 659 : ikg=0
285 5313 : do ikpt=1,nkpt
286 4023 : npw_k=npwarr(ikpt)
287 4023 : istwf_k=istwfk(ikpt)
288 4023 : nband_k=nband(ikpt+(isppol-1)*nkpt)
289 4023 : if(proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband_k,isppol,me_kpt))cycle
290 3019 : ikpt_this_proc=mpi_enreg%my_kpttab(ikpt)
291 3019 : if ((ikpt_this_proc > mkmem).or.(ikpt_this_proc==0)) then
292 0 : message = ' this bandfft tab is not allocated !'
293 0 : ABI_ERROR(message)
294 : end if
295 3019 : if (bandfft_kpt_in(ikpt_this_proc)%flag1_is_allocated==0) then
296 12012 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%gbound ,(2*mgfft+8,2))
297 6006 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%recvcounts,(nproc_band))
298 6006 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%sendcounts,(nproc_band))
299 6006 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%rdispls ,(nproc_band))
300 6006 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%sdispls ,(nproc_band))
301 3003 : bandfft_kpt_in(ikpt_this_proc)%flag1_is_allocated=1
302 : end if
303 :
304 : ! Initialize various quantities for the reequilibration step
305 3019 : reequilibrate_allocated=(isppol==2.and.bandfft_kpt_in(ikpt_this_proc)%have_to_reequilibrate)
306 3019 : bandfft_kpt_in(ikpt_this_proc)%have_to_reequilibrate = .false.
307 3019 : bandfft_kpt_in(ikpt_this_proc)%npw_fft = 0
308 :
309 3019 : call xmpi_allgather(npw_k,recvcounts,comm_band,ierr)
310 3019 : rdispls(1)=0
311 8885 : do iproc=2,nproc_band
312 8885 : rdispls(iproc)=rdispls(iproc-1)+recvcounts(iproc-1)
313 : end do
314 3019 : ndatarecv=rdispls(nproc_band)+recvcounts(nproc_band)
315 :
316 9057 : ABI_MALLOC(kg_k_gather,(3,ndatarecv))
317 9057 : ABI_MALLOC(kg_k,(3,npw_k))
318 1256403 : kg_k(:,1:npw_k)=kg(:,1+ikg:npw_k+ikg)
319 20789 : call xmpi_allgatherv(kg_k,3*npw_k,kg_k_gather,3*recvcounts(:),3*rdispls(:),comm_band,ierr)
320 :
321 11904 : sendcounts(:)=npw_k*mpi_enreg%bandpp
322 11904 : do iproc=1,nproc_band
323 11904 : sdispls(iproc)=(iproc-1)*npw_k*mpi_enreg%bandpp
324 : end do
325 :
326 : ! ============================================================================
327 : ! Here we compute gbound, as well for istwf_k=1 as for istwf_k=2 and store it
328 : ! ============================================================================
329 : !MG: Why don't we compute gbound locally by just computing the full G-sphere from ecut
330 9057 : ABI_MALLOC(npw_per_proc,(nproc_fft))
331 6038 : ABI_MALLOC(rdispls_all,(nproc_fft))
332 12076 : ABI_MALLOC(gbound,(2*mgfft+8,2))
333 289973 : if (mgfft>0) gbound(:,:)=0
334 3019 : if (istwf_k==1) then
335 2231 : call xmpi_allgather(ndatarecv,npw_per_proc,mpi_enreg%comm_fft,ierr)
336 2231 : rdispls_all(1)=0
337 3481 : do iproc=2,nproc_fft
338 3481 : rdispls_all(iproc)=rdispls_all(iproc-1)+npw_per_proc(iproc-1)
339 : end do
340 2231 : npw_tot=rdispls_all(nproc_fft)+npw_per_proc(nproc_fft)
341 6693 : ABI_MALLOC(kg_k_gather_all,(3,npw_tot))
342 : call xmpi_allgatherv(kg_k_gather,&
343 9193 : & 3*ndatarecv,kg_k_gather_all,3*npw_per_proc(:),3*rdispls_all,mpi_enreg%comm_fft,ierr)
344 4462 : if (mgfft>0) then
345 2231 : call sphereboundary(gbound,istwf_k,kg_k_gather_all,mgfft,npw_tot)
346 : end if
347 :
348 : else !if (istwf_k==2) then
349 :
350 : ! ============================================================================
351 : ! In this case, we have to add the opposite values in the kg_k_gather tab
352 : ! before computing gbound
353 : ! ============================================================================
354 :
355 : ! Allocation
356 2364 : ABI_MALLOC(tab_proc ,(ndatarecv))
357 1576 : ABI_MALLOC(sendcounts_sym ,(nproc_fft))
358 2364 : ABI_MALLOC(sendcounts_sym_all,(nproc_fft*nproc_fft))
359 1576 : ABI_MALLOC(sdispls_sym ,(nproc_fft))
360 1576 : ABI_MALLOC(recvcounts_sym ,(nproc_fft))
361 1576 : ABI_MALLOC(recvcounts_sym_tot,(nproc_fft))
362 1576 : ABI_MALLOC(rdispls_sym ,(nproc_fft))
363 1576 : ABI_MALLOC(sendcounts_sym_loc,(nproc_fft))
364 1576 : ABI_MALLOC(sdispls_sym_loc ,(nproc_fft))
365 1576 : ABI_MALLOC(recvcounts_sym_loc,(nproc_fft))
366 1576 : ABI_MALLOC(rdispls_sym_loc ,(nproc_fft))
367 :
368 : ! Initialisation
369 140996 : tab_proc(:) = 0
370 1594 : sendcounts_sym(:) = 0
371 1630 : sendcounts_sym_all(:) = 0
372 1594 : sdispls_sym(:) = 0
373 1594 : recvcounts_sym(:) = 0
374 1594 : recvcounts_sym_tot(:) = 0
375 :
376 : ! Localisation of kg_k==[0 0 0]
377 1576 : ABI_MALLOC(sum_kg,(ndatarecv))
378 788 : idatarecv0 = -1
379 788 : ndatasend_sym = ndatarecv
380 562408 : sum_kg=sum(abs(kg_k_gather),1)
381 140996 : if (count(sum_kg==0)/=0) then
382 137621 : do idatarecv=1,ndatarecv
383 137621 : if (sum_kg(idatarecv)==0) idatarecv0=idatarecv
384 : end do
385 779 : ndatasend_sym = ndatarecv-1
386 : end if
387 :
388 : ! Localisation of the processor where the vector -k2 is
389 788 : n2 = mpi_enreg%distribfft%n2_coarse
390 140996 : do idatarecv=1,ndatarecv
391 140996 : if (idatarecv/=idatarecv0) then
392 139429 : tab_proc(idatarecv) = mpi_enreg%distribfft%tab_fftwf2_distrib(modulo(-kg_k_gather(2,idatarecv),n2) + 1)
393 : else
394 779 : tab_proc(idatarecv) = -1
395 : end if
396 : end do
397 :
398 : ! Number of values send by the processor to the others
399 1594 : do iproc=1,nproc_fft
400 148626 : sendcounts_sym(iproc) = count(tab_proc(:)==(iproc-1))
401 : end do
402 :
403 : ! Save sendcounts_sym for each processor in sendcounts_sym_all
404 : ! knowed by all processors of comm_fft
405 788 : rdispls_sym(1)=0
406 806 : do iproc=2,nproc_fft
407 806 : rdispls_sym(iproc)= nproc_fft*(iproc-1)
408 : end do
409 1594 : recvcounts_sym(:)=nproc_fft
410 : call xmpi_allgatherv(sendcounts_sym(:),nproc_fft,&
411 788 : & sendcounts_sym_all(:),recvcounts_sym,rdispls_sym,comm_fft,ierr)
412 :
413 : ! Calculation of the dimension of kg_k_gather_sym for each processor
414 : ! recvcounts_sym_tot is knowed by all processors of comm_fft
415 788 : call xmpi_sum(sendcounts_sym,recvcounts_sym_tot,nproc_fft,comm_fft,ierr)
416 :
417 : ! Dimension of kg_k_gather_sym
418 788 : ndatarecv_tot = ndatarecv+recvcounts_sym_tot(me_fft+1)
419 :
420 : ! Intialize kg_k_gather_sym
421 2364 : ABI_MALLOC(kg_k_gather_sym,(3,ndatarecv_tot))
422 1119336 : kg_k_gather_sym(:,:)=0
423 561620 : kg_k_gather_sym(:,1:ndatarecv) = kg_k_gather(:,:)
424 :
425 : ! Allocation and initialisation
426 2364 : ABI_MALLOC(kg_k_gather_send,(3,ndatasend_sym))
427 558504 : kg_k_gather_send(:,:)=0
428 :
429 : ! The values are sorted in blocks
430 : jsendloc=0
431 1594 : do iproc=1,nproc_fft
432 :
433 : ! Position of the beginning of the block
434 806 : sdispls_sym(iproc)=jsendloc
435 :
436 : ! Creation of the blocks
437 148626 : do idatarecv=1,ndatarecv
438 147838 : if (tab_proc(idatarecv)==(iproc-1)) then
439 139429 : jsendloc=jsendloc+1
440 557716 : kg_k_gather_send(:,jsendloc) = -kg_k_gather(:,idatarecv)
441 : end if
442 : end do
443 : end do
444 :
445 : ! Position of received data
446 788 : rdispls_sym(1)= ndatarecv
447 788 : recvcounts_sym(1)= sendcounts_sym_all((me_fft+1))
448 806 : do iproc=2,nproc_fft
449 : rdispls_sym(iproc) = rdispls_sym(iproc-1) + &
450 18 : sendcounts_sym_all((me_fft+1)+(iproc-2)*nproc_fft)
451 806 : recvcounts_sym(iproc) = sendcounts_sym_all((me_fft+1)+(iproc-1)*nproc_fft)
452 : end do
453 :
454 : ! Exchange of kg_k
455 2382 : sendcounts_sym_loc = sendcounts_sym*3
456 2382 : sdispls_sym_loc = sdispls_sym *3
457 2382 : recvcounts_sym_loc = recvcounts_sym*3
458 2382 : rdispls_sym_loc = rdispls_sym *3
459 : call xmpi_alltoallv(kg_k_gather_send(:,:),sendcounts_sym_loc,sdispls_sym_loc,&
460 788 : & kg_k_gather_sym(:,:) ,recvcounts_sym_loc,rdispls_sym_loc,comm_fft,ierr)
461 :
462 : ! Store the following data in the bandfft_kpt_in data_struc
463 788 : ikpt_this_proc=mpi_enreg%my_kpttab(ikpt)
464 788 : if (bandfft_kpt_in(ikpt_this_proc)%flag3_is_allocated==0) then
465 1576 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%kg_k_gather_sym,(3,ndatarecv_tot))
466 1576 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%rdispls_sym,(nproc_fft))
467 1576 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%recvcounts_sym,(nproc_fft))
468 1576 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%recvcounts_sym_tot,(nproc_fft))
469 1576 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%sdispls_sym,(nproc_fft))
470 1576 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%sendcounts_sym,(nproc_fft))
471 1576 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%sendcounts_sym_all,(nproc_fft*nproc_fft))
472 1576 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%tab_proc,(ndatarecv))
473 788 : bandfft_kpt_in(ikpt_this_proc)%flag3_is_allocated=1
474 : end if
475 :
476 788 : bandfft_kpt_in(ikpt_this_proc)%idatarecv0 =idatarecv0
477 788 : bandfft_kpt_in(ikpt_this_proc)%ndatarecv_tot =ndatarecv_tot
478 788 : bandfft_kpt_in(ikpt_this_proc)%ndatasend_sym =ndatasend_sym
479 1119336 : bandfft_kpt_in(ikpt_this_proc)%kg_k_gather_sym(:,:) =kg_k_gather_sym(:,:)
480 1594 : bandfft_kpt_in(ikpt_this_proc)%rdispls_sym(:) =rdispls_sym(:)
481 1594 : bandfft_kpt_in(ikpt_this_proc)%recvcounts_sym(:) =recvcounts_sym(:)
482 1594 : bandfft_kpt_in(ikpt_this_proc)%recvcounts_sym_tot(:)=recvcounts_sym_tot(:)
483 1594 : bandfft_kpt_in(ikpt_this_proc)%sdispls_sym(:) =sdispls_sym(:)
484 1594 : bandfft_kpt_in(ikpt_this_proc)%sendcounts_sym(:) =sendcounts_sym(:)
485 1630 : bandfft_kpt_in(ikpt_this_proc)%sendcounts_sym_all(:)=sendcounts_sym_all(:)
486 140996 : bandfft_kpt_in(ikpt_this_proc)%tab_proc(:) =tab_proc(:)
487 :
488 788 : ABI_FREE(tab_proc)
489 788 : ABI_FREE(sendcounts_sym)
490 788 : ABI_FREE(sendcounts_sym_all)
491 788 : ABI_FREE(sdispls_sym)
492 788 : ABI_FREE(recvcounts_sym)
493 788 : ABI_FREE(recvcounts_sym_tot)
494 788 : ABI_FREE(rdispls_sym)
495 788 : ABI_FREE(kg_k_gather_sym)
496 788 : ABI_FREE(sendcounts_sym_loc)
497 788 : ABI_FREE(recvcounts_sym_loc)
498 788 : ABI_FREE(sdispls_sym_loc)
499 788 : ABI_FREE(rdispls_sym_loc)
500 788 : ABI_FREE(kg_k_gather_send)
501 788 : ABI_FREE(sum_kg)
502 :
503 : ! Then compute gbound
504 788 : call xmpi_allgather(ndatarecv_tot,npw_per_proc,mpi_enreg%comm_fft,ierr)
505 788 : rdispls_all(1)=0
506 806 : do iproc=2,nproc_fft
507 806 : rdispls_all(iproc)=rdispls_all(iproc-1)+npw_per_proc(iproc-1)
508 : end do
509 788 : npw_tot=rdispls_all(nproc_fft)+npw_per_proc(nproc_fft)
510 2364 : ABI_MALLOC(kg_k_gather_all,(3,npw_tot))
511 : call xmpi_allgatherv(bandfft_kpt_in(ikpt_this_proc)%kg_k_gather_sym,&
512 2400 : & 3*ndatarecv_tot,kg_k_gather_all,3*npw_per_proc(:),3*rdispls_all,mpi_enreg%comm_fft,ierr)
513 2364 : if (mgfft>0) then
514 788 : call sphereboundary(gbound,istwf_k,kg_k_gather_all,mgfft,npw_tot)
515 : end if
516 :
517 : ! Only calculations with istwfk=1 or 2
518 : end if
519 3019 : ABI_FREE(kg_k_gather_all)
520 3019 : ABI_FREE(npw_per_proc)
521 3019 : ABI_FREE(rdispls_all)
522 : ! ============================================================================
523 : ! End of gbound
524 : ! ============================================================================
525 :
526 : ! Check if there is k_G vectors have been redistributed (after unbalancing dectecion)
527 : ! Note that FFT load balancing is directly related to unbalancing detection
528 : ! made in kpgsph routine.
529 3019 : itest=0 ; n2 = mpi_enreg%distribfft%n2_coarse
530 700176 : do idatarecv=1,ndatarecv
531 697157 : iproc=mpi_enreg%distribfft%tab_fftwf2_distrib(modulo(kg_k_gather(2,idatarecv),n2)+1)
532 700176 : if (iproc/=me_fft) itest=itest+1
533 : end do
534 3019 : call xmpi_sum(itest,mpi_enreg%comm_fft,ierr)
535 3019 : if (itest>0) then
536 : write(message, '(a,i4,3a)' ) &
537 0 : & 'There is a load unbalancing for the FFT parallelization (kpt',ikpt,').',ch10,&
538 0 : & 'Plane-wave components will be redistributed before each FFT!'
539 0 : ABI_COMMENT(message)
540 : end if
541 3019 : bandfft_kpt_in(ikpt_this_proc)%have_to_reequilibrate=(itest>0)
542 :
543 : ! If yes, store relevant data
544 3019 : if(bandfft_kpt_in(ikpt_this_proc)%have_to_reequilibrate) then
545 0 : n2 = mpi_enreg%distribfft%n2_coarse
546 0 : sendcounts_fft(:) = 0
547 0 : recvcounts_fft(:) = 0
548 0 : senddisp_fft(:) = 0
549 0 : recvdisp_fft(:) = 0
550 0 : do idatarecv = 1 ,ndatarecv
551 0 : iproc = mpi_enreg%distribfft%tab_fftwf2_distrib(modulo(kg_k_gather(2,idatarecv),n2) + 1)
552 0 : sendcounts_fft(iproc + 1) = sendcounts_fft(iproc + 1) + 1
553 : end do
554 0 : call xmpi_alltoall(sendcounts_fft,1,recvcounts_fft,1,mpi_enreg%comm_fft,ierr)
555 0 : do iproc =2, nproc_fft
556 0 : senddisp_fft(iproc) = senddisp_fft(iproc - 1) + sendcounts_fft(iproc-1)
557 0 : recvdisp_fft(iproc) = recvdisp_fft(iproc - 1) + recvcounts_fft(iproc-1)
558 : end do
559 0 : npw_fft = recvdisp_fft(nproc_fft) + recvcounts_fft(nproc_fft) ! nb plane wave for fourwf call
560 0 : ABI_MALLOC(buff_kg,(3,ndatarecv)) ! for sorting kg_k
561 0 : ABI_MALLOC(kg_k_fft,(3,npw_fft))
562 0 : ABI_MALLOC(indices_pw_fft,(ndatarecv))
563 : !filling of sorted send buffers
564 0 : sendcounts_fft(:) = 0
565 0 : do idatarecv = 1 ,ndatarecv
566 0 : iproc = mpi_enreg%distribfft%tab_fftwf2_distrib(modulo(kg_k_gather(2,idatarecv),n2) + 1)
567 0 : sendcounts_fft(iproc + 1) = sendcounts_fft(iproc + 1) + 1
568 0 : indices_pw_fft(idatarecv) = senddisp_fft(iproc+1) + sendcounts_fft(iproc+1)
569 0 : buff_kg(1:3,indices_pw_fft(idatarecv)) = kg_k_gather(1:3,idatarecv)
570 : end do
571 :
572 : call xmpi_alltoallv(buff_kg, 3*sendcounts_fft, 3*senddisp_fft, &
573 0 : & kg_k_fft,3*recvcounts_fft, 3*recvdisp_fft, mpi_enreg%comm_fft,ierr)
574 :
575 0 : if (.not.reequilibrate_allocated) then
576 0 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%kg_k_fft, (3,npw_fft) )
577 0 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%indices_pw_fft, (ndatarecv))
578 0 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%sendcount_fft, (nproc_fft))
579 0 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%senddisp_fft, (nproc_fft))
580 0 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%recvcount_fft, (nproc_fft))
581 0 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%recvdisp_fft, (nproc_fft))
582 : end if
583 0 : bandfft_kpt_in(ikpt_this_proc)%npw_fft = npw_fft
584 0 : bandfft_kpt_in(ikpt_this_proc)%indices_pw_fft(:) = indices_pw_fft(:)
585 0 : bandfft_kpt_in(ikpt_this_proc)%sendcount_fft (:) = sendcounts_fft (:)
586 0 : bandfft_kpt_in(ikpt_this_proc)%senddisp_fft(:) = senddisp_fft(:)
587 0 : bandfft_kpt_in(ikpt_this_proc)%recvcount_fft(:) = recvcounts_fft(:)
588 0 : bandfft_kpt_in(ikpt_this_proc)%recvdisp_fft(:) = recvdisp_fft(:)
589 0 : bandfft_kpt_in(ikpt_this_proc)%kg_k_fft(:,:) = kg_k_fft(:,:)
590 0 : ABI_FREE(buff_kg )
591 0 : ABI_FREE(kg_k_fft)
592 0 : ABI_FREE(indices_pw_fft)
593 : end if
594 :
595 : ! Tabs which are common to istwf_k=1 and 2
596 : #if defined HAVE_GPU && defined HAVE_YAKL
597 : if (.not. associated(bandfft_kpt_in(ikpt_this_proc)%kg_k_gather)) then
598 : if(bandfft_kpt_in(ikpt_this_proc)%gpu_option==ABI_GPU_KOKKOS) then
599 : ABI_MALLOC_MANAGED(bandfft_kpt_in(ikpt_this_proc)%kg_k_gather,(/3,ndatarecv/))
600 : else
601 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%kg_k_gather,(3,ndatarecv))
602 : end if
603 : end if
604 : #else
605 3019 : if (.not. allocated(bandfft_kpt_in(ikpt_this_proc)%kg_k_gather)) then
606 9009 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%kg_k_gather,(3,ndatarecv))
607 : end if
608 : #endif
609 :
610 11904 : bandfft_kpt_in(ikpt_this_proc)%recvcounts(:) =recvcounts(:)
611 11904 : bandfft_kpt_in(ikpt_this_proc)%sendcounts(:) =sendcounts(:)
612 11904 : bandfft_kpt_in(ikpt_this_proc)%rdispls(:) =rdispls(:)
613 11904 : bandfft_kpt_in(ikpt_this_proc)%sdispls(:) =sdispls(:)
614 289973 : bandfft_kpt_in(ikpt_this_proc)%gbound(:,:) =gbound(:,:)
615 2791647 : bandfft_kpt_in(ikpt_this_proc)%kg_k_gather(:,:)=kg_k_gather(:,:)
616 3019 : bandfft_kpt_in(ikpt_this_proc)%ndatarecv =ndatarecv
617 3019 : bandfft_kpt_in(ikpt_this_proc)%istwf_k =istwf_k
618 3019 : bandfft_kpt_in(ikpt_this_proc)%npw_tot =npw_tot
619 3019 : ABI_FREE(kg_k_gather)
620 3019 : ABI_FREE(kg_k)
621 3019 : ABI_FREE(gbound)
622 :
623 10720 : ikg=ikg+npw_k
624 : end do
625 : end do
626 631 : ABI_FREE(recvcounts)
627 631 : ABI_FREE(sendcounts)
628 631 : ABI_FREE(rdispls)
629 631 : ABI_FREE(sdispls)
630 631 : ABI_FREE(sendcounts_fft)
631 631 : ABI_FREE(senddisp_fft)
632 631 : ABI_FREE(recvcounts_fft)
633 631 : ABI_FREE(recvdisp_fft)
634 :
635 : !=============================================================================
636 : !End of computation and storage of the bandfft_kpt(ikpt) data_struc
637 : !=============================================================================
638 :
639 5669 : end subroutine bandfft_kpt_init1
640 : !!***
641 :
642 : !----------------------------------------------------------------------
643 :
644 : !!****f* m_bandfft_kpt/bandfft_kpt_init2
645 : !! NAME
646 : !! bandfft_kpt_init2
647 : !!
648 : !! FUNCTION
649 : !! Init part of scalars and pointers in a bandfft_kpt datastructure
650 : !!
651 : !! INPUTS
652 : !! dimffnl=second dimension of ffnl (1+number of derivatives)
653 : !! ffnl_gather(ndatarecv,dimffnl,lmnmax,ntypat)=nonlocal form factors on basis sphere.
654 : !! kinpw_gather(:)=(modified) kinetic energy for each plane wave (Hartree)
655 : !! kpg_k_gather(ndatarecv,nkpg)=k+G vector for a given k point
656 : !! lmnmax=if useylm=1, max number of (l,m,n) comp. over all type of psps
657 : !! =if useylm=0, max number of (l,n) comp. over all type of psps
658 : !! matblk=dimension of the array ph3d
659 : !! mkmem =number of k points which can fit in memory; set to 0 if use disk
660 : !! ndatarecv= dimension of the arrays
661 : !! nkpg=second dimension of kpg_k (0 if useylm=0)
662 : !! ntypat=number of types of atoms in unit cell.
663 : !! ph3d_gather(2,ndatarecv,matblk)=3-dim structure factors, for each atom and plane wave.
664 :
665 : !! OUTPUT
666 : !!
667 : !! SIDE EFFECTS
668 : !!
669 : !! SOURCE
670 :
671 13142 : subroutine bandfft_kpt_init2(bandfft_kpt_in,dimffnl,ffnl_gather,ikpt_this_proc,kinpw_gather,&
672 13142 : & kpg_k_gather,lmnmax,matblk,mkmem,ndatarecv,nkpg,ntypat,ph3d_gather)
673 :
674 : !Arguments -------------------------------
675 : integer, intent(in) :: dimffnl,ikpt_this_proc,lmnmax,matblk,mkmem,ndatarecv,nkpg,ntypat
676 : !Local variables-------------------------------
677 : real(dp),intent(in) :: ffnl_gather(:,:,:,:),kinpw_gather(:)
678 : real(dp),intent(in) :: kpg_k_gather(:,:),ph3d_gather(:,:,:)
679 : type(bandfft_kpt_type), intent(inout) :: bandfft_kpt_in (mkmem)
680 :
681 : ! *********************************************************************
682 :
683 13142 : ABI_SFREE(bandfft_kpt_in(ikpt_this_proc)%ffnl_gather)
684 65710 : if (size(ffnl_gather)>0) then
685 78852 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%ffnl_gather,(ndatarecv,dimffnl,lmnmax,ntypat))
686 74025694 : bandfft_kpt_in(ikpt_this_proc)%ffnl_gather(:,:,:,:)=ffnl_gather(:,:,:,:)
687 : else
688 0 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%ffnl_gather,(0,0,0,0))
689 : end if
690 :
691 13142 : ABI_SFREE(bandfft_kpt_in(ikpt_this_proc)%ph3d_gather)
692 13142 : if (size(ph3d_gather,dim=1)>0) then
693 52568 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%ph3d_gather,(2,ndatarecv,matblk))
694 33877544 : bandfft_kpt_in(ikpt_this_proc)%ph3d_gather(:,:,:) =ph3d_gather(:,:,:)
695 : else
696 0 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%ph3d_gather,(0,0,0))
697 : end if
698 :
699 13142 : ABI_SFREE(bandfft_kpt_in(ikpt_this_proc)%kpg_k_gather)
700 39426 : if (size(kpg_k_gather)>0) then
701 13868 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%kpg_k_gather,(ndatarecv,nkpg))
702 2393828 : bandfft_kpt_in(ikpt_this_proc)%kpg_k_gather(:,:) =kpg_k_gather(:,:)
703 : else
704 9675 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%kpg_k_gather,(0,0))
705 : end if
706 :
707 : #if defined HAVE_GPU && defined HAVE_YAKL
708 : if (associated(bandfft_kpt_in(ikpt_this_proc)%kinpw_gather)) then
709 : if(bandfft_kpt_in(ikpt_this_proc)%gpu_option==ABI_GPU_KOKKOS) then
710 : ABI_FREE_MANAGED(bandfft_kpt_in(ikpt_this_proc)%kinpw_gather)
711 : else
712 : ABI_FREE(bandfft_kpt_in(ikpt_this_proc)%kinpw_gather)
713 : end if
714 : end if
715 : if(bandfft_kpt_in(ikpt_this_proc)%gpu_option==ABI_GPU_KOKKOS) then
716 : if (size(kinpw_gather)>0) then
717 : ABI_MALLOC_MANAGED(bandfft_kpt_in(ikpt_this_proc)%kinpw_gather,(/ndatarecv/))
718 : bandfft_kpt_in(ikpt_this_proc)%kinpw_gather(:) =kinpw_gather(:)
719 : else
720 : ABI_MALLOC_MANAGED(bandfft_kpt_in(ikpt_this_proc)%kinpw_gather,(/0/))
721 : end if
722 : else
723 : if (size(kinpw_gather)>0) then
724 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%kinpw_gather,(ndatarecv))
725 : bandfft_kpt_in(ikpt_this_proc)%kinpw_gather(:) =kinpw_gather(:)
726 : else
727 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%kinpw_gather,(0))
728 : end if
729 : end if
730 : #else
731 13142 : ABI_SFREE(bandfft_kpt_in(ikpt_this_proc)%kinpw_gather)
732 13142 : if (size(kinpw_gather)>0) then
733 30576 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%kinpw_gather,(ndatarecv))
734 1880653 : bandfft_kpt_in(ikpt_this_proc)%kinpw_gather(:) =kinpw_gather(:)
735 : else
736 2950 : ABI_MALLOC(bandfft_kpt_in(ikpt_this_proc)%kinpw_gather,(0))
737 : end if
738 : #endif
739 :
740 13142 : bandfft_kpt_in(ikpt_this_proc)%flag2_is_allocated=1
741 :
742 13142 : end subroutine bandfft_kpt_init2
743 : !!***
744 :
745 : !----------------------------------------------------------------------
746 :
747 : !!****f* m_bandfft_kpt/bandfft_kpt_reset
748 : !! NAME
749 : !! bandfft_kpt_reset
750 : !!
751 : !! FUNCTION
752 : !! Reset flags a bandfft_kpt datastructure
753 : !!
754 : !! INPUTS
755 : !!
756 : !! OUTPUT
757 : !!
758 : !! SIDE EFFECTS
759 : !! bandfft_kpt_in=the datastructure to nullify
760 : !!
761 : !! SOURCE
762 :
763 0 : subroutine bandfft_kpt_reset(bandfft_kpt_in)
764 :
765 : !Arguments ------------------------------------
766 : type(bandfft_kpt_type) :: bandfft_kpt_in
767 : !Local variables-------------------------------
768 :
769 : ! ***********************************************************************
770 :
771 0 : bandfft_kpt_in%flag1_is_allocated=0
772 0 : bandfft_kpt_in%flag2_is_allocated=0
773 0 : bandfft_kpt_in%flag3_is_allocated=0
774 0 : bandfft_kpt_in%have_to_reequilibrate=.false.
775 :
776 0 : end subroutine bandfft_kpt_reset
777 : !!***
778 :
779 : !----------------------------------------------------------------------
780 :
781 : !!****f* m_bandfft_kpt/bandfft_kpt_destroy
782 : !! NAME
783 : !! bandfft_kpt_destroy
784 : !!
785 : !! FUNCTION
786 : !! Destroy a bandfft_kpt datastructure
787 : !!
788 : !! INPUTS
789 : !!
790 : !! OUTPUT
791 : !!
792 : !! SIDE EFFECTS
793 : !! bandfft_kpt_in=the datastructure to destroy
794 : !!
795 : !! SOURCE
796 :
797 3019 : subroutine bandfft_kpt_destroy(bandfft_kpt_in)
798 :
799 : !Arguments ------------------------------------
800 : type(bandfft_kpt_type) :: bandfft_kpt_in
801 : !Local variables-------------------------------
802 :
803 : ! ***********************************************************************
804 :
805 3019 : bandfft_kpt_in%flag1_is_allocated=0
806 3019 : bandfft_kpt_in%flag2_is_allocated=0
807 3019 : bandfft_kpt_in%flag3_is_allocated=0
808 3019 : bandfft_kpt_in%have_to_reequilibrate=.false.
809 :
810 : #if defined HAVE_GPU && defined HAVE_YAKL
811 : if (associated(bandfft_kpt_in%kg_k_gather)) then
812 : if(bandfft_kpt_in%gpu_option==ABI_GPU_KOKKOS) then
813 : ABI_FREE_MANAGED(bandfft_kpt_in%kg_k_gather)
814 : else
815 : ABI_FREE(bandfft_kpt_in%kg_k_gather)
816 : end if
817 : end if
818 : #else
819 3019 : ABI_SFREE(bandfft_kpt_in%kg_k_gather)
820 : #endif
821 :
822 3019 : ABI_SFREE(bandfft_kpt_in%gbound)
823 3019 : ABI_SFREE(bandfft_kpt_in%recvcounts)
824 3019 : ABI_SFREE(bandfft_kpt_in%sendcounts)
825 3019 : ABI_SFREE(bandfft_kpt_in%rdispls)
826 3019 : ABI_SFREE(bandfft_kpt_in%sdispls)
827 3019 : ABI_SFREE(bandfft_kpt_in%ffnl_gather)
828 :
829 : #if defined HAVE_GPU && defined HAVE_YAKL
830 : if (associated(bandfft_kpt_in%kinpw_gather)) then
831 : if(bandfft_kpt_in%gpu_option==ABI_GPU_KOKKOS) then
832 : ABI_FREE_MANAGED(bandfft_kpt_in%kinpw_gather)
833 : else
834 : ABI_FREE(bandfft_kpt_in%kinpw_gather)
835 : end if
836 : end if
837 : #else
838 3019 : ABI_SFREE(bandfft_kpt_in%kinpw_gather)
839 : #endif
840 :
841 3019 : ABI_SFREE(bandfft_kpt_in%kpg_k_gather)
842 3019 : ABI_SFREE(bandfft_kpt_in%ph3d_gather)
843 3019 : ABI_SFREE(bandfft_kpt_in%kg_k_gather_sym)
844 3019 : ABI_SFREE(bandfft_kpt_in%rdispls_sym)
845 3019 : ABI_SFREE(bandfft_kpt_in%recvcounts_sym)
846 3019 : ABI_SFREE(bandfft_kpt_in%recvcounts_sym_tot)
847 3019 : ABI_SFREE(bandfft_kpt_in%sdispls_sym)
848 3019 : ABI_SFREE(bandfft_kpt_in%sendcounts_sym)
849 3019 : ABI_SFREE(bandfft_kpt_in%sendcounts_sym_all)
850 3019 : ABI_SFREE(bandfft_kpt_in%tab_proc)
851 3019 : ABI_SFREE(bandfft_kpt_in%indices_pw_fft)
852 3019 : ABI_SFREE(bandfft_kpt_in%sendcount_fft)
853 3019 : ABI_SFREE(bandfft_kpt_in%senddisp_fft)
854 3019 : ABI_SFREE(bandfft_kpt_in%recvcount_fft)
855 3019 : ABI_SFREE(bandfft_kpt_in%recvdisp_fft)
856 3019 : ABI_SFREE(bandfft_kpt_in%kg_k_fft)
857 :
858 3019 : end subroutine bandfft_kpt_destroy
859 : !!***
860 :
861 : !----------------------------------------------------------------------
862 :
863 : !!****f* m_bandfft_kpt/bandfft_kpt_destroy_array
864 : !! NAME
865 : !! bandfft_kpt_destroy_array
866 : !!
867 : !! FUNCTION
868 : !! Clean and destroy an array of bandfft_kpt datastructures
869 : !!
870 : !! INPUTS
871 : !!
872 : !! OUTPUT
873 : !!
874 : !! SIDE EFFECTS
875 : !! bandfft_kpt_in(:)=the array of datastructure to destroy
876 : !!
877 : !!
878 : !! SOURCE
879 :
880 5669 : subroutine bandfft_kpt_destroy_array(bandfft_kpt_in,mpi_enreg)
881 :
882 : !Arguments ------------------------------------
883 : type(bandfft_kpt_type),pointer :: bandfft_kpt_in(:)
884 : type(MPI_type), intent(inout) :: mpi_enreg
885 :
886 : !Local variables-------------------------------
887 : integer :: ikpt_this_proc,isppol,ikpt,mkmem,nband,nkpt,nsppol
888 : character(len=500) :: msg
889 :
890 : ! ***********************************************************************
891 :
892 : if (xmpi_paral==0) return
893 :
894 5669 : if (associated(bandfft_kpt_in)) then
895 631 : mkmem =size(bandfft_kpt_in)
896 631 : nkpt=size(mpi_enreg%proc_distrb,1)
897 631 : nband=size(mpi_enreg%proc_distrb,2)
898 631 : nsppol=size(mpi_enreg%proc_distrb,3)
899 631 : if (nsppol==0.or.nkpt==0) then
900 0 : msg=' mpi_enreg%proc_distrb should be allocated !'
901 0 : ABI_BUG(msg)
902 : end if
903 631 : nkpt=size(mpi_enreg%my_kpttab)
904 631 : if (nkpt==0) then
905 0 : msg=' mpi_enreg%my_kpttab should be allocated !'
906 0 : ABI_BUG(msg)
907 : end if
908 1290 : do isppol=1,nsppol
909 5313 : do ikpt=1,nkpt
910 4023 : if(proc_distrb_cycle(mpi_enreg%proc_distrb,ikpt,1,nband,isppol,mpi_enreg%me_kpt)) cycle
911 3019 : ikpt_this_proc=mpi_enreg%my_kpttab(ikpt)
912 3019 : if ((ikpt_this_proc>mkmem) .or.(ikpt_this_proc<=0)) then
913 0 : msg=' The bandfft tab cannot be deallocated !'
914 0 : ABI_BUG(msg)
915 : end if
916 4682 : call bandfft_kpt_destroy(bandfft_kpt_in(ikpt_this_proc))
917 : end do
918 : end do
919 631 : ABI_FREE(bandfft_kpt_in)
920 : nullify(bandfft_kpt_in)
921 : end if
922 :
923 5669 : end subroutine bandfft_kpt_destroy_array
924 : !!***
925 :
926 : !----------------------------------------------------------------------
927 :
928 : !!****f* m_bandfft_kpt/bandfft_kpt_copy
929 : !! NAME
930 : !! bandfft_kpt_copy
931 : !!
932 : !! FUNCTION
933 : !! Copy a bandfft_kpt datastructure into another
934 : !!
935 : !! INPUTS
936 : !! bandfft_kpt_in=<type(bandfft_kpt_type)>=input bandfft_kpt datastructure
937 : !!
938 : !! OUTPUT
939 : !! bandfft_kpt_out=<type(bandfft_kpt_type)>=output bandfft_kpt datastructure
940 : !!
941 : !! SOURCE
942 :
943 0 : subroutine bandfft_kpt_copy(bandfft_kpt_in,bandfft_kpt_out,mpi_enreg1,opt_bandfft)
944 :
945 : !Arguments ------------------------------------
946 : !scalars
947 : integer,intent(in) :: opt_bandfft
948 : type(bandfft_kpt_type),pointer :: bandfft_kpt_in(:)
949 : type(bandfft_kpt_type),pointer :: bandfft_kpt_out(:)
950 : type(MPI_type),intent(inout) :: mpi_enreg1
951 :
952 : !Local variables-------------------------------
953 : !scalars
954 : integer :: ikpt,isppol,jkpt,sz1,sz2,sz3,sz4
955 :
956 : ! *********************************************************************
957 :
958 : !Optional pointers
959 0 : if (opt_bandfft==0) then
960 0 : nullify(bandfft_kpt_out)
961 0 : else if (opt_bandfft==1) then
962 0 : if (associated(bandfft_kpt_in)) then
963 0 : ABI_MALLOC(bandfft_kpt_out,(size(bandfft_kpt_in)))
964 0 : do isppol=1,size(mpi_enreg1%proc_distrb,3)
965 0 : do ikpt=1,size(mpi_enreg1%proc_distrb,1)
966 0 : sz1=size(mpi_enreg1%proc_distrb,2)
967 0 : if(proc_distrb_cycle(mpi_enreg1%proc_distrb,ikpt,1,sz1,isppol,mpi_enreg1%me_kpt)) then
968 : cycle
969 : end if
970 0 : jkpt=mpi_enreg1%my_kpttab(ikpt)
971 : ! if (allocated(bandfft_kpt_in(jkpt)%ind_kg_mpi_to_seq)) then
972 : ! sz1=size(bandfft_kpt_in(jkpt)%ind_kg_mpi_to_seq)
973 : ! ABI_MALLOC(bandfft_kpt_out(jkpt)%ind_kg_mpi_to_seq,(sz1))
974 : ! bandfft_kpt_out(jkpt)%ind_kg_mpi_to_seq= &
975 : ! & bandfft_kpt_in(jkpt)%ind_kg_mpi_to_seq
976 : ! end if
977 :
978 0 : bandfft_kpt_out(jkpt)%gpu_option=bandfft_kpt_in(jkpt)%gpu_option
979 : #if defined HAVE_GPU && defined HAVE_YAKL
980 : if (associated(bandfft_kpt_in(jkpt)%kg_k_gather)) then
981 : sz1=size(bandfft_kpt_in(jkpt)%kg_k_gather,1)
982 : sz2=size(bandfft_kpt_in(jkpt)%kg_k_gather,2)
983 : if(bandfft_kpt_in(jkpt)%gpu_option==ABI_GPU_KOKKOS) then
984 : ABI_MALLOC_MANAGED(bandfft_kpt_out(jkpt)%kg_k_gather,(/sz1,sz2/))
985 : bandfft_kpt_out(jkpt)%kg_k_gather= &
986 : & bandfft_kpt_in(jkpt)%kg_k_gather
987 : else
988 : ABI_MALLOC(bandfft_kpt_out(jkpt)%kg_k_gather,(sz1,sz2))
989 : bandfft_kpt_out(jkpt)%kg_k_gather= &
990 : & bandfft_kpt_in(jkpt)%kg_k_gather
991 : end if
992 : end if
993 : #else
994 0 : if (allocated(bandfft_kpt_in(jkpt)%kg_k_gather)) then
995 0 : sz1=size(bandfft_kpt_in(jkpt)%kg_k_gather,1)
996 0 : sz2=size(bandfft_kpt_in(jkpt)%kg_k_gather,2)
997 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%kg_k_gather,(sz1,sz2))
998 : bandfft_kpt_out(jkpt)%kg_k_gather= &
999 0 : & bandfft_kpt_in(jkpt)%kg_k_gather
1000 : end if
1001 : #endif
1002 :
1003 0 : bandfft_kpt_out(jkpt)%flag1_is_allocated=bandfft_kpt_in(jkpt)%flag1_is_allocated
1004 0 : if (allocated(bandfft_kpt_in(jkpt)%gbound)) then
1005 0 : sz1=size(bandfft_kpt_in(jkpt)%gbound,1)
1006 0 : sz2=size(bandfft_kpt_in(jkpt)%gbound,2)
1007 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%gbound,(sz1,sz2))
1008 : bandfft_kpt_out(jkpt)%gbound= &
1009 0 : & bandfft_kpt_in(jkpt)%gbound
1010 : end if
1011 0 : if (allocated(bandfft_kpt_in(jkpt)%recvcounts)) then
1012 0 : sz1=size(bandfft_kpt_in(jkpt)%recvcounts)
1013 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%recvcounts,(sz1))
1014 : bandfft_kpt_out(jkpt)%recvcounts= &
1015 0 : & bandfft_kpt_in(jkpt)%recvcounts
1016 : end if
1017 0 : if (allocated(bandfft_kpt_in(jkpt)%sendcounts)) then
1018 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%sendcounts,(size(bandfft_kpt_in(jkpt)%sendcounts)))
1019 : bandfft_kpt_out(jkpt)%sendcounts= &
1020 0 : & bandfft_kpt_in(jkpt)%sendcounts
1021 : end if
1022 0 : if (allocated(bandfft_kpt_in(jkpt)%rdispls)) then
1023 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%rdispls,(size(bandfft_kpt_in(jkpt)%rdispls)))
1024 : bandfft_kpt_out(jkpt)%rdispls= &
1025 0 : & bandfft_kpt_in(jkpt)%rdispls
1026 : end if
1027 0 : if (allocated(bandfft_kpt_in(jkpt)%sdispls)) then
1028 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%sdispls,(size(bandfft_kpt_in(jkpt)%sdispls)))
1029 : bandfft_kpt_out(jkpt)%sdispls= &
1030 0 : & bandfft_kpt_in(jkpt)%sdispls
1031 : end if
1032 0 : bandfft_kpt_out(jkpt)%flag2_is_allocated=bandfft_kpt_in(jkpt)%flag2_is_allocated
1033 0 : if (allocated(bandfft_kpt_in(jkpt)%ffnl_gather)) then
1034 0 : sz1=size(bandfft_kpt_in(jkpt)%ffnl_gather,1)
1035 0 : sz2=size(bandfft_kpt_in(jkpt)%ffnl_gather,2)
1036 0 : sz3=size(bandfft_kpt_in(jkpt)%ffnl_gather,3)
1037 0 : sz4=size(bandfft_kpt_in(jkpt)%ffnl_gather,4)
1038 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%ffnl_gather,(sz1,sz2,sz3,sz4))
1039 : bandfft_kpt_out(jkpt)%ffnl_gather= &
1040 0 : & bandfft_kpt_in(jkpt)%ffnl_gather
1041 : end if
1042 :
1043 : #if defined HAVE_GPU && defined HAVE_YAKL
1044 : if (associated(bandfft_kpt_in(jkpt)%kinpw_gather)) then
1045 : sz1=size(bandfft_kpt_in(jkpt)%kinpw_gather)
1046 : if(bandfft_kpt_in(jkpt)%gpu_option==ABI_GPU_KOKKOS) then
1047 : ABI_MALLOC_MANAGED(bandfft_kpt_out(jkpt)%kinpw_gather,(/sz1/))
1048 : bandfft_kpt_out(jkpt)%kinpw_gather= &
1049 : & bandfft_kpt_in(jkpt)%kinpw_gather
1050 : else
1051 : ABI_MALLOC(bandfft_kpt_out(jkpt)%kinpw_gather,(sz1))
1052 : bandfft_kpt_out(jkpt)%kinpw_gather= &
1053 : & bandfft_kpt_in(jkpt)%kinpw_gather
1054 : end if
1055 : end if
1056 : #else
1057 0 : if (allocated(bandfft_kpt_in(jkpt)%kinpw_gather)) then
1058 0 : sz1=size(bandfft_kpt_in(jkpt)%kinpw_gather)
1059 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%kinpw_gather,(sz1))
1060 : bandfft_kpt_out(jkpt)%kinpw_gather= &
1061 0 : & bandfft_kpt_in(jkpt)%kinpw_gather
1062 : end if
1063 : #endif
1064 :
1065 0 : if (allocated(bandfft_kpt_in(jkpt)%ph3d_gather)) then
1066 0 : sz1=size(bandfft_kpt_in(jkpt)%ph3d_gather,1)
1067 0 : sz2=size(bandfft_kpt_in(jkpt)%ph3d_gather,2)
1068 0 : sz3=size(bandfft_kpt_in(jkpt)%ph3d_gather,3)
1069 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%ph3d_gather,(sz1,sz2,sz3))
1070 : bandfft_kpt_out(jkpt)%ph3d_gather= &
1071 0 : & bandfft_kpt_in(jkpt)%ph3d_gather
1072 : end if
1073 0 : if (allocated(bandfft_kpt_in(jkpt)%kpg_k_gather)) then
1074 0 : sz1=size(bandfft_kpt_in(jkpt)%kpg_k_gather,1)
1075 0 : sz2=size(bandfft_kpt_in(jkpt)%kpg_k_gather,2)
1076 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%kpg_k_gather,(sz1,sz2))
1077 : bandfft_kpt_out(jkpt)%kpg_k_gather= &
1078 0 : & bandfft_kpt_in(jkpt)%kpg_k_gather
1079 : end if
1080 0 : bandfft_kpt_out(jkpt)%flag3_is_allocated=bandfft_kpt_in(jkpt)%flag3_is_allocated
1081 0 : if (allocated(bandfft_kpt_in(jkpt)%kg_k_gather_sym)) then
1082 0 : sz1=size(bandfft_kpt_in(jkpt)%kg_k_gather_sym,1)
1083 0 : sz2=size(bandfft_kpt_in(jkpt)%kg_k_gather_sym,2)
1084 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%kg_k_gather_sym,(sz1,sz2))
1085 : bandfft_kpt_out(jkpt)%kg_k_gather_sym= &
1086 0 : & bandfft_kpt_in(jkpt)%kg_k_gather_sym
1087 : end if
1088 0 : if (allocated(bandfft_kpt_in(jkpt)%rdispls_sym)) then
1089 0 : sz1=size(bandfft_kpt_in(jkpt)%rdispls_sym)
1090 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%rdispls_sym,(sz1))
1091 : bandfft_kpt_out(jkpt)%rdispls_sym= &
1092 0 : & bandfft_kpt_in(jkpt)%rdispls_sym
1093 : end if
1094 0 : if (allocated(bandfft_kpt_in(jkpt)%recvcounts_sym)) then
1095 0 : sz1=size(bandfft_kpt_in(jkpt)%recvcounts_sym)
1096 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%recvcounts_sym,(sz1))
1097 : bandfft_kpt_out(jkpt)%recvcounts_sym= &
1098 0 : & bandfft_kpt_in(jkpt)%recvcounts_sym
1099 : end if
1100 0 : if (allocated(bandfft_kpt_in(jkpt)%recvcounts_sym_tot)) then
1101 0 : sz1=size(bandfft_kpt_in(jkpt)%recvcounts_sym_tot)
1102 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%recvcounts_sym_tot,(sz1))
1103 : bandfft_kpt_out(jkpt)%recvcounts_sym_tot= &
1104 0 : & bandfft_kpt_in(jkpt)%recvcounts_sym_tot
1105 : end if
1106 0 : if (allocated(bandfft_kpt_in(jkpt)%sdispls_sym)) then
1107 0 : sz1=size(bandfft_kpt_in(jkpt)%sdispls_sym)
1108 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%sdispls_sym,(sz1))
1109 : bandfft_kpt_out(jkpt)%sdispls_sym= &
1110 0 : & bandfft_kpt_in(jkpt)%sdispls_sym
1111 : end if
1112 0 : if (allocated(bandfft_kpt_in(jkpt)%sendcounts_sym)) then
1113 0 : sz1=size(bandfft_kpt_in(jkpt)%sendcounts_sym)
1114 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%sendcounts_sym,(sz1))
1115 : bandfft_kpt_out(jkpt)%sendcounts_sym= &
1116 0 : & bandfft_kpt_in(jkpt)%sendcounts_sym
1117 : end if
1118 0 : if (allocated(bandfft_kpt_in(jkpt)%sendcounts_sym_all)) then
1119 0 : sz1=size(bandfft_kpt_in(jkpt)%sendcounts_sym_all)
1120 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%sendcounts_sym_all,(sz1))
1121 : bandfft_kpt_out(jkpt)%sendcounts_sym_all= &
1122 0 : & bandfft_kpt_in(jkpt)%sendcounts_sym_all
1123 : end if
1124 0 : if (allocated(bandfft_kpt_in(jkpt)%tab_proc)) then
1125 0 : sz1=size(bandfft_kpt_in(jkpt)%tab_proc)
1126 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%tab_proc,(sz1))
1127 : bandfft_kpt_out(jkpt)%tab_proc= &
1128 0 : bandfft_kpt_in(jkpt)%tab_proc
1129 : end if
1130 0 : if (bandfft_kpt_in(jkpt)%have_to_reequilibrate) then
1131 0 : bandfft_kpt_out(jkpt)%have_to_reequilibrate = .true.
1132 0 : bandfft_kpt_out(jkpt)%npw_fft = bandfft_kpt_in(jkpt)%npw_fft
1133 0 : sz1=size(bandfft_kpt_in(jkpt)%indices_pw_fft)
1134 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%indices_pw_fft,(sz1))
1135 0 : bandfft_kpt_out(jkpt)%indices_pw_fft=bandfft_kpt_in(jkpt)%indices_pw_fft
1136 0 : sz1=size(bandfft_kpt_in(jkpt)%sendcount_fft)
1137 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%sendcount_fft,(sz1))
1138 0 : bandfft_kpt_out(jkpt)%sendcount_fft=bandfft_kpt_in(jkpt)%sendcount_fft
1139 0 : sz1=size(bandfft_kpt_in(jkpt)%senddisp_fft)
1140 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%senddisp_fft,(sz1))
1141 0 : bandfft_kpt_out(jkpt)%senddisp_fft=bandfft_kpt_in(jkpt)%senddisp_fft
1142 0 : sz1=size(bandfft_kpt_in(jkpt)%recvcount_fft)
1143 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%recvcount_fft,(sz1))
1144 0 : bandfft_kpt_out(jkpt)%recvcount_fft=bandfft_kpt_in(jkpt)%recvcount_fft
1145 0 : sz1=size(bandfft_kpt_in(jkpt)%recvdisp_fft)
1146 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%recvdisp_fft,(sz1))
1147 0 : bandfft_kpt_out(jkpt)%recvdisp_fft=bandfft_kpt_in(jkpt)%recvdisp_fft
1148 0 : sz1=size(bandfft_kpt_in(jkpt)%kg_k_fft,1)
1149 0 : sz2=size(bandfft_kpt_in(jkpt)%kg_k_fft,2)
1150 0 : ABI_MALLOC(bandfft_kpt_out(jkpt)%kg_k_fft,(sz1,sz2))
1151 0 : bandfft_kpt_out(jkpt)%kg_k_fft=bandfft_kpt_in(jkpt)%kg_k_fft
1152 : end if
1153 : end do
1154 : end do
1155 : end if
1156 : end if
1157 :
1158 0 : end subroutine bandfft_kpt_copy
1159 : !!***
1160 :
1161 : !----------------------------------------------------------------------
1162 :
1163 : !!****f* ABINIT/bandfft_kpt_mpi_send
1164 : !! NAME
1165 : !! bandfft_kpt_mpi_send
1166 : !!
1167 : !! FUNCTION
1168 : !! Send a bandfft_kpt_type inside a MPI communicator
1169 : !!
1170 : !! INPUTS
1171 : !! input=The datatype to be transmitted
1172 : !! receiver=ID of the receiver in spaceComm
1173 : !! tag=message tag
1174 : !! spaceComm=MPI Communicator
1175 : !! [profile]=(character, optional, default=full)
1176 : !! Define the part of the datastructure to be sent; possible values:
1177 : !! 'full'= the entire datastructure
1178 : !! 'fourwf'= only arrays needed by the fourwf routine
1179 : !!
1180 : !! OUTPUT
1181 : !! ierr=Error status
1182 : !!
1183 : !! SOURCE
1184 :
1185 0 : subroutine bandfft_kpt_mpi_send(input,receiver,tag,spaceComm,ierr,profile)
1186 :
1187 : !Arguments ------------------------------------
1188 : !scalars
1189 : integer,intent(in) :: receiver,spaceComm,tag
1190 : integer,intent(out) :: ierr
1191 : character(len=*),optional,intent(in) :: profile
1192 : !arrays
1193 : type(bandfft_kpt_type),intent(in) :: input
1194 :
1195 : !Local variables-------------------------------
1196 : !scalars
1197 : integer :: ipck,nsize,size_dp,size_int
1198 : integer :: size1_kg_k_gather=0,size2_kg_k_gather=0,size_recvcounts=0
1199 : integer :: size_sendcounts=0,size_rdispls=0,size_sdispls=0,size1_gbound=0,size2_gbound
1200 : integer :: size1_kg_k_gather_sym=0,size2_kg_k_gather_sym=0,size_rdispls_sym=0
1201 : integer :: size_sdispls_sym=0,size_recvcounts_sym=0,size_recvcounts_sym_tot=0
1202 : integer :: size_sendcounts_sym=0,size_sendcounts_sym_all=0,size_tab_proc=0
1203 : integer :: size_indices_pw_fft=0,size_sendcount_fft=0,size_senddisp_fft=0
1204 : integer :: size_recvcount_fft=0,size_recvdisp_fft=0,size1_kg_k_fft=0,size2_kg_k_fft=0
1205 : integer :: size1_ffnl_gather=0,size2_ffnl_gather=0,size3_ffnl_gather=0,size4_ffnl_gather=0
1206 : integer :: size_kinpw_gather=0,size1_ph3d_gather=0,size2_ph3d_gather=0,size3_ph3d_gather=0
1207 : integer :: size1_kpg_k_gather=0,size2_kpg_k_gather=0
1208 : logical :: fourwf,full
1209 : !arrays
1210 0 : integer,allocatable :: buffer_int(:)
1211 0 : real(dp),allocatable :: buffer_dp(:)
1212 :
1213 : ! *************************************************************************
1214 :
1215 0 : if (xmpi_comm_size(spaceComm)<=1) return
1216 :
1217 0 : fourwf=.false.;if (present(profile)) fourwf=(trim(profile)=='fourwf')
1218 0 : full=(.not.fourwf)
1219 :
1220 : !=== Store sizes ====
1221 : if (fourwf.or.full) then
1222 :
1223 : #if defined HAVE_GPU && defined HAVE_YAKL
1224 : if (associated(input%kg_k_gather)) size1_kg_k_gather=size(input%kg_k_gather,1)
1225 : if (associated(input%kg_k_gather)) size2_kg_k_gather=size(input%kg_k_gather,2)
1226 : #else
1227 0 : if (allocated(input%kg_k_gather)) size1_kg_k_gather=size(input%kg_k_gather,1)
1228 0 : if (allocated(input%kg_k_gather)) size2_kg_k_gather=size(input%kg_k_gather,2)
1229 : #endif
1230 0 : if (input%flag1_is_allocated==1) then
1231 0 : if (allocated(input%recvcounts)) size_recvcounts=size(input%recvcounts)
1232 0 : if (allocated(input%sendcounts)) size_sendcounts=size(input%sendcounts)
1233 0 : if (allocated(input%rdispls)) size_rdispls=size(input%rdispls)
1234 0 : if (allocated(input%sdispls)) size_sdispls=size(input%sdispls)
1235 0 : if (allocated(input%gbound)) size1_gbound=size(input%gbound,1)
1236 0 : if (allocated(input%gbound)) size2_gbound=size(input%gbound,2)
1237 : end if
1238 0 : if (input%flag3_is_allocated==1.and.input%istwf_k>1) then
1239 0 : if (allocated(input%kg_k_gather_sym)) size1_kg_k_gather_sym=size(input%kg_k_gather_sym,1)
1240 0 : if (allocated(input%kg_k_gather_sym)) size2_kg_k_gather_sym=size(input%kg_k_gather_sym,2)
1241 0 : if (allocated(input%rdispls_sym)) size_rdispls_sym=size(input%rdispls_sym)
1242 0 : if (allocated(input%sdispls_sym)) size_sdispls_sym=size(input%sdispls_sym)
1243 0 : if (allocated(input%recvcounts_sym)) size_recvcounts_sym=size(input%recvcounts_sym)
1244 0 : if (allocated(input%recvcounts_sym_tot)) size_recvcounts_sym_tot=size(input%recvcounts_sym_tot)
1245 0 : if (allocated(input%sendcounts_sym)) size_sendcounts_sym=size(input%sendcounts_sym)
1246 0 : if (allocated(input%sendcounts_sym_all)) size_sendcounts_sym_all=size(input%sendcounts_sym_all)
1247 0 : if (allocated(input%tab_proc)) size_tab_proc=size(input%tab_proc)
1248 : end if
1249 0 : if (input%have_to_reequilibrate) then
1250 0 : if (allocated(input%indices_pw_fft)) size_indices_pw_fft=size(input%indices_pw_fft)
1251 0 : if (allocated(input%sendcount_fft)) size_sendcount_fft=size(input%sendcount_fft)
1252 0 : if (allocated(input%senddisp_fft)) size_senddisp_fft=size(input%senddisp_fft)
1253 0 : if (allocated(input%recvcount_fft)) size_recvcount_fft=size(input%recvcount_fft)
1254 0 : if (allocated(input%recvdisp_fft)) size_recvdisp_fft=size(input%recvdisp_fft)
1255 0 : if (allocated(input%kg_k_fft)) size1_kg_k_fft=size(input%kg_k_fft,1)
1256 0 : if (allocated(input%kg_k_fft)) size2_kg_k_fft=size(input%kg_k_fft,2)
1257 : end if
1258 : end if
1259 0 : if (input%flag2_is_allocated==1.and.full) then
1260 0 : if (allocated(input%ffnl_gather)) size1_ffnl_gather=size(input%ffnl_gather,1)
1261 0 : if (allocated(input%ffnl_gather)) size2_ffnl_gather=size(input%ffnl_gather,2)
1262 0 : if (allocated(input%ffnl_gather)) size3_ffnl_gather=size(input%ffnl_gather,3)
1263 0 : if (allocated(input%ffnl_gather)) size4_ffnl_gather=size(input%ffnl_gather,4)
1264 :
1265 : #if defined HAVE_GPU && defined HAVE_YAKL
1266 : if (associated(input%kinpw_gather)) size_kinpw_gather=size(input%kinpw_gather)
1267 : #else
1268 0 : if (allocated(input%kinpw_gather)) size_kinpw_gather=size(input%kinpw_gather)
1269 : #endif
1270 :
1271 0 : if (allocated(input%ph3d_gather)) size1_ph3d_gather=size(input%ph3d_gather,1)
1272 0 : if (allocated(input%ph3d_gather)) size2_ph3d_gather=size(input%ph3d_gather,2)
1273 0 : if (allocated(input%ph3d_gather)) size3_ph3d_gather=size(input%ph3d_gather,3)
1274 0 : if (allocated(input%kpg_k_gather)) size1_kpg_k_gather=size(input%kpg_k_gather,1)
1275 0 : if (allocated(input%kpg_k_gather)) size2_kpg_k_gather=size(input%kpg_k_gather,2)
1276 : end if
1277 :
1278 : !=== Compute amount of data to transmit ====
1279 : size_int=size1_kg_k_gather*size2_kg_k_gather &
1280 : & +size_recvcounts+size_sendcounts+size_rdispls+size_sdispls &
1281 : & +size1_gbound*size2_gbound &
1282 : & +size1_kg_k_gather_sym*size2_kg_k_gather_sym &
1283 : & +size_rdispls_sym+size_sdispls_sym &
1284 : & +size_recvcounts_sym+size_recvcounts_sym_tot &
1285 : & +size_sendcounts_sym+size_sendcounts_sym_all+size_tab_proc &
1286 : & +size_indices_pw_fft+size_sendcount_fft+size_senddisp_fft &
1287 : & +size_recvcount_fft+size_recvdisp_fft &
1288 0 : & +size1_kg_k_fft*size2_kg_k_fft
1289 : size_dp=size1_ffnl_gather*size2_ffnl_gather*size3_ffnl_gather*size4_ffnl_gather &
1290 : & +size_kinpw_gather &
1291 : & +size1_ph3d_gather*size2_ph3d_gather*size3_ph3d_gather &
1292 0 : & +size1_kpg_k_gather*size2_kpg_k_gather
1293 :
1294 : !=== Send flags and array sizes ====
1295 0 : nsize=45
1296 0 : ABI_MALLOC(buffer_int,(nsize))
1297 0 : buffer_int(1)=input%flag1_is_allocated
1298 0 : buffer_int(2)=input%flag2_is_allocated
1299 0 : buffer_int(3)=input%flag3_is_allocated
1300 0 : buffer_int(4)=0;if (input%have_to_reequilibrate) buffer_int(4)=1
1301 0 : buffer_int(5)=input%istwf_k
1302 0 : buffer_int(6)=input%npw_tot
1303 0 : buffer_int(7)=input%npw_fft
1304 0 : buffer_int(8)=input%ndatarecv
1305 0 : buffer_int(9)=input%idatarecv0
1306 0 : buffer_int(10)=input%ndatarecv_tot
1307 0 : buffer_int(11)=input%ndatasend_sym
1308 0 : buffer_int(12)=size_recvcounts
1309 0 : buffer_int(13)=size_sendcounts
1310 0 : buffer_int(14)=size_rdispls
1311 0 : buffer_int(15)=size_sdispls
1312 0 : buffer_int(16)=size1_gbound
1313 0 : buffer_int(17)=size2_gbound
1314 0 : buffer_int(18)=size1_ffnl_gather
1315 0 : buffer_int(19)=size2_ffnl_gather
1316 0 : buffer_int(20)=size3_ffnl_gather
1317 0 : buffer_int(21)=size4_ffnl_gather
1318 0 : buffer_int(22)=size_kinpw_gather
1319 0 : buffer_int(23)=size1_ph3d_gather
1320 0 : buffer_int(24)=size2_ph3d_gather
1321 0 : buffer_int(25)=size3_ph3d_gather
1322 0 : buffer_int(26)=size1_kpg_k_gather
1323 0 : buffer_int(27)=size2_kpg_k_gather
1324 0 : buffer_int(28)=size_indices_pw_fft
1325 0 : buffer_int(29)=size_sendcount_fft
1326 0 : buffer_int(30)=size_senddisp_fft
1327 0 : buffer_int(31)=size_recvcount_fft
1328 0 : buffer_int(32)=size_recvdisp_fft
1329 0 : buffer_int(33)=size1_kg_k_fft
1330 0 : buffer_int(34)=size2_kg_k_fft
1331 0 : buffer_int(35)=size1_kg_k_gather
1332 0 : buffer_int(36)=size2_kg_k_gather
1333 0 : buffer_int(37)=size1_kg_k_gather_sym
1334 0 : buffer_int(38)=size2_kg_k_gather_sym
1335 0 : buffer_int(39)=size_rdispls_sym
1336 0 : buffer_int(40)=size_sdispls_sym
1337 0 : buffer_int(41)=size_recvcounts_sym
1338 0 : buffer_int(42)=size_recvcounts_sym_tot
1339 0 : buffer_int(43)=size_sendcounts_sym
1340 0 : buffer_int(44)=size_sendcounts_sym_all
1341 0 : buffer_int(45)=size_tab_proc
1342 0 : call xmpi_send(buffer_int,receiver,3*tag-2,spaceComm,ierr)
1343 0 : ABI_FREE(buffer_int)
1344 :
1345 : !=== Pack and send integer data ====
1346 0 : if (size_int>0) then
1347 0 : ipck=0
1348 0 : ABI_MALLOC(buffer_int,(size_int))
1349 0 : if (size1_kg_k_gather*size2_kg_k_gather>0) then
1350 0 : nsize=size1_kg_k_gather*size2_kg_k_gather
1351 0 : buffer_int(ipck+1:ipck+nsize)=reshape(input%kg_k_gather(:,:),(/nsize/))
1352 0 : ipck=ipck+nsize
1353 : end if
1354 0 : if (size_recvcounts>0) then
1355 0 : buffer_int(ipck+1:ipck+size_recvcounts)=input%recvcounts(:)
1356 : ipck=ipck+size_recvcounts
1357 : end if
1358 0 : if (size_sendcounts>0) then
1359 0 : buffer_int(ipck+1:ipck+size_sendcounts)=input%sendcounts(:)
1360 : ipck=ipck+size_sendcounts
1361 : end if
1362 0 : if (size_rdispls>0) then
1363 0 : buffer_int(ipck+1:ipck+size_rdispls)=input%rdispls(:)
1364 : ipck=ipck+size_rdispls
1365 : end if
1366 0 : if (size_sdispls>0) then
1367 0 : buffer_int(ipck+1:ipck+size_sdispls)=input%sdispls(:)
1368 : ipck=ipck+size_sdispls
1369 : end if
1370 0 : if (size1_gbound*size2_gbound>0) then
1371 0 : nsize=size1_gbound*size2_gbound
1372 0 : buffer_int(ipck+1:ipck+nsize)=reshape(input%gbound(:,:),(/nsize/))
1373 0 : ipck=ipck+nsize
1374 : end if
1375 0 : if (size1_kg_k_gather_sym*size2_kg_k_gather_sym>0) then
1376 0 : nsize=size1_kg_k_gather_sym*size2_kg_k_gather_sym
1377 0 : buffer_int(ipck+1:ipck+nsize)=reshape(input%kg_k_gather_sym(:,:),(/nsize/))
1378 0 : ipck=ipck+nsize
1379 : end if
1380 0 : if (size_rdispls_sym>0) then
1381 0 : buffer_int(ipck+1:ipck+size_rdispls_sym)=input%rdispls_sym(:)
1382 : ipck=ipck+size_rdispls_sym
1383 : end if
1384 0 : if (size_sdispls_sym>0) then
1385 0 : buffer_int(ipck+1:ipck+size_sdispls_sym)=input%sdispls_sym(:)
1386 : ipck=ipck+size_sdispls_sym
1387 : end if
1388 0 : if (size_recvcounts_sym>0) then
1389 0 : buffer_int(ipck+1:ipck+size_recvcounts_sym)=input%recvcounts_sym(:)
1390 : ipck=ipck+size_recvcounts_sym
1391 : end if
1392 0 : if (size_recvcounts_sym_tot>0) then
1393 0 : buffer_int(ipck+1:ipck+size_recvcounts_sym_tot)=input%recvcounts_sym_tot(:)
1394 : ipck=ipck+size_recvcounts_sym_tot
1395 : end if
1396 0 : if (size_sendcounts_sym>0) then
1397 0 : buffer_int(ipck+1:ipck+size_sendcounts_sym)=input%sendcounts_sym(:)
1398 : ipck=ipck+size_sendcounts_sym
1399 : end if
1400 0 : if (size_sendcounts_sym_all>0) then
1401 0 : buffer_int(ipck+1:ipck+size_sendcounts_sym_all)=input%sendcounts_sym_all(:)
1402 : ipck=ipck+size_sendcounts_sym_all
1403 : end if
1404 0 : if (size_tab_proc>0) then
1405 0 : buffer_int(ipck+1:ipck+size_tab_proc)=input%tab_proc(:)
1406 : ipck=ipck+size_tab_proc
1407 : end if
1408 0 : if (size_indices_pw_fft>0) then
1409 0 : buffer_int(ipck+1:ipck+size_indices_pw_fft)=input%indices_pw_fft(:)
1410 : ipck=ipck+size_indices_pw_fft
1411 : end if
1412 0 : if (size_sendcount_fft>0) then
1413 0 : buffer_int(ipck+1:ipck+size_sendcount_fft)=input%sendcount_fft(:)
1414 : ipck=ipck+size_sendcount_fft
1415 : end if
1416 0 : if (size_senddisp_fft>0) then
1417 0 : buffer_int(ipck+1:ipck+size_senddisp_fft)=input%senddisp_fft(:)
1418 : ipck=ipck+size_senddisp_fft
1419 : end if
1420 0 : if (size_recvcount_fft>0) then
1421 0 : buffer_int(ipck+1:ipck+size_recvcount_fft)=input%recvcount_fft(:)
1422 : ipck=ipck+size_recvcount_fft
1423 : end if
1424 0 : if (size_recvdisp_fft>0) then
1425 0 : buffer_int(ipck+1:ipck+size_recvdisp_fft)=input%recvdisp_fft(:)
1426 : ipck=ipck+size_recvdisp_fft
1427 : end if
1428 0 : if (size1_kg_k_fft*size2_kg_k_fft>0) then
1429 0 : nsize=size1_kg_k_fft*size2_kg_k_fft
1430 0 : buffer_int(ipck+1:ipck+nsize)=reshape(input%kg_k_fft(:,:),(/nsize/))
1431 0 : ipck=ipck+nsize
1432 : end if
1433 0 : call xmpi_send(buffer_int,receiver,3*tag-1,spaceComm,ierr)
1434 0 : ABI_FREE(buffer_int)
1435 : end if
1436 :
1437 : !=== Pack and send real data ====
1438 0 : if (size_dp>0) then
1439 0 : ipck=0
1440 0 : ABI_MALLOC(buffer_dp,(size_dp))
1441 0 : if (size1_ffnl_gather*size2_ffnl_gather*size3_ffnl_gather*size4_ffnl_gather>0) then
1442 0 : nsize=size1_ffnl_gather*size2_ffnl_gather*size3_ffnl_gather*size4_ffnl_gather
1443 0 : buffer_dp(ipck+1:ipck+nsize)=reshape(input%ffnl_gather(:,:,:,:),(/nsize/))
1444 0 : ipck=ipck+nsize
1445 : end if
1446 0 : if (size_kinpw_gather>0) then
1447 0 : buffer_dp(ipck+1:ipck+size_kinpw_gather)=input%kinpw_gather(:)
1448 : ipck=ipck+size_kinpw_gather
1449 : end if
1450 0 : if (size1_ph3d_gather*size2_ph3d_gather*size3_ph3d_gather>0) then
1451 0 : nsize=size1_ph3d_gather*size2_ph3d_gather*size3_ph3d_gather
1452 0 : buffer_dp(ipck+1:ipck+nsize)=reshape(input%ph3d_gather(:,:,:),(/nsize/))
1453 0 : ipck=ipck+nsize
1454 : end if
1455 0 : if (size1_kpg_k_gather*size2_kpg_k_gather>0) then
1456 0 : nsize=size1_kpg_k_gather*size2_kpg_k_gather
1457 0 : buffer_dp(ipck+1:ipck+nsize)=reshape(input%kpg_k_gather(:,:),(/nsize/))
1458 0 : ipck=ipck+nsize
1459 : end if
1460 0 : call xmpi_send(buffer_dp,receiver,3*tag,spaceComm,ierr)
1461 0 : ABI_FREE(buffer_dp)
1462 : end if
1463 :
1464 0 : end subroutine bandfft_kpt_mpi_send
1465 : !!***
1466 :
1467 : !----------------------------------------------------------------------
1468 :
1469 : !!****f* ABINIT/bandfft_kpt_mpi_recv
1470 : !! NAME
1471 : !! bandfft_kpt_mpi_recv
1472 : !!
1473 : !! FUNCTION
1474 : !! Receive a bandfft_kpt_type inside a MPI communicator.
1475 : !!
1476 : !! INPUTS
1477 : !! sender=ID of the sender in spaceComm
1478 : !! tag=message tag
1479 : !! spaceComm=MPI Communicator
1480 : !!
1481 : !! OUTPUT
1482 : !! ierr=Error status
1483 : !! output=# of on proc. sender
1484 : !!
1485 : !! SOURCE
1486 :
1487 0 : subroutine bandfft_kpt_mpi_recv(output,sender,tag,spaceComm,ierr)
1488 :
1489 : !Arguments ------------------------------------
1490 : !scalars
1491 : integer,intent(in) :: sender,spaceComm,tag
1492 : integer,intent(out) :: ierr
1493 : !arrays
1494 : type(bandfft_kpt_type),intent(out) :: output
1495 :
1496 : !Local variables-------------------------------
1497 : !scalars
1498 : integer :: ipck,nsize,size_dp,size_int
1499 : integer :: size1_kg_k_gather=0,size2_kg_k_gather=0,size_recvcounts=0
1500 : integer :: size_sendcounts=0,size_rdispls=0,size_sdispls=0,size1_gbound=0,size2_gbound
1501 : integer :: size1_kg_k_gather_sym=0,size2_kg_k_gather_sym=0,size_rdispls_sym=0
1502 : integer :: size_sdispls_sym=0,size_recvcounts_sym=0,size_recvcounts_sym_tot=0
1503 : integer :: size_sendcounts_sym=0,size_sendcounts_sym_all=0,size_tab_proc=0
1504 : integer :: size_indices_pw_fft=0,size_sendcount_fft=0,size_senddisp_fft=0
1505 : integer :: size_recvcount_fft=0,size_recvdisp_fft=0,size1_kg_k_fft=0,size2_kg_k_fft=0
1506 : integer :: size1_ffnl_gather=0,size2_ffnl_gather=0,size3_ffnl_gather=0,size4_ffnl_gather=0
1507 : integer :: size_kinpw_gather=0,size1_ph3d_gather=0,size2_ph3d_gather=0,size3_ph3d_gather=0
1508 : integer :: size1_kpg_k_gather=0,size2_kpg_k_gather=0,sz1,sz2,sz3,sz4
1509 : !arrays
1510 0 : integer,allocatable :: buffer_int(:)
1511 0 : real(dp),allocatable :: buffer_dp(:)
1512 :
1513 : ! *************************************************************************
1514 :
1515 0 : if (xmpi_comm_size(spaceComm)<=1) return
1516 :
1517 : !=== Receive flags and array sizes ====
1518 0 : nsize=45
1519 0 : ABI_MALLOC(buffer_int,(nsize))
1520 0 : call xmpi_recv(buffer_int,sender,3*tag-2,spaceComm,ierr)
1521 0 : output%flag1_is_allocated=buffer_int(1)
1522 0 : output%flag2_is_allocated=buffer_int(2)
1523 0 : output%flag3_is_allocated=buffer_int(3)
1524 0 : output%have_to_reequilibrate=(buffer_int(4)/=0)
1525 0 : output%istwf_k=buffer_int(5)
1526 0 : output%npw_tot=buffer_int(6)
1527 0 : output%npw_fft=buffer_int(7)
1528 0 : output%ndatarecv=buffer_int(8)
1529 0 : output%idatarecv0=buffer_int(9)
1530 0 : output%ndatarecv_tot=buffer_int(10)
1531 0 : output%ndatasend_sym=buffer_int(11)
1532 0 : size_recvcounts=buffer_int(12)
1533 0 : size_sendcounts=buffer_int(13)
1534 0 : size_rdispls=buffer_int(14)
1535 0 : size_sdispls=buffer_int(15)
1536 0 : size1_gbound=buffer_int(16)
1537 0 : size2_gbound=buffer_int(17)
1538 0 : size1_ffnl_gather=buffer_int(18)
1539 0 : size2_ffnl_gather=buffer_int(19)
1540 0 : size3_ffnl_gather=buffer_int(20)
1541 0 : size4_ffnl_gather=buffer_int(21)
1542 0 : size_kinpw_gather=buffer_int(22)
1543 0 : size1_ph3d_gather=buffer_int(23)
1544 0 : size2_ph3d_gather=buffer_int(24)
1545 0 : size3_ph3d_gather=buffer_int(25)
1546 0 : size1_kpg_k_gather=buffer_int(26)
1547 0 : size2_kpg_k_gather=buffer_int(27)
1548 0 : size_indices_pw_fft=buffer_int(28)
1549 0 : size_sendcount_fft=buffer_int(29)
1550 0 : size_senddisp_fft=buffer_int(30)
1551 0 : size_recvcount_fft=buffer_int(31)
1552 0 : size_recvdisp_fft=buffer_int(32)
1553 0 : size1_kg_k_fft=buffer_int(33)
1554 0 : size2_kg_k_fft=buffer_int(34)
1555 0 : size1_kg_k_gather=buffer_int(35)
1556 0 : size2_kg_k_gather=buffer_int(36)
1557 0 : size1_kg_k_gather_sym=buffer_int(37)
1558 0 : size2_kg_k_gather_sym=buffer_int(38)
1559 0 : size_rdispls_sym=buffer_int(39)
1560 0 : size_sdispls_sym=buffer_int(40)
1561 0 : size_recvcounts_sym=buffer_int(41)
1562 0 : size_recvcounts_sym_tot=buffer_int(42)
1563 0 : size_sendcounts_sym=buffer_int(43)
1564 0 : size_sendcounts_sym_all=buffer_int(44)
1565 0 : size_tab_proc=buffer_int(45)
1566 0 : ABI_FREE(buffer_int)
1567 :
1568 : !=== Compute amount of transmitted data ====
1569 : size_int=size1_kg_k_gather*size2_kg_k_gather &
1570 : & +size_recvcounts+size_sendcounts+size_rdispls+size_sdispls &
1571 : & +size1_gbound*size2_gbound &
1572 : & +size1_kg_k_gather_sym*size2_kg_k_gather_sym &
1573 : & +size_rdispls_sym+size_sdispls_sym &
1574 : & +size_recvcounts_sym+size_recvcounts_sym_tot &
1575 : & +size_sendcounts_sym+size_sendcounts_sym_all+size_tab_proc &
1576 : & +size_indices_pw_fft+size_sendcount_fft+size_senddisp_fft &
1577 : & +size_recvcount_fft+size_recvdisp_fft &
1578 0 : & +size1_kg_k_fft*size2_kg_k_fft
1579 : size_dp=size1_ffnl_gather*size2_ffnl_gather*size3_ffnl_gather*size4_ffnl_gather &
1580 : & +size_kinpw_gather &
1581 : & +size1_ph3d_gather*size2_ph3d_gather*size3_ph3d_gather &
1582 0 : & +size1_kpg_k_gather*size2_kpg_k_gather
1583 :
1584 : !=== Receive and unpack integer data ====
1585 0 : if (size_int>0) then
1586 0 : ipck=0
1587 0 : ABI_MALLOC(buffer_int,(size_int))
1588 0 : call xmpi_recv(buffer_int,sender,3*tag-1,spaceComm,ierr)
1589 :
1590 : #if defined HAVE_GPU && defined HAVE_YAKL
1591 : if (associated(output%kg_k_gather)) then
1592 : if(output%gpu_option==ABI_GPU_KOKKOS) then
1593 : ABI_FREE_MANAGED(output%kg_k_gather)
1594 : else
1595 : ABI_FREE(output%kg_k_gather)
1596 : end if
1597 : end if
1598 : if (size1_kg_k_gather*size2_kg_k_gather>0) then
1599 : nsize=size1_kg_k_gather*size2_kg_k_gather
1600 : sz1=size1_kg_k_gather;sz2=size2_kg_k_gather
1601 : if(output%gpu_option==ABI_GPU_KOKKOS) then
1602 : ABI_MALLOC_MANAGED(output%kg_k_gather,(/sz1,sz2/))
1603 : else
1604 : ABI_MALLOC(output%kg_k_gather,(sz1,sz2))
1605 : end if
1606 : output%kg_k_gather(:,:)=reshape(buffer_int(ipck+1:ipck+nsize),(/sz1,sz2/))
1607 : ipck=ipck+nsize
1608 : end if
1609 : #else
1610 0 : if (allocated(output%kg_k_gather)) then
1611 0 : ABI_FREE(output%kg_k_gather)
1612 : end if
1613 0 : if (size1_kg_k_gather*size2_kg_k_gather>0) then
1614 0 : nsize=size1_kg_k_gather*size2_kg_k_gather
1615 0 : sz1=size1_kg_k_gather;sz2=size2_kg_k_gather
1616 0 : ABI_MALLOC(output%kg_k_gather,(sz1,sz2))
1617 0 : output%kg_k_gather(:,:)=reshape(buffer_int(ipck+1:ipck+nsize),(/sz1,sz2/))
1618 0 : ipck=ipck+nsize
1619 : end if
1620 : #endif
1621 :
1622 0 : ABI_SFREE(output%recvcounts)
1623 0 : if (size_recvcounts>0) then
1624 0 : ABI_MALLOC(output%recvcounts,(size_recvcounts))
1625 0 : output%recvcounts(:)=buffer_int(ipck+1:ipck+size_recvcounts)
1626 : ipck=ipck+size_recvcounts
1627 : end if
1628 0 : ABI_SFREE(output%sendcounts)
1629 0 : if (size_sendcounts>0) then
1630 0 : ABI_MALLOC(output%sendcounts,(size_sendcounts))
1631 0 : output%sendcounts(:)=buffer_int(ipck+1:ipck+size_sendcounts)
1632 : ipck=ipck+size_sendcounts
1633 : end if
1634 0 : ABI_SFREE(output%rdispls)
1635 0 : if (size_rdispls>0) then
1636 0 : ABI_MALLOC(output%rdispls,(size_rdispls))
1637 0 : output%rdispls(:)=buffer_int(ipck+1:ipck+size_rdispls)
1638 : ipck=ipck+size_rdispls
1639 : end if
1640 0 : ABI_SFREE(output%sdispls)
1641 0 : if (size_sdispls>0) then
1642 0 : ABI_MALLOC(output%sdispls,(size_sdispls))
1643 0 : output%sdispls(:)=buffer_int(ipck+1:ipck+size_sdispls)
1644 : ipck=ipck+size_sdispls
1645 : end if
1646 0 : ABI_SFREE(output%gbound)
1647 0 : if (size1_gbound*size2_gbound>0) then
1648 0 : nsize=size1_gbound*size2_gbound
1649 0 : sz1=size1_gbound;sz2=size2_gbound
1650 0 : ABI_MALLOC(output%gbound,(sz1,sz2))
1651 0 : output%gbound(:,:)=reshape(buffer_int(ipck+1:ipck+nsize),(/sz1,sz2/))
1652 0 : ipck=ipck+nsize
1653 : end if
1654 0 : ABI_SFREE(output%kg_k_gather_sym)
1655 0 : if (size1_kg_k_gather_sym*size2_kg_k_gather_sym>0) then
1656 0 : nsize=size1_kg_k_gather_sym*size2_kg_k_gather_sym
1657 0 : sz1=size1_kg_k_gather_sym;sz2=size2_kg_k_gather_sym
1658 0 : ABI_MALLOC(output%kg_k_gather_sym,(sz1,sz2))
1659 0 : output%kg_k_gather_sym(:,:)=reshape(buffer_int(ipck+1:ipck+nsize),(/sz1,sz2/))
1660 0 : ipck=ipck+nsize
1661 : end if
1662 0 : ABI_SFREE(output%rdispls_sym)
1663 0 : if (size_rdispls_sym>0) then
1664 0 : ABI_MALLOC(output%rdispls_sym,(size_rdispls_sym))
1665 0 : output%rdispls_sym(:)=buffer_int(ipck+1:ipck+size_rdispls_sym)
1666 : ipck=ipck+size_rdispls_sym
1667 : end if
1668 0 : ABI_SFREE(output%sdispls_sym)
1669 0 : if (size_sdispls_sym>0) then
1670 0 : ABI_MALLOC(output%sdispls_sym,(size_sdispls_sym))
1671 0 : output%sdispls_sym(:)=buffer_int(ipck+1:ipck+size_sdispls_sym)
1672 : ipck=ipck+size_sdispls_sym
1673 : end if
1674 0 : ABI_SFREE(output%recvcounts_sym)
1675 0 : if (size_recvcounts_sym>0) then
1676 0 : ABI_MALLOC(output%recvcounts_sym,(size_recvcounts_sym))
1677 0 : output%recvcounts_sym(:)=buffer_int(ipck+1:ipck+size_recvcounts_sym)
1678 : ipck=ipck+size_recvcounts_sym
1679 : end if
1680 0 : ABI_SFREE(output%recvcounts_sym_tot)
1681 0 : if (size_recvcounts_sym_tot>0) then
1682 0 : ABI_MALLOC(output%recvcounts_sym_tot,(size_recvcounts_sym_tot))
1683 0 : output%recvcounts_sym_tot(:)=buffer_int(ipck+1:ipck+size_recvcounts_sym_tot)
1684 : ipck=ipck+size_recvcounts_sym_tot
1685 : end if
1686 0 : ABI_SFREE(output%sendcounts_sym)
1687 0 : if (size_sendcounts_sym>0) then
1688 0 : ABI_MALLOC(output%sendcounts_sym,(size_sendcounts_sym))
1689 0 : output%sendcounts_sym(:)=buffer_int(ipck+1:ipck+size_sendcounts_sym)
1690 : ipck=ipck+size_sendcounts_sym
1691 : end if
1692 0 : ABI_SFREE(output%sendcounts_sym_all)
1693 0 : if (size_sendcounts_sym_all>0) then
1694 0 : ABI_MALLOC(output%sendcounts_sym_all,(size_sendcounts_sym_all))
1695 0 : output%sendcounts_sym_all(:)=buffer_int(ipck+1:ipck+size_sendcounts_sym_all)
1696 : ipck=ipck+size_sendcounts_sym_all
1697 : end if
1698 0 : ABI_SFREE(output%tab_proc)
1699 0 : if (size_tab_proc>0) then
1700 0 : ABI_MALLOC(output%tab_proc,(size_tab_proc))
1701 0 : output%tab_proc(:)=buffer_int(ipck+1:ipck+size_tab_proc)
1702 : ipck=ipck+size_tab_proc
1703 : end if
1704 0 : ABI_SFREE(output%indices_pw_fft)
1705 0 : if (size_indices_pw_fft>0) then
1706 0 : ABI_MALLOC(output%indices_pw_fft,(size_indices_pw_fft))
1707 0 : output%indices_pw_fft(:)=buffer_int(ipck+1:ipck+size_indices_pw_fft)
1708 : ipck=ipck+size_indices_pw_fft
1709 : end if
1710 0 : ABI_SFREE(output%sendcount_fft)
1711 0 : if (size_sendcount_fft>0) then
1712 0 : ABI_MALLOC(output%sendcount_fft,(size_sendcount_fft))
1713 0 : output%sendcount_fft(:)=buffer_int(ipck+1:ipck+size_sendcount_fft)
1714 : ipck=ipck+size_sendcount_fft
1715 : end if
1716 0 : ABI_SFREE(output%senddisp_fft)
1717 0 : if (size_senddisp_fft>0) then
1718 0 : ABI_MALLOC(output%senddisp_fft,(size_senddisp_fft))
1719 0 : output%senddisp_fft(:)=buffer_int(ipck+1:ipck+size_senddisp_fft)
1720 : ipck=ipck+size_senddisp_fft
1721 : end if
1722 0 : ABI_SFREE(output%recvcount_fft)
1723 0 : if (size_recvcount_fft>0) then
1724 0 : ABI_MALLOC(output%recvcount_fft,(size_recvcount_fft))
1725 0 : output%recvcount_fft(:)=buffer_int(ipck+1:ipck+size_recvcount_fft)
1726 : ipck=ipck+size_recvcount_fft
1727 : end if
1728 0 : ABI_SFREE(output%recvdisp_fft)
1729 0 : if (size_recvdisp_fft>0) then
1730 0 : ABI_MALLOC(output%recvdisp_fft,(size_recvdisp_fft))
1731 0 : output%recvdisp_fft(:)=buffer_int(ipck+1:ipck+size_recvdisp_fft)
1732 : ipck=ipck+size_recvdisp_fft
1733 : end if
1734 0 : ABI_SFREE(output%kg_k_fft)
1735 0 : if (size1_kg_k_fft*size2_kg_k_fft>0) then
1736 0 : nsize=size1_kg_k_fft*size2_kg_k_fft
1737 0 : sz1=size1_kg_k_fft;sz2=size2_kg_k_fft
1738 0 : ABI_MALLOC(output%kg_k_fft,(sz1,sz2))
1739 0 : output%kg_k_fft(:,:)=reshape(buffer_int(ipck+1:ipck+nsize),(/sz1,sz2/))
1740 0 : ipck=ipck+nsize
1741 : end if
1742 0 : ABI_FREE(buffer_int)
1743 : end if
1744 :
1745 : !=== Receive and unpack real data ====
1746 0 : if (size_dp>0) then
1747 0 : ipck=0
1748 0 : ABI_MALLOC(buffer_dp,(size_dp))
1749 0 : call xmpi_recv(buffer_dp,sender,3*tag,spaceComm,ierr)
1750 0 : ABI_SFREE(output%ffnl_gather)
1751 0 : if (size1_ffnl_gather*size2_ffnl_gather*size3_ffnl_gather*size4_ffnl_gather>0) then
1752 0 : nsize=size1_ffnl_gather*size2_ffnl_gather*size3_ffnl_gather*size4_ffnl_gather
1753 0 : sz1=size1_ffnl_gather;sz2=size2_ffnl_gather;sz3=size3_ffnl_gather;sz4=size4_ffnl_gather
1754 0 : ABI_MALLOC(output%ffnl_gather,(sz1,sz2,sz3,sz4))
1755 0 : output%ffnl_gather(:,:,:,:)=reshape(buffer_dp(ipck+1:ipck+nsize),(/sz1,sz2,sz3,sz4/))
1756 0 : ipck=ipck+nsize
1757 : end if
1758 :
1759 : #if defined HAVE_GPU && defined HAVE_YAKL
1760 : if (associated(output%kinpw_gather)) then
1761 : if(output%gpu_option==ABI_GPU_KOKKOS) then
1762 : ABI_FREE_MANAGED(output%kinpw_gather)
1763 : else
1764 : ABI_FREE(output%kinpw_gather)
1765 : endif
1766 : end if
1767 : if (size_kinpw_gather>0) then
1768 : if(output%gpu_option==ABI_GPU_KOKKOS) then
1769 : ABI_MALLOC_MANAGED(output%kinpw_gather,(/size_kinpw_gather/))
1770 : else
1771 : ABI_MALLOC(output%kinpw_gather,(size_kinpw_gather))
1772 : endif
1773 : output%kinpw_gather(:)=buffer_dp(ipck+1:ipck+size_kinpw_gather)
1774 : ipck=ipck+size_kinpw_gather
1775 : end if
1776 : #else
1777 0 : ABI_SFREE(output%kinpw_gather)
1778 0 : if (size_kinpw_gather>0) then
1779 0 : ABI_MALLOC(output%kinpw_gather,(size_kinpw_gather))
1780 0 : output%kinpw_gather(:)=buffer_dp(ipck+1:ipck+size_kinpw_gather)
1781 : ipck=ipck+size_kinpw_gather
1782 : end if
1783 : #endif
1784 :
1785 0 : ABI_SFREE(output%ph3d_gather)
1786 0 : if (size1_ph3d_gather*size2_ph3d_gather*size3_ph3d_gather>0) then
1787 0 : nsize=size1_ph3d_gather*size2_ph3d_gather*size3_ph3d_gather
1788 0 : sz1=size1_ph3d_gather;sz2=size2_ph3d_gather;sz3=size3_ph3d_gather
1789 0 : ABI_MALLOC(output%ph3d_gather,(sz1,sz2,sz3))
1790 0 : output%ph3d_gather(:,:,:)=reshape(buffer_dp(ipck+1:ipck+nsize),(/sz1,sz2,sz3/))
1791 0 : ipck=ipck+nsize
1792 : end if
1793 0 : ABI_SFREE(output%kpg_k_gather)
1794 0 : if (size1_kpg_k_gather*size2_kpg_k_gather>0) then
1795 0 : nsize=size1_kpg_k_gather*size2_kpg_k_gather
1796 0 : sz1=size1_kpg_k_gather;sz2=size2_kpg_k_gather
1797 0 : ABI_MALLOC(output%kpg_k_gather,(sz1,sz2))
1798 0 : output%kpg_k_gather(:,:)=reshape(buffer_dp(ipck+1:ipck+nsize),(/sz1,sz2/))
1799 0 : ipck=ipck+nsize
1800 : end if
1801 0 : ABI_FREE(buffer_dp)
1802 : end if
1803 :
1804 0 : end subroutine bandfft_kpt_mpi_recv
1805 : !!***
1806 :
1807 : !----------------------------------------------------------------------
1808 :
1809 : !!****f* m_bandfft_kpt/bandfft_kpt_savetabs
1810 : !! NAME
1811 : !! bandfft_kpt_savetabs
1812 : !!
1813 : !! FUNCTION
1814 : !! Save some (kpt-dependent) tabs from a bandfft_kpt datastructure
1815 : !!
1816 : !! INPUTS
1817 : !! bandfft_kpt_in=<type(bandfft_kpt)>=bandfft_kpt datastructure
1818 : !!
1819 : !! OUTPUT
1820 : !! ffnl(:,:,:,:)=nonlocal form factors on basis sphere
1821 : !! ph3d(:,:,:)=3-dim structure factors, for each atom and plane wave
1822 : !! kpg(:,:)=k+G vector for a given k point
1823 : !! kinpw(:)=kinetic energy for each plane wave (Hartree)
1824 : !!
1825 : !! SOURCE
1826 :
1827 2950 : subroutine bandfft_kpt_savetabs(bandfft_kpt_in,ffnl,ph3d,kpg,kinpw)
1828 :
1829 : !Arguments -------------------------------
1830 : type(bandfft_kpt_type),intent(inout) :: bandfft_kpt_in
1831 : real(dp),intent(inout),allocatable,optional :: ffnl(:,:,:,:),ph3d(:,:,:),kpg(:,:),kinpw(:)
1832 : !Local variables-------------------------------
1833 : integer :: is1,is2,is3,is4
1834 :
1835 : ! *********************************************************************
1836 :
1837 2950 : if (present(ffnl)) then
1838 2950 : ABI_SFREE(ffnl)
1839 2950 : if (allocated(bandfft_kpt_in%ffnl_gather)) then
1840 2950 : is1=size(bandfft_kpt_in%ffnl_gather,1)
1841 2950 : is2=size(bandfft_kpt_in%ffnl_gather,2)
1842 2950 : is3=size(bandfft_kpt_in%ffnl_gather,3)
1843 2950 : is4=size(bandfft_kpt_in%ffnl_gather,4)
1844 17700 : ABI_MALLOC(ffnl,(is1,is2,is3,is4))
1845 13553290 : ffnl(:,:,:,:)=bandfft_kpt_in%ffnl_gather(:,:,:,:)
1846 : end if
1847 : end if
1848 2950 : if (present(ph3d)) then
1849 2950 : ABI_SFREE(ph3d)
1850 2950 : if (allocated(bandfft_kpt_in%ph3d_gather)) then
1851 2950 : is1=size(bandfft_kpt_in%ph3d_gather,1)
1852 2950 : is2=size(bandfft_kpt_in%ph3d_gather,2)
1853 2950 : is3=size(bandfft_kpt_in%ph3d_gather,3)
1854 14750 : ABI_MALLOC(ph3d,(is1,is2,is3))
1855 12270736 : ph3d(:,:,:)=bandfft_kpt_in%ph3d_gather(:,:,:)
1856 : end if
1857 : end if
1858 2950 : if (present(kpg)) then
1859 2950 : ABI_SFREE(kpg)
1860 2950 : if (allocated(bandfft_kpt_in%kpg_k_gather)) then
1861 2950 : is1=size(bandfft_kpt_in%kpg_k_gather,1)
1862 2950 : is2=size(bandfft_kpt_in%kpg_k_gather,2)
1863 11800 : ABI_MALLOC(kpg,(is1,is2))
1864 918799 : kpg(:,:)=bandfft_kpt_in%kpg_k_gather(:,:)
1865 : end if
1866 : end if
1867 2950 : if (present(kinpw)) then
1868 0 : ABI_SFREE(kinpw)
1869 :
1870 : #if defined HAVE_GPU && defined HAVE_YAKL
1871 : if (associated(bandfft_kpt_in%kinpw_gather)) then
1872 : is1=size(bandfft_kpt_in%kinpw_gather,1)
1873 : ABI_MALLOC(kinpw,(is1))
1874 : kinpw(:)=bandfft_kpt_in%kinpw_gather(:)
1875 : end if
1876 : #else
1877 0 : if (allocated(bandfft_kpt_in%kinpw_gather)) then
1878 0 : is1=size(bandfft_kpt_in%kinpw_gather,1)
1879 0 : ABI_MALLOC(kinpw,(is1))
1880 0 : kinpw(:)=bandfft_kpt_in%kinpw_gather(:)
1881 : end if
1882 : #endif
1883 :
1884 : end if
1885 :
1886 2950 : end subroutine bandfft_kpt_savetabs
1887 : !!***
1888 :
1889 : !----------------------------------------------------------------------
1890 :
1891 : !!****f* m_bandfft_kpt/bandfft_kpt_restoretabs
1892 : !! NAME
1893 : !! bandfft_kpt_restoretabs
1894 : !!
1895 : !! FUNCTION
1896 : !! Restore some (kpt-dependent) tabs into a bandfft_kpt datastructure
1897 : !!
1898 : !! INPUT
1899 : !!
1900 : !! OUTPUT
1901 : !! === Arrays to be eventually restored =====
1902 : !! ffnl(:,:,:,:)=nonlocal form factors on basis sphere
1903 : !! ph3d(:,:,:)=3-dim structure factors, for each atom and plane wave
1904 : !! kpg(:,:)=k+G vector for a given k point
1905 : !! kinpw(:)=kinetic energy for each plane wave (Hartree)
1906 : !!
1907 : !! SIDE EFFECTS
1908 : !! bandfft_kpt_out=<type(bandfft_kpt)>=bandfft_kpt datastructure
1909 : !!
1910 : !! SOURCE
1911 :
1912 3764 : subroutine bandfft_kpt_restoretabs(bandfft_kpt_out,ffnl,ph3d,kpg,kinpw)
1913 :
1914 : !Arguments -------------------------------
1915 : type(bandfft_kpt_type),intent(inout) :: bandfft_kpt_out
1916 : real(dp),intent(inout),allocatable,optional :: ffnl(:,:,:,:),ph3d(:,:,:),kpg(:,:),kinpw(:)
1917 : !Local variables-------------------------------
1918 : integer :: is1,is2,is3,is4
1919 :
1920 : ! *********************************************************************
1921 :
1922 3764 : if (present(ffnl)) then
1923 3764 : ABI_SFREE(bandfft_kpt_out%ffnl_gather)
1924 3764 : if (allocated(ffnl)) then
1925 2950 : is1=size(ffnl,1)
1926 2950 : is2=size(ffnl,2)
1927 2950 : is3=size(ffnl,3)
1928 2950 : is4=size(ffnl,4)
1929 17700 : ABI_MALLOC(bandfft_kpt_out%ffnl_gather,(is1,is2,is3,is4))
1930 13553290 : bandfft_kpt_out%ffnl_gather(:,:,:,:)=ffnl(:,:,:,:)
1931 2950 : ABI_FREE(ffnl)
1932 2950 : bandfft_kpt_out%flag2_is_allocated=1
1933 : end if
1934 : end if
1935 3764 : if (present(ph3d)) then
1936 3764 : ABI_SFREE(bandfft_kpt_out%ph3d_gather)
1937 3764 : if (allocated(ph3d)) then
1938 2950 : is1=size(ph3d,1)
1939 2950 : is2=size(ph3d,2)
1940 2950 : is3=size(ph3d,3)
1941 14750 : ABI_MALLOC(bandfft_kpt_out%ph3d_gather,(is1,is2,is3))
1942 12270736 : bandfft_kpt_out%ph3d_gather(:,:,:)=ph3d(:,:,:)
1943 2950 : ABI_FREE(ph3d)
1944 2950 : bandfft_kpt_out%flag2_is_allocated=1
1945 : end if
1946 : end if
1947 3764 : if (present(kpg)) then
1948 3764 : ABI_SFREE(bandfft_kpt_out%kpg_k_gather)
1949 3764 : if (allocated(kpg)) then
1950 2950 : is1=size(kpg,1)
1951 2950 : is2=size(kpg,2)
1952 11800 : ABI_MALLOC(bandfft_kpt_out%kpg_k_gather,(is1,is2))
1953 918799 : bandfft_kpt_out%kpg_k_gather(:,:)=kpg(:,:)
1954 2950 : ABI_FREE(kpg)
1955 2950 : bandfft_kpt_out%flag2_is_allocated=1
1956 : end if
1957 : end if
1958 3764 : if (present(kinpw)) then
1959 :
1960 : #if defined HAVE_GPU && defined HAVE_YAKL
1961 : if (associated(bandfft_kpt_out%kinpw_gather)) then
1962 : if(bandfft_kpt_out%gpu_option==ABI_GPU_KOKKOS) then
1963 : ABI_FREE_MANAGED(bandfft_kpt_out%kinpw_gather)
1964 : else
1965 : ABI_FREE(bandfft_kpt_out%kinpw_gather)
1966 : end if
1967 : end if
1968 : if (allocated(kinpw)) then
1969 : is1=size(kinpw,1)
1970 : if(bandfft_kpt_out%gpu_option==ABI_GPU_KOKKOS) then
1971 : ABI_MALLOC_MANAGED(bandfft_kpt_out%kinpw_gather,(/is1/))
1972 : else
1973 : ABI_MALLOC(bandfft_kpt_out%kinpw_gather,(is1))
1974 : end if
1975 : bandfft_kpt_out%kinpw_gather(:)=kinpw(:)
1976 : ABI_FREE(kinpw)
1977 : end if
1978 : #else
1979 0 : ABI_SFREE(bandfft_kpt_out%kinpw_gather)
1980 0 : if (allocated(kinpw)) then
1981 0 : is1=size(kinpw,1)
1982 0 : ABI_MALLOC(bandfft_kpt_out%kinpw_gather,(is1))
1983 0 : bandfft_kpt_out%kinpw_gather(:)=kinpw(:)
1984 0 : ABI_FREE(kinpw)
1985 : end if
1986 : #endif
1987 :
1988 : end if
1989 :
1990 3764 : end subroutine bandfft_kpt_restoretabs
1991 : !!***
1992 :
1993 : !----------------------------------------------------------------------
1994 :
1995 : !!****f* m_bandfft_kpt/bandfft_kpt_set_ikpt
1996 : !! NAME
1997 : !! bandfft_kpt_set_ikpt
1998 : !!
1999 : !! FUNCTION
2000 : !! Set the value of bandfft_kpt_current_ikpt variable,
2001 : !! i.e. current index of bandfft_kpt loaded in memory
2002 : !!
2003 : !! INPUT
2004 : !! ikpt=index of k-point (in the global array dtset%kpt)
2005 : !! mpi_enreg= information about MPI parallelization
2006 : !!
2007 : !! OUTPUT
2008 : !! bandfft_kpt_current_ikpt value changed
2009 : !!
2010 : !! SOURCE
2011 :
2012 393557 : subroutine bandfft_kpt_set_ikpt(ikpt,mpi_enreg)
2013 :
2014 : !Arguments -------------------------------
2015 : integer,intent(in) :: ikpt
2016 : type(MPI_type),intent(in) :: mpi_enreg
2017 : !Local variables-------------------------------
2018 :
2019 : ! *********************************************************************
2020 :
2021 380415 : if (ikpt>0) then
2022 389069 : bandfft_kpt_current_ikpt=mpi_enreg%my_kpttab(ikpt)
2023 : else
2024 4488 : bandfft_kpt_current_ikpt=-1
2025 : end if
2026 :
2027 380415 : end subroutine bandfft_kpt_set_ikpt
2028 : !!***
2029 :
2030 : !----------------------------------------------------------------------
2031 :
2032 : !!****f* m_bandfft_kpt/bandfft_kpt_get_ikpt
2033 : !! NAME
2034 : !! bandfft_kpt_get_ikpt
2035 : !!
2036 : !! FUNCTION
2037 : !! Get the value of bandfft_kpt_current_ikpt variable,
2038 : !! i.e. current index of bandfft_kpt loaded in memory
2039 : !!
2040 : !! INPUT
2041 : !!
2042 : !! OUTPUT
2043 : !! bandfft_kpt_get_ikpt= current index of bandfft_kpt
2044 : !!
2045 : !! SOURCE
2046 :
2047 1573327 : function bandfft_kpt_get_ikpt()
2048 :
2049 : !Arguments -------------------------------
2050 : integer :: bandfft_kpt_get_ikpt
2051 : !Local variables-------------------------------
2052 :
2053 : ! *********************************************************************
2054 :
2055 1573327 : bandfft_kpt_get_ikpt=bandfft_kpt_current_ikpt
2056 :
2057 1573327 : end function bandfft_kpt_get_ikpt
2058 : !!***
2059 :
2060 : !!****f* ABINIT/prep_bandfft_tabs
2061 : !! NAME
2062 : !! prep_bandfft_tabs
2063 : !!
2064 : !! FUNCTION
2065 : !! This routine transpose various tabs needed in bandfft parallelization
2066 : !!
2067 : !! INPUTS
2068 : !! ikpt=index of the k-point
2069 : !! gs_hamk <type(gs_hamiltonian_type)>=all data for the Hamiltonian at k
2070 : !! mkmem=number of k points which can fit in memory; set to 0 if use disk
2071 : !!
2072 : !! SIDE EFFECTS
2073 : !! bandfft_kpt tabs (defined in m_bandfft_kpt module)
2074 : !!
2075 : !! SOURCE
2076 :
2077 :
2078 13142 : subroutine prep_bandfft_tabs(gs_hamk,ikpt,mkmem,mpi_enreg)
2079 :
2080 : !Arguments -------------------------------
2081 : integer,intent(in) :: ikpt,mkmem
2082 : type(gs_hamiltonian_type),intent(inout) :: gs_hamk
2083 : type(MPI_type),intent(inout) :: mpi_enreg
2084 :
2085 : !Local variables-------------------------------
2086 : integer :: dimffnl,ierr,ikpt_this_proc,ipw,lmnmax,matblk,ndatarecv,nkpg,npw_k,ntypat,spaceComm
2087 : logical :: tabs_allocated
2088 : real(dp) :: tsec(2)
2089 : character(len=500) :: message
2090 13142 : integer, allocatable :: recvcounts(:),rdispls(:)
2091 13142 : integer, allocatable :: recvcountsloc(:),rdisplsloc(:)
2092 13142 : real(dp),allocatable :: ffnl_gather(:,:,:,:),ffnl_little(:,:,:,:),ffnl_little_gather(:,:,:,:)
2093 13142 : real(dp),allocatable :: kinpw_gather(:),kpg_k_gather(:,:)
2094 13142 : real(dp),allocatable :: ph3d_gather(:,:,:),ph3d_little(:,:,:),ph3d_little_gather(:,:,:)
2095 :
2096 : ! *********************************************************************
2097 :
2098 13142 : call timab(575,1,tsec)
2099 :
2100 13142 : ikpt_this_proc=mpi_enreg%my_kpttab(ikpt)
2101 : tabs_allocated=((bandfft_kpt(ikpt_this_proc)%flag1_is_allocated==1).and.&
2102 13142 : & (ikpt_this_proc <= mkmem).and.(ikpt_this_proc/=0))
2103 :
2104 : if (.not.tabs_allocated) then
2105 0 : message = ' the bandfft tabs are not allocated !'
2106 0 : ABI_BUG(message)
2107 : end if
2108 :
2109 13142 : ntypat=gs_hamk%ntypat
2110 13142 : lmnmax=gs_hamk%lmnmax
2111 13142 : matblk=gs_hamk%matblk
2112 13142 : npw_k=gs_hamk%npw_k
2113 13142 : dimffnl=size(gs_hamk%ffnl_k,2)
2114 13142 : nkpg=size(gs_hamk%kpg_k,2)
2115 :
2116 39426 : ABI_MALLOC(rdispls,(mpi_enreg%nproc_band))
2117 26284 : ABI_MALLOC(recvcounts,(mpi_enreg%nproc_band))
2118 26284 : ABI_MALLOC(rdisplsloc,(mpi_enreg%nproc_band))
2119 26284 : ABI_MALLOC(recvcountsloc,(mpi_enreg%nproc_band))
2120 :
2121 13142 : spaceComm =mpi_enreg%comm_band
2122 13142 : ndatarecv =bandfft_kpt(ikpt_this_proc)%ndatarecv
2123 43084 : rdispls(:) =bandfft_kpt(ikpt_this_proc)%rdispls(:)
2124 43084 : recvcounts(:)=bandfft_kpt(ikpt_this_proc)%recvcounts(:)
2125 :
2126 : !---- Process FFNL
2127 13142 : if (associated(gs_hamk%ffnl_k)) then
2128 78852 : ABI_MALLOC(ffnl_gather,(ndatarecv,dimffnl,lmnmax,ntypat))
2129 78852 : ABI_MALLOC(ffnl_little,(dimffnl,lmnmax,ntypat,npw_k))
2130 78852 : ABI_MALLOC(ffnl_little_gather,(dimffnl,lmnmax,ntypat,ndatarecv))
2131 1423061 : do ipw=1,npw_k
2132 62050313 : ffnl_little(:,:,:,ipw)=gs_hamk%ffnl_k(ipw,:,:,:)
2133 : end do
2134 43084 : recvcountsloc(:)=recvcounts(:)*dimffnl*lmnmax*ntypat
2135 43084 : rdisplsloc(:)=rdispls(:)*dimffnl*lmnmax*ntypat
2136 : call xmpi_allgatherv(ffnl_little,npw_k*dimffnl*lmnmax*ntypat,ffnl_little_gather,&
2137 13142 : & recvcountsloc(:),rdisplsloc,spaceComm,ierr)
2138 2674274 : do ipw=1,ndatarecv
2139 117357816 : ffnl_gather(ipw,:,:,:)=ffnl_little_gather(:,:,:,ipw)
2140 : end do
2141 13142 : ABI_FREE(ffnl_little)
2142 13142 : ABI_FREE(ffnl_little_gather)
2143 : else
2144 0 : ABI_MALLOC(ffnl_gather,(0,0,0,0))
2145 : end if
2146 :
2147 : !---- Process PH3D
2148 13142 : if (associated(gs_hamk%ph3d_k)) then
2149 52568 : ABI_MALLOC(ph3d_gather,(2,ndatarecv,matblk))
2150 52568 : ABI_MALLOC(ph3d_little,(2,matblk,npw_k))
2151 52568 : ABI_MALLOC(ph3d_little_gather,(2,matblk,ndatarecv))
2152 43084 : recvcountsloc(:)=recvcounts(:)*2*matblk
2153 43084 : rdisplsloc(:)=rdispls(:)*2*matblk
2154 1423061 : do ipw=1,npw_k
2155 19586312 : ph3d_little(:,:,ipw)=gs_hamk%ph3d_k(:,ipw,:)
2156 : end do
2157 : call xmpi_allgatherv(ph3d_little,npw_k*2*matblk,ph3d_little_gather,&
2158 13142 : & recvcountsloc(:),rdisplsloc,spaceComm,ierr)
2159 2674274 : do ipw=1,ndatarecv
2160 36504896 : ph3d_gather(:,ipw,:)=ph3d_little_gather(:,:,ipw)
2161 : end do
2162 13142 : ABI_FREE(ph3d_little_gather)
2163 13142 : ABI_FREE(ph3d_little)
2164 : else
2165 0 : ABI_MALLOC(ph3d_gather,(0,0,0))
2166 : end if
2167 :
2168 : !---- Process KPG_K
2169 13142 : if (associated(gs_hamk%kpg_k)) then
2170 52568 : ABI_MALLOC(kpg_k_gather,(ndatarecv,nkpg))
2171 13142 : if (nkpg>0) then
2172 3467 : call mkkpg(bandfft_kpt(ikpt_this_proc)%kg_k_gather,kpg_k_gather,gs_hamk%kpt_k,nkpg,ndatarecv)
2173 : end if
2174 : else
2175 0 : ABI_MALLOC(kpg_k_gather,(0,0))
2176 : end if
2177 :
2178 : !---- Process KINPW
2179 13142 : if (associated(gs_hamk%kinpw_k)) then
2180 30576 : ABI_MALLOC(kinpw_gather,(ndatarecv))
2181 33160 : recvcountsloc(:)=recvcounts(:)
2182 33160 : rdisplsloc(:)=rdispls(:)
2183 10192 : call xmpi_allgatherv(gs_hamk%kinpw_k,npw_k,kinpw_gather,recvcountsloc(:),rdisplsloc,spaceComm,ierr)
2184 : else
2185 2950 : ABI_MALLOC(kinpw_gather,(0))
2186 : end if
2187 :
2188 13142 : ABI_FREE(recvcounts)
2189 13142 : ABI_FREE(rdispls)
2190 13142 : ABI_FREE(recvcountsloc)
2191 13142 : ABI_FREE(rdisplsloc)
2192 :
2193 : call bandfft_kpt_init2(bandfft_kpt,dimffnl,ffnl_gather,ikpt_this_proc,kinpw_gather,kpg_k_gather,&
2194 13142 : & lmnmax,matblk,mkmem,ndatarecv,nkpg,ntypat,ph3d_gather)
2195 :
2196 13142 : ABI_FREE(ffnl_gather)
2197 13142 : ABI_FREE(ph3d_gather)
2198 13142 : ABI_FREE(kinpw_gather)
2199 13142 : ABI_FREE(kpg_k_gather)
2200 :
2201 : !---- Store current kpt index
2202 13142 : call bandfft_kpt_set_ikpt(ikpt,mpi_enreg)
2203 :
2204 13142 : call timab(575,2,tsec)
2205 :
2206 13142 : end subroutine prep_bandfft_tabs
2207 : !!***
2208 :
2209 0 : END MODULE m_bandfft_kpt
2210 : !!***
|
