Line data Source code
1 : !!****m* ABINIT/m_gstore
2 : !! NAME
3 : !! m_gstore
4 : !!
5 : !! FUNCTION
6 : !! This module implements the gstore_t object that allows one to **precompute"" the e-ph matrix elements g
7 : !! and store them in memory with a MPI-distributed data structure.
8 : !! This approach is the most CPU-efficient one when one has to deal with
9 : !! algorithms in which the same g(q, k) is required several (many) times.
10 : !! Typical examples are iterative solvers for non-linear equations that are called inside a loop over T.
11 : !! At each iteration, indeed, we need g(q, k) and computing these quantities from scratch
12 : !! would be very expensive.
13 : !!
14 : !! Note that g depends on the two wave vectors (q, k), two electron band indices (m, n),
15 : !! phonon mode nu with crystalline momentum q and spin index if nsppol == 2 (collinear case).
16 : !!
17 : !! g(q, k) is therefore a sloppy notation for:
18 : !!
19 : !! g(q, k) = <k+q,m,spin| \Delta_{q,\nu} V^{spin}_{scf} |k,n,spin>
20 : !!
21 : !! There are lots of technical details that should be discussed but, roughly speaking,
22 : !! the gstore API allows one to:
23 : !!
24 : !! - select whether q or k should be in the IBZ or in the BZ.
25 : !! NB: It is not possible to use the IBZ both for q and k as g(Sk, q) = g(k, S^{-1}q)
26 : !! thus one has to select the appropriate zones beforehand.
27 : !!
28 : !! - filter bands and/or k/q wavevectors according to some criterion.
29 : !! In superconductors, for instance, only k/k+q states on the Fermi surface are usually needed.
30 : !! In semiconductors, one can include only k, k+q inside an energy window around the band edge.
31 : !! for transport properties or just the |n,k,spin> states at the band edges while <k+q,m,spin|
32 : !! have q in the BZ and m=1,nband.
33 : !!
34 : !! - whether the code should compute and store the complex valued g or |g|^2.
35 : !! Expression depending of |g|^2 are gauge-invariant provided that all degenerate states are summed over.
36 : !! On the contrary, the complex valued g is gauge-dependent and hic sunt leones.
37 : !! In Abinit, the g elements are computed within the same gauge by reconstructing Bloch states
38 : !! in the BZ from the IBZ by using a deterministic symmetrization algorithm
39 : !! Client code reading the e-ph matrix elements produced by ABINIT is expected to follow the
40 : !! same conventions, especially if one needs to mix g with wavefunctions in the BZ.
41 : !!
42 : !! At the level of the API, we have three different routines.
43 : !!
44 : !! 1) gstore_init builds the object, defines the BZ sampling type (e.g. k in the IBZ, q in the BZ)
45 : !! and implements filtering techniques. The MPI grid is automatically generated at this level.
46 : !!
47 : !! 2) gstore_compute evaluates the KS e-ph matrix elements in parallel and dumps the results to GSTORE.nc.
48 : !!
49 : !! 3) gstore%from_ncpath reconstructs the object from a GSTORE.nc file.
50 : !!
51 : !! In a typical scenario, one uses eph_task 11 to generate GSTORE.nc i.e. steps 1) and 2).
52 : !! Then one introduces a new value of eph_task in which we read the object from file and call
53 : !! a specialized routine that implements the "post-processing" steps needed
54 : !! to compute the physical properties of interest.
55 : !!
56 : !! Last but not least, the GSTORE.nc file can also produced by gwpt_run (eph_task 17).
57 : !! In this case, gvals are the matrix elements computed with the variation of the self-energy
58 : !! instead of the KS Hamiltonian.
59 : !!
60 : !! Now, let us discuss the MPI-distribution.
61 : !!
62 : !! The (q, k) matrix is distributed inside a 2D cartesian grid using block distribution.
63 : !! This is schematic representation for MPI 4 procs with 2 procs for k and 2 procs for q:
64 : !!
65 : !! k-axis (kpt_comm)
66 : !! |--------------------
67 : !! | | |
68 : !! | P00 | P01 |
69 : !! | | |
70 : !! q-axis |--------------------
71 : !! (qpt_comm) | | |
72 : !! | P10 | P11 |
73 : !! | | |
74 : !! |--------------------
75 : !!
76 : !! Each MPI processor stores all the (band_kq, band_k) transitions for a given (q, k) pair.
77 : !!
78 : !! Perturbations can be optionally distributed along a third axis (pert_comm).
79 : !! Note, however, that the parallelism over perturbations is not expected to be the most efficient
80 : !! although it allows one to reduce the memory required to store the scattering potential in the supercell
81 : !! as we can distribute W(r, R, 3 * natom) over the last dimension.
82 : !!
83 : !! For electronic properties, one usually uses k-points in the IBZ and q-points in the BZ.
84 : !! hence the parallelism over q-points is the most efficient one in terms of wall-time.
85 : !! Keep in mind, however, that the k-point parallelism allows one to reduce the memory allocated for the
86 : !! wavefunctions. Using some procs for k-points is also beneficial in terms of performance
87 : !! as we can reduce load imbalance is the number of procs in qpt_comm does not divide nqbz.
88 : !!
89 : !! NB: If nsppol == 2, we create two gqk instances, one for each spin.
90 : !! The reason is that dimensions such as the number of effective bands/q-points/k-points
91 : !! depends on the collinear spin when filters are employed.
92 : !!
93 : !! TODO
94 : !! - Implement possibility of reading a subset of data (bands) from a larger gstore ?
95 : !! - Optimize v^1_loc|psi_nk> by precomputing <r|psi_nk> before the loop over my_npert
96 : !! Big speedup is expected, especially if one loops first over k and then q, provided
97 : !! the interpolation of v^1_q does not start to dominate.
98 : !! - Use similar trick in dfpt_cgw for H^0 |psi_nk>.
99 : !! - Operate on multiple n states in getgh1c (new version of getgh1c allows it).
100 : !! - Write IFC to faciliate interporability with external codes (DONE)
101 : !! - Save alpha parameters so that external codes can handle the short range part of the IFCs (DONE)
102 : !! - Move to atom representation and add symmetry tables qbz --> qibz to fix the gauge in the ph displacements.
103 : !! - Write GSTORE tutorial to explain all the relevant combinations.
104 : !!
105 : !! COPYRIGHT
106 : !! Copyright (C) 2008-2026 ABINIT group (MG)
107 : !! This file is distributed under the terms of the
108 : !! GNU General Public License, see ~abinit/COPYING
109 : !! or http://www.gnu.org/copyleft/gpl.txt .
110 : !!
111 : !! SOURCE
112 :
113 : #if defined HAVE_CONFIG_H
114 : #include "config.h"
115 : #endif
116 :
117 : #include "abi_common.h"
118 :
119 : module m_gstore
120 :
121 : use, intrinsic :: iso_c_binding
122 : use defs_basis
123 : use m_abicore
124 : use m_clib
125 : use m_xmpi
126 : use m_errors
127 : use m_htetra
128 : use libtetrabz
129 : use netcdf
130 : use m_nctk
131 : use m_ddb
132 : use m_ddk
133 : use m_dvdb
134 : use m_fft
135 : use m_hamiltonian
136 : use m_pawcprj
137 : use m_ephtk
138 : use m_mkffnl
139 : use m_sigtk
140 :
141 : use defs_abitypes, only : mpi_type
142 : use defs_datatypes, only : pseudopotential_type
143 : use m_dtset, only : dataset_type
144 : use m_dtfil, only : datafiles_type
145 : use m_time, only : cwtime, cwtime_report, sec2str
146 : use m_fstrings, only : tolower, itoa, ftoa, sjoin, ktoa, ltoa, strcat, replace_ch0, yesno, string_in
147 : use m_numeric_tools, only : arth, get_diag, isdiagmat, safe_div, r2c
148 : use m_krank, only : krank_t, get_ibz2bz, star_from_ibz_idx
149 : use m_io_tools, only : iomode_from_fname, file_exists
150 : use m_special_funcs, only : gaussian
151 : use m_geometry, only : phdispl_cart2red_nmodes
152 : use m_copy, only : alloc_copy
153 : use m_fftcore, only : ngfft_seq, get_kg, sphereboundary
154 : use m_cgtools, only : cg_zdotc, cg_p_psi
155 : use m_kg, only : getph
156 : use m_crystal, only : crystal_t
157 : use m_hdr, only : hdr_type, fform_from_ext
158 : use m_matrix, only : mati3inv, matr3inv
159 : use m_kpts, only : kpts_ibz_from_kptrlatt, kpts_timrev_from_kptopt, kpts_map, kpts_sort, kpts_pack_in_stars, &
160 : kptrlatt_from_ngkpt
161 : use m_ebands, only : ebands_t, gaps_t
162 : use m_lgroup, only : lgroup_t
163 : use m_bz_mesh, only : kmesh_t, isamek
164 : use m_getgh1c, only : getgh1c, rf_transgrid_and_pack
165 : use m_ifc, only : ifc_type
166 : use m_phonons, only : pheigvec_rotate
167 : use m_wfd, only : wfd_t
168 : use m_pawang, only : pawang_type
169 : use m_pawrad, only : pawrad_type
170 : use m_pawtab, only : pawtab_type
171 : use m_pawfgr, only : pawfgr_type
172 : use m_mlwfovlp, only : wan_t, wan_interp_ebands
173 : use m_pstat, only : pstat_proc
174 : use m_io_screening, only : hscr_t, get_hscr_qmesh_gsph
175 : use m_gsphere, only : gsphere_t
176 : use m_abi_linalg, only : abi_gpu_xgemm_d
177 : use m_classify_bands, only : dmats_t
178 :
179 : implicit none
180 :
181 : private
182 :
183 : character(len=abi_slen),public,parameter :: GSTORE_GMODE_ATOM = "atom"
184 : character(len=abi_slen),public,parameter :: GSTORE_GMODE_PHONON = "phonon"
185 : character(len=abi_slen),public,parameter :: GSTORE_GTYPE_KS = "KS"
186 : character(len=abi_slen),public,parameter :: GSTORE_GTYPE_GWPT = "gwpt"
187 :
188 : ! Flags
189 : integer, public :: GSTORE_KQ_MISSING = 0 ! (k, q, spin) has not been computed.
190 : integer, public :: GSTORE_KQ_COMPUTED = 1 ! (k, q, spin) has been computed.
191 : integer, public :: GSTORE_KQ_SYMMETRIZED = 2 ! (k, q, spin) has been reconstructed by symmetry.
192 :
193 : ! Rank of the MPI Cartesian grid.
194 : integer,private,parameter :: ndims = 6
195 : !!***
196 :
197 : !----------------------------------------------------------------------
198 :
199 : !!****t* m_gstore/gqk_t
200 : !! NAME
201 : !! gqk_t
202 : !!
203 : !! FUNCTION
204 : !! This object stores MPI-distributed e-ph matrix elements for
205 : !! a given spin index (if collinear magnetism i.e. nsppol 2).
206 : !! Local dimensions and arrays start with `my_`, global dimensions start with `glob_`
207 : !!
208 : !! SOURCE
209 :
210 : type, public :: gqk_t
211 :
212 : integer :: cplex = -1
213 : ! 1 if |g|^2 is stored
214 : ! 2 if complex-valued g are stored (mind the gauge)
215 :
216 : integer :: spin = -1
217 : ! Spin index.
218 :
219 : integer :: natom3 = -1
220 : ! 3 * natom
221 : ! Mainly used to dimension arrays
222 :
223 : integer :: nb_kq = -1, nb_k = -1
224 : ! Number of bands included in the calculation at k+q and k, for this spin.
225 : ! Global as these dimensions are NOT DISTRIBUTED with MPI
226 : ! NB: nb_kq and nb_k are not necessarily equal to nband.
227 : ! Use bstar_kq and bstart_k to get the band index, e.g.:
228 : !
229 : ! do in_k=1,gqk%nb_k
230 : ! band_k = in_k + gqk%bstart_k - 1
231 : !
232 : ! do imq_k=1,gqk%nb_kq
233 : ! band_kq = im_kq + gqk%bstart_kq - 1
234 :
235 : integer :: bstart_k = -1, bstop_k = -1
236 : integer :: bstart_kq = -1, bstop_kq = -1
237 : ! The first band at k starts at bstart_k.
238 : ! The last band at k is bstop_k (NB: These are global indices)
239 : ! Same meaning for bstart_kq and bstop_kq.
240 :
241 : integer :: my_npert = -1
242 : ! Number of perturbations treated by this MPI rank.
243 :
244 : integer :: my_pert_start = -1
245 : ! Initial perturbation treated by this MPI proc
246 :
247 : integer :: glob_nk = -1, glob_nq = -1
248 : ! Total number of k/q points in global matrix.
249 : ! Note that k-points/q-points can be filtered. Use kzone, qzone and kfilter to interpret these dimensions.
250 :
251 : integer :: my_nk = -1, my_nq = -1
252 : ! Number of k/q points treated by this MPI proc. Used to loop and allocate local arrays.
253 :
254 : integer :: my_kstart = -1, my_qstart = -1
255 : ! Index of the first k/q point in the global matrix treated by this MPI proc
256 :
257 : integer,allocatable :: my_k2ibz(:,:)
258 : ! (6, my_nk)
259 : ! Mapping my_kpoints --> kibz (symrel conventions)
260 :
261 : !integer,allocatable :: my_k2bz(:,:)
262 : ! (my_nk)
263 : ! Mapping my_kpoints --> ik_bz
264 :
265 : real(dp),allocatable :: my_kpts(:,:)
266 : ! (3, my_nkpt)
267 : ! k-points treated by this MPI proc.
268 :
269 : real(dp),allocatable :: my_wtk(:)
270 : ! (my_nkpt)
271 : ! Weights for the k-points treated by this MPI proc.
272 :
273 : integer,allocatable :: my_q2ibz(:,:)
274 : ! (6, my_nq)
275 : ! Mapping my_qpoints --> qibz
276 : ! symrel conventions
277 :
278 : integer,allocatable :: my_q2bz(:)
279 : ! (my_nq)
280 : ! Mapping my_iq index --> iq_bz index in the full BZ
281 :
282 : integer,allocatable :: my_k2glob(:)
283 : ! (my_nk)
284 : ! Mapping my_ik index --> global index in the g(q, k) matrix.
285 :
286 : integer,allocatable :: my_q2glob(:)
287 : ! (my_nq)
288 : ! Mapping my_iq index --> global index in the g(q, k) matrix.
289 :
290 : real(dp),allocatable :: vnk_cart_ibz(:,:,:)
291 : ! (3, nb_k, nkibz)
292 : ! Diagonal v_{n,k} for k in the IBZ.
293 : ! Values in the BZ can be reconstructed by symmetry.
294 : ! Allocated if gstore%with_vk == 1
295 : ! TODO: Here I should decide how to treat nb_k, nk_kq
296 :
297 : real(dp),allocatable :: vnk_mat_cart_ibz(:,:,:,:,:)
298 : ! (3, nb_k, nb_k, nkibz)
299 : ! v_{m, n,k} for the k in the IBZ
300 : ! Allocated if gstore%with_vk in (1, 2)
301 : ! TODO: Here I should decide how to treat nb_k, nk_kq
302 :
303 : integer,allocatable :: my_pertcases(:)
304 : ! (my_npert)
305 : ! List of perturbation indices treated by this MPI proc.
306 : ! Contiguous indices.
307 :
308 : logical :: has_both_g = .False.
309 : ! True if my_g_ks pointer is allocated and use to store the KS matrix elements
310 : ! In this case, my_g stores the GWPT matrix elements.
311 :
312 : complex(dp), allocatable :: my_g(:,:,:,:,:)
313 : complex(dp), contiguous, pointer :: my_g_ks(:,:,:,:,:) => null()
314 : ! (my_npert, nb_kq, my_nq, nb_k, my_nk)
315 : ! ( p, b1_kq, q, b2_k, k) --> <k+q, b1| D_{q,p}H |k, b2>
316 : ! e-ph matrix elements g (local buffer). Allocated if cplex == 2
317 :
318 : real(dp), allocatable :: my_g2(:,:,:,:,:)
319 : real(dp), contiguous, pointer :: my_g2_ks(:,:,:,:,:) => null()
320 : ! (my_npert, nb_kq, my_nq, nb_k, my_nk)
321 : ! e-ph matrix elements g^2 (local buffer).
322 :
323 : real(dp), allocatable :: my_gdw2(:,:,:,:,:)
324 : real(dp), contiguous, pointer :: my_gdw2_ks(:,:,:,:,:) => null()
325 : ! (my_npert, nb_kq, my_nq, nb_k, my_nk)
326 : ! gDW^2 (local buffer) (only for diagonal DW self-energy in the RIA)
327 :
328 : complex(dp), allocatable :: my_iv1p_comm(:,:,:,:,:)
329 : ! (nb_k, nb_k, 3, my_npert, my_nk))
330 : ! Stores i <psi_mk[V1_q0ka, p]|psi_nk> in reduced coordinates.
331 : ! Can be used to compute non-diagonal DW self-energy in the RIA. See [[cite:Lihm2020]], PhysRevB.101.121102
332 : ! Note that in the present implementation both m and n indices run from bstart_k to bstop_k.
333 :
334 : integer :: coords_qkpb_sumbp(ndims) = 0
335 : ! Coordinates of this processor in the (q, k, pert, band, band_sum, pp_sum) Cartesian grid.
336 :
337 : type(xcomm_t) :: kpt_comm
338 : ! MPI communicator over k-points
339 :
340 : type(xcomm_t) :: qpt_comm
341 : ! MPI communicator over q-points
342 :
343 : type(xcomm_t) :: qpt_kpt_comm
344 : ! MPI communicator over k/q subgrid
345 :
346 : type(xcomm_t) :: pert_comm
347 : ! MPI communicator over atomic perturbations.
348 :
349 : type(xcomm_t) :: band_comm
350 : ! MPI communicator for band distribution.
351 :
352 : type(xcomm_t) :: bsum_comm
353 : ! MPI communicator over bands in summation. NB: It is not used to distribute
354 : ! the memory for the g but to distribute a possible sum over bands as done in the GWPT code.
355 :
356 : type(xcomm_t) :: pp_sum_comm
357 : ! MPI communicator over wavevector summation. NB: It not used to distribute
358 : ! the memory for the g but to distribute a possible sum over wavevectors as done in the GWPT code.
359 :
360 : type(xcomm_t) :: qpt_pert_comm
361 : ! MPI communicator over the 2d grid (qpt, atomic perturbations)
362 :
363 : type(xcomm_t) :: pert_ppsum_comm
364 : ! MPI communicator over the 2d grid (atomic perturbations, pp_sum) used in GWPT
365 :
366 : type(xcomm_t) :: pert_ppsum_bsum_comm
367 : ! MPI communicator over the 3d grid (atomic perturbations, pp_sum, band_sum) used in GWPT
368 :
369 : type(xcomm_t) :: comm
370 : ! MPI communicator for full grid of procs treating this spin.
371 :
372 : type(wan_t) :: wan
373 : ! Object used to interpolate the e-ph matrix elements with Wannier.
374 :
375 : real(dp),allocatable :: my_wnuq(:,:)
376 : ! (my_npert, my_nq)
377 : ! Phonon frequencies in Ha (MPI distributed).
378 :
379 : real(dp),allocatable :: my_displ_cart(:,:,:,:,:)
380 : ! (2, 3, natom, my_npert, my_nq))
381 : ! Phonon displacements (MPI distributed).
382 : ! Reconstructed by symmetry from the IBZ (see pheigvec_rotate)
383 : ! Don't use ifc%fourq as this would break the gauge.
384 :
385 : contains
386 :
387 : procedure :: gather => gqk_gather
388 : ! Gather the MPI-distributed matrix elements for a given k/q-point index
389 :
390 : procedure :: get_erange_mask => gqk_get_erange_mask
391 : ! Compute MPI-distributed & global mask for electronic states allowed by energy filtering
392 :
393 : procedure :: filter_erange => gqk_filter_erange
394 : ! Nullify all matrix elements connecting electronic states outside of specified erange
395 :
396 : procedure :: myqpt => gqk_myqpt
397 : ! Return the q-point and the weight from my local index my_iq
398 :
399 : procedure :: dbldelta_qpt => gqk_dbldelta_qpt
400 : ! Compute weights for the double delta.
401 :
402 : procedure :: free => gqk_free
403 : ! Free memory
404 :
405 : end type gqk_t
406 : !!***
407 :
408 : !----------------------------------------------------------------------
409 :
410 : !!****t* m_gstore/gstore_t
411 : !! NAME
412 : !! gstore_t
413 : !!
414 : !! FUNCTION
415 : !! This object stores:
416 : !!
417 : !! - pointers to the crystal structure, the KS bands, the IFCs.
418 : !! - arrays that do not depend on the spin such as the IBZ and weights for k/q-points.
419 : !! - metadata such as kzone, qzone and kfilter that are needed to interpret
420 : !! the storage mode used for the g(k,q).
421 : !!
422 : !! NB: the e-ph matrix elements are stored in gstore%gqk(my_is) where my_is counts
423 : !! the number of collinear spins treated by this MPI processor.
424 : !!
425 : !! SOURCE
426 :
427 : type, public :: gstore_t
428 :
429 : integer :: nsppol
430 : ! Number of independent spin polarizations.
431 :
432 : integer :: my_nspins = 0
433 : ! Number of collinear spins treated by this MPI rank
434 :
435 : integer :: nkibz = -1, nqibz = -1
436 : ! Number of k/q points in the IBZ.
437 :
438 : integer :: nkbz = -1, nqbz = -1
439 : ! Number of k/q points in the BZ.
440 :
441 : integer :: comm
442 : ! Global communicator
443 : ! Inherited by the caller thus we don't free it in gstore_free.
444 :
445 : integer :: with_vk = 0
446 : ! 0 if group velocities should not be computed
447 : ! 1 to compute diagonal terms only
448 : ! 2 to compute diagonal and off-diagonal terms
449 :
450 : integer :: qptopt = -1
451 : ! option for the generation of q points (defines whether spatial symmetries and/or time-reversal can be used)
452 :
453 : integer :: has_used_lgk = 0
454 : ! value of use_lgk used to generate GSTORE.nc (read from file).
455 :
456 : integer :: has_used_lgq = 0
457 : ! value of use_lgq used to generate GSTORE.nc (read from file).
458 :
459 : character(len=fnlen) :: path = " "
460 : ! Path to the nc file associated to the gstore
461 :
462 : character(len=fnlen) :: wfk0_path = " "
463 :
464 : character(len=abi_slen) :: kzone = " ", qzone = " "
465 : ! Specifies whether k- or q-points are in the BZ or in the IBZ.
466 : ! Possible values are "ibz" or "bz".
467 : ! Note that the combination ("ibz", "ibz") is not allowed.
468 :
469 : character(len=abi_slen) :: kfilter = "none"
470 : ! Specifies the technique used to filter k-points.
471 : ! Possible values: "none", "fs_tetra", "erange", "qprange"
472 :
473 : character(len=abi_slen) :: gmode = "atom"
474 : ! "phonon" or "atom"
475 :
476 : character(len=abi_slen) :: gtype = GSTORE_GTYPE_KS
477 : ! Formalism used to compute g(k,q). Either KS or GWPT
478 :
479 : real(dp),allocatable :: erange_spin(:, :)
480 : ! (2, nsppol)
481 : ! Energy window. zero if not used. Requires kfilter == "erange"
482 :
483 : type(crystal_t), pointer :: cryst => null()
484 : ! Crystalline structure
485 :
486 : type(ebands_t), pointer :: ebands => null()
487 : ! Electron bands
488 :
489 : logical :: has_wannier = .False.
490 : ! True when electronic bands and e-ph matrix elements are obtained with
491 : ! Wannier interpolation from ABIWAN.nc and GWAN.nc.
492 :
493 : type(ifc_type), pointer :: ifc => null()
494 : ! interatomic force constants.
495 :
496 : type(dataset_type), pointer :: dtset => null()
497 : ! Reference to the dataset.
498 :
499 : type(krank_t) :: krank_ibz, qrank_ibz
500 : ! Object used to find k-points or q-points in the IBZ and map BZ to IBZ.
501 :
502 : integer :: ngqpt(3) = 0
503 : ! Number of grid points for q-points (either from ddb_ngqpt or eph_ngqpt_fine)
504 :
505 : integer,allocatable :: my_spins(:)
506 : ! (%my_nspins)
507 : ! Indirect table giving the spin indices treated by this MPI rank.
508 : ! Used only in the collinear case with nsppol = 2 and nspinor == 1
509 :
510 : integer,allocatable :: brange_k_spin(:, :)
511 : integer,allocatable :: brange_kq_spin(:, :)
512 : ! (2, nsppol)
513 : ! Range of bands for each spin at k and k+q.
514 : ! These are a global variable
515 :
516 : !integer :: max_nb = -1
517 : ! Max number of bands over spin
518 :
519 : integer,allocatable :: glob_nk_spin(:), glob_nq_spin(:)
520 : ! (nsppol)
521 : ! Total number of k/q points for each spin after filtering (if any).
522 :
523 : integer,allocatable :: kglob2bz(:,:)
524 : ! (max_nk, nsppol))
525 : ! Mapping ik_glob to BZ index for k-points.
526 :
527 : !integer,allocatable qglob2bz(:,:)
528 : ! (max_nq, nsppol))
529 : ! Mapping iq_glob to BZ index for q-points.
530 :
531 : integer,allocatable :: kbz2ibz(:,:)
532 : ! (6, gstore%nkbz))
533 : ! Mapping BZ --> IBZ (symrel conventions that can be used to symmetrize wavefunctions)
534 :
535 : real(dp), contiguous, pointer :: kibz(:,:)
536 : ! k-points in the IBZ. Points to ebands%kptns
537 : ! (3, nkibz)
538 :
539 : real(dp),allocatable :: delta_ef_kibz_spin(:,:,:)
540 : ! (nb, gstore%nkibz, nsppol))
541 : ! Tetrahedron weights at eF in the IBZ.
542 :
543 : real(dp), allocatable :: qibz(:,:)
544 : ! (3, nqibz)
545 : ! q-points in the IBZ in reduced coordinates.
546 :
547 : real(dp), allocatable :: wtq(:)
548 : ! (nqibz)
549 : ! q-points weights in the IBZ
550 :
551 : real(dp),allocatable :: qbz(:,:)
552 : ! q-points in the BZ.
553 : ! TODO: Use MPI shared memory?
554 :
555 : real(dp),allocatable :: kbz(:,:)
556 : ! k-points in the BZ.
557 : ! TODO: Use MPI shared memory?
558 :
559 : integer :: with_cplex = -1
560 : ! Representation of the e-ph matrix elements materialized in memory:
561 : ! 0: no matrix elements, 1: squared moduli in gqk%my_g2, 2: complex values in gqk%my_g.
562 : ! This state is independent of the representation stored in a GSTORE.nc file.
563 :
564 : !integer :: qptrlatt(3, 3) = -1 ! kptrlatt(3, 3) = -1,
565 : ! k-mesh and q-mesh
566 :
567 : !real(dp),allocatable :: kshift(:, :), qshift(:, :)
568 : ! k/q-mesh shift (well, q-mesh is usually gamma-centered)
569 :
570 : type(gqk_t), allocatable :: gqk(:)
571 : ! (my_nspins)
572 : ! Datastructure storing e-ph matrix elements for the collinear spins treated by this MPI proc.
573 :
574 : contains
575 :
576 : procedure :: fill_bks_mask => gstore_fill_bks_mask
577 : ! Fill the table used to read (b, k, s) wavefunctions from the WFK file
578 : ! keeping into account the distribution of the e-ph matrix elements.
579 :
580 : procedure :: fill_bks_mask_pp_mesh => gstore_fill_bks_mask_pp_mesh
581 : ! Fill the table used to read (b, k, s) wavefunctions from the WFK file
582 : ! keeping into account the distribution of the e-ph matrix elements in the GWPT code
583 : ! and the parallel distribution of the pp momenta.
584 :
585 : procedure :: get_mpw_gmax => gstore_get_mpw_gmax
586 : ! Compute the maximum number of PWs for all possible k+q treated.
587 :
588 : procedure :: spin2my_is => gstore_spin2my_is
589 : ! Return the local spin index from the global spin index.
590 : ! 0 if this spin is not treated by this MPI proc.
591 :
592 : procedure :: free => gstore_free
593 : ! Free memory
594 :
595 : procedure :: print => gstore_print
596 : ! Print info on the object.
597 :
598 : procedure :: check_little_group => gstore_check_little_group
599 : ! Check consistency between little group options from file and from input.
600 :
601 : procedure, private :: distribute_spins__ => gstore_distribute_spins
602 : ! Distribute spins, create indirect mapping to spin index and init %brange_k_spin
603 :
604 : procedure, private :: set_mpi_grid__ => gstore_set_mpi_grid__
605 : ! Set the MPI cartesian grid
606 :
607 : procedure, private :: malloc__ => gstore_malloc__
608 : ! Allocate local buffers once the MPI grid has been initialized.
609 :
610 : procedure, private :: filter_fs_tetra__ => gstore_filter_fs_tetra__
611 : ! Select k-points on the FS using the tetrahedron method
612 :
613 : procedure, private :: filter_kptgw__ => gstore_filter_kptgw__
614 : ! Select k-points using kptgw input variable. Useful for ZPR for user-specified k-points.
615 :
616 : procedure, private :: filter_erange__ => gstore_filter_erange__
617 : ! Select k-points inside an energy window.
618 :
619 : procedure, private :: filter_gw_qprange__ => gstore_filter_gw_qprange__
620 : ! Select k-points according to gw_qprange
621 :
622 : procedure :: compute => gstore_compute
623 : ! Compute e-ph matrix elements.
624 :
625 : procedure :: from_ncpath => gstore_from_ncpath
626 : ! Reconstruct object from netcdf file.
627 :
628 : procedure :: init => gstore_init
629 : ! Build object from scratch
630 :
631 : procedure :: init_or_from_ncpath => gstore_init_or_from_ncpath
632 : ! Build object either from a pre-existent GSTORE.nc file (getgstore_filepath) or,
633 : ! alternatively, via on-the-fly Wannier interpolation from ABIWAN.nc + GWAN.nc
634 : ! (getabiwan_filepath + getgwan_filepath), possibly on a denser k/q-mesh.
635 :
636 : procedure :: same_nbands => gstore_same_nbands
637 : ! Returns True if nb_k == nb_kq
638 :
639 : procedure :: has_matrix_elements => gstore_has_matrix_elements
640 : ! True if e-ph matrix elements have been materialized in memory.
641 :
642 : procedure :: has_complex_matrix_elements => gstore_has_complex_matrix_elements
643 : ! True if complex e-ph matrix elements have been materialized in memory.
644 :
645 : procedure :: get_missing_qbz_spin => gstore_get_missing_qbz_spin
646 : ! Return the number of (q-points, spin) entries that have been computed
647 :
648 : procedure :: set_perts_distrib => gstore_set_perts_distrib
649 : ! Activate parallelism over perturbations at the level of the DVDB file.
650 :
651 : procedure :: print_for_abitests => gstore_print_for_abitests
652 : ! Print subset of results to ab_out for testing purposes.
653 :
654 : procedure :: check_cplex_qkzone_gmode => gstore_check_cplex_qkzone_gmode
655 : ! Perform consistency checks.
656 :
657 : procedure :: wannierize_and_write_gwan => gstore_wannierize_and_write_gwan
658 : ! Compute g(R_e,R_ph) from g(k,q) and save results to GWAN.nc file
659 :
660 : procedure :: compute_and_write_ph => gstore_compute_and_write_ph
661 : ! Compute phonon frequencies and eigenvectors in the IBZ. Write results to disk
662 :
663 : procedure :: compute_and_write_vk => gstore_compute_and_write_vk
664 : ! Compute electronic group velocities in the IBZ. Write results to disk
665 :
666 : procedure :: compute_and_write_commutator => gstore_compute_and_write_commutator
667 : ! Compute matrix elements of the commutator. Write results to disk
668 :
669 : end type gstore_t
670 : !!***
671 :
672 : public :: gstore_check_restart ! Check whether restart is possible.
673 : public :: gstore_read_gtype ! Read the value of "gstore_gtype" from the NetCDF file.
674 : public :: gstore_symmetrize ! Reconstruct the electron-phonon matrix elements g(k,q) in the full BZ.
675 :
676 : !----------------------------------------------------------------------
677 :
678 : contains
679 : !!***
680 :
681 : !----------------------------------------------------------------------
682 :
683 : !!****f* m_gstore/gstore_init
684 : !! NAME
685 : !! gstore_init
686 : !!
687 : !! FUNCTION
688 : !! Initialize the object
689 : !!
690 : !! INPUTS
691 : !! path=Filename of the output GSTORE.nc file
692 : !! with_cplex=Optional, only relevant when e-ph matrix elements are interpolated on the fly via
693 : !! Wannier (i.e. getabiwan_filepath + getgwan_filepath are used): 0 to allocate no matrix
694 : !! elements, 1 to store |g|^2, 2 to store the complex g. Default: 2. Ignored otherwise.
695 : !!
696 : !! SOURCE
697 :
698 8 : subroutine gstore_init(gstore, path, dtset, dtfil, wfk0_hdr, cryst, ebands, ifc, comm, &
699 : gtype, with_cplex) ! optional
700 :
701 : !Arguments ------------------------------------
702 : !scalars
703 : class(gstore_t),target,intent(out) :: gstore
704 : character(len=*),intent(in) :: path
705 : type(dataset_type),target,intent(in) :: dtset
706 : type(datafiles_type),intent(in) :: dtfil
707 : type(hdr_type),intent(in) :: wfk0_hdr
708 : class(crystal_t),target,intent(in) :: cryst
709 : class(ebands_t),target,intent(in) :: ebands
710 : class(ifc_type),target,intent(in) :: ifc
711 : integer,intent(in) :: comm
712 : character(len=*),optional,intent(in) :: gtype
713 : integer,optional,intent(in) :: with_cplex
714 :
715 : !Local variables-------------------------------
716 : !scalars
717 : integer,parameter :: master = 0, gstore_has_ifcs = 1
718 : integer :: all_nproc, my_rank, ierr, my_nshiftq, nsppol, spin, natom3, cnt, timrev_q, gqk_cplex
719 : integer :: ik_ibz, ik_bz, iq_bz, iq_ibz, max_nq, max_nk, ncid, spin_ncid, ncerr, gstore_fform
720 : integer :: gap_err, nkcalc
721 : logical :: keep_umats, has_abiwan, has_gwan, write_gstore, has_both_g
722 : real(dp) :: cpu, wall, gflops, gstore_fill_dp
723 : character(len=5000) :: msg
724 8 : type(gaps_t) :: gaps
725 : !arrays
726 : integer :: ngqpt(3), qptrlatt(3,3), intp_kptrlatt(3,3)
727 24 : integer :: comm_spin(ebands%nsppol), nproc_spin(ebands%nsppol), units(2)
728 : integer :: gstore_brange_kq(2, 2), gstore_brange_k(2, 2)
729 8 : integer,allocatable :: qbz2ibz(:,:), kibz2bz(:), qibz2bz(:), qglob2bz(:,:)
730 8 : integer,allocatable :: bstart_ks(:,:), nbcalc_ks(:,:), select_qbz_spin(:,:), select_kbz_spin(:,:)
731 8 : real(dp),allocatable :: kcalc(:,:)
732 : real(dp):: my_shiftq(3,1)
733 8 : real(dp),allocatable :: wtk(:), kibz(:,:)
734 304 : type(wan_t),target :: wan_spin(ebands%nsppol)
735 : !----------------------------------------------------------------------
736 :
737 8 : call cwtime(cpu, wall, gflops, "start")
738 8 : all_nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
739 8 : natom3 = 3 * cryst%natom; nsppol = ebands%nsppol
740 24 : units = [std_out, ab_out]
741 :
742 8 : call wrtout(std_out, " gstore_init: initialize gstore_t instance...")
743 8 : call pstat_proc%print(_PSTAT_ARGS_)
744 :
745 : ! Set basic parameters.
746 8 : gstore%comm = comm; gstore%nsppol = nsppol; gstore%path = path
747 8 : if (present(gtype)) gstore%gtype = gtype
748 8 : ABI_CHECK(gstore%gtype == GSTORE_GTYPE_KS .or. gstore%gtype == GSTORE_GTYPE_GWPT, sjoin("Invalid gstore gtype:", gstore%gtype))
749 :
750 8 : has_both_g = gstore%gtype == GSTORE_GTYPE_GWPT
751 :
752 : ! Get references to other data structures.
753 8 : gstore%dtset => dtset; gstore%cryst => cryst; gstore%ebands => ebands; gstore%ifc => ifc
754 8 : gstore%has_wannier = .False.
755 :
756 : ! Handle possible wannierization.
757 8 : has_abiwan = .False.; has_gwan = .False.; keep_umats = .False.
758 8 : if (dtfil%filabiwanin /= ABI_NOFILE) then
759 0 : has_abiwan = .True.
760 0 : call wrtout(units, sjoin(" Reading set of bands to be included in gstore computation from ABIWAN file:", dtfil%filabiwanin))
761 0 : do spin=1,ebands%nsppol
762 0 : call wan_spin(spin)%from_abiwan(dtfil%filabiwanin, spin, ebands%nsppol, keep_umats, dtfil%filnam_ds(4), comm)
763 0 : call wan_spin(spin)%print(units)
764 : end do
765 0 : if (dtfil%filgwanin /= ABI_NOFILE) then
766 0 : has_gwan = .True.
767 0 : ABI_CHECK(all(dtset%eph_ngkpt_fine > 0), "eph_ngkpt_fine must contain three positive integers when GWAN is used")
768 0 : ABI_CHECK(allocated(dtset%eph_shiftk_fine), "eph_shiftk_fine is not allocated")
769 0 : ABI_CHECK(size(dtset%eph_shiftk_fine, dim=2) == dtset%eph_nshiftk_fine, "Inconsistent eph_nshiftk_fine and eph_shiftk_fine")
770 0 : call kptrlatt_from_ngkpt(dtset%eph_ngkpt_fine, intp_kptrlatt)
771 :
772 0 : nullify(gstore%ebands)
773 0 : ABI_MALLOC_SCALAR(gstore%ebands)
774 : call wan_interp_ebands(wan_spin, cryst, ebands, intp_kptrlatt, dtset%eph_nshiftk_fine, &
775 0 : dtset%eph_shiftk_fine, gstore%ebands, comm)
776 0 : gstore%has_wannier = .True.
777 : end if
778 : end if
779 :
780 : ! Set metadata and set initial value of kfilter from dtset.
781 8 : gstore%kibz => gstore%ebands%kptns
782 8 : gstore%kzone = dtset%gstore_kzone; gstore%qzone = dtset%gstore_qzone; gstore%kfilter = dtset%gstore_kfilter
783 8 : gstore%with_vk = dtset%gstore_with_vk; gstore%gmode = GSTORE_GMODE_ATOM
784 :
785 48 : ABI_CALLOC(gstore%erange_spin, (2, nsppol))
786 40 : gstore%erange_spin = dtset%gstore_erange(:, 1:nsppol)
787 :
788 30 : if (any(gstore%erange_spin /= zero)) then
789 1 : ABI_CHECK(gstore%kfilter == "none", sjoin("kfilter should be none when erange is used while it is:", gstore%kfilter))
790 1 : gstore%kfilter = "erange"
791 : end if
792 :
793 8 : if (gstore%kzone == "ibz" .and. gstore%qzone == "ibz") then
794 0 : ABI_ERROR("The combination kzone: 'ibz' and qzone: 'ibz' is not allowed!")
795 : end if
796 :
797 : ! TODO
798 : !gstore%kptrlatt(3, 3); gstore%kshift(3, 1); gstore%qptrlatt(3, 3); gstore%qshift(3, 1)
799 :
800 : ! Distribute spins, create indirect mapping to spin index and init %brange_k_spin from dtset
801 : ! TODO Should I introduce dtset%gstore_brange_kq or compute it automatically
802 8 : if (.not. has_gwan) then
803 8 : ABI_CHECK_ILEQ(dtset%mband, gstore%ebands%mband, "dtset%mband > ebands%mband")
804 : end if
805 :
806 56 : gstore_brange_k = dtset%gstore_brange
807 56 : gstore_brange_kq = dtset%gstore_brange
808 :
809 8 : if (gstore%kfilter == "qprange") then
810 : ! Assume ZPR calculations requiring virtual k+q transitions from 1 up to nband unless gstore_brange is given.
811 28 : if (all(gstore_brange_kq == 0)) then
812 12 : gstore_brange_kq(:,1) = [1, dtset%mband]
813 12 : gstore_brange_kq(:,2) = [1, dtset%mband]
814 : end if
815 :
816 : ! The same set of calls is found in gstore_filter_gw_qprange__
817 : ! The main difference is that here we set the bands while gstore_filter_gw_qprange__ sets the the k-points.
818 4 : gaps = gstore%ebands%get_gaps(gap_err)
819 :
820 : ! Compute nkcalc, kcalc, bstart_ks, nbcalc_ks
821 4 : if (dtset%gw_qprange /= 0) then
822 0 : call sigtk_kcalc_from_qprange(dtset, gstore%cryst, gstore%ebands, dtset%gw_qprange, nkcalc, kcalc, bstart_ks, nbcalc_ks)
823 :
824 : else
825 : ! gw_qprange is not specified in the input.
826 : ! Include direct and fundamental KS gap or include states depending on the position wrt band edges.
827 4 : call sigtk_kcalc_from_gaps(dtset, gstore%ebands, gaps, nkcalc, kcalc, bstart_ks, nbcalc_ks)
828 : end if
829 :
830 : ! Convert to stop values
831 18 : nbcalc_ks = bstart_ks + nbcalc_ks - 1
832 :
833 : ! Set brange_k
834 : ! FIXME: Handle degeneracies
835 8 : do spin=1,nsppol
836 10 : gstore_brange_k(1, spin) = minval(bstart_ks(1:nkcalc, spin))
837 14 : gstore_brange_k(2, spin) = maxval(nbcalc_ks(1:nkcalc, spin))
838 : end do
839 :
840 4 : ABI_FREE(kcalc)
841 4 : ABI_FREE(bstart_ks)
842 4 : ABI_FREE(nbcalc_ks)
843 4 : call gaps%free()
844 : end if
845 :
846 8 : if (dtset%nkptgw /= 0) then
847 : ! Allow user to specify k-points with kptgw and bdgw.
848 :
849 0 : if (gstore%kfilter /= "none") then
850 0 : ABI_ERROR("gstore_kfilter and nkptgw != 0 cannot be used together!")
851 : end if
852 :
853 : ! Assume ZPR calculations requiring virtual k+q transitions from 1 up to nband unless gstore_brange is given.
854 0 : gstore_brange_kq = dtset%gstore_brange
855 0 : if (all(gstore_brange_kq == 0)) then
856 0 : gstore_brange_kq(:,1) = [1, dtset%mband]
857 0 : gstore_brange_kq(:,2) = [1, dtset%mband]
858 : end if
859 :
860 0 : call sigtk_kcalc_from_nkptgw(dtset, dtset%mband, nkcalc, kcalc, bstart_ks, nbcalc_ks)
861 :
862 : ! Convert to stop values
863 0 : nbcalc_ks = bstart_ks + nbcalc_ks - 1
864 :
865 : ! Set brange_k
866 : ! FIXME: Handle degeneracies
867 0 : do spin=1,nsppol
868 0 : gstore_brange_k(1, spin) = minval(bstart_ks(1:nkcalc, spin))
869 0 : gstore_brange_k(2, spin) = maxval(nbcalc_ks(1:nkcalc, spin))
870 : end do
871 :
872 0 : ABI_FREE(kcalc)
873 0 : ABI_FREE(bstart_ks)
874 0 : ABI_FREE(nbcalc_ks)
875 : end if
876 :
877 8 : if (has_gwan) then
878 : ! Interpolated e-ph matrix elements are Wannier-gauge quantities (nwan x nwan,
879 : ! obtained by diagonalizing the interpolated H(k)), not literal DFT band indices,
880 : ! so nb_k/nb_kq must be set to nwan exactly -- NOT to the (possibly larger)
881 : ! disentanglement outer window [bmin, bmax] -- so that the results returned by
882 : ! wan%interp_eph_manyq (shape (nwan, nwan, my_npert, nq)) fit gqk%my_g exactly,
883 : ! for both the disentangled and disentanglement-free cases.
884 0 : do spin=1,gstore%nsppol
885 0 : gstore_brange_k(:, spin) = [1, wan_spin(spin)%nwan]
886 0 : gstore_brange_kq(:, spin) = [1, wan_spin(spin)%nwan]
887 : end do
888 8 : else if (has_abiwan) then
889 : ! Here we set brange_k_spin to be consistent with the wannierization step.
890 0 : do spin=1,gstore%nsppol
891 0 : gstore_brange_k(:, spin) = [wan_spin(spin)%bmin, wan_spin(spin)%bmax]
892 0 : gstore_brange_kq(:, spin) = [wan_spin(spin)%bmin, wan_spin(spin)%bmax]
893 : end do
894 : end if
895 :
896 8 : call gstore%distribute_spins__(gstore%ebands%mband, gstore_brange_kq, gstore_brange_k, nproc_spin, comm_spin, comm)
897 :
898 : ! Free wan_spin
899 16 : do spin=1,ebands%nsppol
900 16 : call wan_spin(spin)%free()
901 : end do
902 :
903 : ! Define q-mesh: either from DVDB (no interpolation) or eph_ngqpt_fine (Fourier interpolation)
904 : ! Save it in gstore for future reference.
905 56 : ngqpt = dtset%ddb_ngqpt; my_nshiftq = 1; my_shiftq(:,1) = dtset%ddb_shiftq
906 23 : if (all(dtset%eph_ngqpt_fine /= 0)) then
907 20 : ngqpt = dtset%eph_ngqpt_fine; my_shiftq = 0
908 : end if
909 32 : gstore%ngqpt(:) = ngqpt(:)
910 :
911 : ! TODO: Should fix bz2ibz to use the same conventions as krank and listkk
912 : ! NB: only sigmaph seems to be using this optional argument
913 :
914 : ! Setup qIBZ, weights and BZ.
915 : ! Assume qptopt == kptopt unless value is specified in input
916 8 : qptrlatt = 0; qptrlatt(1, 1) = ngqpt(1); qptrlatt(2, 2) = ngqpt(2); qptrlatt(3, 3) = ngqpt(3)
917 8 : gstore%qptopt = gstore%ebands%kptopt; if (dtset%qptopt /= 0) gstore%qptopt = dtset%qptopt
918 : timrev_q = kpts_timrev_from_kptopt(gstore%qptopt)
919 :
920 8 : call wrtout(std_out, sjoin(" Generating q-mesh with ngqpt:", ltoa(ngqpt), " and qptopt:", itoa(gstore%qptopt)))
921 : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, gstore%qptopt, my_nshiftq, my_shiftq, &
922 8 : gstore%nqibz, gstore%qibz, gstore%wtq, gstore%nqbz, gstore%qbz)
923 : !new_kptrlatt=gstore%qptrlatt, new_shiftk=gstore%qshift,
924 : !bz2ibz=new%ind_qbz2ibz) # FIXME
925 :
926 : ! HM: the bz2ibz produced above is incomplete, I do it here using listkk
927 24 : ABI_MALLOC(qbz2ibz, (6, gstore%nqbz))
928 8 : call gstore%qrank_ibz%from_kptrlatt(gstore%nqibz, gstore%qibz, qptrlatt, compute_invrank=.False.)
929 :
930 8 : if (kpts_map("symrec", gstore%qptopt, cryst, gstore%qrank_ibz, gstore%nqbz, gstore%qbz, qbz2ibz) /= 0) then
931 0 : ABI_ERROR("Cannot map qBZ to IBZ!")
932 : end if
933 :
934 : ! Order qbz by stars and rearrange entries in qbz2ibz table.
935 8 : call kpts_pack_in_stars(gstore%nqbz, gstore%qbz, qbz2ibz)
936 :
937 : !call kpts_print_kmap(std_out, qibz, gstore%qbz, qbz2ibz)
938 : !do iq_bz=1,gstore%nqbz
939 : ! print *, "iq_bz -> iq_ibz", qbz2ibz(1, iq_bz), gstore%qbz(:, iq_bz)
940 : !end do
941 :
942 8 : call get_ibz2bz(gstore%nqibz, gstore%nqbz, qbz2ibz, qibz2bz, msg, ierr)
943 8 : ABI_CHECK(ierr == 0, sjoin("Something wrong in symmetry tables for q-points!", ch10, msg))
944 :
945 : ! Get full BZ associated to ebands
946 8 : call wrtout(std_out, sjoin(" Generating k-mesh with ngkpt:", ltoa(get_diag(gstore%ebands%kptrlatt)), " and kptopt:", itoa(gstore%ebands%kptopt)))
947 : call kpts_ibz_from_kptrlatt(cryst, gstore%ebands%kptrlatt, gstore%ebands%kptopt, gstore%ebands%nshiftk, gstore%ebands%shiftk, &
948 8 : gstore%nkibz, kibz, wtk, gstore%nkbz, gstore%kbz) !, bz2ibz=bz2ibz)
949 : !new_kptrlatt=gstore%kptrlatt, new_shiftk=gstore%kshift,
950 : !bz2ibz=new%ind_qbz2ibz) # FIXME
951 :
952 : ! In principle kibz should be equal to ebands%kptns
953 8 : ABI_CHECK(gstore%nkibz == gstore%ebands%nkpt, "nkibz != ebands%nkpt")
954 540 : ABI_CHECK(all(abs(gstore%kibz - kibz) < tol12), "ebands%kibz != kibz")
955 8 : ABI_FREE(kibz)
956 :
957 : ! Note symrel and use_symrec=.False. in get_mapping.
958 : ! This means that this table can be used to symmetrize wavefunctions in cgtk_rotate.
959 : ! TODO This ambiguity should be removed. Change cgtk_rotate so that we can use the symrec convention.
960 :
961 24 : ABI_MALLOC(gstore%kbz2ibz, (6, gstore%nkbz))
962 8 : call gstore%krank_ibz%from_kptrlatt(gstore%nkibz, gstore%kibz, gstore%ebands%kptrlatt, compute_invrank=.False.)
963 8 : if (kpts_map("symrel", gstore%ebands%kptopt, cryst, gstore%krank_ibz, gstore%nkbz, gstore%kbz, gstore%kbz2ibz) /= 0) then
964 0 : ABI_ERROR("Cannot map kBZ to IBZ!")
965 : end if
966 :
967 : ! TODO:
968 : ! Order kbz by stars and rearrange entries in kbz2ibz table.
969 : !call kpts_pack_in_stars(gstore%nkbz, kbz, gstore%kbz2ibz)
970 :
971 8 : call get_ibz2bz(gstore%nkibz, gstore%nkbz, gstore%kbz2ibz, kibz2bz, msg, ierr)
972 8 : ABI_CHECK(ierr == 0, sjoin("Something wrong in symmetry tables for k-points", ch10, msg))
973 :
974 : ! These tables are used to exclude q/k points.
975 : ! We use the full BZ because this mask can be also used when points are restricted to the IBZ
976 : ! provided we convert from ik_ibz to ik_bz. Note that both arrays are initialized with zeros.
977 2597 : ABI_ICALLOC(select_qbz_spin, (gstore%nqbz, nsppol))
978 2597 : ABI_ICALLOC(select_kbz_spin, (gstore%nkbz, nsppol))
979 :
980 4 : select case (gstore%kzone)
981 : case ("ibz")
982 8 : do spin=1,nsppol
983 35 : do ik_ibz=1,gstore%nkibz
984 31 : ik_bz = kibz2bz(ik_ibz); select_kbz_spin(ik_bz, spin) = 1
985 : end do
986 : end do
987 :
988 : case ("bz")
989 2421 : select_kbz_spin = 1
990 :
991 : case default
992 8 : ABI_ERROR(sjoin("Invalid kzone:", gstore%kzone))
993 : end select
994 :
995 8 : select case (gstore%qzone)
996 : case ("ibz")
997 0 : do spin=1,nsppol
998 0 : do iq_ibz=1, gstore%nqibz
999 0 : iq_bz = qibz2bz(iq_ibz); select_qbz_spin(iq_bz, spin) = 1
1000 : end do
1001 : end do
1002 :
1003 : case ("bz")
1004 2573 : select_qbz_spin = 1
1005 :
1006 : case default
1007 8 : ABI_ERROR(sjoin("Invalid qzone:", gstore%qzone))
1008 : end select
1009 :
1010 : ! Here we filter the electronic wavevectors k and recompute select_qbz_spin and select_kbz_spin according to kfilter.
1011 11 : select case (gstore%kfilter)
1012 : case ("none")
1013 3 : if (dtset%nkptgw /= 0) then
1014 : ! Use kptgw input variable. Useful for ZPR for user-specified k-points.
1015 0 : call gstore%filter_kptgw__(dtset, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
1016 : end if
1017 :
1018 : case ("erange")
1019 : ! Use energy range: transport in semiconductors/metals or superconducting propertiea.
1020 1 : call gstore%filter_erange__(qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
1021 :
1022 : case ("qprange")
1023 : ! Use gw_qprange input variable. Useful for ZPR
1024 4 : call gstore%filter_gw_qprange__(dtset, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
1025 :
1026 : case ("fs_tetra")
1027 : ! Use the tetrahedron method to filter k- and k+q points on the FS in metals
1028 : ! and define gstore%brange_k_spin automatically.
1029 : ! Useful for transport in metals or superconducting propertiea.
1030 0 : call gstore%filter_fs_tetra__(qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
1031 :
1032 : case default
1033 8 : ABI_ERROR(sjoin("Invalid gstore%kfilter:", gstore%kfilter))
1034 : end select
1035 :
1036 : ! Total number of k/q points for each spin after filtering (if any)
1037 24 : ABI_MALLOC(gstore%glob_nk_spin, (nsppol))
1038 16 : ABI_MALLOC(gstore%glob_nq_spin, (nsppol))
1039 2581 : gstore%glob_nk_spin(:) = count(select_kbz_spin > 0, dim=1)
1040 2581 : gstore%glob_nq_spin(:) = count(select_qbz_spin > 0, dim=1)
1041 :
1042 : ! We need another table mapping the global index in the gqk matrix to the q/k index in the BZ
1043 : ! so that one can extract the symmetry tables computed above.
1044 : ! Again this is needed as the global sizes of the gqk matrix
1045 : ! is not necessarily equal to the size of the BZ/IBZ if we have filtered the wave vectors.
1046 :
1047 16 : max_nq = maxval(gstore%glob_nq_spin) ! Max dim over spin
1048 16 : max_nk = maxval(gstore%glob_nk_spin)
1049 997 : ABI_ICALLOC(qglob2bz, (max_nq, nsppol))
1050 351 : ABI_ICALLOC(gstore%kglob2bz, (max_nk, nsppol))
1051 :
1052 16 : do spin=1,nsppol
1053 8 : cnt = 0
1054 2565 : do iq_bz=1,gstore%nqbz
1055 2565 : if (select_qbz_spin(iq_bz, spin) /= 0) then
1056 957 : cnt = cnt + 1; qglob2bz(cnt, spin) = iq_bz
1057 : end if
1058 : end do
1059 :
1060 8 : cnt = 0
1061 2573 : do ik_bz=1,gstore%nkbz
1062 2565 : if (select_kbz_spin(ik_bz, spin) /= 0) then
1063 311 : cnt = cnt + 1; gstore%kglob2bz(cnt, spin) = ik_bz
1064 : end if
1065 : end do
1066 : end do
1067 :
1068 : ! =============================================
1069 : ! Initialize gqk basic dimensions and MPI grid
1070 : ! =============================================
1071 8 : call gstore%set_mpi_grid__(dtfil, nproc_spin, comm_spin)
1072 8 : call xmpi_comm_free(comm_spin)
1073 :
1074 : ! At this point, we have the Cartesian grid (one per spin if any),
1075 : ! and we can finally allocate and distribute other arrays.
1076 : ! Note gqk_cplex = 0 --> matrix elements are not allocated here.
1077 8 : gqk_cplex = 0
1078 8 : if (has_gwan) then
1079 0 : gqk_cplex = 2
1080 0 : if (present(with_cplex)) gqk_cplex = with_cplex
1081 : end if
1082 8 : ABI_CHECK(gqk_cplex >= 0 .and. gqk_cplex <= 2, sjoin("Invalid with_cplex:", itoa(gqk_cplex)))
1083 8 : gstore%with_cplex = gqk_cplex
1084 8 : call gstore%malloc__(gqk_cplex, has_both_g, max_nq, qglob2bz, max_nk, gstore%kglob2bz, qbz2ibz, gstore%kbz2ibz)
1085 :
1086 : ! Initialize GSTORE.nc file i.e. define dimensions and arrays
1087 : ! Entries such as the e-ph matrix elements will be filled afterwards in gstore_compute.
1088 : ! Master node defines dimensions and variables.
1089 :
1090 8 : write_gstore = .True.
1091 8 : if (has_gwan) write_gstore = .False.
1092 :
1093 8 : if (my_rank == master .and. write_gstore) then
1094 8 : NCF_CHECK(nctk_open_create(ncid, gstore%path, xmpi_comm_self))
1095 :
1096 : ! Write the abinit header with metadata, structure and occupancies.
1097 8 : gstore_fform = fform_from_ext("GSTORE.nc")
1098 8 : NCF_CHECK(wfk0_hdr%ncwrite(ncid, gstore_fform, spinat=dtset%spinat, nc_define=.True.))
1099 :
1100 : ! Add crystalline structure.
1101 8 : NCF_CHECK(gstore%cryst%ncwrite(ncid))
1102 : ! Add eigenvalues and occupations.
1103 8 : NCF_CHECK(gstore%ebands%ncwrite(ncid))
1104 :
1105 : ! Write gstore dimensions
1106 : ncerr = nctk_def_dims(ncid, [ &
1107 : nctkdim_t("gstore_nkibz", gstore%nkibz), &
1108 : nctkdim_t("gstore_nkbz", gstore%nkbz), &
1109 : nctkdim_t("gstore_nqibz", gstore%nqibz), &
1110 : nctkdim_t("gstore_nqbz", gstore%nqbz), &
1111 : nctkdim_t("gstore_max_nq", max_nq), &
1112 : nctkdim_t("gstore_max_nk", max_nk), &
1113 : nctkdim_t("gstore_max_nb", maxval(gstore%brange_k_spin(2, :) - gstore%brange_k_spin(1, :) + 1) ), &
1114 : nctkdim_t("nrpt", ifc%nrpt), &
1115 : nctkdim_t("ifc_nqbz", size(ifc%dynmat, dim=6)), &
1116 : nctkdim_t("natom", gstore%cryst%natom), &
1117 : nctkdim_t("natom3", 3 * gstore%cryst%natom), &
1118 : nctkdim_t("gstore_cplex", 2), &
1119 : nctkdim_t("ifc_nqbz", ifc%nqbz) &
1120 120 : ], defmode=.True.)
1121 8 : NCF_CHECK(ncerr)
1122 :
1123 : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: &
1124 : "gstore_with_vk", "gstore_qptopt", "gstore_completed", &
1125 : "gstore_use_lgk", "gstore_use_lgq", "gstore_has_ifcs", "gwpt_wmode" &
1126 64 : ])
1127 8 : NCF_CHECK(ncerr)
1128 : ncerr = nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: &
1129 : "ifc_eta" &
1130 16 : ])
1131 8 : NCF_CHECK(ncerr)
1132 :
1133 : ncerr = nctk_def_arrays(ncid, [ &
1134 : nctkarr_t("gstore_qibz", "dp", "three, gstore_nqibz"), &
1135 : nctkarr_t("gstore_qbz", "dp", "three, gstore_nqbz"), &
1136 : nctkarr_t("gstore_wtq", "dp", "gstore_nqibz"), &
1137 : nctkarr_t("gstore_kbz", "dp", "three, gstore_nkbz"), &
1138 : nctkarr_t("gstore_kzone", "c", "character_string_length"), &
1139 : nctkarr_t("gstore_qzone", "c", "character_string_length"), &
1140 : nctkarr_t("gstore_kfilter", "c", "character_string_length"), &
1141 : nctkarr_t("gstore_gmode", "c", "character_string_length"), &
1142 : nctkarr_t("gstore_gtype", "c", "character_string_length"), &
1143 : nctkarr_t("gstore_wfk0_path", "c", "fnlen"), &
1144 : nctkarr_t("gstore_brange_k_spin", "i", "two, number_of_spins"), &
1145 : nctkarr_t("gstore_brange_kq_spin", "i", "two, number_of_spins"), &
1146 : nctkarr_t("gstore_erange_spin", "dp", "two, number_of_spins"), &
1147 : nctkarr_t("gstore_ngqpt", "i", "three"), &
1148 : nctkarr_t("phfreqs_ibz", "dp", "natom3, gstore_nqibz"), &
1149 : nctkarr_t("pheigvec_cart_ibz", "dp", "two, three, natom, natom3, gstore_nqibz"), &
1150 : nctkarr_t("gstore_glob_nq_spin", "i", "number_of_spins"), &
1151 : nctkarr_t("gstore_glob_nk_spin", "i", "number_of_spins"), &
1152 : nctkarr_t("gstore_done_qbz_spin", "i", "gstore_nqbz, number_of_spins"), &
1153 : nctkarr_t("gstore_kbz2ibz", "i", "six, gstore_nkbz"), &
1154 : nctkarr_t("gstore_qbz2ibz", "i", "six, gstore_nqbz"), &
1155 : nctkarr_t("gstore_qglob2bz", "i", "gstore_max_nq, number_of_spins"), &
1156 : nctkarr_t("gstore_kglob2bz", "i", "gstore_max_nk, number_of_spins"), &
1157 : ! Table with status of (k, q, spin) entry, used to symmetrize matrix-elements.
1158 : nctkarr_t("gstore_glob_state_kqs", "i", "gstore_max_nk, gstore_max_nq, number_of_spins"), &
1159 : !
1160 : ! These quantities are needed to interface GSTORE.nc with external codes.
1161 : ! For the meaning of the different variables and conventions see m_ifc module.
1162 : nctkarr_t("ifc_zeff", "dp", "three, three, number_of_atoms"), &
1163 : nctkarr_t("ifc_qdrp_cart", "dp", "three, three, three, number_of_atoms") &
1164 216 : ])
1165 8 : NCF_CHECK(ncerr)
1166 :
1167 : if (gstore_has_ifcs /= 0) then
1168 : ! Define arrays for IFCs.
1169 : ! For the meaning of the different variables and conventions see m_ifc module.
1170 : ncerr = nctk_def_arrays(ncid, [ &
1171 : nctkarr_t("ifc_rpt", "dp", "three, nrpt"), &
1172 : nctkarr_t("ifc_wghatm", "dp", "natom, natom, nrpt"), &
1173 : nctkarr_t("ifc_dynmat", "dp", "two, three, natom, three, natom, ifc_nqbz"), &
1174 : nctkarr_t("ifc_short_atmfrc", "dp", "three, natom, three, natom, nrpt") &
1175 40 : ])
1176 8 : NCF_CHECK(ncerr)
1177 : end if
1178 :
1179 : ! Internal table used to restart computation. Initialized with zeros.
1180 : ! 0 --> (ib_bz, spin) has not been computed.
1181 : ! 1 --> (iq_bz, spin) has been computed.
1182 : ! In order to check if the whole generation is completed, one should test if "gstore_completed" == 1
1183 8 : NCF_CHECK(nf90_def_var_fill(ncid, vid("gstore_done_qbz_spin"), NF90_FILL, 0))
1184 :
1185 8 : NCF_CHECK(nf90_def_var_fill(ncid, vid("gstore_glob_state_kqs"), NF90_FILL, GSTORE_KQ_MISSING))
1186 :
1187 : ! Optional arrays
1188 8 : if (allocated(gstore%delta_ef_kibz_spin)) then
1189 : ncerr = nctk_def_arrays(ncid, &
1190 0 : nctkarr_t("gstore_delta_ef_kibz_spin", "dp", "gstore_max_nb, gstore_nkibz, number_of_spins"))
1191 : end if
1192 8 : NCF_CHECK(ncerr)
1193 :
1194 : ! Write data
1195 8 : NCF_CHECK(nctk_set_datamode(ncid))
1196 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_with_vk"), gstore%with_vk))
1197 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qptopt"), gstore%qptopt))
1198 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_use_lgk"), dtset%gstore_use_lgk))
1199 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_use_lgq"), dtset%gstore_use_lgq))
1200 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_has_ifcs"), gstore_has_ifcs))
1201 8 : NCF_CHECK(nf90_put_var(ncid, vid("gwpt_wmode"), dtset%gwpt_wmode))
1202 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_completed"), 0))
1203 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_kzone"), trim(gstore%kzone)))
1204 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qzone"), trim(gstore%qzone)))
1205 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_kfilter"), trim(gstore%kfilter)))
1206 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_gmode"), trim(gstore%gmode)))
1207 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_gtype"), trim(gstore%gtype)))
1208 :
1209 : ! NB: kibz has been already written by ebands%ncwrite
1210 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qibz"), gstore%qibz))
1211 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qbz"), gstore%qbz))
1212 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_wtq"), gstore%wtq))
1213 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_kbz"), gstore%kbz))
1214 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_brange_k_spin"), gstore%brange_k_spin))
1215 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_brange_kq_spin"), gstore%brange_kq_spin))
1216 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_erange_spin"), gstore%erange_spin))
1217 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_ngqpt"), gstore%ngqpt))
1218 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_glob_nq_spin"), gstore%glob_nq_spin))
1219 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_glob_nk_spin"), gstore%glob_nk_spin))
1220 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_kbz2ibz"), gstore%kbz2ibz))
1221 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qbz2ibz"), qbz2ibz))
1222 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qglob2bz"), qglob2bz))
1223 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_kglob2bz"), gstore%kglob2bz))
1224 :
1225 : ! These quantities are needed to interface GSTORE.nc with external codes.
1226 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_zeff"), ifc%zeff))
1227 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_qdrp_cart"), ifc%qdrp_cart))
1228 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_eta"), ifc%eta))
1229 : if (gstore_has_ifcs /= 0) then
1230 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_rpt"), ifc%rpt))
1231 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_wghatm"), ifc%wghatm))
1232 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_dynmat"), ifc%dynmat))
1233 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_short_atmfrc"), ifc%short_atmfrc))
1234 : end if
1235 :
1236 8 : if (allocated(gstore%delta_ef_kibz_spin)) then
1237 0 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_delta_ef_kibz_spin"), gstore%delta_ef_kibz_spin))
1238 : end if
1239 :
1240 16 : do spin=1,gstore%nsppol
1241 : ! Create hdf group for this spin.
1242 8 : NCF_CHECK(nf90_def_grp(ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
1243 :
1244 : ! Dimensions in gqk_spin group
1245 : ncerr = nctk_def_dims(spin_ncid, [ &
1246 : nctkdim_t("nb_k", gstore%brange_k_spin(2, spin) - gstore%brange_k_spin(1, spin) + 1), &
1247 : nctkdim_t("nb_kq", gstore%brange_kq_spin(2, spin) - gstore%brange_kq_spin(1, spin) + 1), &
1248 : nctkdim_t("glob_nk", gstore%glob_nk_spin(spin)), &
1249 : nctkdim_t("glob_nq", gstore%glob_nq_spin(spin)) &
1250 40 : ], defmode=.True.)
1251 8 : NCF_CHECK(ncerr)
1252 :
1253 : ! Define scalars
1254 24 : ncerr = nctk_def_iscalars(spin_ncid, [character(len=nctk_slen) :: "bstart_k", "bstart_kq"])
1255 8 : NCF_CHECK(ncerr)
1256 :
1257 : ! arrays in gqk_spin group with the precious stuff. Note global dimensions.
1258 : ncerr = nctk_def_arrays(spin_ncid, [ &
1259 : nctkarr_t("gvals", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq") &
1260 16 : ])
1261 8 : NCF_CHECK(ncerr)
1262 :
1263 : ! Compress gvals to reduce size on disk.
1264 : !NCF_CHECK(nf90_def_var_deflate(spin_ncid, spin_vid("gvals"), shuffle=1, deflate=1, deflate_level=5))
1265 :
1266 : ! IMPORTANT: Init gvals with zeros.
1267 : ! Default value for entries in gvals, vnk_cart_ibz and vnk_mat_cart_ibz arrays that have not been written.
1268 : ! This can happen only if we have filtered wavevectors.
1269 8 : gstore_fill_dp = zero
1270 8 : if (gstore%kfilter == "none") gstore_fill_dp = -huge(one)
1271 8 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("gvals"), NF90_FILL, gstore_fill_dp))
1272 :
1273 : ! In GWPT gvals is used for g^Sigma so we declare another array to store g^KS.
1274 8 : if (dtset%eph_task == 17) then
1275 : ncerr = nctk_def_arrays(spin_ncid, [ &
1276 : nctkarr_t("gvals_ks", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq") &
1277 6 : ])
1278 3 : NCF_CHECK(ncerr)
1279 : ! Compress gvals to reduce size on disk.
1280 : !NCF_CHECK(nf90_def_var_deflate(spin_ncid, spin_vid("gvals_ks"), shuffle=1, deflate=1, deflate_level=5))
1281 3 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("gvals_ks"), NF90_FILL, gstore_fill_dp))
1282 : end if
1283 :
1284 16 : select case(gstore%with_vk)
1285 : case (1)
1286 : ! Diagonal terms only
1287 8 : NCF_CHECK(nctk_def_arrays(spin_ncid, nctkarr_t("vk_cart_ibz", "dp", "three, nb_k, gstore_nkibz")))
1288 8 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("vk_cart_ibz"), NF90_FILL, gstore_fill_dp))
1289 :
1290 : case (2)
1291 : ! Full (nb_k x nb_k) matrix.
1292 0 : NCF_CHECK(nctk_def_arrays(spin_ncid, nctkarr_t("vnk_mat_cart_ibz", "dp", "two, three, nb_k, nb_k, gstore_nkibz")))
1293 8 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("vnk_mat_cart_ibz"), NF90_FILL, gstore_fill_dp))
1294 : end select
1295 :
1296 : ! Write (small) data
1297 8 : NCF_CHECK(nctk_set_datamode(spin_ncid))
1298 8 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("bstart_k"), gstore%brange_k_spin(1, spin)))
1299 16 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("bstart_kq"), gstore%brange_kq_spin(1, spin)))
1300 : end do ! spin
1301 :
1302 8 : NCF_CHECK(nf90_close(ncid))
1303 : end if ! master
1304 :
1305 : ! Make sure GSTORE.nc has been written by master.
1306 8 : call xmpi_barrier(gstore%comm)
1307 :
1308 8 : ABI_FREE(wtk)
1309 8 : ABI_FREE(qibz2bz)
1310 8 : ABI_FREE(kibz2bz)
1311 8 : ABI_FREE(select_qbz_spin)
1312 8 : ABI_FREE(select_kbz_spin)
1313 8 : ABI_FREE(qglob2bz)
1314 8 : ABI_FREE(qbz2ibz)
1315 :
1316 8 : call cwtime_report(" gstore_init:", cpu, wall, gflops)
1317 32 : call pstat_proc%print(_PSTAT_ARGS_)
1318 :
1319 : ! NOTE: When has_gwan is True, gqk%my_g/my_g2 have been allocated above (gqk_cplex) but are not
1320 : ! filled here. The actual Wannier interpolation of the e-ph matrix elements is performed by the
1321 : ! caller, gstore_init_or_from_ncpath, where with_gmode/gvals_name/with_g2dw are available.
1322 :
1323 : contains
1324 280 : integer function vid(var_name)
1325 : character(len=*),intent(in) :: var_name
1326 280 : vid = nctk_idname(ncid, var_name)
1327 : end function vid
1328 35 : integer function spin_vid(var_name)
1329 : character(len=*),intent(in) :: var_name
1330 35 : spin_vid = nctk_idname(spin_ncid, var_name)
1331 : end function spin_vid
1332 :
1333 : end subroutine gstore_init
1334 : !!***
1335 :
1336 : !----------------------------------------------------------------------
1337 :
1338 : !!****f* m_gstore/gstore_init_or_from_ncpath
1339 : !! NAME
1340 : !! gstore_init_or_from_ncpath
1341 : !!
1342 : !! FUNCTION
1343 : !! Build a gstore_t object either by reading a pre-existent GSTORE.nc file
1344 : !! (getgstore_filepath) or, alternatively, by interpolating e-ph matrix elements
1345 : !! on the fly from ABIWAN.nc + GWAN.nc (getabiwan_filepath + getgwan_filepath),
1346 : !! e.g. on a k/q-mesh denser than the one used to compute the GWAN.nc file.
1347 : !! In the latter case, no GSTORE.nc file is read or written: gqk%my_g is filled
1348 : !! entirely in memory (see the has_gwan branch in gstore_init).
1349 : !!
1350 : !! from_file (output): set to .True. if gstore was built from a
1351 : !! pre-existent GSTORE.nc file, .False. if built on the fly via Wannier
1352 : !! interpolation. Callers can use this to report which path was taken.
1353 : !!
1354 : !! SOURCE
1355 :
1356 16 : subroutine gstore_init_or_from_ncpath(gstore, with_cplex, dtset, dtfil, wfk0_hdr, cryst, ebands, ifc, &
1357 : with_gmode, gvals_name, with_g2dw, comm, from_file)
1358 :
1359 : !Arguments ------------------------------------
1360 : !scalars
1361 : class(gstore_t),target,intent(out) :: gstore
1362 : integer,intent(in) :: with_cplex
1363 : type(dataset_type),target,intent(in) :: dtset
1364 : type(datafiles_type),intent(in) :: dtfil
1365 : type(hdr_type),intent(in) :: wfk0_hdr
1366 : class(crystal_t),target,intent(in) :: cryst
1367 : class(ebands_t),target,intent(in) :: ebands
1368 : class(ifc_type),target,intent(in) :: ifc
1369 : character(len=*),intent(in) :: with_gmode, gvals_name
1370 : logical,intent(in) :: with_g2dw
1371 : integer,intent(in) :: comm
1372 : logical,intent(out) :: from_file
1373 :
1374 : !Local variables-------------------------------
1375 : !scalars
1376 : integer :: natom, natom3, spin, my_is, my_ik, my_iq, iq_ibz, isym_q, trev_q, ipc, nu, nwan, ierr
1377 : integer :: ik_start, ik_stop, ikb, nkb, nk_batch
1378 : real(dp) :: weight_q, cpu, wall, gflops
1379 : character(len=500) :: msg
1380 : character(len=fnlen) :: gstore_path
1381 : type(gqk_t),pointer :: gqk
1382 : !arrays
1383 : real(dp) :: qpt(3)
1384 16 : real(dp),allocatable :: phfrq_ibz(:,:), displ_cart_dum(:,:,:,:), gatm_real(:,:,:,:), gnu_real(:,:,:,:)
1385 16 : real(dp),allocatable :: eigvec_ibz(:,:,:,:,:), eigvec_qbz(:,:,:,:), displ_cart_qbz(:,:,:,:), displ_red_qbz(:,:,:,:)
1386 16 : complex(dp),allocatable :: intp_gatm(:,:,:,:), gatm_full(:,:,:,:), g_req(:,:,:,:)
1387 : !----------------------------------------------------------------------
1388 :
1389 16 : if (dtfil%filgstorein /= ABI_NOFILE) then
1390 : call gstore%from_ncpath(dtfil%filgstorein, with_cplex, dtset, dtfil, cryst, ebands, ifc, &
1391 16 : with_gmode, gvals_name, with_g2dw, comm)
1392 16 : from_file = .True.
1393 :
1394 0 : else if (dtfil%filabiwanin /= ABI_NOFILE .and. dtfil%filgwanin /= ABI_NOFILE) then
1395 : ! Build gstore on the fly via Wannier interpolation from ABIWAN.nc + GWAN.nc.
1396 0 : call cwtime(cpu, wall, gflops, "start")
1397 : ! with_cplex=0 prepares the Wannier interpolator and gstore metadata without materializing g(k,q).
1398 : ! with_cplex=1/2 stores |g|^2/complex g, respectively. Debye-Waller and gvals_ks are unsupported.
1399 0 : msg = sjoin("Invalid with_cplex:", itoa(with_cplex), "only 0, 1 or 2 are supported")
1400 0 : ABI_CHECK(with_cplex >= 0 .and. with_cplex <= 2, msg)
1401 0 : if (with_g2dw) then
1402 0 : ABI_ERROR("with_g2dw = .True. is not yet supported when building gstore via Wannier interpolation (ABIWAN.nc + GWAN.nc)")
1403 : end if
1404 0 : if (gvals_name == "gvals_ks") then
1405 0 : ABI_ERROR("gvals_name = 'gvals_ks' is not supported when building gstore via Wannier interpolation (ABIWAN.nc + GWAN.nc)")
1406 : end if
1407 0 : if (with_gmode /= GSTORE_GMODE_PHONON) then
1408 0 : ABI_ERROR(sjoin("with_gmode:", with_gmode, "is not yet supported when building gstore via Wannier"))
1409 : end if
1410 :
1411 0 : gstore_path = strcat(dtfil%filnam_ds(4), "_GSTORE.nc")
1412 0 : call gstore%init(gstore_path, dtset, dtfil, wfk0_hdr, cryst, ebands, ifc, comm, with_cplex=with_cplex)
1413 :
1414 0 : if (with_cplex == 0) then
1415 0 : call wrtout([std_out, ab_out], " Preparing on-demand Wannier interpolation of e-ph matrix elements ...", pre_newlines=1)
1416 : else
1417 0 : call wrtout([std_out, ab_out], " Using Wannier interpolation to compute and store e-ph matrix elements ...", pre_newlines=1)
1418 : end if
1419 0 : from_file = .False.
1420 0 : natom = cryst%natom; natom3 = 3 * natom
1421 :
1422 : ! Precompute phonon frequencies/eigenvectors in the IBZ once (spin-independent).
1423 : ! NB: The phonon eigenvector gauge must be fixed from a single IBZ representative + symmetry
1424 : ! rotation (pheigvec_rotate), exactly as done when g(k,q) is read from a pre-existent GSTORE.nc
1425 : ! file (see gstore_from_ncpath). Calling ifc%fourq directly at each interpolated BZ q would give
1426 : ! an independently-diagonalized (and hence potentially differently gauged) eigenbasis for
1427 : ! degenerate modes and would break the e(-q) = e(q)^* convention used elsewhere in the code.
1428 0 : ABI_MALLOC(phfrq_ibz, (natom3, gstore%nqibz))
1429 0 : ABI_MALLOC(eigvec_ibz, (2, 3, natom, natom3, gstore%nqibz))
1430 0 : ABI_MALLOC(displ_cart_dum, (2, 3, natom, natom3))
1431 0 : do iq_ibz=1,gstore%nqibz
1432 : call ifc%fourq(cryst, gstore%qibz(:,iq_ibz), phfrq_ibz(:,iq_ibz), displ_cart_dum, &
1433 0 : out_eigvec=eigvec_ibz(:,:,:,:,iq_ibz))
1434 : end do
1435 0 : ABI_FREE(displ_cart_dum)
1436 :
1437 0 : ABI_MALLOC(eigvec_qbz, (2, 3, natom, natom3))
1438 0 : ABI_MALLOC(displ_cart_qbz, (2, 3, natom, natom3))
1439 0 : ABI_MALLOC(displ_red_qbz, (2, 3, natom, natom3))
1440 :
1441 : ! Interpolate g(k,q) and store data in memory.
1442 0 : do my_is=1,gstore%my_nspins
1443 0 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is); nwan = gqk%nb_k
1444 :
1445 : ! Build gqk%wan for this spin from the ABIWAN.nc file and load g(R_e, R_p) from GWAN.nc.
1446 0 : call gqk%wan%from_abiwan(dtfil%filabiwanin, spin, gstore%nsppol, .False., "", gqk%comm%value)
1447 0 : gqk%wan%my_pert_start = gqk%my_pert_start; gqk%wan%my_npert = gqk%my_npert; gqk%wan%pert_comm => gqk%pert_comm
1448 0 : call gqk%wan%load_gwan(dtfil%filgwanin, cryst, spin, gstore%nsppol, gqk%comm)
1449 :
1450 0 : ABI_MALLOC(gqk%my_wnuq, (gqk%my_npert, gqk%my_nq))
1451 0 : ABI_MALLOC(gqk%my_displ_cart, (2, 3, natom, gqk%my_npert, gqk%my_nq))
1452 :
1453 0 : if (with_cplex > 0) then
1454 : ! Bound the two temporary complex atomic-vertex arrays to the default
1455 : ! 64 MiB workspace. The low-level selector also accepts a custom limit.
1456 0 : nk_batch = gqk%wan%eph_kbatch_size(gqk%my_nk, natom3)
1457 0 : ABI_MALLOC(intp_gatm, (nwan, nwan, gqk%my_npert, nk_batch))
1458 0 : ABI_MALLOC(gatm_full, (nwan, nwan, natom3, nk_batch))
1459 0 : ABI_MALLOC(g_req, (gqk%wan%nr_e, nwan, nwan, gqk%my_npert))
1460 0 : ABI_MALLOC(gatm_real, (2, nwan, nwan, natom3))
1461 0 : ABI_MALLOC(gnu_real, (2, nwan, nwan, natom3))
1462 : end if
1463 :
1464 0 : do my_iq=1,gqk%my_nq
1465 0 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
1466 0 : iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq); trev_q = gqk%my_q2ibz(6, my_iq)
1467 :
1468 : ! Rotate the phonon eigenvector from the IBZ to this BZ q-point (fixes the gauge).
1469 : call pheigvec_rotate(cryst, gstore%qibz(:,iq_ibz), isym_q, trev_q, eigvec_ibz(:,:,:,:,iq_ibz), &
1470 0 : eigvec_qbz, displ_cart_qbz, displ_red_qbz=displ_red_qbz)
1471 :
1472 : ! Fill my arrays with ph data.
1473 0 : gqk%my_wnuq(:,my_iq) = phfrq_ibz(gqk%my_pertcases(:), iq_ibz)
1474 0 : gqk%my_displ_cart(:,:,:,:,my_iq) = displ_cart_qbz(:,:,:,gqk%my_pertcases(:))
1475 :
1476 0 : if (with_cplex == 0) cycle
1477 :
1478 : ! The R_p -> q transform is independent of k and is reused by every
1479 : ! bounded k block below.
1480 0 : call gqk%wan%prepare_eph_q(qpt, g_req)
1481 :
1482 0 : do ik_start=1,gqk%my_nk,nk_batch
1483 0 : ik_stop = min(gqk%my_nk, ik_start + nk_batch - 1); nkb = ik_stop - ik_start + 1
1484 :
1485 : call gqk%wan%interp_eph_manyk_from_q(cryst, nkb, gqk%my_kpts(:,ik_start:ik_stop), qpt, &
1486 0 : g_req, intp_gatm(:,:,:,1:nkb))
1487 :
1488 : ! Complete all atomic perturbations for the block with one collective
1489 : ! instead of one pert_comm reduction per k point.
1490 0 : gatm_full(:,:,:,1:nkb) = czero
1491 0 : do ikb=1,nkb
1492 0 : do ipc=1,gqk%my_npert
1493 0 : gatm_full(:,:,gqk%my_pertcases(ipc),ikb) = intp_gatm(:,:,ipc,ikb)
1494 : end do
1495 : end do
1496 0 : if (gqk%pert_comm%nproc > 1) call xmpi_sum(gatm_full(:,:,:,1:nkb), gqk%pert_comm%value, ierr)
1497 :
1498 0 : do ikb=1,nkb
1499 0 : my_ik = ik_start + ikb - 1
1500 0 : gatm_real(1,:,:,:) = real(gatm_full(:,:,:,ikb), kind=dp)
1501 0 : gatm_real(2,:,:,:) = aimag(gatm_full(:,:,:,ikb))
1502 0 : call ephtk_gkknu_from_atm(nwan, nwan, 1, natom, gatm_real, phfrq_ibz(:,iq_ibz), displ_red_qbz, gnu_real)
1503 :
1504 0 : do ipc=1,gqk%my_npert
1505 0 : nu = gqk%my_pertcases(ipc)
1506 0 : if (with_cplex == 2) then
1507 0 : gqk%my_g(ipc,:,my_iq,:,my_ik) = gnu_real(1,:,:,nu) + j_dpc * gnu_real(2,:,:,nu)
1508 : else
1509 0 : gqk%my_g2(ipc,:,my_iq,:,my_ik) = gnu_real(1,:,:,nu)**2 + gnu_real(2,:,:,nu)**2
1510 : end if
1511 : end do
1512 : end do ! ikb
1513 : end do ! ik_start
1514 : end do ! my_iq
1515 :
1516 0 : if (with_cplex > 0) then
1517 0 : ABI_FREE(intp_gatm)
1518 0 : ABI_FREE(gatm_full)
1519 0 : ABI_FREE(g_req)
1520 0 : ABI_FREE(gatm_real)
1521 0 : ABI_FREE(gnu_real)
1522 : end if
1523 : end do ! my_is
1524 :
1525 0 : ABI_FREE(phfrq_ibz)
1526 0 : ABI_FREE(eigvec_ibz)
1527 0 : ABI_FREE(eigvec_qbz)
1528 0 : ABI_FREE(displ_cart_qbz)
1529 0 : ABI_FREE(displ_red_qbz)
1530 :
1531 : ! We interpolated (and converted to) the phonon representation.
1532 0 : gstore%gmode = GSTORE_GMODE_PHONON
1533 0 : call cwtime_report(" Wannier interpolation of GSTORE matrix elements", cpu, wall, gflops)
1534 :
1535 : else
1536 : write(msg, "(3a)") &
1537 0 : "Cannot build gstore object: either getgstore_filepath or both ", &
1538 0 : "getabiwan_filepath and getgwan_filepath must be provided in the input file.", ch10
1539 0 : ABI_ERROR(msg)
1540 : end if
1541 :
1542 16 : end subroutine gstore_init_or_from_ncpath
1543 : !!***
1544 :
1545 : !----------------------------------------------------------------------
1546 :
1547 0 : logical function gstore_has_matrix_elements(gstore) result(has_g)
1548 :
1549 : class(gstore_t),intent(in) :: gstore
1550 :
1551 0 : has_g = gstore%with_cplex > 0
1552 :
1553 0 : end function gstore_has_matrix_elements
1554 :
1555 : !----------------------------------------------------------------------
1556 :
1557 0 : logical function gstore_has_complex_matrix_elements(gstore) result(has_complex_g)
1558 :
1559 : class(gstore_t),intent(in) :: gstore
1560 :
1561 0 : has_complex_g = gstore%with_cplex == 2
1562 :
1563 0 : end function gstore_has_complex_matrix_elements
1564 :
1565 : !----------------------------------------------------------------------
1566 :
1567 : !!****f* m_gstore/gstore_same_nbands
1568 : !! NAME
1569 : !! gstore_same_nbands
1570 : !!
1571 : !! FUNCTION
1572 : !! True if nb_k == nb_kq.
1573 : !!
1574 : !! SOURCE
1575 :
1576 9 : logical function gstore_same_nbands(gstore, msg) result(same)
1577 :
1578 : class(gstore_t),intent(in) :: gstore
1579 : character(len=*),intent(out) :: msg
1580 :
1581 : !Local variables-------------------------------
1582 : integer :: my_is
1583 : !----------------------------------------------------------------------
1584 :
1585 9 : same = .True.; msg = ""
1586 18 : do my_is=1,gstore%my_nspins
1587 9 : associate (gqk => gstore%gqk(my_is))
1588 9 : if (gqk%nb_k /= gqk%nb_kq) then
1589 0 : same = .False.; msg = sjoin("gstore has different nb_kq, nb_k", itoa(gqk%nb_kq), itoa(gqk%nb_k))
1590 : end if
1591 : end associate
1592 : end do
1593 :
1594 9 : end function gstore_same_nbands
1595 : !!***
1596 :
1597 : !----------------------------------------------------------------------
1598 :
1599 : !!****f* m_gstore/gstore_distribute_spins
1600 : !! NAME
1601 : !! gstore_distribute_spins
1602 : !!
1603 : !! FUNCTION
1604 : !! Distribute spins. Also create and return indirect mapping to spin index and init %brange_k_spin
1605 : !!
1606 : !! INPUTS
1607 : !!
1608 : !! OUTPUT
1609 : !!
1610 : !! NOTES
1611 : !! What works:
1612 : !!
1613 : !! - Setting gstore_kfilter = "qprange" works.
1614 : !! With this, bands (nb_k) and k-points are automatically filtered, including only the VBM and CBM.
1615 : !! This is useful for calculating the ZPR of the fundamental gap.
1616 : !! Manual specification of bands (nb_k) and k-points also works by setting gstore_kfilter = "none" (default)
1617 : !! and providing the values via kptgw and bdgw.
1618 : !!
1619 : !! What does not work:
1620 : !!
1621 : !! - There is currently no effective way to control nb_kq directly.
1622 : !! The only workaround is using gstore_brange. For example, gstore_brange = '1, 8' sets nb_k = nb_kq = 8.
1623 : !! However, gstore_brange has the lowest priority: if gstore_kfilter
1624 : !! is set or kptgw/bdgw are provided, gstore_brange is ignored and nb_kq defaults to nband.
1625 : !!
1626 : !! Notes on use cases:
1627 : !! For ZPR calculations, the current schemes are sufficient.
1628 : !! For tasks comparing g between GWPT and FD, the current schemes are not very convenient.
1629 : !! For instance, to compare g at k=q=Gamma for the first 8 bands of diamond,
1630 : !! ideally we would restrict the calculation to nb_k = nb_kq = {1..8} and k=q=Gamma. But currently
1631 : !!
1632 : !! Using gstore_brange triggers unnecessary k-point calculations (ngkpt is usually a dense k-grid).
1633 : !!
1634 : !! Using kptgw and bdgw triggers unnecessary band calculations (nb_kq = nband is usually a big number).
1635 : !!
1636 : !! Potential improvement (?):
1637 : !! Maybe we could give gstore_brange higher priority to control nb_kq(?). To avoid conflicts:
1638 : !! If gstore_brange is provided and gstore_kfilter = "none", we do
1639 : !! bstart_k = bdgw[1], nb_k = min(nband, bdgw[2] - bdgw[1])
1640 : !! bstart_kq = gstore_brange[1], nb_kq = min(nband, gstore_brange[2] - gstore_brange[1])
1641 : !! If gstore_brange is NOT provided and gstore_kfilter = "none", we do
1642 : !! bstart_kq = bstart_k = bdgw[1], nb_kq = nb_k = max(nband, bdgw[2] - bdgw[1])
1643 : !!
1644 : !! SOURCE
1645 :
1646 24 : subroutine gstore_distribute_spins(gstore, mband, brange_kq, brange_k, nproc_spin, comm_spin, comm)
1647 :
1648 : !Arguments ------------------------------------
1649 : !scalars
1650 : class(gstore_t),target,intent(inout) :: gstore
1651 : integer,intent(in) :: mband, comm, brange_kq(2, gstore%nsppol), brange_k(2, gstore%nsppol)
1652 : integer,intent(out) :: nproc_spin(gstore%nsppol), comm_spin(gstore%nsppol)
1653 :
1654 : !Local variables-------------------------------
1655 : !scalars
1656 : integer :: spin, my_rank, ierr, color, nsppol, nprocs
1657 : !arrays
1658 : integer :: buff_spin(2)
1659 : !----------------------------------------------------------------------
1660 :
1661 24 : nprocs = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
1662 24 : nsppol = gstore%nsppol
1663 :
1664 24 : gstore%my_nspins = 0
1665 72 : ABI_MALLOC(gstore%brange_k_spin, (2, nsppol))
1666 48 : ABI_MALLOC(gstore%brange_kq_spin, (2, nsppol))
1667 :
1668 48 : do spin=1,nsppol
1669 : ! NB: If MPI_UNDEFINED is passed as the colour value, the subgroup in which
1670 : ! the calling MPI process will be placed is MPI_COMM_NULL
1671 24 : color = 1
1672 24 : if (nsppol == 2 .and. nprocs > 1) then
1673 0 : color = xmpi_undefined
1674 0 : if (spin == 1 .and. my_rank <= (nprocs - 1) / 2) color = 1
1675 0 : if (spin == 2 .and. my_rank > (nprocs - 1) / 2) color = 1
1676 : end if
1677 :
1678 24 : call xmpi_comm_split(comm, color, my_rank, comm_spin(spin), ierr)
1679 24 : if (comm_spin(spin) /= xmpi_comm_null) then
1680 24 : gstore%my_nspins = gstore%my_nspins + 1
1681 24 : buff_spin(gstore%my_nspins) = spin
1682 : end if
1683 :
1684 24 : nproc_spin(spin) = xmpi_comm_size(comm_spin(spin))
1685 :
1686 : ! Default values for brange at k, k+q from mband
1687 72 : gstore%brange_k_spin(:, spin) = [1, mband]
1688 72 : gstore%brange_kq_spin(:, spin) = [1, mband]
1689 :
1690 : ! Optionally take values from input brange_k, brange_kq
1691 139 : if (all(brange_k /= 0)) gstore%brange_k_spin(:, spin) = brange_k(:, spin)
1692 139 : if (all(brange_kq /= 0)) gstore%brange_kq_spin(:, spin) = brange_kq(:, spin)
1693 :
1694 : ! Validate against input mband.
1695 24 : ABI_CHECK_IRANGE(gstore%brange_k_spin(1, spin), 1, mband, "brange_k(1, spin)")
1696 24 : ABI_CHECK_IRANGE(gstore%brange_k_spin(2, spin), 1, mband, "brange_k(2, spin)")
1697 24 : ABI_CHECK(gstore%brange_k_spin(1, spin) <= gstore%brange_k_spin(2, spin), "brange_k_spin(1, spin) <= brange_k_spin(2, spin)")
1698 :
1699 24 : ABI_CHECK_IRANGE(gstore%brange_kq_spin(1, spin), 1, mband, "brange_k(1, spin)")
1700 24 : ABI_CHECK_IRANGE(gstore%brange_kq_spin(2, spin), 1, mband, "brange_k(2, spin)")
1701 72 : ABI_CHECK(gstore%brange_kq_spin(1, spin) <= gstore%brange_kq_spin(2, spin), "brange_kq_spin(1, spin) <= brange_kq_spin(2, spin)")
1702 : end do
1703 :
1704 72 : ABI_MALLOC(gstore%my_spins, (gstore%my_nspins))
1705 72 : gstore%my_spins = buff_spin(1:gstore%my_nspins)
1706 384 : ABI_MALLOC(gstore%gqk, (gstore%my_nspins))
1707 :
1708 24 : end subroutine gstore_distribute_spins
1709 : !!***
1710 :
1711 : !----------------------------------------------------------------------
1712 :
1713 : !!****f* m_gstore/gstore_set_mpi_grid__
1714 : !! NAME
1715 : !! gstore_set_mpi_grid__
1716 : !!
1717 : !! FUNCTION
1718 : !!
1719 : !! INPUTS
1720 : !!
1721 : !! OUTPUT
1722 : !!
1723 : !! SOURCE
1724 :
1725 24 : subroutine gstore_set_mpi_grid__(gstore, dtfil, nproc_spin, comm_spin)
1726 :
1727 : !Arguments ------------------------------------
1728 : !scalars
1729 : class(gstore_t),target,intent(inout) :: gstore
1730 : type(datafiles_type),intent(in) :: dtfil
1731 : integer,intent(in) :: nproc_spin(gstore%nsppol)
1732 : integer,intent(inout) :: comm_spin(gstore%nsppol)
1733 : !Local variables-------------------------------
1734 : !scalars
1735 : integer,parameter :: master = 0
1736 : integer :: spin, my_is, np, my_rank, ierr, npp_bz, units(2), bstart_k, bstop_k, nb_k, bstart_kq, bstop_kq, nb_kq
1737 : integer :: comm_cart, me_cart, dims(ndims)
1738 : type(gqk_t),pointer :: gqk
1739 : character(len=5000) :: msg
1740 : character(len=10) :: order, priority
1741 : character(len=fnlen) :: screen_filepath
1742 : logical :: reorder, periods(ndims), keepdim(ndims)
1743 312 : type(kmesh_t) :: pp_mesh
1744 24 : type(gsphere_t) :: gsph_c
1745 24 : real(dp),allocatable :: qlwl(:,:)
1746 96 : type(hscr_t),target :: hscr
1747 : !----------------------------------------------------------------------
1748 :
1749 72 : units = [std_out, ab_out]
1750 :
1751 : associate (dtset => gstore%dtset)
1752 48 : my_rank = xmpi_comm_rank(gstore%comm)
1753 :
1754 48 : do my_is=1,gstore%my_nspins
1755 24 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is)
1756 24 : gqk%spin = spin; gqk%natom3 = 3 * gstore%cryst%natom; gqk%cplex = 2
1757 :
1758 : ! Compute bstart_k and nb_k for this spin.
1759 24 : bstart_k = gstore%brange_k_spin(1, spin)
1760 24 : bstop_k = gstore%brange_k_spin(2, spin)
1761 24 : nb_k = gstore%brange_k_spin(2, spin) - gstore%brange_k_spin(1, spin) + 1
1762 :
1763 : ! Compute bstart_kq and nb_kq for this spin.
1764 24 : bstart_kq = gstore%brange_kq_spin(1, spin)
1765 24 : bstop_kq = gstore%brange_kq_spin(2, spin)
1766 24 : nb_kq = gstore%brange_kq_spin(2, spin) - gstore%brange_kq_spin(1, spin) + 1
1767 :
1768 : ! Here we set nb_k and nb_kq
1769 24 : gqk%nb_k = nb_k; gqk%bstart_k = bstart_k; gqk%bstop_k = bstop_k
1770 24 : gqk%nb_kq = nb_kq; gqk%bstart_kq = bstart_kq; gqk%bstop_kq = bstop_kq
1771 :
1772 : ! Store global shape of the q/k matrix for this spin.
1773 24 : gqk%glob_nq = gstore%glob_nq_spin(spin)
1774 48 : gqk%glob_nk = gstore%glob_nk_spin(spin)
1775 : end do
1776 :
1777 48 : do my_is=1,gstore%my_nspins
1778 24 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is)
1779 :
1780 : ! Init for sequential execution.
1781 24 : gqk%my_npert = gqk%natom3
1782 24 : gqk%qpt_comm%nproc = 1; gqk%kpt_comm%nproc = 1; gqk%pert_comm%nproc = 1; gqk%band_comm%nproc = 1
1783 : ! NB: The communicators below are only used in GWPT.
1784 24 : gqk%bsum_comm%nproc = 1; gqk%pp_sum_comm%nproc = 1
1785 :
1786 24 : np = nproc_spin(spin)
1787 :
1788 24 : if (dtset%eph_task /= 17) then
1789 : ! =============================
1790 : ! For all eph_tasks except GWPT
1791 : ! =============================
1792 :
1793 126 : if (any(dtset%eph_np_pqbks /= 0)) then
1794 : ! Use parameters from input file. Need to perform sanity check though.
1795 0 : gqk%pert_comm%nproc = dtset%eph_np_pqbks(1)
1796 0 : gqk%qpt_comm%nproc = dtset%eph_np_pqbks(2)
1797 0 : gqk%band_comm%nproc = dtset%eph_np_pqbks(3)
1798 0 : ABI_CHECK(dtset%eph_np_pqbks(3) == 1, "Band parallelism not yet implemented in gstore")
1799 0 : gqk%kpt_comm%nproc = dtset%eph_np_pqbks(4)
1800 : !gqk%spin_comm%nproc = dtset%eph_np_pqbks(5)
1801 0 : gqk%my_npert = gqk%natom3 / gqk%pert_comm%nproc
1802 0 : ABI_CHECK(gqk%my_npert > 0, "pert_comm_nproc cannot be greater than 3*natom.")
1803 0 : ABI_CHECK(mod(gqk%natom3, gqk%pert_comm%nproc) == 0, "pert_comm_nproc must divide 3*natom.")
1804 :
1805 : else
1806 : ! Automatic grid generation (hopefully smart)
1807 : ! Keep in mind that in gstore_compute, the first loop is over q-points
1808 : ! in order to reduce the number of interpolations of the DFPT potentials in q-space
1809 : ! hence the q-point parallelism is expected to be more efficient.
1810 : ! On the other hand, the k-point parallelism and the perturbation parallelism
1811 : ! allow one to reduce the memory requirements associated to the wavefunctions (kpt) and
1812 : ! the scattering potentials in the supercell (perturbations).
1813 : ! Here we try to optimize performance but it's clear that for large systems the user
1814 : ! should specify dtset%eph_np_pqbks in the input file.
1815 :
1816 5 : select case (dtset%eph_task)
1817 : case (11)
1818 5 : priority = "qk"
1819 : case (12, -12)
1820 0 : priority = "q"
1821 : case (13)
1822 9 : priority = "q"
1823 : case (14, 17)
1824 0 : priority = "kq"
1825 : case (24)
1826 7 : priority = "qk"
1827 : case default
1828 21 : ABI_ERROR(sjoin("Please register default priority for eph_task:", itoa(dtset%eph_task)))
1829 : end select
1830 :
1831 9 : select case (priority)
1832 : case ("q")
1833 9 : order = "1"
1834 : case ("k")
1835 0 : order = "2"
1836 : case ("kq")
1837 0 : order = "21"
1838 : case ("qk")
1839 12 : order = "12"
1840 : case default
1841 21 : ABI_ERROR(sjoin("Wrong priority:", priority))
1842 : end select
1843 :
1844 21 : if (gqk%glob_nk == 1) order = "21"
1845 21 : if (gqk%glob_nq == 1) order = "12"
1846 21 : call xmpi_distrib_2d(np, order, gqk%glob_nq, gqk%glob_nk, gqk%qpt_comm%nproc, gqk%kpt_comm%nproc, ierr)
1847 21 : ABI_CHECK(ierr == 0, sjoin("Cannot distribute nprocs:", itoa(np), " with priority: ", priority))
1848 : end if
1849 :
1850 : else if (dtset%eph_task == 17) then
1851 : ! =========================
1852 : ! MPI distribution for GWPT
1853 : ! =========================
1854 :
1855 21 : if (any(dtset%gwpt_np_wpqbks /= 0)) then
1856 : ! Use parameters from input file. Need to perform sanity check though.
1857 0 : gqk%pp_sum_comm%nproc = dtset%gwpt_np_wpqbks(1)
1858 0 : gqk%pert_comm%nproc = dtset%gwpt_np_wpqbks(2)
1859 0 : gqk%qpt_comm%nproc = dtset%gwpt_np_wpqbks(3)
1860 0 : gqk%bsum_comm%nproc = dtset%gwpt_np_wpqbks(4)
1861 0 : gqk%kpt_comm%nproc = dtset%gwpt_np_wpqbks(5)
1862 : !gqk%spin_comm%nproc = dtset%gwpt_np_wpqbks(6)
1863 0 : gqk%my_npert = gqk%natom3 / gqk%pert_comm%nproc
1864 0 : ABI_CHECK(gqk%my_npert > 0, "pert_comm_nproc cannot be greater than 3*natom.")
1865 0 : ABI_CHECK(mod(gqk%natom3, gqk%pert_comm%nproc) == 0, "pert_comm_nproc must divide 3*natom.")
1866 :
1867 : else
1868 : ! Automatic grid generation for GWPT (hopefully smart)
1869 :
1870 : ! In GWPT, the loop over pp-wavevectors is always in the BZ and is expected to be the most efficient
1871 : ! Note however that the p-mesh is not necessarly equal to the k-mesh hence we have to read it from the SCR file.
1872 : !npp_bz = product(get_diag(gstore%dtset%kptrlatt))
1873 :
1874 3 : screen_filepath = dtfil%fnameabi_scr
1875 3 : ABI_CHECK(dtfil%fnameabi_scr /= ABI_NOFILE, "SCR file must be specified")
1876 3 : call get_hscr_qmesh_gsph(screen_filepath, gstore%dtset, gstore%cryst, hscr, pp_mesh, gsph_c, qlwl, comm_spin(spin))
1877 3 : npp_bz = pp_mesh%nbz
1878 3 : call hscr%free(); call pp_mesh%free(); call gsph_c%free()
1879 3 : ABI_SFREE(qlwl)
1880 :
1881 3 : if (np <= npp_bz * gqk%natom3) then
1882 : ! "Small" np. Give higher priority to npp_bz and then perturbations.
1883 3 : order = "12"
1884 3 : call xmpi_distrib_2d(np, order, npp_bz, gqk%natom3, gqk%pp_sum_comm%nproc, gqk%pert_comm%nproc, ierr)
1885 3 : ABI_CHECK(ierr == 0, sjoin("Cannot distribute nprocs:", itoa(np), " with priority: ", priority, " Please use gwpt_np_wpqbks"))
1886 : else
1887 : ! "Large" np. Activate parallelism over k-points or q-points depending on gstore input variables.
1888 0 : ABI_ERROR("Your number of MPI procs is too large for the automatic GWPT parallelization. Please use gwpt_np_wpqbks")
1889 : end if
1890 : end if
1891 :
1892 : else
1893 : ABI_ERROR(sjoin("Invalid eph_task", itoa(dtset%eph_task)))
1894 : end if
1895 :
1896 : ! Consistency check.
1897 24 : if (gqk%pert_comm%nproc * gqk%qpt_comm%nproc * gqk%kpt_comm%nproc * gqk%band_comm%nproc * &
1898 24 : gqk%bsum_comm%nproc * gqk%pp_sum_comm%nproc /= nproc_spin(spin)) then
1899 : write(msg, "(a,i0,3a, 7(a,1x,i0))") &
1900 0 : "Cannot create Cartesian grid with total nproc: ", nproc_spin(spin), ch10, &
1901 0 : "Idle processes are not supported. The product of the `nproc_*` vars should be equal to nproc.", ch10, &
1902 0 : "qpt_nproc (", gqk%qpt_comm%nproc, ") x kpt_nproc (", gqk%kpt_comm%nproc, ") x pert_nproc", gqk%pert_comm%nproc, &
1903 0 : "x band_nproc (", gqk%band_comm%nproc, "x bsum_nproc (", gqk%bsum_comm%nproc, ") x psum_nproc (", gqk%pp_sum_comm%nproc, &
1904 0 : ") != ", nproc_spin(spin)
1905 0 : ABI_ERROR(msg)
1906 : end if
1907 :
1908 : end do ! my_is
1909 :
1910 : ! For each spin treated by this rank, create Cartesian communicator of rank ndims.
1911 24 : periods(:) = .False.; reorder = .False.
1912 :
1913 48 : do my_is=1,gstore%my_nspins
1914 24 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is)
1915 :
1916 : ! TODO: Should change order for GWPT.
1917 : dims = [gqk%qpt_comm%nproc, gqk%kpt_comm%nproc, gqk%pert_comm%nproc, gqk%band_comm%nproc, &
1918 168 : gqk%bsum_comm%nproc, gqk%pp_sum_comm%nproc]
1919 :
1920 : ! Note comm_spin(spin).
1921 24 : gqk%comm = xcomm_from_mpi_int(comm_spin(spin))
1922 168 : gqk%coords_qkpb_sumbp = 0
1923 :
1924 : #ifdef HAVE_MPI
1925 24 : call MPI_CART_CREATE(gqk%comm, ndims, dims, periods, reorder, comm_cart, ierr)
1926 : ! Find the index and coordinates of the current processor
1927 24 : call MPI_COMM_RANK(comm_cart, me_cart, ierr)
1928 24 : call MPI_CART_COORDS(comm_cart, me_cart, ndims, gqk%coords_qkpb_sumbp, ierr)
1929 :
1930 : ! Communicator for q-points in g(k,q)
1931 24 : keepdim = .False.; keepdim(1) = .True.; call gqk%qpt_comm%from_cart_sub(comm_cart, keepdim)
1932 : ! Communicator for k-points in g(k,q)
1933 24 : keepdim = .False.; keepdim(2) = .True.; call gqk%kpt_comm%from_cart_sub(comm_cart, keepdim)
1934 : ! Communicator for the (qpt, kpt) 2D grid
1935 24 : keepdim = .False.; keepdim(1) = .True.; keepdim(2) = .True.; call gqk%qpt_kpt_comm%from_cart_sub(comm_cart, keepdim)
1936 : ! Communicator for perturbations in g(k,q)
1937 24 : keepdim = .False.; keepdim(3) = .True.; call gqk%pert_comm%from_cart_sub(comm_cart, keepdim)
1938 : ! 2d Communicator for the (qpt, pert) grid
1939 24 : keepdim = .False.; keepdim(1) = .True.; keepdim(3) = .True.; call gqk%qpt_pert_comm%from_cart_sub(comm_cart, keepdim)
1940 : ! Communicator for band in g(k,q)
1941 24 : keepdim = .False.; keepdim(4) = .True.; call gqk%band_comm%from_cart_sub(comm_cart, keepdim)
1942 : ! Communicator for bsum (GWPT mode)
1943 24 : keepdim = .False.; keepdim(5) = .True.; call gqk%bsum_comm%from_cart_sub(comm_cart, keepdim)
1944 : ! Communicator for pp_sum (GWPT mode)
1945 24 : keepdim = .False.; keepdim(6) = .True.; call gqk%pp_sum_comm%from_cart_sub(comm_cart, keepdim)
1946 : ! 2d Communicator for the (pert, pp_sum) 2D grid
1947 24 : keepdim = .False.; keepdim(3) = .True.; keepdim(6) = .True.; call gqk%pert_ppsum_comm%from_cart_sub(comm_cart, keepdim)
1948 : ! 3d Communicator for the (pert, pp_sum, band_sum) 3D grid (GWPT mode)
1949 24 : keepdim = .False.; keepdim(3) = .True.; keepdim(5) = .True.; keepdim(6) = .True.
1950 24 : call gqk%pert_ppsum_bsum_comm%from_cart_sub(comm_cart, keepdim)
1951 24 : call xmpi_comm_free(comm_cart)
1952 : #endif
1953 :
1954 : ! Distribute perturbations inside pert_comm using block distribution.
1955 24 : call xmpi_split_block(gqk%natom3, gqk%pert_comm%value, gqk%my_npert, gqk%my_pertcases)
1956 24 : gqk%my_pert_start = gqk%my_pertcases(1)
1957 :
1958 24 : call wrtout(units, sjoin("P qpt_comm can use shmem:", yesno(gqk%qpt_comm%can_use_shmem())))
1959 24 : call wrtout(units, sjoin("P kpt_comm can use shmem:", yesno(gqk%kpt_comm%can_use_shmem())))
1960 24 : call wrtout(units, sjoin("P bsum_comm can use shmem:", yesno(gqk%bsum_comm%can_use_shmem())))
1961 48 : call wrtout(units, sjoin("P pp_sum_comm can use shmem:", yesno(gqk%pp_sum_comm%can_use_shmem())), newlines=1)
1962 : end do ! my_is
1963 :
1964 96 : if (my_rank == master) call gstore%print([std_out, ab_out])
1965 :
1966 : end associate
1967 :
1968 24 : end subroutine gstore_set_mpi_grid__
1969 : !!***
1970 :
1971 : !----------------------------------------------------------------------
1972 :
1973 : !!****f* m_gstore/gstore_print
1974 : !! NAME
1975 : !! gstore_print
1976 : !!
1977 : !! FUNCTION
1978 : !! Print info on the gstore object.
1979 : !!
1980 : !! INPUTS
1981 : !! units: Unit numbers.
1982 : !! [header]: header string
1983 : !! [prtvol]: Verbosity level.
1984 : !!
1985 : !! SOURCE
1986 :
1987 32 : subroutine gstore_print(gstore, units, header, prtvol)
1988 :
1989 : !Arguments ------------------------------------
1990 : class(gstore_t),intent(inout) :: gstore
1991 : integer,intent(in) :: units(:)
1992 : character(len=*),optional,intent(in) :: header
1993 : integer,optional,intent(in) :: prtvol
1994 :
1995 : !Local variables ------------------------------
1996 : integer,parameter :: max_nk=10
1997 : integer :: my_is, my_prtvol, ik_calc, ik_bz, ik_ibz !, iq_calc, iq_bz, iq_ibz
1998 : real(dp) :: rtot_num_g
1999 : character(len=500) :: msg
2000 : !----------------------------------------------------------------------
2001 :
2002 32 : my_prtvol = 0; if (present(prtvol)) my_prtvol = prtvol
2003 :
2004 32 : if (present(header)) then
2005 0 : call wrtout(units, header)
2006 : else
2007 32 : call wrtout(units, " === Gstore parameters ===")
2008 : end if
2009 :
2010 32 : call wrtout(units, sjoin(" kzone:", gstore%kzone))
2011 32 : call wrtout(units, sjoin(" kfilter:", gstore%kfilter))
2012 32 : call wrtout(units, sjoin(" nkibz:", itoa(gstore%nkibz)))
2013 32 : call wrtout(units, sjoin(" nkbz:", itoa(gstore%nkbz)))
2014 32 : call wrtout(units, sjoin(" glob_nk_spin:", ltoa(gstore%glob_nk_spin)))
2015 32 : call wrtout(units, sjoin(" qzone:", gstore%qzone))
2016 32 : call wrtout(units, sjoin(" nqibz:", itoa(gstore%nqibz)))
2017 32 : call wrtout(units, sjoin(" nqbz:", itoa(gstore%nqbz)))
2018 32 : call wrtout(units, sjoin(" glob_nq_spin:", ltoa(gstore%glob_nq_spin)))
2019 32 : call wrtout(units, sjoin(" kptopt:", itoa(gstore%ebands%kptopt)))
2020 32 : call wrtout(units, sjoin(" qptopt:", itoa(gstore%qptopt)))
2021 32 : call wrtout(units, sjoin(" has_used_lgk:", itoa(gstore%has_used_lgk)))
2022 32 : call wrtout(units, sjoin(" has_used_lgq:", itoa(gstore%has_used_lgq)))
2023 32 : call wrtout(units, sjoin(" with_vk:", itoa(gstore%with_vk)))
2024 :
2025 64 : do my_is=1,gstore%my_nspins
2026 32 : associate (spin => gstore%my_spins(my_is), gqk => gstore%gqk(my_is))
2027 32 : call wrtout(units, sjoin(" gqk_cplex:", itoa(gqk%cplex)), pre_newlines=1)
2028 32 : call wrtout(units, sjoin(" gqk_bstart_k:", itoa(gqk%bstart_k)))
2029 32 : call wrtout(units, sjoin(" gqk_bstart_kq:", itoa(gqk%bstart_kq)))
2030 32 : call wrtout(units, sjoin(" gqk_bstop_k:", itoa(gqk%bstop_k)))
2031 32 : call wrtout(units, sjoin(" gqk_bstop_kq:", itoa(gqk%bstop_kq)))
2032 32 : call wrtout(units, sjoin(" gqk_nb_k:", itoa(gqk%nb_k)))
2033 32 : call wrtout(units, sjoin(" gqk_nb_kq:", itoa(gqk%nb_kq)))
2034 32 : rtot_num_g = (one * gqk%nb_kq * gqk%nb_k) * (gqk%glob_nk * gqk%glob_nq * one) * gqk%natom3
2035 : !call wrtout(units, sjoin(" total number of g(k,q) elements:", ftoa(rtot_num_g)))
2036 32 : call wrtout(units, sjoin(" gqk_my_npert:", itoa(gqk%my_npert)))
2037 32 : call wrtout(units, sjoin("P gqk_my_nk:", itoa(gqk%my_nk)))
2038 32 : call wrtout(units, sjoin("P gqk_my_nq:", itoa(gqk%my_nq)))
2039 32 : call wrtout(units, sjoin(ch10, " === MPI distribution ==="))
2040 32 : call wrtout(units, sjoin("P Number of CPUs for parallelism over perturbations: ", itoa(gqk%pert_comm%nproc)))
2041 32 : call wrtout(units, sjoin("P Number of perturbations treated by this CPU: ", itoa(gqk%my_npert)))
2042 32 : call wrtout(units, sjoin("P Number of CPUs for parallelism over q-points: ", itoa(gqk%qpt_comm%nproc)))
2043 32 : call wrtout(units, sjoin("P Number of CPUs for parallelism over k-points: ", itoa(gqk%kpt_comm%nproc)))
2044 : ! This only for GWPT calculations.
2045 32 : if (gqk%bsum_comm%nproc /= 1) then
2046 0 : call wrtout(units, sjoin("P Number of CPUs for parallelism over band summation: ", itoa(gqk%bsum_comm%nproc)))
2047 : end if
2048 32 : if (gqk%pp_sum_comm%nproc /= 1) then
2049 0 : call wrtout(units, sjoin("P Number of CPUs for parallelism over wavevector summation: ", itoa(gqk%pp_sum_comm%nproc)))
2050 : end if
2051 :
2052 : ! Print k-points
2053 32 : call wrtout(units, " k-points included in gstore:")
2054 226 : do ik_calc=1,gqk%glob_nk
2055 211 : ik_bz = gstore%kglob2bz(ik_calc, spin)
2056 211 : ik_ibz = gstore%kbz2ibz(1, ik_bz)
2057 211 : call wrtout(units, sjoin(itoa(ik_calc), ":", ktoa(gstore%kbz(:, ik_bz))))
2058 226 : if (ik_calc > max_nk .and. my_prtvol == 0) then
2059 17 : call wrtout(units, sjoin(" Max", itoa(max_nk), " k-points will be written. Use prtvol > 0 to print all of them."))
2060 17 : exit
2061 : end if
2062 : end do
2063 : !call wrtout(units, " ")
2064 :
2065 : ! Print q-points
2066 : !call wrtout(units, " q-points included in gstore:")
2067 : !do iq_calc=1,gqk%glob_nq
2068 : ! iq_bz = gstore%qglob2bz(iq_calc, spin)
2069 : ! iq_ibz = gstore%qbz2ibz(1, iq_bz)
2070 : ! call wrtout(units, sjoin(itoa(iq_calc), ":", ktoa(gstore%qbz(:, iq_bz))))
2071 : ! if (iq_calc > max_nk .and. my_prtvol == 0) then
2072 : ! call wrtout(units, sjoin(" Max", itoa(max_nk), " q-points will be written. Use prtvol > 0 to print all of them."))
2073 : ! exit
2074 : ! end if
2075 : !end do
2076 :
2077 : ! Print memory
2078 32 : if (allocated(gqk%my_g2)) then
2079 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for |g|^2 array: ',ABI_MEM_MB(gqk%my_g2),' [mb] <<< mem'
2080 0 : call wrtout(units, msg)
2081 : end if
2082 32 : if (gqk%has_both_g .and. associated(gqk%my_g2_ks)) then
2083 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for |g_KS|^2 array: ',ABI_MEM_MB(gqk%my_g2_ks),' [mb] <<< mem'
2084 0 : call wrtout(units, msg)
2085 : end if
2086 32 : if (allocated(gqk%my_g)) then
2087 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for g array: ',ABI_MEM_MB(gqk%my_g),' [Mb] <<< MEM'
2088 0 : call wrtout(units, msg)
2089 : end if
2090 32 : if (gqk%has_both_g .and. associated(gqk%my_g_ks)) then
2091 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for g_KS array: ',ABI_MEM_MB(gqk%my_g_ks),' [Mb] <<< MEM'
2092 0 : call wrtout(units, msg)
2093 : end if
2094 32 : if (allocated(gqk%my_gdw2)) then
2095 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for gDW^2 array: ',ABI_MEM_MB(gqk%my_gdw2),' [mb] <<< mem'
2096 : end if
2097 32 : if (gqk%has_both_g .and. associated(gqk%my_gdw2_ks)) then
2098 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for gDW^2_KS array: ',ABI_MEM_MB(gqk%my_gdw2_ks),' [mb] <<< mem'
2099 : end if
2100 :
2101 32 : if (allocated(gqk%vnk_cart_ibz)) then
2102 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for vnk_cart_ibz: ',ABI_MEM_MB(gqk%vnk_cart_ibz),' [Mb] <<< MEM'
2103 0 : call wrtout(units, msg)
2104 : end if
2105 32 : if (allocated(gqk%vnk_mat_cart_ibz)) then
2106 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for vnk_mat_cart_ibz: ',ABI_MEM_MB(gqk%vnk_mat_cart_ibz),' [Mb] <<< MEM'
2107 0 : call wrtout(units, msg)
2108 : end if
2109 64 : if (allocated(gqk%my_iv1p_comm)) then
2110 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for <mk|i[V1,p]|nk> array: ',ABI_MEM_MB(gqk%my_iv1p_comm),' [mb] <<< mem'
2111 : end if
2112 : end associate
2113 : end do
2114 :
2115 32 : if (my_prtvol > 0) then
2116 0 : call gstore%ebands%print(units, header="Electron bands in GSTORE", prtvol=my_prtvol)
2117 : end if
2118 32 : call wrtout(units, " ")
2119 :
2120 32 : end subroutine gstore_print
2121 : !!***
2122 :
2123 : !!****f* m_gstore/gstore_check_little_group
2124 : !! NAME
2125 : !! gstore_check_little_group
2126 : !!
2127 : !! FUNCTION
2128 : !! Check consistency between little group options read from file and from input.
2129 : !!
2130 : !! INPUTS
2131 : !!
2132 : !! SOURCE
2133 :
2134 7 : integer function gstore_check_little_group(gstore, dtset, msg) result(ierr)
2135 :
2136 : !Arguments ------------------------------------
2137 : class(gstore_t),intent(in) :: gstore
2138 : type(dataset_type),intent(in) :: dtset
2139 : character(len=*),intent(out) :: msg
2140 : !----------------------------------------------------------------------
2141 :
2142 7 : ierr = 0; msg = ""
2143 :
2144 7 : if (dtset%gstore_use_lgk /= 0) then
2145 : ! Cannot use IBZ_k if we have used IBZ_q.
2146 0 : if (gstore%has_used_lgq /= 0) then
2147 0 : msg = sjoin("Input var gstore_use_lgq: ", itoa(dtset%gstore_use_lgq), ", but GSTORE file has:", itoa(gstore%has_used_lgq))
2148 0 : ABI_ERROR_NOSTOP(msg, ierr)
2149 : end if
2150 : ! Using IBZ_k when GSTORE has full BZ is OK but inefficient.
2151 0 : if (gstore%has_used_lgk == 0) then
2152 0 : msg = sjoin("Input var gstore_use_lgk: ", itoa(dtset%gstore_use_lgk), ", but GSTORE file has:", itoa(gstore%has_used_lgk))
2153 0 : ABI_COMMENT(msg)
2154 : end if
2155 : end if
2156 :
2157 7 : if (dtset%gstore_use_lgq /= 0) then
2158 : ! Cannot use IBZ_q if we have used IBZ_k.
2159 0 : if (gstore%has_used_lgk /= 0) then
2160 0 : msg = sjoin("Input var gstore_use_lgk: ", itoa(dtset%gstore_use_lgk), ", but GSTORE file has:", itoa(gstore%has_used_lgk))
2161 0 : ABI_ERROR_NOSTOP(msg, ierr)
2162 : end if
2163 : ! Using IBZ_q when GSTORE has full BZ is OK but inefficient.
2164 0 : if (gstore%has_used_lgq == 0) then
2165 0 : msg = sjoin("Input var gstore_use_lgq: ", itoa(dtset%gstore_use_lgq), ", but GSTORE file has:", itoa(gstore%has_used_lgq))
2166 0 : ABI_COMMENT(msg)
2167 : end if
2168 : end if
2169 :
2170 7 : end function gstore_check_little_group
2171 : !!***
2172 :
2173 : !----------------------------------------------------------------------
2174 :
2175 : !!****f* m_gstore/gstore_malloc__
2176 : !! NAME
2177 : !! gstore_malloc__
2178 : !!
2179 : !! FUNCTION
2180 : !! Allocate local buffers once the MPI grid has been initialized.
2181 : !!
2182 : !! INPUTS
2183 : !!
2184 : !! OUTPUT
2185 : !!
2186 : !! SOURCE
2187 :
2188 24 : subroutine gstore_malloc__(gstore, with_cplex, has_both_g, max_nq, qglob2bz, max_nk, kglob2bz, qbz2ibz, kbz2ibz)
2189 :
2190 : !Arguments ------------------------------------
2191 : !scalars
2192 : class(gstore_t),target,intent(inout) :: gstore
2193 : integer,intent(in) :: with_cplex, max_nq, max_nk
2194 : logical,intent(in) :: has_both_g
2195 : integer,intent(in) :: qglob2bz(max_nq, gstore%nsppol), kglob2bz(max_nk, gstore%nsppol)
2196 : integer,intent(in) :: qbz2ibz(6, gstore%nqbz), kbz2ibz(6, gstore%nkbz)
2197 :
2198 : !Local variables-------------------------------
2199 : !scalars
2200 : integer :: my_is, ierr, my_iq, my_ik, iq_glob, iq_bz, ik_glob, ik_bz
2201 : integer :: ik_ibz, isym_k, trev_k, tsign_k, g0_k(3), nb_k, nb_kq
2202 : logical :: isirr_k
2203 : real(dp) :: mem_mb
2204 : type(gqk_t), pointer :: gqk
2205 : !----------------------------------------------------------------------
2206 :
2207 24 : ABI_CHECK(with_cplex >= 0 .and. with_cplex <= 2, sjoin("Invalid with_cplex:", itoa(with_cplex)))
2208 24 : gstore%with_cplex = with_cplex
2209 :
2210 48 : do my_is=1,gstore%my_nspins
2211 24 : associate (spin => gstore%my_spins(my_is))
2212 24 : gqk => gstore%gqk(my_is)
2213 24 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
2214 24 : gqk%has_both_g = has_both_g
2215 :
2216 : ! Split q-points and transfer symmetry tables.
2217 : ! Note that glob_nq and glob_nk does not necessarily correspond to the size of the BZ
2218 : ! First of all we have to consider kzone
2219 : ! Even if kzone == "bz" we may have filtered the wavevectors e.g. Fermi surface.
2220 24 : call xmpi_split_block(gqk%glob_nq, gqk%qpt_comm%value, gqk%my_nq, gqk%my_q2glob)
2221 24 : ABI_CHECK(gqk%my_nq > 0, sjoin("glob_nq:", itoa(gqk%glob_nq), ", qpt_comm%nproc:", itoa(gqk%qpt_comm%nproc), " => my_nq == 0"))
2222 24 : gqk%my_qstart = gqk%my_q2glob(1)
2223 :
2224 72 : ABI_MALLOC(gqk%my_q2ibz, (6, gqk%my_nq))
2225 72 : ABI_MALLOC(gqk%my_q2bz, (gqk%my_nq))
2226 :
2227 2330 : do my_iq=1,gqk%my_nq
2228 2306 : iq_glob = my_iq + gqk%my_qstart - 1
2229 2306 : iq_bz = qglob2bz(iq_glob, spin)
2230 16142 : gqk%my_q2ibz(:, my_iq) = qbz2ibz(:, iq_bz)
2231 2330 : gqk%my_q2bz(my_iq) = iq_bz
2232 : end do
2233 :
2234 : ! Split k-points and transfer symmetry tables
2235 24 : call xmpi_split_block(gqk%glob_nk, gqk%kpt_comm%value, gqk%my_nk, gqk%my_k2glob)
2236 24 : ABI_CHECK(gqk%my_nk > 0, sjoin("glob_nk:", itoa(gqk%glob_nk), ", kpt_comm%nproc:", itoa(gqk%kpt_comm%nproc), " => my_nk == 0"))
2237 24 : gqk%my_kstart = gqk%my_k2glob(1)
2238 :
2239 72 : ABI_MALLOC(gqk%my_k2ibz, (6, gqk%my_nk))
2240 : !ABI_MALLOC(gqk%my_k2bz, (gqk%my_nk))
2241 72 : ABI_MALLOC(gqk%my_kpts, (3, gqk%my_nk))
2242 72 : ABI_MALLOC(gqk%my_wtk, (gqk%my_nk))
2243 :
2244 1020 : do my_ik=1,gqk%my_nk
2245 996 : ik_glob = my_ik + gqk%my_kstart - 1
2246 996 : ik_bz = kglob2bz(ik_glob, spin)
2247 6972 : gqk%my_k2ibz(:, my_ik) = kbz2ibz(:, ik_bz)
2248 : !gqk%my_k2bz(my_ik) = ik_bz
2249 :
2250 996 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
2251 3984 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5, my_ik)
2252 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
2253 996 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
2254 :
2255 : ! Note symrel^T convention for k
2256 30876 : gqk%my_kpts(:, my_ik) = tsign_k * matmul(transpose(gstore%cryst%symrel(:,:,isym_k)), gstore%kibz(:, ik_ibz)) + g0_k
2257 :
2258 24 : select case(gstore%kzone)
2259 : case ("ibz")
2260 18 : gqk%my_wtk(my_ik) = gstore%ebands%wtk(ik_ibz)
2261 : case ("bz")
2262 996 : gqk%my_wtk(my_ik) = one / gstore%nkbz
2263 : end select
2264 : end do
2265 :
2266 : ! Allocate storage for MPI-distributed e-ph matrix elements.
2267 48 : if (with_cplex > 0) then
2268 16 : mem_mb = (one * with_cplex * gqk%my_npert) * gqk%my_nq * gqk%my_nk * nb_kq * nb_k * eight * b2Mb
2269 16 : call wrtout(std_out, sjoin(" Local memory for e-ph matrix elements:", ftoa(mem_mb, fmt="f8.1"), " [Mb] <<< MEM"))
2270 :
2271 : ! The initialization with zero is important as not all the g are computed when we filter in k-space.
2272 : ! Abinit postprocessing tools will operate of the full my_g array
2273 : ! and we don't want to trigger floating point exceptions.
2274 6 : select case (with_cplex)
2275 : case (1)
2276 42 : ABI_MALLOC_OR_DIE(gqk%my_g2, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk), ierr)
2277 76305 : gqk%my_g2 = zero
2278 :
2279 6 : gqk%my_g2_ks => gqk%my_g2
2280 6 : if (gqk%has_both_g) then
2281 35 : ABI_MALLOC_OR_DIE(gqk%my_g2_ks, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk), ierr)
2282 40203 : gqk%my_g2_ks = zero
2283 : end if
2284 : case (2)
2285 70 : ABI_MALLOC_OR_DIE(gqk%my_g, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk), ierr)
2286 4224533 : gqk%my_g = zero
2287 :
2288 10 : gqk%my_g_ks => gqk%my_g
2289 10 : if (gqk%has_both_g) then
2290 : !call wrtout(std_out, "Allocating my_g_ks") !; stop
2291 7 : ABI_MALLOC_OR_DIE(gqk%my_g_ks, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk), ierr)
2292 18182 : gqk%my_g_ks = zero
2293 : end if
2294 : case default
2295 16 : ABI_ERROR(sjoin("Wrong with_cplex:", itoa(with_cplex)))
2296 : end select
2297 :
2298 : ! Allocate storage for MPI-distributed dH/dk matrix elements.
2299 16 : if (any(gstore%with_vk == [1, 2])) then
2300 16 : mem_mb = 3 * gqk%nb_k * gqk%my_nk * eight * b2Mb
2301 16 : call wrtout(std_out, sjoin(" Memory for diagonal vnk_cart_ibz:", ftoa(mem_mb, fmt="f8.1"), " [Mb] <<< MEM"))
2302 64 : ABI_MALLOC_OR_DIE(gqk%vnk_cart_ibz, (3, gqk%nb_k, gstore%nkibz), ierr)
2303 2087 : gqk%vnk_cart_ibz = zero
2304 : end if
2305 :
2306 16 : if (gstore%with_vk == 2) then
2307 0 : mem_mb = two * 3 * gqk%nb_k**2 * gqk%my_nk * eight * b2Mb
2308 0 : call wrtout(std_out, sjoin(" Memory for vnk_mat_cart_ibz:", ftoa(mem_mb, fmt="f8.1"), " [Mb] <<< MEM"))
2309 0 : ABI_MALLOC_OR_DIE(gqk%vnk_mat_cart_ibz, (2, 3, gqk%nb_k, gqk%nb_k, gstore%nkibz), ierr)
2310 0 : gqk%vnk_mat_cart_ibz = zero
2311 : end if
2312 : end if
2313 :
2314 : end associate
2315 : end do ! my_is
2316 :
2317 24 : end subroutine gstore_malloc__
2318 : !!***
2319 :
2320 : !----------------------------------------------------------------------
2321 :
2322 : !!****f* m_gstore/gstore_filter_fs_tetra__
2323 : !! NAME
2324 : !! gstore_filter_fs_tetra__
2325 : !!
2326 : !! FUNCTION
2327 : !! Compute delta(e_k - e_F) with the tetrahedron method. Use weights to filter k-points.
2328 : !! Include only those q-points such that there exists at least one k on the FS with k + q on the FS.
2329 : !! Also, store and precompute gstore%delta_ef_kibz_spin(max_nb, gstore%nkibz, nsppol)
2330 : !! to be used to filter inside gstore%compute.
2331 : !!
2332 : !! INPUTS
2333 : !!
2334 : !! OUTPUT
2335 : !!
2336 : !! SOURCE
2337 :
2338 0 : subroutine gstore_filter_fs_tetra__(gstore, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
2339 :
2340 : !Arguments ------------------------------------
2341 : !scalars
2342 : class(gstore_t),intent(inout) :: gstore
2343 : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2344 : integer,intent(in) :: kibz2bz(gstore%nkibz)
2345 : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2346 : integer,intent(out) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2347 :
2348 : !Local variables-------------------------------
2349 : !scalars
2350 : integer,parameter :: tetra_opt0 = 0
2351 : integer :: nsppol, ierr, cnt, spin, band, ib, ii, max_nb, all_nproc, my_rank, comm
2352 : integer :: ik_bz, ik_ibz, iflag, nk_in_star
2353 : real(dp) :: max_occ
2354 : character(len=80) :: error_string
2355 0 : type(htetra_t) :: ktetra
2356 : !arrays
2357 0 : integer,allocatable :: indkk(:), kstar_bz_inds(:)
2358 : real(dp):: rlatt(3,3), klatt(3,3), delta_theta_ef(2) !, qpt(3)
2359 0 : real(dp),allocatable :: eig_ibz(:)
2360 : !----------------------------------------------------------------------
2361 :
2362 : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2363 :
2364 0 : comm = gstore%comm; all_nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
2365 0 : nsppol = gstore%nsppol
2366 :
2367 : !ABI_CHECK(gstore%same_nbands(msg), sjoin("VarPEq requires nb_k == nb_kq.", msg))
2368 :
2369 : ! Use the tetrahedron method to filter k- and k+q points on the FS in metals
2370 : ! and define gstore%brange_k_spin automatically.
2371 0 : call wrtout(std_out, sjoin(" Filtering k-points using:", gstore%kfilter))
2372 :
2373 : ! NB: here we precompute brange_k_spin
2374 : ! nb_kq == nb_k when FS filtering with tetra is used.
2375 0 : call ebands%get_bands_e0(ebands%fermie, gstore%brange_k_spin, ierr)
2376 0 : ABI_CHECK(ierr == 0, "Error in ebands_get_bands_e0")
2377 0 : gstore%brange_kq_spin = gstore%brange_k_spin
2378 :
2379 0 : ABI_MALLOC(indkk, (gstore%nkbz))
2380 0 : indkk(:) = gstore%kbz2ibz(1, :)
2381 :
2382 0 : rlatt = ebands%kptrlatt; call matr3inv(rlatt, klatt)
2383 : call ktetra%init(indkk, gstore%cryst%gprimd, klatt, gstore%kbz, gstore%nkbz, gstore%kibz, gstore%nkibz, &
2384 0 : ierr, error_string, gstore%comm)
2385 0 : ABI_CHECK(ierr == 0, error_string)
2386 :
2387 0 : ABI_MALLOC(eig_ibz, (gstore%nkibz))
2388 0 : max_occ = two / (ebands%nspinor * nsppol)
2389 0 : select_kbz_spin = 0
2390 :
2391 0 : max_nb = maxval(gstore%brange_k_spin(2, :) - gstore%brange_k_spin(1, :) + 1)
2392 0 : ABI_CALLOC(gstore%delta_ef_kibz_spin, (max_nb, gstore%nkibz, gstore%nsppol))
2393 :
2394 : cnt = 0
2395 0 : do spin=1,nsppol
2396 0 : do band=gstore%brange_k_spin(1, spin), gstore%brange_k_spin(2, spin)
2397 0 : ib = band - gstore%brange_k_spin(1, spin) + 1
2398 0 : eig_ibz = ebands%eig(band, :, spin)
2399 :
2400 0 : do ik_ibz=1,gstore%nkibz
2401 0 : cnt = cnt + 1; if (mod(cnt, all_nproc) /= my_rank) cycle ! MPI parallelism inside comm
2402 :
2403 : call ktetra%get_onewk_wvals(ik_ibz, tetra_opt0, 1, [ebands%fermie], max_occ, &
2404 0 : gstore%nkibz, eig_ibz, delta_theta_ef)
2405 :
2406 0 : gstore%delta_ef_kibz_spin(ib, ik_ibz, spin) = delta_theta_ef(1)
2407 :
2408 0 : iflag = merge(1, 0, abs(delta_theta_ef(1)) > zero)
2409 :
2410 : ! Use iflag to filter k-points.
2411 0 : select case (gstore%kzone)
2412 : case ("ibz")
2413 0 : ik_bz = kibz2bz(ik_ibz)
2414 0 : select_kbz_spin(ik_bz, spin) = select_kbz_spin(ik_bz, spin) + iflag
2415 :
2416 : case ("bz")
2417 0 : call star_from_ibz_idx(ik_ibz, gstore%nkbz, gstore%kbz2ibz, nk_in_star, kstar_bz_inds)
2418 0 : ABI_CHECK(nk_in_star > 0, "Something wrong in star_from_ibz_idx")
2419 0 : do ii=1,nk_in_star
2420 0 : ik_bz = kstar_bz_inds(ii)
2421 0 : select_kbz_spin(ik_bz, spin) = select_kbz_spin(ik_bz, spin) + iflag
2422 : end do
2423 0 : ABI_FREE(kstar_bz_inds)
2424 : end select
2425 : end do
2426 :
2427 : end do
2428 : end do
2429 :
2430 : !call ktetra%print(std_out)
2431 0 : call xmpi_sum(select_kbz_spin, comm, ierr)
2432 0 : call xmpi_sum(gstore%delta_ef_kibz_spin, comm, ierr)
2433 :
2434 : ! Now the tricky part as we want to remove q-points that
2435 : ! do not lead to any scattering process between two states on the FS
2436 : ! Remember that k+q is always a sub-mesh of the input ebands k-mesh.
2437 :
2438 : call recompute_select_qbz_spin(gstore, gstore%qbz, qbz2ibz, qibz2bz, gstore%kbz, gstore%kibz, gstore%kbz2ibz, kibz2bz, &
2439 0 : select_kbz_spin, select_qbz_spin)
2440 :
2441 0 : ABI_FREE(eig_ibz)
2442 0 : ABI_FREE(indkk)
2443 0 : call ktetra%free()
2444 : end associate
2445 :
2446 0 : end subroutine gstore_filter_fs_tetra__
2447 : !!***
2448 :
2449 : !----------------------------------------------------------------------
2450 :
2451 : !!****f* m_gstore/gstore_filter_kptgw__
2452 : !! NAME
2453 : !! gstore_gw_filter_kptgw__
2454 : !!
2455 : !! FUNCTION
2456 : !! Filter k-points according to the input variable kptgw. Useful for ZPR for user-specified k-points.
2457 : !!
2458 : !! INPUTS
2459 : !!
2460 : !! OUTPUT
2461 : !!
2462 : !! SOURCE
2463 :
2464 0 : subroutine gstore_filter_kptgw__(gstore, dtset, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
2465 :
2466 : !Arguments ------------------------------------
2467 : !scalars
2468 : class(gstore_t),intent(inout) :: gstore
2469 : type(dataset_type),intent(in) :: dtset
2470 : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2471 : integer,intent(in) :: kibz2bz(gstore%nkibz)
2472 : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2473 : integer,intent(out) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2474 :
2475 : !Local variables-------------------------------
2476 : !scalars
2477 : integer :: spin, ik_bz, ik_ibz, ik_calc, nkcalc, mapl_kk(6), my_rank
2478 : !arrays
2479 0 : integer,allocatable :: bstart_ks(:,:), nbcalc_ks(:,:)
2480 0 : real(dp),allocatable :: kcalc(:,:)
2481 : !----------------------------------------------------------------------
2482 :
2483 : ABI_UNUSED(qbz2ibz)
2484 : ABI_UNUSED(qibz2bz)
2485 :
2486 : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2487 :
2488 0 : my_rank = xmpi_comm_rank(gstore%comm)
2489 :
2490 0 : call wrtout(std_out, sjoin(" Filtering k-points using nkptgw:", itoa(dtset%nkptgw)))
2491 0 : if (gstore%qzone /= "bz") then
2492 0 : ABI_ERROR(sjoin('gw_qprange filtering requires gstore_qzone = "bz" while it is: ', gstore%qzone))
2493 : end if
2494 :
2495 : ! Compute nkcalc, kcalc, bstart_ks, nbcalc_ks
2496 0 : call sigtk_kcalc_from_nkptgw(dtset, dtset%mband, nkcalc, kcalc, bstart_ks, nbcalc_ks)
2497 :
2498 : ! TODO: kcalc should be spin-dependent to handle magnetic semiconductors.
2499 0 : select_kbz_spin = 0
2500 0 : do spin=1,gstore%nsppol
2501 0 : do ik_calc=1,nkcalc
2502 0 : if (kpts_map("symrel", ebands%kptopt, gstore%cryst, gstore%krank_ibz, 1, kcalc(:,ik_calc), mapl_kk) /= 0) then
2503 0 : ABI_ERROR(sjoin("Cannot map kcalc to IBZ with kcalc:", ktoa(kcalc(:,ik_calc))))
2504 : end if
2505 : ! Change select_kbz_spin
2506 0 : ik_ibz = mapl_kk(1)
2507 0 : ik_bz = kibz2bz(ik_ibz); select_kbz_spin(ik_bz, spin) = 1
2508 : end do
2509 : end do ! spin
2510 :
2511 : !call recompute_select_qbz_spin(gstore, gstore%qbz, qbz2ibz, qibz2bz, gstore%kbz, gstore%kibz, gstore%kbz2ibz, gstore%kibz2bz, &
2512 : ! select_kbz_spin, select_qbz_spin)
2513 :
2514 0 : ABI_FREE(kcalc)
2515 0 : ABI_FREE(bstart_ks)
2516 0 : ABI_FREE(nbcalc_ks)
2517 : end associate
2518 :
2519 0 : end subroutine gstore_filter_kptgw__
2520 : !!***
2521 :
2522 : !----------------------------------------------------------------------
2523 :
2524 : !!****f* m_gstore/gstore_filter_erange__
2525 : !! NAME
2526 : !! gstore_filter_erange__
2527 : !!
2528 : !! FUNCTION
2529 : !! Filter k-points and q-points according to an energy range.
2530 : !!
2531 : !! INPUTS
2532 : !!
2533 : !! OUTPUT
2534 : !!
2535 : !! SOURCE
2536 :
2537 1 : subroutine gstore_filter_erange__(gstore, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
2538 :
2539 : !Arguments ------------------------------------
2540 : !scalars
2541 : class(gstore_t),intent(inout) :: gstore
2542 : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2543 : integer,intent(in) :: kibz2bz(gstore%nkibz)
2544 : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2545 : integer,intent(out) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2546 :
2547 : !Local variables-------------------------------
2548 : !scalars
2549 : integer,parameter :: tetra_opt0 = 0
2550 : integer :: nsppol, cnt, spin, ii, all_nproc, my_rank, comm, band ! ierr,
2551 : integer :: ik_bz, ik_ibz, iflag, nk_in_star, gap_err
2552 : logical :: assume_gap
2553 : real(dp) :: ee, abs_erange1, abs_erange2, vmax, cmin
2554 : type(gaps_t) :: gaps
2555 : !arrays
2556 1 : integer,allocatable :: kstar_bz_inds(:)
2557 : !----------------------------------------------------------------------
2558 :
2559 : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2560 :
2561 1 : comm = gstore%comm; all_nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
2562 1 : nsppol = gstore%nsppol
2563 :
2564 : ! filter k and k + q points according to erange and define gstore%brange_spin_k automatically.
2565 : ! NB: here we recompute brange_k_spin
2566 : call wrtout(std_out, sjoin(" Filtering k-points using gstore_erange:", &
2567 4 : ltoa(reshape(gstore%erange_spin, [2 * gstore%nsppol]) * Ha_eV), "(eV)"))
2568 :
2569 1 : assume_gap = .not. all(gstore%erange_spin < zero)
2570 1 : gaps = ebands%get_gaps(gap_err)
2571 2 : if (assume_gap) call gaps%print([std_out])
2572 :
2573 2199 : select_kbz_spin = 0; cnt = 0
2574 :
2575 2 : do spin=1,nsppol
2576 : ! Init brange. NB: nb_kq == nb_k when erange filtering is used.
2577 3 : gstore%brange_k_spin(:, spin) = [huge(1), -huge(1)]
2578 3 : gstore%brange_kq_spin(:, spin) = [huge(1), -huge(1)]
2579 1 : abs_erange1 = abs(gstore%erange_spin(1, spin))
2580 1 : abs_erange2 = abs(gstore%erange_spin(2, spin))
2581 :
2582 1 : if (assume_gap) then
2583 : ! Get CBM and VBM with some tolerance
2584 1 : vmax = gaps%vb_max(spin) + tol2 * eV_Ha
2585 1 : cmin = gaps%cb_min(spin) - tol2 * eV_Ha
2586 : else
2587 0 : vmax = ebands%fermie
2588 0 : cmin = ebands%fermie
2589 : end if
2590 :
2591 7 : do band=1, ebands%mband
2592 511 : do ik_ibz=1,gstore%nkibz
2593 : !cnt = cnt + 1; if (mod(cnt, all_nproc) /= my_rank) cycle ! MPI parallelism inside comm
2594 :
2595 : ! Use iflag to filter k-points.
2596 504 : ee = ebands%eig(band, ik_ibz, spin)
2597 504 : iflag = 0
2598 :
2599 504 : if (abs_erange1 > zero) then
2600 : ! Filter valence states.
2601 0 : if (ee <= vmax .and. vmax - ee <= abs_erange1) then
2602 504 : iflag = 1 !; write(std_out, *), "Adding valence band", band, " with ee [eV]: ", ee * Ha_eV
2603 : end if
2604 : end if
2605 504 : if (abs_erange2 > zero) then
2606 : ! Filter conduction states.
2607 504 : if (ee >= cmin .and. ee - cmin <= abs_erange2) then
2608 : iflag = 1 !; write(std_out, *)"Adding conduction band", band, " with ee [eV]: ", ee * Ha_eV
2609 : end if
2610 : end if
2611 :
2612 502 : if (iflag == 1) then
2613 8 : gstore%brange_k_spin(1, spin) = min(gstore%brange_k_spin(1, spin), band)
2614 8 : gstore%brange_k_spin(2, spin) = max(gstore%brange_k_spin(2, spin), band)
2615 8 : gstore%brange_kq_spin(1, spin) = min(gstore%brange_kq_spin(1, spin), band)
2616 8 : gstore%brange_kq_spin(2, spin) = max(gstore%brange_kq_spin(2, spin), band)
2617 :
2618 0 : select case (gstore%kzone)
2619 : case ("ibz")
2620 0 : ik_bz = kibz2bz(ik_ibz)
2621 0 : select_kbz_spin(ik_bz, spin) = iflag
2622 :
2623 : case ("bz")
2624 8 : call star_from_ibz_idx(ik_ibz, gstore%nkbz, gstore%kbz2ibz, nk_in_star, kstar_bz_inds)
2625 8 : ABI_CHECK(nk_in_star > 0, "Something wrong in star_from_ibz_idx")
2626 97 : do ii=1,nk_in_star
2627 89 : ik_bz = kstar_bz_inds(ii)
2628 97 : select_kbz_spin(ik_bz, spin) = iflag
2629 : end do
2630 16 : ABI_FREE(kstar_bz_inds)
2631 : end select
2632 : end if
2633 :
2634 : end do ! band
2635 : end do ! ik_ibz
2636 :
2637 : !call wrtout(std_out, sjoin("brange_k_spin:", ltoa(gstore%brange_k_spin(:, spin))))
2638 : !call wrtout(std_out, sjoin("count_select_kbz:", itoa(count(select_kbz_spin == 1))))
2639 : !call wrtout(std_out, sjoin("brange_kq_spin:", ltoa(gstore%brange_k_qspin(:, spin))))
2640 : !call wrtout(std_out, sjoin("count_select_kbz:", itoa(count(select_kbz_spin == 1))))
2641 :
2642 3 : if (any(gstore%brange_k_spin(:, spin) == [huge(1), -huge(1)])) then
2643 0 : ABI_ERROR("Empty list of states inside gstore_erange")
2644 : end if
2645 4 : if (any(gstore%brange_kq_spin(:, spin) == [huge(1), -huge(1)])) then
2646 0 : ABI_ERROR("Empty list of states inside gstore_erange")
2647 : end if
2648 :
2649 : end do ! spin
2650 :
2651 : !call xmpi_sum(select_kbz_spin, comm, ierr)
2652 : call recompute_select_qbz_spin(gstore, gstore%qbz, qbz2ibz, qibz2bz, gstore%kbz, gstore%kibz, gstore%kbz2ibz, kibz2bz, &
2653 1 : select_kbz_spin, select_qbz_spin)
2654 :
2655 2 : call gaps%free()
2656 : end associate
2657 :
2658 1 : end subroutine gstore_filter_erange__
2659 : !!***
2660 :
2661 : !----------------------------------------------------------------------
2662 :
2663 : !!****f* m_gstore/gstore_filter_gw_qprange__
2664 : !! NAME
2665 : !! gstore_gw_filter_qprange__
2666 : !!
2667 : !! FUNCTION
2668 : !! Filter k-points according to the input variable gw_qprange. Useful for ZPR.
2669 : !!
2670 : !! INPUTS
2671 : !!
2672 : !! OUTPUT
2673 : !!
2674 : !! SOURCE
2675 :
2676 4 : subroutine gstore_filter_gw_qprange__(gstore, dtset, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
2677 :
2678 : !Arguments ------------------------------------
2679 : !scalars
2680 : class(gstore_t),intent(inout) :: gstore
2681 : type(dataset_type),intent(in) :: dtset
2682 : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2683 : integer,intent(in) :: kibz2bz(gstore%nkibz)
2684 : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2685 : integer,intent(out) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2686 :
2687 : !Local variables-------------------------------
2688 : !scalars
2689 : integer :: spin, ik_bz, ik_ibz, gap_err, ik_calc, nkcalc, mapl_kk(6), my_rank
2690 4 : type(gaps_t) :: gaps
2691 : !arrays
2692 4 : integer,allocatable :: bstart_ks(:,:), nbcalc_ks(:,:)
2693 4 : real(dp),allocatable :: kcalc(:,:)
2694 : !----------------------------------------------------------------------
2695 :
2696 : ABI_UNUSED(qbz2ibz)
2697 : ABI_UNUSED(qibz2bz)
2698 :
2699 : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2700 :
2701 8 : my_rank = xmpi_comm_rank(gstore%comm)
2702 :
2703 4 : call wrtout(std_out, sjoin(" Filtering k-points using gw_qprange:", itoa(dtset%gw_qprange)))
2704 4 : if (gstore%qzone /= "bz") then
2705 0 : ABI_ERROR(sjoin('gw_qprange filtering requires gstore_qzone = "bz" while it is: ', gstore%qzone))
2706 : end if
2707 :
2708 4 : gaps = ebands%get_gaps(gap_err)
2709 8 : if (my_rank == 0) call gaps%print([std_out])
2710 4 : if (gap_err /= 0) then
2711 0 : ABI_ERROR("Cannot compute fundamental and direct gap (likely metal).")
2712 : end if
2713 :
2714 : ! Use gw_qprange to select the interesting k-points and the corresponding bands.
2715 : !
2716 : ! 0 --> Compute the QP corrections only for the fundamental and the direct gap.
2717 : ! +num --> Compute the QP corrections for all the k-points in the irreducible zone and include `num`
2718 : ! bands above and below the Fermi level.
2719 : ! -num --> Compute the QP corrections for all the k-points in the irreducible zone.
2720 : ! Include all occupied states and `num` empty states.
2721 :
2722 : ! Compute nkcalc, kcalc, bstart_ks, nbcalc_ks
2723 4 : if (dtset%gw_qprange /= 0) then
2724 0 : call sigtk_kcalc_from_qprange(dtset, gstore%cryst, ebands, dtset%gw_qprange, nkcalc, kcalc, bstart_ks, nbcalc_ks)
2725 : else
2726 : ! gw_qprange is not specified in the input.
2727 : ! Include direct and fundamental KS gap or include states depending on the position wrt band edges.
2728 4 : call sigtk_kcalc_from_gaps(dtset, ebands, gaps, nkcalc, kcalc, bstart_ks, nbcalc_ks)
2729 : end if
2730 :
2731 : ! TODO: kcalc should be spin-dependent to handle magnetic semiconductors.
2732 152 : select_kbz_spin = 0
2733 8 : do spin=1,gstore%nsppol
2734 14 : do ik_calc=1,nkcalc
2735 6 : if (kpts_map("symrel", ebands%kptopt, gstore%cryst, gstore%krank_ibz, 1, kcalc(:,ik_calc), mapl_kk) /= 0) then
2736 0 : ABI_ERROR(sjoin("Cannot map kcalc to IBZ with kcalc:", ktoa(kcalc(:,ik_calc))))
2737 : end if
2738 : ! Change select_kbz_spin
2739 6 : ik_ibz = mapl_kk(1)
2740 10 : ik_bz = kibz2bz(ik_ibz); select_kbz_spin(ik_bz, spin) = 1
2741 : end do
2742 : end do ! spin
2743 :
2744 : !call recompute_select_qbz_spin(gstore, gstore%qbz, qbz2ibz, qibz2bz, gstore%kbz, gstore%kibz, gstore%kbz2ibz, gstore%kibz2bz, &
2745 : ! select_kbz_spin, select_qbz_spin)
2746 :
2747 4 : ABI_FREE(kcalc)
2748 4 : ABI_FREE(bstart_ks)
2749 4 : ABI_FREE(nbcalc_ks)
2750 8 : call gaps%free()
2751 : end associate
2752 :
2753 4 : end subroutine gstore_filter_gw_qprange__
2754 : !!***
2755 :
2756 : !!****f* m_gstore/recompute_select_qbz_spin
2757 : !! NAME
2758 : !! recompute_select_qbz_spin
2759 : !!
2760 : !! FUNCTION
2761 : !! Recompute select_qbz_spin table after the filtering on the k-points.
2762 : !!
2763 : !! INPUTS
2764 : !!
2765 : !! OUTPUT
2766 : !!
2767 : !! SOURCE
2768 :
2769 1 : subroutine recompute_select_qbz_spin(gstore, qbz, qbz2ibz, qibz2bz, kbz, kibz, kbz2ibz, kibz2bz, &
2770 1 : select_kbz_spin, select_qbz_spin)
2771 :
2772 : !Arguments ------------------------------------
2773 : !scalars
2774 : class(gstore_t),intent(inout) :: gstore
2775 : !arrays
2776 : real(dp),intent(in) :: qbz(3, gstore%nqbz)
2777 : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2778 : integer,intent(in) :: kbz2ibz(6,gstore%nkbz), kibz2bz(gstore%nkibz)
2779 : real(dp),target,intent(in) :: kibz(3, gstore%nkibz), kbz(3, gstore%nkbz)
2780 : integer,intent(in) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2781 : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2782 :
2783 : !Local variables-------------------------------
2784 : !scalars
2785 : integer :: all_nproc, my_rank, ierr, ii, ik_bz, iq_bz, iq_ibz, ikq_ibz, ikq_bz, len_kpts_ptr, ebands_kptopt, spin
2786 : !arrays
2787 1 : integer,allocatable :: map_kq(:,:)
2788 : real(dp) :: qpt(3)
2789 1 : real(dp),contiguous, pointer :: kpts_ptr(:,:)
2790 : ! *************************************************************************
2791 :
2792 : ABI_UNUSED(kbz2ibz)
2793 : ABI_UNUSED(qbz2ibz)
2794 :
2795 1 : all_nproc = xmpi_comm_size(gstore%comm); my_rank = xmpi_comm_rank(gstore%comm)
2796 1 : ebands_kptopt = gstore%ebands%kptopt
2797 :
2798 2199 : select_qbz_spin = 0
2799 :
2800 1 : if (gstore%kzone == "ibz") kpts_ptr => kibz
2801 1 : if (gstore%kzone == "bz") kpts_ptr => kbz
2802 1 : len_kpts_ptr = size(kpts_ptr, dim=2)
2803 3 : ABI_MALLOC(map_kq, (6, len_kpts_ptr))
2804 :
2805 0 : select case (gstore%qzone)
2806 : case ("ibz")
2807 0 : do iq_ibz=1,gstore%nqibz
2808 0 : if (mod(iq_ibz, all_nproc) /= my_rank) cycle ! MPI parallelism.
2809 0 : qpt = gstore%qibz(:, iq_ibz)
2810 0 : iq_bz = qibz2bz(iq_ibz)
2811 : ! k + q_ibz --> k IBZ --> k BZ
2812 :
2813 0 : if (kpts_map("symrel", ebands_kptopt, gstore%cryst, gstore%krank_ibz, len_kpts_ptr, kpts_ptr, map_kq, qpt=qpt) /= 0) then
2814 0 : ABI_ERROR("Cannot map k+q to IBZ!")
2815 : end if
2816 :
2817 0 : do ii=1,len_kpts_ptr
2818 : ! get the k-index in BZ
2819 0 : select case (gstore%kzone)
2820 : case ("bz")
2821 0 : ik_bz = ii
2822 : case ("ibz")
2823 0 : ik_bz = kibz2bz(ii)
2824 : end select
2825 :
2826 0 : do spin=1,gstore%nsppol
2827 0 : if (select_kbz_spin(ik_bz, spin) /= 0) then
2828 : ! now, see if q-point connects k-points inside the filtered zone
2829 0 : ikq_ibz = map_kq(1, ii)
2830 0 : ikq_bz = kibz2bz(ikq_ibz)
2831 0 : select_qbz_spin(iq_bz, :) = select_qbz_spin(iq_bz, :) + select_kbz_spin(ikq_bz, :)
2832 : end if
2833 : end do
2834 : end do
2835 : end do ! iq_ibz
2836 :
2837 : case ("bz")
2838 2198 : do iq_bz=1,gstore%nqbz
2839 2197 : if (mod(iq_bz, all_nproc) /= my_rank) cycle ! MPI parallelism.
2840 8788 : qpt = qbz(:, iq_bz)
2841 : !iq_ibz = qbz2ibz(1, iq_bz)
2842 : ! k + q_bz --> k IBZ --> k BZ
2843 :
2844 2197 : if (kpts_map("symrel", ebands_kptopt, gstore%cryst, gstore%krank_ibz, len_kpts_ptr, kpts_ptr, map_kq, qpt=qpt) /= 0) then
2845 0 : ABI_ERROR("Cannot map k+q to IBZ!")
2846 : end if
2847 :
2848 : ! here we loop over all k-points in iBZ (kzone="ibz") or BZ (kzone="bz")
2849 4829007 : do ii=1,len_kpts_ptr
2850 : ! but for each spin, we have to loop only over e-range filtered kpts
2851 :
2852 : ! get the k-index in BZ
2853 9653618 : select case (gstore%kzone)
2854 : case ("bz")
2855 4826809 : ik_bz = ii
2856 : case ("ibz")
2857 4826809 : ik_bz = kibz2bz(ii)
2858 : end select
2859 :
2860 9655815 : do spin=1,gstore%nsppol
2861 : ! Now, see if q-point connects k-points inside the filtered zone
2862 9653618 : if (select_kbz_spin(ik_bz, spin) /= 0) then
2863 195533 : ikq_ibz = map_kq(1, ii)
2864 195533 : ikq_bz = kibz2bz(ikq_ibz)
2865 195533 : select_qbz_spin(iq_bz, spin) = select_qbz_spin(iq_bz, spin) + select_kbz_spin(ikq_bz, spin)
2866 : end if
2867 : end do
2868 :
2869 : end do
2870 : end do
2871 : end select
2872 :
2873 1 : call xmpi_sum(select_qbz_spin, gstore%comm, ierr)
2874 :
2875 1 : ABI_FREE(map_kq)
2876 :
2877 1 : end subroutine recompute_select_qbz_spin
2878 : !!***
2879 :
2880 : !!****f* m_gstore/gstore_spin2my_is
2881 : !! NAME
2882 : !! gstore_spin2my_is
2883 : !!
2884 : !! FUNCTION
2885 : !! Return the local spin index from the global spin index.
2886 : !! 0 if this spin is not treated by this MPI proc.
2887 : !!
2888 : !! SOURCE
2889 :
2890 16 : integer pure function gstore_spin2my_is(gstore, spin) result(my_is)
2891 :
2892 : !Arguments ------------------------------------
2893 : class(gstore_t),intent(in) :: gstore
2894 : integer,intent(in) :: spin
2895 : !----------------------------------------------------------------------
2896 :
2897 16 : do my_is=1,gstore%my_nspins
2898 16 : if (gstore%my_spins(my_is) == spin) return
2899 : end do
2900 16 : my_is = 0
2901 :
2902 : end function gstore_spin2my_is
2903 : !!***
2904 :
2905 : !----------------------------------------------------------------------
2906 :
2907 : !!****f* m_gstore/gstore_fill_bks_mask
2908 : !! NAME
2909 : !! gstore_fill_bks_mask
2910 : !!
2911 : !! FUNCTION
2912 : !! Fills the bks_mask array defining the set of wavefunctions that should be read
2913 : !! from the WFK file by this MPI rank when computing the KS e-ph matrix elements.
2914 : !!
2915 : !! INPUTS
2916 : !!
2917 : !! OUTPUT
2918 : !!
2919 : !! SOURCE
2920 :
2921 12 : subroutine gstore_fill_bks_mask(gstore, mband, nkibz, nsppol, bks_mask)
2922 :
2923 : !Arguments ------------------------------------
2924 : class(gstore_t),intent(inout) :: gstore
2925 : integer,intent(in) :: mband, nkibz, nsppol
2926 : logical,intent(out) :: bks_mask(mband, nkibz, nsppol)
2927 :
2928 : !Local variables-------------------------------
2929 : !scalars
2930 : integer :: my_is, my_ik, my_iq, spin, ik_ibz, ikq_ibz, ebands_kptopt, bstart_k, bstop_k, bstart_kq, bstop_kq
2931 : real(dp) :: weight_q, cpu, wall, gflops
2932 : !arrays
2933 12 : integer,allocatable :: map_kq(:,:)
2934 : real(dp) :: qpt(3)
2935 : !----------------------------------------------------------------------
2936 :
2937 12 : call cwtime(cpu, wall, gflops, "start")
2938 : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2939 :
2940 1992 : bks_mask = .False.; ebands_kptopt = gstore%ebands%kptopt
2941 :
2942 24 : do my_is=1,gstore%my_nspins
2943 12 : associate (gqk => gstore%gqk(my_is))
2944 12 : spin = gstore%my_spins(my_is)
2945 12 : bstart_k = gqk%bstart_k; bstop_k = gqk%bstop_k
2946 12 : bstart_kq = gqk%bstart_kq; bstop_kq = gqk%bstop_kq
2947 :
2948 : ! Stop if dtset%nband < gstore%nband before sigfaulting.
2949 0 : ABI_CHECK_ILEQ(bstop_k, mband, "bstop_k should be smaller that mband present in WFK")
2950 12 : ABI_CHECK_ILEQ(bstop_kq, mband, "bstop_kq should be smaller that mband present in WFK")
2951 :
2952 : ! We need the image of this k-point in the IBZ.
2953 330 : do my_ik=1,gqk%my_nk
2954 318 : ik_ibz = gqk%my_k2ibz(1, my_ik)
2955 1139 : bks_mask(bstart_k:bstop_k, ik_ibz, spin) = .True.
2956 : end do
2957 :
2958 : ! As well as the image of k+q in the IBZ.
2959 36 : ABI_MALLOC(map_kq, (6, gqk%my_nk))
2960 :
2961 1057 : do my_iq=1,gqk%my_nq
2962 1045 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
2963 :
2964 1045 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, map_kq, qpt=qpt) /= 0) then
2965 0 : ABI_ERROR(sjoin("Cannot map k+q to IBZ with qpt:", ktoa(qpt)))
2966 : end if
2967 :
2968 74912 : do my_ik=1,gqk%my_nk
2969 73855 : ikq_ibz = map_kq(1, my_ik)
2970 193527 : bks_mask(bstart_kq:bstop_kq, ikq_ibz, spin) = .True.
2971 : end do
2972 : end do
2973 :
2974 24 : ABI_FREE(map_kq)
2975 : end associate
2976 : end do ! my_is
2977 :
2978 12 : call cwtime_report(" gstore_fill_bks_mask", cpu, wall, gflops)
2979 : end associate
2980 :
2981 24 : end subroutine gstore_fill_bks_mask
2982 : !!***
2983 :
2984 : !----------------------------------------------------------------------
2985 :
2986 : !!****f* m_gstore/gstore_fill_bks_mask_with_pp
2987 : !! NAME
2988 : !! gstore_fill_bks_mask_with_pp
2989 : !!
2990 : !! FUNCTION
2991 : !! Fill the bks_mask array defining the set of states that should be read from the WFK file
2992 : !! by this MPI rank when computing the GWPT e-ph matrix elements in which we have
2993 : !! to consider k+q, k-q and k+q-p as well as the sum over states (bsum).
2994 : !!
2995 : !! INPUTS
2996 : !!
2997 : !! OUTPUT
2998 : !!
2999 : !! SOURCE
3000 :
3001 3 : subroutine gstore_fill_bks_mask_pp_mesh(gstore, ecut, mband, nkibz, nsppol, my_pp_start_spin, my_pp_stop_spin, pp_mesh, &
3002 3 : my_bsum_start, my_bsum_stop, bks_mask, mpw, gmax)
3003 :
3004 : !Arguments ------------------------------------
3005 : class(gstore_t),target,intent(inout) :: gstore
3006 : real(dp),intent(in) :: ecut
3007 : integer,intent(in) :: mband, nkibz, nsppol
3008 : integer :: my_pp_start_spin(nsppol), my_pp_stop_spin(nsppol)
3009 : type(kmesh_t),intent(in) :: pp_mesh
3010 : integer,intent(in) :: my_bsum_start(nsppol), my_bsum_stop(nsppol)
3011 : logical,intent(out) :: bks_mask(mband, nkibz, nsppol)
3012 : integer,intent(out) :: mpw, gmax(3)
3013 :
3014 : !Local variables-------------------------------
3015 : !scalars
3016 : integer,parameter :: istwfk1 = 1
3017 : integer :: b1, b2, ebands_kptopt, ierr, ikq_ibz, ik_ibz, ipp_bz, my_ik, my_iq, spin, my_is, onpw, my_mpw, my_gmax(3)
3018 : real(dp) :: weight_q, cpu, wall, gflops
3019 : type(gqk_t),pointer :: gqk
3020 : type(crystal_t),pointer :: cryst
3021 : !arrays
3022 3 : integer,allocatable :: map_kq(:,:), gtmp(:,:)
3023 : real(dp) :: qpt(3), pp(3), kk(3)
3024 : !----------------------------------------------------------------------
3025 :
3026 3 : call cwtime(cpu, wall, gflops, "start")
3027 :
3028 : ! TODO: These loops can be parallelized using bsum_comm and pert_comm if needed.
3029 237 : bks_mask = .False.; cryst => gstore%cryst
3030 3 : ebands_kptopt = gstore%ebands%kptopt
3031 3 : mpw = 0; gmax = 0
3032 :
3033 6 : do my_is=1,gstore%my_nspins
3034 3 : gqk => gstore%gqk(my_is); spin = gstore%my_spins(my_is)
3035 :
3036 : ! These are the first and last band indices used in the sum over states (possibly MPI-distributed)
3037 3 : b1 = my_bsum_start(spin); b2 = my_bsum_stop(spin)
3038 :
3039 : ! Stop if dtset%nband < gstore%nband before sigfaulting.
3040 3 : ABI_CHECK_ILEQ(gqk%bstop_k, mband, "bstop_k should be smaller that mband present in WFK")
3041 3 : ABI_CHECK_ILEQ(gqk%bstop_kq, mband, "bstop_kq should be smaller that mband present in WFK")
3042 3 : ABI_CHECK_ILEQ(b2, mband, "max band index in sum should be smaller that mband present in WFK")
3043 :
3044 9 : ABI_MALLOC(map_kq, (6, gqk%my_nk))
3045 :
3046 8 : do my_ik=1,gqk%my_nk
3047 20 : kk = gqk%my_kpts(:, my_ik); ik_ibz = gqk%my_k2ibz(1, my_ik)
3048 :
3049 : ! We need the image of this k-point in the IBZ for the incoming state |psi_nk>.
3050 33 : bks_mask(gqk%bstart_k:gqk%bstop_k, ik_ibz, spin) = .True.
3051 :
3052 : ! We also need the image of k+q in the IBZ for the outgoing state <psi_mkq|.
3053 104 : do my_iq=1,gqk%my_nq
3054 96 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3055 96 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, 1, kk, map_kq, qpt=qpt) /= 0) then
3056 0 : ABI_ERROR(sjoin("Cannot map k+q to IBZ with qpt:", ktoa(qpt)))
3057 : end if
3058 96 : ikq_ibz = map_kq(1, 1)
3059 1125 : bks_mask(gqk%bstart_kq:gqk%bstop_kq, ikq_ibz, spin) = .True.
3060 : end do ! my_iq
3061 :
3062 : end do ! my_ok
3063 :
3064 : ! We also need the image of k-p in the IBZ for the pp wavevectors treated by this MPI rank.
3065 : ! These states are summed over so use b1 and b2.
3066 83 : do ipp_bz=my_pp_start_spin(spin), my_pp_stop_spin(spin)
3067 320 : pp = pp_mesh%bz(:,ipp_bz)
3068 320 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, map_kq, qpt=-pp) /= 0) then
3069 0 : ABI_ERROR(sjoin("Cannot map k-p to IBZ with qpt:", ktoa(qpt), "and pp:", ktoa(pp)))
3070 : end if
3071 :
3072 179 : do my_ik=1,gqk%my_nk
3073 96 : ikq_ibz = map_kq(1, my_ik)
3074 1120 : bks_mask(b1:b2, ikq_ibz, spin) = .True.
3075 : ! Compute g-sphere, returns onpw. Note istwfk == 1.
3076 384 : kk = gqk%my_kpts(:, my_ik)
3077 384 : call get_kg(kk-pp, istwfk1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3078 176 : ABI_FREE(gtmp)
3079 : end do
3080 : end do ! ipp_bz
3081 :
3082 : ! We also need the image of k+q-p in the IBZ for the pp wavevectors treated by this MPI rank.
3083 : ! These states are summed over so use b1 and b2.
3084 83 : do my_iq=1,gqk%my_nq
3085 80 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3086 :
3087 4307 : do ipp_bz=my_pp_start_spin(spin), my_pp_stop_spin(spin)
3088 16896 : pp = pp_mesh%bz(:,ipp_bz)
3089 :
3090 16896 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, map_kq, qpt=qpt-pp) /= 0) then
3091 0 : ABI_ERROR(sjoin("Cannot map k+q-p to IBZ with qpt:", ktoa(qpt), "and pp:", ktoa(pp)))
3092 : end if
3093 :
3094 8656 : do my_ik=1,gqk%my_nk
3095 4352 : ikq_ibz = map_kq(1, my_ik)
3096 48384 : bks_mask(b1:b2, ikq_ibz, spin) = .True.
3097 : ! Compute g-sphere, returns onpw. Note istwfk = 1.
3098 17408 : kk = gqk%my_kpts(:, my_ik)
3099 17408 : call get_kg(kk+qpt-pp, istwfk1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3100 8576 : ABI_FREE(gtmp)
3101 : end do
3102 : end do ! ipp_bz
3103 :
3104 : end do ! my_iq
3105 :
3106 6 : ABI_FREE(map_kq)
3107 : end do ! my_is
3108 :
3109 3 : my_mpw = mpw; call xmpi_max(my_mpw, mpw, gstore%comm, ierr)
3110 3 : my_gmax = gmax; call xmpi_max(my_gmax, gmax, gstore%comm, ierr)
3111 :
3112 : ! TODO
3113 : !call gstore%get_mpw_gmax(ecut, mpw, gmax, pp_max=)
3114 :
3115 3 : call wrtout(std_out, sjoin(' Optimal value of mpw: ', itoa(mpw)))
3116 3 : call cwtime_report(" gstore_fill_bks_mask_pp_mesh", cpu, wall, gflops)
3117 :
3118 3 : end subroutine gstore_fill_bks_mask_pp_mesh
3119 : !!***
3120 :
3121 : !----------------------------------------------------------------------
3122 :
3123 : !!****f* m_gstore/gstore_get_mpw_gmax
3124 : !! NAME
3125 : !! gstore_get_mpw_gmax
3126 : !!
3127 : !! FUNCTION
3128 : !! Compute the maximum number of PWs for all possible k+q treated.
3129 : !!
3130 : !! INPUTS
3131 : !!
3132 : !! OUTPUT
3133 : !!
3134 : !! SOURCE
3135 :
3136 12 : subroutine gstore_get_mpw_gmax(gstore, ecut, mpw, gmax, pp_max)
3137 :
3138 : !Arguments ------------------------------------
3139 : class(gstore_t),intent(in) :: gstore
3140 : real(dp),intent(in) :: ecut
3141 : integer,intent(out) :: mpw, gmax(3)
3142 : integer,optional,intent(in) :: pp_max
3143 :
3144 : !Local variables-------------------------------
3145 : integer,parameter :: istwfk1 = 1
3146 : integer :: my_is, my_ik, my_iq, spin, onpw, ierr, my_mpw, ipx, ipy, ipz, nprocs, my_rank, pp_max__ !, cnt, i1, i2, i3,
3147 : real(dp) :: weight_q, cpu, wall, gflops
3148 : !arrays
3149 : integer :: my_gmax(3)
3150 12 : integer,allocatable :: gtmp(:,:)
3151 : real(dp) :: kk(3), kq(3), qpt(3), pp(3) !, kq_max(3)
3152 : !----------------------------------------------------------------------
3153 :
3154 : ! TODO: This is an hotspot due to the double loop over k and q. Should use a geometrical approach to compute mpw and gmax.
3155 12 : call wrtout(std_out, " Computing mpw. This may take some time for dense k/q meshes...", pre_newlines=1)
3156 12 : call cwtime(cpu, wall, gflops, "start")
3157 :
3158 12 : nprocs = xmpi_comm_size(gstore%comm); my_rank = xmpi_comm_rank(gstore%comm)
3159 12 : mpw = 0; gmax = 0
3160 12 : pp_max__ = 0; if (present(pp_max)) pp_max__ = pp_max
3161 :
3162 24 : do my_is=1,gstore%my_nspins
3163 12 : associate (gqk => gstore%gqk(my_is))
3164 12 : spin = gstore%my_spins(my_is)
3165 330 : do my_ik=1,gqk%my_nk
3166 1272 : kk = gqk%my_kpts(:, my_ik)
3167 :
3168 : ! Compute g-sphere, returns onpw. Note istwfk == 1.
3169 318 : call get_kg(kk, istwfk1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3170 318 : ABI_FREE(gtmp)
3171 :
3172 74185 : do my_iq=1,gqk%my_nq
3173 73855 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3174 295420 : kq = kk + qpt
3175 :
3176 : ! TODO: g0 umklapp here can enter into play! gmax could not be large enough!
3177 148028 : do ipz=-pp_max__,pp_max__
3178 221565 : do ipy=-pp_max__,pp_max__
3179 221565 : do ipx=-pp_max__,pp_max__
3180 295420 : pp = [ipx, ipy, ipz] * half
3181 295420 : call get_kg(kq - pp, 1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3182 147710 : ABI_FREE(gtmp)
3183 : end do
3184 : end do
3185 : end do
3186 : end do ! my_iq
3187 :
3188 : end do ! my_ik
3189 : end associate
3190 : end do ! my_is
3191 :
3192 12 : my_mpw = mpw; call xmpi_max(my_mpw, mpw, gstore%comm, ierr)
3193 12 : my_gmax = gmax; call xmpi_max(my_gmax, gmax, gstore%comm, ierr)
3194 :
3195 12 : call wrtout(std_out, sjoin(' Optimal value of mpw: ', itoa(mpw), "with gmax:", ltoa(gmax)))
3196 12 : call cwtime_report(" gstore_get_mpw_gmax", cpu, wall, gflops)
3197 :
3198 12 : end subroutine gstore_get_mpw_gmax
3199 : !!***
3200 :
3201 : !----------------------------------------------------------------------
3202 :
3203 : !!****f* m_gstore/gstore_free
3204 : !! NAME
3205 : !! gstore_free
3206 : !!
3207 : !! FUNCTION
3208 : !! Free dynamic memory in gstore_t.
3209 : !!
3210 : !! SOURCE
3211 :
3212 24 : subroutine gstore_free(gstore)
3213 :
3214 : !Arguments ------------------------------------
3215 : class(gstore_t),intent(inout) :: gstore
3216 :
3217 : !Local variables-------------------------------
3218 : integer :: my_is
3219 : !----------------------------------------------------------------------
3220 :
3221 48 : do my_is=1,gstore%my_nspins
3222 48 : call gstore%gqk(my_is)%free()
3223 : end do
3224 48 : ABI_SFREE(gstore%gqk)
3225 :
3226 24 : ABI_SFREE(gstore%delta_ef_kibz_spin)
3227 24 : ABI_SFREE(gstore%qibz)
3228 24 : ABI_SFREE(gstore%wtq)
3229 24 : ABI_SFREE(gstore%my_spins)
3230 24 : ABI_SFREE(gstore%brange_k_spin)
3231 24 : ABI_SFREE(gstore%brange_kq_spin)
3232 24 : ABI_SFREE(gstore%glob_nk_spin)
3233 24 : ABI_SFREE(gstore%glob_nq_spin)
3234 24 : ABI_SFREE(gstore%kglob2bz)
3235 24 : ABI_SFREE(gstore%kbz2ibz)
3236 24 : ABI_SFREE(gstore%erange_spin)
3237 24 : ABI_SFREE(gstore%qbz)
3238 24 : ABI_SFREE(gstore%kbz)
3239 :
3240 24 : if (gstore%has_wannier) then
3241 0 : call gstore%ebands%free()
3242 0 : ABI_FREE_SCALAR(gstore%ebands)
3243 : nullify(gstore%ebands)
3244 : end if
3245 :
3246 24 : call gstore%krank_ibz%free()
3247 24 : call gstore%qrank_ibz%free()
3248 24 : gstore%with_cplex = -1
3249 :
3250 24 : end subroutine gstore_free
3251 : !!***
3252 :
3253 : !----------------------------------------------------------------------
3254 :
3255 : !!****f* m_gstore/gqk_myqpt
3256 : !! NAME
3257 : !! gqk_myqpt
3258 : !!
3259 : !! FUNCTION
3260 : !! Return the weight_q and the reduced coordinates of the q-point from the local index my_iq.
3261 : !!
3262 : !! INPUTS
3263 : !!
3264 : !! OUTPUT
3265 : !!
3266 : !! SOURCE
3267 :
3268 77422 : pure subroutine gqk_myqpt(gqk, my_iq, gstore, weight_q, qpt)
3269 :
3270 : !Arguments ------------------------------------
3271 : class(gqk_t),intent(in) :: gqk
3272 : class(gstore_t),intent(in) :: gstore
3273 : integer,intent(in) :: my_iq
3274 : real(dp),intent(out) :: weight_q, qpt(3)
3275 :
3276 : !Local variables ------------------------------
3277 : integer :: iq_ibz, isym_q, trev_q, tsign_q, g0_q(3)
3278 : logical :: isirr_q
3279 : !----------------------------------------------------------------------
3280 :
3281 : ! Symmetry tables for q-points.
3282 77422 : iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
3283 309688 : trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5, my_iq)
3284 : isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
3285 77422 : tsign_q = 1; if (trev_q == 1) tsign_q = -1
3286 :
3287 : ! NB: Use symrec convention for q
3288 2167816 : qpt = tsign_q * matmul(gstore%cryst%symrec(:,:,isym_q), gstore%qibz(:, iq_ibz)) + g0_q
3289 :
3290 0 : select case(gstore%qzone)
3291 : case ("ibz")
3292 0 : weight_q = gstore%wtq(iq_ibz)
3293 : case ("bz")
3294 77422 : weight_q = one / gstore%nqbz
3295 : end select
3296 :
3297 77422 : end subroutine gqk_myqpt
3298 : !!***
3299 :
3300 : !----------------------------------------------------------------------
3301 :
3302 : !!****f* m_gstore/gqk_dbldelta_qpt
3303 : !! NAME
3304 : !! gqk_dbldelta_qpt
3305 : !!
3306 : !! FUNCTION
3307 : !! Note that k/q weights are not included in dbl_delta_q
3308 : !!
3309 : !! INPUTS
3310 : !!
3311 : !! OUTPUT
3312 : !!
3313 : !! SOURCE
3314 :
3315 0 : subroutine gqk_dbldelta_qpt(gqk, my_iq, gstore, eph_intmeth, eph_fsmear, qpt, weight_q, dbl_delta_q)
3316 :
3317 : !Arguments ------------------------------------
3318 : class(gqk_t),intent(in) :: gqk
3319 : class(gstore_t),target,intent(inout) :: gstore
3320 : integer,intent(in) :: my_iq, eph_intmeth
3321 : real(dp),intent(in) :: eph_fsmear
3322 : real(dp),intent(out) :: qpt(3), weight_q, dbl_delta_q(gqk%nb_kq, gqk%nb_k, gqk%my_nk)
3323 :
3324 : !Local variables ------------------------------
3325 : !scalars
3326 : real(dp), parameter :: min_smear = tol9
3327 : integer :: nb_k, nb_kq, nkbz, spin, my_ik, ib, ib1, ib2, band1, band2, nesting
3328 : integer :: ik_ibz, isym_k, trev_k, tsign_k, g0_k(3)
3329 : integer :: ikq_ibz, isym_kq, trev_kq, tsign_kq, g0_kq(3), ii, i1, i2, i3, cnt, ik_bz, ltetra
3330 : real(dp) :: g1, g2, sigma !, weight_k !, cpu, wall, gflops
3331 : logical :: isirr_k, isirr_kq, use_adaptive
3332 : type(ebands_t), pointer :: ebands
3333 : type(crystal_t), pointer :: cryst
3334 0 : type(krank_t) :: my_krank
3335 : !arrays
3336 : integer :: nge(3), ngw(3)
3337 0 : integer,allocatable :: my_kqmap(:,:), kmesh_map(:,:)
3338 0 : real(dp) :: kk(3), kmesh_cartvec(3,3), rlatt(3,3), klatt(3,3), vb_k(3, gqk%nb_k), vb_kq(3, gqk%nb_kq)
3339 0 : real(dp),allocatable :: eig_k(:,:), eig_kq(:,:), kmesh(:,:), wght_bz(:,:,:)
3340 : !----------------------------------------------------------------------
3341 :
3342 0 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq; nkbz = gstore%nkbz; spin = gqk%spin
3343 0 : ebands => gstore%ebands; cryst => gstore%cryst
3344 :
3345 0 : ABI_CHECK_IEQ(nb_k, nb_kq, "gqk_dbldelta_qpt does not support nb_k != nb_kq")
3346 :
3347 0 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3348 :
3349 : ! The double delta with tetra is ill-defined for q == 0. In this case we fall back to gaussian.
3350 0 : nesting = merge(1, 0, abs(eph_intmeth) == 2 .and. all(abs(qpt) < tol12))
3351 :
3352 0 : rlatt = gstore%ebands%kptrlatt; call matr3inv(rlatt, klatt)
3353 0 : kmesh_cartvec(:, 1) = cryst%gprimd(:,1)*klatt(1,1) + cryst%gprimd(:,2)*klatt(2,1) + cryst%gprimd(:,3)*klatt(3,1)
3354 0 : kmesh_cartvec(:, 2) = cryst%gprimd(:,1)*klatt(1,2) + cryst%gprimd(:,2)*klatt(2,2) + cryst%gprimd(:,3)*klatt(3,2)
3355 0 : kmesh_cartvec(:, 3) = cryst%gprimd(:,1)*klatt(1,3) + cryst%gprimd(:,2)*klatt(2,3) + cryst%gprimd(:,3)*klatt(3,3)
3356 : ! TODO: It seems that two_pi is not needed here!
3357 :
3358 0 : if (abs(eph_intmeth) == 1 .or. nesting /= 0) then
3359 0 : use_adaptive = eph_fsmear < zero .or. abs(eph_intmeth) == 2
3360 : if (use_adaptive) then
3361 0 : ABI_CHECK(allocated(gqk%vnk_cart_ibz), "vnk_cart_ibz should be allocated when use_adaptive is .True.")
3362 : end if
3363 :
3364 : ! Find k + q in the IBZ for all my k-points.
3365 0 : ABI_MALLOC(my_kqmap, (6, gqk%my_nk))
3366 0 : if (kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, my_kqmap, qpt=qpt) /= 0) then
3367 0 : ABI_ERROR(sjoin("Cannot map k+q to IBZ with qpt:", ktoa(qpt)))
3368 : end if
3369 :
3370 : ! Init default sigma
3371 0 : sigma = eph_fsmear
3372 :
3373 0 : do my_ik=1,gqk%my_nk
3374 0 : kk = gqk%my_kpts(:, my_ik)
3375 :
3376 0 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
3377 0 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5, my_ik)
3378 0 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
3379 0 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
3380 :
3381 0 : ikq_ibz = my_kqmap(1, my_ik); isym_kq = my_kqmap(2, my_ik)
3382 0 : trev_kq = my_kqmap(6, my_ik); g0_kq = my_kqmap(3:5, my_ik)
3383 0 : isirr_kq = (isym_kq == 1 .and. trev_kq == 0 .and. all(g0_kq == 0))
3384 0 : tsign_kq = 1; if (trev_kq == 1) tsign_kq = -1
3385 :
3386 0 : if (use_adaptive) then
3387 : ! If k or k+q is not in the IBZ, we need to recostruct the value by symmetry using v(Sq) = S v(q).
3388 : ! Use transpose(R) because we are using the tables for the wavefunctions
3389 : ! In this case listkk has been called with symrec and use_symrec=False
3390 : ! so q_bz = S^T q_ibz where S is the isym_kq symmetry
3391 0 : vb_k = gqk%vnk_cart_ibz(:,:,ik_ibz)
3392 0 : vb_kq = gqk%vnk_cart_ibz(:,:,ikq_ibz)
3393 :
3394 0 : if (.not. isirr_k) then
3395 0 : do ib=1,nb_k
3396 0 : vb_k(:,ib) = tsign_k * matmul(transpose(cryst%symrel_cart(:,:,isym_k)), vb_k(:,ib))
3397 : end do
3398 : end if
3399 0 : if (.not. isirr_kq) then
3400 0 : do ib=1,nb_kq
3401 0 : vb_kq(:,ib) = tsign_kq * matmul(transpose(cryst%symrel_cart(:,:,isym_kq)), vb_kq(:,ib))
3402 : end do
3403 : end if
3404 : end if
3405 :
3406 0 : do ib2=1,nb_k
3407 0 : band2 = ib2 + gqk%bstart_k - 1
3408 0 : if (use_adaptive) then
3409 0 : sigma = max(maxval([(abs(dot_product(vb_k(:, ib2), kmesh_cartvec(:,ii))), ii=1,3)]), min_smear)
3410 : !write(std_out, *)"sigma:", sigma * Ha_eV
3411 : end if
3412 0 : g2 = gaussian(ebands%eig(band2, ik_ibz, spin) - ebands%fermie, sigma)
3413 :
3414 0 : do ib1=1,nb_kq
3415 0 : band1 = ib1 + gqk%bstart_kq - 1
3416 0 : if (use_adaptive) then
3417 0 : sigma = max(maxval([(abs(dot_product(vb_kq(:, ib1), kmesh_cartvec(:,ii))), ii=1,3)]), min_smear)
3418 : end if
3419 0 : g1 = gaussian(ebands%eig(band1, ikq_ibz, spin) - ebands%fermie, sigma)
3420 0 : dbl_delta_q(ib1, ib2, my_ik) = g1 * g2 ! / fs%nktot
3421 : end do
3422 :
3423 : end do
3424 : end do
3425 :
3426 0 : ABI_FREE(my_kqmap)
3427 :
3428 0 : else if (abs(eph_intmeth) == 2) then
3429 :
3430 0 : ABI_CHECK(isdiagmat(ebands%kptrlatt), "kptrlatt must be diagonal when tetra is used.")
3431 0 : ABI_CHECK(ebands%nshiftk == 1, "nshiftk must be 1 when tetra is used")
3432 0 : nge = get_diag(ebands%kptrlatt); ngw = nge
3433 0 : ABI_CHECK_IEQ(nkbz, product(nge(1:3)), "Wrong nge")
3434 :
3435 : ! Compute eig_k and eig_kq in full BZ for the relevant bands around Ef.
3436 0 : ABI_MALLOC(kmesh, (3, nkbz))
3437 0 : ABI_MALLOC(eig_k, (nb_k, nkbz))
3438 0 : ABI_MALLOC(eig_kq, (nb_kq, nkbz))
3439 :
3440 : ! Technical problems:
3441 : !
3442 : ! 1) libtetrabz works with the BZ and assumes a certaing ordering of the k-points (see below)
3443 : ! so we have to fill the array with eig_k and eig_kq from the IBZ by remapping the libtetra kk
3444 : ! to the Abinit IBZ
3445 :
3446 : ! 2) The dbldelta weights are given in the BZ, while the caller requires weights for k in the IBZ
3447 : ! and moreover only for the IBZ k-point treated by this MPI proc.
3448 :
3449 0 : ik_bz = 0
3450 0 : do i3=0,nge(3) - 1
3451 0 : do i2=0,nge(2) - 1
3452 0 : do i1=0,nge(1) - 1
3453 0 : ik_bz = ik_bz + 1
3454 0 : kk = ([i1, i2, i3] + ebands%shiftk(:, 1)) / nge(:)
3455 0 : kmesh(:, ik_bz) = kk
3456 : end do
3457 : end do
3458 : end do
3459 :
3460 : ! Map libtetra BZ mesh to IBZ and fill eig_k
3461 : !call cwtime(cpu, wall, gflops, "start")
3462 0 : ABI_MALLOC(kmesh_map, (6, nkbz))
3463 :
3464 : ! Find correspondence between libtetra mesh and the IBZ.
3465 0 : if (kpts_map("symrec", ebands%kptopt, cryst, gstore%krank_ibz, nkbz, kmesh, kmesh_map) /= 0) then
3466 0 : ABI_ERROR("Cannot map libtetra mesh to IBZ")
3467 : end if
3468 :
3469 0 : do ik_bz=1,nkbz
3470 0 : ik_ibz = kmesh_map(1, ik_bz)
3471 0 : eig_k(:, ik_bz) = ebands%eig(gqk%bstart_k:gqk%bstop_k, ik_ibz, spin) - ebands%fermie
3472 : end do
3473 :
3474 : ! Map libtetra BZ mesh + q to IBZ and fill eig_kq.
3475 0 : if (kpts_map("symrec", ebands%kptopt, cryst, gstore%krank_ibz, nkbz, kmesh, kmesh_map, qpt=qpt) /= 0) then
3476 0 : ABI_ERROR(sjoin("Cannot map libtetra k+q to IBZ with qpt:", ktoa(qpt)))
3477 : end if
3478 :
3479 0 : do ik_bz=1,nkbz
3480 0 : ikq_ibz = kmesh_map(1, ik_bz)
3481 0 : eig_kq(:, ik_bz) = ebands%eig(gqk%bstart_kq:gqk%bstop_kq, ikq_ibz, spin) - ebands%fermie
3482 : end do
3483 :
3484 0 : ABI_FREE(kmesh_map)
3485 : !call cwtime_report(" kmesh_map", cpu, wall, gflops)
3486 :
3487 : ! Call libtetra routine to compute weights for double delta integration.
3488 : ! Note that libtetra assumes Ef set to zero.
3489 : ! TODO: Average weights over degenerate states?
3490 : ! NB: This is a bottleneck, can pass comm_kp
3491 :
3492 : ! Select option for double delta with tetra.
3493 : ! 2 for the optimized tetrahedron method.
3494 : ! -2 for the linear tetrahedron method.
3495 0 : ltetra = 0
3496 0 : if (eph_intmeth == 2) ltetra = 2
3497 0 : if (eph_intmeth == -2) ltetra = 1
3498 :
3499 0 : ABI_MALLOC(wght_bz, (nb_k, nb_kq, nkbz))
3500 0 : call libtetrabz_dbldelta(ltetra, gstore%cryst%gprimd, nb_k, nge, eig_k, eig_kq, ngw, wght_bz) !, comm=comm)
3501 : !call cwtime_report(" libtetrabz_dbldelta", cpu, wall, gflops)
3502 :
3503 0 : call my_krank%init(gqk%my_nk, gqk%my_kpts)
3504 :
3505 : ! Reindex from full BZ to my set of kpoints and rescale weights.
3506 0 : cnt = 0
3507 0 : do ik_bz=1,nkbz
3508 0 : my_ik = my_krank%get_index(kmesh(:, ik_bz))
3509 0 : if (my_ik /= -1) then
3510 0 : dbl_delta_q(:,:,my_ik) = wght_bz(:,:,ik_bz) * gstore%nkbz
3511 0 : cnt = cnt + 1
3512 : end if
3513 : end do
3514 :
3515 : ! FIXME: BUG if k-point (and q-point) parallelism.
3516 0 : ABI_CHECK_IEQ(cnt, gqk%my_nk, sjoin("cnt != my_nk, ", itoa(cnt), itoa(gqk%my_nk)))
3517 0 : call my_krank%free()
3518 : !call cwtime_report(" transfer", cpu, wall, gflops)
3519 :
3520 0 : ABI_FREE(wght_bz)
3521 0 : ABI_FREE(kmesh)
3522 0 : ABI_FREE(eig_k)
3523 0 : ABI_FREE(eig_kq)
3524 :
3525 : else
3526 0 : ABI_ERROR(sjoin("Invalid eph_intmeth:", itoa(eph_intmeth)))
3527 : end if
3528 :
3529 0 : end subroutine gqk_dbldelta_qpt
3530 : !!***
3531 : !----------------------------------------------------------------------
3532 :
3533 : !!****f* m_gstore/gqk_free
3534 : !! NAME
3535 : !! gqk_free
3536 : !!
3537 : !! FUNCTION
3538 : !! Free dynamic memory in gqk_t instance.
3539 : !!
3540 : !! SOURCE
3541 :
3542 24 : subroutine gqk_free(gqk)
3543 :
3544 : !Arguments ------------------------------------
3545 : class(gqk_t),intent(inout) :: gqk
3546 : !----------------------------------------------------------------------
3547 :
3548 24 : ABI_SFREE(gqk%my_k2ibz)
3549 24 : ABI_SFREE(gqk%my_kpts)
3550 24 : ABI_SFREE(gqk%my_wtk)
3551 24 : ABI_SFREE(gqk%my_q2ibz)
3552 24 : ABI_SFREE(gqk%my_q2bz)
3553 24 : ABI_SFREE(gqk%my_k2glob)
3554 24 : ABI_SFREE(gqk%my_q2glob)
3555 24 : ABI_SFREE(gqk%my_wnuq)
3556 24 : ABI_SFREE(gqk%my_displ_cart)
3557 24 : ABI_SFREE(gqk%my_iv1p_comm)
3558 24 : ABI_SFREE(gqk%my_pertcases)
3559 24 : ABI_SFREE(gqk%vnk_cart_ibz)
3560 24 : ABI_SFREE(gqk%vnk_mat_cart_ibz)
3561 :
3562 24 : ABI_SFREE(gqk%my_g)
3563 24 : ABI_SFREE(gqk%my_g2)
3564 24 : ABI_SFREE(gqk%my_gdw2)
3565 24 : if (gqk%has_both_g) then
3566 9 : ABI_SFREE_PTR(gqk%my_g_ks)
3567 9 : ABI_SFREE_PTR(gqk%my_g2_ks)
3568 9 : ABI_SFREE_PTR(gqk%my_gdw2_ks)
3569 : end if
3570 :
3571 24 : call gqk%wan%free()
3572 :
3573 : ! Free MPI communicators
3574 24 : call gqk%kpt_comm%free(); call gqk%qpt_comm%free(); call gqk%qpt_kpt_comm%free()
3575 24 : call gqk%pert_comm%free(); call gqk%band_comm%free(); call gqk%qpt_pert_comm%free()
3576 24 : call gqk%pert_ppsum_comm%free(); call gqk%pert_ppsum_bsum_comm%free()
3577 24 : call gqk%comm%free(); call gqk%bsum_comm%free(); call gqk%pp_sum_comm%free()
3578 :
3579 24 : end subroutine gqk_free
3580 : !!***
3581 :
3582 : !!****f* m_gstore/gstore_get_missing_qbz_spin
3583 : !! NAME
3584 : !! gstore_get_missing_qbz_spin
3585 : !!
3586 : !! FUNCTION
3587 : !! Return the number of (q-points, spin) entries that have been computed.
3588 : !!
3589 : !! SOURCE
3590 :
3591 9 : subroutine gstore_get_missing_qbz_spin(gstore, done_qbz_spin, ndone, nmiss)
3592 :
3593 : !Arguments ------------------------------------
3594 : class(gstore_t),intent(in) :: gstore
3595 : integer,intent(in) :: done_qbz_spin(gstore%nqbz, gstore%nsppol)
3596 : integer,intent(out) :: ndone, nmiss
3597 :
3598 : !Local variables ------------------------------
3599 : integer :: my_is, my_iq, iq_bz, spin, ierr, nscale
3600 : !----------------------------------------------------------------------
3601 :
3602 3 : ndone = 0; nmiss = 0
3603 6 : do my_is=1,gstore%my_nspins
3604 3 : associate (gqk => gstore%gqk(my_is))
3605 3 : spin = gstore%my_spins(my_is)
3606 83 : do my_iq=1,gqk%my_nq
3607 80 : iq_bz = gqk%my_q2bz(my_iq)
3608 80 : if (done_qbz_spin(iq_bz, spin) == 0) nmiss = nmiss + 1
3609 83 : if (done_qbz_spin(iq_bz, spin) == 1) ndone = ndone + 1
3610 : end do ! my_iq
3611 : ! Rescale to avoid overcounting in xmpi_summ
3612 3 : nscale = (gqk%pert_comm%nproc * gqk%bsum_comm%nproc * gqk%pp_sum_comm%nproc)
3613 3 : nmiss = nmiss / nscale
3614 6 : ndone = ndone / nscale
3615 : end associate
3616 : end do ! my_is
3617 :
3618 3 : call xmpi_sum(ndone, gstore%comm, ierr)
3619 3 : call xmpi_sum(nmiss, gstore%comm, ierr)
3620 :
3621 3 : end subroutine gstore_get_missing_qbz_spin
3622 : !!***
3623 :
3624 : !!****f* m_gstore/gstore_set_perts_distrib
3625 : !! NAME
3626 : !! gstore_set_perts_distrib
3627 : !!
3628 : !! FUNCTION
3629 : !! Activate parallelism over perturbations at the level of the DVDB file.
3630 : !!
3631 : !! SOURCE
3632 :
3633 18 : subroutine gstore_set_perts_distrib(gstore, cryst, dvdb, my_npert)
3634 :
3635 : !Arguments ------------------------------------
3636 : class(gstore_t),intent(in) :: gstore
3637 : type(crystal_t),intent(in) :: cryst
3638 : type(dvdb_t),intent(inout) :: dvdb
3639 : integer,intent(out) :: my_npert
3640 :
3641 : !Local variables ------------------------------
3642 : !scalars
3643 : integer :: my_is, spin
3644 : !arrays
3645 18 : integer,allocatable :: my_pinfo(:,:), pert_table(:,:)
3646 : !----------------------------------------------------------------------
3647 :
3648 18 : my_npert = cryst%natom * 3
3649 36 : do my_is=1,gstore%my_nspins
3650 18 : associate (gqk => gstore%gqk(my_is))
3651 18 : spin = gstore%my_spins(my_is)
3652 18 : if (gqk%pert_comm%nproc > 1) then
3653 : ! Activate parallelism over perturbations
3654 : ! Build table with list of perturbations treated by this MPI rank inside pert_comm.
3655 : !ABI_WARNING("GSTORE with pert_comm%nproc > 1 not tested")
3656 0 : my_npert = gqk%my_npert
3657 0 : call ephtk_set_pertables(cryst%natom, my_npert, pert_table, my_pinfo, gqk%pert_comm%value)
3658 0 : call dvdb%set_pert_distrib(my_npert, cryst%natom * 3, my_pinfo, pert_table, gqk%pert_comm%value)
3659 0 : ABI_CHECK(all(my_pinfo(3, :) == gqk%my_pertcases), "my_pinfo(3, :) != gqk%my_pertcases")
3660 :
3661 0 : ABI_FREE(my_pinfo)
3662 0 : ABI_FREE(pert_table)
3663 : end if
3664 : end associate
3665 : end do
3666 :
3667 18 : end subroutine gstore_set_perts_distrib
3668 : !!***
3669 :
3670 : !----------------------------------------------------------------------
3671 :
3672 : !!****f* m_gstore/gstore_compute
3673 : !! NAME
3674 : !! gstore_compute
3675 : !!
3676 : !! FUNCTION
3677 : !! Compute MPI-distributed e-ph matrix elements
3678 : !!
3679 : !! INPUTS
3680 : !! wk0_path=String with the path to the GS unperturbed WFK file.
3681 : !! ngfft(18),ngfftf(18)=Coarse and Fine FFT meshes.
3682 : !! dtset<dataset_type>=All input variables for this dataset.
3683 : !! ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...)
3684 : !! dvdb<dbdb_type>=Database with the DFPT SCF potentials.
3685 : !! pawfgr <type(pawfgr_type)>=fine grid parameters and related data
3686 : !! pawang<pawang_type)>=PAW angular mesh and related data.
3687 : !! pawrad(ntypat*usepaw)<pawrad_type>=Paw radial mesh and related data.
3688 : !! pawtab(ntypat*usepaw)<pawtab_type>=Paw tabulated starting data.
3689 : !! psps<pseudopotential_type>=Variables related to pseudopotentials.
3690 : !! comm=MPI communicator.
3691 : !!
3692 : !! OUTPUT
3693 : !! GSTORE.nc file
3694 : !!
3695 : !! SOURCE
3696 :
3697 5 : subroutine gstore_compute(gstore, wfk0_path, ngfft, ngfftf, dtset, dtfil, cryst, ebands, ifc, dvdb, &
3698 5 : pawfgr, pawang, pawrad, pawtab, psps, mpi_enreg, comm)
3699 :
3700 : !Arguments ------------------------------------
3701 : !scalars
3702 : class(gstore_t),target,intent(inout) :: gstore
3703 : character(len=*),intent(in) :: wfk0_path
3704 : integer,intent(in) :: comm
3705 : type(dataset_type),intent(in) :: dtset
3706 : type(datafiles_type),intent(in) :: dtfil
3707 : type(crystal_t),intent(in) :: cryst
3708 : type(ebands_t),intent(in) :: ebands
3709 : class(ifc_type),intent(in) :: ifc
3710 : type(dvdb_t),intent(inout) :: dvdb
3711 : type(pawang_type),intent(in) :: pawang
3712 : type(pseudopotential_type),intent(in) :: psps
3713 : type(pawfgr_type),intent(in) :: pawfgr
3714 : type(mpi_type),intent(in) :: mpi_enreg
3715 : !arrays
3716 : integer,intent(in) :: ngfft(18),ngfftf(18)
3717 : type(pawrad_type),intent(in) :: pawrad(psps%ntypat*psps%usepaw)
3718 : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
3719 :
3720 : !Local variables ------------------------------
3721 : !scalars
3722 : integer,parameter :: tim_getgh1c = 1, berryopt0 = 0, ider0 = 0, idir0 = 0, LOG_MODQ = 5, master = 0, ndat1 = 1
3723 : integer :: my_rank,nproc,nproc_lim,mband,nsppol,nkibz,idir,ipert, iq_bz
3724 : integer :: cplex,natom,natom3,ipc,nspinor, nskip_tetra_kq, timrev_k, timrev_q
3725 : integer :: band_k, in_k, ik_ibz,ikq_ibz,isym_k,isym_kq,trev_k,trev_kq, nb_k, nb_kq ! im_kq,
3726 : integer :: my_ik, my_is, comm_rpt, my_npert, my_ip, my_iq, spin,istwf_k,istwf_kq,npw_k,npw_kq
3727 : integer :: mpw, ierr, n1,n2,n3,n4,n5,n6,nspden,ndone, db_iqpt
3728 : integer :: sij_opt,usecprj,usevnl,optlocal,optnl,opt_gvnlx1
3729 : integer :: nfft,nfftf,mgfft,mgfftf, nkpg_k, nkpg_kq, qbuf_size, iqbuf_cnt, root_ncid, spin_ncid, ncerr
3730 : integer :: ii, iq_ibz, isym_q, trev_q
3731 : real(dp) :: cpu_q, wall_q, gflops_q, cpu_all, wall_all, gflops_all ! cpu, wall, gflops,
3732 : real(dp) :: ecut, weight_q, weight_k ! eshift,
3733 : logical :: gen_eigenpb, isirr_k, isirr_kq, isirr_q, print_time, need_ftinterp, qq_is_gamma, symmetrize, use_lgk
3734 5 : type(wfd_t) :: wfd
3735 5 : type(gs_hamiltonian_type) :: gs_ham_kq
3736 5 : type(rf_hamiltonian_type) :: rf_ham_kq
3737 : type(gqk_t),pointer :: gqk
3738 5 : type(lgroup_t) :: lg_myq
3739 : character(len=5000) :: msg, qq_bz_string, kk_string
3740 : !arrays
3741 : integer :: g0_k(3), g0_kq(3), g0_q(3), work_ngfft(18),gmax(3),indkk_kq(6,1), units(2), qbz2dvdb(6)
3742 5 : integer,allocatable :: kg_k(:,:), kg_kq(:,:), nband(:,:), wfd_istwfk(:), qmap_symrec(:,:)
3743 5 : integer,allocatable :: iq_buf(:,:), done_qbz_spin(:,:), state_kq(:,:)
3744 : !integer,allocatable :: qibz2dvdb(:) !, displs(:), recvcounts(:)
3745 : real(dp) :: kk_bz(3),kq_bz(3),kk_ibz(3),kq_ibz(3), qq_bz(3), qq_ibz(3) !, v_nk(3)
3746 5 : real(dp),allocatable :: displ_cart_qibz(:,:,:,:), lambda(:)
3747 5 : real(dp),allocatable :: grad_berry(:,:), kinpw_k(:), kinpw_kq(:), kpg_kq(:,:), kpg_k(:,:)
3748 5 : real(dp),allocatable :: ffnl_k(:,:,:,:), ffnl_kq(:,:,:,:), ph3d_k(:,:,:), ph3d_kq(:,:,:)
3749 5 : real(dp),allocatable :: v1scf(:,:,:,:), gkq_atm(:,:,:,:), gkq_atm_ipc(:,:,:)
3750 5 : real(dp),allocatable :: bras_kq(:,:,:), kets_k(:,:,:), h1_kets_kq(:,:,:) !, cgwork(:,:)
3751 5 : real(dp),allocatable :: ph1d(:,:), vlocal(:,:,:,:), vlocal1(:,:,:,:,:)
3752 5 : real(dp),allocatable :: dummy_vtrial(:,:), gvnlx1(:,:,:), work(:,:,:,:)
3753 5 : real(dp),allocatable :: gs1c_kq(:,:) !, vnk_cart_ibz(:,:,:) !, vkq_cart_ibz(:,:,:) !, vnk_mat_cart_ibz(:,:,:,:)
3754 5 : real(dp),allocatable :: my_gbuf(:,:,:,:,:,:)
3755 5 : logical,allocatable :: bks_mask(:,:,:),keep_ur(:,:,:)
3756 5 : type(pawcprj_type),allocatable :: cwaveprj0(:,:)
3757 5 : type(lgroup_t),allocatable :: lg_myk(:)
3758 : !************************************************************************
3759 :
3760 5 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
3761 15 : units = [std_out, ab_out]
3762 :
3763 5 : if (psps%usepaw == 1) then
3764 0 : ABI_ERROR("PAW not implemented")
3765 : ABI_UNUSED((/pawang%nsym, pawrad(1)%mesh_size/))
3766 : end if
3767 :
3768 : ! Check MPI distribution: abort if there are any idle processes
3769 : ! NOTE that we have to perform this check only at the level of gstore%compute:
3770 : ! if gstore object is loaded from a *GSTORE.nc file, there are no calls to individual
3771 : ! phonons/electrons distribution, hence k/q-iBZ is not a limiting factor anymore
3772 10 : do my_is=1,gstore%my_nspins
3773 5 : gqk => gstore%gqk(my_is)
3774 5 : nproc = gqk%comm%nproc
3775 5 : nproc_lim = min(gstore%nkibz, gstore%nqibz)
3776 10 : if (nproc > nproc_lim) then
3777 0 : write(msg, "(a,i0,a,i0,4a)") "gstore%compute: nproc=", nproc, " > min(nkibz, nqibz)=", &
3778 0 : nproc_lim, ch10, "This will lead to idle processes, which are not supported.", ch10, &
3779 0 : "Please decrease the total number of CPUs as the size of your problem is relatively small"
3780 0 : ABI_ERROR(msg)
3781 : endif
3782 : enddo
3783 :
3784 : ! This parameter defines the size of the q-buffer used to store the g(k, q) e-ph matrix elements
3785 : ! for all the k-point treated by this MPI rank.
3786 : ! Increasing the buffer size increases the memory requirements
3787 : ! but it leads to better performance as the number of IO operations is decreased.
3788 : ! TODO: Should compute it on the basis of my_nkpt and my_nqpt
3789 5 : qbuf_size = 16
3790 5 : call wrtout(std_out, sjoin(" Begin computation of e-ph matrix elements with qbuf_size:", itoa(qbuf_size)), pre_newlines=1)
3791 5 : call pstat_proc%print(_PSTAT_ARGS_)
3792 5 : call cwtime(cpu_all, wall_all, gflops_all, "start")
3793 :
3794 : ! If True, only k-points in the IBZ and q-points in the IBZ_k are computed.
3795 : ! Matrix elements in full BZs are then reconstructed by symmetry at the end of the run by calling
3796 : ! gstore_symmetrize.
3797 : symmetrize = (dtset%gstore_kzone == "bz" .and. dtset%gstore_qzone == "bz" &
3798 : .and. dtset%gstore_sym > 0 &
3799 5 : )
3800 : !if (symmetrize) call wrtout(units, " Computing g(k, q) with k in the IBZ and q in the BZ + final reconstruction")
3801 :
3802 : ! Copy important dimensions
3803 5 : natom = cryst%natom; natom3 = 3 * natom; nsppol = ebands%nsppol; nspinor = ebands%nspinor; nspden = dtset%nspden
3804 5 : nkibz = ebands%nkpt; mband = ebands%mband
3805 :
3806 : ! FFT meshes
3807 20 : nfftf = product(ngfftf(1:3)); mgfftf = maxval(ngfftf(1:3))
3808 35 : nfft = product(ngfft(1:3)) ; mgfft = maxval(ngfft(1:3))
3809 5 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); n4 = ngfft(4); n5 = ngfft(5); n6 = ngfft(6)
3810 :
3811 : ! Open the DVDB file
3812 5 : call dvdb%open_read(ngfftf, xmpi_comm_self)
3813 5 : ABI_CHECK(dvdb%has_fields("pot1", msg), msg)
3814 :
3815 : ! Activate parallelism over perturbations at the level of the DVDB
3816 5 : call gstore%set_perts_distrib(cryst, dvdb, my_npert)
3817 :
3818 : ! Prepare Fourier interpolation of DFPT potentials.
3819 5 : comm_rpt = xmpi_comm_self
3820 : !comm_rpt = bqs_comm%value
3821 :
3822 : ! qmap_symrec gives the mapping gstore%ibz --> dvdb%ibz
3823 5 : call dvdb%need_ftinterp(gstore%nqibz, gstore%qibz, gstore%qptopt, qmap_symrec, need_ftinterp)
3824 5 : ABI_FREE(qmap_symrec)
3825 : !need_ftinterp = .True.
3826 :
3827 5 : if (.not. need_ftinterp .and. dtset%eph_use_ftinterp /= 0) then
3828 0 : ABI_WARNING("Enforcing FT interpolation for q-points even if it's not strictly needed.")
3829 0 : need_ftinterp = .True.
3830 : end if
3831 :
3832 5 : if (need_ftinterp) then
3833 3 : call wrtout(units, " Cannot find all IBZ q-points in the DVDB --> Activating Fourier interpolation.")
3834 3 : call dvdb%ftinterp_setup(dtset%ddb_ngqpt, gstore%qptopt, 1, dtset%ddb_shiftq, nfftf, ngfftf, comm_rpt)
3835 : else
3836 2 : call wrtout(units, " DVDB file contains all q-points in the IBZ --> Reading DFPT potentials from file.")
3837 : end if
3838 :
3839 : ! Initialize the wave function descriptor.
3840 : ! Only wavefunctions for the symmetrical image of the k/k+q wavevectors treated by this MPI rank are stored.
3841 20 : ABI_MALLOC(nband, (nkibz, nsppol))
3842 25 : ABI_MALLOC(bks_mask, (mband, nkibz, nsppol))
3843 20 : ABI_MALLOC(keep_ur, (mband, nkibz, nsppol))
3844 2754 : nband = mband; bks_mask = .False.; keep_ur = .False.
3845 :
3846 5 : call gstore%fill_bks_mask(mband, nkibz, nsppol, bks_mask)
3847 :
3848 : ! Impose istwfk = 1 for all k-points. This is also done in respfn (see inkpts)
3849 : ! wfd_read_wfk will handle a possible conversion if WFK contains istwfk /= 1.
3850 15 : ABI_MALLOC(wfd_istwfk, (nkibz))
3851 119 : wfd_istwfk = 1
3852 5 : ecut = dtset%ecut
3853 :
3854 : call wfd%init(cryst, pawtab, psps, keep_ur, mband, nband, nkibz, nsppol, bks_mask,&
3855 : nspden, nspinor, ecut, dtset%ecutsm, dtset%dilatmx, wfd_istwfk, ebands%kptns, ngfft,&
3856 5 : dtset%nloalg, dtset%prtvol, dtset%pawprtvol, comm)
3857 :
3858 10 : call wfd%print([std_out], header="Wavefunctions for GSTORE calculation")
3859 :
3860 5 : ABI_FREE(nband)
3861 5 : ABI_FREE(keep_ur)
3862 5 : ABI_FREE(wfd_istwfk)
3863 5 : ABI_FREE(bks_mask)
3864 :
3865 : ! Read wavefunctions.
3866 5 : call wfd%read_wfk(wfk0_path, iomode_from_fname(wfk0_path))
3867 5 : call pstat_proc%print(_PSTAT_ARGS_)
3868 :
3869 : ! one-dimensional structure factor information on the coarse grid.
3870 15 : ABI_MALLOC(ph1d, (2, 3*(2*mgfft+1)*natom))
3871 5 : call getph(cryst%atindx, natom, n1, n2, n3, ph1d, cryst%xred)
3872 :
3873 : ! mpw is the maximum number of plane-waves over k and k+q where k and k+q are in the BZ.
3874 : ! we also need the max components of the G-spheres (k, k+q) in order to allocate the workspace array work
3875 : ! that will be used to symmetrize the wavefunctions in G-space.
3876 5 : call gstore%get_mpw_gmax(ecut, mpw, gmax)
3877 :
3878 : ! Init work_ngfft
3879 20 : gmax = gmax + 4 ! FIXME: this is to account for umklapp
3880 20 : gmax = 2*gmax + 1
3881 5 : call ngfft_seq(work_ngfft, gmax)
3882 : !write(std_out,*)"work_ngfft(1:3): ",work_ngfft(1:3)
3883 25 : ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
3884 :
3885 : ! Allow PW-arrays dimensioned with mpw
3886 15 : ABI_MALLOC(kg_k, (3, mpw))
3887 10 : ABI_MALLOC(kg_kq, (3, mpw))
3888 :
3889 5 : usecprj = 0
3890 10 : ABI_MALLOC(cwaveprj0, (natom, nspinor*usecprj))
3891 :
3892 : ! Prepare call to getgh1c
3893 5 : usevnl = 0
3894 5 : optlocal = 1 ! local part of H^(1) is computed in gh1c=<G|H^(1)|C>
3895 5 : optnl = 2 ! non-local part of H^(1) is totally computed in gh1c=<G|H^(1)|C>
3896 5 : opt_gvnlx1 = 0 ! gvnlx1 is output
3897 5 : ABI_MALLOC(grad_berry, (2, nspinor*(berryopt0/4)))
3898 :
3899 : ! This part is taken from dfpt_vtorho
3900 : !==== Initialize most of the Hamiltonian (and derivative) ====
3901 : !1) Allocate all arrays and initialize quantities that do not depend on k and spin.
3902 : !2) Perform the setup needed for the non-local factors:
3903 : ! Norm-conserving: Constant kleimann-Bylander energies are copied from psps to gs_hamk.
3904 : ! PAW: Initialize the overlap coefficients and allocate the Dij coefficients.
3905 :
3906 : call gs_ham_kq%init(psps, pawtab, nspinor, nsppol, nspden, natom, &
3907 : dtset%typat, cryst%xred, nfft, mgfft, ngfft, cryst%rprimd, dtset%nloalg, &
3908 : comm_atom=mpi_enreg%comm_atom, mpi_atmtab=mpi_enreg%my_atmtab, mpi_spintab=mpi_enreg%my_isppoltab, &
3909 5 : usecprj=usecprj, ph1d=ph1d, nucdipmom=dtset%nucdipmom, gpu_option=dtset%gpu_option)
3910 :
3911 : ! Allocate vlocal. Note nvloc
3912 : ! I set vlocal to huge to trigger possible bugs (DFPT routines should not access the data)
3913 30 : ABI_MALLOC(vlocal, (n4, n5, n6, gs_ham_kq%nvloc))
3914 26516 : vlocal = huge(one)
3915 :
3916 : ! Allocate work space arrays.
3917 20 : ABI_MALLOC(displ_cart_qibz, (2, 3, cryst%natom, natom3))
3918 22241 : ABI_CALLOC(dummy_vtrial, (nfftf, nspden))
3919 :
3920 : ! Open GSTORE file, and read table used for restarting.
3921 : ! TODO: Fix problem with IO (some q-points are not written)
3922 5 : if (dtset%useria == 888) then
3923 : ! use xmpi_comm_self otherwise there will be a deadlock on lemaitre4
3924 0 : NCF_CHECK(nctk_open_modify(root_ncid, gstore%path, xmpi_comm_self))
3925 : else
3926 5 : NCF_CHECK(nctk_open_modify(root_ncid, gstore%path, gstore%comm))
3927 : end if
3928 :
3929 : ! integer scalars
3930 : ncerr = nctk_def_iscalars(root_ncid, [character(len=nctk_slen) :: &
3931 : "used_ftinterp" &
3932 10 : ])
3933 5 : NCF_CHECK(ncerr)
3934 :
3935 20 : ABI_MALLOC(done_qbz_spin, (gstore%nqbz, nsppol))
3936 5 : NCF_CHECK(nf90_get_var(root_ncid, nctk_idname(root_ncid, "gstore_done_qbz_spin"), done_qbz_spin))
3937 :
3938 5 : gstore%wfk0_path = wfk0_path
3939 :
3940 : !if (my_rank == master) then
3941 5 : ii = merge(1, 0, need_ftinterp)
3942 : ncerr = nctk_write_iscalars(root_ncid, [character(len=nctk_slen) :: &
3943 : "used_ftinterp"], &
3944 : [ii &
3945 15 : ])
3946 5 : NCF_CHECK(ncerr)
3947 :
3948 5 : NCF_CHECK(nf90_put_var(root_ncid, root_vid("gstore_wfk0_path"), trim(gstore%wfk0_path)))
3949 : !end if
3950 :
3951 10 : if (my_rank == master) call gstore%print([std_out])
3952 2487 : ndone = count(done_qbz_spin == 1)
3953 :
3954 5 : if (ndone == 0) then
3955 : ! Write phonon data here as we are not guaranteed to have all the IBZ q-points
3956 : ! inside the loop over my_iq if filtering has been used.
3957 : ! Make sure internal table with gstore_done_qbz_spin is properly filled.
3958 5 : call gstore%compute_and_write_ph(root_ncid)
3959 : else
3960 0 : call wrtout(units, sjoin("- Restarting GSTORE calculation from file:", gstore%path))
3961 0 : call wrtout(units, sjoin(" Found: ", itoa(ndone), " (qpt, spin) entries already computed"))
3962 : end if
3963 :
3964 : ! Create ddkop object to compute group velocities (if needed)
3965 5 : if (gstore%with_vk /= 0 .and. ndone == 0) then
3966 5 : call gstore%compute_and_write_vk(mpw, wfd, ebands, psps, pawtab, root_ncid)
3967 : end if
3968 :
3969 5 : if (dtset%gstore_iv1p_comm /= 0) then
3970 : call gstore%compute_and_write_commutator(mpw, gmax, ngfft, ngfftf, dtset, cryst, pawfgr, psps, &
3971 0 : wfd, mpi_enreg, kg_k, ebands, dvdb, gs_ham_kq, root_ncid)
3972 : end if
3973 :
3974 5 : call wrtout(std_out, " Begin computation of e-ph matrix elements...", pre_newlines=1)
3975 :
3976 : ! TODO: Exchange the q/k loops so that one can reduce the number of calls to _k dependente routines
3977 : ! and precompute u_nk(r) so that we can save one FFT every time we compute <g|v^1_{kappa,a}(r)|u_nk(r)>
3978 : ! The price to pay is an increase in the number of calls to get_ftqbz but for small systems this part does not dominate
3979 : ! Alternatively, one cah have two versions that will be invoked depending on my_nk, my_nq
3980 :
3981 : ! Here we decide if the q-points can be reduced to the IBZ(k)
3982 5 : use_lgk = (dtset%gstore_use_lgk /= 0 .or. dtset%gstore_sym == 2)
3983 : if (use_lgk) then
3984 1 : call wrtout(units, " Only q-points in the IBZ_k will be computed.")
3985 4 : else if (dtset%gstore_use_lgq /= 0) then
3986 0 : call wrtout(units, " Only k-points in the IBZ_q will be computed.")
3987 : else
3988 4 : call wrtout(units, " Little group operations won't be used")
3989 : end if
3990 :
3991 : ! if PAW, one has to solve a generalized eigenproblem
3992 5 : gen_eigenpb = psps%usepaw == 1; sij_opt = 0; if (gen_eigenpb) sij_opt = 1
3993 :
3994 : ! Loop over my spins.
3995 10 : do my_is=1,gstore%my_nspins
3996 5 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is); my_npert = gqk%my_npert
3997 :
3998 5 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
3999 5 : NCF_CHECK(nctk_prepare_mpiio(spin_ncid, "gvals"))
4000 5 : NCF_CHECK(nctk_prepare_mpiio(root_ncid, "gstore_done_qbz_spin"))
4001 :
4002 5 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
4003 :
4004 15 : ABI_MALLOC(iq_buf, (2, qbuf_size))
4005 245 : iq_buf = 0
4006 15 : ABI_MALLOC(lambda, (nb_k))
4007 25 : ABI_MALLOC(gkq_atm, (2, nb_kq, nb_k, natom3))
4008 20 : ABI_MALLOC(gkq_atm_ipc, (2, nb_kq, nb_k))
4009 : #ifdef HAVE_OPENMP_OFFLOAD
4010 : !$OMP TARGET ENTER DATA MAP(alloc:gkq_atm_ipc) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4011 : #endif
4012 :
4013 : ! Inside the loops we compute gkq_atm(2, nb_kq, nb_k, natom3)
4014 40 : ABI_MALLOC_OR_DIE(my_gbuf, (gqk%cplex, nb_kq, nb_k, natom3, gqk%my_nk, qbuf_size), ierr)
4015 5 : call pstat_proc%print(_PSTAT_ARGS_)
4016 :
4017 : ! Compute the little group of the k-point so that we can compute g(k,q) only for q in the IBZ_k
4018 5 : if (use_lgk) then
4019 1 : timrev_k = kpts_timrev_from_kptopt(ebands%kptopt)
4020 4 : ABI_MALLOC(lg_myk, (gqk%my_nk))
4021 2 : do my_ik=1,gqk%my_nk
4022 4 : kk_bz = gqk%my_kpts(:, my_ik)
4023 2 : call lg_myk(my_ik)%init(cryst, kk_bz, timrev_k, gstore%nqbz, gstore%qbz, gstore%nqibz, gstore%qibz, xmpi_comm_self)
4024 : end do
4025 : end if
4026 :
4027 20 : ABI_MALLOC(state_kq, (gqk%my_nk, qbuf_size))
4028 4981 : state_kq = GSTORE_KQ_MISSING
4029 :
4030 : ! Loop over my set of q-points
4031 882 : do my_iq=1,gqk%my_nq
4032 877 : print_time = my_rank == 0 .and. (my_iq <= LOG_MODQ .or. mod(my_iq, LOG_MODQ) == 0)
4033 193 : if (print_time) call cwtime(cpu_q, wall_q, gflops_q, "start")
4034 877 : iq_bz = gqk%my_q2bz(my_iq)
4035 :
4036 877 : call gqk%myqpt(my_iq, gstore, weight_q, qq_bz)
4037 : qq_is_gamma = sum(qq_bz**2) < tol14
4038 877 : qq_bz_string = ktoa(qq_bz)
4039 :
4040 : ! Handle possible restart.
4041 877 : if (done_qbz_spin(iq_bz, spin) == 1) then
4042 0 : call wrtout(std_out, sjoin(" iq_bz:", itoa(iq_bz), ", spin: ", itoa(spin), " already computed --> skipping iteration"))
4043 0 : cycle
4044 : end if
4045 :
4046 : ! Compute the little group of the q-point so that we can compute g(k,q) only for k in the IBZ_q
4047 877 : if (dtset%gstore_use_lgq /= 0) then
4048 0 : timrev_q = kpts_timrev_from_kptopt(gstore%qptopt)
4049 0 : call lg_myq%init(cryst, qq_bz, timrev_q, gstore%nkbz, gstore%kbz, gstore%nkibz, gstore%kibz, xmpi_comm_self)
4050 : end if
4051 :
4052 877 : iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
4053 877 : trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5,my_iq)
4054 : ! Don't test if umklapp == 0 because we use the periodic gauge:
4055 : !
4056 : ! phfreq(q+G) = phfreq(q) and eigvec(q) = eigvec(q+G)
4057 : !
4058 : !isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
4059 877 : isirr_q = (isym_q == 1 .and. trev_q == 0)
4060 3508 : qq_ibz = gstore%qibz(:, iq_ibz)
4061 :
4062 877 : nskip_tetra_kq = 0
4063 877 : iqbuf_cnt = 1 + mod(my_iq - 1, qbuf_size)
4064 2631 : iq_buf(:, iqbuf_cnt) = [my_iq, iq_bz]
4065 :
4066 877 : if (need_ftinterp) then
4067 : ! Fourier interpolation.
4068 786 : call dvdb%get_ftqbz(qq_bz, cplex, nfftf, ngfftf, v1scf, gqk%pert_comm%value)
4069 : else
4070 : ! Read and reconstruct the dvscf potentials for qpt and my_npert perturbations.
4071 91 : db_iqpt = dvdb%findq(qq_ibz)
4072 91 : ABI_CHECK(db_iqpt /= -1, sjoin("Could not find symmetric of q-point:", ktoa(qq_bz), "in DVDB file."))
4073 : ! The first entry in qbz2dvdb gives the index in dvdb%qpts.
4074 : ! The other entries in mapc_qq are OK as they refer to symmetries.
4075 637 : qbz2dvdb = gqk%my_q2ibz(:, my_iq); qbz2dvdb(1) = db_iqpt
4076 91 : call dvdb%readsym_qbz(cryst, qq_bz, qbz2dvdb, cplex, nfftf, ngfftf, v1scf, gqk%pert_comm%value)
4077 : end if
4078 :
4079 : ! Allocate vlocal1 with correct cplex. Note nvloc and my_npert.
4080 6139 : ABI_MALLOC(vlocal1, (cplex*n4, n5, n6, gs_ham_kq%nvloc, my_npert))
4081 :
4082 : ! Set up local potential vlocal1 with proper dimensioning from vtrial1 taking into account the spin.
4083 6139 : do my_ip=1,my_npert
4084 : call rf_transgrid_and_pack(spin, nspden, psps%usepaw, cplex, nfftf, nfft, ngfft, gs_ham_kq%nvloc,&
4085 6139 : pawfgr, mpi_enreg, dummy_vtrial, v1scf(:,:,:,my_ip), vlocal, vlocal1(:,:,:,:,my_ip))
4086 : #ifdef HAVE_OPENMP_OFFLOAD
4087 : !$OMP TARGET ENTER DATA MAP(to:vlocal1(:,:,:,:,my_ip)) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4088 : #endif
4089 : end do
4090 : !$OMP TASKWAIT
4091 :
4092 : ! Continue to initialize the GS Hamiltonian
4093 877 : call gs_ham_kq%load_spin(spin, vlocal=vlocal, with_nonlocal=.true.)
4094 :
4095 : ! Loop over my k-points
4096 74524 : do my_ik=1,gqk%my_nk
4097 : ! The k-point and the symmetries relating the BZ k-point to the IBZ.
4098 294588 : kk_bz = gqk%my_kpts(:, my_ik)
4099 73647 : weight_k = gqk%my_wtk(my_ik)
4100 73647 : kk_string = ktoa(kk_bz)
4101 :
4102 73647 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
4103 294588 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5,my_ik)
4104 282012 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
4105 294588 : kk_ibz = ebands%kptns(:,ik_ibz)
4106 :
4107 : ! Set entry to zero. Important as there are cycle instructions inside these loops
4108 : ! and we don't want random numbers written to disk.
4109 5565417 : my_gbuf(:,:,:,:, my_ik, iqbuf_cnt) = zero
4110 :
4111 73647 : if (symmetrize .and. .not. isirr_k) then
4112 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4113 : end if
4114 :
4115 73647 : if (use_lgk) then
4116 64 : ii = lg_myk(my_ik)%findq_ibzk(qq_bz)
4117 64 : if (ii == -1) then
4118 56 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4119 : end if
4120 : end if
4121 :
4122 73591 : if (dtset%gstore_use_lgq /= 0) then
4123 0 : ii = lg_myq%findq_ibzk(kk_bz)
4124 0 : if (ii == -1) then
4125 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4126 : end if
4127 : end if
4128 :
4129 : ! =========================================
4130 : ! Find symmetrical image of k+q in the kIBZ
4131 : ! =========================================
4132 294364 : kq_bz = kk_bz + qq_bz
4133 73591 : if (kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz, indkk_kq) /= 0) then
4134 : write(msg, '(3a)' ) &
4135 0 : "Cannot find k+q in k-mesh", ch10, 'Check your WFK file and the (k,q) point input variables.'
4136 0 : ABI_ERROR(msg)
4137 : end if
4138 :
4139 73591 : ikq_ibz = indkk_kq(1, 1); isym_kq = indkk_kq(2, 1)
4140 73591 : trev_kq = indkk_kq(6, 1); g0_kq = indkk_kq(3:5, 1)
4141 : isirr_kq = (isym_kq == 1 .and. trev_kq == 0 .and. all(g0_kq == 0))
4142 294364 : kq_ibz = ebands%kptns(:, ikq_ibz)
4143 :
4144 : ! If we have used the KERANGE trick, we may have k or k+q points with just one G component set to zero
4145 : ! so we skip this transition immediately. This should happen only if fsewin > sigma_erange.
4146 73591 : if (wfd%npwarr(ik_ibz) == 1 .or. wfd%npwarr(ikq_ibz) == 1) then
4147 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4148 : end if
4149 :
4150 73591 : if (gstore%kfilter == "fs_tetra") then
4151 : ! Check tetra delta(e_{k+q}) and cycle if all the weights at k+q are zero.
4152 0 : if (all(abs(gstore%delta_ef_kibz_spin(:, ikq_ibz, spin)) == zero)) then
4153 0 : nskip_tetra_kq = nskip_tetra_kq + 1
4154 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4155 : end if
4156 : end if
4157 :
4158 : ! Get npw_k, kg_k and symmetrize wavefunctions from the IBZ (if needed).
4159 : call wfd%sym_ug_kg_npw(ecut, kk_bz, kk_ibz, gqk%bstart_k, nb_k, spin, gqk%my_k2ibz(:, my_ik), cryst, &
4160 73591 : work_ngfft, work, istwf_k, npw_k, kg_k, kets_k)
4161 :
4162 : #ifdef HAVE_OPENMP_OFFLOAD
4163 : !$OMP TARGET ENTER DATA MAP(to:kets_k) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4164 : #endif
4165 :
4166 : ! Get npw_kq, kg_kq and symmetrize wavefunctions from the IBZ (if needed).
4167 : call wfd%sym_ug_kg_npw(ecut, kq_bz, kq_ibz, gqk%bstart_kq, nb_kq, spin, indkk_kq(:,1), cryst, &
4168 73591 : work_ngfft, work, istwf_kq, npw_kq, kg_kq, bras_kq)
4169 :
4170 : #ifdef HAVE_OPENMP_OFFLOAD
4171 : !$OMP TARGET ENTER DATA MAP(to:bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4172 : #endif
4173 :
4174 294364 : ABI_MALLOC(h1_kets_kq, (2, npw_kq*nspinor, nb_k))
4175 220773 : ABI_MALLOC(gs1c_kq, (2, npw_kq*nspinor*nb_k*((sij_opt+1)/2)))
4176 220773 : ABI_MALLOC(gvnlx1, (2, npw_kq*nspinor,nb_k))
4177 : #ifdef HAVE_OPENMP_OFFLOAD
4178 : !$OMP TARGET ENTER DATA MAP(alloc:h1_kets_kq, gvnlx1, kets_k, bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4179 : !$OMP TARGET ENTER DATA MAP(alloc:gs1c_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP .and. sij_opt /= 0) NOWAIT
4180 : #endif
4181 :
4182 : call gs_ham_kq%eph_setup_k("k" , kk_bz, istwf_k, npw_k, kg_k, dtset, cryst, psps, &
4183 73591 : nkpg_k, kpg_k, ffnl_k, kinpw_k, ph3d_k, gqk%pert_comm%value)
4184 :
4185 : #ifdef HAVE_OPENMP_OFFLOAD
4186 : !$OMP TARGET ENTER DATA MAP(to:kpg_k, ffnl_k, kinpw_k, ph3d_k) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4187 : #endif
4188 :
4189 : call gs_ham_kq%eph_setup_k("kq", kq_bz, istwf_k, npw_kq, kg_kq, dtset, cryst, psps, &
4190 73591 : nkpg_kq, kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq, gqk%pert_comm%value)
4191 :
4192 : #ifdef HAVE_OPENMP_OFFLOAD
4193 : !$OMP TARGET ENTER DATA MAP(to:kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4194 : #endif
4195 :
4196 : !$OMP TASKWAIT
4197 :
4198 : ! Loop over my atomic perturbations and compute gkq_atm_ipc.
4199 5483041 : gkq_atm = zero
4200 515137 : do my_ip=1,my_npert
4201 441546 : idir = dvdb%my_pinfo(1, my_ip); ipert = dvdb%my_pinfo(2, my_ip); ipc = dvdb%my_pinfo(3, my_ip)
4202 :
4203 : ! Prepare application of the NL part.
4204 441546 : call rf_ham_kq%init(cplex, gs_ham_kq, ipert, has_e1kbsc=.true.)
4205 441546 : call rf_ham_kq%load_spin(spin, vlocal1=vlocal1(:,:,:,:,my_ip), with_nonlocal=.true.)
4206 :
4207 : #if 1
4208 : ! Calculate dvscf * psi_k, results stored in h1_kets_kq on the k+q sphere.
4209 : ! Compute H(1) applied to GS wavefunction Psi(0)
4210 1128636 : do in_k=1,nb_k
4211 : ! Use scissor shift on 0-order eigenvalue
4212 687090 : band_k = in_k + gqk%bstart_k - 1
4213 1128636 : lambda(in_k) = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
4214 : end do
4215 : !call ebands%get_dfpt_eshifted(gqk%bstart_k, nb_k, ik_ibz, spin, dtset%dfpt_sciss, lambda)
4216 :
4217 : call getgh1c(berryopt0, kets_k, cwaveprj0, h1_kets_kq, &
4218 : grad_berry, gs1c_kq, gs_ham_kq, gvnlx1, idir, ipert, lambda, mpi_enreg, nb_k, optlocal, &
4219 441546 : optnl, opt_gvnlx1, rf_ham_kq, sij_opt, tim_getgh1c, usevnl)
4220 :
4221 : #else
4222 : do in_k=1,nb_k
4223 : ! Use scissor shift on 0-order eigenvalue
4224 : band_k = in_k + gqk%bstart_k - 1
4225 : eshift = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
4226 :
4227 : call getgh1c(berryopt0, kets_k(:,:,in_k), cwaveprj0, h1_kets_kq(:,:,in_k), &
4228 : grad_berry, gs1c_kq, gs_ham_kq, gvnlx1, idir, ipert, [eshift], mpi_enreg, ndat1, optlocal, &
4229 : optnl, opt_gvnlx1, rf_ham_kq, sij_opt, tim_getgh1c, usevnl)
4230 : end do ! in_k
4231 : #endif
4232 :
4233 441546 : call rf_ham_kq%free()
4234 :
4235 : ! Calculate <psi_{k+q,j}|dvscf_q*psi_{k,i}> for this perturbation. No need to handle istwf_kq because it's always 1.
4236 441546 : if (dtset%gpu_option == ABI_GPU_OPENMP) then
4237 : call abi_gpu_xgemm_d(2, 'C', 'N', nb_kq, nb_k, npw_kq*nspinor, cone, bras_kq, npw_kq*nspinor, &
4238 0 : h1_kets_kq, npw_kq*nspinor, czero, gkq_atm_ipc, nb_kq)
4239 : #ifdef HAVE_OPENMP_OFFLOAD
4240 : !$OMP TARGET UPDATE FROM(gkq_atm_ipc)
4241 : #endif
4242 : else
4243 : call ZGEMM('C', 'N', nb_kq, nb_k, npw_kq*nspinor, cone, bras_kq, npw_kq*nspinor, &
4244 441546 : h1_kets_kq, npw_kq*nspinor, czero, gkq_atm_ipc, nb_kq)
4245 : end if
4246 :
4247 : ! Transfer data
4248 5483041 : gkq_atm(:,:,:,ipc) = gkq_atm_ipc
4249 : end do ! my_ip
4250 :
4251 : ! Collect gkq_atm inside pert_comm so that all procs can operate on the data.
4252 73591 : if (gqk%pert_comm%nproc > 1) call xmpi_sum(gkq_atm, gqk%pert_comm%value, ierr)
4253 :
4254 : ! Save e-ph matrix elements in the buffer.
4255 5483041 : my_gbuf(:,:,:,:, my_ik, iqbuf_cnt) = gkq_atm
4256 73591 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_COMPUTED
4257 :
4258 : #ifdef HAVE_OPENMP_OFFLOAD
4259 : !$OMP TARGET EXIT DATA MAP(delete:kpg_k, ffnl_k, kinpw_k, ph3d_k) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4260 : !$OMP TARGET EXIT DATA MAP(delete:kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4261 : !$OMP TARGET EXIT DATA MAP(delete:h1_kets_kq, gvnlx1, kets_k, bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4262 : !$OMP TARGET EXIT DATA MAP(delete:gs1c_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP .and. sij_opt /= 0)
4263 : #endif
4264 73591 : ABI_FREE(ffnl_k)
4265 73591 : ABI_FREE(ffnl_kq)
4266 73591 : ABI_FREE(kpg_k)
4267 73591 : ABI_FREE(kpg_kq)
4268 73591 : ABI_FREE(ph3d_k)
4269 73591 : ABI_FREE(ph3d_kq)
4270 73591 : ABI_FREE(kinpw_k)
4271 73591 : ABI_FREE(kinpw_kq)
4272 73591 : ABI_FREE(kets_k)
4273 73591 : ABI_FREE(bras_kq)
4274 73591 : ABI_FREE(h1_kets_kq)
4275 73591 : ABI_FREE(gs1c_kq)
4276 74468 : ABI_FREE(gvnlx1)
4277 : end do ! my_ik
4278 :
4279 877 : ABI_FREE(v1scf)
4280 :
4281 : #ifdef HAVE_OPENMP_OFFLOAD
4282 : do my_ip=1,my_npert
4283 : !$OMP TARGET EXIT DATA MAP(delete:vlocal1(:,:,:,:,my_ip)) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4284 : end do
4285 : #endif
4286 877 : ABI_FREE(vlocal1)
4287 :
4288 : ! Dump buffer
4289 877 : if (iqbuf_cnt == qbuf_size) call dump_my_gbuf()
4290 :
4291 877 : if (print_time) then
4292 193 : write(msg,'(2(a,i0),a)')" My q-point [", my_iq, "/", gqk%my_nq, "]"
4293 193 : call cwtime_report(msg, cpu_q, wall_q, gflops_q); if (my_iq == LOG_MODQ) call wrtout(std_out, "...", do_flush=.True.)
4294 : end if
4295 882 : call lg_myq%free()
4296 : end do ! my_iq
4297 :
4298 : ! Dump the remainder.
4299 5 : if (iqbuf_cnt /= 0) call dump_my_gbuf()
4300 :
4301 5 : ABI_FREE(state_kq)
4302 5 : ABI_FREE(iq_buf)
4303 5 : ABI_FREE(my_gbuf)
4304 5 : ABI_FREE(lambda)
4305 5 : ABI_FREE(gkq_atm)
4306 : #ifdef HAVE_OPENMP_OFFLOAD
4307 : !$OMP TARGET EXIT DATA MAP(delete:gkq_atm_ipc) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4308 : #endif
4309 5 : ABI_FREE(gkq_atm_ipc)
4310 :
4311 10 : if (use_lgk) then
4312 2 : do my_ik=1,gqk%my_nk
4313 2 : call lg_myk(my_ik)%free()
4314 : end do
4315 2 : ABI_FREE(lg_myk)
4316 : end if
4317 : end do ! my_is
4318 :
4319 5 : call cwtime_report(" GSTORE computation done", cpu_all, wall_all, gflops_all, pre_str=ch10, end_str=ch10) !, comm=gstore%comm)
4320 : !call gstore%print([std_out], header="GSTORE at the end of gstore%compute")
4321 :
4322 : ! Set gstore_completed to 1 so that we can easily check if restarted is needed.
4323 : !if (my_rank == master) then
4324 5 : NCF_CHECK(nf90_put_var(root_ncid, root_vid("gstore_completed"), 1))
4325 : !end if
4326 : ! nf90_sync can deadlock on lemaitre4 for some MPI decompositions.
4327 5 : if (dtset%useria /= 888) then
4328 5 : NCF_CHECK(nf90_sync(root_ncid))
4329 : end if
4330 5 : NCF_CHECK(nf90_close(root_ncid))
4331 5 : call xmpi_barrier(gstore%comm)
4332 :
4333 : ! Free memory
4334 5 : ABI_FREE(grad_berry)
4335 5 : ABI_FREE(dummy_vtrial)
4336 5 : ABI_FREE(work)
4337 5 : ABI_FREE(ph1d)
4338 5 : ABI_FREE(vlocal)
4339 5 : ABI_FREE(kg_k)
4340 5 : ABI_FREE(kg_kq)
4341 5 : ABI_FREE(displ_cart_qibz)
4342 5 : ABI_FREE(done_qbz_spin)
4343 :
4344 5 : call gs_ham_kq%free(); call wfd%free()
4345 5 : call pawcprj_free(cwaveprj0)
4346 5 : ABI_FREE(cwaveprj0)
4347 :
4348 : ! Reconstruct g(k,q) matrix elements in the full BZ by symmetry.
4349 5 : if (symmetrize) then
4350 0 : call gstore_symmetrize(gstore%path, wfk0_path, ngfft, dtset, dtfil, cryst, psps, pawtab, ebands, ifc, comm)
4351 : end if
4352 :
4353 : ! Output some of the results to ab_out for testing purposes
4354 30 : call gstore%print_for_abitests(dtset, ebands, .True.)
4355 :
4356 : contains
4357 :
4358 56 : subroutine dump_my_gbuf()
4359 :
4360 : ! This function is called inside the double loop over (my_is, my_iq) or when we exit
4361 : ! from the my_iq loop to dump the remainder that is still in the q-buffer,
4362 : ! All the MPI procs in the (kpt_comm x pert_comm) grid shall call this contained routine
4363 : ! as we have side-effects i.e. iqbuf_cnt set to 0.
4364 :
4365 : ! On disk we have the global arrays:
4366 : !
4367 : ! nctkarr_t("gvals", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq")
4368 : !
4369 : ! while the local MPI buffers are dimensioned as follows:
4370 : !
4371 : ! my_gbuf(2, nb_kq, nb_k, natom3, gqk%my_nk, qbuf_size)
4372 :
4373 : ! If parallelism over perturbation is activated, only the procs treating the first perturbation
4374 : ! i.e. the procs treating different k-points for this q are involved in IO
4375 : ! as all the local buffers store results for all natom3 perturbations.
4376 :
4377 : ! NOTE: A similar routine is used in m_gstore. The two implementations should be kept in synch.
4378 :
4379 : integer :: ii, iq_bz, iq_glob, my_iq
4380 : logical :: iscontiguous
4381 :
4382 56 : if (gqk%coords_qkpb_sumbp(3) /= 0) goto 10 ! Yes, I'm very proud of this GOTO.
4383 :
4384 : !if (dtset%prtvol > 5) then
4385 : !print *, "in dump_my_gbuf with start: ", [1, 1, 1, 1, gqk%my_kstart, iq_glob]
4386 : !print *, " count; ", [2, gqk%nb_kq, gqk%nb_k, gqk%natom3, gqk%my_nk, iqbuf_cnt]
4387 : !end if
4388 :
4389 : ! Check if the q-points in the buffer are perfectly contiguous (no cycles/holes)
4390 56 : iscontiguous = .True.
4391 933 : do ii=1, iqbuf_cnt
4392 877 : my_iq = iq_buf(1, ii)
4393 877 : if (my_iq == 0) then
4394 : iscontiguous = .False.; exit
4395 : end if
4396 933 : if (ii > 1) then
4397 821 : if (my_iq /= iq_buf(1, ii-1) + 1) then
4398 : iscontiguous = .False.; exit
4399 : end if
4400 : end if
4401 : end do
4402 :
4403 56 : if (iscontiguous) then
4404 : ! Fast path: Write slabs directly
4405 56 : my_iq = iq_buf(1, 1)
4406 56 : iq_glob = my_iq + gqk%my_qstart - 1
4407 :
4408 : ncerr = nf90_put_var(spin_ncid, spin_vid("gvals"), my_gbuf(:,:,:,:,:, 1:iqbuf_cnt), &
4409 : start=[1, 1, 1, 1, gqk%my_kstart, iq_glob], &
4410 728 : count=[2, gqk%nb_kq, gqk%nb_k, gqk%natom3, gqk%my_nk, iqbuf_cnt])
4411 56 : NCF_CHECK(ncerr)
4412 :
4413 : ncerr = nf90_put_var(root_ncid, root_vid("gstore_glob_state_kqs"), state_kq(:, 1:iqbuf_cnt), &
4414 : start=[gqk%my_kstart, iq_glob, spin], &
4415 392 : count=[gqk%my_nk, iqbuf_cnt, 1])
4416 56 : NCF_CHECK(ncerr)
4417 : else
4418 : ! Slow path: Q-points were filtered, write slice by slice avoiding holes
4419 0 : do ii=1, iqbuf_cnt
4420 0 : my_iq = iq_buf(1, ii)
4421 0 : if (my_iq == 0) cycle
4422 0 : iq_glob = my_iq + gqk%my_qstart - 1
4423 :
4424 : ncerr = nf90_put_var(spin_ncid, spin_vid("gvals"), my_gbuf(:,:,:,:,:, ii), &
4425 : start=[1, 1, 1, 1, gqk%my_kstart, iq_glob], &
4426 0 : count=[2, gqk%nb_kq, gqk%nb_k, gqk%natom3, gqk%my_nk, 1])
4427 0 : NCF_CHECK(ncerr)
4428 :
4429 : ncerr = nf90_put_var(root_ncid, root_vid("gstore_glob_state_kqs"), state_kq(:, ii), &
4430 : start=[gqk%my_kstart, iq_glob, spin], &
4431 0 : count=[gqk%my_nk, 1, 1])
4432 0 : NCF_CHECK(ncerr)
4433 : end do
4434 : end if
4435 :
4436 : ! Only one proc sets the entry in done_qbz_spin to 1 for all the q-points in the buffer.
4437 : !if (all(gqk%coords_qkpb_sumbp(2:3) == [0, 0])) then
4438 933 : do ii=1,iqbuf_cnt
4439 877 : my_iq = iq_buf(1, ii)
4440 877 : if (my_iq == 0) cycle
4441 877 : iq_bz = iq_buf(2, ii)
4442 2687 : NCF_CHECK(nf90_put_var(root_ncid, root_vid("gstore_done_qbz_spin"), 1, start=[iq_bz, spin]))
4443 : end do
4444 : !end if
4445 :
4446 : ! Zero the counter before returning
4447 56 : 10 iqbuf_cnt = 0
4448 2744 : iq_buf = 0
4449 76088 : state_kq = GSTORE_KQ_MISSING
4450 :
4451 : ! These syncs can deadlock on lemaitre4 for some MPI decompositions.
4452 56 : if (dtset%useria /= 888) then
4453 56 : NCF_CHECK(nf90_sync(spin_ncid))
4454 56 : NCF_CHECK(nf90_sync(root_ncid))
4455 : end if
4456 :
4457 56 : end subroutine dump_my_gbuf
4458 :
4459 943 : integer function root_vid(var_name)
4460 : character(len=*),intent(in) :: var_name
4461 943 : root_vid = nctk_idname(root_ncid, var_name)
4462 : end function root_vid
4463 :
4464 56 : integer function spin_vid(var_name)
4465 : character(len=*),intent(in) :: var_name
4466 56 : spin_vid = nctk_idname(spin_ncid, var_name)
4467 : end function spin_vid
4468 :
4469 : end subroutine gstore_compute
4470 : !!***
4471 :
4472 : !----------------------------------------------------------------------
4473 :
4474 : !!****f* m_gstore/gstore_check_qkzone_gmode
4475 : !! NAME
4476 : !! gstore_check_cplex_qkzone_gmode
4477 : !!
4478 : !! FUNCTION
4479 : !! Perform consistency checks
4480 : !!
4481 : !! INPUTS
4482 : !!
4483 : !! SOURCE
4484 :
4485 9 : integer function gstore_check_cplex_qkzone_gmode(gstore, cplex, qzone, kzone, gmode, &
4486 : kfilter, check_alloc) result(ierr) ! optional
4487 :
4488 : !Arguments ------------------------------------
4489 : class(gstore_t),target,intent(in) :: gstore
4490 : integer,intent(in) :: cplex
4491 : character(len=*),intent(in) :: qzone, kzone, gmode
4492 : character(len=*),optional,intent(in) :: kfilter
4493 : logical,optional,intent(in) :: check_alloc
4494 :
4495 : !Local variables-------------------------------
4496 : integer :: my_is
4497 : logical :: check_alloc__
4498 : ! *************************************************************************
4499 :
4500 9 : ierr = 0
4501 9 : ABI_CHECK_NOSTOP(gstore%qzone == qzone, sjoin("qzone: ", qzone, "required but got: ", gstore%qzone), ierr)
4502 9 : ABI_CHECK_NOSTOP(gstore%kzone == kzone, sjoin("kzone: ", kzone, "required but got: ", gstore%kzone), ierr)
4503 9 : ABI_CHECK_NOSTOP(gstore%gmode == gmode, sjoin("gmode: ", gmode, "required but got: ", gstore%gmode), ierr)
4504 9 : if (present(kfilter)) then
4505 0 : ABI_CHECK_NOSTOP(gstore%kfilter == kfilter, sjoin("kfilter: ", kfilter, "required but got: ", gstore%kfilter), ierr)
4506 : end if
4507 :
4508 9 : check_alloc__ = .True.; if (present(check_alloc)) check_alloc__ = check_alloc
4509 :
4510 18 : do my_is=1,gstore%my_nspins
4511 9 : associate (gqk => gstore%gqk(my_is))
4512 0 : ABI_CHECK_NOSTOP(gqk%cplex == cplex, sjoin("cplex:", itoa(cplex), "required but got: ", itoa(gqk%cplex)), ierr)
4513 9 : if (check_alloc__) then
4514 9 : if (cplex == 1) then
4515 0 : ABI_CHECK_NOSTOP(allocated(gqk%my_g2), "my_g2 array is not allocated", ierr)
4516 9 : else if (cplex == 2) then
4517 9 : ABI_CHECK_NOSTOP(allocated(gqk%my_g), "my_g array is not allocated", ierr)
4518 : end if
4519 : end if
4520 : end associate
4521 : end do
4522 :
4523 9 : end function gstore_check_cplex_qkzone_gmode
4524 : !!***
4525 :
4526 : !----------------------------------------------------------------------
4527 :
4528 : !!****f* m_gstore/gstore_from_ncpath
4529 : !! NAME
4530 : !! gstore_from_ncpath
4531 : !!
4532 : !! FUNCTION
4533 : !! Reconstruct a gstore_t instance from a netcdf file.
4534 : !!
4535 : !! INPUTS
4536 : !! path: Path to the GSTORE file.
4537 : !! with_cplex: 0 to read no matrix elements, 1 for |g|^2, 2 for complex g.
4538 : !! with_gmode defines the representation.
4539 : !! dtset: Input variables
4540 : !! cryst: crystalline structure
4541 : !! ebands: KS energies
4542 : !! ifc: interatomic force constants
4543 : !! with_gmode: "phonon" to have g in the phonon representation or "atom" to have them in atom representation.
4544 : !! gvals_name: "gvals" or "gvals_ks" to read the KS gs produced by the GWPT code.
4545 : !! This option is valid only for gstore files produced by the GWPT code.
4546 : !! with_g2dw: True if Debye-Waller g2 in the RIA should be computed and stored in memory.
4547 : !! comm: MPI communicator.
4548 : !!
4549 : !! SOURCE
4550 :
4551 16 : subroutine gstore_from_ncpath(gstore, path, with_cplex, dtset, dtfil, cryst, ebands, ifc, &
4552 : with_gmode, gvals_name, with_g2dw, comm)
4553 :
4554 : !Arguments ------------------------------------
4555 : class(gstore_t),target,intent(out) :: gstore
4556 : character(len=*),intent(in) :: path
4557 : integer,intent(in) :: with_cplex
4558 : type(dataset_type),target,intent(in) :: dtset
4559 : type(datafiles_type),intent(in) :: dtfil
4560 : class(crystal_t),target,intent(in) :: cryst
4561 : class(ebands_t),target,intent(in) :: ebands
4562 : class(ifc_type),target,intent(in) :: ifc
4563 : character(len=*),intent(in) :: with_gmode, gvals_name
4564 : logical,intent(in) :: with_g2dw
4565 : integer,intent(in) :: comm
4566 :
4567 : !Local variables-------------------------------
4568 : !scalars
4569 : integer,parameter :: master = 0
4570 : integer :: my_rank, ncid, spin, spin_ncid, nproc, ierr, fform, max_nb, ib, natom, natom3, ib_m, ib_n !, varid
4571 : integer :: max_nq, max_nk, ncerr, my_is, my_iq, iq_glob, my_ik, ik_glob
4572 : integer :: nb_k, nb_kq, nb_k_file, nb_kq_file, gstore_cplex, ib_kq_start !, ip1, ip2
4573 : integer :: my_ip, ipert, iq_ibz, iq_bz, isym_q, trev_q, tsign_q, ii !, im_kq
4574 : real(dp),parameter :: G_SMALL = tol8
4575 : real(dp) :: cpu, wall, gflops, wqnu
4576 : logical :: isirr_q, from_atm_to_nu, has_iv1p_comm, read_ks, has_both_g
4577 16 : type(hdr_type) :: wfk0_hdr
4578 832 : type(crystal_t) :: gstore_cryst
4579 : type(gqk_t),pointer :: gqk
4580 : character(len=500) :: msg
4581 : !arrays
4582 64 : integer :: units(2), ibuffer(9), nproc_spin(ebands%nsppol), comm_spin(ebands%nsppol)
4583 32 : integer :: brange_k_spin(2, ebands%nsppol), brange_kq_spin(2, ebands%nsppol), file_brange_kq_spin(2, ebands%nsppol), g0_q(3)
4584 16 : integer,allocatable :: qglob2bz(:,:), qbz2ibz(:,:)
4585 : real(dp) :: qq_ibz(3)
4586 32 : real(dp) :: displ_nu_red(2, 3, cryst%natom)
4587 16 : real(dp),allocatable :: gwork_q(:,:,:,:,:), slice_bb(:,:,:), iv1p_comm(:,:,:,:,:)
4588 16 : real(dp),allocatable :: ks_gwork_q(:,:,:,:,:), ks_slice_bb(:,:,:)
4589 16 : real(dp),allocatable :: phfreqs_ibz(:,:), pheigvec_cart_ibz(:,:,:,:,:), pheigvec_cart_qbz(:,:,:,:)
4590 16 : real(dp),allocatable :: displ_cart_qbz(:,:,:,:), displ_red_qbz(:,:,:,:), gmn_nu(:,:,:,:)
4591 16 : complex(dp),allocatable :: tpp_red(:,:), my_gq0nm_atm(:,:,:,:), ks_my_gq0nm_atm(:,:,:,:)
4592 : ! *************************************************************************
4593 :
4594 16 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
4595 :
4596 16 : ABI_CHECK(with_cplex >= 0 .and. with_cplex <= 2, sjoin("Invalid with_cplex:", itoa(with_cplex)))
4597 :
4598 48 : units = [std_out, ab_out]
4599 16 : call wrtout(units, sjoin("- Reading e-ph matrix elements from: ", path), pre_newlines=1)
4600 16 : call wrtout(units, sjoin(" Asking for with_cplex: ", itoa(with_cplex)))
4601 16 : call wrtout(units, sjoin(" Asking for with_gmode: ", trim(with_gmode)))
4602 16 : call wrtout(units, sjoin(" Asking for gvals_name: ", trim(gvals_name)))
4603 16 : call wrtout(units, sjoin(" Asking for g2dw: ", yesno(with_g2dw)))
4604 :
4605 : ! Set basic parameters.
4606 16 : gstore%comm = comm; gstore%nsppol = dtset%nsppol; gstore%path = path
4607 :
4608 : ! Get references to other data structures.
4609 16 : gstore%dtset => dtset; gstore%cryst => cryst; gstore%ebands => ebands; gstore%ifc => ifc; gstore%kibz => ebands%kptns
4610 :
4611 16 : natom = cryst%natom; natom3 = cryst%natom * 3
4612 :
4613 96 : ABI_CALLOC(gstore%erange_spin, (2, gstore%nsppol))
4614 48 : ABI_MALLOC(gstore%glob_nk_spin, (gstore%nsppol))
4615 48 : ABI_MALLOC(gstore%glob_nq_spin, (gstore%nsppol))
4616 :
4617 : ! =====================================================
4618 : ! Master node reads basic objects and gstore dimensions
4619 : ! =====================================================
4620 :
4621 16 : if (my_rank == master) then
4622 16 : call wrtout(units, sjoin(" Initializing gstore object from:", path, ch10))
4623 16 : ABI_CHECK(path /= ABI_NOFILE, "Use getgstore_filepath to specify the path to GSTORE.nc")
4624 16 : NCF_CHECK(nctk_open_read(ncid, path, xmpi_comm_self))
4625 :
4626 16 : call wfk0_hdr%ncread(ncid, fform)
4627 16 : ABI_CHECK(fform /= 0, sjoin("Error while reading:", path))
4628 :
4629 : ! Read gstore dimensions
4630 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_cplex", gstore_cplex))
4631 16 : ABI_CHECK_IEQ(gstore_cplex, 2, "gstore_cplex 1 from file not supported")
4632 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nkibz", gstore%nkibz))
4633 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nkbz", gstore%nkbz))
4634 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nqibz", gstore%nqibz))
4635 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nqbz", gstore%nqbz))
4636 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_max_nq", max_nq))
4637 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_max_nk", max_nk))
4638 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_max_nb", max_nb))
4639 :
4640 : ! Read gstore variables
4641 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_with_vk"), gstore%with_vk))
4642 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qptopt"), gstore%qptopt))
4643 :
4644 : ! little group variables were added in Abinit v10.5.6.
4645 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_use_lgk"), gstore%has_used_lgk))
4646 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_use_lgq"), gstore%has_used_lgq))
4647 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kzone"), gstore%kzone))
4648 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qzone"), gstore%qzone))
4649 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kfilter"), gstore%kfilter))
4650 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_wfk0_path"), gstore%wfk0_path))
4651 16 : call replace_ch0(gstore%kzone); call replace_ch0(gstore%qzone); call replace_ch0(gstore%kfilter)
4652 16 : call replace_ch0(gstore%wfk0_path)
4653 :
4654 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_gtype"), gstore%gtype))
4655 16 : call replace_ch0(gstore%gtype)
4656 : !print *, "gstore%gtype:", gstore%gtype
4657 :
4658 16 : if (gvals_name == "gvals_ks") then
4659 2 : call wrtout(units, " Reading KS e-ph matrix elements")
4660 14 : else if (gvals_name == "gvals") then
4661 14 : if (gstore%gtype == GSTORE_GTYPE_GWPT) then
4662 4 : call wrtout(units, " Reading GWPT e-ph matrix elements")
4663 : else
4664 10 : call wrtout(units, " Reading KS e-ph matrix elements")
4665 : end if
4666 : end if
4667 :
4668 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_ngqpt"), gstore%ngqpt))
4669 :
4670 48 : ABI_MALLOC(gstore%qibz, (3, gstore%nqibz))
4671 48 : ABI_MALLOC(gstore%wtq, (gstore%nqibz))
4672 48 : ABI_MALLOC(gstore%qbz, (3, gstore%nqbz))
4673 48 : ABI_MALLOC(gstore%kbz, (3, gstore%nkbz))
4674 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_k_spin"), brange_k_spin))
4675 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_kq_spin"), brange_kq_spin))
4676 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_erange_spin"), gstore%erange_spin))
4677 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qibz"), gstore%qibz))
4678 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_wtq"), gstore%wtq))
4679 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qbz"), gstore%qbz))
4680 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kbz"), gstore%kbz))
4681 :
4682 48 : ABI_MALLOC(qbz2ibz, (6, gstore%nqbz))
4683 48 : ABI_MALLOC(gstore%kbz2ibz, (6, gstore%nkbz))
4684 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qbz2ibz"), qbz2ibz))
4685 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kbz2ibz"), gstore%kbz2ibz))
4686 :
4687 64 : ABI_MALLOC(qglob2bz, (max_nq, gstore%nsppol))
4688 64 : ABI_MALLOC(gstore%kglob2bz, (max_nk, gstore%nsppol))
4689 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qglob2bz"), qglob2bz))
4690 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kglob2bz"), gstore%kglob2bz))
4691 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_glob_nq_spin"), gstore%glob_nq_spin))
4692 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_glob_nk_spin"), gstore%glob_nk_spin))
4693 :
4694 : ! Read optional variables:
4695 16 : if (gstore%kfilter == "fs_tetra") then
4696 0 : ABI_MALLOC(gstore%delta_ef_kibz_spin, (max_nb, gstore%nkibz, gstore%nsppol))
4697 0 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_delta_ef_kibz_spin"), gstore%delta_ef_kibz_spin))
4698 : end if
4699 :
4700 16 : NCF_CHECK(nf90_close(ncid))
4701 :
4702 : ! =================
4703 : ! Consistency check
4704 : ! =================
4705 16 : gstore_cryst = wfk0_hdr%get_crystal()
4706 16 : if (cryst%compare(gstore_cryst, header=" Comparing input crystal with the one from GSTORE file") /= 0) then
4707 0 : ABI_ERROR("Crystal structure from input and GSTORE do not agree! Check messages above!")
4708 : end if
4709 16 : call gstore_cryst%free()
4710 : end if ! master
4711 :
4712 16 : if (nproc > 1) then
4713 : ! Broadcast the header.
4714 0 : call wfk0_hdr%bcast(master, my_rank, comm)
4715 :
4716 : ! Broadcast dimensions.
4717 0 : if (my_rank == master) then
4718 0 : ibuffer = [gstore_cplex, gstore%nkibz, gstore%nkbz, gstore%nqibz, gstore%nqbz, gstore%with_vk, max_nq, max_nk, max_nb]
4719 : end if
4720 0 : call xmpi_bcast(ibuffer, master, comm, ierr)
4721 :
4722 0 : if (my_rank /= master) then
4723 : ! Other MPI procs need to store dims and allocate memory before the bcast.
4724 0 : gstore_cplex = ibuffer(1)
4725 0 : gstore%nkibz = ibuffer(2)
4726 0 : gstore%nkbz = ibuffer(3)
4727 0 : gstore%nqibz = ibuffer(4)
4728 0 : gstore%nqbz = ibuffer(5)
4729 0 : gstore%with_vk = ibuffer(6)
4730 0 : max_nq = ibuffer(7)
4731 0 : max_nk = ibuffer(8)
4732 0 : max_nb = ibuffer(9)
4733 :
4734 0 : ABI_MALLOC(gstore%qibz, (3, gstore%nqibz))
4735 0 : ABI_MALLOC(gstore%wtq, (gstore%nqibz))
4736 0 : ABI_MALLOC(gstore%qbz, (3, gstore%nqbz))
4737 0 : ABI_MALLOC(gstore%kbz, (3, gstore%nkbz))
4738 0 : ABI_MALLOC(qbz2ibz, (6, gstore%nqbz))
4739 0 : ABI_MALLOC(gstore%kbz2ibz, (6, gstore%nkbz))
4740 0 : ABI_MALLOC(qglob2bz, (max_nq, gstore%nsppol))
4741 0 : ABI_MALLOC(gstore%kglob2bz, (max_nk, gstore%nsppol))
4742 : end if
4743 :
4744 0 : call xmpi_bcast(gstore%qptopt, master, comm, ierr)
4745 0 : call xmpi_bcast(gstore%has_used_lgk, master, comm, ierr)
4746 0 : call xmpi_bcast(gstore%has_used_lgq, master, comm, ierr)
4747 0 : call xmpi_bcast(gstore%kzone, master, comm, ierr)
4748 0 : call xmpi_bcast(gstore%qzone, master, comm, ierr)
4749 0 : call xmpi_bcast(gstore%kfilter, master, comm, ierr)
4750 0 : call xmpi_bcast(gstore%gmode, master, comm, ierr)
4751 0 : call xmpi_bcast(gstore%gtype, master, comm, ierr)
4752 0 : call xmpi_bcast(gstore%ngqpt, master, comm, ierr)
4753 0 : call xmpi_bcast(gstore%wfk0_path, master, comm, ierr)
4754 0 : call xmpi_bcast(brange_k_spin, master, comm, ierr)
4755 0 : call xmpi_bcast(brange_kq_spin, master, comm, ierr)
4756 0 : call xmpi_bcast(gstore%erange_spin, master, comm, ierr)
4757 0 : call xmpi_bcast(gstore%qibz, master, comm, ierr)
4758 0 : call xmpi_bcast(gstore%wtq, master, comm, ierr)
4759 0 : call xmpi_bcast(gstore%qbz, master, comm, ierr)
4760 0 : call xmpi_bcast(gstore%kbz, master, comm, ierr)
4761 0 : call xmpi_bcast(qbz2ibz, master, comm, ierr)
4762 0 : call xmpi_bcast(gstore%kbz2ibz, master, comm, ierr)
4763 0 : call xmpi_bcast(qglob2bz, master, comm, ierr)
4764 0 : call xmpi_bcast(gstore%kglob2bz, master, comm, ierr)
4765 0 : call xmpi_bcast(gstore%glob_nq_spin, master, comm, ierr)
4766 0 : call xmpi_bcast(gstore%glob_nk_spin, master, comm, ierr)
4767 :
4768 0 : if (gstore%kfilter == "fs_tetra") then
4769 0 : if (my_rank /= master) then
4770 0 : ABI_MALLOC(gstore%delta_ef_kibz_spin, (max_nb, gstore%nkibz, gstore%nsppol))
4771 : end if
4772 0 : call xmpi_bcast(gstore%delta_ef_kibz_spin, master, comm, ierr)
4773 : end if
4774 : end if ! nproc > 1.
4775 :
4776 : ! Consistency check
4777 16 : call wfk0_hdr%vs_dtset(dtset); call wfk0_hdr%free()
4778 :
4779 : ! When reading an existing GSTORE file, gstore_brange selects a smaller window of
4780 : ! intermediate states at k+q. The external-state window at k is always the one on disk.
4781 : ! Keep the file range to compute the offset in the NetCDF nb_kq dimension below.
4782 64 : file_brange_kq_spin = brange_kq_spin
4783 32 : do spin=1,gstore%nsppol
4784 62 : if (any(dtset%gstore_brange(:, spin) /= 0)) then
4785 3 : ABI_CHECK(all(dtset%gstore_brange(:, spin) /= 0), "Both entries of gstore_brange must be specified")
4786 1 : ABI_CHECK_IEQ(dtset%gstore_brange(2, spin), dtset%mband, "gstore_brange(2, spin) must be equal to nband")
4787 1 : if (dtset%eph_stern /= 0) then
4788 1 : ABI_CHECK_IEQ(dtset%gstore_brange(1, spin), 1, "gstore_brange(1, spin) must be 1 when eph_stern is enabled")
4789 : end if
4790 : msg = sjoin("Requested gstore_brange:", ltoa(dtset%gstore_brange(:, spin)), "is not contained in the k+q band range stored in GSTORE.nc:", &
4791 1 : ltoa(file_brange_kq_spin(:, spin)))
4792 1 : ABI_CHECK(dtset%gstore_brange(1, spin) >= file_brange_kq_spin(1, spin) .and. dtset%gstore_brange(2, spin) <= file_brange_kq_spin(2, spin), msg)
4793 3 : brange_kq_spin(:, spin) = dtset%gstore_brange(:, spin)
4794 : call wrtout(units, sjoin(" Restricting k+q states for spin", itoa(spin), "to gstore_brange:", &
4795 1 : ltoa(brange_kq_spin(:, spin))))
4796 : end if
4797 : end do
4798 :
4799 : ! If has_both_g is true, we allocate and read both the KS and the GWPT matrix elements.
4800 16 : read_ks = gstore%gtype == GSTORE_GTYPE_GWPT
4801 16 : has_both_g = gstore%gtype == GSTORE_GTYPE_GWPT
4802 :
4803 : ! Distribute spins, create indirect mapping to spin index and init gstore%brange_k_spin
4804 16 : call gstore%distribute_spins__(ebands%mband, brange_kq_spin, brange_k_spin, nproc_spin, comm_spin, comm)
4805 :
4806 : ! Compute krank
4807 16 : call gstore%krank_ibz%from_kptrlatt(gstore%nkibz, gstore%kibz, ebands%kptrlatt, compute_invrank=.False.)
4808 :
4809 16 : call gstore%set_mpi_grid__(dtfil, nproc_spin, comm_spin)
4810 :
4811 : ! At this point, we have the Cartesian grid (one per spin if any) and we can finally allocate and distribute other arrays.
4812 16 : call gstore%malloc__(with_cplex, has_both_g, max_nq, qglob2bz, max_nk, gstore%kglob2bz, qbz2ibz, gstore%kbz2ibz)
4813 :
4814 16 : call xmpi_comm_free(comm_spin)
4815 :
4816 : ! Now we read the big arrays with MPI-IO and hdf5 groups.
4817 : ! Note the loop over spin as each gqk has its own dimensions.
4818 : ! Recall the shape of the arrays:
4819 : !
4820 : ! In memory, we have allocated:
4821 : !
4822 : ! my_g(my_npert, nb_kq, my_nq, nb_k, my_nk) if with_cplex == 2 (complex array)
4823 : !
4824 : ! or
4825 : !
4826 : ! my_g2(my_npert, nb_kq, my_nq, nb_k, my_nk) if with_cplex == 1
4827 : !
4828 : ! On disk, we have:
4829 : !
4830 : ! nctkarr_t("gvals", "dp", "two, nb_kq_disk, nb_k_disk, natom3, glob_nk, glob_nq")
4831 : !
4832 16 : call cwtime(cpu, wall, gflops, "start")
4833 :
4834 : ! ===================================================
4835 : ! Load phonon frequencies and eigenvectors in the IBZ
4836 : ! ===================================================
4837 :
4838 : ! nctkarr_t("phfreqs_ibz", "dp", "natom3, gstore_nqibz")
4839 : ! nctkarr_t("pheigvec_cart_ibz", "dp", "two, three, natom, natom3, gstore_nqibz")
4840 64 : ABI_MALLOC(phfreqs_ibz, (natom3, gstore%nqibz))
4841 80 : ABI_MALLOC(pheigvec_cart_ibz, (2, 3, cryst%natom, cryst%natom * 3, gstore%nqibz))
4842 64 : ABI_MALLOC(pheigvec_cart_qbz, (2, 3, cryst%natom, cryst%natom * 3))
4843 48 : ABI_MALLOC(displ_cart_qbz, (2, 3, cryst%natom, cryst%natom * 3))
4844 64 : ABI_MALLOC(displ_red_qbz, (2, 3, cryst%natom, natom3))
4845 :
4846 16 : NCF_CHECK(nctk_open_read(ncid, gstore%path, gstore%comm))
4847 16 : has_iv1p_comm = gstore_nc_has_iv1p_comm(gstore, ncid)
4848 :
4849 16 : if (nproc > 1) then
4850 0 : NCF_CHECK(nctk_set_collective(ncid, vid("phfreqs_ibz")))
4851 0 : NCF_CHECK(nctk_set_collective(ncid, vid("pheigvec_cart_ibz")))
4852 : end if
4853 16 : NCF_CHECK(nf90_get_var(ncid, vid("phfreqs_ibz"), phfreqs_ibz))
4854 16 : NCF_CHECK(nf90_get_var(ncid, vid("pheigvec_cart_ibz"), pheigvec_cart_ibz))
4855 16 : NCF_CHECK(nf90_close(ncid))
4856 :
4857 : ! =========================
4858 : ! Load e-ph matrix elements
4859 : ! =========================
4860 16 : call pstat_proc%print(_PSTAT_ARGS_)
4861 :
4862 16 : from_atm_to_nu = .False.
4863 : ! Compare with_gmode with the one on disk. The only conversion I can think of is: atom --> phonon.
4864 16 : if (gstore%gmode /= with_gmode) then
4865 16 : if (gstore%gmode == GSTORE_GMODE_ATOM .and. with_gmode == GSTORE_GMODE_PHONON) then
4866 16 : from_atm_to_nu = .True.; gstore%gmode = GSTORE_GMODE_PHONON ! Change gstore%gmode here
4867 : else
4868 0 : ABI_ERROR(sjoin("Conversion from gstore%gmode: ", gstore%gmode, "to:", with_gmode, " is not yet supported"))
4869 : end if
4870 : end if
4871 16 : gstore%gmode = with_gmode
4872 :
4873 16 : if (with_g2dw) then
4874 7 : ABI_CHECK(with_gmode == GSTORE_GMODE_PHONON, "g2dw in the atom representation is not coded")
4875 28 : ABI_MALLOC(tpp_red, (natom3, natom3))
4876 : end if
4877 :
4878 32 : do spin=1,gstore%nsppol
4879 16 : my_is = gstore%spin2my_is(spin)
4880 :
4881 32 : if (my_is /= 0) then
4882 16 : gqk => gstore%gqk(my_is)
4883 :
4884 64 : ABI_MALLOC(gqk%my_wnuq, (gqk%my_npert, gqk%my_nq))
4885 80 : ABI_MALLOC(gqk%my_displ_cart, (2, 3, cryst%natom, gqk%my_npert, gqk%my_nq))
4886 :
4887 16 : NCF_CHECK(nctk_open_read(ncid, gstore%path, gqk%comm%value))
4888 16 : NCF_CHECK(nf90_inq_ncid(ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
4889 :
4890 16 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_k", nb_k_file))
4891 16 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_kq", nb_kq_file))
4892 :
4893 : ! Note that these dimensions should be compatible with what is stored on disk.
4894 16 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
4895 16 : ABI_CHECK_IEQ(nb_k, nb_k_file, "nb_k !/ nb_k_file")
4896 16 : ABI_CHECK_ILEQ(nb_kq, nb_kq_file, "nb_kq > nb_kq_file")
4897 16 : ib_kq_start = gqk%bstart_kq - file_brange_kq_spin(1, spin) + 1
4898 16 : ABI_CHECK_IRANGE(ib_kq_start, 1, nb_kq_file, "Invalid k+q band offset in GSTORE.nc")
4899 16 : ABI_CHECK_ILEQ(ib_kq_start + nb_kq - 1, nb_kq_file, "Requested k+q band window exceeds GSTORE.nc")
4900 :
4901 : ! gstore_cplex defines the data on disk while cplex defines what we want to store in memory
4902 112 : ABI_MALLOC_OR_DIE(gwork_q, (gstore_cplex, nb_kq, nb_k, gqk%natom3, gqk%glob_nk), ierr)
4903 80 : ABI_MALLOC(slice_bb, (gstore_cplex, nb_kq, nb_k))
4904 16 : if (read_ks) then
4905 42 : ABI_MALLOC_OR_DIE(ks_gwork_q, (gstore_cplex, nb_kq, nb_k, gqk%natom3, gqk%glob_nk), ierr)
4906 30 : ABI_MALLOC(ks_slice_bb, (gstore_cplex, nb_kq, nb_k))
4907 : end if
4908 :
4909 16 : if (with_g2dw) then
4910 : ! Read my_gq0nm_atm matrix elements for DW in the RIA. Find the index of q = 0.
4911 7 : iq_glob = -1
4912 7 : do ii=1, gstore%glob_nq_spin(spin)
4913 7 : iq_bz = qglob2bz(ii, spin)
4914 28 : if (sum(gstore%qbz(:, iq_bz)**2) < tol4) then
4915 7 : iq_glob = ii; exit
4916 : end if
4917 : end do
4918 7 : ABI_CHECK_INEQ(iq_glob, -1, "Cannot finq q=0 in g(k,q)!")
4919 7 : call wrtout(std_out, sjoin(" Reading g_atm(k,q=0) for Debye-Waller with iq_glob:", itoa(iq_glob)))
4920 :
4921 : ! Read q-slice of the e-ph matrix elements (individual IO).
4922 : ! Note gvals_name so that we can read either g^KS or g^Sigma.
4923 49 : ncerr = nf90_get_var(spin_ncid, spin_vid(gvals_name), gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
4924 7 : NCF_CHECK(ncerr)
4925 :
4926 7 : if (read_ks) then
4927 42 : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals_ks"), ks_gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
4928 6 : NCF_CHECK(ncerr)
4929 : ! Here we set g_GWPT g to g_KS if g_KS is smaller than a certain threshold as GWPT breaks symmetries.
4930 13931 : where (abs(ks_gwork_q) < G_SMALL)
4931 : gwork_q = ks_gwork_q
4932 : end where
4933 : end if
4934 :
4935 : ! Allocate gdw2
4936 49 : ABI_MALLOC(gqk%my_gdw2, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk))
4937 7 : gqk%my_gdw2_ks => gqk%my_gdw2
4938 : ! Allocate my_gq0nm_atm and transfer data. Note TRANSPOSITION in (m, n) indices.
4939 42 : ABI_MALLOC(my_gq0nm_atm, (nb_k, nb_kq, natom3, gqk%my_nk))
4940 :
4941 7 : if (gqk%has_both_g) then
4942 36 : ABI_MALLOC(gqk%my_gdw2_ks, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk))
4943 30 : ABI_MALLOC(ks_my_gq0nm_atm, (nb_k, nb_kq, natom3, gqk%my_nk))
4944 : end if
4945 :
4946 19 : do my_ik=1,gqk%my_nk
4947 12 : ik_glob = my_ik + gqk%my_kstart - 1
4948 167 : do ib_m=1,nb_kq
4949 988 : do ib_n=1,nb_k
4950 5796 : my_gq0nm_atm(ib_n,ib_m,:,my_ik) = gwork_q(1,ib_m,ib_n,:,ik_glob) + j_dpc * gwork_q(2,ib_m,ib_n,:,ik_glob)
4951 976 : if (gqk%has_both_g) then
4952 5236 : ks_my_gq0nm_atm(ib_n,ib_m,:,my_ik) = ks_gwork_q(1,ib_m,ib_n,:,ik_glob) + j_dpc * ks_gwork_q(2,ib_m,ib_n,:,ik_glob)
4953 : end if
4954 : end do
4955 : end do
4956 : end do
4957 : end if ! with_g2dw
4958 :
4959 16 : if (has_iv1p_comm) then
4960 : ! Read matrix elements of commutator [iv, p].
4961 0 : ABI_MALLOC(gqk%my_iv1p_comm, (nb_k, nb_k, 3, gqk%my_npert, gqk%my_nk))
4962 0 : ABI_MALLOC(iv1p_comm, (2, nb_k, nb_k, 3, natom3))
4963 : ! nctkarr_t("iv1p_comm", "dp", "two, nb_k, nb_k, three, natom3, glob_nk")
4964 :
4965 0 : do my_ik=1,gqk%my_nk
4966 0 : ik_glob = my_ik + gqk%my_kstart - 1
4967 0 : ncerr = nf90_get_var(spin_ncid, spin_vid("iv1p_comm"), iv1p_comm, start=[1,1,1,1,1, ik_glob])
4968 0 : NCF_CHECK(ncerr)
4969 :
4970 : ! Save my perturbations for this k-point.
4971 0 : do my_ip=1,gqk%my_npert
4972 0 : ipert = gqk%my_pertcases(my_ip)
4973 0 : gqk%my_iv1p_comm(:,:,:,my_ip, my_ik) = r2c(iv1p_comm(:,:,:,:,ipert))
4974 : end do
4975 : end do
4976 0 : ABI_FREE(iv1p_comm)
4977 : end if
4978 :
4979 16 : if (from_atm_to_nu) then
4980 80 : ABI_MALLOC(gmn_nu, (2, nb_kq, nb_k, 3*natom))
4981 : end if
4982 :
4983 : ! Read my e-ph matrix elements.
4984 1365 : do my_iq=1,gqk%my_nq
4985 1349 : iq_glob = my_iq + gqk%my_qstart - 1
4986 :
4987 : !call wrtout(std_out, " Computing and storing phonons in the full BZ by rotating the data in the IBZ...")
4988 1349 : iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
4989 1349 : trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5, my_iq)
4990 : !isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
4991 1349 : isirr_q = (isym_q == 1 .and. trev_q == 0)
4992 1349 : tsign_q = 1; if (trev_q == 1) tsign_q = -1
4993 5396 : qq_ibz = gstore%qibz(:, iq_ibz)
4994 :
4995 : ! Here we get the ph displacement for this q-point in the BZ from the image in the IBZ.
4996 : ! This is important for complex g as we have to enforce the gauge in the ph eigenvectors, including e(-q) = e(q)^*.
4997 : call pheigvec_rotate(cryst, qq_ibz, isym_q, trev_q, pheigvec_cart_ibz(:,:,:,:,iq_ibz), pheigvec_cart_qbz, displ_cart_qbz, &
4998 1349 : displ_red_qbz=displ_red_qbz)
4999 :
5000 : ! Save my frequencies and my phonon displacements.
5001 17537 : gqk%my_wnuq(:, my_iq) = phfreqs_ibz(gqk%my_pertcases(:), iq_ibz)
5002 179417 : gqk%my_displ_cart(:,:,:,:,my_iq) = displ_cart_qbz(:,:,:,gqk%my_pertcases(:))
5003 :
5004 1349 : if (with_g2dw) then
5005 1176 : do my_ip=1,gqk%my_npert
5006 : ! Compute T_pp'(q,nu) matrix in reduced coordinates for DW.
5007 1008 : call phdispl_cart2red_nmodes(natom, 1, cryst%gprimd, gqk%my_displ_cart(:,:,:,my_ip,my_iq), displ_nu_red)
5008 1008 : call sigtk_dw_tpp_red(natom, displ_nu_red, tpp_red)
5009 1008 : wqnu = gqk%my_wnuq(my_ip, my_iq)
5010 :
5011 2424 : do my_ik=1,gqk%my_nk
5012 2256 : if (.not. gqk%has_both_g .or. dtset%gwpt_g2mode == 1) then
5013 : call calc_and_store_gdw2(gqk, my_ik, my_iq, my_ip, wqnu, tpp_red, &
5014 864 : my_gq0nm_atm(:,:,:,my_ik), my_gq0nm_atm(:,:,:,my_ik))
5015 : else
5016 : !print *, "Computing g2dw with both g^KS g_GWPT"
5017 : call calc_and_store_gdw2(gqk, my_ik, my_iq, my_ip, wqnu, tpp_red, &
5018 384 : ks_my_gq0nm_atm(:,:,:,my_ik), my_gq0nm_atm(:,:,:,my_ik))
5019 : end if
5020 : end do ! my_ik
5021 :
5022 : end do ! my_ip
5023 : end if
5024 :
5025 : ! Read q-slice of g(k,q) in the atom representation. (individual IO).
5026 9443 : ncerr = nf90_get_var(spin_ncid, spin_vid(gvals_name), gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
5027 1349 : NCF_CHECK(ncerr)
5028 :
5029 1349 : if (read_ks) then
5030 728 : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals_ks"), ks_gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
5031 104 : NCF_CHECK(ncerr)
5032 : ! Here we set g_GWPT g to g_KS if g_KS is smaller than a certain threshold as GWPT breaks symmetries.
5033 153560 : where (abs(ks_gwork_q) < G_SMALL)
5034 : gwork_q = ks_gwork_q
5035 : end where
5036 : end if
5037 :
5038 111960 : do my_ik=1,gqk%my_nk
5039 110595 : ik_glob = my_ik + gqk%my_kstart - 1
5040 110595 : if (from_atm_to_nu) then
5041 : ! Here we convert from g(k,q)_atom to g(k,q)_phonon and replace data in gwork_q at ik_glob
5042 : call ephtk_gkknu_from_atm(nb_kq, nb_k, 1, natom, gwork_q(:,:,:,:, ik_glob), &
5043 110595 : phfreqs_ibz(:, iq_ibz), displ_red_qbz, gmn_nu)
5044 12601221 : gwork_q(:,:,:,:, ik_glob) = gmn_nu
5045 :
5046 110595 : if (gqk%has_both_g) then
5047 : call ephtk_gkknu_from_atm(nb_kq, nb_k, 1, natom, ks_gwork_q(:,:,:,:, ik_glob), &
5048 144 : phfreqs_ibz(:, iq_ibz), displ_red_qbz, gmn_nu)
5049 153456 : ks_gwork_q(:,:,:,:, ik_glob) = gmn_nu
5050 : end if
5051 : end if
5052 :
5053 775514 : do my_ip=1,gqk%my_npert
5054 663570 : ipert = gqk%my_pertcases(my_ip)
5055 13154196 : slice_bb = gwork_q(:,:,:, ipert, ik_glob)
5056 663570 : if (read_ks) then
5057 154176 : ks_slice_bb = ks_gwork_q(:,:,:, ipert, ik_glob)
5058 : end if
5059 :
5060 : ! Put data in the right place and handle conversion g --> |g|^2.
5061 774165 : if (with_cplex == gstore_cplex) then
5062 662706 : if (with_cplex == 1) then
5063 0 : gqk%my_g2(my_ip,:,my_iq,:,my_ik) = slice_bb(1,:,:)
5064 0 : if (read_ks .and. gqk%has_both_g) then
5065 0 : gqk%my_g2_ks(my_ip,:,my_iq,:,my_ik) = ks_slice_bb(1,:,:)
5066 : end if
5067 : end if
5068 662706 : if (with_cplex == 2) then
5069 5439486 : gqk%my_g(my_ip,:,my_iq,:,my_ik) = slice_bb(1,:,:) + j_dpc * slice_bb(2,:,:)
5070 662706 : if (read_ks .and. gqk%has_both_g) then
5071 17280 : gqk%my_g_ks(my_ip,:,my_iq,:,my_ik) = ks_slice_bb(1,:,:) + j_dpc * ks_slice_bb(2,:,:)
5072 : end if
5073 : end if
5074 :
5075 : else
5076 864 : if (with_cplex == 1 .and. gstore_cplex == 2) then
5077 69984 : gqk%my_g2(my_ip, :, my_iq, :, my_ik) = slice_bb(1,:,:) ** 2 + slice_bb(2,:,:) ** 2
5078 864 : if (read_ks .and. gqk%has_both_g) then
5079 37344 : gqk%my_g2_ks(my_ip, :, my_iq, :, my_ik) = ks_slice_bb(1,:,:) ** 2 + ks_slice_bb(2,:,:) ** 2
5080 : end if
5081 0 : else if (with_cplex == 0) then
5082 : continue
5083 : else
5084 0 : ABI_ERROR("Conversion from g2 on file to g_complex in memory is not possible!")
5085 : end if
5086 : end if
5087 : end do ! my_ip
5088 : end do ! my_ik
5089 :
5090 : end do ! my_iq
5091 :
5092 16 : ABI_FREE(gwork_q)
5093 16 : ABI_FREE(slice_bb)
5094 16 : if (read_ks) then
5095 6 : ABI_FREE(ks_gwork_q)
5096 6 : ABI_FREE(ks_slice_bb)
5097 : end if
5098 :
5099 16 : ABI_SFREE(gmn_nu)
5100 16 : ABI_SFREE(my_gq0nm_atm)
5101 16 : ABI_SFREE(ks_my_gq0nm_atm)
5102 :
5103 : ! =========================================
5104 : ! Read matrix elements of velocity operator
5105 : ! =========================================
5106 16 : if (gstore%with_vk == 1) then
5107 16 : if (gqk%comm%nproc > 1) then
5108 0 : NCF_CHECK(nctk_set_collective(spin_ncid, spin_vid("vk_cart_ibz")))
5109 : end if
5110 16 : NCF_CHECK(nf90_get_var(spin_ncid, spin_vid("vk_cart_ibz"), gqk%vnk_cart_ibz))
5111 :
5112 0 : else if (gstore%with_vk == 2) then
5113 0 : if (gqk%comm%nproc > 1) then
5114 0 : NCF_CHECK(nctk_set_collective(spin_ncid, spin_vid("vnk_mat_cart_ibz")))
5115 : end if
5116 0 : NCF_CHECK(nf90_get_var(spin_ncid, spin_vid("vnk_mat_cart_ibz"), gqk%vnk_mat_cart_ibz))
5117 :
5118 : ! Transfer diagonal terms to vnk_cart_ibz.
5119 0 : do ib=1,gqk%nb_k
5120 0 : gqk%vnk_cart_ibz(:, ib, :) = gqk%vnk_mat_cart_ibz(1, :, ib, ib, :)
5121 : end do
5122 : end if
5123 :
5124 16 : NCF_CHECK(nf90_close(ncid))
5125 : end if
5126 : end do ! spin
5127 :
5128 16 : ABI_FREE(qglob2bz)
5129 16 : ABI_FREE(qbz2ibz)
5130 16 : ABI_FREE(phfreqs_ibz)
5131 16 : ABI_FREE(pheigvec_cart_ibz)
5132 16 : ABI_FREE(displ_cart_qbz)
5133 16 : ABI_FREE(displ_red_qbz)
5134 16 : ABI_FREE(pheigvec_cart_qbz)
5135 16 : ABI_SFREE(tpp_red)
5136 :
5137 16 : call pstat_proc%print(_PSTAT_ARGS_)
5138 16 : call xmpi_barrier(gstore%comm)
5139 48 : call cwtime_report(" gstore_from_ncpath", cpu, wall, gflops)
5140 :
5141 : !stop
5142 :
5143 : contains
5144 400 : integer function vid(var_name)
5145 : character(len=*),intent(in) :: var_name
5146 400 : vid = nctk_idname(ncid, var_name)
5147 : end function vid
5148 :
5149 1482 : integer function spin_vid(var_name)
5150 : character(len=*),intent(in) :: var_name
5151 1482 : spin_vid = nctk_idname(spin_ncid, var_name)
5152 : end function spin_vid
5153 :
5154 : end subroutine gstore_from_ncpath
5155 : !!***
5156 :
5157 1248 : subroutine calc_and_store_gdw2(gqk, my_ik, my_iq, my_ip, wqnu, tpp_red, gq0l_atm, gq0r_atm)
5158 :
5159 : type(gqk_t), intent(inout) :: gqk
5160 : integer,intent(in) :: my_ik, my_iq, my_ip
5161 : real(dp),intent(in) :: wqnu
5162 : complex(dp),intent(in) :: tpp_red(gqk%natom3, gqk%natom3)
5163 : complex(dp),intent(in) :: gq0l_atm(gqk%nb_k, gqk%nb_kq, gqk%natom3)
5164 : complex(dp),intent(in) :: gq0r_atm(gqk%nb_k, gqk%nb_kq, gqk%natom3)
5165 :
5166 : !Local variables-------------------------------
5167 : !scalars
5168 : integer :: im_kq, in_k, ip2, ip1
5169 : real(dp) :: gdw2
5170 : complex(dp) :: cfact
5171 : ! *************************************************************************
5172 :
5173 : ! Loop over bands in |m,k+q>
5174 18432 : do im_kq=1,gqk%nb_kq
5175 : ! Loop over the n index in |n,k>.
5176 98496 : do in_k=1,gqk%nb_k
5177 : ! Compute DW term following XG paper. Check prefactor.
5178 : gdw2 = zero
5179 560448 : do ip2=1,gqk%natom3
5180 3442752 : do ip1=1,gqk%natom3
5181 : cfact = ( &
5182 : + real(gq0l_atm(in_k, im_kq, ip1)) * real(gq0r_atm(in_k, im_kq, ip2)) &
5183 : + aimag(gq0l_atm(in_k, im_kq, ip1)) * aimag(gq0r_atm(in_k, im_kq, ip2)) &
5184 : + real(gq0l_atm(in_k, im_kq, ip2)) * real(gq0r_atm(in_k, im_kq, ip1)) &
5185 : + aimag(gq0l_atm(in_k, im_kq, ip2)) * aimag(gq0r_atm(in_k, im_kq, ip1)) &
5186 2882304 : )
5187 3362688 : gdw2 = gdw2 + real(tpp_red(ip1,ip2) * cfact)
5188 : end do
5189 : end do
5190 :
5191 80064 : if (wqnu < EPHTK_WTOL) then
5192 : gdw2 = zero
5193 : else
5194 77580 : gdw2 = gdw2 / (four * two * wqnu)
5195 : end if
5196 :
5197 : !print *, "gdw2", gdw2
5198 97248 : gqk%my_gdw2(my_ip, im_kq, my_iq, in_k, my_ik) = gdw2
5199 : end do ! in_k
5200 : end do ! im_kq
5201 :
5202 1248 : end subroutine calc_and_store_gdw2
5203 :
5204 : !----------------------------------------------------------------------
5205 :
5206 : !!****f* m_gstore/gstore_check_restart
5207 : !! NAME
5208 : !! gstore_check_restart
5209 : !!
5210 : !! FUNCTION
5211 : !! Check whether restart from a previous GSTORE.nc is possible.
5212 : !!
5213 : !! INPUTS
5214 : !!
5215 : !! SOURCE
5216 :
5217 3 : subroutine gstore_check_restart(filepath, dtset, nqbz, done_qbz_spin, restart, comm)
5218 :
5219 : !Arguments ------------------------------------
5220 : character(len=*),intent(in) :: filepath
5221 : type(dataset_type),intent(in) :: dtset
5222 : integer,intent(out) :: nqbz, restart
5223 : integer,allocatable,intent(out) :: done_qbz_spin(:,:)
5224 : integer,intent(in) :: comm
5225 :
5226 : !Local variables-------------------------------
5227 : !scalars
5228 : integer,parameter :: master = 0
5229 : integer :: my_rank, root_ncid, ierr, gstore_completed, gstore_fform, units(2) ! fform
5230 : character(len=500) :: msg
5231 3 : type(hdr_type) :: gstore_hdr
5232 : ! *************************************************************************
5233 :
5234 9 : my_rank = xmpi_comm_rank(comm); units = [std_out, ab_out]
5235 :
5236 : !print *, "eph_restart:", dtset%eph_restart
5237 :
5238 3 : restart = 0; nqbz = 0
5239 3 : if (my_rank == master .and. dtset%eph_restart == 1) then
5240 3 : if (file_exists(filepath)) then
5241 0 : call wrtout(units, sjoin("- Found pre-existent GSTORE file:", trim(filepath)))
5242 0 : call wrtout(units, " Testing if all e-ph terms have been computed...")
5243 : ! Use gstore_completed to understand if the previous GSTORE run completed else we need to restart.
5244 0 : NCF_CHECK(nctk_open_read(root_ncid, filepath, xmpi_comm_self))
5245 0 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_completed"), gstore_completed))
5246 0 : call gstore_hdr%ncread(root_ncid, gstore_fform)
5247 0 : ABI_CHECK_INEQ(gstore_fform, 0, "Wrong gstore_fform")
5248 0 : call gstore_hdr%vs_dtset(dtset); call gstore_hdr%free()
5249 :
5250 0 : NCF_CHECK(nctk_get_dim(root_ncid, "gstore_nqbz", nqbz))
5251 0 : ABI_MALLOC(done_qbz_spin, (nqbz, dtset%nsppol))
5252 0 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_done_qbz_spin"), done_qbz_spin))
5253 0 : NCF_CHECK(nf90_close(root_ncid))
5254 : !print *, "done_qbz_spin:", done_qbz_spin
5255 :
5256 : ! FIXME: done_qbz_spin is dimensioned with the q-points in the BZ but we
5257 : ! should set to 1 the q-points in the BZ else we never restart
5258 : ! Perhaps can can set to -1 if q = TS q_ibz if q_ibz is done.
5259 0 : if (gstore_completed /= 0) then
5260 : ! Previous computation completed, keep a backup of the file and start from scratch.
5261 0 : restart = 0; done_qbz_spin = 0
5262 : msg = sjoin("- WARNING: Found GSTORE.nc file with all entries already computed.", ch10, &
5263 0 : "- Will overwrite:", trim(filepath), ch10, "Keeping backup copy in:", strcat(filepath, ".bkp"))
5264 0 : call wrtout(units, msg)
5265 0 : ABI_CHECK(clib_rename(trim(filepath), strcat(filepath, ".bkp")) == 0, "Failed to rename GSTORE file.")
5266 : else
5267 0 : restart = 1
5268 0 : call wrtout(units, "- Restarting from a previous GSTORE.nc file")
5269 : end if
5270 : else
5271 3 : call wrtout(units, sjoin("- Cannot find pre-existent GSTORE file:", trim(filepath)))
5272 : end if
5273 : end if
5274 :
5275 3 : call xmpi_bcast(restart, master, comm, ierr)
5276 3 : call xmpi_bcast(nqbz, master, comm, ierr)
5277 :
5278 3 : if (my_rank /= master) then
5279 0 : ABI_MALLOC(done_qbz_spin, (nqbz, dtset%nsppol))
5280 : end if
5281 3 : if (nqbz /= 0) call xmpi_bcast(done_qbz_spin, master, comm, ierr)
5282 : !stop
5283 :
5284 : contains
5285 0 : integer function root_vid(var_name)
5286 : character(len=*),intent(in) :: var_name
5287 0 : root_vid = nctk_idname(root_ncid, var_name)
5288 : end function root_vid
5289 :
5290 : end subroutine gstore_check_restart
5291 : !!***
5292 :
5293 : !----------------------------------------------------------------------
5294 :
5295 : !!****f* m_gstore/gstore_print_for_abitests
5296 : !! NAME
5297 : !! gstore_print_for_abitests
5298 : !!
5299 : !! FUNCTION
5300 : !! Print subset of results to ab_out for testing purposes.
5301 : !! This routine should be called when the output of the GSTORE.nc file is completed
5302 : !!
5303 : !! INPUTS
5304 : !! dtset<type(dataset_type)>=all input variables for this dataset
5305 : !! [with_ks]: if True, read "gvals" as well as "gvals_ks". This options is used in GWPT
5306 : !! in which "gvals" are the GWPT matrix elements and ""gvals_ks" are the KS ones.
5307 : !!
5308 : !! SOURCE
5309 :
5310 8 : subroutine gstore_print_for_abitests(gstore, dtset, ebands, do_avg, with_ks)
5311 :
5312 : !Arguments ------------------------------------
5313 : class(gstore_t),intent(inout) :: gstore
5314 : type(dataset_type),intent(in) :: dtset
5315 : type(ebands_t),intent(in) :: ebands
5316 : logical,intent(in) :: do_avg
5317 : logical,optional,intent(in) :: with_ks
5318 :
5319 : !Local variables-------------------------------
5320 : !scalars
5321 : integer,parameter :: master = 0
5322 : integer :: root_ncid, spin_ncid, gstore_completed, spin, ik_glob, iq_glob, ipc, ncerr, natom3
5323 : integer :: glob_nq, glob_nk, im_kq, in_k, m_kq, n_k, nb_k, nb_kq, ii ! ib_k,
5324 : integer :: bstart_k, bstop_k, bstart_kq, bstop_kq, max_nk, max_nq, idir
5325 : integer :: ik_bz, ik_ibz, ib_min_k, ib_max_k, iq_bz, ikq_ibz, ib_min_kq, ib_max_kq, nn
5326 : logical :: with_ks__, changed_k, changed_kq, all_gs, has_iv1p_comm
5327 : real(dp) :: gg, gg_ks, g_ratio, min_g_ratio, max_g_ratio, mean_g_ratio, stdev_g_ratio !, vnk
5328 : character(len=abi_slen) :: gstore_gmode
5329 : character(len=500) :: msg
5330 : !arrays
5331 : integer :: mapl_kq(6)
5332 8 : integer,allocatable :: done_qbz_spin(:,:), qglob2bz(:,:), degblock_k(:,:), degblock_kq(:,:)
5333 : real(dp) :: kk(3), qq(3), kq(3), rtmp(2)
5334 8 : real(dp),allocatable :: gslice_mn(:,:,:), gslice_ks_mn(:,:,:), g2_mn(:,:), g2ks_mn(:,:), iv1p_comm(:,:,:,:,:)
5335 : !real(dp),allocatable :: vnk_cart_ibz(:,:) !, vnk_mat_cart_ibz(:,:,:,:)
5336 : ! *************************************************************************
5337 :
5338 : ! Only master prints to ab_out
5339 8 : if (xmpi_comm_rank(gstore%comm) /= master) return
5340 :
5341 8 : with_ks__ = .False.; if (present(with_ks)) with_ks__ = with_ks
5342 8 : all_gs = .False. ; if (dtset%prtvol >= 10) all_gs = .True.
5343 :
5344 8 : natom3 = dtset%natom * 3
5345 16 : max_nq = maxval(gstore%glob_nq_spin) ! Max dim over spin
5346 : max_nk = maxval(gstore%glob_nk_spin)
5347 :
5348 8 : NCF_CHECK(nctk_open_read(root_ncid, gstore%path, xmpi_comm_self))
5349 :
5350 8 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_completed"), gstore_completed))
5351 8 : write(ab_out, *)""
5352 8 : write(ab_out, "(a,i0)")" gstore_completed: ", gstore_completed
5353 :
5354 32 : ABI_MALLOC(done_qbz_spin, (gstore%nqbz, dtset%nsppol))
5355 8 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_done_qbz_spin"), done_qbz_spin))
5356 2573 : write(ab_out, "(a,*(i0,1x))")" gstore_done_qbz_spin: ", count(done_qbz_spin == 1)
5357 8 : ABI_FREE(done_qbz_spin)
5358 :
5359 997 : ABI_CALLOC(qglob2bz, (max_nq, dtset%nsppol))
5360 8 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_qglob2bz"), qglob2bz))
5361 :
5362 : gstore_gmode = GSTORE_GMODE_ATOM
5363 :
5364 16 : do spin=1,gstore%nsppol
5365 8 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
5366 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "glob_nq", glob_nq))
5367 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "glob_nk", glob_nk))
5368 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_k", nb_k))
5369 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_kq", nb_kq))
5370 :
5371 8 : bstart_k = gstore%brange_k_spin(1, spin)
5372 8 : bstop_k = gstore%brange_k_spin(2, spin)
5373 8 : bstart_kq = gstore%brange_kq_spin(1, spin)
5374 8 : bstop_kq = gstore%brange_kq_spin(2, spin)
5375 :
5376 8 : write(ab_out, "(a,i0)")" nb_k: ", nb_k
5377 8 : write(ab_out, "(a,i0)")" bstart_k: ", bstart_k
5378 8 : write(ab_out, "(a,i0)")" nb_kq: ", nb_kq
5379 8 : write(ab_out, "(a,i0)")" bstart_kq: ", bstart_kq
5380 8 : write(ab_out, "(a,i0)")" glob_nq: ", glob_nq
5381 8 : write(ab_out, "(a,i0)")" glob_nk: ", glob_nk
5382 :
5383 : ! Handle the output of group velocities. On disk, we have:
5384 : !
5385 : ! nctkarr_t("vk_cart_ibz", "dp", "three, nb_k, gstore_nkibz"))
5386 : ! or
5387 : ! nctkarr_t("vnk_mat_cart_ibz", "dp", "two, three, nb_k, nb_k, gstore_nkibz")))
5388 :
5389 8 : select case (gstore%with_vk)
5390 : case (0)
5391 : continue
5392 :
5393 : case (1)
5394 0 : continue
5395 : !write(ab_out,"(2a)") ch10," Group velocities |v_nk| in atomic units:"
5396 :
5397 : !ABI_MALLOC(vnk_cart_ibz, (3, nb_k))
5398 : !do ik_ibz=1,gstore%nkibz
5399 : ! ! Only a subset of k-points are written to ab_out.
5400 : ! if (all(ik_ibz /= [1, 2, gstore%nkibz - 1, gstore%nkibz])) cycle
5401 : ! NCF_CHECK(nf90_get_var(spin_ncid, spin_vid("vk_cart_ibz"), vnk_cart_ibz, start=[1,1,ik_ibz], count=[3,nb_k,1]))
5402 :
5403 : ! write(ab_out, "(a)")sjoin(" For k-point:", ktoa(gstore%kibz(:,ik_ibz)), ", spin", itoa(spin))
5404 : ! do ib_k=1,min(nb_k, 10)
5405 : ! vnk = sqrt(norm2(vnk_cart_ibz(:,ib_k)))
5406 : ! write(ab_out, "(a,i0,1x,es16.6)")" ib_k: ", ib_k, vnk
5407 : ! end do
5408 : !end do
5409 : !ABI_FREE(vnk_cart_ibz)
5410 : !write(ab_out, "(a)")" "
5411 :
5412 : case (2)
5413 8 : ABI_ERROR(" TEXT output of vkmat is not coded yet!")
5414 : end select
5415 :
5416 : ! Handle the output of the e-ph matrix elements. On disk we have the global array:
5417 : !
5418 : ! nctkarr_t("gvals", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq")
5419 :
5420 : ! These e-ph matrix elements are ALWAYS in the atom representation.
5421 32 : ABI_MALLOC(gslice_mn, (2, nb_kq, nb_k))
5422 24 : ABI_MALLOC(gslice_ks_mn, (2, nb_kq, nb_k))
5423 32 : ABI_MALLOC(g2_mn, (nb_kq, nb_k))
5424 24 : ABI_MALLOC(g2ks_mn, (nb_kq, nb_k))
5425 :
5426 8 : write(ab_out,"(a)") " E-PH matrix elements in the atom representation: pcase = (idir, iatom)"
5427 8 : if (do_avg) then
5428 8 : write(ab_out,"(a)") " NB: Values are averaged over e_mk+q, and e_nk degenerate states."
5429 : else
5430 0 : write(ab_out,"(a)") " NB: Values are NOT averaged over e_mk+q, and e_nk degenerate states."
5431 : end if
5432 :
5433 8 : if (with_ks__) then
5434 3 : write(ab_out, "(1x,5(a5,1x),2(a16))") "iq", "ik", "pcase", "m_kq", "n_k", "|g^GW| in Ha", "|g^KS| in Ha"
5435 : else
5436 5 : write(ab_out, "(1x,5(a5,1x),a16)") "iq", "ik", "pcase", "m_kq", "n_k", "|g| in Ha"
5437 : end if
5438 :
5439 319 : do ik_glob=1,glob_nk
5440 : ! Write the first and the last k-point.
5441 311 : if ((ik_glob /= 1 .and. ik_glob /= glob_nk) .and. .not. all_gs) cycle
5442 :
5443 14 : ik_bz = gstore%kglob2bz(ik_glob, spin)
5444 14 : ik_ibz = gstore%kbz2ibz(1, ik_bz)
5445 : !ik_ibz = gstore%bz2ibz(1, ik_bz); isym_k = gstore%bz2ibz(2, ik_bz)
5446 : !trev_k = gstore%bz2ibz(6, ik_bz); g0_k = gstore%bz2ibz(3:5, ik_bz)
5447 : !isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
5448 :
5449 56 : kk = ebands%kptns(:,ik_ibz)
5450 14 : ib_min_k = bstart_k; ib_max_k = bstop_k
5451 :
5452 : call ebands%enclose_degbands(ik_ibz, spin, ib_min_k, ib_max_k, changed_k, dtset%symsigma_de, &
5453 14 : degblock=degblock_k)
5454 14 : if (changed_k) then
5455 : !write(ab_out, "(a)")" Non all the degenerate bands at k were included. This should not happen!"
5456 10 : do ii=1,size(degblock_k, dim=2)
5457 8 : degblock_k(1, ii) = max(degblock_k(1, ii), bstart_k)
5458 10 : degblock_k(2, ii) = min(degblock_k(2, ii), bstop_k)
5459 : end do
5460 : end if
5461 :
5462 1800 : do iq_glob=1,glob_nq
5463 : ! Write the first and the last q-point.
5464 1786 : if ((iq_glob /= 1 .and. iq_glob /= glob_nq) .and. .not. all_gs) cycle
5465 :
5466 : ! Find k+q image in the IBZ.
5467 28 : iq_bz = qglob2bz(iq_glob, spin)
5468 112 : qq = gstore%qbz(:, iq_bz)
5469 112 : kq = kk + qq
5470 28 : if (kpts_map("symrel", ebands%kptopt, gstore%cryst, gstore%krank_ibz, 1, kq, mapl_kq) /= 0) then
5471 0 : write(msg, '(4a)' )"k-mesh is not closed!",ch10, "k+q could not be generated from a symmetrical one.",trim(ltoa(kq))
5472 0 : ABI_ERROR(msg)
5473 : end if
5474 28 : ikq_ibz = mapl_kq(1)
5475 28 : ib_min_kq = bstart_kq; ib_max_kq = bstop_kq
5476 :
5477 : call ebands%enclose_degbands(ikq_ibz, spin, ib_min_kq, ib_max_kq, changed_kq, dtset%symsigma_de, &
5478 28 : degblock=degblock_kq)
5479 :
5480 28 : if (changed_kq) then
5481 : !write(ab_out, "(a)")" Non all the degenerate bands at k+q were included. This should not happen!"
5482 34 : do ii=1,size(degblock_kq, dim=2)
5483 30 : degblock_kq(1, ii) = max(degblock_kq(1, ii), bstart_kq)
5484 34 : degblock_kq(2, ii) = min(degblock_kq(2, ii), bstop_kq)
5485 : end do
5486 : end if
5487 :
5488 196 : do ipc=1,natom3
5489 : ! Write the 4th and the last perturbation.
5490 168 : if ((ipc /= 4 .and. ipc /= natom3) .and. .not. all_gs) cycle
5491 : ! TODO: Write that pcase is filtered
5492 : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals"), gslice_mn, &
5493 728 : start=[1,1,1,ipc,ik_glob,iq_glob], count=[2,nb_kq,nb_k,1,1,1])
5494 56 : NCF_CHECK(ncerr)
5495 56 : call average_g2_mn(do_avg, nb_kq, nb_k, bstart_kq, bstart_k, degblock_kq, degblock_k, gslice_mn, g2_mn)
5496 :
5497 56 : write(ab_out, "(3(a,1x,i0,1x))")" |g(k,q)| in Ha for iq:", iq_glob, "ik:", ik_glob, "pcase:", ipc
5498 :
5499 84 : if (.not. with_ks__) then
5500 : ! gvals only.
5501 36 : write(ab_out, "(1x,5(a5,1x),a16)")"iq", "ik", "pcase", "m_kq", "n_k", "|g|"
5502 196 : do im_kq=1,nb_kq
5503 160 : m_kq = im_kq + bstart_kq - 1
5504 740 : do in_k=1,nb_k
5505 544 : n_k = in_k + bstart_k - 1
5506 544 : gg = sqrt(g2_mn(im_kq, in_k))
5507 704 : write(ab_out, "(a1,5(i5,1x),es16.6)")"-", iq_glob, ik_glob, ipc, m_kq, n_k, gg
5508 : end do
5509 : end do
5510 : else
5511 : ! GW/KS ratio, g^GW, g^KS
5512 : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals_ks"), gslice_ks_mn, &
5513 260 : start=[1,1,1,ipc,ik_glob,iq_glob], count=[2,nb_kq,nb_k,1,1,1])
5514 20 : NCF_CHECK(ncerr)
5515 20 : call average_g2_mn(do_avg, nb_kq, nb_k, bstart_kq, bstart_k, degblock_kq, degblock_k, gslice_ks_mn, g2ks_mn)
5516 :
5517 20 : write(ab_out, "(1x,5(a5,1x),3a16)")"iq", "ik", "pcase", "m_kq", "n_k", "GW/KS", "|g^GW|", "|g^KS|"
5518 20 : min_g_ratio = +huge(one); max_g_ratio = -huge(one); mean_g_ratio = zero; stdev_g_ratio = zero; nn = 0
5519 :
5520 252 : do im_kq=1,nb_kq
5521 232 : m_kq = im_kq + bstart_kq - 1
5522 1564 : do in_k=1,nb_k
5523 1312 : n_k = in_k + bstart_k - 1
5524 1312 : gg = sqrt(g2_mn(im_kq, in_k))
5525 1312 : gg_ks = sqrt(g2ks_mn(im_kq, in_k))
5526 1312 : call safe_div(gg, gg_ks, -one, g_ratio)
5527 1312 : if (g_ratio /= -one) then
5528 944 : nn = nn + 1
5529 944 : min_g_ratio = min(g_ratio, min_g_ratio)
5530 944 : max_g_ratio = max(g_ratio, max_g_ratio)
5531 944 : mean_g_ratio = mean_g_ratio + g_ratio
5532 944 : stdev_g_ratio = stdev_g_ratio + g_ratio ** 2
5533 : end if
5534 1544 : write(ab_out, "(a1,5(i5,1x),3(es16.6))")"-", iq_glob, ik_glob, ipc, m_kq, n_k, g_ratio, gg, gg_ks
5535 : end do
5536 : end do
5537 :
5538 20 : if (nn /= 0) then
5539 14 : mean_g_ratio = mean_g_ratio / nn
5540 14 : write(ab_out, "(a,es16.6)")"- mean_g_ratio:", mean_g_ratio
5541 : ! \sigma^{2} = \langle x^{2} \rangle - \langle x \rangle^{2}
5542 14 : write(ab_out, "(a,es16.6)")"- stdev_g_ratio:", sqrt((stdev_g_ratio / nn) - (mean_g_ratio ** 2))
5543 14 : write(ab_out, "(a,es16.6)")"- min_g_ratio:", min_g_ratio
5544 14 : write(ab_out, "(a,es16.6)")"- max_g_ratio:", max_g_ratio
5545 : end if
5546 : end if
5547 :
5548 : end do ! ipc
5549 :
5550 1800 : ABI_FREE(degblock_kq)
5551 : end do ! iq_glob
5552 319 : ABI_FREE(degblock_k)
5553 : end do ! ik_glob
5554 :
5555 8 : ABI_FREE(gslice_mn)
5556 8 : ABI_FREE(gslice_ks_mn)
5557 8 : ABI_FREE(g2_mn)
5558 16 : ABI_FREE(g2ks_mn)
5559 : end do ! spin
5560 :
5561 8 : ABI_FREE(qglob2bz)
5562 :
5563 : ! Here we read the matrix elements of i[V1, p] if present on disk.
5564 8 : has_iv1p_comm = gstore_nc_has_iv1p_comm(gstore, root_ncid)
5565 :
5566 8 : if (has_iv1p_comm) then
5567 0 : do spin=1,gstore%nsppol
5568 0 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
5569 0 : NCF_CHECK(nctk_get_dim(spin_ncid, "glob_nk", glob_nk))
5570 0 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_k", nb_k))
5571 :
5572 0 : bstart_k = gstore%brange_k_spin(1, spin)
5573 0 : bstop_k = gstore%brange_k_spin(2, spin)
5574 :
5575 0 : ABI_CALLOC(iv1p_comm, (2, nb_k, nb_k, 3, natom3))
5576 :
5577 0 : do ik_glob=1,glob_nk
5578 : ! Write the first and the last k-point.
5579 0 : if ((ik_glob /= 1 .and. ik_glob /= glob_nk) .and. .not. all_gs) cycle
5580 :
5581 : !ik_bz = gstore%kglob2bz(ik_glob, spin)
5582 : !ik_ibz = gstore%kbz2ibz(1, ik_bz)
5583 : !kk_ibz = ebands%kptns(:,ik_ibz)
5584 :
5585 : ! nctkarr_t("iv1p_comm", "dp", "two, nb_k, nb_k, three, natom3, glob_nk")
5586 : ncerr = nf90_get_var(spin_ncid, spin_vid("iv1p_comm"), iv1p_comm, &
5587 0 : start=[1,1,1,1,1,ik_glob], count=[2,nb_k,nb_k,3,natom3,1])
5588 0 : NCF_CHECK(ncerr)
5589 :
5590 : ! Only n_nk states are included in the matrix.
5591 0 : write(ab_out, "(1x,5(a5,1x),a16)")"ik", "pcase", "m_k", "n_k", "idir", "i[V1,p]"
5592 0 : do im_kq=1,nb_k
5593 0 : m_kq = im_kq + bstart_k - 1
5594 0 : do in_k=1,nb_k
5595 0 : n_k = in_k + bstart_k - 1
5596 0 : do ipc=1,natom3
5597 0 : if ((ipc /= 4 .and. ipc /= natom3) .and. .not. all_gs) cycle
5598 0 : do idir=1,3
5599 0 : rtmp = iv1p_comm(:, im_kq, in_k, idir, ipc)
5600 0 : write(ab_out, "(a1,5(i5,1x),2es16.6)") "-", ik_glob, ipc, m_kq, n_k, idir, rtmp(1), rtmp(2)
5601 : end do ! idir
5602 : end do ! ipc
5603 : end do ! in_k
5604 : end do ! im_kq
5605 :
5606 : end do ! ik_glob
5607 :
5608 0 : ABI_FREE(iv1p_comm)
5609 : end do ! spin
5610 : end if
5611 :
5612 16 : NCF_CHECK(nf90_close(root_ncid))
5613 :
5614 : contains
5615 24 : integer function root_vid(var_name)
5616 : character(len=*),intent(in) :: var_name
5617 24 : root_vid = nctk_idname(root_ncid, var_name)
5618 : end function root_vid
5619 :
5620 76 : integer function spin_vid(var_name)
5621 : character(len=*),intent(in) :: var_name
5622 76 : spin_vid = nctk_idname(spin_ncid, var_name)
5623 : end function spin_vid
5624 :
5625 : end subroutine gstore_print_for_abitests
5626 : !!***
5627 :
5628 76 : subroutine average_g2_mn(do_avg, nb_kq, nb_k, bstart_kq, bstart_k, degblock_kq, degblock_k, g_mn, g2_mn)
5629 :
5630 : !Arguments ------------------------------------
5631 : logical,intent(in) :: do_avg
5632 : integer,intent(in) :: nb_kq, nb_k, bstart_kq, bstart_k
5633 : integer,intent(in) :: degblock_kq(:,:), degblock_k(:,:)
5634 : real(dp),intent(in) :: g_mn(2, nb_kq, nb_k)
5635 : real(dp),intent(out) :: g2_mn(nb_kq, nb_k)
5636 :
5637 : !Local variables-------------------------------
5638 : integer :: im_group, in_group, count, m_kq, im_kq, n_k, in_k
5639 : real(dp) :: g2_avg
5640 : !----------------------------------------------------------------------
5641 :
5642 76 : if (do_avg) then
5643 : ! Average over electronic degenerate states at k and k+q
5644 3564 : g2_mn = -one
5645 460 : do im_group = 1, size(degblock_kq, dim=2)
5646 1414 : do in_group = 1, size(degblock_k, dim=2)
5647 954 : g2_avg = zero; count = 0
5648 2542 : do m_kq = degblock_kq(1, im_group), degblock_kq(2, im_group)
5649 1588 : im_kq = m_kq - bstart_kq + 1
5650 5710 : do n_k = degblock_k(1, in_group), degblock_k(2, in_group)
5651 3168 : in_k = n_k - bstart_k + 1
5652 3168 : g2_avg = g2_avg + g_mn(1, im_kq, in_k)**2 + g_mn(2, im_kq, in_k)**2
5653 4756 : count = count + 1
5654 : end do
5655 : end do
5656 954 : g2_avg = g2_avg / count
5657 :
5658 : ! Loop again over degenerate bands and copy average.
5659 2926 : do m_kq = degblock_kq(1, im_group), degblock_kq(2, im_group)
5660 1588 : im_kq = m_kq - bstart_kq + 1
5661 5710 : do n_k = degblock_k(1, in_group), degblock_k(2, in_group)
5662 3168 : in_k = n_k - bstart_k + 1
5663 4756 : g2_mn(im_kq, in_k) = g2_avg
5664 : end do
5665 : end do
5666 :
5667 : end do ! in_group
5668 : end do ! im_group
5669 :
5670 : else
5671 : ! No average here.
5672 0 : do im_kq=1, nb_kq
5673 0 : do in_k=1, nb_k
5674 0 : g2_mn(im_kq, in_k) = g_mn(1, im_kq, in_k)**2 + g_mn(2, im_kq, in_k)**2
5675 : end do
5676 : end do
5677 : end if
5678 :
5679 76 : end subroutine average_g2_mn
5680 : !!***
5681 :
5682 : !----------------------------------------------------------------------
5683 :
5684 : !!****f* m_gstore/gqk_gather
5685 : !! NAME
5686 : !! gqk_gather
5687 : !!
5688 : !! FUNCTION
5689 : !! Gather the MPI-distributed matrix elements for a given k/q-point index.
5690 : !! Once one reciprocal dimension is fixed, the gathering is performed across the other one.
5691 : !!
5692 : !! INPUTS
5693 : !! mode = String controlling the choice of the fixed dimension ("k" or "q")
5694 : !! fixed_pt = Index of the fixed k/q-point
5695 : !!
5696 : !! OUTPUT
5697 : !! g_gathered(:,:,:,:) = Matrix elements for the given k/q-point, ordered as
5698 : !! (my_npert, nb, nb, glob_nq) - k-point is fixed
5699 : !! (my_npert, nb, nb, glob_nk) - q-point is fixed
5700 : !!
5701 : !! SOURCE
5702 :
5703 555656 : subroutine gqk_gather(gqk, mode, fixed_pt, g_gathered)
5704 :
5705 : !Arguments ------------------------------------
5706 : !scalars
5707 : class(gqk_t), target, intent(in) :: gqk
5708 : character(len=*),intent(in) :: mode
5709 : integer,intent(in) :: fixed_pt
5710 : !arrays
5711 : complex(dp), allocatable, intent(out) :: g_gathered(:,:,:,:)
5712 :
5713 : !Local variables-------------------------------
5714 : !scalars
5715 : integer :: comm, ierr, ipt_glob, ngather, my_ipt, my_ngather, my_ptstart, my_pert, ib, jb
5716 : !arrays
5717 277828 : complex(dp), pointer :: my_g(:,:,:,:)
5718 : !----------------------------------------------------------------------
5719 :
5720 0 : ABI_CHECK_IEQ(gqk%nb_kq, gqk%nb_k, "nb_kq != nb_k not tested")
5721 :
5722 0 : select case (mode)
5723 : case ("k")
5724 0 : comm = gqk%qpt_comm%value
5725 0 : ngather = gqk%glob_nq
5726 0 : my_ngather = gqk%my_nq
5727 0 : my_ptstart = gqk%my_qstart
5728 0 : my_g => gqk%my_g(:,:,:,:,fixed_pt)
5729 0 : ABI_CALLOC(g_gathered, (gqk%my_npert, gqk%nb_kq, gqk%nb_k, ngather))
5730 :
5731 : case ("q")
5732 277828 : comm = gqk%kpt_comm%value
5733 277828 : ngather = gqk%glob_nk
5734 277828 : my_ngather = gqk%my_nk
5735 277828 : my_ptstart = gqk%my_kstart
5736 277828 : my_g => gqk%my_g(:,:,fixed_pt,:,:)
5737 2150164396 : ABI_CALLOC(g_gathered, (gqk%my_npert, gqk%nb_k, gqk%nb_kq, ngather))
5738 :
5739 : case default
5740 277828 : ABI_ERROR(sjoin("Gathering MPI-distributed matrix elements, unsupported mode: ", mode))
5741 : end select
5742 :
5743 33678830 : do my_ipt=1,my_ngather
5744 33401002 : ipt_glob = my_ipt + my_ptstart - 1
5745 :
5746 : ! FIXME: can the rearrangement be done in the select case statement?
5747 130800122 : do ib=1,gqk%nb_k
5748 418804456 : do jb=1,gqk%nb_kq
5749 2115096426 : do my_pert=1,gqk%my_npert
5750 2017975134 : if (mode == "k") then
5751 0 : g_gathered(my_pert, jb, ib, ipt_glob) = my_g(my_pert, jb, my_ipt, ib)
5752 : else
5753 1729692972 : g_gathered(my_pert, jb, ib, ipt_glob) = my_g(my_pert, jb, ib, my_ipt)
5754 : endif
5755 : enddo
5756 : enddo
5757 : enddo
5758 : enddo
5759 :
5760 277828 : call xmpi_sum(g_gathered, comm, ierr)
5761 :
5762 277828 : end subroutine gqk_gather
5763 : !!***
5764 :
5765 : !----------------------------------------------------------------------
5766 :
5767 : !!****f* m_gstore/gstore_wannierize_and_write_gwan
5768 : !! NAME
5769 : !! gstore_wannierize_and_write_gwan
5770 : !!
5771 : !! FUNCTION
5772 : !! Compute g(R_e,R_ph) from g(k,q). Save results to GWAN.nc file
5773 : !!
5774 : !! INPUTS
5775 : !!
5776 : !! SOURCE
5777 :
5778 0 : subroutine gstore_wannierize_and_write_gwan(gstore, dvdb, dtfil)
5779 :
5780 : !Arguments ------------------------------------
5781 : class(gstore_t),target, intent(in) :: gstore
5782 : type(dvdb_t),intent(in) :: dvdb
5783 : type(datafiles_type),intent(in) :: dtfil
5784 :
5785 : !Local variables-------------------------------
5786 : !scalars
5787 : integer,parameter :: master = 0
5788 : integer,parameter :: wan_ntest = 4
5789 : integer,parameter :: wan_nperiod = 3
5790 : real(dp),parameter :: WAN_CLOSURE_TOL = tol8
5791 : real(dp),parameter :: WAN_VELOCITY_FD_STEP = 1.0d-5
5792 : real(dp),parameter :: WAN_VELOCITY_DEGEN_TOL = 1.0d-5
5793 : real(dp),parameter :: WAN_VELOCITY_TOL = tol6
5794 : integer :: nr_e, nr_p, nwan, iwan, jwan, spin, my_is, my_ip, ir, irp, my_ik, my_iq, nb_k, nb_kq
5795 : integer :: my_nk, my_nq, ierr, ik, ikq, my_npert, nwin_k, nwin_kq, ii, jj, band_kq, band_k, ib_k, ib_kq
5796 : integer :: itest, ip_loc, ik_glob, iq_glob, ntest_found, iperiod, idir, ib, nvelocity_tested
5797 : real(dp) :: max_err, ref_scale, max_period_eig_err, period_eig_scale, max_period_g2_err, period_g2_scale
5798 : real(dp) :: max_velocity_err, velocity_scale, band_gap, velocity_fd
5799 : character(len=500) :: msg
5800 : logical :: keep_umats, test_found(wan_ntest)
5801 : type(wan_t),pointer :: wan
5802 : type(gqk_t),pointer :: gqk
5803 : !arrays
5804 : integer :: qptrlatt_(3,3), units(2)
5805 : integer :: test_ik(wan_ntest), test_iq(wan_ntest)
5806 : integer :: period_gk(3,wan_nperiod), period_gq(3,wan_nperiod)
5807 : real(dp) :: weight_qq, qpt(3), kpt(3), kq(3), dkred(3), cpu, wall, gflops
5808 0 : real(dp),allocatable :: eigens_k_test(:), eigens_kq_test(:), eigens_k_period(:), eigens_kq_period(:)
5809 0 : real(dp),allocatable :: eigens_k_plus(:), eigens_k_minus(:), vcart_test(:,:)
5810 0 : complex(dp),allocatable :: emikr(:), emiqr(:), u_k(:,:), u_kq(:,:), gww_epq(:,:,:,:,:), gww_pk(:,:,:,:), g_bb(:,:), tmp_mat(:,:)
5811 0 : complex(dp),allocatable :: test_gref(:,:,:,:), u_k_test(:,:), u_kq_test(:,:), cmat_test(:,:), g_expected(:,:)
5812 0 : complex(dp),allocatable :: g_atm_test(:,:,:,:), g_atm_period(:,:,:,:)
5813 : ! *************************************************************************
5814 :
5815 0 : units = [std_out, ab_out]
5816 0 : period_gk = reshape([1,0,0, 0,0,0, -1,1,0], shape(period_gk))
5817 0 : period_gq = reshape([0,0,0, 0,1,0, 0,0,1], shape(period_gq))
5818 0 : call wrtout(units, " Computing g(R_e,R_ph) in the Wannier representation...", pre_newlines=1)
5819 0 : call cwtime(cpu, wall, gflops, "start")
5820 :
5821 0 : if (gstore%check_cplex_qkzone_gmode(2, "bz", "bz", "atom", kfilter="none") /= 0) then
5822 0 : ABI_ERROR("The gstore object is inconsistent with gstore_wannierize_and_write_gwan. See messages above.")
5823 : end if
5824 :
5825 : ! TODO: Handle long-range part.
5826 0 : if (dvdb%has_zeff .or. dvdb%has_quadrupoles) then
5827 0 : ABI_WARNING("Treatment of long-range part not yet coded in gstore_wannierize_and_write_gwan!")
5828 : end if
5829 :
5830 0 : do my_is=1,gstore%my_nspins
5831 0 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is); my_nq = gqk%my_nq; my_nk = gqk%my_nk; my_npert = gqk%my_npert
5832 0 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
5833 :
5834 : ! Initialize gkq%wan from ABIWAN.nc for this spin.
5835 0 : keep_umats = .False.
5836 0 : call gqk%wan%from_abiwan(dtfil%filabiwanin, spin, gstore%nsppol, keep_umats, dtfil%filnam_ds(4), gqk%comm%value)
5837 0 : wan => gqk%wan
5838 :
5839 : ! Compute Wigner-Seitz lattice vectors and llocate grpe_wwp with shape: (nr_p, nr_e, nwan, nwan, my_npert).
5840 0 : call kptrlatt_from_ngkpt(gstore%ngqpt, qptrlatt_)
5841 : call wan%setup_eph_ws_kq(gstore%cryst, gstore%ebands%shiftk(:,1), gstore%ebands%kptrlatt, qptrlatt_, &
5842 0 : gqk%my_pert_start, my_npert, gqk%pert_comm)
5843 :
5844 0 : nr_p = wan%nr_p; nr_e = wan%nr_e; nwan = wan%nwan
5845 : !if (gqk%comm%me == master) call wan%print(units)
5846 :
5847 : ! Cache the pre-FT ground truth at four fixed GLOBAL coarse-mesh points. Using
5848 : ! local first/last indices would make the test points depend on the MPI grid.
5849 0 : test_ik = [1, gqk%glob_nk, 1, gqk%glob_nk]
5850 0 : test_iq = [1, 1, gqk%glob_nq, gqk%glob_nq]
5851 0 : test_found = .False.
5852 0 : ABI_CALLOC(test_gref, (nwan, nwan, my_npert, wan_ntest))
5853 :
5854 0 : ABI_MALLOC(emikr, (nr_e))
5855 0 : ABI_MALLOC(emiqr, (nr_p))
5856 0 : ABI_MALLOC(gww_pk, (nwan, nwan, my_npert, my_nk))
5857 : ! Intermediate buffer to store the sum over k-points. Note my_nq.
5858 0 : ABI_CALLOC(gww_epq, (nwan, nwan, nr_e, my_npert, my_nq))
5859 :
5860 : ! Loop over my q-points (partial sum over q).
5861 0 : do my_iq=1,my_nq
5862 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qpt)
5863 :
5864 : !call get_kg(qpt, 1, ecut_lr, gstore%cryst%gmet, ng_q, gvec_q)
5865 : !ABI_FREE(gvec_q)
5866 :
5867 : ! Loop over my k-points (partial sum over k).
5868 0 : do my_ik=1,my_nk
5869 0 : kpt = gqk%my_kpts(:,my_ik); kq = kpt + qpt
5870 0 : ik = wan%krank%get_index(kpt); ikq = wan%krank%get_index(kq)
5871 0 : ABI_CHECK(ik /= -1, sjoin("Cannot find kpt: ", ktoa(kpt)))
5872 0 : ABI_CHECK(ikq /= -1, sjoin("Cannot find k+q: ", ktoa(kq)))
5873 :
5874 : ! Get rotation matrices at k and k+q.
5875 0 : nwin_k = wan%dimwin(ik); nwin_kq = wan%dimwin(ikq)
5876 0 : ABI_MALLOC(g_bb, (nwin_kq, nwin_k))
5877 0 : ABI_MALLOC(u_k, (1:nwin_k, 1:nwan))
5878 0 : ABI_MALLOC(u_kq, (1:nwin_kq, 1:nwan))
5879 0 : ABI_MALLOC(tmp_mat, (nwin_kq, nwan))
5880 :
5881 0 : u_k = wan%u_k(1:nwin_k, 1:nwan, ik)
5882 0 : u_kq = wan%u_k(1:nwin_kq, 1:nwan, ikq)
5883 :
5884 0 : do my_ip=1,gqk%my_npert
5885 : !----------------------------------------------------------
5886 : ! STEP 1: rotation to optimally smooth Bloch states
5887 : !----------------------------------------------------------
5888 : ! [Eqn. 24 of PRB 76, 165108 (2007)]
5889 : ! g~(k,q) = U(k+q)^\dagger * g(k,q) * U(k)
5890 :
5891 : ! gqk%nb = wan%bmax - wan%bmin + 1
5892 : ! (my_npert, nb, my_nq, nb, my_nk)
5893 : ! ( p, b1_kq, q, b2_k, k) --> <k+q, b1| D_{q,p}H |k, b2>
5894 :
5895 : ! Extract e-ph matrix elements from my_g buffer to align bands with the U matrices at k and k+q.
5896 : jj = 0
5897 0 : do ib_k=1,nb_k
5898 0 : band_k = ib_k - wan%bmin + 1; if (.not. wan%lwindow(band_k, ik)) cycle
5899 0 : jj = jj + 1; ii = 0
5900 0 : do ib_kq=1,nb_kq
5901 0 : band_kq = ib_kq - wan%bmin + 1; if (.not. wan%lwindow(band_kq, ikq)) cycle
5902 0 : ii = ii + 1
5903 0 : g_bb(ii, jj) = gqk%my_g(my_ip, ib_kq, my_iq, ib_k, my_ik)
5904 : end do
5905 : end do
5906 :
5907 : ! TODO: Remove LR part.
5908 : !call handle_lr_term(cryst, qpt, ng_q, gvec_q, nwin_kq, nwin_k, nwan, u_kq, u_k, dvdb%zeff, dvdb%qstar, -1, g_bb)
5909 :
5910 : ! the two zgemm calls perform: epmats = [ cu(ikq)^\dagger * epmatk ] * cu(ikk)
5911 : ! [here we have a size-reduction from nbnd*nbnd to nwan*nwan]
5912 : ! output stored in gww_pk(:,:, my_ip, my_ik)
5913 :
5914 : ! gww_pk(:,:, my_ip, my_ik) = MATMUL(CONJG(TRANSPOSE(u_kq)), MATMUL(g_bb, u_k))
5915 : ! tmp_mat (nwin_kq x nwan) = g_bb (nwin_kq x nwin_k) . u_k (nwin_k x nwan)
5916 0 : call ZGEMM('N', 'N', nwin_kq, nwan, nwin_k, cone, g_bb, nwin_kq, u_k, nwin_k, czero, tmp_mat, nwin_kq)
5917 : ! gww_pk (nwan x nwan) = u_kq^dagger (nwan x nwin_kq) . tmp_mat (nwin_kq x nwan)
5918 0 : call ZGEMM('C', 'N', nwan, nwan, nwin_kq, cone, u_kq, nwin_kq, tmp_mat, nwin_kq, czero, gww_pk(:,:, my_ip, my_ik), nwan)
5919 :
5920 : !call ZGEMM('C', 'N', nwan, nbnd, nbnd, cone, u_kq, nbnd, epmatk(:, :, ik, imode), nbnd, czero, eptmp, nwan)
5921 : !call ZGEMM('N', 'N', nwan, nwan, nbnd, cone, eptmp, nwan, u_k, nbnd, czero, epmats(:, :, ik, imode), nwan)
5922 : end do ! my_ip
5923 :
5924 : ! Cache gww_pk(:,:,:,my_ik) for the on-mesh closure self-check below, while it is still
5925 : ! valid for THIS my_iq (it gets overwritten by the next my_iq iteration).
5926 0 : ik_glob = my_ik + gqk%my_kstart - 1
5927 0 : iq_glob = my_iq + gqk%my_qstart - 1
5928 0 : do itest=1,wan_ntest
5929 0 : if (test_ik(itest) == ik_glob .and. test_iq(itest) == iq_glob) then
5930 0 : test_gref(:,:,:,itest) = gww_pk(:,:,:,my_ik)
5931 0 : test_found(itest) = .True.
5932 : end if
5933 : end do
5934 :
5935 0 : ABI_FREE(g_bb)
5936 0 : ABI_FREE(tmp_mat)
5937 :
5938 : !----------------------------------------------------------------------
5939 : ! STEP 3: Fourier transform to obtain matrix elements in electron wannier basis
5940 : !----------------------------------------------------------------------
5941 : ! [Eqn. 24 of PRB 76, 165108 (2007)]
5942 : ! g(R_e,q) = (1/nkc) sum_k e^{-ikR_e} g~(k,q)
5943 : ! g(R_e,q) is epmatw (nwan,nwan,ir)
5944 :
5945 0 : do ir=1,nr_e
5946 0 : emikr(ir) = exp(-j_dpc * two_pi * dot_product(kpt, wan%r_e(:, ir))) / dble(gstore%nkbz)
5947 : end do
5948 : ! gww_pk(nwan, nwan, my_npert,my_nk)
5949 0 : do my_ip=1,gqk%my_npert
5950 0 : do ir=1,nr_e
5951 0 : gww_epq(:,:,ir, my_ip, my_iq) = gww_epq(:,:,ir, my_ip, my_iq) + emikr(ir) * gww_pk(:,:,my_ip, my_ik)
5952 : end do
5953 : end do
5954 :
5955 0 : ABI_FREE(u_k)
5956 0 : ABI_FREE(u_kq)
5957 : end do ! my_ik
5958 : end do ! my_iq
5959 :
5960 0 : call xmpi_sum(gww_epq, gqk%kpt_comm%value, ierr)
5961 :
5962 : !------------------------------------------
5963 : ! Fourier transform to go to Wannier basis
5964 : !------------------------------------------
5965 : ! [Eqn. 24 of PRB 76, 165108 (2007)]
5966 : ! g(R_e,R_p) = (1/nq) sum_q e^{-iqR_p} g(R_e,q)
5967 :
5968 : ! Loop over my q-points (partial sum over q).
5969 0 : do my_iq=1,my_nq
5970 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qpt)
5971 0 : do irp=1,nr_p
5972 0 : emiqr(irp) = exp(-j_dpc * two_pi * dot_product(qpt, wan%r_p(:, irp))) / dble(gstore%nqbz)
5973 : end do
5974 :
5975 0 : do my_ip=1,my_npert
5976 0 : do jwan=1,nwan
5977 0 : do iwan=1,nwan
5978 0 : do ir=1,nr_e
5979 : ! Fixed R_e (index ir), all R_p (colon): g(R_e,R_p) = g(R_e,R_p) + g(R_e,q) * e^{-iq.R_p}
5980 : wan%grpe_wwp(:, ir, iwan, jwan, my_ip) = wan%grpe_wwp(:, ir, iwan, jwan, my_ip) + &
5981 0 : gww_epq(iwan, jwan, ir, my_ip, my_iq) * emiqr(:)
5982 : end do
5983 : end do
5984 : end do
5985 : end do ! my_ip
5986 : end do ! my_iq
5987 :
5988 0 : call xmpi_sum(wan%grpe_wwp, gqk%qpt_kpt_comm%value, ierr)
5989 :
5990 0 : if (gqk%comm%me == master) then
5991 0 : write(std_out, '(a)') '# R_e [Bohr] max_{m,n,nu} |g(m,n,nu R_e,:)| min_{m,n,nu} |g(m,n,nu R_e,:)|[Ha/Bohr] '
5992 0 : do ir=1,nr_e
5993 0 : write(std_out, *) wan%rmod_e(ir), maxval(abs(wan%grpe_wwp(:,ir,:,:,:))), sum(abs(wan%grpe_wwp(:,ir,:,:,:))) / size(wan%grpe_wwp(:,ir,:,:,:))
5994 : end do
5995 : end if
5996 :
5997 : !--------------------------------------------------------------------------------
5998 : ! Wannier on-mesh closure self-check: interpolating g(k,q) back at a handful of
5999 : ! the SAME coarse (k,q) points used to build wan%grpe_wwp must reproduce the pre-FT
6000 : ! gww_pk cached above, once rotated by the SAME wan%interp_ham-derived u_k/u_kq
6001 : ! (interp_ham's gauge is generically different from the ABIWAN gauge used for gww_pk,
6002 : ! even on-mesh, so we apply the identical rotation to both sides rather than comparing
6003 : ! against raw gww_pk). This isolates the WS/ndegen bookkeeping and forward/backward FT
6004 : ! consistency. Cheap (wan_ntest points only) and deterministic: a hard ABI_CHECK, not a
6005 : ! Refs-compared print, since it is a precision-only mathematical identity.
6006 : !--------------------------------------------------------------------------------
6007 0 : ABI_MALLOC(u_k_test, (nwan,nwan))
6008 0 : ABI_MALLOC(u_kq_test, (nwan,nwan))
6009 0 : ABI_MALLOC(eigens_k_test, (nwan))
6010 0 : ABI_MALLOC(eigens_kq_test, (nwan))
6011 0 : ABI_MALLOC(eigens_k_period, (nwan))
6012 0 : ABI_MALLOC(eigens_kq_period, (nwan))
6013 0 : ABI_MALLOC(eigens_k_plus, (nwan))
6014 0 : ABI_MALLOC(eigens_k_minus, (nwan))
6015 0 : ABI_MALLOC(vcart_test, (3,nwan))
6016 0 : ABI_MALLOC(cmat_test, (nwan,nwan))
6017 0 : ABI_MALLOC(g_expected, (nwan,nwan))
6018 0 : ABI_MALLOC(g_atm_test, (nwan, nwan, my_npert, 1))
6019 0 : ABI_MALLOC(g_atm_period, (nwan, nwan, my_npert, 1))
6020 :
6021 0 : max_err = zero; ref_scale = zero
6022 0 : max_period_eig_err = zero; period_eig_scale = zero
6023 0 : max_period_g2_err = zero; period_g2_scale = zero
6024 0 : max_velocity_err = zero; velocity_scale = zero; nvelocity_tested = 0
6025 0 : do itest=1,wan_ntest
6026 0 : if (.not. test_found(itest)) cycle
6027 0 : my_ik = test_ik(itest) - gqk%my_kstart + 1
6028 0 : my_iq = test_iq(itest) - gqk%my_qstart + 1
6029 0 : kpt = gqk%my_kpts(:,my_ik)
6030 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qpt)
6031 0 : call wan%interp_ham(gstore%cryst, kpt, u_k_test, eigens_k_test, vcart_test)
6032 0 : call wan%interp_ham(gstore%cryst, kpt + qpt, u_kq_test, eigens_kq_test)
6033 0 : call wan%interp_eph_manyq(gstore%cryst, 1, qpt, kpt, g_atm_test)
6034 0 : ref_scale = max(ref_scale, maxval(abs(test_gref(:,:,:,itest))))
6035 0 : do ip_loc=1,my_npert
6036 : ! Same order/dagger convention as wan_interp_eph_manyq (m_mlwfovlp.F90).
6037 0 : call ZGEMM('N', 'N', nwan, nwan, nwan, cone, u_kq_test, nwan, test_gref(:,:,ip_loc,itest), nwan, czero, cmat_test, nwan)
6038 0 : call ZGEMM('N', 'C', nwan, nwan, nwan, cone, cmat_test, nwan, u_k_test, nwan, czero, g_expected, nwan)
6039 0 : max_err = max(max_err, maxval(abs(g_expected - g_atm_test(:,:,ip_loc,1))))
6040 : end do
6041 :
6042 : ! Validate analytic Cartesian group velocities against centered finite
6043 : ! differences of the interpolated eigenvalues. Skip degenerate bands,
6044 : ! whose individual diagonal velocities depend on the chosen subspace basis.
6045 : ! These calls intentionally follow the closure comparison because the
6046 : ! finite-difference diagonalizations reuse the u_kq_test work buffer.
6047 0 : do idir=1,3
6048 0 : dkred = WAN_VELOCITY_FD_STEP * gstore%cryst%rprimd(idir,:) / two_pi
6049 0 : call wan%interp_ham(gstore%cryst, kpt + dkred, u_kq_test, eigens_k_plus)
6050 0 : call wan%interp_ham(gstore%cryst, kpt - dkred, u_kq_test, eigens_k_minus)
6051 0 : do ib=1,nwan
6052 0 : band_gap = huge(one)
6053 0 : if (ib > 1) band_gap = min(band_gap, abs(eigens_k_test(ib) - eigens_k_test(ib-1)))
6054 0 : if (ib < nwan) band_gap = min(band_gap, abs(eigens_k_test(ib+1) - eigens_k_test(ib)))
6055 0 : if (band_gap < WAN_VELOCITY_DEGEN_TOL) cycle
6056 0 : velocity_fd = (eigens_k_plus(ib) - eigens_k_minus(ib)) / (two * WAN_VELOCITY_FD_STEP)
6057 0 : max_velocity_err = max(max_velocity_err, abs(vcart_test(idir,ib) - velocity_fd))
6058 0 : velocity_scale = max(velocity_scale, abs(vcart_test(idir,ib)), abs(velocity_fd))
6059 0 : nvelocity_tested = nvelocity_tested + 1
6060 : end do
6061 : end do
6062 :
6063 : ! Reciprocal-periodicity self-check. Integer shifts leave the real-space
6064 : ! Fourier sums invariant. Compare eigenvalues and per-perturbation
6065 : ! Frobenius norms, which remain well defined even if a tiny roundoff
6066 : ! difference rotates eigenvectors inside a degenerate subspace.
6067 0 : period_eig_scale = max(period_eig_scale, maxval(abs(eigens_k_test)), maxval(abs(eigens_kq_test)))
6068 0 : do ip_loc=1,my_npert
6069 0 : period_g2_scale = max(period_g2_scale, sum(abs(g_atm_test(:,:,ip_loc,1))**2))
6070 : end do
6071 0 : do iperiod=1,wan_nperiod
6072 0 : call wan%interp_ham(gstore%cryst, kpt + period_gk(:,iperiod), u_k_test, eigens_k_period)
6073 : call wan%interp_ham(gstore%cryst, kpt + qpt + period_gk(:,iperiod) + period_gq(:,iperiod), &
6074 0 : u_kq_test, eigens_kq_period)
6075 : call wan%interp_eph_manyq(gstore%cryst, 1, qpt + period_gq(:,iperiod), &
6076 0 : kpt + period_gk(:,iperiod), g_atm_period)
6077 : max_period_eig_err = max(max_period_eig_err, maxval(abs(eigens_k_period - eigens_k_test)), &
6078 0 : maxval(abs(eigens_kq_period - eigens_kq_test)))
6079 0 : do ip_loc=1,my_npert
6080 : max_period_g2_err = max(max_period_g2_err, abs( &
6081 0 : sum(abs(g_atm_period(:,:,ip_loc,1))**2) - sum(abs(g_atm_test(:,:,ip_loc,1))**2)))
6082 : end do
6083 : end do
6084 : end do
6085 :
6086 : ! Each fixed (k,q) pair must be owned exactly once within each perturbation
6087 : ! slice. Reduce diagnostics over the complete spin communicator so every rank
6088 : ! applies the same check and the printed result is MPI-decomposition invariant.
6089 0 : ntest_found = count(test_found)
6090 0 : call xmpi_sum(ntest_found, gqk%qpt_kpt_comm%value, ierr)
6091 0 : ABI_CHECK_IEQ(ntest_found, wan_ntest, "Wannier closure test did not find each fixed global (k,q) point exactly once")
6092 0 : call xmpi_max(max_err, gqk%comm%value, ierr)
6093 0 : call xmpi_max(ref_scale, gqk%comm%value, ierr)
6094 0 : call xmpi_max(max_period_eig_err, gqk%comm%value, ierr)
6095 0 : call xmpi_max(period_eig_scale, gqk%comm%value, ierr)
6096 0 : call xmpi_max(max_period_g2_err, gqk%comm%value, ierr)
6097 0 : call xmpi_max(period_g2_scale, gqk%comm%value, ierr)
6098 0 : call xmpi_max(max_velocity_err, gqk%comm%value, ierr)
6099 0 : call xmpi_max(velocity_scale, gqk%comm%value, ierr)
6100 0 : call xmpi_sum(nvelocity_tested, gqk%qpt_kpt_comm%value, ierr)
6101 0 : ref_scale = max(ref_scale, tol12)
6102 0 : period_eig_scale = max(period_eig_scale, tol12)
6103 0 : period_g2_scale = max(period_g2_scale, tol12)
6104 0 : velocity_scale = max(velocity_scale, one)
6105 :
6106 0 : if (gqk%comm%me == master) then
6107 0 : write(std_out,'(a,es10.2,a,es10.2)') " Wannier on-mesh closure self-check: max_err=", max_err, " ref_scale=", ref_scale
6108 0 : write(std_out,'(a,es10.2,a,es10.2)') " Wannier reciprocal-periodicity self-check: max_eig_err=", &
6109 0 : max_period_eig_err, " max_g2_err=", max_period_g2_err
6110 0 : write(std_out,'(a,i0,a,es10.2)') " Wannier group-velocity self-check: nvalues=", &
6111 0 : nvelocity_tested, " max_err=", max_velocity_err
6112 : end if
6113 :
6114 0 : ABI_CHECK(max_err < WAN_CLOSURE_TOL * ref_scale, "Wannier on-mesh closure self-check failed")
6115 0 : msg = "Wannier reciprocal-periodicity self-check failed for interpolated electronic eigenvalues."
6116 0 : ABI_CHECK(max_period_eig_err < WAN_CLOSURE_TOL * period_eig_scale, msg)
6117 0 : msg = "Wannier reciprocal-periodicity self-check failed for gauge-invariant e-ph Frobenius norms."
6118 0 : ABI_CHECK(max_period_g2_err < WAN_CLOSURE_TOL * period_g2_scale, msg)
6119 0 : ABI_CHECK(nvelocity_tested > 0, "Wannier group-velocity self-check did not find a nondegenerate band")
6120 0 : msg = "Analytic Wannier group velocities do not agree with finite differences of the interpolated eigenvalues."
6121 0 : ABI_CHECK(max_velocity_err < WAN_VELOCITY_TOL * velocity_scale, msg)
6122 :
6123 0 : ABI_FREE(u_k_test)
6124 0 : ABI_FREE(u_kq_test)
6125 0 : ABI_FREE(eigens_k_test)
6126 0 : ABI_FREE(eigens_kq_test)
6127 0 : ABI_FREE(eigens_k_period)
6128 0 : ABI_FREE(eigens_kq_period)
6129 0 : ABI_FREE(eigens_k_plus)
6130 0 : ABI_FREE(eigens_k_minus)
6131 0 : ABI_FREE(vcart_test)
6132 0 : ABI_FREE(cmat_test)
6133 0 : ABI_FREE(g_expected)
6134 0 : ABI_FREE(g_atm_test)
6135 0 : ABI_FREE(g_atm_period)
6136 0 : ABI_FREE(test_gref)
6137 :
6138 : ! Free memory for this spin.
6139 0 : ABI_FREE(emikr)
6140 0 : ABI_FREE(emiqr)
6141 0 : ABI_FREE(gww_pk)
6142 0 : ABI_FREE(gww_epq)
6143 : end do ! my_is
6144 :
6145 : ! =====================
6146 : ! Write data to GWAN.nc
6147 : ! =====================
6148 0 : do spin=1,gstore%nsppol
6149 0 : my_is = gstore%spin2my_is(spin)
6150 0 : if (my_is /= 0) then
6151 0 : gqk => gstore%gqk(my_is)
6152 : ! grpe_wwp has already been reduced over qpt_kpt_comm and is replicated
6153 : ! across the q/k (and auxiliary sum/band) grid. Exactly one such slice
6154 : ! must enter the writer; all ranks along its perturbation axis participate
6155 : ! collectively because grpe_wwp remains distributed over perturbations.
6156 0 : if (all(gqk%coords_qkpb_sumbp([1,2,4,5,6]) == 0)) then
6157 0 : call gqk%wan%ncwrite_gwan(dtfil, gstore%cryst, gstore%ebands, gqk%pert_comm)
6158 : end if
6159 : end if
6160 0 : call xmpi_barrier(gstore%comm)
6161 : end do ! spin
6162 :
6163 0 : call cwtime_report(" gstore_wannierize_and_write_gwan:", cpu, wall, gflops)
6164 :
6165 0 : end subroutine gstore_wannierize_and_write_gwan
6166 : !!***
6167 :
6168 : !!****f* m_gstore/handle_lr_term
6169 : !! NAME
6170 : !! handle_lr_term
6171 : !!
6172 : !! FUNCTION
6173 : !! Add/Remove the long range term to/from the e-ph matrix elements.
6174 : !!
6175 : !! INPUTS
6176 : !!
6177 : !! SOURCE
6178 :
6179 : !subroutine handle_lr_term(cryst, qpt, ng, gvec, nwin_kq, nwin_k, nwan, u_kq, u_k, zeff, qstar, isgn, g_bb)
6180 : !
6181 : !!Arguments ------------------------------------
6182 : ! type(crystal_t),intent(in) :: cryst
6183 : ! real(dp),intent(in) :: qpt(3)
6184 : ! integer,intent(in) :: ng, nwin_kq, nwin_k, nwan, isgn, gvec(3,ng)
6185 : ! complex(dp),intent(in) :: u_kq(nwin_kq, nwan), u_k(nwin_k,nwan)
6186 : ! real(dp),intent(in) :: zeff(3,3,cryst%natom), qstar(3,3,3,cryst%natom)
6187 : ! complex(dp),intent(inout) :: g_bb(nwin_kq, nwin_k)
6188 : !
6189 : !!Local variables-------------------------------
6190 : !!scalars
6191 : ! !integer :: ig
6192 : ! !character(len=500) :: msg
6193 : !!arrays
6194 : !! *************************************************************************
6195 : !
6196 : !end subroutine handle_lr_term
6197 : !!***
6198 :
6199 : !----------------------------------------------------------------------
6200 :
6201 : !!****f* m_gstore/gqk_get_erange_mask
6202 : !! NAME
6203 : !! gqk_get_erange_mask
6204 : !!
6205 : !! FUNCTION
6206 : !! Compute MPI-distributed and global masks for electronic states |n,k> allowed by erange.
6207 : !!
6208 : !! INPUTS
6209 : !! gstore<gstore_t>=Electron-phonon object containing dimensions and related quantities.
6210 : !! erange=Energy range:
6211 : !! -- if both entries are negative, assume metal and include states within the
6212 : !! [efermi-abs(erange(1)), efermi+abs(erange(2))] window;
6213 : !! -- otherwise, erange(1) & erange(2) select window wrt VBM & CBM, respectively.
6214 : !!
6215 : !! OUTPUT
6216 : !! my_states(gqk%nb_k, gqk%my_nk)=Mask for selected states at this MPI proc.
6217 : !! glob_states(gqk%nb_k, gqk%my_nk)=Global mask for selected states.
6218 : !!
6219 : !! SOURCE
6220 :
6221 0 : subroutine gqk_get_erange_mask(gqk, gstore, erange, my_states, glob_states)
6222 :
6223 : !Arguments ------------------------------------
6224 : !scalars
6225 : class(gqk_t), target, intent(inout) :: gqk
6226 : class(gstore_t), target, intent(in) :: gstore
6227 : !arrays
6228 : real(dp), intent(in) :: erange(2)
6229 : integer, intent(out) :: my_states(gqk%nb_k, gqk%my_nk), glob_states(gqk%nb_k, gqk%glob_nk)
6230 :
6231 : !Local variables-------------------------------
6232 : !scalars
6233 : class(ebands_t), pointer :: ebands
6234 : type(gaps_t) :: gaps
6235 : integer :: my_ik, ik_ibz, ik_glob, ib_k, bstart_k, gap_err, ierr
6236 : real(dp) :: vmax, cmin, eig
6237 : logical :: assume_gap
6238 : !----------------------------------------------------------------------
6239 :
6240 0 : ebands => gstore%ebands
6241 :
6242 0 : assume_gap = .not. all(erange < tol12)
6243 0 : gaps = ebands%get_gaps(gap_err)
6244 :
6245 0 : if (assume_gap) then
6246 0 : call gaps%print([std_out])
6247 0 : vmax = gaps%vb_max(gqk%spin) + tol2 * eV_Ha
6248 0 : cmin = gaps%cb_min(gqk%spin) - tol2 * eV_Ha
6249 : else
6250 0 : vmax = ebands%fermie
6251 0 : cmin = ebands%fermie
6252 : end if
6253 :
6254 : ! Fill the mask for allowed states
6255 0 : my_states(:,:) = 0
6256 0 : glob_states(:,:) = 0
6257 0 : bstart_k = gstore%brange_k_spin(1, gqk%spin)
6258 :
6259 0 : do my_ik=1,gqk%my_nk
6260 0 : ik_ibz = gqk%my_k2ibz(1, my_ik)
6261 0 : ik_glob = my_ik + gqk%my_kstart - 1
6262 :
6263 0 : do ib_k=1,gqk%nb_k
6264 0 : eig = ebands%eig(bstart_k + ib_k - 1, ik_ibz, gqk%spin)
6265 :
6266 0 : if (abs(erange(1)) > tol12) then
6267 : ! Filter valence states.
6268 0 : if (eig <= vmax .and. vmax - eig <= abs(erange(1))) then
6269 0 : my_states(ib_k, my_ik) = 1; glob_states(ib_k, ik_glob) = 1
6270 : end if
6271 : end if
6272 :
6273 0 : if (abs(erange(2)) > tol12) then
6274 : ! Filter conduction states.
6275 0 : if (eig >= cmin .and. eig - cmin <= abs(erange(2))) then
6276 0 : my_states(ib_k, my_ik) = 1; glob_states(ib_k, ik_glob) = 1
6277 : end if
6278 : end if
6279 :
6280 : enddo
6281 : enddo
6282 :
6283 0 : call xmpi_sum(glob_states, gqk%kpt_comm%value, ierr)
6284 0 : call gaps%free()
6285 :
6286 0 : end subroutine gqk_get_erange_mask
6287 : !!***
6288 :
6289 : !----------------------------------------------------------------------
6290 :
6291 : !!****f* m_gstore/gqk_filter_erange
6292 : !! NAME
6293 : !! gqk_filter_erange
6294 : !!
6295 : !! FUNCTION
6296 : !! Nullify all matrix elements connecting electronic states excluded by energy range.
6297 : !!
6298 : !! INPUTS
6299 : !! gstore<gstore_t>=Electron-phonon object containing dimensions and related quantities.
6300 : !! erange=Energy range:
6301 : !! -- if both entries are negative, assume metal and include states within the
6302 : !! [efermi-abs(erange(1)), efermi+abs(erange(2))] window;
6303 : !! -- otherwise, erange(1) & erange(2) select window wrt VBM & CBM, respectively.
6304 : !!
6305 : !! OUTPUT
6306 : !!
6307 : !! SOURCE
6308 :
6309 0 : subroutine gqk_filter_erange(gqk, gstore, erange)
6310 :
6311 : !Arguments ------------------------------------
6312 : !scalars
6313 : class(gqk_t), target, intent(inout) :: gqk
6314 : class(gstore_t), target, intent(in) :: gstore
6315 : !arrays
6316 : real(dp), intent(in) :: erange(2)
6317 :
6318 : !Local variables-------------------------------
6319 : !scalars
6320 : integer :: my_ik, ik_glob, my_iq, ikq, ipert, ierr, ib_k, jb_kq
6321 : real(dp) :: wtq
6322 : logical :: skip_nk, skip_mkq, skip_q
6323 0 : type(krank_t) :: krank_kpts
6324 : type(ebands_t), pointer :: ebands
6325 : !arrays
6326 0 : integer :: my_states(gqk%nb_k, gqk%my_nk), glob_states(gqk%nb_k, gqk%glob_nk)
6327 0 : real(dp) :: kpt(3), qpt(3), kpq(3), kpts(3, gqk%glob_nk), my_qpts(3, gqk%my_nq)
6328 : !----------------------------------------------------------------------
6329 :
6330 0 : ABI_CHECK_IEQ(gqk%nb_kq, gqk%nb_k, "nb_kq /= nk_k not tested")
6331 :
6332 0 : ebands => gstore%ebands
6333 :
6334 : ! Compute masks
6335 0 : call gqk%get_erange_mask(gstore, erange, my_states, glob_states)
6336 :
6337 : ! Get global krank for k+q transitions
6338 0 : kpts(:, :) = zero
6339 0 : do my_ik=1,gqk%my_nk
6340 0 : ik_glob = my_ik + gqk%my_kstart - 1
6341 0 : kpts(:, ik_glob) = gqk%my_kpts(:, my_ik)
6342 : enddo
6343 0 : call xmpi_sum(kpts, gqk%kpt_comm%value, ierr)
6344 :
6345 0 : call krank_kpts%from_kptrlatt(gqk%glob_nk, kpts, ebands%kptrlatt, compute_invrank=.True.)
6346 :
6347 : ! Get all q-points for this proc
6348 0 : do my_iq=1,gqk%my_nq
6349 0 : call gqk%myqpt(my_iq, gstore, wtq, my_qpts(:, my_iq))
6350 : enddo
6351 :
6352 : ! Nullify matrix elements connecting the excluded states
6353 0 : do my_ik=1,gqk%my_nk
6354 0 : kpt(:) = gqk%my_kpts(:, my_ik)
6355 :
6356 0 : do ib_k=1,gqk%nb_k
6357 : ! |nk> is forbidden
6358 0 : skip_nk = .false.
6359 0 : if (my_states(ib_k, my_ik) == 0) skip_nk = .true.
6360 :
6361 0 : do my_iq=1,gqk%my_nq
6362 0 : qpt(:) = my_qpts(:, my_iq)
6363 :
6364 : ! Find k+q --> k' index in krank_kpts
6365 0 : kpq(:) = kpt(:) + qpt(:)
6366 0 : ikq = krank_kpts%get_index(kpq)
6367 :
6368 : ! k+q falls outside the filtered kpts pool
6369 0 : skip_q = .false.
6370 0 : if (ikq == -1) skip_q = .true.
6371 :
6372 0 : do jb_kq=1,gqk%nb_kq
6373 : ! |mk+q> is forbidden
6374 0 : skip_mkq = .false.
6375 0 : if (glob_states(jb_kq, ikq) == 0) skip_mkq = .true.
6376 :
6377 0 : do ipert=1,gqk%my_npert
6378 :
6379 0 : if (skip_nk .or. skip_q .or. skip_mkq) then
6380 0 : select case (gqk%cplex)
6381 : case (1)
6382 0 : gqk%my_g2(ipert, jb_kq, my_iq, ib_k, my_ik) = zero
6383 : case (2)
6384 0 : gqk%my_g(ipert, jb_kq, my_iq, ib_k, my_ik) = czero
6385 : case default
6386 0 : ABI_ERROR(sjoin("Invalid gqk%cplex:", itoa(gqk%cplex)))
6387 : end select
6388 : end if
6389 :
6390 : enddo
6391 : enddo
6392 : enddo
6393 : enddo
6394 : enddo
6395 :
6396 0 : call krank_kpts%free()
6397 :
6398 0 : end subroutine gqk_filter_erange
6399 : !!***
6400 :
6401 : !----------------------------------------------------------------------
6402 :
6403 : !!****f* m_gstore/gstore_compute_and_write_ph
6404 : !! NAME
6405 : !! gstore_compute_and_write_ph
6406 : !!
6407 : !! FUNCTION
6408 : !! Compute phonon frequencies and eigenvectors in the IBZ. Write results to disk
6409 : !!
6410 : !! SOURCE
6411 :
6412 8 : subroutine gstore_compute_and_write_ph(gstore, root_ncid)
6413 :
6414 : !Arguments ------------------------------------
6415 : !scalars
6416 : class(gstore_t), intent(in) :: gstore
6417 : integer,intent(in) :: root_ncid
6418 :
6419 : !Local variables-------------------------------
6420 : !scalars
6421 : integer :: natom, natom3, nproc, ii, iq_ibz, my_nqibz, iq_start, ncerr
6422 : real(dp) :: cpu, wall, gflops
6423 : !arrays
6424 8 : integer,allocatable :: my_iqibz_inds(:)
6425 8 : real(dp),allocatable :: buf_wqnu(:,:), buf_eigvec_cart(:,:,:,:,:), displ_cart_qibz(:,:,:,:)
6426 : !----------------------------------------------------------------------
6427 :
6428 8 : nproc = xmpi_comm_size(gstore%comm)
6429 8 : natom = gstore%cryst%natom; natom3 = 3 * natom
6430 :
6431 8 : call wrtout(std_out, " Computing phonon frequencies and displacements in the IBZ ...", pre_newlines=1, do_flush=.True.)
6432 8 : call cwtime(cpu, wall, gflops, "start")
6433 :
6434 8 : call xmpi_split_block(gstore%nqibz, gstore%comm, my_nqibz, my_iqibz_inds)
6435 32 : ABI_MALLOC(buf_wqnu, (natom3, my_nqibz))
6436 40 : ABI_MALLOC(buf_eigvec_cart, (2, 3, natom, natom3, my_nqibz))
6437 32 : ABI_MALLOC(displ_cart_qibz, (2, 3, natom, natom3))
6438 :
6439 8 : NCF_CHECK(nctk_prepare_mpiio(root_ncid, "phfreqs_ibz"))
6440 8 : NCF_CHECK(nctk_prepare_mpiio(root_ncid, "pheigvec_cart_ibz"))
6441 :
6442 141 : do ii=1,my_nqibz
6443 133 : iq_ibz = my_iqibz_inds(ii)
6444 : call gstore%ifc%fourq(gstore%cryst, gstore%qibz(:, iq_ibz), buf_wqnu(:,ii), displ_cart_qibz, &
6445 141 : out_eigvec=buf_eigvec_cart(:,:,:,:,ii))
6446 : end do
6447 :
6448 8 : if (nproc > 1 .and. gstore%nqibz >= nproc) then
6449 0 : NCF_CHECK(nctk_set_collective(root_ncid, root_vid("phfreqs_ibz")))
6450 0 : NCF_CHECK(nctk_set_collective(root_ncid, root_vid("pheigvec_cart_ibz")))
6451 : end if
6452 8 : call xmpi_barrier(gstore%comm)
6453 :
6454 8 : if (my_nqibz > 0) then
6455 8 : iq_start = my_iqibz_inds(1)
6456 : ncerr = nf90_put_var(root_ncid, root_vid("phfreqs_ibz"), buf_wqnu, &
6457 40 : start=[1, iq_start], count=[natom3, my_nqibz])
6458 8 : NCF_CHECK(ncerr)
6459 : ncerr = nf90_put_var(root_ncid, root_vid("pheigvec_cart_ibz"), buf_eigvec_cart, &
6460 88 : start=[1,1,1,1,iq_start], count=[2, 3, natom, natom3, my_nqibz])
6461 8 : NCF_CHECK(ncerr)
6462 : end if
6463 :
6464 8 : ABI_FREE(displ_cart_qibz)
6465 8 : ABI_FREE(my_iqibz_inds)
6466 8 : ABI_FREE(buf_wqnu)
6467 8 : ABI_FREE(buf_eigvec_cart)
6468 16 : call cwtime_report(" Phonon computation + output", cpu, wall, gflops)
6469 :
6470 : contains
6471 :
6472 16 : integer function root_vid(var_name)
6473 : character(len=*),intent(in) :: var_name
6474 16 : root_vid = nctk_idname(root_ncid, var_name)
6475 : end function root_vid
6476 :
6477 : end subroutine gstore_compute_and_write_ph
6478 : !!***
6479 :
6480 : !!****f* m_gstore/gstore_compute_and_write_vk
6481 : !! NAME
6482 : !! gstore_compute_and_write_vk
6483 : !!
6484 : !! FUNCTION
6485 : !! Compute electronic group velocities in the IBZ.
6486 : !! Write results to disk
6487 : !!
6488 : !! SOURCE
6489 :
6490 8 : subroutine gstore_compute_and_write_vk(gstore, mpw, wfd, ebands, psps, pawtab, root_ncid)
6491 :
6492 : !Arguments ------------------------------------
6493 : class(gstore_t), intent(in) :: gstore
6494 : integer,intent(in) :: mpw
6495 : type(wfd_t),intent(in) :: wfd
6496 : type(ebands_t),target,intent(in) :: ebands
6497 : type(pseudopotential_type),intent(in) :: psps
6498 : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
6499 : integer,intent(in) :: root_ncid
6500 :
6501 : !Local variables-------------------------------
6502 : !scalars
6503 : integer :: my_is, spin, nb_k, nb_kq, spin_ncid, band, in_k, my_ik, usecprj, ierr, ii, ik_ibz, isym_k, trev_k, npw_k, istwf_k
6504 : real(dp) :: cpu_kk, wall_kk, gflops_kk, eig0nk
6505 : logical :: isirr_k
6506 80 : type(ddkop_t) :: ddkop
6507 : !arrays
6508 : integer :: g0_k(3)
6509 8 : integer,allocatable :: count_bk(:,:)
6510 : real(dp) :: kk(3) !, kk_ibz(3)
6511 16 : real(dp),allocatable :: vnk_cart_ibz(:,:,:), cg_work(:,:)
6512 8 : type(pawcprj_type),allocatable :: cwaveprj0(:,:)
6513 : !----------------------------------------------------------------------
6514 :
6515 8 : call wrtout(std_out, " computing and writing velocity operator matrix elements in the ibz")
6516 8 : call wrtout(std_out, " note that not all the k-points in the ibz are computed when kfilter is activated!")
6517 8 : call cwtime(cpu_kk, wall_kk, gflops_kk, "start")
6518 :
6519 : ! On disk, we have:
6520 : ! nctkarr_t("vk_cart_ibz", "dp", "three, nb_k, gstore_nkibz"))
6521 : ! nctkarr_t("vkmat_cart_ibz", "dp", "two, three, nb, nb, gstore_nkibz")))
6522 :
6523 8 : call ddkop%init(gstore%dtset, gstore%cryst, pawtab, psps, wfd%mpi_enreg, mpw, wfd%ngfft)
6524 24 : ABI_MALLOC(cg_work, (2, mpw*wfd%nspinor))
6525 :
6526 8 : usecprj = gstore%dtset%usepaw
6527 32 : ABI_MALLOC(cwaveprj0, (gstore%cryst%natom, wfd%nspinor*usecprj))
6528 :
6529 16 : do my_is=1,gstore%my_nspins
6530 8 : associate (gqk => gstore%gqk(my_is))
6531 8 : spin = gstore%my_spins(my_is); nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
6532 :
6533 : ! Be careful as wavefunctions might be replicated.
6534 : ! Use count_bk to count how many states have been computed in parallel in order to rescale the results.
6535 8 : if (gstore%with_vk == 1) then
6536 1285 : ABI_CALLOC(vnk_cart_ibz, (3, nb_k, gstore%nkibz))
6537 445 : ABI_ICALLOC(count_bk, (nb_k, gstore%nkibz))
6538 : else
6539 0 : ABI_ERROR("gstore%with_vk 2 not implemented")
6540 : end if
6541 :
6542 8 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6543 8 : NCF_CHECK(nctk_prepare_mpiio(spin_ncid, "vk_cart_ibz"))
6544 :
6545 319 : do my_ik=1,gqk%my_nk
6546 : ! The k-point and the symmetries relating the BZ k-point to the IBZ.
6547 1244 : kk = gqk%my_kpts(:, my_ik)
6548 311 : ik_ibz = gqk%my_k2ibz(1, my_ik) ; isym_k = gqk%my_k2ibz(2, my_ik)
6549 1244 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5,my_ik)
6550 1149 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
6551 : if (.not. isirr_k) cycle
6552 :
6553 : ! parallelize inside (q, pert) so that only one proc in the 3D grid
6554 : ! computes v_nk for this kpt in the BZ and we can use xmpi_sum_master.
6555 : !cnt = cnt + 1
6556 : !if (gqk%qpt_pert_comm%skip(cnt)) cycle
6557 :
6558 36 : npw_k = wfd%npwarr(ik_ibz); istwf_k = wfd%istwfk(ik_ibz)
6559 36 : call ddkop%setup_spin_kpoint(gstore%dtset, gstore%cryst, psps, spin, kk, istwf_k, npw_k, wfd%kdata(ik_ibz)%kg_k)
6560 :
6561 150 : do band=gqk%bstart_k, gqk%bstop_k
6562 106 : call wfd%copy_cg(band, ik_ibz, spin, cg_work)
6563 106 : eig0nk = ebands%eig(band, ik_ibz, spin)
6564 106 : in_k = band - gqk%bstart_k + 1
6565 106 : vnk_cart_ibz(:, in_k, ik_ibz) = ddkop%get_vdiag(eig0nk, istwf_k, npw_k, wfd%nspinor, cg_work, cwaveprj0)
6566 142 : count_bk(in_k, ik_ibz) = count_bk(in_k, ik_ibz) + 1
6567 : end do
6568 : end do ! my_ik
6569 :
6570 8 : call xmpi_sum(count_bk, gqk%comm%value, ierr)
6571 8 : call xmpi_sum(vnk_cart_ibz, gqk%comm%value, ierr)
6572 :
6573 141 : do ik_ibz=1, gstore%nkibz
6574 421 : do band=gqk%bstart_k, gqk%bstop_k
6575 280 : in_k = band - gqk%bstart_k + 1
6576 280 : if (count_bk(in_k, ik_ibz) == 0) cycle
6577 557 : do ii=1,3
6578 598 : vnk_cart_ibz(ii,in_k,ik_ibz) = vnk_cart_ibz(ii,in_k,ik_ibz) / count_bk(in_k, ik_ibz)
6579 : end do
6580 : end do
6581 : end do
6582 :
6583 : ! Write v_nk to disk.
6584 : !if (gqk%comm%me == master) then
6585 8 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("vk_cart_ibz"), vnk_cart_ibz))
6586 : !end if
6587 :
6588 8 : ABI_FREE(vnk_cart_ibz)
6589 16 : ABI_FREE(count_bk)
6590 : end associate
6591 : end do ! my_is
6592 :
6593 8 : ABI_FREE(cg_work)
6594 8 : call ddkop%free()
6595 :
6596 8 : call pawcprj_free(cwaveprj0)
6597 8 : ABI_FREE(cwaveprj0)
6598 :
6599 96 : call cwtime_report(sjoin(" Computation of v_k group velocities with with_vk:", itoa(gstore%with_vk)), cpu_kk, wall_kk, gflops_kk)
6600 :
6601 : contains
6602 :
6603 8 : integer function spin_vid(var_name)
6604 : character(len=*),intent(in) :: var_name
6605 8 : spin_vid = nctk_idname(spin_ncid, var_name)
6606 : end function spin_vid
6607 :
6608 : end subroutine gstore_compute_and_write_vk
6609 : !!***
6610 :
6611 : !!****f* m_gstore/gstore_compute_and_write_commutator
6612 : !! NAME
6613 : !! gstore_compute_and_write_commutator
6614 : !!
6615 : !! FUNCTION
6616 : !! Compute matrix elements i <psi_mk|[V1_q0ka, p]|psi_nk> in the full BZ in reduced coordinates.
6617 : !! Write results to disk.
6618 : !! See [[cite:Lihm2020]], PhysRevB.101.121102
6619 : !!
6620 : !! SOURCE
6621 :
6622 0 : subroutine gstore_compute_and_write_commutator(gstore, mpw, gmax, ngfft, ngfftf, dtset, cryst, pawfgr, psps, &
6623 0 : wfd, mpi_enreg, kg_k, ebands, dvdb, gs_ham_kq, root_ncid)
6624 :
6625 : !Arguments ------------------------------------
6626 : class(gstore_t), intent(in) :: gstore
6627 : integer,intent(in) :: gmax(3), mpw
6628 : integer,intent(in) :: ngfft(18),ngfftf(18)
6629 : type(dvdb_t),intent(inout) :: dvdb
6630 : type(gs_hamiltonian_type),intent(inout) :: gs_ham_kq
6631 : type(dataset_type),intent(in) :: dtset
6632 : type(crystal_t),intent(in) :: cryst
6633 : type(wfd_t),intent(in) :: wfd
6634 : type(mpi_type),intent(in) :: mpi_enreg
6635 : type(ebands_t),intent(in) :: ebands
6636 : type(pawfgr_type),intent(in) :: pawfgr
6637 : type(pseudopotential_type),intent(in) :: psps
6638 : integer,intent(in) :: root_ncid
6639 : !arrays
6640 : integer,intent(inout) :: kg_k(3,mpw)
6641 :
6642 : !Local variables-------------------------------
6643 : !scalars
6644 : integer,parameter :: tim_getgh1c = 1, berryopt0 = 0, master = 0
6645 : integer :: my_is, spin, nb_k, nb_kq, spin_ncid, in_k, my_ik, ii, ik_ibz, npw_k, npwsp_k, istwf_k ! ik_bz,
6646 : integer :: cplex, db_iqpt, idir, ipert, ipc, my_ip, natom, natom3, n1, n2, n3, n4, n5, n6, nsppol, nspinor, nspden
6647 : integer :: nfft, nfftf, mgfftf, my_npert, nkpg_k, band_k !, glob_nk mgfft,
6648 : integer :: sij_opt,usecprj,usevnl,optlocal,optnl,opt_gvnlx1, ncerr, ik_glob, ierr
6649 : real(dp) :: cpu_kk, wall_kk, gflops_kk
6650 : logical :: gen_eigenpb
6651 0 : type(rf_hamiltonian_type) :: rf_ham_kq
6652 : !arrays
6653 : integer :: units(2), work_ngfft(18) ! g0_k(3)
6654 : !integer,allocatable :: count_bk(:,:)
6655 : real(dp) :: kk_ibz(3), kk_bz(3), gamma_point(3)
6656 0 : real(dp),allocatable :: v1scf(:,:,:,:), work(:,:,:,:), p_kets_k(:,:,:,:), gs1c_kq(:,:), dmat(:,:,:,:)
6657 0 : real(dp),allocatable :: kets_k(:,:,:), h1_kets_kq(:,:,:), iv1p_comm(:,:,:,:,:)
6658 0 : real(dp),allocatable :: ffnl_k(:,:,:,:), ph3d_k(:,:,:), grad_berry(:,:), kinpw_k(:), kpg_k(:,:)
6659 0 : real(dp),allocatable :: vlocal(:,:,:,:), vlocal1(:,:,:,:,:), dummy_vtrial(:,:), gvnlx1(:,:,:), lambda(:)
6660 0 : type(pawcprj_type),allocatable :: cwaveprj0(:,:)
6661 : !----------------------------------------------------------------------
6662 :
6663 0 : units = [std_out, ab_out]
6664 0 : call wrtout(units, " Computing and writing i <psi_mk| [V1, p]| psi_nk> ...")
6665 0 : call cwtime(cpu_kk, wall_kk, gflops_kk, "start")
6666 :
6667 : ! Copy important dimensions
6668 0 : natom = cryst%natom; natom3 = 3 * natom; nsppol = ebands%nsppol; nspinor = ebands%nspinor; nspden = dtset%nspden
6669 :
6670 0 : n1 = ngfftf(1); n2 = ngfftf(2); n3 = ngfftf(3); n4 = ngfftf(4); n5 = ngfftf(5); n6 = ngfftf(6)
6671 0 : nfftf = product(ngfftf(1:3)); mgfftf = maxval(ngfftf(1:3))
6672 :
6673 0 : call ngfft_seq(work_ngfft, gmax)
6674 0 : ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
6675 :
6676 : ! Read the dvscf potentials at qq=Gamma for all 3*natom perturbations.
6677 : ! This call allocates v1scf(cplex, nfftf, nspden, 3*natom)
6678 0 : gamma_point(:) = zero; db_iqpt = dvdb%findq(gamma_point)
6679 0 : call dvdb%readsym_allv1(db_iqpt, cplex, nfftf, ngfftf, v1scf, gstore%comm)
6680 0 : ABI_CHECK_IEQ(cplex, 1, "cplex should be zero when q == 0")
6681 :
6682 : ! Allocate vlocal. Note nvloc
6683 : ! I set vlocal to huge to trigger possible bugs (DFPT routines should not access the data)
6684 0 : usecprj = gstore%dtset%usepaw
6685 0 : ABI_MALLOC(vlocal, (n4, n5, n6, gs_ham_kq%nvloc))
6686 0 : vlocal = huge(one)
6687 0 : ABI_CALLOC(dummy_vtrial, (nfftf, nspden))
6688 0 : ABI_MALLOC(cwaveprj0, (gstore%cryst%natom, wfd%nspinor*usecprj))
6689 :
6690 : ! Prepare call to getgh1c
6691 0 : usevnl = 0
6692 0 : optlocal = 1 ! local part of H^(1) is computed in gh1c=<G|H^(1)|C>
6693 0 : optnl = 2 ! non-local part of H^(1) is totally computed in gh1c=<G|H^(1)|C>
6694 0 : opt_gvnlx1 = 0 ! gvnlx1 is output
6695 :
6696 0 : ABI_MALLOC(grad_berry, (2, nspinor*(berryopt0/4)))
6697 :
6698 : ! Since v1(q=0) and p are Hermitian operators, we have:
6699 : !
6700 : ! i <psi_mk| [v1, p] |psi_nk> = i <v1 psi_mk | p psi_nk> -i <p psi_mk | v1 psi_nk>
6701 : !
6702 : ! Note that in the present implementation both m and n indices run from bstart_k to bstop_k.
6703 :
6704 : ! if PAW, one has to solve a generalized eigenproblem
6705 0 : gen_eigenpb = psps%usepaw == 1; sij_opt = 0; if (gen_eigenpb) sij_opt = 1
6706 :
6707 : ! Define netcdf arrays inside the spin group.
6708 0 : do spin=1, nsppol
6709 0 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6710 : ncerr = nctk_def_arrays(spin_ncid, [ &
6711 : nctkarr_t("iv1p_comm", "dp", "two, nb_k, nb_k, three, natom3, glob_nk") &
6712 0 : ], defmode=.True.)
6713 0 : NCF_CHECK(ncerr)
6714 :
6715 0 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("iv1p_comm"), NF90_FILL, -huge(one)))
6716 0 : NCF_CHECK(nctk_set_datamode(spin_ncid))
6717 : end do
6718 : !NCF_CHECK(nctk_set_datamode(root_ncid))
6719 :
6720 0 : do my_is=1,gstore%my_nspins
6721 0 : associate (gqk => gstore%gqk(my_is))
6722 0 : spin = gstore%my_spins(my_is); nb_k = gqk%nb_k; nb_kq = gqk%nb_kq; my_npert = gqk%my_npert
6723 :
6724 : ! Be careful as wavefunctions might be replicated.
6725 : ! Use count_bk to count how many states have been computed in parallel in order to rescale the results.
6726 : !ABI_ICALLOC(count_bk, (nb_k, gstore%nkibz))
6727 0 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6728 0 : NCF_CHECK(nctk_prepare_mpiio(spin_ncid, "iv1p_comm"))
6729 :
6730 : ! Allocate vlocal1 with correct cplex. Note nvloc and my_npert.
6731 0 : ABI_MALLOC(vlocal1, (cplex*n4, n5, n6, gs_ham_kq%nvloc, my_npert))
6732 0 : ABI_MALLOC(lambda, (nb_k))
6733 :
6734 0 : ABI_CALLOC(iv1p_comm, (2, nb_k, nb_k, 3, natom3))
6735 0 : ABI_MALLOC(dmat, (2, nb_k, nb_k, 3))
6736 :
6737 : ! Set up local potential vlocal1 with proper dimensioning from vtrial1 taking into account the spin.
6738 : ! Note that here v1scf contains all 3 natom perturbations as we called dvdb%readsym_allv1.
6739 0 : do my_ip=1,my_npert
6740 0 : idir = dvdb%my_pinfo(1, my_ip); ipert = dvdb%my_pinfo(2, my_ip); ipc = dvdb%my_pinfo(3, my_ip)
6741 : call rf_transgrid_and_pack(spin, nspden, psps%usepaw, cplex, nfftf, nfft, ngfft, gs_ham_kq%nvloc,&
6742 0 : pawfgr, mpi_enreg, dummy_vtrial, v1scf(:,:,:,ipc), vlocal, vlocal1(:,:,:,:,my_ip))
6743 : end do
6744 :
6745 : ! Continue to initialize the GS Hamiltonian
6746 0 : call gs_ham_kq%load_spin(spin, vlocal=vlocal, with_nonlocal=.true.)
6747 :
6748 0 : do my_ik=1,gqk%my_nk
6749 : ! Parallelism inside q-point communicator.
6750 0 : if (gqk%qpt_comm%skip(my_ik)) cycle
6751 :
6752 : ! The k-point and the symmetries relating the BZ k-point to the IBZ.
6753 0 : kk_bz = gqk%my_kpts(:, my_ik)
6754 0 : ik_ibz = gqk%my_k2ibz(1, my_ik)
6755 0 : kk_ibz = ebands%kptns(:,ik_ibz)
6756 0 : ik_glob = my_ik + gqk%my_kstart - 1
6757 :
6758 : ! Get npw_k, kg_k and symmetrize wavefunctions from the IBZ (if needed).
6759 : call wfd%sym_ug_kg_npw(dtset%ecut, kk_bz, kk_ibz, gqk%bstart_k, nb_k, spin, gqk%my_k2ibz(:, my_ik), cryst, &
6760 0 : work_ngfft, work, istwf_k, npw_k, kg_k, kets_k)
6761 :
6762 : call gs_ham_kq%eph_setup_k("k", kk_bz, istwf_k, npw_k, kg_k, dtset, cryst, psps, & ! in
6763 0 : nkpg_k, kpg_k, ffnl_k, kinpw_k, ph3d_k, gqk%pert_comm%value) ! out
6764 :
6765 0 : npwsp_k = npw_k * nspinor
6766 0 : ABI_MALLOC(h1_kets_kq, (2, npwsp_k, nb_k))
6767 0 : ABI_MALLOC(gs1c_kq, (2, npwsp_k*nb_k*((sij_opt+1)/2)))
6768 0 : ABI_MALLOC(gvnlx1, (2, npwsp_k,nb_k))
6769 :
6770 : ! Compute <g|-i\Nabla |psi_nk>.
6771 0 : ABI_MALLOC(p_kets_k, (2, npwsp_k, nb_k, 3))
6772 0 : call cg_p_psi(npw_k, nspinor, nb_k, kk_bz, kg_k, kets_k, p_kets_k)
6773 :
6774 0 : iv1p_comm = zero
6775 0 : do my_ip=1,my_npert
6776 0 : idir = dvdb%my_pinfo(1, my_ip); ipert = dvdb%my_pinfo(2, my_ip); ipc = dvdb%my_pinfo(3, my_ip)
6777 :
6778 : ! Prepare application of the NL part.
6779 0 : call rf_ham_kq%init(cplex, gs_ham_kq, ipert, has_e1kbsc=.true.)
6780 0 : call rf_ham_kq%load_spin(spin, vlocal1=vlocal1(:,:,:,:,my_ip), with_nonlocal=.true.)
6781 :
6782 0 : do in_k=1,nb_k
6783 : ! Use scissor shift on 0-order eigenvalue
6784 0 : band_k = in_k + gqk%bstart_k - 1
6785 0 : lambda(in_k) = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
6786 : end do
6787 : !call ebands%get_dfpt_eshifted(gqk%bstart_k, nb_k, ik_ibz, spin, dtset%dfpt_sciss, lambda)
6788 :
6789 : ! Calculate dvscf * psi_k, results stored in h1_kets_kq on the k+q sphere.
6790 : ! Compute H(1) applied to GS wavefunction Psi(0).
6791 : call getgh1c(berryopt0, kets_k, cwaveprj0, h1_kets_kq, &
6792 : grad_berry, gs1c_kq, gs_ham_kq, gvnlx1, idir, ipert, lambda, mpi_enreg, nb_k, optlocal, &
6793 0 : optnl, opt_gvnlx1, rf_ham_kq, sij_opt, tim_getgh1c, usevnl)
6794 :
6795 0 : call rf_ham_kq%free()
6796 :
6797 : ! Here we compute: i <u_mk| [v1, p] u_nk> = i <v1 u_mk | p u_nk> -i <p u_mk | v1 u_nk>
6798 : ! p_kets_k(:, npwsp_k, nb_k, 3)
6799 : ! h1_kets_kq, (2, npw_k*nspinor, nb_k))
6800 0 : dmat = zero
6801 0 : do ii=1,3
6802 : call ZGEMM('C', 'N', nb_k, nb_k, npwsp_k, j_dpc, h1_kets_kq, npwsp_k, &
6803 0 : p_kets_k(:,:,:,ii), npwsp_k, cone, dmat(:,:,:,ii), nb_k)
6804 :
6805 : call ZGEMM('C', 'N', nb_k, nb_k, npwsp_k, -j_dpc, p_kets_k(:,:,:,ii), npwsp_k, &
6806 0 : h1_kets_kq, npwsp_k, cone, dmat(:,:,:,ii), nb_k)
6807 : end do
6808 :
6809 0 : iv1p_comm(:,:,:,:,ipc) = dmat
6810 : end do ! my_ip
6811 :
6812 0 : call xmpi_sum(iv1p_comm, gqk%pert_comm%value, ierr)
6813 0 : if (gqk%pert_comm%me == 0) then
6814 0 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("iv1p_comm"), iv1p_comm, start=[1,1,1,1,1,ik_glob]))
6815 : end if
6816 :
6817 0 : ABI_FREE(ffnl_k)
6818 0 : ABI_FREE(kinpw_k)
6819 0 : ABI_FREE(ph3d_k)
6820 0 : ABI_FREE(kpg_k)
6821 0 : ABI_FREE(kets_k)
6822 0 : ABI_FREE(p_kets_k)
6823 0 : ABI_FREE(gs1c_kq)
6824 0 : ABI_FREE(h1_kets_kq)
6825 0 : ABI_FREE(gvnlx1)
6826 : end do ! my_ik
6827 :
6828 0 : ABI_FREE(vlocal1)
6829 0 : ABI_FREE(lambda)
6830 0 : ABI_FREE(dmat)
6831 :
6832 : !call xmpi_sum(count_bk, gqk%comm%value, ierr)
6833 :
6834 : !do ik_ibz=1, gstore%nkibz
6835 : ! do band=gqk%bstart_k, gqk%bstop_k
6836 : ! in_k = band - gqk%bstart_k + 1
6837 : ! if (count_bk(in_k, ik_ibz) == 0) cycle
6838 : ! do ii=1,3
6839 : ! vnk_cart_ibz(ii,in_k,ik_ibz) = vnk_cart_ibz(ii,in_k,ik_ibz) / count_bk(in_k, ik_ibz)
6840 : ! end do
6841 : ! end do
6842 : !end do
6843 : !ABI_FREE(count_bk)
6844 :
6845 0 : ABI_FREE(iv1p_comm)
6846 : end associate
6847 : end do ! my_is
6848 :
6849 0 : ABI_FREE(vlocal)
6850 0 : ABI_FREE(dummy_vtrial)
6851 0 : ABI_FREE(v1scf)
6852 0 : ABI_FREE(work)
6853 0 : ABI_FREE(grad_berry)
6854 :
6855 0 : call pawcprj_free(cwaveprj0)
6856 0 : ABI_FREE(cwaveprj0)
6857 :
6858 0 : call xmpi_barrier(gstore%comm)
6859 0 : call cwtime_report(" Computation of commutator:", cpu_kk, wall_kk, gflops_kk)
6860 :
6861 : contains
6862 :
6863 0 : integer function spin_vid(var_name)
6864 : character(len=*),intent(in) :: var_name
6865 0 : spin_vid = nctk_idname(spin_ncid, var_name)
6866 : end function spin_vid
6867 :
6868 : end subroutine gstore_compute_and_write_commutator
6869 : !!***
6870 :
6871 : !!****f* m_gstore/gstore_nc_has_iv1p_comm
6872 : !! NAME
6873 : !! gstore_nc_has_iv1p_comm
6874 : !!
6875 : !! FUNCTION
6876 : !! Return True if GSTORE.nc contains commutator matrix elements.
6877 : !!
6878 : !! SOURCE
6879 :
6880 24 : logical function gstore_nc_has_iv1p_comm(gstore, root_ncid) result (has_iv1p_comm)
6881 :
6882 : !Arguments ------------------------------------
6883 : class(gstore_t),target, intent(in) :: gstore
6884 : integer,intent(in) :: root_ncid
6885 :
6886 : !Local variables-------------------------------
6887 : integer :: spin, ncerr, spin_ncid, varid
6888 : ! *************************************************************************
6889 :
6890 24 : has_iv1p_comm = .True.
6891 24 : do spin=1,gstore%nsppol
6892 24 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6893 24 : ncerr = nf90_inq_varid(spin_ncid, "iv1p_comm", varid)
6894 24 : if (ncerr /= nf90_noerr) then
6895 : has_iv1p_comm = .False.; exit
6896 : end if
6897 : end do
6898 :
6899 24 : end function gstore_nc_has_iv1p_comm
6900 : !!***
6901 :
6902 : !!****f* m_gstore/gstore_read_gtype
6903 : !! NAME
6904 : !! gstore_read_gtype
6905 : !!
6906 : !! FUNCTION
6907 : !! Read the value of "gstore_gtype" from the NetCDF file.
6908 : !! Only the master process reads the value and broadcasts it to all processes in comm.
6909 : !!
6910 : !! INPUTS
6911 : !! ncid: NetCDF file ID (open for reading).
6912 : !! comm: MPI communicator.
6913 : !!
6914 : !! OUTPUTS
6915 : !! gtype: The value of gstore_gtype read from the file.
6916 : !!
6917 : !! SOURCE
6918 :
6919 7 : subroutine gstore_read_gtype(path, gtype, comm, &
6920 7 : brange_k_spin, brange_kq_spin) ! optional
6921 :
6922 : !Arguments ------------------------------------
6923 : character(len=*), intent(in) :: path
6924 : character(len=abi_slen), intent(out) :: gtype
6925 : integer, intent(in) :: comm
6926 : integer,optional,intent(out) :: brange_k_spin(:,:)
6927 : integer,optional,intent(out) :: brange_kq_spin(:,:)
6928 :
6929 : !Local variables-------------------------------
6930 : integer, parameter :: master = 0
6931 : integer :: my_rank, nproc, ierr, varid, ncerr, ncid
6932 : ! *************************************************************************
6933 :
6934 7 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
6935 :
6936 7 : if (my_rank == master) then
6937 7 : NCF_CHECK(nf90_open(path, nf90_nowrite, ncid))
6938 7 : gtype = GSTORE_GTYPE_KS
6939 7 : ncerr = nf90_inq_varid(ncid, "gstore_gtype", varid)
6940 7 : if (ncerr == nf90_noerr) then
6941 7 : NCF_CHECK(nf90_get_var(ncid, varid, gtype))
6942 7 : call replace_ch0(gtype)
6943 : end if
6944 7 : if (present(brange_k_spin)) then
6945 0 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_k_spin"), brange_k_spin))
6946 : end if
6947 7 : if (present(brange_kq_spin)) then
6948 0 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_kq_spin"), brange_kq_spin))
6949 : end if
6950 7 : NCF_CHECK(nf90_close(ncid))
6951 : end if
6952 :
6953 7 : if (nproc > 1) then
6954 0 : call xmpi_bcast(gtype, master, comm, ierr)
6955 0 : if (present(brange_k_spin)) call xmpi_bcast(brange_k_spin, master, comm, ierr)
6956 0 : if (present(brange_kq_spin)) call xmpi_bcast(brange_kq_spin, master, comm, ierr)
6957 : end if
6958 :
6959 : contains
6960 :
6961 0 : integer function vid(var_name)
6962 : character(len=*),intent(in) :: var_name
6963 0 : vid = nctk_idname(ncid, var_name)
6964 : end function vid
6965 :
6966 : end subroutine gstore_read_gtype
6967 : !!***
6968 :
6969 : !----------------------------------------------------------------------
6970 :
6971 : !!****f* m_gstore/gstore_symmetrize
6972 : !! NAME
6973 : !! gstore_symmetrize
6974 : !!
6975 : !! FUNCTION
6976 : !! Reconstruct the electron-phonon matrix elements g(k,q) in the full
6977 : !! Brillouin Zone (BZ) using the values stored in the IBZ for k and the IBZ_k for q.
6978 : !! Uses the NetCDF API for in-place modification of the GSTORE file
6979 : !! and wfd_t to fetch wavefunctions and compute unitary matrices.
6980 : !!
6981 : !! SOURCE
6982 :
6983 0 : subroutine gstore_symmetrize(gstore_path, wfk_path, ngfft, dtset, dtfil, cryst, psps, pawtab, ebands, ifc, comm)
6984 :
6985 : !Arguments ------------------------------------
6986 : !scalars
6987 : character(len=*),intent(in) :: gstore_path
6988 : character(len=*),intent(in) :: wfk_path
6989 : integer,intent(in) :: ngfft(18)
6990 : type(dataset_type),intent(in) :: dtset
6991 : type(datafiles_type),intent(in) :: dtfil
6992 : class(crystal_t),target,intent(in) :: cryst
6993 : class(ebands_t),target,intent(in) :: ebands
6994 : class(ifc_type),target,intent(in) :: ifc
6995 : type(pseudopotential_type),intent(in) :: psps
6996 : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
6997 : integer,intent(in) :: comm
6998 :
6999 : !Local variables-------------------------------
7000 : !scalars
7001 : integer :: with_cplex, my_is, spin, my_ik, my_iq, ik_glob, iq_glob, units(2)
7002 : integer :: ncid, spin_ncid, nprocs, my_rank, ncerr, this_state, ierr
7003 : integer :: nb, nkbz, nkibz, nqbz, nqibz, nsym, itime_k
7004 : integer :: ik_ibz, isym_k, trev_k, tsign_k, g0_k(3), g0_q(3)
7005 : integer :: ik_ibz_file, isym_lg, itime_lg, isym_combined, c1_gs, n_gv, igv
7006 : integer :: n_lg, ii_lg, tsign_lg !, isym_lg, itime_lg,
7007 : integer :: idir, iat, idir_eq, iat_eq, mu, mu_eq, iq_sym
7008 : integer :: symrec_eq(3,3), symrec_eq_kspace(3,3), l0(3), mat_tmp(3,3)
7009 : real(dp) :: weight_qq, phase
7010 : complex(dp) :: cphase
7011 : logical :: with_g2dw, isirr_k, found_lg
7012 : character(len=abi_slen) :: with_gmode, gtype, gvals_name, gv_names(2)
7013 : character(len=5000) :: msg
7014 0 : type(gstore_t) :: gstore
7015 0 : type(dmats_t) :: dmats
7016 : integer :: isym_kqS, isym_kqT, ikq_ibz_s, ikq_ibz_t, h_isym, itime_h, h_isym_inv, trev_kqS, trev_kqT
7017 : integer :: indkk_s(6,1), indkk_t(6,1)
7018 : real(dp) :: L_h_gs(3), kq_ibz_pt(3)
7019 : complex(dp) :: phase_h_gs, phase_ket_gs
7020 : logical,parameter :: DEBUG_DUMP_DH = .False.
7021 : real(dp) :: kk_lg_test(3)
7022 : !!arrays
7023 0 : integer :: brange_kq_spin(2, dtset%nsppol)
7024 0 : integer,allocatable :: state_kq(:,:), kibz2bz(:) !, qibz2bz(:), qglob2bz(:,:), ! kmesh_map(:,:), my_kqmap(:,:),
7025 0 : integer,allocatable :: lg_isym(:), lg_itime(:)
7026 : real(dp) :: kk_bz(3), kk_ibz(3), qpt(3), qpt_tmp(3), kq_bz_source(3), kq_bz_target(3)
7027 0 : real(dp),allocatable :: qbz(:,:)
7028 0 : real(dp),contiguous,pointer :: gkq_rot_ptr(:,:,:,:,:), gkq_base_ptr(:,:,:,:,:)
7029 0 : complex(dp),target,allocatable :: gkq_rot(:,:,:,:,:), gkq_base(:,:,:,:,:)
7030 0 : complex(dp),allocatable :: gtmp(:,:), dh_mat(:,:), ket_mat(:,:)
7031 : !----------------------------------------------------------------------
7032 :
7033 0 : nprocs = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
7034 :
7035 0 : units = [std_out, ab_out]
7036 0 : call wrtout(units, " Entering gstore_symmetrize...")
7037 0 : call wrtout(units, sjoin(" GSTORE file: ", gstore_path))
7038 :
7039 0 : call gstore_read_gtype(gstore_path, gtype, comm, brange_kq_spin=brange_kq_spin)
7040 :
7041 : ! Compute the D-matrices D_mn(S) = <psi_m,S kq_ibz|S|psi_n,kq_ibz>.
7042 : ! These are used below (as dh_mat) to correct the extra rotation the bra (electron state
7043 : ! at k+q) picks up when its own already-computed BZ representative differs from the one
7044 : ! obtained by applying isym_k directly. dh_mat is applied to the (k+q)/bra band index only
7045 : ! (gvals' first band dimension, nb_kq) -- never to the k/ket index (nb_k) -- so dmats must be
7046 : ! built with brange_kq_spin (bstart_kq:bstop_kq), NOT brange_k_spin: the two band windows are
7047 : ! only required to have the SAME COUNT (gstore%same_nbands, checked below) but may start at a
7048 : ! different absolute band (bstart_k need not equal bstart_kq, and neither needs to start at 1).
7049 : ! All MPI ranks participate here since dmats%init distributes the work internally over comm.
7050 : !
7051 : ! NOTE: dmats_init also computes genuine (WFK-derived) D-matrices for symmetries S that do
7052 : ! NOT stabilize a given IBZ k-point (S.k /= k+G), not just little-group elements -- this
7053 : ! routine (gstore_symmetrize) is UNAFFECTED by that generalization and needs no changes
7054 : ! because it never reads a non-little-group slot: every dmats%for_spin(...) lookup below
7055 : ! uses either h_isym/h_isym_inv (searched for specifically as a stabilizer of ikq_ibz_t --
7056 : ! see "Cannot find little-group element h for the k+q leg" below) or isym_k (drawn directly
7057 : ! from lg_isym, the explicitly-enumerated little group of kk_ibz in Pass A). Both are
7058 : ! guaranteed, by construction, to land on the little-group branch of dmats_init, which is
7059 : ! untouched by the generalization -- confirmed by byte-identical validation numbers on
7060 : ! diamond/AlAs before and after. See gstore_symmetrize_status memory for the full story.
7061 0 : call dmats%init(wfk_path, dtset, cryst, brange_kq_spin, ngfft, pawtab, psps, comm)
7062 :
7063 : ! Only master processor performs the symmetrization of the e-ph matrix elements.
7064 : ! Performance is not crucial and the algorithm is IO-bound.
7065 0 : if (my_rank /= 0) goto 100
7066 :
7067 : ! GWPT files store two sets of e-ph matrix elements: "gvals" (g^Sigma) and "gvals_ks" (g^KS),
7068 : ! written at the same (k,q) grid positions (see m_gwpt.F90's dump_my_gbuf). Symmetrize both.
7069 0 : n_gv = 1; gv_names(1) = "gvals"
7070 0 : if (gtype == GSTORE_GTYPE_GWPT) then
7071 0 : n_gv = 2; gv_names(2) = "gvals_ks"
7072 : end if
7073 :
7074 : ! Read GSTORE.nc dimensions and metadata from file, without allocating gvals buffer.
7075 0 : with_cplex = 0; with_gmode = GSTORE_GMODE_ATOM; with_g2dw = .False.; gvals_name = "gvals"
7076 : call gstore%from_ncpath(gstore_path, with_cplex, dtset, dtfil, cryst, ebands, ifc, &
7077 0 : with_gmode, gvals_name, with_g2dw, xmpi_comm_self)
7078 :
7079 : ! We need the same number of bands for m and n. Also, k and q must be in the BZ without any filter.
7080 0 : ABI_CHECK(gstore%same_nbands(msg), msg)
7081 0 : if (gstore%check_cplex_qkzone_gmode(2, "bz", "bz", "atom", kfilter="none", check_alloc=.False.) /= 0) then
7082 0 : ABI_ERROR("GSTORE.nc should have both k and q in the full BZ. See messages above.")
7083 : end if
7084 :
7085 : ! has_used_lgk is supported via the gstore_sym == 2 "Pass A" reconstruction below.
7086 : ! has_used_lgq remains unsupported: it is a structurally different restriction
7087 : ! (k filtered by the little group of q), out of scope for gstore_sym.
7088 0 : ABI_CHECK_IEQ(gstore%has_used_lgq, 0, "Symmetrization of g(k,q) with use_lgq /= 0 is not coded")
7089 :
7090 : ! Useful dimensions.
7091 0 : nkbz = gstore%nkbz; nkibz = gstore%nkibz
7092 0 : nqbz = gstore%nqbz; nqibz = gstore%nqibz
7093 0 : nsym = cryst%nsym
7094 :
7095 : ! Need to know the position of the IBZ k-points in the netcdf array..
7096 0 : call get_ibz2bz(gstore%nkibz, gstore%nkbz, gstore%kbz2ibz, kibz2bz, msg, ierr)
7097 0 : ABI_CHECK(ierr == 0, sjoin("Something wrong in symmetry tables for k-points", ch10, msg))
7098 :
7099 0 : NCF_CHECK(nctk_open_modify(ncid, gstore_path, xmpi_comm_self))
7100 :
7101 : if (DEBUG_DUMP_DH) open(unit=789, file="dh_debug.csv", status="replace", action="write")
7102 : if (DEBUG_DUMP_DH) open(unit=790, file="dh_mat_full_debug.csv", status="replace", action="write")
7103 : if (DEBUG_DUMP_DH) open(unit=791, file="gtmp_debug.csv", status="replace", action="write")
7104 : if (DEBUG_DUMP_DH) open(unit=792, file="mu_debug.csv", status="replace", action="write")
7105 :
7106 : ! Loop over collinear spins.
7107 0 : do my_is=1,gstore%my_nspins
7108 0 : spin = gstore%my_spins(my_is)
7109 : associate (gqk => gstore%gqk(my_is))
7110 : ! nb_k == nb_kq is enforced by gstore%same_nbands above, so either count can be used here for
7111 : ! sizing; the absolute band offsets (bstart_k vs bstart_kq, handled via brange_kq_spin passed
7112 : ! to dmats%init above) are what actually differ and matter for correctness.
7113 0 : nb = gqk%nb_k
7114 0 : ABI_CHECK_IEQ(gqk%bstart_kq, brange_kq_spin(1, spin), "gqk%bstart_kq != brange_kq_spin(1, spin)")
7115 0 : ABI_CHECK_IEQ(gqk%bstop_kq, brange_kq_spin(2, spin), "gqk%bstop_kq != brange_kq_spin(2, spin)")
7116 :
7117 : ! Get the group id for this spin.
7118 0 : NCF_CHECK(nf90_inq_ncid(ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
7119 :
7120 : ! Read table with status of the (k, q) entry.
7121 0 : ABI_MALLOC(state_kq, (gqk%glob_nk, gqk%glob_nq))
7122 0 : ncerr = nf90_get_var(ncid, nctk_idname(ncid, "gstore_glob_state_kqs"), state_kq, start=[1,1,spin])
7123 0 : NCF_CHECK(ncerr)
7124 :
7125 0 : ABI_MALLOC(gkq_base, (nb, nb, gqk%natom3, gqk%my_nq, n_gv))
7126 0 : ABI_MALLOC(gkq_rot, (nb, nb, gqk%natom3, gqk%my_nq, n_gv))
7127 0 : ABI_MALLOC(gtmp, (nb, nb))
7128 0 : ABI_MALLOC(dh_mat, (nb, nb))
7129 0 : ABI_MALLOC(ket_mat, (nb, nb))
7130 :
7131 : ! Build q-points in the BZ.
7132 0 : ABI_MALLOC(qbz, (3, gqk%my_nq))
7133 0 : do my_iq=1, gqk%my_nq
7134 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qbz(:,my_iq))
7135 : end do
7136 :
7137 : ! =====================================================================
7138 : ! Pass A (gstore_sym == 2 only): if gstore_use_lgk restricted the q's
7139 : ! actually computed directly for k in the IBZ, an IBZ row may have some
7140 : ! q entries GSTORE_KQ_COMPUTED (q in IBZ_k) and others GSTORE_KQ_MISSING
7141 : ! (q outside IBZ_k). Fill the MISSING ones here, using ONLY the little
7142 : ! group of kk_ibz itself (k never moves in this pass -- the degenerate
7143 : ! case of the k-star formula below, kk_bz := kk_ibz). Once every IBZ row
7144 : ! is fully populated, the k-star loop below runs completely unchanged
7145 : ! for the non-IBZ rows, exactly as it always has when gstore_use_lgk == 0.
7146 : ! =====================================================================
7147 0 : if (dtset%gstore_sym == 2) then
7148 0 : do ik_ibz=1,nkibz
7149 0 : ik_glob = kibz2bz(ik_ibz)
7150 0 : if (all(state_kq(ik_glob, :) /= GSTORE_KQ_MISSING)) cycle
7151 :
7152 0 : kk_ibz = ebands%kptns(:, ik_ibz)
7153 0 : ik_ibz_file = ik_glob
7154 0 : kk_bz = kk_ibz ! degenerate case: k never moves in Pass A
7155 :
7156 : ! Enumerate the little group of kk_ibz once per row: symrel^T membership
7157 : ! test, mirroring dmats_get_star_dmats (m_classify_bands.F90:2048-2061).
7158 : ! Deliberately NOT lgroup_t/littlegroup_q here: those use the symrec
7159 : ! convention, which can disagree with the symrel^T convention used
7160 : ! throughout dmats/gstore_symmetrize for non-orthogonal symrel.
7161 0 : ABI_MALLOC(lg_isym, (2*nsym))
7162 0 : ABI_MALLOC(lg_itime, (2*nsym))
7163 0 : n_lg = 0
7164 0 : do itime_lg=1,2
7165 0 : do isym_lg=1,nsym
7166 0 : tsign_lg = 1; if (itime_lg == 2) tsign_lg = -1
7167 0 : kk_lg_test = tsign_lg * matmul(transpose(cryst%symrel(:,:,isym_lg)), kk_ibz)
7168 0 : if (isamek(kk_ibz, kk_lg_test, g0_q)) then
7169 0 : n_lg = n_lg + 1
7170 0 : lg_isym(n_lg) = isym_lg; lg_itime(n_lg) = itime_lg
7171 : end if
7172 : end do
7173 : end do
7174 0 : ABI_CHECK(n_lg > 0, "Little group of kk_ibz is empty (should at least contain the identity)")
7175 :
7176 : ! Read g(k_ibz, q) for all q already available (same read pattern as below).
7177 0 : do igv=1,n_gv
7178 0 : call c_f_pointer(c_loc(gkq_base(1,1,1,1,igv)), gkq_base_ptr, [2, nb, nb, gqk%natom3, gqk%my_nq])
7179 : ncerr = nf90_get_var(spin_ncid, spin_vid(gv_names(igv)), gkq_base_ptr, &
7180 : start=[1, 1, 1, 1, ik_ibz_file, 1], &
7181 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7182 0 : NCF_CHECK(ncerr)
7183 : end do
7184 :
7185 0 : do my_iq=1, gqk%my_nq
7186 0 : iq_glob = my_iq + gqk%my_qstart - 1
7187 :
7188 0 : if (state_kq(ik_glob, iq_glob) /= GSTORE_KQ_MISSING) then
7189 : ! Already GSTORE_KQ_COMPUTED (q in IBZ_k): keep the on-disk value unchanged.
7190 0 : gkq_rot(:,:,:,iq_glob,:) = gkq_base(:,:,:,iq_glob,:)
7191 0 : cycle
7192 : end if
7193 :
7194 0 : qpt = qbz(:, my_iq)
7195 :
7196 : ! Search the little group x the row's own COMPUTED q entries for a source match.
7197 : found_lg = .False.
7198 0 : do ii_lg=1,n_lg
7199 0 : isym_k = lg_isym(ii_lg); trev_k = lg_itime(ii_lg) - 1
7200 0 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
7201 0 : symrec_eq = transpose(cryst%symrel(:,:,isym_k))
7202 0 : symrec_eq_kspace = tsign_k * symrec_eq
7203 0 : do iq_sym=1, gqk%my_nq
7204 0 : if (state_kq(ik_glob, iq_sym + gqk%my_qstart - 1) /= GSTORE_KQ_COMPUTED) cycle
7205 0 : qpt_tmp = matmul(symrec_eq_kspace, qbz(:, iq_sym))
7206 0 : if (isamek(qpt, qpt_tmp, g0_q)) then
7207 0 : found_lg = .True.; exit
7208 : end if
7209 : end do
7210 0 : if (found_lg) exit
7211 : end do
7212 :
7213 : msg = sjoin("Pass A: no little-group image of q found among GSTORE_KQ_COMPUTED", &
7214 0 : " entries for ik_ibz=", itoa(ik_ibz), " -- IBZ_k does not cover this q's star")
7215 0 : ABI_CHECK(found_lg, msg)
7216 :
7217 0 : do isym_combined=1,nsym
7218 0 : if (all(cryst%symrec(:,:,isym_combined) == symrec_eq)) exit
7219 : end do
7220 0 : ABI_CHECK(isym_combined /= nsym + 1, "Cannot find symrec_eq")
7221 :
7222 : ! Note on non-uniqueness of (isym_k, iq_sym): when kk_ibz has a non-trivial little group
7223 : ! (the typical case, not a rare corner case -- measured on the reference test systems
7224 : ! below, EVERY Pass-A point in diamond and most in AlAs have more than one valid
7225 : ! candidate, up to ~96 at Gamma), the found_lg search above can match several different
7226 : ! (isym,itime,iq_sym) triples for the same target q; "first found" is taken arbitrarily.
7227 : ! Verified this does NOT introduce a gauge/correctness bug: a dedicated diagnostic
7228 : ! (temporarily instrumented, then removed) recomputed the full reconstruction using EVERY
7229 : ! valid candidate for a set of known-redundant points on both diamond (4 points, 2-4
7230 : ! candidates each) and AlAs (2 points), and all candidates agreed with each other to
7231 : ! numerical noise (~1e-7 to 1e-10) in every case -- i.e. the formula is empirically
7232 : ! gauge-invariant to this choice, the same way the bra leg's h_isym/phase_h_gs/L_h_gs
7233 : ! machinery is already known (and was originally designed) to be invariant to which
7234 : ! (isym_kqS,isym_kqT) kpts_map happens to return. See gstore_symmetrize_status memory for
7235 : ! the full data. Contrast with dmats_get_star_dmats_at_kpt (m_classify_bands.F90), a
7236 : ! DIAGNOSTIC-only routine with a structurally identical first-match-wins search that its
7237 : ! own authors flag as an unverified risk -- that routine has NOT been checked this way and
7238 : ! is a separate, lower-priority open item (never reached by production gstore_symmetrize).
7239 :
7240 : ! -----------------------------------------------------------------
7241 : ! From here on, reused VERBATIM from the k-star loop below (Bug A /
7242 : ! h_isym / phase_h_gs / phase_ket_gs / itime_h / dh_mat / mu-rotation
7243 : ! -- kk_bz == kk_ibz here, the degenerate case, so the formula
7244 : ! derived for the general k-star case applies unchanged). See the
7245 : ! k-star loop's own comments for the full derivation.
7246 0 : kq_bz_source = kk_ibz + qbz(:, iq_sym)
7247 0 : kq_bz_target = kk_bz + qpt
7248 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_source, indkk_s)
7249 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (source)")
7250 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_target, indkk_t)
7251 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (target)")
7252 0 : ikq_ibz_s = indkk_s(1,1); isym_kqS = indkk_s(2,1)
7253 0 : ikq_ibz_t = indkk_t(1,1); isym_kqT = indkk_t(2,1)
7254 0 : trev_kqS = indkk_s(6,1); trev_kqT = indkk_t(6,1)
7255 0 : ABI_CHECK(ikq_ibz_s == ikq_ibz_t, "Source and target k+q map to different IBZ points!")
7256 :
7257 0 : mat_tmp = matmul(transpose(cryst%symrel(:,:,dmats%toinv(1,isym_kqT))), &
7258 0 : matmul(symrec_eq, transpose(cryst%symrel(:,:,isym_kqS))))
7259 0 : do h_isym=1,nsym
7260 0 : if (all(transpose(cryst%symrel(:,:,h_isym)) == mat_tmp)) exit
7261 : end do
7262 0 : ABI_CHECK(h_isym /= nsym + 1, "Cannot find little-group element h for the k+q leg")
7263 :
7264 0 : c1_gs = dmats%multable(1, isym_kqS, isym_k)
7265 : L_h_gs = real(dmats%multable(2:4, isym_kqS, isym_k), dp) &
7266 : + real(dmats%multable(2:4, c1_gs, dmats%toinv(1,isym_kqT)), dp) &
7267 0 : - matmul(real(cryst%symrel(:,:,h_isym), dp), real(dmats%toinv(2:4,isym_kqT), dp))
7268 0 : kq_ibz_pt = ebands%kptns(:, ikq_ibz_t)
7269 0 : phase_h_gs = exp(cmplx(zero, two_pi * sum(kq_ibz_pt * L_h_gs), dp))
7270 :
7271 : ! Pass-A-only companion to phase_ket_gs. The k-star formula below (kk_bz generally
7272 : ! != kk_ibz) was validated to 100% exact match WITHOUT this extra term. In Pass A,
7273 : ! kk_bz == kk_ibz identically (the degenerate case), and an extra residual survived
7274 : ! even after the ket_mat fix: isolated (h_isym==1, scalar-only residual, i.e. exactly
7275 : ! reproducible by a single global phase -- see gstore_symmetrize_status memory) to be
7276 : ! a clean function of isym_k and kk_ibz alone: exp(-i*2pi*kk_ibz.w(isym_k)) for an
7277 : ! integer vector w. Empirically fit w(isym_k) exactly (32/32 points, zero exceptions,
7278 : ! all 3 distinct ik_ibz/isym_k combinations in the reference test) to
7279 : ! toinv(2:4,isym_k) -- the SAME single-inverse convention used for L_h_gs's own
7280 : ! toinv(1,isym_kqT) term, and notably NOT the double-inverse toinv(2:4,toinv(1,isym_k))
7281 : ! used by the qpt term just above. Plausible reading: the qpt-term's
7282 : ! toinv(2:4,toinv(1,isym_k)) is the companion to kk_bz = symrec_eq.kk_ibz (the k-star's
7283 : ! moved k), which in Pass A degenerates to kk_ibz itself, making this term newly
7284 : ! separate and nonzero instead of staying absorbed into the k-star's single term.
7285 : phase_ket_gs = exp(cmplx(zero, -two_pi * sum(qpt * real(dmats%toinv(2:4, dmats%toinv(1,isym_k)), dp)), dp)) &
7286 0 : * exp(cmplx(zero, -two_pi * sum(kk_ibz * real(dmats%toinv(2:4, isym_k), dp)), dp))
7287 :
7288 0 : itime_h = 1 + mod(trev_k + trev_kqS + trev_kqT, 2)
7289 :
7290 0 : h_isym_inv = dmats%toinv(1, h_isym)
7291 0 : if (itime_h == 2) then
7292 0 : dh_mat = conjg(phase_h_gs) * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
7293 : else
7294 0 : dh_mat = phase_h_gs * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
7295 : end if
7296 :
7297 0 : if (trev_kqT == 1) dh_mat = conjg(dh_mat)
7298 :
7299 : ! Ket-leg correction (Pass A only -- k-star never needs this, see below). Unlike k-star
7300 : ! reconstruction, whose ket is always *derived* via cgtk_rotate from the IBZ wavefunction
7301 : ! (so ground truth and reconstruction structurally share the same gauge for any degenerate
7302 : ! ket subspace), Pass A's ket lives AT kk_ibz itself and is read directly from the WFK for
7303 : ! every q processed there. Ground truth's own independent direct e-ph calculations at
7304 : ! different q (same k) do not share a common internal gauge for a degenerate ket subspace.
7305 : ! isym_k stabilizes kk_ibz (drawn from its own little group, by construction), so
7306 : ! dmats%for_spin(...)(isym_k,...) is a genuine, tabulated (non-placeholder) D-matrix here
7307 : ! -- unlike the general k-star case, where isym_k need not stabilize anything.
7308 : !
7309 : ! Convention: read dmats%for_spin(...)(isym_k,...) DIRECTLY, not the toinv(1,isym_k) slot.
7310 : ! isym_k here is found purely via the symrel^T convention (little-group membership test),
7311 : ! and dmats's own array is indexed the same way (symrel^T, per dmats_init's own little-group
7312 : ! check), so isym_k already names the exact tabulated operation that rotates the ket -- no
7313 : ! inversion is needed or correct. (Contrast with the BRA correction above, dh_mat: h_isym
7314 : ! there is defined as a genuine COMPOSITE/residual little-group element of kq_ibz whose
7315 : ! natural tabulated slot -- per dmats_init's own toinv/multable bookkeeping around
7316 : ! cgtk_rotate's isym_inv=toinv(isym) workaround -- is toinv(1,h_isym), not h_isym itself;
7317 : ! that is a property of how h_isym's OWN definition composes with dmats_init's internal
7318 : ! convention, not a general rule that every dmats lookup needs a toinv step.) The original
7319 : ! implementation used toinv(1,isym_k) "by analogy" with dh_mat and was validated only on an
7320 : ! involutory isym_k (toinv(1,isym_k)==isym_k), which cannot distinguish the two conventions.
7321 : ! Diagnosed by finding a 100%/0% clean split: EVERY point with non-involutory isym_k was
7322 : ! wrong (needing a genuine unitary matrix fix, not a scalar) while every involutory-isym_k
7323 : ! point was already exact -- direct, decisive evidence the toinv(1,.) step was the bug.
7324 0 : itime_k = trev_k + 1
7325 0 : ket_mat = dmats%for_spin(spin)%value(:,:,isym_k,itime_k,ik_ibz)
7326 0 : if (trev_k == 1) ket_mat = conjg(ket_mat)
7327 : ! -----------------------------------------------------------------
7328 :
7329 : ! Perform symmetrization.
7330 0 : do mu=1,gqk%natom3
7331 0 : idir = mod(mu-1, 3) + 1; iat = (mu - idir) / 3 + 1
7332 :
7333 0 : iat_eq = cryst%indsym(4, isym_combined, iat)
7334 0 : l0 = cryst%indsym(1:3, isym_combined, iat)
7335 0 : phase = -two_pi * dot_product(qbz(:, iq_sym), l0)
7336 0 : cphase = cmplx(cos(phase), sin(phase), dp)
7337 :
7338 0 : do igv=1,n_gv
7339 0 : gtmp = zero
7340 0 : do idir_eq=1,3
7341 0 : mu_eq = idir_eq + (iat_eq - 1) * 3
7342 0 : gtmp = gtmp + cphase * symrec_eq(idir, idir_eq) * gkq_base(:,:,mu_eq,iq_sym,igv)
7343 : end do
7344 0 : if (trev_k == 1) gtmp = conjg(gtmp)
7345 0 : gkq_rot(:,:,mu,iq_glob,igv) = matmul(matmul(dh_mat, gtmp), ket_mat)
7346 : end do
7347 : end do
7348 :
7349 : end do ! my_iq
7350 :
7351 : ! Write the newly reconstructed + copied-through rows back to the netcdf file.
7352 0 : do igv=1,n_gv
7353 0 : call c_f_pointer(c_loc(gkq_rot(1,1,1,1,igv)), gkq_rot_ptr, [2, nb, nb, gqk%natom3, gqk%my_nq])
7354 : ncerr = nf90_put_var(spin_ncid, spin_vid(gv_names(igv)), gkq_rot_ptr, &
7355 : start=[1, 1, 1, 1, ik_glob, 1], &
7356 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7357 0 : NCF_CHECK(ncerr)
7358 : end do
7359 0 : where (state_kq(ik_glob, :) == GSTORE_KQ_MISSING) state_kq(ik_glob, :) = GSTORE_KQ_SYMMETRIZED
7360 :
7361 0 : ABI_FREE(lg_isym)
7362 0 : ABI_FREE(lg_itime)
7363 : end do ! ik_ibz
7364 : end if ! gstore_sym == 2
7365 :
7366 0 : NCF_CHECK(nf90_sync(spin_ncid))
7367 :
7368 : ! Loop over k-points in the IBZ.
7369 0 : do my_ik=1,gqk%my_nk
7370 0 : ik_glob = my_ik + gqk%my_kstart - 1
7371 0 : kk_bz = gqk%my_kpts(:, my_ik)
7372 :
7373 0 : if (state_kq(ik_glob, 1) /= GSTORE_KQ_MISSING) then
7374 : ! Row already fully resolved: either directly COMPUTED (gstore_use_lgk == 0), or
7375 : ! filled by Pass A above (gstore_sym == 2, mix of COMPUTED and SYMMETRIZED).
7376 0 : ABI_CHECK(all(state_kq(ik_glob, :) /= GSTORE_KQ_MISSING), "all state")
7377 0 : cycle
7378 : end if
7379 :
7380 : ! Symmetry tables for k-point. Using symrel^T convention for k..
7381 0 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
7382 0 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5, my_ik)
7383 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
7384 0 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
7385 0 : itime_k = trev_k + 1
7386 0 : kk_ibz = ebands%kptns(:,ik_ibz)
7387 :
7388 : ! Index of the IBZ k-point on disk.
7389 0 : ik_ibz_file = kibz2bz(ik_ibz)
7390 :
7391 : ! symrec_eq is the SPATIAL rotation (used for atomic-perturbation-direction
7392 : ! bookkeeping below, which is TR-blind: time reversal does not move atoms.
7393 : ! symrec_eq_kspace additionally carries the TR sign and is the one that actually relates k-space
7394 : ! vectors (kk_bz, q) to their IBZ images
7395 0 : symrec_eq = transpose(cryst%symrel(:,:,isym_k))
7396 0 : symrec_eq_kspace = tsign_k * symrec_eq
7397 0 : ABI_CHECK(isamek(kk_bz, matmul(symrec_eq_kspace, kk_ibz), g0_q), "kk_bz != symrec_eq_kspace kk_ibz")
7398 :
7399 0 : do isym_combined=1,nsym
7400 0 : if (all(cryst%symrec(:,:,isym_combined) == symrec_eq)) exit
7401 : end do
7402 0 : ABI_CHECK(isym_combined /= nsym + 1, "Cannot find symrec_eq")
7403 :
7404 : ! Read g(k_ibz, q) for all q-point in the BZ, for each gvals stream ("gvals", and "gvals_ks" too when gtype == "gwpt").
7405 0 : do igv=1,n_gv
7406 0 : call c_f_pointer(c_loc(gkq_base(1,1,1,1,igv)), gkq_base_ptr, [2, nb, nb, gqk%natom3, gqk%my_nq])
7407 : ncerr = nf90_get_var(spin_ncid, spin_vid(gv_names(igv)), gkq_base_ptr, &
7408 : start=[1, 1, 1, 1, ik_ibz_file, 1], &
7409 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7410 0 : NCF_CHECK(ncerr)
7411 : end do
7412 :
7413 : ! Loop over q-points in the BZ.
7414 0 : do my_iq=1, gqk%my_nq
7415 0 : iq_glob = my_iq + gqk%my_qstart - 1
7416 0 : this_state = state_kq(ik_glob, iq_glob)
7417 0 : if (this_state /= GSTORE_KQ_MISSING) cycle
7418 :
7419 : ! Symmetry tables for q-point. NB: Using symrec convention for q.
7420 : !iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
7421 : !trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5, my_iq)
7422 : !isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
7423 : !tsign_q = 1; if (trev_q == 1) tsign_q = -1
7424 : !qq_ibz = gstore%qibz(:, iq_ibz)
7425 0 : qpt = qbz(:, my_iq)
7426 :
7427 : ! Find q. Uses symrec_eq_kspace (not symrec_eq): q, like k, is a genuine k-space vector
7428 : ! that picks up the TR sign under the same combined operation mapping kk_ibz -> kk_bz.
7429 0 : do iq_sym=1, gqk%my_nq
7430 : ! qpt = qpt_tmp + G0_q
7431 0 : qpt_tmp = matmul(symrec_eq_kspace, qbz(:, iq_sym)); if (isamek(qpt, qpt_tmp, g0_q)) exit
7432 : end do
7433 0 : ABI_CHECK(iq_sym /= gqk%my_nq + 1, sjoin("Cannot find:", ktoa(qpt)))
7434 :
7435 : ! -----------------------------------------------------------------
7436 : ! Bug A fix: the bra (electron state at k+q) reaches its target BZ
7437 : ! point via two composed rotations (isym_k applied to the SOURCE
7438 : ! bra's own rotation from kq_ibz), while the "true" bra is obtained
7439 : ! by a single direct rotation from kq_ibz. The two differ by U(h),
7440 : ! h being the residual element of the little group (stabilizer) of
7441 : ! kq_ibz. h always stabilizes kq_ibz by construction (never an
7442 : ! out-of-domain little-group lookup), so the D-matrices already
7443 : ! tabulated by dmats are valid here. See gstore_symmetrize_status
7444 : ! memory (session 10) for the full derivation.
7445 0 : kq_bz_source = kk_ibz + qbz(:, iq_sym)
7446 0 : kq_bz_target = kk_bz + qpt
7447 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_source, indkk_s)
7448 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (source)")
7449 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_target, indkk_t)
7450 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (target)")
7451 0 : ikq_ibz_s = indkk_s(1,1); isym_kqS = indkk_s(2,1)
7452 0 : ikq_ibz_t = indkk_t(1,1); isym_kqT = indkk_t(2,1)
7453 0 : trev_kqS = indkk_s(6,1); trev_kqT = indkk_t(6,1)
7454 0 : ABI_CHECK(ikq_ibz_s == ikq_ibz_t, "Source and target k+q map to different IBZ points!")
7455 :
7456 : ! mat_tmp = Srel(toinv(isym_kqT)) . Srel(isym_k) . Srel(isym_kqS), with Srel(S) := symrel(S)^T
7457 : ! (same k/kq convention as symrec_eq above, i.e. NOT cryst%symrec). h_isym is the isym s.t.
7458 : ! Srel(h_isym) == mat_tmp.
7459 0 : mat_tmp = matmul(transpose(cryst%symrel(:,:,dmats%toinv(1,isym_kqT))), &
7460 0 : matmul(symrec_eq, transpose(cryst%symrel(:,:,isym_kqS))))
7461 0 : do h_isym=1,nsym
7462 0 : if (all(transpose(cryst%symrel(:,:,h_isym)) == mat_tmp)) exit
7463 : end do
7464 0 : ABI_CHECK(h_isym /= nsym + 1, "Cannot find little-group element h for the k+q leg")
7465 :
7466 : ! Lattice-vector-phase companion to h_isym (bra leg). The rotation-only h_isym search above
7467 : ! finds the correct isym s.t. Srel(h_isym) matches the literal 3-way rotation product, but
7468 : ! (analogous to dmats_get_star_dmats's validated S0.g.S0^{-1} + L_h construction) the literal
7469 : ! Seitz composition Tab(isym_kqS).Tab(isym_k).Tab(isym_kqT)^{-1} generally differs from
7470 : ! Tab(h_isym) by a residual lattice vector L_h_gs whenever any of isym_kqS/isym_k/isym_kqT is
7471 : ! non-symmorphic, even when h_isym is the identity rotation. Derived by substituting
7472 : ! Tab(c1)=T_{-L1}.Tab(isym_kqS).Tab(isym_k) [c1=multable(1,isym_kqS,isym_k), the SAME rotation
7473 : ! recipe already validated for h_isym itself] into Tab(c1).Tab(toinv(isym_kqT))=T_{L2}.Tab(h_isym),
7474 : ! then Tab(toinv(isym_kqT)) = Tab(isym_kqT)^{-1}.T_{L0} (L0=toinv(2:4,isym_kqT)), and pushing
7475 : ! T_{-L0} through Tab(h_isym) (Tab(h).T_v = T_{R(h).v}.Tab(h)). Verified EXACTLY (3000/3000
7476 : ! random (isym_k,isym_kqS,isym_kqT) triples, zero umklapp) against the literal 3-operator
7477 : ! Seitz composition computed independently with the EXACT (non-tabulated) group inverse. The
7478 : ! overall sign was pinned down against a hand-verified counterexample (h_isym=1, needing a
7479 : ! missing factor of exactly +i).
7480 0 : c1_gs = dmats%multable(1, isym_kqS, isym_k)
7481 : L_h_gs = real(dmats%multable(2:4, isym_kqS, isym_k), dp) &
7482 : + real(dmats%multable(2:4, c1_gs, dmats%toinv(1,isym_kqT)), dp) &
7483 0 : - matmul(real(cryst%symrel(:,:,h_isym), dp), real(dmats%toinv(2:4,isym_kqT), dp))
7484 0 : kq_ibz_pt = ebands%kptns(:, ikq_ibz_t)
7485 0 : phase_h_gs = exp(cmplx(zero, two_pi * sum(kq_ibz_pt * L_h_gs), dp))
7486 :
7487 : ! Companion phase on the KET leg. Even with phase_h_gs above, a residual remained, isolated
7488 : ! (via h_isym==1 points, where dh_mat=I so phase_h_gs is the only other active correction) to
7489 : ! be a clean function of isym_k and the TARGET q alone: exp(-i*2pi*qpt.v(isym_k)) for an
7490 : ! integer vector v. Empirically fit v(isym_k) exactly (100% across all isym_k appearing in
7491 : ! the reference test, zero exceptions) to toinv(2:4, toinv(1,isym_k)) -- i.e. the
7492 : ! lattice-vector residual of composing isym_k with its OWN inverse in the OTHER order from
7493 : ! toinv's own convention (toinv(2:4,isym_k) is for S(isym_k).S(isym_k^{-1}); this needs
7494 : ! S(isym_k^{-1}).S(isym_k) instead, which only coincides with the former when isym_k is
7495 : ! self-inverse -- the same class of composition-order mixup fixed in dmats_check_one_k and in
7496 : ! deriving L_h_gs above). Physical origin not fully pinned down: isym_k plays a role in BOTH
7497 : ! the ket rotation (kk_bz = symrec_eq.kk_ibz) AND the atomic-perturbation-direction rotation
7498 : ! via the SAME symrec_eq in the mu-loop below (whose existing cphase/l0 term is dotted with
7499 : ! the SOURCE q, not the target) -- plausibly this is the missing lattice-vector companion to
7500 : ! THAT term, evaluated at the target q instead, but this is a plausible reading of the
7501 : ! empirical formula, not an independently re-derived physical proof (unlike L_h_gs above,
7502 : ! which was verified against the literal Seitz composition directly). Trust the formula
7503 : ! (exhaustively validated below); treat the physical narrative as informed conjecture only.
7504 : !
7505 : ! Effect of phase_h_gs+phase_ket_gs alone on the gstore_brange 1 4 reference test: raw
7506 : ! exact-match rate 60.4% -> 91.7%, gauge-invariant unchanged at 100%. NOTE: the remaining 8.3%
7507 : ! was INITIALLY (wrongly) attributed entirely to expected degenerate-band gauge freedom per
7508 : ! AGENTS.md -- this was corrected later (see the THIRD correction right below): a Procrustes
7509 : ! best-fit-unitary check proved EXACT reconstruction is achievable for within-range-degenerate
7510 : ! bra multiplets, so that mismatch was a real, fixable bug, not gauge freedom. Do not repeat
7511 : ! that mistake: eigenvalue-degeneracy alone never proves a mismatch is harmless -- check
7512 : ! whether a single matrix can exactly relate reconstruction to truth first.
7513 0 : phase_ket_gs = exp(cmplx(zero, -two_pi * sum(qpt * real(dmats%toinv(2:4, dmats%toinv(1,isym_k)), dp)), dp))
7514 :
7515 : ! THIRD correction: dmats%for_spin(h_isym) is the WRONG tabulated matrix for the bra whenever
7516 : ! h_isym is a non-self-inverse symmetry. Root cause: dmats_init computes D(isym) by calling
7517 : ! cgtk_rotate with isym_inv=toinv(isym) and a separately-recomputed umklapp g0_inv (a
7518 : ! documented workaround for cgtk_rotate silently returning D_true(S)^{-1} for non-involutions).
7519 : ! D(h) and D(toinv(h)) are unitary inverses of each other only up to an EXTRA phase that
7520 : ! dmats_init's own toinv/multable bookkeeping already knows about (this is exactly what
7521 : ! dmats_check_one_k's "inv_phase"/"phase_analytic" diagnostic measures and validates) --
7522 : ! reconstructing D(toinv(h)) from D(h) via a bare conjugate-transpose silently drops that
7523 : ! phase. Looking up dmats%for_spin(toinv(h_isym)) directly sidesteps this entirely, since
7524 : ! dmats_init already computed that matrix independently and self-consistently under its own
7525 : ! label: there is nothing to reconstruct.
7526 : !
7527 : ! Earlier sessions gated this substitution behind an empirical "is a correction needed at
7528 : ! all" heuristic (g0-mismatch OR non-self-inverse-and-degenerate-bra), applying toinv(h_isym)
7529 : ! only when it fired and h_isym unmodified otherwise. That heuristic is UNNECESSARY: applying
7530 : ! dmats%for_spin(toinv(h_isym)) unconditionally (i.e. always, regardless of degeneracy or g0)
7531 : ! reproduces the exact same result on every point where the heuristic previously used
7532 : ! h_isym directly -- because on the reference test system, no such point exists: every
7533 : ! non-self-inverse h_isym already satisfied the heuristic's trigger condition. (For
7534 : ! self-inverse h_isym, toinv(1,h_isym)==h_isym, so the two forms are trivially identical
7535 : ! regardless.) Verified end-to-end against check_symm.py: byte-for-byte identical results to
7536 : ! the old conditional form -- 3584/3584 (100.0%) raw+gauge-invariant exact matches on
7537 : ! gstore_brange 1 4 (max diff 3.66e-7, noise level), 3533/3584 (98.6%) raw==gauge-invariant on
7538 : ! gstore_brange 1 2 (the residual there is the known, inherent out-of-range-degeneracy
7539 : ! limitation of truncating the band range, not a bug). See gstore_symmetrize_status memory
7540 : ! (sessions 14-15) for the full derivation history and this final unconditional-formula
7541 : ! confirmation.
7542 : ! TIME-REVERSAL generalization of itime_h (was hardcoded to 1, i.e. always the pure-spatial
7543 : ! D-matrix slice). The unitary/antiunitary character of a composed operator is a Z2
7544 : ! homomorphism (same rule dmats_check_one_k's group-multiplication test uses:
7545 : ! itime3 = 1 + mod((itime1-1)+(itime2-1), 2), Bradley & Cracknell sec. 7.3), extended here
7546 : ! by associativity to h's three-fold composition toinv(isym_kqT).isym_k.isym_kqS
7547 : ! (itime(A^{-1}) = itime(A), so toinv(isym_kqT) contributes trev_kqT unchanged). High
7548 : ! confidence, not yet empirically validated on a TR-nonzero system.
7549 0 : itime_h = 1 + mod(trev_k + trev_kqS + trev_kqT, 2)
7550 :
7551 : ! HYPOTHESIS (open question, validate empirically -- see gstore_symmetrize_status memory):
7552 : ! phase_h_gs's lattice-vector phase is built from dmats%multable/toinv, which are
7553 : ! itime-independent by construction, so its formula should carry over unchanged. But the
7554 : ! closest validated analogue, dmats_get_star_dmats (m_classify_bands.F90), needs an EXTRA
7555 : ! conjugation on its own analogous phase whenever itime==2. Applying the same pattern here
7556 : ! as a first hypothesis; h's composition shape differs from that routine's, so this is not
7557 : ! a proof, only a well-motivated starting point.
7558 0 : h_isym_inv = dmats%toinv(1, h_isym)
7559 0 : if (itime_h == 2) then
7560 0 : dh_mat = conjg(phase_h_gs) * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
7561 : else
7562 0 : dh_mat = phase_h_gs * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
7563 : end if
7564 :
7565 : ! HYPOTHESIS (open question, validate empirically): pulling D(h) through the outer operator
7566 : ! that maps ikq_ibz -> kq_bz_target picks up a conjugate exactly when that operator
7567 : ! (governed by isym_kqT/trev_kqT) is antiunitary -- a flag logically independent of trev_k
7568 : ! (see 2.4's gtmp conjugation below) and of itime_h (which only selects WHICH tabulated
7569 : ! matrix to read, not whether the whole assembled dh_mat needs conjugating on top).
7570 0 : if (trev_kqT == 1) dh_mat = conjg(dh_mat)
7571 :
7572 : if (DEBUG_DUMP_DH) then
7573 : write(789,'(7(i0,1x),2(es16.8,1x),9(i0,1x),6(es16.8,1x))') ik_glob, iq_glob, isym_k, h_isym, ikq_ibz_t, &
7574 : isym_kqS, isym_kqT, real(dh_mat(1,1)), aimag(dh_mat(1,1)), indkk_s(3:5,1), indkk_t(3:5,1), g0_k, &
7575 : qpt, kk_ibz
7576 : write(790,*) ik_glob, iq_glob, nb, isym_k, h_isym, ikq_ibz_t, isym_kqS, isym_kqT, g0_q, &
7577 : trev_k, trev_kqS, trev_kqT, itime_h, &
7578 : real(phase_h_gs), aimag(phase_h_gs), real(phase_ket_gs), aimag(phase_ket_gs), &
7579 : dmats%for_spin(spin)%value(:,:,h_isym,itime_h,ikq_ibz_t)
7580 : end if
7581 : ! -----------------------------------------------------------------
7582 :
7583 : ! Perform symmetrization.
7584 0 : do mu=1,gqk%natom3
7585 0 : idir = mod(mu-1, 3) + 1; iat = (mu - idir) / 3 + 1
7586 :
7587 0 : iat_eq = cryst%indsym(4, isym_combined, iat)
7588 0 : l0 = cryst%indsym(1:3, isym_combined, iat)
7589 0 : phase = -two_pi * dot_product(qbz(:, iq_sym), l0)
7590 0 : cphase = cmplx(cos(phase), sin(phase), dp)
7591 :
7592 : ! Per-mu atomic-mapping/phase diagnostic (iat_eq, l0, symrec_eq row, cphase, iq_sym):
7593 : ! reusable general-purpose dump, not tied to any specific (ik_glob,iq_glob) -- add a
7594 : ! filter here (e.g. "if (ik_glob==... .and. iq_glob==...)") when tracing one point on a
7595 : ! large system, to keep mu_debug.csv a manageable size.
7596 : if (DEBUG_DUMP_DH) then
7597 : write(792,*) ik_glob, iq_glob, mu, iat, iat_eq, isym_combined, isym_k, ik_ibz, iq_sym, &
7598 : l0, symrec_eq(idir,1), symrec_eq(idir,2), symrec_eq(idir,3), idir, ik_ibz_file, cphase
7599 : end if
7600 :
7601 : ! Apply the same geometric rotation (cphase/symrec_eq/dh_mat, all independent of which
7602 : ! gvals stream is being processed) to each stream separately, since gtmp's accumulation
7603 : ! reads actual matrix-element values from gkq_base.
7604 0 : do igv=1,n_gv
7605 0 : gtmp = zero
7606 0 : do idir_eq=1,3
7607 0 : mu_eq = idir_eq + (iat_eq - 1) * 3
7608 0 : gtmp = gtmp + cphase * symrec_eq(idir, idir_eq) * gkq_base(:,:,mu_eq,iq_sym,igv)
7609 : end do
7610 : ! HYPOTHESIS (open question, validate empirically): conjugate gtmp before the dh_mat
7611 : ! multiply whenever the ket leg's own operation (isym_k, trev_k) is antiunitary. Matches
7612 : ! the "rotate spatially first, conjugate as the last step" pattern used identically by
7613 : ! cgtk_rotate, pheigvec_rotate, rotate_fqg and dmats_init elsewhere in this codebase.
7614 : ! Order matters: conjugate gtmp itself, not matmul(dh_mat,gtmp), since dh_mat is complex.
7615 0 : if (trev_k == 1) gtmp = conjg(gtmp)
7616 : ! Apply the Bug A correction: left-multiply by D(h) on the bra (m) index.
7617 0 : gkq_rot(:,:,mu,iq_glob,igv) = matmul(dh_mat, gtmp)
7618 0 : if (DEBUG_DUMP_DH) write(791,*) ik_glob, iq_glob, mu, nb, trev_k, trim(gv_names(igv)), gtmp
7619 : end do
7620 : end do
7621 :
7622 : end do ! my_iq
7623 :
7624 : ! Write the newly computed g_{mn, nu} back to the netcdf file (in-place modification),
7625 : ! for each gvals stream, and update the entry in state_kq.
7626 0 : do igv=1,n_gv
7627 0 : call c_f_pointer(c_loc(gkq_rot(1,1,1,1,igv)), gkq_rot_ptr, [2, nb, nb, gqk%natom3, gqk%my_nq])
7628 : ncerr = nf90_put_var(spin_ncid, spin_vid(gv_names(igv)), gkq_rot_ptr, &
7629 : start=[1, 1, 1, 1, ik_glob, 1], &
7630 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7631 0 : NCF_CHECK(ncerr)
7632 : end do
7633 0 : state_kq(ik_glob, :) = GSTORE_KQ_SYMMETRIZED
7634 : end do ! my_ik
7635 : end associate
7636 :
7637 : ! Update state_kq for this spin.
7638 0 : ncerr = nf90_put_var(ncid, vid("gstore_glob_state_kqs"), state_kq, start=[1,1,spin])
7639 0 : NCF_CHECK(ncerr)
7640 :
7641 0 : ABI_FREE(qbz)
7642 0 : ABI_FREE(gkq_base)
7643 0 : ABI_FREE(gkq_rot)
7644 0 : ABI_FREE(state_kq)
7645 0 : ABI_FREE(gtmp)
7646 0 : ABI_FREE(dh_mat)
7647 0 : ABI_FREE(ket_mat)
7648 : end do ! my_is
7649 :
7650 0 : NCF_CHECK(nf90_close(ncid))
7651 : if (DEBUG_DUMP_DH) close(789)
7652 : if (DEBUG_DUMP_DH) close(790)
7653 : if (DEBUG_DUMP_DH) close(791)
7654 : if (DEBUG_DUMP_DH) close(792)
7655 :
7656 0 : ABI_FREE(kibz2bz)
7657 0 : call gstore%free()
7658 :
7659 0 : 100 call dmats%free()
7660 0 : call xmpi_barrier(comm)
7661 0 : call wrtout(units, " Symmetrization completed successfully.")
7662 :
7663 : contains
7664 0 : integer function vid(var_name)
7665 : character(len=*),intent(in) :: var_name
7666 0 : vid = nctk_idname(ncid, var_name)
7667 : end function vid
7668 :
7669 0 : integer function spin_vid(var_name)
7670 : character(len=*),intent(in) :: var_name
7671 0 : spin_vid = nctk_idname(spin_ncid, var_name)
7672 : end function spin_vid
7673 :
7674 : end subroutine gstore_symmetrize
7675 : !!***
7676 :
7677 78498 : end module m_gstore
7678 : !!***
|
