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 : : real(dp) :: weight_q, cpu, wall, gflops
3045 : : type(gqk_t),pointer :: gqk
3046 : : type(crystal_t),pointer :: cryst
3047 : : !arrays
3048 : 3 : integer,allocatable :: map_kq(:,:), gtmp(:,:)
3049 : : real(dp) :: qpt(3), pp(3), kk(3)
3050 : : !----------------------------------------------------------------------
3051 : :
3052 : 3 : call cwtime(cpu, wall, gflops, "start")
3053 : :
3054 : : ! TODO: These loops can be parallelized using bsum_comm and pert_comm if needed.
3055 [ + + + + : 237 : bks_mask = .False.; cryst => gstore%cryst
+ + ]
3056 : 3 : ebands_kptopt = gstore%ebands%kptopt
3057 : 3 : mpw = 0; gmax = 0
3058 : :
3059 [ + + ]: 6 : do my_is=1,gstore%my_nspins
3060 : 3 : gqk => gstore%gqk(my_is); spin = gstore%my_spins(my_is)
3061 : :
3062 : : ! These are the first and last band indices used in the sum over states (possibly MPI-distributed)
3063 : 3 : b1 = my_bsum_start(spin); b2 = my_bsum_stop(spin)
3064 : :
3065 : : ! Stop if dtset%nband < gstore%nband before sigfaulting.
3066 [ - + ]: 3 : ABI_CHECK_ILEQ(gqk%bstop_k, mband, "bstop_k should be smaller that mband present in WFK")
3067 [ - + ]: 3 : ABI_CHECK_ILEQ(gqk%bstop_kq, mband, "bstop_kq should be smaller that mband present in WFK")
3068 [ - + ]: 3 : ABI_CHECK_ILEQ(b2, mband, "max band index in sum should be smaller that mband present in WFK")
3069 : :
3070 [ - + + - : 9 : ABI_MALLOC(map_kq, (6, gqk%my_nk))
+ - + - -
+ - + ]
3071 : :
3072 [ + + ]: 8 : do my_ik=1,gqk%my_nk
3073 [ + + ]: 20 : kk = gqk%my_kpts(:, my_ik); ik_ibz = gqk%my_k2ibz(1, my_ik)
3074 : :
3075 : : ! We need the image of this k-point in the IBZ for the incoming state |psi_nk>.
3076 [ + + ]: 33 : bks_mask(gqk%bstart_k:gqk%bstop_k, ik_ibz, spin) = .True.
3077 : :
3078 : : ! We also need the image of k+q in the IBZ for the outgoing state <psi_mkq|.
3079 [ + + ]: 104 : do my_iq=1,gqk%my_nq
3080 : 96 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3081 [ - + ]: 96 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, 1, kk, map_kq, qpt=qpt) /= 0) then
3082 : 0 : ABI_ERROR(sjoin("Cannot map k+q to IBZ with qpt:", ktoa(qpt)))
3083 : : end if
3084 : 96 : ikq_ibz = map_kq(1, 1)
3085 [ + + ]: 1125 : bks_mask(gqk%bstart_kq:gqk%bstop_kq, ikq_ibz, spin) = .True.
3086 : : end do ! my_iq
3087 : :
3088 : : end do ! my_ok
3089 : :
3090 : : ! We also need the image of k-p in the IBZ for the pp wavevectors treated by this MPI rank.
3091 : : ! These states are summed over so use b1 and b2.
3092 [ + + ]: 83 : do ipp_bz=my_pp_start_spin(spin), my_pp_stop_spin(spin)
3093 [ + + ]: 320 : pp = pp_mesh%bz(:,ipp_bz)
3094 [ + + - + ]: 320 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, map_kq, qpt=-pp) /= 0) then
3095 : 0 : ABI_ERROR(sjoin("Cannot map k-p to IBZ with qpt:", ktoa(qpt), "and pp:", ktoa(pp)))
3096 : : end if
3097 : :
3098 [ + + ]: 179 : do my_ik=1,gqk%my_nk
3099 : 96 : ikq_ibz = map_kq(1, my_ik)
3100 [ + + ]: 1120 : bks_mask(b1:b2, ikq_ibz, spin) = .True.
3101 : : ! Compute g-sphere, returns onpw. Note istwfk == 1.
3102 [ + + ]: 384 : kk = gqk%my_kpts(:, my_ik)
3103 [ + + - + ]: 384 : call get_kg(kk-pp, istwfk1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3104 [ - + ]: 176 : ABI_FREE(gtmp)
3105 : : end do
3106 : : end do ! ipp_bz
3107 : :
3108 : : ! We also need the image of k+q-p in the IBZ for the pp wavevectors treated by this MPI rank.
3109 : : ! These states are summed over so use b1 and b2.
3110 [ + + ]: 83 : do my_iq=1,gqk%my_nq
3111 : 80 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3112 : :
3113 [ + + ]: 4307 : do ipp_bz=my_pp_start_spin(spin), my_pp_stop_spin(spin)
3114 [ + + ]: 16896 : pp = pp_mesh%bz(:,ipp_bz)
3115 : :
3116 [ + + - + ]: 16896 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, map_kq, qpt=qpt-pp) /= 0) then
3117 : 0 : ABI_ERROR(sjoin("Cannot map k+q-p to IBZ with qpt:", ktoa(qpt), "and pp:", ktoa(pp)))
3118 : : end if
3119 : :
3120 [ + + ]: 8656 : do my_ik=1,gqk%my_nk
3121 : 4352 : ikq_ibz = map_kq(1, my_ik)
3122 [ + + ]: 48384 : bks_mask(b1:b2, ikq_ibz, spin) = .True.
3123 : : ! Compute g-sphere, returns onpw. Note istwfk = 1.
3124 [ + + ]: 17408 : kk = gqk%my_kpts(:, my_ik)
3125 [ + + - + ]: 17408 : call get_kg(kk+qpt-pp, istwfk1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3126 [ - + ]: 8576 : ABI_FREE(gtmp)
3127 : : end do
3128 : : end do ! ipp_bz
3129 : :
3130 : : end do ! my_iq
3131 : :
3132 [ - + ]: 6 : ABI_FREE(map_kq)
3133 : : end do ! my_is
3134 : :
3135 : 3 : my_mpw = mpw; call xmpi_max(my_mpw, mpw, gstore%comm, ierr)
3136 : 3 : my_gmax = gmax; call xmpi_max(my_gmax, gmax, gstore%comm, ierr)
3137 : :
3138 : : ! TODO
3139 : : !call gstore%get_mpw_gmax(ecut, mpw, gmax, pp_max=)
3140 : :
3141 : 3 : call wrtout(std_out, sjoin(' Optimal value of mpw: ', itoa(mpw)))
3142 : 3 : call cwtime_report(" gstore_fill_bks_mask_pp_mesh", cpu, wall, gflops)
3143 : :
3144 [ - + ]: 3 : end subroutine gstore_fill_bks_mask_pp_mesh
3145 : : !!***
3146 : :
3147 : : !----------------------------------------------------------------------
3148 : :
3149 : : !!****f* m_gstore/gstore_get_mpw_gmax
3150 : : !! NAME
3151 : : !! gstore_get_mpw_gmax
3152 : : !!
3153 : : !! FUNCTION
3154 : : !! Compute the maximum number of PWs for all possible k+q treated.
3155 : : !!
3156 : : !! INPUTS
3157 : : !!
3158 : : !! OUTPUT
3159 : : !!
3160 : : !! SOURCE
3161 : :
3162 : 12 : subroutine gstore_get_mpw_gmax(gstore, ecut, mpw, gmax, pp_max)
3163 : :
3164 : : !Arguments ------------------------------------
3165 : : class(gstore_t),intent(in) :: gstore
3166 : : real(dp),intent(in) :: ecut
3167 : : integer,intent(out) :: mpw, gmax(3)
3168 : : integer,optional,intent(in) :: pp_max
3169 : :
3170 : : !Local variables-------------------------------
3171 : : integer,parameter :: istwfk1 = 1
3172 : : integer :: my_is, my_ik, my_iq, spin, onpw, ierr, my_mpw, ipx, ipy, ipz, nprocs, my_rank, pp_max__ !, cnt, i1, i2, i3,
3173 : : real(dp) :: weight_q, cpu, wall, gflops
3174 : : !arrays
3175 : : integer :: my_gmax(3)
3176 : 12 : integer,allocatable :: gtmp(:,:)
3177 : : real(dp) :: kk(3), kq(3), qpt(3), pp(3) !, kq_max(3)
3178 : : !----------------------------------------------------------------------
3179 : :
3180 : : ! TODO: This is an hotspot due to the double loop over k and q. Should use a geometrical approach to compute mpw and gmax.
3181 : 12 : call wrtout(std_out, " Computing mpw. This may take some time for dense k/q meshes...", pre_newlines=1)
3182 : 12 : call cwtime(cpu, wall, gflops, "start")
3183 : :
3184 : 12 : nprocs = xmpi_comm_size(gstore%comm); my_rank = xmpi_comm_rank(gstore%comm)
3185 : 12 : mpw = 0; gmax = 0
3186 [ - + ]: 12 : pp_max__ = 0; if (present(pp_max)) pp_max__ = pp_max
3187 : :
3188 [ + + ]: 24 : do my_is=1,gstore%my_nspins
3189 : 12 : associate (gqk => gstore%gqk(my_is))
3190 : 12 : spin = gstore%my_spins(my_is)
3191 [ + + ]: 330 : do my_ik=1,gqk%my_nk
3192 [ + + ]: 1272 : kk = gqk%my_kpts(:, my_ik)
3193 : :
3194 : : ! Compute g-sphere, returns onpw. Note istwfk == 1.
3195 [ - + ]: 318 : call get_kg(kk, istwfk1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3196 [ - + ]: 318 : ABI_FREE(gtmp)
3197 : :
3198 [ + + ]: 74185 : do my_iq=1,gqk%my_nq
3199 : 73855 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3200 [ + + ]: 295420 : kq = kk + qpt
3201 : :
3202 : : ! TODO: g0 umklapp here can enter into play! gmax could not be large enough!
3203 [ + + ]: 148028 : do ipz=-pp_max__,pp_max__
3204 [ + + ]: 221565 : do ipy=-pp_max__,pp_max__
3205 [ + + ]: 221565 : do ipx=-pp_max__,pp_max__
3206 [ + + ]: 295420 : pp = [ipx, ipy, ipz] * half
3207 [ + + - + ]: 295420 : call get_kg(kq - pp, 1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3208 [ - + ]: 147710 : ABI_FREE(gtmp)
3209 : : end do
3210 : : end do
3211 : : end do
3212 : : end do ! my_iq
3213 : :
3214 : : end do ! my_ik
3215 : : end associate
3216 : : end do ! my_is
3217 : :
3218 : 12 : my_mpw = mpw; call xmpi_max(my_mpw, mpw, gstore%comm, ierr)
3219 : 12 : my_gmax = gmax; call xmpi_max(my_gmax, gmax, gstore%comm, ierr)
3220 : :
3221 : 12 : call wrtout(std_out, sjoin(' Optimal value of mpw: ', itoa(mpw), "with gmax:", ltoa(gmax)))
3222 : 12 : call cwtime_report(" gstore_get_mpw_gmax", cpu, wall, gflops)
3223 : :
3224 [ - + ]: 12 : end subroutine gstore_get_mpw_gmax
3225 : : !!***
3226 : :
3227 : : !----------------------------------------------------------------------
3228 : :
3229 : : !!****f* m_gstore/gstore_free
3230 : : !! NAME
3231 : : !! gstore_free
3232 : : !!
3233 : : !! FUNCTION
3234 : : !! Free dynamic memory in gstore_t.
3235 : : !!
3236 : : !! SOURCE
3237 : :
3238 : 24 : subroutine gstore_free(gstore)
3239 : :
3240 : : !Arguments ------------------------------------
3241 : : class(gstore_t),intent(inout) :: gstore
3242 : :
3243 : : !Local variables-------------------------------
3244 : : integer :: my_is
3245 : : !----------------------------------------------------------------------
3246 : :
3247 [ + + ]: 48 : do my_is=1,gstore%my_nspins
3248 : 48 : call gstore%gqk(my_is)%free()
3249 : : end do
3250 [ + - + + : 48 : ABI_SFREE(gstore%gqk)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ ]
3251 : :
3252 [ - + ]: 24 : ABI_SFREE(gstore%delta_ef_kibz_spin)
3253 [ + - ]: 24 : ABI_SFREE(gstore%qibz)
3254 [ + - ]: 24 : ABI_SFREE(gstore%wtq)
3255 [ + - ]: 24 : ABI_SFREE(gstore%my_spins)
3256 [ + - ]: 24 : ABI_SFREE(gstore%brange_k_spin)
3257 [ + - ]: 24 : ABI_SFREE(gstore%brange_kq_spin)
3258 [ + - ]: 24 : ABI_SFREE(gstore%glob_nk_spin)
3259 [ + - ]: 24 : ABI_SFREE(gstore%glob_nq_spin)
3260 [ + - ]: 24 : ABI_SFREE(gstore%kglob2bz)
3261 [ + - ]: 24 : ABI_SFREE(gstore%kbz2ibz)
3262 [ + - ]: 24 : ABI_SFREE(gstore%erange_spin)
3263 [ + - ]: 24 : ABI_SFREE(gstore%qbz)
3264 [ + - ]: 24 : ABI_SFREE(gstore%kbz)
3265 : :
3266 [ - + ]: 24 : if (gstore%has_wannier) then
3267 : 0 : call gstore%ebands%free()
3268 [ # # # # : 0 : ABI_FREE_SCALAR(gstore%ebands)
# # # # #
# # # # #
# # # # #
# # # #
# ]
3269 : : nullify(gstore%ebands)
3270 : : end if
3271 : :
3272 : 24 : call gstore%krank_ibz%free()
3273 : 24 : call gstore%qrank_ibz%free()
3274 : 24 : gstore%with_cplex = -1
3275 : :
3276 : 24 : end subroutine gstore_free
3277 : : !!***
3278 : :
3279 : : !----------------------------------------------------------------------
3280 : :
3281 : : !!****f* m_gstore/gqk_myqpt
3282 : : !! NAME
3283 : : !! gqk_myqpt
3284 : : !!
3285 : : !! FUNCTION
3286 : : !! Return the weight_q and the reduced coordinates of the q-point from the local index my_iq.
3287 : : !!
3288 : : !! INPUTS
3289 : : !!
3290 : : !! OUTPUT
3291 : : !!
3292 : : !! SOURCE
3293 : :
3294 : 77422 : pure subroutine gqk_myqpt(gqk, my_iq, gstore, weight_q, qpt)
3295 : :
3296 : : !Arguments ------------------------------------
3297 : : class(gqk_t),intent(in) :: gqk
3298 : : class(gstore_t),intent(in) :: gstore
3299 : : integer,intent(in) :: my_iq
3300 : : real(dp),intent(out) :: weight_q, qpt(3)
3301 : :
3302 : : !Local variables ------------------------------
3303 : : integer :: iq_ibz, isym_q, trev_q, tsign_q, g0_q(3)
3304 : : logical :: isirr_q
3305 : : !----------------------------------------------------------------------
3306 : :
3307 : : ! Symmetry tables for q-points.
3308 : 77422 : iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
3309 [ + + ]: 309688 : trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5, my_iq)
3310 : : isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
3311 [ - + ]: 77422 : tsign_q = 1; if (trev_q == 1) tsign_q = -1
3312 : :
3313 : : ! NB: Use symrec convention for q
3314 [ + + + + : 2167816 : qpt = tsign_q * matmul(gstore%cryst%symrec(:,:,isym_q), gstore%qibz(:, iq_ibz)) + g0_q
+ + + + +
- + - +
+ ]
3315 : :
3316 : 0 : select case(gstore%qzone)
3317 : : case ("ibz")
3318 : 0 : weight_q = gstore%wtq(iq_ibz)
3319 : : case ("bz")
3320 [ - + - ]: 77422 : weight_q = one / gstore%nqbz
3321 : : end select
3322 : :
3323 : 77422 : end subroutine gqk_myqpt
3324 : : !!***
3325 : :
3326 : : !----------------------------------------------------------------------
3327 : :
3328 : : !!****f* m_gstore/gqk_dbldelta_qpt
3329 : : !! NAME
3330 : : !! gqk_dbldelta_qpt
3331 : : !!
3332 : : !! FUNCTION
3333 : : !! Note that k/q weights are not included in dbl_delta_q
3334 : : !!
3335 : : !! INPUTS
3336 : : !!
3337 : : !! OUTPUT
3338 : : !!
3339 : : !! SOURCE
3340 : :
3341 : 0 : subroutine gqk_dbldelta_qpt(gqk, my_iq, gstore, eph_intmeth, eph_fsmear, qpt, weight_q, dbl_delta_q)
3342 : :
3343 : : !Arguments ------------------------------------
3344 : : class(gqk_t),intent(in) :: gqk
3345 : : class(gstore_t),target,intent(inout) :: gstore
3346 : : integer,intent(in) :: my_iq, eph_intmeth
3347 : : real(dp),intent(in) :: eph_fsmear
3348 : : real(dp),intent(out) :: qpt(3), weight_q, dbl_delta_q(gqk%nb_kq, gqk%nb_k, gqk%my_nk)
3349 : :
3350 : : !Local variables ------------------------------
3351 : : !scalars
3352 : : real(dp), parameter :: min_smear = tol9
3353 : : integer :: nb_k, nb_kq, nkbz, spin, my_ik, ib, ib1, ib2, band1, band2, nesting
3354 : : integer :: ik_ibz, isym_k, trev_k, tsign_k, g0_k(3)
3355 : : integer :: ikq_ibz, isym_kq, trev_kq, tsign_kq, g0_kq(3), ii, i1, i2, i3, cnt, ik_bz, ltetra
3356 : : real(dp) :: g1, g2, sigma !, weight_k !, cpu, wall, gflops
3357 : : logical :: isirr_k, isirr_kq, use_adaptive
3358 : : type(ebands_t), pointer :: ebands
3359 : : type(crystal_t), pointer :: cryst
3360 : 0 : type(krank_t) :: my_krank
3361 : : !arrays
3362 : : integer :: nge(3), ngw(3)
3363 : 0 : integer,allocatable :: my_kqmap(:,:), kmesh_map(:,:)
3364 : 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)
3365 : 0 : real(dp),allocatable :: eig_k(:,:), eig_kq(:,:), kmesh(:,:), wght_bz(:,:,:)
3366 : : !----------------------------------------------------------------------
3367 : :
3368 : 0 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq; nkbz = gstore%nkbz; spin = gqk%spin
3369 : 0 : ebands => gstore%ebands; cryst => gstore%cryst
3370 : :
3371 [ # # ]: 0 : ABI_CHECK_IEQ(nb_k, nb_kq, "gqk_dbldelta_qpt does not support nb_k != nb_kq")
3372 : :
3373 : 0 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3374 : :
3375 : : ! The double delta with tetra is ill-defined for q == 0. In this case we fall back to gaussian.
3376 [ # # # # : 0 : nesting = merge(1, 0, abs(eph_intmeth) == 2 .and. all(abs(qpt) < tol12))
# # # # ]
3377 : :
3378 [ # # # # ]: 0 : rlatt = gstore%ebands%kptrlatt; call matr3inv(rlatt, klatt)
3379 [ # # ]: 0 : kmesh_cartvec(:, 1) = cryst%gprimd(:,1)*klatt(1,1) + cryst%gprimd(:,2)*klatt(2,1) + cryst%gprimd(:,3)*klatt(3,1)
3380 [ # # ]: 0 : kmesh_cartvec(:, 2) = cryst%gprimd(:,1)*klatt(1,2) + cryst%gprimd(:,2)*klatt(2,2) + cryst%gprimd(:,3)*klatt(3,2)
3381 [ # # ]: 0 : kmesh_cartvec(:, 3) = cryst%gprimd(:,1)*klatt(1,3) + cryst%gprimd(:,2)*klatt(2,3) + cryst%gprimd(:,3)*klatt(3,3)
3382 : : ! TODO: It seems that two_pi is not needed here!
3383 : :
3384 [ # # # # ]: 0 : if (abs(eph_intmeth) == 1 .or. nesting /= 0) then
3385 [ # # # # ]: 0 : use_adaptive = eph_fsmear < zero .or. abs(eph_intmeth) == 2
3386 : : if (use_adaptive) then
3387 [ # # ]: 0 : ABI_CHECK(allocated(gqk%vnk_cart_ibz), "vnk_cart_ibz should be allocated when use_adaptive is .True.")
3388 : : end if
3389 : :
3390 : : ! Find k + q in the IBZ for all my k-points.
3391 [ # # # # : 0 : ABI_MALLOC(my_kqmap, (6, gqk%my_nk))
# # # # #
# # # ]
3392 [ # # ]: 0 : if (kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, my_kqmap, qpt=qpt) /= 0) then
3393 : 0 : ABI_ERROR(sjoin("Cannot map k+q to IBZ with qpt:", ktoa(qpt)))
3394 : : end if
3395 : :
3396 : : ! Init default sigma
3397 : 0 : sigma = eph_fsmear
3398 : :
3399 [ # # ]: 0 : do my_ik=1,gqk%my_nk
3400 : 0 : kk = gqk%my_kpts(:, my_ik)
3401 : :
3402 : 0 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
3403 [ # # ]: 0 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5, my_ik)
3404 [ # # # # : 0 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
# # # # ]
3405 [ # # ]: 0 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
3406 : :
3407 : 0 : ikq_ibz = my_kqmap(1, my_ik); isym_kq = my_kqmap(2, my_ik)
3408 [ # # ]: 0 : trev_kq = my_kqmap(6, my_ik); g0_kq = my_kqmap(3:5, my_ik)
3409 [ # # # # : 0 : isirr_kq = (isym_kq == 1 .and. trev_kq == 0 .and. all(g0_kq == 0))
# # # # ]
3410 [ # # ]: 0 : tsign_kq = 1; if (trev_kq == 1) tsign_kq = -1
3411 : :
3412 [ # # ]: 0 : if (use_adaptive) then
3413 : : ! If k or k+q is not in the IBZ, we need to recostruct the value by symmetry using v(Sq) = S v(q).
3414 : : ! Use transpose(R) because we are using the tables for the wavefunctions
3415 : : ! In this case listkk has been called with symrec and use_symrec=False
3416 : : ! so q_bz = S^T q_ibz where S is the isym_kq symmetry
3417 [ # # # # ]: 0 : vb_k = gqk%vnk_cart_ibz(:,:,ik_ibz)
3418 [ # # # # ]: 0 : vb_kq = gqk%vnk_cart_ibz(:,:,ikq_ibz)
3419 : :
3420 [ # # ]: 0 : if (.not. isirr_k) then
3421 [ # # ]: 0 : do ib=1,nb_k
3422 [ # # # # ]: 0 : vb_k(:,ib) = tsign_k * matmul(transpose(cryst%symrel_cart(:,:,isym_k)), vb_k(:,ib))
3423 : : end do
3424 : : end if
3425 [ # # ]: 0 : if (.not. isirr_kq) then
3426 [ # # ]: 0 : do ib=1,nb_kq
3427 [ # # # # ]: 0 : vb_kq(:,ib) = tsign_kq * matmul(transpose(cryst%symrel_cart(:,:,isym_kq)), vb_kq(:,ib))
3428 : : end do
3429 : : end if
3430 : : end if
3431 : :
3432 [ # # ]: 0 : do ib2=1,nb_k
3433 : 0 : band2 = ib2 + gqk%bstart_k - 1
3434 [ # # ]: 0 : if (use_adaptive) then
3435 [ # # # # : 0 : sigma = max(maxval([(abs(dot_product(vb_k(:, ib2), kmesh_cartvec(:,ii))), ii=1,3)]), min_smear)
# # # # #
# ]
3436 : : !write(std_out, *)"sigma:", sigma * Ha_eV
3437 : : end if
3438 : 0 : g2 = gaussian(ebands%eig(band2, ik_ibz, spin) - ebands%fermie, sigma)
3439 : :
3440 [ # # ]: 0 : do ib1=1,nb_kq
3441 : 0 : band1 = ib1 + gqk%bstart_kq - 1
3442 [ # # ]: 0 : if (use_adaptive) then
3443 [ # # # # : 0 : sigma = max(maxval([(abs(dot_product(vb_kq(:, ib1), kmesh_cartvec(:,ii))), ii=1,3)]), min_smear)
# # # # #
# ]
3444 : : end if
3445 : 0 : g1 = gaussian(ebands%eig(band1, ikq_ibz, spin) - ebands%fermie, sigma)
3446 : 0 : dbl_delta_q(ib1, ib2, my_ik) = g1 * g2 ! / fs%nktot
3447 : : end do
3448 : :
3449 : : end do
3450 : : end do
3451 : :
3452 [ # # ]: 0 : ABI_FREE(my_kqmap)
3453 : :
3454 [ # # ]: 0 : else if (abs(eph_intmeth) == 2) then
3455 : :
3456 [ # # ]: 0 : ABI_CHECK(isdiagmat(ebands%kptrlatt), "kptrlatt must be diagonal when tetra is used.")
3457 [ # # ]: 0 : ABI_CHECK(ebands%nshiftk == 1, "nshiftk must be 1 when tetra is used")
3458 : 0 : nge = get_diag(ebands%kptrlatt); ngw = nge
3459 [ # # # # : 0 : ABI_CHECK_IEQ(nkbz, product(nge(1:3)), "Wrong nge")
# # ]
3460 : :
3461 : : ! Compute eig_k and eig_kq in full BZ for the relevant bands around Ef.
3462 [ # # # # : 0 : ABI_MALLOC(kmesh, (3, nkbz))
# # # # #
# # # ]
3463 [ # # # # : 0 : ABI_MALLOC(eig_k, (nb_k, nkbz))
# # # # #
# # # # #
# # ]
3464 [ # # # # : 0 : ABI_MALLOC(eig_kq, (nb_kq, nkbz))
# # # # #
# # # # #
# # ]
3465 : :
3466 : : ! Technical problems:
3467 : : !
3468 : : ! 1) libtetrabz works with the BZ and assumes a certaing ordering of the k-points (see below)
3469 : : ! so we have to fill the array with eig_k and eig_kq from the IBZ by remapping the libtetra kk
3470 : : ! to the Abinit IBZ
3471 : :
3472 : : ! 2) The dbldelta weights are given in the BZ, while the caller requires weights for k in the IBZ
3473 : : ! and moreover only for the IBZ k-point treated by this MPI proc.
3474 : :
3475 : 0 : ik_bz = 0
3476 [ # # ]: 0 : do i3=0,nge(3) - 1
3477 [ # # ]: 0 : do i2=0,nge(2) - 1
3478 [ # # ]: 0 : do i1=0,nge(1) - 1
3479 : 0 : ik_bz = ik_bz + 1
3480 [ # # ]: 0 : kk = ([i1, i2, i3] + ebands%shiftk(:, 1)) / nge(:)
3481 [ # # ]: 0 : kmesh(:, ik_bz) = kk
3482 : : end do
3483 : : end do
3484 : : end do
3485 : :
3486 : : ! Map libtetra BZ mesh to IBZ and fill eig_k
3487 : : !call cwtime(cpu, wall, gflops, "start")
3488 [ # # # # : 0 : ABI_MALLOC(kmesh_map, (6, nkbz))
# # # # #
# # # ]
3489 : :
3490 : : ! Find correspondence between libtetra mesh and the IBZ.
3491 [ # # ]: 0 : if (kpts_map("symrec", ebands%kptopt, cryst, gstore%krank_ibz, nkbz, kmesh, kmesh_map) /= 0) then
3492 : 0 : ABI_ERROR("Cannot map libtetra mesh to IBZ")
3493 : : end if
3494 : :
3495 [ # # ]: 0 : do ik_bz=1,nkbz
3496 : 0 : ik_ibz = kmesh_map(1, ik_bz)
3497 [ # # ]: 0 : eig_k(:, ik_bz) = ebands%eig(gqk%bstart_k:gqk%bstop_k, ik_ibz, spin) - ebands%fermie
3498 : : end do
3499 : :
3500 : : ! Map libtetra BZ mesh + q to IBZ and fill eig_kq.
3501 [ # # ]: 0 : if (kpts_map("symrec", ebands%kptopt, cryst, gstore%krank_ibz, nkbz, kmesh, kmesh_map, qpt=qpt) /= 0) then
3502 : 0 : ABI_ERROR(sjoin("Cannot map libtetra k+q to IBZ with qpt:", ktoa(qpt)))
3503 : : end if
3504 : :
3505 [ # # ]: 0 : do ik_bz=1,nkbz
3506 : 0 : ikq_ibz = kmesh_map(1, ik_bz)
3507 [ # # ]: 0 : eig_kq(:, ik_bz) = ebands%eig(gqk%bstart_kq:gqk%bstop_kq, ikq_ibz, spin) - ebands%fermie
3508 : : end do
3509 : :
3510 [ # # ]: 0 : ABI_FREE(kmesh_map)
3511 : : !call cwtime_report(" kmesh_map", cpu, wall, gflops)
3512 : :
3513 : : ! Call libtetra routine to compute weights for double delta integration.
3514 : : ! Note that libtetra assumes Ef set to zero.
3515 : : ! TODO: Average weights over degenerate states?
3516 : : ! NB: This is a bottleneck, can pass comm_kp
3517 : :
3518 : : ! Select option for double delta with tetra.
3519 : : ! 2 for the optimized tetrahedron method.
3520 : : ! -2 for the linear tetrahedron method.
3521 : 0 : ltetra = 0
3522 [ # # ]: 0 : if (eph_intmeth == 2) ltetra = 2
3523 [ # # ]: 0 : if (eph_intmeth == -2) ltetra = 1
3524 : :
3525 [ # # # # : 0 : ABI_MALLOC(wght_bz, (nb_k, nb_kq, nkbz))
# # # # #
# # # # #
# # # # #
# ]
3526 : 0 : call libtetrabz_dbldelta(ltetra, gstore%cryst%gprimd, nb_k, nge, eig_k, eig_kq, ngw, wght_bz) !, comm=comm)
3527 : : !call cwtime_report(" libtetrabz_dbldelta", cpu, wall, gflops)
3528 : :
3529 : 0 : call my_krank%init(gqk%my_nk, gqk%my_kpts)
3530 : :
3531 : : ! Reindex from full BZ to my set of kpoints and rescale weights.
3532 : 0 : cnt = 0
3533 [ # # ]: 0 : do ik_bz=1,nkbz
3534 : 0 : my_ik = my_krank%get_index(kmesh(:, ik_bz))
3535 [ # # ]: 0 : if (my_ik /= -1) then
3536 [ # # # # ]: 0 : dbl_delta_q(:,:,my_ik) = wght_bz(:,:,ik_bz) * gstore%nkbz
3537 : 0 : cnt = cnt + 1
3538 : : end if
3539 : : end do
3540 : :
3541 : : ! FIXME: BUG if k-point (and q-point) parallelism.
3542 [ # # ]: 0 : ABI_CHECK_IEQ(cnt, gqk%my_nk, sjoin("cnt != my_nk, ", itoa(cnt), itoa(gqk%my_nk)))
3543 : 0 : call my_krank%free()
3544 : : !call cwtime_report(" transfer", cpu, wall, gflops)
3545 : :
3546 [ # # ]: 0 : ABI_FREE(wght_bz)
3547 [ # # ]: 0 : ABI_FREE(kmesh)
3548 [ # # ]: 0 : ABI_FREE(eig_k)
3549 [ # # ]: 0 : ABI_FREE(eig_kq)
3550 : :
3551 : : else
3552 : 0 : ABI_ERROR(sjoin("Invalid eph_intmeth:", itoa(eph_intmeth)))
3553 : : end if
3554 : :
3555 [ # # # # : 0 : end subroutine gqk_dbldelta_qpt
# # ]
3556 : : !!***
3557 : : !----------------------------------------------------------------------
3558 : :
3559 : : !!****f* m_gstore/gqk_free
3560 : : !! NAME
3561 : : !! gqk_free
3562 : : !!
3563 : : !! FUNCTION
3564 : : !! Free dynamic memory in gqk_t instance.
3565 : : !!
3566 : : !! SOURCE
3567 : :
3568 : 24 : subroutine gqk_free(gqk)
3569 : :
3570 : : !Arguments ------------------------------------
3571 : : class(gqk_t),intent(inout) :: gqk
3572 : : !----------------------------------------------------------------------
3573 : :
3574 [ + - ]: 24 : ABI_SFREE(gqk%my_k2ibz)
3575 [ + - ]: 24 : ABI_SFREE(gqk%my_kpts)
3576 [ + - ]: 24 : ABI_SFREE(gqk%my_wtk)
3577 [ + - ]: 24 : ABI_SFREE(gqk%my_q2ibz)
3578 [ + - ]: 24 : ABI_SFREE(gqk%my_q2bz)
3579 [ + - ]: 24 : ABI_SFREE(gqk%my_k2glob)
3580 [ + - ]: 24 : ABI_SFREE(gqk%my_q2glob)
3581 [ + + ]: 24 : ABI_SFREE(gqk%my_wnuq)
3582 [ + + ]: 24 : ABI_SFREE(gqk%my_displ_cart)
3583 [ - + ]: 24 : ABI_SFREE(gqk%my_iv1p_comm)
3584 [ + - ]: 24 : ABI_SFREE(gqk%my_pertcases)
3585 [ + + ]: 24 : ABI_SFREE(gqk%vnk_cart_ibz)
3586 [ - + ]: 24 : ABI_SFREE(gqk%vnk_mat_cart_ibz)
3587 : :
3588 [ + + ]: 24 : ABI_SFREE(gqk%my_g)
3589 [ + + ]: 24 : ABI_SFREE(gqk%my_g2)
3590 [ + + ]: 24 : ABI_SFREE(gqk%my_gdw2)
3591 [ + + ]: 24 : if (gqk%has_both_g) then
3592 [ + + ]: 9 : ABI_SFREE_PTR(gqk%my_g_ks)
3593 [ + + ]: 9 : ABI_SFREE_PTR(gqk%my_g2_ks)
3594 [ + + ]: 9 : ABI_SFREE_PTR(gqk%my_gdw2_ks)
3595 : : end if
3596 : :
3597 : 24 : call gqk%wan%free()
3598 : :
3599 : : ! Free MPI communicators
3600 : 24 : call gqk%kpt_comm%free(); call gqk%qpt_comm%free(); call gqk%qpt_kpt_comm%free()
3601 : 24 : call gqk%pert_comm%free(); call gqk%band_comm%free(); call gqk%qpt_pert_comm%free()
3602 : 24 : call gqk%pert_ppsum_comm%free(); call gqk%pert_ppsum_bsum_comm%free()
3603 : 24 : call gqk%comm%free(); call gqk%bsum_comm%free(); call gqk%pp_sum_comm%free()
3604 : :
3605 : 24 : end subroutine gqk_free
3606 : : !!***
3607 : :
3608 : : !!****f* m_gstore/gstore_get_missing_qbz_spin
3609 : : !! NAME
3610 : : !! gstore_get_missing_qbz_spin
3611 : : !!
3612 : : !! FUNCTION
3613 : : !! Return the number of (q-points, spin) entries that have been computed.
3614 : : !!
3615 : : !! SOURCE
3616 : :
3617 : 9 : subroutine gstore_get_missing_qbz_spin(gstore, done_qbz_spin, ndone, nmiss)
3618 : :
3619 : : !Arguments ------------------------------------
3620 : : class(gstore_t),intent(in) :: gstore
3621 : : integer,intent(in) :: done_qbz_spin(gstore%nqbz, gstore%nsppol)
3622 : : integer,intent(out) :: ndone, nmiss
3623 : :
3624 : : !Local variables ------------------------------
3625 : : integer :: my_is, my_iq, iq_bz, spin, ierr, nscale
3626 : : !----------------------------------------------------------------------
3627 : :
3628 : 3 : ndone = 0; nmiss = 0
3629 [ + + ]: 6 : do my_is=1,gstore%my_nspins
3630 : 3 : associate (gqk => gstore%gqk(my_is))
3631 : 3 : spin = gstore%my_spins(my_is)
3632 [ + + ]: 83 : do my_iq=1,gqk%my_nq
3633 : 80 : iq_bz = gqk%my_q2bz(my_iq)
3634 [ + - ]: 80 : if (done_qbz_spin(iq_bz, spin) == 0) nmiss = nmiss + 1
3635 [ - + ]: 83 : if (done_qbz_spin(iq_bz, spin) == 1) ndone = ndone + 1
3636 : : end do ! my_iq
3637 : : ! Rescale to avoid overcounting in xmpi_summ
3638 : 3 : nscale = (gqk%pert_comm%nproc * gqk%bsum_comm%nproc * gqk%pp_sum_comm%nproc)
3639 : 3 : nmiss = nmiss / nscale
3640 : 6 : ndone = ndone / nscale
3641 : : end associate
3642 : : end do ! my_is
3643 : :
3644 : 3 : call xmpi_sum(ndone, gstore%comm, ierr)
3645 : 3 : call xmpi_sum(nmiss, gstore%comm, ierr)
3646 : :
3647 : 3 : end subroutine gstore_get_missing_qbz_spin
3648 : : !!***
3649 : :
3650 : : !!****f* m_gstore/gstore_set_perts_distrib
3651 : : !! NAME
3652 : : !! gstore_set_perts_distrib
3653 : : !!
3654 : : !! FUNCTION
3655 : : !! Activate parallelism over perturbations at the level of the DVDB file.
3656 : : !!
3657 : : !! SOURCE
3658 : :
3659 : 18 : subroutine gstore_set_perts_distrib(gstore, cryst, dvdb, my_npert)
3660 : :
3661 : : !Arguments ------------------------------------
3662 : : class(gstore_t),intent(in) :: gstore
3663 : : type(crystal_t),intent(in) :: cryst
3664 : : type(dvdb_t),intent(inout) :: dvdb
3665 : : integer,intent(out) :: my_npert
3666 : :
3667 : : !Local variables ------------------------------
3668 : : !scalars
3669 : : integer :: my_is, spin
3670 : : !arrays
3671 : 18 : integer,allocatable :: my_pinfo(:,:), pert_table(:,:)
3672 : : !----------------------------------------------------------------------
3673 : :
3674 : 18 : my_npert = cryst%natom * 3
3675 [ + + ]: 36 : do my_is=1,gstore%my_nspins
3676 : 18 : associate (gqk => gstore%gqk(my_is))
3677 : 18 : spin = gstore%my_spins(my_is)
3678 [ - + ]: 18 : if (gqk%pert_comm%nproc > 1) then
3679 : : ! Activate parallelism over perturbations
3680 : : ! Build table with list of perturbations treated by this MPI rank inside pert_comm.
3681 : : !ABI_WARNING("GSTORE with pert_comm%nproc > 1 not tested")
3682 : 0 : my_npert = gqk%my_npert
3683 [ # # # # ]: 0 : call ephtk_set_pertables(cryst%natom, my_npert, pert_table, my_pinfo, gqk%pert_comm%value)
3684 : 0 : call dvdb%set_pert_distrib(my_npert, cryst%natom * 3, my_pinfo, pert_table, gqk%pert_comm%value)
3685 [ # # # # : 0 : ABI_CHECK(all(my_pinfo(3, :) == gqk%my_pertcases), "my_pinfo(3, :) != gqk%my_pertcases")
# # ]
3686 : :
3687 [ # # ]: 0 : ABI_FREE(my_pinfo)
3688 [ # # ]: 0 : ABI_FREE(pert_table)
3689 : : end if
3690 : : end associate
3691 : : end do
3692 : :
3693 [ - + - + ]: 18 : end subroutine gstore_set_perts_distrib
3694 : : !!***
3695 : :
3696 : : !----------------------------------------------------------------------
3697 : :
3698 : : !!****f* m_gstore/gstore_compute
3699 : : !! NAME
3700 : : !! gstore_compute
3701 : : !!
3702 : : !! FUNCTION
3703 : : !! Compute MPI-distributed e-ph matrix elements
3704 : : !!
3705 : : !! INPUTS
3706 : : !! wk0_path=String with the path to the GS unperturbed WFK file.
3707 : : !! ngfft(18),ngfftf(18)=Coarse and Fine FFT meshes.
3708 : : !! dtset<dataset_type>=All input variables for this dataset.
3709 : : !! ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...)
3710 : : !! dvdb<dbdb_type>=Database with the DFPT SCF potentials.
3711 : : !! pawfgr <type(pawfgr_type)>=fine grid parameters and related data
3712 : : !! pawang<pawang_type)>=PAW angular mesh and related data.
3713 : : !! pawrad(ntypat*usepaw)<pawrad_type>=Paw radial mesh and related data.
3714 : : !! pawtab(ntypat*usepaw)<pawtab_type>=Paw tabulated starting data.
3715 : : !! psps<pseudopotential_type>=Variables related to pseudopotentials.
3716 : : !! comm=MPI communicator.
3717 : : !!
3718 : : !! OUTPUT
3719 : : !! GSTORE.nc file
3720 : : !!
3721 : : !! SOURCE
3722 : :
3723 : 5 : subroutine gstore_compute(gstore, wfk0_path, ngfft, ngfftf, dtset, dtfil, cryst, ebands, ifc, dvdb, &
3724 : 5 : pawfgr, pawang, pawrad, pawtab, psps, mpi_enreg, comm)
3725 : :
3726 : : !Arguments ------------------------------------
3727 : : !scalars
3728 : : class(gstore_t),target,intent(inout) :: gstore
3729 : : character(len=*),intent(in) :: wfk0_path
3730 : : integer,intent(in) :: comm
3731 : : type(dataset_type),intent(in) :: dtset
3732 : : type(datafiles_type),intent(in) :: dtfil
3733 : : type(crystal_t),intent(in) :: cryst
3734 : : type(ebands_t),intent(in) :: ebands
3735 : : class(ifc_type),intent(in) :: ifc
3736 : : type(dvdb_t),intent(inout) :: dvdb
3737 : : type(pawang_type),intent(in) :: pawang
3738 : : type(pseudopotential_type),intent(in) :: psps
3739 : : type(pawfgr_type),intent(in) :: pawfgr
3740 : : type(mpi_type),intent(in) :: mpi_enreg
3741 : : !arrays
3742 : : integer,intent(in) :: ngfft(18),ngfftf(18)
3743 : : type(pawrad_type),intent(in) :: pawrad(psps%ntypat*psps%usepaw)
3744 : : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
3745 : :
3746 : : !Local variables ------------------------------
3747 : : !scalars
3748 : : integer,parameter :: tim_getgh1c = 1, berryopt0 = 0, ider0 = 0, idir0 = 0, LOG_MODQ = 5, master = 0, ndat1 = 1
3749 : : integer :: my_rank,nproc,mband,nsppol,nkibz,idir,ipert, iq_bz
3750 : : integer :: cplex,natom,natom3,ipc,nspinor, nskip_tetra_kq, timrev_k, timrev_q
3751 : : integer :: band_k, in_k, ik_ibz,ikq_ibz,isym_k,isym_kq,trev_k,trev_kq, nb_k, nb_kq ! im_kq,
3752 : : integer :: my_ik, my_is, comm_rpt, my_npert, my_ip, my_iq, spin,istwf_k,istwf_kq,npw_k,npw_kq
3753 : : integer :: mpw, ierr, n1,n2,n3,n4,n5,n6,nspden,ndone, db_iqpt
3754 : : integer :: sij_opt,usecprj,usevnl,optlocal,optnl,opt_gvnlx1
3755 : : integer :: nfft,nfftf,mgfft,mgfftf, nkpg_k, nkpg_kq, qbuf_size, iqbuf_cnt, root_ncid, spin_ncid, ncerr
3756 : : integer :: ii, iq_ibz, isym_q, trev_q
3757 : : real(dp) :: cpu_q, wall_q, gflops_q, cpu_all, wall_all, gflops_all ! cpu, wall, gflops,
3758 : : real(dp) :: ecut, weight_q, weight_k ! eshift,
3759 : : logical :: gen_eigenpb, isirr_k, isirr_kq, isirr_q, print_time, need_ftinterp, qq_is_gamma, symmetrize, use_lgk
3760 : 5 : type(wfd_t) :: wfd
3761 : 5 : type(gs_hamiltonian_type) :: gs_ham_kq
3762 : 5 : type(rf_hamiltonian_type) :: rf_ham_kq
3763 : : type(gqk_t),pointer :: gqk
3764 : 5 : type(lgroup_t) :: lg_myq
3765 : : character(len=5000) :: msg, qq_bz_string, kk_string
3766 : : !arrays
3767 : : integer :: g0_k(3), g0_kq(3), g0_q(3), work_ngfft(18),gmax(3),indkk_kq(6,1), units(2), qbz2dvdb(6)
3768 : 5 : integer,allocatable :: kg_k(:,:), kg_kq(:,:), nband(:,:), wfd_istwfk(:), qmap_symrec(:,:)
3769 : 5 : integer,allocatable :: iq_buf(:,:), done_qbz_spin(:,:), state_kq(:,:)
3770 : : !integer,allocatable :: qibz2dvdb(:) !, displs(:), recvcounts(:)
3771 : : real(dp) :: kk_bz(3),kq_bz(3),kk_ibz(3),kq_ibz(3), qq_bz(3), qq_ibz(3) !, v_nk(3)
3772 : 5 : real(dp),allocatable :: displ_cart_qibz(:,:,:,:), lambda(:)
3773 : 5 : real(dp),allocatable :: grad_berry(:,:), kinpw_k(:), kinpw_kq(:), kpg_kq(:,:), kpg_k(:,:)
3774 : 5 : real(dp),allocatable :: ffnl_k(:,:,:,:), ffnl_kq(:,:,:,:), ph3d_k(:,:,:), ph3d_kq(:,:,:)
3775 : 5 : real(dp),allocatable :: v1scf(:,:,:,:), gkq_atm(:,:,:,:), gkq_atm_ipc(:,:,:)
3776 : 5 : real(dp),allocatable :: bras_kq(:,:,:), kets_k(:,:,:), h1_kets_kq(:,:,:) !, cgwork(:,:)
3777 : 5 : real(dp),allocatable :: ph1d(:,:), vlocal(:,:,:,:), vlocal1(:,:,:,:,:)
3778 : 5 : real(dp),allocatable :: dummy_vtrial(:,:), gvnlx1(:,:,:), work(:,:,:,:)
3779 : 5 : real(dp),allocatable :: gs1c_kq(:,:) !, vnk_cart_ibz(:,:,:) !, vkq_cart_ibz(:,:,:) !, vnk_mat_cart_ibz(:,:,:,:)
3780 : 5 : real(dp),allocatable :: my_gbuf(:,:,:,:,:,:)
3781 : 5 : logical,allocatable :: bks_mask(:,:,:),keep_ur(:,:,:)
3782 : 5 : type(pawcprj_type),allocatable :: cwaveprj0(:,:)
3783 : 5 : type(lgroup_t),allocatable :: lg_myk(:)
3784 : : !************************************************************************
3785 : :
3786 : 5 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
3787 [ + + ]: 15 : units = [std_out, ab_out]
3788 : :
3789 [ - + ]: 5 : if (psps%usepaw == 1) then
3790 : 0 : ABI_ERROR("PAW not implemented")
3791 : : ABI_UNUSED((/pawang%nsym, pawrad(1)%mesh_size/))
3792 : : end if
3793 : :
3794 : : ! Check MPI distribution: abort if there are any idle processes in the loops over k and q.
3795 : : ! NOTE that we have to perform this check only at the level of gstore%compute.
3796 : : ! The k- and q-points distributed inside kpt_comm and qpt_comm are the glob_nk and glob_nq points of the gstore
3797 : : ! (e.g. q in the full BZ), not the IBZ points. The IBZ-based steps (phonons, velocities) support nproc > nqibz.
3798 [ + + ]: 10 : do my_is=1,gstore%my_nspins
3799 : 5 : gqk => gstore%gqk(my_is)
3800 [ + - - + ]: 10 : if (gqk%kpt_comm%nproc > gqk%glob_nk .or. gqk%qpt_comm%nproc > gqk%glob_nq) then
3801 : 0 : write(msg, "(4(a,i0),4a)") "gstore%compute: kpt_comm%nproc=", gqk%kpt_comm%nproc, " > glob_nk=", gqk%glob_nk, &
3802 : 0 : " or qpt_comm%nproc=", gqk%qpt_comm%nproc, " > glob_nq=", gqk%glob_nq, ch10, &
3803 : 0 : "This will lead to idle processes, which are not supported.", ch10, &
3804 : 0 : "Please decrease the number of CPUs for k-points or q-points (eph_np_pqbks)"
3805 : 0 : ABI_ERROR(msg)
3806 : : endif
3807 : : enddo
3808 : :
3809 : : ! This parameter defines the size of the q-buffer used to store the g(k, q) e-ph matrix elements
3810 : : ! for all the k-point treated by this MPI rank.
3811 : : ! Increasing the buffer size increases the memory requirements
3812 : : ! but it leads to better performance as the number of IO operations is decreased.
3813 : : ! TODO: Should compute it on the basis of my_nkpt and my_nqpt
3814 : 5 : qbuf_size = 16
3815 : 5 : call wrtout(std_out, sjoin(" Begin computation of e-ph matrix elements with qbuf_size:", itoa(qbuf_size)), pre_newlines=1)
3816 : 5 : call pstat_proc%print(_PSTAT_ARGS_)
3817 : 5 : call cwtime(cpu_all, wall_all, gflops_all, "start")
3818 : :
3819 : : ! If True, only k-points in the IBZ and q-points in the IBZ_k are computed.
3820 : : ! Matrix elements in full BZs are then reconstructed by symmetry at the end of the run by calling
3821 : : ! gstore_symmetrize.
3822 : : symmetrize = (dtset%gstore_kzone == "bz" .and. dtset%gstore_qzone == "bz" &
3823 : : .and. dtset%gstore_sym > 0 &
3824 [ + + + - : 5 : )
+ - ]
3825 : : !if (symmetrize) call wrtout(units, " Computing g(k, q) with k in the IBZ and q in the BZ + final reconstruction")
3826 : :
3827 : : ! Copy important dimensions
3828 : 5 : natom = cryst%natom; natom3 = 3 * natom; nsppol = ebands%nsppol; nspinor = ebands%nspinor; nspden = dtset%nspden
3829 : 5 : nkibz = ebands%nkpt; mband = ebands%mband
3830 : :
3831 : : ! FFT meshes
3832 [ + + ]: 20 : nfftf = product(ngfftf(1:3)); mgfftf = maxval(ngfftf(1:3))
3833 [ + + + + ]: 35 : nfft = product(ngfft(1:3)) ; mgfft = maxval(ngfft(1:3))
3834 : 5 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); n4 = ngfft(4); n5 = ngfft(5); n6 = ngfft(6)
3835 : :
3836 : : ! Open the DVDB file
3837 : 5 : call dvdb%open_read(ngfftf, xmpi_comm_self)
3838 [ - + ]: 5 : ABI_CHECK(dvdb%has_fields("pot1", msg), msg)
3839 : :
3840 : : ! Activate parallelism over perturbations at the level of the DVDB
3841 : 5 : call gstore%set_perts_distrib(cryst, dvdb, my_npert)
3842 : :
3843 : : ! Prepare Fourier interpolation of DFPT potentials.
3844 : 5 : comm_rpt = xmpi_comm_self
3845 : : !comm_rpt = bqs_comm%value
3846 : :
3847 : : ! qmap_symrec gives the mapping gstore%ibz --> dvdb%ibz
3848 [ - + ]: 5 : call dvdb%need_ftinterp(gstore%nqibz, gstore%qibz, gstore%qptopt, qmap_symrec, need_ftinterp)
3849 [ - + ]: 5 : ABI_FREE(qmap_symrec)
3850 : : !need_ftinterp = .True.
3851 : :
3852 [ + + - + ]: 5 : if (.not. need_ftinterp .and. dtset%eph_use_ftinterp /= 0) then
3853 : 0 : ABI_WARNING("Enforcing FT interpolation for q-points even if it's not strictly needed.")
3854 : 0 : need_ftinterp = .True.
3855 : : end if
3856 : :
3857 [ + + ]: 5 : if (need_ftinterp) then
3858 : 3 : call wrtout(units, " Cannot find all IBZ q-points in the DVDB --> Activating Fourier interpolation.")
3859 : 3 : call dvdb%ftinterp_setup(dtset%ddb_ngqpt, gstore%qptopt, 1, dtset%ddb_shiftq, nfftf, ngfftf, comm_rpt)
3860 : : else
3861 : 2 : call wrtout(units, " DVDB file contains all q-points in the IBZ --> Reading DFPT potentials from file.")
3862 : : end if
3863 : :
3864 : : ! Initialize the wave function descriptor.
3865 : : ! Only wavefunctions for the symmetrical image of the k/k+q wavevectors treated by this MPI rank are stored.
3866 [ - + + - : 20 : ABI_MALLOC(nband, (nkibz, nsppol))
- + + - +
- + - - +
- + ]
3867 [ - + + - : 25 : ABI_MALLOC(bks_mask, (mband, nkibz, nsppol))
- + + - -
+ + - + -
+ - - + -
+ ]
3868 [ - + + - : 20 : ABI_MALLOC(keep_ur, (mband, nkibz, nsppol))
- + + - -
+ + - - +
- + ]
3869 [ + + + + : 2754 : nband = mband; bks_mask = .False.; keep_ur = .False.
+ + + + +
+ + + + +
+ + ]
3870 : :
3871 : 5 : call gstore%fill_bks_mask(mband, nkibz, nsppol, bks_mask)
3872 : :
3873 : : ! Impose istwfk = 1 for all k-points. This is also done in respfn (see inkpts)
3874 : : ! wfd_read_wfk will handle a possible conversion if WFK contains istwfk /= 1.
3875 [ - + + - : 15 : ABI_MALLOC(wfd_istwfk, (nkibz))
+ - + - -
+ - + ]
3876 [ + + ]: 119 : wfd_istwfk = 1
3877 : 5 : ecut = dtset%ecut
3878 : :
3879 : : call wfd%init(cryst, pawtab, psps, keep_ur, mband, nband, nkibz, nsppol, bks_mask,&
3880 : : nspden, nspinor, ecut, dtset%ecutsm, dtset%dilatmx, wfd_istwfk, ebands%kptns, ngfft,&
3881 : 5 : dtset%nloalg, dtset%prtvol, dtset%pawprtvol, comm)
3882 : :
3883 [ + + ]: 10 : call wfd%print([std_out], header="Wavefunctions for GSTORE calculation")
3884 : :
3885 [ - + ]: 5 : ABI_FREE(nband)
3886 [ - + ]: 5 : ABI_FREE(keep_ur)
3887 [ - + ]: 5 : ABI_FREE(wfd_istwfk)
3888 [ - + ]: 5 : ABI_FREE(bks_mask)
3889 : :
3890 : : ! Read wavefunctions.
3891 : 5 : call wfd%read_wfk(wfk0_path, iomode_from_fname(wfk0_path))
3892 : 5 : call pstat_proc%print(_PSTAT_ARGS_)
3893 : :
3894 : : ! one-dimensional structure factor information on the coarse grid.
3895 [ + - - + : 15 : ABI_MALLOC(ph1d, (2, 3*(2*mgfft+1)*natom))
+ - + - +
- - + - +
- + ]
3896 : 5 : call getph(cryst%atindx, natom, n1, n2, n3, ph1d, cryst%xred)
3897 : :
3898 : : ! mpw is the maximum number of plane-waves over k and k+q where k and k+q are in the BZ.
3899 : : ! we also need the max components of the G-spheres (k, k+q) in order to allocate the workspace array work
3900 : : ! that will be used to symmetrize the wavefunctions in G-space.
3901 : 5 : call gstore%get_mpw_gmax(ecut, mpw, gmax)
3902 : :
3903 : : ! Init work_ngfft
3904 [ + + ]: 20 : gmax = gmax + 4 ! FIXME: this is to account for umklapp
3905 [ + + ]: 20 : gmax = 2*gmax + 1
3906 : 5 : call ngfft_seq(work_ngfft, gmax)
3907 : : !write(std_out,*)"work_ngfft(1:3): ",work_ngfft(1:3)
3908 [ - + + - : 25 : ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
- + + - -
+ + - + -
+ - - + -
+ ]
3909 : :
3910 : : ! Allow PW-arrays dimensioned with mpw
3911 [ - + + - : 15 : ABI_MALLOC(kg_k, (3, mpw))
+ - + - -
+ - + -
+ ]
3912 [ - + + - : 10 : ABI_MALLOC(kg_kq, (3, mpw))
- + - + -
+ ]
3913 : :
3914 : 5 : usecprj = 0
3915 [ - + + - : 10 : ABI_MALLOC(cwaveprj0, (natom, nspinor*usecprj))
- + - + -
+ ]
3916 : :
3917 : : ! Prepare call to getgh1c
3918 : 5 : usevnl = 0
3919 : 5 : optlocal = 1 ! local part of H^(1) is computed in gh1c=<G|H^(1)|C>
3920 : 5 : optnl = 2 ! non-local part of H^(1) is totally computed in gh1c=<G|H^(1)|C>
3921 : 5 : opt_gvnlx1 = 0 ! gvnlx1 is output
3922 [ - + - + ]: 5 : ABI_MALLOC(grad_berry, (2, nspinor*(berryopt0/4)))
3923 : :
3924 : : ! This part is taken from dfpt_vtorho
3925 : : !==== Initialize most of the Hamiltonian (and derivative) ====
3926 : : !1) Allocate all arrays and initialize quantities that do not depend on k and spin.
3927 : : !2) Perform the setup needed for the non-local factors:
3928 : : ! Norm-conserving: Constant kleimann-Bylander energies are copied from psps to gs_hamk.
3929 : : ! PAW: Initialize the overlap coefficients and allocate the Dij coefficients.
3930 : :
3931 : : call gs_ham_kq%init(psps, pawtab, nspinor, nsppol, nspden, natom, &
3932 : : dtset%typat, cryst%xred, nfft, mgfft, ngfft, cryst%rprimd, dtset%nloalg, &
3933 : : comm_atom=mpi_enreg%comm_atom, mpi_atmtab=mpi_enreg%my_atmtab, mpi_spintab=mpi_enreg%my_isppoltab, &
3934 : 5 : usecprj=usecprj, ph1d=ph1d, nucdipmom=dtset%nucdipmom, gpu_option=dtset%gpu_option)
3935 : :
3936 : : ! Allocate vlocal. Note nvloc
3937 : : ! I set vlocal to huge to trigger possible bugs (DFPT routines should not access the data)
3938 [ - + + - : 30 : ABI_MALLOC(vlocal, (n4, n5, n6, gs_ham_kq%nvloc))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
3939 [ + + + + : 26516 : vlocal = huge(one)
+ + + + ]
3940 : :
3941 : : ! Allocate work space arrays.
3942 [ - + + - : 20 : ABI_MALLOC(displ_cart_qibz, (2, 3, cryst%natom, natom3))
- + + - +
- + - - +
- + ]
3943 [ - + + - : 22241 : ABI_CALLOC(dummy_vtrial, (nfftf, nspden))
- + + - +
- + - - +
- + + + +
+ ]
3944 : :
3945 : : ! Open GSTORE file, and read table used for restarting.
3946 : : ! TODO: Fix problem with IO (some q-points are not written)
3947 : : !if (dtset%useria == 888) then
3948 : : ! ! use xmpi_comm_self otherwise there will be a deadlock on lemaitre4
3949 : : ! NCF_CHECK(nctk_open_modify(root_ncid, gstore%path, xmpi_comm_self))
3950 : : !else
3951 [ - + ]: 5 : NCF_CHECK(nctk_open_modify(root_ncid, gstore%path, gstore%comm))
3952 : : !end if
3953 : :
3954 : : ! integer scalars
3955 : : ncerr = nctk_def_iscalars(root_ncid, [character(len=nctk_slen) :: &
3956 : : "used_ftinterp" &
3957 [ + + ]: 10 : ])
3958 [ - + ]: 5 : NCF_CHECK(ncerr)
3959 : :
3960 [ - + + - : 20 : ABI_MALLOC(done_qbz_spin, (gstore%nqbz, nsppol))
- + + - +
- + - - +
- + - + ]
3961 [ - + ]: 5 : NCF_CHECK(nf90_get_var(root_ncid, nctk_idname(root_ncid, "gstore_done_qbz_spin"), done_qbz_spin))
3962 : :
3963 [ - + ]: 5 : gstore%wfk0_path = wfk0_path
3964 : :
3965 : : !if (my_rank == master) then
3966 [ + + ]: 5 : ii = merge(1, 0, need_ftinterp)
3967 : : ncerr = nctk_write_iscalars(root_ncid, [character(len=nctk_slen) :: &
3968 : : "used_ftinterp"], &
3969 : : [ii &
3970 [ + + + + ]: 15 : ])
3971 [ - + ]: 5 : NCF_CHECK(ncerr)
3972 : :
3973 [ - + - - ]: 5 : NCF_CHECK(nf90_put_var(root_ncid, root_vid("gstore_wfk0_path"), trim(gstore%wfk0_path)))
3974 : : !end if
3975 : :
3976 : : ! SC: The writes below are done by a subset of the procs (dump_my_gbuf) and a lazy collective read
3977 : : ! triggered by this subset would deadlock. Therefore, we load the metadata of all the variables here
3978 : : ! with all the procs of gstore%comm.
3979 : 5 : call gstore_prepare_mpiio(root_ncid, gstore%nsppol)
3980 : :
3981 [ + - + + ]: 10 : if (my_rank == master) call gstore%print([std_out])
3982 [ + + + + : 2487 : ndone = count(done_qbz_spin == 1)
- + ]
3983 : :
3984 [ + - ]: 5 : if (ndone == 0) then
3985 : : ! Write phonon data here as we are not guaranteed to have all the IBZ q-points
3986 : : ! inside the loop over my_iq if filtering has been used.
3987 : : ! Make sure internal table with gstore_done_qbz_spin is properly filled.
3988 : 5 : call gstore%compute_and_write_ph(root_ncid)
3989 : : else
3990 : 0 : call wrtout(units, sjoin("- Restarting GSTORE calculation from file:", gstore%path))
3991 : 0 : call wrtout(units, sjoin(" Found: ", itoa(ndone), " (qpt, spin) entries already computed"))
3992 : : end if
3993 : :
3994 : : ! Create ddkop object to compute group velocities (if needed)
3995 [ + - + - ]: 5 : if (gstore%with_vk /= 0 .and. ndone == 0) then
3996 : 5 : call gstore%compute_and_write_vk(mpw, wfd, ebands, psps, pawtab, root_ncid)
3997 : : end if
3998 : :
3999 [ - + ]: 5 : if (dtset%gstore_iv1p_comm /= 0) then
4000 : : call gstore%compute_and_write_commutator(mpw, gmax, ngfft, ngfftf, dtset, cryst, pawfgr, psps, &
4001 : 0 : wfd, mpi_enreg, kg_k, ebands, dvdb, gs_ham_kq, root_ncid)
4002 : : end if
4003 : :
4004 : 5 : call wrtout(std_out, " Begin computation of e-ph matrix elements...", pre_newlines=1)
4005 : :
4006 : : ! TODO: Exchange the q/k loops so that one can reduce the number of calls to _k dependente routines
4007 : : ! 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)>
4008 : : ! The price to pay is an increase in the number of calls to get_ftqbz but for small systems this part does not dominate
4009 : : ! Alternatively, one cah have two versions that will be invoked depending on my_nk, my_nq
4010 : :
4011 : : ! Here we decide if the q-points can be reduced to the IBZ(k)
4012 [ + + + - ]: 5 : use_lgk = (dtset%gstore_use_lgk /= 0 .or. dtset%gstore_sym == 2)
4013 : : if (use_lgk) then
4014 : 1 : call wrtout(units, " Only q-points in the IBZ_k will be computed.")
4015 [ - + ]: 4 : else if (dtset%gstore_use_lgq /= 0) then
4016 : 0 : call wrtout(units, " Only k-points in the IBZ_q will be computed.")
4017 : : else
4018 : 4 : call wrtout(units, " Little group operations won't be used")
4019 : : end if
4020 : :
4021 : : ! if PAW, one has to solve a generalized eigenproblem
4022 [ - + ]: 5 : gen_eigenpb = psps%usepaw == 1; sij_opt = 0; if (gen_eigenpb) sij_opt = 1
4023 : :
4024 : : ! Loop over my spins.
4025 [ + + ]: 10 : do my_is=1,gstore%my_nspins
4026 : 5 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is); my_npert = gqk%my_npert
4027 : :
4028 [ - + ]: 5 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
4029 : : ! SC: these nctk_prepare_mpiio are not needed anymore. gstore_prepare_mpiio has accessed all the variables after the open,
4030 : : ! and netcdf reads the metadata of a variable only at the first access, so these calls would do nothing.
4031 : : !NCF_CHECK(nctk_prepare_mpiio(spin_ncid, "gvals"))
4032 : : !NCF_CHECK(nctk_prepare_mpiio(root_ncid, "gstore_done_qbz_spin"))
4033 : :
4034 : 5 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
4035 : :
4036 [ - + + - : 15 : ABI_MALLOC(iq_buf, (2, qbuf_size))
+ - + - -
+ - + -
+ ]
4037 [ + + + + ]: 245 : iq_buf = 0
4038 [ - + + - : 15 : ABI_MALLOC(lambda, (nb_k))
+ - + - -
+ - + ]
4039 [ - + + - : 25 : ABI_MALLOC(gkq_atm, (2, nb_kq, nb_k, natom3))
- + + - -
+ + - + -
+ - - + -
+ - + ]
4040 [ - + + - : 20 : ABI_MALLOC(gkq_atm_ipc, (2, nb_kq, nb_k))
- + + - +
- + - - +
- + ]
4041 : : #ifdef HAVE_OPENMP_OFFLOAD
4042 : : !$OMP TARGET ENTER DATA MAP(alloc:gkq_atm_ipc) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4043 : : #endif
4044 : :
4045 : : ! Inside the loops we compute gkq_atm(2, nb_kq, nb_k, natom3)
4046 [ - + + - : 40 : ABI_MALLOC_OR_DIE(my_gbuf, (gqk%cplex, nb_kq, nb_k, natom3, gqk%my_nk, qbuf_size), ierr)
- + + - -
+ + - - +
+ - - + +
- - + + -
+ - + - +
- + - - +
+ - - + ]
4047 : 5 : call pstat_proc%print(_PSTAT_ARGS_)
4048 : :
4049 : : ! Compute the little group of the k-point so that we can compute g(k,q) only for q in the IBZ_k
4050 [ + + ]: 5 : if (use_lgk) then
4051 : 1 : timrev_k = kpts_timrev_from_kptopt(ebands%kptopt)
4052 [ - + + - : 4 : ABI_MALLOC(lg_myk, (gqk%my_nk))
+ - + - -
+ - + - +
+ + + - -
+ - + - +
- + - + -
+ - + ]
4053 [ + + ]: 2 : do my_ik=1,gqk%my_nk
4054 [ + + ]: 4 : kk_bz = gqk%my_kpts(:, my_ik)
4055 : 2 : call lg_myk(my_ik)%init(cryst, kk_bz, timrev_k, gstore%nqbz, gstore%qbz, gstore%nqibz, gstore%qibz, xmpi_comm_self)
4056 : : end do
4057 : : end if
4058 : :
4059 [ - + + - : 20 : ABI_MALLOC(state_kq, (gqk%my_nk, qbuf_size))
- + + - +
- + - - +
- + - + ]
4060 [ + + + + ]: 4981 : state_kq = GSTORE_KQ_MISSING
4061 : :
4062 : : ! SC: iqbuf_cnt is set only for the q-points that are computed, so is has to be initialized. Otherwise a
4063 : : ! proc whose q-points are all done (restart) would read an undefined value in "if (iqbuf_cnt /= 0)" later.
4064 : 5 : iqbuf_cnt = 0
4065 : :
4066 : : ! Loop over my set of q-points
4067 [ + + ]: 882 : do my_iq=1,gqk%my_nq
4068 [ + - + + : 877 : print_time = my_rank == 0 .and. (my_iq <= LOG_MODQ .or. mod(my_iq, LOG_MODQ) == 0)
+ + ]
4069 : 193 : if (print_time) call cwtime(cpu_q, wall_q, gflops_q, "start")
4070 : 877 : iq_bz = gqk%my_q2bz(my_iq)
4071 : :
4072 : 877 : call gqk%myqpt(my_iq, gstore, weight_q, qq_bz)
4073 : : qq_is_gamma = sum(qq_bz**2) < tol14
4074 : 877 : qq_bz_string = ktoa(qq_bz)
4075 : :
4076 : : ! Handle possible restart.
4077 [ - + ]: 877 : if (done_qbz_spin(iq_bz, spin) == 1) then
4078 : 0 : call wrtout(std_out, sjoin(" iq_bz:", itoa(iq_bz), ", spin: ", itoa(spin), " already computed --> skipping iteration"))
4079 : 0 : cycle
4080 : : end if
4081 : :
4082 : : ! Compute the little group of the q-point so that we can compute g(k,q) only for k in the IBZ_q
4083 [ - + ]: 877 : if (dtset%gstore_use_lgq /= 0) then
4084 : 0 : timrev_q = kpts_timrev_from_kptopt(gstore%qptopt)
4085 [ # # # # : 0 : call lg_myq%init(cryst, qq_bz, timrev_q, gstore%nkbz, gstore%kbz, gstore%nkibz, gstore%kibz, xmpi_comm_self)
# # # # #
# ]
4086 : : end if
4087 : :
4088 : 877 : iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
4089 : 877 : trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5,my_iq)
4090 : : ! Don't test if umklapp == 0 because we use the periodic gauge:
4091 : : !
4092 : : ! phfreq(q+G) = phfreq(q) and eigvec(q) = eigvec(q+G)
4093 : : !
4094 : : !isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
4095 : 877 : isirr_q = (isym_q == 1 .and. trev_q == 0)
4096 [ + + ]: 3508 : qq_ibz = gstore%qibz(:, iq_ibz)
4097 : :
4098 : 877 : nskip_tetra_kq = 0
4099 : 877 : iqbuf_cnt = 1 + mod(my_iq - 1, qbuf_size)
4100 [ + + ]: 2631 : iq_buf(:, iqbuf_cnt) = [my_iq, iq_bz]
4101 : :
4102 [ + + ]: 877 : if (need_ftinterp) then
4103 : : ! Fourier interpolation.
4104 [ - + ]: 786 : call dvdb%get_ftqbz(qq_bz, cplex, nfftf, ngfftf, v1scf, gqk%pert_comm%value)
4105 : : else
4106 : : ! Read and reconstruct the dvscf potentials for qpt and my_npert perturbations.
4107 : 91 : db_iqpt = dvdb%findq(qq_ibz)
4108 [ - + ]: 91 : ABI_CHECK(db_iqpt /= -1, sjoin("Could not find symmetric of q-point:", ktoa(qq_bz), "in DVDB file."))
4109 : : ! The first entry in qbz2dvdb gives the index in dvdb%qpts.
4110 : : ! The other entries in mapc_qq are OK as they refer to symmetries.
4111 [ + + ]: 637 : qbz2dvdb = gqk%my_q2ibz(:, my_iq); qbz2dvdb(1) = db_iqpt
4112 [ - + ]: 91 : call dvdb%readsym_qbz(cryst, qq_bz, qbz2dvdb, cplex, nfftf, ngfftf, v1scf, gqk%pert_comm%value)
4113 : : end if
4114 : :
4115 : : ! Allocate vlocal1 with correct cplex. Note nvloc and my_npert.
4116 [ - + + - : 6139 : ABI_MALLOC(vlocal1, (cplex*n4, n5, n6, gs_ham_kq%nvloc, my_npert))
- + + - -
+ + - - +
+ - - + +
- + - + -
- + - + ]
4117 : :
4118 : : ! Set up local potential vlocal1 with proper dimensioning from vtrial1 taking into account the spin.
4119 [ + + ]: 6139 : do my_ip=1,my_npert
4120 : : call rf_transgrid_and_pack(spin, nspden, psps%usepaw, cplex, nfftf, nfft, ngfft, gs_ham_kq%nvloc,&
4121 : 6139 : pawfgr, mpi_enreg, dummy_vtrial, v1scf(:,:,:,my_ip), vlocal, vlocal1(:,:,:,:,my_ip))
4122 : : #ifdef HAVE_OPENMP_OFFLOAD
4123 : : !$OMP TARGET ENTER DATA MAP(to:vlocal1(:,:,:,:,my_ip)) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4124 : : #endif
4125 : : end do
4126 : : !$OMP TASKWAIT
4127 : :
4128 : : ! Continue to initialize the GS Hamiltonian
4129 : 877 : call gs_ham_kq%load_spin(spin, vlocal=vlocal, with_nonlocal=.true.)
4130 : :
4131 : : ! Loop over my k-points
4132 [ + + ]: 74524 : do my_ik=1,gqk%my_nk
4133 : : ! The k-point and the symmetries relating the BZ k-point to the IBZ.
4134 [ + + ]: 294588 : kk_bz = gqk%my_kpts(:, my_ik)
4135 : 73647 : weight_k = gqk%my_wtk(my_ik)
4136 : 73647 : kk_string = ktoa(kk_bz)
4137 : :
4138 : 73647 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
4139 [ + + ]: 294588 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5,my_ik)
4140 [ + + + + : 282012 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
+ + - + ]
4141 [ + + ]: 294588 : kk_ibz = ebands%kptns(:,ik_ibz)
4142 : :
4143 : : ! Set entry to zero. Important as there are cycle instructions inside these loops
4144 : : ! and we don't want random numbers written to disk.
4145 [ + + + + : 5565417 : my_gbuf(:,:,:,:, my_ik, iqbuf_cnt) = zero
+ + + + ]
4146 : :
4147 [ - + ]: 73647 : if (symmetrize .and. .not. isirr_k) then
4148 : 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4149 : : end if
4150 : :
4151 [ + + ]: 73647 : if (use_lgk) then
4152 : 64 : ii = lg_myk(my_ik)%findq_ibzk(qq_bz)
4153 [ + + ]: 64 : if (ii == -1) then
4154 : 56 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4155 : : end if
4156 : : end if
4157 : :
4158 [ - + ]: 73591 : if (dtset%gstore_use_lgq /= 0) then
4159 : 0 : ii = lg_myq%findq_ibzk(kk_bz)
4160 [ # # ]: 0 : if (ii == -1) then
4161 : 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4162 : : end if
4163 : : end if
4164 : :
4165 : : ! =========================================
4166 : : ! Find symmetrical image of k+q in the kIBZ
4167 : : ! =========================================
4168 [ + + ]: 294364 : kq_bz = kk_bz + qq_bz
4169 [ - + ]: 73591 : if (kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz, indkk_kq) /= 0) then
4170 : : write(msg, '(3a)' ) &
4171 : 0 : "Cannot find k+q in k-mesh", ch10, 'Check your WFK file and the (k,q) point input variables.'
4172 : 0 : ABI_ERROR(msg)
4173 : : end if
4174 : :
4175 : 73591 : ikq_ibz = indkk_kq(1, 1); isym_kq = indkk_kq(2, 1)
4176 : 73591 : trev_kq = indkk_kq(6, 1); g0_kq = indkk_kq(3:5, 1)
4177 : : isirr_kq = (isym_kq == 1 .and. trev_kq == 0 .and. all(g0_kq == 0))
4178 [ + + ]: 294364 : kq_ibz = ebands%kptns(:, ikq_ibz)
4179 : :
4180 : : ! If we have used the KERANGE trick, we may have k or k+q points with just one G component set to zero
4181 : : ! so we skip this transition immediately. This should happen only if fsewin > sigma_erange.
4182 [ + - - + ]: 73591 : if (wfd%npwarr(ik_ibz) == 1 .or. wfd%npwarr(ikq_ibz) == 1) then
4183 : 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4184 : : end if
4185 : :
4186 [ - + ]: 73591 : if (gstore%kfilter == "fs_tetra") then
4187 : : ! Check tetra delta(e_{k+q}) and cycle if all the weights at k+q are zero.
4188 [ # # # # : 0 : if (all(abs(gstore%delta_ef_kibz_spin(:, ikq_ibz, spin)) == zero)) then
# # ]
4189 : 0 : nskip_tetra_kq = nskip_tetra_kq + 1
4190 : 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4191 : : end if
4192 : : end if
4193 : :
4194 : : ! Get npw_k, kg_k and symmetrize wavefunctions from the IBZ (if needed).
4195 : : call wfd%sym_ug_kg_npw(ecut, kk_bz, kk_ibz, gqk%bstart_k, nb_k, spin, gqk%my_k2ibz(:, my_ik), cryst, &
4196 [ - + ]: 73591 : work_ngfft, work, istwf_k, npw_k, kg_k, kets_k)
4197 : :
4198 : : #ifdef HAVE_OPENMP_OFFLOAD
4199 : : !$OMP TARGET ENTER DATA MAP(to:kets_k) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4200 : : #endif
4201 : :
4202 : : ! Get npw_kq, kg_kq and symmetrize wavefunctions from the IBZ (if needed).
4203 : : call wfd%sym_ug_kg_npw(ecut, kq_bz, kq_ibz, gqk%bstart_kq, nb_kq, spin, indkk_kq(:,1), cryst, &
4204 [ - + ]: 73591 : work_ngfft, work, istwf_kq, npw_kq, kg_kq, bras_kq)
4205 : :
4206 : : #ifdef HAVE_OPENMP_OFFLOAD
4207 : : !$OMP TARGET ENTER DATA MAP(to:bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4208 : : #endif
4209 : :
4210 [ - + + - : 294364 : ABI_MALLOC(h1_kets_kq, (2, npw_kq*nspinor, nb_k))
- + + - +
- + - - +
- + ]
4211 [ + - - - : 220773 : ABI_MALLOC(gs1c_kq, (2, npw_kq*nspinor*nb_k*((sij_opt+1)/2)))
+ - - + -
+ - + ]
4212 [ - + + - : 220773 : ABI_MALLOC(gvnlx1, (2, npw_kq*nspinor,nb_k))
- + + - -
+ - + ]
4213 : : #ifdef HAVE_OPENMP_OFFLOAD
4214 : : !$OMP TARGET ENTER DATA MAP(alloc:h1_kets_kq, gvnlx1, kets_k, bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4215 : : !$OMP TARGET ENTER DATA MAP(alloc:gs1c_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP .and. sij_opt /= 0) NOWAIT
4216 : : #endif
4217 : :
4218 : : call gs_ham_kq%eph_setup_k("k" , kk_bz, istwf_k, npw_k, kg_k, dtset, cryst, psps, &
4219 [ - + - + : 73591 : nkpg_k, kpg_k, ffnl_k, kinpw_k, ph3d_k, gqk%pert_comm%value)
- + - + ]
4220 : :
4221 : : #ifdef HAVE_OPENMP_OFFLOAD
4222 : : !$OMP TARGET ENTER DATA MAP(to:kpg_k, ffnl_k, kinpw_k, ph3d_k) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4223 : : #endif
4224 : :
4225 : : call gs_ham_kq%eph_setup_k("kq", kq_bz, istwf_k, npw_kq, kg_kq, dtset, cryst, psps, &
4226 [ - + - + : 73591 : nkpg_kq, kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq, gqk%pert_comm%value)
- + - + ]
4227 : :
4228 : : #ifdef HAVE_OPENMP_OFFLOAD
4229 : : !$OMP TARGET ENTER DATA MAP(to:kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4230 : : #endif
4231 : :
4232 : : !$OMP TASKWAIT
4233 : :
4234 : : ! Loop over my atomic perturbations and compute gkq_atm_ipc.
4235 [ + + + + : 5483041 : gkq_atm = zero
+ + + + ]
4236 [ + + ]: 515137 : do my_ip=1,my_npert
4237 : 441546 : idir = dvdb%my_pinfo(1, my_ip); ipert = dvdb%my_pinfo(2, my_ip); ipc = dvdb%my_pinfo(3, my_ip)
4238 : :
4239 : : ! Prepare application of the NL part.
4240 : 441546 : call rf_ham_kq%init(cplex, gs_ham_kq, ipert, has_e1kbsc=.true.)
4241 : 441546 : call rf_ham_kq%load_spin(spin, vlocal1=vlocal1(:,:,:,:,my_ip), with_nonlocal=.true.)
4242 : :
4243 : : #if 1
4244 : : ! Calculate dvscf * psi_k, results stored in h1_kets_kq on the k+q sphere.
4245 : : ! Compute H(1) applied to GS wavefunction Psi(0)
4246 [ + + ]: 1128636 : do in_k=1,nb_k
4247 : : ! Use scissor shift on 0-order eigenvalue
4248 : 687090 : band_k = in_k + gqk%bstart_k - 1
4249 : 1128636 : lambda(in_k) = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
4250 : : end do
4251 : : !call ebands%get_dfpt_eshifted(gqk%bstart_k, nb_k, ik_ibz, spin, dtset%dfpt_sciss, lambda)
4252 : :
4253 : : call getgh1c(berryopt0, kets_k, cwaveprj0, h1_kets_kq, &
4254 : : grad_berry, gs1c_kq, gs_ham_kq, gvnlx1, idir, ipert, lambda, mpi_enreg, nb_k, optlocal, &
4255 : 441546 : optnl, opt_gvnlx1, rf_ham_kq, sij_opt, tim_getgh1c, usevnl)
4256 : :
4257 : : #else
4258 : : do in_k=1,nb_k
4259 : : ! Use scissor shift on 0-order eigenvalue
4260 : : band_k = in_k + gqk%bstart_k - 1
4261 : : eshift = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
4262 : :
4263 : : call getgh1c(berryopt0, kets_k(:,:,in_k), cwaveprj0, h1_kets_kq(:,:,in_k), &
4264 : : grad_berry, gs1c_kq, gs_ham_kq, gvnlx1, idir, ipert, [eshift], mpi_enreg, ndat1, optlocal, &
4265 : : optnl, opt_gvnlx1, rf_ham_kq, sij_opt, tim_getgh1c, usevnl)
4266 : : end do ! in_k
4267 : : #endif
4268 : :
4269 : 441546 : call rf_ham_kq%free()
4270 : :
4271 : : ! Calculate <psi_{k+q,j}|dvscf_q*psi_{k,i}> for this perturbation. No need to handle istwf_kq because it's always 1.
4272 [ - + ]: 441546 : if (dtset%gpu_option == ABI_GPU_OPENMP) then
4273 : : call abi_gpu_xgemm_d(2, 'C', 'N', nb_kq, nb_k, npw_kq*nspinor, cone, bras_kq, npw_kq*nspinor, &
4274 : 0 : h1_kets_kq, npw_kq*nspinor, czero, gkq_atm_ipc, nb_kq)
4275 : : #ifdef HAVE_OPENMP_OFFLOAD
4276 : : !$OMP TARGET UPDATE FROM(gkq_atm_ipc)
4277 : : #endif
4278 : : else
4279 : : call ZGEMM('C', 'N', nb_kq, nb_k, npw_kq*nspinor, cone, bras_kq, npw_kq*nspinor, &
4280 : 441546 : h1_kets_kq, npw_kq*nspinor, czero, gkq_atm_ipc, nb_kq)
4281 : : end if
4282 : :
4283 : : ! Transfer data
4284 [ + + + + : 5483041 : gkq_atm(:,:,:,ipc) = gkq_atm_ipc
+ + ]
4285 : : end do ! my_ip
4286 : :
4287 : : ! Collect gkq_atm inside pert_comm so that all procs can operate on the data.
4288 [ - + ]: 73591 : if (gqk%pert_comm%nproc > 1) call xmpi_sum(gkq_atm, gqk%pert_comm%value, ierr)
4289 : :
4290 : : ! Save e-ph matrix elements in the buffer.
4291 [ + + + + : 5483041 : my_gbuf(:,:,:,:, my_ik, iqbuf_cnt) = gkq_atm
+ + + + ]
4292 : 73591 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_COMPUTED
4293 : :
4294 : : #ifdef HAVE_OPENMP_OFFLOAD
4295 : : !$OMP TARGET EXIT DATA MAP(delete:kpg_k, ffnl_k, kinpw_k, ph3d_k) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4296 : : !$OMP TARGET EXIT DATA MAP(delete:kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4297 : : !$OMP TARGET EXIT DATA MAP(delete:h1_kets_kq, gvnlx1, kets_k, bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4298 : : !$OMP TARGET EXIT DATA MAP(delete:gs1c_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP .and. sij_opt /= 0)
4299 : : #endif
4300 [ - + ]: 73591 : ABI_FREE(ffnl_k)
4301 [ - + ]: 73591 : ABI_FREE(ffnl_kq)
4302 [ - + ]: 73591 : ABI_FREE(kpg_k)
4303 [ - + ]: 73591 : ABI_FREE(kpg_kq)
4304 [ - + ]: 73591 : ABI_FREE(ph3d_k)
4305 [ - + ]: 73591 : ABI_FREE(ph3d_kq)
4306 [ - + ]: 73591 : ABI_FREE(kinpw_k)
4307 [ - + ]: 73591 : ABI_FREE(kinpw_kq)
4308 [ - + ]: 73591 : ABI_FREE(kets_k)
4309 [ - + ]: 73591 : ABI_FREE(bras_kq)
4310 [ - + ]: 73591 : ABI_FREE(h1_kets_kq)
4311 [ - + ]: 73591 : ABI_FREE(gs1c_kq)
4312 [ - + ]: 74468 : ABI_FREE(gvnlx1)
4313 : : end do ! my_ik
4314 : :
4315 [ - + ]: 877 : ABI_FREE(v1scf)
4316 : :
4317 : : #ifdef HAVE_OPENMP_OFFLOAD
4318 : : do my_ip=1,my_npert
4319 : : !$OMP TARGET EXIT DATA MAP(delete:vlocal1(:,:,:,:,my_ip)) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4320 : : end do
4321 : : #endif
4322 [ - + ]: 877 : ABI_FREE(vlocal1)
4323 : :
4324 : : ! Dump buffer
4325 [ + + ]: 877 : if (iqbuf_cnt == qbuf_size) call dump_my_gbuf()
4326 : :
4327 [ + + ]: 877 : if (print_time) then
4328 : 193 : write(msg,'(2(a,i0),a)')" My q-point [", my_iq, "/", gqk%my_nq, "]"
4329 [ + + ]: 193 : call cwtime_report(msg, cpu_q, wall_q, gflops_q); if (my_iq == LOG_MODQ) call wrtout(std_out, "...", do_flush=.True.)
4330 : : end if
4331 : 882 : call lg_myq%free()
4332 : : end do ! my_iq
4333 : :
4334 : : ! Dump the remainder.
4335 [ + + ]: 5 : if (iqbuf_cnt /= 0) call dump_my_gbuf()
4336 : :
4337 [ - + ]: 5 : ABI_FREE(state_kq)
4338 [ - + ]: 5 : ABI_FREE(iq_buf)
4339 [ - + ]: 5 : ABI_FREE(my_gbuf)
4340 [ - + ]: 5 : ABI_FREE(lambda)
4341 [ - + ]: 5 : ABI_FREE(gkq_atm)
4342 : : #ifdef HAVE_OPENMP_OFFLOAD
4343 : : !$OMP TARGET EXIT DATA MAP(delete:gkq_atm_ipc) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4344 : : #endif
4345 [ - + ]: 5 : ABI_FREE(gkq_atm_ipc)
4346 : :
4347 [ + + ]: 10 : if (use_lgk) then
4348 [ + + ]: 2 : do my_ik=1,gqk%my_nk
4349 : 2 : call lg_myk(my_ik)%free()
4350 : : end do
4351 [ + - + + : 2 : ABI_FREE(lg_myk)
- + - + -
+ - + - +
- + - + -
+ ]
4352 : : end if
4353 : : end do ! my_is
4354 : :
4355 : 5 : call cwtime_report(" GSTORE computation done", cpu_all, wall_all, gflops_all, pre_str=ch10, end_str=ch10) !, comm=gstore%comm)
4356 : : !call gstore%print([std_out], header="GSTORE at the end of gstore%compute")
4357 : :
4358 : : ! Set gstore_completed to 1 so that we can easily check if restarted is needed.
4359 : : !if (my_rank == master) then
4360 [ - + ]: 5 : NCF_CHECK(nf90_put_var(root_ncid, root_vid("gstore_completed"), 1))
4361 : : !end if
4362 : : ! nf90_sync can deadlock on lemaitre4 for some MPI decompositions.
4363 : : !if (dtset%useria /= 888) then
4364 [ - + ]: 5 : NCF_CHECK(nf90_sync(root_ncid))
4365 : : !end if
4366 [ - + ]: 5 : NCF_CHECK(nf90_close(root_ncid))
4367 : 5 : call xmpi_barrier(gstore%comm)
4368 : :
4369 : : ! Free memory
4370 [ - + ]: 5 : ABI_FREE(grad_berry)
4371 [ - + ]: 5 : ABI_FREE(dummy_vtrial)
4372 [ - + ]: 5 : ABI_FREE(work)
4373 [ - + ]: 5 : ABI_FREE(ph1d)
4374 [ - + ]: 5 : ABI_FREE(vlocal)
4375 [ - + ]: 5 : ABI_FREE(kg_k)
4376 [ - + ]: 5 : ABI_FREE(kg_kq)
4377 [ - + ]: 5 : ABI_FREE(displ_cart_qibz)
4378 [ - + ]: 5 : ABI_FREE(done_qbz_spin)
4379 : :
4380 : 5 : call gs_ham_kq%free(); call wfd%free()
4381 : 5 : call pawcprj_free(cwaveprj0)
4382 [ + - - + : 5 : ABI_FREE(cwaveprj0)
- - - - -
+ ]
4383 : :
4384 : : ! Reconstruct g(k,q) matrix elements in the full BZ by symmetry.
4385 [ - + ]: 5 : if (symmetrize) then
4386 : 0 : call gstore_symmetrize(gstore%path, wfk0_path, ngfft, dtset, dtfil, cryst, psps, pawtab, ebands, ifc, comm)
4387 : : end if
4388 : :
4389 : : ! Output some of the results to ab_out for testing purposes
4390 [ - + - + : 30 : call gstore%print_for_abitests(dtset, ebands, .True.)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - - - -
- - - - -
- - - - -
- + - - -
- - - - -
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
+ - + - +
- + ]
4391 : :
4392 : : contains
4393 : :
4394 : 56 : subroutine dump_my_gbuf()
4395 : :
4396 : : ! This function is called inside the double loop over (my_is, my_iq) or when we exit
4397 : : ! from the my_iq loop to dump the remainder that is still in the q-buffer,
4398 : : ! All the MPI procs in the (kpt_comm x pert_comm) grid shall call this contained routine
4399 : : ! as we have side-effects i.e. iqbuf_cnt set to 0.
4400 : :
4401 : : ! On disk we have the global arrays:
4402 : : !
4403 : : ! nctkarr_t("gvals", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq")
4404 : : !
4405 : : ! while the local MPI buffers are dimensioned as follows:
4406 : : !
4407 : : ! my_gbuf(2, nb_kq, nb_k, natom3, gqk%my_nk, qbuf_size)
4408 : :
4409 : : ! If parallelism over perturbation is activated, only the procs treating the first perturbation
4410 : : ! i.e. the procs treating different k-points for this q are involved in IO
4411 : : ! as all the local buffers store results for all natom3 perturbations.
4412 : :
4413 : : ! NOTE: A similar routine is used in m_gstore. The two implementations should be kept in synch.
4414 : :
4415 : : integer :: ii, iq_bz, iq_glob, my_iq
4416 : : logical :: iscontiguous
4417 : :
4418 : : ! All the procs in pert_comm write the same data (my_gbuf is summed inside pert_comm): the procs with
4419 : : ! coords_qkpb_sumbp(3) /= 0 used to skip the writes, but then the nf90_sync below, called by all the procs,
4420 : : ! fails with "NetCDF: Can't add HDF5 file metadata" when GSTORE.nc is opened with gstore%comm.
4421 : : ! SC: The GOTO was not the cause: the first access to gstore_glob_state_kqs, which was not prepared,
4422 : : ! triggered a collective metadata read done by the writers only, while the other procs were in nf90_sync.
4423 : : ! All the variables are now prepared after the open (gstore_prepare_mpiio), so the GOTO is restored:
4424 : : ! only the procs with coords_qkpb_sumbp(3) == 0 write.
4425 [ + - ]: 56 : if (gqk%coords_qkpb_sumbp(3) /= 0) goto 10 ! Yes, I'm very proud of this GOTO.
4426 : :
4427 : : !if (dtset%prtvol > 5) then
4428 : : !print *, "in dump_my_gbuf with start: ", [1, 1, 1, 1, gqk%my_kstart, iq_glob]
4429 : : !print *, " count; ", [2, gqk%nb_kq, gqk%nb_k, gqk%natom3, gqk%my_nk, iqbuf_cnt]
4430 : : !end if
4431 : :
4432 : : ! Check if the q-points in the buffer are perfectly contiguous (no cycles/holes)
4433 : 56 : iscontiguous = .True.
4434 [ + + ]: 933 : do ii=1, iqbuf_cnt
4435 : 877 : my_iq = iq_buf(1, ii)
4436 [ + - ]: 877 : if (my_iq == 0) then
4437 : : iscontiguous = .False.; exit
4438 : : end if
4439 [ + + ]: 933 : if (ii > 1) then
4440 [ + - ]: 821 : if (my_iq /= iq_buf(1, ii-1) + 1) then
4441 : : iscontiguous = .False.; exit
4442 : : end if
4443 : : end if
4444 : : end do
4445 : :
4446 [ - + ]: 56 : if (iscontiguous) then
4447 : : ! Fast path: Write slabs directly
4448 : 56 : my_iq = iq_buf(1, 1)
4449 : 56 : iq_glob = my_iq + gqk%my_qstart - 1
4450 : :
4451 : : ncerr = nf90_put_var(spin_ncid, spin_vid("gvals"), my_gbuf(:,:,:,:,:, 1:iqbuf_cnt), &
4452 : : start=[1, 1, 1, 1, gqk%my_kstart, iq_glob], &
4453 [ + + + + ]: 728 : count=[2, gqk%nb_kq, gqk%nb_k, gqk%natom3, gqk%my_nk, iqbuf_cnt])
4454 [ - + ]: 56 : NCF_CHECK(ncerr)
4455 : :
4456 : : ncerr = nf90_put_var(root_ncid, root_vid("gstore_glob_state_kqs"), state_kq(:, 1:iqbuf_cnt), &
4457 : : start=[gqk%my_kstart, iq_glob, spin], &
4458 [ + + + + ]: 392 : count=[gqk%my_nk, iqbuf_cnt, 1])
4459 [ - + ]: 56 : NCF_CHECK(ncerr)
4460 : : else
4461 : : ! Slow path: Q-points were filtered, write slice by slice avoiding holes
4462 [ # # ]: 0 : do ii=1, iqbuf_cnt
4463 : 0 : my_iq = iq_buf(1, ii)
4464 [ # # ]: 0 : if (my_iq == 0) cycle
4465 : 0 : iq_glob = my_iq + gqk%my_qstart - 1
4466 : :
4467 : : ncerr = nf90_put_var(spin_ncid, spin_vid("gvals"), my_gbuf(:,:,:,:,:, ii), &
4468 : : start=[1, 1, 1, 1, gqk%my_kstart, iq_glob], &
4469 [ # # # # ]: 0 : count=[2, gqk%nb_kq, gqk%nb_k, gqk%natom3, gqk%my_nk, 1])
4470 [ # # ]: 0 : NCF_CHECK(ncerr)
4471 : :
4472 : : ncerr = nf90_put_var(root_ncid, root_vid("gstore_glob_state_kqs"), state_kq(:, ii), &
4473 : : start=[gqk%my_kstart, iq_glob, spin], &
4474 [ # # # # ]: 0 : count=[gqk%my_nk, 1, 1])
4475 [ # # ]: 0 : NCF_CHECK(ncerr)
4476 : : end do
4477 : : end if
4478 : :
4479 : : ! SC: each k-block writes only its own k-points, and a restart skips a q-point marked as done for all the
4480 : : ! k-points. Wait until all the writers of these q-points (the procs of kpt_comm, which all treat the same
4481 : : ! q-points) have written their slab, then only one proc sets the entry in done_qbz_spin to 1.
4482 : 56 : call xmpi_barrier(gqk%kpt_comm%value)
4483 [ + + + - : 168 : if (all(gqk%coords_qkpb_sumbp(2:3) == [0, 0])) then
+ - ]
4484 [ + + ]: 933 : do ii=1,iqbuf_cnt
4485 : 877 : my_iq = iq_buf(1, ii)
4486 [ - + ]: 877 : if (my_iq == 0) cycle
4487 : 877 : iq_bz = iq_buf(2, ii)
4488 [ + + - + : 2687 : NCF_CHECK(nf90_put_var(root_ncid, root_vid("gstore_done_qbz_spin"), 1, start=[iq_bz, spin]))
- - ]
4489 : : end do
4490 : : end if
4491 : :
4492 : : ! Zero the counter before returning
4493 : 56 : 10 iqbuf_cnt = 0
4494 [ + + + + ]: 2744 : iq_buf = 0
4495 [ + + + + ]: 76088 : state_kq = GSTORE_KQ_MISSING
4496 : :
4497 : : ! These syncs can deadlock on lemaitre4 for some MPI decompositions.
4498 : : ! SC: nf90_sync is collective on a file opened with gstore%comm (HDF5 flush of the metadata cache), so all
4499 : : ! the procs must call it the same number of times. dump_my_gbuf is called a number of times that depends on
4500 : : ! the proc (my_nq differs when nqbz is not a multiple of the number of q-blocks, q-points done in a previous
4501 : : ! run are skipped on restart), hence these syncs deadlock on the machine. The file is synced once by all
4502 : : ! the procs after the loops. The syncs are not needed for restart as the q-points written before a kill are
4503 : : ! in the file (checked with kill -9 in gwpt_run, which writes GSTORE.nc in the same way).
4504 : : !if (dtset%useria /= 888) then
4505 : : ! NCF_CHECK(nf90_sync(spin_ncid))
4506 : : ! NCF_CHECK(nf90_sync(root_ncid))
4507 : : !end if
4508 : :
4509 : 56 : end subroutine dump_my_gbuf
4510 : :
4511 : 943 : integer function root_vid(var_name)
4512 : : character(len=*),intent(in) :: var_name
4513 : 943 : root_vid = nctk_idname(root_ncid, var_name)
4514 : : end function root_vid
4515 : :
4516 : 56 : integer function spin_vid(var_name)
4517 : : character(len=*),intent(in) :: var_name
4518 : 56 : spin_vid = nctk_idname(spin_ncid, var_name)
4519 : : end function spin_vid
4520 : :
4521 : : end subroutine gstore_compute
4522 : : !!***
4523 : :
4524 : : !----------------------------------------------------------------------
4525 : :
4526 : : !!****f* m_gstore/gstore_check_qkzone_gmode
4527 : : !! NAME
4528 : : !! gstore_check_cplex_qkzone_gmode
4529 : : !!
4530 : : !! FUNCTION
4531 : : !! Perform consistency checks
4532 : : !!
4533 : : !! INPUTS
4534 : : !!
4535 : : !! SOURCE
4536 : :
4537 : 9 : integer function gstore_check_cplex_qkzone_gmode(gstore, cplex, qzone, kzone, gmode, &
4538 : : kfilter, check_alloc) result(ierr) ! optional
4539 : :
4540 : : !Arguments ------------------------------------
4541 : : class(gstore_t),target,intent(in) :: gstore
4542 : : integer,intent(in) :: cplex
4543 : : character(len=*),intent(in) :: qzone, kzone, gmode
4544 : : character(len=*),optional,intent(in) :: kfilter
4545 : : logical,optional,intent(in) :: check_alloc
4546 : :
4547 : : !Local variables-------------------------------
4548 : : integer :: my_is
4549 : : logical :: check_alloc__
4550 : : ! *************************************************************************
4551 : :
4552 : 9 : ierr = 0
4553 [ - + ]: 9 : ABI_CHECK_NOSTOP(gstore%qzone == qzone, sjoin("qzone: ", qzone, "required but got: ", gstore%qzone), ierr)
4554 [ - + ]: 9 : ABI_CHECK_NOSTOP(gstore%kzone == kzone, sjoin("kzone: ", kzone, "required but got: ", gstore%kzone), ierr)
4555 [ - + ]: 9 : ABI_CHECK_NOSTOP(gstore%gmode == gmode, sjoin("gmode: ", gmode, "required but got: ", gstore%gmode), ierr)
4556 [ - + ]: 9 : if (present(kfilter)) then
4557 [ # # ]: 0 : ABI_CHECK_NOSTOP(gstore%kfilter == kfilter, sjoin("kfilter: ", kfilter, "required but got: ", gstore%kfilter), ierr)
4558 : : end if
4559 : :
4560 [ - + ]: 9 : check_alloc__ = .True.; if (present(check_alloc)) check_alloc__ = check_alloc
4561 : :
4562 [ + + ]: 18 : do my_is=1,gstore%my_nspins
4563 : 9 : associate (gqk => gstore%gqk(my_is))
4564 : 0 : ABI_CHECK_NOSTOP(gqk%cplex == cplex, sjoin("cplex:", itoa(cplex), "required but got: ", itoa(gqk%cplex)), ierr)
4565 [ - + + - ]: 9 : if (check_alloc__) then
4566 [ - + ]: 9 : if (cplex == 1) then
4567 [ # # ]: 0 : ABI_CHECK_NOSTOP(allocated(gqk%my_g2), "my_g2 array is not allocated", ierr)
4568 [ + - ]: 9 : else if (cplex == 2) then
4569 [ - + ]: 9 : ABI_CHECK_NOSTOP(allocated(gqk%my_g), "my_g array is not allocated", ierr)
4570 : : end if
4571 : : end if
4572 : : end associate
4573 : : end do
4574 : :
4575 : 9 : end function gstore_check_cplex_qkzone_gmode
4576 : : !!***
4577 : :
4578 : : !----------------------------------------------------------------------
4579 : :
4580 : : !!****f* m_gstore/gstore_from_ncpath
4581 : : !! NAME
4582 : : !! gstore_from_ncpath
4583 : : !!
4584 : : !! FUNCTION
4585 : : !! Reconstruct a gstore_t instance from a netcdf file.
4586 : : !!
4587 : : !! INPUTS
4588 : : !! path: Path to the GSTORE file.
4589 : : !! with_cplex: 0 to read no matrix elements, 1 for |g|^2, 2 for complex g.
4590 : : !! with_gmode defines the representation.
4591 : : !! dtset: Input variables
4592 : : !! cryst: crystalline structure
4593 : : !! ebands: KS energies
4594 : : !! ifc: interatomic force constants
4595 : : !! with_gmode: "phonon" to have g in the phonon representation or "atom" to have them in atom representation.
4596 : : !! gvals_name: "gvals" or "gvals_ks" to read the KS gs produced by the GWPT code.
4597 : : !! This option is valid only for gstore files produced by the GWPT code.
4598 : : !! with_g2dw: True if Debye-Waller g2 in the RIA should be computed and stored in memory.
4599 : : !! comm: MPI communicator.
4600 : : !!
4601 : : !! SOURCE
4602 : :
4603 : 16 : subroutine gstore_from_ncpath(gstore, path, with_cplex, dtset, dtfil, cryst, ebands, ifc, &
4604 : : with_gmode, gvals_name, with_g2dw, comm)
4605 : :
4606 : : !Arguments ------------------------------------
4607 : : class(gstore_t),target,intent(out) :: gstore
4608 : : character(len=*),intent(in) :: path
4609 : : integer,intent(in) :: with_cplex
4610 : : type(dataset_type),target,intent(in) :: dtset
4611 : : type(datafiles_type),intent(in) :: dtfil
4612 : : class(crystal_t),target,intent(in) :: cryst
4613 : : class(ebands_t),target,intent(in) :: ebands
4614 : : class(ifc_type),target,intent(in) :: ifc
4615 : : character(len=*),intent(in) :: with_gmode, gvals_name
4616 : : logical,intent(in) :: with_g2dw
4617 : : integer,intent(in) :: comm
4618 : :
4619 : : !Local variables-------------------------------
4620 : : !scalars
4621 : : integer,parameter :: master = 0
4622 : : integer :: my_rank, ncid, spin, spin_ncid, nproc, ierr, fform, max_nb, ib, natom, natom3, ib_m, ib_n !, varid
4623 : : integer :: max_nq, max_nk, ncerr, my_is, my_iq, iq_glob, my_ik, ik_glob
4624 : : integer :: nb_k, nb_kq, nb_k_file, nb_kq_file, gstore_cplex, ib_kq_start, file_fnlen !, ip1, ip2
4625 : : integer :: my_ip, ipert, iq_ibz, iq_bz, isym_q, trev_q, tsign_q, ii !, im_kq
4626 : : real(dp),parameter :: G_SMALL = tol8
4627 : : real(dp) :: cpu, wall, gflops, wqnu
4628 : : logical :: isirr_q, from_atm_to_nu, has_iv1p_comm, read_ks, has_both_g
4629 : 16 : type(hdr_type) :: wfk0_hdr
4630 [ + + + + : 832 : type(crystal_t) :: gstore_cryst
+ + + + +
+ + + + +
+ + + + ]
4631 : : type(gqk_t),pointer :: gqk
4632 : : character(len=500) :: msg
4633 : : !arrays
4634 : 64 : integer :: units(2), ibuffer(9), nproc_spin(ebands%nsppol), comm_spin(ebands%nsppol)
4635 : 32 : integer :: brange_k_spin(2, ebands%nsppol), brange_kq_spin(2, ebands%nsppol), file_brange_kq_spin(2, ebands%nsppol), g0_q(3)
4636 : 16 : integer,allocatable :: qglob2bz(:,:), qbz2ibz(:,:)
4637 : : real(dp) :: qq_ibz(3)
4638 : 32 : real(dp) :: displ_nu_red(2, 3, cryst%natom)
4639 : 16 : real(dp),allocatable :: gwork_q(:,:,:,:,:), slice_bb(:,:,:), iv1p_comm(:,:,:,:,:)
4640 : 16 : real(dp),allocatable :: ks_gwork_q(:,:,:,:,:), ks_slice_bb(:,:,:)
4641 : 16 : real(dp),allocatable :: phfreqs_ibz(:,:), pheigvec_cart_ibz(:,:,:,:,:), pheigvec_cart_qbz(:,:,:,:)
4642 : 16 : real(dp),allocatable :: displ_cart_qbz(:,:,:,:), displ_red_qbz(:,:,:,:), gmn_nu(:,:,:,:)
4643 [ + - ]: 16 : complex(dp),allocatable :: tpp_red(:,:), my_gq0nm_atm(:,:,:,:), ks_my_gq0nm_atm(:,:,:,:)
4644 : : ! *************************************************************************
4645 : :
4646 : 16 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
4647 : :
4648 [ - + ]: 16 : ABI_CHECK(with_cplex >= 0 .and. with_cplex <= 2, sjoin("Invalid with_cplex:", itoa(with_cplex)))
4649 : :
4650 [ + + ]: 48 : units = [std_out, ab_out]
4651 : 16 : call wrtout(units, sjoin("- Reading e-ph matrix elements from: ", path), pre_newlines=1)
4652 : 16 : call wrtout(units, sjoin(" Asking for with_cplex: ", itoa(with_cplex)))
4653 [ + - ]: 16 : call wrtout(units, sjoin(" Asking for with_gmode: ", trim(with_gmode)))
4654 [ + - ]: 16 : call wrtout(units, sjoin(" Asking for gvals_name: ", trim(gvals_name)))
4655 : 16 : call wrtout(units, sjoin(" Asking for g2dw: ", yesno(with_g2dw)))
4656 : :
4657 : : ! Set basic parameters.
4658 [ - + ]: 16 : gstore%comm = comm; gstore%nsppol = dtset%nsppol; gstore%path = path
4659 : :
4660 : : ! Get references to other data structures.
4661 : 16 : gstore%dtset => dtset; gstore%cryst => cryst; gstore%ebands => ebands; gstore%ifc => ifc; gstore%kibz => ebands%kptns
4662 : :
4663 : 16 : natom = cryst%natom; natom3 = cryst%natom * 3
4664 : :
4665 [ - + + - : 96 : ABI_CALLOC(gstore%erange_spin, (2, gstore%nsppol))
+ - + - -
+ - + - +
+ + + + ]
4666 [ - + + - : 48 : ABI_MALLOC(gstore%glob_nk_spin, (gstore%nsppol))
+ - + - -
+ - + -
+ ]
4667 [ - + + - : 48 : ABI_MALLOC(gstore%glob_nq_spin, (gstore%nsppol))
+ - + - -
+ - + -
+ ]
4668 : :
4669 : : ! =====================================================
4670 : : ! Master node reads basic objects and gstore dimensions
4671 : : ! =====================================================
4672 : :
4673 [ + - ]: 16 : if (my_rank == master) then
4674 : 16 : call wrtout(units, sjoin(" Initializing gstore object from:", path, ch10))
4675 [ - + ]: 16 : ABI_CHECK(path /= ABI_NOFILE, "Use getgstore_filepath to specify the path to GSTORE.nc")
4676 [ - + ]: 16 : NCF_CHECK(nctk_open_read(ncid, path, xmpi_comm_self))
4677 : :
4678 : 16 : call wfk0_hdr%ncread(ncid, fform)
4679 [ - + ]: 16 : ABI_CHECK(fform /= 0, sjoin("Error while reading:", path))
4680 : :
4681 : : ! Read gstore dimensions
4682 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_cplex", gstore_cplex))
4683 [ - + ]: 16 : ABI_CHECK_IEQ(gstore_cplex, 2, "gstore_cplex 1 from file not supported")
4684 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nkibz", gstore%nkibz))
4685 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nkbz", gstore%nkbz))
4686 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nqibz", gstore%nqibz))
4687 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nqbz", gstore%nqbz))
4688 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_max_nq", max_nq))
4689 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_max_nk", max_nk))
4690 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_max_nb", max_nb))
4691 : :
4692 : : ! Read gstore variables
4693 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_with_vk"), gstore%with_vk))
4694 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qptopt"), gstore%qptopt))
4695 : :
4696 : : ! little group variables were added in Abinit v10.5.6.
4697 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_use_lgk"), gstore%has_used_lgk))
4698 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_use_lgq"), gstore%has_used_lgq))
4699 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kzone"), gstore%kzone))
4700 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qzone"), gstore%qzone))
4701 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kfilter"), gstore%kfilter))
4702 : : ! SC: GSTORE.nc files written before fnlen was raised from 264 to 400 have a shorter fnlen dimension.
4703 : : ! Read only the characters present in the file so that these old files can still be read.
4704 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "fnlen", file_fnlen))
4705 : 16 : gstore%wfk0_path = ""
4706 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_wfk0_path"), gstore%wfk0_path(1:min(fnlen, file_fnlen))))
4707 : 16 : call replace_ch0(gstore%kzone); call replace_ch0(gstore%qzone); call replace_ch0(gstore%kfilter)
4708 : 16 : call replace_ch0(gstore%wfk0_path)
4709 : :
4710 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_gtype"), gstore%gtype))
4711 : 16 : call replace_ch0(gstore%gtype)
4712 : : !print *, "gstore%gtype:", gstore%gtype
4713 : :
4714 [ + + ]: 16 : if (gvals_name == "gvals_ks") then
4715 : 2 : call wrtout(units, " Reading KS e-ph matrix elements")
4716 [ + - ]: 14 : else if (gvals_name == "gvals") then
4717 [ + + ]: 14 : if (gstore%gtype == GSTORE_GTYPE_GWPT) then
4718 : 4 : call wrtout(units, " Reading GWPT e-ph matrix elements")
4719 : : else
4720 : 10 : call wrtout(units, " Reading KS e-ph matrix elements")
4721 : : end if
4722 : : end if
4723 : :
4724 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_ngqpt"), gstore%ngqpt))
4725 : :
4726 [ - + + - : 48 : ABI_MALLOC(gstore%qibz, (3, gstore%nqibz))
+ - + - -
+ - + -
+ ]
4727 [ - + + - : 48 : ABI_MALLOC(gstore%wtq, (gstore%nqibz))
+ - + - -
+ - + -
+ ]
4728 [ - + + - : 48 : ABI_MALLOC(gstore%qbz, (3, gstore%nqbz))
+ - + - -
+ - + -
+ ]
4729 [ - + + - : 48 : ABI_MALLOC(gstore%kbz, (3, gstore%nkbz))
+ - + - -
+ - + -
+ ]
4730 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_k_spin"), brange_k_spin))
4731 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_kq_spin"), brange_kq_spin))
4732 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_erange_spin"), gstore%erange_spin))
4733 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qibz"), gstore%qibz))
4734 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_wtq"), gstore%wtq))
4735 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qbz"), gstore%qbz))
4736 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kbz"), gstore%kbz))
4737 : :
4738 [ - + + - : 48 : ABI_MALLOC(qbz2ibz, (6, gstore%nqbz))
+ - + - -
+ - + -
+ ]
4739 [ - + + - : 48 : ABI_MALLOC(gstore%kbz2ibz, (6, gstore%nkbz))
+ - + - -
+ - + -
+ ]
4740 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qbz2ibz"), qbz2ibz))
4741 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kbz2ibz"), gstore%kbz2ibz))
4742 : :
4743 [ - + + - : 64 : ABI_MALLOC(qglob2bz, (max_nq, gstore%nsppol))
- + + - +
- + - - +
- + - + ]
4744 [ - + + - : 64 : ABI_MALLOC(gstore%kglob2bz, (max_nk, gstore%nsppol))
- + + - +
- + - - +
- + - + ]
4745 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qglob2bz"), qglob2bz))
4746 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kglob2bz"), gstore%kglob2bz))
4747 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_glob_nq_spin"), gstore%glob_nq_spin))
4748 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_glob_nk_spin"), gstore%glob_nk_spin))
4749 : :
4750 : : ! Read optional variables:
4751 [ - + ]: 16 : if (gstore%kfilter == "fs_tetra") then
4752 [ # # # # : 0 : ABI_MALLOC(gstore%delta_ef_kibz_spin, (max_nb, gstore%nkibz, gstore%nsppol))
# # # # #
# # # # #
# # # # #
# # # ]
4753 [ # # ]: 0 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_delta_ef_kibz_spin"), gstore%delta_ef_kibz_spin))
4754 : : end if
4755 : :
4756 [ - + ]: 16 : NCF_CHECK(nf90_close(ncid))
4757 : :
4758 : : ! =================
4759 : : ! Consistency check
4760 : : ! =================
4761 [ - + - + : 16 : gstore_cryst = wfk0_hdr%get_crystal()
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + ]
4762 [ - + ]: 16 : if (cryst%compare(gstore_cryst, header=" Comparing input crystal with the one from GSTORE file") /= 0) then
4763 : 0 : ABI_ERROR("Crystal structure from input and GSTORE do not agree! Check messages above!")
4764 : : end if
4765 : 16 : call gstore_cryst%free()
4766 : : end if ! master
4767 : :
4768 [ - + ]: 16 : if (nproc > 1) then
4769 : : ! Broadcast the header.
4770 : 0 : call wfk0_hdr%bcast(master, my_rank, comm)
4771 : :
4772 : : ! Broadcast dimensions.
4773 [ # # ]: 0 : if (my_rank == master) then
4774 [ # # ]: 0 : ibuffer = [gstore_cplex, gstore%nkibz, gstore%nkbz, gstore%nqibz, gstore%nqbz, gstore%with_vk, max_nq, max_nk, max_nb]
4775 : : end if
4776 : 0 : call xmpi_bcast(ibuffer, master, comm, ierr)
4777 : :
4778 [ # # ]: 0 : if (my_rank /= master) then
4779 : : ! Other MPI procs need to store dims and allocate memory before the bcast.
4780 : 0 : gstore_cplex = ibuffer(1)
4781 : 0 : gstore%nkibz = ibuffer(2)
4782 : 0 : gstore%nkbz = ibuffer(3)
4783 : 0 : gstore%nqibz = ibuffer(4)
4784 : 0 : gstore%nqbz = ibuffer(5)
4785 : 0 : gstore%with_vk = ibuffer(6)
4786 : 0 : max_nq = ibuffer(7)
4787 : 0 : max_nk = ibuffer(8)
4788 : 0 : max_nb = ibuffer(9)
4789 : :
4790 [ # # # # : 0 : ABI_MALLOC(gstore%qibz, (3, gstore%nqibz))
# # # # #
# # # #
# ]
4791 [ # # # # : 0 : ABI_MALLOC(gstore%wtq, (gstore%nqibz))
# # # # #
# # # #
# ]
4792 [ # # # # : 0 : ABI_MALLOC(gstore%qbz, (3, gstore%nqbz))
# # # # #
# # # #
# ]
4793 [ # # # # : 0 : ABI_MALLOC(gstore%kbz, (3, gstore%nkbz))
# # # # #
# # # #
# ]
4794 [ # # # # : 0 : ABI_MALLOC(qbz2ibz, (6, gstore%nqbz))
# # # # #
# # # #
# ]
4795 [ # # # # : 0 : ABI_MALLOC(gstore%kbz2ibz, (6, gstore%nkbz))
# # # # #
# # # #
# ]
4796 [ # # # # : 0 : ABI_MALLOC(qglob2bz, (max_nq, gstore%nsppol))
# # # # #
# # # # #
# # # # ]
4797 [ # # # # : 0 : ABI_MALLOC(gstore%kglob2bz, (max_nk, gstore%nsppol))
# # # # #
# # # # #
# # # # ]
4798 : : end if
4799 : :
4800 : 0 : call xmpi_bcast(gstore%qptopt, master, comm, ierr)
4801 : 0 : call xmpi_bcast(gstore%has_used_lgk, master, comm, ierr)
4802 : 0 : call xmpi_bcast(gstore%has_used_lgq, master, comm, ierr)
4803 : 0 : call xmpi_bcast(gstore%kzone, master, comm, ierr)
4804 : 0 : call xmpi_bcast(gstore%qzone, master, comm, ierr)
4805 : 0 : call xmpi_bcast(gstore%kfilter, master, comm, ierr)
4806 : 0 : call xmpi_bcast(gstore%gmode, master, comm, ierr)
4807 : 0 : call xmpi_bcast(gstore%gtype, master, comm, ierr)
4808 : 0 : call xmpi_bcast(gstore%ngqpt, master, comm, ierr)
4809 : 0 : call xmpi_bcast(gstore%wfk0_path, master, comm, ierr)
4810 : 0 : call xmpi_bcast(brange_k_spin, master, comm, ierr)
4811 : 0 : call xmpi_bcast(brange_kq_spin, master, comm, ierr)
4812 : 0 : call xmpi_bcast(gstore%erange_spin, master, comm, ierr)
4813 : 0 : call xmpi_bcast(gstore%qibz, master, comm, ierr)
4814 : 0 : call xmpi_bcast(gstore%wtq, master, comm, ierr)
4815 : 0 : call xmpi_bcast(gstore%qbz, master, comm, ierr)
4816 : 0 : call xmpi_bcast(gstore%kbz, master, comm, ierr)
4817 : 0 : call xmpi_bcast(qbz2ibz, master, comm, ierr)
4818 : 0 : call xmpi_bcast(gstore%kbz2ibz, master, comm, ierr)
4819 : 0 : call xmpi_bcast(qglob2bz, master, comm, ierr)
4820 : 0 : call xmpi_bcast(gstore%kglob2bz, master, comm, ierr)
4821 : 0 : call xmpi_bcast(gstore%glob_nq_spin, master, comm, ierr)
4822 : 0 : call xmpi_bcast(gstore%glob_nk_spin, master, comm, ierr)
4823 : :
4824 [ # # ]: 0 : if (gstore%kfilter == "fs_tetra") then
4825 [ # # ]: 0 : if (my_rank /= master) then
4826 [ # # # # : 0 : ABI_MALLOC(gstore%delta_ef_kibz_spin, (max_nb, gstore%nkibz, gstore%nsppol))
# # # # #
# # # # #
# # # # #
# # # ]
4827 : : end if
4828 : 0 : call xmpi_bcast(gstore%delta_ef_kibz_spin, master, comm, ierr)
4829 : : end if
4830 : : end if ! nproc > 1.
4831 : :
4832 : : ! Consistency check
4833 : 16 : call wfk0_hdr%vs_dtset(dtset); call wfk0_hdr%free()
4834 : :
4835 : : ! When reading an existing GSTORE file, gstore_brange selects a smaller window of
4836 : : ! intermediate states at k+q. The external-state window at k is always the one on disk.
4837 : : ! Keep the file range to compute the offset in the NetCDF nb_kq dimension below.
4838 [ + + + + ]: 64 : file_brange_kq_spin = brange_kq_spin
4839 [ + + ]: 32 : do spin=1,gstore%nsppol
4840 [ + + + + : 62 : if (any(dtset%gstore_brange(:, spin) /= 0)) then
+ + ]
4841 [ + + + - : 3 : ABI_CHECK(all(dtset%gstore_brange(:, spin) /= 0), "Both entries of gstore_brange must be specified")
- + ]
4842 [ - + ]: 1 : ABI_CHECK_IEQ(dtset%gstore_brange(2, spin), dtset%mband, "gstore_brange(2, spin) must be equal to nband")
4843 [ + - ]: 1 : if (dtset%eph_stern /= 0) then
4844 [ - + ]: 1 : ABI_CHECK_IEQ(dtset%gstore_brange(1, spin), 1, "gstore_brange(1, spin) must be 1 when eph_stern is enabled")
4845 : : end if
4846 : : msg = sjoin("Requested gstore_brange:", ltoa(dtset%gstore_brange(:, spin)), "is not contained in the k+q band range stored in GSTORE.nc:", &
4847 [ + - ]: 1 : ltoa(file_brange_kq_spin(:, spin)))
4848 [ + - - + ]: 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)
4849 [ + + ]: 3 : brange_kq_spin(:, spin) = dtset%gstore_brange(:, spin)
4850 : : call wrtout(units, sjoin(" Restricting k+q states for spin", itoa(spin), "to gstore_brange:", &
4851 : 1 : ltoa(brange_kq_spin(:, spin))))
4852 : : end if
4853 : : end do
4854 : :
4855 : : ! If has_both_g is true, we allocate and read both the KS and the GWPT matrix elements.
4856 : 16 : read_ks = gstore%gtype == GSTORE_GTYPE_GWPT
4857 : 16 : has_both_g = gstore%gtype == GSTORE_GTYPE_GWPT
4858 : :
4859 : : ! Distribute spins, create indirect mapping to spin index and init gstore%brange_k_spin
4860 : 16 : call gstore%distribute_spins__(ebands%mband, brange_kq_spin, brange_k_spin, nproc_spin, comm_spin, comm)
4861 : :
4862 : : ! Compute krank
4863 [ + - - - : 16 : call gstore%krank_ibz%from_kptrlatt(gstore%nkibz, gstore%kibz, ebands%kptrlatt, compute_invrank=.False.)
- - - - -
+ ]
4864 : :
4865 : 16 : call gstore%set_mpi_grid__(dtfil, nproc_spin, comm_spin)
4866 : :
4867 : : ! At this point, we have the Cartesian grid (one per spin if any) and we can finally allocate and distribute other arrays.
4868 : 16 : call gstore%malloc__(with_cplex, has_both_g, max_nq, qglob2bz, max_nk, gstore%kglob2bz, qbz2ibz, gstore%kbz2ibz)
4869 : :
4870 : 16 : call xmpi_comm_free(comm_spin)
4871 : :
4872 : : ! Now we read the big arrays with MPI-IO and hdf5 groups.
4873 : : ! Note the loop over spin as each gqk has its own dimensions.
4874 : : ! Recall the shape of the arrays:
4875 : : !
4876 : : ! In memory, we have allocated:
4877 : : !
4878 : : ! my_g(my_npert, nb_kq, my_nq, nb_k, my_nk) if with_cplex == 2 (complex array)
4879 : : !
4880 : : ! or
4881 : : !
4882 : : ! my_g2(my_npert, nb_kq, my_nq, nb_k, my_nk) if with_cplex == 1
4883 : : !
4884 : : ! On disk, we have:
4885 : : !
4886 : : ! nctkarr_t("gvals", "dp", "two, nb_kq_disk, nb_k_disk, natom3, glob_nk, glob_nq")
4887 : : !
4888 : 16 : call cwtime(cpu, wall, gflops, "start")
4889 : :
4890 : : ! ===================================================
4891 : : ! Load phonon frequencies and eigenvectors in the IBZ
4892 : : ! ===================================================
4893 : :
4894 : : ! nctkarr_t("phfreqs_ibz", "dp", "natom3, gstore_nqibz")
4895 : : ! nctkarr_t("pheigvec_cart_ibz", "dp", "two, three, natom, natom3, gstore_nqibz")
4896 [ - + + - : 64 : ABI_MALLOC(phfreqs_ibz, (natom3, gstore%nqibz))
- + + - +
- + - - +
- + - + ]
4897 [ - + + - : 80 : ABI_MALLOC(pheigvec_cart_ibz, (2, 3, cryst%natom, cryst%natom * 3, gstore%nqibz))
+ - - + +
- - + + -
+ - + - -
+ - + -
+ ]
4898 [ - + + - : 64 : ABI_MALLOC(pheigvec_cart_qbz, (2, 3, cryst%natom, cryst%natom * 3))
- + + - +
- + - - +
- + ]
4899 [ - + + - : 48 : ABI_MALLOC(displ_cart_qbz, (2, 3, cryst%natom, cryst%natom * 3))
- + + - -
+ - + ]
4900 [ - + + - : 64 : ABI_MALLOC(displ_red_qbz, (2, 3, cryst%natom, natom3))
- + + - +
- + - - +
- + ]
4901 : :
4902 : : !NCF_CHECK(nctk_open_read(ncid, gstore%path, gstore%comm))
4903 : : ! SC: Open with xmpi_comm_self (independent IO) instead of gqk%comm, otherwise there will be a deadlock on lemaitre4
4904 [ - + ]: 16 : NCF_CHECK(nctk_open_read(ncid, gstore%path, xmpi_comm_self))
4905 : 16 : has_iv1p_comm = gstore_nc_has_iv1p_comm(gstore, ncid)
4906 : : ! SC: nctk_set_collective can cause a deadlock on lemaitre4
4907 : : !if (nproc > 1) then
4908 : : ! NCF_CHECK(nctk_set_collective(ncid, vid("phfreqs_ibz")))
4909 : : ! NCF_CHECK(nctk_set_collective(ncid, vid("pheigvec_cart_ibz")))
4910 : : !end if
4911 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("phfreqs_ibz"), phfreqs_ibz))
4912 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("pheigvec_cart_ibz"), pheigvec_cart_ibz))
4913 [ - + ]: 16 : NCF_CHECK(nf90_close(ncid))
4914 : :
4915 : : ! =========================
4916 : : ! Load e-ph matrix elements
4917 : : ! =========================
4918 : 16 : call pstat_proc%print(_PSTAT_ARGS_)
4919 : :
4920 : 16 : from_atm_to_nu = .False.
4921 : : ! Compare with_gmode with the one on disk. The only conversion I can think of is: atom --> phonon.
4922 [ - + ]: 16 : if (gstore%gmode /= with_gmode) then
4923 [ + - + - ]: 16 : if (gstore%gmode == GSTORE_GMODE_ATOM .and. with_gmode == GSTORE_GMODE_PHONON) then
4924 : 16 : from_atm_to_nu = .True.; gstore%gmode = GSTORE_GMODE_PHONON ! Change gstore%gmode here
4925 : : else
4926 : 0 : ABI_ERROR(sjoin("Conversion from gstore%gmode: ", gstore%gmode, "to:", with_gmode, " is not yet supported"))
4927 : : end if
4928 : : end if
4929 [ + - ]: 16 : gstore%gmode = with_gmode
4930 : :
4931 [ + + ]: 16 : if (with_g2dw) then
4932 [ - + ]: 7 : ABI_CHECK(with_gmode == GSTORE_GMODE_PHONON, "g2dw in the atom representation is not coded")
4933 [ - + + - : 28 : ABI_MALLOC(tpp_red, (natom3, natom3))
- + + - +
- + - - +
- + ]
4934 : : end if
4935 : :
4936 [ + + ]: 32 : do spin=1,gstore%nsppol
4937 : 16 : my_is = gstore%spin2my_is(spin)
4938 : :
4939 [ + - ]: 32 : if (my_is /= 0) then
4940 : 16 : gqk => gstore%gqk(my_is)
4941 : :
4942 [ - + + - : 64 : ABI_MALLOC(gqk%my_wnuq, (gqk%my_npert, gqk%my_nq))
- + + - +
- + - - +
- + - + ]
4943 [ - + + - : 80 : ABI_MALLOC(gqk%my_displ_cart, (2, 3, cryst%natom, gqk%my_npert, gqk%my_nq))
- + + - -
+ + - + -
+ - - + -
+ - + ]
4944 : :
4945 : : !NCF_CHECK(nctk_open_read(ncid, gstore%path, gqk%comm%value))
4946 : : ! SC: Open with xmpi_comm_self (independent IO) instead of gqk%comm, otherwise there will be a deadlock on lemaitre4
4947 [ - + ]: 16 : NCF_CHECK(nctk_open_read(ncid, gstore%path, xmpi_comm_self))
4948 [ - + ]: 16 : NCF_CHECK(nf90_inq_ncid(ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
4949 : :
4950 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_k", nb_k_file))
4951 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_kq", nb_kq_file))
4952 : :
4953 : : ! Note that these dimensions should be compatible with what is stored on disk.
4954 : 16 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
4955 [ - + ]: 16 : ABI_CHECK_IEQ(nb_k, nb_k_file, "nb_k !/ nb_k_file")
4956 [ - + ]: 16 : ABI_CHECK_ILEQ(nb_kq, nb_kq_file, "nb_kq > nb_kq_file")
4957 : 16 : ib_kq_start = gqk%bstart_kq - file_brange_kq_spin(1, spin) + 1
4958 [ + - - + ]: 16 : ABI_CHECK_IRANGE(ib_kq_start, 1, nb_kq_file, "Invalid k+q band offset in GSTORE.nc")
4959 [ - + ]: 16 : ABI_CHECK_ILEQ(ib_kq_start + nb_kq - 1, nb_kq_file, "Requested k+q band window exceeds GSTORE.nc")
4960 : :
4961 : : ! gstore_cplex defines the data on disk while cplex defines what we want to store in memory
4962 [ - + + - : 112 : ABI_MALLOC_OR_DIE(gwork_q, (gstore_cplex, nb_kq, nb_k, gqk%natom3, gqk%glob_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - -
+ + - -
+ ]
4963 [ - + + - : 80 : ABI_MALLOC(slice_bb, (gstore_cplex, nb_kq, nb_k))
- + + - -
+ + - + -
+ - - + -
+ ]
4964 [ + + ]: 16 : if (read_ks) then
4965 [ - + + - : 42 : ABI_MALLOC_OR_DIE(ks_gwork_q, (gstore_cplex, nb_kq, nb_k, gqk%natom3, gqk%glob_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - -
+ + - -
+ ]
4966 [ - + + - : 30 : ABI_MALLOC(ks_slice_bb, (gstore_cplex, nb_kq, nb_k))
- + + - -
+ + - + -
+ - - + -
+ - + ]
4967 : : end if
4968 : :
4969 [ + + ]: 16 : if (with_g2dw) then
4970 : : ! Read my_gq0nm_atm matrix elements for DW in the RIA. Find the index of q = 0.
4971 : 7 : iq_glob = -1
4972 [ + - ]: 7 : do ii=1, gstore%glob_nq_spin(spin)
4973 : 7 : iq_bz = qglob2bz(ii, spin)
4974 [ + + + - ]: 28 : if (sum(gstore%qbz(:, iq_bz)**2) < tol4) then
4975 : 7 : iq_glob = ii; exit
4976 : : end if
4977 : : end do
4978 [ - + ]: 7 : ABI_CHECK_INEQ(iq_glob, -1, "Cannot finq q=0 in g(k,q)!")
4979 : 7 : call wrtout(std_out, sjoin(" Reading g_atm(k,q=0) for Debye-Waller with iq_glob:", itoa(iq_glob)))
4980 : :
4981 : : ! Read q-slice of the e-ph matrix elements (individual IO).
4982 : : ! Note gvals_name so that we can read either g^KS or g^Sigma.
4983 [ + + ]: 49 : ncerr = nf90_get_var(spin_ncid, spin_vid(gvals_name), gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
4984 [ - + ]: 7 : NCF_CHECK(ncerr)
4985 : :
4986 [ + + ]: 7 : if (read_ks) then
4987 [ + + ]: 42 : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals_ks"), ks_gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
4988 [ - + ]: 6 : NCF_CHECK(ncerr)
4989 : : ! Here we set g_GWPT g to g_KS if g_KS is smaller than a certain threshold as GWPT breaks symmetries.
4990 [ + + + + : 13931 : where (abs(ks_gwork_q) < G_SMALL)
+ + + + +
+ + + ]
4991 : : gwork_q = ks_gwork_q
4992 : : end where
4993 : : end if
4994 : :
4995 : : ! Allocate gdw2
4996 [ - + + - : 49 : ABI_MALLOC(gqk%my_gdw2, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk))
- + + - -
+ + - - +
+ - - + +
- + - + -
- + - + -
+ ]
4997 : 7 : gqk%my_gdw2_ks => gqk%my_gdw2
4998 : : ! Allocate my_gq0nm_atm and transfer data. Note TRANSPOSITION in (m, n) indices.
4999 [ - + + - : 42 : ABI_MALLOC(my_gq0nm_atm, (nb_k, nb_kq, natom3, gqk%my_nk))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
5000 : :
5001 [ + + ]: 7 : if (gqk%has_both_g) then
5002 [ - + + - : 36 : ABI_MALLOC(gqk%my_gdw2_ks, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk))
- + + - -
+ + - - +
+ - - + +
- - + -
+ ]
5003 [ - + + - : 30 : ABI_MALLOC(ks_my_gq0nm_atm, (nb_k, nb_kq, natom3, gqk%my_nk))
- + + - -
+ + - - +
+ - - + -
+ - + ]
5004 : : end if
5005 : :
5006 [ + + ]: 19 : do my_ik=1,gqk%my_nk
5007 : 12 : ik_glob = my_ik + gqk%my_kstart - 1
5008 [ + + ]: 167 : do ib_m=1,nb_kq
5009 [ + + ]: 988 : do ib_n=1,nb_k
5010 [ + + ]: 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)
5011 [ + + ]: 976 : if (gqk%has_both_g) then
5012 [ + + ]: 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)
5013 : : end if
5014 : : end do
5015 : : end do
5016 : : end do
5017 : : end if ! with_g2dw
5018 : :
5019 [ - + ]: 16 : if (has_iv1p_comm) then
5020 : : ! Read matrix elements of commutator [iv, p].
5021 [ # # # # : 0 : ABI_MALLOC(gqk%my_iv1p_comm, (nb_k, nb_k, 3, gqk%my_npert, gqk%my_nk))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5022 [ # # # # : 0 : ABI_MALLOC(iv1p_comm, (2, nb_k, nb_k, 3, natom3))
# # # # #
# # # # #
# # # # #
# # # #
# ]
5023 : : ! nctkarr_t("iv1p_comm", "dp", "two, nb_k, nb_k, three, natom3, glob_nk")
5024 : :
5025 [ # # ]: 0 : do my_ik=1,gqk%my_nk
5026 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
5027 [ # # ]: 0 : ncerr = nf90_get_var(spin_ncid, spin_vid("iv1p_comm"), iv1p_comm, start=[1,1,1,1,1, ik_glob])
5028 [ # # ]: 0 : NCF_CHECK(ncerr)
5029 : :
5030 : : ! Save my perturbations for this k-point.
5031 [ # # ]: 0 : do my_ip=1,gqk%my_npert
5032 : 0 : ipert = gqk%my_pertcases(my_ip)
5033 [ # # # # : 0 : gqk%my_iv1p_comm(:,:,:,my_ip, my_ik) = r2c(iv1p_comm(:,:,:,:,ipert))
# # # # ]
5034 : : end do
5035 : : end do
5036 [ # # ]: 0 : ABI_FREE(iv1p_comm)
5037 : : end if
5038 : :
5039 [ + - ]: 16 : if (from_atm_to_nu) then
5040 [ - + + - : 80 : ABI_MALLOC(gmn_nu, (2, nb_kq, nb_k, 3*natom))
- + + - +
- - + + -
+ - + - -
+ - + -
+ ]
5041 : : end if
5042 : :
5043 : : ! Read my e-ph matrix elements.
5044 [ + + ]: 1365 : do my_iq=1,gqk%my_nq
5045 : 1349 : iq_glob = my_iq + gqk%my_qstart - 1
5046 : :
5047 : : !call wrtout(std_out, " Computing and storing phonons in the full BZ by rotating the data in the IBZ...")
5048 : 1349 : iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
5049 : 1349 : trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5, my_iq)
5050 : : !isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
5051 : 1349 : isirr_q = (isym_q == 1 .and. trev_q == 0)
5052 : 1349 : tsign_q = 1; if (trev_q == 1) tsign_q = -1
5053 [ + + ]: 5396 : qq_ibz = gstore%qibz(:, iq_ibz)
5054 : :
5055 : : ! Here we get the ph displacement for this q-point in the BZ from the image in the IBZ.
5056 : : ! This is important for complex g as we have to enforce the gauge in the ph eigenvectors, including e(-q) = e(q)^*.
5057 : : call pheigvec_rotate(cryst, qq_ibz, isym_q, trev_q, pheigvec_cart_ibz(:,:,:,:,iq_ibz), pheigvec_cart_qbz, displ_cart_qbz, &
5058 : 1349 : displ_red_qbz=displ_red_qbz)
5059 : :
5060 : : ! Save my frequencies and my phonon displacements.
5061 [ + - + + : 17537 : gqk%my_wnuq(:, my_iq) = phfreqs_ibz(gqk%my_pertcases(:), iq_ibz)
+ + ]
5062 [ + - + + : 179417 : gqk%my_displ_cart(:,:,:,:,my_iq) = displ_cart_qbz(:,:,:,gqk%my_pertcases(:))
+ + + + +
+ + + ]
5063 : :
5064 [ + + ]: 1349 : if (with_g2dw) then
5065 [ + + ]: 1176 : do my_ip=1,gqk%my_npert
5066 : : ! Compute T_pp'(q,nu) matrix in reduced coordinates for DW.
5067 : 1008 : call phdispl_cart2red_nmodes(natom, 1, cryst%gprimd, gqk%my_displ_cart(:,:,:,my_ip,my_iq), displ_nu_red)
5068 : 1008 : call sigtk_dw_tpp_red(natom, displ_nu_red, tpp_red)
5069 : 1008 : wqnu = gqk%my_wnuq(my_ip, my_iq)
5070 : :
5071 [ + + ]: 2424 : do my_ik=1,gqk%my_nk
5072 [ + + + + ]: 2256 : if (.not. gqk%has_both_g .or. dtset%gwpt_g2mode == 1) then
5073 : : call calc_and_store_gdw2(gqk, my_ik, my_iq, my_ip, wqnu, tpp_red, &
5074 : 864 : my_gq0nm_atm(:,:,:,my_ik), my_gq0nm_atm(:,:,:,my_ik))
5075 : : else
5076 : : !print *, "Computing g2dw with both g^KS g_GWPT"
5077 : : call calc_and_store_gdw2(gqk, my_ik, my_iq, my_ip, wqnu, tpp_red, &
5078 : 384 : ks_my_gq0nm_atm(:,:,:,my_ik), my_gq0nm_atm(:,:,:,my_ik))
5079 : : end if
5080 : : end do ! my_ik
5081 : :
5082 : : end do ! my_ip
5083 : : end if
5084 : :
5085 : : ! Read q-slice of g(k,q) in the atom representation. (individual IO).
5086 [ + + ]: 9443 : ncerr = nf90_get_var(spin_ncid, spin_vid(gvals_name), gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
5087 [ - + ]: 1349 : NCF_CHECK(ncerr)
5088 : :
5089 [ + + ]: 1349 : if (read_ks) then
5090 [ + + ]: 728 : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals_ks"), ks_gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
5091 [ - + ]: 104 : NCF_CHECK(ncerr)
5092 : : ! Here we set g_GWPT g to g_KS if g_KS is smaller than a certain threshold as GWPT breaks symmetries.
5093 [ + + + + : 153560 : where (abs(ks_gwork_q) < G_SMALL)
+ + + + +
+ + + ]
5094 : : gwork_q = ks_gwork_q
5095 : : end where
5096 : : end if
5097 : :
5098 [ + + ]: 111960 : do my_ik=1,gqk%my_nk
5099 : 110595 : ik_glob = my_ik + gqk%my_kstart - 1
5100 [ + - ]: 110595 : if (from_atm_to_nu) then
5101 : : ! Here we convert from g(k,q)_atom to g(k,q)_phonon and replace data in gwork_q at ik_glob
5102 : : call ephtk_gkknu_from_atm(nb_kq, nb_k, 1, natom, gwork_q(:,:,:,:, ik_glob), &
5103 : 110595 : phfreqs_ibz(:, iq_ibz), displ_red_qbz, gmn_nu)
5104 [ + + + + : 12601221 : gwork_q(:,:,:,:, ik_glob) = gmn_nu
+ + + + ]
5105 : :
5106 [ + + ]: 110595 : if (gqk%has_both_g) then
5107 : : call ephtk_gkknu_from_atm(nb_kq, nb_k, 1, natom, ks_gwork_q(:,:,:,:, ik_glob), &
5108 : 144 : phfreqs_ibz(:, iq_ibz), displ_red_qbz, gmn_nu)
5109 [ + + + + : 153456 : ks_gwork_q(:,:,:,:, ik_glob) = gmn_nu
+ + + + ]
5110 : : end if
5111 : : end if
5112 : :
5113 [ + + ]: 775514 : do my_ip=1,gqk%my_npert
5114 : 663570 : ipert = gqk%my_pertcases(my_ip)
5115 [ + - + - : 13154196 : slice_bb = gwork_q(:,:,:, ipert, ik_glob)
+ - - + -
- + + + +
+ + ]
5116 [ + + ]: 663570 : if (read_ks) then
5117 [ + - + - : 154176 : ks_slice_bb = ks_gwork_q(:,:,:, ipert, ik_glob)
+ - - + -
- + + + +
+ + ]
5118 : : end if
5119 : :
5120 : : ! Put data in the right place and handle conversion g --> |g|^2.
5121 [ + + ]: 774165 : if (with_cplex == gstore_cplex) then
5122 [ - + ]: 662706 : if (with_cplex == 1) then
5123 [ # # # # ]: 0 : gqk%my_g2(my_ip,:,my_iq,:,my_ik) = slice_bb(1,:,:)
5124 [ # # # # ]: 0 : if (read_ks .and. gqk%has_both_g) then
5125 [ # # # # ]: 0 : gqk%my_g2_ks(my_ip,:,my_iq,:,my_ik) = ks_slice_bb(1,:,:)
5126 : : end if
5127 : : end if
5128 [ + - ]: 662706 : if (with_cplex == 2) then
5129 [ + + + + ]: 5439486 : gqk%my_g(my_ip,:,my_iq,:,my_ik) = slice_bb(1,:,:) + j_dpc * slice_bb(2,:,:)
5130 [ + + + - ]: 662706 : if (read_ks .and. gqk%has_both_g) then
5131 [ + + + + ]: 17280 : gqk%my_g_ks(my_ip,:,my_iq,:,my_ik) = ks_slice_bb(1,:,:) + j_dpc * ks_slice_bb(2,:,:)
5132 : : end if
5133 : : end if
5134 : :
5135 : : else
5136 [ + - + - ]: 864 : if (with_cplex == 1 .and. gstore_cplex == 2) then
5137 [ + + + + ]: 69984 : gqk%my_g2(my_ip, :, my_iq, :, my_ik) = slice_bb(1,:,:) ** 2 + slice_bb(2,:,:) ** 2
5138 [ + + + - ]: 864 : if (read_ks .and. gqk%has_both_g) then
5139 [ + + + + ]: 37344 : gqk%my_g2_ks(my_ip, :, my_iq, :, my_ik) = ks_slice_bb(1,:,:) ** 2 + ks_slice_bb(2,:,:) ** 2
5140 : : end if
5141 [ # # ]: 0 : else if (with_cplex == 0) then
5142 : : continue
5143 : : else
5144 : 0 : ABI_ERROR("Conversion from g2 on file to g_complex in memory is not possible!")
5145 : : end if
5146 : : end if
5147 : : end do ! my_ip
5148 : : end do ! my_ik
5149 : :
5150 : : end do ! my_iq
5151 : :
5152 [ - + ]: 16 : ABI_FREE(gwork_q)
5153 [ - + ]: 16 : ABI_FREE(slice_bb)
5154 [ + + ]: 16 : if (read_ks) then
5155 [ - + ]: 6 : ABI_FREE(ks_gwork_q)
5156 [ - + ]: 6 : ABI_FREE(ks_slice_bb)
5157 : : end if
5158 : :
5159 [ + - ]: 16 : ABI_SFREE(gmn_nu)
5160 [ + + ]: 16 : ABI_SFREE(my_gq0nm_atm)
5161 [ + + ]: 16 : ABI_SFREE(ks_my_gq0nm_atm)
5162 : :
5163 : : ! =========================================
5164 : : ! Read matrix elements of velocity operator
5165 : : ! =========================================
5166 : : ! SC: nctk_set_collective can cause a deadlock on lemaitre4
5167 [ + - ]: 16 : if (gstore%with_vk == 1) then
5168 : : !if (gqk%comm%nproc > 1) then
5169 : : ! NCF_CHECK(nctk_set_collective(spin_ncid, spin_vid("vk_cart_ibz")))
5170 : : !end if
5171 [ - + ]: 16 : NCF_CHECK(nf90_get_var(spin_ncid, spin_vid("vk_cart_ibz"), gqk%vnk_cart_ibz))
5172 : :
5173 [ # # ]: 0 : else if (gstore%with_vk == 2) then
5174 : : !if (gqk%comm%nproc > 1) then
5175 : : ! NCF_CHECK(nctk_set_collective(spin_ncid, spin_vid("vnk_mat_cart_ibz")))
5176 : : !end if
5177 [ # # ]: 0 : NCF_CHECK(nf90_get_var(spin_ncid, spin_vid("vnk_mat_cart_ibz"), gqk%vnk_mat_cart_ibz))
5178 : :
5179 : : ! Transfer diagonal terms to vnk_cart_ibz.
5180 [ # # ]: 0 : do ib=1,gqk%nb_k
5181 [ # # # # ]: 0 : gqk%vnk_cart_ibz(:, ib, :) = gqk%vnk_mat_cart_ibz(1, :, ib, ib, :)
5182 : : end do
5183 : : end if
5184 : :
5185 [ - + ]: 16 : NCF_CHECK(nf90_close(ncid))
5186 : : end if
5187 : : end do ! spin
5188 : :
5189 [ - + ]: 16 : ABI_FREE(qglob2bz)
5190 [ - + ]: 16 : ABI_FREE(qbz2ibz)
5191 [ - + ]: 16 : ABI_FREE(phfreqs_ibz)
5192 [ - + ]: 16 : ABI_FREE(pheigvec_cart_ibz)
5193 [ - + ]: 16 : ABI_FREE(displ_cart_qbz)
5194 [ - + ]: 16 : ABI_FREE(displ_red_qbz)
5195 [ - + ]: 16 : ABI_FREE(pheigvec_cart_qbz)
5196 [ + + ]: 16 : ABI_SFREE(tpp_red)
5197 : :
5198 : 16 : call pstat_proc%print(_PSTAT_ARGS_)
5199 : 16 : call xmpi_barrier(gstore%comm)
5200 [ - + - + : 48 : call cwtime_report(" gstore_from_ncpath", cpu, wall, gflops)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
5201 : :
5202 : : !stop
5203 : :
5204 : : contains
5205 : 400 : integer function vid(var_name)
5206 : : character(len=*),intent(in) :: var_name
5207 : 400 : vid = nctk_idname(ncid, var_name)
5208 : : end function vid
5209 : :
5210 : 1482 : integer function spin_vid(var_name)
5211 : : character(len=*),intent(in) :: var_name
5212 : 1482 : spin_vid = nctk_idname(spin_ncid, var_name)
5213 : : end function spin_vid
5214 : :
5215 : : end subroutine gstore_from_ncpath
5216 : : !!***
5217 : :
5218 : 1248 : subroutine calc_and_store_gdw2(gqk, my_ik, my_iq, my_ip, wqnu, tpp_red, gq0l_atm, gq0r_atm)
5219 : :
5220 : : type(gqk_t), intent(inout) :: gqk
5221 : : integer,intent(in) :: my_ik, my_iq, my_ip
5222 : : real(dp),intent(in) :: wqnu
5223 : : complex(dp),intent(in) :: tpp_red(gqk%natom3, gqk%natom3)
5224 : : complex(dp),intent(in) :: gq0l_atm(gqk%nb_k, gqk%nb_kq, gqk%natom3)
5225 : : complex(dp),intent(in) :: gq0r_atm(gqk%nb_k, gqk%nb_kq, gqk%natom3)
5226 : :
5227 : : !Local variables-------------------------------
5228 : : !scalars
5229 : : integer :: im_kq, in_k, ip2, ip1
5230 : : real(dp) :: gdw2
5231 : : complex(dp) :: cfact
5232 : : ! *************************************************************************
5233 : :
5234 : : ! Loop over bands in |m,k+q>
5235 [ + + ]: 18432 : do im_kq=1,gqk%nb_kq
5236 : : ! Loop over the n index in |n,k>.
5237 [ + + ]: 98496 : do in_k=1,gqk%nb_k
5238 : : ! Compute DW term following XG paper. Check prefactor.
5239 : : gdw2 = zero
5240 [ + + ]: 560448 : do ip2=1,gqk%natom3
5241 [ + + ]: 3442752 : do ip1=1,gqk%natom3
5242 : : cfact = ( &
5243 : : + real(gq0l_atm(in_k, im_kq, ip1)) * real(gq0r_atm(in_k, im_kq, ip2)) &
5244 : : + aimag(gq0l_atm(in_k, im_kq, ip1)) * aimag(gq0r_atm(in_k, im_kq, ip2)) &
5245 : : + real(gq0l_atm(in_k, im_kq, ip2)) * real(gq0r_atm(in_k, im_kq, ip1)) &
5246 : : + aimag(gq0l_atm(in_k, im_kq, ip2)) * aimag(gq0r_atm(in_k, im_kq, ip1)) &
5247 : 2882304 : )
5248 : 3362688 : gdw2 = gdw2 + real(tpp_red(ip1,ip2) * cfact)
5249 : : end do
5250 : : end do
5251 : :
5252 [ + + ]: 80064 : if (wqnu < EPHTK_WTOL) then
5253 : : gdw2 = zero
5254 : : else
5255 : 77580 : gdw2 = gdw2 / (four * two * wqnu)
5256 : : end if
5257 : :
5258 : : !print *, "gdw2", gdw2
5259 : 97248 : gqk%my_gdw2(my_ip, im_kq, my_iq, in_k, my_ik) = gdw2
5260 : : end do ! in_k
5261 : : end do ! im_kq
5262 : :
5263 : 1248 : end subroutine calc_and_store_gdw2
5264 : :
5265 : : !----------------------------------------------------------------------
5266 : :
5267 : : !!****f* m_gstore/gstore_check_restart
5268 : : !! NAME
5269 : : !! gstore_check_restart
5270 : : !!
5271 : : !! FUNCTION
5272 : : !! Check whether restart from a previous GSTORE.nc is possible.
5273 : : !!
5274 : : !! INPUTS
5275 : : !!
5276 : : !! SOURCE
5277 : :
5278 : 3 : subroutine gstore_check_restart(filepath, dtset, nqbz, done_qbz_spin, restart, comm)
5279 : :
5280 : : !Arguments ------------------------------------
5281 : : character(len=*),intent(in) :: filepath
5282 : : type(dataset_type),intent(in) :: dtset
5283 : : integer,intent(out) :: nqbz, restart
5284 : : integer,allocatable,intent(out) :: done_qbz_spin(:,:)
5285 : : integer,intent(in) :: comm
5286 : :
5287 : : !Local variables-------------------------------
5288 : : !scalars
5289 : : integer,parameter :: master = 0
5290 : : integer :: my_rank, root_ncid, ierr, gstore_completed, gstore_fform, units(2) ! fform
5291 : : character(len=500) :: msg
5292 : 3 : type(hdr_type) :: gstore_hdr
5293 : : ! *************************************************************************
5294 : :
5295 [ + + ]: 9 : my_rank = xmpi_comm_rank(comm); units = [std_out, ab_out]
5296 : :
5297 : : !print *, "eph_restart:", dtset%eph_restart
5298 : :
5299 : 3 : restart = 0; nqbz = 0
5300 [ + - + - ]: 3 : if (my_rank == master .and. dtset%eph_restart == 1) then
5301 [ - + ]: 3 : if (file_exists(filepath)) then
5302 [ # # ]: 0 : call wrtout(units, sjoin("- Found pre-existent GSTORE file:", trim(filepath)))
5303 : 0 : call wrtout(units, " Testing if all e-ph terms have been computed...")
5304 : : ! Use gstore_completed to understand if the previous GSTORE run completed else we need to restart.
5305 [ # # ]: 0 : NCF_CHECK(nctk_open_read(root_ncid, filepath, xmpi_comm_self))
5306 [ # # ]: 0 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_completed"), gstore_completed))
5307 : 0 : call gstore_hdr%ncread(root_ncid, gstore_fform)
5308 [ # # ]: 0 : ABI_CHECK_INEQ(gstore_fform, 0, "Wrong gstore_fform")
5309 : 0 : call gstore_hdr%vs_dtset(dtset); call gstore_hdr%free()
5310 : :
5311 [ # # ]: 0 : NCF_CHECK(nctk_get_dim(root_ncid, "gstore_nqbz", nqbz))
5312 [ # # # # : 0 : ABI_MALLOC(done_qbz_spin, (nqbz, dtset%nsppol))
# # # # #
# # # # #
# # # # ]
5313 [ # # ]: 0 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_done_qbz_spin"), done_qbz_spin))
5314 [ # # ]: 0 : NCF_CHECK(nf90_close(root_ncid))
5315 : : !print *, "done_qbz_spin:", done_qbz_spin
5316 : :
5317 : : ! FIXME: done_qbz_spin is dimensioned with the q-points in the BZ but we
5318 : : ! should set to 1 the q-points in the BZ else we never restart
5319 : : ! Perhaps can can set to -1 if q = TS q_ibz if q_ibz is done.
5320 [ # # ]: 0 : if (gstore_completed /= 0) then
5321 : : ! Previous computation completed, keep a backup of the file and start from scratch.
5322 [ # # # # ]: 0 : restart = 0; done_qbz_spin = 0
5323 : : msg = sjoin("- WARNING: Found GSTORE.nc file with all entries already computed.", ch10, &
5324 [ # # ]: 0 : "- Will overwrite:", trim(filepath), ch10, "Keeping backup copy in:", strcat(filepath, ".bkp"))
5325 : 0 : call wrtout(units, msg)
5326 [ # # ]: 0 : ABI_CHECK(clib_rename(trim(filepath), strcat(filepath, ".bkp")) == 0, "Failed to rename GSTORE file.")
5327 : : else
5328 : 0 : restart = 1
5329 : 0 : call wrtout(units, "- Restarting from a previous GSTORE.nc file")
5330 : : end if
5331 : : else
5332 [ + - ]: 3 : call wrtout(units, sjoin("- Cannot find pre-existent GSTORE file:", trim(filepath)))
5333 : : end if
5334 : : end if
5335 : :
5336 : 3 : call xmpi_bcast(restart, master, comm, ierr)
5337 : 3 : call xmpi_bcast(nqbz, master, comm, ierr)
5338 : :
5339 [ - + ]: 3 : if (my_rank /= master) then
5340 [ # # # # : 0 : ABI_MALLOC(done_qbz_spin, (nqbz, dtset%nsppol))
# # # # #
# # # # #
# # # # ]
5341 : : end if
5342 [ - + - + : 3 : if (nqbz /= 0) call xmpi_bcast(done_qbz_spin, master, comm, ierr)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - ]
5343 : : !stop
5344 : :
5345 : : contains
5346 : 0 : integer function root_vid(var_name)
5347 : : character(len=*),intent(in) :: var_name
5348 : 0 : root_vid = nctk_idname(root_ncid, var_name)
5349 : : end function root_vid
5350 : :
5351 : : end subroutine gstore_check_restart
5352 : : !!***
5353 : :
5354 : : !----------------------------------------------------------------------
5355 : :
5356 : : !!****f* m_gstore/gstore_prepare_mpiio
5357 : : !! NAME
5358 : : !! gstore_prepare_mpiio
5359 : : !!
5360 : : !! FUNCTION
5361 : : !! Access all the variables of GSTORE.nc (root group and gqk_spin groups) with all the procs that opened the file.
5362 : : !! With a file opened in parallel, netcdf reads the metadata of a variable the first time the variable is accessed
5363 : : !! and, with parallel HDF5, this read is collective. If a subset of the procs accesses a variable first
5364 : : !! (e.g. a single writer per (q, k) block), the other procs do not take part in the read and the run deadlocks
5365 : : !! or aborts with "NetCDF: Can't add HDF5 file metadata".
5366 : : !! This generalizes nctk_prepare_mpiio to all the variables of the file, so that new variables cannot be forgotten.
5367 : : !! Must be called by all the procs that opened the file, in data mode, before any access by a subset of the procs.
5368 : : !!
5369 : : !! INPUTS
5370 : : !! root_ncid=Netcdf identifier of the root group of GSTORE.nc.
5371 : : !! nsppol=Number of gqk_spin groups in the file.
5372 : : !!
5373 : : !! SOURCE
5374 : :
5375 : 8 : subroutine gstore_prepare_mpiio(root_ncid, nsppol)
5376 : :
5377 : : !Arguments ------------------------------------
5378 : : integer,intent(in) :: root_ncid, nsppol
5379 : :
5380 : : !Local variables-------------------------------
5381 : : integer :: spin, spin_ncid
5382 : : ! *************************************************************************
5383 : :
5384 : 8 : call prepare_group(root_ncid)
5385 [ + + ]: 16 : do spin=1,nsppol
5386 [ - + ]: 8 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
5387 : 16 : call prepare_group(spin_ncid)
5388 : : end do
5389 : :
5390 : : contains
5391 : :
5392 : 16 : subroutine prepare_group(ncid)
5393 : : integer,intent(in) :: ncid
5394 : : integer :: nvars, varid
5395 : : character(len=nf90_max_name) :: varname
5396 : :
5397 [ - + ]: 16 : NCF_CHECK(nf90_inquire(ncid, nVariables=nvars))
5398 [ + + ]: 979 : do varid=1,nvars
5399 [ - + ]: 979 : NCF_CHECK(nf90_inquire_variable(ncid, varid, varname))
5400 : : end do
5401 : :
5402 : 16 : end subroutine prepare_group
5403 : :
5404 : : end subroutine gstore_prepare_mpiio
5405 : : !!***
5406 : :
5407 : : !----------------------------------------------------------------------
5408 : :
5409 : : !!****f* m_gstore/gstore_print_for_abitests
5410 : : !! NAME
5411 : : !! gstore_print_for_abitests
5412 : : !!
5413 : : !! FUNCTION
5414 : : !! Print subset of results to ab_out for testing purposes.
5415 : : !! This routine should be called when the output of the GSTORE.nc file is completed
5416 : : !!
5417 : : !! INPUTS
5418 : : !! dtset<type(dataset_type)>=all input variables for this dataset
5419 : : !! [with_ks]: if True, read "gvals" as well as "gvals_ks". This options is used in GWPT
5420 : : !! in which "gvals" are the GWPT matrix elements and ""gvals_ks" are the KS ones.
5421 : : !!
5422 : : !! SOURCE
5423 : :
5424 : 8 : subroutine gstore_print_for_abitests(gstore, dtset, ebands, do_avg, with_ks)
5425 : :
5426 : : !Arguments ------------------------------------
5427 : : class(gstore_t),intent(inout) :: gstore
5428 : : type(dataset_type),intent(in) :: dtset
5429 : : type(ebands_t),intent(in) :: ebands
5430 : : logical,intent(in) :: do_avg
5431 : : logical,optional,intent(in) :: with_ks
5432 : :
5433 : : !Local variables-------------------------------
5434 : : !scalars
5435 : : integer,parameter :: master = 0
5436 : : integer :: root_ncid, spin_ncid, gstore_completed, spin, ik_glob, iq_glob, ipc, ncerr, natom3
5437 : : integer :: glob_nq, glob_nk, im_kq, in_k, m_kq, n_k, nb_k, nb_kq, ii ! ib_k,
5438 : : integer :: bstart_k, bstop_k, bstart_kq, bstop_kq, max_nk, max_nq, idir
5439 : : integer :: ik_bz, ik_ibz, ib_min_k, ib_max_k, iq_bz, ikq_ibz, ib_min_kq, ib_max_kq, nn
5440 : : logical :: with_ks__, changed_k, changed_kq, all_gs, has_iv1p_comm
5441 : : real(dp) :: gg, gg_ks, g_ratio, min_g_ratio, max_g_ratio, mean_g_ratio, stdev_g_ratio !, vnk
5442 : : character(len=abi_slen) :: gstore_gmode
5443 : : character(len=500) :: msg
5444 : : !arrays
5445 : : integer :: mapl_kq(6)
5446 : 8 : integer,allocatable :: done_qbz_spin(:,:), qglob2bz(:,:), degblock_k(:,:), degblock_kq(:,:)
5447 : : real(dp) :: kk(3), qq(3), kq(3), rtmp(2)
5448 : 8 : real(dp),allocatable :: gslice_mn(:,:,:), gslice_ks_mn(:,:,:), g2_mn(:,:), g2ks_mn(:,:), iv1p_comm(:,:,:,:,:)
5449 : : !real(dp),allocatable :: vnk_cart_ibz(:,:) !, vnk_mat_cart_ibz(:,:,:,:)
5450 : : ! *************************************************************************
5451 : :
5452 : : ! Only master prints to ab_out
5453 [ + - ]: 8 : if (xmpi_comm_rank(gstore%comm) /= master) return
5454 : :
5455 [ + + ]: 8 : with_ks__ = .False.; if (present(with_ks)) with_ks__ = with_ks
5456 [ - + ]: 8 : all_gs = .False. ; if (dtset%prtvol >= 10) all_gs = .True.
5457 : :
5458 : 8 : natom3 = dtset%natom * 3
5459 [ + + ]: 16 : max_nq = maxval(gstore%glob_nq_spin) ! Max dim over spin
5460 : : max_nk = maxval(gstore%glob_nk_spin)
5461 : :
5462 [ - + ]: 8 : NCF_CHECK(nctk_open_read(root_ncid, gstore%path, xmpi_comm_self))
5463 : :
5464 [ - + ]: 8 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_completed"), gstore_completed))
5465 : 8 : write(ab_out, *)""
5466 : 8 : write(ab_out, "(a,i0)")" gstore_completed: ", gstore_completed
5467 : :
5468 [ - + + - : 32 : ABI_MALLOC(done_qbz_spin, (gstore%nqbz, dtset%nsppol))
- + + - +
- + - - +
- + ]
5469 [ - + ]: 8 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_done_qbz_spin"), done_qbz_spin))
5470 [ + + + + : 2573 : write(ab_out, "(a,*(i0,1x))")" gstore_done_qbz_spin: ", count(done_qbz_spin == 1)
+ + ]
5471 [ - + ]: 8 : ABI_FREE(done_qbz_spin)
5472 : :
5473 [ - + + - : 997 : ABI_CALLOC(qglob2bz, (max_nq, dtset%nsppol))
- + + - +
- + - - +
- + + + +
+ ]
5474 [ - + ]: 8 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_qglob2bz"), qglob2bz))
5475 : :
5476 : : gstore_gmode = GSTORE_GMODE_ATOM
5477 : :
5478 [ + + ]: 16 : do spin=1,gstore%nsppol
5479 [ - + ]: 8 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
5480 [ - + ]: 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "glob_nq", glob_nq))
5481 [ - + ]: 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "glob_nk", glob_nk))
5482 [ - + ]: 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_k", nb_k))
5483 [ - + ]: 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_kq", nb_kq))
5484 : :
5485 : 8 : bstart_k = gstore%brange_k_spin(1, spin)
5486 : 8 : bstop_k = gstore%brange_k_spin(2, spin)
5487 : 8 : bstart_kq = gstore%brange_kq_spin(1, spin)
5488 : 8 : bstop_kq = gstore%brange_kq_spin(2, spin)
5489 : :
5490 : 8 : write(ab_out, "(a,i0)")" nb_k: ", nb_k
5491 : 8 : write(ab_out, "(a,i0)")" bstart_k: ", bstart_k
5492 : 8 : write(ab_out, "(a,i0)")" nb_kq: ", nb_kq
5493 : 8 : write(ab_out, "(a,i0)")" bstart_kq: ", bstart_kq
5494 : 8 : write(ab_out, "(a,i0)")" glob_nq: ", glob_nq
5495 : 8 : write(ab_out, "(a,i0)")" glob_nk: ", glob_nk
5496 : :
5497 : : ! Handle the output of group velocities. On disk, we have:
5498 : : !
5499 : : ! nctkarr_t("vk_cart_ibz", "dp", "three, nb_k, gstore_nkibz"))
5500 : : ! or
5501 : : ! nctkarr_t("vnk_mat_cart_ibz", "dp", "two, three, nb_k, nb_k, gstore_nkibz")))
5502 : :
5503 : 8 : select case (gstore%with_vk)
5504 : : case (0)
5505 : : continue
5506 : :
5507 : : case (1)
5508 : 0 : continue
5509 : : !write(ab_out,"(2a)") ch10," Group velocities |v_nk| in atomic units:"
5510 : :
5511 : : !ABI_MALLOC(vnk_cart_ibz, (3, nb_k))
5512 : : !do ik_ibz=1,gstore%nkibz
5513 : : ! ! Only a subset of k-points are written to ab_out.
5514 : : ! if (all(ik_ibz /= [1, 2, gstore%nkibz - 1, gstore%nkibz])) cycle
5515 : : ! 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]))
5516 : :
5517 : : ! write(ab_out, "(a)")sjoin(" For k-point:", ktoa(gstore%kibz(:,ik_ibz)), ", spin", itoa(spin))
5518 : : ! do ib_k=1,min(nb_k, 10)
5519 : : ! vnk = sqrt(norm2(vnk_cart_ibz(:,ib_k)))
5520 : : ! write(ab_out, "(a,i0,1x,es16.6)")" ib_k: ", ib_k, vnk
5521 : : ! end do
5522 : : !end do
5523 : : !ABI_FREE(vnk_cart_ibz)
5524 : : !write(ab_out, "(a)")" "
5525 : :
5526 : : case (2)
5527 [ - + ]: 8 : ABI_ERROR(" TEXT output of vkmat is not coded yet!")
5528 : : end select
5529 : :
5530 : : ! Handle the output of the e-ph matrix elements. On disk we have the global array:
5531 : : !
5532 : : ! nctkarr_t("gvals", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq")
5533 : :
5534 : : ! These e-ph matrix elements are ALWAYS in the atom representation.
5535 [ - + + - : 32 : ABI_MALLOC(gslice_mn, (2, nb_kq, nb_k))
- + + - +
- + - - +
- + - + ]
5536 [ - + + - : 24 : ABI_MALLOC(gslice_ks_mn, (2, nb_kq, nb_k))
- + + - -
+ - + -
+ ]
5537 [ - + + - : 32 : ABI_MALLOC(g2_mn, (nb_kq, nb_k))
- + + - +
- + - - +
- + ]
5538 [ - + + - : 24 : ABI_MALLOC(g2ks_mn, (nb_kq, nb_k))
- + + - -
+ - + ]
5539 : :
5540 : 8 : write(ab_out,"(a)") " E-PH matrix elements in the atom representation: pcase = (idir, iatom)"
5541 [ + - ]: 8 : if (do_avg) then
5542 : 8 : write(ab_out,"(a)") " NB: Values are averaged over e_mk+q, and e_nk degenerate states."
5543 : : else
5544 : 0 : write(ab_out,"(a)") " NB: Values are NOT averaged over e_mk+q, and e_nk degenerate states."
5545 : : end if
5546 : :
5547 [ + + ]: 8 : if (with_ks__) then
5548 : 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"
5549 : : else
5550 : 5 : write(ab_out, "(1x,5(a5,1x),a16)") "iq", "ik", "pcase", "m_kq", "n_k", "|g| in Ha"
5551 : : end if
5552 : :
5553 [ + + ]: 319 : do ik_glob=1,glob_nk
5554 : : ! Write the first and the last k-point.
5555 [ + + + + : 311 : if ((ik_glob /= 1 .and. ik_glob /= glob_nk) .and. .not. all_gs) cycle
+ - ]
5556 : :
5557 : 14 : ik_bz = gstore%kglob2bz(ik_glob, spin)
5558 : 14 : ik_ibz = gstore%kbz2ibz(1, ik_bz)
5559 : : !ik_ibz = gstore%bz2ibz(1, ik_bz); isym_k = gstore%bz2ibz(2, ik_bz)
5560 : : !trev_k = gstore%bz2ibz(6, ik_bz); g0_k = gstore%bz2ibz(3:5, ik_bz)
5561 : : !isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
5562 : :
5563 [ + + ]: 56 : kk = ebands%kptns(:,ik_ibz)
5564 : 14 : ib_min_k = bstart_k; ib_max_k = bstop_k
5565 : :
5566 : : call ebands%enclose_degbands(ik_ibz, spin, ib_min_k, ib_max_k, changed_k, dtset%symsigma_de, &
5567 [ - + ]: 14 : degblock=degblock_k)
5568 [ + + ]: 14 : if (changed_k) then
5569 : : !write(ab_out, "(a)")" Non all the degenerate bands at k were included. This should not happen!"
5570 [ + + ]: 10 : do ii=1,size(degblock_k, dim=2)
5571 : 8 : degblock_k(1, ii) = max(degblock_k(1, ii), bstart_k)
5572 : 10 : degblock_k(2, ii) = min(degblock_k(2, ii), bstop_k)
5573 : : end do
5574 : : end if
5575 : :
5576 [ + + ]: 1800 : do iq_glob=1,glob_nq
5577 : : ! Write the first and the last q-point.
5578 [ + + + + : 1786 : if ((iq_glob /= 1 .and. iq_glob /= glob_nq) .and. .not. all_gs) cycle
+ - ]
5579 : :
5580 : : ! Find k+q image in the IBZ.
5581 : 28 : iq_bz = qglob2bz(iq_glob, spin)
5582 [ + + ]: 112 : qq = gstore%qbz(:, iq_bz)
5583 [ + + ]: 112 : kq = kk + qq
5584 [ - + ]: 28 : if (kpts_map("symrel", ebands%kptopt, gstore%cryst, gstore%krank_ibz, 1, kq, mapl_kq) /= 0) then
5585 [ # # ]: 0 : write(msg, '(4a)' )"k-mesh is not closed!",ch10, "k+q could not be generated from a symmetrical one.",trim(ltoa(kq))
5586 : 0 : ABI_ERROR(msg)
5587 : : end if
5588 : 28 : ikq_ibz = mapl_kq(1)
5589 : 28 : ib_min_kq = bstart_kq; ib_max_kq = bstop_kq
5590 : :
5591 : : call ebands%enclose_degbands(ikq_ibz, spin, ib_min_kq, ib_max_kq, changed_kq, dtset%symsigma_de, &
5592 [ - + ]: 28 : degblock=degblock_kq)
5593 : :
5594 [ + + ]: 28 : if (changed_kq) then
5595 : : !write(ab_out, "(a)")" Non all the degenerate bands at k+q were included. This should not happen!"
5596 [ + + ]: 34 : do ii=1,size(degblock_kq, dim=2)
5597 : 30 : degblock_kq(1, ii) = max(degblock_kq(1, ii), bstart_kq)
5598 : 34 : degblock_kq(2, ii) = min(degblock_kq(2, ii), bstop_kq)
5599 : : end do
5600 : : end if
5601 : :
5602 [ + + ]: 196 : do ipc=1,natom3
5603 : : ! Write the 4th and the last perturbation.
5604 [ + + - + ]: 168 : if ((ipc /= 4 .and. ipc /= natom3) .and. .not. all_gs) cycle
5605 : : ! TODO: Write that pcase is filtered
5606 : : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals"), gslice_mn, &
5607 [ + + + + ]: 728 : start=[1,1,1,ipc,ik_glob,iq_glob], count=[2,nb_kq,nb_k,1,1,1])
5608 [ - + ]: 56 : NCF_CHECK(ncerr)
5609 : 56 : call average_g2_mn(do_avg, nb_kq, nb_k, bstart_kq, bstart_k, degblock_kq, degblock_k, gslice_mn, g2_mn)
5610 : :
5611 : 56 : write(ab_out, "(3(a,1x,i0,1x))")" |g(k,q)| in Ha for iq:", iq_glob, "ik:", ik_glob, "pcase:", ipc
5612 : :
5613 [ + + ]: 84 : if (.not. with_ks__) then
5614 : : ! gvals only.
5615 : 36 : write(ab_out, "(1x,5(a5,1x),a16)")"iq", "ik", "pcase", "m_kq", "n_k", "|g|"
5616 [ + + ]: 196 : do im_kq=1,nb_kq
5617 : 160 : m_kq = im_kq + bstart_kq - 1
5618 [ + + ]: 740 : do in_k=1,nb_k
5619 : 544 : n_k = in_k + bstart_k - 1
5620 : 544 : gg = sqrt(g2_mn(im_kq, in_k))
5621 : 704 : write(ab_out, "(a1,5(i5,1x),es16.6)")"-", iq_glob, ik_glob, ipc, m_kq, n_k, gg
5622 : : end do
5623 : : end do
5624 : : else
5625 : : ! GW/KS ratio, g^GW, g^KS
5626 : : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals_ks"), gslice_ks_mn, &
5627 [ + + + + ]: 260 : start=[1,1,1,ipc,ik_glob,iq_glob], count=[2,nb_kq,nb_k,1,1,1])
5628 [ - + ]: 20 : NCF_CHECK(ncerr)
5629 : 20 : call average_g2_mn(do_avg, nb_kq, nb_k, bstart_kq, bstart_k, degblock_kq, degblock_k, gslice_ks_mn, g2ks_mn)
5630 : :
5631 : 20 : write(ab_out, "(1x,5(a5,1x),3a16)")"iq", "ik", "pcase", "m_kq", "n_k", "GW/KS", "|g^GW|", "|g^KS|"
5632 : 20 : min_g_ratio = +huge(one); max_g_ratio = -huge(one); mean_g_ratio = zero; stdev_g_ratio = zero; nn = 0
5633 : :
5634 [ + + ]: 252 : do im_kq=1,nb_kq
5635 : 232 : m_kq = im_kq + bstart_kq - 1
5636 [ + + ]: 1564 : do in_k=1,nb_k
5637 : 1312 : n_k = in_k + bstart_k - 1
5638 : 1312 : gg = sqrt(g2_mn(im_kq, in_k))
5639 : 1312 : gg_ks = sqrt(g2ks_mn(im_kq, in_k))
5640 : 1312 : call safe_div(gg, gg_ks, -one, g_ratio)
5641 [ + + ]: 1312 : if (g_ratio /= -one) then
5642 : 944 : nn = nn + 1
5643 : 944 : min_g_ratio = min(g_ratio, min_g_ratio)
5644 : 944 : max_g_ratio = max(g_ratio, max_g_ratio)
5645 : 944 : mean_g_ratio = mean_g_ratio + g_ratio
5646 : 944 : stdev_g_ratio = stdev_g_ratio + g_ratio ** 2
5647 : : end if
5648 : 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
5649 : : end do
5650 : : end do
5651 : :
5652 [ + + ]: 20 : if (nn /= 0) then
5653 : 14 : mean_g_ratio = mean_g_ratio / nn
5654 : 14 : write(ab_out, "(a,es16.6)")"- mean_g_ratio:", mean_g_ratio
5655 : : ! \sigma^{2} = \langle x^{2} \rangle - \langle x \rangle^{2}
5656 : 14 : write(ab_out, "(a,es16.6)")"- stdev_g_ratio:", sqrt((stdev_g_ratio / nn) - (mean_g_ratio ** 2))
5657 : 14 : write(ab_out, "(a,es16.6)")"- min_g_ratio:", min_g_ratio
5658 : 14 : write(ab_out, "(a,es16.6)")"- max_g_ratio:", max_g_ratio
5659 : : end if
5660 : : end if
5661 : :
5662 : : end do ! ipc
5663 : :
5664 [ - + ]: 1800 : ABI_FREE(degblock_kq)
5665 : : end do ! iq_glob
5666 [ - + ]: 319 : ABI_FREE(degblock_k)
5667 : : end do ! ik_glob
5668 : :
5669 [ - + ]: 8 : ABI_FREE(gslice_mn)
5670 [ - + ]: 8 : ABI_FREE(gslice_ks_mn)
5671 [ - + ]: 8 : ABI_FREE(g2_mn)
5672 [ - + ]: 16 : ABI_FREE(g2ks_mn)
5673 : : end do ! spin
5674 : :
5675 [ - + ]: 8 : ABI_FREE(qglob2bz)
5676 : :
5677 : : ! Here we read the matrix elements of i[V1, p] if present on disk.
5678 : 8 : has_iv1p_comm = gstore_nc_has_iv1p_comm(gstore, root_ncid)
5679 : :
5680 [ - + ]: 8 : if (has_iv1p_comm) then
5681 [ # # ]: 0 : do spin=1,gstore%nsppol
5682 [ # # ]: 0 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
5683 [ # # ]: 0 : NCF_CHECK(nctk_get_dim(spin_ncid, "glob_nk", glob_nk))
5684 [ # # ]: 0 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_k", nb_k))
5685 : :
5686 : 0 : bstart_k = gstore%brange_k_spin(1, spin)
5687 : 0 : bstop_k = gstore%brange_k_spin(2, spin)
5688 : :
5689 [ # # # # : 0 : ABI_CALLOC(iv1p_comm, (2, nb_k, nb_k, 3, natom3))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # #
# ]
5690 : :
5691 [ # # ]: 0 : do ik_glob=1,glob_nk
5692 : : ! Write the first and the last k-point.
5693 [ # # # # : 0 : if ((ik_glob /= 1 .and. ik_glob /= glob_nk) .and. .not. all_gs) cycle
# # ]
5694 : :
5695 : : !ik_bz = gstore%kglob2bz(ik_glob, spin)
5696 : : !ik_ibz = gstore%kbz2ibz(1, ik_bz)
5697 : : !kk_ibz = ebands%kptns(:,ik_ibz)
5698 : :
5699 : : ! nctkarr_t("iv1p_comm", "dp", "two, nb_k, nb_k, three, natom3, glob_nk")
5700 : : ncerr = nf90_get_var(spin_ncid, spin_vid("iv1p_comm"), iv1p_comm, &
5701 [ # # # # ]: 0 : start=[1,1,1,1,1,ik_glob], count=[2,nb_k,nb_k,3,natom3,1])
5702 [ # # ]: 0 : NCF_CHECK(ncerr)
5703 : :
5704 : : ! Only n_nk states are included in the matrix.
5705 : 0 : write(ab_out, "(1x,5(a5,1x),a16)")"ik", "pcase", "m_k", "n_k", "idir", "i[V1,p]"
5706 [ # # ]: 0 : do im_kq=1,nb_k
5707 : 0 : m_kq = im_kq + bstart_k - 1
5708 [ # # ]: 0 : do in_k=1,nb_k
5709 : 0 : n_k = in_k + bstart_k - 1
5710 [ # # ]: 0 : do ipc=1,natom3
5711 [ # # # # : 0 : if ((ipc /= 4 .and. ipc /= natom3) .and. .not. all_gs) cycle
# # ]
5712 [ # # ]: 0 : do idir=1,3
5713 [ # # ]: 0 : rtmp = iv1p_comm(:, im_kq, in_k, idir, ipc)
5714 : 0 : write(ab_out, "(a1,5(i5,1x),2es16.6)") "-", ik_glob, ipc, m_kq, n_k, idir, rtmp(1), rtmp(2)
5715 : : end do ! idir
5716 : : end do ! ipc
5717 : : end do ! in_k
5718 : : end do ! im_kq
5719 : :
5720 : : end do ! ik_glob
5721 : :
5722 [ # # ]: 0 : ABI_FREE(iv1p_comm)
5723 : : end do ! spin
5724 : : end if
5725 : :
5726 [ - + - + : 16 : NCF_CHECK(nf90_close(root_ncid))
- + - + -
+ - + - +
- + ]
5727 : :
5728 : : contains
5729 : 24 : integer function root_vid(var_name)
5730 : : character(len=*),intent(in) :: var_name
5731 : 24 : root_vid = nctk_idname(root_ncid, var_name)
5732 : : end function root_vid
5733 : :
5734 : 76 : integer function spin_vid(var_name)
5735 : : character(len=*),intent(in) :: var_name
5736 : 76 : spin_vid = nctk_idname(spin_ncid, var_name)
5737 : : end function spin_vid
5738 : :
5739 : : end subroutine gstore_print_for_abitests
5740 : : !!***
5741 : :
5742 [ - + - + ]: 76 : subroutine average_g2_mn(do_avg, nb_kq, nb_k, bstart_kq, bstart_k, degblock_kq, degblock_k, g_mn, g2_mn)
5743 : :
5744 : : !Arguments ------------------------------------
5745 : : logical,intent(in) :: do_avg
5746 : : integer,intent(in) :: nb_kq, nb_k, bstart_kq, bstart_k
5747 : : integer,intent(in) :: degblock_kq(:,:), degblock_k(:,:)
5748 : : real(dp),intent(in) :: g_mn(2, nb_kq, nb_k)
5749 : : real(dp),intent(out) :: g2_mn(nb_kq, nb_k)
5750 : :
5751 : : !Local variables-------------------------------
5752 : : integer :: im_group, in_group, count, m_kq, im_kq, n_k, in_k
5753 : : real(dp) :: g2_avg
5754 : : !----------------------------------------------------------------------
5755 : :
5756 [ - + ]: 76 : if (do_avg) then
5757 : : ! Average over electronic degenerate states at k and k+q
5758 [ + + + + ]: 3564 : g2_mn = -one
5759 [ + + ]: 460 : do im_group = 1, size(degblock_kq, dim=2)
5760 [ + + ]: 1414 : do in_group = 1, size(degblock_k, dim=2)
5761 : 954 : g2_avg = zero; count = 0
5762 [ + + ]: 2542 : do m_kq = degblock_kq(1, im_group), degblock_kq(2, im_group)
5763 : 1588 : im_kq = m_kq - bstart_kq + 1
5764 [ + + ]: 5710 : do n_k = degblock_k(1, in_group), degblock_k(2, in_group)
5765 : 3168 : in_k = n_k - bstart_k + 1
5766 : 3168 : g2_avg = g2_avg + g_mn(1, im_kq, in_k)**2 + g_mn(2, im_kq, in_k)**2
5767 : 4756 : count = count + 1
5768 : : end do
5769 : : end do
5770 : 954 : g2_avg = g2_avg / count
5771 : :
5772 : : ! Loop again over degenerate bands and copy average.
5773 [ + + ]: 2926 : do m_kq = degblock_kq(1, im_group), degblock_kq(2, im_group)
5774 : 1588 : im_kq = m_kq - bstart_kq + 1
5775 [ + + ]: 5710 : do n_k = degblock_k(1, in_group), degblock_k(2, in_group)
5776 : 3168 : in_k = n_k - bstart_k + 1
5777 : 4756 : g2_mn(im_kq, in_k) = g2_avg
5778 : : end do
5779 : : end do
5780 : :
5781 : : end do ! in_group
5782 : : end do ! im_group
5783 : :
5784 : : else
5785 : : ! No average here.
5786 [ # # ]: 0 : do im_kq=1, nb_kq
5787 [ # # ]: 0 : do in_k=1, nb_k
5788 : 0 : g2_mn(im_kq, in_k) = g_mn(1, im_kq, in_k)**2 + g_mn(2, im_kq, in_k)**2
5789 : : end do
5790 : : end do
5791 : : end if
5792 : :
5793 : 76 : end subroutine average_g2_mn
5794 : : !!***
5795 : :
5796 : : !----------------------------------------------------------------------
5797 : :
5798 : : !!****f* m_gstore/gqk_gather
5799 : : !! NAME
5800 : : !! gqk_gather
5801 : : !!
5802 : : !! FUNCTION
5803 : : !! Gather the MPI-distributed matrix elements for a given k/q-point index.
5804 : : !! Once one reciprocal dimension is fixed, the gathering is performed across the other one.
5805 : : !!
5806 : : !! INPUTS
5807 : : !! mode = String controlling the choice of the fixed dimension ("k" or "q")
5808 : : !! fixed_pt = Index of the fixed k/q-point
5809 : : !!
5810 : : !! OUTPUT
5811 : : !! g_gathered(:,:,:,:) = Matrix elements for the given k/q-point, ordered as
5812 : : !! (my_npert, nb, nb, glob_nq) - k-point is fixed
5813 : : !! (my_npert, nb, nb, glob_nk) - q-point is fixed
5814 : : !!
5815 : : !! SOURCE
5816 : :
5817 : 555656 : subroutine gqk_gather(gqk, mode, fixed_pt, g_gathered)
5818 : :
5819 : : !Arguments ------------------------------------
5820 : : !scalars
5821 : : class(gqk_t), target, intent(in) :: gqk
5822 : : character(len=*),intent(in) :: mode
5823 : : integer,intent(in) :: fixed_pt
5824 : : !arrays
5825 : : complex(dp), allocatable, intent(out) :: g_gathered(:,:,:,:)
5826 : :
5827 : : !Local variables-------------------------------
5828 : : !scalars
5829 : : integer :: comm, ierr, ipt_glob, ngather, my_ipt, my_ngather, my_ptstart, my_pert, ib, jb
5830 : : !arrays
5831 : 277828 : complex(dp), pointer :: my_g(:,:,:,:)
5832 : : !----------------------------------------------------------------------
5833 : :
5834 : 0 : ABI_CHECK_IEQ(gqk%nb_kq, gqk%nb_k, "nb_kq != nb_k not tested")
5835 : :
5836 : 0 : select case (mode)
5837 : : case ("k")
5838 : 0 : comm = gqk%qpt_comm%value
5839 : 0 : ngather = gqk%glob_nq
5840 : 0 : my_ngather = gqk%my_nq
5841 : 0 : my_ptstart = gqk%my_qstart
5842 : 0 : my_g => gqk%my_g(:,:,:,:,fixed_pt)
5843 [ # # # # : 0 : ABI_CALLOC(g_gathered, (gqk%my_npert, gqk%nb_kq, gqk%nb_k, ngather))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # #
# ]
5844 : :
5845 : : case ("q")
5846 : 277828 : comm = gqk%kpt_comm%value
5847 : 277828 : ngather = gqk%glob_nk
5848 : 277828 : my_ngather = gqk%my_nk
5849 : 277828 : my_ptstart = gqk%my_kstart
5850 : 277828 : my_g => gqk%my_g(:,:,fixed_pt,:,:)
5851 [ - + + - : 2150164396 : ABI_CALLOC(g_gathered, (gqk%my_npert, gqk%nb_k, gqk%nb_kq, ngather))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + + + +
+ + + +
+ ]
5852 : :
5853 : : case default
5854 [ - + - ]: 277828 : ABI_ERROR(sjoin("Gathering MPI-distributed matrix elements, unsupported mode: ", mode))
5855 : : end select
5856 : :
5857 [ + + ]: 33678830 : do my_ipt=1,my_ngather
5858 : 33401002 : ipt_glob = my_ipt + my_ptstart - 1
5859 : :
5860 : : ! FIXME: can the rearrangement be done in the select case statement?
5861 [ + + ]: 130800122 : do ib=1,gqk%nb_k
5862 [ + + ]: 418804456 : do jb=1,gqk%nb_kq
5863 [ + + ]: 2115096426 : do my_pert=1,gqk%my_npert
5864 [ - + ]: 2017975134 : if (mode == "k") then
5865 : 0 : g_gathered(my_pert, jb, ib, ipt_glob) = my_g(my_pert, jb, my_ipt, ib)
5866 : : else
5867 : 1729692972 : g_gathered(my_pert, jb, ib, ipt_glob) = my_g(my_pert, jb, ib, my_ipt)
5868 : : endif
5869 : : enddo
5870 : : enddo
5871 : : enddo
5872 : : enddo
5873 : :
5874 : 277828 : call xmpi_sum(g_gathered, comm, ierr)
5875 : :
5876 [ - + ]: 277828 : end subroutine gqk_gather
5877 : : !!***
5878 : :
5879 : : !----------------------------------------------------------------------
5880 : :
5881 : : !!****f* m_gstore/gstore_wannierize_and_write_gwan
5882 : : !! NAME
5883 : : !! gstore_wannierize_and_write_gwan
5884 : : !!
5885 : : !! FUNCTION
5886 : : !! Compute g(R_e,R_ph) from g(k,q). Save results to GWAN.nc file
5887 : : !!
5888 : : !! INPUTS
5889 : : !!
5890 : : !! SOURCE
5891 : :
5892 : 0 : subroutine gstore_wannierize_and_write_gwan(gstore, dvdb, dtfil)
5893 : :
5894 : : !Arguments ------------------------------------
5895 : : class(gstore_t),target, intent(in) :: gstore
5896 : : type(dvdb_t),intent(in) :: dvdb
5897 : : type(datafiles_type),intent(in) :: dtfil
5898 : :
5899 : : !Local variables-------------------------------
5900 : : !scalars
5901 : : integer,parameter :: master = 0
5902 : : integer,parameter :: wan_ntest = 4
5903 : : integer,parameter :: wan_nperiod = 3
5904 : : real(dp),parameter :: WAN_CLOSURE_TOL = tol8
5905 : : real(dp),parameter :: WAN_VELOCITY_FD_STEP = 1.0d-5
5906 : : real(dp),parameter :: WAN_VELOCITY_DEGEN_TOL = 1.0d-5
5907 : : real(dp),parameter :: WAN_VELOCITY_TOL = tol6
5908 : : integer :: nr_e, nr_p, nwan, iwan, jwan, spin, my_is, my_ip, ir, irp, my_ik, my_iq, nb_k, nb_kq
5909 : : integer :: my_nk, my_nq, ierr, ik, ikq, my_npert, nwin_k, nwin_kq, ii, jj, band_kq, band_k, ib_k, ib_kq
5910 : : integer :: itest, ip_loc, ik_glob, iq_glob, ntest_found, iperiod, idir, ib, nvelocity_tested
5911 : : real(dp) :: max_err, ref_scale, max_period_eig_err, period_eig_scale, max_period_g2_err, period_g2_scale
5912 : : real(dp) :: max_velocity_err, velocity_scale, band_gap, velocity_fd
5913 : : character(len=500) :: msg
5914 : : logical :: keep_umats, test_found(wan_ntest)
5915 : : type(wan_t),pointer :: wan
5916 : : type(gqk_t),pointer :: gqk
5917 : : !arrays
5918 : : integer :: qptrlatt_(3,3), units(2)
5919 : : integer :: test_ik(wan_ntest), test_iq(wan_ntest)
5920 : : integer :: period_gk(3,wan_nperiod), period_gq(3,wan_nperiod)
5921 : : real(dp) :: weight_qq, qpt(3), kpt(3), kq(3), dkred(3), cpu, wall, gflops
5922 : 0 : real(dp),allocatable :: eigens_k_test(:), eigens_kq_test(:), eigens_k_period(:), eigens_kq_period(:)
5923 : 0 : real(dp),allocatable :: eigens_k_plus(:), eigens_k_minus(:), vcart_test(:,:)
5924 : 0 : complex(dp),allocatable :: emikr(:), emiqr(:), u_k(:,:), u_kq(:,:), gww_epq(:,:,:,:,:), gww_pk(:,:,:,:), g_bb(:,:), tmp_mat(:,:)
5925 : 0 : complex(dp),allocatable :: test_gref(:,:,:,:), u_k_test(:,:), u_kq_test(:,:), cmat_test(:,:), g_expected(:,:)
5926 : 0 : complex(dp),allocatable :: g_atm_test(:,:,:,:), g_atm_period(:,:,:,:)
5927 : : ! *************************************************************************
5928 : :
5929 [ # # ]: 0 : units = [std_out, ab_out]
5930 : 0 : period_gk = reshape([1,0,0, 0,0,0, -1,1,0], shape(period_gk))
5931 : 0 : period_gq = reshape([0,0,0, 0,1,0, 0,0,1], shape(period_gq))
5932 : 0 : call wrtout(units, " Computing g(R_e,R_ph) in the Wannier representation...", pre_newlines=1)
5933 : 0 : call cwtime(cpu, wall, gflops, "start")
5934 : :
5935 [ # # ]: 0 : if (gstore%check_cplex_qkzone_gmode(2, "bz", "bz", "atom", kfilter="none") /= 0) then
5936 : 0 : ABI_ERROR("The gstore object is inconsistent with gstore_wannierize_and_write_gwan. See messages above.")
5937 : : end if
5938 : :
5939 : : ! TODO: Handle long-range part.
5940 [ # # # # ]: 0 : if (dvdb%has_zeff .or. dvdb%has_quadrupoles) then
5941 : 0 : ABI_WARNING("Treatment of long-range part not yet coded in gstore_wannierize_and_write_gwan!")
5942 : : end if
5943 : :
5944 [ # # ]: 0 : do my_is=1,gstore%my_nspins
5945 : 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
5946 : 0 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
5947 : :
5948 : : ! Initialize gkq%wan from ABIWAN.nc for this spin.
5949 : 0 : keep_umats = .False.
5950 : 0 : call gqk%wan%from_abiwan(dtfil%filabiwanin, spin, gstore%nsppol, keep_umats, dtfil%filnam_ds(4), gqk%comm%value)
5951 : 0 : wan => gqk%wan
5952 : :
5953 : : ! Compute Wigner-Seitz lattice vectors and llocate grpe_wwp with shape: (nr_p, nr_e, nwan, nwan, my_npert).
5954 : 0 : call kptrlatt_from_ngkpt(gstore%ngqpt, qptrlatt_)
5955 : : call wan%setup_eph_ws_kq(gstore%cryst, gstore%ebands%shiftk(:,1), gstore%ebands%kptrlatt, qptrlatt_, &
5956 : 0 : gqk%my_pert_start, my_npert, gqk%pert_comm)
5957 : :
5958 : 0 : nr_p = wan%nr_p; nr_e = wan%nr_e; nwan = wan%nwan
5959 : : !if (gqk%comm%me == master) call wan%print(units)
5960 : :
5961 : : ! Cache the pre-FT ground truth at four fixed GLOBAL coarse-mesh points. Using
5962 : : ! local first/last indices would make the test points depend on the MPI grid.
5963 [ # # ]: 0 : test_ik = [1, gqk%glob_nk, 1, gqk%glob_nk]
5964 [ # # ]: 0 : test_iq = [1, 1, gqk%glob_nq, gqk%glob_nq]
5965 : 0 : test_found = .False.
5966 [ # # # # : 0 : ABI_CALLOC(test_gref, (nwan, nwan, my_npert, wan_ntest))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
5967 : :
5968 [ # # # # : 0 : ABI_MALLOC(emikr, (nr_e))
# # # # #
# # # ]
5969 [ # # # # : 0 : ABI_MALLOC(emiqr, (nr_p))
# # # # #
# # # ]
5970 [ # # # # : 0 : ABI_MALLOC(gww_pk, (nwan, nwan, my_npert, my_nk))
# # # # #
# # # # #
# # # # #
# # # #
# ]
5971 : : ! Intermediate buffer to store the sum over k-points. Note my_nq.
5972 [ # # # # : 0 : ABI_CALLOC(gww_epq, (nwan, nwan, nr_e, my_npert, my_nq))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
5973 : :
5974 : : ! Loop over my q-points (partial sum over q).
5975 [ # # ]: 0 : do my_iq=1,my_nq
5976 : 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qpt)
5977 : :
5978 : : !call get_kg(qpt, 1, ecut_lr, gstore%cryst%gmet, ng_q, gvec_q)
5979 : : !ABI_FREE(gvec_q)
5980 : :
5981 : : ! Loop over my k-points (partial sum over k).
5982 [ # # ]: 0 : do my_ik=1,my_nk
5983 [ # # # # ]: 0 : kpt = gqk%my_kpts(:,my_ik); kq = kpt + qpt
5984 : 0 : ik = wan%krank%get_index(kpt); ikq = wan%krank%get_index(kq)
5985 [ # # ]: 0 : ABI_CHECK(ik /= -1, sjoin("Cannot find kpt: ", ktoa(kpt)))
5986 [ # # ]: 0 : ABI_CHECK(ikq /= -1, sjoin("Cannot find k+q: ", ktoa(kq)))
5987 : :
5988 : : ! Get rotation matrices at k and k+q.
5989 : 0 : nwin_k = wan%dimwin(ik); nwin_kq = wan%dimwin(ikq)
5990 [ # # # # : 0 : ABI_MALLOC(g_bb, (nwin_kq, nwin_k))
# # # # #
# # # # #
# # ]
5991 [ # # # # : 0 : ABI_MALLOC(u_k, (1:nwin_k, 1:nwan))
# # # # #
# # # # #
# # ]
5992 [ # # # # : 0 : ABI_MALLOC(u_kq, (1:nwin_kq, 1:nwan))
# # # # #
# # # # #
# # ]
5993 [ # # # # : 0 : ABI_MALLOC(tmp_mat, (nwin_kq, nwan))
# # # # #
# # # # #
# # ]
5994 : :
5995 [ # # # # : 0 : u_k = wan%u_k(1:nwin_k, 1:nwan, ik)
# # ]
5996 [ # # # # : 0 : u_kq = wan%u_k(1:nwin_kq, 1:nwan, ikq)
# # ]
5997 : :
5998 [ # # ]: 0 : do my_ip=1,gqk%my_npert
5999 : : !----------------------------------------------------------
6000 : : ! STEP 1: rotation to optimally smooth Bloch states
6001 : : !----------------------------------------------------------
6002 : : ! [Eqn. 24 of PRB 76, 165108 (2007)]
6003 : : ! g~(k,q) = U(k+q)^\dagger * g(k,q) * U(k)
6004 : :
6005 : : ! gqk%nb = wan%bmax - wan%bmin + 1
6006 : : ! (my_npert, nb, my_nq, nb, my_nk)
6007 : : ! ( p, b1_kq, q, b2_k, k) --> <k+q, b1| D_{q,p}H |k, b2>
6008 : :
6009 : : ! Extract e-ph matrix elements from my_g buffer to align bands with the U matrices at k and k+q.
6010 : : jj = 0
6011 [ # # ]: 0 : do ib_k=1,nb_k
6012 [ # # ]: 0 : band_k = ib_k - wan%bmin + 1; if (.not. wan%lwindow(band_k, ik)) cycle
6013 : 0 : jj = jj + 1; ii = 0
6014 [ # # ]: 0 : do ib_kq=1,nb_kq
6015 [ # # ]: 0 : band_kq = ib_kq - wan%bmin + 1; if (.not. wan%lwindow(band_kq, ikq)) cycle
6016 : 0 : ii = ii + 1
6017 : 0 : g_bb(ii, jj) = gqk%my_g(my_ip, ib_kq, my_iq, ib_k, my_ik)
6018 : : end do
6019 : : end do
6020 : :
6021 : : ! TODO: Remove LR part.
6022 : : !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)
6023 : :
6024 : : ! the two zgemm calls perform: epmats = [ cu(ikq)^\dagger * epmatk ] * cu(ikk)
6025 : : ! [here we have a size-reduction from nbnd*nbnd to nwan*nwan]
6026 : : ! output stored in gww_pk(:,:, my_ip, my_ik)
6027 : :
6028 : : ! gww_pk(:,:, my_ip, my_ik) = MATMUL(CONJG(TRANSPOSE(u_kq)), MATMUL(g_bb, u_k))
6029 : : ! tmp_mat (nwin_kq x nwan) = g_bb (nwin_kq x nwin_k) . u_k (nwin_k x nwan)
6030 : 0 : call ZGEMM('N', 'N', nwin_kq, nwan, nwin_k, cone, g_bb, nwin_kq, u_k, nwin_k, czero, tmp_mat, nwin_kq)
6031 : : ! gww_pk (nwan x nwan) = u_kq^dagger (nwan x nwin_kq) . tmp_mat (nwin_kq x nwan)
6032 : 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)
6033 : :
6034 : : !call ZGEMM('C', 'N', nwan, nbnd, nbnd, cone, u_kq, nbnd, epmatk(:, :, ik, imode), nbnd, czero, eptmp, nwan)
6035 : : !call ZGEMM('N', 'N', nwan, nwan, nbnd, cone, eptmp, nwan, u_k, nbnd, czero, epmats(:, :, ik, imode), nwan)
6036 : : end do ! my_ip
6037 : :
6038 : : ! Cache gww_pk(:,:,:,my_ik) for the on-mesh closure self-check below, while it is still
6039 : : ! valid for THIS my_iq (it gets overwritten by the next my_iq iteration).
6040 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
6041 : 0 : iq_glob = my_iq + gqk%my_qstart - 1
6042 [ # # ]: 0 : do itest=1,wan_ntest
6043 [ # # # # ]: 0 : if (test_ik(itest) == ik_glob .and. test_iq(itest) == iq_glob) then
6044 [ # # # # : 0 : test_gref(:,:,:,itest) = gww_pk(:,:,:,my_ik)
# # ]
6045 : 0 : test_found(itest) = .True.
6046 : : end if
6047 : : end do
6048 : :
6049 [ # # ]: 0 : ABI_FREE(g_bb)
6050 [ # # ]: 0 : ABI_FREE(tmp_mat)
6051 : :
6052 : : !----------------------------------------------------------------------
6053 : : ! STEP 3: Fourier transform to obtain matrix elements in electron wannier basis
6054 : : !----------------------------------------------------------------------
6055 : : ! [Eqn. 24 of PRB 76, 165108 (2007)]
6056 : : ! g(R_e,q) = (1/nkc) sum_k e^{-ikR_e} g~(k,q)
6057 : : ! g(R_e,q) is epmatw (nwan,nwan,ir)
6058 : :
6059 [ # # ]: 0 : do ir=1,nr_e
6060 [ # # ]: 0 : emikr(ir) = exp(-j_dpc * two_pi * dot_product(kpt, wan%r_e(:, ir))) / dble(gstore%nkbz)
6061 : : end do
6062 : : ! gww_pk(nwan, nwan, my_npert,my_nk)
6063 [ # # ]: 0 : do my_ip=1,gqk%my_npert
6064 [ # # ]: 0 : do ir=1,nr_e
6065 [ # # # # ]: 0 : gww_epq(:,:,ir, my_ip, my_iq) = gww_epq(:,:,ir, my_ip, my_iq) + emikr(ir) * gww_pk(:,:,my_ip, my_ik)
6066 : : end do
6067 : : end do
6068 : :
6069 [ # # ]: 0 : ABI_FREE(u_k)
6070 [ # # ]: 0 : ABI_FREE(u_kq)
6071 : : end do ! my_ik
6072 : : end do ! my_iq
6073 : :
6074 : 0 : call xmpi_sum(gww_epq, gqk%kpt_comm%value, ierr)
6075 : :
6076 : : !------------------------------------------
6077 : : ! Fourier transform to go to Wannier basis
6078 : : !------------------------------------------
6079 : : ! [Eqn. 24 of PRB 76, 165108 (2007)]
6080 : : ! g(R_e,R_p) = (1/nq) sum_q e^{-iqR_p} g(R_e,q)
6081 : :
6082 : : ! Loop over my q-points (partial sum over q).
6083 [ # # ]: 0 : do my_iq=1,my_nq
6084 : 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qpt)
6085 [ # # ]: 0 : do irp=1,nr_p
6086 [ # # ]: 0 : emiqr(irp) = exp(-j_dpc * two_pi * dot_product(qpt, wan%r_p(:, irp))) / dble(gstore%nqbz)
6087 : : end do
6088 : :
6089 [ # # ]: 0 : do my_ip=1,my_npert
6090 [ # # ]: 0 : do jwan=1,nwan
6091 [ # # ]: 0 : do iwan=1,nwan
6092 [ # # ]: 0 : do ir=1,nr_e
6093 : : ! 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}
6094 : : wan%grpe_wwp(:, ir, iwan, jwan, my_ip) = wan%grpe_wwp(:, ir, iwan, jwan, my_ip) + &
6095 [ # # ]: 0 : gww_epq(iwan, jwan, ir, my_ip, my_iq) * emiqr(:)
6096 : : end do
6097 : : end do
6098 : : end do
6099 : : end do ! my_ip
6100 : : end do ! my_iq
6101 : :
6102 : 0 : call xmpi_sum(wan%grpe_wwp, gqk%qpt_kpt_comm%value, ierr)
6103 : :
6104 [ # # ]: 0 : if (gqk%comm%me == master) then
6105 : 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] '
6106 [ # # ]: 0 : do ir=1,nr_e
6107 [ # # # # : 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,:,:,:))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
6108 : : end do
6109 : : end if
6110 : :
6111 : : !--------------------------------------------------------------------------------
6112 : : ! Wannier on-mesh closure self-check: interpolating g(k,q) back at a handful of
6113 : : ! the SAME coarse (k,q) points used to build wan%grpe_wwp must reproduce the pre-FT
6114 : : ! gww_pk cached above, once rotated by the SAME wan%interp_ham-derived u_k/u_kq
6115 : : ! (interp_ham's gauge is generically different from the ABIWAN gauge used for gww_pk,
6116 : : ! even on-mesh, so we apply the identical rotation to both sides rather than comparing
6117 : : ! against raw gww_pk). This isolates the WS/ndegen bookkeeping and forward/backward FT
6118 : : ! consistency. Cheap (wan_ntest points only) and deterministic: a hard ABI_CHECK, not a
6119 : : ! Refs-compared print, since it is a precision-only mathematical identity.
6120 : : !--------------------------------------------------------------------------------
6121 [ # # # # : 0 : ABI_MALLOC(u_k_test, (nwan,nwan))
# # # # #
# # # # #
# # ]
6122 [ # # # # : 0 : ABI_MALLOC(u_kq_test, (nwan,nwan))
# # # # #
# # # ]
6123 [ # # # # : 0 : ABI_MALLOC(eigens_k_test, (nwan))
# # # # #
# # # ]
6124 [ # # # # : 0 : ABI_MALLOC(eigens_kq_test, (nwan))
# # # # ]
6125 [ # # # # : 0 : ABI_MALLOC(eigens_k_period, (nwan))
# # # # ]
6126 [ # # # # : 0 : ABI_MALLOC(eigens_kq_period, (nwan))
# # # # ]
6127 [ # # # # : 0 : ABI_MALLOC(eigens_k_plus, (nwan))
# # # # ]
6128 [ # # # # : 0 : ABI_MALLOC(eigens_k_minus, (nwan))
# # # # ]
6129 [ # # # # : 0 : ABI_MALLOC(vcart_test, (3,nwan))
# # # # #
# # # ]
6130 [ # # # # : 0 : ABI_MALLOC(cmat_test, (nwan,nwan))
# # # # #
# # # ]
6131 [ # # # # : 0 : ABI_MALLOC(g_expected, (nwan,nwan))
# # # # #
# # # ]
6132 [ # # # # : 0 : ABI_MALLOC(g_atm_test, (nwan, nwan, my_npert, 1))
# # # # #
# # # # #
# # # # #
# ]
6133 [ # # # # : 0 : ABI_MALLOC(g_atm_period, (nwan, nwan, my_npert, 1))
# # # # #
# # # # #
# # ]
6134 : :
6135 : 0 : max_err = zero; ref_scale = zero
6136 : 0 : max_period_eig_err = zero; period_eig_scale = zero
6137 : 0 : max_period_g2_err = zero; period_g2_scale = zero
6138 : 0 : max_velocity_err = zero; velocity_scale = zero; nvelocity_tested = 0
6139 [ # # ]: 0 : do itest=1,wan_ntest
6140 [ # # ]: 0 : if (.not. test_found(itest)) cycle
6141 : 0 : my_ik = test_ik(itest) - gqk%my_kstart + 1
6142 : 0 : my_iq = test_iq(itest) - gqk%my_qstart + 1
6143 [ # # ]: 0 : kpt = gqk%my_kpts(:,my_ik)
6144 : 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qpt)
6145 : 0 : call wan%interp_ham(gstore%cryst, kpt, u_k_test, eigens_k_test, vcart_test)
6146 [ # # ]: 0 : call wan%interp_ham(gstore%cryst, kpt + qpt, u_kq_test, eigens_kq_test)
6147 : 0 : call wan%interp_eph_manyq(gstore%cryst, 1, qpt, kpt, g_atm_test)
6148 [ # # # # : 0 : ref_scale = max(ref_scale, maxval(abs(test_gref(:,:,:,itest))))
# # # # #
# # # #
# ]
6149 [ # # ]: 0 : do ip_loc=1,my_npert
6150 : : ! Same order/dagger convention as wan_interp_eph_manyq (m_mlwfovlp.F90).
6151 : 0 : call ZGEMM('N', 'N', nwan, nwan, nwan, cone, u_kq_test, nwan, test_gref(:,:,ip_loc,itest), nwan, czero, cmat_test, nwan)
6152 : 0 : call ZGEMM('N', 'C', nwan, nwan, nwan, cone, cmat_test, nwan, u_k_test, nwan, czero, g_expected, nwan)
6153 [ # # # # : 0 : max_err = max(max_err, maxval(abs(g_expected - g_atm_test(:,:,ip_loc,1))))
# # # # #
# # # ]
6154 : : end do
6155 : :
6156 : : ! Validate analytic Cartesian group velocities against centered finite
6157 : : ! differences of the interpolated eigenvalues. Skip degenerate bands,
6158 : : ! whose individual diagonal velocities depend on the chosen subspace basis.
6159 : : ! These calls intentionally follow the closure comparison because the
6160 : : ! finite-difference diagonalizations reuse the u_kq_test work buffer.
6161 [ # # ]: 0 : do idir=1,3
6162 [ # # ]: 0 : dkred = WAN_VELOCITY_FD_STEP * gstore%cryst%rprimd(idir,:) / two_pi
6163 [ # # ]: 0 : call wan%interp_ham(gstore%cryst, kpt + dkred, u_kq_test, eigens_k_plus)
6164 [ # # ]: 0 : call wan%interp_ham(gstore%cryst, kpt - dkred, u_kq_test, eigens_k_minus)
6165 [ # # ]: 0 : do ib=1,nwan
6166 : 0 : band_gap = huge(one)
6167 [ # # ]: 0 : if (ib > 1) band_gap = min(band_gap, abs(eigens_k_test(ib) - eigens_k_test(ib-1)))
6168 [ # # ]: 0 : if (ib < nwan) band_gap = min(band_gap, abs(eigens_k_test(ib+1) - eigens_k_test(ib)))
6169 [ # # ]: 0 : if (band_gap < WAN_VELOCITY_DEGEN_TOL) cycle
6170 : 0 : velocity_fd = (eigens_k_plus(ib) - eigens_k_minus(ib)) / (two * WAN_VELOCITY_FD_STEP)
6171 : 0 : max_velocity_err = max(max_velocity_err, abs(vcart_test(idir,ib) - velocity_fd))
6172 : 0 : velocity_scale = max(velocity_scale, abs(vcart_test(idir,ib)), abs(velocity_fd))
6173 : 0 : nvelocity_tested = nvelocity_tested + 1
6174 : : end do
6175 : : end do
6176 : :
6177 : : ! Reciprocal-periodicity self-check. Integer shifts leave the real-space
6178 : : ! Fourier sums invariant. Compare eigenvalues and per-perturbation
6179 : : ! Frobenius norms, which remain well defined even if a tiny roundoff
6180 : : ! difference rotates eigenvectors inside a degenerate subspace.
6181 [ # # # # : 0 : period_eig_scale = max(period_eig_scale, maxval(abs(eigens_k_test)), maxval(abs(eigens_kq_test)))
# # # # #
# # # # #
# # ]
6182 [ # # ]: 0 : do ip_loc=1,my_npert
6183 [ # # # # ]: 0 : period_g2_scale = max(period_g2_scale, sum(abs(g_atm_test(:,:,ip_loc,1))**2))
6184 : : end do
6185 [ # # ]: 0 : do iperiod=1,wan_nperiod
6186 [ # # ]: 0 : call wan%interp_ham(gstore%cryst, kpt + period_gk(:,iperiod), u_k_test, eigens_k_period)
6187 : : call wan%interp_ham(gstore%cryst, kpt + qpt + period_gk(:,iperiod) + period_gq(:,iperiod), &
6188 [ # # ]: 0 : u_kq_test, eigens_kq_period)
6189 : : call wan%interp_eph_manyq(gstore%cryst, 1, qpt + period_gq(:,iperiod), &
6190 [ # # # # ]: 0 : kpt + period_gk(:,iperiod), g_atm_period)
6191 : : max_period_eig_err = max(max_period_eig_err, maxval(abs(eigens_k_period - eigens_k_test)), &
6192 [ # # # # : 0 : maxval(abs(eigens_kq_period - eigens_kq_test)))
# # # # #
# # # # #
# # ]
6193 [ # # ]: 0 : do ip_loc=1,my_npert
6194 : : max_period_g2_err = max(max_period_g2_err, abs( &
6195 [ # # # # : 0 : sum(abs(g_atm_period(:,:,ip_loc,1))**2) - sum(abs(g_atm_test(:,:,ip_loc,1))**2)))
# # # # ]
6196 : : end do
6197 : : end do
6198 : : end do
6199 : :
6200 : : ! Each fixed (k,q) pair must be owned exactly once within each perturbation
6201 : : ! slice. Reduce diagnostics over the complete spin communicator so every rank
6202 : : ! applies the same check and the printed result is MPI-decomposition invariant.
6203 [ # # # # ]: 0 : ntest_found = count(test_found)
6204 : 0 : call xmpi_sum(ntest_found, gqk%qpt_kpt_comm%value, ierr)
6205 [ # # ]: 0 : ABI_CHECK_IEQ(ntest_found, wan_ntest, "Wannier closure test did not find each fixed global (k,q) point exactly once")
6206 : 0 : call xmpi_max(max_err, gqk%comm%value, ierr)
6207 : 0 : call xmpi_max(ref_scale, gqk%comm%value, ierr)
6208 : 0 : call xmpi_max(max_period_eig_err, gqk%comm%value, ierr)
6209 : 0 : call xmpi_max(period_eig_scale, gqk%comm%value, ierr)
6210 : 0 : call xmpi_max(max_period_g2_err, gqk%comm%value, ierr)
6211 : 0 : call xmpi_max(period_g2_scale, gqk%comm%value, ierr)
6212 : 0 : call xmpi_max(max_velocity_err, gqk%comm%value, ierr)
6213 : 0 : call xmpi_max(velocity_scale, gqk%comm%value, ierr)
6214 : 0 : call xmpi_sum(nvelocity_tested, gqk%qpt_kpt_comm%value, ierr)
6215 : 0 : ref_scale = max(ref_scale, tol12)
6216 : 0 : period_eig_scale = max(period_eig_scale, tol12)
6217 : 0 : period_g2_scale = max(period_g2_scale, tol12)
6218 : 0 : velocity_scale = max(velocity_scale, one)
6219 : :
6220 [ # # ]: 0 : if (gqk%comm%me == master) then
6221 : 0 : write(std_out,'(a,es10.2,a,es10.2)') " Wannier on-mesh closure self-check: max_err=", max_err, " ref_scale=", ref_scale
6222 : 0 : write(std_out,'(a,es10.2,a,es10.2)') " Wannier reciprocal-periodicity self-check: max_eig_err=", &
6223 : 0 : max_period_eig_err, " max_g2_err=", max_period_g2_err
6224 : 0 : write(std_out,'(a,i0,a,es10.2)') " Wannier group-velocity self-check: nvalues=", &
6225 : 0 : nvelocity_tested, " max_err=", max_velocity_err
6226 : : end if
6227 : :
6228 [ # # ]: 0 : ABI_CHECK(max_err < WAN_CLOSURE_TOL * ref_scale, "Wannier on-mesh closure self-check failed")
6229 : 0 : msg = "Wannier reciprocal-periodicity self-check failed for interpolated electronic eigenvalues."
6230 [ # # ]: 0 : ABI_CHECK(max_period_eig_err < WAN_CLOSURE_TOL * period_eig_scale, msg)
6231 : 0 : msg = "Wannier reciprocal-periodicity self-check failed for gauge-invariant e-ph Frobenius norms."
6232 [ # # ]: 0 : ABI_CHECK(max_period_g2_err < WAN_CLOSURE_TOL * period_g2_scale, msg)
6233 [ # # ]: 0 : ABI_CHECK(nvelocity_tested > 0, "Wannier group-velocity self-check did not find a nondegenerate band")
6234 : 0 : msg = "Analytic Wannier group velocities do not agree with finite differences of the interpolated eigenvalues."
6235 [ # # ]: 0 : ABI_CHECK(max_velocity_err < WAN_VELOCITY_TOL * velocity_scale, msg)
6236 : :
6237 [ # # ]: 0 : ABI_FREE(u_k_test)
6238 [ # # ]: 0 : ABI_FREE(u_kq_test)
6239 [ # # ]: 0 : ABI_FREE(eigens_k_test)
6240 [ # # ]: 0 : ABI_FREE(eigens_kq_test)
6241 [ # # ]: 0 : ABI_FREE(eigens_k_period)
6242 [ # # ]: 0 : ABI_FREE(eigens_kq_period)
6243 [ # # ]: 0 : ABI_FREE(eigens_k_plus)
6244 [ # # ]: 0 : ABI_FREE(eigens_k_minus)
6245 [ # # ]: 0 : ABI_FREE(vcart_test)
6246 [ # # ]: 0 : ABI_FREE(cmat_test)
6247 [ # # ]: 0 : ABI_FREE(g_expected)
6248 [ # # ]: 0 : ABI_FREE(g_atm_test)
6249 [ # # ]: 0 : ABI_FREE(g_atm_period)
6250 [ # # ]: 0 : ABI_FREE(test_gref)
6251 : :
6252 : : ! Free memory for this spin.
6253 [ # # ]: 0 : ABI_FREE(emikr)
6254 [ # # ]: 0 : ABI_FREE(emiqr)
6255 [ # # ]: 0 : ABI_FREE(gww_pk)
6256 [ # # ]: 0 : ABI_FREE(gww_epq)
6257 : : end do ! my_is
6258 : :
6259 : : ! =====================
6260 : : ! Write data to GWAN.nc
6261 : : ! =====================
6262 [ # # ]: 0 : do spin=1,gstore%nsppol
6263 : 0 : my_is = gstore%spin2my_is(spin)
6264 [ # # ]: 0 : if (my_is /= 0) then
6265 : 0 : gqk => gstore%gqk(my_is)
6266 : : ! grpe_wwp has already been reduced over qpt_kpt_comm and is replicated
6267 : : ! across the q/k (and auxiliary sum/band) grid. Exactly one such slice
6268 : : ! must enter the writer; all ranks along its perturbation axis participate
6269 : : ! collectively because grpe_wwp remains distributed over perturbations.
6270 [ # # # # : 0 : if (all(gqk%coords_qkpb_sumbp([1,2,4,5,6]) == 0)) then
# # ]
6271 : 0 : call gqk%wan%ncwrite_gwan(dtfil, gstore%cryst, gstore%ebands, gqk%pert_comm)
6272 : : end if
6273 : : end if
6274 : 0 : call xmpi_barrier(gstore%comm)
6275 : : end do ! spin
6276 : :
6277 : 0 : call cwtime_report(" gstore_wannierize_and_write_gwan:", cpu, wall, gflops)
6278 : :
6279 [ # # ]: 0 : end subroutine gstore_wannierize_and_write_gwan
6280 : : !!***
6281 : :
6282 : : !!****f* m_gstore/handle_lr_term
6283 : : !! NAME
6284 : : !! handle_lr_term
6285 : : !!
6286 : : !! FUNCTION
6287 : : !! Add/Remove the long range term to/from the e-ph matrix elements.
6288 : : !!
6289 : : !! INPUTS
6290 : : !!
6291 : : !! SOURCE
6292 : :
6293 : : !subroutine handle_lr_term(cryst, qpt, ng, gvec, nwin_kq, nwin_k, nwan, u_kq, u_k, zeff, qstar, isgn, g_bb)
6294 : : !
6295 : : !!Arguments ------------------------------------
6296 : : ! type(crystal_t),intent(in) :: cryst
6297 : : ! real(dp),intent(in) :: qpt(3)
6298 : : ! integer,intent(in) :: ng, nwin_kq, nwin_k, nwan, isgn, gvec(3,ng)
6299 : : ! complex(dp),intent(in) :: u_kq(nwin_kq, nwan), u_k(nwin_k,nwan)
6300 : : ! real(dp),intent(in) :: zeff(3,3,cryst%natom), qstar(3,3,3,cryst%natom)
6301 : : ! complex(dp),intent(inout) :: g_bb(nwin_kq, nwin_k)
6302 : : !
6303 : : !!Local variables-------------------------------
6304 : : !!scalars
6305 : : ! !integer :: ig
6306 : : ! !character(len=500) :: msg
6307 : : !!arrays
6308 : : !! *************************************************************************
6309 : : !
6310 : : !end subroutine handle_lr_term
6311 : : !!***
6312 : :
6313 : : !----------------------------------------------------------------------
6314 : :
6315 : : !!****f* m_gstore/gqk_get_erange_mask
6316 : : !! NAME
6317 : : !! gqk_get_erange_mask
6318 : : !!
6319 : : !! FUNCTION
6320 : : !! Compute MPI-distributed and global masks for electronic states |n,k> allowed by erange.
6321 : : !!
6322 : : !! INPUTS
6323 : : !! gstore<gstore_t>=Electron-phonon object containing dimensions and related quantities.
6324 : : !! erange=Energy range:
6325 : : !! -- if both entries are negative, assume metal and include states within the
6326 : : !! [efermi-abs(erange(1)), efermi+abs(erange(2))] window;
6327 : : !! -- otherwise, erange(1) & erange(2) select window wrt VBM & CBM, respectively.
6328 : : !!
6329 : : !! OUTPUT
6330 : : !! my_states(gqk%nb_k, gqk%my_nk)=Mask for selected states at this MPI proc.
6331 : : !! glob_states(gqk%nb_k, gqk%my_nk)=Global mask for selected states.
6332 : : !!
6333 : : !! SOURCE
6334 : :
6335 : 0 : subroutine gqk_get_erange_mask(gqk, gstore, erange, my_states, glob_states)
6336 : :
6337 : : !Arguments ------------------------------------
6338 : : !scalars
6339 : : class(gqk_t), target, intent(inout) :: gqk
6340 : : class(gstore_t), target, intent(in) :: gstore
6341 : : !arrays
6342 : : real(dp), intent(in) :: erange(2)
6343 : : integer, intent(out) :: my_states(gqk%nb_k, gqk%my_nk), glob_states(gqk%nb_k, gqk%glob_nk)
6344 : :
6345 : : !Local variables-------------------------------
6346 : : !scalars
6347 : : class(ebands_t), pointer :: ebands
6348 : : type(gaps_t) :: gaps
6349 : : integer :: my_ik, ik_ibz, ik_glob, ib_k, bstart_k, gap_err, ierr
6350 : : real(dp) :: vmax, cmin, eig
6351 : : logical :: assume_gap
6352 : : !----------------------------------------------------------------------
6353 : :
6354 : 0 : ebands => gstore%ebands
6355 : :
6356 [ # # # # ]: 0 : assume_gap = .not. all(erange < tol12)
6357 : 0 : gaps = ebands%get_gaps(gap_err)
6358 : :
6359 [ # # ]: 0 : if (assume_gap) then
6360 [ # # ]: 0 : call gaps%print([std_out])
6361 : 0 : vmax = gaps%vb_max(gqk%spin) + tol2 * eV_Ha
6362 : 0 : cmin = gaps%cb_min(gqk%spin) - tol2 * eV_Ha
6363 : : else
6364 : 0 : vmax = ebands%fermie
6365 : 0 : cmin = ebands%fermie
6366 : : end if
6367 : :
6368 : : ! Fill the mask for allowed states
6369 [ # # # # ]: 0 : my_states(:,:) = 0
6370 [ # # # # ]: 0 : glob_states(:,:) = 0
6371 : 0 : bstart_k = gstore%brange_k_spin(1, gqk%spin)
6372 : :
6373 [ # # ]: 0 : do my_ik=1,gqk%my_nk
6374 : 0 : ik_ibz = gqk%my_k2ibz(1, my_ik)
6375 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
6376 : :
6377 [ # # ]: 0 : do ib_k=1,gqk%nb_k
6378 : 0 : eig = ebands%eig(bstart_k + ib_k - 1, ik_ibz, gqk%spin)
6379 : :
6380 [ # # ]: 0 : if (abs(erange(1)) > tol12) then
6381 : : ! Filter valence states.
6382 [ # # # # ]: 0 : if (eig <= vmax .and. vmax - eig <= abs(erange(1))) then
6383 : 0 : my_states(ib_k, my_ik) = 1; glob_states(ib_k, ik_glob) = 1
6384 : : end if
6385 : : end if
6386 : :
6387 [ # # ]: 0 : if (abs(erange(2)) > tol12) then
6388 : : ! Filter conduction states.
6389 [ # # # # ]: 0 : if (eig >= cmin .and. eig - cmin <= abs(erange(2))) then
6390 : 0 : my_states(ib_k, my_ik) = 1; glob_states(ib_k, ik_glob) = 1
6391 : : end if
6392 : : end if
6393 : :
6394 : : enddo
6395 : : enddo
6396 : :
6397 : 0 : call xmpi_sum(glob_states, gqk%kpt_comm%value, ierr)
6398 : 0 : call gaps%free()
6399 : :
6400 [ # # # # : 0 : end subroutine gqk_get_erange_mask
# # # # #
# # # # #
# # ]
6401 : : !!***
6402 : :
6403 : : !----------------------------------------------------------------------
6404 : :
6405 : : !!****f* m_gstore/gqk_filter_erange
6406 : : !! NAME
6407 : : !! gqk_filter_erange
6408 : : !!
6409 : : !! FUNCTION
6410 : : !! Nullify all matrix elements connecting electronic states excluded by energy range.
6411 : : !!
6412 : : !! INPUTS
6413 : : !! gstore<gstore_t>=Electron-phonon object containing dimensions and related quantities.
6414 : : !! erange=Energy range:
6415 : : !! -- if both entries are negative, assume metal and include states within the
6416 : : !! [efermi-abs(erange(1)), efermi+abs(erange(2))] window;
6417 : : !! -- otherwise, erange(1) & erange(2) select window wrt VBM & CBM, respectively.
6418 : : !!
6419 : : !! OUTPUT
6420 : : !!
6421 : : !! SOURCE
6422 : :
6423 : 0 : subroutine gqk_filter_erange(gqk, gstore, erange)
6424 : :
6425 : : !Arguments ------------------------------------
6426 : : !scalars
6427 : : class(gqk_t), target, intent(inout) :: gqk
6428 : : class(gstore_t), target, intent(in) :: gstore
6429 : : !arrays
6430 : : real(dp), intent(in) :: erange(2)
6431 : :
6432 : : !Local variables-------------------------------
6433 : : !scalars
6434 : : integer :: my_ik, ik_glob, my_iq, ikq, ipert, ierr, ib_k, jb_kq
6435 : : real(dp) :: wtq
6436 : : logical :: skip_nk, skip_mkq, skip_q
6437 : 0 : type(krank_t) :: krank_kpts
6438 : : type(ebands_t), pointer :: ebands
6439 : : !arrays
6440 : 0 : integer :: my_states(gqk%nb_k, gqk%my_nk), glob_states(gqk%nb_k, gqk%glob_nk)
6441 : 0 : real(dp) :: kpt(3), qpt(3), kpq(3), kpts(3, gqk%glob_nk), my_qpts(3, gqk%my_nq)
6442 : : !----------------------------------------------------------------------
6443 : :
6444 [ # # ]: 0 : ABI_CHECK_IEQ(gqk%nb_kq, gqk%nb_k, "nb_kq /= nk_k not tested")
6445 : :
6446 : 0 : ebands => gstore%ebands
6447 : :
6448 : : ! Compute masks
6449 : 0 : call gqk%get_erange_mask(gstore, erange, my_states, glob_states)
6450 : :
6451 : : ! Get global krank for k+q transitions
6452 [ # # # # ]: 0 : kpts(:, :) = zero
6453 [ # # ]: 0 : do my_ik=1,gqk%my_nk
6454 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
6455 [ # # ]: 0 : kpts(:, ik_glob) = gqk%my_kpts(:, my_ik)
6456 : : enddo
6457 : 0 : call xmpi_sum(kpts, gqk%kpt_comm%value, ierr)
6458 : :
6459 : 0 : call krank_kpts%from_kptrlatt(gqk%glob_nk, kpts, ebands%kptrlatt, compute_invrank=.True.)
6460 : :
6461 : : ! Get all q-points for this proc
6462 [ # # ]: 0 : do my_iq=1,gqk%my_nq
6463 : 0 : call gqk%myqpt(my_iq, gstore, wtq, my_qpts(:, my_iq))
6464 : : enddo
6465 : :
6466 : : ! Nullify matrix elements connecting the excluded states
6467 [ # # ]: 0 : do my_ik=1,gqk%my_nk
6468 [ # # ]: 0 : kpt(:) = gqk%my_kpts(:, my_ik)
6469 : :
6470 [ # # ]: 0 : do ib_k=1,gqk%nb_k
6471 : : ! |nk> is forbidden
6472 : 0 : skip_nk = .false.
6473 [ # # ]: 0 : if (my_states(ib_k, my_ik) == 0) skip_nk = .true.
6474 : :
6475 [ # # ]: 0 : do my_iq=1,gqk%my_nq
6476 [ # # ]: 0 : qpt(:) = my_qpts(:, my_iq)
6477 : :
6478 : : ! Find k+q --> k' index in krank_kpts
6479 [ # # ]: 0 : kpq(:) = kpt(:) + qpt(:)
6480 : 0 : ikq = krank_kpts%get_index(kpq)
6481 : :
6482 : : ! k+q falls outside the filtered kpts pool
6483 : 0 : skip_q = .false.
6484 [ # # ]: 0 : if (ikq == -1) skip_q = .true.
6485 : :
6486 [ # # ]: 0 : do jb_kq=1,gqk%nb_kq
6487 : : ! |mk+q> is forbidden
6488 : 0 : skip_mkq = .false.
6489 [ # # ]: 0 : if (glob_states(jb_kq, ikq) == 0) skip_mkq = .true.
6490 : :
6491 [ # # ]: 0 : do ipert=1,gqk%my_npert
6492 : :
6493 [ # # # # ]: 0 : if (skip_nk .or. skip_q .or. skip_mkq) then
6494 : 0 : select case (gqk%cplex)
6495 : : case (1)
6496 : 0 : gqk%my_g2(ipert, jb_kq, my_iq, ib_k, my_ik) = zero
6497 : : case (2)
6498 : 0 : gqk%my_g(ipert, jb_kq, my_iq, ib_k, my_ik) = czero
6499 : : case default
6500 [ # # # ]: 0 : ABI_ERROR(sjoin("Invalid gqk%cplex:", itoa(gqk%cplex)))
6501 : : end select
6502 : : end if
6503 : :
6504 : : enddo
6505 : : enddo
6506 : : enddo
6507 : : enddo
6508 : : enddo
6509 : :
6510 : 0 : call krank_kpts%free()
6511 : :
6512 [ # # # # : 0 : end subroutine gqk_filter_erange
# # ]
6513 : : !!***
6514 : :
6515 : : !----------------------------------------------------------------------
6516 : :
6517 : : !!****f* m_gstore/gstore_compute_and_write_ph
6518 : : !! NAME
6519 : : !! gstore_compute_and_write_ph
6520 : : !!
6521 : : !! FUNCTION
6522 : : !! Compute phonon frequencies and eigenvectors in the IBZ. Write results to disk
6523 : : !!
6524 : : !! SOURCE
6525 : :
6526 : 8 : subroutine gstore_compute_and_write_ph(gstore, root_ncid)
6527 : :
6528 : : !Arguments ------------------------------------
6529 : : !scalars
6530 : : class(gstore_t), intent(in) :: gstore
6531 : : integer,intent(in) :: root_ncid
6532 : :
6533 : : !Local variables-------------------------------
6534 : : !scalars
6535 : : integer :: natom, natom3, nproc, ii, iq_ibz, my_nqibz, iq_start, ncerr
6536 : : real(dp) :: cpu, wall, gflops
6537 : : !arrays
6538 : 8 : integer,allocatable :: my_iqibz_inds(:)
6539 : 8 : real(dp),allocatable :: buf_wqnu(:,:), buf_eigvec_cart(:,:,:,:,:), displ_cart_qibz(:,:,:,:)
6540 : : !----------------------------------------------------------------------
6541 : :
6542 : 8 : nproc = xmpi_comm_size(gstore%comm)
6543 : 8 : natom = gstore%cryst%natom; natom3 = 3 * natom
6544 : :
6545 : 8 : call wrtout(std_out, " Computing phonon frequencies and displacements in the IBZ ...", pre_newlines=1, do_flush=.True.)
6546 : 8 : call cwtime(cpu, wall, gflops, "start")
6547 : :
6548 : 8 : call xmpi_split_block(gstore%nqibz, gstore%comm, my_nqibz, my_iqibz_inds)
6549 [ - + + - : 32 : ABI_MALLOC(buf_wqnu, (natom3, my_nqibz))
- + + - +
- + - - +
- + ]
6550 [ - + + - : 40 : ABI_MALLOC(buf_eigvec_cart, (2, 3, natom, natom3, my_nqibz))
- + + - -
+ + - + -
+ - - + -
+ ]
6551 [ - + + - : 32 : ABI_MALLOC(displ_cart_qibz, (2, 3, natom, natom3))
- + + - +
- + - - +
- + ]
6552 : :
6553 [ - + ]: 8 : NCF_CHECK(nctk_prepare_mpiio(root_ncid, "phfreqs_ibz"))
6554 [ - + ]: 8 : NCF_CHECK(nctk_prepare_mpiio(root_ncid, "pheigvec_cart_ibz"))
6555 : :
6556 [ + + ]: 141 : do ii=1,my_nqibz
6557 : 133 : iq_ibz = my_iqibz_inds(ii)
6558 : : call gstore%ifc%fourq(gstore%cryst, gstore%qibz(:, iq_ibz), buf_wqnu(:,ii), displ_cart_qibz, &
6559 : 141 : out_eigvec=buf_eigvec_cart(:,:,:,:,ii))
6560 : : end do
6561 : :
6562 [ - + - - ]: 8 : if (nproc > 1 .and. gstore%nqibz >= nproc) then
6563 [ # # ]: 0 : NCF_CHECK(nctk_set_collective(root_ncid, root_vid("phfreqs_ibz")))
6564 [ # # ]: 0 : NCF_CHECK(nctk_set_collective(root_ncid, root_vid("pheigvec_cart_ibz")))
6565 : : end if
6566 : 8 : call xmpi_barrier(gstore%comm)
6567 : :
6568 [ + - ]: 8 : if (my_nqibz > 0) then
6569 : 8 : iq_start = my_iqibz_inds(1)
6570 : : ncerr = nf90_put_var(root_ncid, root_vid("phfreqs_ibz"), buf_wqnu, &
6571 [ + + + + ]: 40 : start=[1, iq_start], count=[natom3, my_nqibz])
6572 [ - + ]: 8 : NCF_CHECK(ncerr)
6573 : : ncerr = nf90_put_var(root_ncid, root_vid("pheigvec_cart_ibz"), buf_eigvec_cart, &
6574 [ + + + + ]: 88 : start=[1,1,1,1,iq_start], count=[2, 3, natom, natom3, my_nqibz])
6575 [ - + ]: 8 : NCF_CHECK(ncerr)
6576 : : end if
6577 : :
6578 [ - + ]: 8 : ABI_FREE(displ_cart_qibz)
6579 [ - + ]: 8 : ABI_FREE(my_iqibz_inds)
6580 [ - + ]: 8 : ABI_FREE(buf_wqnu)
6581 [ - + ]: 8 : ABI_FREE(buf_eigvec_cart)
6582 : 16 : call cwtime_report(" Phonon computation + output", cpu, wall, gflops)
6583 : :
6584 : : contains
6585 : :
6586 : 16 : integer function root_vid(var_name)
6587 : : character(len=*),intent(in) :: var_name
6588 : 16 : root_vid = nctk_idname(root_ncid, var_name)
6589 : : end function root_vid
6590 : :
6591 : : end subroutine gstore_compute_and_write_ph
6592 : : !!***
6593 : :
6594 : : !!****f* m_gstore/gstore_compute_and_write_vk
6595 : : !! NAME
6596 : : !! gstore_compute_and_write_vk
6597 : : !!
6598 : : !! FUNCTION
6599 : : !! Compute electronic group velocities in the IBZ.
6600 : : !! Write results to disk
6601 : : !!
6602 : : !! SOURCE
6603 : :
6604 : 8 : subroutine gstore_compute_and_write_vk(gstore, mpw, wfd, ebands, psps, pawtab, root_ncid)
6605 : :
6606 : : !Arguments ------------------------------------
6607 : : class(gstore_t), intent(in) :: gstore
6608 : : integer,intent(in) :: mpw
6609 : : type(wfd_t),intent(in) :: wfd
6610 : : type(ebands_t),target,intent(in) :: ebands
6611 : : type(pseudopotential_type),intent(in) :: psps
6612 : : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
6613 : : integer,intent(in) :: root_ncid
6614 : :
6615 : : !Local variables-------------------------------
6616 : : !scalars
6617 : : 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
6618 : : real(dp) :: cpu_kk, wall_kk, gflops_kk, eig0nk
6619 : : logical :: isirr_k
6620 [ + + + + : 80 : type(ddkop_t) :: ddkop
+ + ]
6621 : : !arrays
6622 : : integer :: g0_k(3)
6623 : 8 : integer,allocatable :: count_bk(:,:)
6624 : : real(dp) :: kk(3) !, kk_ibz(3)
6625 : 16 : real(dp),allocatable :: vnk_cart_ibz(:,:,:), cg_work(:,:)
6626 : 8 : type(pawcprj_type),allocatable :: cwaveprj0(:,:)
6627 : : !----------------------------------------------------------------------
6628 : :
6629 : 8 : call wrtout(std_out, " computing and writing velocity operator matrix elements in the ibz")
6630 : 8 : call wrtout(std_out, " note that not all the k-points in the ibz are computed when kfilter is activated!")
6631 : 8 : call cwtime(cpu_kk, wall_kk, gflops_kk, "start")
6632 : :
6633 : : ! On disk, we have:
6634 : : ! nctkarr_t("vk_cart_ibz", "dp", "three, nb_k, gstore_nkibz"))
6635 : : ! nctkarr_t("vkmat_cart_ibz", "dp", "two, three, nb, nb, gstore_nkibz")))
6636 : :
6637 : 8 : call ddkop%init(gstore%dtset, gstore%cryst, pawtab, psps, wfd%mpi_enreg, mpw, wfd%ngfft)
6638 [ - + + - : 24 : ABI_MALLOC(cg_work, (2, mpw*wfd%nspinor))
+ - + - -
+ - + ]
6639 : :
6640 : 8 : usecprj = gstore%dtset%usepaw
6641 [ - + + - : 32 : ABI_MALLOC(cwaveprj0, (gstore%cryst%natom, wfd%nspinor*usecprj))
+ - - - +
- - + - +
- + - + -
- ]
6642 : :
6643 [ + + ]: 16 : do my_is=1,gstore%my_nspins
6644 : 8 : associate (gqk => gstore%gqk(my_is))
6645 : 8 : spin = gstore%my_spins(my_is); nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
6646 : :
6647 : : ! Be careful as wavefunctions might be replicated.
6648 : : ! Use count_bk to count how many states have been computed in parallel in order to rescale the results.
6649 : 8 : if (gstore%with_vk == 1) then
6650 [ - + + - : 1285 : ABI_CALLOC(vnk_cart_ibz, (3, nb_k, gstore%nkibz))
- + + - +
- + - - +
- + - + +
+ + + +
+ ]
6651 [ - + + - : 445 : ABI_ICALLOC(count_bk, (nb_k, gstore%nkibz))
- + + - +
- + - - +
- + - + +
+ + + ]
6652 : : else
6653 : 0 : ABI_ERROR("gstore%with_vk 2 not implemented")
6654 : : end if
6655 : :
6656 [ - + ]: 8 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6657 [ - + ]: 8 : NCF_CHECK(nctk_prepare_mpiio(spin_ncid, "vk_cart_ibz"))
6658 : :
6659 [ + + ]: 319 : do my_ik=1,gqk%my_nk
6660 : : ! The k-point and the symmetries relating the BZ k-point to the IBZ.
6661 [ + + ]: 1244 : kk = gqk%my_kpts(:, my_ik)
6662 : 311 : ik_ibz = gqk%my_k2ibz(1, my_ik) ; isym_k = gqk%my_k2ibz(2, my_ik)
6663 [ + + ]: 1244 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5,my_ik)
6664 [ + + + + : 1149 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
+ + + - ]
6665 : : if (.not. isirr_k) cycle
6666 : :
6667 : : ! parallelize inside (q, pert) so that only one proc in the 3D grid
6668 : : ! computes v_nk for this kpt in the BZ and we can use xmpi_sum_master.
6669 : : !cnt = cnt + 1
6670 : : !if (gqk%qpt_pert_comm%skip(cnt)) cycle
6671 : :
6672 : 36 : npw_k = wfd%npwarr(ik_ibz); istwf_k = wfd%istwfk(ik_ibz)
6673 : 36 : call ddkop%setup_spin_kpoint(gstore%dtset, gstore%cryst, psps, spin, kk, istwf_k, npw_k, wfd%kdata(ik_ibz)%kg_k)
6674 : :
6675 [ + + ]: 150 : do band=gqk%bstart_k, gqk%bstop_k
6676 : 106 : call wfd%copy_cg(band, ik_ibz, spin, cg_work)
6677 : 106 : eig0nk = ebands%eig(band, ik_ibz, spin)
6678 : 106 : in_k = band - gqk%bstart_k + 1
6679 : 106 : vnk_cart_ibz(:, in_k, ik_ibz) = ddkop%get_vdiag(eig0nk, istwf_k, npw_k, wfd%nspinor, cg_work, cwaveprj0)
6680 : 142 : count_bk(in_k, ik_ibz) = count_bk(in_k, ik_ibz) + 1
6681 : : end do
6682 : : end do ! my_ik
6683 : :
6684 : 8 : call xmpi_sum(count_bk, gqk%comm%value, ierr)
6685 : 8 : call xmpi_sum(vnk_cart_ibz, gqk%comm%value, ierr)
6686 : :
6687 [ + + ]: 141 : do ik_ibz=1, gstore%nkibz
6688 [ + + ]: 421 : do band=gqk%bstart_k, gqk%bstop_k
6689 : 280 : in_k = band - gqk%bstart_k + 1
6690 [ + + ]: 280 : if (count_bk(in_k, ik_ibz) == 0) cycle
6691 [ + + ]: 557 : do ii=1,3
6692 : 598 : vnk_cart_ibz(ii,in_k,ik_ibz) = vnk_cart_ibz(ii,in_k,ik_ibz) / count_bk(in_k, ik_ibz)
6693 : : end do
6694 : : end do
6695 : : end do
6696 : :
6697 : : ! Write v_nk to disk.
6698 : : !if (gqk%comm%me == master) then
6699 [ - + ]: 8 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("vk_cart_ibz"), vnk_cart_ibz))
6700 : : !end if
6701 : :
6702 [ - + ]: 8 : ABI_FREE(vnk_cart_ibz)
6703 [ + - - + ]: 16 : ABI_FREE(count_bk)
6704 : : end associate
6705 : : end do ! my_is
6706 : :
6707 [ - + ]: 8 : ABI_FREE(cg_work)
6708 : 8 : call ddkop%free()
6709 : :
6710 : 8 : call pawcprj_free(cwaveprj0)
6711 [ + - - + : 8 : ABI_FREE(cwaveprj0)
- - - - -
+ ]
6712 : :
6713 [ - + + + : 96 : call cwtime_report(sjoin(" Computation of v_k group velocities with with_vk:", itoa(gstore%with_vk)), cpu_kk, wall_kk, gflops_kk)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + + +
- + - + +
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + ]
6714 : :
6715 : : contains
6716 : :
6717 : 8 : integer function spin_vid(var_name)
6718 : : character(len=*),intent(in) :: var_name
6719 : 8 : spin_vid = nctk_idname(spin_ncid, var_name)
6720 : : end function spin_vid
6721 : :
6722 : : end subroutine gstore_compute_and_write_vk
6723 : : !!***
6724 : :
6725 : : !!****f* m_gstore/gstore_compute_and_write_commutator
6726 : : !! NAME
6727 : : !! gstore_compute_and_write_commutator
6728 : : !!
6729 : : !! FUNCTION
6730 : : !! Compute matrix elements i <psi_mk|[V1_q0ka, p]|psi_nk> in the full BZ in reduced coordinates.
6731 : : !! Write results to disk.
6732 : : !! See [[cite:Lihm2020]], PhysRevB.101.121102
6733 : : !!
6734 : : !! SOURCE
6735 : :
6736 : 0 : subroutine gstore_compute_and_write_commutator(gstore, mpw, gmax, ngfft, ngfftf, dtset, cryst, pawfgr, psps, &
6737 : 0 : wfd, mpi_enreg, kg_k, ebands, dvdb, gs_ham_kq, root_ncid)
6738 : :
6739 : : !Arguments ------------------------------------
6740 : : class(gstore_t), intent(in) :: gstore
6741 : : integer,intent(in) :: gmax(3), mpw
6742 : : integer,intent(in) :: ngfft(18),ngfftf(18)
6743 : : type(dvdb_t),intent(inout) :: dvdb
6744 : : type(gs_hamiltonian_type),intent(inout) :: gs_ham_kq
6745 : : type(dataset_type),intent(in) :: dtset
6746 : : type(crystal_t),intent(in) :: cryst
6747 : : type(wfd_t),intent(in) :: wfd
6748 : : type(mpi_type),intent(in) :: mpi_enreg
6749 : : type(ebands_t),intent(in) :: ebands
6750 : : type(pawfgr_type),intent(in) :: pawfgr
6751 : : type(pseudopotential_type),intent(in) :: psps
6752 : : integer,intent(in) :: root_ncid
6753 : : !arrays
6754 : : integer,intent(inout) :: kg_k(3,mpw)
6755 : :
6756 : : !Local variables-------------------------------
6757 : : !scalars
6758 : : integer,parameter :: tim_getgh1c = 1, berryopt0 = 0, master = 0
6759 : : 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,
6760 : : integer :: cplex, db_iqpt, idir, ipert, ipc, my_ip, natom, natom3, n1, n2, n3, n4, n5, n6, nsppol, nspinor, nspden
6761 : : integer :: nfft, nfftf, mgfftf, my_npert, nkpg_k, band_k !, glob_nk mgfft,
6762 : : integer :: sij_opt,usecprj,usevnl,optlocal,optnl,opt_gvnlx1, ncerr, ik_glob, ierr
6763 : : real(dp) :: cpu_kk, wall_kk, gflops_kk
6764 : : logical :: gen_eigenpb
6765 : 0 : type(rf_hamiltonian_type) :: rf_ham_kq
6766 : : !arrays
6767 : : integer :: units(2), work_ngfft(18) ! g0_k(3)
6768 : : !integer,allocatable :: count_bk(:,:)
6769 : : real(dp) :: kk_ibz(3), kk_bz(3), gamma_point(3)
6770 : 0 : real(dp),allocatable :: v1scf(:,:,:,:), work(:,:,:,:), p_kets_k(:,:,:,:), gs1c_kq(:,:), dmat(:,:,:,:)
6771 : 0 : real(dp),allocatable :: kets_k(:,:,:), h1_kets_kq(:,:,:), iv1p_comm(:,:,:,:,:)
6772 : 0 : real(dp),allocatable :: ffnl_k(:,:,:,:), ph3d_k(:,:,:), grad_berry(:,:), kinpw_k(:), kpg_k(:,:)
6773 : 0 : real(dp),allocatable :: vlocal(:,:,:,:), vlocal1(:,:,:,:,:), dummy_vtrial(:,:), gvnlx1(:,:,:), lambda(:)
6774 : 0 : type(pawcprj_type),allocatable :: cwaveprj0(:,:)
6775 : : !----------------------------------------------------------------------
6776 : :
6777 [ # # ]: 0 : units = [std_out, ab_out]
6778 : 0 : call wrtout(units, " Computing and writing i <psi_mk| [V1, p]| psi_nk> ...")
6779 : 0 : call cwtime(cpu_kk, wall_kk, gflops_kk, "start")
6780 : :
6781 : : ! Copy important dimensions
6782 : 0 : natom = cryst%natom; natom3 = 3 * natom; nsppol = ebands%nsppol; nspinor = ebands%nspinor; nspden = dtset%nspden
6783 : :
6784 : 0 : n1 = ngfftf(1); n2 = ngfftf(2); n3 = ngfftf(3); n4 = ngfftf(4); n5 = ngfftf(5); n6 = ngfftf(6)
6785 [ # # ]: 0 : nfftf = product(ngfftf(1:3)); mgfftf = maxval(ngfftf(1:3))
6786 : :
6787 : 0 : call ngfft_seq(work_ngfft, gmax)
6788 [ # # # # : 0 : ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
# # # # #
# # # # #
# # # # #
# ]
6789 : :
6790 : : ! Read the dvscf potentials at qq=Gamma for all 3*natom perturbations.
6791 : : ! This call allocates v1scf(cplex, nfftf, nspden, 3*natom)
6792 : 0 : gamma_point(:) = zero; db_iqpt = dvdb%findq(gamma_point)
6793 : 0 : call dvdb%readsym_allv1(db_iqpt, cplex, nfftf, ngfftf, v1scf, gstore%comm)
6794 [ # # ]: 0 : ABI_CHECK_IEQ(cplex, 1, "cplex should be zero when q == 0")
6795 : :
6796 : : ! Allocate vlocal. Note nvloc
6797 : : ! I set vlocal to huge to trigger possible bugs (DFPT routines should not access the data)
6798 : 0 : usecprj = gstore%dtset%usepaw
6799 [ # # # # : 0 : ABI_MALLOC(vlocal, (n4, n5, n6, gs_ham_kq%nvloc))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
6800 [ # # # # : 0 : vlocal = huge(one)
# # # # ]
6801 [ # # # # : 0 : ABI_CALLOC(dummy_vtrial, (nfftf, nspden))
# # # # #
# # # # #
# # # # #
# ]
6802 [ # # # # : 0 : ABI_MALLOC(cwaveprj0, (gstore%cryst%natom, wfd%nspinor*usecprj))
# # # # #
# # # # #
# # # # #
# # # ]
6803 : :
6804 : : ! Prepare call to getgh1c
6805 : 0 : usevnl = 0
6806 : 0 : optlocal = 1 ! local part of H^(1) is computed in gh1c=<G|H^(1)|C>
6807 : 0 : optnl = 2 ! non-local part of H^(1) is totally computed in gh1c=<G|H^(1)|C>
6808 : 0 : opt_gvnlx1 = 0 ! gvnlx1 is output
6809 : :
6810 [ # # ]: 0 : ABI_MALLOC(grad_berry, (2, nspinor*(berryopt0/4)))
6811 : :
6812 : : ! Since v1(q=0) and p are Hermitian operators, we have:
6813 : : !
6814 : : ! i <psi_mk| [v1, p] |psi_nk> = i <v1 psi_mk | p psi_nk> -i <p psi_mk | v1 psi_nk>
6815 : : !
6816 : : ! Note that in the present implementation both m and n indices run from bstart_k to bstop_k.
6817 : :
6818 : : ! if PAW, one has to solve a generalized eigenproblem
6819 [ # # ]: 0 : gen_eigenpb = psps%usepaw == 1; sij_opt = 0; if (gen_eigenpb) sij_opt = 1
6820 : :
6821 : : ! Define netcdf arrays inside the spin group.
6822 [ # # ]: 0 : do spin=1, nsppol
6823 [ # # ]: 0 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6824 : : ncerr = nctk_def_arrays(spin_ncid, [ &
6825 : : nctkarr_t("iv1p_comm", "dp", "two, nb_k, nb_k, three, natom3, glob_nk") &
6826 [ # # ]: 0 : ], defmode=.True.)
6827 [ # # ]: 0 : NCF_CHECK(ncerr)
6828 : :
6829 [ # # ]: 0 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("iv1p_comm"), NF90_FILL, -huge(one)))
6830 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(spin_ncid))
6831 : : end do
6832 : : !NCF_CHECK(nctk_set_datamode(root_ncid))
6833 : :
6834 [ # # ]: 0 : do my_is=1,gstore%my_nspins
6835 : 0 : associate (gqk => gstore%gqk(my_is))
6836 : 0 : spin = gstore%my_spins(my_is); nb_k = gqk%nb_k; nb_kq = gqk%nb_kq; my_npert = gqk%my_npert
6837 : :
6838 : : ! Be careful as wavefunctions might be replicated.
6839 : : ! Use count_bk to count how many states have been computed in parallel in order to rescale the results.
6840 : : !ABI_ICALLOC(count_bk, (nb_k, gstore%nkibz))
6841 [ # # ]: 0 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6842 [ # # ]: 0 : NCF_CHECK(nctk_prepare_mpiio(spin_ncid, "iv1p_comm"))
6843 : :
6844 : : ! Allocate vlocal1 with correct cplex. Note nvloc and my_npert.
6845 [ # # # # : 0 : ABI_MALLOC(vlocal1, (cplex*n4, n5, n6, gs_ham_kq%nvloc, my_npert))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
6846 [ # # # # : 0 : ABI_MALLOC(lambda, (nb_k))
# # # # #
# # # ]
6847 : :
6848 [ # # # # : 0 : ABI_CALLOC(iv1p_comm, (2, nb_k, nb_k, 3, natom3))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # #
# ]
6849 [ # # # # : 0 : ABI_MALLOC(dmat, (2, nb_k, nb_k, 3))
# # # # #
# # # # #
# # ]
6850 : :
6851 : : ! Set up local potential vlocal1 with proper dimensioning from vtrial1 taking into account the spin.
6852 : : ! Note that here v1scf contains all 3 natom perturbations as we called dvdb%readsym_allv1.
6853 [ # # ]: 0 : do my_ip=1,my_npert
6854 : 0 : idir = dvdb%my_pinfo(1, my_ip); ipert = dvdb%my_pinfo(2, my_ip); ipc = dvdb%my_pinfo(3, my_ip)
6855 : : call rf_transgrid_and_pack(spin, nspden, psps%usepaw, cplex, nfftf, nfft, ngfft, gs_ham_kq%nvloc,&
6856 : 0 : pawfgr, mpi_enreg, dummy_vtrial, v1scf(:,:,:,ipc), vlocal, vlocal1(:,:,:,:,my_ip))
6857 : : end do
6858 : :
6859 : : ! Continue to initialize the GS Hamiltonian
6860 : 0 : call gs_ham_kq%load_spin(spin, vlocal=vlocal, with_nonlocal=.true.)
6861 : :
6862 [ # # ]: 0 : do my_ik=1,gqk%my_nk
6863 : : ! Parallelism inside q-point communicator.
6864 [ # # ]: 0 : if (gqk%qpt_comm%skip(my_ik)) cycle
6865 : :
6866 : : ! The k-point and the symmetries relating the BZ k-point to the IBZ.
6867 [ # # ]: 0 : kk_bz = gqk%my_kpts(:, my_ik)
6868 : 0 : ik_ibz = gqk%my_k2ibz(1, my_ik)
6869 [ # # ]: 0 : kk_ibz = ebands%kptns(:,ik_ibz)
6870 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
6871 : :
6872 : : ! Get npw_k, kg_k and symmetrize wavefunctions from the IBZ (if needed).
6873 : : call wfd%sym_ug_kg_npw(dtset%ecut, kk_bz, kk_ibz, gqk%bstart_k, nb_k, spin, gqk%my_k2ibz(:, my_ik), cryst, &
6874 [ # # ]: 0 : work_ngfft, work, istwf_k, npw_k, kg_k, kets_k)
6875 : :
6876 : : call gs_ham_kq%eph_setup_k("k", kk_bz, istwf_k, npw_k, kg_k, dtset, cryst, psps, & ! in
6877 [ # # # # : 0 : nkpg_k, kpg_k, ffnl_k, kinpw_k, ph3d_k, gqk%pert_comm%value) ! out
# # # # ]
6878 : :
6879 : 0 : npwsp_k = npw_k * nspinor
6880 [ # # # # : 0 : ABI_MALLOC(h1_kets_kq, (2, npwsp_k, nb_k))
# # # # #
# # # # #
# # ]
6881 [ # # # # : 0 : ABI_MALLOC(gs1c_kq, (2, npwsp_k*nb_k*((sij_opt+1)/2)))
# # # # #
# # # ]
6882 [ # # # # : 0 : ABI_MALLOC(gvnlx1, (2, npwsp_k,nb_k))
# # # # #
# # # ]
6883 : :
6884 : : ! Compute <g|-i\Nabla |psi_nk>.
6885 [ # # # # : 0 : ABI_MALLOC(p_kets_k, (2, npwsp_k, nb_k, 3))
# # # # #
# # # # #
# # # # ]
6886 : 0 : call cg_p_psi(npw_k, nspinor, nb_k, kk_bz, kg_k, kets_k, p_kets_k)
6887 : :
6888 [ # # # # : 0 : iv1p_comm = zero
# # # # #
# ]
6889 [ # # ]: 0 : do my_ip=1,my_npert
6890 : 0 : idir = dvdb%my_pinfo(1, my_ip); ipert = dvdb%my_pinfo(2, my_ip); ipc = dvdb%my_pinfo(3, my_ip)
6891 : :
6892 : : ! Prepare application of the NL part.
6893 : 0 : call rf_ham_kq%init(cplex, gs_ham_kq, ipert, has_e1kbsc=.true.)
6894 : 0 : call rf_ham_kq%load_spin(spin, vlocal1=vlocal1(:,:,:,:,my_ip), with_nonlocal=.true.)
6895 : :
6896 [ # # ]: 0 : do in_k=1,nb_k
6897 : : ! Use scissor shift on 0-order eigenvalue
6898 : 0 : band_k = in_k + gqk%bstart_k - 1
6899 : 0 : lambda(in_k) = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
6900 : : end do
6901 : : !call ebands%get_dfpt_eshifted(gqk%bstart_k, nb_k, ik_ibz, spin, dtset%dfpt_sciss, lambda)
6902 : :
6903 : : ! Calculate dvscf * psi_k, results stored in h1_kets_kq on the k+q sphere.
6904 : : ! Compute H(1) applied to GS wavefunction Psi(0).
6905 : : call getgh1c(berryopt0, kets_k, cwaveprj0, h1_kets_kq, &
6906 : : grad_berry, gs1c_kq, gs_ham_kq, gvnlx1, idir, ipert, lambda, mpi_enreg, nb_k, optlocal, &
6907 : 0 : optnl, opt_gvnlx1, rf_ham_kq, sij_opt, tim_getgh1c, usevnl)
6908 : :
6909 : 0 : call rf_ham_kq%free()
6910 : :
6911 : : ! Here we compute: i <u_mk| [v1, p] u_nk> = i <v1 u_mk | p u_nk> -i <p u_mk | v1 u_nk>
6912 : : ! p_kets_k(:, npwsp_k, nb_k, 3)
6913 : : ! h1_kets_kq, (2, npw_k*nspinor, nb_k))
6914 [ # # # # : 0 : dmat = zero
# # # # ]
6915 [ # # ]: 0 : do ii=1,3
6916 : : call ZGEMM('C', 'N', nb_k, nb_k, npwsp_k, j_dpc, h1_kets_kq, npwsp_k, &
6917 : 0 : p_kets_k(:,:,:,ii), npwsp_k, cone, dmat(:,:,:,ii), nb_k)
6918 : :
6919 : : call ZGEMM('C', 'N', nb_k, nb_k, npwsp_k, -j_dpc, p_kets_k(:,:,:,ii), npwsp_k, &
6920 : 0 : h1_kets_kq, npwsp_k, cone, dmat(:,:,:,ii), nb_k)
6921 : : end do
6922 : :
6923 [ # # # # : 0 : iv1p_comm(:,:,:,:,ipc) = dmat
# # # # ]
6924 : : end do ! my_ip
6925 : :
6926 : 0 : call xmpi_sum(iv1p_comm, gqk%pert_comm%value, ierr)
6927 [ # # ]: 0 : if (gqk%pert_comm%me == 0) then
6928 [ # # # # : 0 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("iv1p_comm"), iv1p_comm, start=[1,1,1,1,1,ik_glob]))
# # ]
6929 : : end if
6930 : :
6931 [ # # ]: 0 : ABI_FREE(ffnl_k)
6932 [ # # ]: 0 : ABI_FREE(kinpw_k)
6933 [ # # ]: 0 : ABI_FREE(ph3d_k)
6934 [ # # ]: 0 : ABI_FREE(kpg_k)
6935 [ # # ]: 0 : ABI_FREE(kets_k)
6936 [ # # ]: 0 : ABI_FREE(p_kets_k)
6937 [ # # ]: 0 : ABI_FREE(gs1c_kq)
6938 [ # # ]: 0 : ABI_FREE(h1_kets_kq)
6939 [ # # ]: 0 : ABI_FREE(gvnlx1)
6940 : : end do ! my_ik
6941 : :
6942 [ # # ]: 0 : ABI_FREE(vlocal1)
6943 [ # # ]: 0 : ABI_FREE(lambda)
6944 [ # # ]: 0 : ABI_FREE(dmat)
6945 : :
6946 : : !call xmpi_sum(count_bk, gqk%comm%value, ierr)
6947 : :
6948 : : !do ik_ibz=1, gstore%nkibz
6949 : : ! do band=gqk%bstart_k, gqk%bstop_k
6950 : : ! in_k = band - gqk%bstart_k + 1
6951 : : ! if (count_bk(in_k, ik_ibz) == 0) cycle
6952 : : ! do ii=1,3
6953 : : ! vnk_cart_ibz(ii,in_k,ik_ibz) = vnk_cart_ibz(ii,in_k,ik_ibz) / count_bk(in_k, ik_ibz)
6954 : : ! end do
6955 : : ! end do
6956 : : !end do
6957 : : !ABI_FREE(count_bk)
6958 : :
6959 [ # # ]: 0 : ABI_FREE(iv1p_comm)
6960 : : end associate
6961 : : end do ! my_is
6962 : :
6963 [ # # ]: 0 : ABI_FREE(vlocal)
6964 [ # # ]: 0 : ABI_FREE(dummy_vtrial)
6965 [ # # ]: 0 : ABI_FREE(v1scf)
6966 [ # # ]: 0 : ABI_FREE(work)
6967 [ # # ]: 0 : ABI_FREE(grad_berry)
6968 : :
6969 : 0 : call pawcprj_free(cwaveprj0)
6970 [ # # # # : 0 : ABI_FREE(cwaveprj0)
# # # # #
# ]
6971 : :
6972 : 0 : call xmpi_barrier(gstore%comm)
6973 [ # # # # : 0 : call cwtime_report(" Computation of commutator:", cpu_kk, wall_kk, gflops_kk)
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
6974 : :
6975 : : contains
6976 : :
6977 : 0 : integer function spin_vid(var_name)
6978 : : character(len=*),intent(in) :: var_name
6979 : 0 : spin_vid = nctk_idname(spin_ncid, var_name)
6980 : : end function spin_vid
6981 : :
6982 : : end subroutine gstore_compute_and_write_commutator
6983 : : !!***
6984 : :
6985 : : !!****f* m_gstore/gstore_nc_has_iv1p_comm
6986 : : !! NAME
6987 : : !! gstore_nc_has_iv1p_comm
6988 : : !!
6989 : : !! FUNCTION
6990 : : !! Return True if GSTORE.nc contains commutator matrix elements.
6991 : : !!
6992 : : !! SOURCE
6993 : :
6994 : 24 : logical function gstore_nc_has_iv1p_comm(gstore, root_ncid) result (has_iv1p_comm)
6995 : :
6996 : : !Arguments ------------------------------------
6997 : : class(gstore_t),target, intent(in) :: gstore
6998 : : integer,intent(in) :: root_ncid
6999 : :
7000 : : !Local variables-------------------------------
7001 : : integer :: spin, ncerr, spin_ncid, varid
7002 : : ! *************************************************************************
7003 : :
7004 : 24 : has_iv1p_comm = .True.
7005 [ + - ]: 24 : do spin=1,gstore%nsppol
7006 [ - + ]: 24 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
7007 : 24 : ncerr = nf90_inq_varid(spin_ncid, "iv1p_comm", varid)
7008 [ - + ]: 24 : if (ncerr /= nf90_noerr) then
7009 : : has_iv1p_comm = .False.; exit
7010 : : end if
7011 : : end do
7012 : :
7013 : 24 : end function gstore_nc_has_iv1p_comm
7014 : : !!***
7015 : :
7016 : : !!****f* m_gstore/gstore_read_gtype
7017 : : !! NAME
7018 : : !! gstore_read_gtype
7019 : : !!
7020 : : !! FUNCTION
7021 : : !! Read the value of "gstore_gtype" from the NetCDF file.
7022 : : !! Only the master process reads the value and broadcasts it to all processes in comm.
7023 : : !!
7024 : : !! INPUTS
7025 : : !! ncid: NetCDF file ID (open for reading).
7026 : : !! comm: MPI communicator.
7027 : : !!
7028 : : !! OUTPUTS
7029 : : !! gtype: The value of gstore_gtype read from the file.
7030 : : !!
7031 : : !! SOURCE
7032 : :
7033 : 7 : subroutine gstore_read_gtype(path, gtype, comm, &
7034 [ - + - - : 7 : brange_k_spin, brange_kq_spin) ! optional
- - - + -
- - - ]
7035 : :
7036 : : !Arguments ------------------------------------
7037 : : character(len=*), intent(in) :: path
7038 : : character(len=abi_slen), intent(out) :: gtype
7039 : : integer, intent(in) :: comm
7040 : : integer,optional,intent(out) :: brange_k_spin(:,:)
7041 : : integer,optional,intent(out) :: brange_kq_spin(:,:)
7042 : :
7043 : : !Local variables-------------------------------
7044 : : integer, parameter :: master = 0
7045 : : integer :: my_rank, nproc, ierr, varid, ncerr, ncid
7046 : : ! *************************************************************************
7047 : :
7048 : 7 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
7049 : :
7050 [ + - ]: 7 : if (my_rank == master) then
7051 [ - + ]: 7 : NCF_CHECK(nf90_open(path, nf90_nowrite, ncid))
7052 : 7 : gtype = GSTORE_GTYPE_KS
7053 : 7 : ncerr = nf90_inq_varid(ncid, "gstore_gtype", varid)
7054 [ + - ]: 7 : if (ncerr == nf90_noerr) then
7055 [ - + ]: 7 : NCF_CHECK(nf90_get_var(ncid, varid, gtype))
7056 : 7 : call replace_ch0(gtype)
7057 : : end if
7058 [ - + ]: 7 : if (present(brange_k_spin)) then
7059 [ # # ]: 0 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_k_spin"), brange_k_spin))
7060 : : end if
7061 [ - + ]: 7 : if (present(brange_kq_spin)) then
7062 [ # # ]: 0 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_kq_spin"), brange_kq_spin))
7063 : : end if
7064 [ - + ]: 7 : NCF_CHECK(nf90_close(ncid))
7065 : : end if
7066 : :
7067 [ - + ]: 7 : if (nproc > 1) then
7068 : 0 : call xmpi_bcast(gtype, master, comm, ierr)
7069 [ # # ]: 0 : if (present(brange_k_spin)) call xmpi_bcast(brange_k_spin, master, comm, ierr)
7070 [ # # ]: 0 : if (present(brange_kq_spin)) call xmpi_bcast(brange_kq_spin, master, comm, ierr)
7071 : : end if
7072 : :
7073 : : contains
7074 : :
7075 : 0 : integer function vid(var_name)
7076 : : character(len=*),intent(in) :: var_name
7077 : 0 : vid = nctk_idname(ncid, var_name)
7078 : : end function vid
7079 : :
7080 : : end subroutine gstore_read_gtype
7081 : : !!***
7082 : :
7083 : : !----------------------------------------------------------------------
7084 : :
7085 : : !!****f* m_gstore/gstore_symmetrize
7086 : : !! NAME
7087 : : !! gstore_symmetrize
7088 : : !!
7089 : : !! FUNCTION
7090 : : !! Reconstruct the electron-phonon matrix elements g(k,q) in the full
7091 : : !! Brillouin Zone (BZ) using the values stored in the IBZ for k and the IBZ_k for q.
7092 : : !! Uses the NetCDF API for in-place modification of the GSTORE file
7093 : : !! and wfd_t to fetch wavefunctions and compute unitary matrices.
7094 : : !!
7095 : : !! SOURCE
7096 : :
7097 : 0 : subroutine gstore_symmetrize(gstore_path, wfk_path, ngfft, dtset, dtfil, cryst, psps, pawtab, ebands, ifc, comm)
7098 : :
7099 : : !Arguments ------------------------------------
7100 : : !scalars
7101 : : character(len=*),intent(in) :: gstore_path
7102 : : character(len=*),intent(in) :: wfk_path
7103 : : integer,intent(in) :: ngfft(18)
7104 : : type(dataset_type),intent(in) :: dtset
7105 : : type(datafiles_type),intent(in) :: dtfil
7106 : : class(crystal_t),target,intent(in) :: cryst
7107 : : class(ebands_t),target,intent(in) :: ebands
7108 : : class(ifc_type),target,intent(in) :: ifc
7109 : : type(pseudopotential_type),intent(in) :: psps
7110 : : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
7111 : : integer,intent(in) :: comm
7112 : :
7113 : : !Local variables-------------------------------
7114 : : !scalars
7115 : : integer :: with_cplex, my_is, spin, my_ik, my_iq, ik_glob, iq_glob, units(2)
7116 : : integer :: ncid, spin_ncid, nprocs, my_rank, ncerr, this_state, ierr
7117 : : integer :: nb, nkbz, nkibz, nqbz, nqibz, nsym, itime_k
7118 : : integer :: ik_ibz, isym_k, trev_k, tsign_k, g0_k(3), g0_q(3)
7119 : : integer :: ik_ibz_file, isym_lg, itime_lg, isym_combined, c1_gs, n_gv, igv
7120 : : integer :: n_lg, ii_lg, tsign_lg !, isym_lg, itime_lg,
7121 : : integer :: idir, iat, idir_eq, iat_eq, mu, mu_eq, iq_sym
7122 : : integer :: symrec_eq(3,3), symrec_eq_kspace(3,3), l0(3), mat_tmp(3,3)
7123 : : real(dp) :: weight_qq, phase
7124 : : complex(dp) :: cphase
7125 : : logical :: with_g2dw, isirr_k, found_lg
7126 : : character(len=abi_slen) :: with_gmode, gtype, gvals_name, gv_names(2)
7127 : : character(len=5000) :: msg
7128 [ # # ]: 0 : type(gstore_t) :: gstore
7129 : 0 : type(dmats_t) :: dmats
7130 : : integer :: isym_kqS, isym_kqT, ikq_ibz_s, ikq_ibz_t, h_isym, itime_h, h_isym_inv, trev_kqS, trev_kqT
7131 : : integer :: indkk_s(6,1), indkk_t(6,1)
7132 : : real(dp) :: L_h_gs(3), kq_ibz_pt(3)
7133 : : complex(dp) :: phase_h_gs, phase_ket_gs
7134 : : logical,parameter :: DEBUG_DUMP_DH = .False.
7135 : : real(dp) :: kk_lg_test(3)
7136 : : !!arrays
7137 : 0 : integer :: brange_kq_spin(2, dtset%nsppol)
7138 : 0 : integer,allocatable :: state_kq(:,:), kibz2bz(:) !, qibz2bz(:), qglob2bz(:,:), ! kmesh_map(:,:), my_kqmap(:,:),
7139 : 0 : integer,allocatable :: lg_isym(:), lg_itime(:)
7140 : : real(dp) :: kk_bz(3), kk_ibz(3), qpt(3), qpt_tmp(3), kq_bz_source(3), kq_bz_target(3)
7141 : 0 : real(dp),allocatable :: qbz(:,:)
7142 : 0 : real(dp),contiguous,pointer :: gkq_rot_ptr(:,:,:,:,:), gkq_base_ptr(:,:,:,:,:)
7143 : 0 : complex(dp),target,allocatable :: gkq_rot(:,:,:,:,:), gkq_base(:,:,:,:,:)
7144 : 0 : complex(dp),allocatable :: gtmp(:,:), dh_mat(:,:), ket_mat(:,:)
7145 : : !----------------------------------------------------------------------
7146 : :
7147 : 0 : nprocs = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
7148 : :
7149 [ # # ]: 0 : units = [std_out, ab_out]
7150 : 0 : call wrtout(units, " Entering gstore_symmetrize...")
7151 : 0 : call wrtout(units, sjoin(" GSTORE file: ", gstore_path))
7152 : :
7153 : 0 : call gstore_read_gtype(gstore_path, gtype, comm, brange_kq_spin=brange_kq_spin)
7154 : :
7155 : : ! Compute the D-matrices D_mn(S) = <psi_m,S kq_ibz|S|psi_n,kq_ibz>.
7156 : : ! These are used below (as dh_mat) to correct the extra rotation the bra (electron state
7157 : : ! at k+q) picks up when its own already-computed BZ representative differs from the one
7158 : : ! obtained by applying isym_k directly. dh_mat is applied to the (k+q)/bra band index only
7159 : : ! (gvals' first band dimension, nb_kq) -- never to the k/ket index (nb_k) -- so dmats must be
7160 : : ! built with brange_kq_spin (bstart_kq:bstop_kq), NOT brange_k_spin: the two band windows are
7161 : : ! only required to have the SAME COUNT (gstore%same_nbands, checked below) but may start at a
7162 : : ! different absolute band (bstart_k need not equal bstart_kq, and neither needs to start at 1).
7163 : : ! All MPI ranks participate here since dmats%init distributes the work internally over comm.
7164 : : !
7165 : : ! NOTE: dmats_init also computes genuine (WFK-derived) D-matrices for symmetries S that do
7166 : : ! NOT stabilize a given IBZ k-point (S.k /= k+G), not just little-group elements -- this
7167 : : ! routine (gstore_symmetrize) is UNAFFECTED by that generalization and needs no changes
7168 : : ! because it never reads a non-little-group slot: every dmats%for_spin(...) lookup below
7169 : : ! uses either h_isym/h_isym_inv (searched for specifically as a stabilizer of ikq_ibz_t --
7170 : : ! see "Cannot find little-group element h for the k+q leg" below) or isym_k (drawn directly
7171 : : ! from lg_isym, the explicitly-enumerated little group of kk_ibz in Pass A). Both are
7172 : : ! guaranteed, by construction, to land on the little-group branch of dmats_init, which is
7173 : : ! untouched by the generalization -- confirmed by byte-identical validation numbers on
7174 : : ! diamond/AlAs before and after. See gstore_symmetrize_status memory for the full story.
7175 : 0 : call dmats%init(wfk_path, dtset, cryst, brange_kq_spin, ngfft, pawtab, psps, comm)
7176 : :
7177 : : ! Only master processor performs the symmetrization of the e-ph matrix elements.
7178 : : ! Performance is not crucial and the algorithm is IO-bound.
7179 [ # # ]: 0 : if (my_rank /= 0) goto 100
7180 : :
7181 : : ! GWPT files store two sets of e-ph matrix elements: "gvals" (g^Sigma) and "gvals_ks" (g^KS),
7182 : : ! written at the same (k,q) grid positions (see m_gwpt.F90's dump_my_gbuf). Symmetrize both.
7183 : 0 : n_gv = 1; gv_names(1) = "gvals"
7184 [ # # ]: 0 : if (gtype == GSTORE_GTYPE_GWPT) then
7185 : 0 : n_gv = 2; gv_names(2) = "gvals_ks"
7186 : : end if
7187 : :
7188 : : ! Read GSTORE.nc dimensions and metadata from file, without allocating gvals buffer.
7189 : 0 : with_cplex = 0; with_gmode = GSTORE_GMODE_ATOM; with_g2dw = .False.; gvals_name = "gvals"
7190 : : call gstore%from_ncpath(gstore_path, with_cplex, dtset, dtfil, cryst, ebands, ifc, &
7191 : 0 : with_gmode, gvals_name, with_g2dw, xmpi_comm_self)
7192 : :
7193 : : ! We need the same number of bands for m and n. Also, k and q must be in the BZ without any filter.
7194 [ # # ]: 0 : ABI_CHECK(gstore%same_nbands(msg), msg)
7195 [ # # ]: 0 : if (gstore%check_cplex_qkzone_gmode(2, "bz", "bz", "atom", kfilter="none", check_alloc=.False.) /= 0) then
7196 : 0 : ABI_ERROR("GSTORE.nc should have both k and q in the full BZ. See messages above.")
7197 : : end if
7198 : :
7199 : : ! has_used_lgk is supported via the gstore_sym == 2 "Pass A" reconstruction below.
7200 : : ! has_used_lgq remains unsupported: it is a structurally different restriction
7201 : : ! (k filtered by the little group of q), out of scope for gstore_sym.
7202 [ # # ]: 0 : ABI_CHECK_IEQ(gstore%has_used_lgq, 0, "Symmetrization of g(k,q) with use_lgq /= 0 is not coded")
7203 : :
7204 : : ! Useful dimensions.
7205 : 0 : nkbz = gstore%nkbz; nkibz = gstore%nkibz
7206 : 0 : nqbz = gstore%nqbz; nqibz = gstore%nqibz
7207 : 0 : nsym = cryst%nsym
7208 : :
7209 : : ! Need to know the position of the IBZ k-points in the netcdf array..
7210 [ # # ]: 0 : call get_ibz2bz(gstore%nkibz, gstore%nkbz, gstore%kbz2ibz, kibz2bz, msg, ierr)
7211 [ # # ]: 0 : ABI_CHECK(ierr == 0, sjoin("Something wrong in symmetry tables for k-points", ch10, msg))
7212 : :
7213 [ # # ]: 0 : NCF_CHECK(nctk_open_modify(ncid, gstore_path, xmpi_comm_self))
7214 : :
7215 : : if (DEBUG_DUMP_DH) open(unit=789, file="dh_debug.csv", status="replace", action="write")
7216 : : if (DEBUG_DUMP_DH) open(unit=790, file="dh_mat_full_debug.csv", status="replace", action="write")
7217 : : if (DEBUG_DUMP_DH) open(unit=791, file="gtmp_debug.csv", status="replace", action="write")
7218 : : if (DEBUG_DUMP_DH) open(unit=792, file="mu_debug.csv", status="replace", action="write")
7219 : :
7220 : : ! Loop over collinear spins.
7221 [ # # ]: 0 : do my_is=1,gstore%my_nspins
7222 : 0 : spin = gstore%my_spins(my_is)
7223 : : associate (gqk => gstore%gqk(my_is))
7224 : : ! nb_k == nb_kq is enforced by gstore%same_nbands above, so either count can be used here for
7225 : : ! sizing; the absolute band offsets (bstart_k vs bstart_kq, handled via brange_kq_spin passed
7226 : : ! to dmats%init above) are what actually differ and matter for correctness.
7227 : 0 : nb = gqk%nb_k
7228 : 0 : ABI_CHECK_IEQ(gqk%bstart_kq, brange_kq_spin(1, spin), "gqk%bstart_kq != brange_kq_spin(1, spin)")
7229 [ # # ]: 0 : ABI_CHECK_IEQ(gqk%bstop_kq, brange_kq_spin(2, spin), "gqk%bstop_kq != brange_kq_spin(2, spin)")
7230 : :
7231 : : ! Get the group id for this spin.
7232 [ # # ]: 0 : NCF_CHECK(nf90_inq_ncid(ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
7233 : :
7234 : : ! Read table with status of the (k, q) entry.
7235 [ # # # # : 0 : ABI_MALLOC(state_kq, (gqk%glob_nk, gqk%glob_nq))
# # # # #
# # # # #
# # # # ]
7236 [ # # ]: 0 : ncerr = nf90_get_var(ncid, nctk_idname(ncid, "gstore_glob_state_kqs"), state_kq, start=[1,1,spin])
7237 [ # # ]: 0 : NCF_CHECK(ncerr)
7238 : :
7239 [ # # # # : 0 : ABI_MALLOC(gkq_base, (nb, nb, gqk%natom3, gqk%my_nq, n_gv))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
7240 [ # # # # : 0 : ABI_MALLOC(gkq_rot, (nb, nb, gqk%natom3, gqk%my_nq, n_gv))
# # # # #
# # # # #
# # # # #
# # # #
# ]
7241 [ # # # # : 0 : ABI_MALLOC(gtmp, (nb, nb))
# # # # #
# # # # #
# # # # ]
7242 [ # # # # : 0 : ABI_MALLOC(dh_mat, (nb, nb))
# # # # #
# # # #
# ]
7243 [ # # # # : 0 : ABI_MALLOC(ket_mat, (nb, nb))
# # # # #
# # # #
# ]
7244 : :
7245 : : ! Build q-points in the BZ.
7246 [ # # # # : 0 : ABI_MALLOC(qbz, (3, gqk%my_nq))
# # # # #
# # # ]
7247 [ # # ]: 0 : do my_iq=1, gqk%my_nq
7248 : 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qbz(:,my_iq))
7249 : : end do
7250 : :
7251 : : ! =====================================================================
7252 : : ! Pass A (gstore_sym == 2 only): if gstore_use_lgk restricted the q's
7253 : : ! actually computed directly for k in the IBZ, an IBZ row may have some
7254 : : ! q entries GSTORE_KQ_COMPUTED (q in IBZ_k) and others GSTORE_KQ_MISSING
7255 : : ! (q outside IBZ_k). Fill the MISSING ones here, using ONLY the little
7256 : : ! group of kk_ibz itself (k never moves in this pass -- the degenerate
7257 : : ! case of the k-star formula below, kk_bz := kk_ibz). Once every IBZ row
7258 : : ! is fully populated, the k-star loop below runs completely unchanged
7259 : : ! for the non-IBZ rows, exactly as it always has when gstore_use_lgk == 0.
7260 : : ! =====================================================================
7261 [ # # ]: 0 : if (dtset%gstore_sym == 2) then
7262 [ # # ]: 0 : do ik_ibz=1,nkibz
7263 : 0 : ik_glob = kibz2bz(ik_ibz)
7264 [ # # # # : 0 : if (all(state_kq(ik_glob, :) /= GSTORE_KQ_MISSING)) cycle
# # ]
7265 : :
7266 [ # # ]: 0 : kk_ibz = ebands%kptns(:, ik_ibz)
7267 : 0 : ik_ibz_file = ik_glob
7268 : 0 : kk_bz = kk_ibz ! degenerate case: k never moves in Pass A
7269 : :
7270 : : ! Enumerate the little group of kk_ibz once per row: symrel^T membership
7271 : : ! test, mirroring dmats_get_star_dmats (m_classify_bands.F90:2048-2061).
7272 : : ! Deliberately NOT lgroup_t/littlegroup_q here: those use the symrec
7273 : : ! convention, which can disagree with the symrel^T convention used
7274 : : ! throughout dmats/gstore_symmetrize for non-orthogonal symrel.
7275 [ # # # # : 0 : ABI_MALLOC(lg_isym, (2*nsym))
# # # # #
# # # #
# ]
7276 [ # # # # : 0 : ABI_MALLOC(lg_itime, (2*nsym))
# # # # ]
7277 : 0 : n_lg = 0
7278 [ # # ]: 0 : do itime_lg=1,2
7279 [ # # ]: 0 : do isym_lg=1,nsym
7280 [ # # ]: 0 : tsign_lg = 1; if (itime_lg == 2) tsign_lg = -1
7281 [ # # # # : 0 : kk_lg_test = tsign_lg * matmul(transpose(cryst%symrel(:,:,isym_lg)), kk_ibz)
# # # # #
# # # ]
7282 [ # # ]: 0 : if (isamek(kk_ibz, kk_lg_test, g0_q)) then
7283 : 0 : n_lg = n_lg + 1
7284 : 0 : lg_isym(n_lg) = isym_lg; lg_itime(n_lg) = itime_lg
7285 : : end if
7286 : : end do
7287 : : end do
7288 [ # # ]: 0 : ABI_CHECK(n_lg > 0, "Little group of kk_ibz is empty (should at least contain the identity)")
7289 : :
7290 : : ! Read g(k_ibz, q) for all q already available (same read pattern as below).
7291 [ # # ]: 0 : do igv=1,n_gv
7292 [ # # ]: 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])
7293 : : ncerr = nf90_get_var(spin_ncid, spin_vid(gv_names(igv)), gkq_base_ptr, &
7294 : : start=[1, 1, 1, 1, ik_ibz_file, 1], &
7295 [ # # # # ]: 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7296 [ # # ]: 0 : NCF_CHECK(ncerr)
7297 : : end do
7298 : :
7299 [ # # ]: 0 : do my_iq=1, gqk%my_nq
7300 : 0 : iq_glob = my_iq + gqk%my_qstart - 1
7301 : :
7302 [ # # ]: 0 : if (state_kq(ik_glob, iq_glob) /= GSTORE_KQ_MISSING) then
7303 : : ! Already GSTORE_KQ_COMPUTED (q in IBZ_k): keep the on-disk value unchanged.
7304 [ # # # # : 0 : gkq_rot(:,:,:,iq_glob,:) = gkq_base(:,:,:,iq_glob,:)
# # # # ]
7305 : 0 : cycle
7306 : : end if
7307 : :
7308 [ # # ]: 0 : qpt = qbz(:, my_iq)
7309 : :
7310 : : ! Search the little group x the row's own COMPUTED q entries for a source match.
7311 : : found_lg = .False.
7312 [ # # ]: 0 : do ii_lg=1,n_lg
7313 : 0 : isym_k = lg_isym(ii_lg); trev_k = lg_itime(ii_lg) - 1
7314 [ # # ]: 0 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
7315 [ # # # # ]: 0 : symrec_eq = transpose(cryst%symrel(:,:,isym_k))
7316 [ # # # # ]: 0 : symrec_eq_kspace = tsign_k * symrec_eq
7317 [ # # ]: 0 : do iq_sym=1, gqk%my_nq
7318 [ # # ]: 0 : if (state_kq(ik_glob, iq_sym + gqk%my_qstart - 1) /= GSTORE_KQ_COMPUTED) cycle
7319 [ # # # # : 0 : qpt_tmp = matmul(symrec_eq_kspace, qbz(:, iq_sym))
# # # # ]
7320 [ # # ]: 0 : if (isamek(qpt, qpt_tmp, g0_q)) then
7321 : 0 : found_lg = .True.; exit
7322 : : end if
7323 : : end do
7324 : 0 : if (found_lg) exit
7325 : : end do
7326 : :
7327 : : msg = sjoin("Pass A: no little-group image of q found among GSTORE_KQ_COMPUTED", &
7328 [ # # ]: 0 : " entries for ik_ibz=", itoa(ik_ibz), " -- IBZ_k does not cover this q's star")
7329 [ # # ]: 0 : ABI_CHECK(found_lg, msg)
7330 : :
7331 [ # # ]: 0 : do isym_combined=1,nsym
7332 [ # # # # : 0 : if (all(cryst%symrec(:,:,isym_combined) == symrec_eq)) exit
# # # # ]
7333 : : end do
7334 [ # # ]: 0 : ABI_CHECK(isym_combined /= nsym + 1, "Cannot find symrec_eq")
7335 : :
7336 : : ! Note on non-uniqueness of (isym_k, iq_sym): when kk_ibz has a non-trivial little group
7337 : : ! (the typical case, not a rare corner case -- measured on the reference test systems
7338 : : ! below, EVERY Pass-A point in diamond and most in AlAs have more than one valid
7339 : : ! candidate, up to ~96 at Gamma), the found_lg search above can match several different
7340 : : ! (isym,itime,iq_sym) triples for the same target q; "first found" is taken arbitrarily.
7341 : : ! Verified this does NOT introduce a gauge/correctness bug: a dedicated diagnostic
7342 : : ! (temporarily instrumented, then removed) recomputed the full reconstruction using EVERY
7343 : : ! valid candidate for a set of known-redundant points on both diamond (4 points, 2-4
7344 : : ! candidates each) and AlAs (2 points), and all candidates agreed with each other to
7345 : : ! numerical noise (~1e-7 to 1e-10) in every case -- i.e. the formula is empirically
7346 : : ! gauge-invariant to this choice, the same way the bra leg's h_isym/phase_h_gs/L_h_gs
7347 : : ! machinery is already known (and was originally designed) to be invariant to which
7348 : : ! (isym_kqS,isym_kqT) kpts_map happens to return. See gstore_symmetrize_status memory for
7349 : : ! the full data. Contrast with dmats_get_star_dmats_at_kpt (m_classify_bands.F90), a
7350 : : ! DIAGNOSTIC-only routine with a structurally identical first-match-wins search that its
7351 : : ! own authors flag as an unverified risk -- that routine has NOT been checked this way and
7352 : : ! is a separate, lower-priority open item (never reached by production gstore_symmetrize).
7353 : :
7354 : : ! -----------------------------------------------------------------
7355 : : ! From here on, reused VERBATIM from the k-star loop below (Bug A /
7356 : : ! h_isym / phase_h_gs / phase_ket_gs / itime_h / dh_mat / mu-rotation
7357 : : ! -- kk_bz == kk_ibz here, the degenerate case, so the formula
7358 : : ! derived for the general k-star case applies unchanged). See the
7359 : : ! k-star loop's own comments for the full derivation.
7360 [ # # ]: 0 : kq_bz_source = kk_ibz + qbz(:, iq_sym)
7361 [ # # ]: 0 : kq_bz_target = kk_bz + qpt
7362 : 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_source, indkk_s)
7363 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (source)")
7364 : 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_target, indkk_t)
7365 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (target)")
7366 : 0 : ikq_ibz_s = indkk_s(1,1); isym_kqS = indkk_s(2,1)
7367 : 0 : ikq_ibz_t = indkk_t(1,1); isym_kqT = indkk_t(2,1)
7368 : 0 : trev_kqS = indkk_s(6,1); trev_kqT = indkk_t(6,1)
7369 [ # # ]: 0 : ABI_CHECK(ikq_ibz_s == ikq_ibz_t, "Source and target k+q map to different IBZ points!")
7370 : :
7371 [ # # ]: 0 : mat_tmp = matmul(transpose(cryst%symrel(:,:,dmats%toinv(1,isym_kqT))), &
7372 [ # # # # : 0 : matmul(symrec_eq, transpose(cryst%symrel(:,:,isym_kqS))))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
7373 [ # # ]: 0 : do h_isym=1,nsym
7374 [ # # # # : 0 : if (all(transpose(cryst%symrel(:,:,h_isym)) == mat_tmp)) exit
# # # # ]
7375 : : end do
7376 [ # # ]: 0 : ABI_CHECK(h_isym /= nsym + 1, "Cannot find little-group element h for the k+q leg")
7377 : :
7378 : 0 : c1_gs = dmats%multable(1, isym_kqS, isym_k)
7379 : : L_h_gs = real(dmats%multable(2:4, isym_kqS, isym_k), dp) &
7380 : : + real(dmats%multable(2:4, c1_gs, dmats%toinv(1,isym_kqT)), dp) &
7381 [ # # # # : 0 : - matmul(real(cryst%symrel(:,:,h_isym), dp), real(dmats%toinv(2:4,isym_kqT), dp))
# # # # #
# # # #
# ]
7382 [ # # ]: 0 : kq_ibz_pt = ebands%kptns(:, ikq_ibz_t)
7383 [ # # ]: 0 : phase_h_gs = exp(cmplx(zero, two_pi * sum(kq_ibz_pt * L_h_gs), dp))
7384 : :
7385 : : ! Pass-A-only companion to phase_ket_gs. The k-star formula below (kk_bz generally
7386 : : ! != kk_ibz) was validated to 100% exact match WITHOUT this extra term. In Pass A,
7387 : : ! kk_bz == kk_ibz identically (the degenerate case), and an extra residual survived
7388 : : ! even after the ket_mat fix: isolated (h_isym==1, scalar-only residual, i.e. exactly
7389 : : ! reproducible by a single global phase -- see gstore_symmetrize_status memory) to be
7390 : : ! a clean function of isym_k and kk_ibz alone: exp(-i*2pi*kk_ibz.w(isym_k)) for an
7391 : : ! integer vector w. Empirically fit w(isym_k) exactly (32/32 points, zero exceptions,
7392 : : ! all 3 distinct ik_ibz/isym_k combinations in the reference test) to
7393 : : ! toinv(2:4,isym_k) -- the SAME single-inverse convention used for L_h_gs's own
7394 : : ! toinv(1,isym_kqT) term, and notably NOT the double-inverse toinv(2:4,toinv(1,isym_k))
7395 : : ! used by the qpt term just above. Plausible reading: the qpt-term's
7396 : : ! toinv(2:4,toinv(1,isym_k)) is the companion to kk_bz = symrec_eq.kk_ibz (the k-star's
7397 : : ! moved k), which in Pass A degenerates to kk_ibz itself, making this term newly
7398 : : ! separate and nonzero instead of staying absorbed into the k-star's single term.
7399 : : phase_ket_gs = exp(cmplx(zero, -two_pi * sum(qpt * real(dmats%toinv(2:4, dmats%toinv(1,isym_k)), dp)), dp)) &
7400 [ # # # # ]: 0 : * exp(cmplx(zero, -two_pi * sum(kk_ibz * real(dmats%toinv(2:4, isym_k), dp)), dp))
7401 : :
7402 : 0 : itime_h = 1 + mod(trev_k + trev_kqS + trev_kqT, 2)
7403 : :
7404 : 0 : h_isym_inv = dmats%toinv(1, h_isym)
7405 [ # # ]: 0 : if (itime_h == 2) then
7406 [ # # # # : 0 : dh_mat = conjg(phase_h_gs) * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
# # # # #
# # # ]
7407 : : else
7408 [ # # # # : 0 : dh_mat = phase_h_gs * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
# # # # #
# # # ]
7409 : : end if
7410 : :
7411 [ # # # # : 0 : if (trev_kqT == 1) dh_mat = conjg(dh_mat)
# # ]
7412 : :
7413 : : ! Ket-leg correction (Pass A only -- k-star never needs this, see below). Unlike k-star
7414 : : ! reconstruction, whose ket is always *derived* via cgtk_rotate from the IBZ wavefunction
7415 : : ! (so ground truth and reconstruction structurally share the same gauge for any degenerate
7416 : : ! ket subspace), Pass A's ket lives AT kk_ibz itself and is read directly from the WFK for
7417 : : ! every q processed there. Ground truth's own independent direct e-ph calculations at
7418 : : ! different q (same k) do not share a common internal gauge for a degenerate ket subspace.
7419 : : ! isym_k stabilizes kk_ibz (drawn from its own little group, by construction), so
7420 : : ! dmats%for_spin(...)(isym_k,...) is a genuine, tabulated (non-placeholder) D-matrix here
7421 : : ! -- unlike the general k-star case, where isym_k need not stabilize anything.
7422 : : !
7423 : : ! Convention: read dmats%for_spin(...)(isym_k,...) DIRECTLY, not the toinv(1,isym_k) slot.
7424 : : ! isym_k here is found purely via the symrel^T convention (little-group membership test),
7425 : : ! and dmats's own array is indexed the same way (symrel^T, per dmats_init's own little-group
7426 : : ! check), so isym_k already names the exact tabulated operation that rotates the ket -- no
7427 : : ! inversion is needed or correct. (Contrast with the BRA correction above, dh_mat: h_isym
7428 : : ! there is defined as a genuine COMPOSITE/residual little-group element of kq_ibz whose
7429 : : ! natural tabulated slot -- per dmats_init's own toinv/multable bookkeeping around
7430 : : ! cgtk_rotate's isym_inv=toinv(isym) workaround -- is toinv(1,h_isym), not h_isym itself;
7431 : : ! that is a property of how h_isym's OWN definition composes with dmats_init's internal
7432 : : ! convention, not a general rule that every dmats lookup needs a toinv step.) The original
7433 : : ! implementation used toinv(1,isym_k) "by analogy" with dh_mat and was validated only on an
7434 : : ! involutory isym_k (toinv(1,isym_k)==isym_k), which cannot distinguish the two conventions.
7435 : : ! Diagnosed by finding a 100%/0% clean split: EVERY point with non-involutory isym_k was
7436 : : ! wrong (needing a genuine unitary matrix fix, not a scalar) while every involutory-isym_k
7437 : : ! point was already exact -- direct, decisive evidence the toinv(1,.) step was the bug.
7438 : 0 : itime_k = trev_k + 1
7439 [ # # # # : 0 : ket_mat = dmats%for_spin(spin)%value(:,:,isym_k,itime_k,ik_ibz)
# # # # #
# # # ]
7440 [ # # # # : 0 : if (trev_k == 1) ket_mat = conjg(ket_mat)
# # ]
7441 : : ! -----------------------------------------------------------------
7442 : :
7443 : : ! Perform symmetrization.
7444 [ # # ]: 0 : do mu=1,gqk%natom3
7445 : 0 : idir = mod(mu-1, 3) + 1; iat = (mu - idir) / 3 + 1
7446 : :
7447 : 0 : iat_eq = cryst%indsym(4, isym_combined, iat)
7448 [ # # ]: 0 : l0 = cryst%indsym(1:3, isym_combined, iat)
7449 [ # # ]: 0 : phase = -two_pi * dot_product(qbz(:, iq_sym), l0)
7450 : 0 : cphase = cmplx(cos(phase), sin(phase), dp)
7451 : :
7452 [ # # ]: 0 : do igv=1,n_gv
7453 [ # # # # ]: 0 : gtmp = zero
7454 [ # # ]: 0 : do idir_eq=1,3
7455 : 0 : mu_eq = idir_eq + (iat_eq - 1) * 3
7456 [ # # # # : 0 : gtmp = gtmp + cphase * symrec_eq(idir, idir_eq) * gkq_base(:,:,mu_eq,iq_sym,igv)
# # ]
7457 : : end do
7458 [ # # # # : 0 : if (trev_k == 1) gtmp = conjg(gtmp)
# # ]
7459 [ # # # # : 0 : gkq_rot(:,:,mu,iq_glob,igv) = matmul(matmul(dh_mat, gtmp), ket_mat)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
7460 : : end do
7461 : : end do
7462 : :
7463 : : end do ! my_iq
7464 : :
7465 : : ! Write the newly reconstructed + copied-through rows back to the netcdf file.
7466 [ # # ]: 0 : do igv=1,n_gv
7467 [ # # ]: 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])
7468 : : ncerr = nf90_put_var(spin_ncid, spin_vid(gv_names(igv)), gkq_rot_ptr, &
7469 : : start=[1, 1, 1, 1, ik_glob, 1], &
7470 [ # # # # ]: 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7471 [ # # ]: 0 : NCF_CHECK(ncerr)
7472 : : end do
7473 [ # # # # ]: 0 : where (state_kq(ik_glob, :) == GSTORE_KQ_MISSING) state_kq(ik_glob, :) = GSTORE_KQ_SYMMETRIZED
7474 : :
7475 [ # # ]: 0 : ABI_FREE(lg_isym)
7476 [ # # ]: 0 : ABI_FREE(lg_itime)
7477 : : end do ! ik_ibz
7478 : : end if ! gstore_sym == 2
7479 : :
7480 [ # # ]: 0 : NCF_CHECK(nf90_sync(spin_ncid))
7481 : :
7482 : : ! Loop over k-points in the IBZ.
7483 [ # # # # ]: 0 : do my_ik=1,gqk%my_nk
7484 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
7485 [ # # ]: 0 : kk_bz = gqk%my_kpts(:, my_ik)
7486 : :
7487 [ # # ]: 0 : if (state_kq(ik_glob, 1) /= GSTORE_KQ_MISSING) then
7488 : : ! Row already fully resolved: either directly COMPUTED (gstore_use_lgk == 0), or
7489 : : ! filled by Pass A above (gstore_sym == 2, mix of COMPUTED and SYMMETRIZED).
7490 [ # # # # : 0 : ABI_CHECK(all(state_kq(ik_glob, :) /= GSTORE_KQ_MISSING), "all state")
# # ]
7491 : 0 : cycle
7492 : : end if
7493 : :
7494 : : ! Symmetry tables for k-point. Using symrel^T convention for k..
7495 : 0 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
7496 : 0 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5, my_ik)
7497 : : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
7498 [ # # ]: 0 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
7499 : 0 : itime_k = trev_k + 1
7500 [ # # ]: 0 : kk_ibz = ebands%kptns(:,ik_ibz)
7501 : :
7502 : : ! Index of the IBZ k-point on disk.
7503 : 0 : ik_ibz_file = kibz2bz(ik_ibz)
7504 : :
7505 : : ! symrec_eq is the SPATIAL rotation (used for atomic-perturbation-direction
7506 : : ! bookkeeping below, which is TR-blind: time reversal does not move atoms.
7507 : : ! symrec_eq_kspace additionally carries the TR sign and is the one that actually relates k-space
7508 : : ! vectors (kk_bz, q) to their IBZ images
7509 [ # # # # ]: 0 : symrec_eq = transpose(cryst%symrel(:,:,isym_k))
7510 [ # # # # ]: 0 : symrec_eq_kspace = tsign_k * symrec_eq
7511 [ # # # # : 0 : ABI_CHECK(isamek(kk_bz, matmul(symrec_eq_kspace, kk_ibz), g0_q), "kk_bz != symrec_eq_kspace kk_ibz")
# # # # #
# ]
7512 : :
7513 [ # # ]: 0 : do isym_combined=1,nsym
7514 [ # # # # : 0 : if (all(cryst%symrec(:,:,isym_combined) == symrec_eq)) exit
# # # # ]
7515 : : end do
7516 [ # # ]: 0 : ABI_CHECK(isym_combined /= nsym + 1, "Cannot find symrec_eq")
7517 : :
7518 : : ! Read g(k_ibz, q) for all q-point in the BZ, for each gvals stream ("gvals", and "gvals_ks" too when gtype == "gwpt").
7519 [ # # ]: 0 : do igv=1,n_gv
7520 [ # # ]: 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])
7521 : : ncerr = nf90_get_var(spin_ncid, spin_vid(gv_names(igv)), gkq_base_ptr, &
7522 : : start=[1, 1, 1, 1, ik_ibz_file, 1], &
7523 [ # # # # ]: 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7524 [ # # ]: 0 : NCF_CHECK(ncerr)
7525 : : end do
7526 : :
7527 : : ! Loop over q-points in the BZ.
7528 [ # # ]: 0 : do my_iq=1, gqk%my_nq
7529 : 0 : iq_glob = my_iq + gqk%my_qstart - 1
7530 : 0 : this_state = state_kq(ik_glob, iq_glob)
7531 [ # # ]: 0 : if (this_state /= GSTORE_KQ_MISSING) cycle
7532 : :
7533 : : ! Symmetry tables for q-point. NB: Using symrec convention for q.
7534 : : !iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
7535 : : !trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5, my_iq)
7536 : : !isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
7537 : : !tsign_q = 1; if (trev_q == 1) tsign_q = -1
7538 : : !qq_ibz = gstore%qibz(:, iq_ibz)
7539 [ # # ]: 0 : qpt = qbz(:, my_iq)
7540 : :
7541 : : ! Find q. Uses symrec_eq_kspace (not symrec_eq): q, like k, is a genuine k-space vector
7542 : : ! that picks up the TR sign under the same combined operation mapping kk_ibz -> kk_bz.
7543 [ # # ]: 0 : do iq_sym=1, gqk%my_nq
7544 : : ! qpt = qpt_tmp + G0_q
7545 [ # # # # : 0 : qpt_tmp = matmul(symrec_eq_kspace, qbz(:, iq_sym)); if (isamek(qpt, qpt_tmp, g0_q)) exit
# # # # #
# ]
7546 : : end do
7547 [ # # ]: 0 : ABI_CHECK(iq_sym /= gqk%my_nq + 1, sjoin("Cannot find:", ktoa(qpt)))
7548 : :
7549 : : ! -----------------------------------------------------------------
7550 : : ! Bug A fix: the bra (electron state at k+q) reaches its target BZ
7551 : : ! point via two composed rotations (isym_k applied to the SOURCE
7552 : : ! bra's own rotation from kq_ibz), while the "true" bra is obtained
7553 : : ! by a single direct rotation from kq_ibz. The two differ by U(h),
7554 : : ! h being the residual element of the little group (stabilizer) of
7555 : : ! kq_ibz. h always stabilizes kq_ibz by construction (never an
7556 : : ! out-of-domain little-group lookup), so the D-matrices already
7557 : : ! tabulated by dmats are valid here. See gstore_symmetrize_status
7558 : : ! memory (session 10) for the full derivation.
7559 [ # # ]: 0 : kq_bz_source = kk_ibz + qbz(:, iq_sym)
7560 [ # # ]: 0 : kq_bz_target = kk_bz + qpt
7561 : 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_source, indkk_s)
7562 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (source)")
7563 : 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_target, indkk_t)
7564 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (target)")
7565 : 0 : ikq_ibz_s = indkk_s(1,1); isym_kqS = indkk_s(2,1)
7566 : 0 : ikq_ibz_t = indkk_t(1,1); isym_kqT = indkk_t(2,1)
7567 : 0 : trev_kqS = indkk_s(6,1); trev_kqT = indkk_t(6,1)
7568 [ # # ]: 0 : ABI_CHECK(ikq_ibz_s == ikq_ibz_t, "Source and target k+q map to different IBZ points!")
7569 : :
7570 : : ! mat_tmp = Srel(toinv(isym_kqT)) . Srel(isym_k) . Srel(isym_kqS), with Srel(S) := symrel(S)^T
7571 : : ! (same k/kq convention as symrec_eq above, i.e. NOT cryst%symrec). h_isym is the isym s.t.
7572 : : ! Srel(h_isym) == mat_tmp.
7573 [ # # ]: 0 : mat_tmp = matmul(transpose(cryst%symrel(:,:,dmats%toinv(1,isym_kqT))), &
7574 [ # # # # : 0 : matmul(symrec_eq, transpose(cryst%symrel(:,:,isym_kqS))))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
7575 [ # # ]: 0 : do h_isym=1,nsym
7576 [ # # # # : 0 : if (all(transpose(cryst%symrel(:,:,h_isym)) == mat_tmp)) exit
# # # # ]
7577 : : end do
7578 [ # # ]: 0 : ABI_CHECK(h_isym /= nsym + 1, "Cannot find little-group element h for the k+q leg")
7579 : :
7580 : : ! Lattice-vector-phase companion to h_isym (bra leg). The rotation-only h_isym search above
7581 : : ! finds the correct isym s.t. Srel(h_isym) matches the literal 3-way rotation product, but
7582 : : ! (analogous to dmats_get_star_dmats's validated S0.g.S0^{-1} + L_h construction) the literal
7583 : : ! Seitz composition Tab(isym_kqS).Tab(isym_k).Tab(isym_kqT)^{-1} generally differs from
7584 : : ! Tab(h_isym) by a residual lattice vector L_h_gs whenever any of isym_kqS/isym_k/isym_kqT is
7585 : : ! non-symmorphic, even when h_isym is the identity rotation. Derived by substituting
7586 : : ! Tab(c1)=T_{-L1}.Tab(isym_kqS).Tab(isym_k) [c1=multable(1,isym_kqS,isym_k), the SAME rotation
7587 : : ! recipe already validated for h_isym itself] into Tab(c1).Tab(toinv(isym_kqT))=T_{L2}.Tab(h_isym),
7588 : : ! then Tab(toinv(isym_kqT)) = Tab(isym_kqT)^{-1}.T_{L0} (L0=toinv(2:4,isym_kqT)), and pushing
7589 : : ! T_{-L0} through Tab(h_isym) (Tab(h).T_v = T_{R(h).v}.Tab(h)). Verified EXACTLY (3000/3000
7590 : : ! random (isym_k,isym_kqS,isym_kqT) triples, zero umklapp) against the literal 3-operator
7591 : : ! Seitz composition computed independently with the EXACT (non-tabulated) group inverse. The
7592 : : ! overall sign was pinned down against a hand-verified counterexample (h_isym=1, needing a
7593 : : ! missing factor of exactly +i).
7594 : 0 : c1_gs = dmats%multable(1, isym_kqS, isym_k)
7595 : : L_h_gs = real(dmats%multable(2:4, isym_kqS, isym_k), dp) &
7596 : : + real(dmats%multable(2:4, c1_gs, dmats%toinv(1,isym_kqT)), dp) &
7597 [ # # # # : 0 : - matmul(real(cryst%symrel(:,:,h_isym), dp), real(dmats%toinv(2:4,isym_kqT), dp))
# # # # #
# # # #
# ]
7598 [ # # ]: 0 : kq_ibz_pt = ebands%kptns(:, ikq_ibz_t)
7599 [ # # ]: 0 : phase_h_gs = exp(cmplx(zero, two_pi * sum(kq_ibz_pt * L_h_gs), dp))
7600 : :
7601 : : ! Companion phase on the KET leg. Even with phase_h_gs above, a residual remained, isolated
7602 : : ! (via h_isym==1 points, where dh_mat=I so phase_h_gs is the only other active correction) to
7603 : : ! be a clean function of isym_k and the TARGET q alone: exp(-i*2pi*qpt.v(isym_k)) for an
7604 : : ! integer vector v. Empirically fit v(isym_k) exactly (100% across all isym_k appearing in
7605 : : ! the reference test, zero exceptions) to toinv(2:4, toinv(1,isym_k)) -- i.e. the
7606 : : ! lattice-vector residual of composing isym_k with its OWN inverse in the OTHER order from
7607 : : ! toinv's own convention (toinv(2:4,isym_k) is for S(isym_k).S(isym_k^{-1}); this needs
7608 : : ! S(isym_k^{-1}).S(isym_k) instead, which only coincides with the former when isym_k is
7609 : : ! self-inverse -- the same class of composition-order mixup fixed in dmats_check_one_k and in
7610 : : ! deriving L_h_gs above). Physical origin not fully pinned down: isym_k plays a role in BOTH
7611 : : ! the ket rotation (kk_bz = symrec_eq.kk_ibz) AND the atomic-perturbation-direction rotation
7612 : : ! via the SAME symrec_eq in the mu-loop below (whose existing cphase/l0 term is dotted with
7613 : : ! the SOURCE q, not the target) -- plausibly this is the missing lattice-vector companion to
7614 : : ! THAT term, evaluated at the target q instead, but this is a plausible reading of the
7615 : : ! empirical formula, not an independently re-derived physical proof (unlike L_h_gs above,
7616 : : ! which was verified against the literal Seitz composition directly). Trust the formula
7617 : : ! (exhaustively validated below); treat the physical narrative as informed conjecture only.
7618 : : !
7619 : : ! Effect of phase_h_gs+phase_ket_gs alone on the gstore_brange 1 4 reference test: raw
7620 : : ! exact-match rate 60.4% -> 91.7%, gauge-invariant unchanged at 100%. NOTE: the remaining 8.3%
7621 : : ! was INITIALLY (wrongly) attributed entirely to expected degenerate-band gauge freedom per
7622 : : ! AGENTS.md -- this was corrected later (see the THIRD correction right below): a Procrustes
7623 : : ! best-fit-unitary check proved EXACT reconstruction is achievable for within-range-degenerate
7624 : : ! bra multiplets, so that mismatch was a real, fixable bug, not gauge freedom. Do not repeat
7625 : : ! that mistake: eigenvalue-degeneracy alone never proves a mismatch is harmless -- check
7626 : : ! whether a single matrix can exactly relate reconstruction to truth first.
7627 [ # # ]: 0 : phase_ket_gs = exp(cmplx(zero, -two_pi * sum(qpt * real(dmats%toinv(2:4, dmats%toinv(1,isym_k)), dp)), dp))
7628 : :
7629 : : ! THIRD correction: dmats%for_spin(h_isym) is the WRONG tabulated matrix for the bra whenever
7630 : : ! h_isym is a non-self-inverse symmetry. Root cause: dmats_init computes D(isym) by calling
7631 : : ! cgtk_rotate with isym_inv=toinv(isym) and a separately-recomputed umklapp g0_inv (a
7632 : : ! documented workaround for cgtk_rotate silently returning D_true(S)^{-1} for non-involutions).
7633 : : ! D(h) and D(toinv(h)) are unitary inverses of each other only up to an EXTRA phase that
7634 : : ! dmats_init's own toinv/multable bookkeeping already knows about (this is exactly what
7635 : : ! dmats_check_one_k's "inv_phase"/"phase_analytic" diagnostic measures and validates) --
7636 : : ! reconstructing D(toinv(h)) from D(h) via a bare conjugate-transpose silently drops that
7637 : : ! phase. Looking up dmats%for_spin(toinv(h_isym)) directly sidesteps this entirely, since
7638 : : ! dmats_init already computed that matrix independently and self-consistently under its own
7639 : : ! label: there is nothing to reconstruct.
7640 : : !
7641 : : ! Earlier sessions gated this substitution behind an empirical "is a correction needed at
7642 : : ! all" heuristic (g0-mismatch OR non-self-inverse-and-degenerate-bra), applying toinv(h_isym)
7643 : : ! only when it fired and h_isym unmodified otherwise. That heuristic is UNNECESSARY: applying
7644 : : ! dmats%for_spin(toinv(h_isym)) unconditionally (i.e. always, regardless of degeneracy or g0)
7645 : : ! reproduces the exact same result on every point where the heuristic previously used
7646 : : ! h_isym directly -- because on the reference test system, no such point exists: every
7647 : : ! non-self-inverse h_isym already satisfied the heuristic's trigger condition. (For
7648 : : ! self-inverse h_isym, toinv(1,h_isym)==h_isym, so the two forms are trivially identical
7649 : : ! regardless.) Verified end-to-end against check_symm.py: byte-for-byte identical results to
7650 : : ! the old conditional form -- 3584/3584 (100.0%) raw+gauge-invariant exact matches on
7651 : : ! gstore_brange 1 4 (max diff 3.66e-7, noise level), 3533/3584 (98.6%) raw==gauge-invariant on
7652 : : ! gstore_brange 1 2 (the residual there is the known, inherent out-of-range-degeneracy
7653 : : ! limitation of truncating the band range, not a bug). See gstore_symmetrize_status memory
7654 : : ! (sessions 14-15) for the full derivation history and this final unconditional-formula
7655 : : ! confirmation.
7656 : : ! TIME-REVERSAL generalization of itime_h (was hardcoded to 1, i.e. always the pure-spatial
7657 : : ! D-matrix slice). The unitary/antiunitary character of a composed operator is a Z2
7658 : : ! homomorphism (same rule dmats_check_one_k's group-multiplication test uses:
7659 : : ! itime3 = 1 + mod((itime1-1)+(itime2-1), 2), Bradley & Cracknell sec. 7.3), extended here
7660 : : ! by associativity to h's three-fold composition toinv(isym_kqT).isym_k.isym_kqS
7661 : : ! (itime(A^{-1}) = itime(A), so toinv(isym_kqT) contributes trev_kqT unchanged). High
7662 : : ! confidence, not yet empirically validated on a TR-nonzero system.
7663 : 0 : itime_h = 1 + mod(trev_k + trev_kqS + trev_kqT, 2)
7664 : :
7665 : : ! HYPOTHESIS (open question, validate empirically -- see gstore_symmetrize_status memory):
7666 : : ! phase_h_gs's lattice-vector phase is built from dmats%multable/toinv, which are
7667 : : ! itime-independent by construction, so its formula should carry over unchanged. But the
7668 : : ! closest validated analogue, dmats_get_star_dmats (m_classify_bands.F90), needs an EXTRA
7669 : : ! conjugation on its own analogous phase whenever itime==2. Applying the same pattern here
7670 : : ! as a first hypothesis; h's composition shape differs from that routine's, so this is not
7671 : : ! a proof, only a well-motivated starting point.
7672 : 0 : h_isym_inv = dmats%toinv(1, h_isym)
7673 [ # # ]: 0 : if (itime_h == 2) then
7674 [ # # # # : 0 : dh_mat = conjg(phase_h_gs) * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
# # # # #
# # # ]
7675 : : else
7676 [ # # # # : 0 : dh_mat = phase_h_gs * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
# # # # #
# # # ]
7677 : : end if
7678 : :
7679 : : ! HYPOTHESIS (open question, validate empirically): pulling D(h) through the outer operator
7680 : : ! that maps ikq_ibz -> kq_bz_target picks up a conjugate exactly when that operator
7681 : : ! (governed by isym_kqT/trev_kqT) is antiunitary -- a flag logically independent of trev_k
7682 : : ! (see 2.4's gtmp conjugation below) and of itime_h (which only selects WHICH tabulated
7683 : : ! matrix to read, not whether the whole assembled dh_mat needs conjugating on top).
7684 [ # # # # : 0 : if (trev_kqT == 1) dh_mat = conjg(dh_mat)
# # ]
7685 : :
7686 : : if (DEBUG_DUMP_DH) then
7687 : : 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, &
7688 : : 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, &
7689 : : qpt, kk_ibz
7690 : : write(790,*) ik_glob, iq_glob, nb, isym_k, h_isym, ikq_ibz_t, isym_kqS, isym_kqT, g0_q, &
7691 : : trev_k, trev_kqS, trev_kqT, itime_h, &
7692 : : real(phase_h_gs), aimag(phase_h_gs), real(phase_ket_gs), aimag(phase_ket_gs), &
7693 : : dmats%for_spin(spin)%value(:,:,h_isym,itime_h,ikq_ibz_t)
7694 : : end if
7695 : : ! -----------------------------------------------------------------
7696 : :
7697 : : ! Perform symmetrization.
7698 [ # # ]: 0 : do mu=1,gqk%natom3
7699 : 0 : idir = mod(mu-1, 3) + 1; iat = (mu - idir) / 3 + 1
7700 : :
7701 : 0 : iat_eq = cryst%indsym(4, isym_combined, iat)
7702 [ # # ]: 0 : l0 = cryst%indsym(1:3, isym_combined, iat)
7703 [ # # ]: 0 : phase = -two_pi * dot_product(qbz(:, iq_sym), l0)
7704 : 0 : cphase = cmplx(cos(phase), sin(phase), dp)
7705 : :
7706 : : ! Per-mu atomic-mapping/phase diagnostic (iat_eq, l0, symrec_eq row, cphase, iq_sym):
7707 : : ! reusable general-purpose dump, not tied to any specific (ik_glob,iq_glob) -- add a
7708 : : ! filter here (e.g. "if (ik_glob==... .and. iq_glob==...)") when tracing one point on a
7709 : : ! large system, to keep mu_debug.csv a manageable size.
7710 : : if (DEBUG_DUMP_DH) then
7711 : : write(792,*) ik_glob, iq_glob, mu, iat, iat_eq, isym_combined, isym_k, ik_ibz, iq_sym, &
7712 : : l0, symrec_eq(idir,1), symrec_eq(idir,2), symrec_eq(idir,3), idir, ik_ibz_file, cphase
7713 : : end if
7714 : :
7715 : : ! Apply the same geometric rotation (cphase/symrec_eq/dh_mat, all independent of which
7716 : : ! gvals stream is being processed) to each stream separately, since gtmp's accumulation
7717 : : ! reads actual matrix-element values from gkq_base.
7718 [ # # ]: 0 : do igv=1,n_gv
7719 [ # # # # ]: 0 : gtmp = zero
7720 [ # # ]: 0 : do idir_eq=1,3
7721 : 0 : mu_eq = idir_eq + (iat_eq - 1) * 3
7722 [ # # # # : 0 : gtmp = gtmp + cphase * symrec_eq(idir, idir_eq) * gkq_base(:,:,mu_eq,iq_sym,igv)
# # ]
7723 : : end do
7724 : : ! HYPOTHESIS (open question, validate empirically): conjugate gtmp before the dh_mat
7725 : : ! multiply whenever the ket leg's own operation (isym_k, trev_k) is antiunitary. Matches
7726 : : ! the "rotate spatially first, conjugate as the last step" pattern used identically by
7727 : : ! cgtk_rotate, pheigvec_rotate, rotate_fqg and dmats_init elsewhere in this codebase.
7728 : : ! Order matters: conjugate gtmp itself, not matmul(dh_mat,gtmp), since dh_mat is complex.
7729 [ # # # # : 0 : if (trev_k == 1) gtmp = conjg(gtmp)
# # ]
7730 : : ! Apply the Bug A correction: left-multiply by D(h) on the bra (m) index.
7731 [ # # # # : 0 : gkq_rot(:,:,mu,iq_glob,igv) = matmul(dh_mat, gtmp)
# # # # #
# # # # #
# # # # #
# # # #
# ]
7732 : 0 : if (DEBUG_DUMP_DH) write(791,*) ik_glob, iq_glob, mu, nb, trev_k, trim(gv_names(igv)), gtmp
7733 : : end do
7734 : : end do
7735 : :
7736 : : end do ! my_iq
7737 : :
7738 : : ! Write the newly computed g_{mn, nu} back to the netcdf file (in-place modification),
7739 : : ! for each gvals stream, and update the entry in state_kq.
7740 [ # # ]: 0 : do igv=1,n_gv
7741 [ # # ]: 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])
7742 : : ncerr = nf90_put_var(spin_ncid, spin_vid(gv_names(igv)), gkq_rot_ptr, &
7743 : : start=[1, 1, 1, 1, ik_glob, 1], &
7744 [ # # # # ]: 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7745 [ # # ]: 0 : NCF_CHECK(ncerr)
7746 : : end do
7747 [ # # ]: 0 : state_kq(ik_glob, :) = GSTORE_KQ_SYMMETRIZED
7748 : : end do ! my_ik
7749 : : end associate
7750 : :
7751 : : ! Update state_kq for this spin.
7752 [ # # ]: 0 : ncerr = nf90_put_var(ncid, vid("gstore_glob_state_kqs"), state_kq, start=[1,1,spin])
7753 [ # # ]: 0 : NCF_CHECK(ncerr)
7754 : :
7755 [ # # ]: 0 : ABI_FREE(qbz)
7756 [ # # ]: 0 : ABI_FREE(gkq_base)
7757 [ # # ]: 0 : ABI_FREE(gkq_rot)
7758 [ # # ]: 0 : ABI_FREE(state_kq)
7759 [ # # ]: 0 : ABI_FREE(gtmp)
7760 [ # # ]: 0 : ABI_FREE(dh_mat)
7761 [ # # ]: 0 : ABI_FREE(ket_mat)
7762 : : end do ! my_is
7763 : :
7764 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
7765 : : if (DEBUG_DUMP_DH) close(789)
7766 : : if (DEBUG_DUMP_DH) close(790)
7767 : : if (DEBUG_DUMP_DH) close(791)
7768 : : if (DEBUG_DUMP_DH) close(792)
7769 : :
7770 [ # # ]: 0 : ABI_FREE(kibz2bz)
7771 : 0 : call gstore%free()
7772 : :
7773 : 0 : 100 call dmats%free()
7774 : 0 : call xmpi_barrier(comm)
7775 [ # # # # : 0 : call wrtout(units, " Symmetrization completed successfully.")
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
7776 : :
7777 : : contains
7778 : 0 : integer function vid(var_name)
7779 : : character(len=*),intent(in) :: var_name
7780 : 0 : vid = nctk_idname(ncid, var_name)
7781 : : end function vid
7782 : :
7783 : 0 : integer function spin_vid(var_name)
7784 : : character(len=*),intent(in) :: var_name
7785 : 0 : spin_vid = nctk_idname(spin_ncid, var_name)
7786 : : end function spin_vid
7787 : :
7788 : : end subroutine gstore_symmetrize
7789 : : !!***
7790 : :
7791 [ - + - - : 78498 : end module m_gstore
+ + - + +
- - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - + ]
7792 : : !!***
|
