Branch data 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 [ + + + - : 9622 : 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 : 9622 : real(dp),allocatable :: ylmgr_k(:,:,:),kpg_k(:,:),ph1d(:,:)
620 : : !************************************************************************
621 : :
622 : : !@kdata_t
623 : 9622 : Kdata%istwfk = istwfk
624 : 9622 : Kdata%useylm = Psps%useylm
625 : :
626 [ + + ]: 9622 : if (present(ecut)) then
627 : : ! Calculate G-sphere from input ecut.
628 [ - + ]: 4628 : ABI_CHECK(.not.allocated(Kdata%kg_k), "Kdata%kg_k is allocated!")
629 [ - + ]: 4628 : call get_kg(kpoint,istwfk,ecut,Cryst%gmet,npw_k,Kdata%kg_k)
630 : :
631 [ + - ]: 4994 : else if (present(kg_k)) then
632 : : ! Use input g-vectors.
633 : 4994 : npw_k = SIZE(kg_k,DIM=2)
634 [ - + + - : 14982 : ABI_MALLOC(Kdata%kg_k,(3,npw_k))
+ - + - -
+ - + -
+ ]
635 [ + - + - : 6087400 : Kdata%kg_k = kg_k
- + - - +
+ + + ]
636 : : else
637 : 0 : ABI_ERROR("Either ecut or kg_k must be present")
638 : : end if
639 : 9622 : Kdata%npw = npw_k
640 : :
641 [ + + ]: 38488 : 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 [ + - - + : 38488 : ABI_MALLOC(Kdata%gbound,(2*mgfft+8, 2))
+ - + - +
- + - - +
- + - + ]
646 : 9622 : 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 [ - + + - : 28866 : ABI_MALLOC(Kdata%phkxred,(2, Cryst%natom))
+ - + - -
+ - + -
+ ]
650 [ + + ]: 29571 : do iatom=1,Cryst%natom
651 : 19949 : iatm=Cryst%atindx(iatom)
652 [ + + ]: 79796 : arg=two_pi*(DOT_PRODUCT(kpoint,Cryst%xred(:,iatom)))
653 : 19949 : Kdata%phkxred(1,iatm)=DCOS(arg)
654 : 29571 : 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 [ + + ]: 38488 : mgfft = MAXVAL(ngfft(1:3))
662 [ + - - + : 28866 : ABI_MALLOC(ph1d,(2, 3*(2*mgfft+1)*Cryst%natom))
+ - + - +
- - + -
+ ]
663 : 9622 : 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 : 9622 : matblk = 0
667 [ + + + + ]: 9622 : if(psps%usepaw == 1 .or. Kdata%use_fnl_dir0der0) then
668 : 354 : matblk=Cryst%natom
669 : : end if
670 [ - + + - : 38488 : ABI_MALLOC(Kdata%ph3d,(2, npw_k, matblk))
+ + + - +
- + + - +
- + - + ]
671 [ + + + + ]: 9622 : 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 : 354 : &ngfft(3),Kdata%phkxred,ph1d,Kdata%ph3d)
674 : : end if
675 [ - + ]: 9622 : ABI_FREE(ph1d)
676 : :
677 : : ! Compute spherical harmonics.
678 : 9622 : Kdata%has_ylm = 1
679 [ - + + - : 38488 : ABI_MALLOC(Kdata%ylm, (npw_k, Psps%mpsang**2*Psps%useylm))
+ + + - +
- + + - +
- + - + ]
680 : 9622 : useylmgr=0
681 [ - + + - : 19244 : ABI_MALLOC(ylmgr_k,(npw_k, 3, Psps%mpsang**2*useylmgr))
- + - + ]
682 : :
683 [ + + ]: 9622 : if (Kdata%useylm == 1) then
684 : 302 : mkmem_=1; mpw_=npw_k; nband_=0; nkpt_=1; npwarr_(1)=npw_k
685 : 302 : 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 : 302 : npwarr_, 1, optder, Cryst%rprimd, Kdata%ylm, ylmgr_k)
689 : :
690 : 302 : Kdata%has_ylm = 2
691 : : end if
692 : :
693 : : ! Compute (k+G) vectors.
694 : 9622 : nkpg = 0
695 [ - + + - : 19244 : 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 : 9622 : dimffnl = 0
700 [ + + + + ]: 9622 : if(psps%usepaw == 1 .or. Kdata%use_fnl_dir0der0) then
701 : 354 : dimffnl = 1+3*ider0
702 : : end if
703 [ - + + - : 57732 : ABI_MALLOC(Kdata%fnl_dir0der0,(npw_k, dimffnl, Psps%lmnmax, Cryst%ntypat))
+ + + - -
+ + - - +
+ - + - +
+ - + - +
- + ]
704 : :
705 [ + + ]: 9622 : 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 : 354 : Psps%pspso,Psps%qgrid_ff,Cryst%rmet,Psps%usepaw,Psps%useylm,Kdata%ylm,ylmgr_k)
710 : : end if
711 : :
712 [ - + ]: 9622 : ABI_FREE(kpg_k)
713 [ - + ]: 9622 : ABI_FREE(ylmgr_k)
714 : :
715 : 9622 : 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 : 13230 : subroutine kdata_free_0D(Kdata)
730 : :
731 : : !Arguments ------------------------------------
732 : : class(kdata_t),intent(inout) :: Kdata
733 : : !************************************************************************
734 : :
735 [ + + ]: 13230 : ABI_SFREE(Kdata%kg_k)
736 [ + + ]: 13230 : ABI_SFREE(Kdata%gbound)
737 : :
738 [ + + ]: 13230 : ABI_SFREE(Kdata%ph3d)
739 [ + + ]: 13230 : ABI_SFREE(Kdata%phkxred)
740 [ + + ]: 13230 : ABI_SFREE(Kdata%fnl_dir0der0)
741 [ + + ]: 13230 : ABI_SFREE(Kdata%ylm)
742 : :
743 : 13230 : 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 [ - + ]: 493 : 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 [ + - + + ]: 9222 : do ik=LBOUND(Kdata,DIM=1),UBOUND(Kdata,DIM=1)
769 : 8729 : call kdata_free_0D(Kdata(ik))
770 : : end do
771 : :
772 : 493 : 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 : 493 : subroutine wfd_init(Wfd,Cryst,Pawtab,Psps,keep_ur,mband,nband,nkibz,nsppol,bks_mask,&
882 : 493 : 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 : 493 : call cwtime(cpu, wall, gflops, "start")
912 : :
913 : : ! MPI info
914 : 493 : Wfd%comm = comm
915 : 493 : Wfd%my_rank = xmpi_comm_rank(Wfd%comm)
916 : 493 : Wfd%nproc = xmpi_comm_size(Wfd%comm)
917 : 493 : Wfd%master = 0
918 : :
919 : : ! Sequential MPI datatype to be passed to abinit routines.
920 : 493 : call initmpi_seq(Wfd%MPI_enreg)
921 : 493 : 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 : 493 : Wfd%nkibz = nkibz
930 : 493 : Wfd%nsppol = nsppol
931 : 493 : Wfd%nspden = nspden
932 : 493 : Wfd%nspinor = nspinor
933 : 493 : Wfd%paral_kgb = 0
934 [ + + ]: 1972 : Wfd%nloalg = nloalg
935 : :
936 : 493 : Wfd%usepaw = Psps%usepaw
937 : 493 : Wfd%usewvl = 0 ! wavelets are not supported.
938 : 493 : Wfd%use_fnl_dir0der0 = .false.
939 [ + + ]: 493 : if(present(use_fnl_dir0der0)) Wfd%use_fnl_dir0der0 = use_fnl_dir0der0
940 : 493 : Wfd%natom = Cryst%natom
941 : 493 : Wfd%ntypat = Cryst%ntypat
942 : 493 : Wfd%lmnmax = Psps%lmnmax
943 : 493 : Wfd%prtvol = prtvol
944 : 493 : Wfd%pawprtvol = pawprtvol
945 : :
946 : 493 : Wfd%ecutsm = ecutsm
947 : 493 : Wfd%dilatmx = dilatmx
948 : :
949 [ - + + - : 1972 : ABI_MALLOC(Wfd%indlmn,(6, Wfd%lmnmax, Wfd%ntypat))
- + + - +
- + - - +
- + - + ]
950 [ + - + - : 17443 : Wfd%indlmn = Psps%indlmn
+ - - + -
- - - - -
- - + + +
+ + + ]
951 : :
952 [ + + ]: 493 : if (Wfd%usepaw==1) then
953 [ - + + - : 45 : ABI_MALLOC(Wfd%nlmn_atm, (Cryst%natom))
+ - + - -
+ - + -
+ ]
954 [ - + + - : 45 : ABI_MALLOC(Wfd%nlmn_type, (Cryst%ntypat))
+ - + - -
+ - + -
+ ]
955 [ + + ]: 87 : do iatom=1,Cryst%natom
956 : 87 : Wfd%nlmn_atm(iatom) = Pawtab(Cryst%typat(iatom))%lmn_size
957 : : end do
958 : :
959 [ + + ]: 41 : do itypat=1,Cryst%ntypat
960 : 41 : Wfd%nlmn_type(itypat)=Pawtab(itypat)%lmn_size
961 : : end do
962 : :
963 [ - + + - : 30 : ABI_MALLOC(Wfd%nlmn_sort,(Cryst%natom))
- + - + -
+ ]
964 : 15 : iat=0 ! nlmn dims sorted by atom type.
965 [ + + ]: 41 : do itypat=1,Cryst%ntypat
966 [ + + ]: 98 : Wfd%nlmn_sort(iat+1:iat+Cryst%nattyp(itypat))=Pawtab(itypat)%lmn_size
967 : 41 : iat=iat+Cryst%nattyp(itypat)
968 : : end do
969 : : end if
970 : :
971 [ - + + - : 2465 : ABI_MALLOC(Wfd%keep_ur, (mband, nkibz, nsppol))
- + + - -
+ + - + -
+ - - + -
+ - + ]
972 [ - + + + : 119533 : Wfd%keep_ur = keep_ur
+ + + + ]
973 : :
974 : : ! Setup of the FFT mesh
975 [ + + ]: 9367 : Wfd%ngfft = ngfft
976 [ + + ]: 1972 : Wfd%mgfft = MAXVAL (Wfd%ngfft(1:3))
977 [ + + ]: 1972 : Wfd%nfftot = PRODUCT(Wfd%ngfft(1:3))
978 : 493 : Wfd%nfft = Wfd%nfftot ! At present no FFT parallelism.
979 : 493 : Wfd%ecut = ecut
980 : :
981 : : ! Precalculate the FFT index of $ R^{-1} (r-\tau) $ used to symmetrize u_Rk.
982 [ - + + - : 1972 : ABI_MALLOC(Wfd%irottb,(Wfd%nfftot, Cryst%nsym))
- + + - +
- + - - +
- + - + ]
983 : 493 : call rotate_FFT_mesh(Cryst%nsym,Cryst%symrel,Cryst%tnons,Wfd%ngfft,Wfd%irottb,iscompatibleFFT)
984 : :
985 [ + + ]: 493 : 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 : 493 : Wfd%rfft_is_symok = check_rot_fft(Cryst%nsym,Cryst%symrel,Wfd%ngfft(1),Wfd%ngfft(2),Wfd%ngfft(3))
992 : :
993 [ - + + - : 1479 : ABI_MALLOC(Wfd%kibz, (3, Wfd%nkibz))
+ - + - -
+ - + -
+ ]
994 [ + - - + : 33930 : Wfd%kibz = kibz
- - + + +
+ ]
995 [ - + + - : 1479 : ABI_MALLOC(Wfd%istwfk, (Wfd%nkibz))
+ - + - -
+ - + -
+ ]
996 [ + - - + : 9222 : Wfd%istwfk = istwfk
- - + + ]
997 : :
998 : : ! Get the number of planewaves npw_k
999 : : ! TODO Here we should use ecut_eff instead of ecut
1000 [ - + + - : 9715 : ABI_ICALLOC(Wfd%npwarr, (Wfd%nkibz))
+ - + - -
+ - + - +
+ + ]
1001 : 493 : exchn2n3d = 0
1002 [ + + ]: 8729 : do ik_ibz=1,Wfd%nkibz
1003 [ + + ]: 8236 : if (mod(ik_ibz, wfd%nproc) /= wfd%my_rank) cycle ! MPI parallelism.
1004 : 7572 : istwf_k = Wfd%istwfk(ik_ibz)
1005 [ + + ]: 30288 : kpoint = Wfd%kibz(:,ik_ibz)
1006 : 7572 : call kpgsph(Wfd%ecut,exchn2n3d,Cryst%gmet,ikg0,ik_ibz,istwf_k,dum_kg,kpoint,0,Wfd%MPI_enreg,mpw0,npw_k)
1007 : 8729 : Wfd%npwarr(ik_ibz)= npw_k
1008 : : end do
1009 : 493 : call xmpi_sum(wfd%npwarr, wfd%comm, ierr)
1010 : :
1011 [ + + ]: 8729 : mpw = maxval(Wfd%npwarr)
1012 : :
1013 [ - + + - : 1972 : ABI_MALLOC(Wfd%nband, (nkibz,nsppol))
- + + - +
- + - - +
- + - + ]
1014 [ - + + + : 9742 : Wfd%nband = nband; Wfd%mband = mband
+ + ]
1015 [ + + + + : 9249 : ABI_CHECK_IEQ(maxval(Wfd%nband), mband, "Wrong mband")
- + - - -
- ]
1016 : :
1017 : : ! Allocate u(g) and, if required, also u(r)
1018 [ + + + + : 119040 : ug_size = one*nspinor*mpw*COUNT(bks_mask)
+ + + + ]
1019 : 493 : write(msg,'(a,f8.1,a)')' Memory needed for Fourier components u(G): ',two*gwp*ug_size*b2Mb, ' [Mb] <<< MEM'
1020 : 493 : call wrtout(std_out, msg)
1021 : : #ifdef HAVE_GW_DPC
1022 : 493 : call wrtout(std_out, ' Storing wavefunctions in double precision as `enable_gw_dpc="no"`')
1023 : 493 : 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 [ + + ]: 493 : if (Wfd%usepaw==1) then
1029 [ + + + + : 1917 : cprj_size = one * nspinor*SUM(Wfd%nlmn_atm)*COUNT(bks_mask)
+ + + + +
- ]
1030 : 15 : write(msg,'(a,f8.1,a)')' Memory needed for PAW projections cprj: ',dp*cprj_size*b2Mb,' [Mb] <<< MEM'
1031 : 15 : call wrtout(std_out, msg)
1032 : : end if
1033 : :
1034 [ + + + + : 119040 : ur_size = one*nspinor*Wfd%nfft*COUNT(Wfd%keep_ur)
+ + + + ]
1035 : 493 : write(msg,'(a,f8.1,a)')' Memory needed for real-space u(r): ',two*gwp*ur_size*b2Mb,' [Mb] <<< MEM'
1036 : 493 : call wrtout(std_out, msg)
1037 : :
1038 : : ! Count the number of spins treated by this proc.
1039 : 493 : wfd%my_nspins = 0
1040 [ + + ]: 993 : do spin=1,wfd%nsppol
1041 [ + - + + : 12288 : 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 [ - + + - : 1979 : 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 [ - + + - : 1979 : ABI_ICALLOC(wfd%my_nkspin, (wfd%nsppol))
+ - + - -
+ - + - +
+ + ]
1048 : 493 : cnt_s = 0
1049 [ + + ]: 993 : do spin=1,wfd%nsppol
1050 [ + + ]: 8756 : do ik_ibz=1,wfd%nkibz
1051 [ + + + + : 39968 : if (any(bks_mask(:,ik_ibz,spin))) wfd%my_nkspin(spin) = wfd%my_nkspin(spin) + 1
+ + ]
1052 : : end do
1053 [ + - ]: 993 : if (wfd%my_nkspin(spin) > 0) then
1054 : 500 : cnt_s = cnt_s + 1
1055 [ - + + - : 6148 : 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 [ - + + - : 450385 : ABI_ICALLOC(wfd%bks2wfd, (3, wfd%mband, wfd%nkibz, wfd%nsppol))
- + + - -
+ + - + -
+ - - + -
+ - + + +
+ + + + +
+ ]
1061 : 493 : cnt_s = 0
1062 [ + + ]: 993 : do spin=1,wfd%nsppol
1063 [ + - ]: 500 : if (wfd%my_nkspin(spin) == 0) cycle
1064 : 500 : cnt_s = cnt_s + 1
1065 : 500 : cnt_k = 0
1066 [ + + ]: 9249 : do ik_ibz=1,wfd%nkibz
1067 [ + + + + ]: 118047 : cnt_b = count(bks_mask(:, ik_ibz, spin))
1068 [ + + ]: 8256 : if (cnt_b == 0) cycle
1069 : 4648 : cnt_k = cnt_k + 1
1070 [ - + + - : 86039 : ABI_MALLOC(wfd%s(cnt_s)%k(cnt_k)%b, (cnt_b))
+ - - + -
+ - + +
+ ]
1071 : 4648 : cnt_b = 0
1072 : 4648 : npw_k = Wfd%npwarr(ik_ibz)
1073 [ + + ]: 84830 : do band=1,Wfd%nband(ik_ibz, spin)
1074 [ + + ]: 87938 : if (bks_mask(band, ik_ibz, spin)) then
1075 : 72095 : cnt_b = cnt_b + 1
1076 : : call wave_init(wfd%s(cnt_s)%k(cnt_k)%b(cnt_b), &
1077 : 72095 : Wfd%usepaw, npw_k, nfft0, Wfd%nspinor, Wfd%natom, Wfd%nlmn_atm, CPR_RANDOM)
1078 [ + + ]: 288380 : 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 [ + - - + : 1479 : ABI_MALLOC(Wfd%ph1d, (2, 3*(2*Wfd%mgfft+1)*Wfd%natom))
+ - + - +
- - + - +
- + ]
1090 : 493 : 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 [ - + + - : 9715 : ABI_MALLOC(Wfd%Kdata, (Wfd%nkibz))
+ - + - -
+ - + - +
+ + ]
1094 [ + + ]: 8729 : Wfd%Kdata%use_fnl_dir0der0 = Wfd%use_fnl_dir0der0
1095 : :
1096 [ + + ]: 8729 : do ik_ibz=1,Wfd%nkibz
1097 [ + + ]: 32944 : kpoint = Wfd%kibz(:,ik_ibz)
1098 : 8236 : istwf_k = Wfd%istwfk(ik_ibz)
1099 : 8236 : npw_k = Wfd%npwarr(ik_ibz)
1100 [ + + + + : 43549 : if (any(wfd%bks2wfd(1, :, ik_ibz, :) /= 0)) then
+ + + + ]
1101 : 4628 : 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 : 394 : bks_size = one * wfd%mband * wfd%nkibz * wfd%nsppol * wfd%nproc
1109 : 394 : write(msg,'(a,f8.1,a)')' Memory needed for bks_tab: ',one * bks_size * b2Mb,' [Mb] <<< MEM'
1110 : 394 : call wrtout(std_out, msg)
1111 : :
1112 : : !ABI_MALLOC(wfd%bks_ranks, (wfd%mband, nkibz, nsppol))
1113 : :
1114 [ - + + - : 2364 : ABI_MALLOC(Wfd%bks_tab, (Wfd%mband, nkibz, nsppol, 0:Wfd%nproc-1))
- + + - -
+ + - - +
+ - + - -
+ - + -
+ ]
1115 [ + + + + : 103138 : Wfd%bks_tab = WFD_NOWAVE
+ + + + ]
1116 : :
1117 : : ! Update the kbs table storing the distribution of the ug.
1118 : 394 : call wfd%update_bkstab(show=-std_out)
1119 : : end select
1120 : :
1121 : : ! Build MPI communicator for collinear spin
1122 [ - + + - : 1479 : ABI_MALLOC(wfd%comm_spin, (nsppol))
+ - + - -
+ - + -
+ ]
1123 [ + + ]: 993 : do spin=1,nsppol
1124 [ + - + + : 11795 : color = merge(0, 1, any(bks_mask(:,:,spin)))
+ + - + ]
1125 : 993 : call xmpi_comm_split(wfd%comm, color, wfd%my_rank, wfd%comm_spin(spin), ierr)
1126 : : end do
1127 : :
1128 : 493 : call cwtime_report(" wfd_init", cpu, wall, gflops)
1129 : :
1130 : 1479 : 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 : 504 : 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 [ + + ]: 504 : ABI_SFREE(Wfd%irottb)
1155 [ + + ]: 504 : ABI_SFREE(Wfd%istwfk)
1156 [ + + ]: 504 : ABI_SFREE(Wfd%nband)
1157 [ + + ]: 504 : ABI_SFREE(Wfd%indlmn)
1158 [ + + ]: 504 : ABI_SFREE(Wfd%nlmn_atm)
1159 [ + + ]: 504 : ABI_SFREE(Wfd%nlmn_sort)
1160 [ + + ]: 504 : ABI_SFREE(Wfd%nlmn_type)
1161 [ + + ]: 504 : ABI_SFREE(Wfd%npwarr)
1162 : :
1163 : : select type (wfd)
1164 : : class is (wfdgw_t)
1165 [ + - ]: 394 : ABI_SFREE(Wfd%bks_tab)
1166 : : end select
1167 : :
1168 [ + + ]: 504 : if (allocated(wfd%s)) then
1169 [ + + ]: 993 : do is=1,size(wfd%s)
1170 [ + + ]: 5148 : do ik=1,size(wfd%s(is)%k)
1171 [ + + ]: 76743 : do ib=1,size(wfd%s(is)%k(ik)%b)
1172 : 76743 : call wfd%s(is)%k(ik)%b(ib)%free()
1173 : : end do
1174 [ + - + + : 77243 : ABI_FREE(wfd%s(is)%k(ik)%b)
- + - + -
+ - - - -
- - - + ]
1175 : : end do
1176 [ + - + + : 5641 : ABI_FREE(wfd%s(is)%k)
- + - - -
- - - - -
- - - - -
- - + ]
1177 : : end do
1178 [ + - + + : 993 : ABI_FREE(wfd%s)
- + - - -
- - - - -
- - - - -
- - - - -
- + ]
1179 : : end if
1180 : :
1181 [ + + ]: 504 : ABI_SFREE(wfd%my_nkspin)
1182 [ + + ]: 504 : ABI_SFREE(wfd%bks2wfd)
1183 : :
1184 : : ! real arrays.
1185 [ + + ]: 504 : ABI_SFREE(Wfd%kibz)
1186 [ + + ]: 504 : ABI_SFREE(Wfd%ph1d)
1187 : :
1188 : : ! logical arrays.
1189 [ + + ]: 504 : ABI_SFREE(Wfd%keep_ur)
1190 : :
1191 : : ! datatypes.
1192 [ + + ]: 504 : if (allocated(Wfd%Kdata)) then
1193 : 493 : call kdata_free(Wfd%Kdata)
1194 [ + - + + : 8729 : ABI_FREE(Wfd%Kdata)
- + - + -
+ - + - +
- + - + ]
1195 : : end if
1196 : :
1197 : 504 : 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 [ + + ]: 504 : ABI_SFREE(wfd%comm_spin)
1204 : :
1205 : 504 : 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 [ - + ]: 1134 : 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 [ + + ]: 9962 : do dat=1,SIZE(bands)
1609 : 8828 : band = bands(dat)
1610 : 8828 : ptr = 1 + (dat-1)*Wfd%nfft*Wfd%nspinor
1611 : 9962 : call wfd%get_ur(band,ik_ibz,spin,ur(ptr))
1612 : : end do
1613 : :
1614 : 1134 : 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 : 400291 : 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 [ - + ]: 400291 : ABI_CHECK(wfd%get_wave_ptr(band, ik_ibz, spin, wave, msg) == 0, msg)
1656 : :
1657 [ - + ]: 400291 : 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 : 400291 : csiz = wfd%npwarr(ik_ibz) * wfd%nspinor
1663 : : #ifdef HAVE_GW_DPC
1664 : 400291 : 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 : 400291 : 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 : 2415712 : 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 : 2415712 : integer,contiguous, pointer :: kg_k(:,:),gbound(:,:)
1711 : 2415712 : complex(gwp),contiguous, pointer :: ug(:)
1712 : : !************************************************************************
1713 : :
1714 : 2415712 : npw_k = Wfd%npwarr(ik_ibz)
1715 : 2415712 : nfft = Wfd%nfft
1716 : 2415712 : nspinor= Wfd%nspinor
1717 : :
1718 [ - + ]: 2415712 : ABI_CHECK(wfd%get_wave_ptr(band, ik_ibz, spin, wave, msg) == 0, msg)
1719 : :
1720 : 2528451 : select case (wave%has_ur)
1721 : :
1722 : : case (WFD_NOWAVE, WFD_ALLOCATED)
1723 : : ! FFT is required.
1724 [ - + ]: 112739 : 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 : 112739 : ug => wave%ug
1730 : 112739 : kg_k => Wfd%Kdata(ik_ibz)%kg_k
1731 : 112739 : gbound => Wfd%Kdata(ik_ibz)%gbound(:,:)
1732 : :
1733 : 112739 : call fft_ug(npw_k,nfft,nspinor,ndat1,Wfd%mgfft,Wfd%ngfft,Wfd%istwfk(ik_ibz),kg_k,gbound,ug,ur)
1734 : :
1735 [ + + ]: 112739 : if (Wfd%keep_ur(band,ik_ibz,spin)) then
1736 : : ! Store results
1737 [ + + ]: 67401 : if (wave%has_ur == WFD_NOWAVE) then
1738 : : ! Alloc buffer for ur.
1739 : 63261 : call wave_init(wave, Wfd%usepaw,npw0,nfft,nspinor,Wfd%natom,Wfd%nlmn_atm,CPR_RANDOM)
1740 : : end if
1741 : 67401 : call xcopy(nfft*nspinor, ur, 1, wave%ur, 1)
1742 : 67401 : wave%has_ur = WFD_STORED
1743 : : end if
1744 : :
1745 : : case (WFD_STORED)
1746 : : ! copy it back.
1747 : 2302973 : call xcopy(nfft*nspinor, wave%ur, 1, ur, 1)
1748 : :
1749 : : case default
1750 [ + + - ]: 2415712 : ABI_BUG(sjoin("Wrong has_ur:", itoa(wave%has_ur)))
1751 : : end select
1752 : :
1753 : 2415712 : 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 : 956 : 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 [ - + ]: 478 : my_prtvol=0 ; if (present(prtvol )) my_prtvol=prtvol
1791 : :
1792 : 478 : msg = ' ==== Info on the wfd% object ==== '
1793 [ + + + - : 478 : if (present(header)) msg=' ==== '//TRIM(ADJUSTL(header))//' ==== '
+ - ]
1794 : 478 : call wrtout(units, msg)
1795 : :
1796 : : write(msg,'(3(a,i0,a),a,i0,2a,f5.1)')&
1797 : 478 : ' Number of irreducible k-points ........ ',Wfd%nkibz,ch10,&
1798 : 478 : ' Number of spinorial components ........ ',Wfd%nspinor,ch10,&
1799 : 478 : ' Number of spin-density components ..... ',Wfd%nspden,ch10,&
1800 : 478 : ' Number of spin polarizations .......... ',Wfd%nsppol,ch10,&
1801 : 956 : ' Plane wave cutoff energy .............. ',Wfd%ecut
1802 : 478 : call wrtout(units, msg)
1803 : :
1804 [ + + ]: 8337 : mpw = maxval(Wfd%npwarr)
1805 : : write(msg,'(3(a,i0,a))')&
1806 : 478 : ' Max number of G-vectors ............... ',mpw,ch10,&
1807 : 478 : ' Total number of FFT points ............ ',Wfd%nfftot,ch10,&
1808 : 956 : '- Number of FFT points treated by me .... ',Wfd%nfft,ch10
1809 : 478 : call wrtout(units, msg)
1810 : :
1811 : 478 : call print_ngfft(units, Wfd%ngfft, 'FFT mesh for wavefunctions', prtvol=my_prtvol)
1812 : :
1813 : 478 : ug_cnt = 0; ur_cnt = 0; cprj_cnt = 0
1814 [ + + ]: 963 : do spin=1,Wfd%nsppol
1815 [ + + ]: 8842 : do ik_ibz=1,Wfd%nkibz
1816 [ + + ]: 114167 : do band=1,Wfd%nband(ik_ibz,spin)
1817 : 105803 : ib = wfd%bks2wfd(1, band, ik_ibz, spin)
1818 [ + + ]: 105803 : if (ib == 0) cycle
1819 : 68107 : ik = wfd%bks2wfd(2, band, ik_ibz, spin)
1820 : 68107 : is = wfd%bks2wfd(3, band, ik_ibz, spin)
1821 [ + - ]: 68107 : if (wfd%s(is)%k(ik)%b(ib)%has_ug >= WFD_ALLOCATED) ug_cnt = ug_cnt + 1
1822 [ + + ]: 68107 : if (wfd%s(is)%k(ik)%b(ib)%has_ur >= WFD_ALLOCATED) ur_cnt = ur_cnt + 1
1823 [ + + ]: 75986 : 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 : 478 : write(msg, '(a,i0)')'P Total number of (b,k,s) states stored by this rank: ', ug_cnt
1830 : 478 : call wrtout(units, msg, pre_newlines=1)
1831 : :
1832 : 478 : ug_size = one * Wfd%nspinor * mpw * ug_cnt
1833 : 478 : write(msg,'(a,f8.1,a)')'P Memory allocated for Fourier components u(G): ',two*gwp*ug_size*b2Mb,' [Mb] <<< MEM'
1834 : 478 : call wrtout(units, msg)
1835 : :
1836 [ + + + + : 52404 : if (any(wfd%keep_ur)) then
+ + + + +
+ ]
1837 : 356 : ur_size = one * Wfd%nspinor * Wfd%nfft * ur_cnt
1838 : 356 : write(msg,'(a,f8.1,a)')'P Memory allocated for real-space u(r): ',two*gwp*ur_size*b2Mb,' [Mb] <<< MEM'
1839 : 356 : call wrtout(units, msg)
1840 : : end if
1841 : :
1842 [ + + ]: 478 : if (wfd%usepaw==1) then
1843 [ + + ]: 87 : cprj_size = one * Wfd%nspinor * sum(Wfd%nlmn_atm) * cprj_cnt
1844 : 15 : write(msg,'(a,f8.1,a)')'P Memory allocated for PAW projections cprj: ',dp*cprj_size*b2Mb,' [Mb] <<< MEM'
1845 : 15 : call wrtout(units, msg)
1846 : : end if
1847 : :
1848 [ + + ]: 956 : write(msg,'(a,f8.1,a)')'P Memory needed for wfd%s datastructure: ',ABI_MEM_MB(wfd%s),' [Mb] <<< MEM'
1849 : 478 : call wrtout(units, msg)
1850 [ + + ]: 956 : 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 : 478 : call wrtout(units, msg)
1852 [ + + ]: 956 : write(msg,'(a,f8.1,a)')'P Memory allocated for Kdata array: ',ABI_MEM_MB(wfd%kdata),' [Mb] <<< MEM'
1853 : 478 : call wrtout(units, msg, newlines=1)
1854 : :
1855 [ - + ]: 478 : 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 : 1725 : 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 : 1725 : integer,contiguous, pointer :: kg_k(:,:)
1916 : 1725 : integer,allocatable :: dimcprj_srt(:)
1917 : : real(dp) :: kpoint(3)
1918 : 1725 : real(dp),contiguous, pointer :: phkxred(:,:)
1919 : 1725 : real(dp),allocatable :: cwavef(:,:), kpg(:,:)
1920 : : !real(dp),allocatable :: ph1d(2,3*(2*mgfft+1)*natom)
1921 : 1725 : real(dp),contiguous, pointer :: ph3d(:,:,:) ! ph3d(2,npw_k,matblk)
1922 : 1725 : real(dp),contiguous, pointer :: ffnl(:,:,:,:) ! ffnl(npw_k,dimffnl,lmnmax,ntypat)
1923 : 1725 : 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 : 1725 : dimffnl = 1
1930 : 1725 : npw_k = Wfd%npwarr(ik_ibz)
1931 : 1725 : istwf_k = Wfd%istwfk(ik_ibz)
1932 [ + + ]: 6900 : kpoint = Wfd%kibz(:,ik_ibz)
1933 : :
1934 : 1725 : kg_k => Wfd%Kdata(ik_ibz)%kg_k
1935 : 1725 : ph3d => Wfd%Kdata(ik_ibz)%ph3d
1936 : 1725 : ffnl => Wfd%Kdata(ik_ibz)%fnl_dir0der0
1937 : 1725 : phkxred => Wfd%Kdata(ik_ibz)%phkxred
1938 : :
1939 : : ! Compute (k+G) vectors
1940 : 1725 : 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 [ - + + - : 3450 : 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 [ - + + - : 5175 : ABI_MALLOC(cwavef, (2,npw_k*Wfd%nspinor))
+ - + - -
+ - + ]
1948 [ - + ]: 1725 : ABI_CHECK(wfd%get_wave_ptr(band, ik_ibz, spin, wave, msg) == 0, msg)
1949 [ + + ]: 994748 : cwavef(1,:) = DBLE (wave%ug)
1950 [ + + ]: 994748 : cwavef(2,:) = AIMAG(wave%ug)
1951 : :
1952 : 1725 : cpopt = 0 ! Nothing is already calculated.
1953 : :
1954 [ + - ]: 1725 : want_sorted=.FALSE.; if (present(sorted)) want_sorted=sorted
1955 : :
1956 [ - + ]: 1725 : 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 [ - + + - : 5175 : ABI_MALLOC(dimcprj_srt,(Cryst%natom))
+ - + - -
+ - + ]
1966 : 1725 : ia=0
1967 [ + + ]: 3912 : do itypat=1,Cryst%ntypat
1968 [ + + ]: 6813 : dimcprj_srt(ia+1:ia+Cryst%nattyp(itypat))=Wfd%nlmn_type(itypat)
1969 : 3912 : ia=ia+Cryst%nattyp(itypat)
1970 : : end do
1971 : :
1972 [ - + + - : 13251 : ABI_MALLOC(Cprj_srt,(natom,Wfd%nspinor))
- + + - +
- + - - +
- + + + +
+ ]
1973 : 1725 : call pawcprj_alloc(Cprj_srt,0,dimcprj_srt)
1974 [ - + ]: 1725 : 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 : 1725 : phkxred,Wfd%ph1d,ph3d,Cryst%ucvol,1)
1981 : :
1982 : : ! Reorder cprj (sorted --> unsorted)
1983 [ + + ]: 6351 : do iatom=1,Cryst%natom
1984 : 4626 : iatm=Cryst%atindx(iatom)
1985 [ + + ]: 10977 : do isp=1,Wfd%nspinor
1986 [ + - + - : 134730 : cwaveprj(iatom,isp)%cp=Cprj_srt(iatm,isp)%cp
- + - - -
- - - + +
+ + ]
1987 : : end do
1988 : : end do
1989 : :
1990 : 1725 : call pawcprj_free(Cprj_srt)
1991 [ + - + + : 6351 : ABI_FREE(Cprj_srt)
- + - + -
+ ]
1992 : : end if
1993 : :
1994 [ - + ]: 1725 : ABI_FREE(cwavef)
1995 [ - + ]: 1725 : ABI_FREE(kpg)
1996 : :
1997 [ - + - + : 3450 : 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 [ + + ]: 135356 : 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 [ + + ]: 135356 : if (npw >0) then
2040 [ - + + - : 216285 : ABI_MALLOC(Wave%ug, (npw*nspinor))
+ - + - -
+ - + -
+ ]
2041 : 72095 : Wave%has_ug = WFD_ALLOCATED
2042 [ + + ]: 32367505 : Wave%ug = huge(one_gw)
2043 [ + + ]: 72095 : if (usepaw == 1) then
2044 [ - + + - : 13300 : ABI_MALLOC(Wave%Cprj, (natom,nspinor))
- + + - +
- + - - +
- + - + +
+ + + +
- ]
2045 : 1732 : call pawcprj_alloc(Wave%Cprj,ncpgr0,nlmn_size)
2046 : 1732 : Wave%has_cprj = WFD_ALLOCATED
2047 : 1732 : Wave%cprj_order = cprj_order
2048 : : end if
2049 : : end if
2050 : :
2051 [ + + ]: 135356 : if (nfft > 0) then
2052 [ - + + - : 189783 : ABI_MALLOC(Wave%ur, (nfft*nspinor))
+ - + - -
+ - + -
+ ]
2053 [ + + ]: 421261595 : Wave%ur = huge(one_gw)
2054 : 63261 : Wave%has_ur = WFD_ALLOCATED
2055 : : end if
2056 : :
2057 : 135356 : 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 : 165376 : 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 [ + + + + ]: 165376 : my_what="ALL"; if (present(what)) my_what=toupper(what)
2093 : :
2094 [ + + - + ]: 826880 : if (.not.firstchar(my_what, ["A", "G", "R", "C"] )) then
2095 : 0 : ABI_ERROR(sjoin("Unknown what:", what))
2096 : : end if
2097 : :
2098 [ + + + + ]: 496128 : if (firstchar(my_what, ["A", "G"])) then
2099 [ + + ]: 80703 : ABI_SFREE(Wave%ug)
2100 : 80703 : Wave%has_ug = WFD_NOWAVE
2101 : : end if
2102 : :
2103 [ + + + - ]: 496128 : if (firstchar(my_what, ["A", "R"])) then
2104 [ + + ]: 165376 : ABI_SFREE(Wave%ur)
2105 : 165376 : Wave%has_ur = WFD_NOWAVE
2106 : : end if
2107 : :
2108 [ + + + + ]: 496128 : if (firstchar(my_what, ["A", "C"])) then
2109 [ + + ]: 80703 : if (allocated(Wave%Cprj)) then
2110 : 1732 : call pawcprj_free(Wave%Cprj)
2111 [ + - + + : 6372 : ABI_FREE(Wave%Cprj)
- + - + -
+ ]
2112 : : end if
2113 : 80703 : Wave%has_cprj = WFD_NOWAVE
2114 : : end if
2115 : :
2116 : 165376 : 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 : 467401049 : 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 : 467401049 : ierr = 1
2202 [ + + + - : 1869604196 : 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 : 467401049 : ib = wfd%bks2wfd(1, band, ik_ibz, spin)
2208 : 467401049 : ik = wfd%bks2wfd(2, band, ik_ibz, spin)
2209 : 467401049 : is = wfd%bks2wfd(3, band, ik_ibz, spin)
2210 : 467401049 : wave_ptr => wfd%s(is)%k(ik)%b(ib)
2211 : : !if (wave_ptr%has_ug /= WFD_STORED)
2212 : :
2213 : 467401049 : ierr = 0
2214 : :
2215 : 467401049 : 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 : 2526604 : 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 [ + + ]: 10106416 : indices = [band,ik_ibz,spin]
2423 : 2526604 : bks_flag = WFD_STORED
2424 : :
2425 [ + + + - : 10106416 : if (ALL(indices/= [0,0,0])) then
+ - ]
2426 : 2526604 : 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 : 185625 : 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 : 185625 : check2 = [WFD_ALLOCATED, WFD_STORED]
2491 [ + + ]: 185625 : if (present(how)) then
2492 [ + + - + ]: 207021 : if (firstchar(how, ["A", "a"])) check2 = [WFD_ALLOCATED, WFD_ALLOCATED]
2493 [ + + + - ]: 207021 : if (firstchar(how, ["S", "s"])) check2 = [WFD_STORED, WFD_STORED]
2494 : : end if
2495 : 185625 : ib = wfd%bks2wfd(1, band, ik_ibz, spin)
2496 : 185625 : ik = wfd%bks2wfd(2, band, ik_ibz, spin)
2497 : 185625 : is = wfd%bks2wfd(3, band, ik_ibz, spin)
2498 : 185625 : wfd_ihave_ug = .False.
2499 [ + + + + : 331944 : if (ib /= 0) wfd_ihave_ug = any(wfd%s(is)%k(ik)%b(ib)%has_ug == check2)
+ + ]
2500 : :
2501 : 185625 : 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 : 176206 : 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 [ + + ]: 2702810 : how_manyb=0; rank_band_list=-1
2648 [ + + ]: 2702810 : do band=1,Wfd%nband(ik_ibz,spin)
2649 : 2526604 : it_has = Wfd%rank_has_ug(rank, band, ik_ibz, spin)
2650 [ + + ]: 2702810 : if (it_has) then
2651 : 2261444 : how_manyb = how_manyb +1
2652 : 2261444 : rank_band_list(how_manyb)=band
2653 : : end if
2654 : : end do
2655 : :
2656 : 176206 : 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 : 410861 : 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 [ + - + - : 410861 : bks_select = (band/=0.and.ik_ibz/=0.and.spin/=0)
- + ]
2816 [ - + - - : 410861 : spin_select = (band==0.and.ik_ibz==0.and.spin/=0)
- - ]
2817 [ - + - - : 410861 : kpt_select = (band==0.and.ik_ibz/=0.and.spin/=0)
- - ]
2818 : :
2819 [ + + ]: 1148762 : how_many=0; proc_ranks=-1
2820 : :
2821 [ + - ]: 410861 : if (bks_select) then
2822 : : ! List the proc owining this (b,k,s) state.
2823 [ + + ]: 1148762 : do irank=0,Wfd%nproc-1
2824 [ + + ]: 1148762 : if (Wfd%bks_tab(band, ik_ibz, spin, irank) == WFD_STORED) then
2825 : 714423 : how_many = how_many +1
2826 : 714423 : 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 : 410861 : 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 : 2491 : 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 : 2491 : 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 [ + + ]: 5021 : do spin=1,wfd%nsppol
2890 [ + + ]: 23434 : do ik_ibz=1,wfd%nkibz
2891 [ + + ]: 341304 : do band=1,Wfd%nband(ik_ibz, spin)
2892 : 320361 : ib = wfd%bks2wfd(1, band, ik_ibz, spin)
2893 : 320361 : ik = wfd%bks2wfd(2, band, ik_ibz, spin)
2894 : 320361 : is = wfd%bks2wfd(3, band, ik_ibz, spin)
2895 [ + + ]: 338774 : if (ib /= 0) then
2896 : 298845 : 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 : 2491 : nelem = Wfd%mband*Wfd%nkibz*Wfd%nsppol
2906 [ - + + - : 7473 : ABI_MALLOC(my_vtab, (nelem))
+ - - + -
+ ]
2907 [ + + ]: 4982 : my_vtab(:) = reshape(Wfd%bks_tab(:,:,:,Wfd%my_rank), [nelem])
2908 : :
2909 [ - + + - : 7473 : ABI_MALLOC(gather_vtabs, (nelem*Wfd%nproc))
+ - - + -
+ - + ]
2910 : :
2911 : 2491 : call xmpi_allgather(my_vtab,nelem,gather_vtabs,Wfd%comm,ierr)
2912 : :
2913 [ + + + + : 565004 : Wfd%bks_tab(:,:,:,:) = reshape(gather_vtabs, [Wfd%mband, Wfd%nkibz, Wfd%nsppol, Wfd%nproc])
+ + + + +
+ ]
2914 [ - + ]: 2491 : ABI_FREE(my_vtab)
2915 [ - + ]: 2491 : 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 [ + + ]: 2491 : if (present(show)) then
2938 [ - + ]: 394 : if (show >= 0) call wfd%show_bkstab(unit=show)
2939 : : end if
2940 : :
2941 [ - + - + ]: 4982 : 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 : 47848 : 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 : 103504 : integer :: proc_ranks(Wfd%nproc),get_more(Wfd%nproc)
2986 : 103504 : logical :: rank_mask(Wfd%nproc)
2987 : : !************************************************************************
2988 : :
2989 [ + + ]: 767503 : my_nband=0; my_band_list=0
2990 [ + + + + : 241708 : get_more=0; if (present(got)) get_more = got
+ + ]
2991 : :
2992 [ + + ]: 767503 : do band=1,Wfd%nband(ik_ibz,spin)
2993 [ + + ]: 715751 : if (present(bmask)) then
2994 [ + + ]: 711575 : if (.not.bmask(band)) CYCLE
2995 : : end if
2996 : :
2997 : 410429 : call wfdgw_who_has_ug(Wfd, band, ik_ibz, spin, how_many, proc_ranks)
2998 : :
2999 [ + + ]: 462181 : if (how_many == 1) then
3000 : : ! I am the only one owing this band. Add it to list.
3001 [ + + ]: 280331 : if (proc_ranks(1) == Wfd%my_rank) then
3002 : 273623 : my_nband=my_nband + 1
3003 : 273623 : 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 [ + + + + ]: 143364 : if (present(got)) got = get_more
3021 : :
3022 [ + + ]: 51752 : 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 : 466 : 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 : 932 : integer :: my_band_list(Wfd%mband)
3185 : : !************************************************************************
3186 : :
3187 [ + + ]: 1398 : call iter_alloc(iter_bks,(/Wfd%nkibz,Wfd%nsppol/))
3188 : :
3189 [ + + ]: 941 : do spin=1,Wfd%nsppol
3190 [ + + ]: 4436 : do ik_ibz=1,Wfd%nkibz
3191 [ + - ]: 3495 : if (present(bks_mask)) then
3192 : 3495 : 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 : 3970 : call iter_push(iter_bks,ik_ibz,spin,my_band_list(1:my_nband))
3197 : : end do
3198 : : end do
3199 : :
3200 [ + - ]: 466 : 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 : 2434 : 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 : 9190 : integer :: loc_got(Wfd%nproc)
3457 : : !************************************************************************
3458 : :
3459 : : ! Just a wrapper around wfdgw_distribute_kb_kpbp.
3460 [ + + + + : 31340 : loc_got=0; if (present(got)) loc_got = got
+ + ]
3461 : :
3462 [ + - ]: 9190 : if (present(bbp_mask)) then
3463 : 9190 : 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 [ + + ]: 9190 : 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 : 85906 : subroutine wfdgw_distribute_kb_kpbp(Wfd, ik_ibz, ikp_ibz, spin, allup, my_nbbp, bbp_distrb, &
3501 : 85906 : 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 : 85906 : integer :: rank_bandlist_k(Wfd%mband),rank_bandlist_kp(Wfd%mband)
3521 : 85906 : integer :: get_more(Wfd%nproc),my_band_list_k(Wfd%mband)
3522 : 42953 : integer,allocatable :: whocan_k(:,:),whocan_kp(:,:)
3523 : 85906 : logical :: b_mask(Wfd%mband)
3524 : : !************************************************************************
3525 : :
3526 [ - + + - : 171812 : ABI_MALLOC_OR_DIE(whocan_k ,(Wfd%mband,Wfd%nproc), ierr)
- + + - +
- + - + -
- + - + ]
3527 [ - + + - : 171812 : ABI_MALLOC_OR_DIE(whocan_kp,(Wfd%mband,Wfd%nproc), ierr)
- + + - +
- + - + -
- + - + ]
3528 [ + + + + ]: 1394358 : whocan_k =0 ! Will be set to 1 if this node can calculate something containing (k,b)
3529 [ + + + + ]: 1394358 : whocan_kp=0 ! Will be set to 1 if this node can calculate something containing (kp,bp)
3530 : :
3531 [ + + ]: 131056 : do rank=0,Wfd%nproc-1
3532 : :
3533 : 88103 : call wfd%bands_of_rank(rank,ik_ibz ,spin,howmany_b, rank_bandlist_k )
3534 [ + + ]: 1218825 : do pcb1=1,howmany_b
3535 : 1130722 : ib1 = rank_bandlist_k(pcb1)
3536 : 1218825 : whocan_k(ib1,rank+1) = 1
3537 : : end do
3538 : :
3539 : 88103 : call wfd%bands_of_rank(rank,ikp_ibz,spin,howmany_bp,rank_bandlist_kp)
3540 [ + + ]: 1349881 : do pcb2=1,howmany_bp
3541 : 1130722 : ib2 = rank_bandlist_kp(pcb2)
3542 : 1218825 : whocan_kp(ib2,rank+1) = 1
3543 : : end do
3544 : :
3545 : : end do
3546 : :
3547 [ + + + - : 219159 : get_more=0; if (present(got)) get_more=got
+ + ]
3548 : 42953 : b1_stop=Wfd%nband(ik_ibz,spin)
3549 : :
3550 [ + + + + ]: 20667979 : bbp_distrb = xmpi_undefined_rank
3551 : :
3552 [ + + ]: 713999 : do ib2=1,Wfd%nband(ikp_ibz,spin)
3553 [ + + + - : 40579006 : b_mask = .TRUE.; if (present(bbp_mask)) b_mask = bbp_mask(:,ib2)
+ + ]
3554 [ + + + + : 17923644 : if (ANY(b_mask)) then
+ + ]
3555 [ + + ]: 3759589 : my_nband=0; my_band_list_k=0
3556 : : ! Only the upper triangle of the (b1,b2) matrix.
3557 [ + + + + ]: 654150 : if (firstchar(allup, ["U","u"])) b1_stop = MIN(ib2,Wfd%nband(ik_ibz,spin))
3558 : :
3559 [ + + ]: 3674483 : do ib1=1,b1_stop
3560 [ + + ]: 3674483 : 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 : 2355894 : ncpus=0
3565 : 2355894 : workload_min=HUGE(0)
3566 [ + + ]: 6448460 : do rank=0,Wfd%nproc-1
3567 [ + + + - ]: 6448460 : if( whocan_k(ib1,rank+1)==1 .AND. whocan_kp(ib2,rank+1)==1 ) then
3568 : 3598338 : ncpus=ncpus+1
3569 [ + + ]: 3598338 : if( get_more(rank+1) < workload_min ) then
3570 : 2709322 : idle=rank+1
3571 : 2709322 : workload_min=get_more(idle)
3572 : : end if
3573 : :
3574 : : end if
3575 : : end do
3576 : :
3577 [ + - ]: 2355894 : if(ncpus>0) then
3578 : 2355894 : bbp_distrb(ib1,ib2)=idle-1
3579 : 2355894 : 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 [ - + ]: 42953 : ABI_FREE(whocan_k)
3593 [ - + ]: 42953 : ABI_FREE(whocan_kp)
3594 : :
3595 [ + + + + : 20667979 : my_nbbp = COUNT(bbp_distrb==Wfd%my_rank)
+ + ]
3596 [ + - + + ]: 131056 : if (present(got)) got=get_more
3597 : :
3598 [ + - + - ]: 85906 : 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 : 130795 : 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 [ - + ]: 130795 : want_order=CPR_RANDOM; if (sorted) want_order=CPR_SORTED
3642 : :
3643 [ - + ]: 130795 : ABI_CHECK(wfd%get_wave_ptr(band, ik_ibz, spin, wave, msg) == 0, msg)
3644 : :
3645 : 132520 : select case (wave%has_cprj)
3646 : :
3647 : : case (WFD_NOWAVE, WFD_ALLOCATED)
3648 : : ! Have to calculate it!
3649 [ - + ]: 1725 : 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 : 1725 : call wfd%ug2cprj(band,ik_ibz,spin,choice1,idir0,Wfd%natom,Cryst,Cprj_out,sorted=sorted)
3655 : :
3656 [ + - ]: 1725 : if (wave%has_cprj == WFD_ALLOCATED) then
3657 : : ! Store it.
3658 [ + - ]: 1725 : if (want_order == wave%cprj_order) then
3659 : 1725 : call pawcprj_copy(Cprj_out, wave%Cprj)
3660 : 1725 : 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 [ + - ]: 129070 : if (want_order == wave%cprj_order) then
3684 : 129070 : 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 [ + + - ]: 130795 : ABI_BUG(sjoin("Wrong has_cprj: ", itoa(wave%has_cprj)))
3705 : : end select
3706 : :
3707 : 130795 : 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 : 662 : 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 : 662 : integer,allocatable :: kg_k(:,:)
3743 : : !************************************************************************
3744 : :
3745 [ + + + + : 671 : if (all(Wfd%ngfft(1:3) == new_ngfft(1:3)) ) RETURN ! Nothing to do.
+ + ]
3746 : :
3747 [ + + ]: 659 : 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 [ + + ]: 12521 : Wfd%ngfft = new_ngfft
3753 [ + + ]: 2636 : Wfd%mgfft = MAXVAL(new_ngfft(1:3))
3754 [ + + ]: 2636 : Wfd%nfftot = PRODUCT(new_ngfft(1:3))
3755 : 659 : Wfd%nfft = Wfd%nfftot ! No FFT parallelism.
3756 : :
3757 : : ! Re-initialize fft distribution
3758 : 659 : call Wfd%MPI_enreg%distribfft%free()
3759 : 659 : call Wfd%MPI_enreg%distribfft%init('c',Wfd%MPI_enreg%nproc_fft,new_ngfft(2),new_ngfft(3))
3760 : :
3761 [ + - + - : 1977 : ABI_REMALLOC(Wfd%ph1d,(2,3*(2*Wfd%mgfft+1)*Cryst%natom))
- + + - +
- + - - +
- + - + ]
3762 : 659 : 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 [ + - - + : 2636 : ABI_REMALLOC(Wfd%irottb, (Wfd%nfftot,Cryst%nsym))
+ - - + +
- + - + -
- + - + -
+ ]
3771 : : #endif
3772 : 659 : call rotate_FFT_mesh(Cryst%nsym,Cryst%symrel,Cryst%tnons,Wfd%ngfft,Wfd%irottb,iscompatibleFFT)
3773 : :
3774 [ + + ]: 659 : 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 : 659 : 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 [ + + ]: 1330 : do is=1,size(wfd%s)
3783 [ + + ]: 6362 : do ik=1,size(wfd%s(is)%k)
3784 [ + + ]: 84403 : do ib=1,size(wfd%s(is)%k(ik)%b)
3785 : 83732 : 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 [ + + ]: 5653 : do ik_ibz=1,Wfd%nkibz
3792 [ + - + - : 5987 : if (any(wfd%bks2wfd(1, :, ik_ibz, :) /= 0)) then
+ + + - ]
3793 : 4994 : istwf_k = Wfd%istwfk(ik_ibz)
3794 : 4994 : npw_k = Wfd%Kdata(ik_ibz)%npw
3795 [ - + + - : 14982 : ABI_MALLOC(kg_k, (3,npw_k))
+ - + - -
+ - + -
+ ]
3796 [ + - + - : 6087400 : kg_k = Wfd%Kdata(ik_ibz)%kg_k
- + - - -
- - - + +
+ + ]
3797 : 4994 : call Wfd%Kdata(ik_ibz)%free()
3798 : 4994 : call Wfd%Kdata(ik_ibz)%init(Cryst,Psps,Wfd%kibz(:,ik_ibz),istwf_k,new_ngfft,Wfd%MPI_enreg,kg_k=kg_k)
3799 [ - + ]: 4994 : ABI_FREE(kg_k)
3800 : : end if
3801 : : end do
3802 : :
3803 [ - + ]: 659 : 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 : 488 : 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 [ + + ]: 1952 : type(Wfk_t) :: Wfk
4716 : 488 : type(Hdr_type) :: Hdr
4717 : : type(wave_t),pointer :: wave
4718 : : !arrays
4719 : 488 : 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 : 976 : real(dp),allocatable :: eig_k(:), cg_k(:,:), out_cg(:,:), work(:,:,:,:), allcg_k(:,:)
4723 : 488 : logical,allocatable :: my_readmask(:,:,:)
4724 : : character(len=6) :: tag_spin(2)
4725 : : !************************************************************************
4726 : :
4727 : : ! Keep track of time spent in wfd_read_wfk
4728 : 488 : call timab(300, 1, tsec)
4729 : :
4730 [ - + ]: 488 : 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 : 488 : my_rank = Wfd%my_rank; master = Wfd%master
4737 : 488 : io_comm = wfd%comm; sc_mode = xmpio_collective; master_only = .False.; iread = .True.
4738 : : !if (iomode == IO_MODE_FORTRAN) then
4739 : 488 : 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 : 488 : " with iomode:", iomode2str(iomode),", master_only:", yesno(master_only)), pre_newlines=2)
4745 [ - + ]: 488 : 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 [ + + ]: 488 : if (iread) then
4752 : 428 : wfk_unt = get_unit()
4753 : 428 : call wfk%open_read(wfk_fname, formeig0, iomode, wfk_unt, io_comm, Hdr_out=Hdr)
4754 : : end if
4755 : :
4756 : 488 : if (master_only) call hdr%bcast(wfd%master, wfd%my_rank, wfd%comm)
4757 [ - + ]: 488 : 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 : 488 : fform = 0
4762 [ + + + - ]: 488 : if (wfd%prtvol /= 0 .and. wfd%my_rank == 0) call hdr%echo(fform, 4, unit=std_out)
4763 : :
4764 [ + + ]: 8440 : mband_disk = MAXVAL(Hdr%nband)
4765 [ - + ]: 488 : 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 [ - + ]: 488 : ABI_CHECK_IEQ(wfd%nkibz, hdr%nkpt, "wfd%nkibz != hdr%nkpt")
4769 : 488 : ierr = 0
4770 [ + + ]: 8420 : do ik_ibz=1,wfd%nkibz
4771 [ + + + - : 32216 : 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 [ - + ]: 488 : 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 [ - + + - : 2440 : ABI_MALLOC(my_readmask, (mband_disk, Wfd%nkibz, Wfd%nsppol))
- + + - -
+ + - + -
+ - - + -
+ ]
4782 [ + + + + : 171759 : my_readmask = .False.
+ + ]
4783 : 488 : my_bmin = huge(1); my_bmax = -huge(1)
4784 [ - + + - : 10399 : ABI_ICALLOC(all_countks, (wfd%nkibz, wfd%nsppol))
- + + - +
- + - - +
- + + + +
+ ]
4785 : :
4786 [ + + ]: 983 : do spin=1,Wfd%nsppol
4787 [ + + ]: 8935 : do ik_ibz=1,Wfd%nkibz
4788 [ + + ]: 114910 : do band=1,Wfd%nband(ik_ibz,spin)
4789 [ + + ]: 114415 : if (wfd%ihave_ug(band, ik_ibz, spin)) then
4790 : 68767 : my_bmin = min(my_bmin, band)
4791 : 68767 : my_bmax = max(my_bmax, band)
4792 : 68767 : my_readmask(band, ik_ibz, spin) = .True.
4793 : 68767 : all_countks(ik_ibz, spin) = 1
4794 [ - + ]: 68767 : 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 : 488 : call xmpi_sum(all_countks, wfd%comm, ierr)
4805 : 488 : call xmpi_min(my_bmin, bmin, wfd%comm, ierr)
4806 : 488 : call xmpi_max(my_bmax, bmax, wfd%comm, ierr)
4807 : :
4808 [ + + + + : 171759 : call wrtout(std_out, sjoin(" About to read: ",itoa(count(my_readmask)), " (b, k, s) states in total."))
+ + + + ]
4809 [ + + ]: 983 : do spin=1,wfd%nsppol
4810 : : call wrtout(std_out, sjoin(" For spin:", itoa(spin), &
4811 [ + + + + ]: 8935 : ", will read:", itoa(count(any(my_readmask(:,:,spin), dim=1))), " k-points out of:", itoa(wfd%nkibz)))
4812 : : end do
4813 [ + + + + : 1478 : tag_spin(: )= [' ',' ']; if (Wfd%nsppol==2) tag_spin(:)= [' UP ',' DOWN ']
+ + ]
4814 [ + + ]: 488 : if (wfd%prtvol > 0) call wrtout(std_out,' k eigenvalues [eV]')
4815 : :
4816 : 488 : 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 [ + + ]: 983 : do spin=1,Wfd%nsppol
4898 [ + + ]: 8935 : do ik_ibz=1,Wfd%nkibz
4899 [ + + ]: 7952 : if (all_countks(ik_ibz, spin) == 0) cycle
4900 : 4344 : call cwtime(cpu_ks, wall_ks, gflops_ks, "start")
4901 : : !write(std_out,*)" About to read ik_ibz: ",ik_ibz,", spin: ",spin
4902 : :
4903 : 4344 : npw_disk = Hdr%npwarr(ik_ibz)
4904 : 4344 : nband_disk = Hdr%nband(ik_ibz+(spin-1)*Hdr%nkpt)
4905 : 4344 : istwfk_disk = hdr%istwfk(ik_ibz)
4906 : 4344 : change_gsphere = istwfk_disk /= wfd%istwfk(ik_ibz)
4907 : 4344 : nband_wfd = Wfd%nband(ik_ibz, spin)
4908 : :
4909 [ - + ]: 4344 : 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 [ - + + - : 13032 : ABI_MALLOC(eig_k, ((2*nband_disk)**formeig0*nband_disk))
+ - + - -
+ - + -
+ ]
4917 [ - + + - : 13032 : ABI_MALLOC(kg_k, (3,optkg1*npw_disk))
+ - + - -
+ - + -
+ ]
4918 : :
4919 : : ! Allocate array to store my wavefunctions and read data
4920 [ + + + + ]: 137011 : mcg = npw_disk * wfd%nspinor * count(my_readmask(:, ik_ibz, spin))
4921 : : !print *, "mcg", mcg
4922 [ - + + - : 13032 : 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 [ - + + - : 13032 : ABI_MALLOC_OR_DIE(allcg_k, (2, npw_disk*wfd%nspinor*(bmax-bmin+1)), ierr)
+ - + - +
- + - - +
+ - - + ]
4934 : : !call pstat_proc%print(_PSTAT_ARGS_)
4935 : :
4936 [ + + ]: 4344 : if (my_rank == master) then
4937 [ + + ]: 11040 : 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 : 4344 : call xmpi_bcast(kg_k, wfd%master, wfd%comm, ierr)
4941 : 4344 : call xmpi_bcast(eig_k, wfd%master, wfd%comm, ierr)
4942 : 4344 : call xmpi_bcast(allcg_k, wfd%master, wfd%comm, ierr)
4943 : :
4944 : 4344 : bcount = 0
4945 [ + + ]: 78331 : do band=bmin,bmax
4946 [ + + ]: 78331 : if (my_readmask(band, ik_ibz, spin)) then
4947 : 68767 : bcount = bcount + 1
4948 : 68767 : cg_bpad = npw_disk * wfd%nspinor * (bcount-1)
4949 : 68767 : allcg_bpad = npw_disk * wfd%nspinor * (band - bmin)
4950 : 68767 : call cg_zcopy(npw_disk * wfd%nspinor, allcg_k(:, allcg_bpad+1), cg_k(:, cg_bpad+1))
4951 : : end if
4952 : : end do
4953 [ - + ]: 8688 : ABI_FREE(allcg_k)
4954 : : end if
4955 : :
4956 [ + + + + ]: 4344 : if (Wfd%my_rank == Wfd%master .and. wfd%prtvol > 0) then
4957 [ + + ]: 730 : 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 [ + - + + ]: 13056 : 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 [ - + + - : 13032 : ABI_MALLOC(gf2wfd, (npw_disk))
+ - + - -
+ - + ]
4970 [ + - + + : 5447 : 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 : 4344 : 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 [ + - + + : 5447 : 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 : 4344 : bcount = 0
5000 [ + + ]: 80698 : do band=1,Wfd%nband(ik_ibz,spin)
5001 [ + + ]: 80698 : if (my_readmask(band, ik_ibz, spin)) then
5002 : :
5003 : 68767 : ib = wfd%bks2wfd(1, band, ik_ibz, spin)
5004 : 68767 : ik = wfd%bks2wfd(2, band, ik_ibz, spin)
5005 : 68767 : is = wfd%bks2wfd(3, band, ik_ibz, spin)
5006 [ + + + - : 275068 : ABI_CHECK(all(wfd%bks2wfd(:, band, ik_ibz, spin) /= 0), "state in not allocated")
- + ]
5007 : :
5008 : 68767 : wave => wfd%s(is)%k(ik)%b(ib)
5009 [ + + ]: 31627701 : wave%ug = czero
5010 : :
5011 : 68767 : bcount = bcount + 1
5012 : 68767 : cg_bpad = npw_disk*Wfd%nspinor*(bcount-1)
5013 : : !print *, "Before change_gpshere"
5014 : :
5015 [ + + ]: 68767 : 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 [ + + ]: 132130 : do spinor=1,Wfd%nspinor
5025 : 66529 : cg_spad=(spinor-1)*npw_disk
5026 : 66529 : gw_spad=(spinor-1)*Wfd%npwarr(ik_ibz)
5027 [ + + ]: 28115060 : do ig=1,npw_disk
5028 : 27982930 : icg = ig+cg_spad+cg_bpad
5029 : 27982930 : igw = gf2wfd(ig)+gw_spad
5030 [ + + ]: 28049459 : if (gf2wfd(ig) /= 0) then
5031 : 27436610 : 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 : 68767 : wave%has_ug = WFD_STORED
5039 : : end if
5040 : : end do
5041 : :
5042 [ - + ]: 4344 : ABI_FREE(eig_k)
5043 [ - + ]: 4344 : ABI_FREE(kg_k)
5044 [ - + ]: 4344 : ABI_FREE(cg_k)
5045 [ - + ]: 4344 : ABI_FREE(gf2wfd)
5046 [ + + ]: 4344 : ABI_SFREE(work)
5047 [ + + ]: 4344 : ABI_SFREE(out_cg)
5048 : :
5049 [ + + + - ]: 9183 : if (ik_ibz <= 10 .or. mod(ik_ibz, 200) == 0) then
5050 : 2782 : write(msg,'(4x,4(a,i0),a)') "Reading kpt [", ik_ibz, "/", wfd%nkibz, "] spin [", spin, "/", wfd%nsppol, "]"
5051 : 2782 : 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 : 488 : call wfk%close(); call Hdr%free()
5061 : :
5062 [ - + ]: 488 : ABI_FREE(my_readmask)
5063 [ - + ]: 488 : 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 : 394 : call wfd%update_bkstab()
5069 : : end select
5070 : :
5071 : 488 : call cwtime_report(" WFK IO", cpu, wall, gflops, end_str=ch10)
5072 : 488 : call timab(300, 2, tsec)
5073 : :
5074 [ - + - + : 1952 : 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 : 466 : 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 : 466 : integer,allocatable :: irrzon(:,:,:)
5795 : 466 : real(dp),allocatable :: phnons(:,:,:),rhog(:,:),rhor_down(:),rhor_mx(:),rhor_my(:),cwavef(:,:)
5796 : 466 : complex(dp),allocatable :: wfr_x(:),wfr_y(:)
5797 : 466 : complex(gwp),allocatable :: gradug(:),work(:)
5798 : 466 : complex(gwp),allocatable,target :: wfr(:)
5799 : 466 : complex(gwp), contiguous, pointer :: cwavef1(:),cwavef2(:)
5800 : 466 : type(iter2_t) :: Iter_bks
5801 : : !*************************************************************************
5802 : :
5803 : : ! Consistency check.
5804 : 0 : ABI_CHECK(Wfd%nsppol == ebands%nsppol, "Mismatch in nsppol")
5805 : :
5806 [ + + + + : 895 : 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 [ - + + - : 1398 : ABI_MALLOC(wfr, (nfftf*Wfd%nspinor))
+ - + - -
+ - + ]
5810 : :
5811 [ + + ]: 466 : 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 : 466 : call wfd%update_bkstab()
5822 : :
5823 : : ! Calculate the unsymmetrized density.
5824 [ + + + + ]: 8289368 : rhor=zero
5825 [ - + ]: 466 : myoptcalc=0; if (present(optcalc)) myoptcalc=optcalc
5826 [ - + ]: 466 : nalpha=1; if (myoptcalc==1) nalpha=3
5827 [ - + - - ]: 466 : 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 [ + - + + : 67599 : Iter_bks = wfd%iterator_bks(bks_mask=ABS(ebands%occ)>=tol8)
+ + + + ]
5833 : :
5834 [ + + ]: 932 : do alpha=1,nalpha
5835 [ + + ]: 1407 : do is=1,Wfd%nsppol
5836 [ + + ]: 4436 : do ik=1,Wfd%nkibz
5837 [ + + ]: 16532 : do ib_iter=1,iter_len(Iter_bks,ik,is)
5838 : 12562 : ib = iter_yield(Iter_bks,ib_iter,ik,is)
5839 : 12562 : bks_weight = ebands%occ(ib,ik,is) * ebands%wtk(ik) / Cryst%ucvol
5840 : :
5841 : 12562 : call wfd%get_ur(ib,ik,is,wfr)
5842 : :
5843 : 12562 : cwavef1 => wfr(1:nfftf)
5844 [ - + ]: 12562 : 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 [ + + ]: 119880262 : do ir=1,nfftf
5878 : 119880262 : 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 [ + + ]: 12562 : 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 [ + + ]: 16057 : 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 : 466 : call iter_free(Iter_bks)
5908 : :
5909 : 466 : select case (myoptcalc)
5910 : : case (0)
5911 : : ! density
5912 [ + + ]: 466 : 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 [ + - - ]: 466 : ABI_ERROR(sjoin("Wrong myoptcalc:", itoa(myoptcalc)))
5923 : : end select
5924 : :
5925 : 466 : call xmpi_sum(rhor,Wfd%comm,ierr)
5926 : :
5927 : : ! Symmetrization in G-space implementing also the AFM case
5928 : 466 : n1=ngfftf(1); n2=ngfftf(2); n3=ngfftf(3); nfftotf=n1*n2*n3
5929 : :
5930 [ - + + - : 1864 : ABI_MALLOC(irrzon,(nfftotf**(1-1/Cryst%nsym),2,(Wfd%nspden/Wfd%nsppol)-3*(Wfd%nspden/4)))
- + + - +
- + - - +
- + ]
5931 [ - + + - : 1864 : ABI_MALLOC(phnons,(2,nfftotf,(Wfd%nspden/Wfd%nsppol)-3*(Wfd%nspden/4)))
- + + - +
- + - - +
- + ]
5932 : :
5933 [ + - ]: 466 : if (Cryst%nsym/=1) then
5934 : 466 : 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 : 466 : cplex=1
5939 [ - + + - : 1398 : 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 : 466 : Cryst%nsym,phnons,rhog,rhor,Cryst%rprimd,Cryst%symafm,Cryst%symrel,Cryst%tnons)
5943 : :
5944 [ - + ]: 466 : ABI_FREE(rhog)
5945 [ - + ]: 466 : ABI_FREE(phnons)
5946 [ - + ]: 466 : 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 [ + + ]: 7821113 : write(msg,'(a,f9.4)')' planewave contribution to nelect: ',SUM(rhor(:,1))*Cryst%ucvol/nfftf
5954 : 466 : call wrtout(std_out, msg)
5955 : :
5956 [ + + ]: 466 : 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 [ - + ]: 466 : ABI_FREE(wfr)
5963 : :
5964 [ + + ]: 466 : 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 [ - + - + : 932 : 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 : 461 : 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 [ + + ]: 461 : if (usepaw==1) then
6016 : : !if (usepaw==1.and.usexcnhat>0) then ! TODO I still dont understand this if!
6017 : 15 : write(msg,'(4a)')ch10,' PAW TEST:',ch10,' ==== Compensation charge inside spheres ============'
6018 [ + - + - ]: 15 : if (compch_sph<greatest_real.and.compch_fft<greatest_real) &
6019 : 15 : write(msg,'(3a)')TRIM(msg),ch10,' The following values must be close...'
6020 [ + - ]: 15 : if (compch_sph<greatest_real) &
6021 : 15 : write(msg,'(3a,f22.15)')TRIM(msg),ch10,' Compensation charge over spherical meshes = ',compch_sph
6022 [ + - ]: 15 : if (compch_fft<greatest_real) then
6023 [ + + ]: 15 : if (usefinegrid==1) then
6024 : 9 : 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 [ + + ]: 45 : call wrtout([std_out, ab_out], msg)
6030 : 15 : write(msg,'(a)')ch10
6031 [ + + ]: 45 : call wrtout([std_out, ab_out], msg)
6032 : : end if !PAW
6033 : :
6034 [ + + ]: 7802108 : nelectron_pw =SUM(rhor(:,1))*ucvol/nfftf
6035 : 461 : nelectron_tot=nelectron_pw
6036 : 461 : nratio =nelectron_exp/nelectron_tot
6037 : :
6038 [ + + ]: 461 : if (usepaw==1) then
6039 : 15 : nelectron_sph=nelectron_pw+compch_sph
6040 : 15 : nelectron_fft=nelectron_pw+compch_fft
6041 : 15 : nelectron_tot=nelectron_sph
6042 : 15 : nratio=(nelectron_exp-nelectron_sph)/nelectron_pw
6043 : : end if
6044 : :
6045 : 461 : rhoav=nelectron_tot/ucvol ; rs=(three/(four_pi*rhoav))**third
6046 [ + + ]: 461 : if (usepaw==0) then
6047 : : write(msg,'(2(a,f9.4))')&
6048 : 446 : ' Number of electrons calculated from density = ',nelectron_tot,'; Expected = ',nelectron_exp
6049 : : else
6050 : : write(msg,'(2(a,f9.4),a)')&
6051 : 15 : ' Total number of electrons per unit cell = ',nelectron_sph,' (Spherical mesh), ',nelectron_fft,' (FFT mesh)'
6052 : : end if
6053 [ + + ]: 1383 : 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 : 461 : write(msg,'(a,f9.6)')' average of density, n = ',rhoav
6059 [ + + ]: 1383 : call wrtout([std_out, ab_out], msg)
6060 : 461 : write(msg,'(a,f9.4)')' r_s = ',rs
6061 [ + + ]: 1383 : call wrtout([std_out, ab_out], msg)
6062 : 461 : omegaplasma=SQRT(four_pi*rhoav)
6063 : 461 : write(msg,'(a,f9.4,2a)')' omega_plasma = ',omegaplasma*Ha_eV,' [eV]',ch10
6064 [ + + ]: 1383 : call wrtout([std_out, ab_out], msg)
6065 : :
6066 : 461 : 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 [ + + + + : 16330 : end module m_wfd
+ + + + +
- - + - +
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
6341 : : !!***
|
