Branch data 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_prepare_mpiio ! Access all the variables of GSTORE.nc with all the procs that opened it.
674 : : public :: gstore_read_gtype ! Read the value of "gstore_gtype" from the NetCDF file.
675 : : public :: gstore_symmetrize ! Reconstruct the electron-phonon matrix elements g(k,q) in the full BZ.
676 : :
677 : : !----------------------------------------------------------------------
678 : :
679 : : contains
680 : : !!***
681 : :
682 : : !----------------------------------------------------------------------
683 : :
684 : : !!****f* m_gstore/gstore_init
685 : : !! NAME
686 : : !! gstore_init
687 : : !!
688 : : !! FUNCTION
689 : : !! Initialize the object
690 : : !!
691 : : !! INPUTS
692 : : !! path=Filename of the output GSTORE.nc file
693 : : !! with_cplex=Optional, only relevant when e-ph matrix elements are interpolated on the fly via
694 : : !! Wannier (i.e. getabiwan_filepath + getgwan_filepath are used): 0 to allocate no matrix
695 : : !! elements, 1 to store |g|^2, 2 to store the complex g. Default: 2. Ignored otherwise.
696 : : !!
697 : : !! SOURCE
698 : :
699 : 8 : subroutine gstore_init(gstore, path, dtset, dtfil, wfk0_hdr, cryst, ebands, ifc, comm, &
700 : : gtype, with_cplex) ! optional
701 : :
702 : : !Arguments ------------------------------------
703 : : !scalars
704 : : class(gstore_t),target,intent(out) :: gstore
705 : : character(len=*),intent(in) :: path
706 : : type(dataset_type),target,intent(in) :: dtset
707 : : type(datafiles_type),intent(in) :: dtfil
708 : : type(hdr_type),intent(in) :: wfk0_hdr
709 : : class(crystal_t),target,intent(in) :: cryst
710 : : class(ebands_t),target,intent(in) :: ebands
711 : : class(ifc_type),target,intent(in) :: ifc
712 : : integer,intent(in) :: comm
713 : : character(len=*),optional,intent(in) :: gtype
714 : : integer,optional,intent(in) :: with_cplex
715 : :
716 : : !Local variables-------------------------------
717 : : !scalars
718 : : integer,parameter :: master = 0, gstore_has_ifcs = 1
719 : : integer :: all_nproc, my_rank, ierr, my_nshiftq, nsppol, spin, natom3, cnt, timrev_q, gqk_cplex
720 : : integer :: ik_ibz, ik_bz, iq_bz, iq_ibz, max_nq, max_nk, ncid, spin_ncid, ncerr, gstore_fform
721 : : integer :: gap_err, nkcalc
722 : : logical :: keep_umats, has_abiwan, has_gwan, write_gstore, has_both_g
723 : : real(dp) :: cpu, wall, gflops, gstore_fill_dp
724 : : character(len=5000) :: msg
725 : 8 : type(gaps_t) :: gaps
726 : : !arrays
727 : : integer :: ngqpt(3), qptrlatt(3,3), intp_kptrlatt(3,3)
728 : 24 : integer :: comm_spin(ebands%nsppol), nproc_spin(ebands%nsppol), units(2)
729 : : integer :: gstore_brange_kq(2, 2), gstore_brange_k(2, 2)
730 : 8 : integer,allocatable :: qbz2ibz(:,:), kibz2bz(:), qibz2bz(:), qglob2bz(:,:)
731 : 8 : integer,allocatable :: bstart_ks(:,:), nbcalc_ks(:,:), select_qbz_spin(:,:), select_kbz_spin(:,:)
732 : 8 : real(dp),allocatable :: kcalc(:,:)
733 : : real(dp):: my_shiftq(3,1)
734 [ + - ]: 8 : real(dp),allocatable :: wtk(:), kibz(:,:)
735 [ + + + + : 304 : type(wan_t),target :: wan_spin(ebands%nsppol)
+ + + + +
- - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + + +
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - ]
736 : : !----------------------------------------------------------------------
737 : :
738 : 8 : call cwtime(cpu, wall, gflops, "start")
739 : 8 : all_nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
740 : 8 : natom3 = 3 * cryst%natom; nsppol = ebands%nsppol
741 [ + + ]: 24 : units = [std_out, ab_out]
742 : :
743 : 8 : call wrtout(std_out, " gstore_init: initialize gstore_t instance...")
744 : 8 : call pstat_proc%print(_PSTAT_ARGS_)
745 : :
746 : : ! Set basic parameters.
747 [ - + ]: 8 : gstore%comm = comm; gstore%nsppol = nsppol; gstore%path = path
748 [ + + - + ]: 8 : if (present(gtype)) gstore%gtype = gtype
749 [ + + - + ]: 8 : ABI_CHECK(gstore%gtype == GSTORE_GTYPE_KS .or. gstore%gtype == GSTORE_GTYPE_GWPT, sjoin("Invalid gstore gtype:", gstore%gtype))
750 : :
751 : 8 : has_both_g = gstore%gtype == GSTORE_GTYPE_GWPT
752 : :
753 : : ! Get references to other data structures.
754 : 8 : gstore%dtset => dtset; gstore%cryst => cryst; gstore%ebands => ebands; gstore%ifc => ifc
755 : 8 : gstore%has_wannier = .False.
756 : :
757 : : ! Handle possible wannierization.
758 : 8 : has_abiwan = .False.; has_gwan = .False.; keep_umats = .False.
759 [ - + ]: 8 : if (dtfil%filabiwanin /= ABI_NOFILE) then
760 : 0 : has_abiwan = .True.
761 : 0 : call wrtout(units, sjoin(" Reading set of bands to be included in gstore computation from ABIWAN file:", dtfil%filabiwanin))
762 [ # # ]: 0 : do spin=1,ebands%nsppol
763 : 0 : call wan_spin(spin)%from_abiwan(dtfil%filabiwanin, spin, ebands%nsppol, keep_umats, dtfil%filnam_ds(4), comm)
764 : 0 : call wan_spin(spin)%print(units)
765 : : end do
766 [ # # ]: 0 : if (dtfil%filgwanin /= ABI_NOFILE) then
767 : 0 : has_gwan = .True.
768 [ # # # # : 0 : ABI_CHECK(all(dtset%eph_ngkpt_fine > 0), "eph_ngkpt_fine must contain three positive integers when GWAN is used")
# # ]
769 [ # # ]: 0 : ABI_CHECK(allocated(dtset%eph_shiftk_fine), "eph_shiftk_fine is not allocated")
770 [ # # ]: 0 : ABI_CHECK(size(dtset%eph_shiftk_fine, dim=2) == dtset%eph_nshiftk_fine, "Inconsistent eph_nshiftk_fine and eph_shiftk_fine")
771 : 0 : call kptrlatt_from_ngkpt(dtset%eph_ngkpt_fine, intp_kptrlatt)
772 : :
773 : 0 : nullify(gstore%ebands)
774 [ # # ]: 0 : ABI_MALLOC_SCALAR(gstore%ebands)
775 : : call wan_interp_ebands(wan_spin, cryst, ebands, intp_kptrlatt, dtset%eph_nshiftk_fine, &
776 : 0 : dtset%eph_shiftk_fine, gstore%ebands, comm)
777 : 0 : gstore%has_wannier = .True.
778 : : end if
779 : : end if
780 : :
781 : : ! Set metadata and set initial value of kfilter from dtset.
782 : 8 : gstore%kibz => gstore%ebands%kptns
783 : 8 : gstore%kzone = dtset%gstore_kzone; gstore%qzone = dtset%gstore_qzone; gstore%kfilter = dtset%gstore_kfilter
784 : 8 : gstore%with_vk = dtset%gstore_with_vk; gstore%gmode = GSTORE_GMODE_ATOM
785 : :
786 [ - + + - : 48 : ABI_CALLOC(gstore%erange_spin, (2, nsppol))
+ - + - -
+ - + - +
+ + + + ]
787 [ - + + + : 40 : gstore%erange_spin = dtset%gstore_erange(:, 1:nsppol)
+ + ]
788 : :
789 [ + + + + : 30 : if (any(gstore%erange_spin /= zero)) then
+ + + + ]
790 [ - + ]: 1 : ABI_CHECK(gstore%kfilter == "none", sjoin("kfilter should be none when erange is used while it is:", gstore%kfilter))
791 : 1 : gstore%kfilter = "erange"
792 : : end if
793 : :
794 [ + + - + ]: 8 : if (gstore%kzone == "ibz" .and. gstore%qzone == "ibz") then
795 : 0 : ABI_ERROR("The combination kzone: 'ibz' and qzone: 'ibz' is not allowed!")
796 : : end if
797 : :
798 : : ! TODO
799 : : !gstore%kptrlatt(3, 3); gstore%kshift(3, 1); gstore%qptrlatt(3, 3); gstore%qshift(3, 1)
800 : :
801 : : ! Distribute spins, create indirect mapping to spin index and init %brange_k_spin from dtset
802 : : ! TODO Should I introduce dtset%gstore_brange_kq or compute it automatically
803 [ + - ]: 8 : if (.not. has_gwan) then
804 [ - + ]: 8 : ABI_CHECK_ILEQ(dtset%mband, gstore%ebands%mband, "dtset%mband > ebands%mband")
805 : : end if
806 : :
807 [ + + + + ]: 56 : gstore_brange_k = dtset%gstore_brange
808 [ + + + + ]: 56 : gstore_brange_kq = dtset%gstore_brange
809 : :
810 [ + + ]: 8 : if (gstore%kfilter == "qprange") then
811 : : ! Assume ZPR calculations requiring virtual k+q transitions from 1 up to nband unless gstore_brange is given.
812 [ + + + + : 28 : if (all(gstore_brange_kq == 0)) then
+ - + - ]
813 [ + + ]: 12 : gstore_brange_kq(:,1) = [1, dtset%mband]
814 [ + + ]: 12 : gstore_brange_kq(:,2) = [1, dtset%mband]
815 : : end if
816 : :
817 : : ! The same set of calls is found in gstore_filter_gw_qprange__
818 : : ! The main difference is that here we set the bands while gstore_filter_gw_qprange__ sets the the k-points.
819 [ - + - + : 4 : gaps = gstore%ebands%get_gaps(gap_err)
- + - + -
+ - + - +
- + ]
820 : :
821 : : ! Compute nkcalc, kcalc, bstart_ks, nbcalc_ks
822 [ - + ]: 4 : if (dtset%gw_qprange /= 0) then
823 [ # # # # : 0 : call sigtk_kcalc_from_qprange(dtset, gstore%cryst, gstore%ebands, dtset%gw_qprange, nkcalc, kcalc, bstart_ks, nbcalc_ks)
# # ]
824 : :
825 : : else
826 : : ! gw_qprange is not specified in the input.
827 : : ! Include direct and fundamental KS gap or include states depending on the position wrt band edges.
828 [ - + - + : 4 : call sigtk_kcalc_from_gaps(dtset, gstore%ebands, gaps, nkcalc, kcalc, bstart_ks, nbcalc_ks)
- + ]
829 : : end if
830 : :
831 : : ! Convert to stop values
832 [ + - + - : 18 : nbcalc_ks = bstart_ks + nbcalc_ks - 1
- + - - +
+ + + ]
833 : :
834 : : ! Set brange_k
835 : : ! FIXME: Handle degeneracies
836 [ + + ]: 8 : do spin=1,nsppol
837 [ + + ]: 10 : gstore_brange_k(1, spin) = minval(bstart_ks(1:nkcalc, spin))
838 [ + + ]: 14 : gstore_brange_k(2, spin) = maxval(nbcalc_ks(1:nkcalc, spin))
839 : : end do
840 : :
841 [ - + ]: 4 : ABI_FREE(kcalc)
842 [ - + ]: 4 : ABI_FREE(bstart_ks)
843 [ - + ]: 4 : ABI_FREE(nbcalc_ks)
844 : 4 : call gaps%free()
845 : : end if
846 : :
847 [ - + ]: 8 : if (dtset%nkptgw /= 0) then
848 : : ! Allow user to specify k-points with kptgw and bdgw.
849 : :
850 [ # # ]: 0 : if (gstore%kfilter /= "none") then
851 : 0 : ABI_ERROR("gstore_kfilter and nkptgw != 0 cannot be used together!")
852 : : end if
853 : :
854 : : ! Assume ZPR calculations requiring virtual k+q transitions from 1 up to nband unless gstore_brange is given.
855 [ # # # # ]: 0 : gstore_brange_kq = dtset%gstore_brange
856 [ # # # # : 0 : if (all(gstore_brange_kq == 0)) then
# # # # ]
857 [ # # ]: 0 : gstore_brange_kq(:,1) = [1, dtset%mband]
858 [ # # ]: 0 : gstore_brange_kq(:,2) = [1, dtset%mband]
859 : : end if
860 : :
861 [ # # # # : 0 : call sigtk_kcalc_from_nkptgw(dtset, dtset%mband, nkcalc, kcalc, bstart_ks, nbcalc_ks)
# # ]
862 : :
863 : : ! Convert to stop values
864 [ # # # # : 0 : nbcalc_ks = bstart_ks + nbcalc_ks - 1
# # # # #
# # # ]
865 : :
866 : : ! Set brange_k
867 : : ! FIXME: Handle degeneracies
868 [ # # ]: 0 : do spin=1,nsppol
869 [ # # ]: 0 : gstore_brange_k(1, spin) = minval(bstart_ks(1:nkcalc, spin))
870 [ # # ]: 0 : gstore_brange_k(2, spin) = maxval(nbcalc_ks(1:nkcalc, spin))
871 : : end do
872 : :
873 [ # # ]: 0 : ABI_FREE(kcalc)
874 [ # # ]: 0 : ABI_FREE(bstart_ks)
875 [ # # ]: 0 : ABI_FREE(nbcalc_ks)
876 : : end if
877 : :
878 [ - + ]: 8 : if (has_gwan) then
879 : : ! Interpolated e-ph matrix elements are Wannier-gauge quantities (nwan x nwan,
880 : : ! obtained by diagonalizing the interpolated H(k)), not literal DFT band indices,
881 : : ! so nb_k/nb_kq must be set to nwan exactly -- NOT to the (possibly larger)
882 : : ! disentanglement outer window [bmin, bmax] -- so that the results returned by
883 : : ! wan%interp_eph_manyq (shape (nwan, nwan, my_npert, nq)) fit gqk%my_g exactly,
884 : : ! for both the disentangled and disentanglement-free cases.
885 [ # # ]: 0 : do spin=1,gstore%nsppol
886 [ # # ]: 0 : gstore_brange_k(:, spin) = [1, wan_spin(spin)%nwan]
887 [ # # ]: 0 : gstore_brange_kq(:, spin) = [1, wan_spin(spin)%nwan]
888 : : end do
889 [ - + ]: 8 : else if (has_abiwan) then
890 : : ! Here we set brange_k_spin to be consistent with the wannierization step.
891 [ # # ]: 0 : do spin=1,gstore%nsppol
892 [ # # ]: 0 : gstore_brange_k(:, spin) = [wan_spin(spin)%bmin, wan_spin(spin)%bmax]
893 [ # # ]: 0 : gstore_brange_kq(:, spin) = [wan_spin(spin)%bmin, wan_spin(spin)%bmax]
894 : : end do
895 : : end if
896 : :
897 : 8 : call gstore%distribute_spins__(gstore%ebands%mband, gstore_brange_kq, gstore_brange_k, nproc_spin, comm_spin, comm)
898 : :
899 : : ! Free wan_spin
900 [ + + ]: 16 : do spin=1,ebands%nsppol
901 : 16 : call wan_spin(spin)%free()
902 : : end do
903 : :
904 : : ! Define q-mesh: either from DVDB (no interpolation) or eph_ngqpt_fine (Fourier interpolation)
905 : : ! Save it in gstore for future reference.
906 [ + + + + ]: 56 : ngqpt = dtset%ddb_ngqpt; my_nshiftq = 1; my_shiftq(:,1) = dtset%ddb_shiftq
907 [ + + + + : 23 : if (all(dtset%eph_ngqpt_fine /= 0)) then
+ + ]
908 [ + + ]: 20 : ngqpt = dtset%eph_ngqpt_fine; my_shiftq = 0
909 : : end if
910 [ + + ]: 32 : gstore%ngqpt(:) = ngqpt(:)
911 : :
912 : : ! TODO: Should fix bz2ibz to use the same conventions as krank and listkk
913 : : ! NB: only sigmaph seems to be using this optional argument
914 : :
915 : : ! Setup qIBZ, weights and BZ.
916 : : ! Assume qptopt == kptopt unless value is specified in input
917 : 8 : qptrlatt = 0; qptrlatt(1, 1) = ngqpt(1); qptrlatt(2, 2) = ngqpt(2); qptrlatt(3, 3) = ngqpt(3)
918 [ - + ]: 8 : gstore%qptopt = gstore%ebands%kptopt; if (dtset%qptopt /= 0) gstore%qptopt = dtset%qptopt
919 : : timrev_q = kpts_timrev_from_kptopt(gstore%qptopt)
920 : :
921 : 8 : call wrtout(std_out, sjoin(" Generating q-mesh with ngqpt:", ltoa(ngqpt), " and qptopt:", itoa(gstore%qptopt)))
922 : : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, gstore%qptopt, my_nshiftq, my_shiftq, &
923 [ - + - + : 8 : gstore%nqibz, gstore%qibz, gstore%wtq, gstore%nqbz, gstore%qbz)
- + ]
924 : : !new_kptrlatt=gstore%qptrlatt, new_shiftk=gstore%qshift,
925 : : !bz2ibz=new%ind_qbz2ibz) # FIXME
926 : :
927 : : ! HM: the bz2ibz produced above is incomplete, I do it here using listkk
928 [ - + + - : 24 : ABI_MALLOC(qbz2ibz, (6, gstore%nqbz))
+ - + - -
+ - + -
+ ]
929 : 8 : call gstore%qrank_ibz%from_kptrlatt(gstore%nqibz, gstore%qibz, qptrlatt, compute_invrank=.False.)
930 : :
931 [ - + ]: 8 : if (kpts_map("symrec", gstore%qptopt, cryst, gstore%qrank_ibz, gstore%nqbz, gstore%qbz, qbz2ibz) /= 0) then
932 : 0 : ABI_ERROR("Cannot map qBZ to IBZ!")
933 : : end if
934 : :
935 : : ! Order qbz by stars and rearrange entries in qbz2ibz table.
936 : 8 : call kpts_pack_in_stars(gstore%nqbz, gstore%qbz, qbz2ibz)
937 : :
938 : : !call kpts_print_kmap(std_out, qibz, gstore%qbz, qbz2ibz)
939 : : !do iq_bz=1,gstore%nqbz
940 : : ! print *, "iq_bz -> iq_ibz", qbz2ibz(1, iq_bz), gstore%qbz(:, iq_bz)
941 : : !end do
942 : :
943 [ - + ]: 8 : call get_ibz2bz(gstore%nqibz, gstore%nqbz, qbz2ibz, qibz2bz, msg, ierr)
944 [ - + ]: 8 : ABI_CHECK(ierr == 0, sjoin("Something wrong in symmetry tables for q-points!", ch10, msg))
945 : :
946 : : ! Get full BZ associated to ebands
947 : 8 : call wrtout(std_out, sjoin(" Generating k-mesh with ngkpt:", ltoa(get_diag(gstore%ebands%kptrlatt)), " and kptopt:", itoa(gstore%ebands%kptopt)))
948 : : call kpts_ibz_from_kptrlatt(cryst, gstore%ebands%kptrlatt, gstore%ebands%kptopt, gstore%ebands%nshiftk, gstore%ebands%shiftk, &
949 [ - + - + : 8 : gstore%nkibz, kibz, wtk, gstore%nkbz, gstore%kbz) !, bz2ibz=bz2ibz)
- + ]
950 : : !new_kptrlatt=gstore%kptrlatt, new_shiftk=gstore%kshift,
951 : : !bz2ibz=new%ind_qbz2ibz) # FIXME
952 : :
953 : : ! In principle kibz should be equal to ebands%kptns
954 [ - + ]: 8 : ABI_CHECK(gstore%nkibz == gstore%ebands%nkpt, "nkibz != ebands%nkpt")
955 [ + + + + : 540 : ABI_CHECK(all(abs(gstore%kibz - kibz) < tol12), "ebands%kibz != kibz")
+ - - + ]
956 [ - + ]: 8 : ABI_FREE(kibz)
957 : :
958 : : ! Note symrel and use_symrec=.False. in get_mapping.
959 : : ! This means that this table can be used to symmetrize wavefunctions in cgtk_rotate.
960 : : ! TODO This ambiguity should be removed. Change cgtk_rotate so that we can use the symrec convention.
961 : :
962 [ - + + - : 24 : ABI_MALLOC(gstore%kbz2ibz, (6, gstore%nkbz))
+ - + - -
+ - + -
+ ]
963 [ + - - - : 8 : call gstore%krank_ibz%from_kptrlatt(gstore%nkibz, gstore%kibz, gstore%ebands%kptrlatt, compute_invrank=.False.)
- - - - -
+ ]
964 [ - + ]: 8 : if (kpts_map("symrel", gstore%ebands%kptopt, cryst, gstore%krank_ibz, gstore%nkbz, gstore%kbz, gstore%kbz2ibz) /= 0) then
965 : 0 : ABI_ERROR("Cannot map kBZ to IBZ!")
966 : : end if
967 : :
968 : : ! TODO:
969 : : ! Order kbz by stars and rearrange entries in kbz2ibz table.
970 : : !call kpts_pack_in_stars(gstore%nkbz, kbz, gstore%kbz2ibz)
971 : :
972 [ - + ]: 8 : call get_ibz2bz(gstore%nkibz, gstore%nkbz, gstore%kbz2ibz, kibz2bz, msg, ierr)
973 [ - + ]: 8 : ABI_CHECK(ierr == 0, sjoin("Something wrong in symmetry tables for k-points", ch10, msg))
974 : :
975 : : ! These tables are used to exclude q/k points.
976 : : ! We use the full BZ because this mask can be also used when points are restricted to the IBZ
977 : : ! provided we convert from ik_ibz to ik_bz. Note that both arrays are initialized with zeros.
978 [ - + + - : 2597 : ABI_ICALLOC(select_qbz_spin, (gstore%nqbz, nsppol))
- + + - +
- + - - +
- + + + +
+ ]
979 [ - + + - : 2597 : ABI_ICALLOC(select_kbz_spin, (gstore%nkbz, nsppol))
- + + - +
- + - - +
- + + + +
+ ]
980 : :
981 : 4 : select case (gstore%kzone)
982 : : case ("ibz")
983 [ + + ]: 8 : do spin=1,nsppol
984 [ + + ]: 35 : do ik_ibz=1,gstore%nkibz
985 : 31 : ik_bz = kibz2bz(ik_ibz); select_kbz_spin(ik_bz, spin) = 1
986 : : end do
987 : : end do
988 : :
989 : : case ("bz")
990 [ + + + + ]: 2421 : select_kbz_spin = 1
991 : :
992 : : case default
993 [ + + - ]: 8 : ABI_ERROR(sjoin("Invalid kzone:", gstore%kzone))
994 : : end select
995 : :
996 : 8 : select case (gstore%qzone)
997 : : case ("ibz")
998 [ # # ]: 0 : do spin=1,nsppol
999 [ # # ]: 0 : do iq_ibz=1, gstore%nqibz
1000 : 0 : iq_bz = qibz2bz(iq_ibz); select_qbz_spin(iq_bz, spin) = 1
1001 : : end do
1002 : : end do
1003 : :
1004 : : case ("bz")
1005 [ + + + + ]: 2573 : select_qbz_spin = 1
1006 : :
1007 : : case default
1008 [ - + - ]: 8 : ABI_ERROR(sjoin("Invalid qzone:", gstore%qzone))
1009 : : end select
1010 : :
1011 : : ! Here we filter the electronic wavevectors k and recompute select_qbz_spin and select_kbz_spin according to kfilter.
1012 : 11 : select case (gstore%kfilter)
1013 : : case ("none")
1014 [ - + ]: 3 : if (dtset%nkptgw /= 0) then
1015 : : ! Use kptgw input variable. Useful for ZPR for user-specified k-points.
1016 : 0 : call gstore%filter_kptgw__(dtset, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
1017 : : end if
1018 : :
1019 : : case ("erange")
1020 : : ! Use energy range: transport in semiconductors/metals or superconducting propertiea.
1021 : 1 : call gstore%filter_erange__(qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
1022 : :
1023 : : case ("qprange")
1024 : : ! Use gw_qprange input variable. Useful for ZPR
1025 : 4 : call gstore%filter_gw_qprange__(dtset, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
1026 : :
1027 : : case ("fs_tetra")
1028 : : ! Use the tetrahedron method to filter k- and k+q points on the FS in metals
1029 : : ! and define gstore%brange_k_spin automatically.
1030 : : ! Useful for transport in metals or superconducting propertiea.
1031 : 0 : call gstore%filter_fs_tetra__(qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
1032 : :
1033 : : case default
1034 [ + + + - : 8 : ABI_ERROR(sjoin("Invalid gstore%kfilter:", gstore%kfilter))
- ]
1035 : : end select
1036 : :
1037 : : ! Total number of k/q points for each spin after filtering (if any)
1038 [ - + + - : 24 : ABI_MALLOC(gstore%glob_nk_spin, (nsppol))
+ - + - -
+ - + -
+ ]
1039 [ - + + - : 16 : ABI_MALLOC(gstore%glob_nq_spin, (nsppol))
- + - + -
+ ]
1040 [ + - + + : 2581 : gstore%glob_nk_spin(:) = count(select_kbz_spin > 0, dim=1)
+ + + + ]
1041 [ + - + + : 2581 : gstore%glob_nq_spin(:) = count(select_qbz_spin > 0, dim=1)
+ + + + ]
1042 : :
1043 : : ! We need another table mapping the global index in the gqk matrix to the q/k index in the BZ
1044 : : ! so that one can extract the symmetry tables computed above.
1045 : : ! Again this is needed as the global sizes of the gqk matrix
1046 : : ! is not necessarily equal to the size of the BZ/IBZ if we have filtered the wave vectors.
1047 : :
1048 [ + + ]: 16 : max_nq = maxval(gstore%glob_nq_spin) ! Max dim over spin
1049 [ + + ]: 16 : max_nk = maxval(gstore%glob_nk_spin)
1050 [ - + + - : 997 : ABI_ICALLOC(qglob2bz, (max_nq, nsppol))
- + + - +
- + - - +
- + - + +
+ + + ]
1051 [ - + + - : 351 : ABI_ICALLOC(gstore%kglob2bz, (max_nk, nsppol))
- + + - +
- + - - +
- + - + +
+ + + ]
1052 : :
1053 [ + + ]: 16 : do spin=1,nsppol
1054 : 8 : cnt = 0
1055 [ + + ]: 2565 : do iq_bz=1,gstore%nqbz
1056 [ + + ]: 2565 : if (select_qbz_spin(iq_bz, spin) /= 0) then
1057 : 957 : cnt = cnt + 1; qglob2bz(cnt, spin) = iq_bz
1058 : : end if
1059 : : end do
1060 : :
1061 : 8 : cnt = 0
1062 [ + + ]: 2573 : do ik_bz=1,gstore%nkbz
1063 [ + + ]: 2565 : if (select_kbz_spin(ik_bz, spin) /= 0) then
1064 : 311 : cnt = cnt + 1; gstore%kglob2bz(cnt, spin) = ik_bz
1065 : : end if
1066 : : end do
1067 : : end do
1068 : :
1069 : : ! =============================================
1070 : : ! Initialize gqk basic dimensions and MPI grid
1071 : : ! =============================================
1072 : 8 : call gstore%set_mpi_grid__(dtfil, nproc_spin, comm_spin)
1073 : 8 : call xmpi_comm_free(comm_spin)
1074 : :
1075 : : ! At this point, we have the Cartesian grid (one per spin if any),
1076 : : ! and we can finally allocate and distribute other arrays.
1077 : : ! Note gqk_cplex = 0 --> matrix elements are not allocated here.
1078 : 8 : gqk_cplex = 0
1079 [ - + ]: 8 : if (has_gwan) then
1080 : 0 : gqk_cplex = 2
1081 [ # # ]: 0 : if (present(with_cplex)) gqk_cplex = with_cplex
1082 : : end if
1083 [ - + ]: 8 : ABI_CHECK(gqk_cplex >= 0 .and. gqk_cplex <= 2, sjoin("Invalid with_cplex:", itoa(gqk_cplex)))
1084 : 8 : gstore%with_cplex = gqk_cplex
1085 : 8 : call gstore%malloc__(gqk_cplex, has_both_g, max_nq, qglob2bz, max_nk, gstore%kglob2bz, qbz2ibz, gstore%kbz2ibz)
1086 : :
1087 : : ! In GWPT, the states at k must be within the sum over n' (nband). Check it before writing the file:
1088 : : ! without nkptgw or gstore_brange the band range at k is all the bands of the WFK file, and the file can be huge.
1089 [ + + ]: 8 : if (gstore%gtype == GSTORE_GTYPE_GWPT) then
1090 [ + + ]: 6 : do spin=1,nsppol
1091 [ - + ]: 6 : ABI_CHECK_ILEQ(gstore%brange_k_spin(2, spin), dtset%mband, "GWPT: the band range at k must be within nband (sum over n')")
1092 : : end do
1093 : : end if
1094 : :
1095 : : ! Initialize GSTORE.nc file i.e. define dimensions and arrays
1096 : : ! Entries such as the e-ph matrix elements will be filled afterwards in gstore_compute.
1097 : : ! Master node defines dimensions and variables.
1098 : :
1099 : 8 : write_gstore = .True.
1100 [ - + ]: 8 : if (has_gwan) write_gstore = .False.
1101 : :
1102 [ + - ]: 8 : if (my_rank == master .and. write_gstore) then
1103 [ - + ]: 8 : NCF_CHECK(nctk_open_create(ncid, gstore%path, xmpi_comm_self))
1104 : :
1105 : : ! Write the abinit header with metadata, structure and occupancies.
1106 : 8 : gstore_fform = fform_from_ext("GSTORE.nc")
1107 [ - + ]: 8 : NCF_CHECK(wfk0_hdr%ncwrite(ncid, gstore_fform, spinat=dtset%spinat, nc_define=.True.))
1108 : :
1109 : : ! Add crystalline structure.
1110 [ - + ]: 8 : NCF_CHECK(gstore%cryst%ncwrite(ncid))
1111 : : ! Add eigenvalues and occupations.
1112 [ - + ]: 8 : NCF_CHECK(gstore%ebands%ncwrite(ncid))
1113 : :
1114 : : ! Write gstore dimensions
1115 : : ncerr = nctk_def_dims(ncid, [ &
1116 : : nctkdim_t("gstore_nkibz", gstore%nkibz), &
1117 : : nctkdim_t("gstore_nkbz", gstore%nkbz), &
1118 : : nctkdim_t("gstore_nqibz", gstore%nqibz), &
1119 : : nctkdim_t("gstore_nqbz", gstore%nqbz), &
1120 : : nctkdim_t("gstore_max_nq", max_nq), &
1121 : : nctkdim_t("gstore_max_nk", max_nk), &
1122 : : nctkdim_t("gstore_max_nb", maxval(gstore%brange_k_spin(2, :) - gstore%brange_k_spin(1, :) + 1) ), &
1123 : : nctkdim_t("nrpt", ifc%nrpt), &
1124 : : nctkdim_t("natom", gstore%cryst%natom), &
1125 : : nctkdim_t("natom3", 3 * gstore%cryst%natom), &
1126 : : nctkdim_t("gstore_cplex", 2), &
1127 : : nctkdim_t("ifc_nqbz", ifc%nqbz) &
1128 [ + + + + ]: 112 : ], defmode=.True.)
1129 [ - + ]: 8 : NCF_CHECK(ncerr)
1130 : :
1131 : : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: &
1132 : : "gstore_with_vk", "gstore_qptopt", "gstore_completed", &
1133 : : "gstore_use_lgk", "gstore_use_lgq", "gstore_has_ifcs", "gwpt_wmode", "used_ftinterp", "gwcomp" &
1134 [ + + ]: 80 : ])
1135 [ - + ]: 8 : NCF_CHECK(ncerr)
1136 : : ncerr = nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: &
1137 : : "ifc_eta" &
1138 [ + + ]: 16 : ])
1139 [ - + ]: 8 : NCF_CHECK(ncerr)
1140 : :
1141 : : ncerr = nctk_def_arrays(ncid, [ &
1142 : : nctkarr_t("gstore_qibz", "dp", "three, gstore_nqibz"), &
1143 : : nctkarr_t("gstore_qbz", "dp", "three, gstore_nqbz"), &
1144 : : nctkarr_t("gstore_wtq", "dp", "gstore_nqibz"), &
1145 : : nctkarr_t("gstore_kbz", "dp", "three, gstore_nkbz"), &
1146 : : nctkarr_t("gstore_kzone", "c", "character_string_length"), &
1147 : : nctkarr_t("gstore_qzone", "c", "character_string_length"), &
1148 : : nctkarr_t("gstore_kfilter", "c", "character_string_length"), &
1149 : : nctkarr_t("gstore_gmode", "c", "character_string_length"), &
1150 : : nctkarr_t("gstore_gtype", "c", "character_string_length"), &
1151 : : nctkarr_t("gstore_wfk0_path", "c", "fnlen"), &
1152 : : nctkarr_t("gstore_brange_k_spin", "i", "two, number_of_spins"), &
1153 : : nctkarr_t("gstore_brange_kq_spin", "i", "two, number_of_spins"), &
1154 : : nctkarr_t("gstore_erange_spin", "dp", "two, number_of_spins"), &
1155 : : nctkarr_t("gstore_ngqpt", "i", "three"), &
1156 : : nctkarr_t("phfreqs_ibz", "dp", "natom3, gstore_nqibz"), &
1157 : : nctkarr_t("pheigvec_cart_ibz", "dp", "two, three, natom, natom3, gstore_nqibz"), &
1158 : : nctkarr_t("gstore_glob_nq_spin", "i", "number_of_spins"), &
1159 : : nctkarr_t("gstore_glob_nk_spin", "i", "number_of_spins"), &
1160 : : nctkarr_t("gstore_done_qbz_spin", "i", "gstore_nqbz, number_of_spins"), &
1161 : : nctkarr_t("gstore_kbz2ibz", "i", "six, gstore_nkbz"), &
1162 : : nctkarr_t("gstore_qbz2ibz", "i", "six, gstore_nqbz"), &
1163 : : nctkarr_t("gstore_qglob2bz", "i", "gstore_max_nq, number_of_spins"), &
1164 : : nctkarr_t("gstore_kglob2bz", "i", "gstore_max_nk, number_of_spins"), &
1165 : : ! Table with status of (k, q, spin) entry, used to symmetrize matrix-elements.
1166 : : nctkarr_t("gstore_glob_state_kqs", "i", "gstore_max_nk, gstore_max_nq, number_of_spins"), &
1167 : : !
1168 : : ! These quantities are needed to interface GSTORE.nc with external codes.
1169 : : ! For the meaning of the different variables and conventions see m_ifc module.
1170 : : nctkarr_t("ifc_dielt", "dp", "three, three"), &
1171 : : nctkarr_t("ifc_zeff", "dp", "three, three, number_of_atoms"), &
1172 : : nctkarr_t("ifc_qdrp_cart", "dp", "three, three, three, number_of_atoms") &
1173 [ + + ]: 224 : ])
1174 [ - + ]: 8 : NCF_CHECK(ncerr)
1175 : :
1176 : : if (gstore_has_ifcs /= 0) then
1177 : : ! Define arrays for IFCs.
1178 : : ! For the meaning of the different variables and conventions see m_ifc module.
1179 : : ncerr = nctk_def_arrays(ncid, [ &
1180 : : nctkarr_t("ifc_rpt", "dp", "three, nrpt"), &
1181 : : nctkarr_t("ifc_wghatm", "dp", "natom, natom, nrpt"), &
1182 : : nctkarr_t("ifc_dynmat", "dp", "two, three, natom, three, natom, ifc_nqbz"), &
1183 : : nctkarr_t("ifc_short_atmfrc", "dp", "three, natom, three, natom, nrpt") &
1184 [ + + ]: 40 : ])
1185 [ - + ]: 8 : NCF_CHECK(ncerr)
1186 : : end if
1187 : :
1188 : : ! Internal table used to restart computation. Initialized with zeros.
1189 : : ! 0 --> (ib_bz, spin) has not been computed.
1190 : : ! 1 --> (iq_bz, spin) has been computed.
1191 : : ! In order to check if the whole generation is completed, one should test if "gstore_completed" == 1
1192 [ - + ]: 8 : NCF_CHECK(nf90_def_var_fill(ncid, vid("gstore_done_qbz_spin"), NF90_FILL, 0))
1193 : :
1194 [ - + ]: 8 : NCF_CHECK(nf90_def_var_fill(ncid, vid("gstore_glob_state_kqs"), NF90_FILL, GSTORE_KQ_MISSING))
1195 : :
1196 : : ! Optional arrays
1197 [ - + ]: 8 : if (allocated(gstore%delta_ef_kibz_spin)) then
1198 : : ncerr = nctk_def_arrays(ncid, &
1199 : 0 : nctkarr_t("gstore_delta_ef_kibz_spin", "dp", "gstore_max_nb, gstore_nkibz, number_of_spins"))
1200 : : end if
1201 [ - + ]: 8 : NCF_CHECK(ncerr)
1202 : :
1203 : : ! Write data
1204 [ - + ]: 8 : NCF_CHECK(nctk_set_datamode(ncid))
1205 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_with_vk"), gstore%with_vk))
1206 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qptopt"), gstore%qptopt))
1207 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_use_lgk"), dtset%gstore_use_lgk))
1208 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_use_lgq"), dtset%gstore_use_lgq))
1209 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_has_ifcs"), gstore_has_ifcs))
1210 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gwpt_wmode"), dtset%gwpt_wmode))
1211 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_completed"), 0))
1212 : : ! 1 if the DFPT potentials have been Fourier-interpolated. Set by the routines computing g (gstore_compute, gwpt_run).
1213 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("used_ftinterp"), 0))
1214 : : ! Value of gwcomp used to compute the GWPT matrix elements (COH static remainder if 2). Set by gwpt_run.
1215 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gwcomp"), 0))
1216 [ - + - - ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_kzone"), trim(gstore%kzone)))
1217 [ - + - - ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qzone"), trim(gstore%qzone)))
1218 [ - + - - ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_kfilter"), trim(gstore%kfilter)))
1219 [ - + - - ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_gmode"), trim(gstore%gmode)))
1220 [ - + - - ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_gtype"), trim(gstore%gtype)))
1221 : :
1222 : : ! NB: kibz has been already written by ebands%ncwrite
1223 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qibz"), gstore%qibz))
1224 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qbz"), gstore%qbz))
1225 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_wtq"), gstore%wtq))
1226 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_kbz"), gstore%kbz))
1227 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_brange_k_spin"), gstore%brange_k_spin))
1228 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_brange_kq_spin"), gstore%brange_kq_spin))
1229 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_erange_spin"), gstore%erange_spin))
1230 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_ngqpt"), gstore%ngqpt))
1231 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_glob_nq_spin"), gstore%glob_nq_spin))
1232 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_glob_nk_spin"), gstore%glob_nk_spin))
1233 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_kbz2ibz"), gstore%kbz2ibz))
1234 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qbz2ibz"), qbz2ibz))
1235 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qglob2bz"), qglob2bz))
1236 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_kglob2bz"), gstore%kglob2bz))
1237 : :
1238 : : ! These quantities are needed to interface GSTORE.nc with external codes.
1239 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_dielt"), ifc%dielt))
1240 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_zeff"), ifc%zeff))
1241 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_qdrp_cart"), ifc%qdrp_cart))
1242 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_eta"), ifc%eta))
1243 : : if (gstore_has_ifcs /= 0) then
1244 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_rpt"), ifc%rpt))
1245 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_wghatm"), ifc%wghatm))
1246 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_dynmat"), ifc%dynmat))
1247 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_short_atmfrc"), ifc%short_atmfrc))
1248 : : end if
1249 : :
1250 [ - + ]: 8 : if (allocated(gstore%delta_ef_kibz_spin)) then
1251 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_delta_ef_kibz_spin"), gstore%delta_ef_kibz_spin))
1252 : : end if
1253 : :
1254 [ + + ]: 16 : do spin=1,gstore%nsppol
1255 : : ! Create hdf group for this spin.
1256 [ - + ]: 8 : NCF_CHECK(nf90_def_grp(ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
1257 : :
1258 : : ! Dimensions in gqk_spin group
1259 : : ncerr = nctk_def_dims(spin_ncid, [ &
1260 : : nctkdim_t("nb_k", gstore%brange_k_spin(2, spin) - gstore%brange_k_spin(1, spin) + 1), &
1261 : : nctkdim_t("nb_kq", gstore%brange_kq_spin(2, spin) - gstore%brange_kq_spin(1, spin) + 1), &
1262 : : nctkdim_t("glob_nk", gstore%glob_nk_spin(spin)), &
1263 : : nctkdim_t("glob_nq", gstore%glob_nq_spin(spin)) &
1264 [ + + ]: 40 : ], defmode=.True.)
1265 [ - + ]: 8 : NCF_CHECK(ncerr)
1266 : :
1267 : : ! Define scalars
1268 [ + + ]: 24 : ncerr = nctk_def_iscalars(spin_ncid, [character(len=nctk_slen) :: "bstart_k", "bstart_kq"])
1269 [ - + ]: 8 : NCF_CHECK(ncerr)
1270 : :
1271 : : ! arrays in gqk_spin group with the precious stuff. Note global dimensions.
1272 : : ncerr = nctk_def_arrays(spin_ncid, [ &
1273 : : nctkarr_t("gvals", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq") &
1274 [ + + ]: 16 : ])
1275 [ - + ]: 8 : NCF_CHECK(ncerr)
1276 : :
1277 : : ! Compress gvals to reduce size on disk.
1278 : : !NCF_CHECK(nf90_def_var_deflate(spin_ncid, spin_vid("gvals"), shuffle=1, deflate=1, deflate_level=5))
1279 : :
1280 : : ! IMPORTANT: Init gvals with zeros.
1281 : : ! Default value for entries in gvals, vnk_cart_ibz and vnk_mat_cart_ibz arrays that have not been written.
1282 : : ! This can happen only if we have filtered wavevectors.
1283 : 8 : gstore_fill_dp = zero
1284 [ + + ]: 8 : if (gstore%kfilter == "none") gstore_fill_dp = -huge(one)
1285 [ - + ]: 8 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("gvals"), NF90_FILL, gstore_fill_dp))
1286 : :
1287 : : ! In GWPT gvals is used for g^Sigma so we declare another array to store g^KS.
1288 [ + + ]: 8 : if (dtset%eph_task == 17) then
1289 : : ncerr = nctk_def_arrays(spin_ncid, [ &
1290 : : nctkarr_t("gvals_ks", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq") &
1291 [ + + ]: 6 : ])
1292 [ - + ]: 3 : NCF_CHECK(ncerr)
1293 : : ! Compress gvals to reduce size on disk.
1294 : : !NCF_CHECK(nf90_def_var_deflate(spin_ncid, spin_vid("gvals_ks"), shuffle=1, deflate=1, deflate_level=5))
1295 [ - + ]: 3 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("gvals_ks"), NF90_FILL, gstore_fill_dp))
1296 : : end if
1297 : :
1298 : 16 : select case(gstore%with_vk)
1299 : : case (1)
1300 : : ! Diagonal terms only
1301 [ - + ]: 8 : NCF_CHECK(nctk_def_arrays(spin_ncid, nctkarr_t("vk_cart_ibz", "dp", "three, nb_k, gstore_nkibz")))
1302 [ - + ]: 8 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("vk_cart_ibz"), NF90_FILL, gstore_fill_dp))
1303 : :
1304 : : case (2)
1305 : : ! Full (nb_k x nb_k) matrix.
1306 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(spin_ncid, nctkarr_t("vnk_mat_cart_ibz", "dp", "two, three, nb_k, nb_k, gstore_nkibz")))
1307 [ + - - - : 8 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("vnk_mat_cart_ibz"), NF90_FILL, gstore_fill_dp))
- ]
1308 : : end select
1309 : :
1310 : : ! Write (small) data
1311 [ - + ]: 8 : NCF_CHECK(nctk_set_datamode(spin_ncid))
1312 [ - + ]: 8 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("bstart_k"), gstore%brange_k_spin(1, spin)))
1313 [ - + ]: 16 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("bstart_kq"), gstore%brange_kq_spin(1, spin)))
1314 : : end do ! spin
1315 : :
1316 [ - + ]: 8 : NCF_CHECK(nf90_close(ncid))
1317 : : end if ! master
1318 : :
1319 : : ! Make sure GSTORE.nc has been written by master.
1320 : 8 : call xmpi_barrier(gstore%comm)
1321 : :
1322 [ - + ]: 8 : ABI_FREE(wtk)
1323 [ - + ]: 8 : ABI_FREE(qibz2bz)
1324 [ - + ]: 8 : ABI_FREE(kibz2bz)
1325 [ - + ]: 8 : ABI_FREE(select_qbz_spin)
1326 [ - + ]: 8 : ABI_FREE(select_kbz_spin)
1327 [ - + ]: 8 : ABI_FREE(qglob2bz)
1328 [ - + ]: 8 : ABI_FREE(qbz2ibz)
1329 : :
1330 : 8 : call cwtime_report(" gstore_init:", cpu, wall, gflops)
1331 [ - + - + : 32 : call pstat_proc%print(_PSTAT_ARGS_)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + -
+ ]
1332 : :
1333 : : ! NOTE: When has_gwan is True, gqk%my_g/my_g2 have been allocated above (gqk_cplex) but are not
1334 : : ! filled here. The actual Wannier interpolation of the e-ph matrix elements is performed by the
1335 : : ! caller, gstore_init_or_from_ncpath, where with_gmode/gvals_name/with_g2dw are available.
1336 : :
1337 : : contains
1338 : 304 : integer function vid(var_name)
1339 : : character(len=*),intent(in) :: var_name
1340 : 304 : vid = nctk_idname(ncid, var_name)
1341 : : end function vid
1342 : 35 : integer function spin_vid(var_name)
1343 : : character(len=*),intent(in) :: var_name
1344 : 35 : spin_vid = nctk_idname(spin_ncid, var_name)
1345 : : end function spin_vid
1346 : :
1347 : : end subroutine gstore_init
1348 : : !!***
1349 : :
1350 : : !----------------------------------------------------------------------
1351 : :
1352 : : !!****f* m_gstore/gstore_init_or_from_ncpath
1353 : : !! NAME
1354 : : !! gstore_init_or_from_ncpath
1355 : : !!
1356 : : !! FUNCTION
1357 : : !! Build a gstore_t object either by reading a pre-existent GSTORE.nc file
1358 : : !! (getgstore_filepath) or, alternatively, by interpolating e-ph matrix elements
1359 : : !! on the fly from ABIWAN.nc + GWAN.nc (getabiwan_filepath + getgwan_filepath),
1360 : : !! e.g. on a k/q-mesh denser than the one used to compute the GWAN.nc file.
1361 : : !! In the latter case, no GSTORE.nc file is read or written: gqk%my_g is filled
1362 : : !! entirely in memory (see the has_gwan branch in gstore_init).
1363 : : !!
1364 : : !! from_file (output): set to .True. if gstore was built from a
1365 : : !! pre-existent GSTORE.nc file, .False. if built on the fly via Wannier
1366 : : !! interpolation. Callers can use this to report which path was taken.
1367 : : !!
1368 : : !! SOURCE
1369 : :
1370 : 16 : subroutine gstore_init_or_from_ncpath(gstore, with_cplex, dtset, dtfil, wfk0_hdr, cryst, ebands, ifc, &
1371 : : with_gmode, gvals_name, with_g2dw, comm, from_file)
1372 : :
1373 : : !Arguments ------------------------------------
1374 : : !scalars
1375 : : class(gstore_t),target,intent(out) :: gstore
1376 : : integer,intent(in) :: with_cplex
1377 : : type(dataset_type),target,intent(in) :: dtset
1378 : : type(datafiles_type),intent(in) :: dtfil
1379 : : type(hdr_type),intent(in) :: wfk0_hdr
1380 : : class(crystal_t),target,intent(in) :: cryst
1381 : : class(ebands_t),target,intent(in) :: ebands
1382 : : class(ifc_type),target,intent(in) :: ifc
1383 : : character(len=*),intent(in) :: with_gmode, gvals_name
1384 : : logical,intent(in) :: with_g2dw
1385 : : integer,intent(in) :: comm
1386 : : logical,intent(out) :: from_file
1387 : :
1388 : : !Local variables-------------------------------
1389 : : !scalars
1390 : : integer :: natom, natom3, spin, my_is, my_ik, my_iq, iq_ibz, isym_q, trev_q, ipc, nu, nwan, ierr
1391 : : integer :: ik_start, ik_stop, ikb, nkb, nk_batch, ncid, varid, gstore_completed
1392 : : real(dp) :: weight_q, cpu, wall, gflops
1393 : : character(len=500) :: msg
1394 : : character(len=fnlen) :: gstore_path
1395 : : type(gqk_t),pointer :: gqk
1396 : : !arrays
1397 : : real(dp) :: qpt(3)
1398 : 16 : real(dp),allocatable :: phfrq_ibz(:,:), displ_cart_dum(:,:,:,:), gatm_real(:,:,:,:), gnu_real(:,:,:,:)
1399 : 16 : real(dp),allocatable :: eigvec_ibz(:,:,:,:,:), eigvec_qbz(:,:,:,:), displ_cart_qbz(:,:,:,:), displ_red_qbz(:,:,:,:)
1400 [ + - ]: 16 : complex(dp),allocatable :: intp_gatm(:,:,:,:), gatm_full(:,:,:,:), g_req(:,:,:,:)
1401 : : !----------------------------------------------------------------------
1402 : :
1403 [ + - ]: 16 : if (dtfil%filgstorein /= ABI_NOFILE) then
1404 : : ! Do not use a GSTORE file whose generation did not complete (e.g. an interrupted GWPT run): the (k,q) blocks
1405 : : ! that were not computed still hold fill values. The restart of a GSTORE run calls from_ncpath directly.
1406 [ + - ]: 16 : if (xmpi_comm_rank(comm) == 0) then
1407 [ - + ]: 16 : NCF_CHECK(nctk_open_read(ncid, dtfil%filgstorein, xmpi_comm_self))
1408 [ - + ]: 16 : NCF_CHECK(nf90_inq_varid(ncid, "gstore_completed", varid))
1409 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, varid, gstore_completed))
1410 [ - + ]: 16 : NCF_CHECK(nf90_close(ncid))
1411 : : end if
1412 : 16 : call xmpi_bcast(gstore_completed, 0, comm, ierr)
1413 : : msg = sjoin("GSTORE file:", dtfil%filgstorein, "is not complete (gstore_completed = 0).", &
1414 [ + - ]: 16 : ch10, "Restart the run that produced it (eph_restart) before using the file.")
1415 [ - + ]: 16 : ABI_CHECK(gstore_completed /= 0, msg)
1416 : : call gstore%from_ncpath(dtfil%filgstorein, with_cplex, dtset, dtfil, cryst, ebands, ifc, &
1417 : 16 : with_gmode, gvals_name, with_g2dw, comm)
1418 : 16 : from_file = .True.
1419 : :
1420 [ # # # # ]: 0 : else if (dtfil%filabiwanin /= ABI_NOFILE .and. dtfil%filgwanin /= ABI_NOFILE) then
1421 : : ! Build gstore on the fly via Wannier interpolation from ABIWAN.nc + GWAN.nc.
1422 : 0 : call cwtime(cpu, wall, gflops, "start")
1423 : : ! with_cplex=0 prepares the Wannier interpolator and gstore metadata without materializing g(k,q).
1424 : : ! with_cplex=1/2 stores |g|^2/complex g, respectively. Debye-Waller and gvals_ks are unsupported.
1425 [ # # ]: 0 : msg = sjoin("Invalid with_cplex:", itoa(with_cplex), "only 0, 1 or 2 are supported")
1426 [ # # ]: 0 : ABI_CHECK(with_cplex >= 0 .and. with_cplex <= 2, msg)
1427 [ # # ]: 0 : if (with_g2dw) then
1428 : 0 : ABI_ERROR("with_g2dw = .True. is not yet supported when building gstore via Wannier interpolation (ABIWAN.nc + GWAN.nc)")
1429 : : end if
1430 [ # # ]: 0 : if (gvals_name == "gvals_ks") then
1431 : 0 : ABI_ERROR("gvals_name = 'gvals_ks' is not supported when building gstore via Wannier interpolation (ABIWAN.nc + GWAN.nc)")
1432 : : end if
1433 [ # # ]: 0 : if (with_gmode /= GSTORE_GMODE_PHONON) then
1434 : 0 : ABI_ERROR(sjoin("with_gmode:", with_gmode, "is not yet supported when building gstore via Wannier"))
1435 : : end if
1436 : :
1437 [ # # ]: 0 : gstore_path = strcat(dtfil%filnam_ds(4), "_GSTORE.nc")
1438 : 0 : call gstore%init(gstore_path, dtset, dtfil, wfk0_hdr, cryst, ebands, ifc, comm, with_cplex=with_cplex)
1439 : :
1440 [ # # ]: 0 : if (with_cplex == 0) then
1441 [ # # ]: 0 : call wrtout([std_out, ab_out], " Preparing on-demand Wannier interpolation of e-ph matrix elements ...", pre_newlines=1)
1442 : : else
1443 [ # # ]: 0 : call wrtout([std_out, ab_out], " Using Wannier interpolation to compute and store e-ph matrix elements ...", pre_newlines=1)
1444 : : end if
1445 : 0 : from_file = .False.
1446 : 0 : natom = cryst%natom; natom3 = 3 * natom
1447 : :
1448 : : ! Precompute phonon frequencies/eigenvectors in the IBZ once (spin-independent).
1449 : : ! NB: The phonon eigenvector gauge must be fixed from a single IBZ representative + symmetry
1450 : : ! rotation (pheigvec_rotate), exactly as done when g(k,q) is read from a pre-existent GSTORE.nc
1451 : : ! file (see gstore_from_ncpath). Calling ifc%fourq directly at each interpolated BZ q would give
1452 : : ! an independently-diagonalized (and hence potentially differently gauged) eigenbasis for
1453 : : ! degenerate modes and would break the e(-q) = e(q)^* convention used elsewhere in the code.
1454 [ # # # # : 0 : ABI_MALLOC(phfrq_ibz, (natom3, gstore%nqibz))
# # # # #
# # # # #
# # ]
1455 [ # # # # : 0 : ABI_MALLOC(eigvec_ibz, (2, 3, natom, natom3, gstore%nqibz))
# # # # #
# # # # #
# # # # #
# ]
1456 [ # # # # : 0 : ABI_MALLOC(displ_cart_dum, (2, 3, natom, natom3))
# # # # #
# # # # #
# # ]
1457 [ # # ]: 0 : do iq_ibz=1,gstore%nqibz
1458 : : call ifc%fourq(cryst, gstore%qibz(:,iq_ibz), phfrq_ibz(:,iq_ibz), displ_cart_dum, &
1459 : 0 : out_eigvec=eigvec_ibz(:,:,:,:,iq_ibz))
1460 : : end do
1461 [ # # ]: 0 : ABI_FREE(displ_cart_dum)
1462 : :
1463 [ # # # # : 0 : ABI_MALLOC(eigvec_qbz, (2, 3, natom, natom3))
# # # # #
# # # # #
# # ]
1464 [ # # # # : 0 : ABI_MALLOC(displ_cart_qbz, (2, 3, natom, natom3))
# # # # #
# # # ]
1465 [ # # # # : 0 : ABI_MALLOC(displ_red_qbz, (2, 3, natom, natom3))
# # # # #
# # # ]
1466 : :
1467 : : ! Interpolate g(k,q) and store data in memory.
1468 [ # # ]: 0 : do my_is=1,gstore%my_nspins
1469 : 0 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is); nwan = gqk%nb_k
1470 : :
1471 : : ! Build gqk%wan for this spin from the ABIWAN.nc file and load g(R_e, R_p) from GWAN.nc.
1472 : 0 : call gqk%wan%from_abiwan(dtfil%filabiwanin, spin, gstore%nsppol, .False., "", gqk%comm%value)
1473 : 0 : gqk%wan%my_pert_start = gqk%my_pert_start; gqk%wan%my_npert = gqk%my_npert; gqk%wan%pert_comm => gqk%pert_comm
1474 : 0 : call gqk%wan%load_gwan(dtfil%filgwanin, cryst, spin, gstore%nsppol, gqk%comm)
1475 : :
1476 [ # # # # : 0 : ABI_MALLOC(gqk%my_wnuq, (gqk%my_npert, gqk%my_nq))
# # # # #
# # # # #
# # # # ]
1477 [ # # # # : 0 : ABI_MALLOC(gqk%my_displ_cart, (2, 3, natom, gqk%my_npert, gqk%my_nq))
# # # # #
# # # # #
# # # # #
# # # ]
1478 : :
1479 [ # # ]: 0 : if (with_cplex > 0) then
1480 : : ! Bound the two temporary complex atomic-vertex arrays to the default
1481 : : ! 64 MiB workspace. The low-level selector also accepts a custom limit.
1482 : 0 : nk_batch = gqk%wan%eph_kbatch_size(gqk%my_nk, natom3)
1483 [ # # # # : 0 : ABI_MALLOC(intp_gatm, (nwan, nwan, gqk%my_npert, nk_batch))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1484 [ # # # # : 0 : ABI_MALLOC(gatm_full, (nwan, nwan, natom3, nk_batch))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1485 [ # # # # : 0 : ABI_MALLOC(g_req, (gqk%wan%nr_e, nwan, nwan, gqk%my_npert))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1486 [ # # # # : 0 : ABI_MALLOC(gatm_real, (2, nwan, nwan, natom3))
# # # # #
# # # # #
# # # # #
# # # ]
1487 [ # # # # : 0 : ABI_MALLOC(gnu_real, (2, nwan, nwan, natom3))
# # # # #
# # # # #
# # # # ]
1488 : : end if
1489 : :
1490 [ # # ]: 0 : do my_iq=1,gqk%my_nq
1491 : 0 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
1492 : 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)
1493 : :
1494 : : ! Rotate the phonon eigenvector from the IBZ to this BZ q-point (fixes the gauge).
1495 : : call pheigvec_rotate(cryst, gstore%qibz(:,iq_ibz), isym_q, trev_q, eigvec_ibz(:,:,:,:,iq_ibz), &
1496 : 0 : eigvec_qbz, displ_cart_qbz, displ_red_qbz=displ_red_qbz)
1497 : :
1498 : : ! Fill my arrays with ph data.
1499 [ # # # # : 0 : gqk%my_wnuq(:,my_iq) = phfrq_ibz(gqk%my_pertcases(:), iq_ibz)
# # ]
1500 [ # # # # : 0 : gqk%my_displ_cart(:,:,:,:,my_iq) = displ_cart_qbz(:,:,:,gqk%my_pertcases(:))
# # # # #
# ]
1501 : :
1502 [ # # ]: 0 : if (with_cplex == 0) cycle
1503 : :
1504 : : ! The R_p -> q transform is independent of k and is reused by every
1505 : : ! bounded k block below.
1506 : 0 : call gqk%wan%prepare_eph_q(qpt, g_req)
1507 : :
1508 [ # # # # : 0 : do ik_start=1,gqk%my_nk,nk_batch
# # # # ]
1509 : 0 : ik_stop = min(gqk%my_nk, ik_start + nk_batch - 1); nkb = ik_stop - ik_start + 1
1510 : :
1511 : : call gqk%wan%interp_eph_manyk_from_q(cryst, nkb, gqk%my_kpts(:,ik_start:ik_stop), qpt, &
1512 : 0 : g_req, intp_gatm(:,:,:,1:nkb))
1513 : :
1514 : : ! Complete all atomic perturbations for the block with one collective
1515 : : ! instead of one pert_comm reduction per k point.
1516 [ # # # # : 0 : gatm_full(:,:,:,1:nkb) = czero
# # # # ]
1517 [ # # ]: 0 : do ikb=1,nkb
1518 [ # # ]: 0 : do ipc=1,gqk%my_npert
1519 [ # # # # ]: 0 : gatm_full(:,:,gqk%my_pertcases(ipc),ikb) = intp_gatm(:,:,ipc,ikb)
1520 : : end do
1521 : : end do
1522 [ # # ]: 0 : if (gqk%pert_comm%nproc > 1) call xmpi_sum(gatm_full(:,:,:,1:nkb), gqk%pert_comm%value, ierr)
1523 : :
1524 [ # # ]: 0 : do ikb=1,nkb
1525 : 0 : my_ik = ik_start + ikb - 1
1526 [ # # # # : 0 : gatm_real(1,:,:,:) = real(gatm_full(:,:,:,ikb), kind=dp)
# # ]
1527 [ # # # # : 0 : gatm_real(2,:,:,:) = aimag(gatm_full(:,:,:,ikb))
# # ]
1528 : 0 : call ephtk_gkknu_from_atm(nwan, nwan, 1, natom, gatm_real, phfrq_ibz(:,iq_ibz), displ_red_qbz, gnu_real)
1529 : :
1530 [ # # ]: 0 : do ipc=1,gqk%my_npert
1531 : 0 : nu = gqk%my_pertcases(ipc)
1532 [ # # ]: 0 : if (with_cplex == 2) then
1533 [ # # # # ]: 0 : gqk%my_g(ipc,:,my_iq,:,my_ik) = gnu_real(1,:,:,nu) + j_dpc * gnu_real(2,:,:,nu)
1534 : : else
1535 [ # # # # ]: 0 : gqk%my_g2(ipc,:,my_iq,:,my_ik) = gnu_real(1,:,:,nu)**2 + gnu_real(2,:,:,nu)**2
1536 : : end if
1537 : : end do
1538 : : end do ! ikb
1539 : : end do ! ik_start
1540 : : end do ! my_iq
1541 : :
1542 [ # # ]: 0 : if (with_cplex > 0) then
1543 [ # # ]: 0 : ABI_FREE(intp_gatm)
1544 [ # # ]: 0 : ABI_FREE(gatm_full)
1545 [ # # ]: 0 : ABI_FREE(g_req)
1546 [ # # ]: 0 : ABI_FREE(gatm_real)
1547 [ # # ]: 0 : ABI_FREE(gnu_real)
1548 : : end if
1549 : : end do ! my_is
1550 : :
1551 [ # # ]: 0 : ABI_FREE(phfrq_ibz)
1552 [ # # ]: 0 : ABI_FREE(eigvec_ibz)
1553 [ # # ]: 0 : ABI_FREE(eigvec_qbz)
1554 [ # # ]: 0 : ABI_FREE(displ_cart_qbz)
1555 [ # # ]: 0 : ABI_FREE(displ_red_qbz)
1556 : :
1557 : : ! We interpolated (and converted to) the phonon representation.
1558 : 0 : gstore%gmode = GSTORE_GMODE_PHONON
1559 : 0 : call cwtime_report(" Wannier interpolation of GSTORE matrix elements", cpu, wall, gflops)
1560 : :
1561 : : else
1562 : : write(msg, "(3a)") &
1563 : 0 : "Cannot build gstore object: either getgstore_filepath or both ", &
1564 : 0 : "getabiwan_filepath and getgwan_filepath must be provided in the input file.", ch10
1565 : 0 : ABI_ERROR(msg)
1566 : : end if
1567 : :
1568 [ - + - + : 16 : end subroutine gstore_init_or_from_ncpath
- + - + -
+ ]
1569 : : !!***
1570 : :
1571 : : !----------------------------------------------------------------------
1572 : :
1573 : 0 : logical function gstore_has_matrix_elements(gstore) result(has_g)
1574 : :
1575 : : class(gstore_t),intent(in) :: gstore
1576 : :
1577 : 0 : has_g = gstore%with_cplex > 0
1578 : :
1579 : 0 : end function gstore_has_matrix_elements
1580 : :
1581 : : !----------------------------------------------------------------------
1582 : :
1583 : 0 : logical function gstore_has_complex_matrix_elements(gstore) result(has_complex_g)
1584 : :
1585 : : class(gstore_t),intent(in) :: gstore
1586 : :
1587 : 0 : has_complex_g = gstore%with_cplex == 2
1588 : :
1589 : 0 : end function gstore_has_complex_matrix_elements
1590 : :
1591 : : !----------------------------------------------------------------------
1592 : :
1593 : : !!****f* m_gstore/gstore_same_nbands
1594 : : !! NAME
1595 : : !! gstore_same_nbands
1596 : : !!
1597 : : !! FUNCTION
1598 : : !! True if nb_k == nb_kq.
1599 : : !!
1600 : : !! SOURCE
1601 : :
1602 : 9 : logical function gstore_same_nbands(gstore, msg) result(same)
1603 : :
1604 : : class(gstore_t),intent(in) :: gstore
1605 : : character(len=*),intent(out) :: msg
1606 : :
1607 : : !Local variables-------------------------------
1608 : : integer :: my_is
1609 : : !----------------------------------------------------------------------
1610 : :
1611 : 9 : same = .True.; msg = ""
1612 [ + + ]: 18 : do my_is=1,gstore%my_nspins
1613 : 9 : associate (gqk => gstore%gqk(my_is))
1614 [ - + ]: 9 : if (gqk%nb_k /= gqk%nb_kq) then
1615 [ # # # # ]: 0 : same = .False.; msg = sjoin("gstore has different nb_kq, nb_k", itoa(gqk%nb_kq), itoa(gqk%nb_k))
1616 : : end if
1617 : : end associate
1618 : : end do
1619 : :
1620 [ + - ]: 9 : end function gstore_same_nbands
1621 : : !!***
1622 : :
1623 : : !----------------------------------------------------------------------
1624 : :
1625 : : !!****f* m_gstore/gstore_distribute_spins
1626 : : !! NAME
1627 : : !! gstore_distribute_spins
1628 : : !!
1629 : : !! FUNCTION
1630 : : !! Distribute spins. Also create and return indirect mapping to spin index and init %brange_k_spin
1631 : : !!
1632 : : !! INPUTS
1633 : : !!
1634 : : !! OUTPUT
1635 : : !!
1636 : : !! NOTES
1637 : : !! What works:
1638 : : !!
1639 : : !! - Setting gstore_kfilter = "qprange" works.
1640 : : !! With this, bands (nb_k) and k-points are automatically filtered, including only the VBM and CBM.
1641 : : !! This is useful for calculating the ZPR of the fundamental gap.
1642 : : !! Manual specification of bands (nb_k) and k-points also works by setting gstore_kfilter = "none" (default)
1643 : : !! and providing the values via kptgw and bdgw.
1644 : : !!
1645 : : !! What does not work:
1646 : : !!
1647 : : !! - There is currently no effective way to control nb_kq directly.
1648 : : !! The only workaround is using gstore_brange. For example, gstore_brange = '1, 8' sets nb_k = nb_kq = 8.
1649 : : !! However, gstore_brange has the lowest priority: if gstore_kfilter
1650 : : !! is set or kptgw/bdgw are provided, gstore_brange is ignored and nb_kq defaults to nband.
1651 : : !!
1652 : : !! Notes on use cases:
1653 : : !! For ZPR calculations, the current schemes are sufficient.
1654 : : !! For tasks comparing g between GWPT and FD, the current schemes are not very convenient.
1655 : : !! For instance, to compare g at k=q=Gamma for the first 8 bands of diamond,
1656 : : !! ideally we would restrict the calculation to nb_k = nb_kq = {1..8} and k=q=Gamma. But currently
1657 : : !!
1658 : : !! Using gstore_brange triggers unnecessary k-point calculations (ngkpt is usually a dense k-grid).
1659 : : !!
1660 : : !! Using kptgw and bdgw triggers unnecessary band calculations (nb_kq = nband is usually a big number).
1661 : : !!
1662 : : !! Potential improvement (?):
1663 : : !! Maybe we could give gstore_brange higher priority to control nb_kq(?). To avoid conflicts:
1664 : : !! If gstore_brange is provided and gstore_kfilter = "none", we do
1665 : : !! bstart_k = bdgw[1], nb_k = min(nband, bdgw[2] - bdgw[1])
1666 : : !! bstart_kq = gstore_brange[1], nb_kq = min(nband, gstore_brange[2] - gstore_brange[1])
1667 : : !! If gstore_brange is NOT provided and gstore_kfilter = "none", we do
1668 : : !! bstart_kq = bstart_k = bdgw[1], nb_kq = nb_k = max(nband, bdgw[2] - bdgw[1])
1669 : : !!
1670 : : !! SOURCE
1671 : :
1672 : 24 : subroutine gstore_distribute_spins(gstore, mband, brange_kq, brange_k, nproc_spin, comm_spin, comm)
1673 : :
1674 : : !Arguments ------------------------------------
1675 : : !scalars
1676 : : class(gstore_t),target,intent(inout) :: gstore
1677 : : integer,intent(in) :: mband, comm, brange_kq(2, gstore%nsppol), brange_k(2, gstore%nsppol)
1678 : : integer,intent(out) :: nproc_spin(gstore%nsppol), comm_spin(gstore%nsppol)
1679 : :
1680 : : !Local variables-------------------------------
1681 : : !scalars
1682 : : integer :: spin, my_rank, ierr, color, nsppol, nprocs
1683 : : !arrays
1684 : : integer :: buff_spin(2)
1685 : : !----------------------------------------------------------------------
1686 : :
1687 : 24 : nprocs = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
1688 : 24 : nsppol = gstore%nsppol
1689 : :
1690 : 24 : gstore%my_nspins = 0
1691 [ - + + - : 72 : ABI_MALLOC(gstore%brange_k_spin, (2, nsppol))
+ - + - -
+ - + -
+ ]
1692 [ - + + - : 48 : ABI_MALLOC(gstore%brange_kq_spin, (2, nsppol))
- + - + -
+ ]
1693 : :
1694 [ + + ]: 48 : do spin=1,nsppol
1695 : : ! NB: If MPI_UNDEFINED is passed as the colour value, the subgroup in which
1696 : : ! the calling MPI process will be placed is MPI_COMM_NULL
1697 : 24 : color = 1
1698 [ - + ]: 24 : if (nsppol == 2 .and. nprocs > 1) then
1699 : 0 : color = xmpi_undefined
1700 [ # # # # ]: 0 : if (spin == 1 .and. my_rank <= (nprocs - 1) / 2) color = 1
1701 [ # # # # ]: 0 : if (spin == 2 .and. my_rank > (nprocs - 1) / 2) color = 1
1702 : : end if
1703 : :
1704 : 24 : call xmpi_comm_split(comm, color, my_rank, comm_spin(spin), ierr)
1705 [ + - ]: 24 : if (comm_spin(spin) /= xmpi_comm_null) then
1706 : 24 : gstore%my_nspins = gstore%my_nspins + 1
1707 : 24 : buff_spin(gstore%my_nspins) = spin
1708 : : end if
1709 : :
1710 : 24 : nproc_spin(spin) = xmpi_comm_size(comm_spin(spin))
1711 : :
1712 : : ! Default values for brange at k, k+q from mband
1713 [ + + ]: 72 : gstore%brange_k_spin(:, spin) = [1, mband]
1714 [ + + ]: 72 : gstore%brange_kq_spin(:, spin) = [1, mband]
1715 : :
1716 : : ! Optionally take values from input brange_k, brange_kq
1717 [ + + + + : 139 : if (all(brange_k /= 0)) gstore%brange_k_spin(:, spin) = brange_k(:, spin)
+ + + + +
+ ]
1718 [ + + + + : 139 : if (all(brange_kq /= 0)) gstore%brange_kq_spin(:, spin) = brange_kq(:, spin)
+ + + + +
+ ]
1719 : :
1720 : : ! Validate against input mband.
1721 [ + - - + ]: 24 : ABI_CHECK_IRANGE(gstore%brange_k_spin(1, spin), 1, mband, "brange_k(1, spin)")
1722 [ + - - + ]: 24 : ABI_CHECK_IRANGE(gstore%brange_k_spin(2, spin), 1, mband, "brange_k(2, spin)")
1723 [ - + ]: 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)")
1724 : :
1725 [ + - - + ]: 24 : ABI_CHECK_IRANGE(gstore%brange_kq_spin(1, spin), 1, mband, "brange_k(1, spin)")
1726 [ + - - + ]: 24 : ABI_CHECK_IRANGE(gstore%brange_kq_spin(2, spin), 1, mband, "brange_k(2, spin)")
1727 [ - + ]: 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)")
1728 : : end do
1729 : :
1730 [ - + + - : 72 : ABI_MALLOC(gstore%my_spins, (gstore%my_nspins))
+ - + - -
+ - + -
+ ]
1731 [ - + + + ]: 72 : gstore%my_spins = buff_spin(1:gstore%my_nspins)
1732 [ - + + - : 384 : ABI_MALLOC(gstore%gqk, (gstore%my_nspins))
+ - + - -
+ - + - +
+ + + + +
+ + + ]
1733 : :
1734 : 24 : end subroutine gstore_distribute_spins
1735 : : !!***
1736 : :
1737 : : !----------------------------------------------------------------------
1738 : :
1739 : : !!****f* m_gstore/gstore_set_mpi_grid__
1740 : : !! NAME
1741 : : !! gstore_set_mpi_grid__
1742 : : !!
1743 : : !! FUNCTION
1744 : : !!
1745 : : !! INPUTS
1746 : : !!
1747 : : !! OUTPUT
1748 : : !!
1749 : : !! SOURCE
1750 : :
1751 : 24 : subroutine gstore_set_mpi_grid__(gstore, dtfil, nproc_spin, comm_spin)
1752 : :
1753 : : !Arguments ------------------------------------
1754 : : !scalars
1755 : : class(gstore_t),target,intent(inout) :: gstore
1756 : : type(datafiles_type),intent(in) :: dtfil
1757 : : integer,intent(in) :: nproc_spin(gstore%nsppol)
1758 : : integer,intent(inout) :: comm_spin(gstore%nsppol)
1759 : : !Local variables-------------------------------
1760 : : !scalars
1761 : : integer,parameter :: master = 0
1762 : : integer :: spin, my_is, np, my_rank, ierr, npp_bz, units(2), bstart_k, bstop_k, nb_k, bstart_kq, bstop_kq, nb_kq
1763 : : integer :: comm_cart, me_cart, dims(ndims)
1764 : : type(gqk_t),pointer :: gqk
1765 : : character(len=5000) :: msg
1766 : : character(len=10) :: order, priority
1767 : : character(len=fnlen) :: screen_filepath
1768 : : logical :: reorder, periods(ndims), keepdim(ndims)
1769 [ + + + + ]: 312 : type(kmesh_t) :: pp_mesh
1770 : 24 : type(gsphere_t) :: gsph_c
1771 : 24 : real(dp),allocatable :: qlwl(:,:)
1772 [ + + ]: 96 : type(hscr_t),target :: hscr
1773 : : !----------------------------------------------------------------------
1774 : :
1775 [ + + ]: 72 : units = [std_out, ab_out]
1776 : :
1777 : : associate (dtset => gstore%dtset)
1778 : 48 : my_rank = xmpi_comm_rank(gstore%comm)
1779 : :
1780 [ + + ]: 48 : do my_is=1,gstore%my_nspins
1781 : 24 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is)
1782 : 24 : gqk%spin = spin; gqk%natom3 = 3 * gstore%cryst%natom; gqk%cplex = 2
1783 : :
1784 : : ! Compute bstart_k and nb_k for this spin.
1785 : 24 : bstart_k = gstore%brange_k_spin(1, spin)
1786 : 24 : bstop_k = gstore%brange_k_spin(2, spin)
1787 : 24 : nb_k = gstore%brange_k_spin(2, spin) - gstore%brange_k_spin(1, spin) + 1
1788 : :
1789 : : ! Compute bstart_kq and nb_kq for this spin.
1790 : 24 : bstart_kq = gstore%brange_kq_spin(1, spin)
1791 : 24 : bstop_kq = gstore%brange_kq_spin(2, spin)
1792 : 24 : nb_kq = gstore%brange_kq_spin(2, spin) - gstore%brange_kq_spin(1, spin) + 1
1793 : :
1794 : : ! Here we set nb_k and nb_kq
1795 : 24 : gqk%nb_k = nb_k; gqk%bstart_k = bstart_k; gqk%bstop_k = bstop_k
1796 : 24 : gqk%nb_kq = nb_kq; gqk%bstart_kq = bstart_kq; gqk%bstop_kq = bstop_kq
1797 : :
1798 : : ! Store global shape of the q/k matrix for this spin.
1799 : 24 : gqk%glob_nq = gstore%glob_nq_spin(spin)
1800 : 48 : gqk%glob_nk = gstore%glob_nk_spin(spin)
1801 : : end do
1802 : :
1803 [ + + ]: 48 : do my_is=1,gstore%my_nspins
1804 : 24 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is)
1805 : :
1806 : : ! Init for sequential execution.
1807 : 24 : gqk%my_npert = gqk%natom3
1808 : 24 : gqk%qpt_comm%nproc = 1; gqk%kpt_comm%nproc = 1; gqk%pert_comm%nproc = 1; gqk%band_comm%nproc = 1
1809 : : ! NB: The communicators below are only used in GWPT.
1810 : 24 : gqk%bsum_comm%nproc = 1; gqk%pp_sum_comm%nproc = 1
1811 : :
1812 : 24 : np = nproc_spin(spin)
1813 : :
1814 [ + + ]: 24 : if (dtset%eph_task /= 17) then
1815 : : ! =============================
1816 : : ! For all eph_tasks except GWPT
1817 : : ! =============================
1818 : :
1819 [ + + + - : 126 : if (any(dtset%eph_np_pqbks /= 0)) then
- + ]
1820 : : ! Use parameters from input file. Need to perform sanity check though.
1821 : 0 : gqk%pert_comm%nproc = dtset%eph_np_pqbks(1)
1822 : 0 : gqk%qpt_comm%nproc = dtset%eph_np_pqbks(2)
1823 : 0 : gqk%band_comm%nproc = dtset%eph_np_pqbks(3)
1824 [ # # ]: 0 : ABI_CHECK(dtset%eph_np_pqbks(3) == 1, "Band parallelism not yet implemented in gstore")
1825 : 0 : gqk%kpt_comm%nproc = dtset%eph_np_pqbks(4)
1826 : : !gqk%spin_comm%nproc = dtset%eph_np_pqbks(5)
1827 : 0 : gqk%my_npert = gqk%natom3 / gqk%pert_comm%nproc
1828 [ # # ]: 0 : ABI_CHECK(gqk%my_npert > 0, "pert_comm_nproc cannot be greater than 3*natom.")
1829 [ # # ]: 0 : ABI_CHECK(mod(gqk%natom3, gqk%pert_comm%nproc) == 0, "pert_comm_nproc must divide 3*natom.")
1830 : :
1831 : : else
1832 : : ! Automatic grid generation (hopefully smart)
1833 : : ! Keep in mind that in gstore_compute, the first loop is over q-points
1834 : : ! in order to reduce the number of interpolations of the DFPT potentials in q-space
1835 : : ! hence the q-point parallelism is expected to be more efficient.
1836 : : ! On the other hand, the k-point parallelism and the perturbation parallelism
1837 : : ! allow one to reduce the memory requirements associated to the wavefunctions (kpt) and
1838 : : ! the scattering potentials in the supercell (perturbations).
1839 : : ! Here we try to optimize performance but it's clear that for large systems the user
1840 : : ! should specify dtset%eph_np_pqbks in the input file.
1841 : :
1842 : 5 : select case (dtset%eph_task)
1843 : : case (11)
1844 : 5 : priority = "qk"
1845 : : case (12, -12)
1846 : 0 : priority = "q"
1847 : : case (13)
1848 : 9 : priority = "q"
1849 : : case (14, 17)
1850 : 0 : priority = "kq"
1851 : : case (24)
1852 : 7 : priority = "qk"
1853 : : case default
1854 [ + - + - : 21 : ABI_ERROR(sjoin("Please register default priority for eph_task:", itoa(dtset%eph_task)))
+ - ]
1855 : : end select
1856 : :
1857 : 9 : select case (priority)
1858 : : case ("q")
1859 : 9 : order = "1"
1860 : : case ("k")
1861 : 0 : order = "2"
1862 : : case ("kq")
1863 : 0 : order = "21"
1864 : : case ("qk")
1865 : 12 : order = "12"
1866 : : case default
1867 [ + - - + : 21 : ABI_ERROR(sjoin("Wrong priority:", priority))
- ]
1868 : : end select
1869 : :
1870 [ + + ]: 21 : if (gqk%glob_nk == 1) order = "21"
1871 [ - + ]: 21 : if (gqk%glob_nq == 1) order = "12"
1872 : 21 : call xmpi_distrib_2d(np, order, gqk%glob_nq, gqk%glob_nk, gqk%qpt_comm%nproc, gqk%kpt_comm%nproc, ierr)
1873 [ - + ]: 21 : ABI_CHECK(ierr == 0, sjoin("Cannot distribute nprocs:", itoa(np), " with priority: ", priority))
1874 : : end if
1875 : :
1876 : : else if (dtset%eph_task == 17) then
1877 : : ! =========================
1878 : : ! MPI distribution for GWPT
1879 : : ! =========================
1880 : :
1881 [ + + + - : 21 : if (any(dtset%gwpt_np_wpqbks /= 0)) then
- + ]
1882 : : ! Use parameters from input file. Need to perform sanity check though.
1883 : 0 : gqk%pp_sum_comm%nproc = dtset%gwpt_np_wpqbks(1)
1884 : 0 : gqk%pert_comm%nproc = dtset%gwpt_np_wpqbks(2)
1885 : 0 : gqk%qpt_comm%nproc = dtset%gwpt_np_wpqbks(3)
1886 : 0 : gqk%bsum_comm%nproc = dtset%gwpt_np_wpqbks(4)
1887 : 0 : gqk%kpt_comm%nproc = dtset%gwpt_np_wpqbks(5)
1888 : : !gqk%spin_comm%nproc = dtset%gwpt_np_wpqbks(6)
1889 : 0 : gqk%my_npert = gqk%natom3 / gqk%pert_comm%nproc
1890 [ # # ]: 0 : ABI_CHECK(gqk%my_npert > 0, "pert_comm_nproc cannot be greater than 3*natom.")
1891 [ # # ]: 0 : ABI_CHECK(mod(gqk%natom3, gqk%pert_comm%nproc) == 0, "pert_comm_nproc must divide 3*natom.")
1892 : :
1893 : : else
1894 : : ! Automatic grid generation for GWPT (hopefully smart)
1895 : :
1896 : : ! In GWPT, the loop over pp-wavevectors is always in the BZ and is expected to be the most efficient
1897 : : ! Note however that the p-mesh is not necessarly equal to the k-mesh hence we have to read it from the SCR file.
1898 : : !npp_bz = product(get_diag(gstore%dtset%kptrlatt))
1899 : :
1900 : 3 : screen_filepath = dtfil%fnameabi_scr
1901 [ - + ]: 3 : ABI_CHECK(dtfil%fnameabi_scr /= ABI_NOFILE, "SCR file must be specified")
1902 [ - + ]: 3 : call get_hscr_qmesh_gsph(screen_filepath, gstore%dtset, gstore%cryst, hscr, pp_mesh, gsph_c, qlwl, comm_spin(spin))
1903 : 3 : npp_bz = pp_mesh%nbz
1904 : 3 : call hscr%free(); call pp_mesh%free(); call gsph_c%free()
1905 [ + - ]: 3 : ABI_SFREE(qlwl)
1906 : :
1907 [ + - ]: 3 : if (np <= npp_bz * gqk%natom3) then
1908 : : ! "Small" np. Give higher priority to npp_bz and then perturbations.
1909 : 3 : order = "12"
1910 : 3 : call xmpi_distrib_2d(np, order, npp_bz, gqk%natom3, gqk%pp_sum_comm%nproc, gqk%pert_comm%nproc, ierr)
1911 [ - + ]: 3 : ABI_CHECK(ierr == 0, sjoin("Cannot distribute nprocs:", itoa(np), " with priority: ", priority, " Please use gwpt_np_wpqbks"))
1912 : : else
1913 : : ! "Large" np. Activate parallelism over k-points or q-points depending on gstore input variables.
1914 : 0 : ABI_ERROR("Your number of MPI procs is too large for the automatic GWPT parallelization. Please use gwpt_np_wpqbks")
1915 : : end if
1916 : : end if
1917 : :
1918 : : else
1919 : : ABI_ERROR(sjoin("Invalid eph_task", itoa(dtset%eph_task)))
1920 : : end if
1921 : :
1922 : : ! Consistency check.
1923 [ - + ]: 24 : if (gqk%pert_comm%nproc * gqk%qpt_comm%nproc * gqk%kpt_comm%nproc * gqk%band_comm%nproc * &
1924 : 24 : gqk%bsum_comm%nproc * gqk%pp_sum_comm%nproc /= nproc_spin(spin)) then
1925 : : write(msg, "(a,i0,3a, 7(a,1x,i0))") &
1926 : 0 : "Cannot create Cartesian grid with total nproc: ", nproc_spin(spin), ch10, &
1927 : 0 : "Idle processes are not supported. The product of the `nproc_*` vars should be equal to nproc.", ch10, &
1928 : 0 : "qpt_nproc (", gqk%qpt_comm%nproc, ") x kpt_nproc (", gqk%kpt_comm%nproc, ") x pert_nproc", gqk%pert_comm%nproc, &
1929 : 0 : "x band_nproc (", gqk%band_comm%nproc, "x bsum_nproc (", gqk%bsum_comm%nproc, ") x psum_nproc (", gqk%pp_sum_comm%nproc, &
1930 : 0 : ") != ", nproc_spin(spin)
1931 : 0 : ABI_ERROR(msg)
1932 : : end if
1933 : :
1934 : : end do ! my_is
1935 : :
1936 : : ! For each spin treated by this rank, create Cartesian communicator of rank ndims.
1937 : 24 : periods(:) = .False.; reorder = .False.
1938 : :
1939 [ + + ]: 48 : do my_is=1,gstore%my_nspins
1940 : 24 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is)
1941 : :
1942 : : ! TODO: Should change order for GWPT.
1943 : : dims = [gqk%qpt_comm%nproc, gqk%kpt_comm%nproc, gqk%pert_comm%nproc, gqk%band_comm%nproc, &
1944 [ + + ]: 168 : gqk%bsum_comm%nproc, gqk%pp_sum_comm%nproc]
1945 : :
1946 : : ! Note comm_spin(spin).
1947 : 24 : gqk%comm = xcomm_from_mpi_int(comm_spin(spin))
1948 [ + + ]: 168 : gqk%coords_qkpb_sumbp = 0
1949 : :
1950 : : #ifdef HAVE_MPI
1951 : 24 : call MPI_CART_CREATE(gqk%comm, ndims, dims, periods, reorder, comm_cart, ierr)
1952 : : ! Find the index and coordinates of the current processor
1953 : 24 : call MPI_COMM_RANK(comm_cart, me_cart, ierr)
1954 : 24 : call MPI_CART_COORDS(comm_cart, me_cart, ndims, gqk%coords_qkpb_sumbp, ierr)
1955 : :
1956 : : ! Communicator for q-points in g(k,q)
1957 : 24 : keepdim = .False.; keepdim(1) = .True.; call gqk%qpt_comm%from_cart_sub(comm_cart, keepdim)
1958 : : ! Communicator for k-points in g(k,q)
1959 : 24 : keepdim = .False.; keepdim(2) = .True.; call gqk%kpt_comm%from_cart_sub(comm_cart, keepdim)
1960 : : ! Communicator for the (qpt, kpt) 2D grid
1961 : 24 : keepdim = .False.; keepdim(1) = .True.; keepdim(2) = .True.; call gqk%qpt_kpt_comm%from_cart_sub(comm_cart, keepdim)
1962 : : ! Communicator for perturbations in g(k,q)
1963 : 24 : keepdim = .False.; keepdim(3) = .True.; call gqk%pert_comm%from_cart_sub(comm_cart, keepdim)
1964 : : ! 2d Communicator for the (qpt, pert) grid
1965 : 24 : keepdim = .False.; keepdim(1) = .True.; keepdim(3) = .True.; call gqk%qpt_pert_comm%from_cart_sub(comm_cart, keepdim)
1966 : : ! Communicator for band in g(k,q)
1967 : 24 : keepdim = .False.; keepdim(4) = .True.; call gqk%band_comm%from_cart_sub(comm_cart, keepdim)
1968 : : ! Communicator for bsum (GWPT mode)
1969 : 24 : keepdim = .False.; keepdim(5) = .True.; call gqk%bsum_comm%from_cart_sub(comm_cart, keepdim)
1970 : : ! Communicator for pp_sum (GWPT mode)
1971 : 24 : keepdim = .False.; keepdim(6) = .True.; call gqk%pp_sum_comm%from_cart_sub(comm_cart, keepdim)
1972 : : ! 2d Communicator for the (pert, pp_sum) 2D grid
1973 : 24 : keepdim = .False.; keepdim(3) = .True.; keepdim(6) = .True.; call gqk%pert_ppsum_comm%from_cart_sub(comm_cart, keepdim)
1974 : : ! 3d Communicator for the (pert, pp_sum, band_sum) 3D grid (GWPT mode)
1975 : 24 : keepdim = .False.; keepdim(3) = .True.; keepdim(5) = .True.; keepdim(6) = .True.
1976 : 24 : call gqk%pert_ppsum_bsum_comm%from_cart_sub(comm_cart, keepdim)
1977 : 24 : call xmpi_comm_free(comm_cart)
1978 : : #endif
1979 : :
1980 : : ! Distribute perturbations inside pert_comm using block distribution.
1981 [ - + ]: 24 : call xmpi_split_block(gqk%natom3, gqk%pert_comm%value, gqk%my_npert, gqk%my_pertcases)
1982 : 24 : gqk%my_pert_start = gqk%my_pertcases(1)
1983 : :
1984 : 24 : call wrtout(units, sjoin("P qpt_comm can use shmem:", yesno(gqk%qpt_comm%can_use_shmem())))
1985 : 24 : call wrtout(units, sjoin("P kpt_comm can use shmem:", yesno(gqk%kpt_comm%can_use_shmem())))
1986 : 24 : call wrtout(units, sjoin("P bsum_comm can use shmem:", yesno(gqk%bsum_comm%can_use_shmem())))
1987 : 48 : call wrtout(units, sjoin("P pp_sum_comm can use shmem:", yesno(gqk%pp_sum_comm%can_use_shmem())), newlines=1)
1988 : : end do ! my_is
1989 : :
1990 [ + - + + ]: 96 : if (my_rank == master) call gstore%print([std_out, ab_out])
1991 : :
1992 : : end associate
1993 : :
1994 [ - + - + : 24 : end subroutine gstore_set_mpi_grid__
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- - + - +
- + - + -
+ - + - +
- + - + ]
1995 : : !!***
1996 : :
1997 : : !----------------------------------------------------------------------
1998 : :
1999 : : !!****f* m_gstore/gstore_print
2000 : : !! NAME
2001 : : !! gstore_print
2002 : : !!
2003 : : !! FUNCTION
2004 : : !! Print info on the gstore object.
2005 : : !!
2006 : : !! INPUTS
2007 : : !! units: Unit numbers.
2008 : : !! [header]: header string
2009 : : !! [prtvol]: Verbosity level.
2010 : : !!
2011 : : !! SOURCE
2012 : :
2013 [ - + ]: 32 : subroutine gstore_print(gstore, units, header, prtvol)
2014 : :
2015 : : !Arguments ------------------------------------
2016 : : class(gstore_t),intent(inout) :: gstore
2017 : : integer,intent(in) :: units(:)
2018 : : character(len=*),optional,intent(in) :: header
2019 : : integer,optional,intent(in) :: prtvol
2020 : :
2021 : : !Local variables ------------------------------
2022 : : integer,parameter :: max_nk=10
2023 : : integer :: my_is, my_prtvol, ik_calc, ik_bz, ik_ibz !, iq_calc, iq_bz, iq_ibz
2024 : : real(dp) :: rtot_num_g
2025 : : character(len=500) :: msg
2026 : : !----------------------------------------------------------------------
2027 : :
2028 [ - + ]: 32 : my_prtvol = 0; if (present(prtvol)) my_prtvol = prtvol
2029 : :
2030 [ - + ]: 32 : if (present(header)) then
2031 : 0 : call wrtout(units, header)
2032 : : else
2033 : 32 : call wrtout(units, " === Gstore parameters ===")
2034 : : end if
2035 : :
2036 : 32 : call wrtout(units, sjoin(" kzone:", gstore%kzone))
2037 : 32 : call wrtout(units, sjoin(" kfilter:", gstore%kfilter))
2038 : 32 : call wrtout(units, sjoin(" nkibz:", itoa(gstore%nkibz)))
2039 : 32 : call wrtout(units, sjoin(" nkbz:", itoa(gstore%nkbz)))
2040 : 32 : call wrtout(units, sjoin(" glob_nk_spin:", ltoa(gstore%glob_nk_spin)))
2041 : 32 : call wrtout(units, sjoin(" qzone:", gstore%qzone))
2042 : 32 : call wrtout(units, sjoin(" nqibz:", itoa(gstore%nqibz)))
2043 : 32 : call wrtout(units, sjoin(" nqbz:", itoa(gstore%nqbz)))
2044 : 32 : call wrtout(units, sjoin(" glob_nq_spin:", ltoa(gstore%glob_nq_spin)))
2045 : 32 : call wrtout(units, sjoin(" kptopt:", itoa(gstore%ebands%kptopt)))
2046 : 32 : call wrtout(units, sjoin(" qptopt:", itoa(gstore%qptopt)))
2047 : 32 : call wrtout(units, sjoin(" has_used_lgk:", itoa(gstore%has_used_lgk)))
2048 : 32 : call wrtout(units, sjoin(" has_used_lgq:", itoa(gstore%has_used_lgq)))
2049 : 32 : call wrtout(units, sjoin(" with_vk:", itoa(gstore%with_vk)))
2050 : :
2051 [ + + ]: 64 : do my_is=1,gstore%my_nspins
2052 : 32 : associate (spin => gstore%my_spins(my_is), gqk => gstore%gqk(my_is))
2053 : 32 : call wrtout(units, sjoin(" gqk_cplex:", itoa(gqk%cplex)), pre_newlines=1)
2054 : 32 : call wrtout(units, sjoin(" gqk_bstart_k:", itoa(gqk%bstart_k)))
2055 : 32 : call wrtout(units, sjoin(" gqk_bstart_kq:", itoa(gqk%bstart_kq)))
2056 : 32 : call wrtout(units, sjoin(" gqk_bstop_k:", itoa(gqk%bstop_k)))
2057 : 32 : call wrtout(units, sjoin(" gqk_bstop_kq:", itoa(gqk%bstop_kq)))
2058 : 32 : call wrtout(units, sjoin(" gqk_nb_k:", itoa(gqk%nb_k)))
2059 : 32 : call wrtout(units, sjoin(" gqk_nb_kq:", itoa(gqk%nb_kq)))
2060 : 32 : rtot_num_g = (one * gqk%nb_kq * gqk%nb_k) * (gqk%glob_nk * gqk%glob_nq * one) * gqk%natom3
2061 : : !call wrtout(units, sjoin(" total number of g(k,q) elements:", ftoa(rtot_num_g)))
2062 : 32 : call wrtout(units, sjoin("P gqk_my_npert:", itoa(gqk%my_npert)))
2063 : 32 : call wrtout(units, sjoin("P gqk_my_nk:", itoa(gqk%my_nk)))
2064 : 32 : call wrtout(units, sjoin("P gqk_my_nq:", itoa(gqk%my_nq)))
2065 : 32 : call wrtout(units, sjoin(ch10, " === MPI distribution ==="))
2066 : 32 : call wrtout(units, sjoin("P Number of CPUs for parallelism over perturbations: ", itoa(gqk%pert_comm%nproc)))
2067 : 32 : call wrtout(units, sjoin("P Number of perturbations treated by this CPU: ", itoa(gqk%my_npert)))
2068 : 32 : call wrtout(units, sjoin("P Number of CPUs for parallelism over q-points: ", itoa(gqk%qpt_comm%nproc)))
2069 : 32 : call wrtout(units, sjoin("P Number of CPUs for parallelism over k-points: ", itoa(gqk%kpt_comm%nproc)))
2070 : : ! This only for GWPT calculations.
2071 [ - + ]: 32 : if (gqk%bsum_comm%nproc /= 1) then
2072 : 0 : call wrtout(units, sjoin("P Number of CPUs for parallelism over band summation: ", itoa(gqk%bsum_comm%nproc)))
2073 : : end if
2074 [ - + ]: 32 : if (gqk%pp_sum_comm%nproc /= 1) then
2075 : 0 : call wrtout(units, sjoin("P Number of CPUs for parallelism over wavevector summation: ", itoa(gqk%pp_sum_comm%nproc)))
2076 : : end if
2077 : :
2078 : : ! Print k-points
2079 : 32 : call wrtout(units, " k-points included in gstore:")
2080 [ + + ]: 226 : do ik_calc=1,gqk%glob_nk
2081 : 211 : ik_bz = gstore%kglob2bz(ik_calc, spin)
2082 : 211 : ik_ibz = gstore%kbz2ibz(1, ik_bz)
2083 : 211 : call wrtout(units, sjoin(itoa(ik_calc), ":", ktoa(gstore%kbz(:, ik_bz))))
2084 [ + + + - ]: 226 : if (ik_calc > max_nk .and. my_prtvol == 0) then
2085 : 17 : call wrtout(units, sjoin(" Max", itoa(max_nk), " k-points will be written. Use prtvol > 0 to print all of them."))
2086 : 17 : exit
2087 : : end if
2088 : : end do
2089 : : !call wrtout(units, " ")
2090 : :
2091 : : ! Print q-points
2092 : : !call wrtout(units, " q-points included in gstore:")
2093 : : !do iq_calc=1,gqk%glob_nq
2094 : : ! iq_bz = gstore%qglob2bz(iq_calc, spin)
2095 : : ! iq_ibz = gstore%qbz2ibz(1, iq_bz)
2096 : : ! call wrtout(units, sjoin(itoa(iq_calc), ":", ktoa(gstore%qbz(:, iq_bz))))
2097 : : ! if (iq_calc > max_nk .and. my_prtvol == 0) then
2098 : : ! call wrtout(units, sjoin(" Max", itoa(max_nk), " q-points will be written. Use prtvol > 0 to print all of them."))
2099 : : ! exit
2100 : : ! end if
2101 : : !end do
2102 : :
2103 : : ! Print memory
2104 [ - + ]: 32 : if (allocated(gqk%my_g2)) then
2105 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for |g|^2 array: ',ABI_MEM_MB(gqk%my_g2),' [mb] <<< mem'
2106 : 0 : call wrtout(units, msg)
2107 : : end if
2108 [ + + - + ]: 32 : if (gqk%has_both_g .and. associated(gqk%my_g2_ks)) then
2109 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for |g_KS|^2 array: ',ABI_MEM_MB(gqk%my_g2_ks),' [mb] <<< mem'
2110 : 0 : call wrtout(units, msg)
2111 : : end if
2112 [ - + ]: 32 : if (allocated(gqk%my_g)) then
2113 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for g array: ',ABI_MEM_MB(gqk%my_g),' [Mb] <<< MEM'
2114 : 0 : call wrtout(units, msg)
2115 : : end if
2116 [ + + - + ]: 32 : if (gqk%has_both_g .and. associated(gqk%my_g_ks)) then
2117 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for g_KS array: ',ABI_MEM_MB(gqk%my_g_ks),' [Mb] <<< MEM'
2118 : 0 : call wrtout(units, msg)
2119 : : end if
2120 [ - + ]: 32 : if (allocated(gqk%my_gdw2)) then
2121 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for gDW^2 array: ',ABI_MEM_MB(gqk%my_gdw2),' [mb] <<< mem'
2122 : : end if
2123 [ + + - + ]: 32 : if (gqk%has_both_g .and. associated(gqk%my_gdw2_ks)) then
2124 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for gDW^2_KS array: ',ABI_MEM_MB(gqk%my_gdw2_ks),' [mb] <<< mem'
2125 : : end if
2126 : :
2127 [ - + ]: 32 : if (allocated(gqk%vnk_cart_ibz)) then
2128 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for vnk_cart_ibz: ',ABI_MEM_MB(gqk%vnk_cart_ibz),' [Mb] <<< MEM'
2129 : 0 : call wrtout(units, msg)
2130 : : end if
2131 [ - + ]: 32 : if (allocated(gqk%vnk_mat_cart_ibz)) then
2132 [ # # ]: 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'
2133 : 0 : call wrtout(units, msg)
2134 : : end if
2135 [ - + ]: 64 : if (allocated(gqk%my_iv1p_comm)) then
2136 [ # # ]: 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'
2137 : : end if
2138 : : end associate
2139 : : end do
2140 : :
2141 [ - + ]: 32 : if (my_prtvol > 0) then
2142 : 0 : call gstore%ebands%print(units, header="Electron bands in GSTORE", prtvol=my_prtvol)
2143 : : end if
2144 : 32 : call wrtout(units, " ")
2145 : :
2146 : 32 : end subroutine gstore_print
2147 : : !!***
2148 : :
2149 : : !!****f* m_gstore/gstore_check_little_group
2150 : : !! NAME
2151 : : !! gstore_check_little_group
2152 : : !!
2153 : : !! FUNCTION
2154 : : !! Check consistency between little group options read from file and from input.
2155 : : !!
2156 : : !! INPUTS
2157 : : !!
2158 : : !! SOURCE
2159 : :
2160 : 7 : integer function gstore_check_little_group(gstore, dtset, msg) result(ierr)
2161 : :
2162 : : !Arguments ------------------------------------
2163 : : class(gstore_t),intent(in) :: gstore
2164 : : type(dataset_type),intent(in) :: dtset
2165 : : character(len=*),intent(out) :: msg
2166 : : !----------------------------------------------------------------------
2167 : :
2168 : 7 : ierr = 0; msg = ""
2169 : :
2170 [ - + ]: 7 : if (dtset%gstore_use_lgk /= 0) then
2171 : : ! Cannot use IBZ_k if we have used IBZ_q.
2172 [ # # ]: 0 : if (gstore%has_used_lgq /= 0) then
2173 [ # # # # ]: 0 : msg = sjoin("Input var gstore_use_lgq: ", itoa(dtset%gstore_use_lgq), ", but GSTORE file has:", itoa(gstore%has_used_lgq))
2174 : 0 : ABI_ERROR_NOSTOP(msg, ierr)
2175 : : end if
2176 : : ! Using IBZ_k when GSTORE has full BZ is OK but inefficient.
2177 [ # # ]: 0 : if (gstore%has_used_lgk == 0) then
2178 [ # # # # ]: 0 : msg = sjoin("Input var gstore_use_lgk: ", itoa(dtset%gstore_use_lgk), ", but GSTORE file has:", itoa(gstore%has_used_lgk))
2179 : 0 : ABI_COMMENT(msg)
2180 : : end if
2181 : : end if
2182 : :
2183 [ - + ]: 7 : if (dtset%gstore_use_lgq /= 0) then
2184 : : ! Cannot use IBZ_q if we have used IBZ_k.
2185 [ # # ]: 0 : if (gstore%has_used_lgk /= 0) then
2186 [ # # # # ]: 0 : msg = sjoin("Input var gstore_use_lgk: ", itoa(dtset%gstore_use_lgk), ", but GSTORE file has:", itoa(gstore%has_used_lgk))
2187 : 0 : ABI_ERROR_NOSTOP(msg, ierr)
2188 : : end if
2189 : : ! Using IBZ_q when GSTORE has full BZ is OK but inefficient.
2190 [ # # ]: 0 : if (gstore%has_used_lgq == 0) then
2191 [ # # # # ]: 0 : msg = sjoin("Input var gstore_use_lgq: ", itoa(dtset%gstore_use_lgq), ", but GSTORE file has:", itoa(gstore%has_used_lgq))
2192 : 0 : ABI_COMMENT(msg)
2193 : : end if
2194 : : end if
2195 : :
2196 [ + - ]: 7 : end function gstore_check_little_group
2197 : : !!***
2198 : :
2199 : : !----------------------------------------------------------------------
2200 : :
2201 : : !!****f* m_gstore/gstore_malloc__
2202 : : !! NAME
2203 : : !! gstore_malloc__
2204 : : !!
2205 : : !! FUNCTION
2206 : : !! Allocate local buffers once the MPI grid has been initialized.
2207 : : !!
2208 : : !! INPUTS
2209 : : !!
2210 : : !! OUTPUT
2211 : : !!
2212 : : !! SOURCE
2213 : :
2214 : 24 : subroutine gstore_malloc__(gstore, with_cplex, has_both_g, max_nq, qglob2bz, max_nk, kglob2bz, qbz2ibz, kbz2ibz)
2215 : :
2216 : : !Arguments ------------------------------------
2217 : : !scalars
2218 : : class(gstore_t),target,intent(inout) :: gstore
2219 : : integer,intent(in) :: with_cplex, max_nq, max_nk
2220 : : logical,intent(in) :: has_both_g
2221 : : integer,intent(in) :: qglob2bz(max_nq, gstore%nsppol), kglob2bz(max_nk, gstore%nsppol)
2222 : : integer,intent(in) :: qbz2ibz(6, gstore%nqbz), kbz2ibz(6, gstore%nkbz)
2223 : :
2224 : : !Local variables-------------------------------
2225 : : !scalars
2226 : : integer :: my_is, ierr, my_iq, my_ik, iq_glob, iq_bz, ik_glob, ik_bz
2227 : : integer :: ik_ibz, isym_k, trev_k, tsign_k, g0_k(3), nb_k, nb_kq
2228 : : logical :: isirr_k
2229 : : real(dp) :: mem_mb
2230 : : type(gqk_t), pointer :: gqk
2231 : : !----------------------------------------------------------------------
2232 : :
2233 [ - + ]: 24 : ABI_CHECK(with_cplex >= 0 .and. with_cplex <= 2, sjoin("Invalid with_cplex:", itoa(with_cplex)))
2234 : 24 : gstore%with_cplex = with_cplex
2235 : :
2236 [ + + ]: 48 : do my_is=1,gstore%my_nspins
2237 : 24 : associate (spin => gstore%my_spins(my_is))
2238 : 24 : gqk => gstore%gqk(my_is)
2239 : 24 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
2240 : 24 : gqk%has_both_g = has_both_g
2241 : :
2242 : : ! Split q-points and transfer symmetry tables.
2243 : : ! Note that glob_nq and glob_nk does not necessarily correspond to the size of the BZ
2244 : : ! First of all we have to consider kzone
2245 : : ! Even if kzone == "bz" we may have filtered the wavevectors e.g. Fermi surface.
2246 : 24 : call xmpi_split_block(gqk%glob_nq, gqk%qpt_comm%value, gqk%my_nq, gqk%my_q2glob)
2247 [ - + ]: 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"))
2248 : 24 : gqk%my_qstart = gqk%my_q2glob(1)
2249 : :
2250 [ - + + - : 72 : ABI_MALLOC(gqk%my_q2ibz, (6, gqk%my_nq))
+ - + - -
+ - + -
+ ]
2251 [ - + + - : 72 : ABI_MALLOC(gqk%my_q2bz, (gqk%my_nq))
+ - + - -
+ - + -
+ ]
2252 : :
2253 [ + + ]: 2330 : do my_iq=1,gqk%my_nq
2254 : 2306 : iq_glob = my_iq + gqk%my_qstart - 1
2255 : 2306 : iq_bz = qglob2bz(iq_glob, spin)
2256 [ + + ]: 16142 : gqk%my_q2ibz(:, my_iq) = qbz2ibz(:, iq_bz)
2257 : 2330 : gqk%my_q2bz(my_iq) = iq_bz
2258 : : end do
2259 : :
2260 : : ! Split k-points and transfer symmetry tables
2261 [ - + ]: 24 : call xmpi_split_block(gqk%glob_nk, gqk%kpt_comm%value, gqk%my_nk, gqk%my_k2glob)
2262 [ - + ]: 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"))
2263 : 24 : gqk%my_kstart = gqk%my_k2glob(1)
2264 : :
2265 [ - + + - : 72 : ABI_MALLOC(gqk%my_k2ibz, (6, gqk%my_nk))
+ - + - -
+ - + -
+ ]
2266 : : !ABI_MALLOC(gqk%my_k2bz, (gqk%my_nk))
2267 [ - + + - : 72 : ABI_MALLOC(gqk%my_kpts, (3, gqk%my_nk))
+ - + - -
+ - + -
+ ]
2268 [ - + + - : 72 : ABI_MALLOC(gqk%my_wtk, (gqk%my_nk))
+ - + - -
+ - + -
+ ]
2269 : :
2270 [ + + ]: 1020 : do my_ik=1,gqk%my_nk
2271 : 996 : ik_glob = my_ik + gqk%my_kstart - 1
2272 : 996 : ik_bz = kglob2bz(ik_glob, spin)
2273 [ + + ]: 6972 : gqk%my_k2ibz(:, my_ik) = kbz2ibz(:, ik_bz)
2274 : : !gqk%my_k2bz(my_ik) = ik_bz
2275 : :
2276 : 996 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
2277 [ + + ]: 3984 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5, my_ik)
2278 : : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
2279 [ - + ]: 996 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
2280 : :
2281 : : ! Note symrel^T convention for k
2282 [ + + + + : 30876 : gqk%my_kpts(:, my_ik) = tsign_k * matmul(transpose(gstore%cryst%symrel(:,:,isym_k)), gstore%kibz(:, ik_ibz)) + g0_k
+ + + + +
+ + - + -
+ + ]
2283 : :
2284 : 24 : select case(gstore%kzone)
2285 : : case ("ibz")
2286 : 18 : gqk%my_wtk(my_ik) = gstore%ebands%wtk(ik_ibz)
2287 : : case ("bz")
2288 [ + + - ]: 996 : gqk%my_wtk(my_ik) = one / gstore%nkbz
2289 : : end select
2290 : : end do
2291 : :
2292 : : ! Allocate storage for MPI-distributed e-ph matrix elements.
2293 [ - + + + ]: 48 : if (with_cplex > 0) then
2294 : 16 : mem_mb = (one * with_cplex * gqk%my_npert) * gqk%my_nq * gqk%my_nk * nb_kq * nb_k * eight * b2Mb
2295 : 16 : call wrtout(std_out, sjoin(" Local memory for e-ph matrix elements:", ftoa(mem_mb, fmt="f8.1"), " [Mb] <<< MEM"))
2296 : :
2297 : : ! The initialization with zero is important as not all the g are computed when we filter in k-space.
2298 : : ! Abinit postprocessing tools will operate of the full my_g array
2299 : : ! and we don't want to trigger floating point exceptions.
2300 : 6 : select case (with_cplex)
2301 : : case (1)
2302 [ - + + - : 42 : ABI_MALLOC_OR_DIE(gqk%my_g2, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - -
+ + - -
+ ]
2303 [ + + + + : 76305 : gqk%my_g2 = zero
+ + + + +
+ ]
2304 : :
2305 : 6 : gqk%my_g2_ks => gqk%my_g2
2306 [ + + ]: 6 : if (gqk%has_both_g) then
2307 [ - + + - : 35 : ABI_MALLOC_OR_DIE(gqk%my_g2_ks, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - ]
2308 [ + + + + : 40203 : gqk%my_g2_ks = zero
+ + + + +
+ ]
2309 : : end if
2310 : : case (2)
2311 [ - + + - : 70 : ABI_MALLOC_OR_DIE(gqk%my_g, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - -
+ + - -
+ ]
2312 [ + + + + : 4224533 : gqk%my_g = zero
+ + + + +
+ ]
2313 : :
2314 : 10 : gqk%my_g_ks => gqk%my_g
2315 [ + + ]: 10 : if (gqk%has_both_g) then
2316 : : !call wrtout(std_out, "Allocating my_g_ks") !; stop
2317 [ - + + - : 7 : ABI_MALLOC_OR_DIE(gqk%my_g_ks, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - ]
2318 [ + + + + : 18182 : gqk%my_g_ks = zero
+ + + + +
+ ]
2319 : : end if
2320 : : case default
2321 [ + + - ]: 16 : ABI_ERROR(sjoin("Wrong with_cplex:", itoa(with_cplex)))
2322 : : end select
2323 : :
2324 : : ! Allocate storage for MPI-distributed dH/dk matrix elements.
2325 [ + - ]: 16 : if (any(gstore%with_vk == [1, 2])) then
2326 : 16 : mem_mb = 3 * gqk%nb_k * gqk%my_nk * eight * b2Mb
2327 : 16 : call wrtout(std_out, sjoin(" Memory for diagonal vnk_cart_ibz:", ftoa(mem_mb, fmt="f8.1"), " [Mb] <<< MEM"))
2328 [ - + + - : 64 : ABI_MALLOC_OR_DIE(gqk%vnk_cart_ibz, (3, gqk%nb_k, gstore%nkibz), ierr)
- + + - +
- + - + -
+ - - + +
- - + ]
2329 [ + + + + : 2087 : gqk%vnk_cart_ibz = zero
+ + ]
2330 : : end if
2331 : :
2332 [ - + ]: 16 : if (gstore%with_vk == 2) then
2333 : 0 : mem_mb = two * 3 * gqk%nb_k**2 * gqk%my_nk * eight * b2Mb
2334 : 0 : call wrtout(std_out, sjoin(" Memory for vnk_mat_cart_ibz:", ftoa(mem_mb, fmt="f8.1"), " [Mb] <<< MEM"))
2335 [ # # # # : 0 : ABI_MALLOC_OR_DIE(gqk%vnk_mat_cart_ibz, (2, 3, gqk%nb_k, gqk%nb_k, gstore%nkibz), ierr)
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
2336 [ # # # # : 0 : gqk%vnk_mat_cart_ibz = zero
# # # # #
# ]
2337 : : end if
2338 : : end if
2339 : :
2340 : : end associate
2341 : : end do ! my_is
2342 : :
2343 : 24 : end subroutine gstore_malloc__
2344 : : !!***
2345 : :
2346 : : !----------------------------------------------------------------------
2347 : :
2348 : : !!****f* m_gstore/gstore_filter_fs_tetra__
2349 : : !! NAME
2350 : : !! gstore_filter_fs_tetra__
2351 : : !!
2352 : : !! FUNCTION
2353 : : !! Compute delta(e_k - e_F) with the tetrahedron method. Use weights to filter k-points.
2354 : : !! Include only those q-points such that there exists at least one k on the FS with k + q on the FS.
2355 : : !! Also, store and precompute gstore%delta_ef_kibz_spin(max_nb, gstore%nkibz, nsppol)
2356 : : !! to be used to filter inside gstore%compute.
2357 : : !!
2358 : : !! INPUTS
2359 : : !!
2360 : : !! OUTPUT
2361 : : !!
2362 : : !! SOURCE
2363 : :
2364 : 0 : subroutine gstore_filter_fs_tetra__(gstore, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
2365 : :
2366 : : !Arguments ------------------------------------
2367 : : !scalars
2368 : : class(gstore_t),intent(inout) :: gstore
2369 : : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2370 : : integer,intent(in) :: kibz2bz(gstore%nkibz)
2371 : : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2372 : : integer,intent(out) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2373 : :
2374 : : !Local variables-------------------------------
2375 : : !scalars
2376 : : integer,parameter :: tetra_opt0 = 0
2377 : : integer :: nsppol, ierr, cnt, spin, band, ib, ii, max_nb, all_nproc, my_rank, comm
2378 : : integer :: ik_bz, ik_ibz, iflag, nk_in_star
2379 : : real(dp) :: max_occ
2380 : : character(len=80) :: error_string
2381 : 0 : type(htetra_t) :: ktetra
2382 : : !arrays
2383 : 0 : integer,allocatable :: indkk(:), kstar_bz_inds(:)
2384 : : real(dp):: rlatt(3,3), klatt(3,3), delta_theta_ef(2) !, qpt(3)
2385 : 0 : real(dp),allocatable :: eig_ibz(:)
2386 : : !----------------------------------------------------------------------
2387 : :
2388 : : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2389 : :
2390 : 0 : comm = gstore%comm; all_nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
2391 : 0 : nsppol = gstore%nsppol
2392 : :
2393 : : !ABI_CHECK(gstore%same_nbands(msg), sjoin("VarPEq requires nb_k == nb_kq.", msg))
2394 : :
2395 : : ! Use the tetrahedron method to filter k- and k+q points on the FS in metals
2396 : : ! and define gstore%brange_k_spin automatically.
2397 : 0 : call wrtout(std_out, sjoin(" Filtering k-points using:", gstore%kfilter))
2398 : :
2399 : : ! NB: here we precompute brange_k_spin
2400 : : ! nb_kq == nb_k when FS filtering with tetra is used.
2401 : 0 : call ebands%get_bands_e0(ebands%fermie, gstore%brange_k_spin, ierr)
2402 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Error in ebands_get_bands_e0")
2403 [ # # # # : 0 : gstore%brange_kq_spin = gstore%brange_k_spin
# # # # #
# # # # #
# # ]
2404 : :
2405 [ # # # # : 0 : ABI_MALLOC(indkk, (gstore%nkbz))
# # # # #
# # # ]
2406 [ # # ]: 0 : indkk(:) = gstore%kbz2ibz(1, :)
2407 : :
2408 [ # # # # ]: 0 : rlatt = ebands%kptrlatt; call matr3inv(rlatt, klatt)
2409 : : call ktetra%init(indkk, gstore%cryst%gprimd, klatt, gstore%kbz, gstore%nkbz, gstore%kibz, gstore%nkibz, &
2410 [ # # # # : 0 : ierr, error_string, gstore%comm)
# # # # #
# ]
2411 [ # # ]: 0 : ABI_CHECK(ierr == 0, error_string)
2412 : :
2413 [ # # # # : 0 : ABI_MALLOC(eig_ibz, (gstore%nkibz))
# # # # #
# # # ]
2414 : 0 : max_occ = two / (ebands%nspinor * nsppol)
2415 [ # # # # ]: 0 : select_kbz_spin = 0
2416 : :
2417 [ # # ]: 0 : max_nb = maxval(gstore%brange_k_spin(2, :) - gstore%brange_k_spin(1, :) + 1)
2418 [ # # # # : 0 : ABI_CALLOC(gstore%delta_ef_kibz_spin, (max_nb, gstore%nkibz, gstore%nsppol))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
2419 : :
2420 : : cnt = 0
2421 [ # # ]: 0 : do spin=1,nsppol
2422 [ # # ]: 0 : do band=gstore%brange_k_spin(1, spin), gstore%brange_k_spin(2, spin)
2423 : 0 : ib = band - gstore%brange_k_spin(1, spin) + 1
2424 [ # # # # : 0 : eig_ibz = ebands%eig(band, :, spin)
# # # # ]
2425 : :
2426 [ # # ]: 0 : do ik_ibz=1,gstore%nkibz
2427 [ # # ]: 0 : cnt = cnt + 1; if (mod(cnt, all_nproc) /= my_rank) cycle ! MPI parallelism inside comm
2428 : :
2429 : : call ktetra%get_onewk_wvals(ik_ibz, tetra_opt0, 1, [ebands%fermie], max_occ, &
2430 [ # # ]: 0 : gstore%nkibz, eig_ibz, delta_theta_ef)
2431 : :
2432 : 0 : gstore%delta_ef_kibz_spin(ib, ik_ibz, spin) = delta_theta_ef(1)
2433 : :
2434 [ # # ]: 0 : iflag = merge(1, 0, abs(delta_theta_ef(1)) > zero)
2435 : :
2436 : : ! Use iflag to filter k-points.
2437 : 0 : select case (gstore%kzone)
2438 : : case ("ibz")
2439 : 0 : ik_bz = kibz2bz(ik_ibz)
2440 : 0 : select_kbz_spin(ik_bz, spin) = select_kbz_spin(ik_bz, spin) + iflag
2441 : :
2442 : : case ("bz")
2443 [ # # ]: 0 : call star_from_ibz_idx(ik_ibz, gstore%nkbz, gstore%kbz2ibz, nk_in_star, kstar_bz_inds)
2444 [ # # ]: 0 : ABI_CHECK(nk_in_star > 0, "Something wrong in star_from_ibz_idx")
2445 [ # # ]: 0 : do ii=1,nk_in_star
2446 : 0 : ik_bz = kstar_bz_inds(ii)
2447 : 0 : select_kbz_spin(ik_bz, spin) = select_kbz_spin(ik_bz, spin) + iflag
2448 : : end do
2449 [ # # # # : 0 : ABI_FREE(kstar_bz_inds)
# ]
2450 : : end select
2451 : : end do
2452 : :
2453 : : end do
2454 : : end do
2455 : :
2456 : : !call ktetra%print(std_out)
2457 : 0 : call xmpi_sum(select_kbz_spin, comm, ierr)
2458 : 0 : call xmpi_sum(gstore%delta_ef_kibz_spin, comm, ierr)
2459 : :
2460 : : ! Now the tricky part as we want to remove q-points that
2461 : : ! do not lead to any scattering process between two states on the FS
2462 : : ! Remember that k+q is always a sub-mesh of the input ebands k-mesh.
2463 : :
2464 : : call recompute_select_qbz_spin(gstore, gstore%qbz, qbz2ibz, qibz2bz, gstore%kbz, gstore%kibz, gstore%kbz2ibz, kibz2bz, &
2465 [ # # # # : 0 : select_kbz_spin, select_qbz_spin)
# # # # #
# ]
2466 : :
2467 [ # # ]: 0 : ABI_FREE(eig_ibz)
2468 [ # # ]: 0 : ABI_FREE(indkk)
2469 : 0 : call ktetra%free()
2470 : : end associate
2471 : :
2472 [ # # # # : 0 : end subroutine gstore_filter_fs_tetra__
# # # # #
# # # # #
# # # # #
# ]
2473 : : !!***
2474 : :
2475 : : !----------------------------------------------------------------------
2476 : :
2477 : : !!****f* m_gstore/gstore_filter_kptgw__
2478 : : !! NAME
2479 : : !! gstore_gw_filter_kptgw__
2480 : : !!
2481 : : !! FUNCTION
2482 : : !! Filter k-points according to the input variable kptgw. Useful for ZPR for user-specified k-points.
2483 : : !!
2484 : : !! INPUTS
2485 : : !!
2486 : : !! OUTPUT
2487 : : !!
2488 : : !! SOURCE
2489 : :
2490 : 0 : subroutine gstore_filter_kptgw__(gstore, dtset, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
2491 : :
2492 : : !Arguments ------------------------------------
2493 : : !scalars
2494 : : class(gstore_t),intent(inout) :: gstore
2495 : : type(dataset_type),intent(in) :: dtset
2496 : : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2497 : : integer,intent(in) :: kibz2bz(gstore%nkibz)
2498 : : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2499 : : integer,intent(out) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2500 : :
2501 : : !Local variables-------------------------------
2502 : : !scalars
2503 : : integer :: spin, ik_bz, ik_ibz, ik_calc, nkcalc, mapl_kk(6), my_rank
2504 : : !arrays
2505 : 0 : integer,allocatable :: bstart_ks(:,:), nbcalc_ks(:,:)
2506 : 0 : real(dp),allocatable :: kcalc(:,:)
2507 : : !----------------------------------------------------------------------
2508 : :
2509 : : ABI_UNUSED(qbz2ibz)
2510 : : ABI_UNUSED(qibz2bz)
2511 : :
2512 : : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2513 : :
2514 : 0 : my_rank = xmpi_comm_rank(gstore%comm)
2515 : :
2516 : 0 : call wrtout(std_out, sjoin(" Filtering k-points using nkptgw:", itoa(dtset%nkptgw)))
2517 [ # # ]: 0 : if (gstore%qzone /= "bz") then
2518 : 0 : ABI_ERROR(sjoin('kptgw filtering requires gstore_qzone = "bz" while it is: ', gstore%qzone))
2519 : : end if
2520 : :
2521 : : ! Compute nkcalc, kcalc, bstart_ks, nbcalc_ks
2522 : 0 : call sigtk_kcalc_from_nkptgw(dtset, dtset%mband, nkcalc, kcalc, bstart_ks, nbcalc_ks)
2523 : :
2524 : : ! TODO: kcalc should be spin-dependent to handle magnetic semiconductors.
2525 [ # # # # ]: 0 : select_kbz_spin = 0
2526 [ # # ]: 0 : do spin=1,gstore%nsppol
2527 [ # # ]: 0 : do ik_calc=1,nkcalc
2528 [ # # ]: 0 : if (kpts_map("symrel", ebands%kptopt, gstore%cryst, gstore%krank_ibz, 1, kcalc(:,ik_calc), mapl_kk) /= 0) then
2529 : 0 : ABI_ERROR(sjoin("Cannot map kcalc to IBZ with kcalc:", ktoa(kcalc(:,ik_calc))))
2530 : : end if
2531 : : ! Change select_kbz_spin
2532 : 0 : ik_ibz = mapl_kk(1)
2533 : 0 : ik_bz = kibz2bz(ik_ibz); select_kbz_spin(ik_bz, spin) = 1
2534 : : end do
2535 : : end do ! spin
2536 : :
2537 : : !call recompute_select_qbz_spin(gstore, gstore%qbz, qbz2ibz, qibz2bz, gstore%kbz, gstore%kibz, gstore%kbz2ibz, gstore%kibz2bz, &
2538 : : ! select_kbz_spin, select_qbz_spin)
2539 : :
2540 [ # # ]: 0 : ABI_FREE(kcalc)
2541 [ # # ]: 0 : ABI_FREE(bstart_ks)
2542 [ # # ]: 0 : ABI_FREE(nbcalc_ks)
2543 : : end associate
2544 : :
2545 : 0 : end subroutine gstore_filter_kptgw__
2546 : : !!***
2547 : :
2548 : : !----------------------------------------------------------------------
2549 : :
2550 : : !!****f* m_gstore/gstore_filter_erange__
2551 : : !! NAME
2552 : : !! gstore_filter_erange__
2553 : : !!
2554 : : !! FUNCTION
2555 : : !! Filter k-points and q-points according to an energy range.
2556 : : !!
2557 : : !! INPUTS
2558 : : !!
2559 : : !! OUTPUT
2560 : : !!
2561 : : !! SOURCE
2562 : :
2563 : 1 : subroutine gstore_filter_erange__(gstore, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
2564 : :
2565 : : !Arguments ------------------------------------
2566 : : !scalars
2567 : : class(gstore_t),intent(inout) :: gstore
2568 : : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2569 : : integer,intent(in) :: kibz2bz(gstore%nkibz)
2570 : : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2571 : : integer,intent(out) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2572 : :
2573 : : !Local variables-------------------------------
2574 : : !scalars
2575 : : integer,parameter :: tetra_opt0 = 0
2576 : : integer :: nsppol, cnt, spin, ii, all_nproc, my_rank, comm, band ! ierr,
2577 : : integer :: ik_bz, ik_ibz, iflag, nk_in_star, gap_err
2578 : : logical :: assume_gap
2579 : : real(dp) :: ee, abs_erange1, abs_erange2, vmax, cmin
2580 : : type(gaps_t) :: gaps
2581 : : !arrays
2582 : 1 : integer,allocatable :: kstar_bz_inds(:)
2583 : : !----------------------------------------------------------------------
2584 : :
2585 : : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2586 : :
2587 : 1 : comm = gstore%comm; all_nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
2588 : 1 : nsppol = gstore%nsppol
2589 : :
2590 : : ! filter k and k + q points according to erange and define gstore%brange_spin_k automatically.
2591 : : ! NB: here we recompute brange_k_spin
2592 : : call wrtout(std_out, sjoin(" Filtering k-points using gstore_erange:", &
2593 [ + + + - : 4 : ltoa(reshape(gstore%erange_spin, [2 * gstore%nsppol]) * Ha_eV), "(eV)"))
+ + ]
2594 : :
2595 [ + - + - : 1 : assume_gap = .not. all(gstore%erange_spin < zero)
- + ]
2596 : 1 : gaps = ebands%get_gaps(gap_err)
2597 [ + - + + ]: 2 : if (assume_gap) call gaps%print([std_out])
2598 : :
2599 [ + + + + ]: 2199 : select_kbz_spin = 0; cnt = 0
2600 : :
2601 [ + + ]: 2 : do spin=1,nsppol
2602 : : ! Init brange. NB: nb_kq == nb_k when erange filtering is used.
2603 [ + + ]: 3 : gstore%brange_k_spin(:, spin) = [huge(1), -huge(1)]
2604 [ + + ]: 3 : gstore%brange_kq_spin(:, spin) = [huge(1), -huge(1)]
2605 : 1 : abs_erange1 = abs(gstore%erange_spin(1, spin))
2606 : 1 : abs_erange2 = abs(gstore%erange_spin(2, spin))
2607 : :
2608 [ + - ]: 1 : if (assume_gap) then
2609 : : ! Get CBM and VBM with some tolerance
2610 : 1 : vmax = gaps%vb_max(spin) + tol2 * eV_Ha
2611 : 1 : cmin = gaps%cb_min(spin) - tol2 * eV_Ha
2612 : : else
2613 : 0 : vmax = ebands%fermie
2614 : 0 : cmin = ebands%fermie
2615 : : end if
2616 : :
2617 [ + + ]: 7 : do band=1, ebands%mband
2618 [ + + ]: 511 : do ik_ibz=1,gstore%nkibz
2619 : : !cnt = cnt + 1; if (mod(cnt, all_nproc) /= my_rank) cycle ! MPI parallelism inside comm
2620 : :
2621 : : ! Use iflag to filter k-points.
2622 : 504 : ee = ebands%eig(band, ik_ibz, spin)
2623 : 504 : iflag = 0
2624 : :
2625 [ + - ]: 504 : if (abs_erange1 > zero) then
2626 : : ! Filter valence states.
2627 [ # # # # ]: 0 : if (ee <= vmax .and. vmax - ee <= abs_erange1) then
2628 : 504 : iflag = 1 !; write(std_out, *), "Adding valence band", band, " with ee [eV]: ", ee * Ha_eV
2629 : : end if
2630 : : end if
2631 [ + - ]: 504 : if (abs_erange2 > zero) then
2632 : : ! Filter conduction states.
2633 [ + + + + ]: 504 : if (ee >= cmin .and. ee - cmin <= abs_erange2) then
2634 : : iflag = 1 !; write(std_out, *)"Adding conduction band", band, " with ee [eV]: ", ee * Ha_eV
2635 : : end if
2636 : : end if
2637 : :
2638 [ - + ]: 502 : if (iflag == 1) then
2639 : 8 : gstore%brange_k_spin(1, spin) = min(gstore%brange_k_spin(1, spin), band)
2640 : 8 : gstore%brange_k_spin(2, spin) = max(gstore%brange_k_spin(2, spin), band)
2641 : 8 : gstore%brange_kq_spin(1, spin) = min(gstore%brange_kq_spin(1, spin), band)
2642 : 8 : gstore%brange_kq_spin(2, spin) = max(gstore%brange_kq_spin(2, spin), band)
2643 : :
2644 : 0 : select case (gstore%kzone)
2645 : : case ("ibz")
2646 : 0 : ik_bz = kibz2bz(ik_ibz)
2647 : 0 : select_kbz_spin(ik_bz, spin) = iflag
2648 : :
2649 : : case ("bz")
2650 [ - + ]: 8 : call star_from_ibz_idx(ik_ibz, gstore%nkbz, gstore%kbz2ibz, nk_in_star, kstar_bz_inds)
2651 [ - + ]: 8 : ABI_CHECK(nk_in_star > 0, "Something wrong in star_from_ibz_idx")
2652 [ + + ]: 97 : do ii=1,nk_in_star
2653 : 89 : ik_bz = kstar_bz_inds(ii)
2654 : 97 : select_kbz_spin(ik_bz, spin) = iflag
2655 : : end do
2656 [ - + - - : 16 : ABI_FREE(kstar_bz_inds)
+ ]
2657 : : end select
2658 : : end if
2659 : :
2660 : : end do ! band
2661 : : end do ! ik_ibz
2662 : :
2663 : : !call wrtout(std_out, sjoin("brange_k_spin:", ltoa(gstore%brange_k_spin(:, spin))))
2664 : : !call wrtout(std_out, sjoin("count_select_kbz:", itoa(count(select_kbz_spin == 1))))
2665 : : !call wrtout(std_out, sjoin("brange_kq_spin:", ltoa(gstore%brange_k_qspin(:, spin))))
2666 : : !call wrtout(std_out, sjoin("count_select_kbz:", itoa(count(select_kbz_spin == 1))))
2667 : :
2668 [ + + + - : 3 : if (any(gstore%brange_k_spin(:, spin) == [huge(1), -huge(1)])) then
- + ]
2669 : 0 : ABI_ERROR("Empty list of states inside gstore_erange")
2670 : : end if
2671 [ + + + - : 4 : if (any(gstore%brange_kq_spin(:, spin) == [huge(1), -huge(1)])) then
- + ]
2672 : 0 : ABI_ERROR("Empty list of states inside gstore_erange")
2673 : : end if
2674 : :
2675 : : end do ! spin
2676 : :
2677 : : !call xmpi_sum(select_kbz_spin, comm, ierr)
2678 : : call recompute_select_qbz_spin(gstore, gstore%qbz, qbz2ibz, qibz2bz, gstore%kbz, gstore%kibz, gstore%kbz2ibz, kibz2bz, &
2679 [ + - - - : 1 : select_kbz_spin, select_qbz_spin)
- - - - -
+ ]
2680 : :
2681 : 2 : call gaps%free()
2682 : : end associate
2683 : :
2684 [ - + - + : 1 : end subroutine gstore_filter_erange__
- + - + -
+ - + - +
- + - + ]
2685 : : !!***
2686 : :
2687 : : !----------------------------------------------------------------------
2688 : :
2689 : : !!****f* m_gstore/gstore_filter_gw_qprange__
2690 : : !! NAME
2691 : : !! gstore_gw_filter_qprange__
2692 : : !!
2693 : : !! FUNCTION
2694 : : !! Filter k-points according to the input variable gw_qprange. Useful for ZPR.
2695 : : !!
2696 : : !! INPUTS
2697 : : !!
2698 : : !! OUTPUT
2699 : : !!
2700 : : !! SOURCE
2701 : :
2702 : 4 : subroutine gstore_filter_gw_qprange__(gstore, dtset, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
2703 : :
2704 : : !Arguments ------------------------------------
2705 : : !scalars
2706 : : class(gstore_t),intent(inout) :: gstore
2707 : : type(dataset_type),intent(in) :: dtset
2708 : : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2709 : : integer,intent(in) :: kibz2bz(gstore%nkibz)
2710 : : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2711 : : integer,intent(out) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2712 : :
2713 : : !Local variables-------------------------------
2714 : : !scalars
2715 : : integer :: spin, ik_bz, ik_ibz, gap_err, ik_calc, nkcalc, mapl_kk(6), my_rank
2716 : 4 : type(gaps_t) :: gaps
2717 : : !arrays
2718 : 4 : integer,allocatable :: bstart_ks(:,:), nbcalc_ks(:,:)
2719 : 4 : real(dp),allocatable :: kcalc(:,:)
2720 : : !----------------------------------------------------------------------
2721 : :
2722 : : ABI_UNUSED(qbz2ibz)
2723 : : ABI_UNUSED(qibz2bz)
2724 : :
2725 : : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2726 : :
2727 : 8 : my_rank = xmpi_comm_rank(gstore%comm)
2728 : :
2729 : 4 : call wrtout(std_out, sjoin(" Filtering k-points using gw_qprange:", itoa(dtset%gw_qprange)))
2730 [ - + ]: 4 : if (gstore%qzone /= "bz") then
2731 : 0 : ABI_ERROR(sjoin('gw_qprange filtering requires gstore_qzone = "bz" while it is: ', gstore%qzone))
2732 : : end if
2733 : :
2734 : 4 : gaps = ebands%get_gaps(gap_err)
2735 [ + - + + ]: 8 : if (my_rank == 0) call gaps%print([std_out])
2736 [ - + ]: 4 : if (gap_err /= 0) then
2737 : 0 : ABI_ERROR("Cannot compute fundamental and direct gap (likely metal).")
2738 : : end if
2739 : :
2740 : : ! Use gw_qprange to select the interesting k-points and the corresponding bands.
2741 : : !
2742 : : ! 0 --> Compute the QP corrections only for the fundamental and the direct gap.
2743 : : ! +num --> Compute the QP corrections for all the k-points in the irreducible zone and include `num`
2744 : : ! bands above and below the Fermi level.
2745 : : ! -num --> Compute the QP corrections for all the k-points in the irreducible zone.
2746 : : ! Include all occupied states and `num` empty states.
2747 : :
2748 : : ! Compute nkcalc, kcalc, bstart_ks, nbcalc_ks
2749 [ - + ]: 4 : if (dtset%gw_qprange /= 0) then
2750 : 0 : call sigtk_kcalc_from_qprange(dtset, gstore%cryst, ebands, dtset%gw_qprange, nkcalc, kcalc, bstart_ks, nbcalc_ks)
2751 : : else
2752 : : ! gw_qprange is not specified in the input.
2753 : : ! Include direct and fundamental KS gap or include states depending on the position wrt band edges.
2754 : 4 : call sigtk_kcalc_from_gaps(dtset, ebands, gaps, nkcalc, kcalc, bstart_ks, nbcalc_ks)
2755 : : end if
2756 : :
2757 : : ! TODO: kcalc should be spin-dependent to handle magnetic semiconductors.
2758 [ + + + + ]: 152 : select_kbz_spin = 0
2759 [ + + ]: 8 : do spin=1,gstore%nsppol
2760 [ + + ]: 14 : do ik_calc=1,nkcalc
2761 [ - + ]: 6 : if (kpts_map("symrel", ebands%kptopt, gstore%cryst, gstore%krank_ibz, 1, kcalc(:,ik_calc), mapl_kk) /= 0) then
2762 : 0 : ABI_ERROR(sjoin("Cannot map kcalc to IBZ with kcalc:", ktoa(kcalc(:,ik_calc))))
2763 : : end if
2764 : : ! Change select_kbz_spin
2765 : 6 : ik_ibz = mapl_kk(1)
2766 : 10 : ik_bz = kibz2bz(ik_ibz); select_kbz_spin(ik_bz, spin) = 1
2767 : : end do
2768 : : end do ! spin
2769 : :
2770 : : !call recompute_select_qbz_spin(gstore, gstore%qbz, qbz2ibz, qibz2bz, gstore%kbz, gstore%kibz, gstore%kbz2ibz, gstore%kibz2bz, &
2771 : : ! select_kbz_spin, select_qbz_spin)
2772 : :
2773 [ - + ]: 4 : ABI_FREE(kcalc)
2774 [ - + ]: 4 : ABI_FREE(bstart_ks)
2775 [ - + ]: 4 : ABI_FREE(nbcalc_ks)
2776 : 8 : call gaps%free()
2777 : : end associate
2778 : :
2779 [ - + - + : 4 : end subroutine gstore_filter_gw_qprange__
- + - + -
+ - + - +
- + ]
2780 : : !!***
2781 : :
2782 : : !!****f* m_gstore/recompute_select_qbz_spin
2783 : : !! NAME
2784 : : !! recompute_select_qbz_spin
2785 : : !!
2786 : : !! FUNCTION
2787 : : !! Recompute select_qbz_spin table after the filtering on the k-points.
2788 : : !!
2789 : : !! INPUTS
2790 : : !!
2791 : : !! OUTPUT
2792 : : !!
2793 : : !! SOURCE
2794 : :
2795 : 1 : subroutine recompute_select_qbz_spin(gstore, qbz, qbz2ibz, qibz2bz, kbz, kibz, kbz2ibz, kibz2bz, &
2796 : 1 : select_kbz_spin, select_qbz_spin)
2797 : :
2798 : : !Arguments ------------------------------------
2799 : : !scalars
2800 : : class(gstore_t),intent(inout) :: gstore
2801 : : !arrays
2802 : : real(dp),intent(in) :: qbz(3, gstore%nqbz)
2803 : : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2804 : : integer,intent(in) :: kbz2ibz(6,gstore%nkbz), kibz2bz(gstore%nkibz)
2805 : : real(dp),target,intent(in) :: kibz(3, gstore%nkibz), kbz(3, gstore%nkbz)
2806 : : integer,intent(in) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2807 : : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2808 : :
2809 : : !Local variables-------------------------------
2810 : : !scalars
2811 : : integer :: all_nproc, my_rank, ierr, ii, ik_bz, iq_bz, iq_ibz, ikq_ibz, ikq_bz, len_kpts_ptr, ebands_kptopt, spin
2812 : : !arrays
2813 : 1 : integer,allocatable :: map_kq(:,:)
2814 : : real(dp) :: qpt(3)
2815 : 1 : real(dp),contiguous, pointer :: kpts_ptr(:,:)
2816 : : ! *************************************************************************
2817 : :
2818 : : ABI_UNUSED(kbz2ibz)
2819 : : ABI_UNUSED(qbz2ibz)
2820 : :
2821 : 1 : all_nproc = xmpi_comm_size(gstore%comm); my_rank = xmpi_comm_rank(gstore%comm)
2822 : 1 : ebands_kptopt = gstore%ebands%kptopt
2823 : :
2824 [ + + + + ]: 2199 : select_qbz_spin = 0
2825 : :
2826 [ - + ]: 1 : if (gstore%kzone == "ibz") kpts_ptr => kibz
2827 [ + - ]: 1 : if (gstore%kzone == "bz") kpts_ptr => kbz
2828 : 1 : len_kpts_ptr = size(kpts_ptr, dim=2)
2829 [ - + + - : 3 : ABI_MALLOC(map_kq, (6, len_kpts_ptr))
+ - + - -
+ - + ]
2830 : :
2831 : 0 : select case (gstore%qzone)
2832 : : case ("ibz")
2833 [ # # ]: 0 : do iq_ibz=1,gstore%nqibz
2834 [ # # ]: 0 : if (mod(iq_ibz, all_nproc) /= my_rank) cycle ! MPI parallelism.
2835 [ # # ]: 0 : qpt = gstore%qibz(:, iq_ibz)
2836 : 0 : iq_bz = qibz2bz(iq_ibz)
2837 : : ! k + q_ibz --> k IBZ --> k BZ
2838 : :
2839 [ # # ]: 0 : if (kpts_map("symrel", ebands_kptopt, gstore%cryst, gstore%krank_ibz, len_kpts_ptr, kpts_ptr, map_kq, qpt=qpt) /= 0) then
2840 : 0 : ABI_ERROR("Cannot map k+q to IBZ!")
2841 : : end if
2842 : :
2843 [ # # ]: 0 : do ii=1,len_kpts_ptr
2844 : : ! get the k-index in BZ
2845 : 0 : select case (gstore%kzone)
2846 : : case ("bz")
2847 : 0 : ik_bz = ii
2848 : : case ("ibz")
2849 [ # # # ]: 0 : ik_bz = kibz2bz(ii)
2850 : : end select
2851 : :
2852 [ # # ]: 0 : do spin=1,gstore%nsppol
2853 [ # # ]: 0 : if (select_kbz_spin(ik_bz, spin) /= 0) then
2854 : : ! now, see if q-point connects k-points inside the filtered zone
2855 : 0 : ikq_ibz = map_kq(1, ii)
2856 : 0 : ikq_bz = kibz2bz(ikq_ibz)
2857 [ # # ]: 0 : select_qbz_spin(iq_bz, :) = select_qbz_spin(iq_bz, :) + select_kbz_spin(ikq_bz, :)
2858 : : end if
2859 : : end do
2860 : : end do
2861 : : end do ! iq_ibz
2862 : :
2863 : : case ("bz")
2864 [ - + - + : 2198 : do iq_bz=1,gstore%nqbz
+ ]
2865 [ + - ]: 2197 : if (mod(iq_bz, all_nproc) /= my_rank) cycle ! MPI parallelism.
2866 [ + + ]: 8788 : qpt = qbz(:, iq_bz)
2867 : : !iq_ibz = qbz2ibz(1, iq_bz)
2868 : : ! k + q_bz --> k IBZ --> k BZ
2869 : :
2870 [ - + ]: 2197 : if (kpts_map("symrel", ebands_kptopt, gstore%cryst, gstore%krank_ibz, len_kpts_ptr, kpts_ptr, map_kq, qpt=qpt) /= 0) then
2871 : 0 : ABI_ERROR("Cannot map k+q to IBZ!")
2872 : : end if
2873 : :
2874 : : ! here we loop over all k-points in iBZ (kzone="ibz") or BZ (kzone="bz")
2875 [ + + ]: 4829007 : do ii=1,len_kpts_ptr
2876 : : ! but for each spin, we have to loop only over e-range filtered kpts
2877 : :
2878 : : ! get the k-index in BZ
2879 : 9653618 : select case (gstore%kzone)
2880 : : case ("bz")
2881 : 4826809 : ik_bz = ii
2882 : : case ("ibz")
2883 [ + - - ]: 4826809 : ik_bz = kibz2bz(ii)
2884 : : end select
2885 : :
2886 [ + + ]: 9655815 : do spin=1,gstore%nsppol
2887 : : ! Now, see if q-point connects k-points inside the filtered zone
2888 [ + + ]: 9653618 : if (select_kbz_spin(ik_bz, spin) /= 0) then
2889 : 195533 : ikq_ibz = map_kq(1, ii)
2890 : 195533 : ikq_bz = kibz2bz(ikq_ibz)
2891 : 195533 : select_qbz_spin(iq_bz, spin) = select_qbz_spin(iq_bz, spin) + select_kbz_spin(ikq_bz, spin)
2892 : : end if
2893 : : end do
2894 : :
2895 : : end do
2896 : : end do
2897 : : end select
2898 : :
2899 : 1 : call xmpi_sum(select_qbz_spin, gstore%comm, ierr)
2900 : :
2901 [ - + ]: 1 : ABI_FREE(map_kq)
2902 : :
2903 : 1 : end subroutine recompute_select_qbz_spin
2904 : : !!***
2905 : :
2906 : : !!****f* m_gstore/gstore_spin2my_is
2907 : : !! NAME
2908 : : !! gstore_spin2my_is
2909 : : !!
2910 : : !! FUNCTION
2911 : : !! Return the local spin index from the global spin index.
2912 : : !! 0 if this spin is not treated by this MPI proc.
2913 : : !!
2914 : : !! SOURCE
2915 : :
2916 : 16 : integer pure function gstore_spin2my_is(gstore, spin) result(my_is)
2917 : :
2918 : : !Arguments ------------------------------------
2919 : : class(gstore_t),intent(in) :: gstore
2920 : : integer,intent(in) :: spin
2921 : : !----------------------------------------------------------------------
2922 : :
2923 [ + - ]: 16 : do my_is=1,gstore%my_nspins
2924 [ - + ]: 16 : if (gstore%my_spins(my_is) == spin) return
2925 : : end do
2926 : 16 : my_is = 0
2927 : :
2928 : : end function gstore_spin2my_is
2929 : : !!***
2930 : :
2931 : : !----------------------------------------------------------------------
2932 : :
2933 : : !!****f* m_gstore/gstore_fill_bks_mask
2934 : : !! NAME
2935 : : !! gstore_fill_bks_mask
2936 : : !!
2937 : : !! FUNCTION
2938 : : !! Fills the bks_mask array defining the set of wavefunctions that should be read
2939 : : !! from the WFK file by this MPI rank when computing the KS e-ph matrix elements.
2940 : : !!
2941 : : !! INPUTS
2942 : : !!
2943 : : !! OUTPUT
2944 : : !!
2945 : : !! SOURCE
2946 : :
2947 : 12 : subroutine gstore_fill_bks_mask(gstore, mband, nkibz, nsppol, bks_mask)
2948 : :
2949 : : !Arguments ------------------------------------
2950 : : class(gstore_t),intent(inout) :: gstore
2951 : : integer,intent(in) :: mband, nkibz, nsppol
2952 : : logical,intent(out) :: bks_mask(mband, nkibz, nsppol)
2953 : :
2954 : : !Local variables-------------------------------
2955 : : !scalars
2956 : : integer :: my_is, my_ik, my_iq, spin, ik_ibz, ikq_ibz, ebands_kptopt, bstart_k, bstop_k, bstart_kq, bstop_kq
2957 : : real(dp) :: weight_q, cpu, wall, gflops
2958 : : !arrays
2959 : 12 : integer,allocatable :: map_kq(:,:)
2960 : : real(dp) :: qpt(3)
2961 : : !----------------------------------------------------------------------
2962 : :
2963 : 12 : call cwtime(cpu, wall, gflops, "start")
2964 : : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2965 : :
2966 [ + + + + : 1992 : bks_mask = .False.; ebands_kptopt = gstore%ebands%kptopt
+ + ]
2967 : :
2968 [ + + ]: 24 : do my_is=1,gstore%my_nspins
2969 : 12 : associate (gqk => gstore%gqk(my_is))
2970 : 12 : spin = gstore%my_spins(my_is)
2971 : 12 : bstart_k = gqk%bstart_k; bstop_k = gqk%bstop_k
2972 : 12 : bstart_kq = gqk%bstart_kq; bstop_kq = gqk%bstop_kq
2973 : :
2974 : : ! Stop if dtset%nband < gstore%nband before sigfaulting.
2975 : 0 : ABI_CHECK_ILEQ(bstop_k, mband, "bstop_k should be smaller that mband present in WFK")
2976 [ - + ]: 12 : ABI_CHECK_ILEQ(bstop_kq, mband, "bstop_kq should be smaller that mband present in WFK")
2977 : :
2978 : : ! We need the image of this k-point in the IBZ.
2979 [ + + ]: 330 : do my_ik=1,gqk%my_nk
2980 : 318 : ik_ibz = gqk%my_k2ibz(1, my_ik)
2981 [ + + ]: 1139 : bks_mask(bstart_k:bstop_k, ik_ibz, spin) = .True.
2982 : : end do
2983 : :
2984 : : ! As well as the image of k+q in the IBZ.
2985 [ - + + - : 36 : ABI_MALLOC(map_kq, (6, gqk%my_nk))
+ - + - -
+ - + ]
2986 : :
2987 [ + + ]: 1057 : do my_iq=1,gqk%my_nq
2988 : 1045 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
2989 : :
2990 [ - + ]: 1045 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, map_kq, qpt=qpt) /= 0) then
2991 : 0 : ABI_ERROR(sjoin("Cannot map k+q to IBZ with qpt:", ktoa(qpt)))
2992 : : end if
2993 : :
2994 [ + + ]: 74912 : do my_ik=1,gqk%my_nk
2995 : 73855 : ikq_ibz = map_kq(1, my_ik)
2996 [ + + ]: 193527 : bks_mask(bstart_kq:bstop_kq, ikq_ibz, spin) = .True.
2997 : : end do
2998 : : end do
2999 : :
3000 [ - + - + ]: 24 : ABI_FREE(map_kq)
3001 : : end associate
3002 : : end do ! my_is
3003 : :
3004 : 12 : call cwtime_report(" gstore_fill_bks_mask", cpu, wall, gflops)
3005 : : end associate
3006 : :
3007 : 24 : end subroutine gstore_fill_bks_mask
3008 : : !!***
3009 : :
3010 : : !----------------------------------------------------------------------
3011 : :
3012 : : !!****f* m_gstore/gstore_fill_bks_mask_with_pp
3013 : : !! NAME
3014 : : !! gstore_fill_bks_mask_with_pp
3015 : : !!
3016 : : !! FUNCTION
3017 : : !! Fill the bks_mask array defining the set of states that should be read from the WFK file
3018 : : !! by this MPI rank when computing the GWPT e-ph matrix elements in which we have
3019 : : !! to consider k+q, k-q and k+q-p as well as the sum over states (bsum).
3020 : : !!
3021 : : !! INPUTS
3022 : : !!
3023 : : !! OUTPUT
3024 : : !!
3025 : : !! SOURCE
3026 : :
3027 : 3 : subroutine gstore_fill_bks_mask_pp_mesh(gstore, ecut, mband, nkibz, nsppol, my_pp_start_spin, my_pp_stop_spin, pp_mesh, &
3028 : 3 : my_bsum_start, my_bsum_stop, bks_mask, mpw, gmax)
3029 : :
3030 : : !Arguments ------------------------------------
3031 : : class(gstore_t),target,intent(inout) :: gstore
3032 : : real(dp),intent(in) :: ecut
3033 : : integer,intent(in) :: mband, nkibz, nsppol
3034 : : integer :: my_pp_start_spin(nsppol), my_pp_stop_spin(nsppol)
3035 : : type(kmesh_t),intent(in) :: pp_mesh
3036 : : integer,intent(in) :: my_bsum_start(nsppol), my_bsum_stop(nsppol)
3037 : : logical,intent(out) :: bks_mask(mband, nkibz, nsppol)
3038 : : integer,intent(out) :: mpw, gmax(3)
3039 : :
3040 : : !Local variables-------------------------------
3041 : : !scalars
3042 : : integer,parameter :: istwfk1 = 1
3043 : : 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)
3044 : : integer :: cnt, ii
3045 : : real(dp) :: weight_q, cpu, wall, gflops
3046 : : type(gqk_t),pointer :: gqk
3047 : : type(crystal_t),pointer :: cryst
3048 : : !arrays
3049 : 3 : integer,allocatable :: map_kq(:,:), gtmp(:,:), kq2ibz(:,:)
3050 : : real(dp) :: qpt(3), pp(3), kk(3)
3051 : 3 : real(dp),allocatable :: kq_list(:,:)
3052 : : !----------------------------------------------------------------------
3053 : :
3054 : 3 : call cwtime(cpu, wall, gflops, "start")
3055 : :
3056 : : ! TODO: These loops can be parallelized using bsum_comm and pert_comm if needed.
3057 [ + + + + : 237 : bks_mask = .False.; cryst => gstore%cryst
+ + ]
3058 : 3 : ebands_kptopt = gstore%ebands%kptopt
3059 : 3 : mpw = 0; gmax = 0
3060 : :
3061 [ + + ]: 6 : do my_is=1,gstore%my_nspins
3062 : 3 : gqk => gstore%gqk(my_is); spin = gstore%my_spins(my_is)
3063 : :
3064 : : ! These are the first and last band indices used in the sum over states (possibly MPI-distributed)
3065 : 3 : b1 = my_bsum_start(spin); b2 = my_bsum_stop(spin)
3066 : :
3067 : : ! Stop if dtset%nband < gstore%nband before sigfaulting.
3068 [ - + ]: 3 : ABI_CHECK_ILEQ(gqk%bstop_k, mband, "bstop_k should be smaller that mband present in WFK")
3069 [ - + ]: 3 : ABI_CHECK_ILEQ(gqk%bstop_kq, mband, "bstop_kq should be smaller that mband present in WFK")
3070 [ - + ]: 3 : ABI_CHECK_ILEQ(b2, mband, "max band index in sum should be smaller that mband present in WFK")
3071 : :
3072 [ - + + - : 9 : ABI_MALLOC(map_kq, (6, gqk%my_nk))
+ - + - -
+ - + ]
3073 : : ! SC: kpts_map rebuilds its table of the symmetry images of the IBZ at each call (~ 2*nsym*nkibz get_rank), so one
3074 : : ! call per q and per (q,p) costs ~ my_nq*(1+my_npp)*2*nsym*nkibz get_rank: a few minutes for a 32x32x32 k-mesh,
3075 : : ! about a day for 88x88x88. The k+q and the k+q-p points are now stored in kq_list and mapped with one call after
3076 : : ! each loop, as done for gstore%kbz2ibz in gstore_init.
3077 [ - + + - : 9 : ABI_MALLOC(kq_list, (3, gqk%my_nk * gqk%my_nq * max(1, my_pp_stop_spin(spin) - my_pp_start_spin(spin) + 1)))
+ - + - -
+ - + ]
3078 [ - + + - : 9 : ABI_MALLOC(kq2ibz, (6, size(kq_list, dim=2)))
+ - + - -
+ - + ]
3079 : :
3080 : 3 : cnt = 0
3081 [ + + ]: 8 : do my_ik=1,gqk%my_nk
3082 [ + + ]: 20 : kk = gqk%my_kpts(:, my_ik); ik_ibz = gqk%my_k2ibz(1, my_ik)
3083 : :
3084 : : ! We need the image of this k-point in the IBZ for the incoming state |psi_nk>.
3085 [ + + ]: 33 : bks_mask(gqk%bstart_k:gqk%bstop_k, ik_ibz, spin) = .True.
3086 : :
3087 : : ! We also need the image of k+q in the IBZ for the outgoing state <psi_mkq|.
3088 [ + + ]: 104 : do my_iq=1,gqk%my_nq
3089 : 96 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3090 : : !if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, 1, kk, map_kq, qpt=qpt) /= 0) then
3091 : : ! ABI_ERROR(sjoin("Cannot map k+q to IBZ with qpt:", ktoa(qpt)))
3092 : : !end if
3093 : : !ikq_ibz = map_kq(1, 1)
3094 : : !bks_mask(gqk%bstart_kq:gqk%bstop_kq, ikq_ibz, spin) = .True.
3095 [ + + ]: 389 : cnt = cnt + 1; kq_list(:, cnt) = kk + qpt
3096 : : end do ! my_iq
3097 : :
3098 : : end do ! my_ok
3099 : :
3100 [ - + ]: 3 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, cnt, kq_list, kq2ibz) /= 0) then
3101 : 0 : ABI_ERROR(sjoin("k+q not on the k-mesh (q-mesh not a sub-mesh of the k-mesh?) for spin:", itoa(spin)))
3102 : : end if
3103 [ + + ]: 99 : do ii=1,cnt
3104 [ + + ]: 1123 : bks_mask(gqk%bstart_kq:gqk%bstop_kq, kq2ibz(1, ii), spin) = .True.
3105 : : end do
3106 : :
3107 : : ! We also need the image of k-p in the IBZ for the pp wavevectors treated by this MPI rank.
3108 : : ! These states are summed over so use b1 and b2.
3109 [ + + ]: 83 : do ipp_bz=my_pp_start_spin(spin), my_pp_stop_spin(spin)
3110 [ + + ]: 320 : pp = pp_mesh%bz(:,ipp_bz)
3111 [ + + - + ]: 320 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, map_kq, qpt=-pp) /= 0) then
3112 : 0 : ABI_ERROR(sjoin("Cannot map k-p to IBZ with qpt:", ktoa(qpt), "and pp:", ktoa(pp)))
3113 : : end if
3114 : :
3115 [ + + ]: 179 : do my_ik=1,gqk%my_nk
3116 : 96 : ikq_ibz = map_kq(1, my_ik)
3117 [ + + ]: 1120 : bks_mask(b1:b2, ikq_ibz, spin) = .True.
3118 : : ! Compute g-sphere, returns onpw. Note istwfk == 1.
3119 [ + + ]: 384 : kk = gqk%my_kpts(:, my_ik)
3120 [ + + - + ]: 384 : call get_kg(kk-pp, istwfk1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3121 [ - + ]: 176 : ABI_FREE(gtmp)
3122 : : end do
3123 : : end do ! ipp_bz
3124 : :
3125 : : ! We also need the image of k+q-p in the IBZ for the pp wavevectors treated by this MPI rank.
3126 : : ! These states are summed over so use b1 and b2.
3127 : 3 : cnt = 0
3128 [ + + ]: 83 : do my_iq=1,gqk%my_nq
3129 : 80 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3130 : :
3131 [ + + ]: 4307 : do ipp_bz=my_pp_start_spin(spin), my_pp_stop_spin(spin)
3132 [ + + ]: 16896 : pp = pp_mesh%bz(:,ipp_bz)
3133 : :
3134 : : !if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, map_kq, qpt=qpt-pp) /= 0) then
3135 : : ! ABI_ERROR(sjoin("Cannot map k+q-p to IBZ with qpt:", ktoa(qpt), "and pp:", ktoa(pp)))
3136 : : !end if
3137 : :
3138 [ + + ]: 8656 : do my_ik=1,gqk%my_nk
3139 : : !ikq_ibz = map_kq(1, my_ik)
3140 : : !bks_mask(b1:b2, ikq_ibz, spin) = .True.
3141 : : ! Compute g-sphere, returns onpw. Note istwfk = 1.
3142 [ + + ]: 17408 : kk = gqk%my_kpts(:, my_ik)
3143 [ + + ]: 17408 : cnt = cnt + 1; kq_list(:, cnt) = kk + (qpt - pp)
3144 [ + + - + ]: 17408 : call get_kg(kk+qpt-pp, istwfk1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3145 [ - + ]: 8576 : ABI_FREE(gtmp)
3146 : : end do
3147 : : end do ! ipp_bz
3148 : :
3149 : : end do ! my_iq
3150 : :
3151 [ - + ]: 3 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, cnt, kq_list, kq2ibz) /= 0) then
3152 : 0 : ABI_ERROR(sjoin("k+q-p not on the k-mesh for spin:", itoa(spin)))
3153 : : end if
3154 [ + + ]: 4355 : do ii=1,cnt
3155 [ + + ]: 48387 : bks_mask(b1:b2, kq2ibz(1, ii), spin) = .True.
3156 : : end do
3157 : :
3158 [ - + ]: 3 : ABI_FREE(kq_list)
3159 [ - + ]: 3 : ABI_FREE(kq2ibz)
3160 [ - + ]: 6 : ABI_FREE(map_kq)
3161 : : end do ! my_is
3162 : :
3163 : 3 : my_mpw = mpw; call xmpi_max(my_mpw, mpw, gstore%comm, ierr)
3164 : 3 : my_gmax = gmax; call xmpi_max(my_gmax, gmax, gstore%comm, ierr)
3165 : :
3166 : : ! TODO
3167 : : !call gstore%get_mpw_gmax(ecut, mpw, gmax, pp_max=)
3168 : :
3169 : 3 : call wrtout(std_out, sjoin(' Optimal value of mpw: ', itoa(mpw)))
3170 : 3 : call cwtime_report(" gstore_fill_bks_mask_pp_mesh", cpu, wall, gflops)
3171 : :
3172 [ - + ]: 3 : end subroutine gstore_fill_bks_mask_pp_mesh
3173 : : !!***
3174 : :
3175 : : !----------------------------------------------------------------------
3176 : :
3177 : : !!****f* m_gstore/gstore_get_mpw_gmax
3178 : : !! NAME
3179 : : !! gstore_get_mpw_gmax
3180 : : !!
3181 : : !! FUNCTION
3182 : : !! Compute the maximum number of PWs for all possible k+q treated.
3183 : : !!
3184 : : !! INPUTS
3185 : : !!
3186 : : !! OUTPUT
3187 : : !!
3188 : : !! SOURCE
3189 : :
3190 : 12 : subroutine gstore_get_mpw_gmax(gstore, ecut, mpw, gmax, pp_max)
3191 : :
3192 : : !Arguments ------------------------------------
3193 : : class(gstore_t),intent(in) :: gstore
3194 : : real(dp),intent(in) :: ecut
3195 : : integer,intent(out) :: mpw, gmax(3)
3196 : : integer,optional,intent(in) :: pp_max
3197 : :
3198 : : !Local variables-------------------------------
3199 : : integer,parameter :: istwfk1 = 1
3200 : : integer :: my_is, my_ik, my_iq, spin, onpw, ierr, my_mpw, ipx, ipy, ipz, nprocs, my_rank, pp_max__ !, cnt, i1, i2, i3,
3201 : : real(dp) :: weight_q, cpu, wall, gflops
3202 : : !arrays
3203 : : integer :: my_gmax(3)
3204 : 12 : integer,allocatable :: gtmp(:,:)
3205 : : real(dp) :: kk(3), kq(3), qpt(3), pp(3) !, kq_max(3)
3206 : : !----------------------------------------------------------------------
3207 : :
3208 : : ! TODO: This is an hotspot due to the double loop over k and q. Should use a geometrical approach to compute mpw and gmax.
3209 : 12 : call wrtout(std_out, " Computing mpw. This may take some time for dense k/q meshes...", pre_newlines=1)
3210 : 12 : call cwtime(cpu, wall, gflops, "start")
3211 : :
3212 : 12 : nprocs = xmpi_comm_size(gstore%comm); my_rank = xmpi_comm_rank(gstore%comm)
3213 : 12 : mpw = 0; gmax = 0
3214 [ - + ]: 12 : pp_max__ = 0; if (present(pp_max)) pp_max__ = pp_max
3215 : :
3216 [ + + ]: 24 : do my_is=1,gstore%my_nspins
3217 : 12 : associate (gqk => gstore%gqk(my_is))
3218 : 12 : spin = gstore%my_spins(my_is)
3219 [ + + ]: 330 : do my_ik=1,gqk%my_nk
3220 [ + + ]: 1272 : kk = gqk%my_kpts(:, my_ik)
3221 : :
3222 : : ! Compute g-sphere, returns onpw. Note istwfk == 1.
3223 [ - + ]: 318 : call get_kg(kk, istwfk1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3224 [ - + ]: 318 : ABI_FREE(gtmp)
3225 : :
3226 [ + + ]: 74185 : do my_iq=1,gqk%my_nq
3227 : 73855 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3228 [ + + ]: 295420 : kq = kk + qpt
3229 : :
3230 : : ! TODO: g0 umklapp here can enter into play! gmax could not be large enough!
3231 [ + + ]: 148028 : do ipz=-pp_max__,pp_max__
3232 [ + + ]: 221565 : do ipy=-pp_max__,pp_max__
3233 [ + + ]: 221565 : do ipx=-pp_max__,pp_max__
3234 [ + + ]: 295420 : pp = [ipx, ipy, ipz] * half
3235 [ + + - + ]: 295420 : call get_kg(kq - pp, 1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3236 [ - + ]: 147710 : ABI_FREE(gtmp)
3237 : : end do
3238 : : end do
3239 : : end do
3240 : : end do ! my_iq
3241 : :
3242 : : end do ! my_ik
3243 : : end associate
3244 : : end do ! my_is
3245 : :
3246 : 12 : my_mpw = mpw; call xmpi_max(my_mpw, mpw, gstore%comm, ierr)
3247 : 12 : my_gmax = gmax; call xmpi_max(my_gmax, gmax, gstore%comm, ierr)
3248 : :
3249 : 12 : call wrtout(std_out, sjoin(' Optimal value of mpw: ', itoa(mpw), "with gmax:", ltoa(gmax)))
3250 : 12 : call cwtime_report(" gstore_get_mpw_gmax", cpu, wall, gflops)
3251 : :
3252 [ - + ]: 12 : end subroutine gstore_get_mpw_gmax
3253 : : !!***
3254 : :
3255 : : !----------------------------------------------------------------------
3256 : :
3257 : : !!****f* m_gstore/gstore_free
3258 : : !! NAME
3259 : : !! gstore_free
3260 : : !!
3261 : : !! FUNCTION
3262 : : !! Free dynamic memory in gstore_t.
3263 : : !!
3264 : : !! SOURCE
3265 : :
3266 : 24 : subroutine gstore_free(gstore)
3267 : :
3268 : : !Arguments ------------------------------------
3269 : : class(gstore_t),intent(inout) :: gstore
3270 : :
3271 : : !Local variables-------------------------------
3272 : : integer :: my_is
3273 : : !----------------------------------------------------------------------
3274 : :
3275 [ + + ]: 48 : do my_is=1,gstore%my_nspins
3276 : 48 : call gstore%gqk(my_is)%free()
3277 : : end do
3278 [ + - + + : 48 : ABI_SFREE(gstore%gqk)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ ]
3279 : :
3280 [ - + ]: 24 : ABI_SFREE(gstore%delta_ef_kibz_spin)
3281 [ + - ]: 24 : ABI_SFREE(gstore%qibz)
3282 [ + - ]: 24 : ABI_SFREE(gstore%wtq)
3283 [ + - ]: 24 : ABI_SFREE(gstore%my_spins)
3284 [ + - ]: 24 : ABI_SFREE(gstore%brange_k_spin)
3285 [ + - ]: 24 : ABI_SFREE(gstore%brange_kq_spin)
3286 [ + - ]: 24 : ABI_SFREE(gstore%glob_nk_spin)
3287 [ + - ]: 24 : ABI_SFREE(gstore%glob_nq_spin)
3288 [ + - ]: 24 : ABI_SFREE(gstore%kglob2bz)
3289 [ + - ]: 24 : ABI_SFREE(gstore%kbz2ibz)
3290 [ + - ]: 24 : ABI_SFREE(gstore%erange_spin)
3291 [ + - ]: 24 : ABI_SFREE(gstore%qbz)
3292 [ + - ]: 24 : ABI_SFREE(gstore%kbz)
3293 : :
3294 [ - + ]: 24 : if (gstore%has_wannier) then
3295 : 0 : call gstore%ebands%free()
3296 [ # # # # : 0 : ABI_FREE_SCALAR(gstore%ebands)
# # # # #
# # # # #
# # # # #
# # # #
# ]
3297 : : nullify(gstore%ebands)
3298 : : end if
3299 : :
3300 : 24 : call gstore%krank_ibz%free()
3301 : 24 : call gstore%qrank_ibz%free()
3302 : 24 : gstore%with_cplex = -1
3303 : :
3304 : 24 : end subroutine gstore_free
3305 : : !!***
3306 : :
3307 : : !----------------------------------------------------------------------
3308 : :
3309 : : !!****f* m_gstore/gqk_myqpt
3310 : : !! NAME
3311 : : !! gqk_myqpt
3312 : : !!
3313 : : !! FUNCTION
3314 : : !! Return the weight_q and the reduced coordinates of the q-point from the local index my_iq.
3315 : : !!
3316 : : !! INPUTS
3317 : : !!
3318 : : !! OUTPUT
3319 : : !!
3320 : : !! SOURCE
3321 : :
3322 : 77422 : pure subroutine gqk_myqpt(gqk, my_iq, gstore, weight_q, qpt)
3323 : :
3324 : : !Arguments ------------------------------------
3325 : : class(gqk_t),intent(in) :: gqk
3326 : : class(gstore_t),intent(in) :: gstore
3327 : : integer,intent(in) :: my_iq
3328 : : real(dp),intent(out) :: weight_q, qpt(3)
3329 : :
3330 : : !Local variables ------------------------------
3331 : : integer :: iq_ibz, isym_q, trev_q, tsign_q, g0_q(3)
3332 : : logical :: isirr_q
3333 : : !----------------------------------------------------------------------
3334 : :
3335 : : ! Symmetry tables for q-points.
3336 : 77422 : iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
3337 [ + + ]: 309688 : trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5, my_iq)
3338 : : isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
3339 [ - + ]: 77422 : tsign_q = 1; if (trev_q == 1) tsign_q = -1
3340 : :
3341 : : ! NB: Use symrec convention for q
3342 [ + + + + : 2167816 : qpt = tsign_q * matmul(gstore%cryst%symrec(:,:,isym_q), gstore%qibz(:, iq_ibz)) + g0_q
+ + + + +
- + - +
+ ]
3343 : :
3344 : 0 : select case(gstore%qzone)
3345 : : case ("ibz")
3346 : 0 : weight_q = gstore%wtq(iq_ibz)
3347 : : case ("bz")
3348 [ - + - ]: 77422 : weight_q = one / gstore%nqbz
3349 : : end select
3350 : :
3351 : 77422 : end subroutine gqk_myqpt
3352 : : !!***
3353 : :
3354 : : !----------------------------------------------------------------------
3355 : :
3356 : : !!****f* m_gstore/gqk_dbldelta_qpt
3357 : : !! NAME
3358 : : !! gqk_dbldelta_qpt
3359 : : !!
3360 : : !! FUNCTION
3361 : : !! Note that k/q weights are not included in dbl_delta_q
3362 : : !!
3363 : : !! INPUTS
3364 : : !!
3365 : : !! OUTPUT
3366 : : !!
3367 : : !! SOURCE
3368 : :
3369 : 0 : subroutine gqk_dbldelta_qpt(gqk, my_iq, gstore, eph_intmeth, eph_fsmear, qpt, weight_q, dbl_delta_q)
3370 : :
3371 : : !Arguments ------------------------------------
3372 : : class(gqk_t),intent(in) :: gqk
3373 : : class(gstore_t),target,intent(inout) :: gstore
3374 : : integer,intent(in) :: my_iq, eph_intmeth
3375 : : real(dp),intent(in) :: eph_fsmear
3376 : : real(dp),intent(out) :: qpt(3), weight_q, dbl_delta_q(gqk%nb_kq, gqk%nb_k, gqk%my_nk)
3377 : :
3378 : : !Local variables ------------------------------
3379 : : !scalars
3380 : : real(dp), parameter :: min_smear = tol9
3381 : : integer :: nb_k, nb_kq, nkbz, spin, my_ik, ib, ib1, ib2, band1, band2, nesting
3382 : : integer :: ik_ibz, isym_k, trev_k, tsign_k, g0_k(3)
3383 : : integer :: ikq_ibz, isym_kq, trev_kq, tsign_kq, g0_kq(3), ii, i1, i2, i3, cnt, ik_bz, ltetra
3384 : : real(dp) :: g1, g2, sigma !, weight_k !, cpu, wall, gflops
3385 : : logical :: isirr_k, isirr_kq, use_adaptive
3386 : : type(ebands_t), pointer :: ebands
3387 : : type(crystal_t), pointer :: cryst
3388 : 0 : type(krank_t) :: my_krank
3389 : : !arrays
3390 : : integer :: nge(3), ngw(3)
3391 : 0 : integer,allocatable :: my_kqmap(:,:), kmesh_map(:,:)
3392 : 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)
3393 : 0 : real(dp),allocatable :: eig_k(:,:), eig_kq(:,:), kmesh(:,:), wght_bz(:,:,:)
3394 : : !----------------------------------------------------------------------
3395 : :
3396 : 0 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq; nkbz = gstore%nkbz; spin = gqk%spin
3397 : 0 : ebands => gstore%ebands; cryst => gstore%cryst
3398 : :
3399 [ # # ]: 0 : ABI_CHECK_IEQ(nb_k, nb_kq, "gqk_dbldelta_qpt does not support nb_k != nb_kq")
3400 : :
3401 : 0 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3402 : :
3403 : : ! The double delta with tetra is ill-defined for q == 0. In this case we fall back to gaussian.
3404 [ # # # # : 0 : nesting = merge(1, 0, abs(eph_intmeth) == 2 .and. all(abs(qpt) < tol12))
# # # # ]
3405 : :
3406 [ # # # # ]: 0 : rlatt = gstore%ebands%kptrlatt; call matr3inv(rlatt, klatt)
3407 [ # # ]: 0 : kmesh_cartvec(:, 1) = cryst%gprimd(:,1)*klatt(1,1) + cryst%gprimd(:,2)*klatt(2,1) + cryst%gprimd(:,3)*klatt(3,1)
3408 [ # # ]: 0 : kmesh_cartvec(:, 2) = cryst%gprimd(:,1)*klatt(1,2) + cryst%gprimd(:,2)*klatt(2,2) + cryst%gprimd(:,3)*klatt(3,2)
3409 [ # # ]: 0 : kmesh_cartvec(:, 3) = cryst%gprimd(:,1)*klatt(1,3) + cryst%gprimd(:,2)*klatt(2,3) + cryst%gprimd(:,3)*klatt(3,3)
3410 : : ! TODO: It seems that two_pi is not needed here!
3411 : :
3412 [ # # # # ]: 0 : if (abs(eph_intmeth) == 1 .or. nesting /= 0) then
3413 [ # # # # ]: 0 : use_adaptive = eph_fsmear < zero .or. abs(eph_intmeth) == 2
3414 : : if (use_adaptive) then
3415 [ # # ]: 0 : ABI_CHECK(allocated(gqk%vnk_cart_ibz), "vnk_cart_ibz should be allocated when use_adaptive is .True.")
3416 : : end if
3417 : :
3418 : : ! Find k + q in the IBZ for all my k-points.
3419 [ # # # # : 0 : ABI_MALLOC(my_kqmap, (6, gqk%my_nk))
# # # # #
# # # ]
3420 [ # # ]: 0 : if (kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, my_kqmap, qpt=qpt) /= 0) then
3421 : 0 : ABI_ERROR(sjoin("Cannot map k+q to IBZ with qpt:", ktoa(qpt)))
3422 : : end if
3423 : :
3424 : : ! Init default sigma
3425 : 0 : sigma = eph_fsmear
3426 : :
3427 [ # # ]: 0 : do my_ik=1,gqk%my_nk
3428 : 0 : kk = gqk%my_kpts(:, my_ik)
3429 : :
3430 : 0 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
3431 [ # # ]: 0 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5, my_ik)
3432 [ # # # # : 0 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
# # # # ]
3433 [ # # ]: 0 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
3434 : :
3435 : 0 : ikq_ibz = my_kqmap(1, my_ik); isym_kq = my_kqmap(2, my_ik)
3436 [ # # ]: 0 : trev_kq = my_kqmap(6, my_ik); g0_kq = my_kqmap(3:5, my_ik)
3437 [ # # # # : 0 : isirr_kq = (isym_kq == 1 .and. trev_kq == 0 .and. all(g0_kq == 0))
# # # # ]
3438 [ # # ]: 0 : tsign_kq = 1; if (trev_kq == 1) tsign_kq = -1
3439 : :
3440 [ # # ]: 0 : if (use_adaptive) then
3441 : : ! If k or k+q is not in the IBZ, we need to recostruct the value by symmetry using v(Sq) = S v(q).
3442 : : ! Use transpose(R) because we are using the tables for the wavefunctions
3443 : : ! In this case listkk has been called with symrec and use_symrec=False
3444 : : ! so q_bz = S^T q_ibz where S is the isym_kq symmetry
3445 [ # # # # ]: 0 : vb_k = gqk%vnk_cart_ibz(:,:,ik_ibz)
3446 [ # # # # ]: 0 : vb_kq = gqk%vnk_cart_ibz(:,:,ikq_ibz)
3447 : :
3448 [ # # ]: 0 : if (.not. isirr_k) then
3449 [ # # ]: 0 : do ib=1,nb_k
3450 [ # # # # ]: 0 : vb_k(:,ib) = tsign_k * matmul(transpose(cryst%symrel_cart(:,:,isym_k)), vb_k(:,ib))
3451 : : end do
3452 : : end if
3453 [ # # ]: 0 : if (.not. isirr_kq) then
3454 [ # # ]: 0 : do ib=1,nb_kq
3455 [ # # # # ]: 0 : vb_kq(:,ib) = tsign_kq * matmul(transpose(cryst%symrel_cart(:,:,isym_kq)), vb_kq(:,ib))
3456 : : end do
3457 : : end if
3458 : : end if
3459 : :
3460 [ # # ]: 0 : do ib2=1,nb_k
3461 : 0 : band2 = ib2 + gqk%bstart_k - 1
3462 [ # # ]: 0 : if (use_adaptive) then
3463 [ # # # # : 0 : sigma = max(maxval([(abs(dot_product(vb_k(:, ib2), kmesh_cartvec(:,ii))), ii=1,3)]), min_smear)
# # # # #
# ]
3464 : : !write(std_out, *)"sigma:", sigma * Ha_eV
3465 : : end if
3466 : 0 : g2 = gaussian(ebands%eig(band2, ik_ibz, spin) - ebands%fermie, sigma)
3467 : :
3468 [ # # ]: 0 : do ib1=1,nb_kq
3469 : 0 : band1 = ib1 + gqk%bstart_kq - 1
3470 [ # # ]: 0 : if (use_adaptive) then
3471 [ # # # # : 0 : sigma = max(maxval([(abs(dot_product(vb_kq(:, ib1), kmesh_cartvec(:,ii))), ii=1,3)]), min_smear)
# # # # #
# ]
3472 : : end if
3473 : 0 : g1 = gaussian(ebands%eig(band1, ikq_ibz, spin) - ebands%fermie, sigma)
3474 : 0 : dbl_delta_q(ib1, ib2, my_ik) = g1 * g2 ! / fs%nktot
3475 : : end do
3476 : :
3477 : : end do
3478 : : end do
3479 : :
3480 [ # # ]: 0 : ABI_FREE(my_kqmap)
3481 : :
3482 [ # # ]: 0 : else if (abs(eph_intmeth) == 2) then
3483 : :
3484 [ # # ]: 0 : ABI_CHECK(isdiagmat(ebands%kptrlatt), "kptrlatt must be diagonal when tetra is used.")
3485 [ # # ]: 0 : ABI_CHECK(ebands%nshiftk == 1, "nshiftk must be 1 when tetra is used")
3486 : 0 : nge = get_diag(ebands%kptrlatt); ngw = nge
3487 [ # # # # : 0 : ABI_CHECK_IEQ(nkbz, product(nge(1:3)), "Wrong nge")
# # ]
3488 : :
3489 : : ! Compute eig_k and eig_kq in full BZ for the relevant bands around Ef.
3490 [ # # # # : 0 : ABI_MALLOC(kmesh, (3, nkbz))
# # # # #
# # # ]
3491 [ # # # # : 0 : ABI_MALLOC(eig_k, (nb_k, nkbz))
# # # # #
# # # # #
# # ]
3492 [ # # # # : 0 : ABI_MALLOC(eig_kq, (nb_kq, nkbz))
# # # # #
# # # # #
# # ]
3493 : :
3494 : : ! Technical problems:
3495 : : !
3496 : : ! 1) libtetrabz works with the BZ and assumes a certaing ordering of the k-points (see below)
3497 : : ! so we have to fill the array with eig_k and eig_kq from the IBZ by remapping the libtetra kk
3498 : : ! to the Abinit IBZ
3499 : :
3500 : : ! 2) The dbldelta weights are given in the BZ, while the caller requires weights for k in the IBZ
3501 : : ! and moreover only for the IBZ k-point treated by this MPI proc.
3502 : :
3503 : 0 : ik_bz = 0
3504 [ # # ]: 0 : do i3=0,nge(3) - 1
3505 [ # # ]: 0 : do i2=0,nge(2) - 1
3506 [ # # ]: 0 : do i1=0,nge(1) - 1
3507 : 0 : ik_bz = ik_bz + 1
3508 [ # # ]: 0 : kk = ([i1, i2, i3] + ebands%shiftk(:, 1)) / nge(:)
3509 [ # # ]: 0 : kmesh(:, ik_bz) = kk
3510 : : end do
3511 : : end do
3512 : : end do
3513 : :
3514 : : ! Map libtetra BZ mesh to IBZ and fill eig_k
3515 : : !call cwtime(cpu, wall, gflops, "start")
3516 [ # # # # : 0 : ABI_MALLOC(kmesh_map, (6, nkbz))
# # # # #
# # # ]
3517 : :
3518 : : ! Find correspondence between libtetra mesh and the IBZ.
3519 [ # # ]: 0 : if (kpts_map("symrec", ebands%kptopt, cryst, gstore%krank_ibz, nkbz, kmesh, kmesh_map) /= 0) then
3520 : 0 : ABI_ERROR("Cannot map libtetra mesh to IBZ")
3521 : : end if
3522 : :
3523 [ # # ]: 0 : do ik_bz=1,nkbz
3524 : 0 : ik_ibz = kmesh_map(1, ik_bz)
3525 [ # # ]: 0 : eig_k(:, ik_bz) = ebands%eig(gqk%bstart_k:gqk%bstop_k, ik_ibz, spin) - ebands%fermie
3526 : : end do
3527 : :
3528 : : ! Map libtetra BZ mesh + q to IBZ and fill eig_kq.
3529 [ # # ]: 0 : if (kpts_map("symrec", ebands%kptopt, cryst, gstore%krank_ibz, nkbz, kmesh, kmesh_map, qpt=qpt) /= 0) then
3530 : 0 : ABI_ERROR(sjoin("Cannot map libtetra k+q to IBZ with qpt:", ktoa(qpt)))
3531 : : end if
3532 : :
3533 [ # # ]: 0 : do ik_bz=1,nkbz
3534 : 0 : ikq_ibz = kmesh_map(1, ik_bz)
3535 [ # # ]: 0 : eig_kq(:, ik_bz) = ebands%eig(gqk%bstart_kq:gqk%bstop_kq, ikq_ibz, spin) - ebands%fermie
3536 : : end do
3537 : :
3538 [ # # ]: 0 : ABI_FREE(kmesh_map)
3539 : : !call cwtime_report(" kmesh_map", cpu, wall, gflops)
3540 : :
3541 : : ! Call libtetra routine to compute weights for double delta integration.
3542 : : ! Note that libtetra assumes Ef set to zero.
3543 : : ! TODO: Average weights over degenerate states?
3544 : : ! NB: This is a bottleneck, can pass comm_kp
3545 : :
3546 : : ! Select option for double delta with tetra.
3547 : : ! 2 for the optimized tetrahedron method.
3548 : : ! -2 for the linear tetrahedron method.
3549 : 0 : ltetra = 0
3550 [ # # ]: 0 : if (eph_intmeth == 2) ltetra = 2
3551 [ # # ]: 0 : if (eph_intmeth == -2) ltetra = 1
3552 : :
3553 [ # # # # : 0 : ABI_MALLOC(wght_bz, (nb_k, nb_kq, nkbz))
# # # # #
# # # # #
# # # # #
# ]
3554 : 0 : call libtetrabz_dbldelta(ltetra, gstore%cryst%gprimd, nb_k, nge, eig_k, eig_kq, ngw, wght_bz) !, comm=comm)
3555 : : !call cwtime_report(" libtetrabz_dbldelta", cpu, wall, gflops)
3556 : :
3557 : 0 : call my_krank%init(gqk%my_nk, gqk%my_kpts)
3558 : :
3559 : : ! Reindex from full BZ to my set of kpoints and rescale weights.
3560 : 0 : cnt = 0
3561 [ # # ]: 0 : do ik_bz=1,nkbz
3562 : 0 : my_ik = my_krank%get_index(kmesh(:, ik_bz))
3563 [ # # ]: 0 : if (my_ik /= -1) then
3564 [ # # # # ]: 0 : dbl_delta_q(:,:,my_ik) = wght_bz(:,:,ik_bz) * gstore%nkbz
3565 : 0 : cnt = cnt + 1
3566 : : end if
3567 : : end do
3568 : :
3569 : : ! FIXME: BUG if k-point (and q-point) parallelism.
3570 [ # # ]: 0 : ABI_CHECK_IEQ(cnt, gqk%my_nk, sjoin("cnt != my_nk, ", itoa(cnt), itoa(gqk%my_nk)))
3571 : 0 : call my_krank%free()
3572 : : !call cwtime_report(" transfer", cpu, wall, gflops)
3573 : :
3574 [ # # ]: 0 : ABI_FREE(wght_bz)
3575 [ # # ]: 0 : ABI_FREE(kmesh)
3576 [ # # ]: 0 : ABI_FREE(eig_k)
3577 [ # # ]: 0 : ABI_FREE(eig_kq)
3578 : :
3579 : : else
3580 : 0 : ABI_ERROR(sjoin("Invalid eph_intmeth:", itoa(eph_intmeth)))
3581 : : end if
3582 : :
3583 [ # # # # : 0 : end subroutine gqk_dbldelta_qpt
# # ]
3584 : : !!***
3585 : : !----------------------------------------------------------------------
3586 : :
3587 : : !!****f* m_gstore/gqk_free
3588 : : !! NAME
3589 : : !! gqk_free
3590 : : !!
3591 : : !! FUNCTION
3592 : : !! Free dynamic memory in gqk_t instance.
3593 : : !!
3594 : : !! SOURCE
3595 : :
3596 : 24 : subroutine gqk_free(gqk)
3597 : :
3598 : : !Arguments ------------------------------------
3599 : : class(gqk_t),intent(inout) :: gqk
3600 : : !----------------------------------------------------------------------
3601 : :
3602 [ + - ]: 24 : ABI_SFREE(gqk%my_k2ibz)
3603 [ + - ]: 24 : ABI_SFREE(gqk%my_kpts)
3604 [ + - ]: 24 : ABI_SFREE(gqk%my_wtk)
3605 [ + - ]: 24 : ABI_SFREE(gqk%my_q2ibz)
3606 [ + - ]: 24 : ABI_SFREE(gqk%my_q2bz)
3607 [ + - ]: 24 : ABI_SFREE(gqk%my_k2glob)
3608 [ + - ]: 24 : ABI_SFREE(gqk%my_q2glob)
3609 [ + + ]: 24 : ABI_SFREE(gqk%my_wnuq)
3610 [ + + ]: 24 : ABI_SFREE(gqk%my_displ_cart)
3611 [ - + ]: 24 : ABI_SFREE(gqk%my_iv1p_comm)
3612 [ + - ]: 24 : ABI_SFREE(gqk%my_pertcases)
3613 [ + + ]: 24 : ABI_SFREE(gqk%vnk_cart_ibz)
3614 [ - + ]: 24 : ABI_SFREE(gqk%vnk_mat_cart_ibz)
3615 : :
3616 [ + + ]: 24 : ABI_SFREE(gqk%my_g)
3617 [ + + ]: 24 : ABI_SFREE(gqk%my_g2)
3618 [ + + ]: 24 : ABI_SFREE(gqk%my_gdw2)
3619 [ + + ]: 24 : if (gqk%has_both_g) then
3620 [ + + ]: 9 : ABI_SFREE_PTR(gqk%my_g_ks)
3621 [ + + ]: 9 : ABI_SFREE_PTR(gqk%my_g2_ks)
3622 [ + + ]: 9 : ABI_SFREE_PTR(gqk%my_gdw2_ks)
3623 : : end if
3624 : :
3625 : 24 : call gqk%wan%free()
3626 : :
3627 : : ! Free MPI communicators
3628 : 24 : call gqk%kpt_comm%free(); call gqk%qpt_comm%free(); call gqk%qpt_kpt_comm%free()
3629 : 24 : call gqk%pert_comm%free(); call gqk%band_comm%free(); call gqk%qpt_pert_comm%free()
3630 : 24 : call gqk%pert_ppsum_comm%free(); call gqk%pert_ppsum_bsum_comm%free()
3631 : 24 : call gqk%comm%free(); call gqk%bsum_comm%free(); call gqk%pp_sum_comm%free()
3632 : :
3633 : 24 : end subroutine gqk_free
3634 : : !!***
3635 : :
3636 : : !!****f* m_gstore/gstore_get_missing_qbz_spin
3637 : : !! NAME
3638 : : !! gstore_get_missing_qbz_spin
3639 : : !!
3640 : : !! FUNCTION
3641 : : !! Return the number of (q-points, spin) entries that have been computed.
3642 : : !!
3643 : : !! SOURCE
3644 : :
3645 : 9 : subroutine gstore_get_missing_qbz_spin(gstore, done_qbz_spin, ndone, nmiss)
3646 : :
3647 : : !Arguments ------------------------------------
3648 : : class(gstore_t),intent(in) :: gstore
3649 : : integer,intent(in) :: done_qbz_spin(gstore%nqbz, gstore%nsppol)
3650 : : integer,intent(out) :: ndone, nmiss
3651 : :
3652 : : !Local variables ------------------------------
3653 : : integer :: my_is, my_iq, iq_bz, spin, ierr, nscale
3654 : : !----------------------------------------------------------------------
3655 : :
3656 : 3 : ndone = 0; nmiss = 0
3657 [ + + ]: 6 : do my_is=1,gstore%my_nspins
3658 : 3 : associate (gqk => gstore%gqk(my_is))
3659 : 3 : spin = gstore%my_spins(my_is)
3660 [ + + ]: 83 : do my_iq=1,gqk%my_nq
3661 : 80 : iq_bz = gqk%my_q2bz(my_iq)
3662 [ + - ]: 80 : if (done_qbz_spin(iq_bz, spin) == 0) nmiss = nmiss + 1
3663 [ - + ]: 83 : if (done_qbz_spin(iq_bz, spin) == 1) ndone = ndone + 1
3664 : : end do ! my_iq
3665 : : ! Rescale to avoid overcounting in xmpi_summ
3666 : 3 : nscale = (gqk%pert_comm%nproc * gqk%bsum_comm%nproc * gqk%pp_sum_comm%nproc)
3667 : 3 : nmiss = nmiss / nscale
3668 : 6 : ndone = ndone / nscale
3669 : : end associate
3670 : : end do ! my_is
3671 : :
3672 : 3 : call xmpi_sum(ndone, gstore%comm, ierr)
3673 : 3 : call xmpi_sum(nmiss, gstore%comm, ierr)
3674 : :
3675 : 3 : end subroutine gstore_get_missing_qbz_spin
3676 : : !!***
3677 : :
3678 : : !!****f* m_gstore/gstore_set_perts_distrib
3679 : : !! NAME
3680 : : !! gstore_set_perts_distrib
3681 : : !!
3682 : : !! FUNCTION
3683 : : !! Activate parallelism over perturbations at the level of the DVDB file.
3684 : : !!
3685 : : !! SOURCE
3686 : :
3687 : 18 : subroutine gstore_set_perts_distrib(gstore, cryst, dvdb, my_npert)
3688 : :
3689 : : !Arguments ------------------------------------
3690 : : class(gstore_t),intent(in) :: gstore
3691 : : type(crystal_t),intent(in) :: cryst
3692 : : type(dvdb_t),intent(inout) :: dvdb
3693 : : integer,intent(out) :: my_npert
3694 : :
3695 : : !Local variables ------------------------------
3696 : : !scalars
3697 : : integer :: my_is, spin
3698 : : !arrays
3699 : 18 : integer,allocatable :: my_pinfo(:,:), pert_table(:,:)
3700 : : !----------------------------------------------------------------------
3701 : :
3702 : 18 : my_npert = cryst%natom * 3
3703 [ + + ]: 36 : do my_is=1,gstore%my_nspins
3704 : 18 : associate (gqk => gstore%gqk(my_is))
3705 : 18 : spin = gstore%my_spins(my_is)
3706 [ - + ]: 18 : if (gqk%pert_comm%nproc > 1) then
3707 : : ! Activate parallelism over perturbations
3708 : : ! Build table with list of perturbations treated by this MPI rank inside pert_comm.
3709 : : !ABI_WARNING("GSTORE with pert_comm%nproc > 1 not tested")
3710 : 0 : my_npert = gqk%my_npert
3711 [ # # # # ]: 0 : call ephtk_set_pertables(cryst%natom, my_npert, pert_table, my_pinfo, gqk%pert_comm%value)
3712 : 0 : call dvdb%set_pert_distrib(my_npert, cryst%natom * 3, my_pinfo, pert_table, gqk%pert_comm%value)
3713 [ # # # # : 0 : ABI_CHECK(all(my_pinfo(3, :) == gqk%my_pertcases), "my_pinfo(3, :) != gqk%my_pertcases")
# # ]
3714 : :
3715 [ # # ]: 0 : ABI_FREE(my_pinfo)
3716 [ # # ]: 0 : ABI_FREE(pert_table)
3717 : : end if
3718 : : end associate
3719 : : end do
3720 : :
3721 [ - + - + ]: 18 : end subroutine gstore_set_perts_distrib
3722 : : !!***
3723 : :
3724 : : !----------------------------------------------------------------------
3725 : :
3726 : : !!****f* m_gstore/gstore_compute
3727 : : !! NAME
3728 : : !! gstore_compute
3729 : : !!
3730 : : !! FUNCTION
3731 : : !! Compute MPI-distributed e-ph matrix elements
3732 : : !!
3733 : : !! INPUTS
3734 : : !! wk0_path=String with the path to the GS unperturbed WFK file.
3735 : : !! ngfft(18),ngfftf(18)=Coarse and Fine FFT meshes.
3736 : : !! dtset<dataset_type>=All input variables for this dataset.
3737 : : !! ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...)
3738 : : !! dvdb<dbdb_type>=Database with the DFPT SCF potentials.
3739 : : !! pawfgr <type(pawfgr_type)>=fine grid parameters and related data
3740 : : !! pawang<pawang_type)>=PAW angular mesh and related data.
3741 : : !! pawrad(ntypat*usepaw)<pawrad_type>=Paw radial mesh and related data.
3742 : : !! pawtab(ntypat*usepaw)<pawtab_type>=Paw tabulated starting data.
3743 : : !! psps<pseudopotential_type>=Variables related to pseudopotentials.
3744 : : !! comm=MPI communicator.
3745 : : !!
3746 : : !! OUTPUT
3747 : : !! GSTORE.nc file
3748 : : !!
3749 : : !! SOURCE
3750 : :
3751 : 5 : subroutine gstore_compute(gstore, wfk0_path, ngfft, ngfftf, dtset, dtfil, cryst, ebands, ifc, dvdb, &
3752 : 5 : pawfgr, pawang, pawrad, pawtab, psps, mpi_enreg, comm)
3753 : :
3754 : : !Arguments ------------------------------------
3755 : : !scalars
3756 : : class(gstore_t),target,intent(inout) :: gstore
3757 : : character(len=*),intent(in) :: wfk0_path
3758 : : integer,intent(in) :: comm
3759 : : type(dataset_type),intent(in) :: dtset
3760 : : type(datafiles_type),intent(in) :: dtfil
3761 : : type(crystal_t),intent(in) :: cryst
3762 : : type(ebands_t),intent(in) :: ebands
3763 : : class(ifc_type),intent(in) :: ifc
3764 : : type(dvdb_t),intent(inout) :: dvdb
3765 : : type(pawang_type),intent(in) :: pawang
3766 : : type(pseudopotential_type),intent(in) :: psps
3767 : : type(pawfgr_type),intent(in) :: pawfgr
3768 : : type(mpi_type),intent(in) :: mpi_enreg
3769 : : !arrays
3770 : : integer,intent(in) :: ngfft(18),ngfftf(18)
3771 : : type(pawrad_type),intent(in) :: pawrad(psps%ntypat*psps%usepaw)
3772 : : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
3773 : :
3774 : : !Local variables ------------------------------
3775 : : !scalars
3776 : : integer,parameter :: tim_getgh1c = 1, berryopt0 = 0, ider0 = 0, idir0 = 0, LOG_MODQ = 5, master = 0, ndat1 = 1
3777 : : integer :: my_rank,nproc,mband,nsppol,nkibz,idir,ipert, iq_bz
3778 : : integer :: cplex,natom,natom3,ipc,nspinor, nskip_tetra_kq, timrev_k, timrev_q
3779 : : integer :: band_k, in_k, ik_ibz,ikq_ibz,isym_k,isym_kq,trev_k,trev_kq, nb_k, nb_kq ! im_kq,
3780 : : integer :: my_ik, my_is, comm_rpt, my_npert, my_ip, my_iq, spin,istwf_k,istwf_kq,npw_k,npw_kq
3781 : : integer :: mpw, ierr, n1,n2,n3,n4,n5,n6,nspden,ndone, db_iqpt
3782 : : integer :: sij_opt,usecprj,usevnl,optlocal,optnl,opt_gvnlx1
3783 : : integer :: nfft,nfftf,mgfft,mgfftf, nkpg_k, nkpg_kq, qbuf_size, iqbuf_cnt, root_ncid, spin_ncid, ncerr
3784 : : integer :: ii, iq_ibz, isym_q, trev_q
3785 : : real(dp) :: cpu_q, wall_q, gflops_q, cpu_all, wall_all, gflops_all ! cpu, wall, gflops,
3786 : : real(dp) :: ecut, weight_q, weight_k ! eshift,
3787 : : logical :: gen_eigenpb, isirr_k, isirr_kq, isirr_q, print_time, need_ftinterp, qq_is_gamma, symmetrize, use_lgk
3788 : 5 : type(wfd_t) :: wfd
3789 : 5 : type(gs_hamiltonian_type) :: gs_ham_kq
3790 : 5 : type(rf_hamiltonian_type) :: rf_ham_kq
3791 : : type(gqk_t),pointer :: gqk
3792 : 5 : type(lgroup_t) :: lg_myq
3793 : : character(len=5000) :: msg, qq_bz_string, kk_string
3794 : : !arrays
3795 : : integer :: g0_k(3), g0_kq(3), g0_q(3), work_ngfft(18),gmax(3),indkk_kq(6,1), units(2), qbz2dvdb(6)
3796 : 5 : integer,allocatable :: kg_k(:,:), kg_kq(:,:), nband(:,:), wfd_istwfk(:), qmap_symrec(:,:)
3797 : 5 : integer,allocatable :: iq_buf(:,:), done_qbz_spin(:,:), state_kq(:,:)
3798 : : !integer,allocatable :: qibz2dvdb(:) !, displs(:), recvcounts(:)
3799 : : real(dp) :: kk_bz(3),kq_bz(3),kk_ibz(3),kq_ibz(3), qq_bz(3), qq_ibz(3) !, v_nk(3)
3800 : 5 : real(dp),allocatable :: displ_cart_qibz(:,:,:,:), lambda(:)
3801 : 5 : real(dp),allocatable :: grad_berry(:,:), kinpw_k(:), kinpw_kq(:), kpg_kq(:,:), kpg_k(:,:)
3802 : 5 : real(dp),allocatable :: ffnl_k(:,:,:,:), ffnl_kq(:,:,:,:), ph3d_k(:,:,:), ph3d_kq(:,:,:)
3803 : 5 : real(dp),allocatable :: v1scf(:,:,:,:), gkq_atm(:,:,:,:), gkq_atm_ipc(:,:,:)
3804 : 5 : real(dp),allocatable :: bras_kq(:,:,:), kets_k(:,:,:), h1_kets_kq(:,:,:) !, cgwork(:,:)
3805 : 5 : real(dp),allocatable :: ph1d(:,:), vlocal(:,:,:,:), vlocal1(:,:,:,:,:)
3806 : 5 : real(dp),allocatable :: dummy_vtrial(:,:), gvnlx1(:,:,:), work(:,:,:,:)
3807 : 5 : real(dp),allocatable :: gs1c_kq(:,:) !, vnk_cart_ibz(:,:,:) !, vkq_cart_ibz(:,:,:) !, vnk_mat_cart_ibz(:,:,:,:)
3808 : 5 : real(dp),allocatable :: my_gbuf(:,:,:,:,:,:)
3809 : 5 : logical,allocatable :: bks_mask(:,:,:),keep_ur(:,:,:)
3810 : 5 : type(pawcprj_type),allocatable :: cwaveprj0(:,:)
3811 : 5 : type(lgroup_t),allocatable :: lg_myk(:)
3812 : : !************************************************************************
3813 : :
3814 : 5 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
3815 [ + + ]: 15 : units = [std_out, ab_out]
3816 : :
3817 [ - + ]: 5 : if (psps%usepaw == 1) then
3818 : 0 : ABI_ERROR("PAW not implemented")
3819 : : ABI_UNUSED((/pawang%nsym, pawrad(1)%mesh_size/))
3820 : : end if
3821 : :
3822 : : ! Check MPI distribution: abort if there are any idle processes in the loops over k and q.
3823 : : ! NOTE that we have to perform this check only at the level of gstore%compute.
3824 : : ! The k- and q-points distributed inside kpt_comm and qpt_comm are the glob_nk and glob_nq points of the gstore
3825 : : ! (e.g. q in the full BZ), not the IBZ points. The IBZ-based steps (phonons, velocities) support nproc > nqibz.
3826 [ + + ]: 10 : do my_is=1,gstore%my_nspins
3827 : 5 : gqk => gstore%gqk(my_is)
3828 [ + - - + ]: 10 : if (gqk%kpt_comm%nproc > gqk%glob_nk .or. gqk%qpt_comm%nproc > gqk%glob_nq) then
3829 : 0 : write(msg, "(4(a,i0),4a)") "gstore%compute: kpt_comm%nproc=", gqk%kpt_comm%nproc, " > glob_nk=", gqk%glob_nk, &
3830 : 0 : " or qpt_comm%nproc=", gqk%qpt_comm%nproc, " > glob_nq=", gqk%glob_nq, ch10, &
3831 : 0 : "This will lead to idle processes, which are not supported.", ch10, &
3832 : 0 : "Please decrease the number of CPUs for k-points or q-points (eph_np_pqbks)"
3833 : 0 : ABI_ERROR(msg)
3834 : : endif
3835 : : enddo
3836 : :
3837 : : ! This parameter defines the size of the q-buffer used to store the g(k, q) e-ph matrix elements
3838 : : ! for all the k-point treated by this MPI rank.
3839 : : ! Increasing the buffer size increases the memory requirements
3840 : : ! but it leads to better performance as the number of IO operations is decreased.
3841 : : ! TODO: Should compute it on the basis of my_nkpt and my_nqpt
3842 : 5 : qbuf_size = 16
3843 : 5 : call wrtout(std_out, sjoin(" Begin computation of e-ph matrix elements with qbuf_size:", itoa(qbuf_size)), pre_newlines=1)
3844 : 5 : call pstat_proc%print(_PSTAT_ARGS_)
3845 : 5 : call cwtime(cpu_all, wall_all, gflops_all, "start")
3846 : :
3847 : : ! If True, only k-points in the IBZ and q-points in the IBZ_k are computed.
3848 : : ! Matrix elements in full BZs are then reconstructed by symmetry at the end of the run by calling
3849 : : ! gstore_symmetrize.
3850 : : symmetrize = (dtset%gstore_kzone == "bz" .and. dtset%gstore_qzone == "bz" &
3851 : : .and. dtset%gstore_sym > 0 &
3852 [ + + + - : 5 : )
+ - ]
3853 : : !if (symmetrize) call wrtout(units, " Computing g(k, q) with k in the IBZ and q in the BZ + final reconstruction")
3854 : :
3855 : : ! Copy important dimensions
3856 : 5 : natom = cryst%natom; natom3 = 3 * natom; nsppol = ebands%nsppol; nspinor = ebands%nspinor; nspden = dtset%nspden
3857 : 5 : nkibz = ebands%nkpt; mband = ebands%mband
3858 : :
3859 : : ! FFT meshes
3860 [ + + ]: 20 : nfftf = product(ngfftf(1:3)); mgfftf = maxval(ngfftf(1:3))
3861 [ + + + + ]: 35 : nfft = product(ngfft(1:3)) ; mgfft = maxval(ngfft(1:3))
3862 : 5 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); n4 = ngfft(4); n5 = ngfft(5); n6 = ngfft(6)
3863 : :
3864 : : ! Open the DVDB file
3865 : 5 : call dvdb%open_read(ngfftf, xmpi_comm_self)
3866 [ - + ]: 5 : ABI_CHECK(dvdb%has_fields("pot1", msg), msg)
3867 : :
3868 : : ! Activate parallelism over perturbations at the level of the DVDB
3869 : 5 : call gstore%set_perts_distrib(cryst, dvdb, my_npert)
3870 : :
3871 : : ! Prepare Fourier interpolation of DFPT potentials.
3872 : 5 : comm_rpt = xmpi_comm_self
3873 : : !comm_rpt = bqs_comm%value
3874 : :
3875 : : ! qmap_symrec gives the mapping gstore%ibz --> dvdb%ibz
3876 [ - + ]: 5 : call dvdb%need_ftinterp(gstore%nqibz, gstore%qibz, gstore%qptopt, qmap_symrec, need_ftinterp)
3877 [ - + ]: 5 : ABI_FREE(qmap_symrec)
3878 : : !need_ftinterp = .True.
3879 : :
3880 [ + + - + ]: 5 : if (.not. need_ftinterp .and. dtset%eph_use_ftinterp /= 0) then
3881 : 0 : ABI_WARNING("Enforcing FT interpolation for q-points even if it's not strictly needed.")
3882 : 0 : need_ftinterp = .True.
3883 : : end if
3884 : :
3885 [ + + ]: 5 : if (need_ftinterp) then
3886 : 3 : call wrtout(units, " Cannot find all IBZ q-points in the DVDB --> Activating Fourier interpolation.")
3887 : 3 : call dvdb%ftinterp_setup(dtset%ddb_ngqpt, gstore%qptopt, 1, dtset%ddb_shiftq, nfftf, ngfftf, comm_rpt)
3888 : : else
3889 : 2 : call wrtout(units, " DVDB file contains all q-points in the IBZ --> Reading DFPT potentials from file.")
3890 : : end if
3891 : :
3892 : : ! Initialize the wave function descriptor.
3893 : : ! Only wavefunctions for the symmetrical image of the k/k+q wavevectors treated by this MPI rank are stored.
3894 [ - + + - : 20 : ABI_MALLOC(nband, (nkibz, nsppol))
- + + - +
- + - - +
- + ]
3895 [ - + + - : 25 : ABI_MALLOC(bks_mask, (mband, nkibz, nsppol))
- + + - -
+ + - + -
+ - - + -
+ ]
3896 [ - + + - : 20 : ABI_MALLOC(keep_ur, (mband, nkibz, nsppol))
- + + - -
+ + - - +
- + ]
3897 [ + + + + : 2754 : nband = mband; bks_mask = .False.; keep_ur = .False.
+ + + + +
+ + + + +
+ + ]
3898 : :
3899 : 5 : call gstore%fill_bks_mask(mband, nkibz, nsppol, bks_mask)
3900 : :
3901 : : ! Impose istwfk = 1 for all k-points. This is also done in respfn (see inkpts)
3902 : : ! wfd_read_wfk will handle a possible conversion if WFK contains istwfk /= 1.
3903 [ - + + - : 15 : ABI_MALLOC(wfd_istwfk, (nkibz))
+ - + - -
+ - + ]
3904 [ + + ]: 119 : wfd_istwfk = 1
3905 : 5 : ecut = dtset%ecut
3906 : :
3907 : : call wfd%init(cryst, pawtab, psps, keep_ur, mband, nband, nkibz, nsppol, bks_mask,&
3908 : : nspden, nspinor, ecut, dtset%ecutsm, dtset%dilatmx, wfd_istwfk, ebands%kptns, ngfft,&
3909 : 5 : dtset%nloalg, dtset%prtvol, dtset%pawprtvol, comm)
3910 : :
3911 [ + + ]: 10 : call wfd%print([std_out], header="Wavefunctions for GSTORE calculation")
3912 : :
3913 [ - + ]: 5 : ABI_FREE(nband)
3914 [ - + ]: 5 : ABI_FREE(keep_ur)
3915 [ - + ]: 5 : ABI_FREE(wfd_istwfk)
3916 [ - + ]: 5 : ABI_FREE(bks_mask)
3917 : :
3918 : : ! Read wavefunctions.
3919 : 5 : call wfd%read_wfk(wfk0_path, iomode_from_fname(wfk0_path))
3920 : 5 : call pstat_proc%print(_PSTAT_ARGS_)
3921 : :
3922 : : ! one-dimensional structure factor information on the coarse grid.
3923 [ + - - + : 15 : ABI_MALLOC(ph1d, (2, 3*(2*mgfft+1)*natom))
+ - + - +
- - + - +
- + ]
3924 : 5 : call getph(cryst%atindx, natom, n1, n2, n3, ph1d, cryst%xred)
3925 : :
3926 : : ! mpw is the maximum number of plane-waves over k and k+q where k and k+q are in the BZ.
3927 : : ! we also need the max components of the G-spheres (k, k+q) in order to allocate the workspace array work
3928 : : ! that will be used to symmetrize the wavefunctions in G-space.
3929 : 5 : call gstore%get_mpw_gmax(ecut, mpw, gmax)
3930 : :
3931 : : ! Init work_ngfft
3932 [ + + ]: 20 : gmax = gmax + 4 ! FIXME: this is to account for umklapp
3933 [ + + ]: 20 : gmax = 2*gmax + 1
3934 : 5 : call ngfft_seq(work_ngfft, gmax)
3935 : : !write(std_out,*)"work_ngfft(1:3): ",work_ngfft(1:3)
3936 [ - + + - : 25 : ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
- + + - -
+ + - + -
+ - - + -
+ ]
3937 : :
3938 : : ! Allow PW-arrays dimensioned with mpw
3939 [ - + + - : 15 : ABI_MALLOC(kg_k, (3, mpw))
+ - + - -
+ - + -
+ ]
3940 [ - + + - : 10 : ABI_MALLOC(kg_kq, (3, mpw))
- + - + -
+ ]
3941 : :
3942 : 5 : usecprj = 0
3943 [ - + + - : 10 : ABI_MALLOC(cwaveprj0, (natom, nspinor*usecprj))
- + - + -
+ ]
3944 : :
3945 : : ! Prepare call to getgh1c
3946 : 5 : usevnl = 0
3947 : 5 : optlocal = 1 ! local part of H^(1) is computed in gh1c=<G|H^(1)|C>
3948 : 5 : optnl = 2 ! non-local part of H^(1) is totally computed in gh1c=<G|H^(1)|C>
3949 : 5 : opt_gvnlx1 = 0 ! gvnlx1 is output
3950 [ - + - + ]: 5 : ABI_MALLOC(grad_berry, (2, nspinor*(berryopt0/4)))
3951 : :
3952 : : ! This part is taken from dfpt_vtorho
3953 : : !==== Initialize most of the Hamiltonian (and derivative) ====
3954 : : !1) Allocate all arrays and initialize quantities that do not depend on k and spin.
3955 : : !2) Perform the setup needed for the non-local factors:
3956 : : ! Norm-conserving: Constant kleimann-Bylander energies are copied from psps to gs_hamk.
3957 : : ! PAW: Initialize the overlap coefficients and allocate the Dij coefficients.
3958 : :
3959 : : call gs_ham_kq%init(psps, pawtab, nspinor, nsppol, nspden, natom, &
3960 : : dtset%typat, cryst%xred, nfft, mgfft, ngfft, cryst%rprimd, dtset%nloalg, &
3961 : : comm_atom=mpi_enreg%comm_atom, mpi_atmtab=mpi_enreg%my_atmtab, mpi_spintab=mpi_enreg%my_isppoltab, &
3962 : 5 : usecprj=usecprj, ph1d=ph1d, nucdipmom=dtset%nucdipmom, gpu_option=dtset%gpu_option)
3963 : :
3964 : : ! Allocate vlocal. Note nvloc
3965 : : ! I set vlocal to huge to trigger possible bugs (DFPT routines should not access the data)
3966 [ - + + - : 30 : ABI_MALLOC(vlocal, (n4, n5, n6, gs_ham_kq%nvloc))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
3967 [ + + + + : 26516 : vlocal = huge(one)
+ + + + ]
3968 : :
3969 : : ! Allocate work space arrays.
3970 [ - + + - : 20 : ABI_MALLOC(displ_cart_qibz, (2, 3, cryst%natom, natom3))
- + + - +
- + - - +
- + ]
3971 [ - + + - : 22241 : ABI_CALLOC(dummy_vtrial, (nfftf, nspden))
- + + - +
- + - - +
- + + + +
+ ]
3972 : :
3973 : : ! Open GSTORE file, and read table used for restarting.
3974 : : ! TODO: Fix problem with IO (some q-points are not written)
3975 : : !if (dtset%useria == 888) then
3976 : : ! ! use xmpi_comm_self otherwise there will be a deadlock on lemaitre4
3977 : : ! NCF_CHECK(nctk_open_modify(root_ncid, gstore%path, xmpi_comm_self))
3978 : : !else
3979 [ - + ]: 5 : NCF_CHECK(nctk_open_modify(root_ncid, gstore%path, gstore%comm))
3980 : : !end if
3981 : :
3982 : : ! integer scalars
3983 : : ncerr = nctk_def_iscalars(root_ncid, [character(len=nctk_slen) :: &
3984 : : "used_ftinterp" &
3985 [ + + ]: 10 : ])
3986 [ - + ]: 5 : NCF_CHECK(ncerr)
3987 : :
3988 [ - + + - : 20 : ABI_MALLOC(done_qbz_spin, (gstore%nqbz, nsppol))
- + + - +
- + - - +
- + - + ]
3989 [ - + ]: 5 : NCF_CHECK(nf90_get_var(root_ncid, nctk_idname(root_ncid, "gstore_done_qbz_spin"), done_qbz_spin))
3990 : :
3991 [ - + ]: 5 : gstore%wfk0_path = wfk0_path
3992 : :
3993 : : !if (my_rank == master) then
3994 [ + + ]: 5 : ii = merge(1, 0, need_ftinterp)
3995 : : ncerr = nctk_write_iscalars(root_ncid, [character(len=nctk_slen) :: &
3996 : : "used_ftinterp"], &
3997 : : [ii &
3998 [ + + + + ]: 15 : ])
3999 [ - + ]: 5 : NCF_CHECK(ncerr)
4000 : :
4001 [ - + - - ]: 5 : NCF_CHECK(nf90_put_var(root_ncid, root_vid("gstore_wfk0_path"), trim(gstore%wfk0_path)))
4002 : : !end if
4003 : :
4004 : : ! SC: The writes below are done by a subset of the procs (dump_my_gbuf) and a lazy collective read
4005 : : ! triggered by this subset would deadlock. Therefore, we load the metadata of all the variables here
4006 : : ! with all the procs of gstore%comm.
4007 : 5 : call gstore_prepare_mpiio(root_ncid, gstore%nsppol)
4008 : :
4009 [ + - + + ]: 10 : if (my_rank == master) call gstore%print([std_out])
4010 [ + + + + : 2487 : ndone = count(done_qbz_spin == 1)
- + ]
4011 : :
4012 [ + - ]: 5 : if (ndone == 0) then
4013 : : ! Write phonon data here as we are not guaranteed to have all the IBZ q-points
4014 : : ! inside the loop over my_iq if filtering has been used.
4015 : : ! Make sure internal table with gstore_done_qbz_spin is properly filled.
4016 : 5 : call gstore%compute_and_write_ph(root_ncid)
4017 : : else
4018 : 0 : call wrtout(units, sjoin("- Restarting GSTORE calculation from file:", gstore%path))
4019 : 0 : call wrtout(units, sjoin(" Found: ", itoa(ndone), " (qpt, spin) entries already computed"))
4020 : : end if
4021 : :
4022 : : ! Create ddkop object to compute group velocities (if needed)
4023 [ + - + - ]: 5 : if (gstore%with_vk /= 0 .and. ndone == 0) then
4024 : 5 : call gstore%compute_and_write_vk(mpw, wfd, ebands, psps, pawtab, root_ncid)
4025 : : end if
4026 : :
4027 [ - + ]: 5 : if (dtset%gstore_iv1p_comm /= 0) then
4028 : : call gstore%compute_and_write_commutator(mpw, gmax, ngfft, ngfftf, dtset, cryst, pawfgr, psps, &
4029 : 0 : wfd, mpi_enreg, kg_k, ebands, dvdb, gs_ham_kq, root_ncid)
4030 : : end if
4031 : :
4032 : 5 : call wrtout(std_out, " Begin computation of e-ph matrix elements...", pre_newlines=1)
4033 : :
4034 : : ! TODO: Exchange the q/k loops so that one can reduce the number of calls to _k dependente routines
4035 : : ! 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)>
4036 : : ! The price to pay is an increase in the number of calls to get_ftqbz but for small systems this part does not dominate
4037 : : ! Alternatively, one cah have two versions that will be invoked depending on my_nk, my_nq
4038 : :
4039 : : ! Here we decide if the q-points can be reduced to the IBZ(k)
4040 [ + + + - ]: 5 : use_lgk = (dtset%gstore_use_lgk /= 0 .or. dtset%gstore_sym == 2)
4041 : : if (use_lgk) then
4042 : 1 : call wrtout(units, " Only q-points in the IBZ_k will be computed.")
4043 [ - + ]: 4 : else if (dtset%gstore_use_lgq /= 0) then
4044 : 0 : call wrtout(units, " Only k-points in the IBZ_q will be computed.")
4045 : : else
4046 : 4 : call wrtout(units, " Little group operations won't be used")
4047 : : end if
4048 : :
4049 : : ! if PAW, one has to solve a generalized eigenproblem
4050 [ - + ]: 5 : gen_eigenpb = psps%usepaw == 1; sij_opt = 0; if (gen_eigenpb) sij_opt = 1
4051 : :
4052 : : ! Loop over my spins.
4053 [ + + ]: 10 : do my_is=1,gstore%my_nspins
4054 : 5 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is); my_npert = gqk%my_npert
4055 : :
4056 [ - + ]: 5 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
4057 : : ! SC: these nctk_prepare_mpiio are not needed anymore. gstore_prepare_mpiio has accessed all the variables after the open,
4058 : : ! and netcdf reads the metadata of a variable only at the first access, so these calls would do nothing.
4059 : : !NCF_CHECK(nctk_prepare_mpiio(spin_ncid, "gvals"))
4060 : : !NCF_CHECK(nctk_prepare_mpiio(root_ncid, "gstore_done_qbz_spin"))
4061 : :
4062 : 5 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
4063 : :
4064 [ - + + - : 15 : ABI_MALLOC(iq_buf, (2, qbuf_size))
+ - + - -
+ - + -
+ ]
4065 [ + + + + ]: 245 : iq_buf = 0
4066 [ - + + - : 15 : ABI_MALLOC(lambda, (nb_k))
+ - + - -
+ - + ]
4067 [ - + + - : 25 : ABI_MALLOC(gkq_atm, (2, nb_kq, nb_k, natom3))
- + + - -
+ + - + -
+ - - + -
+ - + ]
4068 [ - + + - : 20 : ABI_MALLOC(gkq_atm_ipc, (2, nb_kq, nb_k))
- + + - +
- + - - +
- + ]
4069 : : #ifdef HAVE_OPENMP_OFFLOAD
4070 : : !$OMP TARGET ENTER DATA MAP(alloc:gkq_atm_ipc) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4071 : : #endif
4072 : :
4073 : : ! Inside the loops we compute gkq_atm(2, nb_kq, nb_k, natom3)
4074 [ - + + - : 40 : ABI_MALLOC_OR_DIE(my_gbuf, (gqk%cplex, nb_kq, nb_k, natom3, gqk%my_nk, qbuf_size), ierr)
- + + - -
+ + - - +
+ - - + +
- - + + -
+ - + - +
- + - - +
+ - - + ]
4075 : 5 : call pstat_proc%print(_PSTAT_ARGS_)
4076 : :
4077 : : ! Compute the little group of the k-point so that we can compute g(k,q) only for q in the IBZ_k
4078 [ + + ]: 5 : if (use_lgk) then
4079 : 1 : timrev_k = kpts_timrev_from_kptopt(ebands%kptopt)
4080 [ - + + - : 4 : ABI_MALLOC(lg_myk, (gqk%my_nk))
+ - + - -
+ - + - +
+ + + - -
+ - + - +
- + - + -
+ - + ]
4081 [ + + ]: 2 : do my_ik=1,gqk%my_nk
4082 [ + + ]: 4 : kk_bz = gqk%my_kpts(:, my_ik)
4083 : 2 : call lg_myk(my_ik)%init(cryst, kk_bz, timrev_k, gstore%nqbz, gstore%qbz, gstore%nqibz, gstore%qibz, xmpi_comm_self)
4084 : : end do
4085 : : end if
4086 : :
4087 [ - + + - : 20 : ABI_MALLOC(state_kq, (gqk%my_nk, qbuf_size))
- + + - +
- + - - +
- + - + ]
4088 [ + + + + ]: 4981 : state_kq = GSTORE_KQ_MISSING
4089 : :
4090 : : ! SC: iqbuf_cnt is set only for the q-points that are computed, so is has to be initialized. Otherwise a
4091 : : ! proc whose q-points are all done (restart) would read an undefined value in "if (iqbuf_cnt /= 0)" later.
4092 : 5 : iqbuf_cnt = 0
4093 : :
4094 : : ! Loop over my set of q-points
4095 [ + + ]: 882 : do my_iq=1,gqk%my_nq
4096 [ + - + + : 877 : print_time = my_rank == 0 .and. (my_iq <= LOG_MODQ .or. mod(my_iq, LOG_MODQ) == 0)
+ + ]
4097 : 193 : if (print_time) call cwtime(cpu_q, wall_q, gflops_q, "start")
4098 : 877 : iq_bz = gqk%my_q2bz(my_iq)
4099 : :
4100 : 877 : call gqk%myqpt(my_iq, gstore, weight_q, qq_bz)
4101 : : qq_is_gamma = sum(qq_bz**2) < tol14
4102 : 877 : qq_bz_string = ktoa(qq_bz)
4103 : :
4104 : : ! Handle possible restart.
4105 [ - + ]: 877 : if (done_qbz_spin(iq_bz, spin) == 1) then
4106 : 0 : call wrtout(std_out, sjoin(" iq_bz:", itoa(iq_bz), ", spin: ", itoa(spin), " already computed --> skipping iteration"))
4107 : 0 : cycle
4108 : : end if
4109 : :
4110 : : ! Compute the little group of the q-point so that we can compute g(k,q) only for k in the IBZ_q
4111 [ - + ]: 877 : if (dtset%gstore_use_lgq /= 0) then
4112 : 0 : timrev_q = kpts_timrev_from_kptopt(gstore%qptopt)
4113 [ # # # # : 0 : call lg_myq%init(cryst, qq_bz, timrev_q, gstore%nkbz, gstore%kbz, gstore%nkibz, gstore%kibz, xmpi_comm_self)
# # # # #
# ]
4114 : : end if
4115 : :
4116 : 877 : iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
4117 : 877 : trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5,my_iq)
4118 : : ! Don't test if umklapp == 0 because we use the periodic gauge:
4119 : : !
4120 : : ! phfreq(q+G) = phfreq(q) and eigvec(q) = eigvec(q+G)
4121 : : !
4122 : : !isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
4123 : 877 : isirr_q = (isym_q == 1 .and. trev_q == 0)
4124 [ + + ]: 3508 : qq_ibz = gstore%qibz(:, iq_ibz)
4125 : :
4126 : 877 : nskip_tetra_kq = 0
4127 : 877 : iqbuf_cnt = 1 + mod(my_iq - 1, qbuf_size)
4128 [ + + ]: 2631 : iq_buf(:, iqbuf_cnt) = [my_iq, iq_bz]
4129 : :
4130 [ + + ]: 877 : if (need_ftinterp) then
4131 : : ! Fourier interpolation.
4132 [ - + ]: 786 : call dvdb%get_ftqbz(qq_bz, cplex, nfftf, ngfftf, v1scf, gqk%pert_comm%value)
4133 : : else
4134 : : ! Read and reconstruct the dvscf potentials for qpt and my_npert perturbations.
4135 : 91 : db_iqpt = dvdb%findq(qq_ibz)
4136 [ - + ]: 91 : ABI_CHECK(db_iqpt /= -1, sjoin("Could not find symmetric of q-point:", ktoa(qq_bz), "in DVDB file."))
4137 : : ! The first entry in qbz2dvdb gives the index in dvdb%qpts.
4138 : : ! The other entries in mapc_qq are OK as they refer to symmetries.
4139 [ + + ]: 637 : qbz2dvdb = gqk%my_q2ibz(:, my_iq); qbz2dvdb(1) = db_iqpt
4140 [ - + ]: 91 : call dvdb%readsym_qbz(cryst, qq_bz, qbz2dvdb, cplex, nfftf, ngfftf, v1scf, gqk%pert_comm%value)
4141 : : end if
4142 : :
4143 : : ! Allocate vlocal1 with correct cplex. Note nvloc and my_npert.
4144 [ - + + - : 6139 : ABI_MALLOC(vlocal1, (cplex*n4, n5, n6, gs_ham_kq%nvloc, my_npert))
- + + - -
+ + - - +
+ - - + +
- + - + -
- + - + ]
4145 : :
4146 : : ! Set up local potential vlocal1 with proper dimensioning from vtrial1 taking into account the spin.
4147 [ + + ]: 6139 : do my_ip=1,my_npert
4148 : : call rf_transgrid_and_pack(spin, nspden, psps%usepaw, cplex, nfftf, nfft, ngfft, gs_ham_kq%nvloc,&
4149 : 6139 : pawfgr, mpi_enreg, dummy_vtrial, v1scf(:,:,:,my_ip), vlocal, vlocal1(:,:,:,:,my_ip))
4150 : : #ifdef HAVE_OPENMP_OFFLOAD
4151 : : !$OMP TARGET ENTER DATA MAP(to:vlocal1(:,:,:,:,my_ip)) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4152 : : #endif
4153 : : end do
4154 : : !$OMP TASKWAIT
4155 : :
4156 : : ! Continue to initialize the GS Hamiltonian
4157 : 877 : call gs_ham_kq%load_spin(spin, vlocal=vlocal, with_nonlocal=.true.)
4158 : :
4159 : : ! Loop over my k-points
4160 [ + + ]: 74524 : do my_ik=1,gqk%my_nk
4161 : : ! The k-point and the symmetries relating the BZ k-point to the IBZ.
4162 [ + + ]: 294588 : kk_bz = gqk%my_kpts(:, my_ik)
4163 : 73647 : weight_k = gqk%my_wtk(my_ik)
4164 : 73647 : kk_string = ktoa(kk_bz)
4165 : :
4166 : 73647 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
4167 [ + + ]: 294588 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5,my_ik)
4168 [ + + + + : 282012 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
+ + - + ]
4169 [ + + ]: 294588 : kk_ibz = ebands%kptns(:,ik_ibz)
4170 : :
4171 : : ! Set entry to zero. Important as there are cycle instructions inside these loops
4172 : : ! and we don't want random numbers written to disk.
4173 [ + + + + : 5565417 : my_gbuf(:,:,:,:, my_ik, iqbuf_cnt) = zero
+ + + + ]
4174 : :
4175 [ - + ]: 73647 : if (symmetrize .and. .not. isirr_k) then
4176 : 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4177 : : end if
4178 : :
4179 [ + + ]: 73647 : if (use_lgk) then
4180 : 64 : ii = lg_myk(my_ik)%findq_ibzk(qq_bz)
4181 [ + + ]: 64 : if (ii == -1) then
4182 : 56 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4183 : : end if
4184 : : end if
4185 : :
4186 [ - + ]: 73591 : if (dtset%gstore_use_lgq /= 0) then
4187 : 0 : ii = lg_myq%findq_ibzk(kk_bz)
4188 [ # # ]: 0 : if (ii == -1) then
4189 : 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4190 : : end if
4191 : : end if
4192 : :
4193 : : ! =========================================
4194 : : ! Find symmetrical image of k+q in the kIBZ
4195 : : ! =========================================
4196 [ + + ]: 294364 : kq_bz = kk_bz + qq_bz
4197 [ - + ]: 73591 : if (kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz, indkk_kq) /= 0) then
4198 : : write(msg, '(3a)' ) &
4199 : 0 : "Cannot find k+q in k-mesh", ch10, 'Check your WFK file and the (k,q) point input variables.'
4200 : 0 : ABI_ERROR(msg)
4201 : : end if
4202 : :
4203 : 73591 : ikq_ibz = indkk_kq(1, 1); isym_kq = indkk_kq(2, 1)
4204 : 73591 : trev_kq = indkk_kq(6, 1); g0_kq = indkk_kq(3:5, 1)
4205 : : isirr_kq = (isym_kq == 1 .and. trev_kq == 0 .and. all(g0_kq == 0))
4206 [ + + ]: 294364 : kq_ibz = ebands%kptns(:, ikq_ibz)
4207 : :
4208 : : ! If we have used the KERANGE trick, we may have k or k+q points with just one G component set to zero
4209 : : ! so we skip this transition immediately. This should happen only if fsewin > sigma_erange.
4210 [ + - - + ]: 73591 : if (wfd%npwarr(ik_ibz) == 1 .or. wfd%npwarr(ikq_ibz) == 1) then
4211 : 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4212 : : end if
4213 : :
4214 [ - + ]: 73591 : if (gstore%kfilter == "fs_tetra") then
4215 : : ! Check tetra delta(e_{k+q}) and cycle if all the weights at k+q are zero.
4216 [ # # # # : 0 : if (all(abs(gstore%delta_ef_kibz_spin(:, ikq_ibz, spin)) == zero)) then
# # ]
4217 : 0 : nskip_tetra_kq = nskip_tetra_kq + 1
4218 : 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4219 : : end if
4220 : : end if
4221 : :
4222 : : ! Get npw_k, kg_k and symmetrize wavefunctions from the IBZ (if needed).
4223 : : call wfd%sym_ug_kg_npw(ecut, kk_bz, kk_ibz, gqk%bstart_k, nb_k, spin, gqk%my_k2ibz(:, my_ik), cryst, &
4224 [ - + ]: 73591 : work_ngfft, work, istwf_k, npw_k, kg_k, kets_k)
4225 : :
4226 : : #ifdef HAVE_OPENMP_OFFLOAD
4227 : : !$OMP TARGET ENTER DATA MAP(to:kets_k) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4228 : : #endif
4229 : :
4230 : : ! Get npw_kq, kg_kq and symmetrize wavefunctions from the IBZ (if needed).
4231 : : call wfd%sym_ug_kg_npw(ecut, kq_bz, kq_ibz, gqk%bstart_kq, nb_kq, spin, indkk_kq(:,1), cryst, &
4232 [ - + ]: 73591 : work_ngfft, work, istwf_kq, npw_kq, kg_kq, bras_kq)
4233 : :
4234 : : #ifdef HAVE_OPENMP_OFFLOAD
4235 : : !$OMP TARGET ENTER DATA MAP(to:bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4236 : : #endif
4237 : :
4238 [ - + + - : 294364 : ABI_MALLOC(h1_kets_kq, (2, npw_kq*nspinor, nb_k))
- + + - +
- + - - +
- + ]
4239 [ + - - - : 220773 : ABI_MALLOC(gs1c_kq, (2, npw_kq*nspinor*nb_k*((sij_opt+1)/2)))
+ - - + -
+ - + ]
4240 [ - + + - : 220773 : ABI_MALLOC(gvnlx1, (2, npw_kq*nspinor,nb_k))
- + + - -
+ - + ]
4241 : : #ifdef HAVE_OPENMP_OFFLOAD
4242 : : !$OMP TARGET ENTER DATA MAP(alloc:h1_kets_kq, gvnlx1, kets_k, bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4243 : : !$OMP TARGET ENTER DATA MAP(alloc:gs1c_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP .and. sij_opt /= 0) NOWAIT
4244 : : #endif
4245 : :
4246 : : call gs_ham_kq%eph_setup_k("k" , kk_bz, istwf_k, npw_k, kg_k, dtset, cryst, psps, &
4247 [ - + - + : 73591 : nkpg_k, kpg_k, ffnl_k, kinpw_k, ph3d_k, gqk%pert_comm%value)
- + - + ]
4248 : :
4249 : : #ifdef HAVE_OPENMP_OFFLOAD
4250 : : !$OMP TARGET ENTER DATA MAP(to:kpg_k, ffnl_k, kinpw_k, ph3d_k) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4251 : : #endif
4252 : :
4253 : : call gs_ham_kq%eph_setup_k("kq", kq_bz, istwf_k, npw_kq, kg_kq, dtset, cryst, psps, &
4254 [ - + - + : 73591 : nkpg_kq, kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq, gqk%pert_comm%value)
- + - + ]
4255 : :
4256 : : #ifdef HAVE_OPENMP_OFFLOAD
4257 : : !$OMP TARGET ENTER DATA MAP(to:kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4258 : : #endif
4259 : :
4260 : : !$OMP TASKWAIT
4261 : :
4262 : : ! Loop over my atomic perturbations and compute gkq_atm_ipc.
4263 [ + + + + : 5483041 : gkq_atm = zero
+ + + + ]
4264 [ + + ]: 515137 : do my_ip=1,my_npert
4265 : 441546 : idir = dvdb%my_pinfo(1, my_ip); ipert = dvdb%my_pinfo(2, my_ip); ipc = dvdb%my_pinfo(3, my_ip)
4266 : :
4267 : : ! Prepare application of the NL part.
4268 : 441546 : call rf_ham_kq%init(cplex, gs_ham_kq, ipert, has_e1kbsc=.true.)
4269 : 441546 : call rf_ham_kq%load_spin(spin, vlocal1=vlocal1(:,:,:,:,my_ip), with_nonlocal=.true.)
4270 : :
4271 : : #if 1
4272 : : ! Calculate dvscf * psi_k, results stored in h1_kets_kq on the k+q sphere.
4273 : : ! Compute H(1) applied to GS wavefunction Psi(0)
4274 [ + + ]: 1128636 : do in_k=1,nb_k
4275 : : ! Use scissor shift on 0-order eigenvalue
4276 : 687090 : band_k = in_k + gqk%bstart_k - 1
4277 : 1128636 : lambda(in_k) = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
4278 : : end do
4279 : : !call ebands%get_dfpt_eshifted(gqk%bstart_k, nb_k, ik_ibz, spin, dtset%dfpt_sciss, lambda)
4280 : :
4281 : : call getgh1c(berryopt0, kets_k, cwaveprj0, h1_kets_kq, &
4282 : : grad_berry, gs1c_kq, gs_ham_kq, gvnlx1, idir, ipert, lambda, mpi_enreg, nb_k, optlocal, &
4283 : 441546 : optnl, opt_gvnlx1, rf_ham_kq, sij_opt, tim_getgh1c, usevnl)
4284 : :
4285 : : #else
4286 : : do in_k=1,nb_k
4287 : : ! Use scissor shift on 0-order eigenvalue
4288 : : band_k = in_k + gqk%bstart_k - 1
4289 : : eshift = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
4290 : :
4291 : : call getgh1c(berryopt0, kets_k(:,:,in_k), cwaveprj0, h1_kets_kq(:,:,in_k), &
4292 : : grad_berry, gs1c_kq, gs_ham_kq, gvnlx1, idir, ipert, [eshift], mpi_enreg, ndat1, optlocal, &
4293 : : optnl, opt_gvnlx1, rf_ham_kq, sij_opt, tim_getgh1c, usevnl)
4294 : : end do ! in_k
4295 : : #endif
4296 : :
4297 : 441546 : call rf_ham_kq%free()
4298 : :
4299 : : ! Calculate <psi_{k+q,j}|dvscf_q*psi_{k,i}> for this perturbation. No need to handle istwf_kq because it's always 1.
4300 [ - + ]: 441546 : if (dtset%gpu_option == ABI_GPU_OPENMP) then
4301 : : call abi_gpu_xgemm_d(2, 'C', 'N', nb_kq, nb_k, npw_kq*nspinor, cone, bras_kq, npw_kq*nspinor, &
4302 : 0 : h1_kets_kq, npw_kq*nspinor, czero, gkq_atm_ipc, nb_kq)
4303 : : #ifdef HAVE_OPENMP_OFFLOAD
4304 : : !$OMP TARGET UPDATE FROM(gkq_atm_ipc)
4305 : : #endif
4306 : : else
4307 : : call ZGEMM('C', 'N', nb_kq, nb_k, npw_kq*nspinor, cone, bras_kq, npw_kq*nspinor, &
4308 : 441546 : h1_kets_kq, npw_kq*nspinor, czero, gkq_atm_ipc, nb_kq)
4309 : : end if
4310 : :
4311 : : ! Transfer data
4312 [ + + + + : 5483041 : gkq_atm(:,:,:,ipc) = gkq_atm_ipc
+ + ]
4313 : : end do ! my_ip
4314 : :
4315 : : ! Collect gkq_atm inside pert_comm so that all procs can operate on the data.
4316 [ - + ]: 73591 : if (gqk%pert_comm%nproc > 1) call xmpi_sum(gkq_atm, gqk%pert_comm%value, ierr)
4317 : :
4318 : : ! Save e-ph matrix elements in the buffer.
4319 [ + + + + : 5483041 : my_gbuf(:,:,:,:, my_ik, iqbuf_cnt) = gkq_atm
+ + + + ]
4320 : 73591 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_COMPUTED
4321 : :
4322 : : #ifdef HAVE_OPENMP_OFFLOAD
4323 : : !$OMP TARGET EXIT DATA MAP(delete:kpg_k, ffnl_k, kinpw_k, ph3d_k) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4324 : : !$OMP TARGET EXIT DATA MAP(delete:kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4325 : : !$OMP TARGET EXIT DATA MAP(delete:h1_kets_kq, gvnlx1, kets_k, bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4326 : : !$OMP TARGET EXIT DATA MAP(delete:gs1c_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP .and. sij_opt /= 0)
4327 : : #endif
4328 [ - + ]: 73591 : ABI_FREE(ffnl_k)
4329 [ - + ]: 73591 : ABI_FREE(ffnl_kq)
4330 [ - + ]: 73591 : ABI_FREE(kpg_k)
4331 [ - + ]: 73591 : ABI_FREE(kpg_kq)
4332 [ - + ]: 73591 : ABI_FREE(ph3d_k)
4333 [ - + ]: 73591 : ABI_FREE(ph3d_kq)
4334 [ - + ]: 73591 : ABI_FREE(kinpw_k)
4335 [ - + ]: 73591 : ABI_FREE(kinpw_kq)
4336 [ - + ]: 73591 : ABI_FREE(kets_k)
4337 [ - + ]: 73591 : ABI_FREE(bras_kq)
4338 [ - + ]: 73591 : ABI_FREE(h1_kets_kq)
4339 [ - + ]: 73591 : ABI_FREE(gs1c_kq)
4340 [ - + ]: 74468 : ABI_FREE(gvnlx1)
4341 : : end do ! my_ik
4342 : :
4343 [ - + ]: 877 : ABI_FREE(v1scf)
4344 : :
4345 : : #ifdef HAVE_OPENMP_OFFLOAD
4346 : : do my_ip=1,my_npert
4347 : : !$OMP TARGET EXIT DATA MAP(delete:vlocal1(:,:,:,:,my_ip)) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4348 : : end do
4349 : : #endif
4350 [ - + ]: 877 : ABI_FREE(vlocal1)
4351 : :
4352 : : ! Dump buffer
4353 [ + + ]: 877 : if (iqbuf_cnt == qbuf_size) call dump_my_gbuf()
4354 : :
4355 [ + + ]: 877 : if (print_time) then
4356 : 193 : write(msg,'(2(a,i0),a)')" My q-point [", my_iq, "/", gqk%my_nq, "]"
4357 [ + + ]: 193 : call cwtime_report(msg, cpu_q, wall_q, gflops_q); if (my_iq == LOG_MODQ) call wrtout(std_out, "...", do_flush=.True.)
4358 : : end if
4359 : 882 : call lg_myq%free()
4360 : : end do ! my_iq
4361 : :
4362 : : ! Dump the remainder.
4363 [ + + ]: 5 : if (iqbuf_cnt /= 0) call dump_my_gbuf()
4364 : :
4365 [ - + ]: 5 : ABI_FREE(state_kq)
4366 [ - + ]: 5 : ABI_FREE(iq_buf)
4367 [ - + ]: 5 : ABI_FREE(my_gbuf)
4368 [ - + ]: 5 : ABI_FREE(lambda)
4369 [ - + ]: 5 : ABI_FREE(gkq_atm)
4370 : : #ifdef HAVE_OPENMP_OFFLOAD
4371 : : !$OMP TARGET EXIT DATA MAP(delete:gkq_atm_ipc) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4372 : : #endif
4373 [ - + ]: 5 : ABI_FREE(gkq_atm_ipc)
4374 : :
4375 [ + + ]: 10 : if (use_lgk) then
4376 [ + + ]: 2 : do my_ik=1,gqk%my_nk
4377 : 2 : call lg_myk(my_ik)%free()
4378 : : end do
4379 [ + - + + : 2 : ABI_FREE(lg_myk)
- + - + -
+ - + - +
- + - + -
+ ]
4380 : : end if
4381 : : end do ! my_is
4382 : :
4383 : 5 : call cwtime_report(" GSTORE computation done", cpu_all, wall_all, gflops_all, pre_str=ch10, end_str=ch10) !, comm=gstore%comm)
4384 : : !call gstore%print([std_out], header="GSTORE at the end of gstore%compute")
4385 : :
4386 : : ! Set gstore_completed to 1 so that we can easily check if restarted is needed.
4387 : : !if (my_rank == master) then
4388 [ - + ]: 5 : NCF_CHECK(nf90_put_var(root_ncid, root_vid("gstore_completed"), 1))
4389 : : !end if
4390 : : ! nf90_sync can deadlock on lemaitre4 for some MPI decompositions.
4391 : : !if (dtset%useria /= 888) then
4392 [ - + ]: 5 : NCF_CHECK(nf90_sync(root_ncid))
4393 : : !end if
4394 [ - + ]: 5 : NCF_CHECK(nf90_close(root_ncid))
4395 : 5 : call xmpi_barrier(gstore%comm)
4396 : :
4397 : : ! Free memory
4398 [ - + ]: 5 : ABI_FREE(grad_berry)
4399 [ - + ]: 5 : ABI_FREE(dummy_vtrial)
4400 [ - + ]: 5 : ABI_FREE(work)
4401 [ - + ]: 5 : ABI_FREE(ph1d)
4402 [ - + ]: 5 : ABI_FREE(vlocal)
4403 [ - + ]: 5 : ABI_FREE(kg_k)
4404 [ - + ]: 5 : ABI_FREE(kg_kq)
4405 [ - + ]: 5 : ABI_FREE(displ_cart_qibz)
4406 [ - + ]: 5 : ABI_FREE(done_qbz_spin)
4407 : :
4408 : 5 : call gs_ham_kq%free(); call wfd%free()
4409 : 5 : call pawcprj_free(cwaveprj0)
4410 [ + - - + : 5 : ABI_FREE(cwaveprj0)
- - - - -
+ ]
4411 : :
4412 : : ! Reconstruct g(k,q) matrix elements in the full BZ by symmetry.
4413 [ - + ]: 5 : if (symmetrize) then
4414 : 0 : call gstore_symmetrize(gstore%path, wfk0_path, ngfft, dtset, dtfil, cryst, psps, pawtab, ebands, ifc, comm)
4415 : : end if
4416 : :
4417 : : ! Output some of the results to ab_out for testing purposes
4418 [ - + - + : 30 : call gstore%print_for_abitests(dtset, ebands, .True.)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - - - -
- - - - -
- - - - -
- + - - -
- - - - -
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
+ - + - +
- + ]
4419 : :
4420 : : contains
4421 : :
4422 : 56 : subroutine dump_my_gbuf()
4423 : :
4424 : : ! This function is called inside the double loop over (my_is, my_iq) or when we exit
4425 : : ! from the my_iq loop to dump the remainder that is still in the q-buffer,
4426 : : ! All the MPI procs in the (kpt_comm x pert_comm) grid shall call this contained routine
4427 : : ! as we have side-effects i.e. iqbuf_cnt set to 0.
4428 : :
4429 : : ! On disk we have the global arrays:
4430 : : !
4431 : : ! nctkarr_t("gvals", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq")
4432 : : !
4433 : : ! while the local MPI buffers are dimensioned as follows:
4434 : : !
4435 : : ! my_gbuf(2, nb_kq, nb_k, natom3, gqk%my_nk, qbuf_size)
4436 : :
4437 : : ! If parallelism over perturbation is activated, only the procs treating the first perturbation
4438 : : ! i.e. the procs treating different k-points for this q are involved in IO
4439 : : ! as all the local buffers store results for all natom3 perturbations.
4440 : :
4441 : : ! NOTE: A similar routine is used in m_gstore. The two implementations should be kept in synch.
4442 : :
4443 : : integer :: ii, iq_bz, iq_glob, my_iq
4444 : : logical :: iscontiguous
4445 : :
4446 : : ! All the procs in pert_comm write the same data (my_gbuf is summed inside pert_comm): the procs with
4447 : : ! coords_qkpb_sumbp(3) /= 0 used to skip the writes, but then the nf90_sync below, called by all the procs,
4448 : : ! fails with "NetCDF: Can't add HDF5 file metadata" when GSTORE.nc is opened with gstore%comm.
4449 : : ! SC: The GOTO was not the cause: the first access to gstore_glob_state_kqs, which was not prepared,
4450 : : ! triggered a collective metadata read done by the writers only, while the other procs were in nf90_sync.
4451 : : ! All the variables are now prepared after the open (gstore_prepare_mpiio), so the GOTO is restored:
4452 : : ! only the procs with coords_qkpb_sumbp(3) == 0 write.
4453 [ + - ]: 56 : if (gqk%coords_qkpb_sumbp(3) /= 0) goto 10 ! Yes, I'm very proud of this GOTO.
4454 : :
4455 : : !if (dtset%prtvol > 5) then
4456 : : !print *, "in dump_my_gbuf with start: ", [1, 1, 1, 1, gqk%my_kstart, iq_glob]
4457 : : !print *, " count; ", [2, gqk%nb_kq, gqk%nb_k, gqk%natom3, gqk%my_nk, iqbuf_cnt]
4458 : : !end if
4459 : :
4460 : : ! Check if the q-points in the buffer are perfectly contiguous (no cycles/holes)
4461 : 56 : iscontiguous = .True.
4462 [ + + ]: 933 : do ii=1, iqbuf_cnt
4463 : 877 : my_iq = iq_buf(1, ii)
4464 [ + - ]: 877 : if (my_iq == 0) then
4465 : : iscontiguous = .False.; exit
4466 : : end if
4467 [ + + ]: 933 : if (ii > 1) then
4468 [ + - ]: 821 : if (my_iq /= iq_buf(1, ii-1) + 1) then
4469 : : iscontiguous = .False.; exit
4470 : : end if
4471 : : end if
4472 : : end do
4473 : :
4474 [ - + ]: 56 : if (iscontiguous) then
4475 : : ! Fast path: Write slabs directly
4476 : 56 : my_iq = iq_buf(1, 1)
4477 : 56 : iq_glob = my_iq + gqk%my_qstart - 1
4478 : :
4479 : : ncerr = nf90_put_var(spin_ncid, spin_vid("gvals"), my_gbuf(:,:,:,:,:, 1:iqbuf_cnt), &
4480 : : start=[1, 1, 1, 1, gqk%my_kstart, iq_glob], &
4481 [ + + + + ]: 728 : count=[2, gqk%nb_kq, gqk%nb_k, gqk%natom3, gqk%my_nk, iqbuf_cnt])
4482 [ - + ]: 56 : NCF_CHECK(ncerr)
4483 : :
4484 : : ncerr = nf90_put_var(root_ncid, root_vid("gstore_glob_state_kqs"), state_kq(:, 1:iqbuf_cnt), &
4485 : : start=[gqk%my_kstart, iq_glob, spin], &
4486 [ + + + + ]: 392 : count=[gqk%my_nk, iqbuf_cnt, 1])
4487 [ - + ]: 56 : NCF_CHECK(ncerr)
4488 : : else
4489 : : ! Slow path: Q-points were filtered, write slice by slice avoiding holes
4490 [ # # ]: 0 : do ii=1, iqbuf_cnt
4491 : 0 : my_iq = iq_buf(1, ii)
4492 [ # # ]: 0 : if (my_iq == 0) cycle
4493 : 0 : iq_glob = my_iq + gqk%my_qstart - 1
4494 : :
4495 : : ncerr = nf90_put_var(spin_ncid, spin_vid("gvals"), my_gbuf(:,:,:,:,:, ii), &
4496 : : start=[1, 1, 1, 1, gqk%my_kstart, iq_glob], &
4497 [ # # # # ]: 0 : count=[2, gqk%nb_kq, gqk%nb_k, gqk%natom3, gqk%my_nk, 1])
4498 [ # # ]: 0 : NCF_CHECK(ncerr)
4499 : :
4500 : : ncerr = nf90_put_var(root_ncid, root_vid("gstore_glob_state_kqs"), state_kq(:, ii), &
4501 : : start=[gqk%my_kstart, iq_glob, spin], &
4502 [ # # # # ]: 0 : count=[gqk%my_nk, 1, 1])
4503 [ # # ]: 0 : NCF_CHECK(ncerr)
4504 : : end do
4505 : : end if
4506 : :
4507 : : ! SC: each k-block writes only its own k-points, and a restart skips a q-point marked as done for all the
4508 : : ! k-points. Wait until all the writers of these q-points (the procs of kpt_comm, which all treat the same
4509 : : ! q-points) have written their slab, then only one proc sets the entry in done_qbz_spin to 1.
4510 : 56 : call xmpi_barrier(gqk%kpt_comm%value)
4511 [ + + + - : 168 : if (all(gqk%coords_qkpb_sumbp(2:3) == [0, 0])) then
+ - ]
4512 [ + + ]: 933 : do ii=1,iqbuf_cnt
4513 : 877 : my_iq = iq_buf(1, ii)
4514 [ - + ]: 877 : if (my_iq == 0) cycle
4515 : 877 : iq_bz = iq_buf(2, ii)
4516 [ + + - + : 2687 : NCF_CHECK(nf90_put_var(root_ncid, root_vid("gstore_done_qbz_spin"), 1, start=[iq_bz, spin]))
- - ]
4517 : : end do
4518 : : end if
4519 : :
4520 : : ! Zero the counter before returning
4521 : 56 : 10 iqbuf_cnt = 0
4522 [ + + + + ]: 2744 : iq_buf = 0
4523 [ + + + + ]: 76088 : state_kq = GSTORE_KQ_MISSING
4524 : :
4525 : : ! These syncs can deadlock on lemaitre4 for some MPI decompositions.
4526 : : ! SC: nf90_sync is collective on a file opened with gstore%comm (HDF5 flush of the metadata cache), so all
4527 : : ! the procs must call it the same number of times. dump_my_gbuf is called a number of times that depends on
4528 : : ! the proc (my_nq differs when nqbz is not a multiple of the number of q-blocks, q-points done in a previous
4529 : : ! run are skipped on restart), hence these syncs deadlock on the machine. The file is synced once by all
4530 : : ! the procs after the loops. The syncs are not needed for restart as the q-points written before a kill are
4531 : : ! in the file (checked with kill -9 in gwpt_run, which writes GSTORE.nc in the same way).
4532 : : !if (dtset%useria /= 888) then
4533 : : ! NCF_CHECK(nf90_sync(spin_ncid))
4534 : : ! NCF_CHECK(nf90_sync(root_ncid))
4535 : : !end if
4536 : :
4537 : 56 : end subroutine dump_my_gbuf
4538 : :
4539 : 943 : integer function root_vid(var_name)
4540 : : character(len=*),intent(in) :: var_name
4541 : 943 : root_vid = nctk_idname(root_ncid, var_name)
4542 : : end function root_vid
4543 : :
4544 : 56 : integer function spin_vid(var_name)
4545 : : character(len=*),intent(in) :: var_name
4546 : 56 : spin_vid = nctk_idname(spin_ncid, var_name)
4547 : : end function spin_vid
4548 : :
4549 : : end subroutine gstore_compute
4550 : : !!***
4551 : :
4552 : : !----------------------------------------------------------------------
4553 : :
4554 : : !!****f* m_gstore/gstore_check_qkzone_gmode
4555 : : !! NAME
4556 : : !! gstore_check_cplex_qkzone_gmode
4557 : : !!
4558 : : !! FUNCTION
4559 : : !! Perform consistency checks
4560 : : !!
4561 : : !! INPUTS
4562 : : !!
4563 : : !! SOURCE
4564 : :
4565 : 9 : integer function gstore_check_cplex_qkzone_gmode(gstore, cplex, qzone, kzone, gmode, &
4566 : : kfilter, check_alloc) result(ierr) ! optional
4567 : :
4568 : : !Arguments ------------------------------------
4569 : : class(gstore_t),target,intent(in) :: gstore
4570 : : integer,intent(in) :: cplex
4571 : : character(len=*),intent(in) :: qzone, kzone, gmode
4572 : : character(len=*),optional,intent(in) :: kfilter
4573 : : logical,optional,intent(in) :: check_alloc
4574 : :
4575 : : !Local variables-------------------------------
4576 : : integer :: my_is
4577 : : logical :: check_alloc__
4578 : : ! *************************************************************************
4579 : :
4580 : 9 : ierr = 0
4581 [ - + ]: 9 : ABI_CHECK_NOSTOP(gstore%qzone == qzone, sjoin("qzone: ", qzone, "required but got: ", gstore%qzone), ierr)
4582 [ - + ]: 9 : ABI_CHECK_NOSTOP(gstore%kzone == kzone, sjoin("kzone: ", kzone, "required but got: ", gstore%kzone), ierr)
4583 [ - + ]: 9 : ABI_CHECK_NOSTOP(gstore%gmode == gmode, sjoin("gmode: ", gmode, "required but got: ", gstore%gmode), ierr)
4584 [ - + ]: 9 : if (present(kfilter)) then
4585 [ # # ]: 0 : ABI_CHECK_NOSTOP(gstore%kfilter == kfilter, sjoin("kfilter: ", kfilter, "required but got: ", gstore%kfilter), ierr)
4586 : : end if
4587 : :
4588 [ - + ]: 9 : check_alloc__ = .True.; if (present(check_alloc)) check_alloc__ = check_alloc
4589 : :
4590 [ + + ]: 18 : do my_is=1,gstore%my_nspins
4591 : 9 : associate (gqk => gstore%gqk(my_is))
4592 : 0 : ABI_CHECK_NOSTOP(gqk%cplex == cplex, sjoin("cplex:", itoa(cplex), "required but got: ", itoa(gqk%cplex)), ierr)
4593 [ - + + - ]: 9 : if (check_alloc__) then
4594 [ - + ]: 9 : if (cplex == 1) then
4595 [ # # ]: 0 : ABI_CHECK_NOSTOP(allocated(gqk%my_g2), "my_g2 array is not allocated", ierr)
4596 [ + - ]: 9 : else if (cplex == 2) then
4597 [ - + ]: 9 : ABI_CHECK_NOSTOP(allocated(gqk%my_g), "my_g array is not allocated", ierr)
4598 : : end if
4599 : : end if
4600 : : end associate
4601 : : end do
4602 : :
4603 : 9 : end function gstore_check_cplex_qkzone_gmode
4604 : : !!***
4605 : :
4606 : : !----------------------------------------------------------------------
4607 : :
4608 : : !!****f* m_gstore/gstore_from_ncpath
4609 : : !! NAME
4610 : : !! gstore_from_ncpath
4611 : : !!
4612 : : !! FUNCTION
4613 : : !! Reconstruct a gstore_t instance from a netcdf file.
4614 : : !!
4615 : : !! INPUTS
4616 : : !! path: Path to the GSTORE file.
4617 : : !! with_cplex: 0 to read no matrix elements, 1 for |g|^2, 2 for complex g.
4618 : : !! with_gmode defines the representation.
4619 : : !! dtset: Input variables
4620 : : !! cryst: crystalline structure
4621 : : !! ebands: KS energies
4622 : : !! ifc: interatomic force constants
4623 : : !! with_gmode: "phonon" to have g in the phonon representation or "atom" to have them in atom representation.
4624 : : !! gvals_name: "gvals" or "gvals_ks" to read the KS gs produced by the GWPT code.
4625 : : !! This option is valid only for gstore files produced by the GWPT code.
4626 : : !! with_g2dw: True if Debye-Waller g2 in the RIA should be computed and stored in memory.
4627 : : !! comm: MPI communicator.
4628 : : !!
4629 : : !! SOURCE
4630 : :
4631 : 16 : subroutine gstore_from_ncpath(gstore, path, with_cplex, dtset, dtfil, cryst, ebands, ifc, &
4632 : : with_gmode, gvals_name, with_g2dw, comm)
4633 : :
4634 : : !Arguments ------------------------------------
4635 : : class(gstore_t),target,intent(out) :: gstore
4636 : : character(len=*),intent(in) :: path
4637 : : integer,intent(in) :: with_cplex
4638 : : type(dataset_type),target,intent(in) :: dtset
4639 : : type(datafiles_type),intent(in) :: dtfil
4640 : : class(crystal_t),target,intent(in) :: cryst
4641 : : class(ebands_t),target,intent(in) :: ebands
4642 : : class(ifc_type),target,intent(in) :: ifc
4643 : : character(len=*),intent(in) :: with_gmode, gvals_name
4644 : : logical,intent(in) :: with_g2dw
4645 : : integer,intent(in) :: comm
4646 : :
4647 : : !Local variables-------------------------------
4648 : : !scalars
4649 : : integer,parameter :: master = 0
4650 : : integer :: my_rank, ncid, spin, spin_ncid, nproc, ierr, fform, max_nb, ib, natom, natom3, ib_m, ib_n !, varid
4651 : : integer :: max_nq, max_nk, ncerr, my_is, my_iq, iq_glob, my_ik, ik_glob
4652 : : integer :: nb_k, nb_kq, nb_k_file, nb_kq_file, gstore_cplex, ib_kq_start, file_fnlen !, ip1, ip2
4653 : : integer :: my_ip, ipert, iq_ibz, iq_bz, isym_q, trev_q, tsign_q, ii !, im_kq
4654 : : real(dp),parameter :: G_SMALL = tol8
4655 : : real(dp) :: cpu, wall, gflops, wqnu
4656 : : logical :: isirr_q, from_atm_to_nu, has_iv1p_comm, read_ks, has_both_g
4657 : 16 : type(hdr_type) :: wfk0_hdr
4658 [ + + + + : 832 : type(crystal_t) :: gstore_cryst
+ + + + +
+ + + + +
+ + + + ]
4659 : : type(gqk_t),pointer :: gqk
4660 : : character(len=500) :: msg
4661 : : !arrays
4662 : 64 : integer :: units(2), ibuffer(9), nproc_spin(ebands%nsppol), comm_spin(ebands%nsppol)
4663 : 32 : integer :: brange_k_spin(2, ebands%nsppol), brange_kq_spin(2, ebands%nsppol), file_brange_kq_spin(2, ebands%nsppol), g0_q(3)
4664 : 16 : integer,allocatable :: qglob2bz(:,:), qbz2ibz(:,:)
4665 : : real(dp) :: qq_ibz(3)
4666 : 32 : real(dp) :: displ_nu_red(2, 3, cryst%natom)
4667 : 16 : real(dp),allocatable :: gwork_q(:,:,:,:,:), slice_bb(:,:,:), iv1p_comm(:,:,:,:,:)
4668 : 16 : real(dp),allocatable :: ks_gwork_q(:,:,:,:,:), ks_slice_bb(:,:,:)
4669 : 16 : real(dp),allocatable :: phfreqs_ibz(:,:), pheigvec_cart_ibz(:,:,:,:,:), pheigvec_cart_qbz(:,:,:,:)
4670 : 16 : real(dp),allocatable :: displ_cart_qbz(:,:,:,:), displ_red_qbz(:,:,:,:), gmn_nu(:,:,:,:)
4671 [ + - ]: 16 : complex(dp),allocatable :: tpp_red(:,:), my_gq0nm_atm(:,:,:,:), ks_my_gq0nm_atm(:,:,:,:)
4672 : : ! *************************************************************************
4673 : :
4674 : 16 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
4675 : :
4676 [ - + ]: 16 : ABI_CHECK(with_cplex >= 0 .and. with_cplex <= 2, sjoin("Invalid with_cplex:", itoa(with_cplex)))
4677 : :
4678 [ + + ]: 48 : units = [std_out, ab_out]
4679 : 16 : call wrtout(units, sjoin("- Reading e-ph matrix elements from: ", path), pre_newlines=1)
4680 : 16 : call wrtout(units, sjoin(" Asking for with_cplex: ", itoa(with_cplex)))
4681 [ + - ]: 16 : call wrtout(units, sjoin(" Asking for with_gmode: ", trim(with_gmode)))
4682 [ + - ]: 16 : call wrtout(units, sjoin(" Asking for gvals_name: ", trim(gvals_name)))
4683 : 16 : call wrtout(units, sjoin(" Asking for g2dw: ", yesno(with_g2dw)))
4684 : :
4685 : : ! Set basic parameters.
4686 [ - + ]: 16 : gstore%comm = comm; gstore%nsppol = dtset%nsppol; gstore%path = path
4687 : :
4688 : : ! Get references to other data structures.
4689 : 16 : gstore%dtset => dtset; gstore%cryst => cryst; gstore%ebands => ebands; gstore%ifc => ifc; gstore%kibz => ebands%kptns
4690 : :
4691 : 16 : natom = cryst%natom; natom3 = cryst%natom * 3
4692 : :
4693 [ - + + - : 96 : ABI_CALLOC(gstore%erange_spin, (2, gstore%nsppol))
+ - + - -
+ - + - +
+ + + + ]
4694 [ - + + - : 48 : ABI_MALLOC(gstore%glob_nk_spin, (gstore%nsppol))
+ - + - -
+ - + -
+ ]
4695 [ - + + - : 48 : ABI_MALLOC(gstore%glob_nq_spin, (gstore%nsppol))
+ - + - -
+ - + -
+ ]
4696 : :
4697 : : ! =====================================================
4698 : : ! Master node reads basic objects and gstore dimensions
4699 : : ! =====================================================
4700 : :
4701 [ + - ]: 16 : if (my_rank == master) then
4702 : 16 : call wrtout(units, sjoin(" Initializing gstore object from:", path, ch10))
4703 [ - + ]: 16 : ABI_CHECK(path /= ABI_NOFILE, "Use getgstore_filepath to specify the path to GSTORE.nc")
4704 [ - + ]: 16 : NCF_CHECK(nctk_open_read(ncid, path, xmpi_comm_self))
4705 : :
4706 : 16 : call wfk0_hdr%ncread(ncid, fform)
4707 [ - + ]: 16 : ABI_CHECK(fform /= 0, sjoin("Error while reading:", path))
4708 : :
4709 : : ! Read gstore dimensions
4710 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_cplex", gstore_cplex))
4711 [ - + ]: 16 : ABI_CHECK_IEQ(gstore_cplex, 2, "gstore_cplex 1 from file not supported")
4712 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nkibz", gstore%nkibz))
4713 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nkbz", gstore%nkbz))
4714 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nqibz", gstore%nqibz))
4715 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nqbz", gstore%nqbz))
4716 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_max_nq", max_nq))
4717 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_max_nk", max_nk))
4718 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_max_nb", max_nb))
4719 : :
4720 : : ! Read gstore variables
4721 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_with_vk"), gstore%with_vk))
4722 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qptopt"), gstore%qptopt))
4723 : :
4724 : : ! little group variables were added in Abinit v10.5.6.
4725 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_use_lgk"), gstore%has_used_lgk))
4726 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_use_lgq"), gstore%has_used_lgq))
4727 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kzone"), gstore%kzone))
4728 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qzone"), gstore%qzone))
4729 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kfilter"), gstore%kfilter))
4730 : : ! SC: GSTORE.nc files written before fnlen was raised from 264 to 400 have a shorter fnlen dimension.
4731 : : ! Read only the characters present in the file so that these old files can still be read.
4732 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "fnlen", file_fnlen))
4733 : 16 : gstore%wfk0_path = ""
4734 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_wfk0_path"), gstore%wfk0_path(1:min(fnlen, file_fnlen))))
4735 : 16 : call replace_ch0(gstore%kzone); call replace_ch0(gstore%qzone); call replace_ch0(gstore%kfilter)
4736 : 16 : call replace_ch0(gstore%wfk0_path)
4737 : :
4738 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_gtype"), gstore%gtype))
4739 : 16 : call replace_ch0(gstore%gtype)
4740 : : !print *, "gstore%gtype:", gstore%gtype
4741 : :
4742 [ + + ]: 16 : if (gvals_name == "gvals_ks") then
4743 : 2 : call wrtout(units, " Reading KS e-ph matrix elements")
4744 [ + - ]: 14 : else if (gvals_name == "gvals") then
4745 [ + + ]: 14 : if (gstore%gtype == GSTORE_GTYPE_GWPT) then
4746 : 4 : call wrtout(units, " Reading GWPT e-ph matrix elements")
4747 : : else
4748 : 10 : call wrtout(units, " Reading KS e-ph matrix elements")
4749 : : end if
4750 : : end if
4751 : :
4752 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_ngqpt"), gstore%ngqpt))
4753 : :
4754 [ - + + - : 48 : ABI_MALLOC(gstore%qibz, (3, gstore%nqibz))
+ - + - -
+ - + -
+ ]
4755 [ - + + - : 48 : ABI_MALLOC(gstore%wtq, (gstore%nqibz))
+ - + - -
+ - + -
+ ]
4756 [ - + + - : 48 : ABI_MALLOC(gstore%qbz, (3, gstore%nqbz))
+ - + - -
+ - + -
+ ]
4757 [ - + + - : 48 : ABI_MALLOC(gstore%kbz, (3, gstore%nkbz))
+ - + - -
+ - + -
+ ]
4758 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_k_spin"), brange_k_spin))
4759 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_kq_spin"), brange_kq_spin))
4760 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_erange_spin"), gstore%erange_spin))
4761 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qibz"), gstore%qibz))
4762 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_wtq"), gstore%wtq))
4763 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qbz"), gstore%qbz))
4764 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kbz"), gstore%kbz))
4765 : :
4766 [ - + + - : 48 : ABI_MALLOC(qbz2ibz, (6, gstore%nqbz))
+ - + - -
+ - + -
+ ]
4767 [ - + + - : 48 : ABI_MALLOC(gstore%kbz2ibz, (6, gstore%nkbz))
+ - + - -
+ - + -
+ ]
4768 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qbz2ibz"), qbz2ibz))
4769 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kbz2ibz"), gstore%kbz2ibz))
4770 : :
4771 [ - + + - : 64 : ABI_MALLOC(qglob2bz, (max_nq, gstore%nsppol))
- + + - +
- + - - +
- + - + ]
4772 [ - + + - : 64 : ABI_MALLOC(gstore%kglob2bz, (max_nk, gstore%nsppol))
- + + - +
- + - - +
- + - + ]
4773 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qglob2bz"), qglob2bz))
4774 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kglob2bz"), gstore%kglob2bz))
4775 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_glob_nq_spin"), gstore%glob_nq_spin))
4776 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_glob_nk_spin"), gstore%glob_nk_spin))
4777 : :
4778 : : ! Read optional variables:
4779 [ - + ]: 16 : if (gstore%kfilter == "fs_tetra") then
4780 [ # # # # : 0 : ABI_MALLOC(gstore%delta_ef_kibz_spin, (max_nb, gstore%nkibz, gstore%nsppol))
# # # # #
# # # # #
# # # # #
# # # ]
4781 [ # # ]: 0 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_delta_ef_kibz_spin"), gstore%delta_ef_kibz_spin))
4782 : : end if
4783 : :
4784 [ - + ]: 16 : NCF_CHECK(nf90_close(ncid))
4785 : :
4786 : : ! =================
4787 : : ! Consistency check
4788 : : ! =================
4789 [ - + - + : 16 : gstore_cryst = wfk0_hdr%get_crystal()
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + ]
4790 [ - + ]: 16 : if (cryst%compare(gstore_cryst, header=" Comparing input crystal with the one from GSTORE file") /= 0) then
4791 : 0 : ABI_ERROR("Crystal structure from input and GSTORE do not agree! Check messages above!")
4792 : : end if
4793 : 16 : call gstore_cryst%free()
4794 : : end if ! master
4795 : :
4796 [ - + ]: 16 : if (nproc > 1) then
4797 : : ! Broadcast the header.
4798 : 0 : call wfk0_hdr%bcast(master, my_rank, comm)
4799 : :
4800 : : ! Broadcast dimensions.
4801 [ # # ]: 0 : if (my_rank == master) then
4802 [ # # ]: 0 : ibuffer = [gstore_cplex, gstore%nkibz, gstore%nkbz, gstore%nqibz, gstore%nqbz, gstore%with_vk, max_nq, max_nk, max_nb]
4803 : : end if
4804 : 0 : call xmpi_bcast(ibuffer, master, comm, ierr)
4805 : :
4806 [ # # ]: 0 : if (my_rank /= master) then
4807 : : ! Other MPI procs need to store dims and allocate memory before the bcast.
4808 : 0 : gstore_cplex = ibuffer(1)
4809 : 0 : gstore%nkibz = ibuffer(2)
4810 : 0 : gstore%nkbz = ibuffer(3)
4811 : 0 : gstore%nqibz = ibuffer(4)
4812 : 0 : gstore%nqbz = ibuffer(5)
4813 : 0 : gstore%with_vk = ibuffer(6)
4814 : 0 : max_nq = ibuffer(7)
4815 : 0 : max_nk = ibuffer(8)
4816 : 0 : max_nb = ibuffer(9)
4817 : :
4818 [ # # # # : 0 : ABI_MALLOC(gstore%qibz, (3, gstore%nqibz))
# # # # #
# # # #
# ]
4819 [ # # # # : 0 : ABI_MALLOC(gstore%wtq, (gstore%nqibz))
# # # # #
# # # #
# ]
4820 [ # # # # : 0 : ABI_MALLOC(gstore%qbz, (3, gstore%nqbz))
# # # # #
# # # #
# ]
4821 [ # # # # : 0 : ABI_MALLOC(gstore%kbz, (3, gstore%nkbz))
# # # # #
# # # #
# ]
4822 [ # # # # : 0 : ABI_MALLOC(qbz2ibz, (6, gstore%nqbz))
# # # # #
# # # #
# ]
4823 [ # # # # : 0 : ABI_MALLOC(gstore%kbz2ibz, (6, gstore%nkbz))
# # # # #
# # # #
# ]
4824 [ # # # # : 0 : ABI_MALLOC(qglob2bz, (max_nq, gstore%nsppol))
# # # # #
# # # # #
# # # # ]
4825 [ # # # # : 0 : ABI_MALLOC(gstore%kglob2bz, (max_nk, gstore%nsppol))
# # # # #
# # # # #
# # # # ]
4826 : : end if
4827 : :
4828 : 0 : call xmpi_bcast(gstore%qptopt, master, comm, ierr)
4829 : 0 : call xmpi_bcast(gstore%has_used_lgk, master, comm, ierr)
4830 : 0 : call xmpi_bcast(gstore%has_used_lgq, master, comm, ierr)
4831 : 0 : call xmpi_bcast(gstore%kzone, master, comm, ierr)
4832 : 0 : call xmpi_bcast(gstore%qzone, master, comm, ierr)
4833 : 0 : call xmpi_bcast(gstore%kfilter, master, comm, ierr)
4834 : 0 : call xmpi_bcast(gstore%gmode, master, comm, ierr)
4835 : 0 : call xmpi_bcast(gstore%gtype, master, comm, ierr)
4836 : 0 : call xmpi_bcast(gstore%ngqpt, master, comm, ierr)
4837 : 0 : call xmpi_bcast(gstore%wfk0_path, master, comm, ierr)
4838 : 0 : call xmpi_bcast(brange_k_spin, master, comm, ierr)
4839 : 0 : call xmpi_bcast(brange_kq_spin, master, comm, ierr)
4840 : 0 : call xmpi_bcast(gstore%erange_spin, master, comm, ierr)
4841 : 0 : call xmpi_bcast(gstore%qibz, master, comm, ierr)
4842 : 0 : call xmpi_bcast(gstore%wtq, master, comm, ierr)
4843 : 0 : call xmpi_bcast(gstore%qbz, master, comm, ierr)
4844 : 0 : call xmpi_bcast(gstore%kbz, master, comm, ierr)
4845 : 0 : call xmpi_bcast(qbz2ibz, master, comm, ierr)
4846 : 0 : call xmpi_bcast(gstore%kbz2ibz, master, comm, ierr)
4847 : 0 : call xmpi_bcast(qglob2bz, master, comm, ierr)
4848 : 0 : call xmpi_bcast(gstore%kglob2bz, master, comm, ierr)
4849 : 0 : call xmpi_bcast(gstore%glob_nq_spin, master, comm, ierr)
4850 : 0 : call xmpi_bcast(gstore%glob_nk_spin, master, comm, ierr)
4851 : :
4852 [ # # ]: 0 : if (gstore%kfilter == "fs_tetra") then
4853 [ # # ]: 0 : if (my_rank /= master) then
4854 [ # # # # : 0 : ABI_MALLOC(gstore%delta_ef_kibz_spin, (max_nb, gstore%nkibz, gstore%nsppol))
# # # # #
# # # # #
# # # # #
# # # ]
4855 : : end if
4856 : 0 : call xmpi_bcast(gstore%delta_ef_kibz_spin, master, comm, ierr)
4857 : : end if
4858 : : end if ! nproc > 1.
4859 : :
4860 : : ! Consistency check
4861 : 16 : call wfk0_hdr%vs_dtset(dtset); call wfk0_hdr%free()
4862 : :
4863 : : ! When reading an existing GSTORE file, gstore_brange selects a smaller window of
4864 : : ! intermediate states at k+q. The external-state window at k is always the one on disk.
4865 : : ! Keep the file range to compute the offset in the NetCDF nb_kq dimension below.
4866 [ + + + + ]: 64 : file_brange_kq_spin = brange_kq_spin
4867 [ + + ]: 32 : do spin=1,gstore%nsppol
4868 [ + + + + : 62 : if (any(dtset%gstore_brange(:, spin) /= 0)) then
+ + ]
4869 [ + + + - : 3 : ABI_CHECK(all(dtset%gstore_brange(:, spin) /= 0), "Both entries of gstore_brange must be specified")
- + ]
4870 [ - + ]: 1 : ABI_CHECK_IEQ(dtset%gstore_brange(2, spin), dtset%mband, "gstore_brange(2, spin) must be equal to nband")
4871 [ + - ]: 1 : if (dtset%eph_stern /= 0) then
4872 [ - + ]: 1 : ABI_CHECK_IEQ(dtset%gstore_brange(1, spin), 1, "gstore_brange(1, spin) must be 1 when eph_stern is enabled")
4873 : : end if
4874 : : msg = sjoin("Requested gstore_brange:", ltoa(dtset%gstore_brange(:, spin)), "is not contained in the k+q band range stored in GSTORE.nc:", &
4875 [ + - ]: 1 : ltoa(file_brange_kq_spin(:, spin)))
4876 [ + - - + ]: 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)
4877 [ + + ]: 3 : brange_kq_spin(:, spin) = dtset%gstore_brange(:, spin)
4878 : : call wrtout(units, sjoin(" Restricting k+q states for spin", itoa(spin), "to gstore_brange:", &
4879 : 1 : ltoa(brange_kq_spin(:, spin))))
4880 : : end if
4881 : : end do
4882 : :
4883 : : ! If has_both_g is true, we allocate and read both the KS and the GWPT matrix elements.
4884 : 16 : read_ks = gstore%gtype == GSTORE_GTYPE_GWPT
4885 : 16 : has_both_g = gstore%gtype == GSTORE_GTYPE_GWPT
4886 : :
4887 : : ! Distribute spins, create indirect mapping to spin index and init gstore%brange_k_spin
4888 : 16 : call gstore%distribute_spins__(ebands%mband, brange_kq_spin, brange_k_spin, nproc_spin, comm_spin, comm)
4889 : :
4890 : : ! Compute krank
4891 [ + - - - : 16 : call gstore%krank_ibz%from_kptrlatt(gstore%nkibz, gstore%kibz, ebands%kptrlatt, compute_invrank=.False.)
- - - - -
+ ]
4892 : :
4893 : 16 : call gstore%set_mpi_grid__(dtfil, nproc_spin, comm_spin)
4894 : :
4895 : : ! At this point, we have the Cartesian grid (one per spin if any) and we can finally allocate and distribute other arrays.
4896 : 16 : call gstore%malloc__(with_cplex, has_both_g, max_nq, qglob2bz, max_nk, gstore%kglob2bz, qbz2ibz, gstore%kbz2ibz)
4897 : :
4898 : 16 : call xmpi_comm_free(comm_spin)
4899 : :
4900 : : ! Now we read the big arrays with MPI-IO and hdf5 groups.
4901 : : ! Note the loop over spin as each gqk has its own dimensions.
4902 : : ! Recall the shape of the arrays:
4903 : : !
4904 : : ! In memory, we have allocated:
4905 : : !
4906 : : ! my_g(my_npert, nb_kq, my_nq, nb_k, my_nk) if with_cplex == 2 (complex array)
4907 : : !
4908 : : ! or
4909 : : !
4910 : : ! my_g2(my_npert, nb_kq, my_nq, nb_k, my_nk) if with_cplex == 1
4911 : : !
4912 : : ! On disk, we have:
4913 : : !
4914 : : ! nctkarr_t("gvals", "dp", "two, nb_kq_disk, nb_k_disk, natom3, glob_nk, glob_nq")
4915 : : !
4916 : 16 : call cwtime(cpu, wall, gflops, "start")
4917 : :
4918 : : ! ===================================================
4919 : : ! Load phonon frequencies and eigenvectors in the IBZ
4920 : : ! ===================================================
4921 : :
4922 : : ! nctkarr_t("phfreqs_ibz", "dp", "natom3, gstore_nqibz")
4923 : : ! nctkarr_t("pheigvec_cart_ibz", "dp", "two, three, natom, natom3, gstore_nqibz")
4924 [ - + + - : 64 : ABI_MALLOC(phfreqs_ibz, (natom3, gstore%nqibz))
- + + - +
- + - - +
- + - + ]
4925 [ - + + - : 80 : ABI_MALLOC(pheigvec_cart_ibz, (2, 3, cryst%natom, cryst%natom * 3, gstore%nqibz))
+ - - + +
- - + + -
+ - + - -
+ - + -
+ ]
4926 [ - + + - : 64 : ABI_MALLOC(pheigvec_cart_qbz, (2, 3, cryst%natom, cryst%natom * 3))
- + + - +
- + - - +
- + ]
4927 [ - + + - : 48 : ABI_MALLOC(displ_cart_qbz, (2, 3, cryst%natom, cryst%natom * 3))
- + + - -
+ - + ]
4928 [ - + + - : 64 : ABI_MALLOC(displ_red_qbz, (2, 3, cryst%natom, natom3))
- + + - +
- + - - +
- + ]
4929 : :
4930 : : !NCF_CHECK(nctk_open_read(ncid, gstore%path, gstore%comm))
4931 : : ! SC: Open with xmpi_comm_self (independent IO) instead of gqk%comm, otherwise there will be a deadlock on lemaitre4
4932 [ - + ]: 16 : NCF_CHECK(nctk_open_read(ncid, gstore%path, xmpi_comm_self))
4933 : 16 : has_iv1p_comm = gstore_nc_has_iv1p_comm(gstore, ncid)
4934 : : ! SC: nctk_set_collective can cause a deadlock on lemaitre4
4935 : : !if (nproc > 1) then
4936 : : ! NCF_CHECK(nctk_set_collective(ncid, vid("phfreqs_ibz")))
4937 : : ! NCF_CHECK(nctk_set_collective(ncid, vid("pheigvec_cart_ibz")))
4938 : : !end if
4939 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("phfreqs_ibz"), phfreqs_ibz))
4940 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("pheigvec_cart_ibz"), pheigvec_cart_ibz))
4941 [ - + ]: 16 : NCF_CHECK(nf90_close(ncid))
4942 : :
4943 : : ! =========================
4944 : : ! Load e-ph matrix elements
4945 : : ! =========================
4946 : 16 : call pstat_proc%print(_PSTAT_ARGS_)
4947 : :
4948 : 16 : from_atm_to_nu = .False.
4949 : : ! Compare with_gmode with the one on disk. The only conversion I can think of is: atom --> phonon.
4950 [ - + ]: 16 : if (gstore%gmode /= with_gmode) then
4951 [ + - + - ]: 16 : if (gstore%gmode == GSTORE_GMODE_ATOM .and. with_gmode == GSTORE_GMODE_PHONON) then
4952 : 16 : from_atm_to_nu = .True.; gstore%gmode = GSTORE_GMODE_PHONON ! Change gstore%gmode here
4953 : : else
4954 : 0 : ABI_ERROR(sjoin("Conversion from gstore%gmode: ", gstore%gmode, "to:", with_gmode, " is not yet supported"))
4955 : : end if
4956 : : end if
4957 [ + - ]: 16 : gstore%gmode = with_gmode
4958 : :
4959 [ + + ]: 16 : if (with_g2dw) then
4960 [ - + ]: 7 : ABI_CHECK(with_gmode == GSTORE_GMODE_PHONON, "g2dw in the atom representation is not coded")
4961 [ - + + - : 28 : ABI_MALLOC(tpp_red, (natom3, natom3))
- + + - +
- + - - +
- + ]
4962 : : end if
4963 : :
4964 [ + + ]: 32 : do spin=1,gstore%nsppol
4965 : 16 : my_is = gstore%spin2my_is(spin)
4966 : :
4967 [ + - ]: 32 : if (my_is /= 0) then
4968 : 16 : gqk => gstore%gqk(my_is)
4969 : :
4970 [ - + + - : 64 : ABI_MALLOC(gqk%my_wnuq, (gqk%my_npert, gqk%my_nq))
- + + - +
- + - - +
- + - + ]
4971 [ - + + - : 80 : ABI_MALLOC(gqk%my_displ_cart, (2, 3, cryst%natom, gqk%my_npert, gqk%my_nq))
- + + - -
+ + - + -
+ - - + -
+ - + ]
4972 : :
4973 : : !NCF_CHECK(nctk_open_read(ncid, gstore%path, gqk%comm%value))
4974 : : ! SC: Open with xmpi_comm_self (independent IO) instead of gqk%comm, otherwise there will be a deadlock on lemaitre4
4975 [ - + ]: 16 : NCF_CHECK(nctk_open_read(ncid, gstore%path, xmpi_comm_self))
4976 [ - + ]: 16 : NCF_CHECK(nf90_inq_ncid(ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
4977 : :
4978 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_k", nb_k_file))
4979 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_kq", nb_kq_file))
4980 : :
4981 : : ! Note that these dimensions should be compatible with what is stored on disk.
4982 : 16 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
4983 [ - + ]: 16 : ABI_CHECK_IEQ(nb_k, nb_k_file, "nb_k !/ nb_k_file")
4984 [ - + ]: 16 : ABI_CHECK_ILEQ(nb_kq, nb_kq_file, "nb_kq > nb_kq_file")
4985 : 16 : ib_kq_start = gqk%bstart_kq - file_brange_kq_spin(1, spin) + 1
4986 [ + - - + ]: 16 : ABI_CHECK_IRANGE(ib_kq_start, 1, nb_kq_file, "Invalid k+q band offset in GSTORE.nc")
4987 [ - + ]: 16 : ABI_CHECK_ILEQ(ib_kq_start + nb_kq - 1, nb_kq_file, "Requested k+q band window exceeds GSTORE.nc")
4988 : :
4989 : : ! gstore_cplex defines the data on disk while cplex defines what we want to store in memory
4990 [ - + + - : 112 : ABI_MALLOC_OR_DIE(gwork_q, (gstore_cplex, nb_kq, nb_k, gqk%natom3, gqk%glob_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - -
+ + - -
+ ]
4991 [ - + + - : 80 : ABI_MALLOC(slice_bb, (gstore_cplex, nb_kq, nb_k))
- + + - -
+ + - + -
+ - - + -
+ ]
4992 [ + + ]: 16 : if (read_ks) then
4993 [ - + + - : 42 : ABI_MALLOC_OR_DIE(ks_gwork_q, (gstore_cplex, nb_kq, nb_k, gqk%natom3, gqk%glob_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - -
+ + - -
+ ]
4994 [ - + + - : 30 : ABI_MALLOC(ks_slice_bb, (gstore_cplex, nb_kq, nb_k))
- + + - -
+ + - + -
+ - - + -
+ - + ]
4995 : : end if
4996 : :
4997 [ + + ]: 16 : if (with_g2dw) then
4998 : : ! Read my_gq0nm_atm matrix elements for DW in the RIA. Find the index of q = 0.
4999 : 7 : iq_glob = -1
5000 [ + - ]: 7 : do ii=1, gstore%glob_nq_spin(spin)
5001 : 7 : iq_bz = qglob2bz(ii, spin)
5002 [ + + + - ]: 28 : if (sum(gstore%qbz(:, iq_bz)**2) < tol4) then
5003 : 7 : iq_glob = ii; exit
5004 : : end if
5005 : : end do
5006 [ - + ]: 7 : ABI_CHECK_INEQ(iq_glob, -1, "Cannot finq q=0 in g(k,q)!")
5007 : 7 : call wrtout(std_out, sjoin(" Reading g_atm(k,q=0) for Debye-Waller with iq_glob:", itoa(iq_glob)))
5008 : :
5009 : : ! Read q-slice of the e-ph matrix elements (individual IO).
5010 : : ! Note gvals_name so that we can read either g^KS or g^Sigma.
5011 [ + + ]: 49 : ncerr = nf90_get_var(spin_ncid, spin_vid(gvals_name), gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
5012 [ - + ]: 7 : NCF_CHECK(ncerr)
5013 : :
5014 [ + + ]: 7 : if (read_ks) then
5015 [ + + ]: 42 : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals_ks"), ks_gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
5016 [ - + ]: 6 : NCF_CHECK(ncerr)
5017 : : ! Here we set g_GWPT g to g_KS if g_KS is smaller than a certain threshold as GWPT breaks symmetries.
5018 [ + + + + : 13931 : where (abs(ks_gwork_q) < G_SMALL)
+ + + + +
+ + + ]
5019 : : gwork_q = ks_gwork_q
5020 : : end where
5021 : : end if
5022 : :
5023 : : ! Allocate gdw2
5024 [ - + + - : 49 : ABI_MALLOC(gqk%my_gdw2, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk))
- + + - -
+ + - - +
+ - - + +
- + - + -
- + - + -
+ ]
5025 : 7 : gqk%my_gdw2_ks => gqk%my_gdw2
5026 : : ! Allocate my_gq0nm_atm and transfer data. Note TRANSPOSITION in (m, n) indices.
5027 [ - + + - : 42 : ABI_MALLOC(my_gq0nm_atm, (nb_k, nb_kq, natom3, gqk%my_nk))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
5028 : :
5029 [ + + ]: 7 : if (gqk%has_both_g) then
5030 [ - + + - : 36 : ABI_MALLOC(gqk%my_gdw2_ks, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk))
- + + - -
+ + - - +
+ - - + +
- - + -
+ ]
5031 [ - + + - : 30 : ABI_MALLOC(ks_my_gq0nm_atm, (nb_k, nb_kq, natom3, gqk%my_nk))
- + + - -
+ + - - +
+ - - + -
+ - + ]
5032 : : end if
5033 : :
5034 [ + + ]: 19 : do my_ik=1,gqk%my_nk
5035 : 12 : ik_glob = my_ik + gqk%my_kstart - 1
5036 [ + + ]: 167 : do ib_m=1,nb_kq
5037 [ + + ]: 988 : do ib_n=1,nb_k
5038 [ + + ]: 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)
5039 [ + + ]: 976 : if (gqk%has_both_g) then
5040 [ + + ]: 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)
5041 : : end if
5042 : : end do
5043 : : end do
5044 : : end do
5045 : : end if ! with_g2dw
5046 : :
5047 [ - + ]: 16 : if (has_iv1p_comm) then
5048 : : ! Read matrix elements of commutator [iv, p].
5049 [ # # # # : 0 : ABI_MALLOC(gqk%my_iv1p_comm, (nb_k, nb_k, 3, gqk%my_npert, gqk%my_nk))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5050 [ # # # # : 0 : ABI_MALLOC(iv1p_comm, (2, nb_k, nb_k, 3, natom3))
# # # # #
# # # # #
# # # # #
# # # #
# ]
5051 : : ! nctkarr_t("iv1p_comm", "dp", "two, nb_k, nb_k, three, natom3, glob_nk")
5052 : :
5053 [ # # ]: 0 : do my_ik=1,gqk%my_nk
5054 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
5055 [ # # ]: 0 : ncerr = nf90_get_var(spin_ncid, spin_vid("iv1p_comm"), iv1p_comm, start=[1,1,1,1,1, ik_glob])
5056 [ # # ]: 0 : NCF_CHECK(ncerr)
5057 : :
5058 : : ! Save my perturbations for this k-point.
5059 [ # # ]: 0 : do my_ip=1,gqk%my_npert
5060 : 0 : ipert = gqk%my_pertcases(my_ip)
5061 [ # # # # : 0 : gqk%my_iv1p_comm(:,:,:,my_ip, my_ik) = r2c(iv1p_comm(:,:,:,:,ipert))
# # # # ]
5062 : : end do
5063 : : end do
5064 [ # # ]: 0 : ABI_FREE(iv1p_comm)
5065 : : end if
5066 : :
5067 [ + - ]: 16 : if (from_atm_to_nu) then
5068 [ - + + - : 80 : ABI_MALLOC(gmn_nu, (2, nb_kq, nb_k, 3*natom))
- + + - +
- - + + -
+ - + - -
+ - + -
+ ]
5069 : : end if
5070 : :
5071 : : ! Read my e-ph matrix elements.
5072 [ + + ]: 1365 : do my_iq=1,gqk%my_nq
5073 : 1349 : iq_glob = my_iq + gqk%my_qstart - 1
5074 : :
5075 : : !call wrtout(std_out, " Computing and storing phonons in the full BZ by rotating the data in the IBZ...")
5076 : 1349 : iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
5077 : 1349 : trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5, my_iq)
5078 : : !isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
5079 : 1349 : isirr_q = (isym_q == 1 .and. trev_q == 0)
5080 : 1349 : tsign_q = 1; if (trev_q == 1) tsign_q = -1
5081 [ + + ]: 5396 : qq_ibz = gstore%qibz(:, iq_ibz)
5082 : :
5083 : : ! Here we get the ph displacement for this q-point in the BZ from the image in the IBZ.
5084 : : ! This is important for complex g as we have to enforce the gauge in the ph eigenvectors, including e(-q) = e(q)^*.
5085 : : call pheigvec_rotate(cryst, qq_ibz, isym_q, trev_q, pheigvec_cart_ibz(:,:,:,:,iq_ibz), pheigvec_cart_qbz, displ_cart_qbz, &
5086 : 1349 : displ_red_qbz=displ_red_qbz)
5087 : :
5088 : : ! Save my frequencies and my phonon displacements.
5089 [ + - + + : 17537 : gqk%my_wnuq(:, my_iq) = phfreqs_ibz(gqk%my_pertcases(:), iq_ibz)
+ + ]
5090 [ + - + + : 179417 : gqk%my_displ_cart(:,:,:,:,my_iq) = displ_cart_qbz(:,:,:,gqk%my_pertcases(:))
+ + + + +
+ + + ]
5091 : :
5092 [ + + ]: 1349 : if (with_g2dw) then
5093 [ + + ]: 1176 : do my_ip=1,gqk%my_npert
5094 : : ! Compute T_pp'(q,nu) matrix in reduced coordinates for DW.
5095 : 1008 : call phdispl_cart2red_nmodes(natom, 1, cryst%gprimd, gqk%my_displ_cart(:,:,:,my_ip,my_iq), displ_nu_red)
5096 : 1008 : call sigtk_dw_tpp_red(natom, displ_nu_red, tpp_red)
5097 : 1008 : wqnu = gqk%my_wnuq(my_ip, my_iq)
5098 : :
5099 [ + + ]: 2424 : do my_ik=1,gqk%my_nk
5100 [ + + + + ]: 2256 : if (.not. gqk%has_both_g .or. dtset%gwpt_g2mode == 1) then
5101 : : call calc_and_store_gdw2(gqk, my_ik, my_iq, my_ip, wqnu, tpp_red, &
5102 : 864 : my_gq0nm_atm(:,:,:,my_ik), my_gq0nm_atm(:,:,:,my_ik))
5103 : : else
5104 : : !print *, "Computing g2dw with both g^KS g_GWPT"
5105 : : call calc_and_store_gdw2(gqk, my_ik, my_iq, my_ip, wqnu, tpp_red, &
5106 : 384 : ks_my_gq0nm_atm(:,:,:,my_ik), my_gq0nm_atm(:,:,:,my_ik))
5107 : : end if
5108 : : end do ! my_ik
5109 : :
5110 : : end do ! my_ip
5111 : : end if
5112 : :
5113 : : ! Read q-slice of g(k,q) in the atom representation. (individual IO).
5114 [ + + ]: 9443 : ncerr = nf90_get_var(spin_ncid, spin_vid(gvals_name), gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
5115 [ - + ]: 1349 : NCF_CHECK(ncerr)
5116 : :
5117 [ + + ]: 1349 : if (read_ks) then
5118 [ + + ]: 728 : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals_ks"), ks_gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
5119 [ - + ]: 104 : NCF_CHECK(ncerr)
5120 : : ! Here we set g_GWPT g to g_KS if g_KS is smaller than a certain threshold as GWPT breaks symmetries.
5121 [ + + + + : 153560 : where (abs(ks_gwork_q) < G_SMALL)
+ + + + +
+ + + ]
5122 : : gwork_q = ks_gwork_q
5123 : : end where
5124 : : end if
5125 : :
5126 [ + + ]: 111960 : do my_ik=1,gqk%my_nk
5127 : 110595 : ik_glob = my_ik + gqk%my_kstart - 1
5128 [ + - ]: 110595 : if (from_atm_to_nu) then
5129 : : ! Here we convert from g(k,q)_atom to g(k,q)_phonon and replace data in gwork_q at ik_glob
5130 : : call ephtk_gkknu_from_atm(nb_kq, nb_k, 1, natom, gwork_q(:,:,:,:, ik_glob), &
5131 : 110595 : phfreqs_ibz(:, iq_ibz), displ_red_qbz, gmn_nu)
5132 [ + + + + : 12601221 : gwork_q(:,:,:,:, ik_glob) = gmn_nu
+ + + + ]
5133 : :
5134 [ + + ]: 110595 : if (gqk%has_both_g) then
5135 : : call ephtk_gkknu_from_atm(nb_kq, nb_k, 1, natom, ks_gwork_q(:,:,:,:, ik_glob), &
5136 : 144 : phfreqs_ibz(:, iq_ibz), displ_red_qbz, gmn_nu)
5137 [ + + + + : 153456 : ks_gwork_q(:,:,:,:, ik_glob) = gmn_nu
+ + + + ]
5138 : : end if
5139 : : end if
5140 : :
5141 [ + + ]: 775514 : do my_ip=1,gqk%my_npert
5142 : 663570 : ipert = gqk%my_pertcases(my_ip)
5143 [ + - + - : 13154196 : slice_bb = gwork_q(:,:,:, ipert, ik_glob)
+ - - + -
- + + + +
+ + ]
5144 [ + + ]: 663570 : if (read_ks) then
5145 [ + - + - : 154176 : ks_slice_bb = ks_gwork_q(:,:,:, ipert, ik_glob)
+ - - + -
- + + + +
+ + ]
5146 : : end if
5147 : :
5148 : : ! Put data in the right place and handle conversion g --> |g|^2.
5149 [ + + ]: 774165 : if (with_cplex == gstore_cplex) then
5150 [ - + ]: 662706 : if (with_cplex == 1) then
5151 [ # # # # ]: 0 : gqk%my_g2(my_ip,:,my_iq,:,my_ik) = slice_bb(1,:,:)
5152 [ # # # # ]: 0 : if (read_ks .and. gqk%has_both_g) then
5153 [ # # # # ]: 0 : gqk%my_g2_ks(my_ip,:,my_iq,:,my_ik) = ks_slice_bb(1,:,:)
5154 : : end if
5155 : : end if
5156 [ + - ]: 662706 : if (with_cplex == 2) then
5157 [ + + + + ]: 5439486 : gqk%my_g(my_ip,:,my_iq,:,my_ik) = slice_bb(1,:,:) + j_dpc * slice_bb(2,:,:)
5158 [ + + + - ]: 662706 : if (read_ks .and. gqk%has_both_g) then
5159 [ + + + + ]: 17280 : gqk%my_g_ks(my_ip,:,my_iq,:,my_ik) = ks_slice_bb(1,:,:) + j_dpc * ks_slice_bb(2,:,:)
5160 : : end if
5161 : : end if
5162 : :
5163 : : else
5164 [ + - + - ]: 864 : if (with_cplex == 1 .and. gstore_cplex == 2) then
5165 [ + + + + ]: 69984 : gqk%my_g2(my_ip, :, my_iq, :, my_ik) = slice_bb(1,:,:) ** 2 + slice_bb(2,:,:) ** 2
5166 [ + + + - ]: 864 : if (read_ks .and. gqk%has_both_g) then
5167 [ + + + + ]: 37344 : gqk%my_g2_ks(my_ip, :, my_iq, :, my_ik) = ks_slice_bb(1,:,:) ** 2 + ks_slice_bb(2,:,:) ** 2
5168 : : end if
5169 [ # # ]: 0 : else if (with_cplex == 0) then
5170 : : continue
5171 : : else
5172 : 0 : ABI_ERROR("Conversion from g2 on file to g_complex in memory is not possible!")
5173 : : end if
5174 : : end if
5175 : : end do ! my_ip
5176 : : end do ! my_ik
5177 : :
5178 : : end do ! my_iq
5179 : :
5180 [ - + ]: 16 : ABI_FREE(gwork_q)
5181 [ - + ]: 16 : ABI_FREE(slice_bb)
5182 [ + + ]: 16 : if (read_ks) then
5183 [ - + ]: 6 : ABI_FREE(ks_gwork_q)
5184 [ - + ]: 6 : ABI_FREE(ks_slice_bb)
5185 : : end if
5186 : :
5187 [ + - ]: 16 : ABI_SFREE(gmn_nu)
5188 [ + + ]: 16 : ABI_SFREE(my_gq0nm_atm)
5189 [ + + ]: 16 : ABI_SFREE(ks_my_gq0nm_atm)
5190 : :
5191 : : ! =========================================
5192 : : ! Read matrix elements of velocity operator
5193 : : ! =========================================
5194 : : ! SC: nctk_set_collective can cause a deadlock on lemaitre4
5195 [ + - ]: 16 : if (gstore%with_vk == 1) then
5196 : : !if (gqk%comm%nproc > 1) then
5197 : : ! NCF_CHECK(nctk_set_collective(spin_ncid, spin_vid("vk_cart_ibz")))
5198 : : !end if
5199 [ - + ]: 16 : NCF_CHECK(nf90_get_var(spin_ncid, spin_vid("vk_cart_ibz"), gqk%vnk_cart_ibz))
5200 : :
5201 [ # # ]: 0 : else if (gstore%with_vk == 2) then
5202 : : !if (gqk%comm%nproc > 1) then
5203 : : ! NCF_CHECK(nctk_set_collective(spin_ncid, spin_vid("vnk_mat_cart_ibz")))
5204 : : !end if
5205 [ # # ]: 0 : NCF_CHECK(nf90_get_var(spin_ncid, spin_vid("vnk_mat_cart_ibz"), gqk%vnk_mat_cart_ibz))
5206 : :
5207 : : ! Transfer diagonal terms to vnk_cart_ibz.
5208 [ # # ]: 0 : do ib=1,gqk%nb_k
5209 [ # # # # ]: 0 : gqk%vnk_cart_ibz(:, ib, :) = gqk%vnk_mat_cart_ibz(1, :, ib, ib, :)
5210 : : end do
5211 : : end if
5212 : :
5213 [ - + ]: 16 : NCF_CHECK(nf90_close(ncid))
5214 : : end if
5215 : : end do ! spin
5216 : :
5217 [ - + ]: 16 : ABI_FREE(qglob2bz)
5218 [ - + ]: 16 : ABI_FREE(qbz2ibz)
5219 [ - + ]: 16 : ABI_FREE(phfreqs_ibz)
5220 [ - + ]: 16 : ABI_FREE(pheigvec_cart_ibz)
5221 [ - + ]: 16 : ABI_FREE(displ_cart_qbz)
5222 [ - + ]: 16 : ABI_FREE(displ_red_qbz)
5223 [ - + ]: 16 : ABI_FREE(pheigvec_cart_qbz)
5224 [ + + ]: 16 : ABI_SFREE(tpp_red)
5225 : :
5226 : 16 : call pstat_proc%print(_PSTAT_ARGS_)
5227 : 16 : call xmpi_barrier(gstore%comm)
5228 [ - + - + : 48 : call cwtime_report(" gstore_from_ncpath", cpu, wall, gflops)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
5229 : :
5230 : : !stop
5231 : :
5232 : : contains
5233 : 400 : integer function vid(var_name)
5234 : : character(len=*),intent(in) :: var_name
5235 : 400 : vid = nctk_idname(ncid, var_name)
5236 : : end function vid
5237 : :
5238 : 1482 : integer function spin_vid(var_name)
5239 : : character(len=*),intent(in) :: var_name
5240 : 1482 : spin_vid = nctk_idname(spin_ncid, var_name)
5241 : : end function spin_vid
5242 : :
5243 : : end subroutine gstore_from_ncpath
5244 : : !!***
5245 : :
5246 : 1248 : subroutine calc_and_store_gdw2(gqk, my_ik, my_iq, my_ip, wqnu, tpp_red, gq0l_atm, gq0r_atm)
5247 : :
5248 : : type(gqk_t), intent(inout) :: gqk
5249 : : integer,intent(in) :: my_ik, my_iq, my_ip
5250 : : real(dp),intent(in) :: wqnu
5251 : : complex(dp),intent(in) :: tpp_red(gqk%natom3, gqk%natom3)
5252 : : complex(dp),intent(in) :: gq0l_atm(gqk%nb_k, gqk%nb_kq, gqk%natom3)
5253 : : complex(dp),intent(in) :: gq0r_atm(gqk%nb_k, gqk%nb_kq, gqk%natom3)
5254 : :
5255 : : !Local variables-------------------------------
5256 : : !scalars
5257 : : integer :: im_kq, in_k, ip2, ip1
5258 : : real(dp) :: gdw2
5259 : : complex(dp) :: cfact
5260 : : ! *************************************************************************
5261 : :
5262 : : ! Loop over bands in |m,k+q>
5263 [ + + ]: 18432 : do im_kq=1,gqk%nb_kq
5264 : : ! Loop over the n index in |n,k>.
5265 [ + + ]: 98496 : do in_k=1,gqk%nb_k
5266 : : ! Compute DW term following XG paper. Check prefactor.
5267 : : gdw2 = zero
5268 [ + + ]: 560448 : do ip2=1,gqk%natom3
5269 [ + + ]: 3442752 : do ip1=1,gqk%natom3
5270 : : cfact = ( &
5271 : : + real(gq0l_atm(in_k, im_kq, ip1)) * real(gq0r_atm(in_k, im_kq, ip2)) &
5272 : : + aimag(gq0l_atm(in_k, im_kq, ip1)) * aimag(gq0r_atm(in_k, im_kq, ip2)) &
5273 : : + real(gq0l_atm(in_k, im_kq, ip2)) * real(gq0r_atm(in_k, im_kq, ip1)) &
5274 : : + aimag(gq0l_atm(in_k, im_kq, ip2)) * aimag(gq0r_atm(in_k, im_kq, ip1)) &
5275 : 2882304 : )
5276 : 3362688 : gdw2 = gdw2 + real(tpp_red(ip1,ip2) * cfact)
5277 : : end do
5278 : : end do
5279 : :
5280 [ + + ]: 80064 : if (wqnu < EPHTK_WTOL) then
5281 : : gdw2 = zero
5282 : : else
5283 : 77580 : gdw2 = gdw2 / (four * two * wqnu)
5284 : : end if
5285 : :
5286 : : !print *, "gdw2", gdw2
5287 : 97248 : gqk%my_gdw2(my_ip, im_kq, my_iq, in_k, my_ik) = gdw2
5288 : : end do ! in_k
5289 : : end do ! im_kq
5290 : :
5291 : 1248 : end subroutine calc_and_store_gdw2
5292 : :
5293 : : !----------------------------------------------------------------------
5294 : :
5295 : : !!****f* m_gstore/gstore_check_restart
5296 : : !! NAME
5297 : : !! gstore_check_restart
5298 : : !!
5299 : : !! FUNCTION
5300 : : !! Check whether restart from a previous GSTORE.nc is possible.
5301 : : !!
5302 : : !! INPUTS
5303 : : !!
5304 : : !! SOURCE
5305 : :
5306 : 3 : subroutine gstore_check_restart(filepath, dtset, nqbz, done_qbz_spin, restart, comm)
5307 : :
5308 : : !Arguments ------------------------------------
5309 : : character(len=*),intent(in) :: filepath
5310 : : type(dataset_type),intent(in) :: dtset
5311 : : integer,intent(out) :: nqbz, restart
5312 : : integer,allocatable,intent(out) :: done_qbz_spin(:,:)
5313 : : integer,intent(in) :: comm
5314 : :
5315 : : !Local variables-------------------------------
5316 : : !scalars
5317 : : integer,parameter :: master = 0
5318 : : integer :: my_rank, root_ncid, ierr, gstore_completed, gstore_fform, units(2) ! fform
5319 : : character(len=500) :: msg
5320 : 3 : type(hdr_type) :: gstore_hdr
5321 : : ! *************************************************************************
5322 : :
5323 [ + + ]: 9 : my_rank = xmpi_comm_rank(comm); units = [std_out, ab_out]
5324 : :
5325 : : !print *, "eph_restart:", dtset%eph_restart
5326 : :
5327 : 3 : restart = 0; nqbz = 0
5328 [ + - + - ]: 3 : if (my_rank == master .and. dtset%eph_restart == 1) then
5329 [ - + ]: 3 : if (file_exists(filepath)) then
5330 [ # # ]: 0 : call wrtout(units, sjoin("- Found pre-existent GSTORE file:", trim(filepath)))
5331 : 0 : call wrtout(units, " Testing if all e-ph terms have been computed...")
5332 : : ! Use gstore_completed to understand if the previous GSTORE run completed else we need to restart.
5333 [ # # ]: 0 : NCF_CHECK(nctk_open_read(root_ncid, filepath, xmpi_comm_self))
5334 [ # # ]: 0 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_completed"), gstore_completed))
5335 : 0 : call gstore_hdr%ncread(root_ncid, gstore_fform)
5336 [ # # ]: 0 : ABI_CHECK_INEQ(gstore_fform, 0, "Wrong gstore_fform")
5337 : 0 : call gstore_hdr%vs_dtset(dtset); call gstore_hdr%free()
5338 : :
5339 [ # # ]: 0 : NCF_CHECK(nctk_get_dim(root_ncid, "gstore_nqbz", nqbz))
5340 [ # # # # : 0 : ABI_MALLOC(done_qbz_spin, (nqbz, dtset%nsppol))
# # # # #
# # # # #
# # # # ]
5341 [ # # ]: 0 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_done_qbz_spin"), done_qbz_spin))
5342 [ # # ]: 0 : NCF_CHECK(nf90_close(root_ncid))
5343 : : !print *, "done_qbz_spin:", done_qbz_spin
5344 : :
5345 : : ! FIXME: done_qbz_spin is dimensioned with the q-points in the BZ but we
5346 : : ! should set to 1 the q-points in the BZ else we never restart
5347 : : ! Perhaps can can set to -1 if q = TS q_ibz if q_ibz is done.
5348 [ # # ]: 0 : if (gstore_completed /= 0) then
5349 : : ! Previous computation completed, keep a backup of the file and start from scratch.
5350 [ # # # # ]: 0 : restart = 0; done_qbz_spin = 0
5351 : : msg = sjoin("- WARNING: Found GSTORE.nc file with all entries already computed.", ch10, &
5352 [ # # ]: 0 : "- Will overwrite:", trim(filepath), ch10, "Keeping backup copy in:", strcat(filepath, ".bkp"))
5353 : 0 : call wrtout(units, msg)
5354 [ # # ]: 0 : ABI_CHECK(clib_rename(trim(filepath), strcat(filepath, ".bkp")) == 0, "Failed to rename GSTORE file.")
5355 : : else
5356 : 0 : restart = 1
5357 : 0 : call wrtout(units, "- Restarting from a previous GSTORE.nc file")
5358 : : end if
5359 : : else
5360 [ + - ]: 3 : call wrtout(units, sjoin("- Cannot find pre-existent GSTORE file:", trim(filepath)))
5361 : : end if
5362 : : end if
5363 : :
5364 : 3 : call xmpi_bcast(restart, master, comm, ierr)
5365 : 3 : call xmpi_bcast(nqbz, master, comm, ierr)
5366 : :
5367 [ - + ]: 3 : if (my_rank /= master) then
5368 [ # # # # : 0 : ABI_MALLOC(done_qbz_spin, (nqbz, dtset%nsppol))
# # # # #
# # # # #
# # # # ]
5369 : : end if
5370 [ - + - + : 3 : if (nqbz /= 0) call xmpi_bcast(done_qbz_spin, master, comm, ierr)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - ]
5371 : : !stop
5372 : :
5373 : : contains
5374 : 0 : integer function root_vid(var_name)
5375 : : character(len=*),intent(in) :: var_name
5376 : 0 : root_vid = nctk_idname(root_ncid, var_name)
5377 : : end function root_vid
5378 : :
5379 : : end subroutine gstore_check_restart
5380 : : !!***
5381 : :
5382 : : !----------------------------------------------------------------------
5383 : :
5384 : : !!****f* m_gstore/gstore_prepare_mpiio
5385 : : !! NAME
5386 : : !! gstore_prepare_mpiio
5387 : : !!
5388 : : !! FUNCTION
5389 : : !! Access all the variables of GSTORE.nc (root group and gqk_spin groups) with all the procs that opened the file.
5390 : : !! With a file opened in parallel, netcdf reads the metadata of a variable the first time the variable is accessed
5391 : : !! and, with parallel HDF5, this read is collective. If a subset of the procs accesses a variable first
5392 : : !! (e.g. a single writer per (q, k) block), the other procs do not take part in the read and the run deadlocks
5393 : : !! or aborts with "NetCDF: Can't add HDF5 file metadata".
5394 : : !! This generalizes nctk_prepare_mpiio to all the variables of the file, so that new variables cannot be forgotten.
5395 : : !! Must be called by all the procs that opened the file, in data mode, before any access by a subset of the procs.
5396 : : !!
5397 : : !! INPUTS
5398 : : !! root_ncid=Netcdf identifier of the root group of GSTORE.nc.
5399 : : !! nsppol=Number of gqk_spin groups in the file.
5400 : : !!
5401 : : !! SOURCE
5402 : :
5403 : 8 : subroutine gstore_prepare_mpiio(root_ncid, nsppol)
5404 : :
5405 : : !Arguments ------------------------------------
5406 : : integer,intent(in) :: root_ncid, nsppol
5407 : :
5408 : : !Local variables-------------------------------
5409 : : integer :: spin, spin_ncid
5410 : : ! *************************************************************************
5411 : :
5412 : 8 : call prepare_group(root_ncid)
5413 [ + + ]: 16 : do spin=1,nsppol
5414 [ - + ]: 8 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
5415 : 16 : call prepare_group(spin_ncid)
5416 : : end do
5417 : :
5418 : : contains
5419 : :
5420 : 16 : subroutine prepare_group(ncid)
5421 : : integer,intent(in) :: ncid
5422 : : integer :: nvars, varid
5423 : : character(len=nf90_max_name) :: varname
5424 : :
5425 [ - + ]: 16 : NCF_CHECK(nf90_inquire(ncid, nVariables=nvars))
5426 [ + + ]: 979 : do varid=1,nvars
5427 [ - + ]: 979 : NCF_CHECK(nf90_inquire_variable(ncid, varid, varname))
5428 : : end do
5429 : :
5430 : 16 : end subroutine prepare_group
5431 : :
5432 : : end subroutine gstore_prepare_mpiio
5433 : : !!***
5434 : :
5435 : : !----------------------------------------------------------------------
5436 : :
5437 : : !!****f* m_gstore/gstore_print_for_abitests
5438 : : !! NAME
5439 : : !! gstore_print_for_abitests
5440 : : !!
5441 : : !! FUNCTION
5442 : : !! Print subset of results to ab_out for testing purposes.
5443 : : !! This routine should be called when the output of the GSTORE.nc file is completed
5444 : : !!
5445 : : !! INPUTS
5446 : : !! dtset<type(dataset_type)>=all input variables for this dataset
5447 : : !! [with_ks]: if True, read "gvals" as well as "gvals_ks". This options is used in GWPT
5448 : : !! in which "gvals" are the GWPT matrix elements and ""gvals_ks" are the KS ones.
5449 : : !!
5450 : : !! SOURCE
5451 : :
5452 : 8 : subroutine gstore_print_for_abitests(gstore, dtset, ebands, do_avg, with_ks)
5453 : :
5454 : : !Arguments ------------------------------------
5455 : : class(gstore_t),intent(inout) :: gstore
5456 : : type(dataset_type),intent(in) :: dtset
5457 : : type(ebands_t),intent(in) :: ebands
5458 : : logical,intent(in) :: do_avg
5459 : : logical,optional,intent(in) :: with_ks
5460 : :
5461 : : !Local variables-------------------------------
5462 : : !scalars
5463 : : integer,parameter :: master = 0
5464 : : integer :: root_ncid, spin_ncid, gstore_completed, spin, ik_glob, iq_glob, ipc, ncerr, natom3
5465 : : integer :: glob_nq, glob_nk, im_kq, in_k, m_kq, n_k, nb_k, nb_kq, ii ! ib_k,
5466 : : integer :: bstart_k, bstop_k, bstart_kq, bstop_kq, max_nk, max_nq, idir
5467 : : integer :: ik_bz, ik_ibz, ib_min_k, ib_max_k, iq_bz, ikq_ibz, ib_min_kq, ib_max_kq, nn
5468 : : logical :: with_ks__, changed_k, changed_kq, all_gs, has_iv1p_comm
5469 : : real(dp) :: gg, gg_ks, g_ratio, min_g_ratio, max_g_ratio, mean_g_ratio, stdev_g_ratio !, vnk
5470 : : character(len=abi_slen) :: gstore_gmode
5471 : : character(len=500) :: msg
5472 : : !arrays
5473 : : integer :: mapl_kq(6)
5474 : 8 : integer,allocatable :: done_qbz_spin(:,:), qglob2bz(:,:), degblock_k(:,:), degblock_kq(:,:)
5475 : : real(dp) :: kk(3), qq(3), kq(3), rtmp(2)
5476 : 8 : real(dp),allocatable :: gslice_mn(:,:,:), gslice_ks_mn(:,:,:), g2_mn(:,:), g2ks_mn(:,:), iv1p_comm(:,:,:,:,:)
5477 : : !real(dp),allocatable :: vnk_cart_ibz(:,:) !, vnk_mat_cart_ibz(:,:,:,:)
5478 : : ! *************************************************************************
5479 : :
5480 : : ! Only master prints to ab_out
5481 [ + - ]: 8 : if (xmpi_comm_rank(gstore%comm) /= master) return
5482 : :
5483 [ + + ]: 8 : with_ks__ = .False.; if (present(with_ks)) with_ks__ = with_ks
5484 [ - + ]: 8 : all_gs = .False. ; if (dtset%prtvol >= 10) all_gs = .True.
5485 : :
5486 : 8 : natom3 = dtset%natom * 3
5487 [ + + ]: 16 : max_nq = maxval(gstore%glob_nq_spin) ! Max dim over spin
5488 : : max_nk = maxval(gstore%glob_nk_spin)
5489 : :
5490 [ - + ]: 8 : NCF_CHECK(nctk_open_read(root_ncid, gstore%path, xmpi_comm_self))
5491 : :
5492 [ - + ]: 8 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_completed"), gstore_completed))
5493 : 8 : write(ab_out, *)""
5494 : 8 : write(ab_out, "(a,i0)")" gstore_completed: ", gstore_completed
5495 : :
5496 [ - + + - : 32 : ABI_MALLOC(done_qbz_spin, (gstore%nqbz, dtset%nsppol))
- + + - +
- + - - +
- + ]
5497 [ - + ]: 8 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_done_qbz_spin"), done_qbz_spin))
5498 [ + + + + : 2573 : write(ab_out, "(a,*(i0,1x))")" gstore_done_qbz_spin: ", count(done_qbz_spin == 1)
+ + ]
5499 [ - + ]: 8 : ABI_FREE(done_qbz_spin)
5500 : :
5501 [ - + + - : 997 : ABI_CALLOC(qglob2bz, (max_nq, dtset%nsppol))
- + + - +
- + - - +
- + + + +
+ ]
5502 [ - + ]: 8 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_qglob2bz"), qglob2bz))
5503 : :
5504 : : gstore_gmode = GSTORE_GMODE_ATOM
5505 : :
5506 [ + + ]: 16 : do spin=1,gstore%nsppol
5507 [ - + ]: 8 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
5508 [ - + ]: 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "glob_nq", glob_nq))
5509 [ - + ]: 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "glob_nk", glob_nk))
5510 [ - + ]: 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_k", nb_k))
5511 [ - + ]: 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_kq", nb_kq))
5512 : :
5513 : 8 : bstart_k = gstore%brange_k_spin(1, spin)
5514 : 8 : bstop_k = gstore%brange_k_spin(2, spin)
5515 : 8 : bstart_kq = gstore%brange_kq_spin(1, spin)
5516 : 8 : bstop_kq = gstore%brange_kq_spin(2, spin)
5517 : :
5518 : 8 : write(ab_out, "(a,i0)")" nb_k: ", nb_k
5519 : 8 : write(ab_out, "(a,i0)")" bstart_k: ", bstart_k
5520 : 8 : write(ab_out, "(a,i0)")" nb_kq: ", nb_kq
5521 : 8 : write(ab_out, "(a,i0)")" bstart_kq: ", bstart_kq
5522 : 8 : write(ab_out, "(a,i0)")" glob_nq: ", glob_nq
5523 : 8 : write(ab_out, "(a,i0)")" glob_nk: ", glob_nk
5524 : :
5525 : : ! Handle the output of group velocities. On disk, we have:
5526 : : !
5527 : : ! nctkarr_t("vk_cart_ibz", "dp", "three, nb_k, gstore_nkibz"))
5528 : : ! or
5529 : : ! nctkarr_t("vnk_mat_cart_ibz", "dp", "two, three, nb_k, nb_k, gstore_nkibz")))
5530 : :
5531 : 8 : select case (gstore%with_vk)
5532 : : case (0)
5533 : : continue
5534 : :
5535 : : case (1)
5536 : 0 : continue
5537 : : !write(ab_out,"(2a)") ch10," Group velocities |v_nk| in atomic units:"
5538 : :
5539 : : !ABI_MALLOC(vnk_cart_ibz, (3, nb_k))
5540 : : !do ik_ibz=1,gstore%nkibz
5541 : : ! ! Only a subset of k-points are written to ab_out.
5542 : : ! if (all(ik_ibz /= [1, 2, gstore%nkibz - 1, gstore%nkibz])) cycle
5543 : : ! 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]))
5544 : :
5545 : : ! write(ab_out, "(a)")sjoin(" For k-point:", ktoa(gstore%kibz(:,ik_ibz)), ", spin", itoa(spin))
5546 : : ! do ib_k=1,min(nb_k, 10)
5547 : : ! vnk = sqrt(norm2(vnk_cart_ibz(:,ib_k)))
5548 : : ! write(ab_out, "(a,i0,1x,es16.6)")" ib_k: ", ib_k, vnk
5549 : : ! end do
5550 : : !end do
5551 : : !ABI_FREE(vnk_cart_ibz)
5552 : : !write(ab_out, "(a)")" "
5553 : :
5554 : : case (2)
5555 [ - + ]: 8 : ABI_ERROR(" TEXT output of vkmat is not coded yet!")
5556 : : end select
5557 : :
5558 : : ! Handle the output of the e-ph matrix elements. On disk we have the global array:
5559 : : !
5560 : : ! nctkarr_t("gvals", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq")
5561 : :
5562 : : ! These e-ph matrix elements are ALWAYS in the atom representation.
5563 [ - + + - : 32 : ABI_MALLOC(gslice_mn, (2, nb_kq, nb_k))
- + + - +
- + - - +
- + - + ]
5564 [ - + + - : 24 : ABI_MALLOC(gslice_ks_mn, (2, nb_kq, nb_k))
- + + - -
+ - + -
+ ]
5565 [ - + + - : 32 : ABI_MALLOC(g2_mn, (nb_kq, nb_k))
- + + - +
- + - - +
- + ]
5566 [ - + + - : 24 : ABI_MALLOC(g2ks_mn, (nb_kq, nb_k))
- + + - -
+ - + ]
5567 : :
5568 : 8 : write(ab_out,"(a)") " E-PH matrix elements in the atom representation: pcase = (idir, iatom)"
5569 [ + - ]: 8 : if (do_avg) then
5570 : 8 : write(ab_out,"(a)") " NB: Values are averaged over e_mk+q, and e_nk degenerate states."
5571 : : else
5572 : 0 : write(ab_out,"(a)") " NB: Values are NOT averaged over e_mk+q, and e_nk degenerate states."
5573 : : end if
5574 : :
5575 [ + + ]: 8 : if (with_ks__) then
5576 : 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"
5577 : : else
5578 : 5 : write(ab_out, "(1x,5(a5,1x),a16)") "iq", "ik", "pcase", "m_kq", "n_k", "|g| in Ha"
5579 : : end if
5580 : :
5581 [ + + ]: 319 : do ik_glob=1,glob_nk
5582 : : ! Write the first and the last k-point.
5583 [ + + + + : 311 : if ((ik_glob /= 1 .and. ik_glob /= glob_nk) .and. .not. all_gs) cycle
+ - ]
5584 : :
5585 : 14 : ik_bz = gstore%kglob2bz(ik_glob, spin)
5586 : 14 : ik_ibz = gstore%kbz2ibz(1, ik_bz)
5587 : : !ik_ibz = gstore%bz2ibz(1, ik_bz); isym_k = gstore%bz2ibz(2, ik_bz)
5588 : : !trev_k = gstore%bz2ibz(6, ik_bz); g0_k = gstore%bz2ibz(3:5, ik_bz)
5589 : : !isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
5590 : :
5591 [ + + ]: 56 : kk = ebands%kptns(:,ik_ibz)
5592 : 14 : ib_min_k = bstart_k; ib_max_k = bstop_k
5593 : :
5594 : : call ebands%enclose_degbands(ik_ibz, spin, ib_min_k, ib_max_k, changed_k, dtset%symsigma_de, &
5595 [ - + ]: 14 : degblock=degblock_k)
5596 [ + + ]: 14 : if (changed_k) then
5597 : : !write(ab_out, "(a)")" Non all the degenerate bands at k were included. This should not happen!"
5598 [ + + ]: 10 : do ii=1,size(degblock_k, dim=2)
5599 : 8 : degblock_k(1, ii) = max(degblock_k(1, ii), bstart_k)
5600 : 10 : degblock_k(2, ii) = min(degblock_k(2, ii), bstop_k)
5601 : : end do
5602 : : end if
5603 : :
5604 [ + + ]: 1800 : do iq_glob=1,glob_nq
5605 : : ! Write the first and the last q-point.
5606 [ + + + + : 1786 : if ((iq_glob /= 1 .and. iq_glob /= glob_nq) .and. .not. all_gs) cycle
+ - ]
5607 : :
5608 : : ! Find k+q image in the IBZ.
5609 : 28 : iq_bz = qglob2bz(iq_glob, spin)
5610 [ + + ]: 112 : qq = gstore%qbz(:, iq_bz)
5611 [ + + ]: 112 : kq = kk + qq
5612 [ - + ]: 28 : if (kpts_map("symrel", ebands%kptopt, gstore%cryst, gstore%krank_ibz, 1, kq, mapl_kq) /= 0) then
5613 [ # # ]: 0 : write(msg, '(4a)' )"k-mesh is not closed!",ch10, "k+q could not be generated from a symmetrical one.",trim(ltoa(kq))
5614 : 0 : ABI_ERROR(msg)
5615 : : end if
5616 : 28 : ikq_ibz = mapl_kq(1)
5617 : 28 : ib_min_kq = bstart_kq; ib_max_kq = bstop_kq
5618 : :
5619 : : call ebands%enclose_degbands(ikq_ibz, spin, ib_min_kq, ib_max_kq, changed_kq, dtset%symsigma_de, &
5620 [ - + ]: 28 : degblock=degblock_kq)
5621 : :
5622 [ + + ]: 28 : if (changed_kq) then
5623 : : !write(ab_out, "(a)")" Non all the degenerate bands at k+q were included. This should not happen!"
5624 [ + + ]: 34 : do ii=1,size(degblock_kq, dim=2)
5625 : 30 : degblock_kq(1, ii) = max(degblock_kq(1, ii), bstart_kq)
5626 : 34 : degblock_kq(2, ii) = min(degblock_kq(2, ii), bstop_kq)
5627 : : end do
5628 : : end if
5629 : :
5630 [ + + ]: 196 : do ipc=1,natom3
5631 : : ! Write the 4th and the last perturbation.
5632 [ + + - + ]: 168 : if ((ipc /= 4 .and. ipc /= natom3) .and. .not. all_gs) cycle
5633 : : ! TODO: Write that pcase is filtered
5634 : : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals"), gslice_mn, &
5635 [ + + + + ]: 728 : start=[1,1,1,ipc,ik_glob,iq_glob], count=[2,nb_kq,nb_k,1,1,1])
5636 [ - + ]: 56 : NCF_CHECK(ncerr)
5637 : 56 : call average_g2_mn(do_avg, nb_kq, nb_k, bstart_kq, bstart_k, degblock_kq, degblock_k, gslice_mn, g2_mn)
5638 : :
5639 : 56 : write(ab_out, "(3(a,1x,i0,1x))")" |g(k,q)| in Ha for iq:", iq_glob, "ik:", ik_glob, "pcase:", ipc
5640 : :
5641 [ + + ]: 84 : if (.not. with_ks__) then
5642 : : ! gvals only.
5643 : 36 : write(ab_out, "(1x,5(a5,1x),a16)")"iq", "ik", "pcase", "m_kq", "n_k", "|g|"
5644 [ + + ]: 196 : do im_kq=1,nb_kq
5645 : 160 : m_kq = im_kq + bstart_kq - 1
5646 [ + + ]: 740 : do in_k=1,nb_k
5647 : 544 : n_k = in_k + bstart_k - 1
5648 : 544 : gg = sqrt(g2_mn(im_kq, in_k))
5649 : 704 : write(ab_out, "(a1,5(i5,1x),es16.6)")"-", iq_glob, ik_glob, ipc, m_kq, n_k, gg
5650 : : end do
5651 : : end do
5652 : : else
5653 : : ! GW/KS ratio, g^GW, g^KS
5654 : : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals_ks"), gslice_ks_mn, &
5655 [ + + + + ]: 260 : start=[1,1,1,ipc,ik_glob,iq_glob], count=[2,nb_kq,nb_k,1,1,1])
5656 [ - + ]: 20 : NCF_CHECK(ncerr)
5657 : 20 : call average_g2_mn(do_avg, nb_kq, nb_k, bstart_kq, bstart_k, degblock_kq, degblock_k, gslice_ks_mn, g2ks_mn)
5658 : :
5659 : 20 : write(ab_out, "(1x,5(a5,1x),3a16)")"iq", "ik", "pcase", "m_kq", "n_k", "GW/KS", "|g^GW|", "|g^KS|"
5660 : 20 : min_g_ratio = +huge(one); max_g_ratio = -huge(one); mean_g_ratio = zero; stdev_g_ratio = zero; nn = 0
5661 : :
5662 [ + + ]: 252 : do im_kq=1,nb_kq
5663 : 232 : m_kq = im_kq + bstart_kq - 1
5664 [ + + ]: 1564 : do in_k=1,nb_k
5665 : 1312 : n_k = in_k + bstart_k - 1
5666 : 1312 : gg = sqrt(g2_mn(im_kq, in_k))
5667 : 1312 : gg_ks = sqrt(g2ks_mn(im_kq, in_k))
5668 : 1312 : call safe_div(gg, gg_ks, -one, g_ratio)
5669 [ + + ]: 1312 : if (g_ratio /= -one) then
5670 : 944 : nn = nn + 1
5671 : 944 : min_g_ratio = min(g_ratio, min_g_ratio)
5672 : 944 : max_g_ratio = max(g_ratio, max_g_ratio)
5673 : 944 : mean_g_ratio = mean_g_ratio + g_ratio
5674 : 944 : stdev_g_ratio = stdev_g_ratio + g_ratio ** 2
5675 : : end if
5676 : 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
5677 : : end do
5678 : : end do
5679 : :
5680 [ + + ]: 20 : if (nn /= 0) then
5681 : 14 : mean_g_ratio = mean_g_ratio / nn
5682 : 14 : write(ab_out, "(a,es16.6)")"- mean_g_ratio:", mean_g_ratio
5683 : : ! \sigma^{2} = \langle x^{2} \rangle - \langle x \rangle^{2}
5684 : 14 : write(ab_out, "(a,es16.6)")"- stdev_g_ratio:", sqrt((stdev_g_ratio / nn) - (mean_g_ratio ** 2))
5685 : 14 : write(ab_out, "(a,es16.6)")"- min_g_ratio:", min_g_ratio
5686 : 14 : write(ab_out, "(a,es16.6)")"- max_g_ratio:", max_g_ratio
5687 : : end if
5688 : : end if
5689 : :
5690 : : end do ! ipc
5691 : :
5692 [ - + ]: 1800 : ABI_FREE(degblock_kq)
5693 : : end do ! iq_glob
5694 [ - + ]: 319 : ABI_FREE(degblock_k)
5695 : : end do ! ik_glob
5696 : :
5697 [ - + ]: 8 : ABI_FREE(gslice_mn)
5698 [ - + ]: 8 : ABI_FREE(gslice_ks_mn)
5699 [ - + ]: 8 : ABI_FREE(g2_mn)
5700 [ - + ]: 16 : ABI_FREE(g2ks_mn)
5701 : : end do ! spin
5702 : :
5703 [ - + ]: 8 : ABI_FREE(qglob2bz)
5704 : :
5705 : : ! Here we read the matrix elements of i[V1, p] if present on disk.
5706 : 8 : has_iv1p_comm = gstore_nc_has_iv1p_comm(gstore, root_ncid)
5707 : :
5708 [ - + ]: 8 : if (has_iv1p_comm) then
5709 [ # # ]: 0 : do spin=1,gstore%nsppol
5710 [ # # ]: 0 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
5711 [ # # ]: 0 : NCF_CHECK(nctk_get_dim(spin_ncid, "glob_nk", glob_nk))
5712 [ # # ]: 0 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_k", nb_k))
5713 : :
5714 : 0 : bstart_k = gstore%brange_k_spin(1, spin)
5715 : 0 : bstop_k = gstore%brange_k_spin(2, spin)
5716 : :
5717 [ # # # # : 0 : ABI_CALLOC(iv1p_comm, (2, nb_k, nb_k, 3, natom3))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # #
# ]
5718 : :
5719 [ # # ]: 0 : do ik_glob=1,glob_nk
5720 : : ! Write the first and the last k-point.
5721 [ # # # # : 0 : if ((ik_glob /= 1 .and. ik_glob /= glob_nk) .and. .not. all_gs) cycle
# # ]
5722 : :
5723 : : !ik_bz = gstore%kglob2bz(ik_glob, spin)
5724 : : !ik_ibz = gstore%kbz2ibz(1, ik_bz)
5725 : : !kk_ibz = ebands%kptns(:,ik_ibz)
5726 : :
5727 : : ! nctkarr_t("iv1p_comm", "dp", "two, nb_k, nb_k, three, natom3, glob_nk")
5728 : : ncerr = nf90_get_var(spin_ncid, spin_vid("iv1p_comm"), iv1p_comm, &
5729 [ # # # # ]: 0 : start=[1,1,1,1,1,ik_glob], count=[2,nb_k,nb_k,3,natom3,1])
5730 [ # # ]: 0 : NCF_CHECK(ncerr)
5731 : :
5732 : : ! Only n_nk states are included in the matrix.
5733 : 0 : write(ab_out, "(1x,5(a5,1x),a16)")"ik", "pcase", "m_k", "n_k", "idir", "i[V1,p]"
5734 [ # # ]: 0 : do im_kq=1,nb_k
5735 : 0 : m_kq = im_kq + bstart_k - 1
5736 [ # # ]: 0 : do in_k=1,nb_k
5737 : 0 : n_k = in_k + bstart_k - 1
5738 [ # # ]: 0 : do ipc=1,natom3
5739 [ # # # # : 0 : if ((ipc /= 4 .and. ipc /= natom3) .and. .not. all_gs) cycle
# # ]
5740 [ # # ]: 0 : do idir=1,3
5741 [ # # ]: 0 : rtmp = iv1p_comm(:, im_kq, in_k, idir, ipc)
5742 : 0 : write(ab_out, "(a1,5(i5,1x),2es16.6)") "-", ik_glob, ipc, m_kq, n_k, idir, rtmp(1), rtmp(2)
5743 : : end do ! idir
5744 : : end do ! ipc
5745 : : end do ! in_k
5746 : : end do ! im_kq
5747 : :
5748 : : end do ! ik_glob
5749 : :
5750 [ # # ]: 0 : ABI_FREE(iv1p_comm)
5751 : : end do ! spin
5752 : : end if
5753 : :
5754 [ - + - + : 16 : NCF_CHECK(nf90_close(root_ncid))
- + - + -
+ - + - +
- + ]
5755 : :
5756 : : contains
5757 : 24 : integer function root_vid(var_name)
5758 : : character(len=*),intent(in) :: var_name
5759 : 24 : root_vid = nctk_idname(root_ncid, var_name)
5760 : : end function root_vid
5761 : :
5762 : 76 : integer function spin_vid(var_name)
5763 : : character(len=*),intent(in) :: var_name
5764 : 76 : spin_vid = nctk_idname(spin_ncid, var_name)
5765 : : end function spin_vid
5766 : :
5767 : : end subroutine gstore_print_for_abitests
5768 : : !!***
5769 : :
5770 [ - + - + ]: 76 : subroutine average_g2_mn(do_avg, nb_kq, nb_k, bstart_kq, bstart_k, degblock_kq, degblock_k, g_mn, g2_mn)
5771 : :
5772 : : !Arguments ------------------------------------
5773 : : logical,intent(in) :: do_avg
5774 : : integer,intent(in) :: nb_kq, nb_k, bstart_kq, bstart_k
5775 : : integer,intent(in) :: degblock_kq(:,:), degblock_k(:,:)
5776 : : real(dp),intent(in) :: g_mn(2, nb_kq, nb_k)
5777 : : real(dp),intent(out) :: g2_mn(nb_kq, nb_k)
5778 : :
5779 : : !Local variables-------------------------------
5780 : : integer :: im_group, in_group, count, m_kq, im_kq, n_k, in_k
5781 : : real(dp) :: g2_avg
5782 : : !----------------------------------------------------------------------
5783 : :
5784 [ - + ]: 76 : if (do_avg) then
5785 : : ! Average over electronic degenerate states at k and k+q
5786 [ + + + + ]: 3564 : g2_mn = -one
5787 [ + + ]: 460 : do im_group = 1, size(degblock_kq, dim=2)
5788 [ + + ]: 1414 : do in_group = 1, size(degblock_k, dim=2)
5789 : 954 : g2_avg = zero; count = 0
5790 [ + + ]: 2542 : do m_kq = degblock_kq(1, im_group), degblock_kq(2, im_group)
5791 : 1588 : im_kq = m_kq - bstart_kq + 1
5792 [ + + ]: 5710 : do n_k = degblock_k(1, in_group), degblock_k(2, in_group)
5793 : 3168 : in_k = n_k - bstart_k + 1
5794 : 3168 : g2_avg = g2_avg + g_mn(1, im_kq, in_k)**2 + g_mn(2, im_kq, in_k)**2
5795 : 4756 : count = count + 1
5796 : : end do
5797 : : end do
5798 : 954 : g2_avg = g2_avg / count
5799 : :
5800 : : ! Loop again over degenerate bands and copy average.
5801 [ + + ]: 2926 : do m_kq = degblock_kq(1, im_group), degblock_kq(2, im_group)
5802 : 1588 : im_kq = m_kq - bstart_kq + 1
5803 [ + + ]: 5710 : do n_k = degblock_k(1, in_group), degblock_k(2, in_group)
5804 : 3168 : in_k = n_k - bstart_k + 1
5805 : 4756 : g2_mn(im_kq, in_k) = g2_avg
5806 : : end do
5807 : : end do
5808 : :
5809 : : end do ! in_group
5810 : : end do ! im_group
5811 : :
5812 : : else
5813 : : ! No average here.
5814 [ # # ]: 0 : do im_kq=1, nb_kq
5815 [ # # ]: 0 : do in_k=1, nb_k
5816 : 0 : g2_mn(im_kq, in_k) = g_mn(1, im_kq, in_k)**2 + g_mn(2, im_kq, in_k)**2
5817 : : end do
5818 : : end do
5819 : : end if
5820 : :
5821 : 76 : end subroutine average_g2_mn
5822 : : !!***
5823 : :
5824 : : !----------------------------------------------------------------------
5825 : :
5826 : : !!****f* m_gstore/gqk_gather
5827 : : !! NAME
5828 : : !! gqk_gather
5829 : : !!
5830 : : !! FUNCTION
5831 : : !! Gather the MPI-distributed matrix elements for a given k/q-point index.
5832 : : !! Once one reciprocal dimension is fixed, the gathering is performed across the other one.
5833 : : !!
5834 : : !! INPUTS
5835 : : !! mode = String controlling the choice of the fixed dimension ("k" or "q")
5836 : : !! fixed_pt = Index of the fixed k/q-point
5837 : : !!
5838 : : !! OUTPUT
5839 : : !! g_gathered(:,:,:,:) = Matrix elements for the given k/q-point, ordered as
5840 : : !! (my_npert, nb, nb, glob_nq) - k-point is fixed
5841 : : !! (my_npert, nb, nb, glob_nk) - q-point is fixed
5842 : : !!
5843 : : !! SOURCE
5844 : :
5845 : 555656 : subroutine gqk_gather(gqk, mode, fixed_pt, g_gathered)
5846 : :
5847 : : !Arguments ------------------------------------
5848 : : !scalars
5849 : : class(gqk_t), target, intent(in) :: gqk
5850 : : character(len=*),intent(in) :: mode
5851 : : integer,intent(in) :: fixed_pt
5852 : : !arrays
5853 : : complex(dp), allocatable, intent(out) :: g_gathered(:,:,:,:)
5854 : :
5855 : : !Local variables-------------------------------
5856 : : !scalars
5857 : : integer :: comm, ierr, ipt_glob, ngather, my_ipt, my_ngather, my_ptstart, my_pert, ib, jb
5858 : : !arrays
5859 : 277828 : complex(dp), pointer :: my_g(:,:,:,:)
5860 : : !----------------------------------------------------------------------
5861 : :
5862 : 0 : ABI_CHECK_IEQ(gqk%nb_kq, gqk%nb_k, "nb_kq != nb_k not tested")
5863 : :
5864 : 0 : select case (mode)
5865 : : case ("k")
5866 : 0 : comm = gqk%qpt_comm%value
5867 : 0 : ngather = gqk%glob_nq
5868 : 0 : my_ngather = gqk%my_nq
5869 : 0 : my_ptstart = gqk%my_qstart
5870 : 0 : my_g => gqk%my_g(:,:,:,:,fixed_pt)
5871 [ # # # # : 0 : ABI_CALLOC(g_gathered, (gqk%my_npert, gqk%nb_kq, gqk%nb_k, ngather))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # #
# ]
5872 : :
5873 : : case ("q")
5874 : 277828 : comm = gqk%kpt_comm%value
5875 : 277828 : ngather = gqk%glob_nk
5876 : 277828 : my_ngather = gqk%my_nk
5877 : 277828 : my_ptstart = gqk%my_kstart
5878 : 277828 : my_g => gqk%my_g(:,:,fixed_pt,:,:)
5879 [ - + + - : 2150164396 : ABI_CALLOC(g_gathered, (gqk%my_npert, gqk%nb_k, gqk%nb_kq, ngather))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + + + +
+ + + +
+ ]
5880 : :
5881 : : case default
5882 [ - + - ]: 277828 : ABI_ERROR(sjoin("Gathering MPI-distributed matrix elements, unsupported mode: ", mode))
5883 : : end select
5884 : :
5885 [ + + ]: 33678830 : do my_ipt=1,my_ngather
5886 : 33401002 : ipt_glob = my_ipt + my_ptstart - 1
5887 : :
5888 : : ! FIXME: can the rearrangement be done in the select case statement?
5889 [ + + ]: 130800122 : do ib=1,gqk%nb_k
5890 [ + + ]: 418804456 : do jb=1,gqk%nb_kq
5891 [ + + ]: 2115096426 : do my_pert=1,gqk%my_npert
5892 [ - + ]: 2017975134 : if (mode == "k") then
5893 : 0 : g_gathered(my_pert, jb, ib, ipt_glob) = my_g(my_pert, jb, my_ipt, ib)
5894 : : else
5895 : 1729692972 : g_gathered(my_pert, jb, ib, ipt_glob) = my_g(my_pert, jb, ib, my_ipt)
5896 : : endif
5897 : : enddo
5898 : : enddo
5899 : : enddo
5900 : : enddo
5901 : :
5902 : 277828 : call xmpi_sum(g_gathered, comm, ierr)
5903 : :
5904 [ - + ]: 277828 : end subroutine gqk_gather
5905 : : !!***
5906 : :
5907 : : !----------------------------------------------------------------------
5908 : :
5909 : : !!****f* m_gstore/gstore_wannierize_and_write_gwan
5910 : : !! NAME
5911 : : !! gstore_wannierize_and_write_gwan
5912 : : !!
5913 : : !! FUNCTION
5914 : : !! Compute g(R_e,R_ph) from g(k,q). Save results to GWAN.nc file
5915 : : !!
5916 : : !! INPUTS
5917 : : !!
5918 : : !! SOURCE
5919 : :
5920 : 0 : subroutine gstore_wannierize_and_write_gwan(gstore, dvdb, dtfil)
5921 : :
5922 : : !Arguments ------------------------------------
5923 : : class(gstore_t),target, intent(in) :: gstore
5924 : : type(dvdb_t),intent(in) :: dvdb
5925 : : type(datafiles_type),intent(in) :: dtfil
5926 : :
5927 : : !Local variables-------------------------------
5928 : : !scalars
5929 : : integer,parameter :: master = 0
5930 : : integer,parameter :: wan_ntest = 4
5931 : : integer,parameter :: wan_nperiod = 3
5932 : : real(dp),parameter :: WAN_CLOSURE_TOL = tol8
5933 : : real(dp),parameter :: WAN_VELOCITY_FD_STEP = 1.0d-5
5934 : : real(dp),parameter :: WAN_VELOCITY_DEGEN_TOL = 1.0d-5
5935 : : real(dp),parameter :: WAN_VELOCITY_TOL = tol6
5936 : : integer :: nr_e, nr_p, nwan, iwan, jwan, spin, my_is, my_ip, ir, irp, my_ik, my_iq, nb_k, nb_kq
5937 : : integer :: my_nk, my_nq, ierr, ik, ikq, my_npert, nwin_k, nwin_kq, ii, jj, band_kq, band_k, ib_k, ib_kq
5938 : : integer :: itest, ip_loc, ik_glob, iq_glob, ntest_found, iperiod, idir, ib, nvelocity_tested
5939 : : real(dp) :: max_err, ref_scale, max_period_eig_err, period_eig_scale, max_period_g2_err, period_g2_scale
5940 : : real(dp) :: max_velocity_err, velocity_scale, band_gap, velocity_fd
5941 : : character(len=500) :: msg
5942 : : logical :: keep_umats, test_found(wan_ntest)
5943 : : type(wan_t),pointer :: wan
5944 : : type(gqk_t),pointer :: gqk
5945 : : !arrays
5946 : : integer :: qptrlatt_(3,3), units(2)
5947 : : integer :: test_ik(wan_ntest), test_iq(wan_ntest)
5948 : : integer :: period_gk(3,wan_nperiod), period_gq(3,wan_nperiod)
5949 : : real(dp) :: weight_qq, qpt(3), kpt(3), kq(3), dkred(3), cpu, wall, gflops
5950 : 0 : real(dp),allocatable :: eigens_k_test(:), eigens_kq_test(:), eigens_k_period(:), eigens_kq_period(:)
5951 : 0 : real(dp),allocatable :: eigens_k_plus(:), eigens_k_minus(:), vcart_test(:,:)
5952 : 0 : complex(dp),allocatable :: emikr(:), emiqr(:), u_k(:,:), u_kq(:,:), gww_epq(:,:,:,:,:), gww_pk(:,:,:,:), g_bb(:,:), tmp_mat(:,:)
5953 : 0 : complex(dp),allocatable :: test_gref(:,:,:,:), u_k_test(:,:), u_kq_test(:,:), cmat_test(:,:), g_expected(:,:)
5954 : 0 : complex(dp),allocatable :: g_atm_test(:,:,:,:), g_atm_period(:,:,:,:)
5955 : : ! *************************************************************************
5956 : :
5957 [ # # ]: 0 : units = [std_out, ab_out]
5958 : 0 : period_gk = reshape([1,0,0, 0,0,0, -1,1,0], shape(period_gk))
5959 : 0 : period_gq = reshape([0,0,0, 0,1,0, 0,0,1], shape(period_gq))
5960 : 0 : call wrtout(units, " Computing g(R_e,R_ph) in the Wannier representation...", pre_newlines=1)
5961 : 0 : call cwtime(cpu, wall, gflops, "start")
5962 : :
5963 [ # # ]: 0 : if (gstore%check_cplex_qkzone_gmode(2, "bz", "bz", "atom", kfilter="none") /= 0) then
5964 : 0 : ABI_ERROR("The gstore object is inconsistent with gstore_wannierize_and_write_gwan. See messages above.")
5965 : : end if
5966 : :
5967 : : ! TODO: Handle long-range part.
5968 [ # # # # ]: 0 : if (dvdb%has_zeff .or. dvdb%has_quadrupoles) then
5969 : 0 : ABI_WARNING("Treatment of long-range part not yet coded in gstore_wannierize_and_write_gwan!")
5970 : : end if
5971 : :
5972 [ # # ]: 0 : do my_is=1,gstore%my_nspins
5973 : 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
5974 : 0 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
5975 : :
5976 : : ! Initialize gkq%wan from ABIWAN.nc for this spin.
5977 : 0 : keep_umats = .False.
5978 : 0 : call gqk%wan%from_abiwan(dtfil%filabiwanin, spin, gstore%nsppol, keep_umats, dtfil%filnam_ds(4), gqk%comm%value)
5979 : 0 : wan => gqk%wan
5980 : :
5981 : : ! Compute Wigner-Seitz lattice vectors and llocate grpe_wwp with shape: (nr_p, nr_e, nwan, nwan, my_npert).
5982 : 0 : call kptrlatt_from_ngkpt(gstore%ngqpt, qptrlatt_)
5983 : : call wan%setup_eph_ws_kq(gstore%cryst, gstore%ebands%shiftk(:,1), gstore%ebands%kptrlatt, qptrlatt_, &
5984 : 0 : gqk%my_pert_start, my_npert, gqk%pert_comm)
5985 : :
5986 : 0 : nr_p = wan%nr_p; nr_e = wan%nr_e; nwan = wan%nwan
5987 : : !if (gqk%comm%me == master) call wan%print(units)
5988 : :
5989 : : ! Cache the pre-FT ground truth at four fixed GLOBAL coarse-mesh points. Using
5990 : : ! local first/last indices would make the test points depend on the MPI grid.
5991 [ # # ]: 0 : test_ik = [1, gqk%glob_nk, 1, gqk%glob_nk]
5992 [ # # ]: 0 : test_iq = [1, 1, gqk%glob_nq, gqk%glob_nq]
5993 : 0 : test_found = .False.
5994 [ # # # # : 0 : ABI_CALLOC(test_gref, (nwan, nwan, my_npert, wan_ntest))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
5995 : :
5996 [ # # # # : 0 : ABI_MALLOC(emikr, (nr_e))
# # # # #
# # # ]
5997 [ # # # # : 0 : ABI_MALLOC(emiqr, (nr_p))
# # # # #
# # # ]
5998 [ # # # # : 0 : ABI_MALLOC(gww_pk, (nwan, nwan, my_npert, my_nk))
# # # # #
# # # # #
# # # # #
# # # #
# ]
5999 : : ! Intermediate buffer to store the sum over k-points. Note my_nq.
6000 [ # # # # : 0 : ABI_CALLOC(gww_epq, (nwan, nwan, nr_e, my_npert, my_nq))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
6001 : :
6002 : : ! Loop over my q-points (partial sum over q).
6003 [ # # ]: 0 : do my_iq=1,my_nq
6004 : 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qpt)
6005 : :
6006 : : !call get_kg(qpt, 1, ecut_lr, gstore%cryst%gmet, ng_q, gvec_q)
6007 : : !ABI_FREE(gvec_q)
6008 : :
6009 : : ! Loop over my k-points (partial sum over k).
6010 [ # # ]: 0 : do my_ik=1,my_nk
6011 [ # # # # ]: 0 : kpt = gqk%my_kpts(:,my_ik); kq = kpt + qpt
6012 : 0 : ik = wan%krank%get_index(kpt); ikq = wan%krank%get_index(kq)
6013 [ # # ]: 0 : ABI_CHECK(ik /= -1, sjoin("Cannot find kpt: ", ktoa(kpt)))
6014 [ # # ]: 0 : ABI_CHECK(ikq /= -1, sjoin("Cannot find k+q: ", ktoa(kq)))
6015 : :
6016 : : ! Get rotation matrices at k and k+q.
6017 : 0 : nwin_k = wan%dimwin(ik); nwin_kq = wan%dimwin(ikq)
6018 [ # # # # : 0 : ABI_MALLOC(g_bb, (nwin_kq, nwin_k))
# # # # #
# # # # #
# # ]
6019 [ # # # # : 0 : ABI_MALLOC(u_k, (1:nwin_k, 1:nwan))
# # # # #
# # # # #
# # ]
6020 [ # # # # : 0 : ABI_MALLOC(u_kq, (1:nwin_kq, 1:nwan))
# # # # #
# # # # #
# # ]
6021 [ # # # # : 0 : ABI_MALLOC(tmp_mat, (nwin_kq, nwan))
# # # # #
# # # # #
# # ]
6022 : :
6023 [ # # # # : 0 : u_k = wan%u_k(1:nwin_k, 1:nwan, ik)
# # ]
6024 [ # # # # : 0 : u_kq = wan%u_k(1:nwin_kq, 1:nwan, ikq)
# # ]
6025 : :
6026 [ # # ]: 0 : do my_ip=1,gqk%my_npert
6027 : : !----------------------------------------------------------
6028 : : ! STEP 1: rotation to optimally smooth Bloch states
6029 : : !----------------------------------------------------------
6030 : : ! [Eqn. 24 of PRB 76, 165108 (2007)]
6031 : : ! g~(k,q) = U(k+q)^\dagger * g(k,q) * U(k)
6032 : :
6033 : : ! gqk%nb = wan%bmax - wan%bmin + 1
6034 : : ! (my_npert, nb, my_nq, nb, my_nk)
6035 : : ! ( p, b1_kq, q, b2_k, k) --> <k+q, b1| D_{q,p}H |k, b2>
6036 : :
6037 : : ! Extract e-ph matrix elements from my_g buffer to align bands with the U matrices at k and k+q.
6038 : : jj = 0
6039 [ # # ]: 0 : do ib_k=1,nb_k
6040 [ # # ]: 0 : band_k = ib_k - wan%bmin + 1; if (.not. wan%lwindow(band_k, ik)) cycle
6041 : 0 : jj = jj + 1; ii = 0
6042 [ # # ]: 0 : do ib_kq=1,nb_kq
6043 [ # # ]: 0 : band_kq = ib_kq - wan%bmin + 1; if (.not. wan%lwindow(band_kq, ikq)) cycle
6044 : 0 : ii = ii + 1
6045 : 0 : g_bb(ii, jj) = gqk%my_g(my_ip, ib_kq, my_iq, ib_k, my_ik)
6046 : : end do
6047 : : end do
6048 : :
6049 : : ! TODO: Remove LR part.
6050 : : !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)
6051 : :
6052 : : ! the two zgemm calls perform: epmats = [ cu(ikq)^\dagger * epmatk ] * cu(ikk)
6053 : : ! [here we have a size-reduction from nbnd*nbnd to nwan*nwan]
6054 : : ! output stored in gww_pk(:,:, my_ip, my_ik)
6055 : :
6056 : : ! gww_pk(:,:, my_ip, my_ik) = MATMUL(CONJG(TRANSPOSE(u_kq)), MATMUL(g_bb, u_k))
6057 : : ! tmp_mat (nwin_kq x nwan) = g_bb (nwin_kq x nwin_k) . u_k (nwin_k x nwan)
6058 : 0 : call ZGEMM('N', 'N', nwin_kq, nwan, nwin_k, cone, g_bb, nwin_kq, u_k, nwin_k, czero, tmp_mat, nwin_kq)
6059 : : ! gww_pk (nwan x nwan) = u_kq^dagger (nwan x nwin_kq) . tmp_mat (nwin_kq x nwan)
6060 : 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)
6061 : :
6062 : : !call ZGEMM('C', 'N', nwan, nbnd, nbnd, cone, u_kq, nbnd, epmatk(:, :, ik, imode), nbnd, czero, eptmp, nwan)
6063 : : !call ZGEMM('N', 'N', nwan, nwan, nbnd, cone, eptmp, nwan, u_k, nbnd, czero, epmats(:, :, ik, imode), nwan)
6064 : : end do ! my_ip
6065 : :
6066 : : ! Cache gww_pk(:,:,:,my_ik) for the on-mesh closure self-check below, while it is still
6067 : : ! valid for THIS my_iq (it gets overwritten by the next my_iq iteration).
6068 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
6069 : 0 : iq_glob = my_iq + gqk%my_qstart - 1
6070 [ # # ]: 0 : do itest=1,wan_ntest
6071 [ # # # # ]: 0 : if (test_ik(itest) == ik_glob .and. test_iq(itest) == iq_glob) then
6072 [ # # # # : 0 : test_gref(:,:,:,itest) = gww_pk(:,:,:,my_ik)
# # ]
6073 : 0 : test_found(itest) = .True.
6074 : : end if
6075 : : end do
6076 : :
6077 [ # # ]: 0 : ABI_FREE(g_bb)
6078 [ # # ]: 0 : ABI_FREE(tmp_mat)
6079 : :
6080 : : !----------------------------------------------------------------------
6081 : : ! STEP 3: Fourier transform to obtain matrix elements in electron wannier basis
6082 : : !----------------------------------------------------------------------
6083 : : ! [Eqn. 24 of PRB 76, 165108 (2007)]
6084 : : ! g(R_e,q) = (1/nkc) sum_k e^{-ikR_e} g~(k,q)
6085 : : ! g(R_e,q) is epmatw (nwan,nwan,ir)
6086 : :
6087 [ # # ]: 0 : do ir=1,nr_e
6088 [ # # ]: 0 : emikr(ir) = exp(-j_dpc * two_pi * dot_product(kpt, wan%r_e(:, ir))) / dble(gstore%nkbz)
6089 : : end do
6090 : : ! gww_pk(nwan, nwan, my_npert,my_nk)
6091 [ # # ]: 0 : do my_ip=1,gqk%my_npert
6092 [ # # ]: 0 : do ir=1,nr_e
6093 [ # # # # ]: 0 : gww_epq(:,:,ir, my_ip, my_iq) = gww_epq(:,:,ir, my_ip, my_iq) + emikr(ir) * gww_pk(:,:,my_ip, my_ik)
6094 : : end do
6095 : : end do
6096 : :
6097 [ # # ]: 0 : ABI_FREE(u_k)
6098 [ # # ]: 0 : ABI_FREE(u_kq)
6099 : : end do ! my_ik
6100 : : end do ! my_iq
6101 : :
6102 : 0 : call xmpi_sum(gww_epq, gqk%kpt_comm%value, ierr)
6103 : :
6104 : : !------------------------------------------
6105 : : ! Fourier transform to go to Wannier basis
6106 : : !------------------------------------------
6107 : : ! [Eqn. 24 of PRB 76, 165108 (2007)]
6108 : : ! g(R_e,R_p) = (1/nq) sum_q e^{-iqR_p} g(R_e,q)
6109 : :
6110 : : ! Loop over my q-points (partial sum over q).
6111 [ # # ]: 0 : do my_iq=1,my_nq
6112 : 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qpt)
6113 [ # # ]: 0 : do irp=1,nr_p
6114 [ # # ]: 0 : emiqr(irp) = exp(-j_dpc * two_pi * dot_product(qpt, wan%r_p(:, irp))) / dble(gstore%nqbz)
6115 : : end do
6116 : :
6117 [ # # ]: 0 : do my_ip=1,my_npert
6118 [ # # ]: 0 : do jwan=1,nwan
6119 [ # # ]: 0 : do iwan=1,nwan
6120 [ # # ]: 0 : do ir=1,nr_e
6121 : : ! 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}
6122 : : wan%grpe_wwp(:, ir, iwan, jwan, my_ip) = wan%grpe_wwp(:, ir, iwan, jwan, my_ip) + &
6123 [ # # ]: 0 : gww_epq(iwan, jwan, ir, my_ip, my_iq) * emiqr(:)
6124 : : end do
6125 : : end do
6126 : : end do
6127 : : end do ! my_ip
6128 : : end do ! my_iq
6129 : :
6130 : 0 : call xmpi_sum(wan%grpe_wwp, gqk%qpt_kpt_comm%value, ierr)
6131 : :
6132 [ # # ]: 0 : if (gqk%comm%me == master) then
6133 : 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] '
6134 [ # # ]: 0 : do ir=1,nr_e
6135 [ # # # # : 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,:,:,:))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
6136 : : end do
6137 : : end if
6138 : :
6139 : : !--------------------------------------------------------------------------------
6140 : : ! Wannier on-mesh closure self-check: interpolating g(k,q) back at a handful of
6141 : : ! the SAME coarse (k,q) points used to build wan%grpe_wwp must reproduce the pre-FT
6142 : : ! gww_pk cached above, once rotated by the SAME wan%interp_ham-derived u_k/u_kq
6143 : : ! (interp_ham's gauge is generically different from the ABIWAN gauge used for gww_pk,
6144 : : ! even on-mesh, so we apply the identical rotation to both sides rather than comparing
6145 : : ! against raw gww_pk). This isolates the WS/ndegen bookkeeping and forward/backward FT
6146 : : ! consistency. Cheap (wan_ntest points only) and deterministic: a hard ABI_CHECK, not a
6147 : : ! Refs-compared print, since it is a precision-only mathematical identity.
6148 : : !--------------------------------------------------------------------------------
6149 [ # # # # : 0 : ABI_MALLOC(u_k_test, (nwan,nwan))
# # # # #
# # # # #
# # ]
6150 [ # # # # : 0 : ABI_MALLOC(u_kq_test, (nwan,nwan))
# # # # #
# # # ]
6151 [ # # # # : 0 : ABI_MALLOC(eigens_k_test, (nwan))
# # # # #
# # # ]
6152 [ # # # # : 0 : ABI_MALLOC(eigens_kq_test, (nwan))
# # # # ]
6153 [ # # # # : 0 : ABI_MALLOC(eigens_k_period, (nwan))
# # # # ]
6154 [ # # # # : 0 : ABI_MALLOC(eigens_kq_period, (nwan))
# # # # ]
6155 [ # # # # : 0 : ABI_MALLOC(eigens_k_plus, (nwan))
# # # # ]
6156 [ # # # # : 0 : ABI_MALLOC(eigens_k_minus, (nwan))
# # # # ]
6157 [ # # # # : 0 : ABI_MALLOC(vcart_test, (3,nwan))
# # # # #
# # # ]
6158 [ # # # # : 0 : ABI_MALLOC(cmat_test, (nwan,nwan))
# # # # #
# # # ]
6159 [ # # # # : 0 : ABI_MALLOC(g_expected, (nwan,nwan))
# # # # #
# # # ]
6160 [ # # # # : 0 : ABI_MALLOC(g_atm_test, (nwan, nwan, my_npert, 1))
# # # # #
# # # # #
# # # # #
# ]
6161 [ # # # # : 0 : ABI_MALLOC(g_atm_period, (nwan, nwan, my_npert, 1))
# # # # #
# # # # #
# # ]
6162 : :
6163 : 0 : max_err = zero; ref_scale = zero
6164 : 0 : max_period_eig_err = zero; period_eig_scale = zero
6165 : 0 : max_period_g2_err = zero; period_g2_scale = zero
6166 : 0 : max_velocity_err = zero; velocity_scale = zero; nvelocity_tested = 0
6167 [ # # ]: 0 : do itest=1,wan_ntest
6168 [ # # ]: 0 : if (.not. test_found(itest)) cycle
6169 : 0 : my_ik = test_ik(itest) - gqk%my_kstart + 1
6170 : 0 : my_iq = test_iq(itest) - gqk%my_qstart + 1
6171 [ # # ]: 0 : kpt = gqk%my_kpts(:,my_ik)
6172 : 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qpt)
6173 : 0 : call wan%interp_ham(gstore%cryst, kpt, u_k_test, eigens_k_test, vcart_test)
6174 [ # # ]: 0 : call wan%interp_ham(gstore%cryst, kpt + qpt, u_kq_test, eigens_kq_test)
6175 : 0 : call wan%interp_eph_manyq(gstore%cryst, 1, qpt, kpt, g_atm_test)
6176 [ # # # # : 0 : ref_scale = max(ref_scale, maxval(abs(test_gref(:,:,:,itest))))
# # # # #
# # # #
# ]
6177 [ # # ]: 0 : do ip_loc=1,my_npert
6178 : : ! Same order/dagger convention as wan_interp_eph_manyq (m_mlwfovlp.F90).
6179 : 0 : call ZGEMM('N', 'N', nwan, nwan, nwan, cone, u_kq_test, nwan, test_gref(:,:,ip_loc,itest), nwan, czero, cmat_test, nwan)
6180 : 0 : call ZGEMM('N', 'C', nwan, nwan, nwan, cone, cmat_test, nwan, u_k_test, nwan, czero, g_expected, nwan)
6181 [ # # # # : 0 : max_err = max(max_err, maxval(abs(g_expected - g_atm_test(:,:,ip_loc,1))))
# # # # #
# # # ]
6182 : : end do
6183 : :
6184 : : ! Validate analytic Cartesian group velocities against centered finite
6185 : : ! differences of the interpolated eigenvalues. Skip degenerate bands,
6186 : : ! whose individual diagonal velocities depend on the chosen subspace basis.
6187 : : ! These calls intentionally follow the closure comparison because the
6188 : : ! finite-difference diagonalizations reuse the u_kq_test work buffer.
6189 [ # # ]: 0 : do idir=1,3
6190 [ # # ]: 0 : dkred = WAN_VELOCITY_FD_STEP * gstore%cryst%rprimd(idir,:) / two_pi
6191 [ # # ]: 0 : call wan%interp_ham(gstore%cryst, kpt + dkred, u_kq_test, eigens_k_plus)
6192 [ # # ]: 0 : call wan%interp_ham(gstore%cryst, kpt - dkred, u_kq_test, eigens_k_minus)
6193 [ # # ]: 0 : do ib=1,nwan
6194 : 0 : band_gap = huge(one)
6195 [ # # ]: 0 : if (ib > 1) band_gap = min(band_gap, abs(eigens_k_test(ib) - eigens_k_test(ib-1)))
6196 [ # # ]: 0 : if (ib < nwan) band_gap = min(band_gap, abs(eigens_k_test(ib+1) - eigens_k_test(ib)))
6197 [ # # ]: 0 : if (band_gap < WAN_VELOCITY_DEGEN_TOL) cycle
6198 : 0 : velocity_fd = (eigens_k_plus(ib) - eigens_k_minus(ib)) / (two * WAN_VELOCITY_FD_STEP)
6199 : 0 : max_velocity_err = max(max_velocity_err, abs(vcart_test(idir,ib) - velocity_fd))
6200 : 0 : velocity_scale = max(velocity_scale, abs(vcart_test(idir,ib)), abs(velocity_fd))
6201 : 0 : nvelocity_tested = nvelocity_tested + 1
6202 : : end do
6203 : : end do
6204 : :
6205 : : ! Reciprocal-periodicity self-check. Integer shifts leave the real-space
6206 : : ! Fourier sums invariant. Compare eigenvalues and per-perturbation
6207 : : ! Frobenius norms, which remain well defined even if a tiny roundoff
6208 : : ! difference rotates eigenvectors inside a degenerate subspace.
6209 [ # # # # : 0 : period_eig_scale = max(period_eig_scale, maxval(abs(eigens_k_test)), maxval(abs(eigens_kq_test)))
# # # # #
# # # # #
# # ]
6210 [ # # ]: 0 : do ip_loc=1,my_npert
6211 [ # # # # ]: 0 : period_g2_scale = max(period_g2_scale, sum(abs(g_atm_test(:,:,ip_loc,1))**2))
6212 : : end do
6213 [ # # ]: 0 : do iperiod=1,wan_nperiod
6214 [ # # ]: 0 : call wan%interp_ham(gstore%cryst, kpt + period_gk(:,iperiod), u_k_test, eigens_k_period)
6215 : : call wan%interp_ham(gstore%cryst, kpt + qpt + period_gk(:,iperiod) + period_gq(:,iperiod), &
6216 [ # # ]: 0 : u_kq_test, eigens_kq_period)
6217 : : call wan%interp_eph_manyq(gstore%cryst, 1, qpt + period_gq(:,iperiod), &
6218 [ # # # # ]: 0 : kpt + period_gk(:,iperiod), g_atm_period)
6219 : : max_period_eig_err = max(max_period_eig_err, maxval(abs(eigens_k_period - eigens_k_test)), &
6220 [ # # # # : 0 : maxval(abs(eigens_kq_period - eigens_kq_test)))
# # # # #
# # # # #
# # ]
6221 [ # # ]: 0 : do ip_loc=1,my_npert
6222 : : max_period_g2_err = max(max_period_g2_err, abs( &
6223 [ # # # # : 0 : sum(abs(g_atm_period(:,:,ip_loc,1))**2) - sum(abs(g_atm_test(:,:,ip_loc,1))**2)))
# # # # ]
6224 : : end do
6225 : : end do
6226 : : end do
6227 : :
6228 : : ! Each fixed (k,q) pair must be owned exactly once within each perturbation
6229 : : ! slice. Reduce diagnostics over the complete spin communicator so every rank
6230 : : ! applies the same check and the printed result is MPI-decomposition invariant.
6231 [ # # # # ]: 0 : ntest_found = count(test_found)
6232 : 0 : call xmpi_sum(ntest_found, gqk%qpt_kpt_comm%value, ierr)
6233 [ # # ]: 0 : ABI_CHECK_IEQ(ntest_found, wan_ntest, "Wannier closure test did not find each fixed global (k,q) point exactly once")
6234 : 0 : call xmpi_max(max_err, gqk%comm%value, ierr)
6235 : 0 : call xmpi_max(ref_scale, gqk%comm%value, ierr)
6236 : 0 : call xmpi_max(max_period_eig_err, gqk%comm%value, ierr)
6237 : 0 : call xmpi_max(period_eig_scale, gqk%comm%value, ierr)
6238 : 0 : call xmpi_max(max_period_g2_err, gqk%comm%value, ierr)
6239 : 0 : call xmpi_max(period_g2_scale, gqk%comm%value, ierr)
6240 : 0 : call xmpi_max(max_velocity_err, gqk%comm%value, ierr)
6241 : 0 : call xmpi_max(velocity_scale, gqk%comm%value, ierr)
6242 : 0 : call xmpi_sum(nvelocity_tested, gqk%qpt_kpt_comm%value, ierr)
6243 : 0 : ref_scale = max(ref_scale, tol12)
6244 : 0 : period_eig_scale = max(period_eig_scale, tol12)
6245 : 0 : period_g2_scale = max(period_g2_scale, tol12)
6246 : 0 : velocity_scale = max(velocity_scale, one)
6247 : :
6248 [ # # ]: 0 : if (gqk%comm%me == master) then
6249 : 0 : write(std_out,'(a,es10.2,a,es10.2)') " Wannier on-mesh closure self-check: max_err=", max_err, " ref_scale=", ref_scale
6250 : 0 : write(std_out,'(a,es10.2,a,es10.2)') " Wannier reciprocal-periodicity self-check: max_eig_err=", &
6251 : 0 : max_period_eig_err, " max_g2_err=", max_period_g2_err
6252 : 0 : write(std_out,'(a,i0,a,es10.2)') " Wannier group-velocity self-check: nvalues=", &
6253 : 0 : nvelocity_tested, " max_err=", max_velocity_err
6254 : : end if
6255 : :
6256 [ # # ]: 0 : ABI_CHECK(max_err < WAN_CLOSURE_TOL * ref_scale, "Wannier on-mesh closure self-check failed")
6257 : 0 : msg = "Wannier reciprocal-periodicity self-check failed for interpolated electronic eigenvalues."
6258 [ # # ]: 0 : ABI_CHECK(max_period_eig_err < WAN_CLOSURE_TOL * period_eig_scale, msg)
6259 : 0 : msg = "Wannier reciprocal-periodicity self-check failed for gauge-invariant e-ph Frobenius norms."
6260 [ # # ]: 0 : ABI_CHECK(max_period_g2_err < WAN_CLOSURE_TOL * period_g2_scale, msg)
6261 [ # # ]: 0 : ABI_CHECK(nvelocity_tested > 0, "Wannier group-velocity self-check did not find a nondegenerate band")
6262 : 0 : msg = "Analytic Wannier group velocities do not agree with finite differences of the interpolated eigenvalues."
6263 [ # # ]: 0 : ABI_CHECK(max_velocity_err < WAN_VELOCITY_TOL * velocity_scale, msg)
6264 : :
6265 [ # # ]: 0 : ABI_FREE(u_k_test)
6266 [ # # ]: 0 : ABI_FREE(u_kq_test)
6267 [ # # ]: 0 : ABI_FREE(eigens_k_test)
6268 [ # # ]: 0 : ABI_FREE(eigens_kq_test)
6269 [ # # ]: 0 : ABI_FREE(eigens_k_period)
6270 [ # # ]: 0 : ABI_FREE(eigens_kq_period)
6271 [ # # ]: 0 : ABI_FREE(eigens_k_plus)
6272 [ # # ]: 0 : ABI_FREE(eigens_k_minus)
6273 [ # # ]: 0 : ABI_FREE(vcart_test)
6274 [ # # ]: 0 : ABI_FREE(cmat_test)
6275 [ # # ]: 0 : ABI_FREE(g_expected)
6276 [ # # ]: 0 : ABI_FREE(g_atm_test)
6277 [ # # ]: 0 : ABI_FREE(g_atm_period)
6278 [ # # ]: 0 : ABI_FREE(test_gref)
6279 : :
6280 : : ! Free memory for this spin.
6281 [ # # ]: 0 : ABI_FREE(emikr)
6282 [ # # ]: 0 : ABI_FREE(emiqr)
6283 [ # # ]: 0 : ABI_FREE(gww_pk)
6284 [ # # ]: 0 : ABI_FREE(gww_epq)
6285 : : end do ! my_is
6286 : :
6287 : : ! =====================
6288 : : ! Write data to GWAN.nc
6289 : : ! =====================
6290 [ # # ]: 0 : do spin=1,gstore%nsppol
6291 : 0 : my_is = gstore%spin2my_is(spin)
6292 [ # # ]: 0 : if (my_is /= 0) then
6293 : 0 : gqk => gstore%gqk(my_is)
6294 : : ! grpe_wwp has already been reduced over qpt_kpt_comm and is replicated
6295 : : ! across the q/k (and auxiliary sum/band) grid. Exactly one such slice
6296 : : ! must enter the writer; all ranks along its perturbation axis participate
6297 : : ! collectively because grpe_wwp remains distributed over perturbations.
6298 [ # # # # : 0 : if (all(gqk%coords_qkpb_sumbp([1,2,4,5,6]) == 0)) then
# # ]
6299 : 0 : call gqk%wan%ncwrite_gwan(dtfil, gstore%cryst, gstore%ebands, gqk%pert_comm)
6300 : : end if
6301 : : end if
6302 : 0 : call xmpi_barrier(gstore%comm)
6303 : : end do ! spin
6304 : :
6305 : 0 : call cwtime_report(" gstore_wannierize_and_write_gwan:", cpu, wall, gflops)
6306 : :
6307 [ # # ]: 0 : end subroutine gstore_wannierize_and_write_gwan
6308 : : !!***
6309 : :
6310 : : !!****f* m_gstore/handle_lr_term
6311 : : !! NAME
6312 : : !! handle_lr_term
6313 : : !!
6314 : : !! FUNCTION
6315 : : !! Add/Remove the long range term to/from the e-ph matrix elements.
6316 : : !!
6317 : : !! INPUTS
6318 : : !!
6319 : : !! SOURCE
6320 : :
6321 : : !subroutine handle_lr_term(cryst, qpt, ng, gvec, nwin_kq, nwin_k, nwan, u_kq, u_k, zeff, qstar, isgn, g_bb)
6322 : : !
6323 : : !!Arguments ------------------------------------
6324 : : ! type(crystal_t),intent(in) :: cryst
6325 : : ! real(dp),intent(in) :: qpt(3)
6326 : : ! integer,intent(in) :: ng, nwin_kq, nwin_k, nwan, isgn, gvec(3,ng)
6327 : : ! complex(dp),intent(in) :: u_kq(nwin_kq, nwan), u_k(nwin_k,nwan)
6328 : : ! real(dp),intent(in) :: zeff(3,3,cryst%natom), qstar(3,3,3,cryst%natom)
6329 : : ! complex(dp),intent(inout) :: g_bb(nwin_kq, nwin_k)
6330 : : !
6331 : : !!Local variables-------------------------------
6332 : : !!scalars
6333 : : ! !integer :: ig
6334 : : ! !character(len=500) :: msg
6335 : : !!arrays
6336 : : !! *************************************************************************
6337 : : !
6338 : : !end subroutine handle_lr_term
6339 : : !!***
6340 : :
6341 : : !----------------------------------------------------------------------
6342 : :
6343 : : !!****f* m_gstore/gqk_get_erange_mask
6344 : : !! NAME
6345 : : !! gqk_get_erange_mask
6346 : : !!
6347 : : !! FUNCTION
6348 : : !! Compute MPI-distributed and global masks for electronic states |n,k> allowed by erange.
6349 : : !!
6350 : : !! INPUTS
6351 : : !! gstore<gstore_t>=Electron-phonon object containing dimensions and related quantities.
6352 : : !! erange=Energy range:
6353 : : !! -- if both entries are negative, assume metal and include states within the
6354 : : !! [efermi-abs(erange(1)), efermi+abs(erange(2))] window;
6355 : : !! -- otherwise, erange(1) & erange(2) select window wrt VBM & CBM, respectively.
6356 : : !!
6357 : : !! OUTPUT
6358 : : !! my_states(gqk%nb_k, gqk%my_nk)=Mask for selected states at this MPI proc.
6359 : : !! glob_states(gqk%nb_k, gqk%my_nk)=Global mask for selected states.
6360 : : !!
6361 : : !! SOURCE
6362 : :
6363 : 0 : subroutine gqk_get_erange_mask(gqk, gstore, erange, my_states, glob_states)
6364 : :
6365 : : !Arguments ------------------------------------
6366 : : !scalars
6367 : : class(gqk_t), target, intent(inout) :: gqk
6368 : : class(gstore_t), target, intent(in) :: gstore
6369 : : !arrays
6370 : : real(dp), intent(in) :: erange(2)
6371 : : integer, intent(out) :: my_states(gqk%nb_k, gqk%my_nk), glob_states(gqk%nb_k, gqk%glob_nk)
6372 : :
6373 : : !Local variables-------------------------------
6374 : : !scalars
6375 : : class(ebands_t), pointer :: ebands
6376 : : type(gaps_t) :: gaps
6377 : : integer :: my_ik, ik_ibz, ik_glob, ib_k, bstart_k, gap_err, ierr
6378 : : real(dp) :: vmax, cmin, eig
6379 : : logical :: assume_gap
6380 : : !----------------------------------------------------------------------
6381 : :
6382 : 0 : ebands => gstore%ebands
6383 : :
6384 [ # # # # ]: 0 : assume_gap = .not. all(erange < tol12)
6385 : 0 : gaps = ebands%get_gaps(gap_err)
6386 : :
6387 [ # # ]: 0 : if (assume_gap) then
6388 [ # # ]: 0 : call gaps%print([std_out])
6389 : 0 : vmax = gaps%vb_max(gqk%spin) + tol2 * eV_Ha
6390 : 0 : cmin = gaps%cb_min(gqk%spin) - tol2 * eV_Ha
6391 : : else
6392 : 0 : vmax = ebands%fermie
6393 : 0 : cmin = ebands%fermie
6394 : : end if
6395 : :
6396 : : ! Fill the mask for allowed states
6397 [ # # # # ]: 0 : my_states(:,:) = 0
6398 [ # # # # ]: 0 : glob_states(:,:) = 0
6399 : 0 : bstart_k = gstore%brange_k_spin(1, gqk%spin)
6400 : :
6401 [ # # ]: 0 : do my_ik=1,gqk%my_nk
6402 : 0 : ik_ibz = gqk%my_k2ibz(1, my_ik)
6403 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
6404 : :
6405 [ # # ]: 0 : do ib_k=1,gqk%nb_k
6406 : 0 : eig = ebands%eig(bstart_k + ib_k - 1, ik_ibz, gqk%spin)
6407 : :
6408 [ # # ]: 0 : if (abs(erange(1)) > tol12) then
6409 : : ! Filter valence states.
6410 [ # # # # ]: 0 : if (eig <= vmax .and. vmax - eig <= abs(erange(1))) then
6411 : 0 : my_states(ib_k, my_ik) = 1; glob_states(ib_k, ik_glob) = 1
6412 : : end if
6413 : : end if
6414 : :
6415 [ # # ]: 0 : if (abs(erange(2)) > tol12) then
6416 : : ! Filter conduction states.
6417 [ # # # # ]: 0 : if (eig >= cmin .and. eig - cmin <= abs(erange(2))) then
6418 : 0 : my_states(ib_k, my_ik) = 1; glob_states(ib_k, ik_glob) = 1
6419 : : end if
6420 : : end if
6421 : :
6422 : : enddo
6423 : : enddo
6424 : :
6425 : 0 : call xmpi_sum(glob_states, gqk%kpt_comm%value, ierr)
6426 : 0 : call gaps%free()
6427 : :
6428 [ # # # # : 0 : end subroutine gqk_get_erange_mask
# # # # #
# # # # #
# # ]
6429 : : !!***
6430 : :
6431 : : !----------------------------------------------------------------------
6432 : :
6433 : : !!****f* m_gstore/gqk_filter_erange
6434 : : !! NAME
6435 : : !! gqk_filter_erange
6436 : : !!
6437 : : !! FUNCTION
6438 : : !! Nullify all matrix elements connecting electronic states excluded by energy range.
6439 : : !!
6440 : : !! INPUTS
6441 : : !! gstore<gstore_t>=Electron-phonon object containing dimensions and related quantities.
6442 : : !! erange=Energy range:
6443 : : !! -- if both entries are negative, assume metal and include states within the
6444 : : !! [efermi-abs(erange(1)), efermi+abs(erange(2))] window;
6445 : : !! -- otherwise, erange(1) & erange(2) select window wrt VBM & CBM, respectively.
6446 : : !!
6447 : : !! OUTPUT
6448 : : !!
6449 : : !! SOURCE
6450 : :
6451 : 0 : subroutine gqk_filter_erange(gqk, gstore, erange)
6452 : :
6453 : : !Arguments ------------------------------------
6454 : : !scalars
6455 : : class(gqk_t), target, intent(inout) :: gqk
6456 : : class(gstore_t), target, intent(in) :: gstore
6457 : : !arrays
6458 : : real(dp), intent(in) :: erange(2)
6459 : :
6460 : : !Local variables-------------------------------
6461 : : !scalars
6462 : : integer :: my_ik, ik_glob, my_iq, ikq, ipert, ierr, ib_k, jb_kq
6463 : : real(dp) :: wtq
6464 : : logical :: skip_nk, skip_mkq, skip_q
6465 : 0 : type(krank_t) :: krank_kpts
6466 : : type(ebands_t), pointer :: ebands
6467 : : !arrays
6468 : 0 : integer :: my_states(gqk%nb_k, gqk%my_nk), glob_states(gqk%nb_k, gqk%glob_nk)
6469 : 0 : real(dp) :: kpt(3), qpt(3), kpq(3), kpts(3, gqk%glob_nk), my_qpts(3, gqk%my_nq)
6470 : : !----------------------------------------------------------------------
6471 : :
6472 [ # # ]: 0 : ABI_CHECK_IEQ(gqk%nb_kq, gqk%nb_k, "nb_kq /= nk_k not tested")
6473 : :
6474 : 0 : ebands => gstore%ebands
6475 : :
6476 : : ! Compute masks
6477 : 0 : call gqk%get_erange_mask(gstore, erange, my_states, glob_states)
6478 : :
6479 : : ! Get global krank for k+q transitions
6480 [ # # # # ]: 0 : kpts(:, :) = zero
6481 [ # # ]: 0 : do my_ik=1,gqk%my_nk
6482 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
6483 [ # # ]: 0 : kpts(:, ik_glob) = gqk%my_kpts(:, my_ik)
6484 : : enddo
6485 : 0 : call xmpi_sum(kpts, gqk%kpt_comm%value, ierr)
6486 : :
6487 : 0 : call krank_kpts%from_kptrlatt(gqk%glob_nk, kpts, ebands%kptrlatt, compute_invrank=.True.)
6488 : :
6489 : : ! Get all q-points for this proc
6490 [ # # ]: 0 : do my_iq=1,gqk%my_nq
6491 : 0 : call gqk%myqpt(my_iq, gstore, wtq, my_qpts(:, my_iq))
6492 : : enddo
6493 : :
6494 : : ! Nullify matrix elements connecting the excluded states
6495 [ # # ]: 0 : do my_ik=1,gqk%my_nk
6496 [ # # ]: 0 : kpt(:) = gqk%my_kpts(:, my_ik)
6497 : :
6498 [ # # ]: 0 : do ib_k=1,gqk%nb_k
6499 : : ! |nk> is forbidden
6500 : 0 : skip_nk = .false.
6501 [ # # ]: 0 : if (my_states(ib_k, my_ik) == 0) skip_nk = .true.
6502 : :
6503 [ # # ]: 0 : do my_iq=1,gqk%my_nq
6504 [ # # ]: 0 : qpt(:) = my_qpts(:, my_iq)
6505 : :
6506 : : ! Find k+q --> k' index in krank_kpts
6507 [ # # ]: 0 : kpq(:) = kpt(:) + qpt(:)
6508 : 0 : ikq = krank_kpts%get_index(kpq)
6509 : :
6510 : : ! k+q falls outside the filtered kpts pool
6511 : 0 : skip_q = .false.
6512 [ # # ]: 0 : if (ikq == -1) skip_q = .true.
6513 : :
6514 [ # # ]: 0 : do jb_kq=1,gqk%nb_kq
6515 : : ! |mk+q> is forbidden
6516 : 0 : skip_mkq = .false.
6517 [ # # ]: 0 : if (glob_states(jb_kq, ikq) == 0) skip_mkq = .true.
6518 : :
6519 [ # # ]: 0 : do ipert=1,gqk%my_npert
6520 : :
6521 [ # # # # ]: 0 : if (skip_nk .or. skip_q .or. skip_mkq) then
6522 : 0 : select case (gqk%cplex)
6523 : : case (1)
6524 : 0 : gqk%my_g2(ipert, jb_kq, my_iq, ib_k, my_ik) = zero
6525 : : case (2)
6526 : 0 : gqk%my_g(ipert, jb_kq, my_iq, ib_k, my_ik) = czero
6527 : : case default
6528 [ # # # ]: 0 : ABI_ERROR(sjoin("Invalid gqk%cplex:", itoa(gqk%cplex)))
6529 : : end select
6530 : : end if
6531 : :
6532 : : enddo
6533 : : enddo
6534 : : enddo
6535 : : enddo
6536 : : enddo
6537 : :
6538 : 0 : call krank_kpts%free()
6539 : :
6540 [ # # # # : 0 : end subroutine gqk_filter_erange
# # ]
6541 : : !!***
6542 : :
6543 : : !----------------------------------------------------------------------
6544 : :
6545 : : !!****f* m_gstore/gstore_compute_and_write_ph
6546 : : !! NAME
6547 : : !! gstore_compute_and_write_ph
6548 : : !!
6549 : : !! FUNCTION
6550 : : !! Compute phonon frequencies and eigenvectors in the IBZ. Write results to disk
6551 : : !!
6552 : : !! SOURCE
6553 : :
6554 : 8 : subroutine gstore_compute_and_write_ph(gstore, root_ncid)
6555 : :
6556 : : !Arguments ------------------------------------
6557 : : !scalars
6558 : : class(gstore_t), intent(in) :: gstore
6559 : : integer,intent(in) :: root_ncid
6560 : :
6561 : : !Local variables-------------------------------
6562 : : !scalars
6563 : : integer :: natom, natom3, nproc, ii, iq_ibz, my_nqibz, iq_start, ncerr
6564 : : real(dp) :: cpu, wall, gflops
6565 : : !arrays
6566 : 8 : integer,allocatable :: my_iqibz_inds(:)
6567 : 8 : real(dp),allocatable :: buf_wqnu(:,:), buf_eigvec_cart(:,:,:,:,:), displ_cart_qibz(:,:,:,:)
6568 : : !----------------------------------------------------------------------
6569 : :
6570 : 8 : nproc = xmpi_comm_size(gstore%comm)
6571 : 8 : natom = gstore%cryst%natom; natom3 = 3 * natom
6572 : :
6573 : 8 : call wrtout(std_out, " Computing phonon frequencies and displacements in the IBZ ...", pre_newlines=1, do_flush=.True.)
6574 : 8 : call cwtime(cpu, wall, gflops, "start")
6575 : :
6576 : 8 : call xmpi_split_block(gstore%nqibz, gstore%comm, my_nqibz, my_iqibz_inds)
6577 [ - + + - : 32 : ABI_MALLOC(buf_wqnu, (natom3, my_nqibz))
- + + - +
- + - - +
- + ]
6578 [ - + + - : 40 : ABI_MALLOC(buf_eigvec_cart, (2, 3, natom, natom3, my_nqibz))
- + + - -
+ + - + -
+ - - + -
+ ]
6579 [ - + + - : 32 : ABI_MALLOC(displ_cart_qibz, (2, 3, natom, natom3))
- + + - +
- + - - +
- + ]
6580 : :
6581 [ - + ]: 8 : NCF_CHECK(nctk_prepare_mpiio(root_ncid, "phfreqs_ibz"))
6582 [ - + ]: 8 : NCF_CHECK(nctk_prepare_mpiio(root_ncid, "pheigvec_cart_ibz"))
6583 : :
6584 [ + + ]: 141 : do ii=1,my_nqibz
6585 : 133 : iq_ibz = my_iqibz_inds(ii)
6586 : : call gstore%ifc%fourq(gstore%cryst, gstore%qibz(:, iq_ibz), buf_wqnu(:,ii), displ_cart_qibz, &
6587 : 141 : out_eigvec=buf_eigvec_cart(:,:,:,:,ii))
6588 : : end do
6589 : :
6590 [ - + - - ]: 8 : if (nproc > 1 .and. gstore%nqibz >= nproc) then
6591 [ # # ]: 0 : NCF_CHECK(nctk_set_collective(root_ncid, root_vid("phfreqs_ibz")))
6592 [ # # ]: 0 : NCF_CHECK(nctk_set_collective(root_ncid, root_vid("pheigvec_cart_ibz")))
6593 : : end if
6594 : 8 : call xmpi_barrier(gstore%comm)
6595 : :
6596 [ + - ]: 8 : if (my_nqibz > 0) then
6597 : 8 : iq_start = my_iqibz_inds(1)
6598 : : ncerr = nf90_put_var(root_ncid, root_vid("phfreqs_ibz"), buf_wqnu, &
6599 [ + + + + ]: 40 : start=[1, iq_start], count=[natom3, my_nqibz])
6600 [ - + ]: 8 : NCF_CHECK(ncerr)
6601 : : ncerr = nf90_put_var(root_ncid, root_vid("pheigvec_cart_ibz"), buf_eigvec_cart, &
6602 [ + + + + ]: 88 : start=[1,1,1,1,iq_start], count=[2, 3, natom, natom3, my_nqibz])
6603 [ - + ]: 8 : NCF_CHECK(ncerr)
6604 : : end if
6605 : :
6606 [ - + ]: 8 : ABI_FREE(displ_cart_qibz)
6607 [ - + ]: 8 : ABI_FREE(my_iqibz_inds)
6608 [ - + ]: 8 : ABI_FREE(buf_wqnu)
6609 [ - + ]: 8 : ABI_FREE(buf_eigvec_cart)
6610 : 16 : call cwtime_report(" Phonon computation + output", cpu, wall, gflops)
6611 : :
6612 : : contains
6613 : :
6614 : 16 : integer function root_vid(var_name)
6615 : : character(len=*),intent(in) :: var_name
6616 : 16 : root_vid = nctk_idname(root_ncid, var_name)
6617 : : end function root_vid
6618 : :
6619 : : end subroutine gstore_compute_and_write_ph
6620 : : !!***
6621 : :
6622 : : !!****f* m_gstore/gstore_compute_and_write_vk
6623 : : !! NAME
6624 : : !! gstore_compute_and_write_vk
6625 : : !!
6626 : : !! FUNCTION
6627 : : !! Compute electronic group velocities in the IBZ.
6628 : : !! Write results to disk
6629 : : !!
6630 : : !! SOURCE
6631 : :
6632 : 8 : subroutine gstore_compute_and_write_vk(gstore, mpw, wfd, ebands, psps, pawtab, root_ncid)
6633 : :
6634 : : !Arguments ------------------------------------
6635 : : class(gstore_t), intent(in) :: gstore
6636 : : integer,intent(in) :: mpw
6637 : : type(wfd_t),intent(in) :: wfd
6638 : : type(ebands_t),target,intent(in) :: ebands
6639 : : type(pseudopotential_type),intent(in) :: psps
6640 : : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
6641 : : integer,intent(in) :: root_ncid
6642 : :
6643 : : !Local variables-------------------------------
6644 : : !scalars
6645 : : 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
6646 : : real(dp) :: cpu_kk, wall_kk, gflops_kk, eig0nk
6647 : : logical :: isirr_k
6648 [ + + + + : 80 : type(ddkop_t) :: ddkop
+ + ]
6649 : : !arrays
6650 : : integer :: g0_k(3)
6651 : 8 : integer,allocatable :: count_bk(:,:)
6652 : : real(dp) :: kk(3) !, kk_ibz(3)
6653 : 16 : real(dp),allocatable :: vnk_cart_ibz(:,:,:), cg_work(:,:)
6654 : 8 : type(pawcprj_type),allocatable :: cwaveprj0(:,:)
6655 : : !----------------------------------------------------------------------
6656 : :
6657 : 8 : call wrtout(std_out, " computing and writing velocity operator matrix elements in the ibz")
6658 : 8 : call wrtout(std_out, " note that not all the k-points in the ibz are computed when kfilter is activated!")
6659 : 8 : call cwtime(cpu_kk, wall_kk, gflops_kk, "start")
6660 : :
6661 : : ! On disk, we have:
6662 : : ! nctkarr_t("vk_cart_ibz", "dp", "three, nb_k, gstore_nkibz"))
6663 : : ! nctkarr_t("vkmat_cart_ibz", "dp", "two, three, nb, nb, gstore_nkibz")))
6664 : :
6665 : 8 : call ddkop%init(gstore%dtset, gstore%cryst, pawtab, psps, wfd%mpi_enreg, mpw, wfd%ngfft)
6666 [ - + + - : 24 : ABI_MALLOC(cg_work, (2, mpw*wfd%nspinor))
+ - + - -
+ - + ]
6667 : :
6668 : 8 : usecprj = gstore%dtset%usepaw
6669 [ - + + - : 32 : ABI_MALLOC(cwaveprj0, (gstore%cryst%natom, wfd%nspinor*usecprj))
+ - - - +
- - + - +
- + - + -
- ]
6670 : :
6671 [ + + ]: 16 : do my_is=1,gstore%my_nspins
6672 : 8 : associate (gqk => gstore%gqk(my_is))
6673 : 8 : spin = gstore%my_spins(my_is); nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
6674 : :
6675 : : ! Be careful as wavefunctions might be replicated.
6676 : : ! Use count_bk to count how many states have been computed in parallel in order to rescale the results.
6677 : 8 : if (gstore%with_vk == 1) then
6678 [ - + + - : 1285 : ABI_CALLOC(vnk_cart_ibz, (3, nb_k, gstore%nkibz))
- + + - +
- + - - +
- + - + +
+ + + +
+ ]
6679 [ - + + - : 445 : ABI_ICALLOC(count_bk, (nb_k, gstore%nkibz))
- + + - +
- + - - +
- + - + +
+ + + ]
6680 : : else
6681 : 0 : ABI_ERROR("gstore%with_vk 2 not implemented")
6682 : : end if
6683 : :
6684 [ - + ]: 8 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6685 [ - + ]: 8 : NCF_CHECK(nctk_prepare_mpiio(spin_ncid, "vk_cart_ibz"))
6686 : :
6687 [ + + ]: 319 : do my_ik=1,gqk%my_nk
6688 : : ! The k-point and the symmetries relating the BZ k-point to the IBZ.
6689 [ + + ]: 1244 : kk = gqk%my_kpts(:, my_ik)
6690 : 311 : ik_ibz = gqk%my_k2ibz(1, my_ik) ; isym_k = gqk%my_k2ibz(2, my_ik)
6691 [ + + ]: 1244 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5,my_ik)
6692 [ + + + + : 1149 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
+ + + - ]
6693 : : if (.not. isirr_k) cycle
6694 : :
6695 : : ! parallelize inside (q, pert) so that only one proc in the 3D grid
6696 : : ! computes v_nk for this kpt in the BZ and we can use xmpi_sum_master.
6697 : : !cnt = cnt + 1
6698 : : !if (gqk%qpt_pert_comm%skip(cnt)) cycle
6699 : :
6700 : 36 : npw_k = wfd%npwarr(ik_ibz); istwf_k = wfd%istwfk(ik_ibz)
6701 : 36 : call ddkop%setup_spin_kpoint(gstore%dtset, gstore%cryst, psps, spin, kk, istwf_k, npw_k, wfd%kdata(ik_ibz)%kg_k)
6702 : :
6703 [ + + ]: 150 : do band=gqk%bstart_k, gqk%bstop_k
6704 : 106 : call wfd%copy_cg(band, ik_ibz, spin, cg_work)
6705 : 106 : eig0nk = ebands%eig(band, ik_ibz, spin)
6706 : 106 : in_k = band - gqk%bstart_k + 1
6707 : 106 : vnk_cart_ibz(:, in_k, ik_ibz) = ddkop%get_vdiag(eig0nk, istwf_k, npw_k, wfd%nspinor, cg_work, cwaveprj0)
6708 : 142 : count_bk(in_k, ik_ibz) = count_bk(in_k, ik_ibz) + 1
6709 : : end do
6710 : : end do ! my_ik
6711 : :
6712 : 8 : call xmpi_sum(count_bk, gqk%comm%value, ierr)
6713 : 8 : call xmpi_sum(vnk_cart_ibz, gqk%comm%value, ierr)
6714 : :
6715 [ + + ]: 141 : do ik_ibz=1, gstore%nkibz
6716 [ + + ]: 421 : do band=gqk%bstart_k, gqk%bstop_k
6717 : 280 : in_k = band - gqk%bstart_k + 1
6718 [ + + ]: 280 : if (count_bk(in_k, ik_ibz) == 0) cycle
6719 [ + + ]: 557 : do ii=1,3
6720 : 598 : vnk_cart_ibz(ii,in_k,ik_ibz) = vnk_cart_ibz(ii,in_k,ik_ibz) / count_bk(in_k, ik_ibz)
6721 : : end do
6722 : : end do
6723 : : end do
6724 : :
6725 : : ! Write v_nk to disk.
6726 : : !if (gqk%comm%me == master) then
6727 [ - + ]: 8 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("vk_cart_ibz"), vnk_cart_ibz))
6728 : : !end if
6729 : :
6730 [ - + ]: 8 : ABI_FREE(vnk_cart_ibz)
6731 [ + - - + ]: 16 : ABI_FREE(count_bk)
6732 : : end associate
6733 : : end do ! my_is
6734 : :
6735 [ - + ]: 8 : ABI_FREE(cg_work)
6736 : 8 : call ddkop%free()
6737 : :
6738 : 8 : call pawcprj_free(cwaveprj0)
6739 [ + - - + : 8 : ABI_FREE(cwaveprj0)
- - - - -
+ ]
6740 : :
6741 [ - + + + : 96 : call cwtime_report(sjoin(" Computation of v_k group velocities with with_vk:", itoa(gstore%with_vk)), cpu_kk, wall_kk, gflops_kk)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + + +
- + - + +
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + ]
6742 : :
6743 : : contains
6744 : :
6745 : 8 : integer function spin_vid(var_name)
6746 : : character(len=*),intent(in) :: var_name
6747 : 8 : spin_vid = nctk_idname(spin_ncid, var_name)
6748 : : end function spin_vid
6749 : :
6750 : : end subroutine gstore_compute_and_write_vk
6751 : : !!***
6752 : :
6753 : : !!****f* m_gstore/gstore_compute_and_write_commutator
6754 : : !! NAME
6755 : : !! gstore_compute_and_write_commutator
6756 : : !!
6757 : : !! FUNCTION
6758 : : !! Compute matrix elements i <psi_mk|[V1_q0ka, p]|psi_nk> in the full BZ in reduced coordinates.
6759 : : !! Write results to disk.
6760 : : !! See [[cite:Lihm2020]], PhysRevB.101.121102
6761 : : !!
6762 : : !! SOURCE
6763 : :
6764 : 0 : subroutine gstore_compute_and_write_commutator(gstore, mpw, gmax, ngfft, ngfftf, dtset, cryst, pawfgr, psps, &
6765 : 0 : wfd, mpi_enreg, kg_k, ebands, dvdb, gs_ham_kq, root_ncid)
6766 : :
6767 : : !Arguments ------------------------------------
6768 : : class(gstore_t), intent(in) :: gstore
6769 : : integer,intent(in) :: gmax(3), mpw
6770 : : integer,intent(in) :: ngfft(18),ngfftf(18)
6771 : : type(dvdb_t),intent(inout) :: dvdb
6772 : : type(gs_hamiltonian_type),intent(inout) :: gs_ham_kq
6773 : : type(dataset_type),intent(in) :: dtset
6774 : : type(crystal_t),intent(in) :: cryst
6775 : : type(wfd_t),intent(in) :: wfd
6776 : : type(mpi_type),intent(in) :: mpi_enreg
6777 : : type(ebands_t),intent(in) :: ebands
6778 : : type(pawfgr_type),intent(in) :: pawfgr
6779 : : type(pseudopotential_type),intent(in) :: psps
6780 : : integer,intent(in) :: root_ncid
6781 : : !arrays
6782 : : integer,intent(inout) :: kg_k(3,mpw)
6783 : :
6784 : : !Local variables-------------------------------
6785 : : !scalars
6786 : : integer,parameter :: tim_getgh1c = 1, berryopt0 = 0, master = 0
6787 : : 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,
6788 : : integer :: cplex, db_iqpt, idir, ipert, ipc, my_ip, natom, natom3, n1, n2, n3, n4, n5, n6, nsppol, nspinor, nspden
6789 : : integer :: nfft, nfftf, mgfftf, my_npert, nkpg_k, band_k !, glob_nk mgfft,
6790 : : integer :: sij_opt,usecprj,usevnl,optlocal,optnl,opt_gvnlx1, ncerr, ik_glob, ierr
6791 : : real(dp) :: cpu_kk, wall_kk, gflops_kk
6792 : : logical :: gen_eigenpb
6793 : 0 : type(rf_hamiltonian_type) :: rf_ham_kq
6794 : : !arrays
6795 : : integer :: units(2), work_ngfft(18) ! g0_k(3)
6796 : : !integer,allocatable :: count_bk(:,:)
6797 : : real(dp) :: kk_ibz(3), kk_bz(3), gamma_point(3)
6798 : 0 : real(dp),allocatable :: v1scf(:,:,:,:), work(:,:,:,:), p_kets_k(:,:,:,:), gs1c_kq(:,:), dmat(:,:,:,:)
6799 : 0 : real(dp),allocatable :: kets_k(:,:,:), h1_kets_kq(:,:,:), iv1p_comm(:,:,:,:,:)
6800 : 0 : real(dp),allocatable :: ffnl_k(:,:,:,:), ph3d_k(:,:,:), grad_berry(:,:), kinpw_k(:), kpg_k(:,:)
6801 : 0 : real(dp),allocatable :: vlocal(:,:,:,:), vlocal1(:,:,:,:,:), dummy_vtrial(:,:), gvnlx1(:,:,:), lambda(:)
6802 : 0 : type(pawcprj_type),allocatable :: cwaveprj0(:,:)
6803 : : !----------------------------------------------------------------------
6804 : :
6805 [ # # ]: 0 : units = [std_out, ab_out]
6806 : 0 : call wrtout(units, " Computing and writing i <psi_mk| [V1, p]| psi_nk> ...")
6807 : 0 : call cwtime(cpu_kk, wall_kk, gflops_kk, "start")
6808 : :
6809 : : ! Copy important dimensions
6810 : 0 : natom = cryst%natom; natom3 = 3 * natom; nsppol = ebands%nsppol; nspinor = ebands%nspinor; nspden = dtset%nspden
6811 : :
6812 : 0 : n1 = ngfftf(1); n2 = ngfftf(2); n3 = ngfftf(3); n4 = ngfftf(4); n5 = ngfftf(5); n6 = ngfftf(6)
6813 [ # # ]: 0 : nfftf = product(ngfftf(1:3)); mgfftf = maxval(ngfftf(1:3))
6814 : :
6815 : 0 : call ngfft_seq(work_ngfft, gmax)
6816 [ # # # # : 0 : ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
# # # # #
# # # # #
# # # # #
# ]
6817 : :
6818 : : ! Read the dvscf potentials at qq=Gamma for all 3*natom perturbations.
6819 : : ! This call allocates v1scf(cplex, nfftf, nspden, 3*natom)
6820 : 0 : gamma_point(:) = zero; db_iqpt = dvdb%findq(gamma_point)
6821 : 0 : call dvdb%readsym_allv1(db_iqpt, cplex, nfftf, ngfftf, v1scf, gstore%comm)
6822 [ # # ]: 0 : ABI_CHECK_IEQ(cplex, 1, "cplex should be zero when q == 0")
6823 : :
6824 : : ! Allocate vlocal. Note nvloc
6825 : : ! I set vlocal to huge to trigger possible bugs (DFPT routines should not access the data)
6826 : 0 : usecprj = gstore%dtset%usepaw
6827 [ # # # # : 0 : ABI_MALLOC(vlocal, (n4, n5, n6, gs_ham_kq%nvloc))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
6828 [ # # # # : 0 : vlocal = huge(one)
# # # # ]
6829 [ # # # # : 0 : ABI_CALLOC(dummy_vtrial, (nfftf, nspden))
# # # # #
# # # # #
# # # # #
# ]
6830 [ # # # # : 0 : ABI_MALLOC(cwaveprj0, (gstore%cryst%natom, wfd%nspinor*usecprj))
# # # # #
# # # # #
# # # # #
# # # ]
6831 : :
6832 : : ! Prepare call to getgh1c
6833 : 0 : usevnl = 0
6834 : 0 : optlocal = 1 ! local part of H^(1) is computed in gh1c=<G|H^(1)|C>
6835 : 0 : optnl = 2 ! non-local part of H^(1) is totally computed in gh1c=<G|H^(1)|C>
6836 : 0 : opt_gvnlx1 = 0 ! gvnlx1 is output
6837 : :
6838 [ # # ]: 0 : ABI_MALLOC(grad_berry, (2, nspinor*(berryopt0/4)))
6839 : :
6840 : : ! Since v1(q=0) and p are Hermitian operators, we have:
6841 : : !
6842 : : ! i <psi_mk| [v1, p] |psi_nk> = i <v1 psi_mk | p psi_nk> -i <p psi_mk | v1 psi_nk>
6843 : : !
6844 : : ! Note that in the present implementation both m and n indices run from bstart_k to bstop_k.
6845 : :
6846 : : ! if PAW, one has to solve a generalized eigenproblem
6847 [ # # ]: 0 : gen_eigenpb = psps%usepaw == 1; sij_opt = 0; if (gen_eigenpb) sij_opt = 1
6848 : :
6849 : : ! Define netcdf arrays inside the spin group.
6850 [ # # ]: 0 : do spin=1, nsppol
6851 [ # # ]: 0 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6852 : : ncerr = nctk_def_arrays(spin_ncid, [ &
6853 : : nctkarr_t("iv1p_comm", "dp", "two, nb_k, nb_k, three, natom3, glob_nk") &
6854 [ # # ]: 0 : ], defmode=.True.)
6855 [ # # ]: 0 : NCF_CHECK(ncerr)
6856 : :
6857 [ # # ]: 0 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("iv1p_comm"), NF90_FILL, -huge(one)))
6858 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(spin_ncid))
6859 : : end do
6860 : : !NCF_CHECK(nctk_set_datamode(root_ncid))
6861 : :
6862 [ # # ]: 0 : do my_is=1,gstore%my_nspins
6863 : 0 : associate (gqk => gstore%gqk(my_is))
6864 : 0 : spin = gstore%my_spins(my_is); nb_k = gqk%nb_k; nb_kq = gqk%nb_kq; my_npert = gqk%my_npert
6865 : :
6866 : : ! Be careful as wavefunctions might be replicated.
6867 : : ! Use count_bk to count how many states have been computed in parallel in order to rescale the results.
6868 : : !ABI_ICALLOC(count_bk, (nb_k, gstore%nkibz))
6869 [ # # ]: 0 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6870 [ # # ]: 0 : NCF_CHECK(nctk_prepare_mpiio(spin_ncid, "iv1p_comm"))
6871 : :
6872 : : ! Allocate vlocal1 with correct cplex. Note nvloc and my_npert.
6873 [ # # # # : 0 : ABI_MALLOC(vlocal1, (cplex*n4, n5, n6, gs_ham_kq%nvloc, my_npert))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
6874 [ # # # # : 0 : ABI_MALLOC(lambda, (nb_k))
# # # # #
# # # ]
6875 : :
6876 [ # # # # : 0 : ABI_CALLOC(iv1p_comm, (2, nb_k, nb_k, 3, natom3))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # #
# ]
6877 [ # # # # : 0 : ABI_MALLOC(dmat, (2, nb_k, nb_k, 3))
# # # # #
# # # # #
# # ]
6878 : :
6879 : : ! Set up local potential vlocal1 with proper dimensioning from vtrial1 taking into account the spin.
6880 : : ! Note that here v1scf contains all 3 natom perturbations as we called dvdb%readsym_allv1.
6881 [ # # ]: 0 : do my_ip=1,my_npert
6882 : 0 : idir = dvdb%my_pinfo(1, my_ip); ipert = dvdb%my_pinfo(2, my_ip); ipc = dvdb%my_pinfo(3, my_ip)
6883 : : call rf_transgrid_and_pack(spin, nspden, psps%usepaw, cplex, nfftf, nfft, ngfft, gs_ham_kq%nvloc,&
6884 : 0 : pawfgr, mpi_enreg, dummy_vtrial, v1scf(:,:,:,ipc), vlocal, vlocal1(:,:,:,:,my_ip))
6885 : : end do
6886 : :
6887 : : ! Continue to initialize the GS Hamiltonian
6888 : 0 : call gs_ham_kq%load_spin(spin, vlocal=vlocal, with_nonlocal=.true.)
6889 : :
6890 [ # # ]: 0 : do my_ik=1,gqk%my_nk
6891 : : ! Parallelism inside q-point communicator.
6892 [ # # ]: 0 : if (gqk%qpt_comm%skip(my_ik)) cycle
6893 : :
6894 : : ! The k-point and the symmetries relating the BZ k-point to the IBZ.
6895 [ # # ]: 0 : kk_bz = gqk%my_kpts(:, my_ik)
6896 : 0 : ik_ibz = gqk%my_k2ibz(1, my_ik)
6897 [ # # ]: 0 : kk_ibz = ebands%kptns(:,ik_ibz)
6898 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
6899 : :
6900 : : ! Get npw_k, kg_k and symmetrize wavefunctions from the IBZ (if needed).
6901 : : call wfd%sym_ug_kg_npw(dtset%ecut, kk_bz, kk_ibz, gqk%bstart_k, nb_k, spin, gqk%my_k2ibz(:, my_ik), cryst, &
6902 [ # # ]: 0 : work_ngfft, work, istwf_k, npw_k, kg_k, kets_k)
6903 : :
6904 : : call gs_ham_kq%eph_setup_k("k", kk_bz, istwf_k, npw_k, kg_k, dtset, cryst, psps, & ! in
6905 [ # # # # : 0 : nkpg_k, kpg_k, ffnl_k, kinpw_k, ph3d_k, gqk%pert_comm%value) ! out
# # # # ]
6906 : :
6907 : 0 : npwsp_k = npw_k * nspinor
6908 [ # # # # : 0 : ABI_MALLOC(h1_kets_kq, (2, npwsp_k, nb_k))
# # # # #
# # # # #
# # ]
6909 [ # # # # : 0 : ABI_MALLOC(gs1c_kq, (2, npwsp_k*nb_k*((sij_opt+1)/2)))
# # # # #
# # # ]
6910 [ # # # # : 0 : ABI_MALLOC(gvnlx1, (2, npwsp_k,nb_k))
# # # # #
# # # ]
6911 : :
6912 : : ! Compute <g|-i\Nabla |psi_nk>.
6913 [ # # # # : 0 : ABI_MALLOC(p_kets_k, (2, npwsp_k, nb_k, 3))
# # # # #
# # # # #
# # # # ]
6914 : 0 : call cg_p_psi(npw_k, nspinor, nb_k, kk_bz, kg_k, kets_k, p_kets_k)
6915 : :
6916 [ # # # # : 0 : iv1p_comm = zero
# # # # #
# ]
6917 [ # # ]: 0 : do my_ip=1,my_npert
6918 : 0 : idir = dvdb%my_pinfo(1, my_ip); ipert = dvdb%my_pinfo(2, my_ip); ipc = dvdb%my_pinfo(3, my_ip)
6919 : :
6920 : : ! Prepare application of the NL part.
6921 : 0 : call rf_ham_kq%init(cplex, gs_ham_kq, ipert, has_e1kbsc=.true.)
6922 : 0 : call rf_ham_kq%load_spin(spin, vlocal1=vlocal1(:,:,:,:,my_ip), with_nonlocal=.true.)
6923 : :
6924 [ # # ]: 0 : do in_k=1,nb_k
6925 : : ! Use scissor shift on 0-order eigenvalue
6926 : 0 : band_k = in_k + gqk%bstart_k - 1
6927 : 0 : lambda(in_k) = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
6928 : : end do
6929 : : !call ebands%get_dfpt_eshifted(gqk%bstart_k, nb_k, ik_ibz, spin, dtset%dfpt_sciss, lambda)
6930 : :
6931 : : ! Calculate dvscf * psi_k, results stored in h1_kets_kq on the k+q sphere.
6932 : : ! Compute H(1) applied to GS wavefunction Psi(0).
6933 : : call getgh1c(berryopt0, kets_k, cwaveprj0, h1_kets_kq, &
6934 : : grad_berry, gs1c_kq, gs_ham_kq, gvnlx1, idir, ipert, lambda, mpi_enreg, nb_k, optlocal, &
6935 : 0 : optnl, opt_gvnlx1, rf_ham_kq, sij_opt, tim_getgh1c, usevnl)
6936 : :
6937 : 0 : call rf_ham_kq%free()
6938 : :
6939 : : ! Here we compute: i <u_mk| [v1, p] u_nk> = i <v1 u_mk | p u_nk> -i <p u_mk | v1 u_nk>
6940 : : ! p_kets_k(:, npwsp_k, nb_k, 3)
6941 : : ! h1_kets_kq, (2, npw_k*nspinor, nb_k))
6942 [ # # # # : 0 : dmat = zero
# # # # ]
6943 [ # # ]: 0 : do ii=1,3
6944 : : call ZGEMM('C', 'N', nb_k, nb_k, npwsp_k, j_dpc, h1_kets_kq, npwsp_k, &
6945 : 0 : p_kets_k(:,:,:,ii), npwsp_k, cone, dmat(:,:,:,ii), nb_k)
6946 : :
6947 : : call ZGEMM('C', 'N', nb_k, nb_k, npwsp_k, -j_dpc, p_kets_k(:,:,:,ii), npwsp_k, &
6948 : 0 : h1_kets_kq, npwsp_k, cone, dmat(:,:,:,ii), nb_k)
6949 : : end do
6950 : :
6951 [ # # # # : 0 : iv1p_comm(:,:,:,:,ipc) = dmat
# # # # ]
6952 : : end do ! my_ip
6953 : :
6954 : 0 : call xmpi_sum(iv1p_comm, gqk%pert_comm%value, ierr)
6955 [ # # ]: 0 : if (gqk%pert_comm%me == 0) then
6956 [ # # # # : 0 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("iv1p_comm"), iv1p_comm, start=[1,1,1,1,1,ik_glob]))
# # ]
6957 : : end if
6958 : :
6959 [ # # ]: 0 : ABI_FREE(ffnl_k)
6960 [ # # ]: 0 : ABI_FREE(kinpw_k)
6961 [ # # ]: 0 : ABI_FREE(ph3d_k)
6962 [ # # ]: 0 : ABI_FREE(kpg_k)
6963 [ # # ]: 0 : ABI_FREE(kets_k)
6964 [ # # ]: 0 : ABI_FREE(p_kets_k)
6965 [ # # ]: 0 : ABI_FREE(gs1c_kq)
6966 [ # # ]: 0 : ABI_FREE(h1_kets_kq)
6967 [ # # ]: 0 : ABI_FREE(gvnlx1)
6968 : : end do ! my_ik
6969 : :
6970 [ # # ]: 0 : ABI_FREE(vlocal1)
6971 [ # # ]: 0 : ABI_FREE(lambda)
6972 [ # # ]: 0 : ABI_FREE(dmat)
6973 : :
6974 : : !call xmpi_sum(count_bk, gqk%comm%value, ierr)
6975 : :
6976 : : !do ik_ibz=1, gstore%nkibz
6977 : : ! do band=gqk%bstart_k, gqk%bstop_k
6978 : : ! in_k = band - gqk%bstart_k + 1
6979 : : ! if (count_bk(in_k, ik_ibz) == 0) cycle
6980 : : ! do ii=1,3
6981 : : ! vnk_cart_ibz(ii,in_k,ik_ibz) = vnk_cart_ibz(ii,in_k,ik_ibz) / count_bk(in_k, ik_ibz)
6982 : : ! end do
6983 : : ! end do
6984 : : !end do
6985 : : !ABI_FREE(count_bk)
6986 : :
6987 [ # # ]: 0 : ABI_FREE(iv1p_comm)
6988 : : end associate
6989 : : end do ! my_is
6990 : :
6991 [ # # ]: 0 : ABI_FREE(vlocal)
6992 [ # # ]: 0 : ABI_FREE(dummy_vtrial)
6993 [ # # ]: 0 : ABI_FREE(v1scf)
6994 [ # # ]: 0 : ABI_FREE(work)
6995 [ # # ]: 0 : ABI_FREE(grad_berry)
6996 : :
6997 : 0 : call pawcprj_free(cwaveprj0)
6998 [ # # # # : 0 : ABI_FREE(cwaveprj0)
# # # # #
# ]
6999 : :
7000 : 0 : call xmpi_barrier(gstore%comm)
7001 [ # # # # : 0 : call cwtime_report(" Computation of commutator:", cpu_kk, wall_kk, gflops_kk)
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
7002 : :
7003 : : contains
7004 : :
7005 : 0 : integer function spin_vid(var_name)
7006 : : character(len=*),intent(in) :: var_name
7007 : 0 : spin_vid = nctk_idname(spin_ncid, var_name)
7008 : : end function spin_vid
7009 : :
7010 : : end subroutine gstore_compute_and_write_commutator
7011 : : !!***
7012 : :
7013 : : !!****f* m_gstore/gstore_nc_has_iv1p_comm
7014 : : !! NAME
7015 : : !! gstore_nc_has_iv1p_comm
7016 : : !!
7017 : : !! FUNCTION
7018 : : !! Return True if GSTORE.nc contains commutator matrix elements.
7019 : : !!
7020 : : !! SOURCE
7021 : :
7022 : 24 : logical function gstore_nc_has_iv1p_comm(gstore, root_ncid) result (has_iv1p_comm)
7023 : :
7024 : : !Arguments ------------------------------------
7025 : : class(gstore_t),target, intent(in) :: gstore
7026 : : integer,intent(in) :: root_ncid
7027 : :
7028 : : !Local variables-------------------------------
7029 : : integer :: spin, ncerr, spin_ncid, varid
7030 : : ! *************************************************************************
7031 : :
7032 : 24 : has_iv1p_comm = .True.
7033 [ + - ]: 24 : do spin=1,gstore%nsppol
7034 [ - + ]: 24 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
7035 : 24 : ncerr = nf90_inq_varid(spin_ncid, "iv1p_comm", varid)
7036 [ - + ]: 24 : if (ncerr /= nf90_noerr) then
7037 : : has_iv1p_comm = .False.; exit
7038 : : end if
7039 : : end do
7040 : :
7041 : 24 : end function gstore_nc_has_iv1p_comm
7042 : : !!***
7043 : :
7044 : : !!****f* m_gstore/gstore_read_gtype
7045 : : !! NAME
7046 : : !! gstore_read_gtype
7047 : : !!
7048 : : !! FUNCTION
7049 : : !! Read the value of "gstore_gtype" from the NetCDF file.
7050 : : !! Only the master process reads the value and broadcasts it to all processes in comm.
7051 : : !!
7052 : : !! INPUTS
7053 : : !! ncid: NetCDF file ID (open for reading).
7054 : : !! comm: MPI communicator.
7055 : : !!
7056 : : !! OUTPUTS
7057 : : !! gtype: The value of gstore_gtype read from the file.
7058 : : !!
7059 : : !! SOURCE
7060 : :
7061 : 7 : subroutine gstore_read_gtype(path, gtype, comm, &
7062 [ - + - - : 7 : brange_k_spin, brange_kq_spin) ! optional
- - - + -
- - - ]
7063 : :
7064 : : !Arguments ------------------------------------
7065 : : character(len=*), intent(in) :: path
7066 : : character(len=abi_slen), intent(out) :: gtype
7067 : : integer, intent(in) :: comm
7068 : : integer,optional,intent(out) :: brange_k_spin(:,:)
7069 : : integer,optional,intent(out) :: brange_kq_spin(:,:)
7070 : :
7071 : : !Local variables-------------------------------
7072 : : integer, parameter :: master = 0
7073 : : integer :: my_rank, nproc, ierr, varid, ncerr, ncid
7074 : : ! *************************************************************************
7075 : :
7076 : 7 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
7077 : :
7078 [ + - ]: 7 : if (my_rank == master) then
7079 [ - + ]: 7 : NCF_CHECK(nf90_open(path, nf90_nowrite, ncid))
7080 : 7 : gtype = GSTORE_GTYPE_KS
7081 : 7 : ncerr = nf90_inq_varid(ncid, "gstore_gtype", varid)
7082 [ + - ]: 7 : if (ncerr == nf90_noerr) then
7083 [ - + ]: 7 : NCF_CHECK(nf90_get_var(ncid, varid, gtype))
7084 : 7 : call replace_ch0(gtype)
7085 : : end if
7086 [ - + ]: 7 : if (present(brange_k_spin)) then
7087 [ # # ]: 0 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_k_spin"), brange_k_spin))
7088 : : end if
7089 [ - + ]: 7 : if (present(brange_kq_spin)) then
7090 [ # # ]: 0 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_kq_spin"), brange_kq_spin))
7091 : : end if
7092 [ - + ]: 7 : NCF_CHECK(nf90_close(ncid))
7093 : : end if
7094 : :
7095 [ - + ]: 7 : if (nproc > 1) then
7096 : 0 : call xmpi_bcast(gtype, master, comm, ierr)
7097 [ # # ]: 0 : if (present(brange_k_spin)) call xmpi_bcast(brange_k_spin, master, comm, ierr)
7098 [ # # ]: 0 : if (present(brange_kq_spin)) call xmpi_bcast(brange_kq_spin, master, comm, ierr)
7099 : : end if
7100 : :
7101 : : contains
7102 : :
7103 : 0 : integer function vid(var_name)
7104 : : character(len=*),intent(in) :: var_name
7105 : 0 : vid = nctk_idname(ncid, var_name)
7106 : : end function vid
7107 : :
7108 : : end subroutine gstore_read_gtype
7109 : : !!***
7110 : :
7111 : : !----------------------------------------------------------------------
7112 : :
7113 : : !!****f* m_gstore/gstore_symmetrize
7114 : : !! NAME
7115 : : !! gstore_symmetrize
7116 : : !!
7117 : : !! FUNCTION
7118 : : !! Reconstruct the electron-phonon matrix elements g(k,q) in the full
7119 : : !! Brillouin Zone (BZ) using the values stored in the IBZ for k and the IBZ_k for q.
7120 : : !! Uses the NetCDF API for in-place modification of the GSTORE file
7121 : : !! and wfd_t to fetch wavefunctions and compute unitary matrices.
7122 : : !!
7123 : : !! SOURCE
7124 : :
7125 : 0 : subroutine gstore_symmetrize(gstore_path, wfk_path, ngfft, dtset, dtfil, cryst, psps, pawtab, ebands, ifc, comm)
7126 : :
7127 : : !Arguments ------------------------------------
7128 : : !scalars
7129 : : character(len=*),intent(in) :: gstore_path
7130 : : character(len=*),intent(in) :: wfk_path
7131 : : integer,intent(in) :: ngfft(18)
7132 : : type(dataset_type),intent(in) :: dtset
7133 : : type(datafiles_type),intent(in) :: dtfil
7134 : : class(crystal_t),target,intent(in) :: cryst
7135 : : class(ebands_t),target,intent(in) :: ebands
7136 : : class(ifc_type),target,intent(in) :: ifc
7137 : : type(pseudopotential_type),intent(in) :: psps
7138 : : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
7139 : : integer,intent(in) :: comm
7140 : :
7141 : : !Local variables-------------------------------
7142 : : !scalars
7143 : : integer :: with_cplex, my_is, spin, my_ik, my_iq, ik_glob, iq_glob, units(2)
7144 : : integer :: ncid, spin_ncid, nprocs, my_rank, ncerr, this_state, ierr
7145 : : integer :: nb, nkbz, nkibz, nqbz, nqibz, nsym, itime_k
7146 : : integer :: ik_ibz, isym_k, trev_k, tsign_k, g0_k(3), g0_q(3)
7147 : : integer :: ik_ibz_file, isym_lg, itime_lg, isym_combined, c1_gs, n_gv, igv
7148 : : integer :: n_lg, ii_lg, tsign_lg !, isym_lg, itime_lg,
7149 : : integer :: idir, iat, idir_eq, iat_eq, mu, mu_eq, iq_sym
7150 : : integer :: symrec_eq(3,3), symrec_eq_kspace(3,3), l0(3), mat_tmp(3,3)
7151 : : real(dp) :: weight_qq, phase
7152 : : complex(dp) :: cphase
7153 : : logical :: with_g2dw, isirr_k, found_lg
7154 : : character(len=abi_slen) :: with_gmode, gtype, gvals_name, gv_names(2)
7155 : : character(len=5000) :: msg
7156 [ # # ]: 0 : type(gstore_t) :: gstore
7157 : 0 : type(dmats_t) :: dmats
7158 : : integer :: isym_kqS, isym_kqT, ikq_ibz_s, ikq_ibz_t, h_isym, itime_h, h_isym_inv, trev_kqS, trev_kqT
7159 : : integer :: indkk_s(6,1), indkk_t(6,1)
7160 : : real(dp) :: L_h_gs(3), kq_ibz_pt(3)
7161 : : complex(dp) :: phase_h_gs, phase_ket_gs
7162 : : logical,parameter :: DEBUG_DUMP_DH = .False.
7163 : : real(dp) :: kk_lg_test(3)
7164 : : !!arrays
7165 : 0 : integer :: brange_kq_spin(2, dtset%nsppol)
7166 : 0 : integer,allocatable :: state_kq(:,:), kibz2bz(:) !, qibz2bz(:), qglob2bz(:,:), ! kmesh_map(:,:), my_kqmap(:,:),
7167 : 0 : integer,allocatable :: lg_isym(:), lg_itime(:)
7168 : : real(dp) :: kk_bz(3), kk_ibz(3), qpt(3), qpt_tmp(3), kq_bz_source(3), kq_bz_target(3)
7169 : 0 : real(dp),allocatable :: qbz(:,:)
7170 : 0 : real(dp),contiguous,pointer :: gkq_rot_ptr(:,:,:,:,:), gkq_base_ptr(:,:,:,:,:)
7171 : 0 : complex(dp),target,allocatable :: gkq_rot(:,:,:,:,:), gkq_base(:,:,:,:,:)
7172 : 0 : complex(dp),allocatable :: gtmp(:,:), dh_mat(:,:), ket_mat(:,:)
7173 : : !----------------------------------------------------------------------
7174 : :
7175 : 0 : nprocs = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
7176 : :
7177 [ # # ]: 0 : units = [std_out, ab_out]
7178 : 0 : call wrtout(units, " Entering gstore_symmetrize...")
7179 : 0 : call wrtout(units, sjoin(" GSTORE file: ", gstore_path))
7180 : :
7181 : 0 : call gstore_read_gtype(gstore_path, gtype, comm, brange_kq_spin=brange_kq_spin)
7182 : :
7183 : : ! Compute the D-matrices D_mn(S) = <psi_m,S kq_ibz|S|psi_n,kq_ibz>.
7184 : : ! These are used below (as dh_mat) to correct the extra rotation the bra (electron state
7185 : : ! at k+q) picks up when its own already-computed BZ representative differs from the one
7186 : : ! obtained by applying isym_k directly. dh_mat is applied to the (k+q)/bra band index only
7187 : : ! (gvals' first band dimension, nb_kq) -- never to the k/ket index (nb_k) -- so dmats must be
7188 : : ! built with brange_kq_spin (bstart_kq:bstop_kq), NOT brange_k_spin: the two band windows are
7189 : : ! only required to have the SAME COUNT (gstore%same_nbands, checked below) but may start at a
7190 : : ! different absolute band (bstart_k need not equal bstart_kq, and neither needs to start at 1).
7191 : : ! All MPI ranks participate here since dmats%init distributes the work internally over comm.
7192 : : !
7193 : : ! NOTE: dmats_init also computes genuine (WFK-derived) D-matrices for symmetries S that do
7194 : : ! NOT stabilize a given IBZ k-point (S.k /= k+G), not just little-group elements -- this
7195 : : ! routine (gstore_symmetrize) is UNAFFECTED by that generalization and needs no changes
7196 : : ! because it never reads a non-little-group slot: every dmats%for_spin(...) lookup below
7197 : : ! uses either h_isym/h_isym_inv (searched for specifically as a stabilizer of ikq_ibz_t --
7198 : : ! see "Cannot find little-group element h for the k+q leg" below) or isym_k (drawn directly
7199 : : ! from lg_isym, the explicitly-enumerated little group of kk_ibz in Pass A). Both are
7200 : : ! guaranteed, by construction, to land on the little-group branch of dmats_init, which is
7201 : : ! untouched by the generalization -- confirmed by byte-identical validation numbers on
7202 : : ! diamond/AlAs before and after. See gstore_symmetrize_status memory for the full story.
7203 : 0 : call dmats%init(wfk_path, dtset, cryst, brange_kq_spin, ngfft, pawtab, psps, comm)
7204 : :
7205 : : ! Only master processor performs the symmetrization of the e-ph matrix elements.
7206 : : ! Performance is not crucial and the algorithm is IO-bound.
7207 [ # # ]: 0 : if (my_rank /= 0) goto 100
7208 : :
7209 : : ! GWPT files store two sets of e-ph matrix elements: "gvals" (g^Sigma) and "gvals_ks" (g^KS),
7210 : : ! written at the same (k,q) grid positions (see m_gwpt.F90's dump_my_gbuf). Symmetrize both.
7211 : 0 : n_gv = 1; gv_names(1) = "gvals"
7212 [ # # ]: 0 : if (gtype == GSTORE_GTYPE_GWPT) then
7213 : 0 : n_gv = 2; gv_names(2) = "gvals_ks"
7214 : : end if
7215 : :
7216 : : ! Read GSTORE.nc dimensions and metadata from file, without allocating gvals buffer.
7217 : 0 : with_cplex = 0; with_gmode = GSTORE_GMODE_ATOM; with_g2dw = .False.; gvals_name = "gvals"
7218 : : call gstore%from_ncpath(gstore_path, with_cplex, dtset, dtfil, cryst, ebands, ifc, &
7219 : 0 : with_gmode, gvals_name, with_g2dw, xmpi_comm_self)
7220 : :
7221 : : ! We need the same number of bands for m and n. Also, k and q must be in the BZ without any filter.
7222 [ # # ]: 0 : ABI_CHECK(gstore%same_nbands(msg), msg)
7223 [ # # ]: 0 : if (gstore%check_cplex_qkzone_gmode(2, "bz", "bz", "atom", kfilter="none", check_alloc=.False.) /= 0) then
7224 : 0 : ABI_ERROR("GSTORE.nc should have both k and q in the full BZ. See messages above.")
7225 : : end if
7226 : :
7227 : : ! has_used_lgk is supported via the gstore_sym == 2 "Pass A" reconstruction below.
7228 : : ! has_used_lgq remains unsupported: it is a structurally different restriction
7229 : : ! (k filtered by the little group of q), out of scope for gstore_sym.
7230 [ # # ]: 0 : ABI_CHECK_IEQ(gstore%has_used_lgq, 0, "Symmetrization of g(k,q) with use_lgq /= 0 is not coded")
7231 : :
7232 : : ! Useful dimensions.
7233 : 0 : nkbz = gstore%nkbz; nkibz = gstore%nkibz
7234 : 0 : nqbz = gstore%nqbz; nqibz = gstore%nqibz
7235 : 0 : nsym = cryst%nsym
7236 : :
7237 : : ! Need to know the position of the IBZ k-points in the netcdf array..
7238 [ # # ]: 0 : call get_ibz2bz(gstore%nkibz, gstore%nkbz, gstore%kbz2ibz, kibz2bz, msg, ierr)
7239 [ # # ]: 0 : ABI_CHECK(ierr == 0, sjoin("Something wrong in symmetry tables for k-points", ch10, msg))
7240 : :
7241 [ # # ]: 0 : NCF_CHECK(nctk_open_modify(ncid, gstore_path, xmpi_comm_self))
7242 : :
7243 : : if (DEBUG_DUMP_DH) open(unit=789, file="dh_debug.csv", status="replace", action="write")
7244 : : if (DEBUG_DUMP_DH) open(unit=790, file="dh_mat_full_debug.csv", status="replace", action="write")
7245 : : if (DEBUG_DUMP_DH) open(unit=791, file="gtmp_debug.csv", status="replace", action="write")
7246 : : if (DEBUG_DUMP_DH) open(unit=792, file="mu_debug.csv", status="replace", action="write")
7247 : :
7248 : : ! Loop over collinear spins.
7249 [ # # ]: 0 : do my_is=1,gstore%my_nspins
7250 : 0 : spin = gstore%my_spins(my_is)
7251 : : associate (gqk => gstore%gqk(my_is))
7252 : : ! nb_k == nb_kq is enforced by gstore%same_nbands above, so either count can be used here for
7253 : : ! sizing; the absolute band offsets (bstart_k vs bstart_kq, handled via brange_kq_spin passed
7254 : : ! to dmats%init above) are what actually differ and matter for correctness.
7255 : 0 : nb = gqk%nb_k
7256 : 0 : ABI_CHECK_IEQ(gqk%bstart_kq, brange_kq_spin(1, spin), "gqk%bstart_kq != brange_kq_spin(1, spin)")
7257 [ # # ]: 0 : ABI_CHECK_IEQ(gqk%bstop_kq, brange_kq_spin(2, spin), "gqk%bstop_kq != brange_kq_spin(2, spin)")
7258 : :
7259 : : ! Get the group id for this spin.
7260 [ # # ]: 0 : NCF_CHECK(nf90_inq_ncid(ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
7261 : :
7262 : : ! Read table with status of the (k, q) entry.
7263 [ # # # # : 0 : ABI_MALLOC(state_kq, (gqk%glob_nk, gqk%glob_nq))
# # # # #
# # # # #
# # # # ]
7264 [ # # ]: 0 : ncerr = nf90_get_var(ncid, nctk_idname(ncid, "gstore_glob_state_kqs"), state_kq, start=[1,1,spin])
7265 [ # # ]: 0 : NCF_CHECK(ncerr)
7266 : :
7267 [ # # # # : 0 : ABI_MALLOC(gkq_base, (nb, nb, gqk%natom3, gqk%my_nq, n_gv))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
7268 [ # # # # : 0 : ABI_MALLOC(gkq_rot, (nb, nb, gqk%natom3, gqk%my_nq, n_gv))
# # # # #
# # # # #
# # # # #
# # # #
# ]
7269 [ # # # # : 0 : ABI_MALLOC(gtmp, (nb, nb))
# # # # #
# # # # #
# # # # ]
7270 [ # # # # : 0 : ABI_MALLOC(dh_mat, (nb, nb))
# # # # #
# # # #
# ]
7271 [ # # # # : 0 : ABI_MALLOC(ket_mat, (nb, nb))
# # # # #
# # # #
# ]
7272 : :
7273 : : ! Build q-points in the BZ.
7274 [ # # # # : 0 : ABI_MALLOC(qbz, (3, gqk%my_nq))
# # # # #
# # # ]
7275 [ # # ]: 0 : do my_iq=1, gqk%my_nq
7276 : 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qbz(:,my_iq))
7277 : : end do
7278 : :
7279 : : ! =====================================================================
7280 : : ! Pass A (gstore_sym == 2 only): if gstore_use_lgk restricted the q's
7281 : : ! actually computed directly for k in the IBZ, an IBZ row may have some
7282 : : ! q entries GSTORE_KQ_COMPUTED (q in IBZ_k) and others GSTORE_KQ_MISSING
7283 : : ! (q outside IBZ_k). Fill the MISSING ones here, using ONLY the little
7284 : : ! group of kk_ibz itself (k never moves in this pass -- the degenerate
7285 : : ! case of the k-star formula below, kk_bz := kk_ibz). Once every IBZ row
7286 : : ! is fully populated, the k-star loop below runs completely unchanged
7287 : : ! for the non-IBZ rows, exactly as it always has when gstore_use_lgk == 0.
7288 : : ! =====================================================================
7289 [ # # ]: 0 : if (dtset%gstore_sym == 2) then
7290 [ # # ]: 0 : do ik_ibz=1,nkibz
7291 : 0 : ik_glob = kibz2bz(ik_ibz)
7292 [ # # # # : 0 : if (all(state_kq(ik_glob, :) /= GSTORE_KQ_MISSING)) cycle
# # ]
7293 : :
7294 [ # # ]: 0 : kk_ibz = ebands%kptns(:, ik_ibz)
7295 : 0 : ik_ibz_file = ik_glob
7296 : 0 : kk_bz = kk_ibz ! degenerate case: k never moves in Pass A
7297 : :
7298 : : ! Enumerate the little group of kk_ibz once per row: symrel^T membership
7299 : : ! test, mirroring dmats_get_star_dmats (m_classify_bands.F90:2048-2061).
7300 : : ! Deliberately NOT lgroup_t/littlegroup_q here: those use the symrec
7301 : : ! convention, which can disagree with the symrel^T convention used
7302 : : ! throughout dmats/gstore_symmetrize for non-orthogonal symrel.
7303 [ # # # # : 0 : ABI_MALLOC(lg_isym, (2*nsym))
# # # # #
# # # #
# ]
7304 [ # # # # : 0 : ABI_MALLOC(lg_itime, (2*nsym))
# # # # ]
7305 : 0 : n_lg = 0
7306 [ # # ]: 0 : do itime_lg=1,2
7307 [ # # ]: 0 : do isym_lg=1,nsym
7308 [ # # ]: 0 : tsign_lg = 1; if (itime_lg == 2) tsign_lg = -1
7309 [ # # # # : 0 : kk_lg_test = tsign_lg * matmul(transpose(cryst%symrel(:,:,isym_lg)), kk_ibz)
# # # # #
# # # ]
7310 [ # # ]: 0 : if (isamek(kk_ibz, kk_lg_test, g0_q)) then
7311 : 0 : n_lg = n_lg + 1
7312 : 0 : lg_isym(n_lg) = isym_lg; lg_itime(n_lg) = itime_lg
7313 : : end if
7314 : : end do
7315 : : end do
7316 [ # # ]: 0 : ABI_CHECK(n_lg > 0, "Little group of kk_ibz is empty (should at least contain the identity)")
7317 : :
7318 : : ! Read g(k_ibz, q) for all q already available (same read pattern as below).
7319 [ # # ]: 0 : do igv=1,n_gv
7320 [ # # ]: 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])
7321 : : ncerr = nf90_get_var(spin_ncid, spin_vid(gv_names(igv)), gkq_base_ptr, &
7322 : : start=[1, 1, 1, 1, ik_ibz_file, 1], &
7323 [ # # # # ]: 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7324 [ # # ]: 0 : NCF_CHECK(ncerr)
7325 : : end do
7326 : :
7327 [ # # ]: 0 : do my_iq=1, gqk%my_nq
7328 : 0 : iq_glob = my_iq + gqk%my_qstart - 1
7329 : :
7330 [ # # ]: 0 : if (state_kq(ik_glob, iq_glob) /= GSTORE_KQ_MISSING) then
7331 : : ! Already GSTORE_KQ_COMPUTED (q in IBZ_k): keep the on-disk value unchanged.
7332 [ # # # # : 0 : gkq_rot(:,:,:,iq_glob,:) = gkq_base(:,:,:,iq_glob,:)
# # # # ]
7333 : 0 : cycle
7334 : : end if
7335 : :
7336 [ # # ]: 0 : qpt = qbz(:, my_iq)
7337 : :
7338 : : ! Search the little group x the row's own COMPUTED q entries for a source match.
7339 : : found_lg = .False.
7340 [ # # ]: 0 : do ii_lg=1,n_lg
7341 : 0 : isym_k = lg_isym(ii_lg); trev_k = lg_itime(ii_lg) - 1
7342 [ # # ]: 0 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
7343 [ # # # # ]: 0 : symrec_eq = transpose(cryst%symrel(:,:,isym_k))
7344 [ # # # # ]: 0 : symrec_eq_kspace = tsign_k * symrec_eq
7345 [ # # ]: 0 : do iq_sym=1, gqk%my_nq
7346 [ # # ]: 0 : if (state_kq(ik_glob, iq_sym + gqk%my_qstart - 1) /= GSTORE_KQ_COMPUTED) cycle
7347 [ # # # # : 0 : qpt_tmp = matmul(symrec_eq_kspace, qbz(:, iq_sym))
# # # # ]
7348 [ # # ]: 0 : if (isamek(qpt, qpt_tmp, g0_q)) then
7349 : 0 : found_lg = .True.; exit
7350 : : end if
7351 : : end do
7352 : 0 : if (found_lg) exit
7353 : : end do
7354 : :
7355 : : msg = sjoin("Pass A: no little-group image of q found among GSTORE_KQ_COMPUTED", &
7356 [ # # ]: 0 : " entries for ik_ibz=", itoa(ik_ibz), " -- IBZ_k does not cover this q's star")
7357 [ # # ]: 0 : ABI_CHECK(found_lg, msg)
7358 : :
7359 [ # # ]: 0 : do isym_combined=1,nsym
7360 [ # # # # : 0 : if (all(cryst%symrec(:,:,isym_combined) == symrec_eq)) exit
# # # # ]
7361 : : end do
7362 [ # # ]: 0 : ABI_CHECK(isym_combined /= nsym + 1, "Cannot find symrec_eq")
7363 : :
7364 : : ! Note on non-uniqueness of (isym_k, iq_sym): when kk_ibz has a non-trivial little group
7365 : : ! (the typical case, not a rare corner case -- measured on the reference test systems
7366 : : ! below, EVERY Pass-A point in diamond and most in AlAs have more than one valid
7367 : : ! candidate, up to ~96 at Gamma), the found_lg search above can match several different
7368 : : ! (isym,itime,iq_sym) triples for the same target q; "first found" is taken arbitrarily.
7369 : : ! Verified this does NOT introduce a gauge/correctness bug: a dedicated diagnostic
7370 : : ! (temporarily instrumented, then removed) recomputed the full reconstruction using EVERY
7371 : : ! valid candidate for a set of known-redundant points on both diamond (4 points, 2-4
7372 : : ! candidates each) and AlAs (2 points), and all candidates agreed with each other to
7373 : : ! numerical noise (~1e-7 to 1e-10) in every case -- i.e. the formula is empirically
7374 : : ! gauge-invariant to this choice, the same way the bra leg's h_isym/phase_h_gs/L_h_gs
7375 : : ! machinery is already known (and was originally designed) to be invariant to which
7376 : : ! (isym_kqS,isym_kqT) kpts_map happens to return. See gstore_symmetrize_status memory for
7377 : : ! the full data. Contrast with dmats_get_star_dmats_at_kpt (m_classify_bands.F90), a
7378 : : ! DIAGNOSTIC-only routine with a structurally identical first-match-wins search that its
7379 : : ! own authors flag as an unverified risk -- that routine has NOT been checked this way and
7380 : : ! is a separate, lower-priority open item (never reached by production gstore_symmetrize).
7381 : :
7382 : : ! -----------------------------------------------------------------
7383 : : ! From here on, reused VERBATIM from the k-star loop below (Bug A /
7384 : : ! h_isym / phase_h_gs / phase_ket_gs / itime_h / dh_mat / mu-rotation
7385 : : ! -- kk_bz == kk_ibz here, the degenerate case, so the formula
7386 : : ! derived for the general k-star case applies unchanged). See the
7387 : : ! k-star loop's own comments for the full derivation.
7388 [ # # ]: 0 : kq_bz_source = kk_ibz + qbz(:, iq_sym)
7389 [ # # ]: 0 : kq_bz_target = kk_bz + qpt
7390 : 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_source, indkk_s)
7391 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (source)")
7392 : 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_target, indkk_t)
7393 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (target)")
7394 : 0 : ikq_ibz_s = indkk_s(1,1); isym_kqS = indkk_s(2,1)
7395 : 0 : ikq_ibz_t = indkk_t(1,1); isym_kqT = indkk_t(2,1)
7396 : 0 : trev_kqS = indkk_s(6,1); trev_kqT = indkk_t(6,1)
7397 [ # # ]: 0 : ABI_CHECK(ikq_ibz_s == ikq_ibz_t, "Source and target k+q map to different IBZ points!")
7398 : :
7399 [ # # ]: 0 : mat_tmp = matmul(transpose(cryst%symrel(:,:,dmats%toinv(1,isym_kqT))), &
7400 [ # # # # : 0 : matmul(symrec_eq, transpose(cryst%symrel(:,:,isym_kqS))))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
7401 [ # # ]: 0 : do h_isym=1,nsym
7402 [ # # # # : 0 : if (all(transpose(cryst%symrel(:,:,h_isym)) == mat_tmp)) exit
# # # # ]
7403 : : end do
7404 [ # # ]: 0 : ABI_CHECK(h_isym /= nsym + 1, "Cannot find little-group element h for the k+q leg")
7405 : :
7406 : 0 : c1_gs = dmats%multable(1, isym_kqS, isym_k)
7407 : : L_h_gs = real(dmats%multable(2:4, isym_kqS, isym_k), dp) &
7408 : : + real(dmats%multable(2:4, c1_gs, dmats%toinv(1,isym_kqT)), dp) &
7409 [ # # # # : 0 : - matmul(real(cryst%symrel(:,:,h_isym), dp), real(dmats%toinv(2:4,isym_kqT), dp))
# # # # #
# # # #
# ]
7410 [ # # ]: 0 : kq_ibz_pt = ebands%kptns(:, ikq_ibz_t)
7411 [ # # ]: 0 : phase_h_gs = exp(cmplx(zero, two_pi * sum(kq_ibz_pt * L_h_gs), dp))
7412 : :
7413 : : ! Pass-A-only companion to phase_ket_gs. The k-star formula below (kk_bz generally
7414 : : ! != kk_ibz) was validated to 100% exact match WITHOUT this extra term. In Pass A,
7415 : : ! kk_bz == kk_ibz identically (the degenerate case), and an extra residual survived
7416 : : ! even after the ket_mat fix: isolated (h_isym==1, scalar-only residual, i.e. exactly
7417 : : ! reproducible by a single global phase -- see gstore_symmetrize_status memory) to be
7418 : : ! a clean function of isym_k and kk_ibz alone: exp(-i*2pi*kk_ibz.w(isym_k)) for an
7419 : : ! integer vector w. Empirically fit w(isym_k) exactly (32/32 points, zero exceptions,
7420 : : ! all 3 distinct ik_ibz/isym_k combinations in the reference test) to
7421 : : ! toinv(2:4,isym_k) -- the SAME single-inverse convention used for L_h_gs's own
7422 : : ! toinv(1,isym_kqT) term, and notably NOT the double-inverse toinv(2:4,toinv(1,isym_k))
7423 : : ! used by the qpt term just above. Plausible reading: the qpt-term's
7424 : : ! toinv(2:4,toinv(1,isym_k)) is the companion to kk_bz = symrec_eq.kk_ibz (the k-star's
7425 : : ! moved k), which in Pass A degenerates to kk_ibz itself, making this term newly
7426 : : ! separate and nonzero instead of staying absorbed into the k-star's single term.
7427 : : phase_ket_gs = exp(cmplx(zero, -two_pi * sum(qpt * real(dmats%toinv(2:4, dmats%toinv(1,isym_k)), dp)), dp)) &
7428 [ # # # # ]: 0 : * exp(cmplx(zero, -two_pi * sum(kk_ibz * real(dmats%toinv(2:4, isym_k), dp)), dp))
7429 : :
7430 : 0 : itime_h = 1 + mod(trev_k + trev_kqS + trev_kqT, 2)
7431 : :
7432 : 0 : h_isym_inv = dmats%toinv(1, h_isym)
7433 [ # # ]: 0 : if (itime_h == 2) then
7434 [ # # # # : 0 : dh_mat = conjg(phase_h_gs) * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
# # # # #
# # # ]
7435 : : else
7436 [ # # # # : 0 : dh_mat = phase_h_gs * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
# # # # #
# # # ]
7437 : : end if
7438 : :
7439 [ # # # # : 0 : if (trev_kqT == 1) dh_mat = conjg(dh_mat)
# # ]
7440 : :
7441 : : ! Ket-leg correction (Pass A only -- k-star never needs this, see below). Unlike k-star
7442 : : ! reconstruction, whose ket is always *derived* via cgtk_rotate from the IBZ wavefunction
7443 : : ! (so ground truth and reconstruction structurally share the same gauge for any degenerate
7444 : : ! ket subspace), Pass A's ket lives AT kk_ibz itself and is read directly from the WFK for
7445 : : ! every q processed there. Ground truth's own independent direct e-ph calculations at
7446 : : ! different q (same k) do not share a common internal gauge for a degenerate ket subspace.
7447 : : ! isym_k stabilizes kk_ibz (drawn from its own little group, by construction), so
7448 : : ! dmats%for_spin(...)(isym_k,...) is a genuine, tabulated (non-placeholder) D-matrix here
7449 : : ! -- unlike the general k-star case, where isym_k need not stabilize anything.
7450 : : !
7451 : : ! Convention: read dmats%for_spin(...)(isym_k,...) DIRECTLY, not the toinv(1,isym_k) slot.
7452 : : ! isym_k here is found purely via the symrel^T convention (little-group membership test),
7453 : : ! and dmats's own array is indexed the same way (symrel^T, per dmats_init's own little-group
7454 : : ! check), so isym_k already names the exact tabulated operation that rotates the ket -- no
7455 : : ! inversion is needed or correct. (Contrast with the BRA correction above, dh_mat: h_isym
7456 : : ! there is defined as a genuine COMPOSITE/residual little-group element of kq_ibz whose
7457 : : ! natural tabulated slot -- per dmats_init's own toinv/multable bookkeeping around
7458 : : ! cgtk_rotate's isym_inv=toinv(isym) workaround -- is toinv(1,h_isym), not h_isym itself;
7459 : : ! that is a property of how h_isym's OWN definition composes with dmats_init's internal
7460 : : ! convention, not a general rule that every dmats lookup needs a toinv step.) The original
7461 : : ! implementation used toinv(1,isym_k) "by analogy" with dh_mat and was validated only on an
7462 : : ! involutory isym_k (toinv(1,isym_k)==isym_k), which cannot distinguish the two conventions.
7463 : : ! Diagnosed by finding a 100%/0% clean split: EVERY point with non-involutory isym_k was
7464 : : ! wrong (needing a genuine unitary matrix fix, not a scalar) while every involutory-isym_k
7465 : : ! point was already exact -- direct, decisive evidence the toinv(1,.) step was the bug.
7466 : 0 : itime_k = trev_k + 1
7467 [ # # # # : 0 : ket_mat = dmats%for_spin(spin)%value(:,:,isym_k,itime_k,ik_ibz)
# # # # #
# # # ]
7468 [ # # # # : 0 : if (trev_k == 1) ket_mat = conjg(ket_mat)
# # ]
7469 : : ! -----------------------------------------------------------------
7470 : :
7471 : : ! Perform symmetrization.
7472 [ # # ]: 0 : do mu=1,gqk%natom3
7473 : 0 : idir = mod(mu-1, 3) + 1; iat = (mu - idir) / 3 + 1
7474 : :
7475 : 0 : iat_eq = cryst%indsym(4, isym_combined, iat)
7476 [ # # ]: 0 : l0 = cryst%indsym(1:3, isym_combined, iat)
7477 [ # # ]: 0 : phase = -two_pi * dot_product(qbz(:, iq_sym), l0)
7478 : 0 : cphase = cmplx(cos(phase), sin(phase), dp)
7479 : :
7480 [ # # ]: 0 : do igv=1,n_gv
7481 [ # # # # ]: 0 : gtmp = zero
7482 [ # # ]: 0 : do idir_eq=1,3
7483 : 0 : mu_eq = idir_eq + (iat_eq - 1) * 3
7484 [ # # # # : 0 : gtmp = gtmp + cphase * symrec_eq(idir, idir_eq) * gkq_base(:,:,mu_eq,iq_sym,igv)
# # ]
7485 : : end do
7486 [ # # # # : 0 : if (trev_k == 1) gtmp = conjg(gtmp)
# # ]
7487 [ # # # # : 0 : gkq_rot(:,:,mu,iq_glob,igv) = matmul(matmul(dh_mat, gtmp), ket_mat)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
7488 : : end do
7489 : : end do
7490 : :
7491 : : end do ! my_iq
7492 : :
7493 : : ! Write the newly reconstructed + copied-through rows back to the netcdf file.
7494 [ # # ]: 0 : do igv=1,n_gv
7495 [ # # ]: 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])
7496 : : ncerr = nf90_put_var(spin_ncid, spin_vid(gv_names(igv)), gkq_rot_ptr, &
7497 : : start=[1, 1, 1, 1, ik_glob, 1], &
7498 [ # # # # ]: 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7499 [ # # ]: 0 : NCF_CHECK(ncerr)
7500 : : end do
7501 [ # # # # ]: 0 : where (state_kq(ik_glob, :) == GSTORE_KQ_MISSING) state_kq(ik_glob, :) = GSTORE_KQ_SYMMETRIZED
7502 : :
7503 [ # # ]: 0 : ABI_FREE(lg_isym)
7504 [ # # ]: 0 : ABI_FREE(lg_itime)
7505 : : end do ! ik_ibz
7506 : : end if ! gstore_sym == 2
7507 : :
7508 [ # # ]: 0 : NCF_CHECK(nf90_sync(spin_ncid))
7509 : :
7510 : : ! Loop over k-points in the IBZ.
7511 [ # # # # ]: 0 : do my_ik=1,gqk%my_nk
7512 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
7513 [ # # ]: 0 : kk_bz = gqk%my_kpts(:, my_ik)
7514 : :
7515 [ # # ]: 0 : if (state_kq(ik_glob, 1) /= GSTORE_KQ_MISSING) then
7516 : : ! Row already fully resolved: either directly COMPUTED (gstore_use_lgk == 0), or
7517 : : ! filled by Pass A above (gstore_sym == 2, mix of COMPUTED and SYMMETRIZED).
7518 [ # # # # : 0 : ABI_CHECK(all(state_kq(ik_glob, :) /= GSTORE_KQ_MISSING), "all state")
# # ]
7519 : 0 : cycle
7520 : : end if
7521 : :
7522 : : ! Symmetry tables for k-point. Using symrel^T convention for k..
7523 : 0 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
7524 : 0 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5, my_ik)
7525 : : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
7526 [ # # ]: 0 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
7527 : 0 : itime_k = trev_k + 1
7528 [ # # ]: 0 : kk_ibz = ebands%kptns(:,ik_ibz)
7529 : :
7530 : : ! Index of the IBZ k-point on disk.
7531 : 0 : ik_ibz_file = kibz2bz(ik_ibz)
7532 : :
7533 : : ! symrec_eq is the SPATIAL rotation (used for atomic-perturbation-direction
7534 : : ! bookkeeping below, which is TR-blind: time reversal does not move atoms.
7535 : : ! symrec_eq_kspace additionally carries the TR sign and is the one that actually relates k-space
7536 : : ! vectors (kk_bz, q) to their IBZ images
7537 [ # # # # ]: 0 : symrec_eq = transpose(cryst%symrel(:,:,isym_k))
7538 [ # # # # ]: 0 : symrec_eq_kspace = tsign_k * symrec_eq
7539 [ # # # # : 0 : ABI_CHECK(isamek(kk_bz, matmul(symrec_eq_kspace, kk_ibz), g0_q), "kk_bz != symrec_eq_kspace kk_ibz")
# # # # #
# ]
7540 : :
7541 [ # # ]: 0 : do isym_combined=1,nsym
7542 [ # # # # : 0 : if (all(cryst%symrec(:,:,isym_combined) == symrec_eq)) exit
# # # # ]
7543 : : end do
7544 [ # # ]: 0 : ABI_CHECK(isym_combined /= nsym + 1, "Cannot find symrec_eq")
7545 : :
7546 : : ! Read g(k_ibz, q) for all q-point in the BZ, for each gvals stream ("gvals", and "gvals_ks" too when gtype == "gwpt").
7547 [ # # ]: 0 : do igv=1,n_gv
7548 [ # # ]: 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])
7549 : : ncerr = nf90_get_var(spin_ncid, spin_vid(gv_names(igv)), gkq_base_ptr, &
7550 : : start=[1, 1, 1, 1, ik_ibz_file, 1], &
7551 [ # # # # ]: 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7552 [ # # ]: 0 : NCF_CHECK(ncerr)
7553 : : end do
7554 : :
7555 : : ! Loop over q-points in the BZ.
7556 [ # # ]: 0 : do my_iq=1, gqk%my_nq
7557 : 0 : iq_glob = my_iq + gqk%my_qstart - 1
7558 : 0 : this_state = state_kq(ik_glob, iq_glob)
7559 [ # # ]: 0 : if (this_state /= GSTORE_KQ_MISSING) cycle
7560 : :
7561 : : ! Symmetry tables for q-point. NB: Using symrec convention for q.
7562 : : !iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
7563 : : !trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5, my_iq)
7564 : : !isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
7565 : : !tsign_q = 1; if (trev_q == 1) tsign_q = -1
7566 : : !qq_ibz = gstore%qibz(:, iq_ibz)
7567 [ # # ]: 0 : qpt = qbz(:, my_iq)
7568 : :
7569 : : ! Find q. Uses symrec_eq_kspace (not symrec_eq): q, like k, is a genuine k-space vector
7570 : : ! that picks up the TR sign under the same combined operation mapping kk_ibz -> kk_bz.
7571 [ # # ]: 0 : do iq_sym=1, gqk%my_nq
7572 : : ! qpt = qpt_tmp + G0_q
7573 [ # # # # : 0 : qpt_tmp = matmul(symrec_eq_kspace, qbz(:, iq_sym)); if (isamek(qpt, qpt_tmp, g0_q)) exit
# # # # #
# ]
7574 : : end do
7575 [ # # ]: 0 : ABI_CHECK(iq_sym /= gqk%my_nq + 1, sjoin("Cannot find:", ktoa(qpt)))
7576 : :
7577 : : ! -----------------------------------------------------------------
7578 : : ! Bug A fix: the bra (electron state at k+q) reaches its target BZ
7579 : : ! point via two composed rotations (isym_k applied to the SOURCE
7580 : : ! bra's own rotation from kq_ibz), while the "true" bra is obtained
7581 : : ! by a single direct rotation from kq_ibz. The two differ by U(h),
7582 : : ! h being the residual element of the little group (stabilizer) of
7583 : : ! kq_ibz. h always stabilizes kq_ibz by construction (never an
7584 : : ! out-of-domain little-group lookup), so the D-matrices already
7585 : : ! tabulated by dmats are valid here. See gstore_symmetrize_status
7586 : : ! memory (session 10) for the full derivation.
7587 [ # # ]: 0 : kq_bz_source = kk_ibz + qbz(:, iq_sym)
7588 [ # # ]: 0 : kq_bz_target = kk_bz + qpt
7589 : 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_source, indkk_s)
7590 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (source)")
7591 : 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_target, indkk_t)
7592 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (target)")
7593 : 0 : ikq_ibz_s = indkk_s(1,1); isym_kqS = indkk_s(2,1)
7594 : 0 : ikq_ibz_t = indkk_t(1,1); isym_kqT = indkk_t(2,1)
7595 : 0 : trev_kqS = indkk_s(6,1); trev_kqT = indkk_t(6,1)
7596 [ # # ]: 0 : ABI_CHECK(ikq_ibz_s == ikq_ibz_t, "Source and target k+q map to different IBZ points!")
7597 : :
7598 : : ! mat_tmp = Srel(toinv(isym_kqT)) . Srel(isym_k) . Srel(isym_kqS), with Srel(S) := symrel(S)^T
7599 : : ! (same k/kq convention as symrec_eq above, i.e. NOT cryst%symrec). h_isym is the isym s.t.
7600 : : ! Srel(h_isym) == mat_tmp.
7601 [ # # ]: 0 : mat_tmp = matmul(transpose(cryst%symrel(:,:,dmats%toinv(1,isym_kqT))), &
7602 [ # # # # : 0 : matmul(symrec_eq, transpose(cryst%symrel(:,:,isym_kqS))))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
7603 [ # # ]: 0 : do h_isym=1,nsym
7604 [ # # # # : 0 : if (all(transpose(cryst%symrel(:,:,h_isym)) == mat_tmp)) exit
# # # # ]
7605 : : end do
7606 [ # # ]: 0 : ABI_CHECK(h_isym /= nsym + 1, "Cannot find little-group element h for the k+q leg")
7607 : :
7608 : : ! Lattice-vector-phase companion to h_isym (bra leg). The rotation-only h_isym search above
7609 : : ! finds the correct isym s.t. Srel(h_isym) matches the literal 3-way rotation product, but
7610 : : ! (analogous to dmats_get_star_dmats's validated S0.g.S0^{-1} + L_h construction) the literal
7611 : : ! Seitz composition Tab(isym_kqS).Tab(isym_k).Tab(isym_kqT)^{-1} generally differs from
7612 : : ! Tab(h_isym) by a residual lattice vector L_h_gs whenever any of isym_kqS/isym_k/isym_kqT is
7613 : : ! non-symmorphic, even when h_isym is the identity rotation. Derived by substituting
7614 : : ! Tab(c1)=T_{-L1}.Tab(isym_kqS).Tab(isym_k) [c1=multable(1,isym_kqS,isym_k), the SAME rotation
7615 : : ! recipe already validated for h_isym itself] into Tab(c1).Tab(toinv(isym_kqT))=T_{L2}.Tab(h_isym),
7616 : : ! then Tab(toinv(isym_kqT)) = Tab(isym_kqT)^{-1}.T_{L0} (L0=toinv(2:4,isym_kqT)), and pushing
7617 : : ! T_{-L0} through Tab(h_isym) (Tab(h).T_v = T_{R(h).v}.Tab(h)). Verified EXACTLY (3000/3000
7618 : : ! random (isym_k,isym_kqS,isym_kqT) triples, zero umklapp) against the literal 3-operator
7619 : : ! Seitz composition computed independently with the EXACT (non-tabulated) group inverse. The
7620 : : ! overall sign was pinned down against a hand-verified counterexample (h_isym=1, needing a
7621 : : ! missing factor of exactly +i).
7622 : 0 : c1_gs = dmats%multable(1, isym_kqS, isym_k)
7623 : : L_h_gs = real(dmats%multable(2:4, isym_kqS, isym_k), dp) &
7624 : : + real(dmats%multable(2:4, c1_gs, dmats%toinv(1,isym_kqT)), dp) &
7625 [ # # # # : 0 : - matmul(real(cryst%symrel(:,:,h_isym), dp), real(dmats%toinv(2:4,isym_kqT), dp))
# # # # #
# # # #
# ]
7626 [ # # ]: 0 : kq_ibz_pt = ebands%kptns(:, ikq_ibz_t)
7627 [ # # ]: 0 : phase_h_gs = exp(cmplx(zero, two_pi * sum(kq_ibz_pt * L_h_gs), dp))
7628 : :
7629 : : ! Companion phase on the KET leg. Even with phase_h_gs above, a residual remained, isolated
7630 : : ! (via h_isym==1 points, where dh_mat=I so phase_h_gs is the only other active correction) to
7631 : : ! be a clean function of isym_k and the TARGET q alone: exp(-i*2pi*qpt.v(isym_k)) for an
7632 : : ! integer vector v. Empirically fit v(isym_k) exactly (100% across all isym_k appearing in
7633 : : ! the reference test, zero exceptions) to toinv(2:4, toinv(1,isym_k)) -- i.e. the
7634 : : ! lattice-vector residual of composing isym_k with its OWN inverse in the OTHER order from
7635 : : ! toinv's own convention (toinv(2:4,isym_k) is for S(isym_k).S(isym_k^{-1}); this needs
7636 : : ! S(isym_k^{-1}).S(isym_k) instead, which only coincides with the former when isym_k is
7637 : : ! self-inverse -- the same class of composition-order mixup fixed in dmats_check_one_k and in
7638 : : ! deriving L_h_gs above). Physical origin not fully pinned down: isym_k plays a role in BOTH
7639 : : ! the ket rotation (kk_bz = symrec_eq.kk_ibz) AND the atomic-perturbation-direction rotation
7640 : : ! via the SAME symrec_eq in the mu-loop below (whose existing cphase/l0 term is dotted with
7641 : : ! the SOURCE q, not the target) -- plausibly this is the missing lattice-vector companion to
7642 : : ! THAT term, evaluated at the target q instead, but this is a plausible reading of the
7643 : : ! empirical formula, not an independently re-derived physical proof (unlike L_h_gs above,
7644 : : ! which was verified against the literal Seitz composition directly). Trust the formula
7645 : : ! (exhaustively validated below); treat the physical narrative as informed conjecture only.
7646 : : !
7647 : : ! Effect of phase_h_gs+phase_ket_gs alone on the gstore_brange 1 4 reference test: raw
7648 : : ! exact-match rate 60.4% -> 91.7%, gauge-invariant unchanged at 100%. NOTE: the remaining 8.3%
7649 : : ! was INITIALLY (wrongly) attributed entirely to expected degenerate-band gauge freedom per
7650 : : ! AGENTS.md -- this was corrected later (see the THIRD correction right below): a Procrustes
7651 : : ! best-fit-unitary check proved EXACT reconstruction is achievable for within-range-degenerate
7652 : : ! bra multiplets, so that mismatch was a real, fixable bug, not gauge freedom. Do not repeat
7653 : : ! that mistake: eigenvalue-degeneracy alone never proves a mismatch is harmless -- check
7654 : : ! whether a single matrix can exactly relate reconstruction to truth first.
7655 [ # # ]: 0 : phase_ket_gs = exp(cmplx(zero, -two_pi * sum(qpt * real(dmats%toinv(2:4, dmats%toinv(1,isym_k)), dp)), dp))
7656 : :
7657 : : ! THIRD correction: dmats%for_spin(h_isym) is the WRONG tabulated matrix for the bra whenever
7658 : : ! h_isym is a non-self-inverse symmetry. Root cause: dmats_init computes D(isym) by calling
7659 : : ! cgtk_rotate with isym_inv=toinv(isym) and a separately-recomputed umklapp g0_inv (a
7660 : : ! documented workaround for cgtk_rotate silently returning D_true(S)^{-1} for non-involutions).
7661 : : ! D(h) and D(toinv(h)) are unitary inverses of each other only up to an EXTRA phase that
7662 : : ! dmats_init's own toinv/multable bookkeeping already knows about (this is exactly what
7663 : : ! dmats_check_one_k's "inv_phase"/"phase_analytic" diagnostic measures and validates) --
7664 : : ! reconstructing D(toinv(h)) from D(h) via a bare conjugate-transpose silently drops that
7665 : : ! phase. Looking up dmats%for_spin(toinv(h_isym)) directly sidesteps this entirely, since
7666 : : ! dmats_init already computed that matrix independently and self-consistently under its own
7667 : : ! label: there is nothing to reconstruct.
7668 : : !
7669 : : ! Earlier sessions gated this substitution behind an empirical "is a correction needed at
7670 : : ! all" heuristic (g0-mismatch OR non-self-inverse-and-degenerate-bra), applying toinv(h_isym)
7671 : : ! only when it fired and h_isym unmodified otherwise. That heuristic is UNNECESSARY: applying
7672 : : ! dmats%for_spin(toinv(h_isym)) unconditionally (i.e. always, regardless of degeneracy or g0)
7673 : : ! reproduces the exact same result on every point where the heuristic previously used
7674 : : ! h_isym directly -- because on the reference test system, no such point exists: every
7675 : : ! non-self-inverse h_isym already satisfied the heuristic's trigger condition. (For
7676 : : ! self-inverse h_isym, toinv(1,h_isym)==h_isym, so the two forms are trivially identical
7677 : : ! regardless.) Verified end-to-end against check_symm.py: byte-for-byte identical results to
7678 : : ! the old conditional form -- 3584/3584 (100.0%) raw+gauge-invariant exact matches on
7679 : : ! gstore_brange 1 4 (max diff 3.66e-7, noise level), 3533/3584 (98.6%) raw==gauge-invariant on
7680 : : ! gstore_brange 1 2 (the residual there is the known, inherent out-of-range-degeneracy
7681 : : ! limitation of truncating the band range, not a bug). See gstore_symmetrize_status memory
7682 : : ! (sessions 14-15) for the full derivation history and this final unconditional-formula
7683 : : ! confirmation.
7684 : : ! TIME-REVERSAL generalization of itime_h (was hardcoded to 1, i.e. always the pure-spatial
7685 : : ! D-matrix slice). The unitary/antiunitary character of a composed operator is a Z2
7686 : : ! homomorphism (same rule dmats_check_one_k's group-multiplication test uses:
7687 : : ! itime3 = 1 + mod((itime1-1)+(itime2-1), 2), Bradley & Cracknell sec. 7.3), extended here
7688 : : ! by associativity to h's three-fold composition toinv(isym_kqT).isym_k.isym_kqS
7689 : : ! (itime(A^{-1}) = itime(A), so toinv(isym_kqT) contributes trev_kqT unchanged). High
7690 : : ! confidence, not yet empirically validated on a TR-nonzero system.
7691 : 0 : itime_h = 1 + mod(trev_k + trev_kqS + trev_kqT, 2)
7692 : :
7693 : : ! HYPOTHESIS (open question, validate empirically -- see gstore_symmetrize_status memory):
7694 : : ! phase_h_gs's lattice-vector phase is built from dmats%multable/toinv, which are
7695 : : ! itime-independent by construction, so its formula should carry over unchanged. But the
7696 : : ! closest validated analogue, dmats_get_star_dmats (m_classify_bands.F90), needs an EXTRA
7697 : : ! conjugation on its own analogous phase whenever itime==2. Applying the same pattern here
7698 : : ! as a first hypothesis; h's composition shape differs from that routine's, so this is not
7699 : : ! a proof, only a well-motivated starting point.
7700 : 0 : h_isym_inv = dmats%toinv(1, h_isym)
7701 [ # # ]: 0 : if (itime_h == 2) then
7702 [ # # # # : 0 : dh_mat = conjg(phase_h_gs) * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
# # # # #
# # # ]
7703 : : else
7704 [ # # # # : 0 : dh_mat = phase_h_gs * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
# # # # #
# # # ]
7705 : : end if
7706 : :
7707 : : ! HYPOTHESIS (open question, validate empirically): pulling D(h) through the outer operator
7708 : : ! that maps ikq_ibz -> kq_bz_target picks up a conjugate exactly when that operator
7709 : : ! (governed by isym_kqT/trev_kqT) is antiunitary -- a flag logically independent of trev_k
7710 : : ! (see 2.4's gtmp conjugation below) and of itime_h (which only selects WHICH tabulated
7711 : : ! matrix to read, not whether the whole assembled dh_mat needs conjugating on top).
7712 [ # # # # : 0 : if (trev_kqT == 1) dh_mat = conjg(dh_mat)
# # ]
7713 : :
7714 : : if (DEBUG_DUMP_DH) then
7715 : : 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, &
7716 : : 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, &
7717 : : qpt, kk_ibz
7718 : : write(790,*) ik_glob, iq_glob, nb, isym_k, h_isym, ikq_ibz_t, isym_kqS, isym_kqT, g0_q, &
7719 : : trev_k, trev_kqS, trev_kqT, itime_h, &
7720 : : real(phase_h_gs), aimag(phase_h_gs), real(phase_ket_gs), aimag(phase_ket_gs), &
7721 : : dmats%for_spin(spin)%value(:,:,h_isym,itime_h,ikq_ibz_t)
7722 : : end if
7723 : : ! -----------------------------------------------------------------
7724 : :
7725 : : ! Perform symmetrization.
7726 [ # # ]: 0 : do mu=1,gqk%natom3
7727 : 0 : idir = mod(mu-1, 3) + 1; iat = (mu - idir) / 3 + 1
7728 : :
7729 : 0 : iat_eq = cryst%indsym(4, isym_combined, iat)
7730 [ # # ]: 0 : l0 = cryst%indsym(1:3, isym_combined, iat)
7731 [ # # ]: 0 : phase = -two_pi * dot_product(qbz(:, iq_sym), l0)
7732 : 0 : cphase = cmplx(cos(phase), sin(phase), dp)
7733 : :
7734 : : ! Per-mu atomic-mapping/phase diagnostic (iat_eq, l0, symrec_eq row, cphase, iq_sym):
7735 : : ! reusable general-purpose dump, not tied to any specific (ik_glob,iq_glob) -- add a
7736 : : ! filter here (e.g. "if (ik_glob==... .and. iq_glob==...)") when tracing one point on a
7737 : : ! large system, to keep mu_debug.csv a manageable size.
7738 : : if (DEBUG_DUMP_DH) then
7739 : : write(792,*) ik_glob, iq_glob, mu, iat, iat_eq, isym_combined, isym_k, ik_ibz, iq_sym, &
7740 : : l0, symrec_eq(idir,1), symrec_eq(idir,2), symrec_eq(idir,3), idir, ik_ibz_file, cphase
7741 : : end if
7742 : :
7743 : : ! Apply the same geometric rotation (cphase/symrec_eq/dh_mat, all independent of which
7744 : : ! gvals stream is being processed) to each stream separately, since gtmp's accumulation
7745 : : ! reads actual matrix-element values from gkq_base.
7746 [ # # ]: 0 : do igv=1,n_gv
7747 [ # # # # ]: 0 : gtmp = zero
7748 [ # # ]: 0 : do idir_eq=1,3
7749 : 0 : mu_eq = idir_eq + (iat_eq - 1) * 3
7750 [ # # # # : 0 : gtmp = gtmp + cphase * symrec_eq(idir, idir_eq) * gkq_base(:,:,mu_eq,iq_sym,igv)
# # ]
7751 : : end do
7752 : : ! HYPOTHESIS (open question, validate empirically): conjugate gtmp before the dh_mat
7753 : : ! multiply whenever the ket leg's own operation (isym_k, trev_k) is antiunitary. Matches
7754 : : ! the "rotate spatially first, conjugate as the last step" pattern used identically by
7755 : : ! cgtk_rotate, pheigvec_rotate, rotate_fqg and dmats_init elsewhere in this codebase.
7756 : : ! Order matters: conjugate gtmp itself, not matmul(dh_mat,gtmp), since dh_mat is complex.
7757 [ # # # # : 0 : if (trev_k == 1) gtmp = conjg(gtmp)
# # ]
7758 : : ! Apply the Bug A correction: left-multiply by D(h) on the bra (m) index.
7759 [ # # # # : 0 : gkq_rot(:,:,mu,iq_glob,igv) = matmul(dh_mat, gtmp)
# # # # #
# # # # #
# # # # #
# # # #
# ]
7760 : 0 : if (DEBUG_DUMP_DH) write(791,*) ik_glob, iq_glob, mu, nb, trev_k, trim(gv_names(igv)), gtmp
7761 : : end do
7762 : : end do
7763 : :
7764 : : end do ! my_iq
7765 : :
7766 : : ! Write the newly computed g_{mn, nu} back to the netcdf file (in-place modification),
7767 : : ! for each gvals stream, and update the entry in state_kq.
7768 [ # # ]: 0 : do igv=1,n_gv
7769 [ # # ]: 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])
7770 : : ncerr = nf90_put_var(spin_ncid, spin_vid(gv_names(igv)), gkq_rot_ptr, &
7771 : : start=[1, 1, 1, 1, ik_glob, 1], &
7772 [ # # # # ]: 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7773 [ # # ]: 0 : NCF_CHECK(ncerr)
7774 : : end do
7775 [ # # ]: 0 : state_kq(ik_glob, :) = GSTORE_KQ_SYMMETRIZED
7776 : : end do ! my_ik
7777 : : end associate
7778 : :
7779 : : ! Update state_kq for this spin.
7780 [ # # ]: 0 : ncerr = nf90_put_var(ncid, vid("gstore_glob_state_kqs"), state_kq, start=[1,1,spin])
7781 [ # # ]: 0 : NCF_CHECK(ncerr)
7782 : :
7783 [ # # ]: 0 : ABI_FREE(qbz)
7784 [ # # ]: 0 : ABI_FREE(gkq_base)
7785 [ # # ]: 0 : ABI_FREE(gkq_rot)
7786 [ # # ]: 0 : ABI_FREE(state_kq)
7787 [ # # ]: 0 : ABI_FREE(gtmp)
7788 [ # # ]: 0 : ABI_FREE(dh_mat)
7789 [ # # ]: 0 : ABI_FREE(ket_mat)
7790 : : end do ! my_is
7791 : :
7792 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
7793 : : if (DEBUG_DUMP_DH) close(789)
7794 : : if (DEBUG_DUMP_DH) close(790)
7795 : : if (DEBUG_DUMP_DH) close(791)
7796 : : if (DEBUG_DUMP_DH) close(792)
7797 : :
7798 [ # # ]: 0 : ABI_FREE(kibz2bz)
7799 : 0 : call gstore%free()
7800 : :
7801 : 0 : 100 call dmats%free()
7802 : 0 : call xmpi_barrier(comm)
7803 [ # # # # : 0 : call wrtout(units, " Symmetrization completed successfully.")
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
7804 : :
7805 : : contains
7806 : 0 : integer function vid(var_name)
7807 : : character(len=*),intent(in) :: var_name
7808 : 0 : vid = nctk_idname(ncid, var_name)
7809 : : end function vid
7810 : :
7811 : 0 : integer function spin_vid(var_name)
7812 : : character(len=*),intent(in) :: var_name
7813 : 0 : spin_vid = nctk_idname(spin_ncid, var_name)
7814 : : end function spin_vid
7815 : :
7816 : : end subroutine gstore_symmetrize
7817 : : !!***
7818 : :
7819 [ - + - - : 78498 : end module m_gstore
+ + - + +
- - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - + ]
7820 : : !!***
|
