Line data Source code
1 : !****m* ABINIT/m_wfd
2 : !! NAME
3 : !! m_wfd
4 : !!
5 : !! FUNCTION
6 : !! This module contains the declaration of the wfd_t object.
7 : !! The wfd_t is a container of Bloch states (wave_t).
8 : !! It provides a high-level API to perform FFT transforms G --> R, compute PAW projections, etc.
9 : !!
10 : !! COPYRIGHT
11 : !! Copyright (C) 2008-2026 ABINIT group (MG)
12 : !! This file is distributed under the terms of the
13 : !! GNU General Public License, see ~abinit/COPYING
14 : !! or http://www.gnu.org/copyleft/gpl.txt .
15 : !!
16 : !! SOURCE
17 :
18 : #if defined HAVE_CONFIG_H
19 : #include "config.h"
20 : #endif
21 :
22 : #include "abi_common.h"
23 :
24 : module m_wfd
25 :
26 : use, intrinsic :: iso_c_binding
27 : use defs_basis
28 : use m_abicore
29 : use m_xmpi
30 : use m_copy
31 : use m_errors
32 : use m_crystal
33 : use m_wfk
34 : use m_hdr
35 : use m_cgtools
36 : use m_ebands
37 :
38 : use defs_datatypes, only : pseudopotential_type
39 : use defs_abitypes, only : mpi_type
40 : use m_gwdefs, only : one_gw
41 : use m_time, only : cwtime, cwtime_report, timab
42 : use m_fstrings, only : toupper, firstchar, int2char10, sjoin, itoa, strcat, itoa, yesno, ltoa, ktoa, ftoa
43 : use m_io_tools, only : get_unit, iomode_from_fname, iomode2str, open_file
44 : use m_numeric_tools, only : imin_loc, list2blocks, bool2index
45 : use m_hide_blas, only : xcopy, xdotc
46 : use m_pptools, only : printxsf
47 : use m_cgtk, only : cgtk_change_gsphere, cgtk_rotate
48 : use m_fftcore, only : print_ngfft, kgindex, sphereboundary, ngfft_seq
49 : use m_fft_mesh, only : rotate_fft_mesh, calc_ceikr, check_rot_fft
50 : use m_fft, only : fft_ug
51 : use m_kg, only : getph, ph1d3d, mkkpg
52 : use m_gsphere, only : kg_map, make_istwfk_table
53 : use m_fftcore, only : kpgsph, get_kg
54 : use m_mpinfo, only : nullify_mpi_enreg, destroy_mpi_enreg, copy_mpi_enreg, initmpi_seq
55 : use m_bz_mesh, only : kmesh_t
56 : use m_pawrad, only : pawrad_type
57 : use m_pawtab, only : pawtab_type, pawtab_get_lsize
58 : use m_pawfgrtab, only : pawfgrtab_type, pawfgrtab_init, pawfgrtab_free, pawfgrtab_print
59 : use m_pawcprj, only : pawcprj_type, pawcprj_alloc, pawcprj_free, pawcprj_copy, paw_overlap
60 : use m_paw_pwaves_lmn, only : paw_pwaves_lmn_t, paw_pwaves_lmn_init, paw_pwaves_lmn_free
61 : use m_pawrhoij, only : pawrhoij_type, pawrhoij_mpisum_unpacked, pawrhoij_print_rhoij
62 : use m_paw_nhat, only : nhatgrid
63 : use m_paw_occupancies,only : pawaccrhoij
64 : use m_iterators, only : iter2_t, iter_yield, iter_len, iter_free, iter_push, iter_alloc
65 : use m_spacepar, only : symrhg, irrzg
66 : use m_initylmg, only : initylmg
67 : use m_mkffnl, only : mkffnl
68 : use m_cgprj, only : getcprj
69 : use m_hamiltonian, only : gs_hamiltonian_type
70 : use m_nonlop, only : nonlop
71 : use m_pstat, only : pstat_proc
72 :
73 : implicit none
74 :
75 : private
76 : !!***
77 :
78 : ! Flags giving the status of the local %ug, %ur %cprj buffers.
79 : ! Use 1-byte int to save memory as much as possible.
80 : integer(c_int8_t),public,parameter :: WFD_NOWAVE = 0
81 : integer(c_int8_t),public,parameter :: WFD_ALLOCATED = 1
82 : integer(c_int8_t),public,parameter :: WFD_STORED = 2
83 :
84 : integer(c_int8_t),public,parameter :: CPR_RANDOM = 1
85 : integer(c_int8_t),public,parameter :: CPR_SORTED = 2
86 :
87 : !----------------------------------------------------------------------
88 :
89 : !!****t* m_wfd/kdata_t
90 : !! NAME
91 : !! kdata_t
92 : !!
93 : !! FUNCTION
94 : !! Datatype storing k-dependent quantities and tables needed
95 : !! for performing the zero-padded FFT of wavefunctions.
96 : !!
97 : !! SOURCE
98 :
99 : type,public :: kdata_t
100 :
101 : logical :: use_fnl_dir0der0 = .False.
102 : ! Decide if we need to use fnl_dir0der0.
103 :
104 : integer :: istwfk = -1
105 : ! Storage mode for this k point.
106 :
107 : integer :: npw = -1
108 : ! Number of plane-waves for this k-point.
109 :
110 : integer :: useylm = -1
111 : ! 1 if nonlocal part is applied using real spherical Harmonics. 0 for Legendre polynomial.
112 :
113 : integer :: has_ylm = -1
114 : ! 0 if ylm is not used.
115 : ! 1 if ylm is allocated.
116 : ! 2 if ylm is already computed.
117 :
118 : integer,allocatable :: kg_k(:,:)
119 : ! kg_k(3,npw)
120 : ! G vector coordinates in reduced coordinates.
121 :
122 : integer,allocatable :: gbound(:,:)
123 : ! gbound(2*mgfft+8,2))
124 : ! The boundary of the basis sphere of G vectors at a given k point.
125 : ! for use in improved zero padding of FFTs in 3 dimensions.
126 :
127 : real(dp),allocatable :: ph3d(:,:,:)
128 : ! ph3d(2, npw, natom)
129 : ! 3-dim structure factors, for each atom and each plane wave.
130 : ! Available only for PAW or use_fnl_dir0der0 is true.
131 :
132 : real(dp),allocatable :: phkxred(:,:)
133 : ! phkxred(2,natom))
134 : ! e^{ik.Ra} for each atom. Packed according to the atom type (atindx).
135 :
136 : real(dp),allocatable :: fnl_dir0der0(:,:,:,:)
137 : ! fnl_dir0der0(npw, 1, lmnmax,ntypat)
138 : ! nonlocal form factors. Computed only if usepaw == 1 or use_fnl_dir0der0 is true.
139 : ! fnl(k+G).ylm(k+G) if PAW
140 : ! f_ln(k+G)/|k+G|^l if NC
141 :
142 : real(dp),allocatable :: ylm(:,:)
143 : ! ylm(npw, mpsang**2*useylm)
144 : ! Real spherical harmonics for each k+G
145 :
146 : contains
147 :
148 : procedure :: init => kdata_init
149 : ! Init object
150 :
151 : procedure :: free => kdata_free_0D
152 : ! Free memory
153 :
154 : end type kdata_t
155 :
156 : interface kdata_free
157 : module procedure kdata_free_0D
158 : module procedure kdata_free_1D
159 : end interface kdata_free
160 :
161 : public :: kdata_copy
162 :
163 : interface kdata_copy
164 : module procedure copy_kdata_0D
165 : module procedure copy_kdata_1D
166 : end interface kdata_copy
167 : !!***
168 :
169 : !----------------------------------------------------------------------
170 :
171 : !!****t* m_wfd/wave_t
172 : !! NAME
173 : !! wave_t
174 : !!
175 : !! FUNCTION
176 : !! Object storing a single wavefunction in G-space and, optionally, its r-space representation.
177 : !!
178 : !! SOURCE
179 :
180 : type, public :: wave_t
181 :
182 : !! integer :: cplex
183 : ! 1 for real wavefunctions u(r)
184 : ! 2 for complex wavefunctions u(r).
185 : ! At gamma we always have real u(r) provided that time-reversal can be used.
186 : ! In systems with both time-reversal and spatial inversion, wavefunctions can be chosen to be real.
187 : ! One might use this to reduce memory in wave_t.
188 :
189 : integer(c_int8_t) :: has_ug = WFD_NOWAVE
190 : ! Flag giving the status of ug.
191 :
192 : integer(c_int8_t) :: has_ur = WFD_NOWAVE
193 : ! Flag giving the status of ur.
194 :
195 : integer(c_int8_t) :: has_cprj = WFD_NOWAVE
196 : ! Flag giving the status of cprj.
197 :
198 : integer(c_int8_t) :: cprj_order = CPR_RANDOM
199 : ! Flag defining whether cprj are sorted by atom type or ordered according
200 : ! to the typat variable used in the input file.
201 :
202 : complex(gwp),allocatable :: ug(:)
203 : ! ug(npw_k*nspinor)
204 : ! The periodic part of the Bloch wavefunction in G-space.
205 :
206 : complex(gwp),allocatable :: ur(:)
207 : ! ur(nfft*nspinor)
208 : ! The periodic part of the Bloch wavefunction in real space.
209 :
210 : type(pawcprj_type),allocatable :: Cprj(:,:)
211 : ! Cprj(natom,nspinor)
212 : ! PAW projected wave function <Proj_i|Cnk> with all NL projectors.
213 :
214 : contains
215 :
216 : procedure :: free => wave_free
217 : ! Free memory
218 :
219 : procedure :: copy => wave_copy
220 : ! Copy object.
221 :
222 : end type wave_t
223 :
224 : public :: wave_init
225 : !!***
226 :
227 : !----------------------------------------------------------------------
228 :
229 : !!****t* m_wfd/kpt_store_t
230 : !! NAME
231 : !! kpt_store_t
232 : !!
233 : !! FUNCTION
234 : !! Used to build ragged arrays of wave_t in compact form.
235 : !!
236 : !! SOURCE
237 :
238 : type :: kpt_store_t
239 : type(wave_t),allocatable :: b(:)
240 : end type kpt_store_t
241 : !!***
242 :
243 : !----------------------------------------------------------------------
244 :
245 : !!****t* m_wfd/spin_store_t
246 : !! NAME
247 : !! spin_store_t
248 : !!
249 : !! FUNCTION
250 : !! Used to build ragged arrays of wave_t in compact form.
251 : !!
252 : !! SOURCE
253 :
254 : type :: spin_store_t
255 : type(kpt_store_t),allocatable :: k(:)
256 : end type spin_store_t
257 : !!***
258 :
259 : !----------------------------------------------------------------------
260 :
261 : !!****t* m_wfd/wfd_t
262 : !! NAME
263 : !! wfd_t
264 : !!
265 : !! FUNCTION
266 : !! Container gathering information on the set of wavefunctions treated by this node
267 : !! This is a base class without the bks_tab that is used in the GW/BSE code.
268 : !!
269 : !! SOURCE
270 :
271 : type, public :: wfd_t
272 :
273 : integer :: debug_level = 0 ! Internal flag defining the debug level.
274 : integer :: lmnmax
275 : integer :: mband ! MAX(nband)
276 : integer :: mgfft ! Maximum size of 1D FFTs i.e. MAXVAL(ngfft(1:3)), used to dimension some arrays.
277 : integer :: natom
278 : integer :: nfft ! Number of FFT points treated by this processor
279 : integer :: nfftot ! Total number of points in the FFT grid
280 : integer :: nkibz ! Number of irreducible k-points
281 : integer :: nspden ! Number of independent spin-density components
282 : integer :: nspinor ! Number of spinor components
283 : integer :: nsppol ! Number of independent spin polarizations
284 : integer :: ntypat ! Number of type of atoms.
285 : integer :: paral_kgb ! Option for kgb parallelism
286 : integer :: usepaw ! 1 if PAW is used, 0 otherwise.
287 : integer :: prtvol ! Verbosity level.
288 : integer :: pawprtvol ! Verbosity level for PAW.
289 : integer :: usewvl ! 1 if BigDFT is used, 0 otherwise.
290 : integer :: comm ! The MPI communicator for this pool of processors.
291 : integer :: master ! The rank of master node in comm.
292 : integer :: my_rank ! The rank of my processor inside the MPI communicator comm.
293 : integer :: nproc ! The number of processors in MPI comm.
294 : integer :: my_nspins ! Number of spins treated by this MPI proc
295 :
296 : integer,allocatable :: my_nkspin(:)
297 : ! (%nsppol))
298 : ! Number of k-points treated by this MPI proc.
299 :
300 : logical :: rfft_is_symok ! .TRUE. if the real space FFT mesh is compatible with the rotational
301 : ! part of the space group.
302 :
303 : logical :: use_fnl_dir0der0 ! .TRUE. if the the Wfd must store fnl dir0der0.
304 :
305 : real(dp) :: dilatmx
306 :
307 : real(dp) :: ecut
308 : ! Cutoff for plane wave basis set.
309 :
310 : real(dp) :: ecutsm
311 : ! smearing energy for plane wave kinetic energy (Ha)
312 : ! Cutoff for plane wave basis set.
313 :
314 : integer :: ngfft(18)
315 : ! Information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
316 :
317 : integer :: nloalg(3)
318 : ! Governs the choice of the algorithm for nonlocal operator. See doc.
319 :
320 : integer,allocatable :: comm_spin(:)
321 : ! (nsppol)
322 : ! MPI communicator for collinear spin.
323 :
324 : integer,allocatable :: irottb(:,:)
325 : ! (nfftot, nsym)
326 : ! Index of $R^{-1}(r-\tau)$ in the FFT box.
327 :
328 : integer,allocatable :: istwfk(:)
329 : ! (nkibz)
330 : ! Storage mode for this k-point.
331 :
332 : integer,allocatable :: nband(:,:)
333 : ! (nkibz,nsppol)
334 : ! Number of bands at each k-point and spin.
335 :
336 : integer,allocatable :: indlmn(:,:,:)
337 : ! (6, lmnmax, ntypat)
338 : ! array giving l,m,n,lm,ln,spin for i=ln (if useylm=0)
339 : ! or i=lmn (if useylm=1)
340 :
341 : integer,allocatable :: nlmn_atm(:)
342 : ! (natom)
343 : ! Number of (n,l,m) channels for each atom. Only for PAW
344 :
345 : integer,allocatable :: nlmn_sort(:)
346 : ! (natom)
347 : ! Number of (n,l,m) channels for each atom (sorted by atom type). Only for PAW
348 :
349 : integer,allocatable :: nlmn_type(:)
350 : ! (ntypat)
351 : ! Number of (n,l,m) channels for each type of atom. Only for PAW.
352 :
353 : integer,allocatable :: npwarr(:)
354 : ! (nkibz)
355 : ! Number of plane waves for this k-point.
356 :
357 : integer, allocatable :: bks2wfd(:,:,:,:)
358 : ! (3, mband, nkibz, nsppol)
359 : ! Maps global (band, ik_ibz, spin) to index in the wave store.
360 : ! Set to 0 if the (b, k, s) state is not in the store.
361 :
362 : real(dp),allocatable :: kibz(:,:)
363 : ! (3, nkibz)
364 : ! Reduced coordinates of the k-points in the IBZ.
365 :
366 : real(dp),allocatable :: ph1d(:,:)
367 : ! (2,3*(2*mgfft+1)*natom)
368 : ! 1-dim structure factor phase information.
369 :
370 : logical,private, allocatable :: keep_ur(:,:,:)
371 : ! TODO: To be removed
372 : ! keep(mband,nkibz,nsppol)
373 : ! Storage strategy: keep or not keep calculated u(r) in memory.
374 :
375 : type(kdata_t),allocatable :: kdata(:)
376 : ! (nkibz)
377 : ! datatype storing k-dependent quantities.
378 :
379 : type(spin_store_t),allocatable :: s(:)
380 : ! (my_nsppol)
381 : ! wfd%s(is)%k(ik)%b(ib)
382 :
383 : type(MPI_type) :: MPI_enreg
384 : ! The MPI_type structured datatype gather different information about the MPI parallelisation:
385 : ! number of processors, the index of my processor, the different groups of processors, etc ...
386 :
387 : !type(pseudopotential_type), pointer :: psps
388 : !type(pawtab_type), pointer :: pawtab(:)
389 :
390 : contains
391 :
392 : procedure :: free => wfd_free
393 : ! Free memory.
394 :
395 : procedure :: norm2 => wfd_norm2
396 : ! Compute <u(g)|u(g)> for the same k-point and spin.
397 :
398 : procedure :: xdotc => wfd_xdotc
399 : ! Compute <u_{b1ks}|u_{b2ks}> in G-space.
400 :
401 : procedure :: get_gvec_gbound => wfd_get_gvec_gbound
402 : ! Return the g-sphere centered on kk and gbound_kk,
403 : ! mainly used when looping over wavevectors in the full BZ
404 :
405 : procedure :: reset_ur_cprj => wfd_reset_ur_cprj
406 : ! Reinitialize memory storage of u(r) and <p_i|psi>
407 :
408 : procedure :: get_many_ur => wfd_get_many_ur
409 : ! Get many wavefunctions in real space from its (bands(:),k,s) indices.
410 :
411 : procedure :: copy_cg => wfd_copy_cg
412 : ! Return a copy of u(g) in a real(2,npw_k)) array (Abinit convention)
413 :
414 : procedure :: get_ur => wfd_get_ur
415 : ! Get one wavefunction in real space from its (b,k,s) indices.
416 :
417 : procedure :: get_cprj => wfd_get_cprj
418 : ! Get one PAW projection <Proj_i|Cnk> with all NL projectors from its (b,k,s) indices.
419 :
420 : procedure :: change_ngfft => wfd_change_ngfft
421 : ! Reinitialize internal FFT tables.
422 :
423 : procedure :: print => wfd_print
424 : ! Printout of basic info.
425 :
426 : procedure :: ug2cprj => wfd_ug2cprj
427 : ! Get PAW cprj from its (b,k,s) indices.
428 :
429 : procedure :: wave_free => wfd_wave_free
430 : ! Free internal buffers used to store the wavefunctions.
431 :
432 : procedure :: get_wave_ptr => wfd_get_wave_ptr
433 : ! Return pointer to wave_t from its (b,k,s) indices
434 :
435 : procedure :: push_ug => wfd_push_ug
436 : ! Modify the value of u(g)_ks stored in the object.
437 :
438 : procedure :: extract_cgblock => wfd_extract_cgblock
439 : ! Extract a block of wavefunctions for a given spin and k-points (uses the cg storage mode)
440 :
441 : procedure :: ihave_ug => wfd_ihave_ug
442 : ! True if the node has this ug with the specified status.
443 :
444 : procedure :: mybands => wfd_mybands
445 : ! Returns the list of band indices of the u(g) owned by this node at given (k,s).
446 :
447 : procedure :: test_ortho => wfd_test_ortho
448 : ! Test the orthonormalization of the wavefunctions.
449 :
450 : procedure :: sym_ur => wfd_sym_ur
451 : ! Symmetrize a wave function in real space
452 : ! This routine is deprecated, see wfd_sym_ug_kg for algo in G-space.
453 :
454 : procedure :: rotate_cg => wfd_rotate_cg
455 : ! Symmetrize a set of wave functions in G-space
456 :
457 : procedure :: sym_ug_kg => wfd_sym_ug_kg
458 : ! Symmetrize a wave function in G-space
459 : ! Used in phgamma only, use wfd_rotate_cg for a more efficient version (see m_sigmaph for usage)
460 : ! This routine is deprecated and should be replaced by sym_ug_kg_npw in order to call getgh1c with ndat > 1, i
461 :
462 : procedure :: sym_ug_kg_npw => wfd_sym_ug_kg_npw
463 : ! Symmetrize a wave function in G-space
464 :
465 : procedure :: paw_get_aeur => wfd_paw_get_aeur
466 : ! Compute the AE PAW wavefunction in real space.
467 :
468 : procedure :: read_wfk => wfd_read_wfk
469 : ! Read u(g) from the WFK file completing the initialization of the object.
470 :
471 : procedure :: dump_errinfo => wfd_dump_errinfo
472 :
473 : procedure :: init => wfd_init ! Main creation method.
474 :
475 : end type wfd_t
476 :
477 : !public :: wfd_init ! Main creation method.
478 :
479 : !public :: wfd_get_socpert
480 : public :: test_charge
481 : !!***
482 :
483 : !----------------------------------------------------------------------
484 :
485 : !!****t* m_wfd/wfdgw_t
486 : !! NAME
487 : !! wfdgw_t
488 : !!
489 : !! FUNCTION
490 : !! This is a subclass class with the bks_tab used to parallelize the GW/BSE code.
491 : !! Unfortunately, the size of the bks_tab increases with the number of procs
492 : !! This design facilated the implementation of the MPI-algorithms but it leads to a big
493 : !! scalability issue when nprocs/nband/nkibz is large.
494 : !! New algorithms implemented outside of the GW/BSE code should use wfd_t.
495 : !! wfdgw_t is kept to avoid breaking the GW/BSE code.
496 : !!
497 : !! SOURCE
498 :
499 : type, extends (wfd_t), public :: wfdgw_t
500 :
501 : integer(c_int8_t), private, allocatable :: bks_tab(:,:,:,:)
502 : ! bks_tab(mband,nkibz,nsppol,0:nproc-1)
503 : ! Global table used to keep trace of the distribution of the (b,k,s) states on each node inside Wfd%comm.
504 : ! 1 if the node has this state. 0 otherwise.
505 : ! A node owns a wavefunction if the corresponding ug is allocated AND computed.
506 : ! If a node owns ur but not ug, or ug is just allocated then its entry in the table is zero.
507 :
508 : contains
509 :
510 : procedure :: show_bkstab => wfdgw_show_bkstab
511 : ! Print a table showing the distribution of the wavefunctions.
512 :
513 : procedure :: distribute_bands => wfdgw_distribute_bands
514 : ! Distribute a set of bands taking into account the distribution of the ug.
515 :
516 : procedure :: iterator_bks => wfdgw_iterator_bks
517 : ! Iterator used to loop over bands, k-points and spin indices
518 :
519 : procedure :: bks_distrb => wfdgw_bks_distrb
520 : ! Distribute bands, k-points and spins
521 :
522 : procedure :: update_bkstab => wfdgw_update_bkstab
523 : ! Update the internal table with info on the distribution of the ugs.
524 :
525 : procedure :: rotate => wfdgw_rotate
526 : ! Linear transformation of the wavefunctions stored in Wfd
527 :
528 : procedure :: sanity_check => wfdgw_sanity_check
529 : ! Debugging tool
530 :
531 : procedure :: distribute_bbp => wfdgw_distribute_bbp
532 : ! Distribute a set of (b,b') indices
533 :
534 : procedure :: distribute_kb_kpbp => wfdgw_distribute_kb_kpbp
535 :
536 : procedure :: plot_ur => wfdgw_plot_ur
537 : ! Write u(r) to an external file in XSF format.
538 :
539 : procedure :: mkrho => wfdgw_mkrho
540 : ! Calculate the charge density on the fine FFT grid in real space.
541 :
542 : procedure :: pawrhoij => wfdgw_pawrhoij
543 :
544 : procedure :: get_nl_me => wfdgw_get_nl_me
545 :
546 : procedure :: rank_has_ug => wfdgw_rank_has_ug
547 :
548 : procedure :: bands_of_rank => wfdgw_bands_of_rank
549 :
550 : procedure :: write_wfk => wfdgw_write_wfk
551 : ! Write u(g) to a WFK file.
552 :
553 : end type wfdgw_t
554 :
555 : public :: wfdgw_copy
556 : !!***
557 :
558 : type, public :: u0_cache_t
559 : integer :: prev_npw_k = -1, prev_nband_k = - 1, prev_istwf_k = -1
560 : real(dp) :: prev_kpt(3) = -1
561 : logical :: use_cache = .False.
562 : integer :: ngfft(18)
563 : integer, allocatable :: prev_kg_k(:,:)
564 : real(dp),allocatable :: prev_cg_k(:,:,:)
565 : ! (2, prev_npw_k*nspinor, prev_nband_k))
566 : contains
567 : procedure :: init => u0_cache_init
568 : procedure :: store_kpt => u0_cache_store_kpt
569 : procedure :: get_kpt => u0_cache_get_kpt
570 : procedure :: free => u0_cache_free
571 : end type u0_cache_t
572 :
573 : type, public :: u1_cache_t
574 : integer :: prev_npw_kq = -1, prev_bstart_ks = -1, prev_nbcalc_ks = - 1
575 : integer :: hits = 0, miss = 0
576 : real(dp) :: prev_qpt(3)
577 : integer, allocatable :: prev_kg_kq(:,:)
578 : real(dp),allocatable :: prev_cg1s_kq(:,:,:,:)
579 : ! (2, npw_kq*nspinor, natom3, nbcalc_ks))
580 : contains
581 : procedure :: store => u1_cache_store
582 : procedure :: find_band => u1_cache_find_band
583 : procedure :: free => u1_cache_free
584 : end type u1_cache_t
585 :
586 : contains
587 :
588 : !!****f* m_wfd/kdata_init
589 : !! NAME
590 : !! kdata_init
591 : !!
592 : !! FUNCTION
593 : !! Main creation method for the kdata_t datatype.
594 : !!
595 : !! SOURCE
596 :
597 9481 : subroutine kdata_init(Kdata, Cryst, Psps, kpoint, istwfk, ngfft, MPI_enreg, ecut, kg_k)
598 :
599 : !Arguments ------------------------------------
600 : !scalars
601 : class(kdata_t),intent(inout) :: Kdata
602 : integer,intent(in) :: istwfk
603 : real(dp),optional,intent(in) :: ecut
604 : type(crystal_t),intent(in) :: Cryst
605 : type(pseudopotential_type),intent(in) :: Psps
606 : type(MPI_type),intent(in) :: MPI_enreg
607 : !arrays
608 : integer,optional,target,intent(in) :: kg_k(:,:)
609 : integer,intent(in) :: ngfft(18)
610 : real(dp),intent(in) :: kpoint(3)
611 :
612 : !Local variables ------------------------------
613 : !scalars
614 : integer,parameter :: ider0 = 0, idir0 = 0
615 : integer :: mpw_, npw_k, dimffnl, useylmgr, nkpg, iatom, mkmem_, nkpt_, optder, mgfft, iatm, matblk
616 : real(dp) :: arg
617 : !arrays
618 : integer :: nband_(1), npwarr_(1)
619 9481 : real(dp),allocatable :: ylmgr_k(:,:,:),kpg_k(:,:),ph1d(:,:)
620 : !************************************************************************
621 :
622 : !@kdata_t
623 9481 : Kdata%istwfk = istwfk
624 9481 : Kdata%useylm = Psps%useylm
625 :
626 9481 : if (present(ecut)) then
627 : ! Calculate G-sphere from input ecut.
628 4536 : ABI_CHECK(.not.allocated(Kdata%kg_k), "Kdata%kg_k is allocated!")
629 4536 : call get_kg(kpoint,istwfk,ecut,Cryst%gmet,npw_k,Kdata%kg_k)
630 :
631 4945 : else if (present(kg_k)) then
632 : ! Use input g-vectors.
633 4945 : npw_k = SIZE(kg_k,DIM=2)
634 14835 : ABI_MALLOC(Kdata%kg_k,(3,npw_k))
635 6063170 : Kdata%kg_k = kg_k
636 : else
637 0 : ABI_ERROR("Either ecut or kg_k must be present")
638 : end if
639 9481 : Kdata%npw = npw_k
640 :
641 37924 : mgfft = MAXVAL(ngfft(1:3))
642 :
643 : ! Finds the boundary of the basis sphere of G vectors (for this k point)
644 : ! for use in improved zero padding of ffts in 3 dimensions.
645 37924 : ABI_MALLOC(Kdata%gbound,(2*mgfft+8, 2))
646 9481 : call sphereboundary(Kdata%gbound, istwfk, Kdata%kg_k, mgfft, npw_k)
647 :
648 : ! Compute e^{ik.Ra} for each atom. Packed according to the atom type (atindx).
649 28443 : ABI_MALLOC(Kdata%phkxred,(2, Cryst%natom))
650 29148 : do iatom=1,Cryst%natom
651 19667 : iatm=Cryst%atindx(iatom)
652 78668 : arg=two_pi*(DOT_PRODUCT(kpoint,Cryst%xred(:,iatom)))
653 19667 : Kdata%phkxred(1,iatm)=DCOS(arg)
654 29148 : Kdata%phkxred(2,iatm)=DSIN(arg)
655 : end do
656 :
657 : ! TODO: Should avoid storing all this stuff in memory (risky if lots of k-points)
658 : ! Write method to prepare kdata inside loop
659 :
660 : ! Calculate 1-dim structure factor phase information.
661 37924 : mgfft = MAXVAL(ngfft(1:3))
662 28443 : ABI_MALLOC(ph1d,(2, 3*(2*mgfft+1)*Cryst%natom))
663 9481 : call getph(Cryst%atindx,Cryst%natom,ngfft(1),ngfft(2),ngfft(3),ph1d,Cryst%xred)
664 :
665 : ! Calculate 3-dim structure factor phase information.
666 9481 : matblk = 0
667 9481 : if(psps%usepaw == 1 .or. Kdata%use_fnl_dir0der0) then
668 321 : matblk=Cryst%natom
669 : end if
670 37924 : ABI_MALLOC(Kdata%ph3d,(2, npw_k, matblk))
671 9481 : if(psps%usepaw == 1 .or. Kdata%use_fnl_dir0der0) then
672 : call ph1d3d(1,Cryst%natom,Kdata%kg_k,matblk,Cryst%natom,npw_k,ngfft(1),ngfft(2),&
673 321 : &ngfft(3),Kdata%phkxred,ph1d,Kdata%ph3d)
674 : end if
675 9481 : ABI_FREE(ph1d)
676 :
677 : ! Compute spherical harmonics.
678 9481 : Kdata%has_ylm = 1
679 37924 : ABI_MALLOC(Kdata%ylm, (npw_k, Psps%mpsang**2*Psps%useylm))
680 9481 : useylmgr=0
681 18962 : ABI_MALLOC(ylmgr_k,(npw_k, 3, Psps%mpsang**2*useylmgr))
682 :
683 9481 : if (Kdata%useylm == 1) then
684 269 : mkmem_=1; mpw_=npw_k; nband_=0; nkpt_=1; npwarr_(1)=npw_k
685 269 : optder=0 ! only Ylm(K) are computed.
686 :
687 : call initylmg(Cryst%gprimd, Kdata%kg_k, kpoint, mkmem_, MPI_enreg, Psps%mpsang, mpw_, nband_, nkpt_,&
688 269 : npwarr_, 1, optder, Cryst%rprimd, Kdata%ylm, ylmgr_k)
689 :
690 269 : Kdata%has_ylm = 2
691 : end if
692 :
693 : ! Compute (k+G) vectors.
694 9481 : nkpg = 0
695 18962 : ABI_MALLOC(kpg_k,(npw_k, nkpg))
696 : if (nkpg>0) call mkkpg(Kdata%kg_k, kpg_k, kpoint, nkpg, npw_k)
697 :
698 : ! Compute nonlocal form factors fnl_dir0der0 for all (k+G).
699 9481 : dimffnl = 0
700 9481 : if(psps%usepaw == 1 .or. Kdata%use_fnl_dir0der0) then
701 321 : dimffnl = 1+3*ider0
702 : end if
703 56886 : ABI_MALLOC(Kdata%fnl_dir0der0,(npw_k, dimffnl, Psps%lmnmax, Cryst%ntypat))
704 :
705 9481 : if (dimffnl /=0 ) then
706 : call mkffnl(Psps%dimekb,dimffnl,Psps%ekb,Kdata%fnl_dir0der0,Psps%ffspl,&
707 : Cryst%gmet,Cryst%gprimd,ider0,idir0,Psps%indlmn,Kdata%kg_k,kpg_k,kpoint,Psps%lmnmax,&
708 : Psps%lnmax,Psps%mpsang,Psps%mqgrid_ff,nkpg,npw_k,Cryst%ntypat,&
709 321 : Psps%pspso,Psps%qgrid_ff,Cryst%rmet,Psps%usepaw,Psps%useylm,Kdata%ylm,ylmgr_k)
710 : end if
711 :
712 9481 : ABI_FREE(kpg_k)
713 9481 : ABI_FREE(ylmgr_k)
714 :
715 9481 : end subroutine kdata_init
716 : !!***
717 :
718 : !----------------------------------------------------------------------
719 :
720 : !!****f* m_wfd/kdata_free_0D
721 : !! NAME
722 : !! kdata_free_0D
723 : !!
724 : !! FUNCTION
725 : !! Deallocate memory
726 : !!
727 : !! SOURCE
728 :
729 13089 : subroutine kdata_free_0D(Kdata)
730 :
731 : !Arguments ------------------------------------
732 : class(kdata_t),intent(inout) :: Kdata
733 : !************************************************************************
734 :
735 13089 : ABI_SFREE(Kdata%kg_k)
736 13089 : ABI_SFREE(Kdata%gbound)
737 :
738 13089 : ABI_SFREE(Kdata%ph3d)
739 13089 : ABI_SFREE(Kdata%phkxred)
740 13089 : ABI_SFREE(Kdata%fnl_dir0der0)
741 13089 : ABI_SFREE(Kdata%ylm)
742 :
743 13089 : end subroutine kdata_free_0D
744 : !!***
745 :
746 : !----------------------------------------------------------------------
747 :
748 : !!****f* m_wfd/kdata_free_1D
749 : !! NAME
750 : !! kdata_free_1D
751 : !!
752 : !! FUNCTION
753 : !! Deallocate memory.
754 : !!
755 : !! SOURCE
756 :
757 484 : subroutine kdata_free_1D(Kdata)
758 :
759 : !Arguments ------------------------------------
760 : !scalars
761 : type(kdata_t),intent(inout) :: Kdata(:)
762 :
763 : !Local variables ------------------------------
764 : !scalars
765 : integer :: ik
766 : !************************************************************************
767 :
768 9112 : do ik=LBOUND(Kdata,DIM=1),UBOUND(Kdata,DIM=1)
769 8628 : call kdata_free_0D(Kdata(ik))
770 : end do
771 :
772 484 : end subroutine kdata_free_1D
773 : !!***
774 :
775 : !----------------------------------------------------------------------
776 :
777 : !!****f* m_wfd/copy_kdata_0D
778 : !! NAME
779 : !! copy_kdata_0D
780 : !!
781 : !! FUNCTION
782 : !! Copy object
783 : !!
784 : !! SOURCE
785 :
786 0 : subroutine copy_kdata_0D(Kdata_in, Kdata_out)
787 :
788 : !Arguments ------------------------------------
789 : class(kdata_t),intent(in) :: Kdata_in
790 : class(kdata_t),intent(inout) :: Kdata_out
791 : !************************************************************************
792 :
793 : !@kdata_t
794 0 : Kdata_out%istwfk = Kdata_in%istwfk
795 0 : Kdata_out%npw = Kdata_in%npw
796 0 : Kdata_out%useylm = Kdata_in%useylm
797 0 : Kdata_out%has_ylm = Kdata_in%has_ylm
798 :
799 0 : call alloc_copy(Kdata_in%kg_k, Kdata_out%kg_k)
800 0 : call alloc_copy(Kdata_in%gbound, Kdata_out%gbound)
801 :
802 0 : call alloc_copy(Kdata_in%ph3d,Kdata_out%ph3d)
803 0 : call alloc_copy(Kdata_in%phkxred,Kdata_out%phkxred)
804 0 : call alloc_copy(Kdata_in%fnl_dir0der0,Kdata_out%fnl_dir0der0)
805 0 : call alloc_copy(Kdata_in%ylm,Kdata_out%ylm)
806 :
807 0 : end subroutine copy_kdata_0D
808 : !!***
809 :
810 : !----------------------------------------------------------------------
811 :
812 : !!****f* m_wfd/copy_kdata_1D
813 : !! NAME
814 : !! copy_kdata_1D
815 : !!
816 : !! FUNCTION
817 : !! Deallocate memory.
818 : !!
819 : !! SOURCE
820 :
821 0 : subroutine copy_kdata_1D(Kdata_in, Kdata_out)
822 :
823 : !Arguments ------------------------------------
824 : !scalars
825 : type(kdata_t),intent(in) :: Kdata_in(:)
826 : type(kdata_t),intent(inout) :: Kdata_out(:)
827 :
828 : !Local variables ------------------------------
829 : !scalars
830 : integer :: ik
831 : !************************************************************************
832 :
833 0 : if (size(Kdata_in,DIM=1) /= size(Kdata_out,DIM=1)) then
834 0 : ABI_ERROR("copy_kdata_1D: wrong sizes !")
835 : end if
836 :
837 0 : do ik=LBOUND(Kdata_in,DIM=1),UBOUND(Kdata_in,DIM=1)
838 0 : call copy_kdata_0d(Kdata_in(ik), Kdata_out(ik))
839 : end do
840 :
841 0 : end subroutine copy_kdata_1D
842 : !!***
843 :
844 : !----------------------------------------------------------------------
845 :
846 : !!****f* m_wfd/wfd_init
847 : !! NAME
848 : !! wfd_init
849 : !!
850 : !! FUNCTION
851 : !! Initialize the object.
852 : !!
853 : !! INPUTS
854 : !! Cryst<crystal_t>=Object defining the unit cell and its symmetries.
855 : !! Pawtab(ntypat*usepaw)<type(pawtab_type)>=PAW tabulated starting data.
856 : !! Psps<Pseudopotential_type>=datatype storing data on the pseudopotentials.
857 : !! ngfft(18)=All needed information about 3D FFT, see ~abinit/doc/variables/vargs.htm#ngfft
858 : !! nkibz=Number of irreducible k-points.
859 : !! nsppol=Number of independent spin polarizations.
860 : !! nspden=Number of density components.
861 : !! nspinor=Number of spinorial components.
862 : !! ecut=Cutoff energy in Hartree
863 : !! ecutsm=Smearing for kinetic energy
864 : !! dilatmx
865 : !! mband
866 : !! nband(nkibz,nsppol)
867 : !! keep_ur(mband,nkibz,nsppol)=Option for memory storage of u(r).
868 : !! istwfk(nkibz)=Storage mode.
869 : !! kibz(3,nkibz)=Reduced coordinates of the k-points.
870 : !! nloalg(3)=Governs the choice of the algorithm for nonlocal operator. See doc.
871 : !! prtvol=Verbosity level.
872 : !! comm=MPI communicator.
873 : !!
874 : !! OUTPUT
875 : !! Initialize the object with basic dimensions, allocate also memory for u(g) and u(r) according to keep_ur
876 : !! %ug in G-space are always allocated.
877 : !! %ur in r-space only if keep_ur.
878 : !!
879 : !! SOURCE
880 :
881 484 : subroutine wfd_init(Wfd,Cryst,Pawtab,Psps,keep_ur,mband,nband,nkibz,nsppol,bks_mask,&
882 484 : nspden,nspinor,ecut,ecutsm,dilatmx,istwfk,kibz,ngfft,nloalg,prtvol,pawprtvol,comm,&
883 : use_fnl_dir0der0) ! optional
884 :
885 : !Arguments ------------------------------------
886 : !scalars
887 : class(wfd_t),intent(inout) :: Wfd
888 : integer,intent(in) :: mband,comm,prtvol,pawprtvol,nkibz,nsppol,nspden,nspinor
889 : real(dp),intent(in) :: ecut,ecutsm,dilatmx
890 : type(crystal_t),intent(in) :: Cryst
891 : type(pseudopotential_type),intent(in) :: Psps
892 : !array
893 : integer,intent(in) :: ngfft(18),istwfk(nkibz),nband(nkibz,nsppol),nloalg(3)
894 : real(dp),intent(in) :: kibz(3,nkibz)
895 : logical,intent(in) :: bks_mask(mband,nkibz,nsppol), keep_ur(mband,nkibz,nsppol)
896 : logical,intent(in),optional :: use_fnl_dir0der0
897 : type(Pawtab_type),intent(in) :: Pawtab(Cryst%ntypat*Psps%usepaw)
898 :
899 : !Local variables ------------------------------
900 : !scalars
901 : integer,parameter :: nfft0=0,mpw0=0,ikg0=0
902 : integer :: ik_ibz,spin,band,mpw,exchn2n3d,istwf_k,npw_k,iatom,itypat,iat,cnt_b, cnt_k, cnt_s, ierr, color
903 : real(dp) :: ug_size,ur_size,cprj_size, bks_size,cpu, wall, gflops
904 : logical :: iscompatibleFFT
905 : character(len=500) :: msg
906 : !arrays
907 : integer :: dum_kg(3,0)
908 : real(dp) :: kpoint(3)
909 : !************************************************************************
910 :
911 484 : call cwtime(cpu, wall, gflops, "start")
912 :
913 : ! MPI info
914 484 : Wfd%comm = comm
915 484 : Wfd%my_rank = xmpi_comm_rank(Wfd%comm)
916 484 : Wfd%nproc = xmpi_comm_size(Wfd%comm)
917 484 : Wfd%master = 0
918 :
919 : ! Sequential MPI datatype to be passed to abinit routines.
920 484 : call initmpi_seq(Wfd%MPI_enreg)
921 484 : call Wfd%MPI_enreg%distribfft%init('c',Wfd%MPI_enreg%nproc_fft,ngfft(2),ngfft(3))
922 :
923 : ! TODO: To simply high-level API.
924 : !wfd%cryst => cryst
925 : !wfd%psps => psps
926 : !wfd%pawtab => pawtab
927 :
928 : ! Basic dimensions
929 484 : Wfd%nkibz = nkibz
930 484 : Wfd%nsppol = nsppol
931 484 : Wfd%nspden = nspden
932 484 : Wfd%nspinor = nspinor
933 484 : Wfd%paral_kgb = 0
934 1936 : Wfd%nloalg = nloalg
935 :
936 484 : Wfd%usepaw = Psps%usepaw
937 484 : Wfd%usewvl = 0 ! wavelets are not supported.
938 484 : Wfd%use_fnl_dir0der0 = .false.
939 484 : if(present(use_fnl_dir0der0)) Wfd%use_fnl_dir0der0 = use_fnl_dir0der0
940 484 : Wfd%natom = Cryst%natom
941 484 : Wfd%ntypat = Cryst%ntypat
942 484 : Wfd%lmnmax = Psps%lmnmax
943 484 : Wfd%prtvol = prtvol
944 484 : Wfd%pawprtvol = pawprtvol
945 :
946 484 : Wfd%ecutsm = ecutsm
947 484 : Wfd%dilatmx = dilatmx
948 :
949 1936 : ABI_MALLOC(Wfd%indlmn,(6, Wfd%lmnmax, Wfd%ntypat))
950 16457 : Wfd%indlmn = Psps%indlmn
951 :
952 484 : if (Wfd%usepaw==1) then
953 36 : ABI_MALLOC(Wfd%nlmn_atm, (Cryst%natom))
954 36 : ABI_MALLOC(Wfd%nlmn_type, (Cryst%ntypat))
955 78 : do iatom=1,Cryst%natom
956 78 : Wfd%nlmn_atm(iatom) = Pawtab(Cryst%typat(iatom))%lmn_size
957 : end do
958 :
959 32 : do itypat=1,Cryst%ntypat
960 32 : Wfd%nlmn_type(itypat)=Pawtab(itypat)%lmn_size
961 : end do
962 :
963 24 : ABI_MALLOC(Wfd%nlmn_sort,(Cryst%natom))
964 12 : iat=0 ! nlmn dims sorted by atom type.
965 32 : do itypat=1,Cryst%ntypat
966 86 : Wfd%nlmn_sort(iat+1:iat+Cryst%nattyp(itypat))=Pawtab(itypat)%lmn_size
967 32 : iat=iat+Cryst%nattyp(itypat)
968 : end do
969 : end if
970 :
971 2420 : ABI_MALLOC(Wfd%keep_ur, (mband, nkibz, nsppol))
972 118602 : Wfd%keep_ur = keep_ur
973 :
974 : ! Setup of the FFT mesh
975 9196 : Wfd%ngfft = ngfft
976 1936 : Wfd%mgfft = MAXVAL (Wfd%ngfft(1:3))
977 1936 : Wfd%nfftot = PRODUCT(Wfd%ngfft(1:3))
978 484 : Wfd%nfft = Wfd%nfftot ! At present no FFT parallelism.
979 484 : Wfd%ecut = ecut
980 :
981 : ! Precalculate the FFT index of $ R^{-1} (r-\tau) $ used to symmetrize u_Rk.
982 1936 : ABI_MALLOC(Wfd%irottb,(Wfd%nfftot, Cryst%nsym))
983 484 : call rotate_FFT_mesh(Cryst%nsym,Cryst%symrel,Cryst%tnons,Wfd%ngfft,Wfd%irottb,iscompatibleFFT)
984 :
985 484 : if (.not. iscompatibleFFT) then
986 7 : msg = "FFT mesh is not compatible with symmetries. Wavefunction symmetrization might be affected by large errors!"
987 7 : ABI_WARNING(msg)
988 : end if
989 :
990 : ! Is the real space mesh compatible with the rotational part?
991 484 : Wfd%rfft_is_symok = check_rot_fft(Cryst%nsym,Cryst%symrel,Wfd%ngfft(1),Wfd%ngfft(2),Wfd%ngfft(3))
992 :
993 1452 : ABI_MALLOC(Wfd%kibz, (3, Wfd%nkibz))
994 33544 : Wfd%kibz = kibz
995 1452 : ABI_MALLOC(Wfd%istwfk, (Wfd%nkibz))
996 9112 : Wfd%istwfk = istwfk
997 :
998 : ! Get the number of planewaves npw_k
999 : ! TODO Here we should use ecut_eff instead of ecut
1000 9596 : ABI_ICALLOC(Wfd%npwarr, (Wfd%nkibz))
1001 484 : exchn2n3d = 0
1002 8628 : do ik_ibz=1,Wfd%nkibz
1003 8144 : if (mod(ik_ibz, wfd%nproc) /= wfd%my_rank) cycle ! MPI parallelism.
1004 7480 : istwf_k = Wfd%istwfk(ik_ibz)
1005 29920 : kpoint = Wfd%kibz(:,ik_ibz)
1006 7480 : call kpgsph(Wfd%ecut,exchn2n3d,Cryst%gmet,ikg0,ik_ibz,istwf_k,dum_kg,kpoint,0,Wfd%MPI_enreg,mpw0,npw_k)
1007 8628 : Wfd%npwarr(ik_ibz)= npw_k
1008 : end do
1009 484 : call xmpi_sum(wfd%npwarr, wfd%comm, ierr)
1010 :
1011 8628 : mpw = maxval(Wfd%npwarr)
1012 :
1013 1936 : ABI_MALLOC(Wfd%nband, (nkibz,nsppol))
1014 9623 : Wfd%nband = nband; Wfd%mband = mband
1015 9139 : ABI_CHECK_IEQ(maxval(Wfd%nband), mband, "Wrong mband")
1016 :
1017 : ! Allocate u(g) and, if required, also u(r)
1018 118118 : ug_size = one*nspinor*mpw*COUNT(bks_mask)
1019 484 : write(msg,'(a,f8.1,a)')' Memory needed for Fourier components u(G): ',two*gwp*ug_size*b2Mb, ' [Mb] <<< MEM'
1020 484 : call wrtout(std_out, msg)
1021 : #ifdef HAVE_GW_DPC
1022 484 : call wrtout(std_out, ' Storing wavefunctions in double precision as `enable_gw_dpc="no"`')
1023 484 : call wrtout(std_out, ' Recompile the code with `enable_gw_dpc="no"` to halve memory requirements for the WFs')
1024 : #else
1025 : call wrtout(std_out, ' Storing wavefunctions in single precision as `enable_gw_dpc="no"`')
1026 : #endif
1027 :
1028 484 : if (Wfd%usepaw==1) then
1029 1770 : cprj_size = one * nspinor*SUM(Wfd%nlmn_atm)*COUNT(bks_mask)
1030 12 : write(msg,'(a,f8.1,a)')' Memory needed for PAW projections cprj: ',dp*cprj_size*b2Mb,' [Mb] <<< MEM'
1031 12 : call wrtout(std_out, msg)
1032 : end if
1033 :
1034 118118 : ur_size = one*nspinor*Wfd%nfft*COUNT(Wfd%keep_ur)
1035 484 : write(msg,'(a,f8.1,a)')' Memory needed for real-space u(r): ',two*gwp*ur_size*b2Mb,' [Mb] <<< MEM'
1036 484 : call wrtout(std_out, msg)
1037 :
1038 : ! Count the number of spins treated by this proc.
1039 484 : wfd%my_nspins = 0
1040 975 : do spin=1,wfd%nsppol
1041 12270 : if (any(bks_mask(:,:,spin))) wfd%my_nspins = wfd%my_nspins + 1
1042 : end do
1043 : !write(std_out, *)"my_nspins", wfd%my_nspins
1044 1943 : ABI_MALLOC(wfd%s, (wfd%my_nspins))
1045 :
1046 : ! Count the number of kpts in the IBZ treated by this proc. may be spin-dependent.
1047 1943 : ABI_ICALLOC(wfd%my_nkspin, (wfd%nsppol))
1048 484 : cnt_s = 0
1049 975 : do spin=1,wfd%nsppol
1050 8655 : do ik_ibz=1,wfd%nkibz
1051 39867 : if (any(bks_mask(:,ik_ibz,spin))) wfd%my_nkspin(spin) = wfd%my_nkspin(spin) + 1
1052 : end do
1053 975 : if (wfd%my_nkspin(spin) > 0) then
1054 491 : cnt_s = cnt_s + 1
1055 6029 : ABI_MALLOC(wfd%s(cnt_s)%k, (wfd%my_nkspin(spin)))
1056 : end if
1057 : end do
1058 :
1059 : ! Allocate bands in packed form and use bks2wfd to go from global (b,k,s) index to local index.
1060 446991 : ABI_ICALLOC(wfd%bks2wfd, (3, wfd%mband, wfd%nkibz, wfd%nsppol))
1061 484 : cnt_s = 0
1062 975 : do spin=1,wfd%nsppol
1063 491 : if (wfd%my_nkspin(spin) == 0) cycle
1064 491 : cnt_s = cnt_s + 1
1065 491 : cnt_k = 0
1066 9139 : do ik_ibz=1,wfd%nkibz
1067 117143 : cnt_b = count(bks_mask(:, ik_ibz, spin))
1068 8164 : if (cnt_b == 0) cycle
1069 4556 : cnt_k = cnt_k + 1
1070 84951 : ABI_MALLOC(wfd%s(cnt_s)%k(cnt_k)%b, (cnt_b))
1071 4556 : cnt_b = 0
1072 4556 : npw_k = Wfd%npwarr(ik_ibz)
1073 83917 : do band=1,Wfd%nband(ik_ibz, spin)
1074 87034 : if (bks_mask(band, ik_ibz, spin)) then
1075 71283 : cnt_b = cnt_b + 1
1076 : call wave_init(wfd%s(cnt_s)%k(cnt_k)%b(cnt_b), &
1077 71283 : Wfd%usepaw, npw_k, nfft0, Wfd%nspinor, Wfd%natom, Wfd%nlmn_atm, CPR_RANDOM)
1078 285132 : wfd%bks2wfd(:, band, ik_ibz, spin) = [cnt_b, cnt_k, cnt_s]
1079 : end if
1080 : end do
1081 : end do
1082 : end do
1083 :
1084 : ! ===================================================
1085 : ! ==== Precalculate nonlocal form factors for PAW ====
1086 : ! ===================================================
1087 : !
1088 : ! Calculate 1-dim structure factor phase information.
1089 1452 : ABI_MALLOC(Wfd%ph1d, (2, 3*(2*Wfd%mgfft+1)*Wfd%natom))
1090 484 : call getph(Cryst%atindx, Wfd%natom, Wfd%ngfft(1), Wfd%ngfft(2), Wfd%ngfft(3), Wfd%ph1d, Cryst%xred)
1091 :
1092 : ! TODO: This one will require some memory if nkibz is large.
1093 9596 : ABI_MALLOC(Wfd%Kdata, (Wfd%nkibz))
1094 8628 : Wfd%Kdata%use_fnl_dir0der0 = Wfd%use_fnl_dir0der0
1095 :
1096 8628 : do ik_ibz=1,Wfd%nkibz
1097 32576 : kpoint = Wfd%kibz(:,ik_ibz)
1098 8144 : istwf_k = Wfd%istwfk(ik_ibz)
1099 8144 : npw_k = Wfd%npwarr(ik_ibz)
1100 43448 : if (any(wfd%bks2wfd(1, :, ik_ibz, :) /= 0)) then
1101 4536 : call Wfd%Kdata(ik_ibz)%init(Cryst, Psps, kpoint, istwf_k, ngfft, Wfd%MPI_enreg, ecut=Wfd%ecut)
1102 : end if
1103 : end do
1104 :
1105 : select type (wfd)
1106 : class is (wfdgw_t)
1107 : ! Allocate the global table used to keep track of the bks distribution, including possible duplication.
1108 387 : bks_size = one * wfd%mband * wfd%nkibz * wfd%nsppol * wfd%nproc
1109 387 : write(msg,'(a,f8.1,a)')' Memory needed for bks_tab: ',one * bks_size * b2Mb,' [Mb] <<< MEM'
1110 387 : call wrtout(std_out, msg)
1111 :
1112 : !ABI_MALLOC(wfd%bks_ranks, (wfd%mband, nkibz, nsppol))
1113 :
1114 2322 : ABI_MALLOC(Wfd%bks_tab, (Wfd%mband, nkibz, nsppol, 0:Wfd%nproc-1))
1115 102861 : Wfd%bks_tab = WFD_NOWAVE
1116 :
1117 : ! Update the kbs table storing the distribution of the ug.
1118 387 : call wfd%update_bkstab(show=-std_out)
1119 : end select
1120 :
1121 : ! Build MPI communicator for collinear spin
1122 1452 : ABI_MALLOC(wfd%comm_spin, (nsppol))
1123 975 : do spin=1,nsppol
1124 11786 : color = merge(0, 1, any(bks_mask(:,:,spin)))
1125 975 : call xmpi_comm_split(wfd%comm, color, wfd%my_rank, wfd%comm_spin(spin), ierr)
1126 : end do
1127 :
1128 484 : call cwtime_report(" wfd_init", cpu, wall, gflops)
1129 :
1130 1452 : end subroutine wfd_init
1131 : !!***
1132 :
1133 : !----------------------------------------------------------------------
1134 :
1135 : !!****f* m_wfd/wfd_free
1136 : !! NAME
1137 : !! wfd_free
1138 : !!
1139 : !! FUNCTION
1140 : !! Free the memory allocated in the wfd_t data type.
1141 : !!
1142 : !! SOURCE
1143 :
1144 491 : subroutine wfd_free(Wfd)
1145 :
1146 : !Arguments ------------------------------------
1147 : class(wfd_t),intent(inout) :: Wfd
1148 :
1149 : !Local variables ------------------------------
1150 : integer :: ib, ik, is
1151 : !************************************************************************
1152 :
1153 : ! integer.
1154 491 : ABI_SFREE(Wfd%irottb)
1155 491 : ABI_SFREE(Wfd%istwfk)
1156 491 : ABI_SFREE(Wfd%nband)
1157 491 : ABI_SFREE(Wfd%indlmn)
1158 491 : ABI_SFREE(Wfd%nlmn_atm)
1159 491 : ABI_SFREE(Wfd%nlmn_sort)
1160 491 : ABI_SFREE(Wfd%nlmn_type)
1161 491 : ABI_SFREE(Wfd%npwarr)
1162 :
1163 : select type (wfd)
1164 : class is (wfdgw_t)
1165 387 : ABI_SFREE(Wfd%bks_tab)
1166 : end select
1167 :
1168 491 : if (allocated(wfd%s)) then
1169 975 : do is=1,size(wfd%s)
1170 5047 : do ik=1,size(wfd%s(is)%k)
1171 75839 : do ib=1,size(wfd%s(is)%k(ik)%b)
1172 75839 : call wfd%s(is)%k(ik)%b(ib)%free()
1173 : end do
1174 76330 : ABI_FREE(wfd%s(is)%k(ik)%b)
1175 : end do
1176 5531 : ABI_FREE(wfd%s(is)%k)
1177 : end do
1178 975 : ABI_FREE(wfd%s)
1179 : end if
1180 :
1181 491 : ABI_SFREE(wfd%my_nkspin)
1182 491 : ABI_SFREE(wfd%bks2wfd)
1183 :
1184 : ! real arrays.
1185 491 : ABI_SFREE(Wfd%kibz)
1186 491 : ABI_SFREE(Wfd%ph1d)
1187 :
1188 : ! logical arrays.
1189 491 : ABI_SFREE(Wfd%keep_ur)
1190 :
1191 : ! datatypes.
1192 491 : if (allocated(Wfd%Kdata)) then
1193 484 : call kdata_free(Wfd%Kdata)
1194 8628 : ABI_FREE(Wfd%Kdata)
1195 : end if
1196 :
1197 491 : call destroy_mpi_enreg(Wfd%MPI_enreg)
1198 :
1199 : ! FIXME: I don't why but this causes a SIGSEV on the test farm.
1200 : !do is=1,wfd%nsppol
1201 : ! call xmpi_comm_free(wfd%comm_spin(is))
1202 : !end do
1203 491 : ABI_SFREE(wfd%comm_spin)
1204 :
1205 491 : end subroutine wfd_free
1206 : !!***
1207 :
1208 : !----------------------------------------------------------------------
1209 :
1210 : !!****f* m_wfd/wfdgw_copy
1211 : !! NAME
1212 : !! wfdgw_copy
1213 : !!
1214 : !! FUNCTION
1215 : !! Copy a wfd_t data type.
1216 : !!
1217 : !! SOURCE
1218 :
1219 0 : subroutine wfdgw_copy(Wfd_in, Wfd_out)
1220 :
1221 : !Arguments ------------------------------------
1222 : class(wfdgw_t),intent(inout) :: Wfd_in,Wfd_out
1223 :
1224 : !Local variables ------------------------------
1225 : !scalars
1226 : integer :: band, ik_ibz, spin, cnt_s, cnt_b, ib, ik, is
1227 : !************************************************************************
1228 :
1229 : !@wfd_t
1230 0 : call deep_copy(Wfd_in%debug_level ,Wfd_out%debug_level)
1231 0 : call deep_copy(Wfd_in%lmnmax ,Wfd_out%lmnmax)
1232 0 : call deep_copy(Wfd_in%mband ,Wfd_out%mband)
1233 0 : call deep_copy(Wfd_in%mgfft ,Wfd_out%mgfft)
1234 0 : call deep_copy(Wfd_in%natom ,Wfd_out%natom)
1235 0 : call deep_copy(Wfd_in%nfft ,Wfd_out%nfft)
1236 0 : call deep_copy(Wfd_in%nfftot ,Wfd_out%nfftot)
1237 0 : call deep_copy(Wfd_in%nkibz ,Wfd_out%nkibz)
1238 0 : call deep_copy(Wfd_in%nspden ,Wfd_out%nspden)
1239 0 : call deep_copy(Wfd_in%nspinor ,Wfd_out%nspinor)
1240 0 : call deep_copy(Wfd_in%nsppol ,Wfd_out%nsppol)
1241 0 : call deep_copy(Wfd_in%ntypat ,Wfd_out%ntypat)
1242 0 : call deep_copy(Wfd_in%paral_kgb ,Wfd_out%paral_kgb)
1243 0 : call deep_copy(Wfd_in%usepaw ,Wfd_out%usepaw)
1244 0 : call deep_copy(Wfd_in%prtvol ,Wfd_out%prtvol)
1245 0 : call deep_copy(Wfd_in%pawprtvol ,Wfd_out%pawprtvol)
1246 0 : call deep_copy(Wfd_in%usewvl ,Wfd_out%usewvl)
1247 0 : call deep_copy(Wfd_in%comm ,Wfd_out%comm)
1248 0 : call deep_copy(Wfd_in%master ,Wfd_out%master)
1249 0 : call deep_copy(Wfd_in%my_rank ,Wfd_out%my_rank)
1250 0 : call deep_copy(Wfd_in%nproc ,Wfd_out%nproc)
1251 0 : call deep_copy(Wfd_in%my_nspins ,Wfd_out%my_nspins)
1252 0 : call deep_copy(Wfd_in%rfft_is_symok ,Wfd_out%rfft_is_symok)
1253 0 : call deep_copy(Wfd_in%dilatmx ,Wfd_out%dilatmx)
1254 0 : call deep_copy(Wfd_in%ecut ,Wfd_out%ecut)
1255 0 : call deep_copy(Wfd_in%ecutsm ,Wfd_out%ecutsm)
1256 :
1257 : !arrays
1258 0 : Wfd_out%ngfft =Wfd_in%ngfft
1259 0 : Wfd_out%nloalg=Wfd_in%nloalg
1260 :
1261 0 : call alloc_copy(Wfd_in%my_nkspin ,Wfd_out%my_nkspin)
1262 0 : call alloc_copy(Wfd_in%irottb ,Wfd_out%irottb)
1263 0 : call alloc_copy(Wfd_in%istwfk ,Wfd_out%istwfk)
1264 0 : call alloc_copy(Wfd_in%nband ,Wfd_out%nband)
1265 0 : call alloc_copy(Wfd_in%indlmn ,Wfd_out%indlmn)
1266 0 : call alloc_copy(Wfd_in%nlmn_atm ,Wfd_out%nlmn_atm)
1267 0 : call alloc_copy(Wfd_in%nlmn_sort ,Wfd_out%nlmn_sort)
1268 0 : call alloc_copy(Wfd_in%nlmn_type ,Wfd_out%nlmn_type)
1269 0 : call alloc_copy(Wfd_in%npwarr ,Wfd_out%npwarr)
1270 0 : call alloc_copy(Wfd_in%kibz ,Wfd_out%kibz)
1271 0 : call alloc_copy(Wfd_in%bks2wfd ,Wfd_out%bks2wfd)
1272 0 : call alloc_copy(Wfd_in%bks_tab ,Wfd_out%bks_tab)
1273 0 : call alloc_copy(Wfd_in%ph1d ,Wfd_out%ph1d)
1274 0 : call alloc_copy(Wfd_in%keep_ur ,Wfd_out%keep_ur)
1275 :
1276 : ! types
1277 0 : if (size(Wfd_in%Kdata,DIM=1) /= size(Wfd_out%Kdata,DIM=1)) then
1278 0 : ABI_REMALLOC(Wfd_out%Kdata, (Wfd_out%nkibz))
1279 : end if
1280 :
1281 0 : call kdata_copy(Wfd_in%Kdata, Wfd_out%Kdata)
1282 :
1283 : ! Allocate ragged array.
1284 0 : ABI_MALLOC(wfd_out%s, (wfd_out%my_nspins))
1285 0 : cnt_s = 0
1286 0 : do spin=1,wfd_out%nsppol
1287 0 : if (wfd_out%my_nkspin(spin) > 0) then
1288 0 : cnt_s = cnt_s + 1
1289 0 : ABI_MALLOC(wfd_out%s(cnt_s)%k, (wfd_out%my_nkspin(spin)))
1290 0 : do ik=1,wfd_out%my_nkspin(spin)
1291 0 : cnt_b = size(wfd_out%s(cnt_s)%k(ik)%b)
1292 0 : ABI_MALLOC(wfd_out%s(cnt_s)%k(ik)%b, (cnt_b))
1293 : end do
1294 : end if
1295 : end do
1296 :
1297 : ! Copy waves
1298 0 : do spin=1,wfd_in%nsppol
1299 0 : do ik_ibz=1,wfd_in%nkibz
1300 0 : do band=1,wfd_in%nband(ik_ibz, spin)
1301 0 : ib = wfd_in%bks2wfd(1, band, ik_ibz, spin)
1302 0 : ik = wfd_in%bks2wfd(2, band, ik_ibz, spin)
1303 0 : is = wfd_in%bks2wfd(3, band, ik_ibz, spin)
1304 0 : if (ib /= 0) wfd_out%s(is)%k(ik)%b(ib) = wfd_in%s(is)%k(ik)%b(ib)%copy()
1305 : end do
1306 : end do
1307 : end do
1308 :
1309 0 : call copy_mpi_enreg(Wfd_in%MPI_enreg, Wfd_out%MPI_enreg)
1310 :
1311 0 : end subroutine wfdgw_copy
1312 : !!***
1313 :
1314 : !----------------------------------------------------------------------
1315 :
1316 : !!****f* m_wfd/wfd_norm2
1317 : !! NAME
1318 : !! wfd_norm2
1319 : !!
1320 : !! FUNCTION
1321 : !! Compute <u_{bks}|u_{bks}> in G-space
1322 : !!
1323 : !! INPUTS
1324 : !! Wfd<wfd_t>=the wavefunction descriptor.
1325 : !! Cryst<crystal_t>=Structure describing the crystal structure and its symmetries.
1326 : !! Pawtab(ntypat*usepaw)<type(pawtab_type)>=PAW tabulated starting data.
1327 : !! band=Band index.
1328 : !! ik_bz=Index of the k-point in the BZ.
1329 : !! spin=Spin index
1330 : !!
1331 : !! SOURCE
1332 :
1333 0 : function wfd_norm2(Wfd,Cryst,Pawtab,band,ik_ibz,spin) result(norm2)
1334 :
1335 : !Arguments ------------------------------------
1336 : !scalars
1337 : integer,intent(in) :: band,ik_ibz,spin
1338 : real(dp) :: norm2
1339 : type(crystal_t),intent(in) :: Cryst
1340 : class(wfd_t),target,intent(inout) :: Wfd
1341 : type(Pawtab_type),intent(in) :: Pawtab(Cryst%ntypat*Wfd%usepaw)
1342 :
1343 : !Local variables ------------------------------
1344 : !scalars
1345 : integer :: npw_k,istwf_k
1346 : complex(dp) :: cdum
1347 : type(wave_t),pointer :: wave
1348 : character(len=500) :: msg
1349 : !arrays
1350 : real(dp) :: pawovlp(2)
1351 0 : complex(gwp),contiguous, pointer :: ug1(:)
1352 0 : type(pawcprj_type),allocatable :: Cp1(:,:)
1353 : !************************************************************************
1354 :
1355 : ! Planewave part.
1356 0 : npw_k = Wfd%npwarr(ik_ibz)
1357 0 : istwf_k = Wfd%istwfk(ik_ibz)
1358 :
1359 0 : ABI_CHECK(wfd%get_wave_ptr(band, ik_ibz, spin, wave, msg) == 0, msg)
1360 :
1361 0 : ug1 => wave%ug
1362 0 : cdum = xdotc(Wfd%nspinor*npw_k,ug1,1,ug1,1)
1363 :
1364 0 : if (istwf_k>1) then
1365 0 : cdum=two*DBLE(cdum)
1366 0 : if (istwf_k==2) cdum=cdum-CONJG(ug1(1))*ug1(1)
1367 : end if
1368 :
1369 : ! Paw on-site term.
1370 0 : if (Wfd%usepaw==1) then
1371 :
1372 : ! Avoid the computation if Cprj are already in memory with the correct order.
1373 0 : if (wave%has_cprj == WFD_STORED .and. wave%cprj_order == CPR_RANDOM) then
1374 0 : pawovlp = paw_overlap(wave%Cprj, wave%Cprj, Cryst%typat, Pawtab)
1375 0 : cdum = cdum + CMPLX(pawovlp(1),pawovlp(2), kind=dp)
1376 : else
1377 : ! Compute Cproj
1378 0 : ABI_MALLOC(Cp1,(Wfd%natom,Wfd%nspinor))
1379 0 : call pawcprj_alloc(Cp1,0,Wfd%nlmn_atm)
1380 0 : call wfd%get_cprj(band,ik_ibz,spin,Cryst,Cp1,sorted=.FALSE.)
1381 0 : pawovlp = paw_overlap(Cp1,Cp1,Cryst%typat,Pawtab)
1382 0 : cdum = cdum + CMPLX(pawovlp(1),pawovlp(2), kind=dp)
1383 0 : call pawcprj_free(Cp1)
1384 0 : ABI_FREE(Cp1)
1385 : end if
1386 : end if
1387 :
1388 0 : norm2 = DBLE(cdum)
1389 :
1390 0 : end function wfd_norm2
1391 : !!***
1392 :
1393 : !----------------------------------------------------------------------
1394 :
1395 : !!****f* m_wfd/wfd_xdotc
1396 : !! NAME
1397 : !! wfd_xdotc
1398 : !!
1399 : !! FUNCTION
1400 : !! Compute <u_{b1ks}|u_{b2ks}> in G-space
1401 : !!
1402 : !! INPUTS
1403 : !! Wfd<wfd_t>=the wavefunction descriptor.
1404 : !! Cryst<crystal_t>=Structure describing the crystal structure and its symmetries.
1405 : !! Pawtab(ntypat*usepaw)<type(pawtab_type)>=PAW tabulated starting data.
1406 : !! band1, band2=Band indices.
1407 : !! ik_bz=Index of the k-point in the BZ.
1408 : !! spin=Spin index
1409 : !!
1410 : !! SOURCE
1411 :
1412 0 : function wfd_xdotc(Wfd,Cryst,Pawtab,band1,band2,ik_ibz,spin)
1413 :
1414 : !Arguments ------------------------------------
1415 : !scalars
1416 : integer,intent(in) :: band1,band2,ik_ibz,spin
1417 : complex(gwp) :: wfd_xdotc
1418 : class(wfd_t),target,intent(inout) :: Wfd
1419 : type(crystal_t),intent(in) :: Cryst
1420 : !arrays
1421 : type(Pawtab_type),intent(in) :: Pawtab(Cryst%ntypat*Wfd%usepaw)
1422 :
1423 : !Local variables ------------------------------
1424 : !scalars
1425 : integer :: npw_k,istwf_k
1426 : type(wave_t),pointer :: wave1, wave2
1427 : character(len=500) :: msg
1428 : !arrays
1429 : real(dp) :: pawovlp(2)
1430 0 : complex(gwp),contiguous, pointer :: ug1(:),ug2(:)
1431 0 : type(pawcprj_type),allocatable :: Cp1(:,:),Cp2(:,:)
1432 : !************************************************************************
1433 :
1434 : ! Planewave part.
1435 0 : npw_k = Wfd%npwarr(ik_ibz)
1436 0 : istwf_k = Wfd%istwfk(ik_ibz)
1437 :
1438 0 : ABI_CHECK(wfd%get_wave_ptr(band1, ik_ibz, spin, wave1, msg) == 0, msg)
1439 0 : ABI_CHECK(wfd%get_wave_ptr(band2, ik_ibz, spin, wave2, msg) == 0, msg)
1440 0 : ug1 => wave1%ug
1441 0 : ug2 => wave2%ug
1442 :
1443 0 : wfd_xdotc = xdotc(npw_k*Wfd%nspinor,ug1,1,ug2,1)
1444 0 : if (istwf_k>1) then
1445 0 : wfd_xdotc=two*DBLE(wfd_xdotc)
1446 0 : if (istwf_k==2) wfd_xdotc = wfd_xdotc-CONJG(ug1(1))*ug2(1)
1447 : end if
1448 :
1449 : ! Paw on-site term.
1450 0 : if (Wfd%usepaw==1) then
1451 : ! Avoid the computation if Cprj are already in memory with the correct order.
1452 : if (wave1%has_cprj == WFD_STORED .and. wave1%cprj_order == CPR_RANDOM .and. &
1453 0 : wave2%has_cprj == WFD_STORED .and. wave2%cprj_order == CPR_RANDOM) then
1454 :
1455 : pawovlp = paw_overlap(wave1%Cprj, wave2%Cprj,&
1456 0 : Cryst%typat,Pawtab,spinor_comm=Wfd%MPI_enreg%comm_spinor)
1457 0 : wfd_xdotc = wfd_xdotc + CMPLX(pawovlp(1),pawovlp(2), kind=gwp)
1458 : else
1459 : ! Compute Cprj
1460 0 : ABI_MALLOC(Cp1,(Wfd%natom,Wfd%nspinor))
1461 0 : call pawcprj_alloc(Cp1,0,Wfd%nlmn_atm)
1462 0 : ABI_MALLOC(Cp2,(Wfd%natom,Wfd%nspinor))
1463 0 : call pawcprj_alloc(Cp2,0,Wfd%nlmn_atm)
1464 :
1465 0 : call wfd%get_cprj(band1,ik_ibz,spin,Cryst,Cp1,sorted=.FALSE.)
1466 0 : call wfd%get_cprj(band2,ik_ibz,spin,Cryst,Cp2,sorted=.FALSE.)
1467 :
1468 0 : pawovlp = paw_overlap(Cp1,Cp2,Cryst%typat,Pawtab,spinor_comm=Wfd%MPI_enreg%comm_spinor)
1469 0 : wfd_xdotc = wfd_xdotc + CMPLX(pawovlp(1),pawovlp(2), kind=gwp)
1470 :
1471 0 : call pawcprj_free(Cp1)
1472 0 : ABI_FREE(Cp1)
1473 0 : call pawcprj_free(Cp2)
1474 0 : ABI_FREE(Cp2)
1475 : end if
1476 : end if
1477 :
1478 0 : end function wfd_xdotc
1479 : !!***
1480 :
1481 : !----------------------------------------------------------------------
1482 :
1483 : !!****f* m_wfd/wfd_get_gvec_gbound
1484 : !! NAME
1485 : !! wfd_get_gvec_gbound
1486 : !!
1487 : !! FUNCTION
1488 : !! Return the g-sphere centered on kq and gbound_kq,
1489 : !! mainly used when looping over wavevectors in the full BZ.
1490 : !!
1491 : !! INPUTS
1492 : !!
1493 : !! OUTPUT
1494 : !!
1495 : !! SOURCE
1496 :
1497 5491 : subroutine wfd_get_gvec_gbound(wfd, gmet, ecut, kq, ikq_ibz, isirr_kq, nloalg, & ! in
1498 5491 : istwf_kq, npw_kq, kg_kq, nkpg_kq, kpg_kq, gbound_kq) ! out
1499 :
1500 : !Arguments -------------------------------
1501 : class(wfd_t),intent(in) :: wfd
1502 : real(dp),intent(in) :: gmet(3,3), ecut, kq(3)
1503 : integer,intent(in) :: ikq_ibz, nloalg(3)
1504 : logical,intent(in) :: isirr_kq
1505 : integer,intent(out) :: istwf_kq, npw_kq, kg_kq(:,:), nkpg_kq, gbound_kq(2*wfd%mgfft+8,2)
1506 : real(dp),allocatable,intent(out) :: kpg_kq(:,:)
1507 :
1508 : !Local variables ------------------------------
1509 : integer :: mpw
1510 5491 : integer,allocatable :: gtmp(:,:)
1511 : ! *********************************************************************
1512 :
1513 5491 : mpw = size(kg_kq, dim=2)
1514 :
1515 5491 : if (isirr_kq) then
1516 : ! Copy data
1517 1228 : istwf_kq = wfd%istwfk(ikq_ibz); npw_kq = wfd%npwarr(ikq_ibz)
1518 1228 : ABI_CHECK_IGEQ(mpw, npw_kq, sjoin("mpw should be => npw_kq for kq:", ktoa(kq)))
1519 4686408 : kg_kq(:,1:npw_kq) = wfd%kdata(ikq_ibz)%kg_k
1520 : else
1521 : ! Build new g-sphere centered on k+q without TR
1522 4263 : istwf_kq = 1
1523 4263 : call get_kg(kq, istwf_kq, ecut, gmet, npw_kq, gtmp)
1524 4263 : ABI_CHECK_IGEQ(mpw, npw_kq, sjoin("mpw should be => npw_kq for kq:", ktoa(kq)))
1525 11770399 : kg_kq(:,1:npw_kq) = gtmp(:,:npw_kq)
1526 4263 : ABI_FREE(gtmp)
1527 : end if
1528 :
1529 5491 : call sphereboundary(gbound_kq, istwf_kq, kg_kq, wfd%mgfft, npw_kq)
1530 :
1531 5491 : nkpg_kq = 3*nloalg(3)
1532 21964 : ABI_MALLOC(kpg_kq, (npw_kq, nkpg_kq))
1533 5491 : if (nkpg_kq > 0) call mkkpg(kg_kq, kpg_kq, kq, nkpg_kq, npw_kq)
1534 :
1535 5491 : end subroutine wfd_get_gvec_gbound
1536 : !!***
1537 :
1538 : !----------------------------------------------------------------------
1539 :
1540 : !!****f* m_wfd/wfd_reset_ur_cprj
1541 : !! NAME
1542 : !! wfd_reset_ur_cprj
1543 : !!
1544 : !! FUNCTION
1545 : !! Reinitialize the storage mode of the ur treated by this node.
1546 : !!
1547 : !! SOURCE
1548 :
1549 76 : subroutine wfd_reset_ur_cprj(Wfd)
1550 :
1551 : !Arguments ------------------------------------
1552 : class(wfd_t),intent(inout) :: Wfd
1553 :
1554 : !Local variables ------------------------------
1555 : integer :: ib, ik, is
1556 : !************************************************************************
1557 :
1558 154 : do is=1,size(wfd%s)
1559 607 : do ik=1,size(wfd%s(is)%k)
1560 5771 : do ib=1,size(wfd%s(is)%k(ik)%b)
1561 5240 : if (wfd%s(is)%k(ik)%b(ib)%has_ur == WFD_STORED) wfd%s(is)%k(ik)%b(ib)%has_ur = WFD_ALLOCATED
1562 5693 : if (wfd%usepaw == 1) then
1563 0 : if (wfd%s(is)%k(ik)%b(ib)%has_cprj == WFD_STORED) wfd%s(is)%k(ik)%b(ib)%has_cprj = WFD_ALLOCATED
1564 : end if
1565 : end do
1566 : end do
1567 : end do
1568 :
1569 76 : end subroutine wfd_reset_ur_cprj
1570 : !!***
1571 :
1572 : !----------------------------------------------------------------------
1573 :
1574 : !!****f* m_wfd/wfd_get_many_ur
1575 : !! NAME
1576 : !! wfd_get_many_ur
1577 : !!
1578 : !! FUNCTION
1579 : !! Get many wave functions in real space, either by doing a G-->R FFT
1580 : !! or by just retrieving the data already stored in Wfd.
1581 : !!
1582 : !! INPUTS
1583 : !! Wfd<wfd_t>=the wavefunction descriptor.
1584 : !! ndat=Number of wavefunctions required
1585 : !! bands(:)=Band indices.
1586 : !! ik_ibz=Index of the k-point in the IBZ.
1587 : !! spin=Spin index
1588 : !!
1589 : !! OUTPUT
1590 : !! ur(Wfd%nfft*Wfd%nspinor*SIZE(bands))=The wavefunction in real space.
1591 : !!
1592 : !! SOURCE
1593 :
1594 1124 : subroutine wfd_get_many_ur(Wfd, bands, ik_ibz, spin, ur)
1595 :
1596 : !Arguments ------------------------------------
1597 : !scalars
1598 : integer,intent(in) :: ik_ibz,spin
1599 : class(wfd_t),intent(inout) :: Wfd
1600 : !arrays
1601 : integer,intent(in) :: bands(:)
1602 : complex(gwp),intent(out) :: ur(Wfd%nfft*Wfd%nspinor*SIZE(bands))
1603 :
1604 : !Local variables ------------------------------
1605 : integer :: dat,ptr,band
1606 : !************************************************************************
1607 :
1608 9924 : do dat=1,SIZE(bands)
1609 8800 : band = bands(dat)
1610 8800 : ptr = 1 + (dat-1)*Wfd%nfft*Wfd%nspinor
1611 9924 : call wfd%get_ur(band,ik_ibz,spin,ur(ptr))
1612 : end do
1613 :
1614 1124 : end subroutine wfd_get_many_ur
1615 : !!***
1616 :
1617 : !----------------------------------------------------------------------
1618 :
1619 : !!****f* m_wfd/wfd_copy_cg
1620 : !! NAME
1621 : !! wfd_copy_cg
1622 : !!
1623 : !! FUNCTION
1624 : !! Return a copy u(g) in a real(dp) array. Useful if we have to interface
1625 : !! the wavefunction descriptor with Abinit code expecting cg(2,npw_k*nspinor) arrays
1626 : !! The routine takes also into account the fact that the ug in wfs could be stored in single-precision.
1627 : !!
1628 : !! INPUTS
1629 : !! wfd<wfd_t>=the wavefunction descriptor.
1630 : !! band=Band index.
1631 : !! ik_ibz=Index of the k-point in the IBZ.
1632 : !! spin=Spin index
1633 : !!
1634 : !! OUTPUT
1635 : !! cg(npw_k*nspinor)=The wavefunction in real space in the Abinit cg convention.
1636 : !!
1637 : !! SOURCE
1638 :
1639 397347 : subroutine wfd_copy_cg(wfd, band, ik_ibz, spin, cg)
1640 :
1641 : !Arguments ------------------------------------
1642 : !scalars
1643 : integer,intent(in) :: band,ik_ibz,spin
1644 : class(wfd_t),intent(in) :: wfd
1645 : !arrays
1646 : real(dp),intent(out) :: cg(2,*) ! npw_k*wfd%nspinor)
1647 :
1648 : !Local variables ------------------------------
1649 : !scalars
1650 : integer :: csiz
1651 : type(wave_t),pointer :: wave
1652 : character(len=500) :: msg
1653 : !************************************************************************
1654 :
1655 397347 : ABI_CHECK(wfd%get_wave_ptr(band, ik_ibz, spin, wave, msg) == 0, msg)
1656 :
1657 397347 : if (.not. wave%has_ug == WFD_STORED) then
1658 0 : write(msg,'(a,3(i0,1x),a)')" ug for (band, ik_ibz, spin): ",band, ik_ibz, spin," is not stored in memory!"
1659 0 : ABI_ERROR(msg)
1660 : end if
1661 :
1662 397347 : csiz = wfd%npwarr(ik_ibz) * wfd%nspinor
1663 : #ifdef HAVE_GW_DPC
1664 397347 : call zcopy(csiz, wave%ug, 1, cg, 1)
1665 : #else
1666 : cg(1,1:csiz) = dble(wave%ug)
1667 : cg(2,1:csiz) = aimag(wave%ug)
1668 : #endif
1669 :
1670 397347 : end subroutine wfd_copy_cg
1671 : !!***
1672 :
1673 : !----------------------------------------------------------------------
1674 :
1675 : !!****f* m_wfd/wfd_get_ur
1676 : !! NAME
1677 : !! wfd_get_ur
1678 : !!
1679 : !! FUNCTION
1680 : !! Get a wave function in real space, either by doing a G-->R FFT
1681 : !! or by just retrieving the data already stored in Wfd.
1682 : !!
1683 : !! INPUTS
1684 : !! Wfd<wfd_t>=the wavefunction descriptor.
1685 : !! band=Band index.
1686 : !! ik_ibz=Index of the k-point in the IBZ.
1687 : !! spin=Spin index
1688 : !!
1689 : !! OUTPUT
1690 : !! ur(Wfd%nfft*Wfd%nspinor)=The wavefunction in real space.
1691 : !!
1692 : !! SOURCE
1693 :
1694 2413007 : subroutine wfd_get_ur(Wfd, band, ik_ibz, spin, ur)
1695 :
1696 : !Arguments ------------------------------------
1697 : !scalars
1698 : integer,intent(in) :: band,ik_ibz,spin
1699 : class(wfd_t),target,intent(inout) :: Wfd
1700 : !arrays
1701 : complex(gwp),intent(out) :: ur(Wfd%nfft*Wfd%nspinor)
1702 :
1703 : !Local variables ------------------------------
1704 : !scalars
1705 : integer,parameter :: npw0=0,ndat1=1
1706 : integer :: npw_k, nfft, nspinor
1707 : character(len=500) :: msg
1708 : type(wave_t),pointer :: wave
1709 : !arrays
1710 2413007 : integer,contiguous, pointer :: kg_k(:,:),gbound(:,:)
1711 2413007 : complex(gwp),contiguous, pointer :: ug(:)
1712 : !************************************************************************
1713 :
1714 2413007 : npw_k = Wfd%npwarr(ik_ibz)
1715 2413007 : nfft = Wfd%nfft
1716 2413007 : nspinor= Wfd%nspinor
1717 :
1718 2413007 : ABI_CHECK(wfd%get_wave_ptr(band, ik_ibz, spin, wave, msg) == 0, msg)
1719 :
1720 2525311 : select case (wave%has_ur)
1721 :
1722 : case (WFD_NOWAVE, WFD_ALLOCATED)
1723 : ! FFT is required.
1724 112304 : if (.not. wave%has_ug == WFD_STORED) then
1725 0 : write(msg,'(a,3(i0,1x),a)')" ug for (band, ik_ibz, spin): ",band,ik_ibz,spin," is not stored in memory!"
1726 0 : ABI_ERROR(msg)
1727 : end if
1728 :
1729 112304 : ug => wave%ug
1730 112304 : kg_k => Wfd%Kdata(ik_ibz)%kg_k
1731 112304 : gbound => Wfd%Kdata(ik_ibz)%gbound(:,:)
1732 :
1733 112304 : call fft_ug(npw_k,nfft,nspinor,ndat1,Wfd%mgfft,Wfd%ngfft,Wfd%istwfk(ik_ibz),kg_k,gbound,ug,ur)
1734 :
1735 112304 : if (Wfd%keep_ur(band,ik_ibz,spin)) then
1736 : ! Store results
1737 66966 : if (wave%has_ur == WFD_NOWAVE) then
1738 : ! Alloc buffer for ur.
1739 62826 : call wave_init(wave, Wfd%usepaw,npw0,nfft,nspinor,Wfd%natom,Wfd%nlmn_atm,CPR_RANDOM)
1740 : end if
1741 66966 : call xcopy(nfft*nspinor, ur, 1, wave%ur, 1)
1742 66966 : wave%has_ur = WFD_STORED
1743 : end if
1744 :
1745 : case (WFD_STORED)
1746 : ! copy it back.
1747 2300703 : call xcopy(nfft*nspinor, wave%ur, 1, ur, 1)
1748 :
1749 : case default
1750 2413007 : ABI_BUG(sjoin("Wrong has_ur:", itoa(wave%has_ur)))
1751 : end select
1752 :
1753 2413007 : end subroutine wfd_get_ur
1754 : !!***
1755 :
1756 : !----------------------------------------------------------------------
1757 :
1758 : !!****f* m_wfd/wfd_print
1759 : !! NAME
1760 : !! wfd_print
1761 : !!
1762 : !! FUNCTION
1763 : !! Print the content of a wfd_t datatype
1764 : !!
1765 : !! INPUTS
1766 : !! units=Unit numbers for output
1767 : !! [header]=String to be printed as header for additional info.
1768 : !! [prtvol]=Verbosity level
1769 : !!
1770 : !! OUTPUT
1771 : !! Only printing
1772 : !!
1773 : !! SOURCE
1774 :
1775 938 : subroutine wfd_print(Wfd, units, header, prtvol)
1776 :
1777 : !Arguments ------------------------------------
1778 : class(wfd_t),intent(in) :: Wfd
1779 : integer,intent(in) :: units(:)
1780 : integer,optional,intent(in) :: prtvol
1781 : character(len=*),optional,intent(in) :: header
1782 :
1783 : !Local variables-------------------------------
1784 : !scalars
1785 : integer :: my_prtvol, mpw, ib, ik, is, ug_cnt, ur_cnt, cprj_cnt, spin, ik_ibz, band
1786 : real(dp) :: ug_size, ur_size, cprj_size !,kdata_bsize
1787 : character(len=500) :: msg
1788 : ! *************************************************************************
1789 :
1790 469 : my_prtvol=0 ; if (present(prtvol )) my_prtvol=prtvol
1791 :
1792 469 : msg = ' ==== Info on the wfd% object ==== '
1793 469 : if (present(header)) msg=' ==== '//TRIM(ADJUSTL(header))//' ==== '
1794 469 : call wrtout(units, msg)
1795 :
1796 : write(msg,'(3(a,i0,a),a,i0,2a,f5.1)')&
1797 469 : ' Number of irreducible k-points ........ ',Wfd%nkibz,ch10,&
1798 469 : ' Number of spinorial components ........ ',Wfd%nspinor,ch10,&
1799 469 : ' Number of spin-density components ..... ',Wfd%nspden,ch10,&
1800 469 : ' Number of spin polarizations .......... ',Wfd%nsppol,ch10,&
1801 938 : ' Plane wave cutoff energy .............. ',Wfd%ecut
1802 469 : call wrtout(units, msg)
1803 :
1804 8236 : mpw = maxval(Wfd%npwarr)
1805 : write(msg,'(3(a,i0,a))')&
1806 469 : ' Max number of G-vectors ............... ',mpw,ch10,&
1807 469 : ' Total number of FFT points ............ ',Wfd%nfftot,ch10,&
1808 938 : '- Number of FFT points treated by me .... ',Wfd%nfft,ch10
1809 469 : call wrtout(units, msg)
1810 :
1811 469 : call print_ngfft(units, Wfd%ngfft, 'FFT mesh for wavefunctions', prtvol=my_prtvol)
1812 :
1813 469 : ug_cnt = 0; ur_cnt = 0; cprj_cnt = 0
1814 945 : do spin=1,Wfd%nsppol
1815 8732 : do ik_ibz=1,Wfd%nkibz
1816 113254 : do band=1,Wfd%nband(ik_ibz,spin)
1817 104991 : ib = wfd%bks2wfd(1, band, ik_ibz, spin)
1818 104991 : if (ib == 0) cycle
1819 67295 : ik = wfd%bks2wfd(2, band, ik_ibz, spin)
1820 67295 : is = wfd%bks2wfd(3, band, ik_ibz, spin)
1821 67295 : if (wfd%s(is)%k(ik)%b(ib)%has_ug >= WFD_ALLOCATED) ug_cnt = ug_cnt + 1
1822 67295 : if (wfd%s(is)%k(ik)%b(ib)%has_ur >= WFD_ALLOCATED) ur_cnt = ur_cnt + 1
1823 75082 : if (wfd%s(is)%k(ik)%b(ib)%has_cprj >= WFD_ALLOCATED) cprj_cnt = cprj_cnt + 1
1824 : end do
1825 : end do
1826 : end do
1827 :
1828 : ! Info on memory needed for u(g), u(r) and PAW cprj
1829 469 : write(msg, '(a,i0)')'P Total number of (b,k,s) states stored by this rank: ', ug_cnt
1830 469 : call wrtout(units, msg, pre_newlines=1)
1831 :
1832 469 : ug_size = one * Wfd%nspinor * mpw * ug_cnt
1833 469 : write(msg,'(a,f8.1,a)')'P Memory allocated for Fourier components u(G): ',two*gwp*ug_size*b2Mb,' [Mb] <<< MEM'
1834 469 : call wrtout(units, msg)
1835 :
1836 51745 : if (any(wfd%keep_ur)) then
1837 349 : ur_size = one * Wfd%nspinor * Wfd%nfft * ur_cnt
1838 349 : write(msg,'(a,f8.1,a)')'P Memory allocated for real-space u(r): ',two*gwp*ur_size*b2Mb,' [Mb] <<< MEM'
1839 349 : call wrtout(units, msg)
1840 : end if
1841 :
1842 469 : if (wfd%usepaw==1) then
1843 78 : cprj_size = one * Wfd%nspinor * sum(Wfd%nlmn_atm) * cprj_cnt
1844 12 : write(msg,'(a,f8.1,a)')'P Memory allocated for PAW projections cprj: ',dp*cprj_size*b2Mb,' [Mb] <<< MEM'
1845 12 : call wrtout(units, msg)
1846 : end if
1847 :
1848 938 : write(msg,'(a,f8.1,a)')'P Memory needed for wfd%s datastructure: ',ABI_MEM_MB(wfd%s),' [Mb] <<< MEM'
1849 469 : call wrtout(units, msg)
1850 938 : write(msg,'(a,f8.1,a)')'P Memory needed for wfd%s(0)%k datastructure: ',ABI_MEM_MB(wfd%s(1)%k),' [Mb] <<< MEM'
1851 469 : call wrtout(units, msg)
1852 938 : write(msg,'(a,f8.1,a)')'P Memory allocated for Kdata array: ',ABI_MEM_MB(wfd%kdata),' [Mb] <<< MEM'
1853 469 : call wrtout(units, msg, newlines=1)
1854 :
1855 469 : end subroutine wfd_print
1856 : !!***
1857 :
1858 : !----------------------------------------------------------------------
1859 :
1860 : !!****f* m_wfd/wfd_ug2cprj
1861 : !! NAME
1862 : !! wfd_ug2cprj
1863 : !!
1864 : !! FUNCTION
1865 : !! Calculate the projected wave function <Proj_i|Cnk> with all NL projectors for a single
1866 : !! k-point, band and spin.
1867 : !!
1868 : !! INPUTS
1869 : !! Wfd<wfd_t>=Structure containing the wave functions for the GW.
1870 : !! ik_ibz=Index of the required k-point
1871 : !! spin=Required spin index.
1872 : !! choice=chooses possible output:
1873 : !! In addition to projected wave function:
1874 : !! choice=1 => nothing else
1875 : !! =2 => 1st gradients with respect to atomic position(s)
1876 : !! =3 => 1st gradients with respect to strain(s)
1877 : !! =23=> 1st gradients with respect to atm. pos. and strain(s)
1878 : !! =4 => 2nd derivatives with respect to atomic pos.
1879 : !! =24=> 1st and 2nd derivatives with respect to atomic pos.
1880 : !! =5 => 1st gradients with respect to k wavevector
1881 : !! =6 => 2nd derivatives with respect to strain and atm. pos.
1882 : !! idir=direction of the derivative, i.e. dir. of - atom to be moved in the case choice=2
1883 : !! - strain component in the case choice=3
1884 : !! - k point direction in the case choice=5
1885 : !! Compatible only with choice=2,3,5; if idir=0, all derivatives are computed
1886 : !! natom
1887 : !! Cryst
1888 : !! [sorted]=Logical flags defining if the output Cprj has to be sorted by atom type or not.
1889 : !! By default, Cprj matrix elements are unsorted.
1890 : !!
1891 : !! OUTPUT
1892 : !! cwaveprj
1893 : !!
1894 : !! SOURCE
1895 :
1896 1599 : subroutine wfd_ug2cprj(Wfd,band,ik_ibz,spin,choice,idir,natom,Cryst,cwaveprj,sorted)
1897 :
1898 : !Arguments -------------------------------
1899 : !scalars
1900 : integer,intent(in) :: choice,idir,natom,band,ik_ibz,spin
1901 : logical,optional,intent(in) :: sorted
1902 : class(wfd_t),target,intent(inout) :: Wfd
1903 : type(crystal_t),intent(in) :: Cryst
1904 : !arrays
1905 : type(pawcprj_type),intent(inout) :: cwaveprj(natom,Wfd%nspinor)
1906 :
1907 : !Local variables-------------------------------
1908 : !scalars
1909 : integer :: cpopt,istwf_k,npw_k,nkpg
1910 : integer :: ia,iatm,dimffnl,itypat,iatom,isp
1911 : character(len=500) :: msg
1912 : type(wave_t),pointer :: wave
1913 : logical :: want_sorted
1914 : !arrays
1915 1599 : integer,contiguous, pointer :: kg_k(:,:)
1916 1599 : integer,allocatable :: dimcprj_srt(:)
1917 : real(dp) :: kpoint(3)
1918 1599 : real(dp),contiguous, pointer :: phkxred(:,:)
1919 1599 : real(dp),allocatable :: cwavef(:,:), kpg(:,:)
1920 : !real(dp),allocatable :: ph1d(2,3*(2*mgfft+1)*natom)
1921 1599 : real(dp),contiguous, pointer :: ph3d(:,:,:) ! ph3d(2,npw_k,matblk)
1922 1599 : real(dp),contiguous, pointer :: ffnl(:,:,:,:) ! ffnl(npw_k,dimffnl,lmnmax,ntypat)
1923 1599 : type(pawcprj_type),allocatable :: Cprj_srt(:,:)
1924 : ! *********************************************************************
1925 :
1926 : ! Different form factors have to be calculated and stored in Kdata.
1927 0 : ABI_CHECK_IEQ(choice, 1, "choice/=1 not coded")
1928 :
1929 1599 : dimffnl = 1
1930 1599 : npw_k = Wfd%npwarr(ik_ibz)
1931 1599 : istwf_k = Wfd%istwfk(ik_ibz)
1932 6396 : kpoint = Wfd%kibz(:,ik_ibz)
1933 :
1934 1599 : kg_k => Wfd%Kdata(ik_ibz)%kg_k
1935 1599 : ph3d => Wfd%Kdata(ik_ibz)%ph3d
1936 1599 : ffnl => Wfd%Kdata(ik_ibz)%fnl_dir0der0
1937 1599 : phkxred => Wfd%Kdata(ik_ibz)%phkxred
1938 :
1939 : ! Compute (k+G) vectors
1940 1599 : nkpg=0
1941 : !% if (choice==3.or.choice==2.or.choice==23) nkpg=3*Wfd%nloalg(3)
1942 : !% if (choice==4.or.choice==24) nkpg=9*Wfd%nloalg(3)
1943 3198 : ABI_MALLOC(kpg,(npw_k,nkpg))
1944 : if (nkpg>0) call mkkpg(kg_k,kpg,kpoint,nkpg,npw_k)
1945 :
1946 : ! Copy wavefunction in G-space
1947 4797 : ABI_MALLOC(cwavef, (2,npw_k*Wfd%nspinor))
1948 1599 : ABI_CHECK(wfd%get_wave_ptr(band, ik_ibz, spin, wave, msg) == 0, msg)
1949 973832 : cwavef(1,:) = DBLE (wave%ug)
1950 973832 : cwavef(2,:) = AIMAG(wave%ug)
1951 :
1952 1599 : cpopt = 0 ! Nothing is already calculated.
1953 :
1954 1599 : want_sorted=.FALSE.; if (present(sorted)) want_sorted=sorted
1955 :
1956 1599 : if (want_sorted) then
1957 : ! Output cprj are sorted.
1958 : call getcprj(choice,cpopt,cwavef,cwaveprj,ffnl,&
1959 : idir,Wfd%indlmn,istwf_k,kg_k,kpg,kpoint,Wfd%lmnmax,Wfd%mgfft,Wfd%MPI_enreg,1,&
1960 : Cryst%natom,Cryst%nattyp,Wfd%ngfft,Wfd%nloalg,npw_k,Wfd%nspinor,Cryst%ntypat,&
1961 0 : phkxred,Wfd%ph1d,ph3d,Cryst%ucvol,1)
1962 :
1963 : else
1964 : ! Output cprj are unsorted.
1965 4797 : ABI_MALLOC(dimcprj_srt,(Cryst%natom))
1966 1599 : ia=0
1967 3534 : do itypat=1,Cryst%ntypat
1968 6309 : dimcprj_srt(ia+1:ia+Cryst%nattyp(itypat))=Wfd%nlmn_type(itypat)
1969 3534 : ia=ia+Cryst%nattyp(itypat)
1970 : end do
1971 :
1972 12369 : ABI_MALLOC(Cprj_srt,(natom,Wfd%nspinor))
1973 1599 : call pawcprj_alloc(Cprj_srt,0,dimcprj_srt)
1974 1599 : ABI_FREE(dimcprj_srt)
1975 :
1976 : ! Calculate sorted cprj.
1977 : call getcprj(choice,cpopt,cwavef,Cprj_srt,ffnl,&
1978 : idir,Wfd%indlmn,istwf_k,kg_k,kpg,kpoint,Wfd%lmnmax,Wfd%mgfft,Wfd%MPI_enreg,1,&
1979 : Cryst%natom,Cryst%nattyp,Wfd%ngfft,Wfd%nloalg,npw_k,Wfd%nspinor,Cryst%ntypat,&
1980 1599 : phkxred,Wfd%ph1d,ph3d,Cryst%ucvol,1)
1981 :
1982 : ! Reorder cprj (sorted --> unsorted)
1983 5973 : do iatom=1,Cryst%natom
1984 4374 : iatm=Cryst%atindx(iatom)
1985 10347 : do isp=1,Wfd%nspinor
1986 124146 : cwaveprj(iatom,isp)%cp=Cprj_srt(iatm,isp)%cp
1987 : end do
1988 : end do
1989 :
1990 1599 : call pawcprj_free(Cprj_srt)
1991 5973 : ABI_FREE(Cprj_srt)
1992 : end if
1993 :
1994 1599 : ABI_FREE(cwavef)
1995 1599 : ABI_FREE(kpg)
1996 :
1997 3198 : end subroutine wfd_ug2cprj
1998 : !!***
1999 :
2000 : !----------------------------------------------------------------------
2001 :
2002 : !!****f* m_wfd/wave_init
2003 : !! NAME
2004 : !! wave_init
2005 : !!
2006 : !! FUNCTION
2007 : !! Main creation method for the wave_t data type
2008 : !!
2009 : !! INPUTS
2010 : !! usepaw=1 if PAW is used.
2011 : !! npw =Number of plane-waves for ug
2012 : !! nfft=Number of FFT points for the real space wavefunction.
2013 : !! nspinor=Number of spinor components.
2014 : !! natom=Number of atoms in cprj matrix elements.
2015 : !! nlmn_size(natom)=Number of (n,l,m) channel for each atom. Ordering of atoms depends on cprj_order
2016 : !! cprj_order=Flag defining the ordering of the atoms in the cprj matrix elements (CPR_RANDOM|CPR_SORTED).
2017 : !! Use to know if we have to reorder the matrix elements when wfd_get_cprj is called.
2018 : !!
2019 : !! OUTPUT
2020 : !! Wave<wave_t>=The structure fully initialized.
2021 : !!
2022 : !! SOURCE
2023 :
2024 134109 : subroutine wave_init(Wave, usepaw, npw, nfft, nspinor, natom, nlmn_size, cprj_order)
2025 :
2026 : !Arguments ------------------------------------
2027 : !scalars
2028 : integer,intent(in) :: npw,nfft,nspinor,usepaw,natom
2029 : integer(c_int8_t),intent(in) :: cprj_order
2030 : type(wave_t),intent(inout) :: Wave
2031 : !arrays
2032 : integer,intent(in) :: nlmn_size(:)
2033 :
2034 : !Local variables ------------------------------
2035 : integer,parameter :: ncpgr0=0 ! For the time being, no derivatives
2036 : !************************************************************************
2037 :
2038 : !@wave_t
2039 134109 : if (npw >0) then
2040 213849 : ABI_MALLOC(Wave%ug, (npw*nspinor))
2041 71283 : Wave%has_ug = WFD_ALLOCATED
2042 32172485 : Wave%ug = huge(one_gw)
2043 71283 : if (usepaw == 1) then
2044 12418 : ABI_MALLOC(Wave%Cprj, (natom,nspinor))
2045 1606 : call pawcprj_alloc(Wave%Cprj,ncpgr0,nlmn_size)
2046 1606 : Wave%has_cprj = WFD_ALLOCATED
2047 1606 : Wave%cprj_order = cprj_order
2048 : end if
2049 : end if
2050 :
2051 134109 : if (nfft > 0) then
2052 188478 : ABI_MALLOC(Wave%ur, (nfft*nspinor))
2053 418007039 : Wave%ur = huge(one_gw)
2054 62826 : Wave%has_ur = WFD_ALLOCATED
2055 : end if
2056 :
2057 134109 : end subroutine wave_init
2058 : !!***
2059 :
2060 : !----------------------------------------------------------------------
2061 :
2062 : !!****f* m_wfd/wave_free
2063 : !! NAME
2064 : !! wave_free
2065 : !!
2066 : !! FUNCTION
2067 : !! Main destruction method for the wave_t datatype.
2068 : !!
2069 : !! INPUTS
2070 : !! [what]=String defining what has to be freed.
2071 : !! "A" =Both ug and ur and Cprj. Default.
2072 : !! "G" =Only ug.
2073 : !! "R" =Only ur
2074 : !! "C" =Only PAW Cprj.
2075 : !!
2076 : !! SIDE EFFECTS
2077 : !! Memory in Wave is deallocated depending on what
2078 : !!
2079 : !! SOURCE
2080 :
2081 163978 : subroutine wave_free(Wave, what)
2082 :
2083 : !Arguments ------------------------------------
2084 : !scalars
2085 : class(wave_t),intent(inout) :: Wave
2086 : character(len=*),optional,intent(in) :: what
2087 :
2088 : !Local variables ------------------------------
2089 : character(len=10) :: my_what
2090 : !************************************************************************
2091 :
2092 163978 : my_what="ALL"; if (present(what)) my_what=toupper(what)
2093 :
2094 819890 : if (.not.firstchar(my_what, ["A", "G", "R", "C"] )) then
2095 0 : ABI_ERROR(sjoin("Unknown what:", what))
2096 : end if
2097 :
2098 491934 : if (firstchar(my_what, ["A", "G"])) then
2099 79891 : ABI_SFREE(Wave%ug)
2100 79891 : Wave%has_ug = WFD_NOWAVE
2101 : end if
2102 :
2103 491934 : if (firstchar(my_what, ["A", "R"])) then
2104 163978 : ABI_SFREE(Wave%ur)
2105 163978 : Wave%has_ur = WFD_NOWAVE
2106 : end if
2107 :
2108 491934 : if (firstchar(my_what, ["A", "C"])) then
2109 79891 : if (allocated(Wave%Cprj)) then
2110 1606 : call pawcprj_free(Wave%Cprj)
2111 5994 : ABI_FREE(Wave%Cprj)
2112 : end if
2113 79891 : Wave%has_cprj = WFD_NOWAVE
2114 : end if
2115 :
2116 163978 : end subroutine wave_free
2117 : !!***
2118 :
2119 : !----------------------------------------------------------------------
2120 :
2121 : !!****f* m_wfd/wave_copy
2122 : !! NAME
2123 : !! wave_copy
2124 : !!
2125 : !! FUNCTION
2126 : !! Copy method for the wave_t datatype.
2127 : !!
2128 : !! SOURCE
2129 :
2130 0 : type(wave_t) function wave_copy(Wave_in) result(Wave_out)
2131 :
2132 : !Arguments ------------------------------------
2133 : !scalars
2134 : class(wave_t),intent(in) :: Wave_in
2135 :
2136 : !Local variables ------------------------------
2137 : integer :: natom,nspinor,iatom,ispinor
2138 : !************************************************************************
2139 :
2140 0 : Wave_out%has_ug = Wave_in%has_ug
2141 0 : Wave_out%has_ur = Wave_in%has_ur
2142 0 : Wave_out%has_cprj = Wave_in%has_cprj
2143 0 : Wave_out%cprj_order = Wave_in%cprj_order
2144 :
2145 0 : ABI_MALLOC(Wave_out%ug, (SIZE(Wave_in%ug)))
2146 0 : Wave_out%ug = Wave_in%ug
2147 0 : ABI_MALLOC(Wave_out%ur, (SIZE(Wave_in%ur)))
2148 0 : Wave_out%ur = Wave_in%ur
2149 :
2150 0 : natom = size(Wave_in%Cprj,dim=1)
2151 0 : nspinor = size(Wave_in%Cprj,dim=2)
2152 0 : if ((size(Wave_out%Cprj,dim=1) .ne. natom) .or. (size(Wave_out%Cprj,dim=2) .ne. nspinor)) then
2153 : if (allocated(Wave_out%Cprj)) then
2154 : ABI_FREE(Wave_out%Cprj)
2155 : end if
2156 0 : ABI_MALLOC(Wave_out%Cprj,(natom,nspinor))
2157 : end if
2158 :
2159 0 : do ispinor=1,nspinor
2160 0 : do iatom=1,natom
2161 0 : Wave_out%Cprj(iatom,ispinor)%ncpgr=Wave_in%Cprj(iatom,ispinor)%ncpgr
2162 0 : Wave_out%Cprj(iatom,ispinor)%nlmn=Wave_in%Cprj(iatom,ispinor)%nlmn
2163 0 : call alloc_copy(Wave_in%Cprj(iatom,ispinor)%cp,Wave_out%Cprj(iatom,ispinor)%cp)
2164 0 : call alloc_copy(Wave_in%Cprj(iatom,ispinor)%dcp,Wave_out%Cprj(iatom,ispinor)%dcp)
2165 : end do
2166 : end do
2167 :
2168 0 : end function wave_copy
2169 : !!***
2170 :
2171 : !----------------------------------------------------------------------
2172 :
2173 : !!****f* m_wfd/wfd_get_wave_prt
2174 : !! NAME
2175 : !! wfd_get_wave_prt
2176 : !!
2177 : !! FUNCTION
2178 : !! Return pointer to the wave object corresponding to the given (band, ik_ibz, spin) indices.
2179 : !! If the state is not treated ...
2180 : !!
2181 : !! INPUTS
2182 : !! band=Band index.
2183 : !! ik_ibz=k-point index
2184 : !! spin=Spin index.
2185 : !!
2186 : !! SOURCE
2187 :
2188 467394330 : integer function wfd_get_wave_ptr(wfd, band, ik_ibz, spin, wave_ptr, msg) result(ierr)
2189 :
2190 : !Arguments ------------------------------------
2191 : !scalars
2192 : integer,intent(in) :: ik_ibz, spin, band
2193 : class(wfd_t),target,intent(in) :: wfd
2194 : type(wave_t),pointer :: wave_ptr
2195 : character(len=*),intent(out) :: msg
2196 :
2197 : !Local variables ------------------------------
2198 : integer :: ib, ik, is
2199 : !************************************************************************
2200 :
2201 467394330 : ierr = 1
2202 1869577320 : if (any(wfd%bks2wfd(:, band, ik_ibz, spin) == 0)) then
2203 0 : write(msg,'(a,i0,a,3(i0,1x))')" MPI rank ",Wfd%my_rank," does not have wavefunction coefficients (ug) for (band, ik_ibz, spin): ",band,ik_ibz,spin
2204 0 : wave_ptr => null(); return
2205 : end if
2206 :
2207 467394330 : ib = wfd%bks2wfd(1, band, ik_ibz, spin)
2208 467394330 : ik = wfd%bks2wfd(2, band, ik_ibz, spin)
2209 467394330 : is = wfd%bks2wfd(3, band, ik_ibz, spin)
2210 467394330 : wave_ptr => wfd%s(is)%k(ik)%b(ib)
2211 : !if (wave_ptr%has_ug /= WFD_STORED)
2212 :
2213 467394330 : ierr = 0
2214 :
2215 467394330 : end function wfd_get_wave_ptr
2216 : !!***
2217 :
2218 : !----------------------------------------------------------------------
2219 :
2220 : !!****f* m_wfd/wfd_push_ug
2221 : !! NAME
2222 : !! wfd_push_ug
2223 : !!
2224 : !! FUNCTION
2225 : !! This routine changes the status of the object by saving the wavefunction in the correct
2226 : !! slot inside Wfd%Wave. It also set the corresponding has_ug flag to WFD_STORED.
2227 : !! If the status of the corresponding ur is (WFD_STORED|WFD_ALLOCATED), then an G->R FFT transform
2228 : !! is done (see also update_ur)
2229 : !!
2230 : !! INPUTS
2231 : !! band=Band index.
2232 : !! ik_ibz=k-point index
2233 : !! spin=Spin index.
2234 : !! Cryst<crystal_t>=Object defining the unit cell and its symmetries.
2235 : !! ug(npw_k*Wfd%nspinor)=The ug to be saved.
2236 : !! [update_ur]=If .FALSE.: no G-->R transform is done even if ur is (WFD_STORED|WFD_ALLOCATED) so be careful.
2237 : !! Defaults to .TRUE.
2238 : !! [update_cprj]=If .FALSE.: <C|p_i> matrix elements are not recalculatedd even
2239 : !! if cprj is (WFD_STORED|WFD_ALLOCATED) so be careful. Defaults to .TRUE.
2240 : !!
2241 : !! SIDE EFFECTS
2242 : !! Wfd<wfd_t>=See above.
2243 : !!
2244 : !! SOURCE
2245 :
2246 7108 : subroutine wfd_push_ug(Wfd, band, ik_ibz, spin, Cryst, ug, update_ur, update_cprj)
2247 :
2248 : !Arguments ------------------------------------
2249 : !scalars
2250 : integer,intent(in) :: ik_ibz,spin,band
2251 : logical,optional,intent(in) :: update_ur,update_cprj
2252 : class(wfd_t),target,intent(inout) :: Wfd
2253 : type(crystal_t),intent(in) :: Cryst
2254 : !arrays
2255 : complex(gwp),intent(inout) :: ug(:)
2256 :
2257 : !Local variables ------------------------------
2258 : !scalars
2259 : integer,parameter :: choice1=1,idir0=0,tim_fourdp=5,ndat1=1
2260 : integer :: npw_k, ib, ik, is
2261 : logical :: do_update_ur,do_update_cprj,want_sorted
2262 : character(len=500) :: msg
2263 : type(wave_t),pointer :: wave
2264 : !************************************************************************
2265 :
2266 7108 : if (size(ug) /= Wfd%npwarr(ik_ibz) * Wfd%nspinor) then
2267 0 : ABI_ERROR("Wrong size in assumed shape array")
2268 : end if
2269 :
2270 28432 : if (any(wfd%bks2wfd(:, band, ik_ibz, spin) == 0)) then
2271 0 : write(msg,'(a,i0,a,3(i0,1x))')" MPI rank ",Wfd%my_rank," doesn't have ug for (band, ik_ibz, spin): ",band,ik_ibz,spin
2272 0 : ABI_ERROR(msg)
2273 : end if
2274 :
2275 7108 : ib = wfd%bks2wfd(1, band, ik_ibz, spin)
2276 7108 : ik = wfd%bks2wfd(2, band, ik_ibz, spin)
2277 7108 : is = wfd%bks2wfd(3, band, ik_ibz, spin)
2278 :
2279 7108 : wave => wfd%s(is)%k(ik)%b(ib)
2280 1770410 : wave%ug = ug
2281 7108 : wave%has_ug = WFD_STORED
2282 :
2283 7108 : if (Wfd%debug_level>0) then
2284 : if (wave%has_ug == WFD_NOWAVE) then
2285 : write(msg,'(a,i0,a,3(i0,1x))')" MPI rank ",Wfd%my_rank," doesn't have ug for (band, ik_ibz, spin): ",band,ik_ibz,spin
2286 : ABI_ERROR(msg)
2287 : end if
2288 : end if
2289 :
2290 7108 : if (Wfd%usepaw==1) then
2291 : ! Update the corresponding cprj if required.
2292 0 : do_update_cprj=.TRUE.; if (present(update_cprj)) do_update_cprj=update_cprj
2293 0 : if (do_update_cprj) then
2294 0 : want_sorted = (wave%cprj_order == CPR_SORTED)
2295 0 : call wfd%ug2cprj(band, ik_ibz, spin, choice1, idir0, wfd%natom, cryst, wave%cprj, sorted=want_sorted)
2296 0 : wave%has_cprj = WFD_STORED
2297 : else
2298 0 : wave%has_cprj = WFD_ALLOCATED
2299 : end if
2300 : end if
2301 :
2302 7108 : if (any(wave%has_ur == [WFD_STORED, WFD_ALLOCATED])) then
2303 : ! Update the corresponding ur if required.
2304 2532 : do_update_ur=.TRUE.; if (present(update_ur)) do_update_ur=update_ur
2305 :
2306 0 : if (do_update_ur) then
2307 2532 : npw_k = Wfd%npwarr(ik_ibz)
2308 : call fft_ug(npw_k,Wfd%nfft,Wfd%nspinor,ndat1,Wfd%mgfft,Wfd%ngfft,Wfd%istwfk(ik_ibz),&
2309 2532 : Wfd%Kdata(ik_ibz)%kg_k,Wfd%Kdata(ik_ibz)%gbound,ug,wave%ur)
2310 2532 : wave%has_ur = WFD_STORED
2311 : else
2312 0 : wave%has_ur = WFD_ALLOCATED
2313 : end if
2314 : end if
2315 :
2316 7108 : end subroutine wfd_push_ug
2317 : !!***
2318 :
2319 : !----------------------------------------------------------------------
2320 :
2321 : !!****f* m_wfd/wfd_extract_cgblock
2322 : !! NAME
2323 : !! wfd_extract_cgblock
2324 : !!
2325 : !! FUNCTION
2326 : !! This routine extract a block of wavefunctions for a given spin and k-points.
2327 : !! The wavefunctions are stored in a real(dp) array with the same convention
2328 : !! as the one used in the GS part of Abinit, i.e cg_block(2,nspinor*npw_k*num_bands)
2329 : !!
2330 : !! INPUTS
2331 : !! Wfd<wfd_t>=Wavefunction descriptor.
2332 : !! band_list(:)=List of bands to extract
2333 : !! ik_ibz=k-point index
2334 : !! spin=Spin index.
2335 : !!
2336 : !! OUTPUT
2337 : !! cgblock(nspinor*npw_k*num_bands)=A contiguous block of memory with the set of u(g)
2338 : !!
2339 : !! SOURCE
2340 :
2341 30 : subroutine wfd_extract_cgblock(Wfd,band_list,ik_ibz,spin,cgblock)
2342 :
2343 : !Arguments ------------------------------------
2344 : !scalars
2345 : integer,intent(in) :: ik_ibz,spin
2346 : class(wfd_t),intent(in) :: Wfd
2347 : !arrays
2348 : integer,intent(in) :: band_list(:)
2349 : real(dp),intent(out) :: cgblock(:,:)
2350 :
2351 : !Local variables ------------------------------
2352 : !scalars
2353 : integer :: ii,band,start,istop,npw_k
2354 : character(len=500) :: msg
2355 : type(wave_t),pointer :: wave
2356 : !************************************************************************
2357 :
2358 30 : npw_k = Wfd%npwarr(ik_ibz)
2359 :
2360 30 : if (size(cgblock, dim=1) /= 2) then
2361 0 : ABI_ERROR("Wrong size(1) in assumed shape array")
2362 : end if
2363 :
2364 30 : if (size(cgblock, dim=2) /= Wfd%nspinor* npw_k * size(band_list)) then
2365 0 : ABI_ERROR("Wrong size in assumed shape array")
2366 : end if
2367 :
2368 30 : start = 1
2369 270 : do ii=1,size(band_list)
2370 240 : band = band_list(ii)
2371 240 : ABI_CHECK(wfd%get_wave_ptr(band, ik_ibz, spin, wave, msg) == 0, msg)
2372 240 : if (wave%has_ug /= WFD_STORED) then
2373 0 : write(msg,"(3(a,i0),a)")"u(g) for band: ",band,", ik_ibz: ",ik_ibz,", spin: ",spin," is not stored!"
2374 0 : ABI_ERROR(msg)
2375 : end if
2376 240 : istop = start + Wfd%nspinor*npw_k - 1
2377 32656 : cgblock(1,start:istop) = REAL(wave%ug)
2378 32656 : cgblock(2,start:istop) = AIMAG(wave%ug)
2379 270 : start = start + Wfd%nspinor * npw_k
2380 : end do
2381 :
2382 30 : end subroutine wfd_extract_cgblock
2383 : !!***
2384 :
2385 : !----------------------------------------------------------------------
2386 :
2387 : !!****f* m_wfd/wfdgw_rank_has_ug
2388 : !! NAME
2389 : !! wfdgw_rank_has_ug
2390 : !!
2391 : !! FUNCTION
2392 : !! This function is used to ask a particular processor whether it has a particular ug and with which status.
2393 : !!
2394 : !! INPUTS
2395 : !! rank=The MPI rank of the processor.
2396 : !! band=Band index.
2397 : !! ik_ibz=k-point index
2398 : !! spin=Spin index.
2399 : !!
2400 : !! NOTES
2401 : !! A zero index can be used to inquire the status of a bunch of states.
2402 : !! Thus (band,ik_ibz,spin) = (0,1,1) means: Do you have at least one band for the first k-point and the first spin.
2403 : !!
2404 : !! SOURCE
2405 :
2406 2525180 : function wfdgw_rank_has_ug(Wfd,rank,band,ik_ibz,spin)
2407 :
2408 : !Arguments ------------------------------------
2409 : !scalars
2410 : integer,intent(in) :: band,ik_ibz,spin,rank
2411 : logical :: wfdgw_rank_has_ug
2412 : class(wfdgw_t),intent(in) :: Wfd
2413 :
2414 : !Local variables ------------------------------
2415 : !scalars
2416 : integer :: nzeros
2417 : integer(c_int8_t) :: bks_flag
2418 : !arrays
2419 : integer :: indices(3)
2420 : !************************************************************************
2421 :
2422 10100720 : indices = [band,ik_ibz,spin]
2423 2525180 : bks_flag = WFD_STORED
2424 :
2425 10100720 : if (ALL(indices/= [0,0,0])) then
2426 2525180 : wfdgw_rank_has_ug = (Wfd%bks_tab(band,ik_ibz,spin,rank) == bks_flag); RETURN
2427 : else
2428 0 : nzeros = COUNT(indices==0)
2429 0 : if (nzeros==3) ABI_ERROR("All indices are zero!")
2430 :
2431 0 : if (band==0) then
2432 0 : if (nzeros==1) wfdgw_rank_has_ug = ANY( Wfd%bks_tab(:,ik_ibz,spin,rank)==bks_flag)
2433 0 : if (ik_ibz==0) wfdgw_rank_has_ug = ANY( Wfd%bks_tab(:,:,spin,rank) ==bks_flag)
2434 0 : if (spin ==0) wfdgw_rank_has_ug = ANY( Wfd%bks_tab(:,ik_ibz,:,rank) ==bks_flag)
2435 :
2436 0 : else if (ik_ibz==0) then
2437 0 : if (nzeros==1) wfdgw_rank_has_ug = ANY( Wfd%bks_tab(band,:,spin,rank)==bks_flag)
2438 : if (band ==0) wfdgw_rank_has_ug = ANY( Wfd%bks_tab(:,:,spin,rank) ==bks_flag)
2439 0 : if (spin ==0) wfdgw_rank_has_ug = ANY( Wfd%bks_tab(band,:,:,rank) ==bks_flag)
2440 :
2441 : else
2442 0 : if (nzeros==1) wfdgw_rank_has_ug = ANY( Wfd%bks_tab(band,ik_ibz,:,rank)==bks_flag)
2443 : if (ik_ibz==0) wfdgw_rank_has_ug = ANY( Wfd%bks_tab(band,:,:,rank) ==bks_flag)
2444 : if (band ==0) wfdgw_rank_has_ug = ANY( Wfd%bks_tab(:,ik_ibz,:,rank) ==bks_flag)
2445 : end if
2446 : end if
2447 :
2448 : end function wfdgw_rank_has_ug
2449 : !!***
2450 :
2451 : !----------------------------------------------------------------------
2452 :
2453 : !!****f* m_wfd/wfd_ihave_ug
2454 : !! NAME
2455 : !! wfd_ihave_ug
2456 : !!
2457 : !! FUNCTION
2458 : !! This function is used to ask the processor whether it has a particular ug and with which status.
2459 : !!
2460 : !! INPUTS
2461 : !! band=Band index.
2462 : !! ik_ibz=k-point index
2463 : !! spin=Spin index.
2464 : !! [how]=string defining which status is checked.
2465 : !! Possible mutually exclusive values: "Allocated", "Stored".
2466 : !! Only the first character is checked (no case-sensitive)
2467 : !! By default the function returns .TRUE. if the wave is either WFD_ALLOCATED or WFD_STORED.
2468 : !!
2469 : !! NOTES
2470 : !! A zero index can be used to inquire the status of a bunch of states.
2471 : !! Thus (band,ik_ibz,spin) = (0,1,1) means: Do you have at least one band for the first k-point and the first spin.
2472 : !!
2473 : !! SOURCE
2474 :
2475 184001 : pure function wfd_ihave_ug(Wfd, band, ik_ibz, spin, how)
2476 :
2477 : !Arguments ------------------------------------
2478 : !scalars
2479 : integer,intent(in) :: band,ik_ibz,spin
2480 : logical :: wfd_ihave_ug
2481 : character(len=*),optional,intent(in) :: how
2482 : class(wfd_t),intent(in) :: Wfd
2483 :
2484 : !Local variables ------------------------------
2485 : !scalars
2486 : integer :: ib, ik, is
2487 : integer(c_int8_t) :: check2(2)
2488 : !************************************************************************
2489 :
2490 184001 : check2 = [WFD_ALLOCATED, WFD_STORED]
2491 184001 : if (present(how)) then
2492 204585 : if (firstchar(how, ["A", "a"])) check2 = [WFD_ALLOCATED, WFD_ALLOCATED]
2493 204585 : if (firstchar(how, ["S", "s"])) check2 = [WFD_STORED, WFD_STORED]
2494 : end if
2495 184001 : ib = wfd%bks2wfd(1, band, ik_ibz, spin)
2496 184001 : ik = wfd%bks2wfd(2, band, ik_ibz, spin)
2497 184001 : is = wfd%bks2wfd(3, band, ik_ibz, spin)
2498 184001 : wfd_ihave_ug = .False.
2499 328696 : if (ib /= 0) wfd_ihave_ug = any(wfd%s(is)%k(ik)%b(ib)%has_ug == check2)
2500 :
2501 184001 : end function wfd_ihave_ug
2502 : !!***
2503 :
2504 : !----------------------------------------------------------------------
2505 :
2506 : !!****f* m_wfd/wfd_mybands
2507 : !! NAME
2508 : !! wfd_mybands
2509 : !!
2510 : !! FUNCTION
2511 : !! Return the list of band indices of the ug owned by this node at given (k,s).
2512 : !!
2513 : !! INPUTS
2514 : !! ik_ibz=Index of the k-point in the IBZ
2515 : !! spin=spin index
2516 : !! [how]=string defining which status is checked.
2517 : !! Possible mutually exclusive values: "Allocated", "Stored".
2518 : !! Only the first character is checked (no case-sensitive)
2519 : !! By default the list of bands whose status is either WFD_ALLOCATED or WFD_STORED is returned.
2520 : !!
2521 : !! OUTPUT
2522 : !! how_manyb=The number of bands owned by this node
2523 : !! my_band_list(Wfd%mband)=The first how_manyb values are the bands treated by this node.
2524 : !!
2525 : !! SOURCE
2526 :
2527 30 : subroutine wfd_mybands(Wfd, ik_ibz, spin, how_manyb, my_band_list, how)
2528 :
2529 : !Arguments ------------------------------------
2530 : !scalars
2531 : integer,intent(in) :: ik_ibz,spin
2532 : integer,intent(out) :: how_manyb
2533 : character(len=*),optional,intent(in) :: how
2534 : class(wfd_t),intent(in) :: Wfd
2535 : !arrays
2536 : integer,intent(out) :: my_band_list(Wfd%mband)
2537 :
2538 : !Local variables ------------------------------
2539 : integer :: band
2540 : logical :: do_have
2541 : !************************************************************************
2542 :
2543 270 : how_manyb=0; my_band_list=-1
2544 270 : do band=1,Wfd%nband(ik_ibz,spin)
2545 240 : if (present(how)) then
2546 240 : do_have = wfd%ihave_ug(band, ik_ibz, spin, how=how)
2547 : else
2548 0 : do_have = wfd%ihave_ug(band, ik_ibz, spin)
2549 : end if
2550 270 : if (do_have) then
2551 240 : how_manyb = how_manyb + 1
2552 240 : my_band_list(how_manyb) = band
2553 : end if
2554 : end do
2555 :
2556 30 : end subroutine wfd_mybands
2557 : !!***
2558 :
2559 : !----------------------------------------------------------------------
2560 :
2561 : !!****f* m_wfd/wfdgw_show_bkstab
2562 : !! NAME
2563 : !! wfdgw_show_bkstab
2564 : !!
2565 : !! FUNCTION
2566 : !! Print a table showing the distribution of the wavefunctions.
2567 : !!
2568 : !! SOURCE
2569 :
2570 0 : subroutine wfdgw_show_bkstab(Wfd, unit)
2571 :
2572 : !Arguments ------------------------------------
2573 : !scalars
2574 : integer,intent(in) :: unit
2575 : class(wfdgw_t),intent(in) :: Wfd
2576 :
2577 : !Local variables ------------------------------
2578 : !scalars
2579 : integer :: ik_ibz,spin,band,nband_k,width
2580 0 : character(len=1) :: chlist(0:Wfd%nproc-1)
2581 : character(len=500) :: fmt
2582 : !************************************************************************
2583 :
2584 0 : width = max(80, Wfd%nproc)
2585 :
2586 0 : write(fmt,"(a,i0,a)")"(i5,3x,",Wfd%nproc,"(a))"
2587 :
2588 0 : do spin=1,Wfd%nsppol
2589 0 : do ik_ibz=1,Wfd%nkibz
2590 0 : write(unit,"(a)")repeat("=",width)
2591 0 : write(unit,"(2(a,i0))")"Spin: ",spin,", ik_ibz: ",ik_ibz
2592 0 : write(unit,"(a)")"MPI rank ----> (A=allocated, S=Stored, N=NoWave)."
2593 0 : nband_k = Wfd%nband(ik_ibz, spin)
2594 0 : do band=1,nband_k
2595 0 : where (Wfd%bks_tab(band, ik_ibz, spin,:) == WFD_NOWAVE)
2596 : chlist = "N"
2597 : elsewhere (Wfd%bks_tab(band, ik_ibz, spin,:) == WFD_ALLOCATED)
2598 : chlist = "A"
2599 : elsewhere (Wfd%bks_tab(band, ik_ibz, spin,:) == WFD_STORED)
2600 : chlist = "S"
2601 : end where
2602 0 : write(unit,fmt)band,chlist(:)
2603 : end do
2604 0 : write(unit,"(a)")repeat("=",width)
2605 : end do
2606 : end do
2607 :
2608 0 : end subroutine wfdgw_show_bkstab
2609 : !!***
2610 :
2611 : !----------------------------------------------------------------------
2612 :
2613 : !!****f* m_wfd/wfdgw_bands_of_rank
2614 : !! NAME
2615 : !! wfdgw_bands_of_rank
2616 : !!
2617 : !! FUNCTION
2618 : !! Return the list of band index of the ug owned by a given processor at given (k,s).
2619 : !!
2620 : !! INPUTS
2621 : !! Wfd
2622 : !! rank=The MPI rank of the processor.
2623 : !! ik_ibz=Index of the k-point in the IBZ
2624 : !! spin=spin index
2625 : !!
2626 : !! OUTPUT
2627 : !! how_manyb=The number of bands owned by this node
2628 : !! rank_band_list(Wfd%mband)=The first how_manyb values are the bands treated by the node.
2629 : !!
2630 : !! SOURCE
2631 :
2632 176074 : subroutine wfdgw_bands_of_rank(Wfd,rank,ik_ibz,spin,how_manyb,rank_band_list)
2633 :
2634 : !Arguments ------------------------------------
2635 : !scalars
2636 : integer,intent(in) :: ik_ibz,spin,rank
2637 : integer,intent(out) :: how_manyb
2638 : class(wfdgw_t),intent(in) :: Wfd
2639 : !arrays
2640 : integer,intent(out) :: rank_band_list(Wfd%mband)
2641 :
2642 : !Local variables ------------------------------
2643 : integer :: band
2644 : logical :: it_has
2645 : !************************************************************************
2646 :
2647 2701254 : how_manyb=0; rank_band_list=-1
2648 2701254 : do band=1,Wfd%nband(ik_ibz,spin)
2649 2525180 : it_has = Wfd%rank_has_ug(rank, band, ik_ibz, spin)
2650 2701254 : if (it_has) then
2651 2260020 : how_manyb = how_manyb +1
2652 2260020 : rank_band_list(how_manyb)=band
2653 : end if
2654 : end do
2655 :
2656 176074 : end subroutine wfdgw_bands_of_rank
2657 : !!***
2658 :
2659 : !----------------------------------------------------------------------
2660 :
2661 : !!****f* m_wfd/wfd_get_ug
2662 : !! NAME
2663 : !! wfd_get_ug
2664 : !!
2665 : !! FUNCTION
2666 : !! Get a **copy** of a wave function in G-space.
2667 : !!
2668 : !! INPUTS
2669 : !! Wfd<wfd_t>=the data type
2670 : !! band=the index of the band.
2671 : !! ik_ibz=Index of the k-point in the IBZ
2672 : !! spin=spin index
2673 : !!
2674 : !! OUTPUT
2675 : !! ug(npw_k*Wfd%nspinor)=The required wavefunction in G-space
2676 : !!
2677 : !! SOURCE
2678 :
2679 : subroutine wfd_get_ug(Wfd, band, ik_ibz, spin, ug)
2680 :
2681 : !Arguments ------------------------------------
2682 : !scalars
2683 : integer,intent(in) :: band,ik_ibz,spin
2684 : class(wfd_t),intent(inout) :: Wfd
2685 : !arrays
2686 : complex(gwp),intent(out) :: ug(Wfd%npwarr(ik_ibz)*Wfd%nspinor)
2687 :
2688 : !Local variables ------------------------------
2689 : !scalars
2690 : integer :: npw_k
2691 : character(len=500) :: msg
2692 : type(wave_t),pointer :: wave
2693 : !************************************************************************
2694 :
2695 : ABI_CHECK(wfd%get_wave_ptr(band, ik_ibz, spin, wave, msg) == 0, msg)
2696 :
2697 : if (.not. wave%has_ug == WFD_STORED) then
2698 : write(msg,'(a,i0,a,3i0)')" Node ",Wfd%my_rank," doesn't have (band,ik_ibz,spin): ",band,ik_ibz,spin
2699 : ABI_BUG(msg)
2700 : end if
2701 :
2702 : npw_k = Wfd%npwarr(ik_ibz)
2703 : call xcopy(npw_k*Wfd%nspinor, wave%ug, 1, ug, 1)
2704 :
2705 : end subroutine wfd_get_ug
2706 : !!***
2707 :
2708 : !----------------------------------------------------------------------
2709 :
2710 : !!****f* m_wfd/wfd_wave_free
2711 : !! NAME
2712 : !! wfd_wave_free
2713 : !!
2714 : !! FUNCTION
2715 : !! Collection procedure that frees the set of waves specified by mask.
2716 : !!
2717 : !! INPUTS
2718 : !! mask(Wfd%mband,Wfd%nkibz,Wfd%nsppol)=.TRUE. if the memory allocated for
2719 : !! this state has to be freed
2720 : !! [what]=String specifying which array have to be deallocated.
2721 : !! Possible values (no case-sensitive).
2722 : !! "All"= To free both ug and ur and PAW Cprj, if any. Default
2723 : !! "G" = Only ug
2724 : !! "R" = Only ur.
2725 : !! "C" = Only PAW Cprj.
2726 : !!
2727 : !! SIDE EFFECTS
2728 : !! Wfd<wfd_t>=See above.
2729 : !!
2730 : !! SOURCE
2731 :
2732 58 : subroutine wfd_wave_free(Wfd, what, bks_mask)
2733 :
2734 : !Arguments ------------------------------------
2735 : !scalars
2736 : class(wfd_t),target,intent(inout) :: Wfd
2737 : character(len=*),optional,intent(in) :: what
2738 : !arrays
2739 : logical,optional,intent(in) :: bks_mask(Wfd%mband,Wfd%nkibz,Wfd%nsppol)
2740 :
2741 : !Local variables ------------------------------
2742 : !scalars
2743 : integer :: ik_ibz, spin, band, ib, ik, is
2744 : logical :: do_free
2745 : type(wave_t),pointer :: wave
2746 : !character(len=500) :: msg
2747 : character(len=10) :: my_what
2748 : !************************************************************************
2749 :
2750 85 : my_what="ALL"; if (present(what)) my_what=toupper(what)
2751 :
2752 172 : do spin=1,Wfd%nsppol
2753 3110 : do ik_ibz=1,Wfd%nkibz
2754 22872 : do band=1,Wfd%nband(ik_ibz,spin)
2755 19847 : do_free=.TRUE.; if (present(bks_mask)) do_free=bks_mask(band,ik_ibz,spin)
2756 14884 : if (do_free) then
2757 14837 : ib = wfd%bks2wfd(1, band, ik_ibz, spin)
2758 14837 : ik = wfd%bks2wfd(2, band, ik_ibz, spin)
2759 14837 : is = wfd%bks2wfd(3, band, ik_ibz, spin)
2760 14837 : if (ib /= 0) then
2761 14581 : wave => wfd%s(is)%k(ik)%b(ib)
2762 14581 : call wave%free(what=my_what)
2763 : end if
2764 : select type (wfd)
2765 : class is (wfdgw_t)
2766 : ! Update the associated flags if we release the G-space.
2767 44511 : if ( firstchar(my_what, ["A", "G"])) Wfd%bks_tab(band, ik_ibz, spin, Wfd%my_rank) = WFD_NOWAVE
2768 : end select
2769 : end if
2770 : end do
2771 : end do
2772 : end do
2773 :
2774 85 : end subroutine wfd_wave_free
2775 : !!***
2776 :
2777 : !----------------------------------------------------------------------
2778 :
2779 : !!****f* m_wfd/wfdgw_who_has_ug
2780 : !! NAME
2781 : !! wfdgw_who_has_ug
2782 : !!
2783 : !! FUNCTION
2784 : !! Return the number of processors having a particular (b,k,s) state as well as their MPI rank.
2785 : !! Warning: Wfd%bks_tab is supposed to be up-to-date (see wfdgw_update_bkstab).
2786 : !!
2787 : !! INPUTS
2788 : !! band=the index of the band.
2789 : !! ik_ibz=Index of the k-point in the IBZ
2790 : !! spin=spin index
2791 : !!
2792 : !! OUTPUT
2793 : !! how_many=The number of nodes owing this ug state.
2794 : !! proc_ranks(1:how_many)=Gives the MPI rank of the nodes owing the state.
2795 : !!
2796 : !! SOURCE
2797 :
2798 410262 : subroutine wfdgw_who_has_ug(Wfd,band,ik_ibz,spin,how_many,proc_ranks)
2799 :
2800 : !Arguments ------------------------------------
2801 : !scalars
2802 : integer,intent(in) :: band,ik_ibz,spin
2803 : integer,intent(out) :: how_many
2804 : class(wfdgw_t),intent(in) :: Wfd
2805 : !arrays
2806 : integer,intent(out) :: proc_ranks(Wfd%nproc)
2807 :
2808 : !Local variables ------------------------------
2809 : !scalars
2810 : integer :: irank
2811 : logical :: bks_select,spin_select,kpt_select
2812 : character(len=500) :: msg
2813 : !************************************************************************
2814 :
2815 410262 : bks_select = (band/=0.and.ik_ibz/=0.and.spin/=0)
2816 410262 : spin_select = (band==0.and.ik_ibz==0.and.spin/=0)
2817 410262 : kpt_select = (band==0.and.ik_ibz/=0.and.spin/=0)
2818 :
2819 1147564 : how_many=0; proc_ranks=-1
2820 :
2821 410262 : if (bks_select) then
2822 : ! List the proc owining this (b,k,s) state.
2823 1147564 : do irank=0,Wfd%nproc-1
2824 1147564 : if (Wfd%bks_tab(band, ik_ibz, spin, irank) == WFD_STORED) then
2825 713824 : how_many = how_many +1
2826 713824 : proc_ranks(how_many)=irank
2827 : end if
2828 : end do
2829 :
2830 0 : else if (spin_select) then
2831 : ! List the proc owining at least one state with this spin.
2832 0 : do irank=0,Wfd%nproc-1
2833 0 : if ( ANY(Wfd%bks_tab(:,:,spin,irank)==WFD_STORED) ) then
2834 0 : how_many = how_many +1
2835 0 : proc_ranks(how_many)=irank
2836 : end if
2837 : end do
2838 :
2839 0 : else if (kpt_select) then
2840 : ! List the proc owining at least one state with this (k-point, spin).
2841 0 : do irank=0,Wfd%nproc-1
2842 0 : if ( ANY(Wfd%bks_tab(:,ik_ibz,spin,irank)==WFD_STORED) ) then
2843 0 : how_many = how_many +1
2844 0 : proc_ranks(how_many)=irank
2845 : end if
2846 : end do
2847 :
2848 : else
2849 0 : write(msg,'(a,3(i0,1x))')" Wrong value for (b,k,s): ",band,ik_ibz,spin
2850 0 : ABI_ERROR(msg)
2851 : end if
2852 :
2853 410262 : end subroutine wfdgw_who_has_ug
2854 : !!***
2855 :
2856 : !----------------------------------------------------------------------
2857 :
2858 : !!****f* m_wfd/wfdgw_update_bkstab
2859 : !! NAME
2860 : !! wfdgw_update_bkstab
2861 : !!
2862 : !! FUNCTION
2863 : !! This routine should be called by all the nodes before any MPI operation involving the object.
2864 : !! It updates the bks_tab storing information on the distribution of ug.
2865 : !!
2866 : !! INPUT
2867 : !! [show]=If present and > 0, print tabs to unit show.
2868 : !!
2869 : !! SIDE EFFECTS
2870 : !! Wfd%bks_tab
2871 : !!
2872 : !! SOURCE
2873 :
2874 2460 : subroutine wfdgw_update_bkstab(Wfd, show)
2875 :
2876 : !Arguments ------------------------------------
2877 : !scalars
2878 : class(wfdgw_t),intent(inout) :: Wfd
2879 : integer,optional,intent(in) :: show
2880 :
2881 : !Local variables ------------------------------
2882 : !scalars
2883 : integer :: ierr, nelem, spin, ik_ibz, band, is, ik, ib
2884 2460 : integer(c_int8_t),allocatable :: my_vtab(:),gather_vtabs(:)
2885 : !logical,allocatable :: tab_ranks(:)
2886 : !************************************************************************
2887 :
2888 : ! Fill my slice of the global table.
2889 4959 : do spin=1,wfd%nsppol
2890 23282 : do ik_ibz=1,wfd%nkibz
2891 340127 : do band=1,Wfd%nband(ik_ibz, spin)
2892 319305 : ib = wfd%bks2wfd(1, band, ik_ibz, spin)
2893 319305 : ik = wfd%bks2wfd(2, band, ik_ibz, spin)
2894 319305 : is = wfd%bks2wfd(3, band, ik_ibz, spin)
2895 337628 : if (ib /= 0) then
2896 297789 : Wfd%bks_tab(band, ik_ibz, spin, Wfd%my_rank) = wfd%s(is)%k(ik)%b(ib)%has_ug
2897 : else
2898 21516 : Wfd%bks_tab(band, ik_ibz, spin, Wfd%my_rank) = WFD_NOWAVE
2899 : end if
2900 : end do
2901 : end do
2902 : end do
2903 :
2904 : ! Gather flags on each node.
2905 2460 : nelem = Wfd%mband*Wfd%nkibz*Wfd%nsppol
2906 7380 : ABI_MALLOC(my_vtab, (nelem))
2907 4920 : my_vtab(:) = reshape(Wfd%bks_tab(:,:,:,Wfd%my_rank), [nelem])
2908 :
2909 7380 : ABI_MALLOC(gather_vtabs, (nelem*Wfd%nproc))
2910 :
2911 2460 : call xmpi_allgather(my_vtab,nelem,gather_vtabs,Wfd%comm,ierr)
2912 :
2913 563641 : Wfd%bks_tab(:,:,:,:) = reshape(gather_vtabs, [Wfd%mband, Wfd%nkibz, Wfd%nsppol, Wfd%nproc])
2914 2460 : ABI_FREE(my_vtab)
2915 2460 : ABI_FREE(gather_vtabs)
2916 :
2917 : #if 0
2918 : ! This is gonna be slow but if lot of k-points as I cannot assume bands or k-points have been filtered
2919 : ! Need to introduce global_filter_ikibz_spin in wfd_init ...
2920 : ABI_MALLOC(tab_ranks, (wfd%nproc))
2921 : do spin=1,Wfd%nsppol
2922 : do ik_ibz=1,Wfd%nkibz
2923 : !if wfd%global_filter_ikibz_spin(ik_ibz, spin) cycle
2924 : do band=1,Wfd%nband(ik_ibz, spin)
2925 : tab_ranks = .False.
2926 : if (len(wfd%bks_ranks(band, ik_ibz, spin) > 0) then
2927 : if (any(wfd%my_rank == wfd%bks_ranks(band, ik_ibz, spin)) tab_ranks(wfd%my_rank) = .True.
2928 : end if
2929 : call xmpi_lor(tab_ranks, wfd%comm)
2930 : call bool2index(tab_ranks, wfd%bks_ranks(band, ik_ibz, spin))
2931 : end do
2932 : end do
2933 : end do
2934 : ABI_FREE(tab_ranks)
2935 : #endif
2936 :
2937 2460 : if (present(show)) then
2938 387 : if (show >= 0) call wfd%show_bkstab(unit=show)
2939 : end if
2940 :
2941 4920 : end subroutine wfdgw_update_bkstab
2942 : !!***
2943 :
2944 : !----------------------------------------------------------------------
2945 :
2946 : !!****f* m_wfd/wfdgw_distribute_bands
2947 : !! NAME
2948 : !! wfdgw_distribute_bands
2949 : !!
2950 : !! FUNCTION
2951 : !! Distribute a set of bands taking into account the distribution of the ug.
2952 : !!
2953 : !! INPUTS
2954 : !! band=the index of the band.
2955 : !! ik_ibz=Index of the k-point in the IBZ
2956 : !! spin=spin index
2957 : !! [got(Wfd%nproc)]=The number of tasks already assigned to the nodes.
2958 : !! [bmask(Wfd%mband)]=The routine will raise an error if one band index
2959 : !! is not treated by any processor. bmask can be used to select the subset of
2960 : !! indices that are expected to be available.
2961 : !!
2962 : !! OUTPUT
2963 : !! my_nband=The number of bands that will be treated by this node.
2964 : !! my_band_list(1:my_nband)=The band indices for this node
2965 : !!
2966 : !! SOURCE
2967 :
2968 47788 : subroutine wfdgw_distribute_bands(Wfd,ik_ibz,spin,my_nband,my_band_list,got,bmask)
2969 :
2970 : !Arguments ------------------------------------
2971 : !scalars
2972 : integer,intent(in) :: ik_ibz,spin
2973 : integer,intent(out) :: my_nband
2974 : class(wfdgw_t),intent(in) :: Wfd
2975 : !arrays
2976 : integer,intent(out) :: my_band_list(Wfd%mband)
2977 : integer,optional,intent(inout) :: got(Wfd%nproc)
2978 : logical,optional,intent(in) :: bmask(Wfd%mband)
2979 :
2980 : !Local variables ------------------------------
2981 : !scalars
2982 : integer :: band,how_many,idle
2983 : character(len=500) :: msg
2984 : !arrays
2985 103344 : integer :: proc_ranks(Wfd%nproc),get_more(Wfd%nproc)
2986 103344 : logical :: rank_mask(Wfd%nproc)
2987 : !************************************************************************
2988 :
2989 766539 : my_nband=0; my_band_list=0
2990 241488 : get_more=0; if (present(got)) get_more = got
2991 :
2992 766539 : do band=1,Wfd%nband(ik_ibz,spin)
2993 714867 : if (present(bmask)) then
2994 710691 : if (.not.bmask(band)) CYCLE
2995 : end if
2996 :
2997 409830 : call wfdgw_who_has_ug(Wfd, band, ik_ibz, spin, how_many, proc_ranks)
2998 :
2999 461502 : if (how_many == 1) then
3000 : ! I am the only one owing this band. Add it to list.
3001 279732 : if (proc_ranks(1) == Wfd%my_rank) then
3002 273024 : my_nband=my_nband + 1
3003 273024 : my_band_list(my_nband) = band
3004 : end if
3005 130098 : else if (how_many > 1) then
3006 : ! This band is duplicated. Assign it trying to obtain a good load distribution.
3007 1431078 : rank_mask=.FALSE.; rank_mask(proc_ranks(1:how_many)+1)=.TRUE.
3008 130098 : idle = imin_loc(get_more, mask=rank_mask)
3009 130098 : get_more(idle) = get_more(idle) + 1
3010 130098 : if (Wfd%my_rank==idle-1) then
3011 43366 : my_nband=my_nband + 1
3012 43366 : my_band_list(my_nband) = band
3013 : end if
3014 : else
3015 0 : write(msg,'(a,3(i0,1x))')" No processor has (band, ik_ibz, spin): ",band,ik_ibz,spin
3016 0 : ABI_ERROR(msg)
3017 : end if
3018 : end do
3019 :
3020 143224 : if (present(got)) got = get_more
3021 :
3022 51672 : end subroutine wfdgw_distribute_bands
3023 : !!***
3024 :
3025 : !----------------------------------------------------------------------
3026 :
3027 : !!****f* m_wfd/wfdgw_rotate
3028 : !! NAME
3029 : !! wfdgw_rotate
3030 : !!
3031 : !! FUNCTION
3032 : !! This routine performs a linear transformation of the wavefunctions stored in Wfd
3033 : !! taking into account memory distribution. The transformation is done in G-space
3034 : !! therefore all the ug should be available. Wavefunctions in real space are then
3035 : !! obtained via FFT. The implementation assumes that the matrix associated to the
3036 : !! linear transformation is sparse (No BLAS-3 calls here).
3037 : !!
3038 : !! INPUTS
3039 : !! Cryst<crystal_t>=Object defining the unit cell and its symmetries.
3040 : !! m_ks_to_qp(mband,mband,nkibz,nsppol)= expansion of the QP amplitudes in terms of KS wavefunctions.
3041 : !! [bmask(mband,nkibz,nsppol)]=The routine will raise an error if one band index
3042 : !! is not treated by any processor. bmask can be used to select the subset of
3043 : !! indices that are expected to be available.
3044 : !!
3045 : !! SIDE EFFECTS
3046 : !! Wfd<wfd_t>=See above.
3047 : !!
3048 : !! SOURCE
3049 : !!
3050 :
3051 5 : subroutine wfdgw_rotate(Wfd, Cryst, m_ks_to_qp, bmask)
3052 :
3053 : !Arguments ------------------------------------
3054 : !scalars
3055 : class(wfdgw_t),intent(inout) :: Wfd
3056 : type(crystal_t),intent(in) :: Cryst
3057 : !arrays
3058 : complex(dp),target,intent(in) :: m_ks_to_qp(Wfd%mband,Wfd%mband,Wfd%nkibz,Wfd%nsppol)
3059 : logical,optional,intent(in) :: bmask(Wfd%mband,Wfd%nkibz,Wfd%nsppol)
3060 :
3061 : !Local variables-------------------------------
3062 : !scalars
3063 : integer :: band,ik_ibz,spin,ierr,icol,nnew,inew,my_nband,ib,npw_k,istwf_k
3064 : character(len=500) :: msg
3065 : type(wave_t),pointer :: wave
3066 : !arrays
3067 214 : integer :: new_list(Wfd%mband),my_band_list(Wfd%mband)
3068 107 : complex(dp),contiguous, pointer :: umat_sk(:,:)
3069 214 : complex(gwp) :: mcol(Wfd%mband)
3070 107 : complex(gwp),allocatable :: new_ug(:,:) !, new_ur(:)
3071 : !************************************************************************
3072 :
3073 : ! Update the distribution table, first.
3074 107 : call wfd%update_bkstab()
3075 :
3076 : ! Calculate: $\Psi^{QP}_{r,b} = \sum_n \Psi^{KS}_{r,n} M_{n,b}$
3077 216 : do spin=1,Wfd%nsppol
3078 832 : do ik_ibz=1,Wfd%nkibz
3079 616 : npw_k = Wfd%npwarr(ik_ibz)
3080 616 : istwf_k = Wfd%istwfk(ik_ibz)
3081 616 : if (istwf_k /= 1) then
3082 0 : ABI_WARNING("wfdgw_rotate with istwfk /= 1")
3083 : end if
3084 616 : umat_sk => m_ks_to_qp(:,:,ik_ibz,spin)
3085 :
3086 : ! Select only those states that are mixed by the (sparse) m_ks_to_qp.
3087 7552 : nnew=0; new_list=0
3088 7552 : do icol=1,Wfd%nband(ik_ibz,spin)
3089 92684 : mcol = m_ks_to_qp(:,icol,ik_ibz,spin)
3090 6936 : mcol(icol) = mcol(icol) - cone
3091 47077 : if (ANY(ABS(mcol)>tol12)) then ! Avoid a simple copy.
3092 3816 : nnew=nnew+1
3093 3816 : new_list(nnew)=icol
3094 : end if
3095 : end do
3096 616 : if (nnew==0) CYCLE ! Nothing to do.
3097 :
3098 : ! Retrieve the set of band indices that have to be treated by
3099 : ! this node taking into account a possible duplication.
3100 378 : if (present(bmask)) then
3101 30 : call wfd%distribute_bands(ik_ibz,spin,my_nband,my_band_list,bmask=bmask(:,ik_ibz,spin))
3102 : else
3103 348 : call wfd%distribute_bands(ik_ibz,spin,my_nband,my_band_list)
3104 : end if
3105 :
3106 : !if (my_nband>0) then
3107 : ! write(std_out,*)" At (ik_ibz,spin) ",ik_ibz,spin,&
3108 : ! & ", rank ",Wfd%my_rank," will sum ",my_nband," bands, my_band_list: ",my_band_list(1:my_nband)
3109 : !end if
3110 1512 : ABI_MALLOC(new_ug,(npw_k*Wfd%nspinor,nnew))
3111 1192860 : new_ug=czero
3112 4194 : do inew=1,nnew
3113 3816 : icol = new_list(inew)
3114 44466 : do ib=1,my_nband
3115 40272 : band = my_band_list(ib)
3116 44088 : if (ABS(umat_sk(band,icol))>tol12) then
3117 36484 : ABI_CHECK(wfd%get_wave_ptr(band, ik_ibz, spin, wave, msg) == 0, msg)
3118 7275904 : new_ug(:,inew) = new_ug(:,inew) + umat_sk(band, icol) * wave%ug
3119 : end if
3120 : end do
3121 : end do
3122 :
3123 : !if (istwf_k /= 1) then
3124 : ! ABI_MALLOC(new_ur, (wfd%nfft * wfd%nspinor * nnew))
3125 : ! call fft_ug_dpc(npw_k, wfd%nfft, wfd%nspinor, nnew, wfd%mgfft, wfd%ngfft, istwf_k, &
3126 : ! wfd%kdata(ik_ibz)%kg_k, wfd%kdata(ik_ibz)%gbound, new_ug, new_ur)
3127 : ! new_ur = real(new_ur)
3128 : ! call fft_ur_dpc(npw_k, wfd%nfft, wfd%nspinor, nnew, wfd%mgfft, wfd%ngfft, istwf_k, &
3129 : ! wfd%kdata(ik_ibz)%kg_k, wfd%kdata(ik_ibz)%gbound, new_ur, new_ug)
3130 : ! ABI_FREE(new_ur)
3131 : !end if
3132 :
3133 378 : call xmpi_sum(new_ug,Wfd%comm,ierr)
3134 :
3135 : ! Update the input wave functions
3136 4194 : do inew=1,nnew
3137 3816 : band = new_list(inew)
3138 4194 : if (wfd%ihave_ug(band, ik_ibz, spin)) call wfd%push_ug(band, ik_ibz, spin, Cryst, new_ug(:,inew))
3139 : end do
3140 :
3141 1103 : ABI_FREE(new_ug)
3142 : end do !ik_ibz
3143 : end do !spin
3144 :
3145 : ! Reinit the storage mode of Wfd as ug have been changed.
3146 : ! This is needed only if FFTs are not done in wfd_push_ug. Do not know which one is faster.
3147 : !call wfd%reset_ur_cprj()
3148 107 : call xmpi_barrier(Wfd%comm)
3149 :
3150 219 : end subroutine wfdgw_rotate
3151 : !!***
3152 :
3153 : !----------------------------------------------------------------------
3154 :
3155 : !!****f* m_wfd/wfdgw_iterator_bks
3156 : !! NAME
3157 : !! wfdgw_iterator_bks
3158 : !!
3159 : !! FUNCTION
3160 : !! Iterator used to loop over bands, k-points and spin indices
3161 : !! taking into account the distribution of the ug.
3162 : !!
3163 : !! INPUTS
3164 : !! Wfd<wfd_t>=
3165 : !! bks_mask(Wfd%mband.Wfd%nkibz,Wfd%nsppol)= mask used to select the (b,k,s) indices.
3166 : !!
3167 : !! OUTPUT
3168 : !! iter_bks<iter2_t>=Iterator over the bands treated by this node for each k-point and spin.
3169 : !!
3170 : !! SOURCE
3171 :
3172 459 : type(iter2_t) function wfdgw_iterator_bks(Wfd, bks_mask) result(iter_bks)
3173 :
3174 : !Arguments ------------------------------------
3175 : !scalars
3176 : class(wfdgw_t),intent(in) :: Wfd
3177 : !arrays
3178 : logical,optional,intent(in) :: bks_mask(Wfd%mband,Wfd%nkibz,Wfd%nsppol)
3179 :
3180 : !Local variables ------------------------------
3181 : !scalars
3182 : integer :: ik_ibz,spin,my_nband
3183 : !arrays
3184 918 : integer :: my_band_list(Wfd%mband)
3185 : !************************************************************************
3186 :
3187 1377 : call iter_alloc(iter_bks,(/Wfd%nkibz,Wfd%nsppol/))
3188 :
3189 927 : do spin=1,Wfd%nsppol
3190 4402 : do ik_ibz=1,Wfd%nkibz
3191 3475 : if (present(bks_mask)) then
3192 3475 : call wfd%distribute_bands(ik_ibz,spin,my_nband,my_band_list,bmask=bks_mask(:,ik_ibz,spin))
3193 : else
3194 0 : call wfd%distribute_bands(ik_ibz,spin,my_nband,my_band_list)
3195 : end if
3196 3943 : call iter_push(iter_bks,ik_ibz,spin,my_band_list(1:my_nband))
3197 : end do
3198 : end do
3199 :
3200 459 : end function wfdgw_iterator_bks
3201 : !!***
3202 :
3203 : !----------------------------------------------------------------------
3204 :
3205 : !!****f* m_wfd/wfdgw_bks_distrb
3206 : !! NAME
3207 : !! wfdgw_bks_distrb
3208 : !!
3209 : !! FUNCTION
3210 : !! Build a local logical table indexed by bands, k-points and spin that defines
3211 : !! the distribution of the load inside the loops according to the availability of the ug.
3212 : !!
3213 : !! INPUTS
3214 : !! Wfd<wfd_t>=
3215 : !! [bks_mask(Wfd%mband,Wfd%nkibz,Wfd%nsppol)]=Mask used to skip selected (b,k,s) entries.
3216 : !! [got(Wfd%nproc)]=The number of tasks already assigned to the nodes.
3217 : !!
3218 : !! OUTPUT
3219 : !! bks_distrbk(Wfd%mband,Wfd%nkibz,Wfd%nsppol)=Global table with the rank of the node treating (b,k,s)
3220 : !!
3221 : !! SOURCE
3222 :
3223 4 : subroutine wfdgw_bks_distrb(Wfd, bks_distrb, got, bks_mask)
3224 :
3225 : !Arguments ------------------------------------
3226 : !scalars
3227 : class(wfdgw_t),intent(in) :: Wfd
3228 : !arrays
3229 : integer,intent(out) :: bks_distrb(Wfd%mband,Wfd%nkibz,Wfd%nsppol)
3230 : integer,optional,intent(inout) :: got(Wfd%nproc)
3231 : logical,optional,intent(in) :: bks_mask(Wfd%mband,Wfd%nkibz,Wfd%nsppol)
3232 :
3233 : !Local variables ------------------------------
3234 : !scalars
3235 : integer :: ik_ibz,spin,band,how_many,idle
3236 : character(len=500) :: msg
3237 : !arrays
3238 8 : integer :: get_more(Wfd%nproc),proc_ranks(Wfd%nproc)
3239 4 : logical :: rank_mask(Wfd%nproc)
3240 : !************************************************************************
3241 :
3242 8 : get_more=0; if (present(got)) get_more=got
3243 :
3244 : ! Initialize the table here to avoid problem with the cycle instruction below.
3245 224 : bks_distrb = xmpi_undefined_rank
3246 :
3247 8 : do spin=1,Wfd%nsppol
3248 32 : do ik_ibz=1,Wfd%nkibz
3249 220 : do band=1,Wfd%nband(ik_ibz,spin)
3250 192 : if (present(bks_mask)) then
3251 192 : if (.not.bks_mask(band, ik_ibz, spin)) CYCLE
3252 : end if
3253 :
3254 192 : call wfdgw_who_has_ug(Wfd, band, ik_ibz, spin, how_many, proc_ranks)
3255 :
3256 216 : if (how_many == 1) then
3257 : ! I am the only one owing this band. Add it to list.
3258 192 : bks_distrb(band, ik_ibz, spin) = proc_ranks(1)
3259 :
3260 0 : else if (how_many>1) then
3261 : ! This band is duplicated. Assign it trying to obtain a good load distribution.
3262 0 : rank_mask=.FALSE.; rank_mask(proc_ranks(1:how_many)+1)=.TRUE.
3263 0 : idle = imin_loc(get_more,mask=rank_mask)
3264 0 : get_more(idle) = get_more(idle) + 1
3265 0 : bks_distrb(band,ik_ibz,spin) = proc_ranks(idle)
3266 :
3267 : else
3268 0 : call wfd%dump_errinfo()
3269 0 : write(msg,'(a,3(i0,1x))')" Nobody has (band, ik_ibz, spin): ",band,ik_ibz,spin
3270 0 : ABI_ERROR(msg)
3271 : end if
3272 :
3273 : end do
3274 : end do
3275 : end do
3276 :
3277 4 : if (present(got)) got=get_more
3278 :
3279 4 : end subroutine wfdgw_bks_distrb
3280 : !!***
3281 :
3282 : !----------------------------------------------------------------------
3283 :
3284 : !!****f* m_wfd/wfdgw_sanity_check
3285 : !! NAME
3286 : !! wfdgw_sanity_check
3287 : !!
3288 : !! FUNCTION
3289 : !! Debugging tool
3290 : !!
3291 : !! INPUTS
3292 : !! Wfd<wfd_t>=
3293 : !!
3294 : !! OUTPUT
3295 : !!
3296 : !! SOURCE
3297 :
3298 0 : subroutine wfdgw_sanity_check(Wfd)
3299 :
3300 : !Arguments ------------------------------------
3301 : !scalars
3302 : class(wfdgw_t),intent(inout) :: Wfd
3303 :
3304 : !Local variables ------------------------------
3305 : !scalars
3306 : integer :: ik_ibz,spin,band,mpi_ierr,ierr,how_manyb,unt_dbg,irank
3307 : character(len=500) :: msg
3308 : !arrays
3309 0 : integer :: my_band_list(Wfd%mband)
3310 : !************************************************************************
3311 :
3312 0 : call wfd%update_bkstab()
3313 0 : ierr=0
3314 :
3315 0 : do spin=1,Wfd%nsppol
3316 0 : do ik_ibz=1,Wfd%nkibz
3317 0 : do band=1,Wfd%nband(ik_ibz,spin)
3318 0 : if (Wfd%bks_tab(band, ik_ibz, spin, Wfd%my_rank) == WFD_STORED .and. &
3319 0 : .not. wfd%ihave_ug(band, ik_ibz, spin, how="Stored") ) then
3320 0 : write(msg,'(a,3(i0,1x))')" Found inconsistency in bks_tab for (band, ik_ibz, spin): ",band,ik_ibz,spin
3321 0 : call wrtout(std_out, msg)
3322 0 : ierr = ierr+1
3323 : end if
3324 : end do
3325 : end do
3326 : end do
3327 :
3328 0 : call xmpi_sum(ierr,Wfd%comm,mpi_ierr)
3329 :
3330 0 : if (ierr/=0) then
3331 0 : if (open_file("__WFD_DEBUG__",msg,newunit=unt_dbg,form="formatted") /= 0) then
3332 0 : ABI_ERROR(msg)
3333 : end if
3334 :
3335 0 : do irank=0,Wfd%nproc-1
3336 0 : if (irank==Wfd%my_rank) then
3337 0 : write(unt_dbg,*)" (k,b,s) states owned by rank: ",Wfd%my_rank
3338 :
3339 0 : do spin=1,Wfd%nsppol
3340 0 : do ik_ibz=1,Wfd%nkibz
3341 0 : write(unt_dbg,*)" (spin,ik_ibz) ",spin,ik_ibz
3342 0 : call wfd%mybands(ik_ibz, spin, how_manyb, my_band_list, how="Stored")
3343 0 : write(unt_dbg,*) (my_band_list(band),band=1,how_manyb)
3344 : end do
3345 : end do
3346 :
3347 : end if
3348 : end do
3349 0 : close(unt_dbg)
3350 0 : call xmpi_barrier(Wfd%comm)
3351 0 : ABI_ERROR("Sanity check failed. Check WFD_DEBUG")
3352 : end if
3353 :
3354 0 : end subroutine wfdgw_sanity_check
3355 : !!***
3356 :
3357 : !----------------------------------------------------------------------
3358 :
3359 : !!****f* m_wfd/wfd_dump_errinfo
3360 : !! NAME
3361 : !! wfd_dump_errinfo
3362 : !!
3363 : !! FUNCTION
3364 : !!
3365 : !! INPUTS
3366 : !! Wfd<wfd_t>=
3367 : !!
3368 : !! OUTPUT
3369 : !!
3370 : !! SOURCE
3371 :
3372 0 : subroutine wfd_dump_errinfo(Wfd,onfile)
3373 :
3374 : !Arguments ------------------------------------
3375 : !scalars
3376 : logical,optional,intent(in) :: onfile
3377 : class(wfd_t),intent(in) :: Wfd
3378 :
3379 : !Local variables ------------------------------
3380 : !scalars
3381 : integer :: ik_ibz,spin,band,how_manyb,unt_dbg
3382 : character(len=10) :: strank
3383 : character(len=500) :: msg
3384 : character(len=fnlen) :: fname_dbg
3385 : !arrays
3386 0 : integer :: my_band_list(Wfd%mband)
3387 : !************************************************************************
3388 :
3389 0 : unt_dbg=std_out
3390 :
3391 0 : if (present(onfile)) then
3392 0 : if (onfile) then
3393 0 : call int2char10(Wfd%my_rank,strank)
3394 0 : fname_dbg = "WFD_DEBUG_RANK"//TRIM(strank)
3395 0 : if (open_file(fname_dbg,msg,newunit=unt_dbg,form="formatted") /= 0) then
3396 0 : ABI_ERROR(msg)
3397 : end if
3398 : end if
3399 : end if
3400 :
3401 0 : write(unt_dbg,*)" (k,b,s) states owned by rank: ",Wfd%my_rank
3402 0 : do spin=1,Wfd%nsppol
3403 0 : do ik_ibz=1,Wfd%nkibz
3404 0 : write(unt_dbg,*)" ug stored at (ik_ibz, spin) ",ik_ibz,spin
3405 0 : call wfd%mybands(ik_ibz, spin, how_manyb, my_band_list, how="Stored")
3406 0 : write(unt_dbg,*) (my_band_list(band),band=1,how_manyb)
3407 : end do
3408 : end do
3409 :
3410 0 : end subroutine wfd_dump_errinfo
3411 : !!***
3412 :
3413 : !----------------------------------------------------------------------
3414 :
3415 : !!****f* m_wfd/wfdgw_distribute_bbp
3416 : !! NAME
3417 : !! wfdgw_distribute_bbp
3418 : !!
3419 : !! FUNCTION
3420 : !! Distribute a set of (b,b') indices taking into account the MPI distribution of the ug.
3421 : !! It is used to calculate matrix elements of the form <b,k,s|O|b',k,s>
3422 : !!
3423 : !! INPUTS
3424 : !! Wfd<wfd_t>=
3425 : !! ik_ibz=The index of the k-point in the IBZ.
3426 : !! spin=Spin index.
3427 : !! allup=String used to select or not the upper triangle. Possible values:
3428 : !! "All" =Entire (b,b') matrix will be distributed.
3429 : !! "Upper"=Only the upper triangle is distributed.
3430 : !! [got(%nproc)]=The number of tasks already assigned to the nodes. Used to optimize the work load.
3431 : !! Be careful when this routine is called inside several loops since each node should call the routine
3432 : !! at each iteration with the same (local) copy of got so that bbp_distrb will assume the same value on each node.
3433 : !! [bbp_mask(%mband,%mband)]= mask used to select a subset of (b,b') indices.
3434 : !!
3435 : !! OUTPUT
3436 : !! my_nbbp=The number of (b,b') indices treated by this node.
3437 : !! bbp_distrb(%mband%mband)=The rank of the node that will treat (b,b').
3438 : !!
3439 : !! SOURCE
3440 :
3441 2424 : subroutine wfdgw_distribute_bbp(Wfd,ik_ibz,spin,allup,my_nbbp,bbp_distrb,got,bbp_mask)
3442 :
3443 : !Arguments ------------------------------------
3444 : !scalars
3445 : integer,intent(in) :: ik_ibz,spin
3446 : integer,intent(out) :: my_nbbp
3447 : class(wfdgw_t),intent(in) :: Wfd
3448 : character(len=*),intent(in) :: allup
3449 : !arrays
3450 : integer,intent(out) :: bbp_distrb(Wfd%mband,Wfd%mband)
3451 : integer,optional,intent(inout) :: got(Wfd%nproc)
3452 : logical,optional,intent(in) :: bbp_mask(Wfd%mband,Wfd%mband)
3453 :
3454 : !Local variables ------------------------------
3455 : !arrays
3456 9180 : integer :: loc_got(Wfd%nproc)
3457 : !************************************************************************
3458 :
3459 : ! Just a wrapper around wfdgw_distribute_kb_kpbp.
3460 31300 : loc_got=0; if (present(got)) loc_got = got
3461 :
3462 9180 : if (present(bbp_mask)) then
3463 9180 : call wfd%distribute_kb_kpbp(ik_ibz,ik_ibz,spin,allup,my_nbbp,bbp_distrb,loc_got,bbp_mask)
3464 : else
3465 0 : call wfd%distribute_kb_kpbp(ik_ibz,ik_ibz,spin,allup,my_nbbp,bbp_distrb,loc_got)
3466 : end if
3467 :
3468 9180 : end subroutine wfdgw_distribute_bbp
3469 : !!***
3470 :
3471 : !----------------------------------------------------------------------
3472 :
3473 : !!****f* m_wfd/wfdgw_distribute_kb_kpbp
3474 : !! NAME
3475 : !! wfdgw_distribute_kb_kpbp
3476 : !!
3477 : !! FUNCTION
3478 : !! This routines distributes as set of (b,b') indices taking into account the MPI distribution of the ug.
3479 : !! It is used to calculate matrix elements of the form <b,k,s|O|b',k',s>
3480 : !!
3481 : !! INPUTS
3482 : !! Wfd<wfd_t>=
3483 : !! ik_ibz =The index of the k-point k in the IBZ.
3484 : !! ikp_ibz=The index of the k-point k' in the IBZ.
3485 : !! spin=Spin index.
3486 : !! allup=String used to select the upper triangle of the (b,b') matrix. Possible values:
3487 : !! "All" =Entire (b,b') matrix will be distributed.
3488 : !! "Upper"=Only the upper triangle is distributed.
3489 : !! [got(%nproc)]=The number of tasks already assigned to the nodes. Used to optimize the distribution of the tasks.
3490 : !! Be careful when this routine is called inside several loops since each node should call the routine
3491 : !! at each iteration with the same (local) copy of got so that bbp_distrb will assume the same value on each node.
3492 : !! [bbp_mask(%mband,%mband)]= mask used to select a subset of (b,b') indices.
3493 : !!
3494 : !! OUTPUT
3495 : !! my_nbbp=The number of (b,b') indices treated by this node.
3496 : !! bbp_distrb(%mband%mband)=The rank of the node that will treat (b,b').
3497 : !!
3498 : !! SOURCE
3499 :
3500 85774 : subroutine wfdgw_distribute_kb_kpbp(Wfd, ik_ibz, ikp_ibz, spin, allup, my_nbbp, bbp_distrb, &
3501 85774 : got, bbp_mask) ! optional
3502 :
3503 : !Arguments ------------------------------------
3504 : !scalars
3505 : integer,intent(in) :: ik_ibz,ikp_ibz,spin
3506 : integer,intent(out) :: my_nbbp
3507 : class(wfdgw_t),intent(in) :: Wfd
3508 : character(len=*),intent(in) :: allup
3509 : !arrays
3510 : integer,intent(out) :: bbp_distrb(Wfd%mband,Wfd%mband)
3511 : integer,optional,intent(inout) :: got(Wfd%nproc)
3512 : logical,optional,intent(in) :: bbp_mask(Wfd%mband,Wfd%mband)
3513 :
3514 : !Local variables ------------------------------
3515 : !scalars
3516 : integer :: my_nband,ib1,ib2,pcb2,pcb1,howmany_b,howmany_bp,workload_min
3517 : integer :: rank,ncpus,idle,b1_stop,ierr
3518 : character(len=500) :: msg
3519 : !arrays
3520 85774 : integer :: rank_bandlist_k(Wfd%mband),rank_bandlist_kp(Wfd%mband)
3521 85774 : integer :: get_more(Wfd%nproc),my_band_list_k(Wfd%mband)
3522 42887 : integer,allocatable :: whocan_k(:,:),whocan_kp(:,:)
3523 85774 : logical :: b_mask(Wfd%mband)
3524 : !************************************************************************
3525 :
3526 171548 : ABI_MALLOC_OR_DIE(whocan_k ,(Wfd%mband,Wfd%nproc), ierr)
3527 171548 : ABI_MALLOC_OR_DIE(whocan_kp,(Wfd%mband,Wfd%nproc), ierr)
3528 1393514 : whocan_k =0 ! Will be set to 1 if this node can calculate something containing (k,b)
3529 1393514 : whocan_kp=0 ! Will be set to 1 if this node can calculate something containing (kp,bp)
3530 :
3531 130924 : do rank=0,Wfd%nproc-1
3532 :
3533 88037 : call wfd%bands_of_rank(rank,ik_ibz ,spin,howmany_b, rank_bandlist_k )
3534 1218047 : do pcb1=1,howmany_b
3535 1130010 : ib1 = rank_bandlist_k(pcb1)
3536 1218047 : whocan_k(ib1,rank+1) = 1
3537 : end do
3538 :
3539 88037 : call wfd%bands_of_rank(rank,ikp_ibz,spin,howmany_bp,rank_bandlist_kp)
3540 1348971 : do pcb2=1,howmany_bp
3541 1130010 : ib2 = rank_bandlist_kp(pcb2)
3542 1218047 : whocan_kp(ib2,rank+1) = 1
3543 : end do
3544 :
3545 : end do
3546 :
3547 218961 : get_more=0; if (present(got)) get_more=got
3548 42887 : b1_stop=Wfd%nband(ik_ibz,spin)
3549 :
3550 20659353 : bbp_distrb = xmpi_undefined_rank
3551 :
3552 713221 : do ib2=1,Wfd%nband(ikp_ibz,spin)
3553 40562598 : b_mask = .TRUE.; if (present(bbp_mask)) b_mask = bbp_mask(:,ib2)
3554 17916804 : if (ANY(b_mask)) then
3555 3755718 : my_nband=0; my_band_list_k=0
3556 : ! Only the upper triangle of the (b1,b2) matrix.
3557 653211 : if (firstchar(allup, ["U","u"])) b1_stop = MIN(ib2,Wfd%nband(ik_ibz,spin))
3558 :
3559 3670689 : do ib1=1,b1_stop
3560 3670689 : if (b_mask(ib1)) then
3561 : !
3562 : ! find which CPUs can do the calculation (k,b)->(kp,bp)
3563 : ! find the one which is less busy
3564 2354185 : ncpus=0
3565 2354185 : workload_min=HUGE(0)
3566 6445042 : do rank=0,Wfd%nproc-1
3567 6445042 : if( whocan_k(ib1,rank+1)==1 .AND. whocan_kp(ib2,rank+1)==1 ) then
3568 3596629 : ncpus=ncpus+1
3569 3596629 : if( get_more(rank+1) < workload_min ) then
3570 2707613 : idle=rank+1
3571 2707613 : workload_min=get_more(idle)
3572 : end if
3573 :
3574 : end if
3575 : end do
3576 :
3577 2354185 : if(ncpus>0) then
3578 2354185 : bbp_distrb(ib1,ib2)=idle-1
3579 2354185 : get_more(idle) = get_more(idle) + 1
3580 :
3581 : else
3582 0 : call wfd%dump_errinfo()
3583 0 : write(msg,'(a,5(i0,1x))')" Nobody has (band1, ik_ibz) (band2, ikp_ibz) spin: ",ib1,ik_ibz,ib2,ikp_ibz,spin
3584 0 : ABI_ERROR(msg)
3585 : end if
3586 :
3587 : end if
3588 : end do ! ib1
3589 : end if
3590 : end do ! ib2
3591 :
3592 42887 : ABI_FREE(whocan_k)
3593 42887 : ABI_FREE(whocan_kp)
3594 :
3595 20659353 : my_nbbp = COUNT(bbp_distrb==Wfd%my_rank)
3596 130924 : if (present(got)) got=get_more
3597 :
3598 85774 : end subroutine wfdgw_distribute_kb_kpbp
3599 : !!***
3600 :
3601 : !----------------------------------------------------------------------
3602 :
3603 : !!****f* m_wfd/wfd_get_cprj
3604 : !! NAME
3605 : !! wfd_get_cprj
3606 : !!
3607 : !! FUNCTION
3608 : !! Return a copy of Cprj either by calculating it on-the-fly or by just retrieving the data already stored in the data type.
3609 : !!
3610 : !! INPUTS
3611 : !! Wfd<wfd_t>=the wavefunction descriptor.
3612 : !! band=Band index.
3613 : !! ik_ibz=Index of the k-point in the IBZ.
3614 : !! spin=Spin index
3615 : !! sorted=.TRUE. if the output cprj matrix elements have to be sorted by atom type.
3616 : !!
3617 : !! OUTPUT
3618 : !! Cprj_out(Wfd%natom,Wfd%nspinor) <type(pawcprj_type)>=Unsorted matrix elements.
3619 : !!
3620 : !! SOURCE
3621 :
3622 130075 : subroutine wfd_get_cprj(Wfd, band, ik_ibz, spin, Cryst, Cprj_out, sorted)
3623 :
3624 : !Arguments ------------------------------------
3625 : !scalars
3626 : integer,intent(in) :: band,ik_ibz,spin
3627 : logical,intent(in) :: sorted
3628 : class(wfd_t),intent(inout) :: Wfd
3629 : type(crystal_t),intent(in) :: Cryst
3630 : !arrays
3631 : type(pawcprj_type),intent(inout) :: Cprj_out(Wfd%natom,Wfd%nspinor)
3632 :
3633 : !Local variables ------------------------------
3634 : !scalars
3635 : integer,parameter :: choice1=1,idir0=0
3636 : integer :: want_order,iatom,sidx
3637 : character(len=500) :: msg
3638 : type(wave_t),pointer :: wave
3639 : !************************************************************************
3640 :
3641 130075 : want_order=CPR_RANDOM; if (sorted) want_order=CPR_SORTED
3642 :
3643 130075 : ABI_CHECK(wfd%get_wave_ptr(band, ik_ibz, spin, wave, msg) == 0, msg)
3644 :
3645 131674 : select case (wave%has_cprj)
3646 :
3647 : case (WFD_NOWAVE, WFD_ALLOCATED)
3648 : ! Have to calculate it!
3649 1599 : if (.not. wave%has_ug == WFD_STORED) then
3650 0 : write(msg,'(a,3(i0,1x),a)')" ug for (band, ik_ibz, spin): ",band,ik_ibz,spin," is not stored in memory!"
3651 0 : ABI_ERROR(msg)
3652 : end if
3653 : ! Get cprj.
3654 1599 : call wfd%ug2cprj(band,ik_ibz,spin,choice1,idir0,Wfd%natom,Cryst,Cprj_out,sorted=sorted)
3655 :
3656 1599 : if (wave%has_cprj == WFD_ALLOCATED) then
3657 : ! Store it.
3658 1599 : if (want_order == wave%cprj_order) then
3659 1599 : call pawcprj_copy(Cprj_out, wave%Cprj)
3660 1599 : wave%has_cprj = WFD_STORED
3661 :
3662 : else
3663 : ! Have to reorder cprj_out
3664 0 : select case (want_order)
3665 : case (CPR_SORTED)
3666 0 : do iatom=1,Cryst%natom
3667 0 : sidx = Cryst%atindx(iatom) ! random --> sorted table.
3668 0 : call pawcprj_copy(Cprj_out(sidx:sidx,:), wave%Cprj(iatom:iatom,:))
3669 : end do
3670 : case (CPR_RANDOM)
3671 0 : do sidx=1,Cryst%natom
3672 0 : iatom = Cryst%atindx1(sidx) ! sorted --> random table.
3673 0 : call pawcprj_copy(Cprj_out(iatom:iatom,:), wave%Cprj(sidx:sidx,:))
3674 : end do
3675 : case default
3676 0 : ABI_ERROR(sjoin("Wrong value for want_order:", itoa(want_order)))
3677 : end select
3678 : end if
3679 : end if
3680 :
3681 : case (WFD_STORED)
3682 : ! copy it back.
3683 128476 : if (want_order == wave%cprj_order) then
3684 128476 : call pawcprj_copy(wave%Cprj,Cprj_out)
3685 :
3686 : else
3687 0 : select case (want_order)
3688 : case (CPR_SORTED)
3689 0 : do iatom=1,Cryst%natom
3690 0 : sidx = Cryst%atindx(iatom) ! random --> sorted table.
3691 0 : call pawcprj_copy(wave%Cprj(iatom:iatom,:),Cprj_out(sidx:sidx,:))
3692 : end do
3693 : case (CPR_RANDOM)
3694 0 : do sidx=1,Cryst%natom
3695 0 : iatom = Cryst%atindx1(sidx) ! sorted --> random table.
3696 0 : call pawcprj_copy(wave%Cprj(sidx:sidx,:),Cprj_out(iatom:iatom,:))
3697 : end do
3698 : case default
3699 0 : ABI_ERROR(sjoin("Wrong value for want_order:", itoa(want_order)))
3700 : end select
3701 : end if
3702 :
3703 : case default
3704 130075 : ABI_BUG(sjoin("Wrong has_cprj: ", itoa(wave%has_cprj)))
3705 : end select
3706 :
3707 130075 : end subroutine wfd_get_cprj
3708 : !!***
3709 :
3710 : !----------------------------------------------------------------------
3711 :
3712 : !!****f* m_wfd/wfd_change_ngfft
3713 : !! NAME
3714 : !! wfd_change_ngfft
3715 : !!
3716 : !! FUNCTION
3717 : !! Reallocate and reinitialize internal tables for performing FFTs of wavefunctions.
3718 : !!
3719 : !! INPUTS
3720 : !! Cryst<crystal_t>=Info on unit cell.
3721 : !! Psps<pseudopotential_type>=Pseudopotential info.
3722 : !! new_ngfft(18)=FFT descriptor for the new FFT mesh.
3723 : !!
3724 : !! SOURCE
3725 :
3726 645 : subroutine wfd_change_ngfft(Wfd, Cryst, Psps, new_ngfft)
3727 :
3728 : !Arguments ------------------------------------
3729 : !scalars
3730 : integer,intent(in) :: new_ngfft(18)
3731 : type(crystal_t),intent(in) :: Cryst
3732 : type(pseudopotential_type),intent(in) :: Psps
3733 : class(wfd_t),intent(inout) :: Wfd
3734 :
3735 : !Local variables ------------------------------
3736 : !scalars
3737 : integer,parameter :: npw0=0
3738 : integer :: npw_k, ik_ibz, istwf_k, is, ik, ib
3739 : logical :: iscompatibleFFT
3740 : !character(len=500) :: msg
3741 : !arrays
3742 645 : integer,allocatable :: kg_k(:,:)
3743 : !************************************************************************
3744 :
3745 654 : if (all(Wfd%ngfft(1:3) == new_ngfft(1:3)) ) RETURN ! Nothing to do.
3746 :
3747 642 : if (Wfd%prtvol > 0) then
3748 89 : call wrtout(std_out, sjoin(" Changing FFT mesh for wavefunctions: ",ltoa(Wfd%ngfft(1:3)), " ==> ", ltoa(new_ngfft(1:3))))
3749 : end if
3750 :
3751 : ! Change FFT dimensions.
3752 12198 : Wfd%ngfft = new_ngfft
3753 2568 : Wfd%mgfft = MAXVAL(new_ngfft(1:3))
3754 2568 : Wfd%nfftot = PRODUCT(new_ngfft(1:3))
3755 642 : Wfd%nfft = Wfd%nfftot ! No FFT parallelism.
3756 :
3757 : ! Re-initialize fft distribution
3758 642 : call Wfd%MPI_enreg%distribfft%free()
3759 642 : call Wfd%MPI_enreg%distribfft%init('c',Wfd%MPI_enreg%nproc_fft,new_ngfft(2),new_ngfft(3))
3760 :
3761 1926 : ABI_REMALLOC(Wfd%ph1d,(2,3*(2*Wfd%mgfft+1)*Cryst%natom))
3762 642 : call getph(Cryst%atindx,Cryst%natom,Wfd%ngfft(1),Wfd%ngfft(2),Wfd%ngfft(3),Wfd%ph1d,Cryst%xred)
3763 :
3764 : ! Recalculate FFT tables.
3765 : ! Calculate the FFT index of $ R^{-1} (r-\tau) $ used to symmetrize u_Rk.
3766 : #ifdef FC_LLVM
3767 : ! LLVM 16 doesn't recognize this macro here
3768 : ABI_REMALLOC(Wfd%irottb, (Wfd%nfftot,Cryst%nsym) )
3769 : #else
3770 2568 : ABI_REMALLOC(Wfd%irottb, (Wfd%nfftot,Cryst%nsym))
3771 : #endif
3772 642 : call rotate_FFT_mesh(Cryst%nsym,Cryst%symrel,Cryst%tnons,Wfd%ngfft,Wfd%irottb,iscompatibleFFT)
3773 :
3774 642 : if (.not. iscompatibleFFT) then
3775 120 : ABI_WARNING("FFT mesh not compatible with symmetries. Wavefunction symmetrization should not be done in r-space!")
3776 : end if
3777 :
3778 : ! Is the new real space FFT mesh compatible with the rotational part?
3779 642 : Wfd%rfft_is_symok = check_rot_fft(Cryst%nsym,Cryst%symrel,Wfd%ngfft(1),Wfd%ngfft(2),Wfd%ngfft(3))
3780 :
3781 : ! Reallocate ur buffers with correct dimensions.
3782 1296 : do is=1,size(wfd%s)
3783 6279 : do ik=1,size(wfd%s(is)%k)
3784 83751 : do ib=1,size(wfd%s(is)%k(ik)%b)
3785 83097 : call wfd%s(is)%k(ik)%b(ib)%free(what="R")
3786 : end do
3787 : end do
3788 : end do
3789 :
3790 : ! Reinit Kdata_t
3791 5587 : do ik_ibz=1,Wfd%nkibz
3792 5921 : if (any(wfd%bks2wfd(1, :, ik_ibz, :) /= 0)) then
3793 4945 : istwf_k = Wfd%istwfk(ik_ibz)
3794 4945 : npw_k = Wfd%Kdata(ik_ibz)%npw
3795 14835 : ABI_MALLOC(kg_k, (3,npw_k))
3796 6063170 : kg_k = Wfd%Kdata(ik_ibz)%kg_k
3797 4945 : call Wfd%Kdata(ik_ibz)%free()
3798 4945 : call Wfd%Kdata(ik_ibz)%init(Cryst,Psps,Wfd%kibz(:,ik_ibz),istwf_k,new_ngfft,Wfd%MPI_enreg,kg_k=kg_k)
3799 4945 : ABI_FREE(kg_k)
3800 : end if
3801 : end do
3802 :
3803 642 : end subroutine wfd_change_ngfft
3804 : !!***
3805 :
3806 : !----------------------------------------------------------------------
3807 :
3808 : !!****f* m_wfd/wfd_test_ortho
3809 : !! NAME
3810 : !! wfd_test_ortho
3811 : !!
3812 : !! FUNCTION
3813 : !! Test the orthonormalization of the wavefunctions stored in Wfd.
3814 : !!
3815 : !! INPUTS
3816 : !! Cryst<crystal_t>=Object defining the unit cell and its symmetries.
3817 : !! Pawtab(ntypat*usepaw)<type(pawtab_type)>=PAW tabulated starting data.
3818 : !!
3819 : !! OUTPUT
3820 : !! Only writing.
3821 : !!
3822 : !! SOURCE
3823 :
3824 0 : subroutine wfd_test_ortho(Wfd,Cryst,Pawtab,unit,mode_paral)
3825 :
3826 : !Arguments ------------------------------------
3827 : !scalars
3828 : integer,intent(in),optional :: unit
3829 : character(len=4),optional,intent(in) :: mode_paral
3830 : type(crystal_t),intent(in) :: Cryst
3831 : class(wfd_t),target,intent(inout) :: Wfd
3832 : !array
3833 : type(Pawtab_type),intent(in) :: Pawtab(Cryst%ntypat*Wfd%usepaw)
3834 :
3835 : !Local variables ------------------------------
3836 : !scalars
3837 : integer :: ik_ibz,spin,band,band1,band2,ib,ib1,ib2,ierr,how_manyb,my_unt,npw_k,istwf_k
3838 : real(dp) :: glob_cinf,my_cinf,glob_csup,my_csup,glob_einf,min_norm2,glob_esup,max_norm2
3839 : complex(dp) :: cdum
3840 : logical :: bands_are_spread
3841 : character(len=4) :: my_mode
3842 : character(len=500) :: msg
3843 : type(wave_t),pointer :: wave1, wave2
3844 : !arrays
3845 0 : integer :: my_bandlist(Wfd%mband)
3846 : real(dp) :: pawovlp(2)
3847 0 : complex(gwp),contiguous, pointer :: ug1(:),ug2(:)
3848 : !complex(gwp) :: ur(Wfd%nfft*Wfd%nspinor)
3849 : character(len=6) :: tag_spin(2)
3850 0 : type(pawcprj_type),allocatable :: Cp1(:,:),Cp2(:,:)
3851 : !************************************************************************
3852 :
3853 0 : tag_spin(:)=(/' ',' '/); if (Wfd%nsppol==2) tag_spin(:)=(/' UP ',' DOWN '/)
3854 :
3855 0 : my_unt =std_out; if (present(unit )) my_unt =unit
3856 : my_mode ='COLL' ; if (present(mode_paral)) my_mode =mode_paral
3857 :
3858 0 : if (Wfd%usepaw==1) then
3859 0 : ABI_MALLOC(Cp1,(Wfd%natom,Wfd%nspinor))
3860 0 : call pawcprj_alloc(Cp1,0,Wfd%nlmn_atm)
3861 0 : ABI_MALLOC(Cp2,(Wfd%natom,Wfd%nspinor))
3862 0 : call pawcprj_alloc(Cp2,0,Wfd%nlmn_atm)
3863 : end if
3864 :
3865 0 : bands_are_spread = .FALSE.
3866 :
3867 0 : do spin=1,Wfd%nsppol
3868 0 : min_norm2=greatest_real; max_norm2=-greatest_real
3869 0 : my_cinf=greatest_real; my_csup=-greatest_real
3870 0 : do ik_ibz=1,Wfd%nkibz
3871 0 : npw_k = Wfd%npwarr(ik_ibz); istwf_k = Wfd%istwfk(ik_ibz)
3872 :
3873 : ! Select my band indices.
3874 0 : call wfd%mybands(ik_ibz,spin,how_manyb,my_bandlist, how="Stored")
3875 0 : if (how_manyb/=Wfd%nband(ik_ibz,spin)) bands_are_spread = .TRUE.
3876 :
3877 : ! 1) Normalization.
3878 0 : do ib=1,how_manyb
3879 0 : band = my_bandlist(ib)
3880 0 : ABI_CHECK(wfd%get_wave_ptr(band, ik_ibz, spin, wave1, msg) == 0, msg)
3881 0 : ug1 => wave1%ug
3882 0 : cdum = xdotc(npw_k*Wfd%nspinor,ug1,1,ug1,1)
3883 0 : if (istwf_k > 1) then
3884 0 : cdum=two*DBLE(cdum)
3885 0 : if (istwf_k == 2) cdum=cdum-CONJG(ug1(1))*ug1(1)
3886 : end if
3887 0 : if (Wfd%usepaw==1) then
3888 0 : call wfd%get_cprj(band,ik_ibz,spin,Cryst,Cp1,sorted=.FALSE.)
3889 0 : pawovlp = paw_overlap(Cp1,Cp1,Cryst%typat,Pawtab,spinor_comm=Wfd%MPI_enreg%comm_spinor)
3890 0 : cdum = cdum + CMPLX(pawovlp(1),pawovlp(2), kind=dp)
3891 : end if
3892 : !write(std_out,*)"ik_ibz, band, spin, cdum: ",ik_ibz,band,spin,cdum
3893 0 : if (REAL(cdum)<min_norm2) min_norm2=REAL(cdum)
3894 0 : if (REAL(cdum)>max_norm2) max_norm2=REAL(cdum)
3895 : end do
3896 :
3897 : ! TODO should use the communicator for this spin
3898 0 : call xmpi_min(min_norm2,glob_einf,Wfd%comm,ierr)
3899 0 : call xmpi_max(max_norm2,glob_esup,Wfd%comm,ierr)
3900 :
3901 : ! 2) Orthogonality of wavefunctions.
3902 0 : do ib1=1,how_manyb
3903 0 : band1 = my_bandlist(ib1)
3904 0 : ABI_CHECK(wfd%get_wave_ptr(band1, ik_ibz, spin, wave1, msg) == 0, msg)
3905 0 : ug1 => wave1%ug
3906 0 : if (Wfd%usepaw==1) call wfd%get_cprj(band1,ik_ibz,spin,Cryst,Cp1,sorted=.FALSE.)
3907 :
3908 0 : do ib2=ib1+1,how_manyb
3909 0 : band2 = my_bandlist(ib2)
3910 0 : ABI_CHECK(wfd%get_wave_ptr(band2, ik_ibz, spin, wave2, msg) == 0, msg)
3911 0 : ug2 => wave2%ug
3912 0 : if (Wfd%usepaw==1) call wfd%get_cprj(band2,ik_ibz,spin,Cryst,Cp2,sorted=.FALSE.)
3913 :
3914 0 : cdum = xdotc(npw_k*Wfd%nspinor,ug1,1,ug2,1)
3915 0 : if (istwf_k>1) then
3916 0 : cdum=two*DBLE(cdum)
3917 0 : if (istwf_k==2) cdum=cdum-CONJG(ug1(1))*ug2(1)
3918 : end if
3919 0 : if (Wfd%usepaw==1) then
3920 0 : pawovlp = paw_overlap(Cp1,Cp2,Cryst%typat,Pawtab,spinor_comm=Wfd%MPI_enreg%comm_spinor)
3921 0 : cdum = cdum + CMPLX(pawovlp(1),pawovlp(2), kind=dp)
3922 : end if
3923 :
3924 0 : if (ABS(cdum)<my_cinf) my_cinf=ABS(cdum)
3925 0 : if (ABS(cdum)>my_csup) my_csup=ABS(cdum)
3926 : !if (ABS(cdum) > 0.1) write(std_out,*)" ib1,ib2,ABS_dotprod: ",ib1,ib2,ABS(cdum)
3927 : end do !ib2
3928 : end do !ib
3929 :
3930 : ! TODO should use the communicator for this spin
3931 0 : call xmpi_min(my_cinf,glob_cinf,Wfd%comm,ierr)
3932 0 : call xmpi_max(my_csup,glob_csup,Wfd%comm,ierr)
3933 : end do ! ik_ibz
3934 :
3935 : ! Output results for this spin
3936 0 : write(msg,'(2a)')ch10,' test on the normalization of the wavefunctions'
3937 0 : if (Wfd%nsppol==2) write(msg,'(3a)')ch10,' test on the normalization of the wavefunctions with spin ',tag_spin(spin)
3938 0 : call wrtout(my_unt,msg,mode_paral)
3939 : write(msg,'(a,f9.6,a,a,f9.6)')&
3940 0 : ' min sum_G |a(n,k,G)| = ',glob_einf,ch10,&
3941 0 : ' max sum_G |a(n,k,G)| = ',glob_esup
3942 0 : call wrtout(my_unt,msg,mode_paral)
3943 :
3944 0 : write(msg,'(a)')' test on the orthogonalization of the wavefunctions (NB: this is not invariant for degenerate states)'
3945 0 : if (Wfd%nsppol==2) write(msg,'(2a)')' test on the orthogonalization of the wavefunctions with spin ',tag_spin(spin)
3946 0 : call wrtout(my_unt,msg,mode_paral)
3947 : write(msg,'(a,f9.6,a,a,f9.6,a)')&
3948 0 : '- min sum_G a(n,k,G)a(n",k,G) = ',glob_cinf,ch10,&
3949 0 : '- max sum_G a(n,k,G)a(n",k,G) = ',glob_csup,ch10
3950 0 : call wrtout(my_unt,msg,mode_paral)
3951 :
3952 : end do ! spin
3953 :
3954 0 : if (bands_are_spread) then
3955 : write(msg,'(3a)')&
3956 0 : 'Note that the test on the orthogonalization is not complete ',ch10,&
3957 0 : 'since bands are spread among different processors'
3958 0 : call wrtout(my_unt,msg,mode_paral)
3959 : end if
3960 :
3961 0 : if (Wfd%usepaw==1) then
3962 0 : call pawcprj_free(Cp1)
3963 0 : ABI_FREE(Cp1)
3964 0 : call pawcprj_free(Cp2)
3965 0 : ABI_FREE(Cp2)
3966 : end if
3967 :
3968 0 : end subroutine wfd_test_ortho
3969 : !!***
3970 :
3971 : !----------------------------------------------------------------------
3972 :
3973 : !!****f* m_wfd/wfd_sym_ur
3974 : !! NAME
3975 : !! wfd_sym_ur
3976 : !!
3977 : !! FUNCTION
3978 : !! Symmetrize a wave function in real space
3979 : !!
3980 : !! INPUTS
3981 : !! Wfd<wfd_t>=the wavefunction descriptor.
3982 : !! Cryst<crystal_t>=Structure describing the crystal structure and its symmetries.
3983 : !! Kmesh<kmesh_t>=Structure describing the BZ sampling
3984 : !! band=Band index.
3985 : !! ik_bz=Index of the k-point in the BZ.
3986 : !! spin=Spin index
3987 : !! [trans] = "N" if only the symmetried wavefunction is needed, "C" if the complex conjugate is required.
3988 : !! Default is "N"
3989 : !! [with_umklp] = Optional flag. If .True. (Default) the umklapp G0 vector in the relation kbz = Sk + G0
3990 : !! is taken into account when constructing u_kbz.
3991 : !!
3992 : !! NOTES
3993 : !! This method is deprecated. See wfd_sym_ug_kg and wfd_sym_ug_kg_npw for symmetrization in G-space
3994 : !!
3995 : !! OUTPUT
3996 : !! ur_kbz(Wfd%nfft*Wfd%nspinor)=The symmetrized wavefunction in real space.
3997 : !! [ur_kibz(Wfd%nfft*Wfd%nspinor)]= Optional output: u(r) in the IBZ.
3998 : !!
3999 : !! SOURCE
4000 :
4001 51200 : subroutine wfd_sym_ur(Wfd,Cryst,Kmesh,band,ik_bz,spin,ur_kbz,trans,with_umklp,ur_kibz)
4002 :
4003 : !Arguments ------------------------------------
4004 : !scalars
4005 : integer,intent(in) :: band,ik_bz,spin
4006 : character(len=*),optional,intent(in) :: trans
4007 : logical,optional,intent(in) :: with_umklp
4008 : type(crystal_t),intent(in) :: Cryst
4009 : type(kmesh_t),intent(in) :: Kmesh
4010 : class(wfd_t),intent(inout) :: Wfd
4011 : !arrays
4012 : complex(gwp),intent(out) :: ur_kbz(Wfd%nfft*Wfd%nspinor)
4013 : complex(gwp),optional,intent(out) :: ur_kibz(Wfd%nfft*Wfd%nspinor)
4014 :
4015 : !Local variables ------------------------------
4016 : !scalars
4017 : integer :: ik_ibz,isym_k,itim_k,nr,ispinor,spad,ir,ir2
4018 : integer :: fft_idx,ix,iy,iz,nx,ny,nz,irot
4019 : real(dp) :: gdotr
4020 : complex(dp) :: ph_mkt,u2b,u2a
4021 : complex(gwp) :: gwpc_ph_mkt
4022 : logical :: isirred,my_with_umklp
4023 : character(len=1) :: my_trans
4024 : !character(len=500) :: msg
4025 : !arrays
4026 : integer :: umklp(3)
4027 : real(dp) :: kbz(3),spinrot_k(4)
4028 : complex(dp) :: spinrot_mat(2,2)
4029 51200 : complex(gwp),allocatable :: ur(:)
4030 : !************************************************************************
4031 :
4032 51200 : my_trans = "N"; if (present(trans)) my_trans = toupper(trans(1:1))
4033 51200 : my_with_umklp = .TRUE.; if (present(with_umklp)) my_with_umklp = with_umklp
4034 :
4035 : ! k_bz = S k - G0 ==> u_{k_bz} = e^{iG0.r} u_{Sk}
4036 : ! k_bz = -S k - G0 ==> u_{k_bz} = e^{iG0.r} u_{Sk}^*
4037 :
4038 : ! u(r,b,kbz)=e^{-2i\pi kibz.(R^{-1}t} u (R{^-1}(r-t),b,kibz)
4039 : ! =e^{+2i\pi kibz.(R^{-1}t} u*({R^-1}(r-t),b,kibz) for time-reversal
4040 : !
4041 : ! Get ik_ibz, non-symmorphic phase, ph_mkt, and symmetries from ik_bz.
4042 51200 : call Kmesh%get_BZ_item(ik_bz,kbz,ik_ibz,isym_k,itim_k,ph_mkt,umklp,isirred)
4043 51200 : gwpc_ph_mkt = ph_mkt
4044 :
4045 51200 : if (isirred) then
4046 : ! Avoid symmetrization if this point is irreducible.
4047 51200 : call wfd%get_ur(band,ik_ibz,spin,ur_kbz)
4048 51200 : if (present(ur_kibz)) call xcopy(Wfd%nfft*Wfd%nspinor,ur_kbz,1,ur_kibz,1)
4049 51200 : if (my_trans=="C") ur_kbz = GWPC_CONJG(ur_kbz)
4050 : RETURN
4051 : end if
4052 :
4053 : ! Reconstruct ur in the BZ from the corresponding wavefunction in IBZ.
4054 0 : ABI_MALLOC(ur, (Wfd%nfft*Wfd%nspinor))
4055 :
4056 0 : call wfd%get_ur(band,ik_ibz,spin,ur)
4057 0 : if (present(ur_kibz)) call xcopy(Wfd%nfft*Wfd%nspinor,ur,1,ur_kibz,1)
4058 :
4059 : ! Wfd%irottb(:,isym_k) is the table for rotated FFT points
4060 0 : SELECT CASE (Wfd%nspinor)
4061 :
4062 : CASE (1)
4063 : ! Rotation in real space
4064 0 : do ir=1,Wfd%nfft
4065 0 : irot = Wfd%irottb(ir,isym_k)
4066 0 : ur_kbz(ir) = ur(irot) * gwpc_ph_mkt
4067 : end do
4068 :
4069 : ! Apply time-reversal symmetry if needed.
4070 0 : if (itim_k==2) ur_kbz = GWPC_CONJG(ur_kbz)
4071 :
4072 : ! Take into account a possible umklapp.
4073 0 : if (ANY(umklp/=0).and. my_with_umklp) then
4074 : ! Compute ur_kbz = ur_kbz*eig0r
4075 0 : nx = Wfd%ngfft(1); ny = Wfd%ngfft(2); nz = Wfd%ngfft(3)
4076 0 : fft_idx=0
4077 0 : do iz=0,nz-1
4078 0 : do iy=0,ny-1
4079 0 : do ix=0,nx-1
4080 : gdotr= two_pi*( umklp(1)*(ix/DBLE(nx)) &
4081 : +umklp(2)*(iy/DBLE(ny)) &
4082 0 : +umklp(3)*(iz/DBLE(nz)) )
4083 0 : fft_idx = fft_idx+1
4084 0 : ur_kbz(fft_idx) = ur_kbz(fft_idx) * DCMPLX(DCOS(gdotr),DSIN(gdotr))
4085 : end do
4086 : end do
4087 : end do
4088 : end if
4089 :
4090 0 : if (my_trans=="C") ur_kbz = GWPC_CONJG(ur_kbz)
4091 :
4092 : CASE (2)
4093 0 : ABI_ERROR("Implementation has to be tested")
4094 :
4095 0 : nr = Wfd%nfft
4096 0 : spinrot_k = Cryst%spinrot(:,isym_k)
4097 : !
4098 : ! ==== Apply Time-reversal if required ====
4099 : ! \psi_{-k}^1 = (\psi_k^2)^*
4100 : ! \psi_{-k}^2 = -(\psi_k^1)^*
4101 0 : if (itim_k==1) then
4102 0 : ur_kbz = ur
4103 0 : else if (itim_k==2) then
4104 0 : ur_kbz(1:nr) = GWPC_CONJG(ur(nr+1:2*nr))
4105 0 : ur_kbz(nr+1:2*nr)=-GWPC_CONJG(ur(1:nr))
4106 : else
4107 0 : ABI_ERROR('Wrong i2 in spinor')
4108 : end if
4109 : !
4110 : ! Rotate wavefunctions in real space.
4111 0 : do ispinor=1,Wfd%nspinor
4112 0 : spad=(ispinor-1)*nr
4113 0 : do ir=1,nr
4114 0 : ir2 = Wfd%irottb(ir,isym_k)
4115 0 : ur_kbz(ir+spad) = ur_kbz(ir2+spad) * gwpc_ph_mkt
4116 : end do
4117 : end do
4118 : !
4119 : ! Rotation in spinor space.
4120 0 : spinrot_mat(1,1)= spinrot_k(1) + j_dpc*spinrot_k(4)
4121 0 : spinrot_mat(1,2)= spinrot_k(3) + j_dpc*spinrot_k(2)
4122 0 : spinrot_mat(2,1)=-spinrot_k(3) + j_dpc*spinrot_k(2)
4123 0 : spinrot_mat(2,2)= spinrot_k(1) - j_dpc*spinrot_k(4)
4124 :
4125 0 : do ir=1,nr
4126 0 : u2a=ur_kbz(ir)
4127 0 : u2b=ur_kbz(ir+nr)
4128 0 : ur_kbz(ir) =spinrot_mat(1,1)*u2a+spinrot_mat(1,2)*u2b
4129 0 : ur_kbz(ir+nr)=spinrot_mat(2,1)*u2a+spinrot_mat(2,2)*u2b
4130 : end do
4131 :
4132 0 : if (ANY(umklp /=0)) then
4133 : !ur_kbz(1:Wfd%nfft) = ur_kbz(1:Wfd%nfft) *eig0r
4134 : !ur_kbz(Wfd%nfft+1:) = ur_kbz(Wfd%nfft+1:)*eig0r
4135 : end if
4136 :
4137 : CASE DEFAULT
4138 0 : ABI_ERROR(sjoin("Wrong value for nspinor: ", itoa(Wfd%nspinor)))
4139 : END SELECT
4140 :
4141 0 : ABI_FREE(ur)
4142 :
4143 : end subroutine wfd_sym_ur
4144 : !!***
4145 :
4146 : !!****f* m_wfd/wfd_rotate_cg
4147 : !! NAME
4148 : !! wfd_rotate_cg
4149 : !!
4150 : !! FUNCTION
4151 : !! Use crystalline symmetries and time reversal to reconstruct wavefunctions at kk_bz from the IBZ image
4152 : !! Return the periodic part in G-space and, optionally, the real-space term.
4153 : !!
4154 : !! INPUTS
4155 : !! kk_ibz: Symmetrical image of kk_bz in the IBZ.
4156 : !! band: Initial band index
4157 : !! ndat: Number of bands to symmetrize.
4158 : !! spin: Spin index
4159 : !! npw_kbz: Number of G-vectors in kk_bz G-sphere
4160 : !! kg_kbz: G-vectors in reduced coordinates.
4161 : !! istwf_kbz: Time-reversal flag associated to output wavefunctions
4162 : !! cryst: Crystalline structure and symmetries
4163 : !! indkk: Symmetry map kk_bz -> kk_ibz as computed by listkk with the SYMREL convention.
4164 : !! gbound_kbz: The boundary of the basis sphere of G vectors centered on the kk in BZ (not on kk_ibz!)
4165 : !! work_ngfft: Define the size of the workspace array work
4166 : !! work: Workspace array used to symmetrize wavefunctions
4167 : !!
4168 : !! OUTPUT
4169 : !! cgs_kbz: Periodic part of wavefunctions at kk_bz
4170 : !! [urs_kbz]: wavefunctions at kk_bz in real space.
4171 : !!
4172 : !! SOURCE
4173 :
4174 304478 : subroutine wfd_rotate_cg(wfd, band, ndat, spin, kk_ibz, npw_kbz, kg_kbz, istwf_kbz, &
4175 15352 : cryst, indkk, gbound_kbz, work_ngfft, work, cgs_kbz, urs_kbz)
4176 :
4177 : !Arguments ------------------------------------
4178 : !scalars
4179 : class(wfd_t),intent(inout) :: wfd
4180 : integer,intent(in) :: band, ndat, spin, npw_kbz, istwf_kbz
4181 : type(crystal_t),intent(in) :: cryst
4182 : !arrays
4183 : integer,intent(in) :: work_ngfft(18)
4184 : integer,intent(in) :: indkk(6)
4185 : integer,intent(in) :: gbound_kbz(2*wfd%mgfft+8, 2)
4186 : integer,intent(in) :: kg_kbz(3, npw_kbz)
4187 : real(dp),intent(in) :: kk_ibz(3)
4188 : real(dp),intent(out) :: work(2, work_ngfft(4), work_ngfft(5), work_ngfft(6))
4189 : real(dp),target,intent(out) :: cgs_kbz(2, npw_kbz*wfd%nspinor, ndat)
4190 : complex(gwp),optional,intent(out) :: urs_kbz(wfd%nfft*wfd%nspinor, ndat)
4191 :
4192 : !Local variables ------------------------------
4193 : !scalars
4194 : integer,parameter :: ndat1 = 1
4195 : integer :: ik_ibz, isym_k, trev_k, idat, istwf_kirr, npw_kirr, ib
4196 : logical :: isirr_k
4197 : !real(dp) :: norm
4198 : !arrays
4199 : integer :: g0_k(3)
4200 152239 : real(dp),allocatable :: cg_kirr(:,:)
4201 : complex(gwp),allocatable :: cwork_sp(:,:)
4202 : #ifdef HAVE_GW_DPC
4203 152239 : complex(gwp),pointer :: ugs_dp_ptr(:,:)
4204 : #endif
4205 : !************************************************************************
4206 :
4207 : ! As reported by listkk with the symrel convention
4208 608956 : ik_ibz = indkk(1); isym_k = indkk(2); trev_k = indkk(6); g0_k = indkk(3:5)
4209 459244 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
4210 :
4211 : if (isirr_k) then
4212 77340 : do idat=1,ndat
4213 : ! Copy u_k(G)
4214 38670 : ib = band + idat - 1
4215 38670 : call wfd%copy_cg(ib, ik_ibz, spin, cgs_kbz(:,:,idat))
4216 77340 : if (present(urs_kbz)) call wfd%get_ur(ib, ik_ibz, spin, urs_kbz(:,idat))
4217 : end do
4218 :
4219 : else
4220 : ! Reconstruct u_k(G) from the IBZ image. Use cg_kirr as workspace array, results stored in cgs_kbz.
4221 113569 : istwf_kirr = wfd%istwfk(ik_ibz); npw_kirr = wfd%npwarr(ik_ibz)
4222 340707 : ABI_MALLOC(cg_kirr, (2, npw_kirr*wfd%nspinor))
4223 :
4224 227138 : do idat=1,ndat
4225 113569 : ib = band + idat - 1
4226 113569 : call wfd%copy_cg(ib, ik_ibz, spin, cg_kirr)
4227 : call cgtk_rotate(cryst, kk_ibz, isym_k, trev_k, g0_k, wfd%nspinor, ndat1, &
4228 : wfd%npwarr(ik_ibz), wfd%kdata(ik_ibz)%kg_k, &
4229 227138 : npw_kbz, kg_kbz, wfd%istwfk(ik_ibz), istwf_kbz, cg_kirr, cgs_kbz(:,:,idat), work_ngfft, work)
4230 : end do
4231 113569 : ABI_FREE(cg_kirr)
4232 :
4233 113569 : if (present(urs_kbz)) then
4234 : #ifdef HAVE_GW_DPC
4235 : ! we are using double precision -> cast dp cgs_kbz to dp complex pointer.
4236 37686 : call c_f_pointer(c_loc(cgs_kbz), ugs_dp_ptr, [npw_kbz*wfd%nspinor, ndat])
4237 : call fft_ug(npw_kbz, wfd%nfft, wfd%nspinor, ndat, wfd%mgfft, wfd%ngfft, istwf_kbz, kg_kbz, gbound_kbz, &
4238 12562 : ugs_dp_ptr(:,1), urs_kbz(:,1))
4239 : #else
4240 : ! Transfer cgs_kbz from dp to sp and perform FFT in single precision.
4241 : ABI_MALLOC(cwork_sp, (npw_kbz*wfd%nspinor, ndat))
4242 : cwork_sp(:,:) = cgs_kbz(1,:,:) + j_sp * cgs_kbz(2,:,:)
4243 : call fft_ug(npw_kbz, wfd%nfft, wfd%nspinor, ndat, wfd%mgfft, wfd%ngfft, istwf_kbz, kg_kbz, gbound_kbz, &
4244 : cwork_sp(:,1), urs_kbz(:,1))
4245 : ABI_FREE(cwork_sp)
4246 : #endif
4247 : end if
4248 : end if
4249 :
4250 : ! Debug section
4251 : !do idat=1,ndat
4252 : ! norm = sqrt(cg_dznrm2(npw_kbz*wfd%nspinor, cgs_kbz(:, :, idat)))
4253 : ! if (abs(norm - one) > tol12) then
4254 : ! ABI_ERROR(sjoin("norm:", ftoa(norm)))
4255 : ! end if
4256 : !end do
4257 :
4258 167591 : end subroutine wfd_rotate_cg
4259 : !!***
4260 :
4261 : !----------------------------------------------------------------------
4262 :
4263 : !!****f* m_wfd/wfd_sym_ug_kg
4264 : !! NAME
4265 : !! wfd_sym_ug_kg
4266 : !!
4267 : !! FUNCTION
4268 : !! Use crystalline symmetries and time reversal to reconstruct wavefunctions at kk_bz from the IBZ image kk_ibz.
4269 : !! Return periodic part in G-space as well as list of G-vectors belonging to the G-sphere centered on kk_bz
4270 : !!
4271 : !! INPUTS
4272 : !! ecut: Cutoff energy for planewave basis set.
4273 : !! kk_bz: k-point in the BZ for output wavefunctions and G-vectors.
4274 : !! kk_ibz: Symmetrical image of kk_bz in the IBZ.
4275 : !! bstart: Initial band index
4276 : !! nband: Number of bands to symmetrize.
4277 : !! spin: Spin index
4278 : !! mpw: MAXIMUM number of planewaves used to dimension arrays.
4279 : !! indkk: Symmetry map kk_bz -> kk_ibz as computed by listkk with the symrel convention.
4280 : !! cryst: Crystalline structure and symmetries
4281 : !! work_ngfft: Define the size of the workspace array work
4282 : !! work: Workspace array used to symmetrize wavefunctions
4283 : !! force_rotate: optional, use cgtk_rotate for kpoint even if it is in the IBZ.
4284 : !!
4285 : !! OUTPUT
4286 : !! istwf_kbz: Time-reversal flag associated to output wavefunctions.
4287 : !! npw_kbz: Number of G-vectors in kk_bz G-sphere.
4288 : !! kg_kbz: G-vectors in reduced coordinates.
4289 : !! cgs_kbz: Periodic part of wavefunctions at kk_bz.
4290 : !!
4291 : !! NOTES
4292 : !! This routine is deprecated and should be replaced by sym_ug_kg_npw.
4293 : !! In order to call getgh1c with ndat > 1, indeed, one should return an array dimensioned
4294 : !! as (2, npw_kbz*wfd%nspinor, nband) instead of (2, mpw*wfd%nspinor, nband)
4295 : !!
4296 : !! SOURCE
4297 :
4298 304 : subroutine wfd_sym_ug_kg(wfd, ecut, kk_bz, kk_ibz, bstart, nband, spin, mpw, indkk, cryst, &
4299 304 : work_ngfft, work, istwf_kbz, npw_kbz, kg_kbz, cgs_kbz, &
4300 : force_rotate) ! optional
4301 :
4302 : !Arguments ------------------------------------
4303 : !scalars
4304 : class(wfd_t),intent(in) :: wfd
4305 : integer,intent(in) :: bstart, nband, spin, mpw
4306 : type(crystal_t),intent(in) :: cryst
4307 : integer,intent(out) :: istwf_kbz, npw_kbz
4308 : real(dp),intent(in) :: ecut
4309 : !arrays
4310 : integer :: work_ngfft(18)
4311 : integer,intent(in) :: indkk(6)
4312 : integer,intent(out) :: kg_kbz(3, mpw)
4313 : real(dp),intent(in) :: kk_bz(3), kk_ibz(3)
4314 : real(dp),intent(out) :: cgs_kbz(2, mpw*wfd%nspinor, nband)
4315 : real(dp),intent(out) :: work(2, work_ngfft(4), work_ngfft(5), work_ngfft(6))
4316 : logical ,optional, intent(in) :: force_rotate
4317 :
4318 : !Local variables ------------------------------
4319 : !scalars
4320 : integer,parameter :: ndat1 = 1
4321 : integer :: ik_ibz, isym_k, trev_k, ib, band, istwf_kirr, npw_kirr
4322 : logical :: isirr_k, rotate
4323 : !arrays
4324 : integer :: g0_k(3)
4325 304 : integer,allocatable :: gtmp(:,:)
4326 304 : real(dp),allocatable :: cg_kirr(:,:)
4327 : !************************************************************************
4328 :
4329 : ! As reported by listkk via symrel
4330 1216 : ik_ibz = indkk(1); isym_k = indkk(2); trev_k = indkk(6); g0_k = indkk(3:5)
4331 1040 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
4332 :
4333 304 : rotate= .not. isirr_k
4334 304 : if (present(force_rotate)) then
4335 304 : if (force_rotate) rotate=.True.
4336 : endif
4337 :
4338 : ! Get npw_kbz, kg_kbz and symmetrize wavefunctions from IBZ (if needed).
4339 : ! Be careful with time-reversal symmetry.
4340 0 : if (.not. rotate) then
4341 : ! Copy u_k(G)
4342 0 : istwf_kbz = wfd%istwfk(ik_ibz); npw_kbz = wfd%npwarr(ik_ibz)
4343 0 : ABI_CHECK_ILEQ(npw_kbz, mpw, "npw_kbz > mpw!")
4344 0 : kg_kbz(:,1:npw_kbz) = wfd%kdata(ik_ibz)%kg_k
4345 :
4346 0 : do ib=1,nband
4347 0 : band = ib + bstart - 1
4348 0 : call wfd%copy_cg(band, ik_ibz, spin, cgs_kbz(1,1,ib))
4349 : end do
4350 :
4351 : else
4352 : ! Reconstruct u_k(G) from the IBZ image.
4353 304 : istwf_kbz = 1
4354 304 : call get_kg(kk_bz, istwf_kbz, ecut, cryst%gmet, npw_kbz, gtmp)
4355 304 : ABI_CHECK_ILEQ(npw_kbz, mpw, "npw_kbz > mpw!")
4356 278060 : kg_kbz(:,1:npw_kbz) = gtmp(:,:npw_kbz)
4357 304 : ABI_FREE(gtmp)
4358 :
4359 : ! Use cg_kirr as workspace array, results stored in cgs_kbz.
4360 304 : istwf_kirr = wfd%istwfk(ik_ibz); npw_kirr = wfd%npwarr(ik_ibz)
4361 912 : ABI_MALLOC(cg_kirr, (2, npw_kirr*wfd%nspinor))
4362 3632 : do ib=1,nband
4363 3328 : band = ib + bstart - 1
4364 3328 : call wfd%copy_cg(band, ik_ibz, spin, cg_kirr)
4365 : call cgtk_rotate(cryst, kk_ibz, isym_k, trev_k, g0_k, wfd%nspinor, ndat1, &
4366 : npw_kirr, wfd%kdata(ik_ibz)%kg_k, &
4367 3632 : npw_kbz, kg_kbz, istwf_kirr, istwf_kbz, cg_kirr, cgs_kbz(:,:,ib), work_ngfft, work)
4368 : end do
4369 304 : ABI_FREE(cg_kirr)
4370 : end if
4371 :
4372 304 : end subroutine wfd_sym_ug_kg
4373 : !!***
4374 :
4375 : !----------------------------------------------------------------------
4376 :
4377 : !!****f* m_wfd/wfd_sym_ug_kg_npw
4378 : !! NAME
4379 : !! wfd_sym_ug_kg_npw
4380 : !!
4381 : !! FUNCTION
4382 : !! Use crystalline symmetries and time reversal to reconstruct wavefunctions at kk_bz from the IBZ image kk_ibz.
4383 : !! Return periodic part in G-space as well as list of G-vectors belonging to the G-sphere centered on kk_bz
4384 : !!
4385 : !! INPUTS
4386 : !! ecut: Cutoff energy for planewave basis set.
4387 : !! kk_bz: k-point in the BZ for output wavefunctions and G-vectors.
4388 : !! kk_ibz: Symmetrical image of kk_bz in the IBZ.
4389 : !! bstart: Initial band index
4390 : !! nband: Number of bands to symmetrize.
4391 : !! spin: Spin index
4392 : !! mpw: MAXIMUM number of planewaves used to dimension arrays.
4393 : !! indkk: Symmetry map kk_bz -> kk_ibz as computed by listkk with the symrel convention.
4394 : !! cryst: Crystalline structure and symmetries
4395 : !! work_ngfft: Define the size of the workspace array work
4396 : !! work: Workspace array used to symmetrize wavefunctions
4397 : !! force_rotate: optional, use cgtk_rotate for kpoint even if it is in the IBZ.
4398 : !!
4399 : !! OUTPUT
4400 : !! istwf_kbz: Time-reversal flag associated to output wavefunctions.
4401 : !! npw_kbz: Number of G-vectors in kk_bz G-sphere.
4402 : !! kg_kbz: G-vectors in reduced coordinates.
4403 : !! cgs_kbz: Periodic part of wavefunctions at kk_bz.
4404 : !!
4405 : !! NOTES
4406 : !!
4407 : !! SOURCE
4408 :
4409 152910 : subroutine wfd_sym_ug_kg_npw(wfd, ecut, kk_bz, kk_ibz, bstart, nband, spin, indkk, cryst, &
4410 152910 : work_ngfft, work, istwf_kbz, npw_kbz, kg_kbz, cgs_kbz, &
4411 : force_rotate) ! optional
4412 :
4413 : !Arguments ------------------------------------
4414 : !scalars
4415 : class(wfd_t),intent(in) :: wfd
4416 : integer,intent(in) :: bstart, nband, spin
4417 : type(crystal_t),intent(in) :: cryst
4418 : integer,intent(out) :: istwf_kbz, npw_kbz
4419 : real(dp),intent(in) :: ecut
4420 : !arrays
4421 : integer :: work_ngfft(18)
4422 : integer,intent(in) :: indkk(6)
4423 : integer,intent(out) :: kg_kbz(:,:) ! (3, mpw)
4424 : real(dp),intent(in) :: kk_bz(3), kk_ibz(3)
4425 : real(dp),allocatable,intent(out) :: cgs_kbz(:,:,:) ! (2, npw_kbz*wfd%nspinor, nband)
4426 : real(dp),intent(out) :: work(2, work_ngfft(4), work_ngfft(5), work_ngfft(6))
4427 : logical ,optional, intent(in) :: force_rotate
4428 :
4429 : !Local variables ------------------------------
4430 : !scalars
4431 : integer,parameter :: ndat1 = 1
4432 : integer :: ik_ibz, isym_k, trev_k, ib, band, istwf_kirr, npw_kirr, mpw
4433 : logical :: isirr_k, rotate
4434 : !arrays
4435 : integer :: g0_k(3)
4436 152910 : integer,allocatable :: gtmp(:,:)
4437 152910 : real(dp),allocatable :: cg_kirr(:,:)
4438 : !************************************************************************
4439 :
4440 152910 : mpw = size(kg_kbz, dim=2)
4441 :
4442 : ! As reported by listkk via symrel
4443 611640 : ik_ibz = indkk(1); isym_k = indkk(2); trev_k = indkk(6); g0_k = indkk(3:5)
4444 558889 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
4445 :
4446 152910 : rotate= .not. isirr_k
4447 152910 : if (present(force_rotate)) then
4448 0 : if (force_rotate) rotate=.True.
4449 : endif
4450 :
4451 : ! Get npw_kbz, kg_kbz and symmetrize wavefunctions from IBZ (if needed).
4452 : ! Be careful with time-reversal symmetry.
4453 152910 : if (.not. rotate) then
4454 : ! Copy u_k(G)
4455 10306 : istwf_kbz = wfd%istwfk(ik_ibz); npw_kbz = wfd%npwarr(ik_ibz)
4456 10306 : ABI_CHECK_ILEQ(npw_kbz, mpw, "npw_kbz > mpw!")
4457 36430678 : kg_kbz(:,1:npw_kbz) = wfd%kdata(ik_ibz)%kg_k
4458 :
4459 41224 : ABI_MALLOC(cgs_kbz, (2, npw_kbz*wfd%nspinor, nband))
4460 26576 : do ib=1,nband
4461 16270 : band = ib + bstart - 1
4462 26576 : call wfd%copy_cg(band, ik_ibz, spin, cgs_kbz(1,1,ib))
4463 : end do
4464 :
4465 : else
4466 : ! Reconstruct u_k(G) from the IBZ image.
4467 142604 : istwf_kbz = 1
4468 142604 : call get_kg(kk_bz, istwf_kbz, ecut, cryst%gmet, npw_kbz, gtmp)
4469 142604 : ABI_CHECK_ILEQ(npw_kbz, mpw, "npw_kbz > mpw!")
4470 491066936 : kg_kbz(:,1:npw_kbz) = gtmp(:,:npw_kbz)
4471 142604 : ABI_FREE(gtmp)
4472 :
4473 570416 : ABI_MALLOC(cgs_kbz, (2, npw_kbz*wfd%nspinor, nband))
4474 :
4475 : ! Use cg_kirr as workspace array, results stored in cgs_kbz.
4476 142604 : istwf_kirr = wfd%istwfk(ik_ibz); npw_kirr = wfd%npwarr(ik_ibz)
4477 427812 : ABI_MALLOC(cg_kirr, (2, npw_kirr*wfd%nspinor))
4478 361220 : do ib=1,nband
4479 218616 : band = ib + bstart - 1
4480 218616 : call wfd%copy_cg(band, ik_ibz, spin, cg_kirr)
4481 : call cgtk_rotate(cryst, kk_ibz, isym_k, trev_k, g0_k, wfd%nspinor, ndat1, &
4482 : npw_kirr, wfd%kdata(ik_ibz)%kg_k, &
4483 361220 : npw_kbz, kg_kbz, istwf_kirr, istwf_kbz, cg_kirr, cgs_kbz(:,:,ib), work_ngfft, work)
4484 : end do
4485 142604 : ABI_FREE(cg_kirr)
4486 : end if
4487 :
4488 152910 : end subroutine wfd_sym_ug_kg_npw
4489 : !!***
4490 :
4491 : !----------------------------------------------------------------------
4492 :
4493 : !!****f* m_wfd/wfdgw_write_wfk
4494 : !! NAME
4495 : !! wfdgw_write_wfk
4496 : !!
4497 : !! FUNCTION
4498 : !! This routine writes the wavefunctions to the specified WFK file
4499 : !! All the wavefunction are stored on each node, only the spin is distributed.
4500 : !!
4501 : !! INPUTS
4502 : !! Wfd<wfd_t>=Initialized wavefunction descriptor.
4503 : !! wfk_fname=Name of the WFK file.
4504 : !!
4505 : !! OUTPUT
4506 : !! Only writing
4507 : !!
4508 : !! SOURCE
4509 :
4510 5 : subroutine wfdgw_write_wfk(Wfd, Hdr, ebands, wfk_fname, wfknocheck)
4511 :
4512 : !Arguments ------------------------------------
4513 : !scalars
4514 : character(len=*),intent(in) :: wfk_fname
4515 : class(wfdgw_t),intent(in) :: Wfd
4516 : type(Hdr_type),intent(in) :: Hdr
4517 : type(ebands_t),intent(in) :: ebands
4518 : logical,intent(in),optional :: wfknocheck
4519 :
4520 : !Local variables ------------------------------
4521 : !scalars
4522 : integer,parameter :: formeig0=0,master=0
4523 : integer :: nprocs,my_rank,iomode,cgsize,npw_k,ik_ibz,spin,nband_k,band,ii
4524 : integer :: blk,nblocks,how_many,ierr,how_manyb
4525 : real(dp) :: cpu,wall,gflops
4526 : logical :: iam_master,nocheck ! MRM
4527 : character(len=500) :: msg
4528 20 : type(wfk_t) :: Wfkfile
4529 : !arrays
4530 10 : integer :: band_block(2),proc_ranks(Wfd%nproc),my_band_list(Wfd%mband)
4531 5 : integer,allocatable :: blocks(:,:) !
4532 5 : real(dp),allocatable :: cg_k(:,:)
4533 : !************************************************************************
4534 :
4535 5 : nocheck=.false.
4536 5 : if(present(wfknocheck)) nocheck=wfknocheck
4537 :
4538 5 : nprocs = xmpi_comm_size(Wfd%comm); my_rank = xmpi_comm_rank(Wfd%comm)
4539 5 : iam_master = (my_rank == master)
4540 :
4541 : ! Select the IO library from the file extension.
4542 5 : iomode = iomode_from_fname(wfk_fname)
4543 5 : call wrtout(std_out, sjoin('Writing GS WFK file: ',wfk_fname,", with iomode ",iomode2str(iomode)))
4544 :
4545 5 : if (nprocs > 1 .and. iomode /= IO_MODE_MPI) then
4546 0 : ABI_ERROR("You need MPI-IO to write wavefunctions in parallel")
4547 : end if
4548 : !
4549 : ! Check consistency between Wfd and Header!
4550 : ! The ideal approach would be to generate the header from the Wfd but a lot of info are missing
4551 5 : ABI_CHECK(Wfd%nkibz == Hdr%nkpt,"Different number of k-points")
4552 5 : ABI_CHECK(Wfd%nsppol == Hdr%nsppol,"Different number of spins")
4553 5 : ABI_CHECK(Wfd%nspinor == Hdr%nspinor,"Different number of spinors")
4554 :
4555 : !if (any(Wfd%nband /= reshape(Hdr%nband, [Wfd%nkibz, Wfd%nsppol]))) then
4556 : ! ABI_ERROR("Wfd%nband /= Hdr%nband")
4557 : !end if
4558 :
4559 : !endif
4560 : ! Use bks_tab to decide who will write the data. Remember
4561 : ! integer,allocatable :: bks_tab(:,:,:,:)
4562 : ! Wfd%bks_tab(mband,nkibz,nsppol,0:nproc-1)
4563 : ! Global table used to keep trace of the distribution of the (b,k,s) states on each node inside Wfd%comm.
4564 : ! 1 if the node has this state. 0 otherwise.
4565 : ! A node owns a wavefunction if the corresponding ug is allocated AND computed.
4566 : ! If a node owns ur but not ug, or ug is just allocated then its entry in the table is zero.
4567 : ! The main difficulties here are:
4568 : !
4569 : ! 1) FFT parallelism (not coded, indeed)
4570 : ! 2) Wavefunctions that are replicated, i.e. the same (b,k,s) is treated by more than one node.
4571 :
4572 5 : ierr = 0
4573 10 : do spin=1,Wfd%nsppol
4574 40 : do ik_ibz=1,Wfd%nkibz
4575 275 : do band=1,Wfd%nband(ik_ibz,spin)
4576 240 : call wfdgw_who_has_ug(Wfd,band,ik_ibz,spin,how_many,proc_ranks)
4577 270 : if (how_many /= 1) then
4578 0 : ierr = ierr + 1
4579 0 : write(msg,'(a,3(i0,1x))')" Found replicated state (b,k,s) ",band,ik_ibz,spin
4580 0 : ABI_WARNING(msg)
4581 : end if
4582 : end do
4583 : end do
4584 : end do
4585 :
4586 5 : if (ierr /= 0) then
4587 0 : ABI_ERROR("Cannot write WFK file when wavefunctions are replicated")
4588 : end if
4589 :
4590 5 : call cwtime(cpu,wall,gflops,"start")
4591 :
4592 : ! Master node opens the file and writes the Abinit header.
4593 5 : if (iam_master) then
4594 35 : do ik_ibz=1,Wfd%nkibz
4595 35 : if (size(Wfd%Kdata(ik_ibz)%kg_k,dim=2)<Hdr%npwarr(ik_ibz)) then
4596 0 : ABI_ERROR("Impossible to continue when the npw in the Hdr is diff. to the npw in the Wfd")
4597 : end if
4598 : end do
4599 5 : call wfkfile%open_write(Hdr,wfk_fname,formeig0,iomode,get_unit(),xmpi_comm_self,write_hdr=.TRUE.,write_frm=.TRUE.)
4600 : end if
4601 :
4602 : ! Other nodes wait here before opening the same file.
4603 5 : call xmpi_barrier(Wfd%comm)
4604 5 : if (.not.iam_master) then
4605 0 : call wfkfile%open_write(Hdr,wfk_fname,formeig0,iomode,get_unit(),xmpi_comm_self,write_hdr=.FALSE.,write_frm=.FALSE.)
4606 : end if
4607 :
4608 10 : do spin=1,Wfd%nsppol
4609 40 : do ik_ibz=1,Wfd%nkibz
4610 : ! MRM: Well, we do not check because nocheck is used when Wfd is stored only on the master. So it works for this case!
4611 30 : if(.not.nocheck) then
4612 0 : if (.not. wfd%ihave_ug(band, ik_ibz, spin, how="Stored")) cycle
4613 : endif
4614 :
4615 30 : nband_k = Wfd%nband(ik_ibz,spin)
4616 30 : npw_k = Wfd%npwarr(ik_ibz)
4617 :
4618 : ! Compute my block of bands for this k-point and spin.
4619 30 : call wfd%mybands(ik_ibz, spin, how_manyb, my_band_list, how="Stored")
4620 30 : call list2blocks(my_band_list(1:how_manyb), nblocks, blocks)
4621 :
4622 : !if (proc_distrb_cycle(mpi_enreg%proc_distrb,ik_ibz,1,nband_k,spin,my_rank)) CYCLE
4623 : !call mask2blocks(mpi_enreg%proc_distrb(ik_ibz,:,spin)==my_rank, nblocks,blocks)
4624 :
4625 30 : ABI_CHECK(nblocks==1,"nblocks !=1")
4626 30 : write(msg,"(a,3(i0,2x))")" Will write (ik_ibz, spin, nblocks) ",ik_ibz,spin,nblocks
4627 30 : call wrtout(std_out, msg)
4628 :
4629 : ! Extract the block of wavefunctions from Wfd.
4630 : ! Try to allocate all u(g) first,
4631 : ! TODO: If not enough memory fallback to a blocked algorithm.
4632 30 : cgsize = Wfd%nspinor * npw_k * how_manyb
4633 90 : ABI_MALLOC_OR_DIE(cg_k, (2,cgsize), ierr)
4634 :
4635 30 : if (size(Wfd%Kdata(ik_ibz)%kg_k,dim=2)<wfkfile%Hdr%npwarr(ik_ibz)) then
4636 0 : ABI_ERROR("Wrong number of npw before printing")
4637 : end if
4638 : ! Extract the set of u(g) for this (kpoint,spin)
4639 : ! This works only if all the bands are on the same node.
4640 : !band_block = [1, nband_k]
4641 : !call wfd_extract_cgblock(Wfd,[(ii, ii=1,nband_k)],ik_ibz,spin,cg_k)
4642 60 : do blk=1,nblocks
4643 90 : band_block = blocks(:,blk)
4644 510 : call wfd_extract_cgblock(Wfd,[(ii, ii=band_block(1),band_block(2))],ik_ibz,spin,cg_k) ! cg_k extracted from Wfd!
4645 :
4646 60 : if (band_block(1)==1) then
4647 : ! Write also kg_k, eig_k and occ_k
4648 : call wfkfile%write_band_block(band_block,ik_ibz,spin,xmpio_single,&
4649 : kg_k=Wfd%Kdata(ik_ibz)%kg_k,cg_k=cg_k, &
4650 30 : eig_k=ebands%eig(:,ik_ibz,spin),occ_k=ebands%occ(:,ik_ibz,spin)) ! occs extracted from Bands (i.e. QP_BSt)
4651 : ! kg_k obtained from Wfd so OK! It is
4652 : ! how Gs are ordered.
4653 : else
4654 0 : ABI_ERROR("band_block(1)>1 should not happen in the present version!")
4655 : !call wfkfile%write_band_block(band_block,ik_ibz,spin,xmpio_single,cg_k=cg_k(:,1+icg:))
4656 : end if
4657 : end do
4658 :
4659 30 : ABI_FREE(cg_k)
4660 35 : ABI_FREE(blocks)
4661 : end do ! k-points
4662 : end do ! spin
4663 :
4664 5 : call xmpi_barrier(Wfd%comm)
4665 :
4666 : ! Close the file.
4667 5 : call wfkfile%close()
4668 :
4669 5 : call cwtime_report(" write all cg" , cpu, wall, gflops)
4670 :
4671 5 : end subroutine wfdgw_write_wfk
4672 : !!***
4673 :
4674 : !----------------------------------------------------------------------
4675 :
4676 : !!****f* m_wfd/wfd_read_wfk
4677 : !! NAME
4678 : !! wfd_read_wfk
4679 : !!
4680 : !! FUNCTION
4681 : !! This routine reads the WFK file completing the initialization of the wavefunction descriptor
4682 : !!
4683 : !! INPUTS
4684 : !! wfk_fname=Name of the WFK file.
4685 : !! iomode=Option specifying the fileformat as well as the IO mode to be used.
4686 : !!
4687 : !! OUTPUT
4688 : !! [out_hdr]=Header of the WFK file.
4689 : !!
4690 : !! SIDE EFFECTS
4691 : !! Wfd<wfd_t>=All the states owned by this node whose status is (STORED|ALLOCATED) read.
4692 : !!
4693 : !! SOURCE
4694 :
4695 479 : subroutine wfd_read_wfk(Wfd, wfk_fname, iomode, out_hdr)
4696 :
4697 : !Arguments ------------------------------------
4698 : !scalars
4699 : integer,intent(in) :: iomode
4700 : character(len=*),intent(in) :: wfk_fname
4701 : class(wfd_t),target,intent(inout) :: Wfd
4702 : type(Hdr_type),optional,intent(inout) :: out_hdr ! ifort and others are buggy for optional intent(out) structured types
4703 :
4704 : !Local variables ------------------------------
4705 : !scalars
4706 : integer,parameter :: formeig0 = 0, optkg1 = 1, method = 2
4707 : integer :: wfk_unt,npw_disk,nmiss,ig,sc_mode,ii
4708 : integer :: io_comm,master,my_rank,spin,ik_ibz,fform,ierr ! ,igp
4709 : integer :: mcg,nband_wfd,nband_disk,band,mband_disk,bcount,istwfk_disk
4710 : integer :: spinor,cg_spad,gw_spad,icg,igw,cg_bpad, allcg_bpad, ib, ik, is
4711 : integer :: my_bmin, my_bmax, bmin, bmax
4712 : logical :: change_gsphere, master_only, iread
4713 : real(dp) :: cpu, wall, gflops, cpu_ks, wall_ks, gflops_ks
4714 : character(len=500) :: msg
4715 1916 : type(Wfk_t) :: Wfk
4716 479 : type(Hdr_type) :: Hdr
4717 : type(wave_t),pointer :: wave
4718 : !arrays
4719 479 : integer,allocatable :: gf2wfd(:), kg_k(:,:), all_countks(:,:)
4720 : integer :: work_ngfft(18),gmax_wfd(3),gmax_disk(3),gmax(3)
4721 : real(dp) :: tsec(2)
4722 958 : real(dp),allocatable :: eig_k(:), cg_k(:,:), out_cg(:,:), work(:,:,:,:), allcg_k(:,:)
4723 479 : logical,allocatable :: my_readmask(:,:,:)
4724 : character(len=6) :: tag_spin(2)
4725 : !************************************************************************
4726 :
4727 : ! Keep track of time spent in wfd_read_wfk
4728 479 : call timab(300, 1, tsec)
4729 :
4730 479 : if (any(iomode == [IO_MODE_NETCDF, IO_MODE_FORTRAN_MASTER])) then
4731 0 : ABI_ERROR(sjoin("Unsupported value for iomode: ", itoa(iomode)))
4732 : end if
4733 :
4734 : ! IO_MODE_FORTRAN --> only master reads and broadcasts data.
4735 : ! IO_MODE_MPI --> all procs read with collective operations.
4736 479 : my_rank = Wfd%my_rank; master = Wfd%master
4737 479 : io_comm = wfd%comm; sc_mode = xmpio_collective; master_only = .False.; iread = .True.
4738 : !if (iomode == IO_MODE_FORTRAN) then
4739 479 : io_comm = xmpi_comm_self; sc_mode = xmpio_single; master_only = .True.; iread = my_rank == wfd%master
4740 : !end if
4741 :
4742 : call wrtout(std_out, sjoin( &
4743 : " wfd_read_wfk: Reading file:", wfk_fname, &
4744 479 : " with iomode:", iomode2str(iomode),", master_only:", yesno(master_only)), pre_newlines=2)
4745 479 : if (iomode == IO_MODE_MPI) then
4746 : call wrtout(std_out, sjoin( &
4747 : " If MPI-IO is too slow, use the command line option `abinit --enforce-fortran-io ...`", ch10, &
4748 0 : " to make the master proc read data with Fortran-IO and then broadcast (requires more memory)"), do_flush=.True.)
4749 : end if
4750 :
4751 479 : if (iread) then
4752 419 : wfk_unt = get_unit()
4753 419 : call wfk%open_read(wfk_fname, formeig0, iomode, wfk_unt, io_comm, Hdr_out=Hdr)
4754 : end if
4755 :
4756 479 : if (master_only) call hdr%bcast(wfd%master, wfd%my_rank, wfd%comm)
4757 479 : if (present(out_hdr)) call hdr%copy(out_hdr)
4758 :
4759 : ! TODO: Perform more consistency check btw Hdr and Wfd.
4760 : ! Output the header of the GS wavefunction file.
4761 479 : fform = 0
4762 479 : if (wfd%prtvol /= 0 .and. wfd%my_rank == 0) call hdr%echo(fform, 4, unit=std_out)
4763 :
4764 8339 : mband_disk = MAXVAL(Hdr%nband)
4765 479 : ABI_CHECK_ILEQ(Wfd%mband, mband_disk, "Not enough bands stored on WFK file")
4766 :
4767 : ! Make sure wfd%kibz agrees the k-points reported in the hdr.
4768 479 : ABI_CHECK_IEQ(wfd%nkibz, hdr%nkpt, "wfd%nkibz != hdr%nkpt")
4769 479 : ierr = 0
4770 8319 : do ik_ibz=1,wfd%nkibz
4771 31839 : if (any(abs(wfd%kibz(:, ik_ibz) - hdr%kptns(:, ik_ibz)) > tol12)) then
4772 0 : ierr = ierr + 1
4773 : call wrtout(std_out, &
4774 0 : sjoin("For ik_ibz: ", itoa(ik_ibz), "wfd kpt:", ktoa(wfd%kibz(:, ik_ibz)), " /= ", ktoa(hdr%kptns(:,ik_ibz))))
4775 : end if
4776 : end do
4777 479 : ABI_CHECK_IEQ(ierr, 0, "kpoints in wfd% and WFK file do not agree. See messages above")
4778 :
4779 : ! Each node will read the waves whose status if (WFD_ALLOCATED|WFD_STORED).
4780 : ! all_countks is a global array used to skip (ik_ibz, spin) if all MPI procs do not need bands for this (k, s)
4781 2395 : ABI_MALLOC(my_readmask, (mband_disk, Wfd%nkibz, Wfd%nsppol))
4782 170764 : my_readmask = .False.
4783 479 : my_bmin = huge(1); my_bmax = -huge(1)
4784 10262 : ABI_ICALLOC(all_countks, (wfd%nkibz, wfd%nsppol))
4785 :
4786 965 : do spin=1,Wfd%nsppol
4787 8825 : do ik_ibz=1,Wfd%nkibz
4788 113997 : do band=1,Wfd%nband(ik_ibz,spin)
4789 113511 : if (wfd%ihave_ug(band, ik_ibz, spin)) then
4790 67955 : my_bmin = min(my_bmin, band)
4791 67955 : my_bmax = max(my_bmax, band)
4792 67955 : my_readmask(band, ik_ibz, spin) = .True.
4793 67955 : all_countks(ik_ibz, spin) = 1
4794 67955 : if (wfd%ihave_ug(band, ik_ibz, spin, how="Stored")) then
4795 0 : ABI_ERROR("Wavefunction is already stored!")
4796 : end if
4797 : end if
4798 : end do
4799 : end do
4800 : end do
4801 :
4802 : ! All procs must agree when skipping (k, s) states
4803 : ! We also need bmin/bmax for master_only option.
4804 479 : call xmpi_sum(all_countks, wfd%comm, ierr)
4805 479 : call xmpi_min(my_bmin, bmin, wfd%comm, ierr)
4806 479 : call xmpi_max(my_bmax, bmax, wfd%comm, ierr)
4807 :
4808 170764 : call wrtout(std_out, sjoin(" About to read: ",itoa(count(my_readmask)), " (b, k, s) states in total."))
4809 965 : do spin=1,wfd%nsppol
4810 : call wrtout(std_out, sjoin(" For spin:", itoa(spin), &
4811 8825 : ", will read:", itoa(count(any(my_readmask(:,:,spin), dim=1))), " k-points out of:", itoa(wfd%nkibz)))
4812 : end do
4813 1451 : tag_spin(: )= [' ',' ']; if (Wfd%nsppol==2) tag_spin(:)= [' UP ',' DOWN ']
4814 479 : if (wfd%prtvol > 0) call wrtout(std_out,' k eigenvalues [eV]')
4815 :
4816 479 : call cwtime(cpu, wall, gflops, "start")
4817 :
4818 : if (method == 1) then
4819 : do spin=1,wfd%nsppol
4820 : do ik_ibz=1,Wfd%nkibz
4821 : if (all_countks(ik_ibz, spin) == 0) cycle
4822 : npw_disk = Hdr%npwarr(ik_ibz)
4823 : nband_disk = Hdr%nband(ik_ibz+(spin-1)*Hdr%nkpt)
4824 : istwfk_disk = hdr%istwfk(ik_ibz)
4825 : change_gsphere = istwfk_disk /= wfd%istwfk(ik_ibz)
4826 : ABI_CHECK(.not. change_gsphere, "different istwfk values are not coded")
4827 :
4828 : nband_wfd = Wfd%nband(ik_ibz,spin)
4829 : if (nband_wfd > nband_disk) then
4830 : write(msg,'(a,2(i0,1x))')" nband_wfd to be read cannot be greater than nband_disk while: ",nband_wfd, nband_disk
4831 : ABI_ERROR(msg)
4832 : end if
4833 :
4834 : mcg = npw_disk*Wfd%nspinor*nband_wfd
4835 :
4836 : ABI_MALLOC(eig_k,((2*Wfk%mband)**formeig0*Wfk%mband))
4837 : ABI_MALLOC(kg_k,(3,optkg1*npw_disk))
4838 : ABI_MALLOC_OR_DIE(cg_k,(2,mcg), ierr)
4839 :
4840 : call wfk%read_band_block([1, nband_wfd], ik_ibz, spin, sc_mode, kg_k=kg_k, cg_k=cg_k, eig_k=eig_k)
4841 :
4842 : if (wfd%prtvol > 0 .and. Wfd%my_rank==Wfd%master) then
4843 : if (Wfd%nsppol==2) then
4844 : write(std_out,'(i3,a,10f7.2/50(10x,10f7.2/))') ik_ibz,tag_spin(spin),(eig_k(ib)*Ha_eV,ib=1,nband_wfd)
4845 : else
4846 : write(std_out,'(i3,7x,10f7.2/50(10x,10f7.2/))')ik_ibz,(eig_k(ib)*Ha_eV,ib=1,nband_wfd)
4847 : end if
4848 : end if
4849 :
4850 : ! Table with the correspondence btw the k-centered sphere of the WFK file
4851 : ! and the one used in Wfd (possibly smaller due to ecutwfn).
4852 : ABI_MALLOC(gf2wfd, (npw_disk))
4853 : if (any(my_readmask(:,ik_ibz,spin))) then
4854 : call kg_map(wfd%npwarr(ik_ibz), wfd%kdata(ik_ibz)%kg_k, npw_disk, kg_k, gf2wfd, nmiss)
4855 : end if
4856 : !if (nmiss/=0) then
4857 : ! write(msg,'(a,2(1x,i0),a,i0)')" For (k,s) ",ik_ibz,spin," the number of missing G is ",nmiss
4858 : ! ABI_WARNING(msg)
4859 : !end if
4860 :
4861 : ! Conversion of the basis set.
4862 : do band=1,Wfd%nband(ik_ibz,spin)
4863 : if (my_readmask(band, ik_ibz, spin)) then
4864 :
4865 : ABI_CHECK(all(wfd%bks2wfd(:, band, ik_ibz, spin) /= 0), "state in not allocated")
4866 : ib = wfd%bks2wfd(1, band, ik_ibz, spin)
4867 : ik = wfd%bks2wfd(2, band, ik_ibz, spin)
4868 : is = wfd%bks2wfd(3, band, ik_ibz, spin)
4869 : wave => wfd%s(is)%k(ik)%b(ib)
4870 : wave%ug = czero
4871 :
4872 : cg_bpad=npw_disk*Wfd%nspinor*(band-1)
4873 : do spinor=1,Wfd%nspinor
4874 : cg_spad=(spinor-1)*npw_disk
4875 : gw_spad=(spinor-1)*Wfd%npwarr(ik_ibz)
4876 : do ig=1,npw_disk
4877 : icg = ig+cg_spad+cg_bpad
4878 : igw = gf2wfd(ig)+gw_spad
4879 : if (gf2wfd(ig) /= 0) wave%ug(igw) = CMPLX(cg_k(1,icg), cg_k(2,icg), kind=gwp)
4880 : end do
4881 : end do
4882 : wave%has_ug = WFD_STORED
4883 :
4884 : end if
4885 : end do
4886 :
4887 : ABI_FREE(eig_k)
4888 : ABI_FREE(kg_k)
4889 : ABI_FREE(cg_k)
4890 : ABI_FREE(gf2wfd)
4891 : end do !ik_ibz
4892 : end do !spin
4893 :
4894 : else if (method==2) then
4895 : ! DEFAULT ALGO: This seems to be the most efficient one.
4896 :
4897 965 : do spin=1,Wfd%nsppol
4898 8825 : do ik_ibz=1,Wfd%nkibz
4899 7860 : if (all_countks(ik_ibz, spin) == 0) cycle
4900 4252 : call cwtime(cpu_ks, wall_ks, gflops_ks, "start")
4901 : !write(std_out,*)" About to read ik_ibz: ",ik_ibz,", spin: ",spin
4902 :
4903 4252 : npw_disk = Hdr%npwarr(ik_ibz)
4904 4252 : nband_disk = Hdr%nband(ik_ibz+(spin-1)*Hdr%nkpt)
4905 4252 : istwfk_disk = hdr%istwfk(ik_ibz)
4906 4252 : change_gsphere = istwfk_disk /= wfd%istwfk(ik_ibz)
4907 4252 : nband_wfd = Wfd%nband(ik_ibz, spin)
4908 :
4909 4252 : if (nband_wfd > nband_disk) then
4910 0 : write(msg,'(2(a, i0))')"nband_wfd to be read: ", nband_wfd,", cannot be greater than nband_disk: ",nband_disk
4911 0 : ABI_ERROR(msg)
4912 : end if
4913 :
4914 : ! Allocate full array for eigenvalues and G-vectors.
4915 : !print *, "nband_disk, npw_disk", nband_disk, npw_disk
4916 12756 : ABI_MALLOC(eig_k, ((2*nband_disk)**formeig0*nband_disk))
4917 12756 : ABI_MALLOC(kg_k, (3,optkg1*npw_disk))
4918 :
4919 : ! Allocate array to store my wavefunctions and read data
4920 136034 : mcg = npw_disk * wfd%nspinor * count(my_readmask(:, ik_ibz, spin))
4921 : !print *, "mcg", mcg
4922 12756 : ABI_MALLOC_OR_DIE(cg_k, (2, mcg), ierr)
4923 :
4924 : if (.not. master_only) then
4925 : ! All procs read.
4926 : call wfk%read_bmask(my_readmask(:,ik_ibz, spin), ik_ibz, spin, sc_mode, kg_k=kg_k, cg_k=cg_k, eig_k=eig_k)
4927 :
4928 : else
4929 : ! Master reads full set of bands and broadcasts data, then each proc extract its own set of wavefunctions.
4930 : ! TODO: Should read in blocks to reduce memory footprint
4931 : ! See for instance gwr_read_ugb_from_wfk for blocked algorithm.
4932 :
4933 12756 : ABI_MALLOC_OR_DIE(allcg_k, (2, npw_disk*wfd%nspinor*(bmax-bmin+1)), ierr)
4934 : !call pstat_proc%print(_PSTAT_ARGS_)
4935 :
4936 4252 : if (my_rank == master) then
4937 10764 : call wfk%read_band_block([bmin, bmax], ik_ibz, spin, xmpio_single, kg_k=kg_k, cg_k=allcg_k, eig_k=eig_k)
4938 : end if
4939 :
4940 4252 : call xmpi_bcast(kg_k, wfd%master, wfd%comm, ierr)
4941 4252 : call xmpi_bcast(eig_k, wfd%master, wfd%comm, ierr)
4942 4252 : call xmpi_bcast(allcg_k, wfd%master, wfd%comm, ierr)
4943 :
4944 4252 : bcount = 0
4945 77427 : do band=bmin,bmax
4946 77427 : if (my_readmask(band, ik_ibz, spin)) then
4947 67955 : bcount = bcount + 1
4948 67955 : cg_bpad = npw_disk * wfd%nspinor * (bcount-1)
4949 67955 : allcg_bpad = npw_disk * wfd%nspinor * (band - bmin)
4950 67955 : call cg_zcopy(npw_disk * wfd%nspinor, allcg_k(:, allcg_bpad+1), cg_k(:, cg_bpad+1))
4951 : end if
4952 : end do
4953 8504 : ABI_FREE(allcg_k)
4954 : end if
4955 :
4956 4252 : if (Wfd%my_rank == Wfd%master .and. wfd%prtvol > 0) then
4957 658 : if (Wfd%nsppol==2) then
4958 672 : write(std_out,'(i3,a,10f7.2/50(10x,10f7.2/))') ik_ibz,tag_spin(spin),(eig_k(ib)*Ha_eV,ib=1,nband_wfd)
4959 : else
4960 12408 : write(std_out,'(i3,7x,10f7.2/50(10x,10f7.2/))')ik_ibz,(eig_k(ib)*Ha_eV,ib=1,nband_wfd)
4961 : end if
4962 : end if
4963 :
4964 : !print *, "Before change_gpshere-1", npw_disk
4965 :
4966 : ! Table with the correspondence btw the k-centered sphere of the WFK file
4967 : ! and the one used in Wfd (possibly smaller due to ecutwfn).
4968 : ! TODO: Here I should treat the case in which istwfk in wfd differs from the one on disk.
4969 12756 : ABI_MALLOC(gf2wfd, (npw_disk))
4970 5355 : if (any(my_readmask(:,ik_ibz,spin))) then
4971 : #if defined FC_NVHPC
4972 : !write(std_out, *)"NVHPC with netcdf gives crazy values for kg_k"
4973 : !write(std_out,*) "wfd%kdata(ik_ibz)%kg_k(:,1)", wfd%kdata(ik_ibz)%kg_k(:,1)
4974 : !write(std_out,*) "kg_k(:,1):", kg_k(:,1)
4975 : #endif
4976 4252 : call kg_map(wfd%npwarr(ik_ibz), wfd%kdata(ik_ibz)%kg_k, npw_disk, kg_k, gf2wfd, nmiss)
4977 : end if
4978 : !if (nmiss/=0) then
4979 : ! write(msg,'(a,2(1x,i0),a,i0)')" For (k,s) ",ik_ibz,spin," the number of missing G is ",nmiss
4980 : ! ABI_WARNING(msg)
4981 : !end if
4982 : !print *, "Before change_gpshere0"
4983 :
4984 5355 : if (change_gsphere .and. any(my_readmask(:,ik_ibz,spin))) then
4985 : ! Prepare call to ctgk_change_sphere
4986 : ! FFT box must enclose the two spheres (wfd(k), wfk(k))
4987 780012 : gmax_wfd = maxval(abs(wfd%kdata(ik_ibz)%kg_k), dim=2)
4988 390196 : gmax_disk = maxval(abs(kg_k), dim=2)
4989 688 : do ii=1,3
4990 688 : gmax(ii) = max(gmax_wfd(ii), gmax_disk(ii))
4991 : end do
4992 688 : gmax = 2*gmax + 1
4993 172 : call ngfft_seq(work_ngfft, gmax)
4994 860 : ABI_MALLOC(work, (2, work_ngfft(4),work_ngfft(5),work_ngfft(6)))
4995 516 : ABI_MALLOC(out_cg, (2, wfd%npwarr(ik_ibz) * wfd%nspinor))
4996 : end if
4997 :
4998 : ! Conversion of the basis set.
4999 4252 : bcount = 0
5000 79794 : do band=1,Wfd%nband(ik_ibz,spin)
5001 79794 : if (my_readmask(band, ik_ibz, spin)) then
5002 :
5003 67955 : ib = wfd%bks2wfd(1, band, ik_ibz, spin)
5004 67955 : ik = wfd%bks2wfd(2, band, ik_ibz, spin)
5005 67955 : is = wfd%bks2wfd(3, band, ik_ibz, spin)
5006 271820 : ABI_CHECK(all(wfd%bks2wfd(:, band, ik_ibz, spin) /= 0), "state in not allocated")
5007 :
5008 67955 : wave => wfd%s(is)%k(ik)%b(ib)
5009 31432681 : wave%ug = czero
5010 :
5011 67955 : bcount = bcount + 1
5012 67955 : cg_bpad = npw_disk*Wfd%nspinor*(bcount-1)
5013 : !print *, "Before change_gpshere"
5014 :
5015 67955 : if (change_gsphere) then
5016 : ! Different istwfk storage.
5017 : call cgtk_change_gsphere(wfd%nspinor, &
5018 : npw_disk, istwfk_disk, kg_k, cg_k(:, cg_bpad+1:), &
5019 3166 : wfd%npwarr(ik_ibz), wfd%istwfk(ik_ibz), wfd%kdata(ik_ibz)%kg_k, out_cg, work_ngfft, work)
5020 :
5021 3535667 : wave%ug(:) = CMPLX(out_cg(1, :), out_cg(2, :), kind=gwp)
5022 : !call wfd%push_ug(band, ik_ibz, spin, cryst, out_cg)
5023 : else
5024 130506 : do spinor=1,Wfd%nspinor
5025 65717 : cg_spad=(spinor-1)*npw_disk
5026 65717 : gw_spad=(spinor-1)*Wfd%npwarr(ik_ibz)
5027 27919228 : do ig=1,npw_disk
5028 27788722 : icg = ig+cg_spad+cg_bpad
5029 27788722 : igw = gf2wfd(ig)+gw_spad
5030 27854439 : if (gf2wfd(ig) /= 0) then
5031 27242402 : wave%ug(igw) = CMPLX(cg_k(1,icg),cg_k(2,icg), kind=gwp)
5032 : end if
5033 : end do
5034 : !call wfd%push_ug(band, ik_ibz, spin, cryst, out_cg)
5035 : end do
5036 : end if
5037 :
5038 67955 : wave%has_ug = WFD_STORED
5039 : end if
5040 : end do
5041 :
5042 4252 : ABI_FREE(eig_k)
5043 4252 : ABI_FREE(kg_k)
5044 4252 : ABI_FREE(cg_k)
5045 4252 : ABI_FREE(gf2wfd)
5046 4252 : ABI_SFREE(work)
5047 4252 : ABI_SFREE(out_cg)
5048 :
5049 8990 : if (ik_ibz <= 10 .or. mod(ik_ibz, 200) == 0) then
5050 2744 : write(msg,'(4x,4(a,i0),a)') "Reading kpt [", ik_ibz, "/", wfd%nkibz, "] spin [", spin, "/", wfd%nsppol, "]"
5051 2744 : call cwtime_report(msg, cpu_ks, wall_ks, gflops_ks)
5052 : end if
5053 : end do ! ik_ibz
5054 : end do ! spin
5055 :
5056 : else
5057 : ABI_ERROR(sjoin("Wrong method: ", itoa(method)))
5058 : end if
5059 :
5060 479 : call wfk%close(); call Hdr%free()
5061 :
5062 479 : ABI_FREE(my_readmask)
5063 479 : ABI_FREE(all_countks)
5064 :
5065 : ! Update the kbs table storing the distribution of the ug and set the MPI communicators.
5066 : select type (wfd)
5067 : class is (wfdgw_t)
5068 387 : call wfd%update_bkstab()
5069 : end select
5070 :
5071 479 : call cwtime_report(" WFK IO", cpu, wall, gflops, end_str=ch10)
5072 479 : call timab(300, 2, tsec)
5073 :
5074 1916 : end subroutine wfd_read_wfk
5075 : !!***
5076 :
5077 : !----------------------------------------------------------------------
5078 :
5079 : !!****f* m_wfd/wfd_paw_get_aeur
5080 : !! NAME
5081 : !! wfd_paw_get_aeur
5082 : !!
5083 : !! FUNCTION
5084 : !! Compute the AE PAW wavefunction in real space.
5085 : !!
5086 : !! INPUTS
5087 : !! band,ik_ibz,spin=indices specifying the band, the k-point and the spin.
5088 : !! Psps<pseudopotential_type>=variables related to pseudopotentials
5089 : !! Cryst<crystal_t>= data type gathering info on symmetries and unit cell.
5090 : !! Wfd<wfd_t>=wavefunction descriptor.
5091 : !! Pawtab(ntypat*usepaw)<type(pawtab_type)>=paw tabulated starting data.
5092 : !! Pawfgrtab(natom)<pawfgrtab_type>= atomic data given on fine rectangular grid.
5093 : !! NB: rpaw should be used in nhatgrid to initialize the datatype (optcut=1 option) instead of the radius for the
5094 : !! shape functions (rpaw /= rshp).
5095 : !! Paw_onsite(natom)<paw_pwaves_lmn_t>=3D PAW partial waves in real space for each FFT point in the PAW spheres.
5096 : !!
5097 : !! OUTPUT
5098 : !! ur_ae(Wfd%nfft*Wfd%nspinor)=AE PAW wavefunction in real space.
5099 : !! [ur_ae_onsite(Wfd%nfft*Wfd%nspinor)]
5100 : !! [ur_ps_onsite(Wfd%nfft*Wfd%nspinor)]
5101 : !!
5102 : !! NOTES
5103 : !! (1) The true wavefunction integrates in real space to the unit cell volume.
5104 : !! The definition of the cprj matrix elements includes the term 1/SQRT(ucvol) that comes
5105 : !! from the use of a normalized planewave e^(iG.r)/SQRT(omega) in the FFT transform G-->R (see e.g. opernla_ylm)
5106 : !! On the contrary, the convention for the G-->R transform employed in the FFT routines used in abinit is
5107 : !! u(r) = sum_G u(G) e^(iG.r); u(G) = one/omega \int u(r) e^(-iG.r)dr.
5108 : !! Hence we have to multiply the onsite part by SQRT(uvol) before adding the smooth FFT part in real space.
5109 : !!
5110 : !! (2) Care has to be taken in the calculation of the onsite contribution when the FFT point belongs to the PAW
5111 : !! sphere of a periodically repeated atom. In this case one evaluates the onsite term associated to the
5112 : !! atom in the first unit cell then the contribution has to be multiplied by a k- dependent
5113 : !! phase factor to account for the wrapping of the real-space point in the first unit cell.
5114 : !!
5115 : !! SOURCE
5116 :
5117 0 : subroutine wfd_paw_get_aeur(Wfd,band,ik_ibz,spin,Cryst,Paw_onsite,Psps,Pawtab,Pawfgrtab,ur_ae,ur_ae_onsite,ur_ps_onsite)
5118 :
5119 : !Arguments ------------------------------------
5120 : !scalars
5121 : integer,intent(in) :: band,ik_ibz,spin
5122 : type(pseudopotential_type),intent(in) :: Psps
5123 : type(crystal_t),intent(in) :: Cryst
5124 : class(wfd_t),intent(inout) :: Wfd
5125 : !arrays
5126 : type(pawtab_type),intent(in) :: Pawtab(Cryst%ntypat)
5127 : type(pawfgrtab_type),intent(in) :: Pawfgrtab(Cryst%natom)
5128 : type(paw_pwaves_lmn_t),intent(in) :: Paw_onsite(Cryst%natom)
5129 : complex(gwp),intent(out) :: ur_ae(Wfd%nfft*Wfd%nspinor)
5130 : complex(gwp),optional,intent(out) :: ur_ae_onsite(Wfd%nfft*Wfd%nspinor)
5131 : complex(gwp),optional,intent(out) :: ur_ps_onsite(Wfd%nfft*Wfd%nspinor)
5132 :
5133 : !Local variables-------------------------------
5134 : !scalars
5135 : integer :: itypat,ln_size,lmn_size,iatom,spinor
5136 : integer :: nfgd,ifgd,jlmn,jl,jm,ifftsph
5137 : real(dp) :: phj,tphj,arg,re_cp,im_cp
5138 : complex(dp) :: cp,cnorm
5139 : !arrays
5140 : real(dp) :: kpoint(3)
5141 0 : complex(dp),allocatable :: ceikr(:),phk_atm(:)
5142 : type(pawcprj_type),allocatable :: Cp1(:,:)
5143 : ! *************************************************************************
5144 :
5145 : ! TODO ngfft should be included in pawfgrtab_type
5146 : !% if (ANY(Wfd%ngfft(1:3)/=Pawfgrtab%ngfft(1:3)) then
5147 : !! ABI_ERROR("Wfd%ngfft(1:3)/=Pawfgrtab%ngfft(1:3)")
5148 : !% end if
5149 :
5150 0 : call wfd%get_ur(band,ik_ibz,spin,ur_ae)
5151 :
5152 0 : kpoint = Wfd%kibz(:,ik_ibz)
5153 0 : ABI_MALLOC(ceikr, (Wfd%nfftot * wfd%nspinor))
5154 :
5155 0 : call calc_ceikr(kpoint, wfd%ngfft, Wfd%nfftot, wfd%nspinor, ceikr)
5156 0 : ur_ae = ur_ae * ceikr
5157 :
5158 0 : ABI_MALLOC(Cp1,(Wfd%natom,Wfd%nspinor))
5159 0 : call pawcprj_alloc(Cp1,0,Wfd%nlmn_atm)
5160 :
5161 0 : call wfd%get_cprj(band,ik_ibz,spin,Cryst,Cp1,sorted=.FALSE.)
5162 :
5163 : ! Add onsite term on the augmented FFT mesh.
5164 0 : if (present(ur_ae_onsite)) ur_ae_onsite = czero
5165 0 : if (present(ur_ps_onsite)) ur_ps_onsite = czero
5166 :
5167 0 : ABI_CHECK(Wfd%nspinor==1,"nspinor==1 not coded")
5168 :
5169 0 : do iatom=1,Cryst%natom
5170 0 : itypat =Cryst%typat(iatom)
5171 0 : lmn_size=Pawtab(itypat)%lmn_size
5172 0 : ln_size =Pawtab(itypat)%basis_size ! no. of nl elements in PAW basis.
5173 0 : nfgd =Pawfgrtab(iatom)%nfgd ! no. of points in the fine grid for this PAW sphere.
5174 :
5175 0 : ABI_MALLOC(phk_atm,(nfgd))
5176 0 : do ifgd=1,nfgd
5177 0 : arg = -two_pi* DOT_PRODUCT(Paw_onsite(iatom)%r0shift(:,ifgd),kpoint)
5178 0 : phk_atm(ifgd) = DCMPLX(COS(arg),SIN(arg))
5179 : end do
5180 :
5181 0 : do spinor=1,Wfd%nspinor
5182 0 : do jlmn=1,lmn_size
5183 0 : jl=Psps%indlmn(1,jlmn,itypat)
5184 0 : jm=Psps%indlmn(2,jlmn,itypat)
5185 0 : re_cp = Cp1(iatom,spinor)%cp(1,jlmn)
5186 0 : im_cp = Cp1(iatom,spinor)%cp(2,jlmn)
5187 0 : cp = DCMPLX(re_cp, im_cp) * SQRT(Cryst%ucvol) ! Pay attention here. see (1).
5188 :
5189 0 : do ifgd=1,nfgd ! loop over fine grid points in current PAW sphere.
5190 0 : ifftsph = Pawfgrtab(iatom)%ifftsph(ifgd) ! index of the point on the grid
5191 0 : phj = Paw_onsite(iatom)% phi(ifgd,jlmn)
5192 0 : tphj = Paw_onsite(iatom)%tphi(ifgd,jlmn)
5193 0 : ur_ae(ifftsph) = ur_ae(ifftsph) + cp * (phj-tphj) * phk_atm(ifgd)
5194 0 : if (present(ur_ae_onsite)) ur_ae_onsite(ifftsph) = ur_ae_onsite(ifftsph) + cp * phj * phk_atm(ifgd)
5195 0 : if (present(ur_ps_onsite)) ur_ps_onsite(ifftsph) = ur_ps_onsite(ifftsph) + cp * tphj * phk_atm(ifgd)
5196 : end do
5197 : end do !jlmn
5198 : end do !spinor
5199 :
5200 0 : ABI_FREE(phk_atm)
5201 : end do !iatom
5202 :
5203 : ! Remove the phase e^{ikr}, u(r) is returned.
5204 0 : ur_ae = ur_ae * CONJG(ceikr)
5205 0 : cnorm = xdotc(Wfd%nfft*Wfd%nspinor,ur_ae,1,ur_ae,1)/Wfd%nfft
5206 : !write(std_out,*)" AE PAW norm: (b,k,s)",band,ik_ibz,spin,REAL(cnorm)
5207 :
5208 0 : if (present(ur_ae_onsite)) ur_ae_onsite = ur_ae_onsite * CONJG(ceikr)
5209 0 : if (present(ur_ps_onsite)) ur_ps_onsite = ur_ps_onsite * CONJG(ceikr)
5210 :
5211 0 : call pawcprj_free(Cp1)
5212 0 : ABI_FREE(Cp1)
5213 0 : ABI_FREE(ceikr)
5214 :
5215 0 : end subroutine wfd_paw_get_aeur
5216 : !!***
5217 :
5218 : !----------------------------------------------------------------------
5219 :
5220 : !!****f* m_wfd/wfdgw_plot_ur
5221 : !! NAME
5222 : !! wfdgw_plot_ur
5223 : !!
5224 : !! FUNCTION
5225 : !! This routine writes the squared modulus of the wavefunctions in real space
5226 : !! to an external files, one for each (k,b,s). File are written in the XSF format (Xcrysden).
5227 : !! A subset of (b,k,s) states can be specified via the bks_mask. The routine is MPI parallelized.
5228 : !!
5229 : !! INPUTS
5230 : !! Wfd<wfd_t>=Wavefunction descriptor.
5231 : !! Cryst<crystal_t>= Information on symmetries and unit cell.
5232 : !! Psps<pseudopotential_type>=Pseudopotential info.
5233 : !! Pawtab(ntypat*usepaw)<type(pawtab_type)>=PAW tabulated starting data.
5234 : !! Pawrad(ntypat*usepaw)<type(pawrad_type)>=paw radial mesh and related data.
5235 : !! ngfftf(18)=The FFT mesh used for plotting |wfr|**2, it can differ from the one internally used in Wfd.
5236 : !! For example, PAW wavefunctions should be plotted on a much finer FFT mesh.
5237 : !! bks_mask(mband,nkibz,nsppol)=logical mask used to select the states to be plotted.
5238 : !!
5239 : !! OUTPUT
5240 : !! Output is written on file.
5241 : !!
5242 : !! SOURCE
5243 :
5244 0 : subroutine wfdgw_plot_ur(Wfd,Cryst,Psps,Pawtab,Pawrad,ngfftf,bks_mask)
5245 :
5246 : !Arguments ------------------------------------
5247 : !scalars
5248 : type(crystal_t),intent(in) :: Cryst
5249 : type(Pseudopotential_type),intent(in) :: Psps
5250 : class(wfdgw_t),intent(inout) :: Wfd
5251 : !arrays
5252 : integer,intent(in) :: ngfftf(18)
5253 : logical,target,intent(in) :: bks_mask(Wfd%mband,Wfd%nkibz,Wfd%nsppol)
5254 : type(Pawtab_type),intent(in) :: Pawtab(Cryst%ntypat*Wfd%usepaw)
5255 : type(Pawrad_type),intent(in) :: Pawrad(Cryst%ntypat*Wfd%usepaw)
5256 :
5257 : !Local variables ------------------------------
5258 : !scalars
5259 : integer :: spin,band,ik_ibz,optcut,optgr0,optgr1,optgr2,optrad
5260 : integer :: n1,n2,n3,my_nplots,plot,funt,my_nband,cplex
5261 : character(len=500) :: msg
5262 : character(len=fnlen) :: xsf_fname
5263 : !arrays
5264 0 : integer :: got(Wfd%nproc)
5265 0 : integer,allocatable :: l_size_atm(:),my_plot_list(:,:)
5266 0 : integer :: my_band_list(Wfd%mband)
5267 0 : real(dp),allocatable :: data_plot(:)
5268 0 : logical,contiguous, pointer :: bmask(:)
5269 0 : complex(gwp),allocatable :: ur_ae(:),nc_ur(:)
5270 0 : type(Pawfgrtab_type),allocatable :: Pawfgrtab(:)
5271 0 : type(paw_pwaves_lmn_t),allocatable :: Paw_onsite(:)
5272 : !************************************************************************
5273 :
5274 0 : if (ALL(.not.bks_mask)) RETURN
5275 :
5276 0 : call wrtout(std_out," Plotting |wfs|^2 ...")
5277 : !
5278 : ! Change the FFT mesh if needed because we want u(r) on the ngfftf mesh (pawecutd for PAW).
5279 0 : call wfd%change_ngfft(Cryst,Psps,ngfftf)
5280 0 : n1 = ngfftf(1); n2 = ngfftf(2); n3 = ngfftf(3)
5281 :
5282 : ! Distribute the plots among the nodes taking into account the distribution of the waves.
5283 : ! my_plot_list gives the list of (b,k,s) states plotted by this node.
5284 0 : ABI_MALLOC(my_plot_list,(3,Wfd%mband*Wfd%nkibz*Wfd%nsppol))
5285 :
5286 0 : my_nplots=0; got=0
5287 0 : do spin=1,Wfd%nsppol
5288 0 : do ik_ibz=1,Wfd%nkibz
5289 0 : bmask => bks_mask(:,ik_ibz,spin)
5290 0 : call wfd%distribute_bands(ik_ibz,spin,my_nband,my_band_list,got,bmask)
5291 :
5292 0 : if (my_nband>0) then
5293 0 : my_plot_list(1,my_nplots+1:my_nplots+my_nband) = my_band_list(1:my_nband)
5294 0 : my_plot_list(2,my_nplots+1:my_nplots+my_nband) = ik_ibz
5295 0 : my_plot_list(3,my_nplots+1:my_nplots+my_nband) = spin
5296 : my_nplots = my_nplots + my_nband
5297 : end if
5298 : end do
5299 : end do
5300 :
5301 0 : if (Wfd%usepaw==1) then
5302 0 : ABI_WARNING("Testing the calculation of AE PAW wavefunctions.")
5303 : ! Use a local pawfgrtab to make sure we use the correction in the paw spheres
5304 : ! the usual pawfgrtab uses r_shape which may not be the same as r_paw.
5305 0 : cplex=1
5306 0 : call pawtab_get_lsize(Pawtab,l_size_atm,Cryst%natom,Cryst%typat)
5307 0 : ABI_MALLOC(Pawfgrtab,(Cryst%natom))
5308 0 : call pawfgrtab_init(Pawfgrtab,cplex,l_size_atm,Wfd%nspden,Cryst%typat)
5309 0 : ABI_FREE(l_size_atm)
5310 :
5311 0 : optcut=1 ! use rpaw to construct Pawfgrtab.
5312 0 : optgr0=0; optgr1=0; optgr2=0 ! dont need gY terms locally.
5313 0 : optrad=1 ! do store r-R.
5314 :
5315 : call nhatgrid(Cryst%atindx1,Cryst%gmet,Cryst%natom,Cryst%natom,Cryst%nattyp,ngfftf,Cryst%ntypat,&
5316 0 : optcut,optgr0,optgr1,optgr2,optrad,Pawfgrtab,Pawtab,Cryst%rprimd,Cryst%typat,Cryst%ucvol,Cryst%xred)
5317 :
5318 : !Pawfgrtab is ready to use
5319 :
5320 0 : if (Wfd%pawprtvol>0) then
5321 : call pawfgrtab_print(Pawfgrtab,natom=Cryst%natom,unit=std_out,&
5322 0 : prtvol=Wfd%pawprtvol,mode_paral="COLL")
5323 : end if
5324 :
5325 0 : ABI_MALLOC(Paw_onsite,(Cryst%natom))
5326 : call paw_pwaves_lmn_init(Paw_onsite,Cryst%natom,Cryst%natom,Cryst%ntypat,&
5327 0 : Cryst%rprimd,Cryst%xcart,Pawtab,Pawrad,Pawfgrtab)
5328 :
5329 0 : ABI_MALLOC(ur_ae,(Wfd%nfft*Wfd%nspinor))
5330 0 : ABI_MALLOC(data_plot,(Wfd%nfft))
5331 :
5332 0 : do plot=1,my_nplots
5333 0 : band =my_plot_list(1,plot)
5334 0 : ik_ibz=my_plot_list(2,plot)
5335 0 : spin =my_plot_list(3,plot)
5336 :
5337 0 : call wfd%paw_get_aeur(band,ik_ibz,spin,Cryst,Paw_onsite,Psps,Pawtab,Pawfgrtab,ur_ae)
5338 :
5339 0 : data_plot = DBLE(ur_ae(1:Wfd%nfft)*CONJG(ur_ae(1:Wfd%nfft)))/Cryst%ucvol
5340 0 : if (Wfd%nspinor==2) data_plot = data_plot + DBLE(ur_ae(Wfd%nfft+1:)*CONJG(ur_ae(Wfd%nfft+1:)))/Cryst%ucvol
5341 :
5342 0 : write(xsf_fname,'(3(a,i0),a)') 'PAW_AE_wfk2_sp',spin,'_kpt',ik_ibz,'_bd',band,'.xsf'
5343 0 : if (open_file(xsf_fname,msg,newunit=funt,status='unknown',form='formatted') /= 0) then
5344 0 : ABI_ERROR(msg)
5345 : end if
5346 :
5347 : call printxsf(n1,n2,n3,data_plot,Cryst%rprimd,(/zero,zero,zero/),&
5348 0 : Cryst%natom,Cryst%ntypat,Cryst%typat,Cryst%xcart,Cryst%znucl,funt,0)
5349 :
5350 0 : close(funt)
5351 : end do
5352 :
5353 0 : ABI_FREE(ur_ae)
5354 0 : ABI_FREE(data_plot)
5355 :
5356 0 : call pawfgrtab_free(Pawfgrtab)
5357 0 : ABI_FREE(Pawfgrtab)
5358 0 : call paw_pwaves_lmn_free(Paw_onsite)
5359 0 : ABI_FREE(Paw_onsite)
5360 :
5361 : else
5362 : ! NC case. Just a simple FFT G-->R and then dump the results.
5363 0 : ABI_MALLOC(nc_ur,(Wfd%nfft*Wfd%nspinor))
5364 0 : ABI_MALLOC(data_plot,(Wfd%nfft))
5365 :
5366 0 : do plot=1,my_nplots
5367 0 : band =my_plot_list(1,plot)
5368 0 : ik_ibz=my_plot_list(2,plot)
5369 0 : spin =my_plot_list(3,plot)
5370 :
5371 0 : call wfd%get_ur(band,ik_ibz,spin,nc_ur)
5372 :
5373 0 : data_plot = DBLE(nc_ur(1:Wfd%nfft)*CONJG(nc_ur(1:Wfd%nfft)))/Cryst%ucvol
5374 0 : if (Wfd%nspinor==2) data_plot = data_plot + DBLE(nc_ur(Wfd%nfft+1:)*CONJG(nc_ur(Wfd%nfft+1:)))/Cryst%ucvol
5375 :
5376 0 : write(xsf_fname,'(3(a,i0),a)') 'NC_wfk2_sp',spin,'_kpt',ik_ibz,'_bd',band,'.xsf'
5377 0 : if (open_file(xsf_fname,msg,newunit=funt,status='unknown',form='formatted') /= 0) then
5378 0 : ABI_ERROR(msg)
5379 : end if
5380 : call printxsf(n1,n2,n3,data_plot,Cryst%rprimd,(/zero,zero,zero/),&
5381 0 : Cryst%natom,Cryst%ntypat,Cryst%typat,Cryst%xcart,Cryst%znucl,funt,0)
5382 :
5383 0 : close(funt)
5384 : end do
5385 :
5386 0 : ABI_FREE(nc_ur)
5387 0 : ABI_FREE(data_plot)
5388 : end if
5389 :
5390 0 : ABI_FREE(my_plot_list)
5391 :
5392 0 : end subroutine wfdgw_plot_ur
5393 : !!***
5394 :
5395 : !----------------------------------------------------------------------
5396 :
5397 : !!****f* m_wfd/wfdgw_get_nl_me
5398 : !! NAME
5399 : !! wfdgw_get_nl_me
5400 : !!
5401 : !! FUNCTION
5402 : !! Compute the non-local potential using the Wfd information.
5403 : !!
5404 : !! INPUTS
5405 : !! cryst<crystal_t>= data type gathering info on symmetries and unit cell
5406 : !! psps<pseudopotential_type>=variables related to pseudopotentials
5407 : !! pawtab(psps%ntypat) <type(pawtab_type)>=paw tabulated starting data
5408 : !! paw_ij(natom)<type(paw_ij_type)>=data structure containing PAW arrays given on (i,j) channels.
5409 : !!
5410 : !! OUTPUT
5411 : !!
5412 : !! SOURCE
5413 :
5414 4 : subroutine wfdgw_get_nl_me(Wfd, cryst, psps, pawtab, bks_mask, nl_bks)
5415 :
5416 : !Arguments ------------------------------------
5417 : !scalars
5418 : class(wfdgw_t),target,intent(inout) :: Wfd
5419 : type(crystal_t),intent(in) :: cryst
5420 : type(pseudopotential_type),intent(in) :: psps
5421 : ! arrays
5422 : logical,intent(in) :: bks_mask(Wfd%mband, Wfd%nkibz, Wfd%nsppol)
5423 : real(dp),allocatable,intent(out) :: nl_bks(:, :, :)
5424 : type(Pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
5425 :
5426 : !Local variables ------------------------------
5427 : !scalars
5428 : integer,parameter :: nspinor1=1,nspden1=1,nsppol1=1,spin1=1
5429 : integer,parameter :: ndat1=1,nnlout1=1,tim_nonlop0=0,idir0=0
5430 : integer :: natom,ib,ispin,ik_ibz,npw_k,istwf_k,nkpg
5431 : integer :: choice,cpopt,paw_opt,signs,ierr
5432 : character(len=500) :: msg
5433 4 : type(gs_hamiltonian_type) :: ham_k
5434 : type(wave_t),pointer :: wave
5435 : !arrays
5436 8 : integer :: bks_distrb(Wfd%mband, Wfd%nkibz, Wfd%nsppol)
5437 4 : integer, contiguous, pointer :: kg_k(:,:)
5438 : real(dp) :: kpoint(3),enlout(1)
5439 4 : real(dp),allocatable :: kpg_k(:,:),vnl_psi(:,:),vectin(:,:)
5440 : real(dp) :: opaw_psi(1,1)
5441 4 : real(dp),contiguous, pointer :: ffnl_k(:,:,:,:),ph3d_k(:,:,:)
5442 4 : complex(gwp),contiguous, pointer :: ug1(:)
5443 4 : type(pawcprj_type),allocatable :: cprj(:,:)
5444 : !************************************************************************
5445 :
5446 0 : ABI_CHECK(Wfd%paral_kgb == 0, "paral_kgb not coded")
5447 :
5448 4 : natom = cryst%natom
5449 :
5450 4 : signs = 1 ! => get non-local energy in G-space.
5451 4 : choice = 1 ! => <G|V_nonlocal|vectin>.
5452 4 : cpopt =-1; paw_opt= 0
5453 4 : if (Wfd%usepaw==1) then
5454 0 : ABI_ERROR("The construction of the non-local contribution is not tested/implemented for usepaw==1!")
5455 : end if
5456 : ! Initialize the Hamiltonian on the coarse FFT mesh.
5457 : call ham_k%init(psps, pawtab, nspinor1, nsppol1, nspden1, natom, cryst%typat, cryst%xred, &
5458 4 : Wfd%nfft, Wfd%mgfft, Wfd%ngfft, cryst%rprimd, Wfd%nloalg)
5459 :
5460 : ! Continue to prepare the GS Hamiltonian (note spin1)
5461 4 : call ham_k%load_spin(spin1, with_nonlocal=.true.)
5462 :
5463 : ! Distribute (b, k, s) states.
5464 4 : call Wfd%bks_distrb(bks_distrb, bks_mask=bks_mask)
5465 :
5466 240 : ABI_CALLOC(nl_bks, (Wfd%mband, Wfd%nkibz, Wfd%nsppol))
5467 224 : nl_bks(:,:,:) = czero
5468 :
5469 4 : write(std_out,'(a)') " "
5470 224 : call wrtout(std_out,sjoin(" Will calculate ",itoa(count(bks_mask))," <b,k,s|Vnl|b,k,s> matrix elements in wfdgw_get_nl_me."))
5471 8 : do ispin=1,Wfd%nsppol
5472 4 : if (ispin/=1) then
5473 0 : ABI_WARNING("In the construction of the non-local contribution, the case nsppol/=1 is not tested.")
5474 : end if
5475 32 : do ik_ibz=1,Wfd%nkibz
5476 24 : if (all(bks_distrb(:, ik_ibz, ispin) /= Wfd%my_rank)) cycle
5477 :
5478 96 : kpoint = Wfd%kibz(:, ik_ibz)
5479 24 : istwf_k = Wfd%istwfk(ik_ibz)
5480 24 : npw_k = Wfd%Kdata(ik_ibz)%npw
5481 24 : kg_k => Wfd%kdata(ik_ibz)%kg_k
5482 24 : ffnl_k => Wfd%Kdata(ik_ibz)%fnl_dir0der0
5483 24 : ph3d_k => Wfd%Kdata(ik_ibz)%ph3d
5484 :
5485 72 : ABI_MALLOC(vectin, (2, npw_k * nspinor1))
5486 48 : ABI_MALLOC(vnl_psi, (2, npw_k * nspinor1))
5487 6975 : vectin=zero
5488 6975 : vnl_psi=zero
5489 : ! Compute (k+G) vectors (only if psps%useylm=1)
5490 24 : nkpg = 3 * Wfd%nloalg(3)
5491 96 : ABI_MALLOC(kpg_k, (npw_k, nkpg))
5492 24 : if (nkpg > 0) then
5493 0 : call mkkpg(kg_k, kpg_k, kpoint, nkpg, npw_k)
5494 : end if
5495 :
5496 : ! Load k-dependent part in the Hamiltonian datastructure
5497 : call ham_k%load_k(kpt_k=kpoint,istwf_k=istwf_k,npw_k=npw_k,kg_k=kg_k,kpg_k=kpg_k,ffnl_k=ffnl_k,&
5498 24 : ph3d_k=ph3d_k,compute_ph3d=(Wfd%paral_kgb/=1),compute_gbound=(Wfd%paral_kgb/=1))
5499 :
5500 : ! ========================================================
5501 : ! ==== Compute nonlocal form factors ffnl at all (k+G) ====
5502 : ! ========================================================
5503 : ! Calculate <G|Vnl|psi> for this k-point
5504 216 : do ib=1,Wfd%nband(ik_ibz, ispin)
5505 192 : if (bks_distrb(ib, ik_ibz, ispin) /= Wfd%my_rank) cycle
5506 :
5507 192 : ABI_CHECK(Wfd%get_wave_ptr(ib, ik_ibz, ispin, wave, msg) == 0, msg)
5508 192 : ug1 => wave%ug
5509 : ! Input wavefunction coefficients <G|Cnk>.
5510 : ! vectin, (2, npw_k * nspinor1))
5511 55800 : vectin(:,:) = zero
5512 192 : if (ispin == 1) then
5513 18728 : vectin(1, 1:npw_k) = real(ug1)
5514 18728 : vectin(2, 1:npw_k) = aimag(ug1)
5515 : else
5516 0 : vectin(1, npw_k+1:) = real(ug1)
5517 0 : vectin(2, npw_k+1:) = aimag(ug1)
5518 : end if
5519 :
5520 192 : if (Wfd%usepaw == 1) then
5521 0 : call Wfd%get_cprj(ib, ik_ibz, ispin, cryst, cprj, sorted=.True.)
5522 : end if
5523 :
5524 : ! Compute nonlocal band energy. We could use nonlop to get matrix elements but we only need diagonal contributions.
5525 : ! enlout(1) is the band energy
5526 : call nonlop(choice, cpopt, cprj, enlout, ham_k, idir0, (/zero/), Wfd%mpi_enreg, ndat1, nnlout1, &
5527 192 : paw_opt, signs, opaw_psi, tim_nonlop0, vectin, vnl_psi)
5528 216 : nl_bks(ib, ik_ibz, ispin) = enlout(1)
5529 : end do ! ib
5530 :
5531 24 : ABI_FREE(vectin)
5532 24 : ABI_FREE(vnl_psi)
5533 28 : ABI_FREE(kpg_k)
5534 : end do ! ik_ibz
5535 : end do ! ispin
5536 :
5537 4 : call xmpi_sum(nl_bks, Wfd%comm, ierr)
5538 :
5539 4 : call ham_k%free()
5540 :
5541 12 : end subroutine wfdgw_get_nl_me
5542 : !!***
5543 :
5544 : !----------------------------------------------------------------------
5545 :
5546 : !!****f* m_wfd/wfd_get_socpert
5547 : !! NAME
5548 : !! wfd_get_socpert
5549 : !!
5550 : !! FUNCTION
5551 : !!
5552 : !! INPUTS
5553 : !! cryst<crystal_t>= data type gathering info on symmetries and unit cell
5554 : !! psps<pseudopotential_type>=variables related to pseudopotentials
5555 : !! pawtab(psps%ntypat) <type(pawtab_type)>=paw tabulated starting data
5556 : !! paw_ij(natom)<type(paw_ij_type)>=data structure containing PAW arrays given on (i,j) channels.
5557 : !!
5558 : !! OUTPUT
5559 : !!
5560 : !! SOURCE
5561 :
5562 : !!! subroutine wfd_get_socpert(wfd, cryst, psps, pawtab, bks_mask, soc_bks)
5563 : !!!
5564 : !!! !use m_pawcprj
5565 : !!! use m_hamiltonian, only : destroy_hamiltonian, init_hamiltonian, &
5566 : !!! load_spin_hamiltonian,load_k_hamiltonian, gs_hamiltonian_type
5567 : !!!
5568 : !!! implicit none
5569 : !!!
5570 : !!! !Arguments ------------------------------------
5571 : !!! !scalars
5572 : !!! type(wfd_t),target,intent(inout) :: wfd
5573 : !!! type(crystal_t),intent(in) :: cryst
5574 : !!! type(pseudopotential_type),intent(in) :: psps
5575 : !!! ! arrays
5576 : !!! logical,intent(in) :: bks_mask(wfd%mband, wfd%nkibz, wfd%nsppol)
5577 : !!! real(dp),allocatable,intent(out) :: osoc_bks(:, :, :)
5578 : !!! type(Pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
5579 : !!! !type(paw_ij_type),intent(in) :: paw_ij(cryst%natom*psps%usepaw)
5580 : !!!
5581 : !!! !Local variables ------------------------------
5582 : !!! !scalars
5583 : !!! integer,parameter :: nspinor2=2,nspden4=4,nsppol1=1,spin1=1
5584 : !!! integer,parameter :: ndat1=1,nnlout0=0,tim_nonlop0=0,idir0=0 !,ider0=0,
5585 : !!! integer :: natom,band,spin,ik_ibz,npw_k,istwf_k,nkpg !,ig,optder,matblk,mkmem_,nkpg,dimffnl,nspinortot
5586 : !!! integer :: choice,cpopt,cp_dim,paw_opt,signs,ierr
5587 : !!! !character(len=500) :: msg
5588 : !!! type(gs_hamiltonian_type) :: ham_k
5589 : !!! !arrays
5590 : !!! integer :: bks_distrb(wfd%mband, wfd%nkibz, wfd%nsppol)
5591 : !!! integer, contiguous, pointer :: kg_k(:,:)
5592 : !!! !real(dp) :: kptns_(3,1),ylmgr_dum(1,1,1),shifts(3)
5593 : !!! !real(dp),allocatable :: ylm_k(:,:),dum_ylm_gr_k(:,:,:)
5594 : !!! !real(dp),pointer :: ffnl_k(:,:,:,:)
5595 : !!! real(dp) :: kpoint(3),dum_enlout(0),dummy_lambda(1),soc(2)
5596 : !!! real(dp),allocatable :: kpg_k(:,:),vnl_psi(:,:),vectin(:,:) !,s_psi(:,:)
5597 : !!! real(dp),allocatable :: opaw_psi(:,:) !2, npw_k*wfd%nspinor*wfd%usepaw) ! <G|1+S|Cnk>
5598 : !!! real(dp),contiguous, pointer :: ffnl_k(:,:,:,:),ph3d_k(:,:,:)
5599 : !!! type(pawcprj_type),allocatable :: cprj(:,:)
5600 : !!! !************************************************************************
5601 : !!!
5602 : !!! ABI_CHECK(wfd%paral_kgb == 0, "paral_kgb not coded")
5603 : !!!
5604 : !!! natom = cryst%natom
5605 : !!!
5606 : !!! signs = 2 ! => apply the non-local operator to a function in G-space.
5607 : !!! choice = 1 ! => <G|V_nonlocal|vectin>.
5608 : !!! cpopt =-1; paw_opt= 0
5609 : !!! if (wfd%usepaw==1) then
5610 : !!! paw_opt=4 ! both PAW nonlocal part of H (Dij) and overlap matrix (Sij)
5611 : !!! cpopt=3 ! <p_lmn|in> are already in memory
5612 : !!!
5613 : !!! cp_dim = ((cpopt+5) / 5)
5614 : !!! ABI_MALLOC(cprj, (natom, nspinor2*cp_dim))
5615 : !!! call pawcprj_alloc(cprj, 0, wfd%nlmn_sort)
5616 : !!! end if
5617 : !!!
5618 : !!! ! Initialize the Hamiltonian on the coarse FFT mesh.
5619 : !!! call init_hamiltonian(ham_k, psps, pawtab, nspinor2, nsppol1, nspden4, natom, cryst%typat, cryst%xred, &
5620 : !!! wfd%nfft, wfd%mgfft, wfd%ngfft, cryst%rprimd, wfd%nloalg)
5621 : !!! !ham_k%ekb(:,:,1) = zero
5622 : !!!
5623 : !!! ! Continue to prepare the GS Hamiltonian (note spin1)
5624 : !!! call load_spin_hamiltonian(ham_k, spin1, with_nonlocal=.True.)
5625 : !!!
5626 : !!! ! Distribute (b, k, s) states.
5627 : !!! call wfd%bks_distrb(bks_distrb, bks_mask=bks_mask)
5628 : !!!
5629 : !!! ABI_CALLOC(osoc_bks, (wfd%mband, wfd%nkibz, wfd%nsppol))
5630 : !!! osoc_bks = zero
5631 : !!!
5632 : !!! do spin=1,wfd%nsppol
5633 : !!! do ik_ibz=1,wfd%nkibz
5634 : !!! if (all(bks_distrb(:, ik_ibz, spin) /= wfd%my_rank)) cycle
5635 : !!!
5636 : !!! kpoint = wfd%kibz(:, ik_ibz)
5637 : !!! npw_k = wfd%Kdata(ik_ibz)%npw; istwf_k = wfd%istwfk(ik_ibz)
5638 : !!! ABI_CHECK(istwf_k == 1, "istwf_k must be 1 if SOC term is computed with perturbation theory.")
5639 : !!! kg_k => wfd%kdata(ik_ibz)%kg_k
5640 : !!! ffnl_k => wfd%Kdata(ik_ibz)%fnl_dir0der0
5641 : !!! ph3d_k => wfd%Kdata(ik_ibz)%ph3d
5642 : !!!
5643 : !!! ABI_MALLOC(vectin, (2, npw_k * nspinor2))
5644 : !!! ABI_MALLOC(vnl_psi, (2, npw_k * nspinor2))
5645 : !!! !ABI_MALLOC(cvnl_psi, (npw_k * nspinor2))
5646 : !!! !ABI_MALLOC(s_psi, (2, npw_k * nspinor2 * psps%usepaw))
5647 : !!!
5648 : !!! ! Compute (k+G) vectors (only if psps%useylm=1)
5649 : !!! nkpg = 3 * wfd%nloalg(3)
5650 : !!! ABI_MALLOC(kpg_k, (npw_k, nkpg))
5651 : !!! if (nkpg > 0) then
5652 : !!! call mkkpg(kg_k, kpg_k, kpoint, nkpg, npw_k)
5653 : !!! end if
5654 : !!!
5655 : !!! ! Load k-dependent part in the Hamiltonian datastructure
5656 : !!! !matblk = min(NLO_MINCAT, maxval(ham_k%nattyp)); if (wfd%nloalg(2) > 0) matblk = natom
5657 : !!! !ABI_MALLOC(ph3d_k,(2, npw_k, matblk))
5658 : !!! call load_k_hamiltonian(ham_k, kpt_k=kpoint, npw_k=npw_k, istwf_k=istwf_k, kg_k=kg_k, &
5659 : !!! kpg_k=kpg_k, ffnl_k=ffnl_k, ph3d_k=ph3d_k, compute_ph3d=(wfd%paral_kgb/=1))
5660 : !!!
5661 : !!! ! THIS PART IS NEEDED FOR THE CALL TO opernl although some quantities won't be used.
5662 : !!! ! Now I do things cleanly then we try to pass zero-sized arrays!
5663 : !!! !ABI_MALLOC(ylm_k, (npw_k, psps%mpsang**2 * psps%useylm))
5664 : !!! !if (psps%useylm == 1) then
5665 : !!! ! kptns_(:,1) = k4intp; optder = 0; mkmem_ = 1
5666 : !!! ! ABI_MALLOC(dum_ylm_gr_k,(npw_k,3+6*(optder/2),psps%mpsang**2))
5667 : !!! ! ! Here mband is not used if paral_compil_kpt=0
5668 : !!! ! call initylmg(cryst%gprimd, kg_k, kptns_, mkmem_, wfd%MPI_enreg, psps%mpsang, npw_k, [1], 1,&
5669 : !!! ! [npw_k], 1, optder, cryst%rprimd, ylm_k, dum_ylm_gr_k)
5670 : !!! ! ABI_FREE(dum_ylm_gr_k)
5671 : !!! !end if
5672 : !!!
5673 : !!! ! ========================================================
5674 : !!! ! ==== Compute nonlocal form factors ffnl at all (k+G) ====
5675 : !!! ! ========================================================
5676 : !!! !dimffnl = 1 + ider0 ! Derivatives are not needed.
5677 : !!! !ABI_MALLOC(ffnl_k, (npw_k, dimffnl, psps%lmnmax, psps%ntypat))
5678 : !!! !! ffnl_k => Kdata%fnl_dir0der0
5679 : !!! !call mkffnl(psps%dimekb, dimffnl, psps%ekb, ffnl_k, psps%ffspl, cryst%gmet, cryst%gprimd, ider0, idir0, psps%indlmn,&
5680 : !!! ! kg_k, kpg_k, k4intp, psps%lmnmax, psps%lnmax, psps%mpsang, psps%mqgrid_ff, nkpg, npw_k, &
5681 : !!! ! psps%ntypat, psps%pspso, psps%qgrid_ff, cryst%rmet, psps%usepaw, psps%useylm, ylm_k, ylmgr_dum)
5682 : !!! !ABI_FREE(ylm_k)
5683 : !!!
5684 : !!! ! Calculate <G|Vnl|psi> for this k-point
5685 : !!! do band=1,wfd%nband(ik_ibz, spin)
5686 : !!! if (bks_distrb(band, ik_ibz, spin) /= wfd%my_rank) cycle
5687 : !!!
5688 : !!! ! Input wavefunction coefficients <G|Cnk>.
5689 : !!! ! vectin, (2, npw_k * nspinor2))
5690 : !!! if (spin == 1) then
5691 : !!! vectin(1, 1:npw_k) = dble(wfd%wave(band, ik_ibz, spin)%ug)
5692 : !!! vectin(2, 1:npw_k) = aimag(wfd%wave(band, ik_ibz, spin)%ug)
5693 : !!! vectin(:, npw_k+1:) = zero
5694 : !!! else
5695 : !!! vectin(:, 1:npw_k) = zero
5696 : !!! vectin(1, npw_k+1:) = dble(wfd%wave(band, ik_ibz, spin)%ug)
5697 : !!! vectin(2, npw_k+1:) = aimag(wfd%wave(band, ik_ibz, spin)%ug)
5698 : !!! end if
5699 : !!!
5700 : !!! if (wfd%usepaw == 1) call wfd%get_cprj(band, ik_ibz, spin, cryst, cprj, sorted=.True.)
5701 : !!!
5702 : !!! ! TODO: consistency check for only_SO
5703 : !!! call nonlop(choice, cpopt, cprj, dum_enlout, ham_k, idir0, dummy_lambda, wfd%mpi_enreg, ndat1, nnlout0, &
5704 : !!! paw_opt, signs, opaw_psi, tim_nonlop0, vectin, vnl_psi, only_SO=1)
5705 : !!!
5706 : !!! soc = cg_zdotc(npw_k * nspinor2, vectin, vnl_psi)
5707 : !!! write(std_out,*)soc * Ha_eV, "for (b, k, s)",band, ik_ibz, spin
5708 : !!! osoc_bks(band, ik_ibz, spin) = soc(1)
5709 : !!! end do ! band
5710 : !!!
5711 : !!! !ABI_FREE(ffnl_k)
5712 : !!! !ABI_FREE(ph3d_k)
5713 : !!! ABI_FREE(vectin)
5714 : !!! ABI_FREE(vnl_psi)
5715 : !!! ABI_FREE(kpg_k)
5716 : !!! !ABI_FREE(cvnl_psi)
5717 : !!! !ABI_FREE(s_psi)
5718 : !!! end do ! ik_ibz
5719 : !!! end do ! spin
5720 : !!!
5721 : !!! call xmpi_sum(osoc_bks, wfd%comm, ierr)
5722 : !!!
5723 : !!! call destroy_hamiltonian(ham_k)
5724 : !!!
5725 : !!! if (wfd%usepaw == 1) then
5726 : !!! call pawcprj_free(cprj)
5727 : !!! ABI_FREE(cprj)
5728 : !!! end if
5729 : !!!
5730 : !!! end subroutine wfd_get_socpert
5731 : !!***
5732 :
5733 : !!****f* m_wfd/wfdgw_mkrho
5734 : !! NAME
5735 : !! wfdgw_mkrho
5736 : !!
5737 : !! FUNCTION
5738 : !! Calculate the charge density on the fine FFT grid in real space.
5739 : !!
5740 : !! INPUTS
5741 : !! Wfd<wfd_t)=datatype gathering info on the wavefunctions.
5742 : !! ngfftf(18)=array containing all the information for the "fine" FFT.
5743 : !! Cryst<crystal_t> Info on the crystalline structure
5744 : !! optcalc=option for calculation. If =0 (default value) perform calculation
5745 : !! of electronic density. If =1, perform calculation of kinetic energy density.
5746 : !! In both cases, the result is returned in rhor.
5747 : !! Psps<type(pseudopotential_type)>=variables related to pseudopotentials
5748 : !! nfftf=Total number of points on the fine FFT grid (for this processor)
5749 : !! [optcalc]=Optional option used to calculate the kinetic energy density. Defaults to 0.
5750 : !!
5751 : !! OUTPUT
5752 : !! rhor(nfftf,nspden)=The density in the real space on the fine FFT grid.
5753 : !! If nsppol==2, total charge in first half, spin-up component in second half.
5754 : !! (for non-collinear magnetism, first element: total density, 3 next ones: mx,my,mz in units of hbar/2)
5755 : !! If optcalc==1 (optional argument, default value is 0), then rhor will actually
5756 : !! contains kinetic energy density (taur) instead of electronic density.
5757 : !!
5758 : !! NOTES
5759 : !! In the case of PAW calculations:
5760 : !! All computations are done on the fine FFT grid.
5761 : !! All variables (nfftf,ngfftf,mgfftf) refer to this fine FFT grid.
5762 : !! All arrays (densities/potentials...) are computed on this fine FFT grid.
5763 : !! Developers have to be careful when introducing others arrays:
5764 : !! they have to be stored on the fine FFT grid.
5765 : !! In the case of norm-conserving calculations:
5766 : !! The mesh is the usual augmented FFT grid to treat correctly the convolution.
5767 : !!
5768 : !! SOURCE
5769 :
5770 459 : subroutine wfdgw_mkrho(wfd, cryst, psps, ebands, ngfftf, nfftf, rhor, &
5771 : optcalc) ! optional arguments
5772 :
5773 : !Arguments ------------------------------------
5774 : !scalars
5775 : integer,intent(in) :: nfftf
5776 : integer,intent(in),optional :: optcalc
5777 : type(ebands_t),intent(in) :: ebands
5778 : type(crystal_t),intent(in) :: cryst
5779 : type(Pseudopotential_type),intent(in) :: psps
5780 : class(wfdgw_t),intent(inout) :: wfd
5781 : !arrays
5782 : integer,intent(in) :: ngfftf(18)
5783 : real(dp),intent(out) :: rhor(nfftf, Wfd%nspden)
5784 :
5785 : !Local variables ------------------------------
5786 : !scalars
5787 : integer,parameter :: ndat1=1
5788 : integer :: cplex,ib,ib_iter,ierr,ik,ir,is,n1,n2,n3,nfftotf
5789 : integer :: alpha,nalpha,ipw,myoptcalc
5790 : real(dp) :: kpt_cart,kg_k_cart,gp2pi1,gp2pi2,gp2pi3,cwftmp,bks_weight
5791 : character(len=500) :: msg
5792 : type(wave_t),pointer :: wave
5793 : !arrays
5794 459 : integer,allocatable :: irrzon(:,:,:)
5795 459 : real(dp),allocatable :: phnons(:,:,:),rhog(:,:),rhor_down(:),rhor_mx(:),rhor_my(:),cwavef(:,:)
5796 459 : complex(dp),allocatable :: wfr_x(:),wfr_y(:)
5797 459 : complex(gwp),allocatable :: gradug(:),work(:)
5798 459 : complex(gwp),allocatable,target :: wfr(:)
5799 459 : complex(gwp), contiguous, pointer :: cwavef1(:),cwavef2(:)
5800 459 : type(iter2_t) :: Iter_bks
5801 : !*************************************************************************
5802 :
5803 : ! Consistency check.
5804 0 : ABI_CHECK(Wfd%nsppol == ebands%nsppol, "Mismatch in nsppol")
5805 :
5806 888 : if (ANY(ngfftf(1:3) /= Wfd%ngfft(1:3))) call wfd%change_ngfft(Cryst,Psps,ngfftf)
5807 :
5808 : ! Calculate IBZ contribution to the charge density.
5809 1377 : ABI_MALLOC(wfr, (nfftf*Wfd%nspinor))
5810 :
5811 459 : if (wfd%nspden == 4) then
5812 18 : ABI_MALLOC(wfr_x, (nfftf))
5813 12 : ABI_MALLOC(wfr_y, (nfftf))
5814 18 : ABI_MALLOC(rhor_down, (nfftf))
5815 12 : ABI_MALLOC(rhor_mx, (nfftf))
5816 12 : ABI_MALLOC(rhor_my, (nfftf))
5817 144006 : rhor_down = zero; rhor_mx = zero; rhor_my = zero
5818 : end if
5819 :
5820 : ! Update the (b,k,s) distribution table.
5821 459 : call wfd%update_bkstab()
5822 :
5823 : ! Calculate the unsymmetrized density.
5824 8194854 : rhor=zero
5825 459 : myoptcalc=0; if (present(optcalc)) myoptcalc=optcalc
5826 459 : nalpha=1; if (myoptcalc==1) nalpha=3
5827 459 : if (myoptcalc == 1 .and. wfd%nspinor == 2) then
5828 0 : ABI_ERROR("kinetic energy density with nspinor == 2 not implemented")
5829 : end if
5830 :
5831 : ! Build the iterator that will distribute the states in an automated way.
5832 67329 : Iter_bks = wfd%iterator_bks(bks_mask=ABS(ebands%occ)>=tol8)
5833 :
5834 918 : do alpha=1,nalpha
5835 1386 : do is=1,Wfd%nsppol
5836 4402 : do ik=1,Wfd%nkibz
5837 16380 : do ib_iter=1,iter_len(Iter_bks,ik,is)
5838 12437 : ib = iter_yield(Iter_bks,ib_iter,ik,is)
5839 12437 : bks_weight = ebands%occ(ib,ik,is) * ebands%wtk(ik) / Cryst%ucvol
5840 :
5841 12437 : call wfd%get_ur(ib,ik,is,wfr)
5842 :
5843 12437 : cwavef1 => wfr(1:nfftf)
5844 12437 : if (myoptcalc == 1) then
5845 0 : ABI_MALLOC(gradug,(Wfd%Kdata(ik)%npw))
5846 0 : ABI_MALLOC(cwavef,(2,Wfd%Kdata(ik)%npw))
5847 0 : ABI_MALLOC(work,(nfftf))
5848 :
5849 0 : ABI_CHECK(wfd%get_wave_ptr(ib, ik, is, wave, msg) == 0, msg)
5850 0 : cwavef(1,:)= REAL(wave%ug(:))
5851 0 : cwavef(2,:)=AIMAG(wave%ug(:))
5852 :
5853 : ! Multiplication by 2pi i (k+G)_alpha
5854 0 : gp2pi1=Cryst%gprimd(alpha,1)*two_pi
5855 0 : gp2pi2=Cryst%gprimd(alpha,2)*two_pi
5856 0 : gp2pi3=Cryst%gprimd(alpha,3)*two_pi
5857 0 : kpt_cart=gp2pi1*Wfd%kibz(1,ik)+gp2pi2*Wfd%kibz(2,ik)+gp2pi3*Wfd%kibz(3,ik)
5858 0 : do ipw=1,Wfd%Kdata(ik)%npw
5859 : kg_k_cart= gp2pi1*Wfd%Kdata(ik)%kg_k(1,ipw) + &
5860 : gp2pi2*Wfd%Kdata(ik)%kg_k(2,ipw) + &
5861 0 : gp2pi3*Wfd%Kdata(ik)%kg_k(3,ipw)+kpt_cart
5862 : !ipwsp=ipw!+(ispinor-1)*Wfd%Kdata(ik)%npw
5863 0 : cwftmp=-cwavef(2,ipw)*kg_k_cart
5864 0 : cwavef(2,ipw)=cwavef(1,ipw)*kg_k_cart
5865 0 : cwavef(1,ipw)=cwftmp
5866 : end do
5867 0 : gradug(:)=CMPLX(cwavef(1,:),cwavef(2,:),gwp)
5868 : call fft_ug(Wfd%npwarr(ik),nfftf,Wfd%nspinor,ndat1,Wfd%mgfft,Wfd%ngfft,&
5869 0 : Wfd%istwfk(ik),Wfd%Kdata(ik)%kg_k,Wfd%Kdata(ik)%gbound,gradug,work)
5870 0 : cwavef1(:)=work(:)
5871 0 : ABI_FREE(work)
5872 0 : ABI_FREE(cwavef)
5873 0 : ABI_FREE(gradug)
5874 : end if
5875 :
5876 : !$OMP PARALLEL DO
5877 117544637 : do ir=1,nfftf
5878 117544637 : rhor(ir,is) = rhor(ir,is) + CONJG(cwavef1(ir)) * cwavef1(ir) * bks_weight
5879 : end do
5880 : !call cplx_addtorho(n1,n2,n3,n4,n5,n6,ndat,weight_r,ur,rho)
5881 :
5882 12437 : if (wfd%nspinor == 2 .and. wfd%nspden == 1) then
5883 112 : cwavef2 => wfr(1+nfftf:2*nfftf)
5884 1175664 : do ir=1,nfftf
5885 1175664 : rhor(ir, 1) = rhor(ir, 1) + CONJG(cwavef2(ir)) * cwavef2(ir) * bks_weight
5886 : end do
5887 : end if
5888 :
5889 15912 : if (wfd%nspinor == 2 .and. wfd%nspden == 4) then
5890 184 : cwavef2 => wfr(1+nfftf:2*nfftf)
5891 1472184 : wfr_x(:) = cwavef1(:) + cwavef2(:) ! $(\Psi^{1}+\Psi^{2})$
5892 1472184 : wfr_y(:) = cwavef1(:) -j_dpc*cwavef2(:) ! $(\Psi^{1}-i\Psi^{2})$
5893 : !$OMP PARALLEL DO
5894 1472184 : do ir=1,nfftf
5895 1472000 : rhor_down(ir) = rhor_down(ir) + CONJG(cwavef2(ir)) * cwavef2(ir) * bks_weight
5896 1472000 : rhor_mx(ir) = rhor_mx(ir) + CONJG(wfr_x(ir)) * wfr_x(ir) * bks_weight
5897 1472184 : rhor_my(ir) = rhor_my(ir) + CONJG(wfr_y(ir)) * wfr_y(ir) * bks_weight
5898 : end do
5899 : end if
5900 :
5901 : end do
5902 : end do
5903 : end do
5904 :
5905 : end do ! enddo alpha
5906 :
5907 459 : call iter_free(Iter_bks)
5908 :
5909 459 : select case (myoptcalc)
5910 : case (0)
5911 : ! density
5912 459 : if (wfd%nspden == 4) then
5913 48006 : rhor(:, 2) = rhor_mx
5914 48006 : rhor(:, 3) = rhor_my
5915 48006 : rhor(:, 4) = rhor_down
5916 : end if
5917 : case (1)
5918 : ! convention for taur = 1/2 Sum_i |grad phi_i|^2
5919 0 : rhor(:,:)=half*rhor(:,:)
5920 :
5921 : case default
5922 459 : ABI_ERROR(sjoin("Wrong myoptcalc:", itoa(myoptcalc)))
5923 : end select
5924 :
5925 459 : call xmpi_sum(rhor,Wfd%comm,ierr)
5926 :
5927 : ! Symmetrization in G-space implementing also the AFM case
5928 459 : n1=ngfftf(1); n2=ngfftf(2); n3=ngfftf(3); nfftotf=n1*n2*n3
5929 :
5930 1836 : ABI_MALLOC(irrzon,(nfftotf**(1-1/Cryst%nsym),2,(Wfd%nspden/Wfd%nsppol)-3*(Wfd%nspden/4)))
5931 1836 : ABI_MALLOC(phnons,(2,nfftotf,(Wfd%nspden/Wfd%nsppol)-3*(Wfd%nspden/4)))
5932 :
5933 459 : if (Cryst%nsym/=1) then
5934 459 : call irrzg(irrzon,Wfd%nspden,Wfd%nsppol,Cryst%nsym,n1,n2,n3,phnons,Cryst%symafm,Cryst%symrel,Cryst%tnons)
5935 : end if
5936 :
5937 : ! Symmetrize rho(r), and pack nspden components following abinit conventions.
5938 459 : cplex=1
5939 1377 : ABI_MALLOC(rhog,(2,cplex*nfftf))
5940 :
5941 : call symrhg(cplex,Cryst%gprimd,irrzon,Wfd%MPI_enreg,nfftf,nfftotf,ngfftf,Wfd%nspden,Wfd%nsppol,&
5942 459 : Cryst%nsym,phnons,rhog,rhor,Cryst%rprimd,Cryst%symafm,Cryst%symrel,Cryst%tnons)
5943 :
5944 459 : ABI_FREE(rhog)
5945 459 : ABI_FREE(phnons)
5946 459 : ABI_FREE(irrzon)
5947 :
5948 : ! Find and print minimum and maximum total electron density
5949 : ! (or total kinetic energy density, or total element of kinetic energy density tensor) and locations
5950 : !call wrtout(std_out,'mkrho: echo density (plane-wave part only)','COLL')
5951 : !call prtrhomxmn(std_out,wfd%mpi_enreg,nfftf,ngfftf,wfd%nspden,1,rhor,optrhor=optcalc,ucvol=crystl%ucvol)
5952 :
5953 7726606 : write(msg,'(a,f9.4)')' planewave contribution to nelect: ',SUM(rhor(:,1))*Cryst%ucvol/nfftf
5954 459 : call wrtout(std_out, msg)
5955 :
5956 459 : if (Wfd%nspden==4) then
5957 : write(msg,'(a,3f9.4)')&
5958 144006 : ' mx, my, mz: ',SUM(rhor(:,2))*Cryst%ucvol/nfftf,SUM(rhor(:,3))*Cryst%ucvol/nfftf,SUM(rhor(:,4))*Cryst%ucvol/nfftf
5959 6 : call wrtout(std_out, msg)
5960 : end if
5961 :
5962 459 : ABI_FREE(wfr)
5963 :
5964 459 : if (Wfd%nspden == 4) then
5965 6 : ABI_FREE(wfr_x)
5966 6 : ABI_FREE(wfr_y)
5967 6 : ABI_FREE(rhor_down)
5968 6 : ABI_FREE(rhor_mx)
5969 6 : ABI_FREE(rhor_my)
5970 : end if
5971 :
5972 918 : end subroutine wfdgw_mkrho
5973 : !!***
5974 :
5975 : !----------------------------------------------------------------------
5976 :
5977 : !!****f* m_wfd/test_charge
5978 : !! NAME
5979 : !! test_charge
5980 : !!
5981 : !! FUNCTION
5982 : !! Reports info on the electronic charge as well as Drude plasma frequency.
5983 : !! Mainly used in the GW part.
5984 : !!
5985 : !! INPUTS
5986 : !! nelectron_exp=Expected total number of electrons (used to normalize the charge)
5987 : !!
5988 : !! OUTPUT
5989 : !!
5990 : !! SOURCE
5991 :
5992 454 : subroutine test_charge(nfftf,nelectron_exp,nspden,rhor,ucvol,&
5993 : usepaw,usexcnhat,usefinegrid,compch_sph,compch_fft,omegaplasma)
5994 :
5995 : !Arguments ------------------------------------
5996 : !scalars
5997 : integer,intent(in) :: nfftf,nspden,usefinegrid,usepaw,usexcnhat
5998 : real(dp),intent(in) :: compch_fft,compch_sph,ucvol,nelectron_exp
5999 : real(dp),intent(out) :: omegaplasma
6000 : !arrays
6001 : real(dp),intent(inout) :: rhor(nfftf,nspden)
6002 :
6003 : !Local variables ------------------------------
6004 : !scalars
6005 : real(dp) :: nelectron_tot,nelectron_fft
6006 : real(dp) :: nelectron_pw,nelectron_sph,rhoav,rs,nratio
6007 : character(len=500) :: msg
6008 : !*************************************************************************
6009 :
6010 : ! ABI_UNUSED(usexcnhat)
6011 : if (usexcnhat==0)then
6012 : end if
6013 :
6014 : ! === For PAW output of compensation charges ===
6015 454 : if (usepaw==1) then
6016 : !if (usepaw==1.and.usexcnhat>0) then ! TODO I still dont understand this if!
6017 12 : write(msg,'(4a)')ch10,' PAW TEST:',ch10,' ==== Compensation charge inside spheres ============'
6018 12 : if (compch_sph<greatest_real.and.compch_fft<greatest_real) &
6019 12 : write(msg,'(3a)')TRIM(msg),ch10,' The following values must be close...'
6020 12 : if (compch_sph<greatest_real) &
6021 12 : write(msg,'(3a,f22.15)')TRIM(msg),ch10,' Compensation charge over spherical meshes = ',compch_sph
6022 12 : if (compch_fft<greatest_real) then
6023 12 : if (usefinegrid==1) then
6024 6 : write(msg,'(3a,f22.15)')TRIM(msg),ch10,' Compensation charge over fine fft grid = ',compch_fft
6025 : else
6026 6 : write(msg,'(3a,f22.15)')TRIM(msg),ch10,' Compensation charge over fft grid = ',compch_fft
6027 : end if
6028 : end if
6029 36 : call wrtout([std_out, ab_out], msg)
6030 12 : write(msg,'(a)')ch10
6031 36 : call wrtout([std_out, ab_out], msg)
6032 : end if !PAW
6033 :
6034 7707601 : nelectron_pw =SUM(rhor(:,1))*ucvol/nfftf
6035 454 : nelectron_tot=nelectron_pw
6036 454 : nratio =nelectron_exp/nelectron_tot
6037 :
6038 454 : if (usepaw==1) then
6039 12 : nelectron_sph=nelectron_pw+compch_sph
6040 12 : nelectron_fft=nelectron_pw+compch_fft
6041 12 : nelectron_tot=nelectron_sph
6042 12 : nratio=(nelectron_exp-nelectron_sph)/nelectron_pw
6043 : end if
6044 :
6045 454 : rhoav=nelectron_tot/ucvol ; rs=(three/(four_pi*rhoav))**third
6046 454 : if (usepaw==0) then
6047 : write(msg,'(2(a,f9.4))')&
6048 442 : ' Number of electrons calculated from density = ',nelectron_tot,'; Expected = ',nelectron_exp
6049 : else
6050 : write(msg,'(2(a,f9.4),a)')&
6051 12 : ' Total number of electrons per unit cell = ',nelectron_sph,' (Spherical mesh), ',nelectron_fft,' (FFT mesh)'
6052 : end if
6053 1362 : call wrtout([std_out, ab_out], msg)
6054 :
6055 : !write(msg,'(a,f9.4)')' Renormalizing smooth charge density using nratio = ',nratio
6056 : !rhor(:,:)=nratio*rhor(:,:)
6057 :
6058 454 : write(msg,'(a,f9.6)')' average of density, n = ',rhoav
6059 1362 : call wrtout([std_out, ab_out], msg)
6060 454 : write(msg,'(a,f9.4)')' r_s = ',rs
6061 1362 : call wrtout([std_out, ab_out], msg)
6062 454 : omegaplasma=SQRT(four_pi*rhoav)
6063 454 : write(msg,'(a,f9.4,2a)')' omega_plasma = ',omegaplasma*Ha_eV,' [eV]',ch10
6064 1362 : call wrtout([std_out, ab_out], msg)
6065 :
6066 454 : end subroutine test_charge
6067 : !!***
6068 :
6069 : !!****f* m_wfd/wfdgw_pawrhoij
6070 : !! NAME
6071 : !! wfdgw_pawrhoij
6072 : !!
6073 : !! FUNCTION
6074 : !! Calculate the PAW quantities rhoij (augmentation occupancies)
6075 : !! Remember:for each atom, rho_ij=Sum_{n,k} {occ(n,k)*<Cnk|p_i><p_j|Cnk>}
6076 : !!
6077 : !! INPUTS
6078 : !! atindx1(natom)=index table for atoms, inverse of atindx
6079 : !! cprj(natom,nspinor*mband*mkmem*nsppol)= wave functions projected with non-local projectors:
6080 : !! cprj_nk(i)=<p_i|Cnk> where p_i is a non-local projector.
6081 : !! istwfk(nkpt)=parameter that describes the storage of wfs
6082 : !! kptopt=option for the generation of k points
6083 : !! mband=maximum number of bands
6084 : !! natom=number of atoms in cell
6085 : !! nkpt=number of k points
6086 : !! nspinor=number of spinorial components of the wavefunctions
6087 : !! nsppol=1 for unpolarized, 2 for spin-polarized
6088 : !! occ(mband*nkpt*nsppol)=occupation number for each band for each k
6089 : !! pawprtvol=control print volume and debugging output for PAW
6090 : !!
6091 : !! SIDE EFFECTS
6092 : !! pawrhoij(natom) <type(pawrhoij_type)>= paw rhoij occupancies and related data
6093 : !! On input: arrays dimensions
6094 : !! On output:
6095 : !! pawrhoij(:)%rhoij_(lmn2_size,nspden)=
6096 : !! Sum_{n,k} {occ(n,k)*conjugate[cprj_nk(ii)].cprj_nk(jj)} (non symetrized)
6097 : !!
6098 : !! SOURCE
6099 :
6100 0 : subroutine wfdgw_pawrhoij(Wfd,Cryst,Bst,kptopt,pawrhoij,pawprtvol)
6101 :
6102 : !Arguments ---------------------------------------------
6103 : !scalars
6104 : integer,intent(in) :: kptopt,pawprtvol
6105 : type(crystal_t),intent(in) :: Cryst
6106 : class(wfdgw_t),intent(inout) :: Wfd
6107 : type(ebands_t),intent(in) :: Bst
6108 : !arrays
6109 : type(pawrhoij_type),intent(inout) :: pawrhoij(Wfd%natom)
6110 :
6111 : !Local variables ---------------------------------------
6112 : !scalars
6113 : integer :: cplex,cplex_rhoij,qphase,iatom,band,ik_ibz
6114 : integer :: spin,natinc,nband_k,option,lmn2_size,nspden
6115 : logical :: use_timerev,use_zeromag
6116 : real(dp) :: occup,wtk_k
6117 : character(len=500) :: msg
6118 : !arrays
6119 : !real(dp) :: tsec(2)
6120 : character(len=8),parameter :: dspin(6)=(/"up ","down ","dens (n)","magn (x)","magn (y)","magn (z)"/)
6121 : type(pawcprj_type),allocatable :: cwaveprj(:,:)
6122 0 : integer :: bks_distrb(Wfd%mband,Wfd%nkibz,Wfd%nsppol)
6123 0 : integer :: got(Wfd%nproc)
6124 0 : logical :: bks_mask(Wfd%mband,Wfd%nkibz,Wfd%nsppol)
6125 : !************************************************************************
6126 :
6127 : ! Allocate temporary cwaveprj storage (sorted by atom type)
6128 0 : ABI_MALLOC(cwaveprj,(Wfd%natom,Wfd%nspinor))
6129 0 : call pawcprj_alloc(cwaveprj,0,Wfd%nlmn_sort)
6130 :
6131 : ! Initialize output quantities if not already done.
6132 0 : do iatom=1,Wfd%natom
6133 0 : if (pawrhoij(iatom)%use_rhoij_==0) then
6134 0 : cplex_rhoij= pawrhoij(iatom)%cplex_rhoij
6135 0 : qphase = pawrhoij(iatom)%qphase
6136 0 : lmn2_size = pawrhoij(iatom)%lmn2_size
6137 0 : nspden = pawrhoij(iatom)%nspden
6138 0 : ABI_MALLOC(pawrhoij(iatom)%rhoij_,(cplex_rhoij*qphase*lmn2_size,nspden))
6139 0 : pawrhoij(iatom)%use_rhoij_=1
6140 : end if
6141 0 : pawrhoij(iatom)%rhoij_=zero
6142 : end do
6143 :
6144 0 : option=1
6145 0 : use_timerev=(kptopt>0.and.kptopt<3)
6146 0 : use_zeromag=.false. ; if (Wfd%natom>0) use_zeromag=(pawrhoij(1)%nspden==4.and.Wfd%nspden==1)
6147 :
6148 : ! Distribute (b,k,s).
6149 0 : where (ABS(Bst%occ)>tol8)
6150 : bks_mask=.TRUE.
6151 : else where
6152 : bks_mask=.FALSE.
6153 : end where
6154 0 : got = 0
6155 :
6156 0 : call wfd%bks_distrb(bks_distrb,got,bks_mask)
6157 :
6158 0 : do spin=1,Wfd%nsppol
6159 0 : do ik_ibz=1,Wfd%nkibz
6160 :
6161 0 : nband_k=Wfd%nband(ik_ibz,spin)
6162 0 : wtk_k=Bst%wtk(ik_ibz)
6163 :
6164 0 : cplex=2; if (Wfd%istwfk(ik_ibz)>1) cplex=1
6165 :
6166 0 : do band=1,nband_k
6167 :
6168 0 : if (bks_distrb(band,ik_ibz,spin) == Wfd%my_rank) then
6169 : !locc_test = (abs(Bst%occ(band,ik_ibz,spin))>tol8)
6170 0 : occup = Bst%occ(band,ik_ibz,spin)
6171 :
6172 : ! Extract cprj for current band cwaveprj are sorted by atom type.
6173 0 : call wfd%get_cprj(band,ik_ibz,spin,Cryst,cwaveprj,sorted=.TRUE.)
6174 :
6175 : ! Accumulate contribution from (occupied) current band
6176 : !if (locc_test) then
6177 : call pawaccrhoij(Cryst%atindx,cplex,cwaveprj,cwaveprj ,0,spin,Wfd%natom,Wfd%natom,&
6178 0 : Wfd%nspinor,occup,option,pawrhoij,use_timerev,use_zeromag,wtk_k)
6179 : !end if
6180 : end if
6181 : end do !band
6182 :
6183 : end do !ik_ibz
6184 : end do !spin
6185 :
6186 : ! Free temporary cwaveprj storage.
6187 0 : call pawcprj_free(cwaveprj)
6188 0 : ABI_FREE(cwaveprj)
6189 :
6190 : !==========================================
6191 : ! MPI: need to exchange arrays between procs
6192 : ! TODO it should be tested.
6193 0 : call pawrhoij_mpisum_unpacked(pawrhoij,Wfd%comm)
6194 :
6195 : ! Print info.
6196 0 : if (abs(pawprtvol)>=1) then
6197 0 : natinc=1; if(Wfd%natom>1.and.pawprtvol>=0) natinc=Wfd%natom-1
6198 0 : write(msg, '(7a)') ch10," PAW TEST:",ch10,' ========= Values of RHOIJ in wfdgw_pawrhoij =========',ch10
6199 0 : call wrtout(std_out, msg)
6200 0 : do iatom=1,Cryst%natom,natinc
6201 : call pawrhoij_print_rhoij(pawrhoij(iatom)%rhoij_,pawrhoij(iatom)%cplex_rhoij,&
6202 0 : pawrhoij(iatom)%qphase,iatom,Cryst%natom, unit=std_out,opt_prtvol=pawprtvol)
6203 : end do
6204 : end if
6205 :
6206 0 : end subroutine wfdgw_pawrhoij
6207 : !!***
6208 :
6209 4 : subroutine u0_cache_init(u0c, use_cache, ngfft)
6210 :
6211 : !Arguments ------------------------------------
6212 : class(u0_cache_t),intent(out) :: u0c
6213 : logical,intent(in) :: use_cache
6214 : integer,intent(in) :: ngfft(18)
6215 : !************************************************************************
6216 :
6217 4 : u0c%use_cache = use_cache
6218 76 : u0c%ngfft = ngfft
6219 :
6220 4 : end subroutine u0_cache_init
6221 :
6222 127 : subroutine u0_cache_store_kpt(u0c, kpt, istwf_k, npw_k, nspinor, nband_k, kg_k, cg_k)
6223 :
6224 : !Arguments ------------------------------------
6225 : class(u0_cache_t),intent(inout) :: u0c
6226 : real(dp),intent(in) :: kpt(3)
6227 : integer,intent(in) :: istwf_k, npw_k, nspinor, nband_k, kg_k(3,npw_k)
6228 : real(dp),intent(in) :: cg_k(2, npw_k*nspinor, nband_k)
6229 : !************************************************************************
6230 :
6231 127 : if (.not. u0c%use_cache) return
6232 :
6233 84 : call u0c%free()
6234 84 : u0c%prev_npw_k = npw_k
6235 84 : u0c%prev_nband_k = nband_k
6236 84 : u0c%prev_istwf_k = istwf_k
6237 336 : u0c%prev_kpt = kpt
6238 :
6239 84 : call alloc_copy(kg_k, u0c%prev_kg_k)
6240 84 : call alloc_copy(cg_k, u0c%prev_cg_k)
6241 :
6242 : end subroutine u0_cache_store_kpt
6243 :
6244 82 : subroutine u0_cache_get_kpt(u0c, new_kpt, new_istwf_k, new_npw_k, nspinor, new_nband_k, new_kg_k, new_cg_k)
6245 :
6246 : !Arguments ------------------------------------
6247 : class(u0_cache_t),intent(inout) :: u0c
6248 : real(dp),intent(in) :: new_kpt(3)
6249 : integer,intent(in) :: new_istwf_k, new_npw_k, nspinor, new_nband_k, new_kg_k(3,new_npw_k)
6250 : real(dp),intent(out) :: new_cg_k(2, new_npw_k*nspinor, new_nband_k)
6251 :
6252 : !Local variables ------------------------------
6253 : integer :: mg1, mg2, mg3, work_ngfft(18)
6254 82 : real(dp),allocatable :: work(:,:,:,:)
6255 : !************************************************************************
6256 :
6257 82 : if (.not. u0c%use_cache) return
6258 :
6259 82 : ABI_CHECK_IEQ(new_nband_k, u0c%prev_nband_k, "This case is not yet implemented")
6260 :
6261 96 : if (all(abs(new_kpt - u0c%prev_kpt) < tol16) .and. new_npw_k == u0c%prev_npw_k) then
6262 0 : new_cg_k = u0c%prev_cg_k
6263 : return
6264 : end if
6265 :
6266 210746 : mg1 = max(maxval(abs(u0c%prev_kg_k(1,:))), maxval(abs(new_kg_k(1,:))))
6267 210746 : mg2 = max(maxval(abs(u0c%prev_kg_k(2,:))), maxval(abs(new_kg_k(2,:))))
6268 210746 : mg3 = max(maxval(abs(u0c%prev_kg_k(3,:))), maxval(abs(new_kg_k(3,:))))
6269 :
6270 82 : mg1 = 2*mg1 + 1
6271 82 : mg2 = 2*mg2 + 1
6272 82 : mg3 = 2*mg3 + 1
6273 :
6274 328 : call ngfft_seq(work_ngfft, [mg1, mg2, mg3])
6275 410 : ABI_MALLOC(work, (2, work_ngfft(4),work_ngfft(5),work_ngfft(6)))
6276 :
6277 : call cgtk_change_gsphere(nspinor*new_nband_k, u0c%prev_npw_k, u0c%prev_istwf_k, u0c%prev_kg_k, u0c%prev_cg_k, &
6278 82 : new_npw_k, new_istwf_k, new_kg_k, new_cg_k, work_ngfft, work)
6279 :
6280 82 : ABI_FREE(work)
6281 :
6282 : end subroutine u0_cache_get_kpt
6283 :
6284 88 : subroutine u0_cache_free(u0c)
6285 :
6286 : !Arguments ------------------------------------
6287 : class(u0_cache_t),intent(inout) :: u0c
6288 : !************************************************************************
6289 88 : ABI_SFREE(u0c%prev_kg_k)
6290 88 : ABI_SFREE(u0c%prev_cg_k)
6291 88 : end subroutine u0_cache_free
6292 :
6293 579 : subroutine u1_cache_store(u1c, qpt, npw_kq, nspinor, natom3, bstart_ks, nbcalc_ks, kg_kq, cg1s_kq)
6294 :
6295 : !Arguments ------------------------------------
6296 : class(u1_cache_t),intent(inout) :: u1c
6297 : real(dp),intent(in) :: qpt(3)
6298 : integer,intent(in) :: npw_kq, nspinor, natom3, bstart_ks, nbcalc_ks, kg_kq(3,npw_kq)
6299 : real(dp),intent(in) :: cg1s_kq(2, npw_kq*nspinor, natom3, nbcalc_ks)
6300 : !************************************************************************
6301 :
6302 579 : call u1c%free()
6303 2316 : u1c%prev_qpt = qpt
6304 579 : u1c%prev_npw_kq = npw_kq
6305 579 : u1c%prev_bstart_ks = bstart_ks
6306 579 : u1c%prev_nbcalc_ks = nbcalc_ks
6307 579 : call alloc_copy(kg_kq, u1c%prev_kg_kq)
6308 579 : call alloc_copy(cg1s_kq, u1c%prev_cg1s_kq)
6309 579 : end subroutine u1_cache_store
6310 :
6311 14202 : integer function u1_cache_find_band(u1c, band) result(u1c_band)
6312 :
6313 : !Arguments ------------------------------------
6314 : class(u1_cache_t),intent(inout) :: u1c
6315 : integer,intent(in) :: band
6316 : !************************************************************************
6317 :
6318 : ! Make sure we have the proper global band index in the cache as bstart_ks depends on the
6319 : ! k-point in Sigma_{nk}. If not, fill cg1s_kq with zeros and return.
6320 14202 : u1c_band = -1
6321 14202 : if (u1c%prev_nbcalc_ks == -1) return
6322 13704 : u1c_band = band - u1c%prev_bstart_ks + 1
6323 13704 : if (.not. (u1c_band >= 1 .and. u1c_band <= u1c%prev_nbcalc_ks)) u1c_band = -1
6324 : if (u1c_band == -1) then
6325 6 : u1c%miss = u1c%miss + 1
6326 : else
6327 13698 : u1c%hits = u1c%hits + 1
6328 : end if
6329 : end function u1_cache_find_band
6330 :
6331 637 : subroutine u1_cache_free(u1c)
6332 :
6333 : !Arguments ------------------------------------
6334 : class(u1_cache_t),intent(inout) :: u1c
6335 : !************************************************************************
6336 637 : ABI_SFREE(u1c%prev_kg_kq)
6337 637 : ABI_SFREE(u1c%prev_cg1s_kq)
6338 637 : end subroutine u1_cache_free
6339 :
6340 16299 : end module m_wfd
6341 : !!***
|
