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 : : ! Initialize GSTORE.nc file i.e. define dimensions and arrays
1088 : : ! Entries such as the e-ph matrix elements will be filled afterwards in gstore_compute.
1089 : : ! Master node defines dimensions and variables.
1090 : :
1091 : 8 : write_gstore = .True.
1092 [ - + ]: 8 : if (has_gwan) write_gstore = .False.
1093 : :
1094 [ + - ]: 8 : if (my_rank == master .and. write_gstore) then
1095 [ - + ]: 8 : NCF_CHECK(nctk_open_create(ncid, gstore%path, xmpi_comm_self))
1096 : :
1097 : : ! Write the abinit header with metadata, structure and occupancies.
1098 : 8 : gstore_fform = fform_from_ext("GSTORE.nc")
1099 [ - + ]: 8 : NCF_CHECK(wfk0_hdr%ncwrite(ncid, gstore_fform, spinat=dtset%spinat, nc_define=.True.))
1100 : :
1101 : : ! Add crystalline structure.
1102 [ - + ]: 8 : NCF_CHECK(gstore%cryst%ncwrite(ncid))
1103 : : ! Add eigenvalues and occupations.
1104 [ - + ]: 8 : NCF_CHECK(gstore%ebands%ncwrite(ncid))
1105 : :
1106 : : ! Write gstore dimensions
1107 : : ncerr = nctk_def_dims(ncid, [ &
1108 : : nctkdim_t("gstore_nkibz", gstore%nkibz), &
1109 : : nctkdim_t("gstore_nkbz", gstore%nkbz), &
1110 : : nctkdim_t("gstore_nqibz", gstore%nqibz), &
1111 : : nctkdim_t("gstore_nqbz", gstore%nqbz), &
1112 : : nctkdim_t("gstore_max_nq", max_nq), &
1113 : : nctkdim_t("gstore_max_nk", max_nk), &
1114 : : nctkdim_t("gstore_max_nb", maxval(gstore%brange_k_spin(2, :) - gstore%brange_k_spin(1, :) + 1) ), &
1115 : : nctkdim_t("nrpt", ifc%nrpt), &
1116 : : nctkdim_t("natom", gstore%cryst%natom), &
1117 : : nctkdim_t("natom3", 3 * gstore%cryst%natom), &
1118 : : nctkdim_t("gstore_cplex", 2), &
1119 : : nctkdim_t("ifc_nqbz", ifc%nqbz) &
1120 [ + + + + ]: 112 : ], defmode=.True.)
1121 [ - + ]: 8 : NCF_CHECK(ncerr)
1122 : :
1123 : : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: &
1124 : : "gstore_with_vk", "gstore_qptopt", "gstore_completed", &
1125 : : "gstore_use_lgk", "gstore_use_lgq", "gstore_has_ifcs", "gwpt_wmode", "used_ftinterp", "gwcomp" &
1126 [ + + ]: 80 : ])
1127 [ - + ]: 8 : NCF_CHECK(ncerr)
1128 : : ncerr = nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: &
1129 : : "ifc_eta" &
1130 [ + + ]: 16 : ])
1131 [ - + ]: 8 : NCF_CHECK(ncerr)
1132 : :
1133 : : ncerr = nctk_def_arrays(ncid, [ &
1134 : : nctkarr_t("gstore_qibz", "dp", "three, gstore_nqibz"), &
1135 : : nctkarr_t("gstore_qbz", "dp", "three, gstore_nqbz"), &
1136 : : nctkarr_t("gstore_wtq", "dp", "gstore_nqibz"), &
1137 : : nctkarr_t("gstore_kbz", "dp", "three, gstore_nkbz"), &
1138 : : nctkarr_t("gstore_kzone", "c", "character_string_length"), &
1139 : : nctkarr_t("gstore_qzone", "c", "character_string_length"), &
1140 : : nctkarr_t("gstore_kfilter", "c", "character_string_length"), &
1141 : : nctkarr_t("gstore_gmode", "c", "character_string_length"), &
1142 : : nctkarr_t("gstore_gtype", "c", "character_string_length"), &
1143 : : nctkarr_t("gstore_wfk0_path", "c", "fnlen"), &
1144 : : nctkarr_t("gstore_brange_k_spin", "i", "two, number_of_spins"), &
1145 : : nctkarr_t("gstore_brange_kq_spin", "i", "two, number_of_spins"), &
1146 : : nctkarr_t("gstore_erange_spin", "dp", "two, number_of_spins"), &
1147 : : nctkarr_t("gstore_ngqpt", "i", "three"), &
1148 : : nctkarr_t("phfreqs_ibz", "dp", "natom3, gstore_nqibz"), &
1149 : : nctkarr_t("pheigvec_cart_ibz", "dp", "two, three, natom, natom3, gstore_nqibz"), &
1150 : : nctkarr_t("gstore_glob_nq_spin", "i", "number_of_spins"), &
1151 : : nctkarr_t("gstore_glob_nk_spin", "i", "number_of_spins"), &
1152 : : nctkarr_t("gstore_done_qbz_spin", "i", "gstore_nqbz, number_of_spins"), &
1153 : : nctkarr_t("gstore_kbz2ibz", "i", "six, gstore_nkbz"), &
1154 : : nctkarr_t("gstore_qbz2ibz", "i", "six, gstore_nqbz"), &
1155 : : nctkarr_t("gstore_qglob2bz", "i", "gstore_max_nq, number_of_spins"), &
1156 : : nctkarr_t("gstore_kglob2bz", "i", "gstore_max_nk, number_of_spins"), &
1157 : : ! Table with status of (k, q, spin) entry, used to symmetrize matrix-elements.
1158 : : nctkarr_t("gstore_glob_state_kqs", "i", "gstore_max_nk, gstore_max_nq, number_of_spins"), &
1159 : : !
1160 : : ! These quantities are needed to interface GSTORE.nc with external codes.
1161 : : ! For the meaning of the different variables and conventions see m_ifc module.
1162 : : nctkarr_t("ifc_dielt", "dp", "three, three"), &
1163 : : nctkarr_t("ifc_zeff", "dp", "three, three, number_of_atoms"), &
1164 : : nctkarr_t("ifc_qdrp_cart", "dp", "three, three, three, number_of_atoms") &
1165 [ + + ]: 224 : ])
1166 [ - + ]: 8 : NCF_CHECK(ncerr)
1167 : :
1168 : : if (gstore_has_ifcs /= 0) then
1169 : : ! Define arrays for IFCs.
1170 : : ! For the meaning of the different variables and conventions see m_ifc module.
1171 : : ncerr = nctk_def_arrays(ncid, [ &
1172 : : nctkarr_t("ifc_rpt", "dp", "three, nrpt"), &
1173 : : nctkarr_t("ifc_wghatm", "dp", "natom, natom, nrpt"), &
1174 : : nctkarr_t("ifc_dynmat", "dp", "two, three, natom, three, natom, ifc_nqbz"), &
1175 : : nctkarr_t("ifc_short_atmfrc", "dp", "three, natom, three, natom, nrpt") &
1176 [ + + ]: 40 : ])
1177 [ - + ]: 8 : NCF_CHECK(ncerr)
1178 : : end if
1179 : :
1180 : : ! Internal table used to restart computation. Initialized with zeros.
1181 : : ! 0 --> (ib_bz, spin) has not been computed.
1182 : : ! 1 --> (iq_bz, spin) has been computed.
1183 : : ! In order to check if the whole generation is completed, one should test if "gstore_completed" == 1
1184 [ - + ]: 8 : NCF_CHECK(nf90_def_var_fill(ncid, vid("gstore_done_qbz_spin"), NF90_FILL, 0))
1185 : :
1186 [ - + ]: 8 : NCF_CHECK(nf90_def_var_fill(ncid, vid("gstore_glob_state_kqs"), NF90_FILL, GSTORE_KQ_MISSING))
1187 : :
1188 : : ! Optional arrays
1189 [ - + ]: 8 : if (allocated(gstore%delta_ef_kibz_spin)) then
1190 : : ncerr = nctk_def_arrays(ncid, &
1191 : 0 : nctkarr_t("gstore_delta_ef_kibz_spin", "dp", "gstore_max_nb, gstore_nkibz, number_of_spins"))
1192 : : end if
1193 [ - + ]: 8 : NCF_CHECK(ncerr)
1194 : :
1195 : : ! Write data
1196 [ - + ]: 8 : NCF_CHECK(nctk_set_datamode(ncid))
1197 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_with_vk"), gstore%with_vk))
1198 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qptopt"), gstore%qptopt))
1199 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_use_lgk"), dtset%gstore_use_lgk))
1200 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_use_lgq"), dtset%gstore_use_lgq))
1201 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_has_ifcs"), gstore_has_ifcs))
1202 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gwpt_wmode"), dtset%gwpt_wmode))
1203 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_completed"), 0))
1204 : : ! 1 if the DFPT potentials have been Fourier-interpolated. Set by the routines computing g (gstore_compute, gwpt_run).
1205 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("used_ftinterp"), 0))
1206 : : ! Value of gwcomp used to compute the GWPT matrix elements (COH static remainder if 2). Set by gwpt_run.
1207 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gwcomp"), 0))
1208 [ - + - - ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_kzone"), trim(gstore%kzone)))
1209 [ - + - - ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qzone"), trim(gstore%qzone)))
1210 [ - + - - ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_kfilter"), trim(gstore%kfilter)))
1211 [ - + - - ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_gmode"), trim(gstore%gmode)))
1212 [ - + - - ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_gtype"), trim(gstore%gtype)))
1213 : :
1214 : : ! NB: kibz has been already written by ebands%ncwrite
1215 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qibz"), gstore%qibz))
1216 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qbz"), gstore%qbz))
1217 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_wtq"), gstore%wtq))
1218 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_kbz"), gstore%kbz))
1219 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_brange_k_spin"), gstore%brange_k_spin))
1220 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_brange_kq_spin"), gstore%brange_kq_spin))
1221 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_erange_spin"), gstore%erange_spin))
1222 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_ngqpt"), gstore%ngqpt))
1223 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_glob_nq_spin"), gstore%glob_nq_spin))
1224 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_glob_nk_spin"), gstore%glob_nk_spin))
1225 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_kbz2ibz"), gstore%kbz2ibz))
1226 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qbz2ibz"), qbz2ibz))
1227 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_qglob2bz"), qglob2bz))
1228 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_kglob2bz"), gstore%kglob2bz))
1229 : :
1230 : : ! These quantities are needed to interface GSTORE.nc with external codes.
1231 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_dielt"), ifc%dielt))
1232 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_zeff"), ifc%zeff))
1233 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_qdrp_cart"), ifc%qdrp_cart))
1234 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_eta"), ifc%eta))
1235 : : if (gstore_has_ifcs /= 0) then
1236 : : ! TODO: "ifc_rpt"'s on-disk convention is tied to Ifc%rpt's own numeric
1237 : : ! meaning, which is now unconditionally true cartesian vectors (dual to
1238 : : ! Ifc%gprimd) -- previously a DDB-specific dimensionless convention that
1239 : : ! could not be reconstructed from the crystal structure alone. For every
1240 : : ! case currently exercised (identity rprim in the source DDB) the two
1241 : : ! conventions coincide numerically, so this is not a behavior change
1242 : : ! today, but if Ifc%rpt's convention ever changes again, this field's
1243 : : ! on-disk meaning changes with it with no version bump to flag it --
1244 : : ! worth a deliberate versioned migration then, not a silent value change.
1245 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_rpt"), ifc%rpt))
1246 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_wghatm"), ifc%wghatm))
1247 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_dynmat"), ifc%dynmat))
1248 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_short_atmfrc"), ifc%short_atmfrc))
1249 : : end if
1250 : :
1251 [ - + ]: 8 : if (allocated(gstore%delta_ef_kibz_spin)) then
1252 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_delta_ef_kibz_spin"), gstore%delta_ef_kibz_spin))
1253 : : end if
1254 : :
1255 [ + + ]: 16 : do spin=1,gstore%nsppol
1256 : : ! Create hdf group for this spin.
1257 [ - + ]: 8 : NCF_CHECK(nf90_def_grp(ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
1258 : :
1259 : : ! Dimensions in gqk_spin group
1260 : : ncerr = nctk_def_dims(spin_ncid, [ &
1261 : : nctkdim_t("nb_k", gstore%brange_k_spin(2, spin) - gstore%brange_k_spin(1, spin) + 1), &
1262 : : nctkdim_t("nb_kq", gstore%brange_kq_spin(2, spin) - gstore%brange_kq_spin(1, spin) + 1), &
1263 : : nctkdim_t("glob_nk", gstore%glob_nk_spin(spin)), &
1264 : : nctkdim_t("glob_nq", gstore%glob_nq_spin(spin)) &
1265 [ + + ]: 40 : ], defmode=.True.)
1266 [ - + ]: 8 : NCF_CHECK(ncerr)
1267 : :
1268 : : ! Define scalars
1269 [ + + ]: 24 : ncerr = nctk_def_iscalars(spin_ncid, [character(len=nctk_slen) :: "bstart_k", "bstart_kq"])
1270 [ - + ]: 8 : NCF_CHECK(ncerr)
1271 : :
1272 : : ! arrays in gqk_spin group with the precious stuff. Note global dimensions.
1273 : : ncerr = nctk_def_arrays(spin_ncid, [ &
1274 : : nctkarr_t("gvals", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq") &
1275 [ + + ]: 16 : ])
1276 [ - + ]: 8 : NCF_CHECK(ncerr)
1277 : :
1278 : : ! Compress gvals to reduce size on disk.
1279 : : !NCF_CHECK(nf90_def_var_deflate(spin_ncid, spin_vid("gvals"), shuffle=1, deflate=1, deflate_level=5))
1280 : :
1281 : : ! IMPORTANT: Init gvals with zeros.
1282 : : ! Default value for entries in gvals, vnk_cart_ibz and vnk_mat_cart_ibz arrays that have not been written.
1283 : : ! This can happen only if we have filtered wavevectors.
1284 : 8 : gstore_fill_dp = zero
1285 [ + + ]: 8 : if (gstore%kfilter == "none") gstore_fill_dp = -huge(one)
1286 [ - + ]: 8 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("gvals"), NF90_FILL, gstore_fill_dp))
1287 : :
1288 : : ! In GWPT gvals is used for g^Sigma so we declare another array to store g^KS.
1289 [ + + ]: 8 : if (dtset%eph_task == 17) then
1290 : : ncerr = nctk_def_arrays(spin_ncid, [ &
1291 : : nctkarr_t("gvals_ks", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq") &
1292 [ + + ]: 6 : ])
1293 [ - + ]: 3 : NCF_CHECK(ncerr)
1294 : : ! Compress gvals to reduce size on disk.
1295 : : !NCF_CHECK(nf90_def_var_deflate(spin_ncid, spin_vid("gvals_ks"), shuffle=1, deflate=1, deflate_level=5))
1296 [ - + ]: 3 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("gvals_ks"), NF90_FILL, gstore_fill_dp))
1297 : : end if
1298 : :
1299 : 16 : select case(gstore%with_vk)
1300 : : case (1)
1301 : : ! Diagonal terms only
1302 [ - + ]: 8 : NCF_CHECK(nctk_def_arrays(spin_ncid, nctkarr_t("vk_cart_ibz", "dp", "three, nb_k, gstore_nkibz")))
1303 [ - + ]: 8 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("vk_cart_ibz"), NF90_FILL, gstore_fill_dp))
1304 : :
1305 : : case (2)
1306 : : ! Full (nb_k x nb_k) matrix.
1307 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(spin_ncid, nctkarr_t("vnk_mat_cart_ibz", "dp", "two, three, nb_k, nb_k, gstore_nkibz")))
1308 [ + - - - : 8 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("vnk_mat_cart_ibz"), NF90_FILL, gstore_fill_dp))
- ]
1309 : : end select
1310 : :
1311 : : ! Write (small) data
1312 [ - + ]: 8 : NCF_CHECK(nctk_set_datamode(spin_ncid))
1313 [ - + ]: 8 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("bstart_k"), gstore%brange_k_spin(1, spin)))
1314 [ - + ]: 16 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("bstart_kq"), gstore%brange_kq_spin(1, spin)))
1315 : : end do ! spin
1316 : :
1317 [ - + ]: 8 : NCF_CHECK(nf90_close(ncid))
1318 : : end if ! master
1319 : :
1320 : : ! Make sure GSTORE.nc has been written by master.
1321 : 8 : call xmpi_barrier(gstore%comm)
1322 : :
1323 [ - + ]: 8 : ABI_FREE(wtk)
1324 [ - + ]: 8 : ABI_FREE(qibz2bz)
1325 [ - + ]: 8 : ABI_FREE(kibz2bz)
1326 [ - + ]: 8 : ABI_FREE(select_qbz_spin)
1327 [ - + ]: 8 : ABI_FREE(select_kbz_spin)
1328 [ - + ]: 8 : ABI_FREE(qglob2bz)
1329 [ - + ]: 8 : ABI_FREE(qbz2ibz)
1330 : :
1331 : 8 : call cwtime_report(" gstore_init:", cpu, wall, gflops)
1332 [ - + - + : 32 : call pstat_proc%print(_PSTAT_ARGS_)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + -
+ ]
1333 : :
1334 : : ! NOTE: When has_gwan is True, gqk%my_g/my_g2 have been allocated above (gqk_cplex) but are not
1335 : : ! filled here. The actual Wannier interpolation of the e-ph matrix elements is performed by the
1336 : : ! caller, gstore_init_or_from_ncpath, where with_gmode/gvals_name/with_g2dw are available.
1337 : :
1338 : : contains
1339 : 304 : integer function vid(var_name)
1340 : : character(len=*),intent(in) :: var_name
1341 : 304 : vid = nctk_idname(ncid, var_name)
1342 : : end function vid
1343 : 35 : integer function spin_vid(var_name)
1344 : : character(len=*),intent(in) :: var_name
1345 : 35 : spin_vid = nctk_idname(spin_ncid, var_name)
1346 : : end function spin_vid
1347 : :
1348 : : end subroutine gstore_init
1349 : : !!***
1350 : :
1351 : : !----------------------------------------------------------------------
1352 : :
1353 : : !!****f* m_gstore/gstore_init_or_from_ncpath
1354 : : !! NAME
1355 : : !! gstore_init_or_from_ncpath
1356 : : !!
1357 : : !! FUNCTION
1358 : : !! Build a gstore_t object either by reading a pre-existent GSTORE.nc file
1359 : : !! (getgstore_filepath) or, alternatively, by interpolating e-ph matrix elements
1360 : : !! on the fly from ABIWAN.nc + GWAN.nc (getabiwan_filepath + getgwan_filepath),
1361 : : !! e.g. on a k/q-mesh denser than the one used to compute the GWAN.nc file.
1362 : : !! In the latter case, no GSTORE.nc file is read or written: gqk%my_g is filled
1363 : : !! entirely in memory (see the has_gwan branch in gstore_init).
1364 : : !!
1365 : : !! from_file (output): set to .True. if gstore was built from a
1366 : : !! pre-existent GSTORE.nc file, .False. if built on the fly via Wannier
1367 : : !! interpolation. Callers can use this to report which path was taken.
1368 : : !!
1369 : : !! SOURCE
1370 : :
1371 : 16 : subroutine gstore_init_or_from_ncpath(gstore, with_cplex, dtset, dtfil, wfk0_hdr, cryst, ebands, ifc, &
1372 : : with_gmode, gvals_name, with_g2dw, comm, from_file)
1373 : :
1374 : : !Arguments ------------------------------------
1375 : : !scalars
1376 : : class(gstore_t),target,intent(out) :: gstore
1377 : : integer,intent(in) :: with_cplex
1378 : : type(dataset_type),target,intent(in) :: dtset
1379 : : type(datafiles_type),intent(in) :: dtfil
1380 : : type(hdr_type),intent(in) :: wfk0_hdr
1381 : : class(crystal_t),target,intent(in) :: cryst
1382 : : class(ebands_t),target,intent(in) :: ebands
1383 : : class(ifc_type),target,intent(in) :: ifc
1384 : : character(len=*),intent(in) :: with_gmode, gvals_name
1385 : : logical,intent(in) :: with_g2dw
1386 : : integer,intent(in) :: comm
1387 : : logical,intent(out) :: from_file
1388 : :
1389 : : !Local variables-------------------------------
1390 : : !scalars
1391 : : integer :: natom, natom3, spin, my_is, my_ik, my_iq, iq_ibz, isym_q, trev_q, ipc, nu, nwan, ierr
1392 : : integer :: ik_start, ik_stop, ikb, nkb, nk_batch
1393 : : real(dp) :: weight_q, cpu, wall, gflops
1394 : : character(len=500) :: msg
1395 : : character(len=fnlen) :: gstore_path
1396 : : type(gqk_t),pointer :: gqk
1397 : : !arrays
1398 : : real(dp) :: qpt(3)
1399 : 16 : real(dp),allocatable :: phfrq_ibz(:,:), displ_cart_dum(:,:,:,:), gatm_real(:,:,:,:), gnu_real(:,:,:,:)
1400 : 16 : real(dp),allocatable :: eigvec_ibz(:,:,:,:,:), eigvec_qbz(:,:,:,:), displ_cart_qbz(:,:,:,:), displ_red_qbz(:,:,:,:)
1401 [ + - ]: 16 : complex(dp),allocatable :: intp_gatm(:,:,:,:), gatm_full(:,:,:,:), g_req(:,:,:,:)
1402 : : !----------------------------------------------------------------------
1403 : :
1404 [ + - ]: 16 : if (dtfil%filgstorein /= ABI_NOFILE) then
1405 : : call gstore%from_ncpath(dtfil%filgstorein, with_cplex, dtset, dtfil, cryst, ebands, ifc, &
1406 : 16 : with_gmode, gvals_name, with_g2dw, comm)
1407 : 16 : from_file = .True.
1408 : :
1409 [ # # # # ]: 0 : else if (dtfil%filabiwanin /= ABI_NOFILE .and. dtfil%filgwanin /= ABI_NOFILE) then
1410 : : ! Build gstore on the fly via Wannier interpolation from ABIWAN.nc + GWAN.nc.
1411 : 0 : call cwtime(cpu, wall, gflops, "start")
1412 : : ! with_cplex=0 prepares the Wannier interpolator and gstore metadata without materializing g(k,q).
1413 : : ! with_cplex=1/2 stores |g|^2/complex g, respectively. Debye-Waller and gvals_ks are unsupported.
1414 [ # # ]: 0 : msg = sjoin("Invalid with_cplex:", itoa(with_cplex), "only 0, 1 or 2 are supported")
1415 [ # # ]: 0 : ABI_CHECK(with_cplex >= 0 .and. with_cplex <= 2, msg)
1416 [ # # ]: 0 : if (with_g2dw) then
1417 : 0 : ABI_ERROR("with_g2dw = .True. is not yet supported when building gstore via Wannier interpolation (ABIWAN.nc + GWAN.nc)")
1418 : : end if
1419 [ # # ]: 0 : if (gvals_name == "gvals_ks") then
1420 : 0 : ABI_ERROR("gvals_name = 'gvals_ks' is not supported when building gstore via Wannier interpolation (ABIWAN.nc + GWAN.nc)")
1421 : : end if
1422 [ # # ]: 0 : if (with_gmode /= GSTORE_GMODE_PHONON) then
1423 : 0 : ABI_ERROR(sjoin("with_gmode:", with_gmode, "is not yet supported when building gstore via Wannier"))
1424 : : end if
1425 : :
1426 [ # # ]: 0 : gstore_path = strcat(dtfil%filnam_ds(4), "_GSTORE.nc")
1427 : 0 : call gstore%init(gstore_path, dtset, dtfil, wfk0_hdr, cryst, ebands, ifc, comm, with_cplex=with_cplex)
1428 : :
1429 [ # # ]: 0 : if (with_cplex == 0) then
1430 [ # # ]: 0 : call wrtout([std_out, ab_out], " Preparing on-demand Wannier interpolation of e-ph matrix elements ...", pre_newlines=1)
1431 : : else
1432 [ # # ]: 0 : call wrtout([std_out, ab_out], " Using Wannier interpolation to compute and store e-ph matrix elements ...", pre_newlines=1)
1433 : : end if
1434 : 0 : from_file = .False.
1435 : 0 : natom = cryst%natom; natom3 = 3 * natom
1436 : :
1437 : : ! Precompute phonon frequencies/eigenvectors in the IBZ once (spin-independent).
1438 : : ! NB: The phonon eigenvector gauge must be fixed from a single IBZ representative + symmetry
1439 : : ! rotation (pheigvec_rotate), exactly as done when g(k,q) is read from a pre-existent GSTORE.nc
1440 : : ! file (see gstore_from_ncpath). Calling ifc%fourq directly at each interpolated BZ q would give
1441 : : ! an independently-diagonalized (and hence potentially differently gauged) eigenbasis for
1442 : : ! degenerate modes and would break the e(-q) = e(q)^* convention used elsewhere in the code.
1443 [ # # # # : 0 : ABI_MALLOC(phfrq_ibz, (natom3, gstore%nqibz))
# # # # #
# # # # #
# # ]
1444 [ # # # # : 0 : ABI_MALLOC(eigvec_ibz, (2, 3, natom, natom3, gstore%nqibz))
# # # # #
# # # # #
# # # # #
# ]
1445 [ # # # # : 0 : ABI_MALLOC(displ_cart_dum, (2, 3, natom, natom3))
# # # # #
# # # # #
# # ]
1446 [ # # ]: 0 : do iq_ibz=1,gstore%nqibz
1447 : : call ifc%fourq(cryst, gstore%qibz(:,iq_ibz), phfrq_ibz(:,iq_ibz), displ_cart_dum, &
1448 : 0 : out_eigvec=eigvec_ibz(:,:,:,:,iq_ibz))
1449 : : end do
1450 [ # # ]: 0 : ABI_FREE(displ_cart_dum)
1451 : :
1452 [ # # # # : 0 : ABI_MALLOC(eigvec_qbz, (2, 3, natom, natom3))
# # # # #
# # # # #
# # ]
1453 [ # # # # : 0 : ABI_MALLOC(displ_cart_qbz, (2, 3, natom, natom3))
# # # # #
# # # ]
1454 [ # # # # : 0 : ABI_MALLOC(displ_red_qbz, (2, 3, natom, natom3))
# # # # #
# # # ]
1455 : :
1456 : : ! Interpolate g(k,q) and store data in memory.
1457 [ # # ]: 0 : do my_is=1,gstore%my_nspins
1458 : 0 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is); nwan = gqk%nb_k
1459 : :
1460 : : ! Build gqk%wan for this spin from the ABIWAN.nc file and load g(R_e, R_p) from GWAN.nc.
1461 : 0 : call gqk%wan%from_abiwan(dtfil%filabiwanin, spin, gstore%nsppol, .False., "", gqk%comm%value)
1462 : 0 : gqk%wan%my_pert_start = gqk%my_pert_start; gqk%wan%my_npert = gqk%my_npert; gqk%wan%pert_comm => gqk%pert_comm
1463 : 0 : call gqk%wan%load_gwan(dtfil%filgwanin, cryst, spin, gstore%nsppol, gqk%comm)
1464 : :
1465 [ # # # # : 0 : ABI_MALLOC(gqk%my_wnuq, (gqk%my_npert, gqk%my_nq))
# # # # #
# # # # #
# # # # ]
1466 [ # # # # : 0 : ABI_MALLOC(gqk%my_displ_cart, (2, 3, natom, gqk%my_npert, gqk%my_nq))
# # # # #
# # # # #
# # # # #
# # # ]
1467 : :
1468 [ # # ]: 0 : if (with_cplex > 0) then
1469 : : ! Bound the two temporary complex atomic-vertex arrays to the default
1470 : : ! 64 MiB workspace. The low-level selector also accepts a custom limit.
1471 : 0 : nk_batch = gqk%wan%eph_kbatch_size(gqk%my_nk, natom3)
1472 [ # # # # : 0 : ABI_MALLOC(intp_gatm, (nwan, nwan, gqk%my_npert, nk_batch))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1473 [ # # # # : 0 : ABI_MALLOC(gatm_full, (nwan, nwan, natom3, nk_batch))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1474 [ # # # # : 0 : ABI_MALLOC(g_req, (gqk%wan%nr_e, nwan, nwan, gqk%my_npert))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1475 [ # # # # : 0 : ABI_MALLOC(gatm_real, (2, nwan, nwan, natom3))
# # # # #
# # # # #
# # # # #
# # # ]
1476 [ # # # # : 0 : ABI_MALLOC(gnu_real, (2, nwan, nwan, natom3))
# # # # #
# # # # #
# # # # ]
1477 : : end if
1478 : :
1479 [ # # ]: 0 : do my_iq=1,gqk%my_nq
1480 : 0 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
1481 : 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)
1482 : :
1483 : : ! Rotate the phonon eigenvector from the IBZ to this BZ q-point (fixes the gauge).
1484 : : call pheigvec_rotate(cryst, gstore%qibz(:,iq_ibz), isym_q, trev_q, eigvec_ibz(:,:,:,:,iq_ibz), &
1485 : 0 : eigvec_qbz, displ_cart_qbz, displ_red_qbz=displ_red_qbz)
1486 : :
1487 : : ! Fill my arrays with ph data.
1488 [ # # # # : 0 : gqk%my_wnuq(:,my_iq) = phfrq_ibz(gqk%my_pertcases(:), iq_ibz)
# # ]
1489 [ # # # # : 0 : gqk%my_displ_cart(:,:,:,:,my_iq) = displ_cart_qbz(:,:,:,gqk%my_pertcases(:))
# # # # #
# ]
1490 : :
1491 [ # # ]: 0 : if (with_cplex == 0) cycle
1492 : :
1493 : : ! The R_p -> q transform is independent of k and is reused by every
1494 : : ! bounded k block below.
1495 : 0 : call gqk%wan%prepare_eph_q(qpt, g_req)
1496 : :
1497 [ # # # # : 0 : do ik_start=1,gqk%my_nk,nk_batch
# # # # ]
1498 : 0 : ik_stop = min(gqk%my_nk, ik_start + nk_batch - 1); nkb = ik_stop - ik_start + 1
1499 : :
1500 : : call gqk%wan%interp_eph_manyk_from_q(cryst, nkb, gqk%my_kpts(:,ik_start:ik_stop), qpt, &
1501 : 0 : g_req, intp_gatm(:,:,:,1:nkb))
1502 : :
1503 : : ! Complete all atomic perturbations for the block with one collective
1504 : : ! instead of one pert_comm reduction per k point.
1505 [ # # # # : 0 : gatm_full(:,:,:,1:nkb) = czero
# # # # ]
1506 [ # # ]: 0 : do ikb=1,nkb
1507 [ # # ]: 0 : do ipc=1,gqk%my_npert
1508 [ # # # # ]: 0 : gatm_full(:,:,gqk%my_pertcases(ipc),ikb) = intp_gatm(:,:,ipc,ikb)
1509 : : end do
1510 : : end do
1511 [ # # ]: 0 : if (gqk%pert_comm%nproc > 1) call xmpi_sum(gatm_full(:,:,:,1:nkb), gqk%pert_comm%value, ierr)
1512 : :
1513 [ # # ]: 0 : do ikb=1,nkb
1514 : 0 : my_ik = ik_start + ikb - 1
1515 [ # # # # : 0 : gatm_real(1,:,:,:) = real(gatm_full(:,:,:,ikb), kind=dp)
# # ]
1516 [ # # # # : 0 : gatm_real(2,:,:,:) = aimag(gatm_full(:,:,:,ikb))
# # ]
1517 : 0 : call ephtk_gkknu_from_atm(nwan, nwan, 1, natom, gatm_real, phfrq_ibz(:,iq_ibz), displ_red_qbz, gnu_real)
1518 : :
1519 [ # # ]: 0 : do ipc=1,gqk%my_npert
1520 : 0 : nu = gqk%my_pertcases(ipc)
1521 [ # # ]: 0 : if (with_cplex == 2) then
1522 [ # # # # ]: 0 : gqk%my_g(ipc,:,my_iq,:,my_ik) = gnu_real(1,:,:,nu) + j_dpc * gnu_real(2,:,:,nu)
1523 : : else
1524 [ # # # # ]: 0 : gqk%my_g2(ipc,:,my_iq,:,my_ik) = gnu_real(1,:,:,nu)**2 + gnu_real(2,:,:,nu)**2
1525 : : end if
1526 : : end do
1527 : : end do ! ikb
1528 : : end do ! ik_start
1529 : : end do ! my_iq
1530 : :
1531 [ # # ]: 0 : if (with_cplex > 0) then
1532 [ # # ]: 0 : ABI_FREE(intp_gatm)
1533 [ # # ]: 0 : ABI_FREE(gatm_full)
1534 [ # # ]: 0 : ABI_FREE(g_req)
1535 [ # # ]: 0 : ABI_FREE(gatm_real)
1536 [ # # ]: 0 : ABI_FREE(gnu_real)
1537 : : end if
1538 : : end do ! my_is
1539 : :
1540 [ # # ]: 0 : ABI_FREE(phfrq_ibz)
1541 [ # # ]: 0 : ABI_FREE(eigvec_ibz)
1542 [ # # ]: 0 : ABI_FREE(eigvec_qbz)
1543 [ # # ]: 0 : ABI_FREE(displ_cart_qbz)
1544 [ # # ]: 0 : ABI_FREE(displ_red_qbz)
1545 : :
1546 : : ! We interpolated (and converted to) the phonon representation.
1547 : 0 : gstore%gmode = GSTORE_GMODE_PHONON
1548 : 0 : call cwtime_report(" Wannier interpolation of GSTORE matrix elements", cpu, wall, gflops)
1549 : :
1550 : : else
1551 : : write(msg, "(3a)") &
1552 : 0 : "Cannot build gstore object: either getgstore_filepath or both ", &
1553 : 0 : "getabiwan_filepath and getgwan_filepath must be provided in the input file.", ch10
1554 : 0 : ABI_ERROR(msg)
1555 : : end if
1556 : :
1557 [ - + - + : 16 : end subroutine gstore_init_or_from_ncpath
- + - + -
+ ]
1558 : : !!***
1559 : :
1560 : : !----------------------------------------------------------------------
1561 : :
1562 : 0 : logical function gstore_has_matrix_elements(gstore) result(has_g)
1563 : :
1564 : : class(gstore_t),intent(in) :: gstore
1565 : :
1566 : 0 : has_g = gstore%with_cplex > 0
1567 : :
1568 : 0 : end function gstore_has_matrix_elements
1569 : :
1570 : : !----------------------------------------------------------------------
1571 : :
1572 : 0 : logical function gstore_has_complex_matrix_elements(gstore) result(has_complex_g)
1573 : :
1574 : : class(gstore_t),intent(in) :: gstore
1575 : :
1576 : 0 : has_complex_g = gstore%with_cplex == 2
1577 : :
1578 : 0 : end function gstore_has_complex_matrix_elements
1579 : :
1580 : : !----------------------------------------------------------------------
1581 : :
1582 : : !!****f* m_gstore/gstore_same_nbands
1583 : : !! NAME
1584 : : !! gstore_same_nbands
1585 : : !!
1586 : : !! FUNCTION
1587 : : !! True if nb_k == nb_kq.
1588 : : !!
1589 : : !! SOURCE
1590 : :
1591 : 9 : logical function gstore_same_nbands(gstore, msg) result(same)
1592 : :
1593 : : class(gstore_t),intent(in) :: gstore
1594 : : character(len=*),intent(out) :: msg
1595 : :
1596 : : !Local variables-------------------------------
1597 : : integer :: my_is
1598 : : !----------------------------------------------------------------------
1599 : :
1600 : 9 : same = .True.; msg = ""
1601 [ + + ]: 18 : do my_is=1,gstore%my_nspins
1602 : 9 : associate (gqk => gstore%gqk(my_is))
1603 [ - + ]: 9 : if (gqk%nb_k /= gqk%nb_kq) then
1604 [ # # # # ]: 0 : same = .False.; msg = sjoin("gstore has different nb_kq, nb_k", itoa(gqk%nb_kq), itoa(gqk%nb_k))
1605 : : end if
1606 : : end associate
1607 : : end do
1608 : :
1609 [ + - ]: 9 : end function gstore_same_nbands
1610 : : !!***
1611 : :
1612 : : !----------------------------------------------------------------------
1613 : :
1614 : : !!****f* m_gstore/gstore_distribute_spins
1615 : : !! NAME
1616 : : !! gstore_distribute_spins
1617 : : !!
1618 : : !! FUNCTION
1619 : : !! Distribute spins. Also create and return indirect mapping to spin index and init %brange_k_spin
1620 : : !!
1621 : : !! INPUTS
1622 : : !!
1623 : : !! OUTPUT
1624 : : !!
1625 : : !! NOTES
1626 : : !! What works:
1627 : : !!
1628 : : !! - Setting gstore_kfilter = "qprange" works.
1629 : : !! With this, bands (nb_k) and k-points are automatically filtered, including only the VBM and CBM.
1630 : : !! This is useful for calculating the ZPR of the fundamental gap.
1631 : : !! Manual specification of bands (nb_k) and k-points also works by setting gstore_kfilter = "none" (default)
1632 : : !! and providing the values via kptgw and bdgw.
1633 : : !!
1634 : : !! What does not work:
1635 : : !!
1636 : : !! - There is currently no effective way to control nb_kq directly.
1637 : : !! The only workaround is using gstore_brange. For example, gstore_brange = '1, 8' sets nb_k = nb_kq = 8.
1638 : : !! However, gstore_brange has the lowest priority: if gstore_kfilter
1639 : : !! is set or kptgw/bdgw are provided, gstore_brange is ignored and nb_kq defaults to nband.
1640 : : !!
1641 : : !! Notes on use cases:
1642 : : !! For ZPR calculations, the current schemes are sufficient.
1643 : : !! For tasks comparing g between GWPT and FD, the current schemes are not very convenient.
1644 : : !! For instance, to compare g at k=q=Gamma for the first 8 bands of diamond,
1645 : : !! ideally we would restrict the calculation to nb_k = nb_kq = {1..8} and k=q=Gamma. But currently
1646 : : !!
1647 : : !! Using gstore_brange triggers unnecessary k-point calculations (ngkpt is usually a dense k-grid).
1648 : : !!
1649 : : !! Using kptgw and bdgw triggers unnecessary band calculations (nb_kq = nband is usually a big number).
1650 : : !!
1651 : : !! Potential improvement (?):
1652 : : !! Maybe we could give gstore_brange higher priority to control nb_kq(?). To avoid conflicts:
1653 : : !! If gstore_brange is provided and gstore_kfilter = "none", we do
1654 : : !! bstart_k = bdgw[1], nb_k = min(nband, bdgw[2] - bdgw[1])
1655 : : !! bstart_kq = gstore_brange[1], nb_kq = min(nband, gstore_brange[2] - gstore_brange[1])
1656 : : !! If gstore_brange is NOT provided and gstore_kfilter = "none", we do
1657 : : !! bstart_kq = bstart_k = bdgw[1], nb_kq = nb_k = max(nband, bdgw[2] - bdgw[1])
1658 : : !!
1659 : : !! SOURCE
1660 : :
1661 : 24 : subroutine gstore_distribute_spins(gstore, mband, brange_kq, brange_k, nproc_spin, comm_spin, comm)
1662 : :
1663 : : !Arguments ------------------------------------
1664 : : !scalars
1665 : : class(gstore_t),target,intent(inout) :: gstore
1666 : : integer,intent(in) :: mband, comm, brange_kq(2, gstore%nsppol), brange_k(2, gstore%nsppol)
1667 : : integer,intent(out) :: nproc_spin(gstore%nsppol), comm_spin(gstore%nsppol)
1668 : :
1669 : : !Local variables-------------------------------
1670 : : !scalars
1671 : : integer :: spin, my_rank, ierr, color, nsppol, nprocs
1672 : : !arrays
1673 : : integer :: buff_spin(2)
1674 : : !----------------------------------------------------------------------
1675 : :
1676 : 24 : nprocs = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
1677 : 24 : nsppol = gstore%nsppol
1678 : :
1679 : 24 : gstore%my_nspins = 0
1680 [ - + + - : 72 : ABI_MALLOC(gstore%brange_k_spin, (2, nsppol))
+ - + - -
+ - + -
+ ]
1681 [ - + + - : 48 : ABI_MALLOC(gstore%brange_kq_spin, (2, nsppol))
- + - + -
+ ]
1682 : :
1683 [ + + ]: 48 : do spin=1,nsppol
1684 : : ! NB: If MPI_UNDEFINED is passed as the colour value, the subgroup in which
1685 : : ! the calling MPI process will be placed is MPI_COMM_NULL
1686 : 24 : color = 1
1687 [ - + ]: 24 : if (nsppol == 2 .and. nprocs > 1) then
1688 : 0 : color = xmpi_undefined
1689 [ # # # # ]: 0 : if (spin == 1 .and. my_rank <= (nprocs - 1) / 2) color = 1
1690 [ # # # # ]: 0 : if (spin == 2 .and. my_rank > (nprocs - 1) / 2) color = 1
1691 : : end if
1692 : :
1693 : 24 : call xmpi_comm_split(comm, color, my_rank, comm_spin(spin), ierr)
1694 [ + - ]: 24 : if (comm_spin(spin) /= xmpi_comm_null) then
1695 : 24 : gstore%my_nspins = gstore%my_nspins + 1
1696 : 24 : buff_spin(gstore%my_nspins) = spin
1697 : : end if
1698 : :
1699 : 24 : nproc_spin(spin) = xmpi_comm_size(comm_spin(spin))
1700 : :
1701 : : ! Default values for brange at k, k+q from mband
1702 [ + + ]: 72 : gstore%brange_k_spin(:, spin) = [1, mband]
1703 [ + + ]: 72 : gstore%brange_kq_spin(:, spin) = [1, mband]
1704 : :
1705 : : ! Optionally take values from input brange_k, brange_kq
1706 [ + + + + : 139 : if (all(brange_k /= 0)) gstore%brange_k_spin(:, spin) = brange_k(:, spin)
+ + + + +
+ ]
1707 [ + + + + : 139 : if (all(brange_kq /= 0)) gstore%brange_kq_spin(:, spin) = brange_kq(:, spin)
+ + + + +
+ ]
1708 : :
1709 : : ! Validate against input mband.
1710 [ + - - + ]: 24 : ABI_CHECK_IRANGE(gstore%brange_k_spin(1, spin), 1, mband, "brange_k(1, spin)")
1711 [ + - - + ]: 24 : ABI_CHECK_IRANGE(gstore%brange_k_spin(2, spin), 1, mband, "brange_k(2, spin)")
1712 [ - + ]: 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)")
1713 : :
1714 [ + - - + ]: 24 : ABI_CHECK_IRANGE(gstore%brange_kq_spin(1, spin), 1, mband, "brange_k(1, spin)")
1715 [ + - - + ]: 24 : ABI_CHECK_IRANGE(gstore%brange_kq_spin(2, spin), 1, mband, "brange_k(2, spin)")
1716 [ - + ]: 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)")
1717 : : end do
1718 : :
1719 [ - + + - : 72 : ABI_MALLOC(gstore%my_spins, (gstore%my_nspins))
+ - + - -
+ - + -
+ ]
1720 [ - + + + ]: 72 : gstore%my_spins = buff_spin(1:gstore%my_nspins)
1721 [ - + + - : 384 : ABI_MALLOC(gstore%gqk, (gstore%my_nspins))
+ - + - -
+ - + - +
+ + + + +
+ + + ]
1722 : :
1723 : 24 : end subroutine gstore_distribute_spins
1724 : : !!***
1725 : :
1726 : : !----------------------------------------------------------------------
1727 : :
1728 : : !!****f* m_gstore/gstore_set_mpi_grid__
1729 : : !! NAME
1730 : : !! gstore_set_mpi_grid__
1731 : : !!
1732 : : !! FUNCTION
1733 : : !!
1734 : : !! INPUTS
1735 : : !!
1736 : : !! OUTPUT
1737 : : !!
1738 : : !! SOURCE
1739 : :
1740 : 24 : subroutine gstore_set_mpi_grid__(gstore, dtfil, nproc_spin, comm_spin)
1741 : :
1742 : : !Arguments ------------------------------------
1743 : : !scalars
1744 : : class(gstore_t),target,intent(inout) :: gstore
1745 : : type(datafiles_type),intent(in) :: dtfil
1746 : : integer,intent(in) :: nproc_spin(gstore%nsppol)
1747 : : integer,intent(inout) :: comm_spin(gstore%nsppol)
1748 : : !Local variables-------------------------------
1749 : : !scalars
1750 : : integer,parameter :: master = 0
1751 : : integer :: spin, my_is, np, my_rank, ierr, npp_bz, units(2), bstart_k, bstop_k, nb_k, bstart_kq, bstop_kq, nb_kq
1752 : : integer :: comm_cart, me_cart, dims(ndims)
1753 : : type(gqk_t),pointer :: gqk
1754 : : character(len=5000) :: msg
1755 : : character(len=10) :: order, priority
1756 : : character(len=fnlen) :: screen_filepath
1757 : : logical :: reorder, periods(ndims), keepdim(ndims)
1758 [ + + + + ]: 312 : type(kmesh_t) :: pp_mesh
1759 : 24 : type(gsphere_t) :: gsph_c
1760 : 24 : real(dp),allocatable :: qlwl(:,:)
1761 [ + + ]: 96 : type(hscr_t),target :: hscr
1762 : : !----------------------------------------------------------------------
1763 : :
1764 [ + + ]: 72 : units = [std_out, ab_out]
1765 : :
1766 : : associate (dtset => gstore%dtset)
1767 : 48 : my_rank = xmpi_comm_rank(gstore%comm)
1768 : :
1769 [ + + ]: 48 : do my_is=1,gstore%my_nspins
1770 : 24 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is)
1771 : 24 : gqk%spin = spin; gqk%natom3 = 3 * gstore%cryst%natom; gqk%cplex = 2
1772 : :
1773 : : ! Compute bstart_k and nb_k for this spin.
1774 : 24 : bstart_k = gstore%brange_k_spin(1, spin)
1775 : 24 : bstop_k = gstore%brange_k_spin(2, spin)
1776 : 24 : nb_k = gstore%brange_k_spin(2, spin) - gstore%brange_k_spin(1, spin) + 1
1777 : :
1778 : : ! Compute bstart_kq and nb_kq for this spin.
1779 : 24 : bstart_kq = gstore%brange_kq_spin(1, spin)
1780 : 24 : bstop_kq = gstore%brange_kq_spin(2, spin)
1781 : 24 : nb_kq = gstore%brange_kq_spin(2, spin) - gstore%brange_kq_spin(1, spin) + 1
1782 : :
1783 : : ! Here we set nb_k and nb_kq
1784 : 24 : gqk%nb_k = nb_k; gqk%bstart_k = bstart_k; gqk%bstop_k = bstop_k
1785 : 24 : gqk%nb_kq = nb_kq; gqk%bstart_kq = bstart_kq; gqk%bstop_kq = bstop_kq
1786 : :
1787 : : ! Store global shape of the q/k matrix for this spin.
1788 : 24 : gqk%glob_nq = gstore%glob_nq_spin(spin)
1789 : 48 : gqk%glob_nk = gstore%glob_nk_spin(spin)
1790 : : end do
1791 : :
1792 [ + + ]: 48 : do my_is=1,gstore%my_nspins
1793 : 24 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is)
1794 : :
1795 : : ! Init for sequential execution.
1796 : 24 : gqk%my_npert = gqk%natom3
1797 : 24 : gqk%qpt_comm%nproc = 1; gqk%kpt_comm%nproc = 1; gqk%pert_comm%nproc = 1; gqk%band_comm%nproc = 1
1798 : : ! NB: The communicators below are only used in GWPT.
1799 : 24 : gqk%bsum_comm%nproc = 1; gqk%pp_sum_comm%nproc = 1
1800 : :
1801 : 24 : np = nproc_spin(spin)
1802 : :
1803 [ + + ]: 24 : if (dtset%eph_task /= 17) then
1804 : : ! =============================
1805 : : ! For all eph_tasks except GWPT
1806 : : ! =============================
1807 : :
1808 [ + + + - : 126 : if (any(dtset%eph_np_pqbks /= 0)) then
- + ]
1809 : : ! Use parameters from input file. Need to perform sanity check though.
1810 : 0 : gqk%pert_comm%nproc = dtset%eph_np_pqbks(1)
1811 : 0 : gqk%qpt_comm%nproc = dtset%eph_np_pqbks(2)
1812 : 0 : gqk%band_comm%nproc = dtset%eph_np_pqbks(3)
1813 [ # # ]: 0 : ABI_CHECK(dtset%eph_np_pqbks(3) == 1, "Band parallelism not yet implemented in gstore")
1814 : 0 : gqk%kpt_comm%nproc = dtset%eph_np_pqbks(4)
1815 : : !gqk%spin_comm%nproc = dtset%eph_np_pqbks(5)
1816 : 0 : gqk%my_npert = gqk%natom3 / gqk%pert_comm%nproc
1817 [ # # ]: 0 : ABI_CHECK(gqk%my_npert > 0, "pert_comm_nproc cannot be greater than 3*natom.")
1818 [ # # ]: 0 : ABI_CHECK(mod(gqk%natom3, gqk%pert_comm%nproc) == 0, "pert_comm_nproc must divide 3*natom.")
1819 : :
1820 : : else
1821 : : ! Automatic grid generation (hopefully smart)
1822 : : ! Keep in mind that in gstore_compute, the first loop is over q-points
1823 : : ! in order to reduce the number of interpolations of the DFPT potentials in q-space
1824 : : ! hence the q-point parallelism is expected to be more efficient.
1825 : : ! On the other hand, the k-point parallelism and the perturbation parallelism
1826 : : ! allow one to reduce the memory requirements associated to the wavefunctions (kpt) and
1827 : : ! the scattering potentials in the supercell (perturbations).
1828 : : ! Here we try to optimize performance but it's clear that for large systems the user
1829 : : ! should specify dtset%eph_np_pqbks in the input file.
1830 : :
1831 : 5 : select case (dtset%eph_task)
1832 : : case (11)
1833 : 5 : priority = "qk"
1834 : : case (12, -12)
1835 : 0 : priority = "q"
1836 : : case (13)
1837 : 9 : priority = "q"
1838 : : case (14, 17)
1839 : 0 : priority = "kq"
1840 : : case (24)
1841 : 7 : priority = "qk"
1842 : : case default
1843 [ + - + - : 21 : ABI_ERROR(sjoin("Please register default priority for eph_task:", itoa(dtset%eph_task)))
+ - ]
1844 : : end select
1845 : :
1846 : 9 : select case (priority)
1847 : : case ("q")
1848 : 9 : order = "1"
1849 : : case ("k")
1850 : 0 : order = "2"
1851 : : case ("kq")
1852 : 0 : order = "21"
1853 : : case ("qk")
1854 : 12 : order = "12"
1855 : : case default
1856 [ + - - + : 21 : ABI_ERROR(sjoin("Wrong priority:", priority))
- ]
1857 : : end select
1858 : :
1859 [ + + ]: 21 : if (gqk%glob_nk == 1) order = "21"
1860 [ - + ]: 21 : if (gqk%glob_nq == 1) order = "12"
1861 : 21 : call xmpi_distrib_2d(np, order, gqk%glob_nq, gqk%glob_nk, gqk%qpt_comm%nproc, gqk%kpt_comm%nproc, ierr)
1862 [ - + ]: 21 : ABI_CHECK(ierr == 0, sjoin("Cannot distribute nprocs:", itoa(np), " with priority: ", priority))
1863 : : end if
1864 : :
1865 : : else if (dtset%eph_task == 17) then
1866 : : ! =========================
1867 : : ! MPI distribution for GWPT
1868 : : ! =========================
1869 : :
1870 [ + + + - : 21 : if (any(dtset%gwpt_np_wpqbks /= 0)) then
- + ]
1871 : : ! Use parameters from input file. Need to perform sanity check though.
1872 : 0 : gqk%pp_sum_comm%nproc = dtset%gwpt_np_wpqbks(1)
1873 : 0 : gqk%pert_comm%nproc = dtset%gwpt_np_wpqbks(2)
1874 : 0 : gqk%qpt_comm%nproc = dtset%gwpt_np_wpqbks(3)
1875 : 0 : gqk%bsum_comm%nproc = dtset%gwpt_np_wpqbks(4)
1876 : 0 : gqk%kpt_comm%nproc = dtset%gwpt_np_wpqbks(5)
1877 : : !gqk%spin_comm%nproc = dtset%gwpt_np_wpqbks(6)
1878 : 0 : gqk%my_npert = gqk%natom3 / gqk%pert_comm%nproc
1879 [ # # ]: 0 : ABI_CHECK(gqk%my_npert > 0, "pert_comm_nproc cannot be greater than 3*natom.")
1880 [ # # ]: 0 : ABI_CHECK(mod(gqk%natom3, gqk%pert_comm%nproc) == 0, "pert_comm_nproc must divide 3*natom.")
1881 : :
1882 : : else
1883 : : ! Automatic grid generation for GWPT (hopefully smart)
1884 : :
1885 : : ! In GWPT, the loop over pp-wavevectors is always in the BZ and is expected to be the most efficient
1886 : : ! Note however that the p-mesh is not necessarly equal to the k-mesh hence we have to read it from the SCR file.
1887 : : !npp_bz = product(get_diag(gstore%dtset%kptrlatt))
1888 : :
1889 : 3 : screen_filepath = dtfil%fnameabi_scr
1890 [ - + ]: 3 : ABI_CHECK(dtfil%fnameabi_scr /= ABI_NOFILE, "SCR file must be specified")
1891 [ - + ]: 3 : call get_hscr_qmesh_gsph(screen_filepath, gstore%dtset, gstore%cryst, hscr, pp_mesh, gsph_c, qlwl, comm_spin(spin))
1892 : 3 : npp_bz = pp_mesh%nbz
1893 : 3 : call hscr%free(); call pp_mesh%free(); call gsph_c%free()
1894 [ + - ]: 3 : ABI_SFREE(qlwl)
1895 : :
1896 [ + - ]: 3 : if (np <= npp_bz * gqk%natom3) then
1897 : : ! "Small" np. Give higher priority to npp_bz and then perturbations.
1898 : 3 : order = "12"
1899 : 3 : call xmpi_distrib_2d(np, order, npp_bz, gqk%natom3, gqk%pp_sum_comm%nproc, gqk%pert_comm%nproc, ierr)
1900 [ - + ]: 3 : ABI_CHECK(ierr == 0, sjoin("Cannot distribute nprocs:", itoa(np), " with priority: ", priority, " Please use gwpt_np_wpqbks"))
1901 : : else
1902 : : ! "Large" np. Activate parallelism over k-points or q-points depending on gstore input variables.
1903 : 0 : ABI_ERROR("Your number of MPI procs is too large for the automatic GWPT parallelization. Please use gwpt_np_wpqbks")
1904 : : end if
1905 : : end if
1906 : :
1907 : : else
1908 : : ABI_ERROR(sjoin("Invalid eph_task", itoa(dtset%eph_task)))
1909 : : end if
1910 : :
1911 : : ! Consistency check.
1912 [ - + ]: 24 : if (gqk%pert_comm%nproc * gqk%qpt_comm%nproc * gqk%kpt_comm%nproc * gqk%band_comm%nproc * &
1913 : 24 : gqk%bsum_comm%nproc * gqk%pp_sum_comm%nproc /= nproc_spin(spin)) then
1914 : : write(msg, "(a,i0,3a, 7(a,1x,i0))") &
1915 : 0 : "Cannot create Cartesian grid with total nproc: ", nproc_spin(spin), ch10, &
1916 : 0 : "Idle processes are not supported. The product of the `nproc_*` vars should be equal to nproc.", ch10, &
1917 : 0 : "qpt_nproc (", gqk%qpt_comm%nproc, ") x kpt_nproc (", gqk%kpt_comm%nproc, ") x pert_nproc", gqk%pert_comm%nproc, &
1918 : 0 : "x band_nproc (", gqk%band_comm%nproc, "x bsum_nproc (", gqk%bsum_comm%nproc, ") x psum_nproc (", gqk%pp_sum_comm%nproc, &
1919 : 0 : ") != ", nproc_spin(spin)
1920 : 0 : ABI_ERROR(msg)
1921 : : end if
1922 : :
1923 : : end do ! my_is
1924 : :
1925 : : ! For each spin treated by this rank, create Cartesian communicator of rank ndims.
1926 : 24 : periods(:) = .False.; reorder = .False.
1927 : :
1928 [ + + ]: 48 : do my_is=1,gstore%my_nspins
1929 : 24 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is)
1930 : :
1931 : : ! TODO: Should change order for GWPT.
1932 : : dims = [gqk%qpt_comm%nproc, gqk%kpt_comm%nproc, gqk%pert_comm%nproc, gqk%band_comm%nproc, &
1933 [ + + ]: 168 : gqk%bsum_comm%nproc, gqk%pp_sum_comm%nproc]
1934 : :
1935 : : ! Note comm_spin(spin).
1936 : 24 : gqk%comm = xcomm_from_mpi_int(comm_spin(spin))
1937 [ + + ]: 168 : gqk%coords_qkpb_sumbp = 0
1938 : :
1939 : : #ifdef HAVE_MPI
1940 : 24 : call MPI_CART_CREATE(gqk%comm, ndims, dims, periods, reorder, comm_cart, ierr)
1941 : : ! Find the index and coordinates of the current processor
1942 : 24 : call MPI_COMM_RANK(comm_cart, me_cart, ierr)
1943 : 24 : call MPI_CART_COORDS(comm_cart, me_cart, ndims, gqk%coords_qkpb_sumbp, ierr)
1944 : :
1945 : : ! Communicator for q-points in g(k,q)
1946 : 24 : keepdim = .False.; keepdim(1) = .True.; call gqk%qpt_comm%from_cart_sub(comm_cart, keepdim)
1947 : : ! Communicator for k-points in g(k,q)
1948 : 24 : keepdim = .False.; keepdim(2) = .True.; call gqk%kpt_comm%from_cart_sub(comm_cart, keepdim)
1949 : : ! Communicator for the (qpt, kpt) 2D grid
1950 : 24 : keepdim = .False.; keepdim(1) = .True.; keepdim(2) = .True.; call gqk%qpt_kpt_comm%from_cart_sub(comm_cart, keepdim)
1951 : : ! Communicator for perturbations in g(k,q)
1952 : 24 : keepdim = .False.; keepdim(3) = .True.; call gqk%pert_comm%from_cart_sub(comm_cart, keepdim)
1953 : : ! 2d Communicator for the (qpt, pert) grid
1954 : 24 : keepdim = .False.; keepdim(1) = .True.; keepdim(3) = .True.; call gqk%qpt_pert_comm%from_cart_sub(comm_cart, keepdim)
1955 : : ! Communicator for band in g(k,q)
1956 : 24 : keepdim = .False.; keepdim(4) = .True.; call gqk%band_comm%from_cart_sub(comm_cart, keepdim)
1957 : : ! Communicator for bsum (GWPT mode)
1958 : 24 : keepdim = .False.; keepdim(5) = .True.; call gqk%bsum_comm%from_cart_sub(comm_cart, keepdim)
1959 : : ! Communicator for pp_sum (GWPT mode)
1960 : 24 : keepdim = .False.; keepdim(6) = .True.; call gqk%pp_sum_comm%from_cart_sub(comm_cart, keepdim)
1961 : : ! 2d Communicator for the (pert, pp_sum) 2D grid
1962 : 24 : keepdim = .False.; keepdim(3) = .True.; keepdim(6) = .True.; call gqk%pert_ppsum_comm%from_cart_sub(comm_cart, keepdim)
1963 : : ! 3d Communicator for the (pert, pp_sum, band_sum) 3D grid (GWPT mode)
1964 : 24 : keepdim = .False.; keepdim(3) = .True.; keepdim(5) = .True.; keepdim(6) = .True.
1965 : 24 : call gqk%pert_ppsum_bsum_comm%from_cart_sub(comm_cart, keepdim)
1966 : 24 : call xmpi_comm_free(comm_cart)
1967 : : #endif
1968 : :
1969 : : ! Distribute perturbations inside pert_comm using block distribution.
1970 [ - + ]: 24 : call xmpi_split_block(gqk%natom3, gqk%pert_comm%value, gqk%my_npert, gqk%my_pertcases)
1971 : 24 : gqk%my_pert_start = gqk%my_pertcases(1)
1972 : :
1973 : 24 : call wrtout(units, sjoin("P qpt_comm can use shmem:", yesno(gqk%qpt_comm%can_use_shmem())))
1974 : 24 : call wrtout(units, sjoin("P kpt_comm can use shmem:", yesno(gqk%kpt_comm%can_use_shmem())))
1975 : 24 : call wrtout(units, sjoin("P bsum_comm can use shmem:", yesno(gqk%bsum_comm%can_use_shmem())))
1976 : 48 : call wrtout(units, sjoin("P pp_sum_comm can use shmem:", yesno(gqk%pp_sum_comm%can_use_shmem())), newlines=1)
1977 : : end do ! my_is
1978 : :
1979 [ + - + + ]: 96 : if (my_rank == master) call gstore%print([std_out, ab_out])
1980 : :
1981 : : end associate
1982 : :
1983 [ - + - + : 24 : end subroutine gstore_set_mpi_grid__
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- - + - +
- + - + -
+ - + - +
- + - + ]
1984 : : !!***
1985 : :
1986 : : !----------------------------------------------------------------------
1987 : :
1988 : : !!****f* m_gstore/gstore_print
1989 : : !! NAME
1990 : : !! gstore_print
1991 : : !!
1992 : : !! FUNCTION
1993 : : !! Print info on the gstore object.
1994 : : !!
1995 : : !! INPUTS
1996 : : !! units: Unit numbers.
1997 : : !! [header]: header string
1998 : : !! [prtvol]: Verbosity level.
1999 : : !!
2000 : : !! SOURCE
2001 : :
2002 [ - + ]: 32 : subroutine gstore_print(gstore, units, header, prtvol)
2003 : :
2004 : : !Arguments ------------------------------------
2005 : : class(gstore_t),intent(inout) :: gstore
2006 : : integer,intent(in) :: units(:)
2007 : : character(len=*),optional,intent(in) :: header
2008 : : integer,optional,intent(in) :: prtvol
2009 : :
2010 : : !Local variables ------------------------------
2011 : : integer,parameter :: max_nk=10
2012 : : integer :: my_is, my_prtvol, ik_calc, ik_bz, ik_ibz !, iq_calc, iq_bz, iq_ibz
2013 : : real(dp) :: rtot_num_g
2014 : : character(len=500) :: msg
2015 : : !----------------------------------------------------------------------
2016 : :
2017 [ - + ]: 32 : my_prtvol = 0; if (present(prtvol)) my_prtvol = prtvol
2018 : :
2019 [ - + ]: 32 : if (present(header)) then
2020 : 0 : call wrtout(units, header)
2021 : : else
2022 : 32 : call wrtout(units, " === Gstore parameters ===")
2023 : : end if
2024 : :
2025 : 32 : call wrtout(units, sjoin(" kzone:", gstore%kzone))
2026 : 32 : call wrtout(units, sjoin(" kfilter:", gstore%kfilter))
2027 : 32 : call wrtout(units, sjoin(" nkibz:", itoa(gstore%nkibz)))
2028 : 32 : call wrtout(units, sjoin(" nkbz:", itoa(gstore%nkbz)))
2029 : 32 : call wrtout(units, sjoin(" glob_nk_spin:", ltoa(gstore%glob_nk_spin)))
2030 : 32 : call wrtout(units, sjoin(" qzone:", gstore%qzone))
2031 : 32 : call wrtout(units, sjoin(" nqibz:", itoa(gstore%nqibz)))
2032 : 32 : call wrtout(units, sjoin(" nqbz:", itoa(gstore%nqbz)))
2033 : 32 : call wrtout(units, sjoin(" glob_nq_spin:", ltoa(gstore%glob_nq_spin)))
2034 : 32 : call wrtout(units, sjoin(" kptopt:", itoa(gstore%ebands%kptopt)))
2035 : 32 : call wrtout(units, sjoin(" qptopt:", itoa(gstore%qptopt)))
2036 : 32 : call wrtout(units, sjoin(" has_used_lgk:", itoa(gstore%has_used_lgk)))
2037 : 32 : call wrtout(units, sjoin(" has_used_lgq:", itoa(gstore%has_used_lgq)))
2038 : 32 : call wrtout(units, sjoin(" with_vk:", itoa(gstore%with_vk)))
2039 : :
2040 [ + + ]: 64 : do my_is=1,gstore%my_nspins
2041 : 32 : associate (spin => gstore%my_spins(my_is), gqk => gstore%gqk(my_is))
2042 : 32 : call wrtout(units, sjoin(" gqk_cplex:", itoa(gqk%cplex)), pre_newlines=1)
2043 : 32 : call wrtout(units, sjoin(" gqk_bstart_k:", itoa(gqk%bstart_k)))
2044 : 32 : call wrtout(units, sjoin(" gqk_bstart_kq:", itoa(gqk%bstart_kq)))
2045 : 32 : call wrtout(units, sjoin(" gqk_bstop_k:", itoa(gqk%bstop_k)))
2046 : 32 : call wrtout(units, sjoin(" gqk_bstop_kq:", itoa(gqk%bstop_kq)))
2047 : 32 : call wrtout(units, sjoin(" gqk_nb_k:", itoa(gqk%nb_k)))
2048 : 32 : call wrtout(units, sjoin(" gqk_nb_kq:", itoa(gqk%nb_kq)))
2049 : 32 : rtot_num_g = (one * gqk%nb_kq * gqk%nb_k) * (gqk%glob_nk * gqk%glob_nq * one) * gqk%natom3
2050 : : !call wrtout(units, sjoin(" total number of g(k,q) elements:", ftoa(rtot_num_g)))
2051 : 32 : call wrtout(units, sjoin("P gqk_my_npert:", itoa(gqk%my_npert)))
2052 : 32 : call wrtout(units, sjoin("P gqk_my_nk:", itoa(gqk%my_nk)))
2053 : 32 : call wrtout(units, sjoin("P gqk_my_nq:", itoa(gqk%my_nq)))
2054 : 32 : call wrtout(units, sjoin(ch10, " === MPI distribution ==="))
2055 : 32 : call wrtout(units, sjoin("P Number of CPUs for parallelism over perturbations: ", itoa(gqk%pert_comm%nproc)))
2056 : 32 : call wrtout(units, sjoin("P Number of perturbations treated by this CPU: ", itoa(gqk%my_npert)))
2057 : 32 : call wrtout(units, sjoin("P Number of CPUs for parallelism over q-points: ", itoa(gqk%qpt_comm%nproc)))
2058 : 32 : call wrtout(units, sjoin("P Number of CPUs for parallelism over k-points: ", itoa(gqk%kpt_comm%nproc)))
2059 : : ! This only for GWPT calculations.
2060 [ - + ]: 32 : if (gqk%bsum_comm%nproc /= 1) then
2061 : 0 : call wrtout(units, sjoin("P Number of CPUs for parallelism over band summation: ", itoa(gqk%bsum_comm%nproc)))
2062 : : end if
2063 [ - + ]: 32 : if (gqk%pp_sum_comm%nproc /= 1) then
2064 : 0 : call wrtout(units, sjoin("P Number of CPUs for parallelism over wavevector summation: ", itoa(gqk%pp_sum_comm%nproc)))
2065 : : end if
2066 : :
2067 : : ! Print k-points
2068 : 32 : call wrtout(units, " k-points included in gstore:")
2069 [ + + ]: 226 : do ik_calc=1,gqk%glob_nk
2070 : 211 : ik_bz = gstore%kglob2bz(ik_calc, spin)
2071 : 211 : ik_ibz = gstore%kbz2ibz(1, ik_bz)
2072 : 211 : call wrtout(units, sjoin(itoa(ik_calc), ":", ktoa(gstore%kbz(:, ik_bz))))
2073 [ + + + - ]: 226 : if (ik_calc > max_nk .and. my_prtvol == 0) then
2074 : 17 : call wrtout(units, sjoin(" Max", itoa(max_nk), " k-points will be written. Use prtvol > 0 to print all of them."))
2075 : 17 : exit
2076 : : end if
2077 : : end do
2078 : : !call wrtout(units, " ")
2079 : :
2080 : : ! Print q-points
2081 : : !call wrtout(units, " q-points included in gstore:")
2082 : : !do iq_calc=1,gqk%glob_nq
2083 : : ! iq_bz = gstore%qglob2bz(iq_calc, spin)
2084 : : ! iq_ibz = gstore%qbz2ibz(1, iq_bz)
2085 : : ! call wrtout(units, sjoin(itoa(iq_calc), ":", ktoa(gstore%qbz(:, iq_bz))))
2086 : : ! if (iq_calc > max_nk .and. my_prtvol == 0) then
2087 : : ! call wrtout(units, sjoin(" Max", itoa(max_nk), " q-points will be written. Use prtvol > 0 to print all of them."))
2088 : : ! exit
2089 : : ! end if
2090 : : !end do
2091 : :
2092 : : ! Print memory
2093 [ - + ]: 32 : if (allocated(gqk%my_g2)) then
2094 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for |g|^2 array: ',ABI_MEM_MB(gqk%my_g2),' [mb] <<< mem'
2095 : 0 : call wrtout(units, msg)
2096 : : end if
2097 [ + + - + ]: 32 : if (gqk%has_both_g .and. associated(gqk%my_g2_ks)) then
2098 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for |g_KS|^2 array: ',ABI_MEM_MB(gqk%my_g2_ks),' [mb] <<< mem'
2099 : 0 : call wrtout(units, msg)
2100 : : end if
2101 [ - + ]: 32 : if (allocated(gqk%my_g)) then
2102 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for g array: ',ABI_MEM_MB(gqk%my_g),' [Mb] <<< MEM'
2103 : 0 : call wrtout(units, msg)
2104 : : end if
2105 [ + + - + ]: 32 : if (gqk%has_both_g .and. associated(gqk%my_g_ks)) then
2106 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for g_KS array: ',ABI_MEM_MB(gqk%my_g_ks),' [Mb] <<< MEM'
2107 : 0 : call wrtout(units, msg)
2108 : : end if
2109 [ - + ]: 32 : if (allocated(gqk%my_gdw2)) then
2110 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for gDW^2 array: ',ABI_MEM_MB(gqk%my_gdw2),' [mb] <<< mem'
2111 : : end if
2112 [ + + - + ]: 32 : if (gqk%has_both_g .and. associated(gqk%my_gdw2_ks)) then
2113 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for gDW^2_KS array: ',ABI_MEM_MB(gqk%my_gdw2_ks),' [mb] <<< mem'
2114 : : end if
2115 : :
2116 [ - + ]: 32 : if (allocated(gqk%vnk_cart_ibz)) then
2117 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for vnk_cart_ibz: ',ABI_MEM_MB(gqk%vnk_cart_ibz),' [Mb] <<< MEM'
2118 : 0 : call wrtout(units, msg)
2119 : : end if
2120 [ - + ]: 32 : if (allocated(gqk%vnk_mat_cart_ibz)) then
2121 [ # # ]: 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'
2122 : 0 : call wrtout(units, msg)
2123 : : end if
2124 [ - + ]: 64 : if (allocated(gqk%my_iv1p_comm)) then
2125 [ # # ]: 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'
2126 : : end if
2127 : : end associate
2128 : : end do
2129 : :
2130 [ - + ]: 32 : if (my_prtvol > 0) then
2131 : 0 : call gstore%ebands%print(units, header="Electron bands in GSTORE", prtvol=my_prtvol)
2132 : : end if
2133 : 32 : call wrtout(units, " ")
2134 : :
2135 : 32 : end subroutine gstore_print
2136 : : !!***
2137 : :
2138 : : !!****f* m_gstore/gstore_check_little_group
2139 : : !! NAME
2140 : : !! gstore_check_little_group
2141 : : !!
2142 : : !! FUNCTION
2143 : : !! Check consistency between little group options read from file and from input.
2144 : : !!
2145 : : !! INPUTS
2146 : : !!
2147 : : !! SOURCE
2148 : :
2149 : 7 : integer function gstore_check_little_group(gstore, dtset, msg) result(ierr)
2150 : :
2151 : : !Arguments ------------------------------------
2152 : : class(gstore_t),intent(in) :: gstore
2153 : : type(dataset_type),intent(in) :: dtset
2154 : : character(len=*),intent(out) :: msg
2155 : : !----------------------------------------------------------------------
2156 : :
2157 : 7 : ierr = 0; msg = ""
2158 : :
2159 [ - + ]: 7 : if (dtset%gstore_use_lgk /= 0) then
2160 : : ! Cannot use IBZ_k if we have used IBZ_q.
2161 [ # # ]: 0 : if (gstore%has_used_lgq /= 0) then
2162 [ # # # # ]: 0 : msg = sjoin("Input var gstore_use_lgq: ", itoa(dtset%gstore_use_lgq), ", but GSTORE file has:", itoa(gstore%has_used_lgq))
2163 : 0 : ABI_ERROR_NOSTOP(msg, ierr)
2164 : : end if
2165 : : ! Using IBZ_k when GSTORE has full BZ is OK but inefficient.
2166 [ # # ]: 0 : if (gstore%has_used_lgk == 0) then
2167 [ # # # # ]: 0 : msg = sjoin("Input var gstore_use_lgk: ", itoa(dtset%gstore_use_lgk), ", but GSTORE file has:", itoa(gstore%has_used_lgk))
2168 : 0 : ABI_COMMENT(msg)
2169 : : end if
2170 : : end if
2171 : :
2172 [ - + ]: 7 : if (dtset%gstore_use_lgq /= 0) then
2173 : : ! Cannot use IBZ_q if we have used IBZ_k.
2174 [ # # ]: 0 : if (gstore%has_used_lgk /= 0) then
2175 [ # # # # ]: 0 : msg = sjoin("Input var gstore_use_lgk: ", itoa(dtset%gstore_use_lgk), ", but GSTORE file has:", itoa(gstore%has_used_lgk))
2176 : 0 : ABI_ERROR_NOSTOP(msg, ierr)
2177 : : end if
2178 : : ! Using IBZ_q when GSTORE has full BZ is OK but inefficient.
2179 [ # # ]: 0 : if (gstore%has_used_lgq == 0) then
2180 [ # # # # ]: 0 : msg = sjoin("Input var gstore_use_lgq: ", itoa(dtset%gstore_use_lgq), ", but GSTORE file has:", itoa(gstore%has_used_lgq))
2181 : 0 : ABI_COMMENT(msg)
2182 : : end if
2183 : : end if
2184 : :
2185 [ + - ]: 7 : end function gstore_check_little_group
2186 : : !!***
2187 : :
2188 : : !----------------------------------------------------------------------
2189 : :
2190 : : !!****f* m_gstore/gstore_malloc__
2191 : : !! NAME
2192 : : !! gstore_malloc__
2193 : : !!
2194 : : !! FUNCTION
2195 : : !! Allocate local buffers once the MPI grid has been initialized.
2196 : : !!
2197 : : !! INPUTS
2198 : : !!
2199 : : !! OUTPUT
2200 : : !!
2201 : : !! SOURCE
2202 : :
2203 : 24 : subroutine gstore_malloc__(gstore, with_cplex, has_both_g, max_nq, qglob2bz, max_nk, kglob2bz, qbz2ibz, kbz2ibz)
2204 : :
2205 : : !Arguments ------------------------------------
2206 : : !scalars
2207 : : class(gstore_t),target,intent(inout) :: gstore
2208 : : integer,intent(in) :: with_cplex, max_nq, max_nk
2209 : : logical,intent(in) :: has_both_g
2210 : : integer,intent(in) :: qglob2bz(max_nq, gstore%nsppol), kglob2bz(max_nk, gstore%nsppol)
2211 : : integer,intent(in) :: qbz2ibz(6, gstore%nqbz), kbz2ibz(6, gstore%nkbz)
2212 : :
2213 : : !Local variables-------------------------------
2214 : : !scalars
2215 : : integer :: my_is, ierr, my_iq, my_ik, iq_glob, iq_bz, ik_glob, ik_bz
2216 : : integer :: ik_ibz, isym_k, trev_k, tsign_k, g0_k(3), nb_k, nb_kq
2217 : : logical :: isirr_k
2218 : : real(dp) :: mem_mb
2219 : : type(gqk_t), pointer :: gqk
2220 : : !----------------------------------------------------------------------
2221 : :
2222 [ - + ]: 24 : ABI_CHECK(with_cplex >= 0 .and. with_cplex <= 2, sjoin("Invalid with_cplex:", itoa(with_cplex)))
2223 : 24 : gstore%with_cplex = with_cplex
2224 : :
2225 [ + + ]: 48 : do my_is=1,gstore%my_nspins
2226 : 24 : associate (spin => gstore%my_spins(my_is))
2227 : 24 : gqk => gstore%gqk(my_is)
2228 : 24 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
2229 : 24 : gqk%has_both_g = has_both_g
2230 : :
2231 : : ! Split q-points and transfer symmetry tables.
2232 : : ! Note that glob_nq and glob_nk does not necessarily correspond to the size of the BZ
2233 : : ! First of all we have to consider kzone
2234 : : ! Even if kzone == "bz" we may have filtered the wavevectors e.g. Fermi surface.
2235 : 24 : call xmpi_split_block(gqk%glob_nq, gqk%qpt_comm%value, gqk%my_nq, gqk%my_q2glob)
2236 [ - + ]: 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"))
2237 : 24 : gqk%my_qstart = gqk%my_q2glob(1)
2238 : :
2239 [ - + + - : 72 : ABI_MALLOC(gqk%my_q2ibz, (6, gqk%my_nq))
+ - + - -
+ - + -
+ ]
2240 [ - + + - : 72 : ABI_MALLOC(gqk%my_q2bz, (gqk%my_nq))
+ - + - -
+ - + -
+ ]
2241 : :
2242 [ + + ]: 2330 : do my_iq=1,gqk%my_nq
2243 : 2306 : iq_glob = my_iq + gqk%my_qstart - 1
2244 : 2306 : iq_bz = qglob2bz(iq_glob, spin)
2245 [ + + ]: 16142 : gqk%my_q2ibz(:, my_iq) = qbz2ibz(:, iq_bz)
2246 : 2330 : gqk%my_q2bz(my_iq) = iq_bz
2247 : : end do
2248 : :
2249 : : ! Split k-points and transfer symmetry tables
2250 [ - + ]: 24 : call xmpi_split_block(gqk%glob_nk, gqk%kpt_comm%value, gqk%my_nk, gqk%my_k2glob)
2251 [ - + ]: 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"))
2252 : 24 : gqk%my_kstart = gqk%my_k2glob(1)
2253 : :
2254 [ - + + - : 72 : ABI_MALLOC(gqk%my_k2ibz, (6, gqk%my_nk))
+ - + - -
+ - + -
+ ]
2255 : : !ABI_MALLOC(gqk%my_k2bz, (gqk%my_nk))
2256 [ - + + - : 72 : ABI_MALLOC(gqk%my_kpts, (3, gqk%my_nk))
+ - + - -
+ - + -
+ ]
2257 [ - + + - : 72 : ABI_MALLOC(gqk%my_wtk, (gqk%my_nk))
+ - + - -
+ - + -
+ ]
2258 : :
2259 [ + + ]: 1020 : do my_ik=1,gqk%my_nk
2260 : 996 : ik_glob = my_ik + gqk%my_kstart - 1
2261 : 996 : ik_bz = kglob2bz(ik_glob, spin)
2262 [ + + ]: 6972 : gqk%my_k2ibz(:, my_ik) = kbz2ibz(:, ik_bz)
2263 : : !gqk%my_k2bz(my_ik) = ik_bz
2264 : :
2265 : 996 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
2266 [ + + ]: 3984 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5, my_ik)
2267 : : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
2268 [ - + ]: 996 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
2269 : :
2270 : : ! Note symrel^T convention for k
2271 [ + + + + : 30876 : gqk%my_kpts(:, my_ik) = tsign_k * matmul(transpose(gstore%cryst%symrel(:,:,isym_k)), gstore%kibz(:, ik_ibz)) + g0_k
+ + + + +
+ + - + -
+ + ]
2272 : :
2273 : 24 : select case(gstore%kzone)
2274 : : case ("ibz")
2275 : 18 : gqk%my_wtk(my_ik) = gstore%ebands%wtk(ik_ibz)
2276 : : case ("bz")
2277 [ + + - ]: 996 : gqk%my_wtk(my_ik) = one / gstore%nkbz
2278 : : end select
2279 : : end do
2280 : :
2281 : : ! Allocate storage for MPI-distributed e-ph matrix elements.
2282 [ - + + + ]: 48 : if (with_cplex > 0) then
2283 : 16 : mem_mb = (one * with_cplex * gqk%my_npert) * gqk%my_nq * gqk%my_nk * nb_kq * nb_k * eight * b2Mb
2284 : 16 : call wrtout(std_out, sjoin(" Local memory for e-ph matrix elements:", ftoa(mem_mb, fmt="f8.1"), " [Mb] <<< MEM"))
2285 : :
2286 : : ! The initialization with zero is important as not all the g are computed when we filter in k-space.
2287 : : ! Abinit postprocessing tools will operate of the full my_g array
2288 : : ! and we don't want to trigger floating point exceptions.
2289 : 6 : select case (with_cplex)
2290 : : case (1)
2291 [ - + + - : 42 : ABI_MALLOC_OR_DIE(gqk%my_g2, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - -
+ + - -
+ ]
2292 [ + + + + : 76305 : gqk%my_g2 = zero
+ + + + +
+ ]
2293 : :
2294 : 6 : gqk%my_g2_ks => gqk%my_g2
2295 [ + + ]: 6 : if (gqk%has_both_g) then
2296 [ - + + - : 35 : ABI_MALLOC_OR_DIE(gqk%my_g2_ks, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - ]
2297 [ + + + + : 40203 : gqk%my_g2_ks = zero
+ + + + +
+ ]
2298 : : end if
2299 : : case (2)
2300 [ - + + - : 70 : ABI_MALLOC_OR_DIE(gqk%my_g, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - -
+ + - -
+ ]
2301 [ + + + + : 4224533 : gqk%my_g = zero
+ + + + +
+ ]
2302 : :
2303 : 10 : gqk%my_g_ks => gqk%my_g
2304 [ + + ]: 10 : if (gqk%has_both_g) then
2305 : : !call wrtout(std_out, "Allocating my_g_ks") !; stop
2306 [ - + + - : 7 : ABI_MALLOC_OR_DIE(gqk%my_g_ks, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - ]
2307 [ + + + + : 18182 : gqk%my_g_ks = zero
+ + + + +
+ ]
2308 : : end if
2309 : : case default
2310 [ + + - ]: 16 : ABI_ERROR(sjoin("Wrong with_cplex:", itoa(with_cplex)))
2311 : : end select
2312 : :
2313 : : ! Allocate storage for MPI-distributed dH/dk matrix elements.
2314 [ + - ]: 16 : if (any(gstore%with_vk == [1, 2])) then
2315 : 16 : mem_mb = 3 * gqk%nb_k * gqk%my_nk * eight * b2Mb
2316 : 16 : call wrtout(std_out, sjoin(" Memory for diagonal vnk_cart_ibz:", ftoa(mem_mb, fmt="f8.1"), " [Mb] <<< MEM"))
2317 [ - + + - : 64 : ABI_MALLOC_OR_DIE(gqk%vnk_cart_ibz, (3, gqk%nb_k, gstore%nkibz), ierr)
- + + - +
- + - + -
+ - - + +
- - + ]
2318 [ + + + + : 2087 : gqk%vnk_cart_ibz = zero
+ + ]
2319 : : end if
2320 : :
2321 [ - + ]: 16 : if (gstore%with_vk == 2) then
2322 : 0 : mem_mb = two * 3 * gqk%nb_k**2 * gqk%my_nk * eight * b2Mb
2323 : 0 : call wrtout(std_out, sjoin(" Memory for vnk_mat_cart_ibz:", ftoa(mem_mb, fmt="f8.1"), " [Mb] <<< MEM"))
2324 [ # # # # : 0 : ABI_MALLOC_OR_DIE(gqk%vnk_mat_cart_ibz, (2, 3, gqk%nb_k, gqk%nb_k, gstore%nkibz), ierr)
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
2325 [ # # # # : 0 : gqk%vnk_mat_cart_ibz = zero
# # # # #
# ]
2326 : : end if
2327 : : end if
2328 : :
2329 : : end associate
2330 : : end do ! my_is
2331 : :
2332 : 24 : end subroutine gstore_malloc__
2333 : : !!***
2334 : :
2335 : : !----------------------------------------------------------------------
2336 : :
2337 : : !!****f* m_gstore/gstore_filter_fs_tetra__
2338 : : !! NAME
2339 : : !! gstore_filter_fs_tetra__
2340 : : !!
2341 : : !! FUNCTION
2342 : : !! Compute delta(e_k - e_F) with the tetrahedron method. Use weights to filter k-points.
2343 : : !! Include only those q-points such that there exists at least one k on the FS with k + q on the FS.
2344 : : !! Also, store and precompute gstore%delta_ef_kibz_spin(max_nb, gstore%nkibz, nsppol)
2345 : : !! to be used to filter inside gstore%compute.
2346 : : !!
2347 : : !! INPUTS
2348 : : !!
2349 : : !! OUTPUT
2350 : : !!
2351 : : !! SOURCE
2352 : :
2353 : 0 : subroutine gstore_filter_fs_tetra__(gstore, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
2354 : :
2355 : : !Arguments ------------------------------------
2356 : : !scalars
2357 : : class(gstore_t),intent(inout) :: gstore
2358 : : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2359 : : integer,intent(in) :: kibz2bz(gstore%nkibz)
2360 : : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2361 : : integer,intent(out) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2362 : :
2363 : : !Local variables-------------------------------
2364 : : !scalars
2365 : : integer,parameter :: tetra_opt0 = 0
2366 : : integer :: nsppol, ierr, cnt, spin, band, ib, ii, max_nb, all_nproc, my_rank, comm
2367 : : integer :: ik_bz, ik_ibz, iflag, nk_in_star
2368 : : real(dp) :: max_occ
2369 : : character(len=80) :: error_string
2370 : 0 : type(htetra_t) :: ktetra
2371 : : !arrays
2372 : 0 : integer,allocatable :: indkk(:), kstar_bz_inds(:)
2373 : : real(dp):: rlatt(3,3), klatt(3,3), delta_theta_ef(2) !, qpt(3)
2374 : 0 : real(dp),allocatable :: eig_ibz(:)
2375 : : !----------------------------------------------------------------------
2376 : :
2377 : : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2378 : :
2379 : 0 : comm = gstore%comm; all_nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
2380 : 0 : nsppol = gstore%nsppol
2381 : :
2382 : : !ABI_CHECK(gstore%same_nbands(msg), sjoin("VarPEq requires nb_k == nb_kq.", msg))
2383 : :
2384 : : ! Use the tetrahedron method to filter k- and k+q points on the FS in metals
2385 : : ! and define gstore%brange_k_spin automatically.
2386 : 0 : call wrtout(std_out, sjoin(" Filtering k-points using:", gstore%kfilter))
2387 : :
2388 : : ! NB: here we precompute brange_k_spin
2389 : : ! nb_kq == nb_k when FS filtering with tetra is used.
2390 : 0 : call ebands%get_bands_e0(ebands%fermie, gstore%brange_k_spin, ierr)
2391 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Error in ebands_get_bands_e0")
2392 [ # # # # : 0 : gstore%brange_kq_spin = gstore%brange_k_spin
# # # # #
# # # # #
# # ]
2393 : :
2394 [ # # # # : 0 : ABI_MALLOC(indkk, (gstore%nkbz))
# # # # #
# # # ]
2395 [ # # ]: 0 : indkk(:) = gstore%kbz2ibz(1, :)
2396 : :
2397 [ # # # # ]: 0 : rlatt = ebands%kptrlatt; call matr3inv(rlatt, klatt)
2398 : : call ktetra%init(indkk, gstore%cryst%gprimd, klatt, gstore%kbz, gstore%nkbz, gstore%kibz, gstore%nkibz, &
2399 [ # # # # : 0 : ierr, error_string, gstore%comm)
# # # # #
# ]
2400 [ # # ]: 0 : ABI_CHECK(ierr == 0, error_string)
2401 : :
2402 [ # # # # : 0 : ABI_MALLOC(eig_ibz, (gstore%nkibz))
# # # # #
# # # ]
2403 : 0 : max_occ = two / (ebands%nspinor * nsppol)
2404 [ # # # # ]: 0 : select_kbz_spin = 0
2405 : :
2406 [ # # ]: 0 : max_nb = maxval(gstore%brange_k_spin(2, :) - gstore%brange_k_spin(1, :) + 1)
2407 [ # # # # : 0 : ABI_CALLOC(gstore%delta_ef_kibz_spin, (max_nb, gstore%nkibz, gstore%nsppol))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
2408 : :
2409 : : cnt = 0
2410 [ # # ]: 0 : do spin=1,nsppol
2411 [ # # ]: 0 : do band=gstore%brange_k_spin(1, spin), gstore%brange_k_spin(2, spin)
2412 : 0 : ib = band - gstore%brange_k_spin(1, spin) + 1
2413 [ # # # # : 0 : eig_ibz = ebands%eig(band, :, spin)
# # # # ]
2414 : :
2415 [ # # ]: 0 : do ik_ibz=1,gstore%nkibz
2416 [ # # ]: 0 : cnt = cnt + 1; if (mod(cnt, all_nproc) /= my_rank) cycle ! MPI parallelism inside comm
2417 : :
2418 : : call ktetra%get_onewk_wvals(ik_ibz, tetra_opt0, 1, [ebands%fermie], max_occ, &
2419 [ # # ]: 0 : gstore%nkibz, eig_ibz, delta_theta_ef)
2420 : :
2421 : 0 : gstore%delta_ef_kibz_spin(ib, ik_ibz, spin) = delta_theta_ef(1)
2422 : :
2423 [ # # ]: 0 : iflag = merge(1, 0, abs(delta_theta_ef(1)) > zero)
2424 : :
2425 : : ! Use iflag to filter k-points.
2426 : 0 : select case (gstore%kzone)
2427 : : case ("ibz")
2428 : 0 : ik_bz = kibz2bz(ik_ibz)
2429 : 0 : select_kbz_spin(ik_bz, spin) = select_kbz_spin(ik_bz, spin) + iflag
2430 : :
2431 : : case ("bz")
2432 [ # # ]: 0 : call star_from_ibz_idx(ik_ibz, gstore%nkbz, gstore%kbz2ibz, nk_in_star, kstar_bz_inds)
2433 [ # # ]: 0 : ABI_CHECK(nk_in_star > 0, "Something wrong in star_from_ibz_idx")
2434 [ # # ]: 0 : do ii=1,nk_in_star
2435 : 0 : ik_bz = kstar_bz_inds(ii)
2436 : 0 : select_kbz_spin(ik_bz, spin) = select_kbz_spin(ik_bz, spin) + iflag
2437 : : end do
2438 [ # # # # : 0 : ABI_FREE(kstar_bz_inds)
# ]
2439 : : end select
2440 : : end do
2441 : :
2442 : : end do
2443 : : end do
2444 : :
2445 : : !call ktetra%print(std_out)
2446 : 0 : call xmpi_sum(select_kbz_spin, comm, ierr)
2447 : 0 : call xmpi_sum(gstore%delta_ef_kibz_spin, comm, ierr)
2448 : :
2449 : : ! Now the tricky part as we want to remove q-points that
2450 : : ! do not lead to any scattering process between two states on the FS
2451 : : ! Remember that k+q is always a sub-mesh of the input ebands k-mesh.
2452 : :
2453 : : call recompute_select_qbz_spin(gstore, gstore%qbz, qbz2ibz, qibz2bz, gstore%kbz, gstore%kibz, gstore%kbz2ibz, kibz2bz, &
2454 [ # # # # : 0 : select_kbz_spin, select_qbz_spin)
# # # # #
# ]
2455 : :
2456 [ # # ]: 0 : ABI_FREE(eig_ibz)
2457 [ # # ]: 0 : ABI_FREE(indkk)
2458 : 0 : call ktetra%free()
2459 : : end associate
2460 : :
2461 [ # # # # : 0 : end subroutine gstore_filter_fs_tetra__
# # # # #
# # # # #
# # # # #
# ]
2462 : : !!***
2463 : :
2464 : : !----------------------------------------------------------------------
2465 : :
2466 : : !!****f* m_gstore/gstore_filter_kptgw__
2467 : : !! NAME
2468 : : !! gstore_gw_filter_kptgw__
2469 : : !!
2470 : : !! FUNCTION
2471 : : !! Filter k-points according to the input variable kptgw. Useful for ZPR for user-specified k-points.
2472 : : !!
2473 : : !! INPUTS
2474 : : !!
2475 : : !! OUTPUT
2476 : : !!
2477 : : !! SOURCE
2478 : :
2479 : 0 : subroutine gstore_filter_kptgw__(gstore, dtset, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
2480 : :
2481 : : !Arguments ------------------------------------
2482 : : !scalars
2483 : : class(gstore_t),intent(inout) :: gstore
2484 : : type(dataset_type),intent(in) :: dtset
2485 : : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2486 : : integer,intent(in) :: kibz2bz(gstore%nkibz)
2487 : : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2488 : : integer,intent(out) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2489 : :
2490 : : !Local variables-------------------------------
2491 : : !scalars
2492 : : integer :: spin, ik_bz, ik_ibz, ik_calc, nkcalc, mapl_kk(6), my_rank
2493 : : !arrays
2494 : 0 : integer,allocatable :: bstart_ks(:,:), nbcalc_ks(:,:)
2495 : 0 : real(dp),allocatable :: kcalc(:,:)
2496 : : !----------------------------------------------------------------------
2497 : :
2498 : : ABI_UNUSED(qbz2ibz)
2499 : : ABI_UNUSED(qibz2bz)
2500 : :
2501 : : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2502 : :
2503 : 0 : my_rank = xmpi_comm_rank(gstore%comm)
2504 : :
2505 : 0 : call wrtout(std_out, sjoin(" Filtering k-points using nkptgw:", itoa(dtset%nkptgw)))
2506 [ # # ]: 0 : if (gstore%qzone /= "bz") then
2507 : 0 : ABI_ERROR(sjoin('kptgw filtering requires gstore_qzone = "bz" while it is: ', gstore%qzone))
2508 : : end if
2509 : :
2510 : : ! Compute nkcalc, kcalc, bstart_ks, nbcalc_ks
2511 : 0 : call sigtk_kcalc_from_nkptgw(dtset, dtset%mband, nkcalc, kcalc, bstart_ks, nbcalc_ks)
2512 : :
2513 : : ! TODO: kcalc should be spin-dependent to handle magnetic semiconductors.
2514 [ # # # # ]: 0 : select_kbz_spin = 0
2515 [ # # ]: 0 : do spin=1,gstore%nsppol
2516 [ # # ]: 0 : do ik_calc=1,nkcalc
2517 [ # # ]: 0 : if (kpts_map("symrel", ebands%kptopt, gstore%cryst, gstore%krank_ibz, 1, kcalc(:,ik_calc), mapl_kk) /= 0) then
2518 : 0 : ABI_ERROR(sjoin("Cannot map kcalc to IBZ with kcalc:", ktoa(kcalc(:,ik_calc))))
2519 : : end if
2520 : : ! Change select_kbz_spin
2521 : 0 : ik_ibz = mapl_kk(1)
2522 : 0 : ik_bz = kibz2bz(ik_ibz); select_kbz_spin(ik_bz, spin) = 1
2523 : : end do
2524 : : end do ! spin
2525 : :
2526 : : !call recompute_select_qbz_spin(gstore, gstore%qbz, qbz2ibz, qibz2bz, gstore%kbz, gstore%kibz, gstore%kbz2ibz, gstore%kibz2bz, &
2527 : : ! select_kbz_spin, select_qbz_spin)
2528 : :
2529 [ # # ]: 0 : ABI_FREE(kcalc)
2530 [ # # ]: 0 : ABI_FREE(bstart_ks)
2531 [ # # ]: 0 : ABI_FREE(nbcalc_ks)
2532 : : end associate
2533 : :
2534 : 0 : end subroutine gstore_filter_kptgw__
2535 : : !!***
2536 : :
2537 : : !----------------------------------------------------------------------
2538 : :
2539 : : !!****f* m_gstore/gstore_filter_erange__
2540 : : !! NAME
2541 : : !! gstore_filter_erange__
2542 : : !!
2543 : : !! FUNCTION
2544 : : !! Filter k-points and q-points according to an energy range.
2545 : : !!
2546 : : !! INPUTS
2547 : : !!
2548 : : !! OUTPUT
2549 : : !!
2550 : : !! SOURCE
2551 : :
2552 : 1 : subroutine gstore_filter_erange__(gstore, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
2553 : :
2554 : : !Arguments ------------------------------------
2555 : : !scalars
2556 : : class(gstore_t),intent(inout) :: gstore
2557 : : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2558 : : integer,intent(in) :: kibz2bz(gstore%nkibz)
2559 : : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2560 : : integer,intent(out) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2561 : :
2562 : : !Local variables-------------------------------
2563 : : !scalars
2564 : : integer,parameter :: tetra_opt0 = 0
2565 : : integer :: nsppol, cnt, spin, ii, all_nproc, my_rank, comm, band ! ierr,
2566 : : integer :: ik_bz, ik_ibz, iflag, nk_in_star, gap_err
2567 : : logical :: assume_gap
2568 : : real(dp) :: ee, abs_erange1, abs_erange2, vmax, cmin
2569 : : type(gaps_t) :: gaps
2570 : : !arrays
2571 : 1 : integer,allocatable :: kstar_bz_inds(:)
2572 : : !----------------------------------------------------------------------
2573 : :
2574 : : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2575 : :
2576 : 1 : comm = gstore%comm; all_nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
2577 : 1 : nsppol = gstore%nsppol
2578 : :
2579 : : ! filter k and k + q points according to erange and define gstore%brange_spin_k automatically.
2580 : : ! NB: here we recompute brange_k_spin
2581 : : call wrtout(std_out, sjoin(" Filtering k-points using gstore_erange:", &
2582 [ + + + - : 4 : ltoa(reshape(gstore%erange_spin, [2 * gstore%nsppol]) * Ha_eV), "(eV)"))
+ + ]
2583 : :
2584 [ + - + - : 1 : assume_gap = .not. all(gstore%erange_spin < zero)
- + ]
2585 : 1 : gaps = ebands%get_gaps(gap_err)
2586 [ + - + + ]: 2 : if (assume_gap) call gaps%print([std_out])
2587 : :
2588 [ + + + + ]: 2199 : select_kbz_spin = 0; cnt = 0
2589 : :
2590 [ + + ]: 2 : do spin=1,nsppol
2591 : : ! Init brange. NB: nb_kq == nb_k when erange filtering is used.
2592 [ + + ]: 3 : gstore%brange_k_spin(:, spin) = [huge(1), -huge(1)]
2593 [ + + ]: 3 : gstore%brange_kq_spin(:, spin) = [huge(1), -huge(1)]
2594 : 1 : abs_erange1 = abs(gstore%erange_spin(1, spin))
2595 : 1 : abs_erange2 = abs(gstore%erange_spin(2, spin))
2596 : :
2597 [ + - ]: 1 : if (assume_gap) then
2598 : : ! Get CBM and VBM with some tolerance
2599 : 1 : vmax = gaps%vb_max(spin) + tol2 * eV_Ha
2600 : 1 : cmin = gaps%cb_min(spin) - tol2 * eV_Ha
2601 : : else
2602 : 0 : vmax = ebands%fermie
2603 : 0 : cmin = ebands%fermie
2604 : : end if
2605 : :
2606 [ + + ]: 7 : do band=1, ebands%mband
2607 [ + + ]: 511 : do ik_ibz=1,gstore%nkibz
2608 : : !cnt = cnt + 1; if (mod(cnt, all_nproc) /= my_rank) cycle ! MPI parallelism inside comm
2609 : :
2610 : : ! Use iflag to filter k-points.
2611 : 504 : ee = ebands%eig(band, ik_ibz, spin)
2612 : 504 : iflag = 0
2613 : :
2614 [ + - ]: 504 : if (abs_erange1 > zero) then
2615 : : ! Filter valence states.
2616 [ # # # # ]: 0 : if (ee <= vmax .and. vmax - ee <= abs_erange1) then
2617 : 504 : iflag = 1 !; write(std_out, *), "Adding valence band", band, " with ee [eV]: ", ee * Ha_eV
2618 : : end if
2619 : : end if
2620 [ + - ]: 504 : if (abs_erange2 > zero) then
2621 : : ! Filter conduction states.
2622 [ + + + + ]: 504 : if (ee >= cmin .and. ee - cmin <= abs_erange2) then
2623 : : iflag = 1 !; write(std_out, *)"Adding conduction band", band, " with ee [eV]: ", ee * Ha_eV
2624 : : end if
2625 : : end if
2626 : :
2627 [ - + ]: 502 : if (iflag == 1) then
2628 : 8 : gstore%brange_k_spin(1, spin) = min(gstore%brange_k_spin(1, spin), band)
2629 : 8 : gstore%brange_k_spin(2, spin) = max(gstore%brange_k_spin(2, spin), band)
2630 : 8 : gstore%brange_kq_spin(1, spin) = min(gstore%brange_kq_spin(1, spin), band)
2631 : 8 : gstore%brange_kq_spin(2, spin) = max(gstore%brange_kq_spin(2, spin), band)
2632 : :
2633 : 0 : select case (gstore%kzone)
2634 : : case ("ibz")
2635 : 0 : ik_bz = kibz2bz(ik_ibz)
2636 : 0 : select_kbz_spin(ik_bz, spin) = iflag
2637 : :
2638 : : case ("bz")
2639 [ - + ]: 8 : call star_from_ibz_idx(ik_ibz, gstore%nkbz, gstore%kbz2ibz, nk_in_star, kstar_bz_inds)
2640 [ - + ]: 8 : ABI_CHECK(nk_in_star > 0, "Something wrong in star_from_ibz_idx")
2641 [ + + ]: 97 : do ii=1,nk_in_star
2642 : 89 : ik_bz = kstar_bz_inds(ii)
2643 : 97 : select_kbz_spin(ik_bz, spin) = iflag
2644 : : end do
2645 [ - + - - : 16 : ABI_FREE(kstar_bz_inds)
+ ]
2646 : : end select
2647 : : end if
2648 : :
2649 : : end do ! band
2650 : : end do ! ik_ibz
2651 : :
2652 : : !call wrtout(std_out, sjoin("brange_k_spin:", ltoa(gstore%brange_k_spin(:, spin))))
2653 : : !call wrtout(std_out, sjoin("count_select_kbz:", itoa(count(select_kbz_spin == 1))))
2654 : : !call wrtout(std_out, sjoin("brange_kq_spin:", ltoa(gstore%brange_k_qspin(:, spin))))
2655 : : !call wrtout(std_out, sjoin("count_select_kbz:", itoa(count(select_kbz_spin == 1))))
2656 : :
2657 [ + + + - : 3 : if (any(gstore%brange_k_spin(:, spin) == [huge(1), -huge(1)])) then
- + ]
2658 : 0 : ABI_ERROR("Empty list of states inside gstore_erange")
2659 : : end if
2660 [ + + + - : 4 : if (any(gstore%brange_kq_spin(:, spin) == [huge(1), -huge(1)])) then
- + ]
2661 : 0 : ABI_ERROR("Empty list of states inside gstore_erange")
2662 : : end if
2663 : :
2664 : : end do ! spin
2665 : :
2666 : : !call xmpi_sum(select_kbz_spin, comm, ierr)
2667 : : call recompute_select_qbz_spin(gstore, gstore%qbz, qbz2ibz, qibz2bz, gstore%kbz, gstore%kibz, gstore%kbz2ibz, kibz2bz, &
2668 [ + - - - : 1 : select_kbz_spin, select_qbz_spin)
- - - - -
+ ]
2669 : :
2670 : 2 : call gaps%free()
2671 : : end associate
2672 : :
2673 [ - + - + : 1 : end subroutine gstore_filter_erange__
- + - + -
+ - + - +
- + - + ]
2674 : : !!***
2675 : :
2676 : : !----------------------------------------------------------------------
2677 : :
2678 : : !!****f* m_gstore/gstore_filter_gw_qprange__
2679 : : !! NAME
2680 : : !! gstore_gw_filter_qprange__
2681 : : !!
2682 : : !! FUNCTION
2683 : : !! Filter k-points according to the input variable gw_qprange. Useful for ZPR.
2684 : : !!
2685 : : !! INPUTS
2686 : : !!
2687 : : !! OUTPUT
2688 : : !!
2689 : : !! SOURCE
2690 : :
2691 : 4 : subroutine gstore_filter_gw_qprange__(gstore, dtset, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
2692 : :
2693 : : !Arguments ------------------------------------
2694 : : !scalars
2695 : : class(gstore_t),intent(inout) :: gstore
2696 : : type(dataset_type),intent(in) :: dtset
2697 : : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2698 : : integer,intent(in) :: kibz2bz(gstore%nkibz)
2699 : : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2700 : : integer,intent(out) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2701 : :
2702 : : !Local variables-------------------------------
2703 : : !scalars
2704 : : integer :: spin, ik_bz, ik_ibz, gap_err, ik_calc, nkcalc, mapl_kk(6), my_rank
2705 : 4 : type(gaps_t) :: gaps
2706 : : !arrays
2707 : 4 : integer,allocatable :: bstart_ks(:,:), nbcalc_ks(:,:)
2708 : 4 : real(dp),allocatable :: kcalc(:,:)
2709 : : !----------------------------------------------------------------------
2710 : :
2711 : : ABI_UNUSED(qbz2ibz)
2712 : : ABI_UNUSED(qibz2bz)
2713 : :
2714 : : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2715 : :
2716 : 8 : my_rank = xmpi_comm_rank(gstore%comm)
2717 : :
2718 : 4 : call wrtout(std_out, sjoin(" Filtering k-points using gw_qprange:", itoa(dtset%gw_qprange)))
2719 [ - + ]: 4 : if (gstore%qzone /= "bz") then
2720 : 0 : ABI_ERROR(sjoin('gw_qprange filtering requires gstore_qzone = "bz" while it is: ', gstore%qzone))
2721 : : end if
2722 : :
2723 : 4 : gaps = ebands%get_gaps(gap_err)
2724 [ + - + + ]: 8 : if (my_rank == 0) call gaps%print([std_out])
2725 [ - + ]: 4 : if (gap_err /= 0) then
2726 : 0 : ABI_ERROR("Cannot compute fundamental and direct gap (likely metal).")
2727 : : end if
2728 : :
2729 : : ! Use gw_qprange to select the interesting k-points and the corresponding bands.
2730 : : !
2731 : : ! 0 --> Compute the QP corrections only for the fundamental and the direct gap.
2732 : : ! +num --> Compute the QP corrections for all the k-points in the irreducible zone and include `num`
2733 : : ! bands above and below the Fermi level.
2734 : : ! -num --> Compute the QP corrections for all the k-points in the irreducible zone.
2735 : : ! Include all occupied states and `num` empty states.
2736 : :
2737 : : ! Compute nkcalc, kcalc, bstart_ks, nbcalc_ks
2738 [ - + ]: 4 : if (dtset%gw_qprange /= 0) then
2739 : 0 : call sigtk_kcalc_from_qprange(dtset, gstore%cryst, ebands, dtset%gw_qprange, nkcalc, kcalc, bstart_ks, nbcalc_ks)
2740 : : else
2741 : : ! gw_qprange is not specified in the input.
2742 : : ! Include direct and fundamental KS gap or include states depending on the position wrt band edges.
2743 : 4 : call sigtk_kcalc_from_gaps(dtset, ebands, gaps, nkcalc, kcalc, bstart_ks, nbcalc_ks)
2744 : : end if
2745 : :
2746 : : ! TODO: kcalc should be spin-dependent to handle magnetic semiconductors.
2747 [ + + + + ]: 152 : select_kbz_spin = 0
2748 [ + + ]: 8 : do spin=1,gstore%nsppol
2749 [ + + ]: 14 : do ik_calc=1,nkcalc
2750 [ - + ]: 6 : if (kpts_map("symrel", ebands%kptopt, gstore%cryst, gstore%krank_ibz, 1, kcalc(:,ik_calc), mapl_kk) /= 0) then
2751 : 0 : ABI_ERROR(sjoin("Cannot map kcalc to IBZ with kcalc:", ktoa(kcalc(:,ik_calc))))
2752 : : end if
2753 : : ! Change select_kbz_spin
2754 : 6 : ik_ibz = mapl_kk(1)
2755 : 10 : ik_bz = kibz2bz(ik_ibz); select_kbz_spin(ik_bz, spin) = 1
2756 : : end do
2757 : : end do ! spin
2758 : :
2759 : : !call recompute_select_qbz_spin(gstore, gstore%qbz, qbz2ibz, qibz2bz, gstore%kbz, gstore%kibz, gstore%kbz2ibz, gstore%kibz2bz, &
2760 : : ! select_kbz_spin, select_qbz_spin)
2761 : :
2762 [ - + ]: 4 : ABI_FREE(kcalc)
2763 [ - + ]: 4 : ABI_FREE(bstart_ks)
2764 [ - + ]: 4 : ABI_FREE(nbcalc_ks)
2765 : 8 : call gaps%free()
2766 : : end associate
2767 : :
2768 [ - + - + : 4 : end subroutine gstore_filter_gw_qprange__
- + - + -
+ - + - +
- + ]
2769 : : !!***
2770 : :
2771 : : !!****f* m_gstore/recompute_select_qbz_spin
2772 : : !! NAME
2773 : : !! recompute_select_qbz_spin
2774 : : !!
2775 : : !! FUNCTION
2776 : : !! Recompute select_qbz_spin table after the filtering on the k-points.
2777 : : !!
2778 : : !! INPUTS
2779 : : !!
2780 : : !! OUTPUT
2781 : : !!
2782 : : !! SOURCE
2783 : :
2784 : 1 : subroutine recompute_select_qbz_spin(gstore, qbz, qbz2ibz, qibz2bz, kbz, kibz, kbz2ibz, kibz2bz, &
2785 : 1 : select_kbz_spin, select_qbz_spin)
2786 : :
2787 : : !Arguments ------------------------------------
2788 : : !scalars
2789 : : class(gstore_t),intent(inout) :: gstore
2790 : : !arrays
2791 : : real(dp),intent(in) :: qbz(3, gstore%nqbz)
2792 : : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2793 : : integer,intent(in) :: kbz2ibz(6,gstore%nkbz), kibz2bz(gstore%nkibz)
2794 : : real(dp),target,intent(in) :: kibz(3, gstore%nkibz), kbz(3, gstore%nkbz)
2795 : : integer,intent(in) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2796 : : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2797 : :
2798 : : !Local variables-------------------------------
2799 : : !scalars
2800 : : integer :: all_nproc, my_rank, ierr, ii, ik_bz, iq_bz, iq_ibz, ikq_ibz, ikq_bz, len_kpts_ptr, ebands_kptopt, spin
2801 : : !arrays
2802 : 1 : integer,allocatable :: map_kq(:,:)
2803 : : real(dp) :: qpt(3)
2804 : 1 : real(dp),contiguous, pointer :: kpts_ptr(:,:)
2805 : : ! *************************************************************************
2806 : :
2807 : : ABI_UNUSED(kbz2ibz)
2808 : : ABI_UNUSED(qbz2ibz)
2809 : :
2810 : 1 : all_nproc = xmpi_comm_size(gstore%comm); my_rank = xmpi_comm_rank(gstore%comm)
2811 : 1 : ebands_kptopt = gstore%ebands%kptopt
2812 : :
2813 [ + + + + ]: 2199 : select_qbz_spin = 0
2814 : :
2815 [ - + ]: 1 : if (gstore%kzone == "ibz") kpts_ptr => kibz
2816 [ + - ]: 1 : if (gstore%kzone == "bz") kpts_ptr => kbz
2817 : 1 : len_kpts_ptr = size(kpts_ptr, dim=2)
2818 [ - + + - : 3 : ABI_MALLOC(map_kq, (6, len_kpts_ptr))
+ - + - -
+ - + ]
2819 : :
2820 : 0 : select case (gstore%qzone)
2821 : : case ("ibz")
2822 [ # # ]: 0 : do iq_ibz=1,gstore%nqibz
2823 [ # # ]: 0 : if (mod(iq_ibz, all_nproc) /= my_rank) cycle ! MPI parallelism.
2824 [ # # ]: 0 : qpt = gstore%qibz(:, iq_ibz)
2825 : 0 : iq_bz = qibz2bz(iq_ibz)
2826 : : ! k + q_ibz --> k IBZ --> k BZ
2827 : :
2828 [ # # ]: 0 : if (kpts_map("symrel", ebands_kptopt, gstore%cryst, gstore%krank_ibz, len_kpts_ptr, kpts_ptr, map_kq, qpt=qpt) /= 0) then
2829 : 0 : ABI_ERROR("Cannot map k+q to IBZ!")
2830 : : end if
2831 : :
2832 [ # # ]: 0 : do ii=1,len_kpts_ptr
2833 : : ! get the k-index in BZ
2834 : 0 : select case (gstore%kzone)
2835 : : case ("bz")
2836 : 0 : ik_bz = ii
2837 : : case ("ibz")
2838 [ # # # ]: 0 : ik_bz = kibz2bz(ii)
2839 : : end select
2840 : :
2841 [ # # ]: 0 : do spin=1,gstore%nsppol
2842 [ # # ]: 0 : if (select_kbz_spin(ik_bz, spin) /= 0) then
2843 : : ! now, see if q-point connects k-points inside the filtered zone
2844 : 0 : ikq_ibz = map_kq(1, ii)
2845 : 0 : ikq_bz = kibz2bz(ikq_ibz)
2846 [ # # ]: 0 : select_qbz_spin(iq_bz, :) = select_qbz_spin(iq_bz, :) + select_kbz_spin(ikq_bz, :)
2847 : : end if
2848 : : end do
2849 : : end do
2850 : : end do ! iq_ibz
2851 : :
2852 : : case ("bz")
2853 [ - + - + : 2198 : do iq_bz=1,gstore%nqbz
+ ]
2854 [ + - ]: 2197 : if (mod(iq_bz, all_nproc) /= my_rank) cycle ! MPI parallelism.
2855 [ + + ]: 8788 : qpt = qbz(:, iq_bz)
2856 : : !iq_ibz = qbz2ibz(1, iq_bz)
2857 : : ! k + q_bz --> k IBZ --> k BZ
2858 : :
2859 [ - + ]: 2197 : if (kpts_map("symrel", ebands_kptopt, gstore%cryst, gstore%krank_ibz, len_kpts_ptr, kpts_ptr, map_kq, qpt=qpt) /= 0) then
2860 : 0 : ABI_ERROR("Cannot map k+q to IBZ!")
2861 : : end if
2862 : :
2863 : : ! here we loop over all k-points in iBZ (kzone="ibz") or BZ (kzone="bz")
2864 [ + + ]: 4829007 : do ii=1,len_kpts_ptr
2865 : : ! but for each spin, we have to loop only over e-range filtered kpts
2866 : :
2867 : : ! get the k-index in BZ
2868 : 9653618 : select case (gstore%kzone)
2869 : : case ("bz")
2870 : 4826809 : ik_bz = ii
2871 : : case ("ibz")
2872 [ + - - ]: 4826809 : ik_bz = kibz2bz(ii)
2873 : : end select
2874 : :
2875 [ + + ]: 9655815 : do spin=1,gstore%nsppol
2876 : : ! Now, see if q-point connects k-points inside the filtered zone
2877 [ + + ]: 9653618 : if (select_kbz_spin(ik_bz, spin) /= 0) then
2878 : 195533 : ikq_ibz = map_kq(1, ii)
2879 : 195533 : ikq_bz = kibz2bz(ikq_ibz)
2880 : 195533 : select_qbz_spin(iq_bz, spin) = select_qbz_spin(iq_bz, spin) + select_kbz_spin(ikq_bz, spin)
2881 : : end if
2882 : : end do
2883 : :
2884 : : end do
2885 : : end do
2886 : : end select
2887 : :
2888 : 1 : call xmpi_sum(select_qbz_spin, gstore%comm, ierr)
2889 : :
2890 [ - + ]: 1 : ABI_FREE(map_kq)
2891 : :
2892 : 1 : end subroutine recompute_select_qbz_spin
2893 : : !!***
2894 : :
2895 : : !!****f* m_gstore/gstore_spin2my_is
2896 : : !! NAME
2897 : : !! gstore_spin2my_is
2898 : : !!
2899 : : !! FUNCTION
2900 : : !! Return the local spin index from the global spin index.
2901 : : !! 0 if this spin is not treated by this MPI proc.
2902 : : !!
2903 : : !! SOURCE
2904 : :
2905 : 16 : integer pure function gstore_spin2my_is(gstore, spin) result(my_is)
2906 : :
2907 : : !Arguments ------------------------------------
2908 : : class(gstore_t),intent(in) :: gstore
2909 : : integer,intent(in) :: spin
2910 : : !----------------------------------------------------------------------
2911 : :
2912 [ + - ]: 16 : do my_is=1,gstore%my_nspins
2913 [ - + ]: 16 : if (gstore%my_spins(my_is) == spin) return
2914 : : end do
2915 : 16 : my_is = 0
2916 : :
2917 : : end function gstore_spin2my_is
2918 : : !!***
2919 : :
2920 : : !----------------------------------------------------------------------
2921 : :
2922 : : !!****f* m_gstore/gstore_fill_bks_mask
2923 : : !! NAME
2924 : : !! gstore_fill_bks_mask
2925 : : !!
2926 : : !! FUNCTION
2927 : : !! Fills the bks_mask array defining the set of wavefunctions that should be read
2928 : : !! from the WFK file by this MPI rank when computing the KS e-ph matrix elements.
2929 : : !!
2930 : : !! INPUTS
2931 : : !!
2932 : : !! OUTPUT
2933 : : !!
2934 : : !! SOURCE
2935 : :
2936 : 12 : subroutine gstore_fill_bks_mask(gstore, mband, nkibz, nsppol, bks_mask)
2937 : :
2938 : : !Arguments ------------------------------------
2939 : : class(gstore_t),intent(inout) :: gstore
2940 : : integer,intent(in) :: mband, nkibz, nsppol
2941 : : logical,intent(out) :: bks_mask(mband, nkibz, nsppol)
2942 : :
2943 : : !Local variables-------------------------------
2944 : : !scalars
2945 : : integer :: my_is, my_ik, my_iq, spin, ik_ibz, ikq_ibz, ebands_kptopt, bstart_k, bstop_k, bstart_kq, bstop_kq
2946 : : real(dp) :: weight_q, cpu, wall, gflops
2947 : : !arrays
2948 : 12 : integer,allocatable :: map_kq(:,:)
2949 : : real(dp) :: qpt(3)
2950 : : !----------------------------------------------------------------------
2951 : :
2952 : 12 : call cwtime(cpu, wall, gflops, "start")
2953 : : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2954 : :
2955 [ + + + + : 1992 : bks_mask = .False.; ebands_kptopt = gstore%ebands%kptopt
+ + ]
2956 : :
2957 [ + + ]: 24 : do my_is=1,gstore%my_nspins
2958 : 12 : associate (gqk => gstore%gqk(my_is))
2959 : 12 : spin = gstore%my_spins(my_is)
2960 : 12 : bstart_k = gqk%bstart_k; bstop_k = gqk%bstop_k
2961 : 12 : bstart_kq = gqk%bstart_kq; bstop_kq = gqk%bstop_kq
2962 : :
2963 : : ! Stop if dtset%nband < gstore%nband before sigfaulting.
2964 : 0 : ABI_CHECK_ILEQ(bstop_k, mband, "bstop_k should be smaller that mband present in WFK")
2965 [ - + ]: 12 : ABI_CHECK_ILEQ(bstop_kq, mband, "bstop_kq should be smaller that mband present in WFK")
2966 : :
2967 : : ! We need the image of this k-point in the IBZ.
2968 [ + + ]: 330 : do my_ik=1,gqk%my_nk
2969 : 318 : ik_ibz = gqk%my_k2ibz(1, my_ik)
2970 [ + + ]: 1139 : bks_mask(bstart_k:bstop_k, ik_ibz, spin) = .True.
2971 : : end do
2972 : :
2973 : : ! As well as the image of k+q in the IBZ.
2974 [ - + + - : 36 : ABI_MALLOC(map_kq, (6, gqk%my_nk))
+ - + - -
+ - + ]
2975 : :
2976 [ + + ]: 1057 : do my_iq=1,gqk%my_nq
2977 : 1045 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
2978 : :
2979 [ - + ]: 1045 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, map_kq, qpt=qpt) /= 0) then
2980 : 0 : ABI_ERROR(sjoin("Cannot map k+q to IBZ with qpt:", ktoa(qpt)))
2981 : : end if
2982 : :
2983 [ + + ]: 74912 : do my_ik=1,gqk%my_nk
2984 : 73855 : ikq_ibz = map_kq(1, my_ik)
2985 [ + + ]: 193527 : bks_mask(bstart_kq:bstop_kq, ikq_ibz, spin) = .True.
2986 : : end do
2987 : : end do
2988 : :
2989 [ - + - + ]: 24 : ABI_FREE(map_kq)
2990 : : end associate
2991 : : end do ! my_is
2992 : :
2993 : 12 : call cwtime_report(" gstore_fill_bks_mask", cpu, wall, gflops)
2994 : : end associate
2995 : :
2996 : 24 : end subroutine gstore_fill_bks_mask
2997 : : !!***
2998 : :
2999 : : !----------------------------------------------------------------------
3000 : :
3001 : : !!****f* m_gstore/gstore_fill_bks_mask_with_pp
3002 : : !! NAME
3003 : : !! gstore_fill_bks_mask_with_pp
3004 : : !!
3005 : : !! FUNCTION
3006 : : !! Fill the bks_mask array defining the set of states that should be read from the WFK file
3007 : : !! by this MPI rank when computing the GWPT e-ph matrix elements in which we have
3008 : : !! to consider k+q, k-q and k+q-p as well as the sum over states (bsum).
3009 : : !!
3010 : : !! INPUTS
3011 : : !!
3012 : : !! OUTPUT
3013 : : !!
3014 : : !! SOURCE
3015 : :
3016 : 3 : subroutine gstore_fill_bks_mask_pp_mesh(gstore, ecut, mband, nkibz, nsppol, my_pp_start_spin, my_pp_stop_spin, pp_mesh, &
3017 : 3 : my_bsum_start, my_bsum_stop, bks_mask, mpw, gmax)
3018 : :
3019 : : !Arguments ------------------------------------
3020 : : class(gstore_t),target,intent(inout) :: gstore
3021 : : real(dp),intent(in) :: ecut
3022 : : integer,intent(in) :: mband, nkibz, nsppol
3023 : : integer :: my_pp_start_spin(nsppol), my_pp_stop_spin(nsppol)
3024 : : type(kmesh_t),intent(in) :: pp_mesh
3025 : : integer,intent(in) :: my_bsum_start(nsppol), my_bsum_stop(nsppol)
3026 : : logical,intent(out) :: bks_mask(mband, nkibz, nsppol)
3027 : : integer,intent(out) :: mpw, gmax(3)
3028 : :
3029 : : !Local variables-------------------------------
3030 : : !scalars
3031 : : integer,parameter :: istwfk1 = 1
3032 : : 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)
3033 : : real(dp) :: weight_q, cpu, wall, gflops
3034 : : type(gqk_t),pointer :: gqk
3035 : : type(crystal_t),pointer :: cryst
3036 : : !arrays
3037 : 3 : integer,allocatable :: map_kq(:,:), gtmp(:,:)
3038 : : real(dp) :: qpt(3), pp(3), kk(3)
3039 : : !----------------------------------------------------------------------
3040 : :
3041 : 3 : call cwtime(cpu, wall, gflops, "start")
3042 : :
3043 : : ! TODO: These loops can be parallelized using bsum_comm and pert_comm if needed.
3044 [ + + + + : 237 : bks_mask = .False.; cryst => gstore%cryst
+ + ]
3045 : 3 : ebands_kptopt = gstore%ebands%kptopt
3046 : 3 : mpw = 0; gmax = 0
3047 : :
3048 [ + + ]: 6 : do my_is=1,gstore%my_nspins
3049 : 3 : gqk => gstore%gqk(my_is); spin = gstore%my_spins(my_is)
3050 : :
3051 : : ! These are the first and last band indices used in the sum over states (possibly MPI-distributed)
3052 : 3 : b1 = my_bsum_start(spin); b2 = my_bsum_stop(spin)
3053 : :
3054 : : ! Stop if dtset%nband < gstore%nband before sigfaulting.
3055 [ - + ]: 3 : ABI_CHECK_ILEQ(gqk%bstop_k, mband, "bstop_k should be smaller that mband present in WFK")
3056 [ - + ]: 3 : ABI_CHECK_ILEQ(gqk%bstop_kq, mband, "bstop_kq should be smaller that mband present in WFK")
3057 [ - + ]: 3 : ABI_CHECK_ILEQ(b2, mband, "max band index in sum should be smaller that mband present in WFK")
3058 : :
3059 [ - + + - : 9 : ABI_MALLOC(map_kq, (6, gqk%my_nk))
+ - + - -
+ - + ]
3060 : :
3061 [ + + ]: 8 : do my_ik=1,gqk%my_nk
3062 [ + + ]: 20 : kk = gqk%my_kpts(:, my_ik); ik_ibz = gqk%my_k2ibz(1, my_ik)
3063 : :
3064 : : ! We need the image of this k-point in the IBZ for the incoming state |psi_nk>.
3065 [ + + ]: 33 : bks_mask(gqk%bstart_k:gqk%bstop_k, ik_ibz, spin) = .True.
3066 : :
3067 : : ! We also need the image of k+q in the IBZ for the outgoing state <psi_mkq|.
3068 [ + + ]: 104 : do my_iq=1,gqk%my_nq
3069 : 96 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3070 [ - + ]: 96 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, 1, kk, map_kq, qpt=qpt) /= 0) then
3071 : 0 : ABI_ERROR(sjoin("Cannot map k+q to IBZ with qpt:", ktoa(qpt)))
3072 : : end if
3073 : 96 : ikq_ibz = map_kq(1, 1)
3074 [ + + ]: 1125 : bks_mask(gqk%bstart_kq:gqk%bstop_kq, ikq_ibz, spin) = .True.
3075 : : end do ! my_iq
3076 : :
3077 : : end do ! my_ok
3078 : :
3079 : : ! We also need the image of k-p in the IBZ for the pp wavevectors treated by this MPI rank.
3080 : : ! These states are summed over so use b1 and b2.
3081 [ + + ]: 83 : do ipp_bz=my_pp_start_spin(spin), my_pp_stop_spin(spin)
3082 [ + + ]: 320 : pp = pp_mesh%bz(:,ipp_bz)
3083 [ + + - + ]: 320 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, map_kq, qpt=-pp) /= 0) then
3084 : 0 : ABI_ERROR(sjoin("Cannot map k-p to IBZ with qpt:", ktoa(qpt), "and pp:", ktoa(pp)))
3085 : : end if
3086 : :
3087 [ + + ]: 179 : do my_ik=1,gqk%my_nk
3088 : 96 : ikq_ibz = map_kq(1, my_ik)
3089 [ + + ]: 1120 : bks_mask(b1:b2, ikq_ibz, spin) = .True.
3090 : : ! Compute g-sphere, returns onpw. Note istwfk == 1.
3091 [ + + ]: 384 : kk = gqk%my_kpts(:, my_ik)
3092 [ + + - + ]: 384 : call get_kg(kk-pp, istwfk1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3093 [ - + ]: 176 : ABI_FREE(gtmp)
3094 : : end do
3095 : : end do ! ipp_bz
3096 : :
3097 : : ! We also need the image of k+q-p in the IBZ for the pp wavevectors treated by this MPI rank.
3098 : : ! These states are summed over so use b1 and b2.
3099 [ + + ]: 83 : do my_iq=1,gqk%my_nq
3100 : 80 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3101 : :
3102 [ + + ]: 4307 : do ipp_bz=my_pp_start_spin(spin), my_pp_stop_spin(spin)
3103 [ + + ]: 16896 : pp = pp_mesh%bz(:,ipp_bz)
3104 : :
3105 [ + + - + ]: 16896 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, map_kq, qpt=qpt-pp) /= 0) then
3106 : 0 : ABI_ERROR(sjoin("Cannot map k+q-p to IBZ with qpt:", ktoa(qpt), "and pp:", ktoa(pp)))
3107 : : end if
3108 : :
3109 [ + + ]: 8656 : do my_ik=1,gqk%my_nk
3110 : 4352 : ikq_ibz = map_kq(1, my_ik)
3111 [ + + ]: 48384 : bks_mask(b1:b2, ikq_ibz, spin) = .True.
3112 : : ! Compute g-sphere, returns onpw. Note istwfk = 1.
3113 [ + + ]: 17408 : kk = gqk%my_kpts(:, my_ik)
3114 [ + + - + ]: 17408 : call get_kg(kk+qpt-pp, istwfk1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3115 [ - + ]: 8576 : ABI_FREE(gtmp)
3116 : : end do
3117 : : end do ! ipp_bz
3118 : :
3119 : : end do ! my_iq
3120 : :
3121 [ - + ]: 6 : ABI_FREE(map_kq)
3122 : : end do ! my_is
3123 : :
3124 : 3 : my_mpw = mpw; call xmpi_max(my_mpw, mpw, gstore%comm, ierr)
3125 : 3 : my_gmax = gmax; call xmpi_max(my_gmax, gmax, gstore%comm, ierr)
3126 : :
3127 : : ! TODO
3128 : : !call gstore%get_mpw_gmax(ecut, mpw, gmax, pp_max=)
3129 : :
3130 : 3 : call wrtout(std_out, sjoin(' Optimal value of mpw: ', itoa(mpw)))
3131 : 3 : call cwtime_report(" gstore_fill_bks_mask_pp_mesh", cpu, wall, gflops)
3132 : :
3133 [ - + ]: 3 : end subroutine gstore_fill_bks_mask_pp_mesh
3134 : : !!***
3135 : :
3136 : : !----------------------------------------------------------------------
3137 : :
3138 : : !!****f* m_gstore/gstore_get_mpw_gmax
3139 : : !! NAME
3140 : : !! gstore_get_mpw_gmax
3141 : : !!
3142 : : !! FUNCTION
3143 : : !! Compute the maximum number of PWs for all possible k+q treated.
3144 : : !!
3145 : : !! INPUTS
3146 : : !!
3147 : : !! OUTPUT
3148 : : !!
3149 : : !! SOURCE
3150 : :
3151 : 12 : subroutine gstore_get_mpw_gmax(gstore, ecut, mpw, gmax, pp_max)
3152 : :
3153 : : !Arguments ------------------------------------
3154 : : class(gstore_t),intent(in) :: gstore
3155 : : real(dp),intent(in) :: ecut
3156 : : integer,intent(out) :: mpw, gmax(3)
3157 : : integer,optional,intent(in) :: pp_max
3158 : :
3159 : : !Local variables-------------------------------
3160 : : integer,parameter :: istwfk1 = 1
3161 : : integer :: my_is, my_ik, my_iq, spin, onpw, ierr, my_mpw, ipx, ipy, ipz, nprocs, my_rank, pp_max__ !, cnt, i1, i2, i3,
3162 : : real(dp) :: weight_q, cpu, wall, gflops
3163 : : !arrays
3164 : : integer :: my_gmax(3)
3165 : 12 : integer,allocatable :: gtmp(:,:)
3166 : : real(dp) :: kk(3), kq(3), qpt(3), pp(3) !, kq_max(3)
3167 : : !----------------------------------------------------------------------
3168 : :
3169 : : ! TODO: This is an hotspot due to the double loop over k and q. Should use a geometrical approach to compute mpw and gmax.
3170 : 12 : call wrtout(std_out, " Computing mpw. This may take some time for dense k/q meshes...", pre_newlines=1)
3171 : 12 : call cwtime(cpu, wall, gflops, "start")
3172 : :
3173 : 12 : nprocs = xmpi_comm_size(gstore%comm); my_rank = xmpi_comm_rank(gstore%comm)
3174 : 12 : mpw = 0; gmax = 0
3175 [ - + ]: 12 : pp_max__ = 0; if (present(pp_max)) pp_max__ = pp_max
3176 : :
3177 [ + + ]: 24 : do my_is=1,gstore%my_nspins
3178 : 12 : associate (gqk => gstore%gqk(my_is))
3179 : 12 : spin = gstore%my_spins(my_is)
3180 [ + + ]: 330 : do my_ik=1,gqk%my_nk
3181 [ + + ]: 1272 : kk = gqk%my_kpts(:, my_ik)
3182 : :
3183 : : ! Compute g-sphere, returns onpw. Note istwfk == 1.
3184 [ - + ]: 318 : call get_kg(kk, istwfk1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3185 [ - + ]: 318 : ABI_FREE(gtmp)
3186 : :
3187 [ + + ]: 74185 : do my_iq=1,gqk%my_nq
3188 : 73855 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3189 [ + + ]: 295420 : kq = kk + qpt
3190 : :
3191 : : ! TODO: g0 umklapp here can enter into play! gmax could not be large enough!
3192 [ + + ]: 148028 : do ipz=-pp_max__,pp_max__
3193 [ + + ]: 221565 : do ipy=-pp_max__,pp_max__
3194 [ + + ]: 221565 : do ipx=-pp_max__,pp_max__
3195 [ + + ]: 295420 : pp = [ipx, ipy, ipz] * half
3196 [ + + - + ]: 295420 : call get_kg(kq - pp, 1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3197 [ - + ]: 147710 : ABI_FREE(gtmp)
3198 : : end do
3199 : : end do
3200 : : end do
3201 : : end do ! my_iq
3202 : :
3203 : : end do ! my_ik
3204 : : end associate
3205 : : end do ! my_is
3206 : :
3207 : 12 : my_mpw = mpw; call xmpi_max(my_mpw, mpw, gstore%comm, ierr)
3208 : 12 : my_gmax = gmax; call xmpi_max(my_gmax, gmax, gstore%comm, ierr)
3209 : :
3210 : 12 : call wrtout(std_out, sjoin(' Optimal value of mpw: ', itoa(mpw), "with gmax:", ltoa(gmax)))
3211 : 12 : call cwtime_report(" gstore_get_mpw_gmax", cpu, wall, gflops)
3212 : :
3213 [ - + ]: 12 : end subroutine gstore_get_mpw_gmax
3214 : : !!***
3215 : :
3216 : : !----------------------------------------------------------------------
3217 : :
3218 : : !!****f* m_gstore/gstore_free
3219 : : !! NAME
3220 : : !! gstore_free
3221 : : !!
3222 : : !! FUNCTION
3223 : : !! Free dynamic memory in gstore_t.
3224 : : !!
3225 : : !! SOURCE
3226 : :
3227 : 24 : subroutine gstore_free(gstore)
3228 : :
3229 : : !Arguments ------------------------------------
3230 : : class(gstore_t),intent(inout) :: gstore
3231 : :
3232 : : !Local variables-------------------------------
3233 : : integer :: my_is
3234 : : !----------------------------------------------------------------------
3235 : :
3236 [ + + ]: 48 : do my_is=1,gstore%my_nspins
3237 : 48 : call gstore%gqk(my_is)%free()
3238 : : end do
3239 [ + - + + : 48 : ABI_SFREE(gstore%gqk)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ ]
3240 : :
3241 [ - + ]: 24 : ABI_SFREE(gstore%delta_ef_kibz_spin)
3242 [ + - ]: 24 : ABI_SFREE(gstore%qibz)
3243 [ + - ]: 24 : ABI_SFREE(gstore%wtq)
3244 [ + - ]: 24 : ABI_SFREE(gstore%my_spins)
3245 [ + - ]: 24 : ABI_SFREE(gstore%brange_k_spin)
3246 [ + - ]: 24 : ABI_SFREE(gstore%brange_kq_spin)
3247 [ + - ]: 24 : ABI_SFREE(gstore%glob_nk_spin)
3248 [ + - ]: 24 : ABI_SFREE(gstore%glob_nq_spin)
3249 [ + - ]: 24 : ABI_SFREE(gstore%kglob2bz)
3250 [ + - ]: 24 : ABI_SFREE(gstore%kbz2ibz)
3251 [ + - ]: 24 : ABI_SFREE(gstore%erange_spin)
3252 [ + - ]: 24 : ABI_SFREE(gstore%qbz)
3253 [ + - ]: 24 : ABI_SFREE(gstore%kbz)
3254 : :
3255 [ - + ]: 24 : if (gstore%has_wannier) then
3256 : 0 : call gstore%ebands%free()
3257 [ # # # # : 0 : ABI_FREE_SCALAR(gstore%ebands)
# # # # #
# # # # #
# # # # #
# # # #
# ]
3258 : : nullify(gstore%ebands)
3259 : : end if
3260 : :
3261 : 24 : call gstore%krank_ibz%free()
3262 : 24 : call gstore%qrank_ibz%free()
3263 : 24 : gstore%with_cplex = -1
3264 : :
3265 : 24 : end subroutine gstore_free
3266 : : !!***
3267 : :
3268 : : !----------------------------------------------------------------------
3269 : :
3270 : : !!****f* m_gstore/gqk_myqpt
3271 : : !! NAME
3272 : : !! gqk_myqpt
3273 : : !!
3274 : : !! FUNCTION
3275 : : !! Return the weight_q and the reduced coordinates of the q-point from the local index my_iq.
3276 : : !!
3277 : : !! INPUTS
3278 : : !!
3279 : : !! OUTPUT
3280 : : !!
3281 : : !! SOURCE
3282 : :
3283 : 77422 : pure subroutine gqk_myqpt(gqk, my_iq, gstore, weight_q, qpt)
3284 : :
3285 : : !Arguments ------------------------------------
3286 : : class(gqk_t),intent(in) :: gqk
3287 : : class(gstore_t),intent(in) :: gstore
3288 : : integer,intent(in) :: my_iq
3289 : : real(dp),intent(out) :: weight_q, qpt(3)
3290 : :
3291 : : !Local variables ------------------------------
3292 : : integer :: iq_ibz, isym_q, trev_q, tsign_q, g0_q(3)
3293 : : logical :: isirr_q
3294 : : !----------------------------------------------------------------------
3295 : :
3296 : : ! Symmetry tables for q-points.
3297 : 77422 : iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
3298 [ + + ]: 309688 : trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5, my_iq)
3299 : : isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
3300 [ - + ]: 77422 : tsign_q = 1; if (trev_q == 1) tsign_q = -1
3301 : :
3302 : : ! NB: Use symrec convention for q
3303 [ + + + + : 2167816 : qpt = tsign_q * matmul(gstore%cryst%symrec(:,:,isym_q), gstore%qibz(:, iq_ibz)) + g0_q
+ + + + +
- + - +
+ ]
3304 : :
3305 : 0 : select case(gstore%qzone)
3306 : : case ("ibz")
3307 : 0 : weight_q = gstore%wtq(iq_ibz)
3308 : : case ("bz")
3309 [ - + - ]: 77422 : weight_q = one / gstore%nqbz
3310 : : end select
3311 : :
3312 : 77422 : end subroutine gqk_myqpt
3313 : : !!***
3314 : :
3315 : : !----------------------------------------------------------------------
3316 : :
3317 : : !!****f* m_gstore/gqk_dbldelta_qpt
3318 : : !! NAME
3319 : : !! gqk_dbldelta_qpt
3320 : : !!
3321 : : !! FUNCTION
3322 : : !! Note that k/q weights are not included in dbl_delta_q
3323 : : !!
3324 : : !! INPUTS
3325 : : !!
3326 : : !! OUTPUT
3327 : : !!
3328 : : !! SOURCE
3329 : :
3330 : 0 : subroutine gqk_dbldelta_qpt(gqk, my_iq, gstore, eph_intmeth, eph_fsmear, qpt, weight_q, dbl_delta_q)
3331 : :
3332 : : !Arguments ------------------------------------
3333 : : class(gqk_t),intent(in) :: gqk
3334 : : class(gstore_t),target,intent(inout) :: gstore
3335 : : integer,intent(in) :: my_iq, eph_intmeth
3336 : : real(dp),intent(in) :: eph_fsmear
3337 : : real(dp),intent(out) :: qpt(3), weight_q, dbl_delta_q(gqk%nb_kq, gqk%nb_k, gqk%my_nk)
3338 : :
3339 : : !Local variables ------------------------------
3340 : : !scalars
3341 : : real(dp), parameter :: min_smear = tol9
3342 : : integer :: nb_k, nb_kq, nkbz, spin, my_ik, ib, ib1, ib2, band1, band2, nesting
3343 : : integer :: ik_ibz, isym_k, trev_k, tsign_k, g0_k(3)
3344 : : integer :: ikq_ibz, isym_kq, trev_kq, tsign_kq, g0_kq(3), ii, i1, i2, i3, cnt, ik_bz, ltetra
3345 : : real(dp) :: g1, g2, sigma !, weight_k !, cpu, wall, gflops
3346 : : logical :: isirr_k, isirr_kq, use_adaptive
3347 : : type(ebands_t), pointer :: ebands
3348 : : type(crystal_t), pointer :: cryst
3349 : 0 : type(krank_t) :: my_krank
3350 : : !arrays
3351 : : integer :: nge(3), ngw(3)
3352 : 0 : integer,allocatable :: my_kqmap(:,:), kmesh_map(:,:)
3353 : 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)
3354 : 0 : real(dp),allocatable :: eig_k(:,:), eig_kq(:,:), kmesh(:,:), wght_bz(:,:,:)
3355 : : !----------------------------------------------------------------------
3356 : :
3357 : 0 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq; nkbz = gstore%nkbz; spin = gqk%spin
3358 : 0 : ebands => gstore%ebands; cryst => gstore%cryst
3359 : :
3360 [ # # ]: 0 : ABI_CHECK_IEQ(nb_k, nb_kq, "gqk_dbldelta_qpt does not support nb_k != nb_kq")
3361 : :
3362 : 0 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3363 : :
3364 : : ! The double delta with tetra is ill-defined for q == 0. In this case we fall back to gaussian.
3365 [ # # # # : 0 : nesting = merge(1, 0, abs(eph_intmeth) == 2 .and. all(abs(qpt) < tol12))
# # # # ]
3366 : :
3367 [ # # # # ]: 0 : rlatt = gstore%ebands%kptrlatt; call matr3inv(rlatt, klatt)
3368 [ # # ]: 0 : kmesh_cartvec(:, 1) = cryst%gprimd(:,1)*klatt(1,1) + cryst%gprimd(:,2)*klatt(2,1) + cryst%gprimd(:,3)*klatt(3,1)
3369 [ # # ]: 0 : kmesh_cartvec(:, 2) = cryst%gprimd(:,1)*klatt(1,2) + cryst%gprimd(:,2)*klatt(2,2) + cryst%gprimd(:,3)*klatt(3,2)
3370 [ # # ]: 0 : kmesh_cartvec(:, 3) = cryst%gprimd(:,1)*klatt(1,3) + cryst%gprimd(:,2)*klatt(2,3) + cryst%gprimd(:,3)*klatt(3,3)
3371 : : ! TODO: It seems that two_pi is not needed here!
3372 : :
3373 [ # # # # ]: 0 : if (abs(eph_intmeth) == 1 .or. nesting /= 0) then
3374 [ # # # # ]: 0 : use_adaptive = eph_fsmear < zero .or. abs(eph_intmeth) == 2
3375 : : if (use_adaptive) then
3376 [ # # ]: 0 : ABI_CHECK(allocated(gqk%vnk_cart_ibz), "vnk_cart_ibz should be allocated when use_adaptive is .True.")
3377 : : end if
3378 : :
3379 : : ! Find k + q in the IBZ for all my k-points.
3380 [ # # # # : 0 : ABI_MALLOC(my_kqmap, (6, gqk%my_nk))
# # # # #
# # # ]
3381 [ # # ]: 0 : if (kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, my_kqmap, qpt=qpt) /= 0) then
3382 : 0 : ABI_ERROR(sjoin("Cannot map k+q to IBZ with qpt:", ktoa(qpt)))
3383 : : end if
3384 : :
3385 : : ! Init default sigma
3386 : 0 : sigma = eph_fsmear
3387 : :
3388 [ # # ]: 0 : do my_ik=1,gqk%my_nk
3389 : 0 : kk = gqk%my_kpts(:, my_ik)
3390 : :
3391 : 0 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
3392 [ # # ]: 0 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5, my_ik)
3393 [ # # # # : 0 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
# # # # ]
3394 [ # # ]: 0 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
3395 : :
3396 : 0 : ikq_ibz = my_kqmap(1, my_ik); isym_kq = my_kqmap(2, my_ik)
3397 [ # # ]: 0 : trev_kq = my_kqmap(6, my_ik); g0_kq = my_kqmap(3:5, my_ik)
3398 [ # # # # : 0 : isirr_kq = (isym_kq == 1 .and. trev_kq == 0 .and. all(g0_kq == 0))
# # # # ]
3399 [ # # ]: 0 : tsign_kq = 1; if (trev_kq == 1) tsign_kq = -1
3400 : :
3401 [ # # ]: 0 : if (use_adaptive) then
3402 : : ! If k or k+q is not in the IBZ, we need to recostruct the value by symmetry using v(Sq) = S v(q).
3403 : : ! Use transpose(R) because we are using the tables for the wavefunctions
3404 : : ! In this case listkk has been called with symrec and use_symrec=False
3405 : : ! so q_bz = S^T q_ibz where S is the isym_kq symmetry
3406 [ # # # # ]: 0 : vb_k = gqk%vnk_cart_ibz(:,:,ik_ibz)
3407 [ # # # # ]: 0 : vb_kq = gqk%vnk_cart_ibz(:,:,ikq_ibz)
3408 : :
3409 [ # # ]: 0 : if (.not. isirr_k) then
3410 [ # # ]: 0 : do ib=1,nb_k
3411 [ # # # # ]: 0 : vb_k(:,ib) = tsign_k * matmul(transpose(cryst%symrel_cart(:,:,isym_k)), vb_k(:,ib))
3412 : : end do
3413 : : end if
3414 [ # # ]: 0 : if (.not. isirr_kq) then
3415 [ # # ]: 0 : do ib=1,nb_kq
3416 [ # # # # ]: 0 : vb_kq(:,ib) = tsign_kq * matmul(transpose(cryst%symrel_cart(:,:,isym_kq)), vb_kq(:,ib))
3417 : : end do
3418 : : end if
3419 : : end if
3420 : :
3421 [ # # ]: 0 : do ib2=1,nb_k
3422 : 0 : band2 = ib2 + gqk%bstart_k - 1
3423 [ # # ]: 0 : if (use_adaptive) then
3424 [ # # # # : 0 : sigma = max(maxval([(abs(dot_product(vb_k(:, ib2), kmesh_cartvec(:,ii))), ii=1,3)]), min_smear)
# # # # #
# ]
3425 : : !write(std_out, *)"sigma:", sigma * Ha_eV
3426 : : end if
3427 : 0 : g2 = gaussian(ebands%eig(band2, ik_ibz, spin) - ebands%fermie, sigma)
3428 : :
3429 [ # # ]: 0 : do ib1=1,nb_kq
3430 : 0 : band1 = ib1 + gqk%bstart_kq - 1
3431 [ # # ]: 0 : if (use_adaptive) then
3432 [ # # # # : 0 : sigma = max(maxval([(abs(dot_product(vb_kq(:, ib1), kmesh_cartvec(:,ii))), ii=1,3)]), min_smear)
# # # # #
# ]
3433 : : end if
3434 : 0 : g1 = gaussian(ebands%eig(band1, ikq_ibz, spin) - ebands%fermie, sigma)
3435 : 0 : dbl_delta_q(ib1, ib2, my_ik) = g1 * g2 ! / fs%nktot
3436 : : end do
3437 : :
3438 : : end do
3439 : : end do
3440 : :
3441 [ # # ]: 0 : ABI_FREE(my_kqmap)
3442 : :
3443 [ # # ]: 0 : else if (abs(eph_intmeth) == 2) then
3444 : :
3445 [ # # ]: 0 : ABI_CHECK(isdiagmat(ebands%kptrlatt), "kptrlatt must be diagonal when tetra is used.")
3446 [ # # ]: 0 : ABI_CHECK(ebands%nshiftk == 1, "nshiftk must be 1 when tetra is used")
3447 : 0 : nge = get_diag(ebands%kptrlatt); ngw = nge
3448 [ # # # # : 0 : ABI_CHECK_IEQ(nkbz, product(nge(1:3)), "Wrong nge")
# # ]
3449 : :
3450 : : ! Compute eig_k and eig_kq in full BZ for the relevant bands around Ef.
3451 [ # # # # : 0 : ABI_MALLOC(kmesh, (3, nkbz))
# # # # #
# # # ]
3452 [ # # # # : 0 : ABI_MALLOC(eig_k, (nb_k, nkbz))
# # # # #
# # # # #
# # ]
3453 [ # # # # : 0 : ABI_MALLOC(eig_kq, (nb_kq, nkbz))
# # # # #
# # # # #
# # ]
3454 : :
3455 : : ! Technical problems:
3456 : : !
3457 : : ! 1) libtetrabz works with the BZ and assumes a certaing ordering of the k-points (see below)
3458 : : ! so we have to fill the array with eig_k and eig_kq from the IBZ by remapping the libtetra kk
3459 : : ! to the Abinit IBZ
3460 : :
3461 : : ! 2) The dbldelta weights are given in the BZ, while the caller requires weights for k in the IBZ
3462 : : ! and moreover only for the IBZ k-point treated by this MPI proc.
3463 : :
3464 : 0 : ik_bz = 0
3465 [ # # ]: 0 : do i3=0,nge(3) - 1
3466 [ # # ]: 0 : do i2=0,nge(2) - 1
3467 [ # # ]: 0 : do i1=0,nge(1) - 1
3468 : 0 : ik_bz = ik_bz + 1
3469 [ # # ]: 0 : kk = ([i1, i2, i3] + ebands%shiftk(:, 1)) / nge(:)
3470 [ # # ]: 0 : kmesh(:, ik_bz) = kk
3471 : : end do
3472 : : end do
3473 : : end do
3474 : :
3475 : : ! Map libtetra BZ mesh to IBZ and fill eig_k
3476 : : !call cwtime(cpu, wall, gflops, "start")
3477 [ # # # # : 0 : ABI_MALLOC(kmesh_map, (6, nkbz))
# # # # #
# # # ]
3478 : :
3479 : : ! Find correspondence between libtetra mesh and the IBZ.
3480 [ # # ]: 0 : if (kpts_map("symrec", ebands%kptopt, cryst, gstore%krank_ibz, nkbz, kmesh, kmesh_map) /= 0) then
3481 : 0 : ABI_ERROR("Cannot map libtetra mesh to IBZ")
3482 : : end if
3483 : :
3484 [ # # ]: 0 : do ik_bz=1,nkbz
3485 : 0 : ik_ibz = kmesh_map(1, ik_bz)
3486 [ # # ]: 0 : eig_k(:, ik_bz) = ebands%eig(gqk%bstart_k:gqk%bstop_k, ik_ibz, spin) - ebands%fermie
3487 : : end do
3488 : :
3489 : : ! Map libtetra BZ mesh + q to IBZ and fill eig_kq.
3490 [ # # ]: 0 : if (kpts_map("symrec", ebands%kptopt, cryst, gstore%krank_ibz, nkbz, kmesh, kmesh_map, qpt=qpt) /= 0) then
3491 : 0 : ABI_ERROR(sjoin("Cannot map libtetra k+q to IBZ with qpt:", ktoa(qpt)))
3492 : : end if
3493 : :
3494 [ # # ]: 0 : do ik_bz=1,nkbz
3495 : 0 : ikq_ibz = kmesh_map(1, ik_bz)
3496 [ # # ]: 0 : eig_kq(:, ik_bz) = ebands%eig(gqk%bstart_kq:gqk%bstop_kq, ikq_ibz, spin) - ebands%fermie
3497 : : end do
3498 : :
3499 [ # # ]: 0 : ABI_FREE(kmesh_map)
3500 : : !call cwtime_report(" kmesh_map", cpu, wall, gflops)
3501 : :
3502 : : ! Call libtetra routine to compute weights for double delta integration.
3503 : : ! Note that libtetra assumes Ef set to zero.
3504 : : ! TODO: Average weights over degenerate states?
3505 : : ! NB: This is a bottleneck, can pass comm_kp
3506 : :
3507 : : ! Select option for double delta with tetra.
3508 : : ! 2 for the optimized tetrahedron method.
3509 : : ! -2 for the linear tetrahedron method.
3510 : 0 : ltetra = 0
3511 [ # # ]: 0 : if (eph_intmeth == 2) ltetra = 2
3512 [ # # ]: 0 : if (eph_intmeth == -2) ltetra = 1
3513 : :
3514 [ # # # # : 0 : ABI_MALLOC(wght_bz, (nb_k, nb_kq, nkbz))
# # # # #
# # # # #
# # # # #
# ]
3515 : 0 : call libtetrabz_dbldelta(ltetra, gstore%cryst%gprimd, nb_k, nge, eig_k, eig_kq, ngw, wght_bz) !, comm=comm)
3516 : : !call cwtime_report(" libtetrabz_dbldelta", cpu, wall, gflops)
3517 : :
3518 : 0 : call my_krank%init(gqk%my_nk, gqk%my_kpts)
3519 : :
3520 : : ! Reindex from full BZ to my set of kpoints and rescale weights.
3521 : 0 : cnt = 0
3522 [ # # ]: 0 : do ik_bz=1,nkbz
3523 : 0 : my_ik = my_krank%get_index(kmesh(:, ik_bz))
3524 [ # # ]: 0 : if (my_ik /= -1) then
3525 [ # # # # ]: 0 : dbl_delta_q(:,:,my_ik) = wght_bz(:,:,ik_bz) * gstore%nkbz
3526 : 0 : cnt = cnt + 1
3527 : : end if
3528 : : end do
3529 : :
3530 : : ! FIXME: BUG if k-point (and q-point) parallelism.
3531 [ # # ]: 0 : ABI_CHECK_IEQ(cnt, gqk%my_nk, sjoin("cnt != my_nk, ", itoa(cnt), itoa(gqk%my_nk)))
3532 : 0 : call my_krank%free()
3533 : : !call cwtime_report(" transfer", cpu, wall, gflops)
3534 : :
3535 [ # # ]: 0 : ABI_FREE(wght_bz)
3536 [ # # ]: 0 : ABI_FREE(kmesh)
3537 [ # # ]: 0 : ABI_FREE(eig_k)
3538 [ # # ]: 0 : ABI_FREE(eig_kq)
3539 : :
3540 : : else
3541 : 0 : ABI_ERROR(sjoin("Invalid eph_intmeth:", itoa(eph_intmeth)))
3542 : : end if
3543 : :
3544 [ # # # # : 0 : end subroutine gqk_dbldelta_qpt
# # ]
3545 : : !!***
3546 : : !----------------------------------------------------------------------
3547 : :
3548 : : !!****f* m_gstore/gqk_free
3549 : : !! NAME
3550 : : !! gqk_free
3551 : : !!
3552 : : !! FUNCTION
3553 : : !! Free dynamic memory in gqk_t instance.
3554 : : !!
3555 : : !! SOURCE
3556 : :
3557 : 24 : subroutine gqk_free(gqk)
3558 : :
3559 : : !Arguments ------------------------------------
3560 : : class(gqk_t),intent(inout) :: gqk
3561 : : !----------------------------------------------------------------------
3562 : :
3563 [ + - ]: 24 : ABI_SFREE(gqk%my_k2ibz)
3564 [ + - ]: 24 : ABI_SFREE(gqk%my_kpts)
3565 [ + - ]: 24 : ABI_SFREE(gqk%my_wtk)
3566 [ + - ]: 24 : ABI_SFREE(gqk%my_q2ibz)
3567 [ + - ]: 24 : ABI_SFREE(gqk%my_q2bz)
3568 [ + - ]: 24 : ABI_SFREE(gqk%my_k2glob)
3569 [ + - ]: 24 : ABI_SFREE(gqk%my_q2glob)
3570 [ + + ]: 24 : ABI_SFREE(gqk%my_wnuq)
3571 [ + + ]: 24 : ABI_SFREE(gqk%my_displ_cart)
3572 [ - + ]: 24 : ABI_SFREE(gqk%my_iv1p_comm)
3573 [ + - ]: 24 : ABI_SFREE(gqk%my_pertcases)
3574 [ + + ]: 24 : ABI_SFREE(gqk%vnk_cart_ibz)
3575 [ - + ]: 24 : ABI_SFREE(gqk%vnk_mat_cart_ibz)
3576 : :
3577 [ + + ]: 24 : ABI_SFREE(gqk%my_g)
3578 [ + + ]: 24 : ABI_SFREE(gqk%my_g2)
3579 [ + + ]: 24 : ABI_SFREE(gqk%my_gdw2)
3580 [ + + ]: 24 : if (gqk%has_both_g) then
3581 [ + + ]: 9 : ABI_SFREE_PTR(gqk%my_g_ks)
3582 [ + + ]: 9 : ABI_SFREE_PTR(gqk%my_g2_ks)
3583 [ + + ]: 9 : ABI_SFREE_PTR(gqk%my_gdw2_ks)
3584 : : end if
3585 : :
3586 : 24 : call gqk%wan%free()
3587 : :
3588 : : ! Free MPI communicators
3589 : 24 : call gqk%kpt_comm%free(); call gqk%qpt_comm%free(); call gqk%qpt_kpt_comm%free()
3590 : 24 : call gqk%pert_comm%free(); call gqk%band_comm%free(); call gqk%qpt_pert_comm%free()
3591 : 24 : call gqk%pert_ppsum_comm%free(); call gqk%pert_ppsum_bsum_comm%free()
3592 : 24 : call gqk%comm%free(); call gqk%bsum_comm%free(); call gqk%pp_sum_comm%free()
3593 : :
3594 : 24 : end subroutine gqk_free
3595 : : !!***
3596 : :
3597 : : !!****f* m_gstore/gstore_get_missing_qbz_spin
3598 : : !! NAME
3599 : : !! gstore_get_missing_qbz_spin
3600 : : !!
3601 : : !! FUNCTION
3602 : : !! Return the number of (q-points, spin) entries that have been computed.
3603 : : !!
3604 : : !! SOURCE
3605 : :
3606 : 9 : subroutine gstore_get_missing_qbz_spin(gstore, done_qbz_spin, ndone, nmiss)
3607 : :
3608 : : !Arguments ------------------------------------
3609 : : class(gstore_t),intent(in) :: gstore
3610 : : integer,intent(in) :: done_qbz_spin(gstore%nqbz, gstore%nsppol)
3611 : : integer,intent(out) :: ndone, nmiss
3612 : :
3613 : : !Local variables ------------------------------
3614 : : integer :: my_is, my_iq, iq_bz, spin, ierr, nscale
3615 : : !----------------------------------------------------------------------
3616 : :
3617 : 3 : ndone = 0; nmiss = 0
3618 [ + + ]: 6 : do my_is=1,gstore%my_nspins
3619 : 3 : associate (gqk => gstore%gqk(my_is))
3620 : 3 : spin = gstore%my_spins(my_is)
3621 [ + + ]: 83 : do my_iq=1,gqk%my_nq
3622 : 80 : iq_bz = gqk%my_q2bz(my_iq)
3623 [ + - ]: 80 : if (done_qbz_spin(iq_bz, spin) == 0) nmiss = nmiss + 1
3624 [ - + ]: 83 : if (done_qbz_spin(iq_bz, spin) == 1) ndone = ndone + 1
3625 : : end do ! my_iq
3626 : : ! Rescale to avoid overcounting in xmpi_summ
3627 : 3 : nscale = (gqk%pert_comm%nproc * gqk%bsum_comm%nproc * gqk%pp_sum_comm%nproc)
3628 : 3 : nmiss = nmiss / nscale
3629 : 6 : ndone = ndone / nscale
3630 : : end associate
3631 : : end do ! my_is
3632 : :
3633 : 3 : call xmpi_sum(ndone, gstore%comm, ierr)
3634 : 3 : call xmpi_sum(nmiss, gstore%comm, ierr)
3635 : :
3636 : 3 : end subroutine gstore_get_missing_qbz_spin
3637 : : !!***
3638 : :
3639 : : !!****f* m_gstore/gstore_set_perts_distrib
3640 : : !! NAME
3641 : : !! gstore_set_perts_distrib
3642 : : !!
3643 : : !! FUNCTION
3644 : : !! Activate parallelism over perturbations at the level of the DVDB file.
3645 : : !!
3646 : : !! SOURCE
3647 : :
3648 : 18 : subroutine gstore_set_perts_distrib(gstore, cryst, dvdb, my_npert)
3649 : :
3650 : : !Arguments ------------------------------------
3651 : : class(gstore_t),intent(in) :: gstore
3652 : : type(crystal_t),intent(in) :: cryst
3653 : : type(dvdb_t),intent(inout) :: dvdb
3654 : : integer,intent(out) :: my_npert
3655 : :
3656 : : !Local variables ------------------------------
3657 : : !scalars
3658 : : integer :: my_is, spin
3659 : : !arrays
3660 : 18 : integer,allocatable :: my_pinfo(:,:), pert_table(:,:)
3661 : : !----------------------------------------------------------------------
3662 : :
3663 : 18 : my_npert = cryst%natom * 3
3664 [ + + ]: 36 : do my_is=1,gstore%my_nspins
3665 : 18 : associate (gqk => gstore%gqk(my_is))
3666 : 18 : spin = gstore%my_spins(my_is)
3667 [ - + ]: 18 : if (gqk%pert_comm%nproc > 1) then
3668 : : ! Activate parallelism over perturbations
3669 : : ! Build table with list of perturbations treated by this MPI rank inside pert_comm.
3670 : : !ABI_WARNING("GSTORE with pert_comm%nproc > 1 not tested")
3671 : 0 : my_npert = gqk%my_npert
3672 [ # # # # ]: 0 : call ephtk_set_pertables(cryst%natom, my_npert, pert_table, my_pinfo, gqk%pert_comm%value)
3673 : 0 : call dvdb%set_pert_distrib(my_npert, cryst%natom * 3, my_pinfo, pert_table, gqk%pert_comm%value)
3674 [ # # # # : 0 : ABI_CHECK(all(my_pinfo(3, :) == gqk%my_pertcases), "my_pinfo(3, :) != gqk%my_pertcases")
# # ]
3675 : :
3676 [ # # ]: 0 : ABI_FREE(my_pinfo)
3677 [ # # ]: 0 : ABI_FREE(pert_table)
3678 : : end if
3679 : : end associate
3680 : : end do
3681 : :
3682 [ - + - + ]: 18 : end subroutine gstore_set_perts_distrib
3683 : : !!***
3684 : :
3685 : : !----------------------------------------------------------------------
3686 : :
3687 : : !!****f* m_gstore/gstore_compute
3688 : : !! NAME
3689 : : !! gstore_compute
3690 : : !!
3691 : : !! FUNCTION
3692 : : !! Compute MPI-distributed e-ph matrix elements
3693 : : !!
3694 : : !! INPUTS
3695 : : !! wk0_path=String with the path to the GS unperturbed WFK file.
3696 : : !! ngfft(18),ngfftf(18)=Coarse and Fine FFT meshes.
3697 : : !! dtset<dataset_type>=All input variables for this dataset.
3698 : : !! ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...)
3699 : : !! dvdb<dbdb_type>=Database with the DFPT SCF potentials.
3700 : : !! pawfgr <type(pawfgr_type)>=fine grid parameters and related data
3701 : : !! pawang<pawang_type)>=PAW angular mesh and related data.
3702 : : !! pawrad(ntypat*usepaw)<pawrad_type>=Paw radial mesh and related data.
3703 : : !! pawtab(ntypat*usepaw)<pawtab_type>=Paw tabulated starting data.
3704 : : !! psps<pseudopotential_type>=Variables related to pseudopotentials.
3705 : : !! comm=MPI communicator.
3706 : : !!
3707 : : !! OUTPUT
3708 : : !! GSTORE.nc file
3709 : : !!
3710 : : !! SOURCE
3711 : :
3712 : 5 : subroutine gstore_compute(gstore, wfk0_path, ngfft, ngfftf, dtset, dtfil, cryst, ebands, ifc, dvdb, &
3713 : 5 : pawfgr, pawang, pawrad, pawtab, psps, mpi_enreg, comm)
3714 : :
3715 : : !Arguments ------------------------------------
3716 : : !scalars
3717 : : class(gstore_t),target,intent(inout) :: gstore
3718 : : character(len=*),intent(in) :: wfk0_path
3719 : : integer,intent(in) :: comm
3720 : : type(dataset_type),intent(in) :: dtset
3721 : : type(datafiles_type),intent(in) :: dtfil
3722 : : type(crystal_t),intent(in) :: cryst
3723 : : type(ebands_t),intent(in) :: ebands
3724 : : class(ifc_type),intent(in) :: ifc
3725 : : type(dvdb_t),intent(inout) :: dvdb
3726 : : type(pawang_type),intent(in) :: pawang
3727 : : type(pseudopotential_type),intent(in) :: psps
3728 : : type(pawfgr_type),intent(in) :: pawfgr
3729 : : type(mpi_type),intent(in) :: mpi_enreg
3730 : : !arrays
3731 : : integer,intent(in) :: ngfft(18),ngfftf(18)
3732 : : type(pawrad_type),intent(in) :: pawrad(psps%ntypat*psps%usepaw)
3733 : : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
3734 : :
3735 : : !Local variables ------------------------------
3736 : : !scalars
3737 : : integer,parameter :: tim_getgh1c = 1, berryopt0 = 0, ider0 = 0, idir0 = 0, LOG_MODQ = 5, master = 0, ndat1 = 1
3738 : : integer :: my_rank,nproc,mband,nsppol,nkibz,idir,ipert, iq_bz
3739 : : integer :: cplex,natom,natom3,ipc,nspinor, nskip_tetra_kq, timrev_k, timrev_q
3740 : : integer :: band_k, in_k, ik_ibz,ikq_ibz,isym_k,isym_kq,trev_k,trev_kq, nb_k, nb_kq ! im_kq,
3741 : : integer :: my_ik, my_is, comm_rpt, my_npert, my_ip, my_iq, spin,istwf_k,istwf_kq,npw_k,npw_kq
3742 : : integer :: mpw, ierr, n1,n2,n3,n4,n5,n6,nspden,ndone, db_iqpt
3743 : : integer :: sij_opt,usecprj,usevnl,optlocal,optnl,opt_gvnlx1
3744 : : integer :: nfft,nfftf,mgfft,mgfftf, nkpg_k, nkpg_kq, qbuf_size, iqbuf_cnt, root_ncid, spin_ncid, ncerr
3745 : : integer :: ii, iq_ibz, isym_q, trev_q
3746 : : real(dp) :: cpu_q, wall_q, gflops_q, cpu_all, wall_all, gflops_all ! cpu, wall, gflops,
3747 : : real(dp) :: ecut, weight_q, weight_k ! eshift,
3748 : : logical :: gen_eigenpb, isirr_k, isirr_kq, isirr_q, print_time, need_ftinterp, qq_is_gamma, symmetrize, use_lgk
3749 : 5 : type(wfd_t) :: wfd
3750 : 5 : type(gs_hamiltonian_type) :: gs_ham_kq
3751 : 5 : type(rf_hamiltonian_type) :: rf_ham_kq
3752 : : type(gqk_t),pointer :: gqk
3753 : 5 : type(lgroup_t) :: lg_myq
3754 : : character(len=5000) :: msg, qq_bz_string, kk_string
3755 : : !arrays
3756 : : integer :: g0_k(3), g0_kq(3), g0_q(3), work_ngfft(18),gmax(3),indkk_kq(6,1), units(2), qbz2dvdb(6)
3757 : 5 : integer,allocatable :: kg_k(:,:), kg_kq(:,:), nband(:,:), wfd_istwfk(:), qmap_symrec(:,:)
3758 : 5 : integer,allocatable :: iq_buf(:,:), done_qbz_spin(:,:), state_kq(:,:)
3759 : : !integer,allocatable :: qibz2dvdb(:) !, displs(:), recvcounts(:)
3760 : : real(dp) :: kk_bz(3),kq_bz(3),kk_ibz(3),kq_ibz(3), qq_bz(3), qq_ibz(3) !, v_nk(3)
3761 : 5 : real(dp),allocatable :: displ_cart_qibz(:,:,:,:), lambda(:)
3762 : 5 : real(dp),allocatable :: grad_berry(:,:), kinpw_k(:), kinpw_kq(:), kpg_kq(:,:), kpg_k(:,:)
3763 : 5 : real(dp),allocatable :: ffnl_k(:,:,:,:), ffnl_kq(:,:,:,:), ph3d_k(:,:,:), ph3d_kq(:,:,:)
3764 : 5 : real(dp),allocatable :: v1scf(:,:,:,:), gkq_atm(:,:,:,:), gkq_atm_ipc(:,:,:)
3765 : 5 : real(dp),allocatable :: bras_kq(:,:,:), kets_k(:,:,:), h1_kets_kq(:,:,:) !, cgwork(:,:)
3766 : 5 : real(dp),allocatable :: ph1d(:,:), vlocal(:,:,:,:), vlocal1(:,:,:,:,:)
3767 : 5 : real(dp),allocatable :: dummy_vtrial(:,:), gvnlx1(:,:,:), work(:,:,:,:)
3768 : 5 : real(dp),allocatable :: gs1c_kq(:,:) !, vnk_cart_ibz(:,:,:) !, vkq_cart_ibz(:,:,:) !, vnk_mat_cart_ibz(:,:,:,:)
3769 : 5 : real(dp),allocatable :: my_gbuf(:,:,:,:,:,:)
3770 : 5 : logical,allocatable :: bks_mask(:,:,:),keep_ur(:,:,:)
3771 : 5 : type(pawcprj_type),allocatable :: cwaveprj0(:,:)
3772 : 5 : type(lgroup_t),allocatable :: lg_myk(:)
3773 : : !************************************************************************
3774 : :
3775 : 5 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
3776 [ + + ]: 15 : units = [std_out, ab_out]
3777 : :
3778 [ - + ]: 5 : if (psps%usepaw == 1) then
3779 : 0 : ABI_ERROR("PAW not implemented")
3780 : : ABI_UNUSED((/pawang%nsym, pawrad(1)%mesh_size/))
3781 : : end if
3782 : :
3783 : : ! Check MPI distribution: abort if there are any idle processes in the loops over k and q.
3784 : : ! NOTE that we have to perform this check only at the level of gstore%compute.
3785 : : ! The k- and q-points distributed inside kpt_comm and qpt_comm are the glob_nk and glob_nq points of the gstore
3786 : : ! (e.g. q in the full BZ), not the IBZ points. The IBZ-based steps (phonons, velocities) support nproc > nqibz.
3787 [ + + ]: 10 : do my_is=1,gstore%my_nspins
3788 : 5 : gqk => gstore%gqk(my_is)
3789 [ + - - + ]: 10 : if (gqk%kpt_comm%nproc > gqk%glob_nk .or. gqk%qpt_comm%nproc > gqk%glob_nq) then
3790 : 0 : write(msg, "(4(a,i0),4a)") "gstore%compute: kpt_comm%nproc=", gqk%kpt_comm%nproc, " > glob_nk=", gqk%glob_nk, &
3791 : 0 : " or qpt_comm%nproc=", gqk%qpt_comm%nproc, " > glob_nq=", gqk%glob_nq, ch10, &
3792 : 0 : "This will lead to idle processes, which are not supported.", ch10, &
3793 : 0 : "Please decrease the number of CPUs for k-points or q-points (eph_np_pqbks)"
3794 : 0 : ABI_ERROR(msg)
3795 : : endif
3796 : : enddo
3797 : :
3798 : : ! This parameter defines the size of the q-buffer used to store the g(k, q) e-ph matrix elements
3799 : : ! for all the k-point treated by this MPI rank.
3800 : : ! Increasing the buffer size increases the memory requirements
3801 : : ! but it leads to better performance as the number of IO operations is decreased.
3802 : : ! TODO: Should compute it on the basis of my_nkpt and my_nqpt
3803 : 5 : qbuf_size = 16
3804 : 5 : call wrtout(std_out, sjoin(" Begin computation of e-ph matrix elements with qbuf_size:", itoa(qbuf_size)), pre_newlines=1)
3805 : 5 : call pstat_proc%print(_PSTAT_ARGS_)
3806 : 5 : call cwtime(cpu_all, wall_all, gflops_all, "start")
3807 : :
3808 : : ! If True, only k-points in the IBZ and q-points in the IBZ_k are computed.
3809 : : ! Matrix elements in full BZs are then reconstructed by symmetry at the end of the run by calling
3810 : : ! gstore_symmetrize.
3811 : : symmetrize = (dtset%gstore_kzone == "bz" .and. dtset%gstore_qzone == "bz" &
3812 : : .and. dtset%gstore_sym > 0 &
3813 [ + + + - : 5 : )
+ - ]
3814 : : !if (symmetrize) call wrtout(units, " Computing g(k, q) with k in the IBZ and q in the BZ + final reconstruction")
3815 : :
3816 : : ! Copy important dimensions
3817 : 5 : natom = cryst%natom; natom3 = 3 * natom; nsppol = ebands%nsppol; nspinor = ebands%nspinor; nspden = dtset%nspden
3818 : 5 : nkibz = ebands%nkpt; mband = ebands%mband
3819 : :
3820 : : ! FFT meshes
3821 [ + + ]: 20 : nfftf = product(ngfftf(1:3)); mgfftf = maxval(ngfftf(1:3))
3822 [ + + + + ]: 35 : nfft = product(ngfft(1:3)) ; mgfft = maxval(ngfft(1:3))
3823 : 5 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); n4 = ngfft(4); n5 = ngfft(5); n6 = ngfft(6)
3824 : :
3825 : : ! Open the DVDB file
3826 : 5 : call dvdb%open_read(ngfftf, xmpi_comm_self)
3827 [ - + ]: 5 : ABI_CHECK(dvdb%has_fields("pot1", msg), msg)
3828 : :
3829 : : ! Activate parallelism over perturbations at the level of the DVDB
3830 : 5 : call gstore%set_perts_distrib(cryst, dvdb, my_npert)
3831 : :
3832 : : ! Prepare Fourier interpolation of DFPT potentials.
3833 : 5 : comm_rpt = xmpi_comm_self
3834 : : !comm_rpt = bqs_comm%value
3835 : :
3836 : : ! qmap_symrec gives the mapping gstore%ibz --> dvdb%ibz
3837 [ - + ]: 5 : call dvdb%need_ftinterp(gstore%nqibz, gstore%qibz, gstore%qptopt, qmap_symrec, need_ftinterp)
3838 [ - + ]: 5 : ABI_FREE(qmap_symrec)
3839 : : !need_ftinterp = .True.
3840 : :
3841 [ + + - + ]: 5 : if (.not. need_ftinterp .and. dtset%eph_use_ftinterp /= 0) then
3842 : 0 : ABI_WARNING("Enforcing FT interpolation for q-points even if it's not strictly needed.")
3843 : 0 : need_ftinterp = .True.
3844 : : end if
3845 : :
3846 [ + + ]: 5 : if (need_ftinterp) then
3847 : 3 : call wrtout(units, " Cannot find all IBZ q-points in the DVDB --> Activating Fourier interpolation.")
3848 : 3 : call dvdb%ftinterp_setup(dtset%ddb_ngqpt, gstore%qptopt, 1, dtset%ddb_shiftq, nfftf, ngfftf, comm_rpt)
3849 : : else
3850 : 2 : call wrtout(units, " DVDB file contains all q-points in the IBZ --> Reading DFPT potentials from file.")
3851 : : end if
3852 : :
3853 : : ! Initialize the wave function descriptor.
3854 : : ! Only wavefunctions for the symmetrical image of the k/k+q wavevectors treated by this MPI rank are stored.
3855 [ - + + - : 20 : ABI_MALLOC(nband, (nkibz, nsppol))
- + + - +
- + - - +
- + ]
3856 [ - + + - : 25 : ABI_MALLOC(bks_mask, (mband, nkibz, nsppol))
- + + - -
+ + - + -
+ - - + -
+ ]
3857 [ - + + - : 20 : ABI_MALLOC(keep_ur, (mband, nkibz, nsppol))
- + + - -
+ + - - +
- + ]
3858 [ + + + + : 2754 : nband = mband; bks_mask = .False.; keep_ur = .False.
+ + + + +
+ + + + +
+ + ]
3859 : :
3860 : 5 : call gstore%fill_bks_mask(mband, nkibz, nsppol, bks_mask)
3861 : :
3862 : : ! Impose istwfk = 1 for all k-points. This is also done in respfn (see inkpts)
3863 : : ! wfd_read_wfk will handle a possible conversion if WFK contains istwfk /= 1.
3864 [ - + + - : 15 : ABI_MALLOC(wfd_istwfk, (nkibz))
+ - + - -
+ - + ]
3865 [ + + ]: 119 : wfd_istwfk = 1
3866 : 5 : ecut = dtset%ecut
3867 : :
3868 : : call wfd%init(cryst, pawtab, psps, keep_ur, mband, nband, nkibz, nsppol, bks_mask,&
3869 : : nspden, nspinor, ecut, dtset%ecutsm, dtset%dilatmx, wfd_istwfk, ebands%kptns, ngfft,&
3870 : 5 : dtset%nloalg, dtset%prtvol, dtset%pawprtvol, comm)
3871 : :
3872 [ + + ]: 10 : call wfd%print([std_out], header="Wavefunctions for GSTORE calculation")
3873 : :
3874 [ - + ]: 5 : ABI_FREE(nband)
3875 [ - + ]: 5 : ABI_FREE(keep_ur)
3876 [ - + ]: 5 : ABI_FREE(wfd_istwfk)
3877 [ - + ]: 5 : ABI_FREE(bks_mask)
3878 : :
3879 : : ! Read wavefunctions.
3880 : 5 : call wfd%read_wfk(wfk0_path, iomode_from_fname(wfk0_path))
3881 : 5 : call pstat_proc%print(_PSTAT_ARGS_)
3882 : :
3883 : : ! one-dimensional structure factor information on the coarse grid.
3884 [ + - - + : 15 : ABI_MALLOC(ph1d, (2, 3*(2*mgfft+1)*natom))
+ - + - +
- - + - +
- + ]
3885 : 5 : call getph(cryst%atindx, natom, n1, n2, n3, ph1d, cryst%xred)
3886 : :
3887 : : ! mpw is the maximum number of plane-waves over k and k+q where k and k+q are in the BZ.
3888 : : ! we also need the max components of the G-spheres (k, k+q) in order to allocate the workspace array work
3889 : : ! that will be used to symmetrize the wavefunctions in G-space.
3890 : 5 : call gstore%get_mpw_gmax(ecut, mpw, gmax)
3891 : :
3892 : : ! Init work_ngfft
3893 [ + + ]: 20 : gmax = gmax + 4 ! FIXME: this is to account for umklapp
3894 [ + + ]: 20 : gmax = 2*gmax + 1
3895 : 5 : call ngfft_seq(work_ngfft, gmax)
3896 : : !write(std_out,*)"work_ngfft(1:3): ",work_ngfft(1:3)
3897 [ - + + - : 25 : ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
- + + - -
+ + - + -
+ - - + -
+ ]
3898 : :
3899 : : ! Allow PW-arrays dimensioned with mpw
3900 [ - + + - : 15 : ABI_MALLOC(kg_k, (3, mpw))
+ - + - -
+ - + -
+ ]
3901 [ - + + - : 10 : ABI_MALLOC(kg_kq, (3, mpw))
- + - + -
+ ]
3902 : :
3903 : 5 : usecprj = 0
3904 [ - + + - : 10 : ABI_MALLOC(cwaveprj0, (natom, nspinor*usecprj))
- + - + -
+ ]
3905 : :
3906 : : ! Prepare call to getgh1c
3907 : 5 : usevnl = 0
3908 : 5 : optlocal = 1 ! local part of H^(1) is computed in gh1c=<G|H^(1)|C>
3909 : 5 : optnl = 2 ! non-local part of H^(1) is totally computed in gh1c=<G|H^(1)|C>
3910 : 5 : opt_gvnlx1 = 0 ! gvnlx1 is output
3911 [ - + - + ]: 5 : ABI_MALLOC(grad_berry, (2, nspinor*(berryopt0/4)))
3912 : :
3913 : : ! This part is taken from dfpt_vtorho
3914 : : !==== Initialize most of the Hamiltonian (and derivative) ====
3915 : : !1) Allocate all arrays and initialize quantities that do not depend on k and spin.
3916 : : !2) Perform the setup needed for the non-local factors:
3917 : : ! Norm-conserving: Constant kleimann-Bylander energies are copied from psps to gs_hamk.
3918 : : ! PAW: Initialize the overlap coefficients and allocate the Dij coefficients.
3919 : :
3920 : : call gs_ham_kq%init(psps, pawtab, nspinor, nsppol, nspden, natom, &
3921 : : dtset%typat, cryst%xred, nfft, mgfft, ngfft, cryst%rprimd, dtset%nloalg, &
3922 : : comm_atom=mpi_enreg%comm_atom, mpi_atmtab=mpi_enreg%my_atmtab, mpi_spintab=mpi_enreg%my_isppoltab, &
3923 : 5 : usecprj=usecprj, ph1d=ph1d, nucdipmom=dtset%nucdipmom, gpu_option=dtset%gpu_option)
3924 : :
3925 : : ! Allocate vlocal. Note nvloc
3926 : : ! I set vlocal to huge to trigger possible bugs (DFPT routines should not access the data)
3927 [ - + + - : 30 : ABI_MALLOC(vlocal, (n4, n5, n6, gs_ham_kq%nvloc))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
3928 [ + + + + : 26516 : vlocal = huge(one)
+ + + + ]
3929 : :
3930 : : ! Allocate work space arrays.
3931 [ - + + - : 20 : ABI_MALLOC(displ_cart_qibz, (2, 3, cryst%natom, natom3))
- + + - +
- + - - +
- + ]
3932 [ - + + - : 22241 : ABI_CALLOC(dummy_vtrial, (nfftf, nspden))
- + + - +
- + - - +
- + + + +
+ ]
3933 : :
3934 : : ! Open GSTORE file, and read table used for restarting.
3935 : : ! TODO: Fix problem with IO (some q-points are not written)
3936 : : !if (dtset%useria == 888) then
3937 : : ! ! use xmpi_comm_self otherwise there will be a deadlock on lemaitre4
3938 : : ! NCF_CHECK(nctk_open_modify(root_ncid, gstore%path, xmpi_comm_self))
3939 : : !else
3940 [ - + ]: 5 : NCF_CHECK(nctk_open_modify(root_ncid, gstore%path, gstore%comm))
3941 : : !end if
3942 : :
3943 : : ! integer scalars
3944 : : ncerr = nctk_def_iscalars(root_ncid, [character(len=nctk_slen) :: &
3945 : : "used_ftinterp" &
3946 [ + + ]: 10 : ])
3947 [ - + ]: 5 : NCF_CHECK(ncerr)
3948 : :
3949 [ - + + - : 20 : ABI_MALLOC(done_qbz_spin, (gstore%nqbz, nsppol))
- + + - +
- + - - +
- + - + ]
3950 [ - + ]: 5 : NCF_CHECK(nf90_get_var(root_ncid, nctk_idname(root_ncid, "gstore_done_qbz_spin"), done_qbz_spin))
3951 : :
3952 [ - + ]: 5 : gstore%wfk0_path = wfk0_path
3953 : :
3954 : : !if (my_rank == master) then
3955 [ + + ]: 5 : ii = merge(1, 0, need_ftinterp)
3956 : : ncerr = nctk_write_iscalars(root_ncid, [character(len=nctk_slen) :: &
3957 : : "used_ftinterp"], &
3958 : : [ii &
3959 [ + + + + ]: 15 : ])
3960 [ - + ]: 5 : NCF_CHECK(ncerr)
3961 : :
3962 [ - + - - ]: 5 : NCF_CHECK(nf90_put_var(root_ncid, root_vid("gstore_wfk0_path"), trim(gstore%wfk0_path)))
3963 : : !end if
3964 : :
3965 : : ! SC: The writes below are done by a subset of the procs (dump_my_gbuf) and a lazy collective read
3966 : : ! triggered by this subset would deadlock. Therefore, we load the metadata of all the variables here
3967 : : ! with all the procs of gstore%comm.
3968 : 5 : call gstore_prepare_mpiio(root_ncid, gstore%nsppol)
3969 : :
3970 [ + - + + ]: 10 : if (my_rank == master) call gstore%print([std_out])
3971 [ + + + + : 2487 : ndone = count(done_qbz_spin == 1)
- + ]
3972 : :
3973 [ + - ]: 5 : if (ndone == 0) then
3974 : : ! Write phonon data here as we are not guaranteed to have all the IBZ q-points
3975 : : ! inside the loop over my_iq if filtering has been used.
3976 : : ! Make sure internal table with gstore_done_qbz_spin is properly filled.
3977 : 5 : call gstore%compute_and_write_ph(root_ncid)
3978 : : else
3979 : 0 : call wrtout(units, sjoin("- Restarting GSTORE calculation from file:", gstore%path))
3980 : 0 : call wrtout(units, sjoin(" Found: ", itoa(ndone), " (qpt, spin) entries already computed"))
3981 : : end if
3982 : :
3983 : : ! Create ddkop object to compute group velocities (if needed)
3984 [ + - + - ]: 5 : if (gstore%with_vk /= 0 .and. ndone == 0) then
3985 : 5 : call gstore%compute_and_write_vk(mpw, wfd, ebands, psps, pawtab, root_ncid)
3986 : : end if
3987 : :
3988 [ - + ]: 5 : if (dtset%gstore_iv1p_comm /= 0) then
3989 : : call gstore%compute_and_write_commutator(mpw, gmax, ngfft, ngfftf, dtset, cryst, pawfgr, psps, &
3990 : 0 : wfd, mpi_enreg, kg_k, ebands, dvdb, gs_ham_kq, root_ncid)
3991 : : end if
3992 : :
3993 : 5 : call wrtout(std_out, " Begin computation of e-ph matrix elements...", pre_newlines=1)
3994 : :
3995 : : ! TODO: Exchange the q/k loops so that one can reduce the number of calls to _k dependente routines
3996 : : ! 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)>
3997 : : ! The price to pay is an increase in the number of calls to get_ftqbz but for small systems this part does not dominate
3998 : : ! Alternatively, one cah have two versions that will be invoked depending on my_nk, my_nq
3999 : :
4000 : : ! Here we decide if the q-points can be reduced to the IBZ(k)
4001 [ + + + - ]: 5 : use_lgk = (dtset%gstore_use_lgk /= 0 .or. dtset%gstore_sym == 2)
4002 : : if (use_lgk) then
4003 : 1 : call wrtout(units, " Only q-points in the IBZ_k will be computed.")
4004 [ - + ]: 4 : else if (dtset%gstore_use_lgq /= 0) then
4005 : 0 : call wrtout(units, " Only k-points in the IBZ_q will be computed.")
4006 : : else
4007 : 4 : call wrtout(units, " Little group operations won't be used")
4008 : : end if
4009 : :
4010 : : ! if PAW, one has to solve a generalized eigenproblem
4011 [ - + ]: 5 : gen_eigenpb = psps%usepaw == 1; sij_opt = 0; if (gen_eigenpb) sij_opt = 1
4012 : :
4013 : : ! Loop over my spins.
4014 [ + + ]: 10 : do my_is=1,gstore%my_nspins
4015 : 5 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is); my_npert = gqk%my_npert
4016 : :
4017 [ - + ]: 5 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
4018 : : ! SC: these nctk_prepare_mpiio are not needed anymore. gstore_prepare_mpiio has accessed all the variables after the open,
4019 : : ! and netcdf reads the metadata of a variable only at the first access, so these calls would do nothing.
4020 : : !NCF_CHECK(nctk_prepare_mpiio(spin_ncid, "gvals"))
4021 : : !NCF_CHECK(nctk_prepare_mpiio(root_ncid, "gstore_done_qbz_spin"))
4022 : :
4023 : 5 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
4024 : :
4025 [ - + + - : 15 : ABI_MALLOC(iq_buf, (2, qbuf_size))
+ - + - -
+ - + -
+ ]
4026 [ + + + + ]: 245 : iq_buf = 0
4027 [ - + + - : 15 : ABI_MALLOC(lambda, (nb_k))
+ - + - -
+ - + ]
4028 [ - + + - : 25 : ABI_MALLOC(gkq_atm, (2, nb_kq, nb_k, natom3))
- + + - -
+ + - + -
+ - - + -
+ - + ]
4029 [ - + + - : 20 : ABI_MALLOC(gkq_atm_ipc, (2, nb_kq, nb_k))
- + + - +
- + - - +
- + ]
4030 : : #ifdef HAVE_OPENMP_OFFLOAD
4031 : : !$OMP TARGET ENTER DATA MAP(alloc:gkq_atm_ipc) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4032 : : #endif
4033 : :
4034 : : ! Inside the loops we compute gkq_atm(2, nb_kq, nb_k, natom3)
4035 [ - + + - : 40 : ABI_MALLOC_OR_DIE(my_gbuf, (gqk%cplex, nb_kq, nb_k, natom3, gqk%my_nk, qbuf_size), ierr)
- + + - -
+ + - - +
+ - - + +
- - + + -
+ - + - +
- + - - +
+ - - + ]
4036 : 5 : call pstat_proc%print(_PSTAT_ARGS_)
4037 : :
4038 : : ! Compute the little group of the k-point so that we can compute g(k,q) only for q in the IBZ_k
4039 [ + + ]: 5 : if (use_lgk) then
4040 : 1 : timrev_k = kpts_timrev_from_kptopt(ebands%kptopt)
4041 [ - + + - : 4 : ABI_MALLOC(lg_myk, (gqk%my_nk))
+ - + - -
+ - + - +
+ + + - -
+ - + - +
- + - + -
+ - + ]
4042 [ + + ]: 2 : do my_ik=1,gqk%my_nk
4043 [ + + ]: 4 : kk_bz = gqk%my_kpts(:, my_ik)
4044 : 2 : call lg_myk(my_ik)%init(cryst, kk_bz, timrev_k, gstore%nqbz, gstore%qbz, gstore%nqibz, gstore%qibz, xmpi_comm_self)
4045 : : end do
4046 : : end if
4047 : :
4048 [ - + + - : 20 : ABI_MALLOC(state_kq, (gqk%my_nk, qbuf_size))
- + + - +
- + - - +
- + - + ]
4049 [ + + + + ]: 4981 : state_kq = GSTORE_KQ_MISSING
4050 : :
4051 : : ! SC: iqbuf_cnt is set only for the q-points that are computed, so is has to be initialized. Otherwise a
4052 : : ! proc whose q-points are all done (restart) would read an undefined value in "if (iqbuf_cnt /= 0)" later.
4053 : 5 : iqbuf_cnt = 0
4054 : :
4055 : : ! Loop over my set of q-points
4056 [ + + ]: 882 : do my_iq=1,gqk%my_nq
4057 [ + - + + : 877 : print_time = my_rank == 0 .and. (my_iq <= LOG_MODQ .or. mod(my_iq, LOG_MODQ) == 0)
+ + ]
4058 : 193 : if (print_time) call cwtime(cpu_q, wall_q, gflops_q, "start")
4059 : 877 : iq_bz = gqk%my_q2bz(my_iq)
4060 : :
4061 : 877 : call gqk%myqpt(my_iq, gstore, weight_q, qq_bz)
4062 : : qq_is_gamma = sum(qq_bz**2) < tol14
4063 : 877 : qq_bz_string = ktoa(qq_bz)
4064 : :
4065 : : ! Handle possible restart.
4066 [ - + ]: 877 : if (done_qbz_spin(iq_bz, spin) == 1) then
4067 : 0 : call wrtout(std_out, sjoin(" iq_bz:", itoa(iq_bz), ", spin: ", itoa(spin), " already computed --> skipping iteration"))
4068 : 0 : cycle
4069 : : end if
4070 : :
4071 : : ! Compute the little group of the q-point so that we can compute g(k,q) only for k in the IBZ_q
4072 [ - + ]: 877 : if (dtset%gstore_use_lgq /= 0) then
4073 : 0 : timrev_q = kpts_timrev_from_kptopt(gstore%qptopt)
4074 [ # # # # : 0 : call lg_myq%init(cryst, qq_bz, timrev_q, gstore%nkbz, gstore%kbz, gstore%nkibz, gstore%kibz, xmpi_comm_self)
# # # # #
# ]
4075 : : end if
4076 : :
4077 : 877 : iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
4078 : 877 : trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5,my_iq)
4079 : : ! Don't test if umklapp == 0 because we use the periodic gauge:
4080 : : !
4081 : : ! phfreq(q+G) = phfreq(q) and eigvec(q) = eigvec(q+G)
4082 : : !
4083 : : !isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
4084 : 877 : isirr_q = (isym_q == 1 .and. trev_q == 0)
4085 [ + + ]: 3508 : qq_ibz = gstore%qibz(:, iq_ibz)
4086 : :
4087 : 877 : nskip_tetra_kq = 0
4088 : 877 : iqbuf_cnt = 1 + mod(my_iq - 1, qbuf_size)
4089 [ + + ]: 2631 : iq_buf(:, iqbuf_cnt) = [my_iq, iq_bz]
4090 : :
4091 [ + + ]: 877 : if (need_ftinterp) then
4092 : : ! Fourier interpolation.
4093 [ - + ]: 786 : call dvdb%get_ftqbz(qq_bz, cplex, nfftf, ngfftf, v1scf, gqk%pert_comm%value)
4094 : : else
4095 : : ! Read and reconstruct the dvscf potentials for qpt and my_npert perturbations.
4096 : 91 : db_iqpt = dvdb%findq(qq_ibz)
4097 [ - + ]: 91 : ABI_CHECK(db_iqpt /= -1, sjoin("Could not find symmetric of q-point:", ktoa(qq_bz), "in DVDB file."))
4098 : : ! The first entry in qbz2dvdb gives the index in dvdb%qpts.
4099 : : ! The other entries in mapc_qq are OK as they refer to symmetries.
4100 [ + + ]: 637 : qbz2dvdb = gqk%my_q2ibz(:, my_iq); qbz2dvdb(1) = db_iqpt
4101 [ - + ]: 91 : call dvdb%readsym_qbz(cryst, qq_bz, qbz2dvdb, cplex, nfftf, ngfftf, v1scf, gqk%pert_comm%value)
4102 : : end if
4103 : :
4104 : : ! Allocate vlocal1 with correct cplex. Note nvloc and my_npert.
4105 [ - + + - : 6139 : ABI_MALLOC(vlocal1, (cplex*n4, n5, n6, gs_ham_kq%nvloc, my_npert))
- + + - -
+ + - - +
+ - - + +
- + - + -
- + - + ]
4106 : :
4107 : : ! Set up local potential vlocal1 with proper dimensioning from vtrial1 taking into account the spin.
4108 [ + + ]: 6139 : do my_ip=1,my_npert
4109 : : call rf_transgrid_and_pack(spin, nspden, psps%usepaw, cplex, nfftf, nfft, ngfft, gs_ham_kq%nvloc,&
4110 : 6139 : pawfgr, mpi_enreg, dummy_vtrial, v1scf(:,:,:,my_ip), vlocal, vlocal1(:,:,:,:,my_ip))
4111 : : #ifdef HAVE_OPENMP_OFFLOAD
4112 : : !$OMP TARGET ENTER DATA MAP(to:vlocal1(:,:,:,:,my_ip)) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4113 : : #endif
4114 : : end do
4115 : : !$OMP TASKWAIT
4116 : :
4117 : : ! Continue to initialize the GS Hamiltonian
4118 : 877 : call gs_ham_kq%load_spin(spin, vlocal=vlocal, with_nonlocal=.true.)
4119 : :
4120 : : ! Loop over my k-points
4121 [ + + ]: 74524 : do my_ik=1,gqk%my_nk
4122 : : ! The k-point and the symmetries relating the BZ k-point to the IBZ.
4123 [ + + ]: 294588 : kk_bz = gqk%my_kpts(:, my_ik)
4124 : 73647 : weight_k = gqk%my_wtk(my_ik)
4125 : 73647 : kk_string = ktoa(kk_bz)
4126 : :
4127 : 73647 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
4128 [ + + ]: 294588 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5,my_ik)
4129 [ + + + + : 282012 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
+ + - + ]
4130 [ + + ]: 294588 : kk_ibz = ebands%kptns(:,ik_ibz)
4131 : :
4132 : : ! Set entry to zero. Important as there are cycle instructions inside these loops
4133 : : ! and we don't want random numbers written to disk.
4134 [ + + + + : 5565417 : my_gbuf(:,:,:,:, my_ik, iqbuf_cnt) = zero
+ + + + ]
4135 : :
4136 [ - + ]: 73647 : if (symmetrize .and. .not. isirr_k) then
4137 : 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4138 : : end if
4139 : :
4140 [ + + ]: 73647 : if (use_lgk) then
4141 : 64 : ii = lg_myk(my_ik)%findq_ibzk(qq_bz)
4142 [ + + ]: 64 : if (ii == -1) then
4143 : 56 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4144 : : end if
4145 : : end if
4146 : :
4147 [ - + ]: 73591 : if (dtset%gstore_use_lgq /= 0) then
4148 : 0 : ii = lg_myq%findq_ibzk(kk_bz)
4149 [ # # ]: 0 : if (ii == -1) then
4150 : 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4151 : : end if
4152 : : end if
4153 : :
4154 : : ! =========================================
4155 : : ! Find symmetrical image of k+q in the kIBZ
4156 : : ! =========================================
4157 [ + + ]: 294364 : kq_bz = kk_bz + qq_bz
4158 [ - + ]: 73591 : if (kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz, indkk_kq) /= 0) then
4159 : : write(msg, '(3a)' ) &
4160 : 0 : "Cannot find k+q in k-mesh", ch10, 'Check your WFK file and the (k,q) point input variables.'
4161 : 0 : ABI_ERROR(msg)
4162 : : end if
4163 : :
4164 : 73591 : ikq_ibz = indkk_kq(1, 1); isym_kq = indkk_kq(2, 1)
4165 : 73591 : trev_kq = indkk_kq(6, 1); g0_kq = indkk_kq(3:5, 1)
4166 : : isirr_kq = (isym_kq == 1 .and. trev_kq == 0 .and. all(g0_kq == 0))
4167 [ + + ]: 294364 : kq_ibz = ebands%kptns(:, ikq_ibz)
4168 : :
4169 : : ! If we have used the KERANGE trick, we may have k or k+q points with just one G component set to zero
4170 : : ! so we skip this transition immediately. This should happen only if fsewin > sigma_erange.
4171 [ + - - + ]: 73591 : if (wfd%npwarr(ik_ibz) == 1 .or. wfd%npwarr(ikq_ibz) == 1) then
4172 : 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4173 : : end if
4174 : :
4175 [ - + ]: 73591 : if (gstore%kfilter == "fs_tetra") then
4176 : : ! Check tetra delta(e_{k+q}) and cycle if all the weights at k+q are zero.
4177 [ # # # # : 0 : if (all(abs(gstore%delta_ef_kibz_spin(:, ikq_ibz, spin)) == zero)) then
# # ]
4178 : 0 : nskip_tetra_kq = nskip_tetra_kq + 1
4179 : 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4180 : : end if
4181 : : end if
4182 : :
4183 : : ! Get npw_k, kg_k and symmetrize wavefunctions from the IBZ (if needed).
4184 : : call wfd%sym_ug_kg_npw(ecut, kk_bz, kk_ibz, gqk%bstart_k, nb_k, spin, gqk%my_k2ibz(:, my_ik), cryst, &
4185 [ - + ]: 73591 : work_ngfft, work, istwf_k, npw_k, kg_k, kets_k)
4186 : :
4187 : : #ifdef HAVE_OPENMP_OFFLOAD
4188 : : !$OMP TARGET ENTER DATA MAP(to:kets_k) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4189 : : #endif
4190 : :
4191 : : ! Get npw_kq, kg_kq and symmetrize wavefunctions from the IBZ (if needed).
4192 : : call wfd%sym_ug_kg_npw(ecut, kq_bz, kq_ibz, gqk%bstart_kq, nb_kq, spin, indkk_kq(:,1), cryst, &
4193 [ - + ]: 73591 : work_ngfft, work, istwf_kq, npw_kq, kg_kq, bras_kq)
4194 : :
4195 : : #ifdef HAVE_OPENMP_OFFLOAD
4196 : : !$OMP TARGET ENTER DATA MAP(to:bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4197 : : #endif
4198 : :
4199 [ - + + - : 294364 : ABI_MALLOC(h1_kets_kq, (2, npw_kq*nspinor, nb_k))
- + + - +
- + - - +
- + ]
4200 [ + - - - : 220773 : ABI_MALLOC(gs1c_kq, (2, npw_kq*nspinor*nb_k*((sij_opt+1)/2)))
+ - - + -
+ - + ]
4201 [ - + + - : 220773 : ABI_MALLOC(gvnlx1, (2, npw_kq*nspinor,nb_k))
- + + - -
+ - + ]
4202 : : #ifdef HAVE_OPENMP_OFFLOAD
4203 : : !$OMP TARGET ENTER DATA MAP(alloc:h1_kets_kq, gvnlx1, kets_k, bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4204 : : !$OMP TARGET ENTER DATA MAP(alloc:gs1c_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP .and. sij_opt /= 0) NOWAIT
4205 : : #endif
4206 : :
4207 : : call gs_ham_kq%eph_setup_k("k" , kk_bz, istwf_k, npw_k, kg_k, dtset, cryst, psps, &
4208 [ - + - + : 73591 : nkpg_k, kpg_k, ffnl_k, kinpw_k, ph3d_k, gqk%pert_comm%value)
- + - + ]
4209 : :
4210 : : #ifdef HAVE_OPENMP_OFFLOAD
4211 : : !$OMP TARGET ENTER DATA MAP(to:kpg_k, ffnl_k, kinpw_k, ph3d_k) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4212 : : #endif
4213 : :
4214 : : call gs_ham_kq%eph_setup_k("kq", kq_bz, istwf_k, npw_kq, kg_kq, dtset, cryst, psps, &
4215 [ - + - + : 73591 : nkpg_kq, kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq, gqk%pert_comm%value)
- + - + ]
4216 : :
4217 : : #ifdef HAVE_OPENMP_OFFLOAD
4218 : : !$OMP TARGET ENTER DATA MAP(to:kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4219 : : #endif
4220 : :
4221 : : !$OMP TASKWAIT
4222 : :
4223 : : ! Loop over my atomic perturbations and compute gkq_atm_ipc.
4224 [ + + + + : 5483041 : gkq_atm = zero
+ + + + ]
4225 [ + + ]: 515137 : do my_ip=1,my_npert
4226 : 441546 : idir = dvdb%my_pinfo(1, my_ip); ipert = dvdb%my_pinfo(2, my_ip); ipc = dvdb%my_pinfo(3, my_ip)
4227 : :
4228 : : ! Prepare application of the NL part.
4229 : 441546 : call rf_ham_kq%init(cplex, gs_ham_kq, ipert, has_e1kbsc=.true.)
4230 : 441546 : call rf_ham_kq%load_spin(spin, vlocal1=vlocal1(:,:,:,:,my_ip), with_nonlocal=.true.)
4231 : :
4232 : : #if 1
4233 : : ! Calculate dvscf * psi_k, results stored in h1_kets_kq on the k+q sphere.
4234 : : ! Compute H(1) applied to GS wavefunction Psi(0)
4235 [ + + ]: 1128636 : do in_k=1,nb_k
4236 : : ! Use scissor shift on 0-order eigenvalue
4237 : 687090 : band_k = in_k + gqk%bstart_k - 1
4238 : 1128636 : lambda(in_k) = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
4239 : : end do
4240 : : !call ebands%get_dfpt_eshifted(gqk%bstart_k, nb_k, ik_ibz, spin, dtset%dfpt_sciss, lambda)
4241 : :
4242 : : call getgh1c(berryopt0, kets_k, cwaveprj0, h1_kets_kq, &
4243 : : grad_berry, gs1c_kq, gs_ham_kq, gvnlx1, idir, ipert, lambda, mpi_enreg, nb_k, optlocal, &
4244 : 441546 : optnl, opt_gvnlx1, rf_ham_kq, sij_opt, tim_getgh1c, usevnl)
4245 : :
4246 : : #else
4247 : : do in_k=1,nb_k
4248 : : ! Use scissor shift on 0-order eigenvalue
4249 : : band_k = in_k + gqk%bstart_k - 1
4250 : : eshift = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
4251 : :
4252 : : call getgh1c(berryopt0, kets_k(:,:,in_k), cwaveprj0, h1_kets_kq(:,:,in_k), &
4253 : : grad_berry, gs1c_kq, gs_ham_kq, gvnlx1, idir, ipert, [eshift], mpi_enreg, ndat1, optlocal, &
4254 : : optnl, opt_gvnlx1, rf_ham_kq, sij_opt, tim_getgh1c, usevnl)
4255 : : end do ! in_k
4256 : : #endif
4257 : :
4258 : 441546 : call rf_ham_kq%free()
4259 : :
4260 : : ! Calculate <psi_{k+q,j}|dvscf_q*psi_{k,i}> for this perturbation. No need to handle istwf_kq because it's always 1.
4261 [ - + ]: 441546 : if (dtset%gpu_option == ABI_GPU_OPENMP) then
4262 : : call abi_gpu_xgemm_d(2, 'C', 'N', nb_kq, nb_k, npw_kq*nspinor, cone, bras_kq, npw_kq*nspinor, &
4263 : 0 : h1_kets_kq, npw_kq*nspinor, czero, gkq_atm_ipc, nb_kq)
4264 : : #ifdef HAVE_OPENMP_OFFLOAD
4265 : : !$OMP TARGET UPDATE FROM(gkq_atm_ipc)
4266 : : #endif
4267 : : else
4268 : : call ZGEMM('C', 'N', nb_kq, nb_k, npw_kq*nspinor, cone, bras_kq, npw_kq*nspinor, &
4269 : 441546 : h1_kets_kq, npw_kq*nspinor, czero, gkq_atm_ipc, nb_kq)
4270 : : end if
4271 : :
4272 : : ! Transfer data
4273 [ + + + + : 5483041 : gkq_atm(:,:,:,ipc) = gkq_atm_ipc
+ + ]
4274 : : end do ! my_ip
4275 : :
4276 : : ! Collect gkq_atm inside pert_comm so that all procs can operate on the data.
4277 [ - + ]: 73591 : if (gqk%pert_comm%nproc > 1) call xmpi_sum(gkq_atm, gqk%pert_comm%value, ierr)
4278 : :
4279 : : ! Save e-ph matrix elements in the buffer.
4280 [ + + + + : 5483041 : my_gbuf(:,:,:,:, my_ik, iqbuf_cnt) = gkq_atm
+ + + + ]
4281 : 73591 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_COMPUTED
4282 : :
4283 : : #ifdef HAVE_OPENMP_OFFLOAD
4284 : : !$OMP TARGET EXIT DATA MAP(delete:kpg_k, ffnl_k, kinpw_k, ph3d_k) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4285 : : !$OMP TARGET EXIT DATA MAP(delete:kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4286 : : !$OMP TARGET EXIT DATA MAP(delete:h1_kets_kq, gvnlx1, kets_k, bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4287 : : !$OMP TARGET EXIT DATA MAP(delete:gs1c_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP .and. sij_opt /= 0)
4288 : : #endif
4289 [ - + ]: 73591 : ABI_FREE(ffnl_k)
4290 [ - + ]: 73591 : ABI_FREE(ffnl_kq)
4291 [ - + ]: 73591 : ABI_FREE(kpg_k)
4292 [ - + ]: 73591 : ABI_FREE(kpg_kq)
4293 [ - + ]: 73591 : ABI_FREE(ph3d_k)
4294 [ - + ]: 73591 : ABI_FREE(ph3d_kq)
4295 [ - + ]: 73591 : ABI_FREE(kinpw_k)
4296 [ - + ]: 73591 : ABI_FREE(kinpw_kq)
4297 [ - + ]: 73591 : ABI_FREE(kets_k)
4298 [ - + ]: 73591 : ABI_FREE(bras_kq)
4299 [ - + ]: 73591 : ABI_FREE(h1_kets_kq)
4300 [ - + ]: 73591 : ABI_FREE(gs1c_kq)
4301 [ - + ]: 74468 : ABI_FREE(gvnlx1)
4302 : : end do ! my_ik
4303 : :
4304 [ - + ]: 877 : ABI_FREE(v1scf)
4305 : :
4306 : : #ifdef HAVE_OPENMP_OFFLOAD
4307 : : do my_ip=1,my_npert
4308 : : !$OMP TARGET EXIT DATA MAP(delete:vlocal1(:,:,:,:,my_ip)) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4309 : : end do
4310 : : #endif
4311 [ - + ]: 877 : ABI_FREE(vlocal1)
4312 : :
4313 : : ! Dump buffer
4314 [ + + ]: 877 : if (iqbuf_cnt == qbuf_size) call dump_my_gbuf()
4315 : :
4316 [ + + ]: 877 : if (print_time) then
4317 : 193 : write(msg,'(2(a,i0),a)')" My q-point [", my_iq, "/", gqk%my_nq, "]"
4318 [ + + ]: 193 : call cwtime_report(msg, cpu_q, wall_q, gflops_q); if (my_iq == LOG_MODQ) call wrtout(std_out, "...", do_flush=.True.)
4319 : : end if
4320 : 882 : call lg_myq%free()
4321 : : end do ! my_iq
4322 : :
4323 : : ! Dump the remainder.
4324 [ + + ]: 5 : if (iqbuf_cnt /= 0) call dump_my_gbuf()
4325 : :
4326 [ - + ]: 5 : ABI_FREE(state_kq)
4327 [ - + ]: 5 : ABI_FREE(iq_buf)
4328 [ - + ]: 5 : ABI_FREE(my_gbuf)
4329 [ - + ]: 5 : ABI_FREE(lambda)
4330 [ - + ]: 5 : ABI_FREE(gkq_atm)
4331 : : #ifdef HAVE_OPENMP_OFFLOAD
4332 : : !$OMP TARGET EXIT DATA MAP(delete:gkq_atm_ipc) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4333 : : #endif
4334 [ - + ]: 5 : ABI_FREE(gkq_atm_ipc)
4335 : :
4336 [ + + ]: 10 : if (use_lgk) then
4337 [ + + ]: 2 : do my_ik=1,gqk%my_nk
4338 : 2 : call lg_myk(my_ik)%free()
4339 : : end do
4340 [ + - + + : 2 : ABI_FREE(lg_myk)
- + - + -
+ - + - +
- + - + -
+ ]
4341 : : end if
4342 : : end do ! my_is
4343 : :
4344 : 5 : call cwtime_report(" GSTORE computation done", cpu_all, wall_all, gflops_all, pre_str=ch10, end_str=ch10) !, comm=gstore%comm)
4345 : : !call gstore%print([std_out], header="GSTORE at the end of gstore%compute")
4346 : :
4347 : : ! Set gstore_completed to 1 so that we can easily check if restarted is needed.
4348 : : !if (my_rank == master) then
4349 [ - + ]: 5 : NCF_CHECK(nf90_put_var(root_ncid, root_vid("gstore_completed"), 1))
4350 : : !end if
4351 : : ! nf90_sync can deadlock on lemaitre4 for some MPI decompositions.
4352 : : !if (dtset%useria /= 888) then
4353 [ - + ]: 5 : NCF_CHECK(nf90_sync(root_ncid))
4354 : : !end if
4355 [ - + ]: 5 : NCF_CHECK(nf90_close(root_ncid))
4356 : 5 : call xmpi_barrier(gstore%comm)
4357 : :
4358 : : ! Free memory
4359 [ - + ]: 5 : ABI_FREE(grad_berry)
4360 [ - + ]: 5 : ABI_FREE(dummy_vtrial)
4361 [ - + ]: 5 : ABI_FREE(work)
4362 [ - + ]: 5 : ABI_FREE(ph1d)
4363 [ - + ]: 5 : ABI_FREE(vlocal)
4364 [ - + ]: 5 : ABI_FREE(kg_k)
4365 [ - + ]: 5 : ABI_FREE(kg_kq)
4366 [ - + ]: 5 : ABI_FREE(displ_cart_qibz)
4367 [ - + ]: 5 : ABI_FREE(done_qbz_spin)
4368 : :
4369 : 5 : call gs_ham_kq%free(); call wfd%free()
4370 : 5 : call pawcprj_free(cwaveprj0)
4371 [ + - - + : 5 : ABI_FREE(cwaveprj0)
- - - - -
+ ]
4372 : :
4373 : : ! Reconstruct g(k,q) matrix elements in the full BZ by symmetry.
4374 [ - + ]: 5 : if (symmetrize) then
4375 : 0 : call gstore_symmetrize(gstore%path, wfk0_path, ngfft, dtset, dtfil, cryst, psps, pawtab, ebands, ifc, comm)
4376 : : end if
4377 : :
4378 : : ! Output some of the results to ab_out for testing purposes
4379 [ - + - + : 30 : call gstore%print_for_abitests(dtset, ebands, .True.)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - - - -
- - - - -
- - - - -
- + - - -
- - - - -
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
+ - + - +
- + ]
4380 : :
4381 : : contains
4382 : :
4383 : 56 : subroutine dump_my_gbuf()
4384 : :
4385 : : ! This function is called inside the double loop over (my_is, my_iq) or when we exit
4386 : : ! from the my_iq loop to dump the remainder that is still in the q-buffer,
4387 : : ! All the MPI procs in the (kpt_comm x pert_comm) grid shall call this contained routine
4388 : : ! as we have side-effects i.e. iqbuf_cnt set to 0.
4389 : :
4390 : : ! On disk we have the global arrays:
4391 : : !
4392 : : ! nctkarr_t("gvals", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq")
4393 : : !
4394 : : ! while the local MPI buffers are dimensioned as follows:
4395 : : !
4396 : : ! my_gbuf(2, nb_kq, nb_k, natom3, gqk%my_nk, qbuf_size)
4397 : :
4398 : : ! If parallelism over perturbation is activated, only the procs treating the first perturbation
4399 : : ! i.e. the procs treating different k-points for this q are involved in IO
4400 : : ! as all the local buffers store results for all natom3 perturbations.
4401 : :
4402 : : ! NOTE: A similar routine is used in m_gstore. The two implementations should be kept in synch.
4403 : :
4404 : : integer :: ii, iq_bz, iq_glob, my_iq
4405 : : logical :: iscontiguous
4406 : :
4407 : : ! All the procs in pert_comm write the same data (my_gbuf is summed inside pert_comm): the procs with
4408 : : ! coords_qkpb_sumbp(3) /= 0 used to skip the writes, but then the nf90_sync below, called by all the procs,
4409 : : ! fails with "NetCDF: Can't add HDF5 file metadata" when GSTORE.nc is opened with gstore%comm.
4410 : : ! SC: The GOTO was not the cause: the first access to gstore_glob_state_kqs, which was not prepared,
4411 : : ! triggered a collective metadata read done by the writers only, while the other procs were in nf90_sync.
4412 : : ! All the variables are now prepared after the open (gstore_prepare_mpiio), so the GOTO is restored:
4413 : : ! only the procs with coords_qkpb_sumbp(3) == 0 write.
4414 [ + - ]: 56 : if (gqk%coords_qkpb_sumbp(3) /= 0) goto 10 ! Yes, I'm very proud of this GOTO.
4415 : :
4416 : : !if (dtset%prtvol > 5) then
4417 : : !print *, "in dump_my_gbuf with start: ", [1, 1, 1, 1, gqk%my_kstart, iq_glob]
4418 : : !print *, " count; ", [2, gqk%nb_kq, gqk%nb_k, gqk%natom3, gqk%my_nk, iqbuf_cnt]
4419 : : !end if
4420 : :
4421 : : ! Check if the q-points in the buffer are perfectly contiguous (no cycles/holes)
4422 : 56 : iscontiguous = .True.
4423 [ + + ]: 933 : do ii=1, iqbuf_cnt
4424 : 877 : my_iq = iq_buf(1, ii)
4425 [ + - ]: 877 : if (my_iq == 0) then
4426 : : iscontiguous = .False.; exit
4427 : : end if
4428 [ + + ]: 933 : if (ii > 1) then
4429 [ + - ]: 821 : if (my_iq /= iq_buf(1, ii-1) + 1) then
4430 : : iscontiguous = .False.; exit
4431 : : end if
4432 : : end if
4433 : : end do
4434 : :
4435 [ - + ]: 56 : if (iscontiguous) then
4436 : : ! Fast path: Write slabs directly
4437 : 56 : my_iq = iq_buf(1, 1)
4438 : 56 : iq_glob = my_iq + gqk%my_qstart - 1
4439 : :
4440 : : ncerr = nf90_put_var(spin_ncid, spin_vid("gvals"), my_gbuf(:,:,:,:,:, 1:iqbuf_cnt), &
4441 : : start=[1, 1, 1, 1, gqk%my_kstart, iq_glob], &
4442 [ + + + + ]: 728 : count=[2, gqk%nb_kq, gqk%nb_k, gqk%natom3, gqk%my_nk, iqbuf_cnt])
4443 [ - + ]: 56 : NCF_CHECK(ncerr)
4444 : :
4445 : : ncerr = nf90_put_var(root_ncid, root_vid("gstore_glob_state_kqs"), state_kq(:, 1:iqbuf_cnt), &
4446 : : start=[gqk%my_kstart, iq_glob, spin], &
4447 [ + + + + ]: 392 : count=[gqk%my_nk, iqbuf_cnt, 1])
4448 [ - + ]: 56 : NCF_CHECK(ncerr)
4449 : : else
4450 : : ! Slow path: Q-points were filtered, write slice by slice avoiding holes
4451 [ # # ]: 0 : do ii=1, iqbuf_cnt
4452 : 0 : my_iq = iq_buf(1, ii)
4453 [ # # ]: 0 : if (my_iq == 0) cycle
4454 : 0 : iq_glob = my_iq + gqk%my_qstart - 1
4455 : :
4456 : : ncerr = nf90_put_var(spin_ncid, spin_vid("gvals"), my_gbuf(:,:,:,:,:, ii), &
4457 : : start=[1, 1, 1, 1, gqk%my_kstart, iq_glob], &
4458 [ # # # # ]: 0 : count=[2, gqk%nb_kq, gqk%nb_k, gqk%natom3, gqk%my_nk, 1])
4459 [ # # ]: 0 : NCF_CHECK(ncerr)
4460 : :
4461 : : ncerr = nf90_put_var(root_ncid, root_vid("gstore_glob_state_kqs"), state_kq(:, ii), &
4462 : : start=[gqk%my_kstart, iq_glob, spin], &
4463 [ # # # # ]: 0 : count=[gqk%my_nk, 1, 1])
4464 [ # # ]: 0 : NCF_CHECK(ncerr)
4465 : : end do
4466 : : end if
4467 : :
4468 : : ! Only one proc sets the entry in done_qbz_spin to 1 for all the q-points in the buffer.
4469 : : !if (all(gqk%coords_qkpb_sumbp(2:3) == [0, 0])) then
4470 [ + + ]: 933 : do ii=1,iqbuf_cnt
4471 : 877 : my_iq = iq_buf(1, ii)
4472 [ - + ]: 877 : if (my_iq == 0) cycle
4473 : 877 : iq_bz = iq_buf(2, ii)
4474 [ + + - + : 2687 : NCF_CHECK(nf90_put_var(root_ncid, root_vid("gstore_done_qbz_spin"), 1, start=[iq_bz, spin]))
- - ]
4475 : : end do
4476 : : !end if
4477 : :
4478 : : ! Zero the counter before returning
4479 : 56 : 10 iqbuf_cnt = 0
4480 [ + + + + ]: 2744 : iq_buf = 0
4481 [ + + + + ]: 76088 : state_kq = GSTORE_KQ_MISSING
4482 : :
4483 : : ! These syncs can deadlock on lemaitre4 for some MPI decompositions.
4484 : : ! SC: nf90_sync is collective on a file opened with gstore%comm (HDF5 flush of the metadata cache), so all
4485 : : ! the procs must call it the same number of times. dump_my_gbuf is called a number of times that depends on
4486 : : ! the proc (my_nq differs when nqbz is not a multiple of the number of q-blocks, q-points done in a previous
4487 : : ! run are skipped on restart), hence these syncs deadlock on the machine. The file is synced once by all
4488 : : ! the procs after the loops. The syncs are not needed for restart as the q-points written before a kill are
4489 : : ! in the file (checked with kill -9 in gwpt_run, which writes GSTORE.nc in the same way).
4490 : : !if (dtset%useria /= 888) then
4491 : : ! NCF_CHECK(nf90_sync(spin_ncid))
4492 : : ! NCF_CHECK(nf90_sync(root_ncid))
4493 : : !end if
4494 : :
4495 : 56 : end subroutine dump_my_gbuf
4496 : :
4497 : 943 : integer function root_vid(var_name)
4498 : : character(len=*),intent(in) :: var_name
4499 : 943 : root_vid = nctk_idname(root_ncid, var_name)
4500 : : end function root_vid
4501 : :
4502 : 56 : integer function spin_vid(var_name)
4503 : : character(len=*),intent(in) :: var_name
4504 : 56 : spin_vid = nctk_idname(spin_ncid, var_name)
4505 : : end function spin_vid
4506 : :
4507 : : end subroutine gstore_compute
4508 : : !!***
4509 : :
4510 : : !----------------------------------------------------------------------
4511 : :
4512 : : !!****f* m_gstore/gstore_check_qkzone_gmode
4513 : : !! NAME
4514 : : !! gstore_check_cplex_qkzone_gmode
4515 : : !!
4516 : : !! FUNCTION
4517 : : !! Perform consistency checks
4518 : : !!
4519 : : !! INPUTS
4520 : : !!
4521 : : !! SOURCE
4522 : :
4523 : 9 : integer function gstore_check_cplex_qkzone_gmode(gstore, cplex, qzone, kzone, gmode, &
4524 : : kfilter, check_alloc) result(ierr) ! optional
4525 : :
4526 : : !Arguments ------------------------------------
4527 : : class(gstore_t),target,intent(in) :: gstore
4528 : : integer,intent(in) :: cplex
4529 : : character(len=*),intent(in) :: qzone, kzone, gmode
4530 : : character(len=*),optional,intent(in) :: kfilter
4531 : : logical,optional,intent(in) :: check_alloc
4532 : :
4533 : : !Local variables-------------------------------
4534 : : integer :: my_is
4535 : : logical :: check_alloc__
4536 : : ! *************************************************************************
4537 : :
4538 : 9 : ierr = 0
4539 [ - + ]: 9 : ABI_CHECK_NOSTOP(gstore%qzone == qzone, sjoin("qzone: ", qzone, "required but got: ", gstore%qzone), ierr)
4540 [ - + ]: 9 : ABI_CHECK_NOSTOP(gstore%kzone == kzone, sjoin("kzone: ", kzone, "required but got: ", gstore%kzone), ierr)
4541 [ - + ]: 9 : ABI_CHECK_NOSTOP(gstore%gmode == gmode, sjoin("gmode: ", gmode, "required but got: ", gstore%gmode), ierr)
4542 [ - + ]: 9 : if (present(kfilter)) then
4543 [ # # ]: 0 : ABI_CHECK_NOSTOP(gstore%kfilter == kfilter, sjoin("kfilter: ", kfilter, "required but got: ", gstore%kfilter), ierr)
4544 : : end if
4545 : :
4546 [ - + ]: 9 : check_alloc__ = .True.; if (present(check_alloc)) check_alloc__ = check_alloc
4547 : :
4548 [ + + ]: 18 : do my_is=1,gstore%my_nspins
4549 : 9 : associate (gqk => gstore%gqk(my_is))
4550 : 0 : ABI_CHECK_NOSTOP(gqk%cplex == cplex, sjoin("cplex:", itoa(cplex), "required but got: ", itoa(gqk%cplex)), ierr)
4551 [ - + + - ]: 9 : if (check_alloc__) then
4552 [ - + ]: 9 : if (cplex == 1) then
4553 [ # # ]: 0 : ABI_CHECK_NOSTOP(allocated(gqk%my_g2), "my_g2 array is not allocated", ierr)
4554 [ + - ]: 9 : else if (cplex == 2) then
4555 [ - + ]: 9 : ABI_CHECK_NOSTOP(allocated(gqk%my_g), "my_g array is not allocated", ierr)
4556 : : end if
4557 : : end if
4558 : : end associate
4559 : : end do
4560 : :
4561 : 9 : end function gstore_check_cplex_qkzone_gmode
4562 : : !!***
4563 : :
4564 : : !----------------------------------------------------------------------
4565 : :
4566 : : !!****f* m_gstore/gstore_from_ncpath
4567 : : !! NAME
4568 : : !! gstore_from_ncpath
4569 : : !!
4570 : : !! FUNCTION
4571 : : !! Reconstruct a gstore_t instance from a netcdf file.
4572 : : !!
4573 : : !! INPUTS
4574 : : !! path: Path to the GSTORE file.
4575 : : !! with_cplex: 0 to read no matrix elements, 1 for |g|^2, 2 for complex g.
4576 : : !! with_gmode defines the representation.
4577 : : !! dtset: Input variables
4578 : : !! cryst: crystalline structure
4579 : : !! ebands: KS energies
4580 : : !! ifc: interatomic force constants
4581 : : !! with_gmode: "phonon" to have g in the phonon representation or "atom" to have them in atom representation.
4582 : : !! gvals_name: "gvals" or "gvals_ks" to read the KS gs produced by the GWPT code.
4583 : : !! This option is valid only for gstore files produced by the GWPT code.
4584 : : !! with_g2dw: True if Debye-Waller g2 in the RIA should be computed and stored in memory.
4585 : : !! comm: MPI communicator.
4586 : : !!
4587 : : !! SOURCE
4588 : :
4589 : 16 : subroutine gstore_from_ncpath(gstore, path, with_cplex, dtset, dtfil, cryst, ebands, ifc, &
4590 : : with_gmode, gvals_name, with_g2dw, comm)
4591 : :
4592 : : !Arguments ------------------------------------
4593 : : class(gstore_t),target,intent(out) :: gstore
4594 : : character(len=*),intent(in) :: path
4595 : : integer,intent(in) :: with_cplex
4596 : : type(dataset_type),target,intent(in) :: dtset
4597 : : type(datafiles_type),intent(in) :: dtfil
4598 : : class(crystal_t),target,intent(in) :: cryst
4599 : : class(ebands_t),target,intent(in) :: ebands
4600 : : class(ifc_type),target,intent(in) :: ifc
4601 : : character(len=*),intent(in) :: with_gmode, gvals_name
4602 : : logical,intent(in) :: with_g2dw
4603 : : integer,intent(in) :: comm
4604 : :
4605 : : !Local variables-------------------------------
4606 : : !scalars
4607 : : integer,parameter :: master = 0
4608 : : integer :: my_rank, ncid, spin, spin_ncid, nproc, ierr, fform, max_nb, ib, natom, natom3, ib_m, ib_n !, varid
4609 : : integer :: max_nq, max_nk, ncerr, my_is, my_iq, iq_glob, my_ik, ik_glob
4610 : : integer :: nb_k, nb_kq, nb_k_file, nb_kq_file, gstore_cplex, ib_kq_start, file_fnlen !, ip1, ip2
4611 : : integer :: my_ip, ipert, iq_ibz, iq_bz, isym_q, trev_q, tsign_q, ii !, im_kq
4612 : : real(dp),parameter :: G_SMALL = tol8
4613 : : real(dp) :: cpu, wall, gflops, wqnu
4614 : : logical :: isirr_q, from_atm_to_nu, has_iv1p_comm, read_ks, has_both_g
4615 : 16 : type(hdr_type) :: wfk0_hdr
4616 [ + + + + : 1008 : type(crystal_t) :: gstore_cryst
+ + + + +
+ + + + +
+ + + + +
+ ]
4617 : : type(gqk_t),pointer :: gqk
4618 : : character(len=500) :: msg
4619 : : !arrays
4620 : 64 : integer :: units(2), ibuffer(9), nproc_spin(ebands%nsppol), comm_spin(ebands%nsppol)
4621 : 32 : integer :: brange_k_spin(2, ebands%nsppol), brange_kq_spin(2, ebands%nsppol), file_brange_kq_spin(2, ebands%nsppol), g0_q(3)
4622 : 16 : integer,allocatable :: qglob2bz(:,:), qbz2ibz(:,:)
4623 : : real(dp) :: qq_ibz(3)
4624 : 32 : real(dp) :: displ_nu_red(2, 3, cryst%natom)
4625 : 16 : real(dp),allocatable :: gwork_q(:,:,:,:,:), slice_bb(:,:,:), iv1p_comm(:,:,:,:,:)
4626 : 16 : real(dp),allocatable :: ks_gwork_q(:,:,:,:,:), ks_slice_bb(:,:,:)
4627 : 16 : real(dp),allocatable :: phfreqs_ibz(:,:), pheigvec_cart_ibz(:,:,:,:,:), pheigvec_cart_qbz(:,:,:,:)
4628 : 16 : real(dp),allocatable :: displ_cart_qbz(:,:,:,:), displ_red_qbz(:,:,:,:), gmn_nu(:,:,:,:)
4629 [ + - ]: 16 : complex(dp),allocatable :: tpp_red(:,:), my_gq0nm_atm(:,:,:,:), ks_my_gq0nm_atm(:,:,:,:)
4630 : : ! *************************************************************************
4631 : :
4632 : 16 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
4633 : :
4634 [ - + ]: 16 : ABI_CHECK(with_cplex >= 0 .and. with_cplex <= 2, sjoin("Invalid with_cplex:", itoa(with_cplex)))
4635 : :
4636 [ + + ]: 48 : units = [std_out, ab_out]
4637 : 16 : call wrtout(units, sjoin("- Reading e-ph matrix elements from: ", path), pre_newlines=1)
4638 : 16 : call wrtout(units, sjoin(" Asking for with_cplex: ", itoa(with_cplex)))
4639 [ + - ]: 16 : call wrtout(units, sjoin(" Asking for with_gmode: ", trim(with_gmode)))
4640 [ + - ]: 16 : call wrtout(units, sjoin(" Asking for gvals_name: ", trim(gvals_name)))
4641 : 16 : call wrtout(units, sjoin(" Asking for g2dw: ", yesno(with_g2dw)))
4642 : :
4643 : : ! Set basic parameters.
4644 [ - + ]: 16 : gstore%comm = comm; gstore%nsppol = dtset%nsppol; gstore%path = path
4645 : :
4646 : : ! Get references to other data structures.
4647 : 16 : gstore%dtset => dtset; gstore%cryst => cryst; gstore%ebands => ebands; gstore%ifc => ifc; gstore%kibz => ebands%kptns
4648 : :
4649 : 16 : natom = cryst%natom; natom3 = cryst%natom * 3
4650 : :
4651 [ - + + - : 96 : ABI_CALLOC(gstore%erange_spin, (2, gstore%nsppol))
+ - + - -
+ - + - +
+ + + + ]
4652 [ - + + - : 48 : ABI_MALLOC(gstore%glob_nk_spin, (gstore%nsppol))
+ - + - -
+ - + -
+ ]
4653 [ - + + - : 48 : ABI_MALLOC(gstore%glob_nq_spin, (gstore%nsppol))
+ - + - -
+ - + -
+ ]
4654 : :
4655 : : ! =====================================================
4656 : : ! Master node reads basic objects and gstore dimensions
4657 : : ! =====================================================
4658 : :
4659 [ + - ]: 16 : if (my_rank == master) then
4660 : 16 : call wrtout(units, sjoin(" Initializing gstore object from:", path, ch10))
4661 [ - + ]: 16 : ABI_CHECK(path /= ABI_NOFILE, "Use getgstore_filepath to specify the path to GSTORE.nc")
4662 [ - + ]: 16 : NCF_CHECK(nctk_open_read(ncid, path, xmpi_comm_self))
4663 : :
4664 : 16 : call wfk0_hdr%ncread(ncid, fform)
4665 [ - + ]: 16 : ABI_CHECK(fform /= 0, sjoin("Error while reading:", path))
4666 : :
4667 : : ! Read gstore dimensions
4668 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_cplex", gstore_cplex))
4669 [ - + ]: 16 : ABI_CHECK_IEQ(gstore_cplex, 2, "gstore_cplex 1 from file not supported")
4670 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nkibz", gstore%nkibz))
4671 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nkbz", gstore%nkbz))
4672 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nqibz", gstore%nqibz))
4673 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nqbz", gstore%nqbz))
4674 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_max_nq", max_nq))
4675 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_max_nk", max_nk))
4676 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_max_nb", max_nb))
4677 : :
4678 : : ! Read gstore variables
4679 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_with_vk"), gstore%with_vk))
4680 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qptopt"), gstore%qptopt))
4681 : :
4682 : : ! little group variables were added in Abinit v10.5.6.
4683 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_use_lgk"), gstore%has_used_lgk))
4684 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_use_lgq"), gstore%has_used_lgq))
4685 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kzone"), gstore%kzone))
4686 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qzone"), gstore%qzone))
4687 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kfilter"), gstore%kfilter))
4688 : : ! SC: GSTORE.nc files written before fnlen was raised from 264 to 400 have a shorter fnlen dimension.
4689 : : ! Read only the characters present in the file so that these old files can still be read.
4690 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "fnlen", file_fnlen))
4691 : 16 : gstore%wfk0_path = ""
4692 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_wfk0_path"), gstore%wfk0_path(1:min(fnlen, file_fnlen))))
4693 : 16 : call replace_ch0(gstore%kzone); call replace_ch0(gstore%qzone); call replace_ch0(gstore%kfilter)
4694 : 16 : call replace_ch0(gstore%wfk0_path)
4695 : :
4696 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_gtype"), gstore%gtype))
4697 : 16 : call replace_ch0(gstore%gtype)
4698 : : !print *, "gstore%gtype:", gstore%gtype
4699 : :
4700 [ + + ]: 16 : if (gvals_name == "gvals_ks") then
4701 : 2 : call wrtout(units, " Reading KS e-ph matrix elements")
4702 [ + - ]: 14 : else if (gvals_name == "gvals") then
4703 [ + + ]: 14 : if (gstore%gtype == GSTORE_GTYPE_GWPT) then
4704 : 4 : call wrtout(units, " Reading GWPT e-ph matrix elements")
4705 : : else
4706 : 10 : call wrtout(units, " Reading KS e-ph matrix elements")
4707 : : end if
4708 : : end if
4709 : :
4710 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_ngqpt"), gstore%ngqpt))
4711 : :
4712 [ - + + - : 48 : ABI_MALLOC(gstore%qibz, (3, gstore%nqibz))
+ - + - -
+ - + -
+ ]
4713 [ - + + - : 48 : ABI_MALLOC(gstore%wtq, (gstore%nqibz))
+ - + - -
+ - + -
+ ]
4714 [ - + + - : 48 : ABI_MALLOC(gstore%qbz, (3, gstore%nqbz))
+ - + - -
+ - + -
+ ]
4715 [ - + + - : 48 : ABI_MALLOC(gstore%kbz, (3, gstore%nkbz))
+ - + - -
+ - + -
+ ]
4716 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_k_spin"), brange_k_spin))
4717 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_kq_spin"), brange_kq_spin))
4718 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_erange_spin"), gstore%erange_spin))
4719 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qibz"), gstore%qibz))
4720 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_wtq"), gstore%wtq))
4721 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qbz"), gstore%qbz))
4722 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kbz"), gstore%kbz))
4723 : :
4724 [ - + + - : 48 : ABI_MALLOC(qbz2ibz, (6, gstore%nqbz))
+ - + - -
+ - + -
+ ]
4725 [ - + + - : 48 : ABI_MALLOC(gstore%kbz2ibz, (6, gstore%nkbz))
+ - + - -
+ - + -
+ ]
4726 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qbz2ibz"), qbz2ibz))
4727 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kbz2ibz"), gstore%kbz2ibz))
4728 : :
4729 [ - + + - : 64 : ABI_MALLOC(qglob2bz, (max_nq, gstore%nsppol))
- + + - +
- + - - +
- + - + ]
4730 [ - + + - : 64 : ABI_MALLOC(gstore%kglob2bz, (max_nk, gstore%nsppol))
- + + - +
- + - - +
- + - + ]
4731 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qglob2bz"), qglob2bz))
4732 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kglob2bz"), gstore%kglob2bz))
4733 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_glob_nq_spin"), gstore%glob_nq_spin))
4734 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_glob_nk_spin"), gstore%glob_nk_spin))
4735 : :
4736 : : ! Read optional variables:
4737 [ - + ]: 16 : if (gstore%kfilter == "fs_tetra") then
4738 [ # # # # : 0 : ABI_MALLOC(gstore%delta_ef_kibz_spin, (max_nb, gstore%nkibz, gstore%nsppol))
# # # # #
# # # # #
# # # # #
# # # ]
4739 [ # # ]: 0 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_delta_ef_kibz_spin"), gstore%delta_ef_kibz_spin))
4740 : : end if
4741 : :
4742 [ - + ]: 16 : NCF_CHECK(nf90_close(ncid))
4743 : :
4744 : : ! =================
4745 : : ! Consistency check
4746 : : ! =================
4747 [ - + - + : 16 : gstore_cryst = wfk0_hdr%get_crystal()
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + ]
4748 [ - + ]: 16 : if (cryst%compare(gstore_cryst, header=" Comparing input crystal with the one from GSTORE file") /= 0) then
4749 : 0 : ABI_ERROR("Crystal structure from input and GSTORE do not agree! Check messages above!")
4750 : : end if
4751 : 16 : call gstore_cryst%free()
4752 : : end if ! master
4753 : :
4754 [ - + ]: 16 : if (nproc > 1) then
4755 : : ! Broadcast the header.
4756 : 0 : call wfk0_hdr%bcast(master, my_rank, comm)
4757 : :
4758 : : ! Broadcast dimensions.
4759 [ # # ]: 0 : if (my_rank == master) then
4760 [ # # ]: 0 : ibuffer = [gstore_cplex, gstore%nkibz, gstore%nkbz, gstore%nqibz, gstore%nqbz, gstore%with_vk, max_nq, max_nk, max_nb]
4761 : : end if
4762 : 0 : call xmpi_bcast(ibuffer, master, comm, ierr)
4763 : :
4764 [ # # ]: 0 : if (my_rank /= master) then
4765 : : ! Other MPI procs need to store dims and allocate memory before the bcast.
4766 : 0 : gstore_cplex = ibuffer(1)
4767 : 0 : gstore%nkibz = ibuffer(2)
4768 : 0 : gstore%nkbz = ibuffer(3)
4769 : 0 : gstore%nqibz = ibuffer(4)
4770 : 0 : gstore%nqbz = ibuffer(5)
4771 : 0 : gstore%with_vk = ibuffer(6)
4772 : 0 : max_nq = ibuffer(7)
4773 : 0 : max_nk = ibuffer(8)
4774 : 0 : max_nb = ibuffer(9)
4775 : :
4776 [ # # # # : 0 : ABI_MALLOC(gstore%qibz, (3, gstore%nqibz))
# # # # #
# # # #
# ]
4777 [ # # # # : 0 : ABI_MALLOC(gstore%wtq, (gstore%nqibz))
# # # # #
# # # #
# ]
4778 [ # # # # : 0 : ABI_MALLOC(gstore%qbz, (3, gstore%nqbz))
# # # # #
# # # #
# ]
4779 [ # # # # : 0 : ABI_MALLOC(gstore%kbz, (3, gstore%nkbz))
# # # # #
# # # #
# ]
4780 [ # # # # : 0 : ABI_MALLOC(qbz2ibz, (6, gstore%nqbz))
# # # # #
# # # #
# ]
4781 [ # # # # : 0 : ABI_MALLOC(gstore%kbz2ibz, (6, gstore%nkbz))
# # # # #
# # # #
# ]
4782 [ # # # # : 0 : ABI_MALLOC(qglob2bz, (max_nq, gstore%nsppol))
# # # # #
# # # # #
# # # # ]
4783 [ # # # # : 0 : ABI_MALLOC(gstore%kglob2bz, (max_nk, gstore%nsppol))
# # # # #
# # # # #
# # # # ]
4784 : : end if
4785 : :
4786 : 0 : call xmpi_bcast(gstore%qptopt, master, comm, ierr)
4787 : 0 : call xmpi_bcast(gstore%has_used_lgk, master, comm, ierr)
4788 : 0 : call xmpi_bcast(gstore%has_used_lgq, master, comm, ierr)
4789 : 0 : call xmpi_bcast(gstore%kzone, master, comm, ierr)
4790 : 0 : call xmpi_bcast(gstore%qzone, master, comm, ierr)
4791 : 0 : call xmpi_bcast(gstore%kfilter, master, comm, ierr)
4792 : 0 : call xmpi_bcast(gstore%gmode, master, comm, ierr)
4793 : 0 : call xmpi_bcast(gstore%gtype, master, comm, ierr)
4794 : 0 : call xmpi_bcast(gstore%ngqpt, master, comm, ierr)
4795 : 0 : call xmpi_bcast(gstore%wfk0_path, master, comm, ierr)
4796 : 0 : call xmpi_bcast(brange_k_spin, master, comm, ierr)
4797 : 0 : call xmpi_bcast(brange_kq_spin, master, comm, ierr)
4798 : 0 : call xmpi_bcast(gstore%erange_spin, master, comm, ierr)
4799 : 0 : call xmpi_bcast(gstore%qibz, master, comm, ierr)
4800 : 0 : call xmpi_bcast(gstore%wtq, master, comm, ierr)
4801 : 0 : call xmpi_bcast(gstore%qbz, master, comm, ierr)
4802 : 0 : call xmpi_bcast(gstore%kbz, master, comm, ierr)
4803 : 0 : call xmpi_bcast(qbz2ibz, master, comm, ierr)
4804 : 0 : call xmpi_bcast(gstore%kbz2ibz, master, comm, ierr)
4805 : 0 : call xmpi_bcast(qglob2bz, master, comm, ierr)
4806 : 0 : call xmpi_bcast(gstore%kglob2bz, master, comm, ierr)
4807 : 0 : call xmpi_bcast(gstore%glob_nq_spin, master, comm, ierr)
4808 : 0 : call xmpi_bcast(gstore%glob_nk_spin, master, comm, ierr)
4809 : :
4810 [ # # ]: 0 : if (gstore%kfilter == "fs_tetra") then
4811 [ # # ]: 0 : if (my_rank /= master) then
4812 [ # # # # : 0 : ABI_MALLOC(gstore%delta_ef_kibz_spin, (max_nb, gstore%nkibz, gstore%nsppol))
# # # # #
# # # # #
# # # # #
# # # ]
4813 : : end if
4814 : 0 : call xmpi_bcast(gstore%delta_ef_kibz_spin, master, comm, ierr)
4815 : : end if
4816 : : end if ! nproc > 1.
4817 : :
4818 : : ! Consistency check
4819 : 16 : call wfk0_hdr%vs_dtset(dtset); call wfk0_hdr%free()
4820 : :
4821 : : ! When reading an existing GSTORE file, gstore_brange selects a smaller window of
4822 : : ! intermediate states at k+q. The external-state window at k is always the one on disk.
4823 : : ! Keep the file range to compute the offset in the NetCDF nb_kq dimension below.
4824 [ + + + + ]: 64 : file_brange_kq_spin = brange_kq_spin
4825 [ + + ]: 32 : do spin=1,gstore%nsppol
4826 [ + + + + : 62 : if (any(dtset%gstore_brange(:, spin) /= 0)) then
+ + ]
4827 [ + + + - : 3 : ABI_CHECK(all(dtset%gstore_brange(:, spin) /= 0), "Both entries of gstore_brange must be specified")
- + ]
4828 [ - + ]: 1 : ABI_CHECK_IEQ(dtset%gstore_brange(2, spin), dtset%mband, "gstore_brange(2, spin) must be equal to nband")
4829 [ + - ]: 1 : if (dtset%eph_stern /= 0) then
4830 [ - + ]: 1 : ABI_CHECK_IEQ(dtset%gstore_brange(1, spin), 1, "gstore_brange(1, spin) must be 1 when eph_stern is enabled")
4831 : : end if
4832 : : msg = sjoin("Requested gstore_brange:", ltoa(dtset%gstore_brange(:, spin)), "is not contained in the k+q band range stored in GSTORE.nc:", &
4833 [ + - ]: 1 : ltoa(file_brange_kq_spin(:, spin)))
4834 [ + - - + ]: 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)
4835 [ + + ]: 3 : brange_kq_spin(:, spin) = dtset%gstore_brange(:, spin)
4836 : : call wrtout(units, sjoin(" Restricting k+q states for spin", itoa(spin), "to gstore_brange:", &
4837 : 1 : ltoa(brange_kq_spin(:, spin))))
4838 : : end if
4839 : : end do
4840 : :
4841 : : ! If has_both_g is true, we allocate and read both the KS and the GWPT matrix elements.
4842 : 16 : read_ks = gstore%gtype == GSTORE_GTYPE_GWPT
4843 : 16 : has_both_g = gstore%gtype == GSTORE_GTYPE_GWPT
4844 : :
4845 : : ! Distribute spins, create indirect mapping to spin index and init gstore%brange_k_spin
4846 : 16 : call gstore%distribute_spins__(ebands%mband, brange_kq_spin, brange_k_spin, nproc_spin, comm_spin, comm)
4847 : :
4848 : : ! Compute krank
4849 [ + - - - : 16 : call gstore%krank_ibz%from_kptrlatt(gstore%nkibz, gstore%kibz, ebands%kptrlatt, compute_invrank=.False.)
- - - - -
+ ]
4850 : :
4851 : 16 : call gstore%set_mpi_grid__(dtfil, nproc_spin, comm_spin)
4852 : :
4853 : : ! At this point, we have the Cartesian grid (one per spin if any) and we can finally allocate and distribute other arrays.
4854 : 16 : call gstore%malloc__(with_cplex, has_both_g, max_nq, qglob2bz, max_nk, gstore%kglob2bz, qbz2ibz, gstore%kbz2ibz)
4855 : :
4856 : 16 : call xmpi_comm_free(comm_spin)
4857 : :
4858 : : ! Now we read the big arrays with MPI-IO and hdf5 groups.
4859 : : ! Note the loop over spin as each gqk has its own dimensions.
4860 : : ! Recall the shape of the arrays:
4861 : : !
4862 : : ! In memory, we have allocated:
4863 : : !
4864 : : ! my_g(my_npert, nb_kq, my_nq, nb_k, my_nk) if with_cplex == 2 (complex array)
4865 : : !
4866 : : ! or
4867 : : !
4868 : : ! my_g2(my_npert, nb_kq, my_nq, nb_k, my_nk) if with_cplex == 1
4869 : : !
4870 : : ! On disk, we have:
4871 : : !
4872 : : ! nctkarr_t("gvals", "dp", "two, nb_kq_disk, nb_k_disk, natom3, glob_nk, glob_nq")
4873 : : !
4874 : 16 : call cwtime(cpu, wall, gflops, "start")
4875 : :
4876 : : ! ===================================================
4877 : : ! Load phonon frequencies and eigenvectors in the IBZ
4878 : : ! ===================================================
4879 : :
4880 : : ! nctkarr_t("phfreqs_ibz", "dp", "natom3, gstore_nqibz")
4881 : : ! nctkarr_t("pheigvec_cart_ibz", "dp", "two, three, natom, natom3, gstore_nqibz")
4882 [ - + + - : 64 : ABI_MALLOC(phfreqs_ibz, (natom3, gstore%nqibz))
- + + - +
- + - - +
- + - + ]
4883 [ - + + - : 80 : ABI_MALLOC(pheigvec_cart_ibz, (2, 3, cryst%natom, cryst%natom * 3, gstore%nqibz))
+ - - + +
- - + + -
+ - + - -
+ - + -
+ ]
4884 [ - + + - : 64 : ABI_MALLOC(pheigvec_cart_qbz, (2, 3, cryst%natom, cryst%natom * 3))
- + + - +
- + - - +
- + ]
4885 [ - + + - : 48 : ABI_MALLOC(displ_cart_qbz, (2, 3, cryst%natom, cryst%natom * 3))
- + + - -
+ - + ]
4886 [ - + + - : 64 : ABI_MALLOC(displ_red_qbz, (2, 3, cryst%natom, natom3))
- + + - +
- + - - +
- + ]
4887 : :
4888 : : !NCF_CHECK(nctk_open_read(ncid, gstore%path, gstore%comm))
4889 : : ! SC: Open with xmpi_comm_self (independent IO) instead of gqk%comm, otherwise there will be a deadlock on lemaitre4
4890 [ - + ]: 16 : NCF_CHECK(nctk_open_read(ncid, gstore%path, xmpi_comm_self))
4891 : 16 : has_iv1p_comm = gstore_nc_has_iv1p_comm(gstore, ncid)
4892 : : ! SC: nctk_set_collective can cause a deadlock on lemaitre4
4893 : : !if (nproc > 1) then
4894 : : ! NCF_CHECK(nctk_set_collective(ncid, vid("phfreqs_ibz")))
4895 : : ! NCF_CHECK(nctk_set_collective(ncid, vid("pheigvec_cart_ibz")))
4896 : : !end if
4897 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("phfreqs_ibz"), phfreqs_ibz))
4898 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("pheigvec_cart_ibz"), pheigvec_cart_ibz))
4899 [ - + ]: 16 : NCF_CHECK(nf90_close(ncid))
4900 : :
4901 : : ! =========================
4902 : : ! Load e-ph matrix elements
4903 : : ! =========================
4904 : 16 : call pstat_proc%print(_PSTAT_ARGS_)
4905 : :
4906 : 16 : from_atm_to_nu = .False.
4907 : : ! Compare with_gmode with the one on disk. The only conversion I can think of is: atom --> phonon.
4908 [ - + ]: 16 : if (gstore%gmode /= with_gmode) then
4909 [ + - + - ]: 16 : if (gstore%gmode == GSTORE_GMODE_ATOM .and. with_gmode == GSTORE_GMODE_PHONON) then
4910 : 16 : from_atm_to_nu = .True.; gstore%gmode = GSTORE_GMODE_PHONON ! Change gstore%gmode here
4911 : : else
4912 : 0 : ABI_ERROR(sjoin("Conversion from gstore%gmode: ", gstore%gmode, "to:", with_gmode, " is not yet supported"))
4913 : : end if
4914 : : end if
4915 [ + - ]: 16 : gstore%gmode = with_gmode
4916 : :
4917 [ + + ]: 16 : if (with_g2dw) then
4918 [ - + ]: 7 : ABI_CHECK(with_gmode == GSTORE_GMODE_PHONON, "g2dw in the atom representation is not coded")
4919 [ - + + - : 28 : ABI_MALLOC(tpp_red, (natom3, natom3))
- + + - +
- + - - +
- + ]
4920 : : end if
4921 : :
4922 [ + + ]: 32 : do spin=1,gstore%nsppol
4923 : 16 : my_is = gstore%spin2my_is(spin)
4924 : :
4925 [ + - ]: 32 : if (my_is /= 0) then
4926 : 16 : gqk => gstore%gqk(my_is)
4927 : :
4928 [ - + + - : 64 : ABI_MALLOC(gqk%my_wnuq, (gqk%my_npert, gqk%my_nq))
- + + - +
- + - - +
- + - + ]
4929 [ - + + - : 80 : ABI_MALLOC(gqk%my_displ_cart, (2, 3, cryst%natom, gqk%my_npert, gqk%my_nq))
- + + - -
+ + - + -
+ - - + -
+ - + ]
4930 : :
4931 : : !NCF_CHECK(nctk_open_read(ncid, gstore%path, gqk%comm%value))
4932 : : ! SC: Open with xmpi_comm_self (independent IO) instead of gqk%comm, otherwise there will be a deadlock on lemaitre4
4933 [ - + ]: 16 : NCF_CHECK(nctk_open_read(ncid, gstore%path, xmpi_comm_self))
4934 [ - + ]: 16 : NCF_CHECK(nf90_inq_ncid(ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
4935 : :
4936 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_k", nb_k_file))
4937 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_kq", nb_kq_file))
4938 : :
4939 : : ! Note that these dimensions should be compatible with what is stored on disk.
4940 : 16 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
4941 [ - + ]: 16 : ABI_CHECK_IEQ(nb_k, nb_k_file, "nb_k !/ nb_k_file")
4942 [ - + ]: 16 : ABI_CHECK_ILEQ(nb_kq, nb_kq_file, "nb_kq > nb_kq_file")
4943 : 16 : ib_kq_start = gqk%bstart_kq - file_brange_kq_spin(1, spin) + 1
4944 [ + - - + ]: 16 : ABI_CHECK_IRANGE(ib_kq_start, 1, nb_kq_file, "Invalid k+q band offset in GSTORE.nc")
4945 [ - + ]: 16 : ABI_CHECK_ILEQ(ib_kq_start + nb_kq - 1, nb_kq_file, "Requested k+q band window exceeds GSTORE.nc")
4946 : :
4947 : : ! gstore_cplex defines the data on disk while cplex defines what we want to store in memory
4948 [ - + + - : 112 : ABI_MALLOC_OR_DIE(gwork_q, (gstore_cplex, nb_kq, nb_k, gqk%natom3, gqk%glob_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - -
+ + - -
+ ]
4949 [ - + + - : 80 : ABI_MALLOC(slice_bb, (gstore_cplex, nb_kq, nb_k))
- + + - -
+ + - + -
+ - - + -
+ ]
4950 [ + + ]: 16 : if (read_ks) then
4951 [ - + + - : 42 : ABI_MALLOC_OR_DIE(ks_gwork_q, (gstore_cplex, nb_kq, nb_k, gqk%natom3, gqk%glob_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - -
+ + - -
+ ]
4952 [ - + + - : 30 : ABI_MALLOC(ks_slice_bb, (gstore_cplex, nb_kq, nb_k))
- + + - -
+ + - + -
+ - - + -
+ - + ]
4953 : : end if
4954 : :
4955 [ + + ]: 16 : if (with_g2dw) then
4956 : : ! Read my_gq0nm_atm matrix elements for DW in the RIA. Find the index of q = 0.
4957 : 7 : iq_glob = -1
4958 [ + - ]: 7 : do ii=1, gstore%glob_nq_spin(spin)
4959 : 7 : iq_bz = qglob2bz(ii, spin)
4960 [ + + + - ]: 28 : if (sum(gstore%qbz(:, iq_bz)**2) < tol4) then
4961 : 7 : iq_glob = ii; exit
4962 : : end if
4963 : : end do
4964 [ - + ]: 7 : ABI_CHECK_INEQ(iq_glob, -1, "Cannot finq q=0 in g(k,q)!")
4965 : 7 : call wrtout(std_out, sjoin(" Reading g_atm(k,q=0) for Debye-Waller with iq_glob:", itoa(iq_glob)))
4966 : :
4967 : : ! Read q-slice of the e-ph matrix elements (individual IO).
4968 : : ! Note gvals_name so that we can read either g^KS or g^Sigma.
4969 [ + + ]: 49 : ncerr = nf90_get_var(spin_ncid, spin_vid(gvals_name), gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
4970 [ - + ]: 7 : NCF_CHECK(ncerr)
4971 : :
4972 [ + + ]: 7 : if (read_ks) then
4973 [ + + ]: 42 : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals_ks"), ks_gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
4974 [ - + ]: 6 : NCF_CHECK(ncerr)
4975 : : ! Here we set g_GWPT g to g_KS if g_KS is smaller than a certain threshold as GWPT breaks symmetries.
4976 [ + + + + : 13931 : where (abs(ks_gwork_q) < G_SMALL)
+ + + + +
+ + + ]
4977 : : gwork_q = ks_gwork_q
4978 : : end where
4979 : : end if
4980 : :
4981 : : ! Allocate gdw2
4982 [ - + + - : 49 : ABI_MALLOC(gqk%my_gdw2, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk))
- + + - -
+ + - - +
+ - - + +
- + - + -
- + - + -
+ ]
4983 : 7 : gqk%my_gdw2_ks => gqk%my_gdw2
4984 : : ! Allocate my_gq0nm_atm and transfer data. Note TRANSPOSITION in (m, n) indices.
4985 [ - + + - : 42 : ABI_MALLOC(my_gq0nm_atm, (nb_k, nb_kq, natom3, gqk%my_nk))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
4986 : :
4987 [ + + ]: 7 : if (gqk%has_both_g) then
4988 [ - + + - : 36 : ABI_MALLOC(gqk%my_gdw2_ks, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk))
- + + - -
+ + - - +
+ - - + +
- - + -
+ ]
4989 [ - + + - : 30 : ABI_MALLOC(ks_my_gq0nm_atm, (nb_k, nb_kq, natom3, gqk%my_nk))
- + + - -
+ + - - +
+ - - + -
+ - + ]
4990 : : end if
4991 : :
4992 [ + + ]: 19 : do my_ik=1,gqk%my_nk
4993 : 12 : ik_glob = my_ik + gqk%my_kstart - 1
4994 [ + + ]: 167 : do ib_m=1,nb_kq
4995 [ + + ]: 988 : do ib_n=1,nb_k
4996 [ + + ]: 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)
4997 [ + + ]: 976 : if (gqk%has_both_g) then
4998 [ + + ]: 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)
4999 : : end if
5000 : : end do
5001 : : end do
5002 : : end do
5003 : : end if ! with_g2dw
5004 : :
5005 [ - + ]: 16 : if (has_iv1p_comm) then
5006 : : ! Read matrix elements of commutator [iv, p].
5007 [ # # # # : 0 : ABI_MALLOC(gqk%my_iv1p_comm, (nb_k, nb_k, 3, gqk%my_npert, gqk%my_nk))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
5008 [ # # # # : 0 : ABI_MALLOC(iv1p_comm, (2, nb_k, nb_k, 3, natom3))
# # # # #
# # # # #
# # # # #
# # # #
# ]
5009 : : ! nctkarr_t("iv1p_comm", "dp", "two, nb_k, nb_k, three, natom3, glob_nk")
5010 : :
5011 [ # # ]: 0 : do my_ik=1,gqk%my_nk
5012 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
5013 [ # # ]: 0 : ncerr = nf90_get_var(spin_ncid, spin_vid("iv1p_comm"), iv1p_comm, start=[1,1,1,1,1, ik_glob])
5014 [ # # ]: 0 : NCF_CHECK(ncerr)
5015 : :
5016 : : ! Save my perturbations for this k-point.
5017 [ # # ]: 0 : do my_ip=1,gqk%my_npert
5018 : 0 : ipert = gqk%my_pertcases(my_ip)
5019 [ # # # # : 0 : gqk%my_iv1p_comm(:,:,:,my_ip, my_ik) = r2c(iv1p_comm(:,:,:,:,ipert))
# # # # ]
5020 : : end do
5021 : : end do
5022 [ # # ]: 0 : ABI_FREE(iv1p_comm)
5023 : : end if
5024 : :
5025 [ + - ]: 16 : if (from_atm_to_nu) then
5026 [ - + + - : 80 : ABI_MALLOC(gmn_nu, (2, nb_kq, nb_k, 3*natom))
- + + - +
- - + + -
+ - + - -
+ - + -
+ ]
5027 : : end if
5028 : :
5029 : : ! Read my e-ph matrix elements.
5030 [ + + ]: 1365 : do my_iq=1,gqk%my_nq
5031 : 1349 : iq_glob = my_iq + gqk%my_qstart - 1
5032 : :
5033 : : !call wrtout(std_out, " Computing and storing phonons in the full BZ by rotating the data in the IBZ...")
5034 : 1349 : iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
5035 : 1349 : trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5, my_iq)
5036 : : !isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
5037 : 1349 : isirr_q = (isym_q == 1 .and. trev_q == 0)
5038 : 1349 : tsign_q = 1; if (trev_q == 1) tsign_q = -1
5039 [ + + ]: 5396 : qq_ibz = gstore%qibz(:, iq_ibz)
5040 : :
5041 : : ! Here we get the ph displacement for this q-point in the BZ from the image in the IBZ.
5042 : : ! This is important for complex g as we have to enforce the gauge in the ph eigenvectors, including e(-q) = e(q)^*.
5043 : : call pheigvec_rotate(cryst, qq_ibz, isym_q, trev_q, pheigvec_cart_ibz(:,:,:,:,iq_ibz), pheigvec_cart_qbz, displ_cart_qbz, &
5044 : 1349 : displ_red_qbz=displ_red_qbz)
5045 : :
5046 : : ! Save my frequencies and my phonon displacements.
5047 [ + - + + : 17537 : gqk%my_wnuq(:, my_iq) = phfreqs_ibz(gqk%my_pertcases(:), iq_ibz)
+ + ]
5048 [ + - + + : 179417 : gqk%my_displ_cart(:,:,:,:,my_iq) = displ_cart_qbz(:,:,:,gqk%my_pertcases(:))
+ + + + +
+ + + ]
5049 : :
5050 [ + + ]: 1349 : if (with_g2dw) then
5051 [ + + ]: 1176 : do my_ip=1,gqk%my_npert
5052 : : ! Compute T_pp'(q,nu) matrix in reduced coordinates for DW.
5053 : 1008 : call phdispl_cart2red_nmodes(natom, 1, cryst%gprimd, gqk%my_displ_cart(:,:,:,my_ip,my_iq), displ_nu_red)
5054 : 1008 : call sigtk_dw_tpp_red(natom, displ_nu_red, tpp_red)
5055 : 1008 : wqnu = gqk%my_wnuq(my_ip, my_iq)
5056 : :
5057 [ + + ]: 2424 : do my_ik=1,gqk%my_nk
5058 [ + + + + ]: 2256 : if (.not. gqk%has_both_g .or. dtset%gwpt_g2mode == 1) then
5059 : : call calc_and_store_gdw2(gqk, my_ik, my_iq, my_ip, wqnu, tpp_red, &
5060 : 864 : my_gq0nm_atm(:,:,:,my_ik), my_gq0nm_atm(:,:,:,my_ik))
5061 : : else
5062 : : !print *, "Computing g2dw with both g^KS g_GWPT"
5063 : : call calc_and_store_gdw2(gqk, my_ik, my_iq, my_ip, wqnu, tpp_red, &
5064 : 384 : ks_my_gq0nm_atm(:,:,:,my_ik), my_gq0nm_atm(:,:,:,my_ik))
5065 : : end if
5066 : : end do ! my_ik
5067 : :
5068 : : end do ! my_ip
5069 : : end if
5070 : :
5071 : : ! Read q-slice of g(k,q) in the atom representation. (individual IO).
5072 [ + + ]: 9443 : ncerr = nf90_get_var(spin_ncid, spin_vid(gvals_name), gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
5073 [ - + ]: 1349 : NCF_CHECK(ncerr)
5074 : :
5075 [ + + ]: 1349 : if (read_ks) then
5076 [ + + ]: 728 : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals_ks"), ks_gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
5077 [ - + ]: 104 : NCF_CHECK(ncerr)
5078 : : ! Here we set g_GWPT g to g_KS if g_KS is smaller than a certain threshold as GWPT breaks symmetries.
5079 [ + + + + : 153560 : where (abs(ks_gwork_q) < G_SMALL)
+ + + + +
+ + + ]
5080 : : gwork_q = ks_gwork_q
5081 : : end where
5082 : : end if
5083 : :
5084 [ + + ]: 111960 : do my_ik=1,gqk%my_nk
5085 : 110595 : ik_glob = my_ik + gqk%my_kstart - 1
5086 [ + - ]: 110595 : if (from_atm_to_nu) then
5087 : : ! Here we convert from g(k,q)_atom to g(k,q)_phonon and replace data in gwork_q at ik_glob
5088 : : call ephtk_gkknu_from_atm(nb_kq, nb_k, 1, natom, gwork_q(:,:,:,:, ik_glob), &
5089 : 110595 : phfreqs_ibz(:, iq_ibz), displ_red_qbz, gmn_nu)
5090 [ + + + + : 12601221 : gwork_q(:,:,:,:, ik_glob) = gmn_nu
+ + + + ]
5091 : :
5092 [ + + ]: 110595 : if (gqk%has_both_g) then
5093 : : call ephtk_gkknu_from_atm(nb_kq, nb_k, 1, natom, ks_gwork_q(:,:,:,:, ik_glob), &
5094 : 144 : phfreqs_ibz(:, iq_ibz), displ_red_qbz, gmn_nu)
5095 [ + + + + : 153456 : ks_gwork_q(:,:,:,:, ik_glob) = gmn_nu
+ + + + ]
5096 : : end if
5097 : : end if
5098 : :
5099 [ + + ]: 775514 : do my_ip=1,gqk%my_npert
5100 : 663570 : ipert = gqk%my_pertcases(my_ip)
5101 [ + - + - : 13154196 : slice_bb = gwork_q(:,:,:, ipert, ik_glob)
+ - - + -
- + + + +
+ + ]
5102 [ + + ]: 663570 : if (read_ks) then
5103 [ + - + - : 154176 : ks_slice_bb = ks_gwork_q(:,:,:, ipert, ik_glob)
+ - - + -
- + + + +
+ + ]
5104 : : end if
5105 : :
5106 : : ! Put data in the right place and handle conversion g --> |g|^2.
5107 [ + + ]: 774165 : if (with_cplex == gstore_cplex) then
5108 [ - + ]: 662706 : if (with_cplex == 1) then
5109 [ # # # # ]: 0 : gqk%my_g2(my_ip,:,my_iq,:,my_ik) = slice_bb(1,:,:)
5110 [ # # # # ]: 0 : if (read_ks .and. gqk%has_both_g) then
5111 [ # # # # ]: 0 : gqk%my_g2_ks(my_ip,:,my_iq,:,my_ik) = ks_slice_bb(1,:,:)
5112 : : end if
5113 : : end if
5114 [ + - ]: 662706 : if (with_cplex == 2) then
5115 [ + + + + ]: 5439486 : gqk%my_g(my_ip,:,my_iq,:,my_ik) = slice_bb(1,:,:) + j_dpc * slice_bb(2,:,:)
5116 [ + + + - ]: 662706 : if (read_ks .and. gqk%has_both_g) then
5117 [ + + + + ]: 17280 : gqk%my_g_ks(my_ip,:,my_iq,:,my_ik) = ks_slice_bb(1,:,:) + j_dpc * ks_slice_bb(2,:,:)
5118 : : end if
5119 : : end if
5120 : :
5121 : : else
5122 [ + - + - ]: 864 : if (with_cplex == 1 .and. gstore_cplex == 2) then
5123 [ + + + + ]: 69984 : gqk%my_g2(my_ip, :, my_iq, :, my_ik) = slice_bb(1,:,:) ** 2 + slice_bb(2,:,:) ** 2
5124 [ + + + - ]: 864 : if (read_ks .and. gqk%has_both_g) then
5125 [ + + + + ]: 37344 : gqk%my_g2_ks(my_ip, :, my_iq, :, my_ik) = ks_slice_bb(1,:,:) ** 2 + ks_slice_bb(2,:,:) ** 2
5126 : : end if
5127 [ # # ]: 0 : else if (with_cplex == 0) then
5128 : : continue
5129 : : else
5130 : 0 : ABI_ERROR("Conversion from g2 on file to g_complex in memory is not possible!")
5131 : : end if
5132 : : end if
5133 : : end do ! my_ip
5134 : : end do ! my_ik
5135 : :
5136 : : end do ! my_iq
5137 : :
5138 [ - + ]: 16 : ABI_FREE(gwork_q)
5139 [ - + ]: 16 : ABI_FREE(slice_bb)
5140 [ + + ]: 16 : if (read_ks) then
5141 [ - + ]: 6 : ABI_FREE(ks_gwork_q)
5142 [ - + ]: 6 : ABI_FREE(ks_slice_bb)
5143 : : end if
5144 : :
5145 [ + - ]: 16 : ABI_SFREE(gmn_nu)
5146 [ + + ]: 16 : ABI_SFREE(my_gq0nm_atm)
5147 [ + + ]: 16 : ABI_SFREE(ks_my_gq0nm_atm)
5148 : :
5149 : : ! =========================================
5150 : : ! Read matrix elements of velocity operator
5151 : : ! =========================================
5152 : : ! SC: nctk_set_collective can cause a deadlock on lemaitre4
5153 [ + - ]: 16 : if (gstore%with_vk == 1) then
5154 : : !if (gqk%comm%nproc > 1) then
5155 : : ! NCF_CHECK(nctk_set_collective(spin_ncid, spin_vid("vk_cart_ibz")))
5156 : : !end if
5157 [ - + ]: 16 : NCF_CHECK(nf90_get_var(spin_ncid, spin_vid("vk_cart_ibz"), gqk%vnk_cart_ibz))
5158 : :
5159 [ # # ]: 0 : else if (gstore%with_vk == 2) then
5160 : : !if (gqk%comm%nproc > 1) then
5161 : : ! NCF_CHECK(nctk_set_collective(spin_ncid, spin_vid("vnk_mat_cart_ibz")))
5162 : : !end if
5163 [ # # ]: 0 : NCF_CHECK(nf90_get_var(spin_ncid, spin_vid("vnk_mat_cart_ibz"), gqk%vnk_mat_cart_ibz))
5164 : :
5165 : : ! Transfer diagonal terms to vnk_cart_ibz.
5166 [ # # ]: 0 : do ib=1,gqk%nb_k
5167 [ # # # # ]: 0 : gqk%vnk_cart_ibz(:, ib, :) = gqk%vnk_mat_cart_ibz(1, :, ib, ib, :)
5168 : : end do
5169 : : end if
5170 : :
5171 [ - + ]: 16 : NCF_CHECK(nf90_close(ncid))
5172 : : end if
5173 : : end do ! spin
5174 : :
5175 [ - + ]: 16 : ABI_FREE(qglob2bz)
5176 [ - + ]: 16 : ABI_FREE(qbz2ibz)
5177 [ - + ]: 16 : ABI_FREE(phfreqs_ibz)
5178 [ - + ]: 16 : ABI_FREE(pheigvec_cart_ibz)
5179 [ - + ]: 16 : ABI_FREE(displ_cart_qbz)
5180 [ - + ]: 16 : ABI_FREE(displ_red_qbz)
5181 [ - + ]: 16 : ABI_FREE(pheigvec_cart_qbz)
5182 [ + + ]: 16 : ABI_SFREE(tpp_red)
5183 : :
5184 : 16 : call pstat_proc%print(_PSTAT_ARGS_)
5185 : 16 : call xmpi_barrier(gstore%comm)
5186 [ - + - + : 48 : call cwtime_report(" gstore_from_ncpath", cpu, wall, gflops)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
5187 : :
5188 : : !stop
5189 : :
5190 : : contains
5191 : 400 : integer function vid(var_name)
5192 : : character(len=*),intent(in) :: var_name
5193 : 400 : vid = nctk_idname(ncid, var_name)
5194 : : end function vid
5195 : :
5196 : 1482 : integer function spin_vid(var_name)
5197 : : character(len=*),intent(in) :: var_name
5198 : 1482 : spin_vid = nctk_idname(spin_ncid, var_name)
5199 : : end function spin_vid
5200 : :
5201 : : end subroutine gstore_from_ncpath
5202 : : !!***
5203 : :
5204 : 1248 : subroutine calc_and_store_gdw2(gqk, my_ik, my_iq, my_ip, wqnu, tpp_red, gq0l_atm, gq0r_atm)
5205 : :
5206 : : type(gqk_t), intent(inout) :: gqk
5207 : : integer,intent(in) :: my_ik, my_iq, my_ip
5208 : : real(dp),intent(in) :: wqnu
5209 : : complex(dp),intent(in) :: tpp_red(gqk%natom3, gqk%natom3)
5210 : : complex(dp),intent(in) :: gq0l_atm(gqk%nb_k, gqk%nb_kq, gqk%natom3)
5211 : : complex(dp),intent(in) :: gq0r_atm(gqk%nb_k, gqk%nb_kq, gqk%natom3)
5212 : :
5213 : : !Local variables-------------------------------
5214 : : !scalars
5215 : : integer :: im_kq, in_k, ip2, ip1
5216 : : real(dp) :: gdw2
5217 : : complex(dp) :: cfact
5218 : : ! *************************************************************************
5219 : :
5220 : : ! Loop over bands in |m,k+q>
5221 [ + + ]: 18432 : do im_kq=1,gqk%nb_kq
5222 : : ! Loop over the n index in |n,k>.
5223 [ + + ]: 98496 : do in_k=1,gqk%nb_k
5224 : : ! Compute DW term following XG paper. Check prefactor.
5225 : : gdw2 = zero
5226 [ + + ]: 560448 : do ip2=1,gqk%natom3
5227 [ + + ]: 3442752 : do ip1=1,gqk%natom3
5228 : : cfact = ( &
5229 : : + real(gq0l_atm(in_k, im_kq, ip1)) * real(gq0r_atm(in_k, im_kq, ip2)) &
5230 : : + aimag(gq0l_atm(in_k, im_kq, ip1)) * aimag(gq0r_atm(in_k, im_kq, ip2)) &
5231 : : + real(gq0l_atm(in_k, im_kq, ip2)) * real(gq0r_atm(in_k, im_kq, ip1)) &
5232 : : + aimag(gq0l_atm(in_k, im_kq, ip2)) * aimag(gq0r_atm(in_k, im_kq, ip1)) &
5233 : 2882304 : )
5234 : 3362688 : gdw2 = gdw2 + real(tpp_red(ip1,ip2) * cfact)
5235 : : end do
5236 : : end do
5237 : :
5238 [ + + ]: 80064 : if (wqnu < EPHTK_WTOL) then
5239 : : gdw2 = zero
5240 : : else
5241 : 77580 : gdw2 = gdw2 / (four * two * wqnu)
5242 : : end if
5243 : :
5244 : : !print *, "gdw2", gdw2
5245 : 97248 : gqk%my_gdw2(my_ip, im_kq, my_iq, in_k, my_ik) = gdw2
5246 : : end do ! in_k
5247 : : end do ! im_kq
5248 : :
5249 : 1248 : end subroutine calc_and_store_gdw2
5250 : :
5251 : : !----------------------------------------------------------------------
5252 : :
5253 : : !!****f* m_gstore/gstore_check_restart
5254 : : !! NAME
5255 : : !! gstore_check_restart
5256 : : !!
5257 : : !! FUNCTION
5258 : : !! Check whether restart from a previous GSTORE.nc is possible.
5259 : : !!
5260 : : !! INPUTS
5261 : : !!
5262 : : !! SOURCE
5263 : :
5264 : 3 : subroutine gstore_check_restart(filepath, dtset, nqbz, done_qbz_spin, restart, comm)
5265 : :
5266 : : !Arguments ------------------------------------
5267 : : character(len=*),intent(in) :: filepath
5268 : : type(dataset_type),intent(in) :: dtset
5269 : : integer,intent(out) :: nqbz, restart
5270 : : integer,allocatable,intent(out) :: done_qbz_spin(:,:)
5271 : : integer,intent(in) :: comm
5272 : :
5273 : : !Local variables-------------------------------
5274 : : !scalars
5275 : : integer,parameter :: master = 0
5276 : : integer :: my_rank, root_ncid, ierr, gstore_completed, gstore_fform, units(2) ! fform
5277 : : character(len=500) :: msg
5278 : 3 : type(hdr_type) :: gstore_hdr
5279 : : ! *************************************************************************
5280 : :
5281 [ + + ]: 9 : my_rank = xmpi_comm_rank(comm); units = [std_out, ab_out]
5282 : :
5283 : : !print *, "eph_restart:", dtset%eph_restart
5284 : :
5285 : 3 : restart = 0; nqbz = 0
5286 [ + - + - ]: 3 : if (my_rank == master .and. dtset%eph_restart == 1) then
5287 [ - + ]: 3 : if (file_exists(filepath)) then
5288 [ # # ]: 0 : call wrtout(units, sjoin("- Found pre-existent GSTORE file:", trim(filepath)))
5289 : 0 : call wrtout(units, " Testing if all e-ph terms have been computed...")
5290 : : ! Use gstore_completed to understand if the previous GSTORE run completed else we need to restart.
5291 [ # # ]: 0 : NCF_CHECK(nctk_open_read(root_ncid, filepath, xmpi_comm_self))
5292 [ # # ]: 0 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_completed"), gstore_completed))
5293 : 0 : call gstore_hdr%ncread(root_ncid, gstore_fform)
5294 [ # # ]: 0 : ABI_CHECK_INEQ(gstore_fform, 0, "Wrong gstore_fform")
5295 : 0 : call gstore_hdr%vs_dtset(dtset); call gstore_hdr%free()
5296 : :
5297 [ # # ]: 0 : NCF_CHECK(nctk_get_dim(root_ncid, "gstore_nqbz", nqbz))
5298 [ # # # # : 0 : ABI_MALLOC(done_qbz_spin, (nqbz, dtset%nsppol))
# # # # #
# # # # #
# # # # ]
5299 [ # # ]: 0 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_done_qbz_spin"), done_qbz_spin))
5300 [ # # ]: 0 : NCF_CHECK(nf90_close(root_ncid))
5301 : : !print *, "done_qbz_spin:", done_qbz_spin
5302 : :
5303 : : ! FIXME: done_qbz_spin is dimensioned with the q-points in the BZ but we
5304 : : ! should set to 1 the q-points in the BZ else we never restart
5305 : : ! Perhaps can can set to -1 if q = TS q_ibz if q_ibz is done.
5306 [ # # ]: 0 : if (gstore_completed /= 0) then
5307 : : ! Previous computation completed, keep a backup of the file and start from scratch.
5308 [ # # # # ]: 0 : restart = 0; done_qbz_spin = 0
5309 : : msg = sjoin("- WARNING: Found GSTORE.nc file with all entries already computed.", ch10, &
5310 [ # # ]: 0 : "- Will overwrite:", trim(filepath), ch10, "Keeping backup copy in:", strcat(filepath, ".bkp"))
5311 : 0 : call wrtout(units, msg)
5312 [ # # ]: 0 : ABI_CHECK(clib_rename(trim(filepath), strcat(filepath, ".bkp")) == 0, "Failed to rename GSTORE file.")
5313 : : else
5314 : 0 : restart = 1
5315 : 0 : call wrtout(units, "- Restarting from a previous GSTORE.nc file")
5316 : : end if
5317 : : else
5318 [ + - ]: 3 : call wrtout(units, sjoin("- Cannot find pre-existent GSTORE file:", trim(filepath)))
5319 : : end if
5320 : : end if
5321 : :
5322 : 3 : call xmpi_bcast(restart, master, comm, ierr)
5323 : 3 : call xmpi_bcast(nqbz, master, comm, ierr)
5324 : :
5325 [ - + ]: 3 : if (my_rank /= master) then
5326 [ # # # # : 0 : ABI_MALLOC(done_qbz_spin, (nqbz, dtset%nsppol))
# # # # #
# # # # #
# # # # ]
5327 : : end if
5328 [ - + - + : 3 : if (nqbz /= 0) call xmpi_bcast(done_qbz_spin, master, comm, ierr)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - ]
5329 : : !stop
5330 : :
5331 : : contains
5332 : 0 : integer function root_vid(var_name)
5333 : : character(len=*),intent(in) :: var_name
5334 : 0 : root_vid = nctk_idname(root_ncid, var_name)
5335 : : end function root_vid
5336 : :
5337 : : end subroutine gstore_check_restart
5338 : : !!***
5339 : :
5340 : : !----------------------------------------------------------------------
5341 : :
5342 : : !!****f* m_gstore/gstore_prepare_mpiio
5343 : : !! NAME
5344 : : !! gstore_prepare_mpiio
5345 : : !!
5346 : : !! FUNCTION
5347 : : !! Access all the variables of GSTORE.nc (root group and gqk_spin groups) with all the procs that opened the file.
5348 : : !! With a file opened in parallel, netcdf reads the metadata of a variable the first time the variable is accessed
5349 : : !! and, with parallel HDF5, this read is collective. If a subset of the procs accesses a variable first
5350 : : !! (e.g. a single writer per (q, k) block), the other procs do not take part in the read and the run deadlocks
5351 : : !! or aborts with "NetCDF: Can't add HDF5 file metadata".
5352 : : !! This generalizes nctk_prepare_mpiio to all the variables of the file, so that new variables cannot be forgotten.
5353 : : !! Must be called by all the procs that opened the file, in data mode, before any access by a subset of the procs.
5354 : : !!
5355 : : !! INPUTS
5356 : : !! root_ncid=Netcdf identifier of the root group of GSTORE.nc.
5357 : : !! nsppol=Number of gqk_spin groups in the file.
5358 : : !!
5359 : : !! SOURCE
5360 : :
5361 : 8 : subroutine gstore_prepare_mpiio(root_ncid, nsppol)
5362 : :
5363 : : !Arguments ------------------------------------
5364 : : integer,intent(in) :: root_ncid, nsppol
5365 : :
5366 : : !Local variables-------------------------------
5367 : : integer :: spin, spin_ncid
5368 : : ! *************************************************************************
5369 : :
5370 : 8 : call prepare_group(root_ncid)
5371 [ + + ]: 16 : do spin=1,nsppol
5372 [ - + ]: 8 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
5373 : 16 : call prepare_group(spin_ncid)
5374 : : end do
5375 : :
5376 : : contains
5377 : :
5378 : 16 : subroutine prepare_group(ncid)
5379 : : integer,intent(in) :: ncid
5380 : : integer :: nvars, varid
5381 : : character(len=nf90_max_name) :: varname
5382 : :
5383 [ - + ]: 16 : NCF_CHECK(nf90_inquire(ncid, nVariables=nvars))
5384 [ + + ]: 979 : do varid=1,nvars
5385 [ - + ]: 979 : NCF_CHECK(nf90_inquire_variable(ncid, varid, varname))
5386 : : end do
5387 : :
5388 : 16 : end subroutine prepare_group
5389 : :
5390 : : end subroutine gstore_prepare_mpiio
5391 : : !!***
5392 : :
5393 : : !----------------------------------------------------------------------
5394 : :
5395 : : !!****f* m_gstore/gstore_print_for_abitests
5396 : : !! NAME
5397 : : !! gstore_print_for_abitests
5398 : : !!
5399 : : !! FUNCTION
5400 : : !! Print subset of results to ab_out for testing purposes.
5401 : : !! This routine should be called when the output of the GSTORE.nc file is completed
5402 : : !!
5403 : : !! INPUTS
5404 : : !! dtset<type(dataset_type)>=all input variables for this dataset
5405 : : !! [with_ks]: if True, read "gvals" as well as "gvals_ks". This options is used in GWPT
5406 : : !! in which "gvals" are the GWPT matrix elements and ""gvals_ks" are the KS ones.
5407 : : !!
5408 : : !! SOURCE
5409 : :
5410 : 8 : subroutine gstore_print_for_abitests(gstore, dtset, ebands, do_avg, with_ks)
5411 : :
5412 : : !Arguments ------------------------------------
5413 : : class(gstore_t),intent(inout) :: gstore
5414 : : type(dataset_type),intent(in) :: dtset
5415 : : type(ebands_t),intent(in) :: ebands
5416 : : logical,intent(in) :: do_avg
5417 : : logical,optional,intent(in) :: with_ks
5418 : :
5419 : : !Local variables-------------------------------
5420 : : !scalars
5421 : : integer,parameter :: master = 0
5422 : : integer :: root_ncid, spin_ncid, gstore_completed, spin, ik_glob, iq_glob, ipc, ncerr, natom3
5423 : : integer :: glob_nq, glob_nk, im_kq, in_k, m_kq, n_k, nb_k, nb_kq, ii ! ib_k,
5424 : : integer :: bstart_k, bstop_k, bstart_kq, bstop_kq, max_nk, max_nq, idir
5425 : : integer :: ik_bz, ik_ibz, ib_min_k, ib_max_k, iq_bz, ikq_ibz, ib_min_kq, ib_max_kq, nn
5426 : : logical :: with_ks__, changed_k, changed_kq, all_gs, has_iv1p_comm
5427 : : real(dp) :: gg, gg_ks, g_ratio, min_g_ratio, max_g_ratio, mean_g_ratio, stdev_g_ratio !, vnk
5428 : : character(len=abi_slen) :: gstore_gmode
5429 : : character(len=500) :: msg
5430 : : !arrays
5431 : : integer :: mapl_kq(6)
5432 : 8 : integer,allocatable :: done_qbz_spin(:,:), qglob2bz(:,:), degblock_k(:,:), degblock_kq(:,:)
5433 : : real(dp) :: kk(3), qq(3), kq(3), rtmp(2)
5434 : 8 : real(dp),allocatable :: gslice_mn(:,:,:), gslice_ks_mn(:,:,:), g2_mn(:,:), g2ks_mn(:,:), iv1p_comm(:,:,:,:,:)
5435 : : !real(dp),allocatable :: vnk_cart_ibz(:,:) !, vnk_mat_cart_ibz(:,:,:,:)
5436 : : ! *************************************************************************
5437 : :
5438 : : ! Only master prints to ab_out
5439 [ + - ]: 8 : if (xmpi_comm_rank(gstore%comm) /= master) return
5440 : :
5441 [ + + ]: 8 : with_ks__ = .False.; if (present(with_ks)) with_ks__ = with_ks
5442 [ - + ]: 8 : all_gs = .False. ; if (dtset%prtvol >= 10) all_gs = .True.
5443 : :
5444 : 8 : natom3 = dtset%natom * 3
5445 [ + + ]: 16 : max_nq = maxval(gstore%glob_nq_spin) ! Max dim over spin
5446 : : max_nk = maxval(gstore%glob_nk_spin)
5447 : :
5448 [ - + ]: 8 : NCF_CHECK(nctk_open_read(root_ncid, gstore%path, xmpi_comm_self))
5449 : :
5450 [ - + ]: 8 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_completed"), gstore_completed))
5451 : 8 : write(ab_out, *)""
5452 : 8 : write(ab_out, "(a,i0)")" gstore_completed: ", gstore_completed
5453 : :
5454 [ - + + - : 32 : ABI_MALLOC(done_qbz_spin, (gstore%nqbz, dtset%nsppol))
- + + - +
- + - - +
- + ]
5455 [ - + ]: 8 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_done_qbz_spin"), done_qbz_spin))
5456 [ + + + + : 2573 : write(ab_out, "(a,*(i0,1x))")" gstore_done_qbz_spin: ", count(done_qbz_spin == 1)
+ + ]
5457 [ - + ]: 8 : ABI_FREE(done_qbz_spin)
5458 : :
5459 [ - + + - : 997 : ABI_CALLOC(qglob2bz, (max_nq, dtset%nsppol))
- + + - +
- + - - +
- + + + +
+ ]
5460 [ - + ]: 8 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_qglob2bz"), qglob2bz))
5461 : :
5462 : : gstore_gmode = GSTORE_GMODE_ATOM
5463 : :
5464 [ + + ]: 16 : do spin=1,gstore%nsppol
5465 [ - + ]: 8 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
5466 [ - + ]: 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "glob_nq", glob_nq))
5467 [ - + ]: 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "glob_nk", glob_nk))
5468 [ - + ]: 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_k", nb_k))
5469 [ - + ]: 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_kq", nb_kq))
5470 : :
5471 : 8 : bstart_k = gstore%brange_k_spin(1, spin)
5472 : 8 : bstop_k = gstore%brange_k_spin(2, spin)
5473 : 8 : bstart_kq = gstore%brange_kq_spin(1, spin)
5474 : 8 : bstop_kq = gstore%brange_kq_spin(2, spin)
5475 : :
5476 : 8 : write(ab_out, "(a,i0)")" nb_k: ", nb_k
5477 : 8 : write(ab_out, "(a,i0)")" bstart_k: ", bstart_k
5478 : 8 : write(ab_out, "(a,i0)")" nb_kq: ", nb_kq
5479 : 8 : write(ab_out, "(a,i0)")" bstart_kq: ", bstart_kq
5480 : 8 : write(ab_out, "(a,i0)")" glob_nq: ", glob_nq
5481 : 8 : write(ab_out, "(a,i0)")" glob_nk: ", glob_nk
5482 : :
5483 : : ! Handle the output of group velocities. On disk, we have:
5484 : : !
5485 : : ! nctkarr_t("vk_cart_ibz", "dp", "three, nb_k, gstore_nkibz"))
5486 : : ! or
5487 : : ! nctkarr_t("vnk_mat_cart_ibz", "dp", "two, three, nb_k, nb_k, gstore_nkibz")))
5488 : :
5489 : 8 : select case (gstore%with_vk)
5490 : : case (0)
5491 : : continue
5492 : :
5493 : : case (1)
5494 : 0 : continue
5495 : : !write(ab_out,"(2a)") ch10," Group velocities |v_nk| in atomic units:"
5496 : :
5497 : : !ABI_MALLOC(vnk_cart_ibz, (3, nb_k))
5498 : : !do ik_ibz=1,gstore%nkibz
5499 : : ! ! Only a subset of k-points are written to ab_out.
5500 : : ! if (all(ik_ibz /= [1, 2, gstore%nkibz - 1, gstore%nkibz])) cycle
5501 : : ! 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]))
5502 : :
5503 : : ! write(ab_out, "(a)")sjoin(" For k-point:", ktoa(gstore%kibz(:,ik_ibz)), ", spin", itoa(spin))
5504 : : ! do ib_k=1,min(nb_k, 10)
5505 : : ! vnk = sqrt(norm2(vnk_cart_ibz(:,ib_k)))
5506 : : ! write(ab_out, "(a,i0,1x,es16.6)")" ib_k: ", ib_k, vnk
5507 : : ! end do
5508 : : !end do
5509 : : !ABI_FREE(vnk_cart_ibz)
5510 : : !write(ab_out, "(a)")" "
5511 : :
5512 : : case (2)
5513 [ - + ]: 8 : ABI_ERROR(" TEXT output of vkmat is not coded yet!")
5514 : : end select
5515 : :
5516 : : ! Handle the output of the e-ph matrix elements. On disk we have the global array:
5517 : : !
5518 : : ! nctkarr_t("gvals", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq")
5519 : :
5520 : : ! These e-ph matrix elements are ALWAYS in the atom representation.
5521 [ - + + - : 32 : ABI_MALLOC(gslice_mn, (2, nb_kq, nb_k))
- + + - +
- + - - +
- + - + ]
5522 [ - + + - : 24 : ABI_MALLOC(gslice_ks_mn, (2, nb_kq, nb_k))
- + + - -
+ - + -
+ ]
5523 [ - + + - : 32 : ABI_MALLOC(g2_mn, (nb_kq, nb_k))
- + + - +
- + - - +
- + ]
5524 [ - + + - : 24 : ABI_MALLOC(g2ks_mn, (nb_kq, nb_k))
- + + - -
+ - + ]
5525 : :
5526 : 8 : write(ab_out,"(a)") " E-PH matrix elements in the atom representation: pcase = (idir, iatom)"
5527 [ + - ]: 8 : if (do_avg) then
5528 : 8 : write(ab_out,"(a)") " NB: Values are averaged over e_mk+q, and e_nk degenerate states."
5529 : : else
5530 : 0 : write(ab_out,"(a)") " NB: Values are NOT averaged over e_mk+q, and e_nk degenerate states."
5531 : : end if
5532 : :
5533 [ + + ]: 8 : if (with_ks__) then
5534 : 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"
5535 : : else
5536 : 5 : write(ab_out, "(1x,5(a5,1x),a16)") "iq", "ik", "pcase", "m_kq", "n_k", "|g| in Ha"
5537 : : end if
5538 : :
5539 [ + + ]: 319 : do ik_glob=1,glob_nk
5540 : : ! Write the first and the last k-point.
5541 [ + + + + : 311 : if ((ik_glob /= 1 .and. ik_glob /= glob_nk) .and. .not. all_gs) cycle
+ - ]
5542 : :
5543 : 14 : ik_bz = gstore%kglob2bz(ik_glob, spin)
5544 : 14 : ik_ibz = gstore%kbz2ibz(1, ik_bz)
5545 : : !ik_ibz = gstore%bz2ibz(1, ik_bz); isym_k = gstore%bz2ibz(2, ik_bz)
5546 : : !trev_k = gstore%bz2ibz(6, ik_bz); g0_k = gstore%bz2ibz(3:5, ik_bz)
5547 : : !isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
5548 : :
5549 [ + + ]: 56 : kk = ebands%kptns(:,ik_ibz)
5550 : 14 : ib_min_k = bstart_k; ib_max_k = bstop_k
5551 : :
5552 : : call ebands%enclose_degbands(ik_ibz, spin, ib_min_k, ib_max_k, changed_k, dtset%symsigma_de, &
5553 [ - + ]: 14 : degblock=degblock_k)
5554 [ + + ]: 14 : if (changed_k) then
5555 : : !write(ab_out, "(a)")" Non all the degenerate bands at k were included. This should not happen!"
5556 [ + + ]: 10 : do ii=1,size(degblock_k, dim=2)
5557 : 8 : degblock_k(1, ii) = max(degblock_k(1, ii), bstart_k)
5558 : 10 : degblock_k(2, ii) = min(degblock_k(2, ii), bstop_k)
5559 : : end do
5560 : : end if
5561 : :
5562 [ + + ]: 1800 : do iq_glob=1,glob_nq
5563 : : ! Write the first and the last q-point.
5564 [ + + + + : 1786 : if ((iq_glob /= 1 .and. iq_glob /= glob_nq) .and. .not. all_gs) cycle
+ - ]
5565 : :
5566 : : ! Find k+q image in the IBZ.
5567 : 28 : iq_bz = qglob2bz(iq_glob, spin)
5568 [ + + ]: 112 : qq = gstore%qbz(:, iq_bz)
5569 [ + + ]: 112 : kq = kk + qq
5570 [ - + ]: 28 : if (kpts_map("symrel", ebands%kptopt, gstore%cryst, gstore%krank_ibz, 1, kq, mapl_kq) /= 0) then
5571 [ # # ]: 0 : write(msg, '(4a)' )"k-mesh is not closed!",ch10, "k+q could not be generated from a symmetrical one.",trim(ltoa(kq))
5572 : 0 : ABI_ERROR(msg)
5573 : : end if
5574 : 28 : ikq_ibz = mapl_kq(1)
5575 : 28 : ib_min_kq = bstart_kq; ib_max_kq = bstop_kq
5576 : :
5577 : : call ebands%enclose_degbands(ikq_ibz, spin, ib_min_kq, ib_max_kq, changed_kq, dtset%symsigma_de, &
5578 [ - + ]: 28 : degblock=degblock_kq)
5579 : :
5580 [ + + ]: 28 : if (changed_kq) then
5581 : : !write(ab_out, "(a)")" Non all the degenerate bands at k+q were included. This should not happen!"
5582 [ + + ]: 34 : do ii=1,size(degblock_kq, dim=2)
5583 : 30 : degblock_kq(1, ii) = max(degblock_kq(1, ii), bstart_kq)
5584 : 34 : degblock_kq(2, ii) = min(degblock_kq(2, ii), bstop_kq)
5585 : : end do
5586 : : end if
5587 : :
5588 [ + + ]: 196 : do ipc=1,natom3
5589 : : ! Write the 4th and the last perturbation.
5590 [ + + - + ]: 168 : if ((ipc /= 4 .and. ipc /= natom3) .and. .not. all_gs) cycle
5591 : : ! TODO: Write that pcase is filtered
5592 : : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals"), gslice_mn, &
5593 [ + + + + ]: 728 : start=[1,1,1,ipc,ik_glob,iq_glob], count=[2,nb_kq,nb_k,1,1,1])
5594 [ - + ]: 56 : NCF_CHECK(ncerr)
5595 : 56 : call average_g2_mn(do_avg, nb_kq, nb_k, bstart_kq, bstart_k, degblock_kq, degblock_k, gslice_mn, g2_mn)
5596 : :
5597 : 56 : write(ab_out, "(3(a,1x,i0,1x))")" |g(k,q)| in Ha for iq:", iq_glob, "ik:", ik_glob, "pcase:", ipc
5598 : :
5599 [ + + ]: 84 : if (.not. with_ks__) then
5600 : : ! gvals only.
5601 : 36 : write(ab_out, "(1x,5(a5,1x),a16)")"iq", "ik", "pcase", "m_kq", "n_k", "|g|"
5602 [ + + ]: 196 : do im_kq=1,nb_kq
5603 : 160 : m_kq = im_kq + bstart_kq - 1
5604 [ + + ]: 740 : do in_k=1,nb_k
5605 : 544 : n_k = in_k + bstart_k - 1
5606 : 544 : gg = sqrt(g2_mn(im_kq, in_k))
5607 : 704 : write(ab_out, "(a1,5(i5,1x),es16.6)")"-", iq_glob, ik_glob, ipc, m_kq, n_k, gg
5608 : : end do
5609 : : end do
5610 : : else
5611 : : ! GW/KS ratio, g^GW, g^KS
5612 : : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals_ks"), gslice_ks_mn, &
5613 [ + + + + ]: 260 : start=[1,1,1,ipc,ik_glob,iq_glob], count=[2,nb_kq,nb_k,1,1,1])
5614 [ - + ]: 20 : NCF_CHECK(ncerr)
5615 : 20 : call average_g2_mn(do_avg, nb_kq, nb_k, bstart_kq, bstart_k, degblock_kq, degblock_k, gslice_ks_mn, g2ks_mn)
5616 : :
5617 : 20 : write(ab_out, "(1x,5(a5,1x),3a16)")"iq", "ik", "pcase", "m_kq", "n_k", "GW/KS", "|g^GW|", "|g^KS|"
5618 : 20 : min_g_ratio = +huge(one); max_g_ratio = -huge(one); mean_g_ratio = zero; stdev_g_ratio = zero; nn = 0
5619 : :
5620 [ + + ]: 252 : do im_kq=1,nb_kq
5621 : 232 : m_kq = im_kq + bstart_kq - 1
5622 [ + + ]: 1564 : do in_k=1,nb_k
5623 : 1312 : n_k = in_k + bstart_k - 1
5624 : 1312 : gg = sqrt(g2_mn(im_kq, in_k))
5625 : 1312 : gg_ks = sqrt(g2ks_mn(im_kq, in_k))
5626 : 1312 : call safe_div(gg, gg_ks, -one, g_ratio)
5627 [ + + ]: 1312 : if (g_ratio /= -one) then
5628 : 944 : nn = nn + 1
5629 : 944 : min_g_ratio = min(g_ratio, min_g_ratio)
5630 : 944 : max_g_ratio = max(g_ratio, max_g_ratio)
5631 : 944 : mean_g_ratio = mean_g_ratio + g_ratio
5632 : 944 : stdev_g_ratio = stdev_g_ratio + g_ratio ** 2
5633 : : end if
5634 : 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
5635 : : end do
5636 : : end do
5637 : :
5638 [ + + ]: 20 : if (nn /= 0) then
5639 : 14 : mean_g_ratio = mean_g_ratio / nn
5640 : 14 : write(ab_out, "(a,es16.6)")"- mean_g_ratio:", mean_g_ratio
5641 : : ! \sigma^{2} = \langle x^{2} \rangle - \langle x \rangle^{2}
5642 : 14 : write(ab_out, "(a,es16.6)")"- stdev_g_ratio:", sqrt((stdev_g_ratio / nn) - (mean_g_ratio ** 2))
5643 : 14 : write(ab_out, "(a,es16.6)")"- min_g_ratio:", min_g_ratio
5644 : 14 : write(ab_out, "(a,es16.6)")"- max_g_ratio:", max_g_ratio
5645 : : end if
5646 : : end if
5647 : :
5648 : : end do ! ipc
5649 : :
5650 [ - + ]: 1800 : ABI_FREE(degblock_kq)
5651 : : end do ! iq_glob
5652 [ - + ]: 319 : ABI_FREE(degblock_k)
5653 : : end do ! ik_glob
5654 : :
5655 [ - + ]: 8 : ABI_FREE(gslice_mn)
5656 [ - + ]: 8 : ABI_FREE(gslice_ks_mn)
5657 [ - + ]: 8 : ABI_FREE(g2_mn)
5658 [ - + ]: 16 : ABI_FREE(g2ks_mn)
5659 : : end do ! spin
5660 : :
5661 [ - + ]: 8 : ABI_FREE(qglob2bz)
5662 : :
5663 : : ! Here we read the matrix elements of i[V1, p] if present on disk.
5664 : 8 : has_iv1p_comm = gstore_nc_has_iv1p_comm(gstore, root_ncid)
5665 : :
5666 [ - + ]: 8 : if (has_iv1p_comm) then
5667 [ # # ]: 0 : do spin=1,gstore%nsppol
5668 [ # # ]: 0 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
5669 [ # # ]: 0 : NCF_CHECK(nctk_get_dim(spin_ncid, "glob_nk", glob_nk))
5670 [ # # ]: 0 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_k", nb_k))
5671 : :
5672 : 0 : bstart_k = gstore%brange_k_spin(1, spin)
5673 : 0 : bstop_k = gstore%brange_k_spin(2, spin)
5674 : :
5675 [ # # # # : 0 : ABI_CALLOC(iv1p_comm, (2, nb_k, nb_k, 3, natom3))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # #
# ]
5676 : :
5677 [ # # ]: 0 : do ik_glob=1,glob_nk
5678 : : ! Write the first and the last k-point.
5679 [ # # # # : 0 : if ((ik_glob /= 1 .and. ik_glob /= glob_nk) .and. .not. all_gs) cycle
# # ]
5680 : :
5681 : : !ik_bz = gstore%kglob2bz(ik_glob, spin)
5682 : : !ik_ibz = gstore%kbz2ibz(1, ik_bz)
5683 : : !kk_ibz = ebands%kptns(:,ik_ibz)
5684 : :
5685 : : ! nctkarr_t("iv1p_comm", "dp", "two, nb_k, nb_k, three, natom3, glob_nk")
5686 : : ncerr = nf90_get_var(spin_ncid, spin_vid("iv1p_comm"), iv1p_comm, &
5687 [ # # # # ]: 0 : start=[1,1,1,1,1,ik_glob], count=[2,nb_k,nb_k,3,natom3,1])
5688 [ # # ]: 0 : NCF_CHECK(ncerr)
5689 : :
5690 : : ! Only n_nk states are included in the matrix.
5691 : 0 : write(ab_out, "(1x,5(a5,1x),a16)")"ik", "pcase", "m_k", "n_k", "idir", "i[V1,p]"
5692 [ # # ]: 0 : do im_kq=1,nb_k
5693 : 0 : m_kq = im_kq + bstart_k - 1
5694 [ # # ]: 0 : do in_k=1,nb_k
5695 : 0 : n_k = in_k + bstart_k - 1
5696 [ # # ]: 0 : do ipc=1,natom3
5697 [ # # # # : 0 : if ((ipc /= 4 .and. ipc /= natom3) .and. .not. all_gs) cycle
# # ]
5698 [ # # ]: 0 : do idir=1,3
5699 [ # # ]: 0 : rtmp = iv1p_comm(:, im_kq, in_k, idir, ipc)
5700 : 0 : write(ab_out, "(a1,5(i5,1x),2es16.6)") "-", ik_glob, ipc, m_kq, n_k, idir, rtmp(1), rtmp(2)
5701 : : end do ! idir
5702 : : end do ! ipc
5703 : : end do ! in_k
5704 : : end do ! im_kq
5705 : :
5706 : : end do ! ik_glob
5707 : :
5708 [ # # ]: 0 : ABI_FREE(iv1p_comm)
5709 : : end do ! spin
5710 : : end if
5711 : :
5712 [ - + - + : 16 : NCF_CHECK(nf90_close(root_ncid))
- + - + -
+ - + - +
- + ]
5713 : :
5714 : : contains
5715 : 24 : integer function root_vid(var_name)
5716 : : character(len=*),intent(in) :: var_name
5717 : 24 : root_vid = nctk_idname(root_ncid, var_name)
5718 : : end function root_vid
5719 : :
5720 : 76 : integer function spin_vid(var_name)
5721 : : character(len=*),intent(in) :: var_name
5722 : 76 : spin_vid = nctk_idname(spin_ncid, var_name)
5723 : : end function spin_vid
5724 : :
5725 : : end subroutine gstore_print_for_abitests
5726 : : !!***
5727 : :
5728 [ - + - + ]: 76 : subroutine average_g2_mn(do_avg, nb_kq, nb_k, bstart_kq, bstart_k, degblock_kq, degblock_k, g_mn, g2_mn)
5729 : :
5730 : : !Arguments ------------------------------------
5731 : : logical,intent(in) :: do_avg
5732 : : integer,intent(in) :: nb_kq, nb_k, bstart_kq, bstart_k
5733 : : integer,intent(in) :: degblock_kq(:,:), degblock_k(:,:)
5734 : : real(dp),intent(in) :: g_mn(2, nb_kq, nb_k)
5735 : : real(dp),intent(out) :: g2_mn(nb_kq, nb_k)
5736 : :
5737 : : !Local variables-------------------------------
5738 : : integer :: im_group, in_group, count, m_kq, im_kq, n_k, in_k
5739 : : real(dp) :: g2_avg
5740 : : !----------------------------------------------------------------------
5741 : :
5742 [ - + ]: 76 : if (do_avg) then
5743 : : ! Average over electronic degenerate states at k and k+q
5744 [ + + + + ]: 3564 : g2_mn = -one
5745 [ + + ]: 460 : do im_group = 1, size(degblock_kq, dim=2)
5746 [ + + ]: 1414 : do in_group = 1, size(degblock_k, dim=2)
5747 : 954 : g2_avg = zero; count = 0
5748 [ + + ]: 2542 : do m_kq = degblock_kq(1, im_group), degblock_kq(2, im_group)
5749 : 1588 : im_kq = m_kq - bstart_kq + 1
5750 [ + + ]: 5710 : do n_k = degblock_k(1, in_group), degblock_k(2, in_group)
5751 : 3168 : in_k = n_k - bstart_k + 1
5752 : 3168 : g2_avg = g2_avg + g_mn(1, im_kq, in_k)**2 + g_mn(2, im_kq, in_k)**2
5753 : 4756 : count = count + 1
5754 : : end do
5755 : : end do
5756 : 954 : g2_avg = g2_avg / count
5757 : :
5758 : : ! Loop again over degenerate bands and copy average.
5759 [ + + ]: 2926 : do m_kq = degblock_kq(1, im_group), degblock_kq(2, im_group)
5760 : 1588 : im_kq = m_kq - bstart_kq + 1
5761 [ + + ]: 5710 : do n_k = degblock_k(1, in_group), degblock_k(2, in_group)
5762 : 3168 : in_k = n_k - bstart_k + 1
5763 : 4756 : g2_mn(im_kq, in_k) = g2_avg
5764 : : end do
5765 : : end do
5766 : :
5767 : : end do ! in_group
5768 : : end do ! im_group
5769 : :
5770 : : else
5771 : : ! No average here.
5772 [ # # ]: 0 : do im_kq=1, nb_kq
5773 [ # # ]: 0 : do in_k=1, nb_k
5774 : 0 : g2_mn(im_kq, in_k) = g_mn(1, im_kq, in_k)**2 + g_mn(2, im_kq, in_k)**2
5775 : : end do
5776 : : end do
5777 : : end if
5778 : :
5779 : 76 : end subroutine average_g2_mn
5780 : : !!***
5781 : :
5782 : : !----------------------------------------------------------------------
5783 : :
5784 : : !!****f* m_gstore/gqk_gather
5785 : : !! NAME
5786 : : !! gqk_gather
5787 : : !!
5788 : : !! FUNCTION
5789 : : !! Gather the MPI-distributed matrix elements for a given k/q-point index.
5790 : : !! Once one reciprocal dimension is fixed, the gathering is performed across the other one.
5791 : : !!
5792 : : !! INPUTS
5793 : : !! mode = String controlling the choice of the fixed dimension ("k" or "q")
5794 : : !! fixed_pt = Index of the fixed k/q-point
5795 : : !!
5796 : : !! OUTPUT
5797 : : !! g_gathered(:,:,:,:) = Matrix elements for the given k/q-point, ordered as
5798 : : !! (my_npert, nb, nb, glob_nq) - k-point is fixed
5799 : : !! (my_npert, nb, nb, glob_nk) - q-point is fixed
5800 : : !!
5801 : : !! SOURCE
5802 : :
5803 : 554656 : subroutine gqk_gather(gqk, mode, fixed_pt, g_gathered)
5804 : :
5805 : : !Arguments ------------------------------------
5806 : : !scalars
5807 : : class(gqk_t), target, intent(in) :: gqk
5808 : : character(len=*),intent(in) :: mode
5809 : : integer,intent(in) :: fixed_pt
5810 : : !arrays
5811 : : complex(dp), allocatable, intent(out) :: g_gathered(:,:,:,:)
5812 : :
5813 : : !Local variables-------------------------------
5814 : : !scalars
5815 : : integer :: comm, ierr, ipt_glob, ngather, my_ipt, my_ngather, my_ptstart, my_pert, ib, jb
5816 : : !arrays
5817 : 277328 : complex(dp), pointer :: my_g(:,:,:,:)
5818 : : !----------------------------------------------------------------------
5819 : :
5820 : 0 : ABI_CHECK_IEQ(gqk%nb_kq, gqk%nb_k, "nb_kq != nb_k not tested")
5821 : :
5822 : 0 : select case (mode)
5823 : : case ("k")
5824 : 0 : comm = gqk%qpt_comm%value
5825 : 0 : ngather = gqk%glob_nq
5826 : 0 : my_ngather = gqk%my_nq
5827 : 0 : my_ptstart = gqk%my_qstart
5828 : 0 : my_g => gqk%my_g(:,:,:,:,fixed_pt)
5829 [ # # # # : 0 : ABI_CALLOC(g_gathered, (gqk%my_npert, gqk%nb_kq, gqk%nb_k, ngather))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # #
# ]
5830 : :
5831 : : case ("q")
5832 : 277328 : comm = gqk%kpt_comm%value
5833 : 277328 : ngather = gqk%glob_nk
5834 : 277328 : my_ngather = gqk%my_nk
5835 : 277328 : my_ptstart = gqk%my_kstart
5836 : 277328 : my_g => gqk%my_g(:,:,fixed_pt,:,:)
5837 [ - + + - : 2145973896 : ABI_CALLOC(g_gathered, (gqk%my_npert, gqk%nb_k, gqk%nb_kq, ngather))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + + + +
+ + + +
+ ]
5838 : :
5839 : : case default
5840 [ - + - ]: 277328 : ABI_ERROR(sjoin("Gathering MPI-distributed matrix elements, unsupported mode: ", mode))
5841 : : end select
5842 : :
5843 [ + + ]: 33615830 : do my_ipt=1,my_ngather
5844 : 33338502 : ipt_glob = my_ipt + my_ptstart - 1
5845 : :
5846 : : ! FIXME: can the rearrangement be done in the select case statement?
5847 [ + + ]: 130549622 : do ib=1,gqk%nb_k
5848 [ + + ]: 417991956 : do jb=1,gqk%nb_kq
5849 [ + + ]: 2110971426 : do my_pert=1,gqk%my_npert
5850 [ - + ]: 2014037634 : if (mode == "k") then
5851 : 0 : g_gathered(my_pert, jb, ib, ipt_glob) = my_g(my_pert, jb, my_ipt, ib)
5852 : : else
5853 : 1726317972 : g_gathered(my_pert, jb, ib, ipt_glob) = my_g(my_pert, jb, ib, my_ipt)
5854 : : endif
5855 : : enddo
5856 : : enddo
5857 : : enddo
5858 : : enddo
5859 : :
5860 : 277328 : call xmpi_sum(g_gathered, comm, ierr)
5861 : :
5862 [ - + ]: 277328 : end subroutine gqk_gather
5863 : : !!***
5864 : :
5865 : : !----------------------------------------------------------------------
5866 : :
5867 : : !!****f* m_gstore/gstore_wannierize_and_write_gwan
5868 : : !! NAME
5869 : : !! gstore_wannierize_and_write_gwan
5870 : : !!
5871 : : !! FUNCTION
5872 : : !! Compute g(R_e,R_ph) from g(k,q). Save results to GWAN.nc file
5873 : : !!
5874 : : !! INPUTS
5875 : : !!
5876 : : !! SOURCE
5877 : :
5878 : 0 : subroutine gstore_wannierize_and_write_gwan(gstore, dvdb, dtfil)
5879 : :
5880 : : !Arguments ------------------------------------
5881 : : class(gstore_t),target, intent(in) :: gstore
5882 : : type(dvdb_t),intent(in) :: dvdb
5883 : : type(datafiles_type),intent(in) :: dtfil
5884 : :
5885 : : !Local variables-------------------------------
5886 : : !scalars
5887 : : integer,parameter :: master = 0
5888 : : integer,parameter :: wan_ntest = 4
5889 : : integer,parameter :: wan_nperiod = 3
5890 : : real(dp),parameter :: WAN_CLOSURE_TOL = tol8
5891 : : real(dp),parameter :: WAN_VELOCITY_FD_STEP = 1.0d-5
5892 : : real(dp),parameter :: WAN_VELOCITY_DEGEN_TOL = 1.0d-5
5893 : : real(dp),parameter :: WAN_VELOCITY_TOL = tol6
5894 : : integer :: nr_e, nr_p, nwan, iwan, jwan, spin, my_is, my_ip, ir, irp, my_ik, my_iq, nb_k, nb_kq
5895 : : integer :: my_nk, my_nq, ierr, ik, ikq, my_npert, nwin_k, nwin_kq, ii, jj, band_kq, band_k, ib_k, ib_kq
5896 : : integer :: itest, ip_loc, ik_glob, iq_glob, ntest_found, iperiod, idir, ib, nvelocity_tested
5897 : : real(dp) :: max_err, ref_scale, max_period_eig_err, period_eig_scale, max_period_g2_err, period_g2_scale
5898 : : real(dp) :: max_velocity_err, velocity_scale, band_gap, velocity_fd
5899 : : character(len=500) :: msg
5900 : : logical :: keep_umats, test_found(wan_ntest)
5901 : : type(wan_t),pointer :: wan
5902 : : type(gqk_t),pointer :: gqk
5903 : : !arrays
5904 : : integer :: qptrlatt_(3,3), units(2)
5905 : : integer :: test_ik(wan_ntest), test_iq(wan_ntest)
5906 : : integer :: period_gk(3,wan_nperiod), period_gq(3,wan_nperiod)
5907 : : real(dp) :: weight_qq, qpt(3), kpt(3), kq(3), dkred(3), cpu, wall, gflops
5908 : 0 : real(dp),allocatable :: eigens_k_test(:), eigens_kq_test(:), eigens_k_period(:), eigens_kq_period(:)
5909 : 0 : real(dp),allocatable :: eigens_k_plus(:), eigens_k_minus(:), vcart_test(:,:)
5910 : 0 : complex(dp),allocatable :: emikr(:), emiqr(:), u_k(:,:), u_kq(:,:), gww_epq(:,:,:,:,:), gww_pk(:,:,:,:), g_bb(:,:), tmp_mat(:,:)
5911 : 0 : complex(dp),allocatable :: test_gref(:,:,:,:), u_k_test(:,:), u_kq_test(:,:), cmat_test(:,:), g_expected(:,:)
5912 : 0 : complex(dp),allocatable :: g_atm_test(:,:,:,:), g_atm_period(:,:,:,:)
5913 : : ! *************************************************************************
5914 : :
5915 [ # # ]: 0 : units = [std_out, ab_out]
5916 : 0 : period_gk = reshape([1,0,0, 0,0,0, -1,1,0], shape(period_gk))
5917 : 0 : period_gq = reshape([0,0,0, 0,1,0, 0,0,1], shape(period_gq))
5918 : 0 : call wrtout(units, " Computing g(R_e,R_ph) in the Wannier representation...", pre_newlines=1)
5919 : 0 : call cwtime(cpu, wall, gflops, "start")
5920 : :
5921 [ # # ]: 0 : if (gstore%check_cplex_qkzone_gmode(2, "bz", "bz", "atom", kfilter="none") /= 0) then
5922 : 0 : ABI_ERROR("The gstore object is inconsistent with gstore_wannierize_and_write_gwan. See messages above.")
5923 : : end if
5924 : :
5925 : : ! TODO: Handle long-range part.
5926 [ # # # # ]: 0 : if (dvdb%has_zeff .or. dvdb%has_quadrupoles) then
5927 : 0 : ABI_WARNING("Treatment of long-range part not yet coded in gstore_wannierize_and_write_gwan!")
5928 : : end if
5929 : :
5930 [ # # ]: 0 : do my_is=1,gstore%my_nspins
5931 : 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
5932 : 0 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
5933 : :
5934 : : ! Initialize gkq%wan from ABIWAN.nc for this spin.
5935 : 0 : keep_umats = .False.
5936 : 0 : call gqk%wan%from_abiwan(dtfil%filabiwanin, spin, gstore%nsppol, keep_umats, dtfil%filnam_ds(4), gqk%comm%value)
5937 : 0 : wan => gqk%wan
5938 : :
5939 : : ! Compute Wigner-Seitz lattice vectors and llocate grpe_wwp with shape: (nr_p, nr_e, nwan, nwan, my_npert).
5940 : 0 : call kptrlatt_from_ngkpt(gstore%ngqpt, qptrlatt_)
5941 : : call wan%setup_eph_ws_kq(gstore%cryst, gstore%ebands%shiftk(:,1), gstore%ebands%kptrlatt, qptrlatt_, &
5942 : 0 : gqk%my_pert_start, my_npert, gqk%pert_comm)
5943 : :
5944 : 0 : nr_p = wan%nr_p; nr_e = wan%nr_e; nwan = wan%nwan
5945 : : !if (gqk%comm%me == master) call wan%print(units)
5946 : :
5947 : : ! Cache the pre-FT ground truth at four fixed GLOBAL coarse-mesh points. Using
5948 : : ! local first/last indices would make the test points depend on the MPI grid.
5949 [ # # ]: 0 : test_ik = [1, gqk%glob_nk, 1, gqk%glob_nk]
5950 [ # # ]: 0 : test_iq = [1, 1, gqk%glob_nq, gqk%glob_nq]
5951 : 0 : test_found = .False.
5952 [ # # # # : 0 : ABI_CALLOC(test_gref, (nwan, nwan, my_npert, wan_ntest))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
5953 : :
5954 [ # # # # : 0 : ABI_MALLOC(emikr, (nr_e))
# # # # #
# # # ]
5955 [ # # # # : 0 : ABI_MALLOC(emiqr, (nr_p))
# # # # #
# # # ]
5956 [ # # # # : 0 : ABI_MALLOC(gww_pk, (nwan, nwan, my_npert, my_nk))
# # # # #
# # # # #
# # # # #
# # # #
# ]
5957 : : ! Intermediate buffer to store the sum over k-points. Note my_nq.
5958 [ # # # # : 0 : ABI_CALLOC(gww_epq, (nwan, nwan, nr_e, my_npert, my_nq))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
5959 : :
5960 : : ! Loop over my q-points (partial sum over q).
5961 [ # # ]: 0 : do my_iq=1,my_nq
5962 : 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qpt)
5963 : :
5964 : : !call get_kg(qpt, 1, ecut_lr, gstore%cryst%gmet, ng_q, gvec_q)
5965 : : !ABI_FREE(gvec_q)
5966 : :
5967 : : ! Loop over my k-points (partial sum over k).
5968 [ # # ]: 0 : do my_ik=1,my_nk
5969 [ # # # # ]: 0 : kpt = gqk%my_kpts(:,my_ik); kq = kpt + qpt
5970 : 0 : ik = wan%krank%get_index(kpt); ikq = wan%krank%get_index(kq)
5971 [ # # ]: 0 : ABI_CHECK(ik /= -1, sjoin("Cannot find kpt: ", ktoa(kpt)))
5972 [ # # ]: 0 : ABI_CHECK(ikq /= -1, sjoin("Cannot find k+q: ", ktoa(kq)))
5973 : :
5974 : : ! Get rotation matrices at k and k+q.
5975 : 0 : nwin_k = wan%dimwin(ik); nwin_kq = wan%dimwin(ikq)
5976 [ # # # # : 0 : ABI_MALLOC(g_bb, (nwin_kq, nwin_k))
# # # # #
# # # # #
# # ]
5977 [ # # # # : 0 : ABI_MALLOC(u_k, (1:nwin_k, 1:nwan))
# # # # #
# # # # #
# # ]
5978 [ # # # # : 0 : ABI_MALLOC(u_kq, (1:nwin_kq, 1:nwan))
# # # # #
# # # # #
# # ]
5979 [ # # # # : 0 : ABI_MALLOC(tmp_mat, (nwin_kq, nwan))
# # # # #
# # # # #
# # ]
5980 : :
5981 [ # # # # : 0 : u_k = wan%u_k(1:nwin_k, 1:nwan, ik)
# # ]
5982 [ # # # # : 0 : u_kq = wan%u_k(1:nwin_kq, 1:nwan, ikq)
# # ]
5983 : :
5984 [ # # ]: 0 : do my_ip=1,gqk%my_npert
5985 : : !----------------------------------------------------------
5986 : : ! STEP 1: rotation to optimally smooth Bloch states
5987 : : !----------------------------------------------------------
5988 : : ! [Eqn. 24 of PRB 76, 165108 (2007)]
5989 : : ! g~(k,q) = U(k+q)^\dagger * g(k,q) * U(k)
5990 : :
5991 : : ! gqk%nb = wan%bmax - wan%bmin + 1
5992 : : ! (my_npert, nb, my_nq, nb, my_nk)
5993 : : ! ( p, b1_kq, q, b2_k, k) --> <k+q, b1| D_{q,p}H |k, b2>
5994 : :
5995 : : ! Extract e-ph matrix elements from my_g buffer to align bands with the U matrices at k and k+q.
5996 : : jj = 0
5997 [ # # ]: 0 : do ib_k=1,nb_k
5998 [ # # ]: 0 : band_k = ib_k - wan%bmin + 1; if (.not. wan%lwindow(band_k, ik)) cycle
5999 : 0 : jj = jj + 1; ii = 0
6000 [ # # ]: 0 : do ib_kq=1,nb_kq
6001 [ # # ]: 0 : band_kq = ib_kq - wan%bmin + 1; if (.not. wan%lwindow(band_kq, ikq)) cycle
6002 : 0 : ii = ii + 1
6003 : 0 : g_bb(ii, jj) = gqk%my_g(my_ip, ib_kq, my_iq, ib_k, my_ik)
6004 : : end do
6005 : : end do
6006 : :
6007 : : ! TODO: Remove LR part.
6008 : : !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)
6009 : :
6010 : : ! the two zgemm calls perform: epmats = [ cu(ikq)^\dagger * epmatk ] * cu(ikk)
6011 : : ! [here we have a size-reduction from nbnd*nbnd to nwan*nwan]
6012 : : ! output stored in gww_pk(:,:, my_ip, my_ik)
6013 : :
6014 : : ! gww_pk(:,:, my_ip, my_ik) = MATMUL(CONJG(TRANSPOSE(u_kq)), MATMUL(g_bb, u_k))
6015 : : ! tmp_mat (nwin_kq x nwan) = g_bb (nwin_kq x nwin_k) . u_k (nwin_k x nwan)
6016 : 0 : call ZGEMM('N', 'N', nwin_kq, nwan, nwin_k, cone, g_bb, nwin_kq, u_k, nwin_k, czero, tmp_mat, nwin_kq)
6017 : : ! gww_pk (nwan x nwan) = u_kq^dagger (nwan x nwin_kq) . tmp_mat (nwin_kq x nwan)
6018 : 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)
6019 : :
6020 : : !call ZGEMM('C', 'N', nwan, nbnd, nbnd, cone, u_kq, nbnd, epmatk(:, :, ik, imode), nbnd, czero, eptmp, nwan)
6021 : : !call ZGEMM('N', 'N', nwan, nwan, nbnd, cone, eptmp, nwan, u_k, nbnd, czero, epmats(:, :, ik, imode), nwan)
6022 : : end do ! my_ip
6023 : :
6024 : : ! Cache gww_pk(:,:,:,my_ik) for the on-mesh closure self-check below, while it is still
6025 : : ! valid for THIS my_iq (it gets overwritten by the next my_iq iteration).
6026 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
6027 : 0 : iq_glob = my_iq + gqk%my_qstart - 1
6028 [ # # ]: 0 : do itest=1,wan_ntest
6029 [ # # # # ]: 0 : if (test_ik(itest) == ik_glob .and. test_iq(itest) == iq_glob) then
6030 [ # # # # : 0 : test_gref(:,:,:,itest) = gww_pk(:,:,:,my_ik)
# # ]
6031 : 0 : test_found(itest) = .True.
6032 : : end if
6033 : : end do
6034 : :
6035 [ # # ]: 0 : ABI_FREE(g_bb)
6036 [ # # ]: 0 : ABI_FREE(tmp_mat)
6037 : :
6038 : : !----------------------------------------------------------------------
6039 : : ! STEP 3: Fourier transform to obtain matrix elements in electron wannier basis
6040 : : !----------------------------------------------------------------------
6041 : : ! [Eqn. 24 of PRB 76, 165108 (2007)]
6042 : : ! g(R_e,q) = (1/nkc) sum_k e^{-ikR_e} g~(k,q)
6043 : : ! g(R_e,q) is epmatw (nwan,nwan,ir)
6044 : :
6045 [ # # ]: 0 : do ir=1,nr_e
6046 [ # # ]: 0 : emikr(ir) = exp(-j_dpc * two_pi * dot_product(kpt, wan%r_e(:, ir))) / dble(gstore%nkbz)
6047 : : end do
6048 : : ! gww_pk(nwan, nwan, my_npert,my_nk)
6049 [ # # ]: 0 : do my_ip=1,gqk%my_npert
6050 [ # # ]: 0 : do ir=1,nr_e
6051 [ # # # # ]: 0 : gww_epq(:,:,ir, my_ip, my_iq) = gww_epq(:,:,ir, my_ip, my_iq) + emikr(ir) * gww_pk(:,:,my_ip, my_ik)
6052 : : end do
6053 : : end do
6054 : :
6055 [ # # ]: 0 : ABI_FREE(u_k)
6056 [ # # ]: 0 : ABI_FREE(u_kq)
6057 : : end do ! my_ik
6058 : : end do ! my_iq
6059 : :
6060 : 0 : call xmpi_sum(gww_epq, gqk%kpt_comm%value, ierr)
6061 : :
6062 : : !------------------------------------------
6063 : : ! Fourier transform to go to Wannier basis
6064 : : !------------------------------------------
6065 : : ! [Eqn. 24 of PRB 76, 165108 (2007)]
6066 : : ! g(R_e,R_p) = (1/nq) sum_q e^{-iqR_p} g(R_e,q)
6067 : :
6068 : : ! Loop over my q-points (partial sum over q).
6069 [ # # ]: 0 : do my_iq=1,my_nq
6070 : 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qpt)
6071 [ # # ]: 0 : do irp=1,nr_p
6072 [ # # ]: 0 : emiqr(irp) = exp(-j_dpc * two_pi * dot_product(qpt, wan%r_p(:, irp))) / dble(gstore%nqbz)
6073 : : end do
6074 : :
6075 [ # # ]: 0 : do my_ip=1,my_npert
6076 [ # # ]: 0 : do jwan=1,nwan
6077 [ # # ]: 0 : do iwan=1,nwan
6078 [ # # ]: 0 : do ir=1,nr_e
6079 : : ! 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}
6080 : : wan%grpe_wwp(:, ir, iwan, jwan, my_ip) = wan%grpe_wwp(:, ir, iwan, jwan, my_ip) + &
6081 [ # # ]: 0 : gww_epq(iwan, jwan, ir, my_ip, my_iq) * emiqr(:)
6082 : : end do
6083 : : end do
6084 : : end do
6085 : : end do ! my_ip
6086 : : end do ! my_iq
6087 : :
6088 : 0 : call xmpi_sum(wan%grpe_wwp, gqk%qpt_kpt_comm%value, ierr)
6089 : :
6090 [ # # ]: 0 : if (gqk%comm%me == master) then
6091 : 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] '
6092 [ # # ]: 0 : do ir=1,nr_e
6093 [ # # # # : 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,:,:,:))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
6094 : : end do
6095 : : end if
6096 : :
6097 : : !--------------------------------------------------------------------------------
6098 : : ! Wannier on-mesh closure self-check: interpolating g(k,q) back at a handful of
6099 : : ! the SAME coarse (k,q) points used to build wan%grpe_wwp must reproduce the pre-FT
6100 : : ! gww_pk cached above, once rotated by the SAME wan%interp_ham-derived u_k/u_kq
6101 : : ! (interp_ham's gauge is generically different from the ABIWAN gauge used for gww_pk,
6102 : : ! even on-mesh, so we apply the identical rotation to both sides rather than comparing
6103 : : ! against raw gww_pk). This isolates the WS/ndegen bookkeeping and forward/backward FT
6104 : : ! consistency. Cheap (wan_ntest points only) and deterministic: a hard ABI_CHECK, not a
6105 : : ! Refs-compared print, since it is a precision-only mathematical identity.
6106 : : !--------------------------------------------------------------------------------
6107 [ # # # # : 0 : ABI_MALLOC(u_k_test, (nwan,nwan))
# # # # #
# # # # #
# # ]
6108 [ # # # # : 0 : ABI_MALLOC(u_kq_test, (nwan,nwan))
# # # # #
# # # ]
6109 [ # # # # : 0 : ABI_MALLOC(eigens_k_test, (nwan))
# # # # #
# # # ]
6110 [ # # # # : 0 : ABI_MALLOC(eigens_kq_test, (nwan))
# # # # ]
6111 [ # # # # : 0 : ABI_MALLOC(eigens_k_period, (nwan))
# # # # ]
6112 [ # # # # : 0 : ABI_MALLOC(eigens_kq_period, (nwan))
# # # # ]
6113 [ # # # # : 0 : ABI_MALLOC(eigens_k_plus, (nwan))
# # # # ]
6114 [ # # # # : 0 : ABI_MALLOC(eigens_k_minus, (nwan))
# # # # ]
6115 [ # # # # : 0 : ABI_MALLOC(vcart_test, (3,nwan))
# # # # #
# # # ]
6116 [ # # # # : 0 : ABI_MALLOC(cmat_test, (nwan,nwan))
# # # # #
# # # ]
6117 [ # # # # : 0 : ABI_MALLOC(g_expected, (nwan,nwan))
# # # # #
# # # ]
6118 [ # # # # : 0 : ABI_MALLOC(g_atm_test, (nwan, nwan, my_npert, 1))
# # # # #
# # # # #
# # # # #
# ]
6119 [ # # # # : 0 : ABI_MALLOC(g_atm_period, (nwan, nwan, my_npert, 1))
# # # # #
# # # # #
# # ]
6120 : :
6121 : 0 : max_err = zero; ref_scale = zero
6122 : 0 : max_period_eig_err = zero; period_eig_scale = zero
6123 : 0 : max_period_g2_err = zero; period_g2_scale = zero
6124 : 0 : max_velocity_err = zero; velocity_scale = zero; nvelocity_tested = 0
6125 [ # # ]: 0 : do itest=1,wan_ntest
6126 [ # # ]: 0 : if (.not. test_found(itest)) cycle
6127 : 0 : my_ik = test_ik(itest) - gqk%my_kstart + 1
6128 : 0 : my_iq = test_iq(itest) - gqk%my_qstart + 1
6129 [ # # ]: 0 : kpt = gqk%my_kpts(:,my_ik)
6130 : 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qpt)
6131 : 0 : call wan%interp_ham(gstore%cryst, kpt, u_k_test, eigens_k_test, vcart_test)
6132 [ # # ]: 0 : call wan%interp_ham(gstore%cryst, kpt + qpt, u_kq_test, eigens_kq_test)
6133 : 0 : call wan%interp_eph_manyq(gstore%cryst, 1, qpt, kpt, g_atm_test)
6134 [ # # # # : 0 : ref_scale = max(ref_scale, maxval(abs(test_gref(:,:,:,itest))))
# # # # #
# # # #
# ]
6135 [ # # ]: 0 : do ip_loc=1,my_npert
6136 : : ! Same order/dagger convention as wan_interp_eph_manyq (m_mlwfovlp.F90).
6137 : 0 : call ZGEMM('N', 'N', nwan, nwan, nwan, cone, u_kq_test, nwan, test_gref(:,:,ip_loc,itest), nwan, czero, cmat_test, nwan)
6138 : 0 : call ZGEMM('N', 'C', nwan, nwan, nwan, cone, cmat_test, nwan, u_k_test, nwan, czero, g_expected, nwan)
6139 [ # # # # : 0 : max_err = max(max_err, maxval(abs(g_expected - g_atm_test(:,:,ip_loc,1))))
# # # # #
# # # ]
6140 : : end do
6141 : :
6142 : : ! Validate analytic Cartesian group velocities against centered finite
6143 : : ! differences of the interpolated eigenvalues. Skip degenerate bands,
6144 : : ! whose individual diagonal velocities depend on the chosen subspace basis.
6145 : : ! These calls intentionally follow the closure comparison because the
6146 : : ! finite-difference diagonalizations reuse the u_kq_test work buffer.
6147 [ # # ]: 0 : do idir=1,3
6148 [ # # ]: 0 : dkred = WAN_VELOCITY_FD_STEP * gstore%cryst%rprimd(idir,:) / two_pi
6149 [ # # ]: 0 : call wan%interp_ham(gstore%cryst, kpt + dkred, u_kq_test, eigens_k_plus)
6150 [ # # ]: 0 : call wan%interp_ham(gstore%cryst, kpt - dkred, u_kq_test, eigens_k_minus)
6151 [ # # ]: 0 : do ib=1,nwan
6152 : 0 : band_gap = huge(one)
6153 [ # # ]: 0 : if (ib > 1) band_gap = min(band_gap, abs(eigens_k_test(ib) - eigens_k_test(ib-1)))
6154 [ # # ]: 0 : if (ib < nwan) band_gap = min(band_gap, abs(eigens_k_test(ib+1) - eigens_k_test(ib)))
6155 [ # # ]: 0 : if (band_gap < WAN_VELOCITY_DEGEN_TOL) cycle
6156 : 0 : velocity_fd = (eigens_k_plus(ib) - eigens_k_minus(ib)) / (two * WAN_VELOCITY_FD_STEP)
6157 : 0 : max_velocity_err = max(max_velocity_err, abs(vcart_test(idir,ib) - velocity_fd))
6158 : 0 : velocity_scale = max(velocity_scale, abs(vcart_test(idir,ib)), abs(velocity_fd))
6159 : 0 : nvelocity_tested = nvelocity_tested + 1
6160 : : end do
6161 : : end do
6162 : :
6163 : : ! Reciprocal-periodicity self-check. Integer shifts leave the real-space
6164 : : ! Fourier sums invariant. Compare eigenvalues and per-perturbation
6165 : : ! Frobenius norms, which remain well defined even if a tiny roundoff
6166 : : ! difference rotates eigenvectors inside a degenerate subspace.
6167 [ # # # # : 0 : period_eig_scale = max(period_eig_scale, maxval(abs(eigens_k_test)), maxval(abs(eigens_kq_test)))
# # # # #
# # # # #
# # ]
6168 [ # # ]: 0 : do ip_loc=1,my_npert
6169 [ # # # # ]: 0 : period_g2_scale = max(period_g2_scale, sum(abs(g_atm_test(:,:,ip_loc,1))**2))
6170 : : end do
6171 [ # # ]: 0 : do iperiod=1,wan_nperiod
6172 [ # # ]: 0 : call wan%interp_ham(gstore%cryst, kpt + period_gk(:,iperiod), u_k_test, eigens_k_period)
6173 : : call wan%interp_ham(gstore%cryst, kpt + qpt + period_gk(:,iperiod) + period_gq(:,iperiod), &
6174 [ # # ]: 0 : u_kq_test, eigens_kq_period)
6175 : : call wan%interp_eph_manyq(gstore%cryst, 1, qpt + period_gq(:,iperiod), &
6176 [ # # # # ]: 0 : kpt + period_gk(:,iperiod), g_atm_period)
6177 : : max_period_eig_err = max(max_period_eig_err, maxval(abs(eigens_k_period - eigens_k_test)), &
6178 [ # # # # : 0 : maxval(abs(eigens_kq_period - eigens_kq_test)))
# # # # #
# # # # #
# # ]
6179 [ # # ]: 0 : do ip_loc=1,my_npert
6180 : : max_period_g2_err = max(max_period_g2_err, abs( &
6181 [ # # # # : 0 : sum(abs(g_atm_period(:,:,ip_loc,1))**2) - sum(abs(g_atm_test(:,:,ip_loc,1))**2)))
# # # # ]
6182 : : end do
6183 : : end do
6184 : : end do
6185 : :
6186 : : ! Each fixed (k,q) pair must be owned exactly once within each perturbation
6187 : : ! slice. Reduce diagnostics over the complete spin communicator so every rank
6188 : : ! applies the same check and the printed result is MPI-decomposition invariant.
6189 [ # # # # ]: 0 : ntest_found = count(test_found)
6190 : 0 : call xmpi_sum(ntest_found, gqk%qpt_kpt_comm%value, ierr)
6191 [ # # ]: 0 : ABI_CHECK_IEQ(ntest_found, wan_ntest, "Wannier closure test did not find each fixed global (k,q) point exactly once")
6192 : 0 : call xmpi_max(max_err, gqk%comm%value, ierr)
6193 : 0 : call xmpi_max(ref_scale, gqk%comm%value, ierr)
6194 : 0 : call xmpi_max(max_period_eig_err, gqk%comm%value, ierr)
6195 : 0 : call xmpi_max(period_eig_scale, gqk%comm%value, ierr)
6196 : 0 : call xmpi_max(max_period_g2_err, gqk%comm%value, ierr)
6197 : 0 : call xmpi_max(period_g2_scale, gqk%comm%value, ierr)
6198 : 0 : call xmpi_max(max_velocity_err, gqk%comm%value, ierr)
6199 : 0 : call xmpi_max(velocity_scale, gqk%comm%value, ierr)
6200 : 0 : call xmpi_sum(nvelocity_tested, gqk%qpt_kpt_comm%value, ierr)
6201 : 0 : ref_scale = max(ref_scale, tol12)
6202 : 0 : period_eig_scale = max(period_eig_scale, tol12)
6203 : 0 : period_g2_scale = max(period_g2_scale, tol12)
6204 : 0 : velocity_scale = max(velocity_scale, one)
6205 : :
6206 [ # # ]: 0 : if (gqk%comm%me == master) then
6207 : 0 : write(std_out,'(a,es10.2,a,es10.2)') " Wannier on-mesh closure self-check: max_err=", max_err, " ref_scale=", ref_scale
6208 : 0 : write(std_out,'(a,es10.2,a,es10.2)') " Wannier reciprocal-periodicity self-check: max_eig_err=", &
6209 : 0 : max_period_eig_err, " max_g2_err=", max_period_g2_err
6210 : 0 : write(std_out,'(a,i0,a,es10.2)') " Wannier group-velocity self-check: nvalues=", &
6211 : 0 : nvelocity_tested, " max_err=", max_velocity_err
6212 : : end if
6213 : :
6214 [ # # ]: 0 : ABI_CHECK(max_err < WAN_CLOSURE_TOL * ref_scale, "Wannier on-mesh closure self-check failed")
6215 : 0 : msg = "Wannier reciprocal-periodicity self-check failed for interpolated electronic eigenvalues."
6216 [ # # ]: 0 : ABI_CHECK(max_period_eig_err < WAN_CLOSURE_TOL * period_eig_scale, msg)
6217 : 0 : msg = "Wannier reciprocal-periodicity self-check failed for gauge-invariant e-ph Frobenius norms."
6218 [ # # ]: 0 : ABI_CHECK(max_period_g2_err < WAN_CLOSURE_TOL * period_g2_scale, msg)
6219 [ # # ]: 0 : ABI_CHECK(nvelocity_tested > 0, "Wannier group-velocity self-check did not find a nondegenerate band")
6220 : 0 : msg = "Analytic Wannier group velocities do not agree with finite differences of the interpolated eigenvalues."
6221 [ # # ]: 0 : ABI_CHECK(max_velocity_err < WAN_VELOCITY_TOL * velocity_scale, msg)
6222 : :
6223 [ # # ]: 0 : ABI_FREE(u_k_test)
6224 [ # # ]: 0 : ABI_FREE(u_kq_test)
6225 [ # # ]: 0 : ABI_FREE(eigens_k_test)
6226 [ # # ]: 0 : ABI_FREE(eigens_kq_test)
6227 [ # # ]: 0 : ABI_FREE(eigens_k_period)
6228 [ # # ]: 0 : ABI_FREE(eigens_kq_period)
6229 [ # # ]: 0 : ABI_FREE(eigens_k_plus)
6230 [ # # ]: 0 : ABI_FREE(eigens_k_minus)
6231 [ # # ]: 0 : ABI_FREE(vcart_test)
6232 [ # # ]: 0 : ABI_FREE(cmat_test)
6233 [ # # ]: 0 : ABI_FREE(g_expected)
6234 [ # # ]: 0 : ABI_FREE(g_atm_test)
6235 [ # # ]: 0 : ABI_FREE(g_atm_period)
6236 [ # # ]: 0 : ABI_FREE(test_gref)
6237 : :
6238 : : ! Free memory for this spin.
6239 [ # # ]: 0 : ABI_FREE(emikr)
6240 [ # # ]: 0 : ABI_FREE(emiqr)
6241 [ # # ]: 0 : ABI_FREE(gww_pk)
6242 [ # # ]: 0 : ABI_FREE(gww_epq)
6243 : : end do ! my_is
6244 : :
6245 : : ! =====================
6246 : : ! Write data to GWAN.nc
6247 : : ! =====================
6248 [ # # ]: 0 : do spin=1,gstore%nsppol
6249 : 0 : my_is = gstore%spin2my_is(spin)
6250 [ # # ]: 0 : if (my_is /= 0) then
6251 : 0 : gqk => gstore%gqk(my_is)
6252 : : ! grpe_wwp has already been reduced over qpt_kpt_comm and is replicated
6253 : : ! across the q/k (and auxiliary sum/band) grid. Exactly one such slice
6254 : : ! must enter the writer; all ranks along its perturbation axis participate
6255 : : ! collectively because grpe_wwp remains distributed over perturbations.
6256 [ # # # # : 0 : if (all(gqk%coords_qkpb_sumbp([1,2,4,5,6]) == 0)) then
# # ]
6257 : 0 : call gqk%wan%ncwrite_gwan(dtfil, gstore%cryst, gstore%ebands, gqk%pert_comm)
6258 : : end if
6259 : : end if
6260 : 0 : call xmpi_barrier(gstore%comm)
6261 : : end do ! spin
6262 : :
6263 : 0 : call cwtime_report(" gstore_wannierize_and_write_gwan:", cpu, wall, gflops)
6264 : :
6265 [ # # ]: 0 : end subroutine gstore_wannierize_and_write_gwan
6266 : : !!***
6267 : :
6268 : : !!****f* m_gstore/handle_lr_term
6269 : : !! NAME
6270 : : !! handle_lr_term
6271 : : !!
6272 : : !! FUNCTION
6273 : : !! Add/Remove the long range term to/from the e-ph matrix elements.
6274 : : !!
6275 : : !! INPUTS
6276 : : !!
6277 : : !! SOURCE
6278 : :
6279 : : !subroutine handle_lr_term(cryst, qpt, ng, gvec, nwin_kq, nwin_k, nwan, u_kq, u_k, zeff, qstar, isgn, g_bb)
6280 : : !
6281 : : !!Arguments ------------------------------------
6282 : : ! type(crystal_t),intent(in) :: cryst
6283 : : ! real(dp),intent(in) :: qpt(3)
6284 : : ! integer,intent(in) :: ng, nwin_kq, nwin_k, nwan, isgn, gvec(3,ng)
6285 : : ! complex(dp),intent(in) :: u_kq(nwin_kq, nwan), u_k(nwin_k,nwan)
6286 : : ! real(dp),intent(in) :: zeff(3,3,cryst%natom), qstar(3,3,3,cryst%natom)
6287 : : ! complex(dp),intent(inout) :: g_bb(nwin_kq, nwin_k)
6288 : : !
6289 : : !!Local variables-------------------------------
6290 : : !!scalars
6291 : : ! !integer :: ig
6292 : : ! !character(len=500) :: msg
6293 : : !!arrays
6294 : : !! *************************************************************************
6295 : : !
6296 : : !end subroutine handle_lr_term
6297 : : !!***
6298 : :
6299 : : !----------------------------------------------------------------------
6300 : :
6301 : : !!****f* m_gstore/gqk_get_erange_mask
6302 : : !! NAME
6303 : : !! gqk_get_erange_mask
6304 : : !!
6305 : : !! FUNCTION
6306 : : !! Compute MPI-distributed and global masks for electronic states |n,k> allowed by erange.
6307 : : !!
6308 : : !! INPUTS
6309 : : !! gstore<gstore_t>=Electron-phonon object containing dimensions and related quantities.
6310 : : !! erange=Energy range:
6311 : : !! -- if both entries are negative, assume metal and include states within the
6312 : : !! [efermi-abs(erange(1)), efermi+abs(erange(2))] window;
6313 : : !! -- otherwise, erange(1) & erange(2) select window wrt VBM & CBM, respectively.
6314 : : !!
6315 : : !! OUTPUT
6316 : : !! my_states(gqk%nb_k, gqk%my_nk)=Mask for selected states at this MPI proc.
6317 : : !! glob_states(gqk%nb_k, gqk%my_nk)=Global mask for selected states.
6318 : : !!
6319 : : !! SOURCE
6320 : :
6321 : 0 : subroutine gqk_get_erange_mask(gqk, gstore, erange, my_states, glob_states)
6322 : :
6323 : : !Arguments ------------------------------------
6324 : : !scalars
6325 : : class(gqk_t), target, intent(inout) :: gqk
6326 : : class(gstore_t), target, intent(in) :: gstore
6327 : : !arrays
6328 : : real(dp), intent(in) :: erange(2)
6329 : : integer, intent(out) :: my_states(gqk%nb_k, gqk%my_nk), glob_states(gqk%nb_k, gqk%glob_nk)
6330 : :
6331 : : !Local variables-------------------------------
6332 : : !scalars
6333 : : class(ebands_t), pointer :: ebands
6334 : : type(gaps_t) :: gaps
6335 : : integer :: my_ik, ik_ibz, ik_glob, ib_k, bstart_k, gap_err, ierr
6336 : : real(dp) :: vmax, cmin, eig
6337 : : logical :: assume_gap
6338 : : !----------------------------------------------------------------------
6339 : :
6340 : 0 : ebands => gstore%ebands
6341 : :
6342 [ # # # # ]: 0 : assume_gap = .not. all(erange < tol12)
6343 : 0 : gaps = ebands%get_gaps(gap_err)
6344 : :
6345 [ # # ]: 0 : if (assume_gap) then
6346 [ # # ]: 0 : call gaps%print([std_out])
6347 : 0 : vmax = gaps%vb_max(gqk%spin) + tol2 * eV_Ha
6348 : 0 : cmin = gaps%cb_min(gqk%spin) - tol2 * eV_Ha
6349 : : else
6350 : 0 : vmax = ebands%fermie
6351 : 0 : cmin = ebands%fermie
6352 : : end if
6353 : :
6354 : : ! Fill the mask for allowed states
6355 [ # # # # ]: 0 : my_states(:,:) = 0
6356 [ # # # # ]: 0 : glob_states(:,:) = 0
6357 : 0 : bstart_k = gstore%brange_k_spin(1, gqk%spin)
6358 : :
6359 [ # # ]: 0 : do my_ik=1,gqk%my_nk
6360 : 0 : ik_ibz = gqk%my_k2ibz(1, my_ik)
6361 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
6362 : :
6363 [ # # ]: 0 : do ib_k=1,gqk%nb_k
6364 : 0 : eig = ebands%eig(bstart_k + ib_k - 1, ik_ibz, gqk%spin)
6365 : :
6366 [ # # ]: 0 : if (abs(erange(1)) > tol12) then
6367 : : ! Filter valence states.
6368 [ # # # # ]: 0 : if (eig <= vmax .and. vmax - eig <= abs(erange(1))) then
6369 : 0 : my_states(ib_k, my_ik) = 1; glob_states(ib_k, ik_glob) = 1
6370 : : end if
6371 : : end if
6372 : :
6373 [ # # ]: 0 : if (abs(erange(2)) > tol12) then
6374 : : ! Filter conduction states.
6375 [ # # # # ]: 0 : if (eig >= cmin .and. eig - cmin <= abs(erange(2))) then
6376 : 0 : my_states(ib_k, my_ik) = 1; glob_states(ib_k, ik_glob) = 1
6377 : : end if
6378 : : end if
6379 : :
6380 : : enddo
6381 : : enddo
6382 : :
6383 : 0 : call xmpi_sum(glob_states, gqk%kpt_comm%value, ierr)
6384 : 0 : call gaps%free()
6385 : :
6386 [ # # # # : 0 : end subroutine gqk_get_erange_mask
# # # # #
# # # # #
# # ]
6387 : : !!***
6388 : :
6389 : : !----------------------------------------------------------------------
6390 : :
6391 : : !!****f* m_gstore/gqk_filter_erange
6392 : : !! NAME
6393 : : !! gqk_filter_erange
6394 : : !!
6395 : : !! FUNCTION
6396 : : !! Nullify all matrix elements connecting electronic states excluded by energy range.
6397 : : !!
6398 : : !! INPUTS
6399 : : !! gstore<gstore_t>=Electron-phonon object containing dimensions and related quantities.
6400 : : !! erange=Energy range:
6401 : : !! -- if both entries are negative, assume metal and include states within the
6402 : : !! [efermi-abs(erange(1)), efermi+abs(erange(2))] window;
6403 : : !! -- otherwise, erange(1) & erange(2) select window wrt VBM & CBM, respectively.
6404 : : !!
6405 : : !! OUTPUT
6406 : : !!
6407 : : !! SOURCE
6408 : :
6409 : 0 : subroutine gqk_filter_erange(gqk, gstore, erange)
6410 : :
6411 : : !Arguments ------------------------------------
6412 : : !scalars
6413 : : class(gqk_t), target, intent(inout) :: gqk
6414 : : class(gstore_t), target, intent(in) :: gstore
6415 : : !arrays
6416 : : real(dp), intent(in) :: erange(2)
6417 : :
6418 : : !Local variables-------------------------------
6419 : : !scalars
6420 : : integer :: my_ik, ik_glob, my_iq, ikq, ipert, ierr, ib_k, jb_kq
6421 : : real(dp) :: wtq
6422 : : logical :: skip_nk, skip_mkq, skip_q
6423 : 0 : type(krank_t) :: krank_kpts
6424 : : type(ebands_t), pointer :: ebands
6425 : : !arrays
6426 : 0 : integer :: my_states(gqk%nb_k, gqk%my_nk), glob_states(gqk%nb_k, gqk%glob_nk)
6427 : 0 : real(dp) :: kpt(3), qpt(3), kpq(3), kpts(3, gqk%glob_nk), my_qpts(3, gqk%my_nq)
6428 : : !----------------------------------------------------------------------
6429 : :
6430 [ # # ]: 0 : ABI_CHECK_IEQ(gqk%nb_kq, gqk%nb_k, "nb_kq /= nk_k not tested")
6431 : :
6432 : 0 : ebands => gstore%ebands
6433 : :
6434 : : ! Compute masks
6435 : 0 : call gqk%get_erange_mask(gstore, erange, my_states, glob_states)
6436 : :
6437 : : ! Get global krank for k+q transitions
6438 [ # # # # ]: 0 : kpts(:, :) = zero
6439 [ # # ]: 0 : do my_ik=1,gqk%my_nk
6440 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
6441 [ # # ]: 0 : kpts(:, ik_glob) = gqk%my_kpts(:, my_ik)
6442 : : enddo
6443 : 0 : call xmpi_sum(kpts, gqk%kpt_comm%value, ierr)
6444 : :
6445 : 0 : call krank_kpts%from_kptrlatt(gqk%glob_nk, kpts, ebands%kptrlatt, compute_invrank=.True.)
6446 : :
6447 : : ! Get all q-points for this proc
6448 [ # # ]: 0 : do my_iq=1,gqk%my_nq
6449 : 0 : call gqk%myqpt(my_iq, gstore, wtq, my_qpts(:, my_iq))
6450 : : enddo
6451 : :
6452 : : ! Nullify matrix elements connecting the excluded states
6453 [ # # ]: 0 : do my_ik=1,gqk%my_nk
6454 [ # # ]: 0 : kpt(:) = gqk%my_kpts(:, my_ik)
6455 : :
6456 [ # # ]: 0 : do ib_k=1,gqk%nb_k
6457 : : ! |nk> is forbidden
6458 : 0 : skip_nk = .false.
6459 [ # # ]: 0 : if (my_states(ib_k, my_ik) == 0) skip_nk = .true.
6460 : :
6461 [ # # ]: 0 : do my_iq=1,gqk%my_nq
6462 [ # # ]: 0 : qpt(:) = my_qpts(:, my_iq)
6463 : :
6464 : : ! Find k+q --> k' index in krank_kpts
6465 [ # # ]: 0 : kpq(:) = kpt(:) + qpt(:)
6466 : 0 : ikq = krank_kpts%get_index(kpq)
6467 : :
6468 : : ! k+q falls outside the filtered kpts pool
6469 : 0 : skip_q = .false.
6470 [ # # ]: 0 : if (ikq == -1) skip_q = .true.
6471 : :
6472 [ # # ]: 0 : do jb_kq=1,gqk%nb_kq
6473 : : ! |mk+q> is forbidden
6474 : 0 : skip_mkq = .false.
6475 [ # # ]: 0 : if (glob_states(jb_kq, ikq) == 0) skip_mkq = .true.
6476 : :
6477 [ # # ]: 0 : do ipert=1,gqk%my_npert
6478 : :
6479 [ # # # # ]: 0 : if (skip_nk .or. skip_q .or. skip_mkq) then
6480 : 0 : select case (gqk%cplex)
6481 : : case (1)
6482 : 0 : gqk%my_g2(ipert, jb_kq, my_iq, ib_k, my_ik) = zero
6483 : : case (2)
6484 : 0 : gqk%my_g(ipert, jb_kq, my_iq, ib_k, my_ik) = czero
6485 : : case default
6486 [ # # # ]: 0 : ABI_ERROR(sjoin("Invalid gqk%cplex:", itoa(gqk%cplex)))
6487 : : end select
6488 : : end if
6489 : :
6490 : : enddo
6491 : : enddo
6492 : : enddo
6493 : : enddo
6494 : : enddo
6495 : :
6496 : 0 : call krank_kpts%free()
6497 : :
6498 [ # # # # : 0 : end subroutine gqk_filter_erange
# # ]
6499 : : !!***
6500 : :
6501 : : !----------------------------------------------------------------------
6502 : :
6503 : : !!****f* m_gstore/gstore_compute_and_write_ph
6504 : : !! NAME
6505 : : !! gstore_compute_and_write_ph
6506 : : !!
6507 : : !! FUNCTION
6508 : : !! Compute phonon frequencies and eigenvectors in the IBZ. Write results to disk
6509 : : !!
6510 : : !! SOURCE
6511 : :
6512 : 8 : subroutine gstore_compute_and_write_ph(gstore, root_ncid)
6513 : :
6514 : : !Arguments ------------------------------------
6515 : : !scalars
6516 : : class(gstore_t), intent(in) :: gstore
6517 : : integer,intent(in) :: root_ncid
6518 : :
6519 : : !Local variables-------------------------------
6520 : : !scalars
6521 : : integer :: natom, natom3, nproc, ii, iq_ibz, my_nqibz, iq_start, ncerr
6522 : : real(dp) :: cpu, wall, gflops
6523 : : !arrays
6524 : 8 : integer,allocatable :: my_iqibz_inds(:)
6525 : 8 : real(dp),allocatable :: buf_wqnu(:,:), buf_eigvec_cart(:,:,:,:,:), displ_cart_qibz(:,:,:,:)
6526 : : !----------------------------------------------------------------------
6527 : :
6528 : 8 : nproc = xmpi_comm_size(gstore%comm)
6529 : 8 : natom = gstore%cryst%natom; natom3 = 3 * natom
6530 : :
6531 : 8 : call wrtout(std_out, " Computing phonon frequencies and displacements in the IBZ ...", pre_newlines=1, do_flush=.True.)
6532 : 8 : call cwtime(cpu, wall, gflops, "start")
6533 : :
6534 : 8 : call xmpi_split_block(gstore%nqibz, gstore%comm, my_nqibz, my_iqibz_inds)
6535 [ - + + - : 32 : ABI_MALLOC(buf_wqnu, (natom3, my_nqibz))
- + + - +
- + - - +
- + ]
6536 [ - + + - : 40 : ABI_MALLOC(buf_eigvec_cart, (2, 3, natom, natom3, my_nqibz))
- + + - -
+ + - + -
+ - - + -
+ ]
6537 [ - + + - : 32 : ABI_MALLOC(displ_cart_qibz, (2, 3, natom, natom3))
- + + - +
- + - - +
- + ]
6538 : :
6539 [ - + ]: 8 : NCF_CHECK(nctk_prepare_mpiio(root_ncid, "phfreqs_ibz"))
6540 [ - + ]: 8 : NCF_CHECK(nctk_prepare_mpiio(root_ncid, "pheigvec_cart_ibz"))
6541 : :
6542 [ + + ]: 141 : do ii=1,my_nqibz
6543 : 133 : iq_ibz = my_iqibz_inds(ii)
6544 : : call gstore%ifc%fourq(gstore%cryst, gstore%qibz(:, iq_ibz), buf_wqnu(:,ii), displ_cart_qibz, &
6545 : 141 : out_eigvec=buf_eigvec_cart(:,:,:,:,ii))
6546 : : end do
6547 : :
6548 [ - + - - ]: 8 : if (nproc > 1 .and. gstore%nqibz >= nproc) then
6549 [ # # ]: 0 : NCF_CHECK(nctk_set_collective(root_ncid, root_vid("phfreqs_ibz")))
6550 [ # # ]: 0 : NCF_CHECK(nctk_set_collective(root_ncid, root_vid("pheigvec_cart_ibz")))
6551 : : end if
6552 : 8 : call xmpi_barrier(gstore%comm)
6553 : :
6554 [ + - ]: 8 : if (my_nqibz > 0) then
6555 : 8 : iq_start = my_iqibz_inds(1)
6556 : : ncerr = nf90_put_var(root_ncid, root_vid("phfreqs_ibz"), buf_wqnu, &
6557 [ + + + + ]: 40 : start=[1, iq_start], count=[natom3, my_nqibz])
6558 [ - + ]: 8 : NCF_CHECK(ncerr)
6559 : : ncerr = nf90_put_var(root_ncid, root_vid("pheigvec_cart_ibz"), buf_eigvec_cart, &
6560 [ + + + + ]: 88 : start=[1,1,1,1,iq_start], count=[2, 3, natom, natom3, my_nqibz])
6561 [ - + ]: 8 : NCF_CHECK(ncerr)
6562 : : end if
6563 : :
6564 [ - + ]: 8 : ABI_FREE(displ_cart_qibz)
6565 [ - + ]: 8 : ABI_FREE(my_iqibz_inds)
6566 [ - + ]: 8 : ABI_FREE(buf_wqnu)
6567 [ - + ]: 8 : ABI_FREE(buf_eigvec_cart)
6568 : 16 : call cwtime_report(" Phonon computation + output", cpu, wall, gflops)
6569 : :
6570 : : contains
6571 : :
6572 : 16 : integer function root_vid(var_name)
6573 : : character(len=*),intent(in) :: var_name
6574 : 16 : root_vid = nctk_idname(root_ncid, var_name)
6575 : : end function root_vid
6576 : :
6577 : : end subroutine gstore_compute_and_write_ph
6578 : : !!***
6579 : :
6580 : : !!****f* m_gstore/gstore_compute_and_write_vk
6581 : : !! NAME
6582 : : !! gstore_compute_and_write_vk
6583 : : !!
6584 : : !! FUNCTION
6585 : : !! Compute electronic group velocities in the IBZ.
6586 : : !! Write results to disk
6587 : : !!
6588 : : !! SOURCE
6589 : :
6590 : 8 : subroutine gstore_compute_and_write_vk(gstore, mpw, wfd, ebands, psps, pawtab, root_ncid)
6591 : :
6592 : : !Arguments ------------------------------------
6593 : : class(gstore_t), intent(in) :: gstore
6594 : : integer,intent(in) :: mpw
6595 : : type(wfd_t),intent(in) :: wfd
6596 : : type(ebands_t),target,intent(in) :: ebands
6597 : : type(pseudopotential_type),intent(in) :: psps
6598 : : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
6599 : : integer,intent(in) :: root_ncid
6600 : :
6601 : : !Local variables-------------------------------
6602 : : !scalars
6603 : : 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
6604 : : real(dp) :: cpu_kk, wall_kk, gflops_kk, eig0nk
6605 : : logical :: isirr_k
6606 [ + + + + : 80 : type(ddkop_t) :: ddkop
+ + ]
6607 : : !arrays
6608 : : integer :: g0_k(3)
6609 : 8 : integer,allocatable :: count_bk(:,:)
6610 : : real(dp) :: kk(3) !, kk_ibz(3)
6611 : 16 : real(dp),allocatable :: vnk_cart_ibz(:,:,:), cg_work(:,:)
6612 : 8 : type(pawcprj_type),allocatable :: cwaveprj0(:,:)
6613 : : !----------------------------------------------------------------------
6614 : :
6615 : 8 : call wrtout(std_out, " computing and writing velocity operator matrix elements in the ibz")
6616 : 8 : call wrtout(std_out, " note that not all the k-points in the ibz are computed when kfilter is activated!")
6617 : 8 : call cwtime(cpu_kk, wall_kk, gflops_kk, "start")
6618 : :
6619 : : ! On disk, we have:
6620 : : ! nctkarr_t("vk_cart_ibz", "dp", "three, nb_k, gstore_nkibz"))
6621 : : ! nctkarr_t("vkmat_cart_ibz", "dp", "two, three, nb, nb, gstore_nkibz")))
6622 : :
6623 : 8 : call ddkop%init(gstore%dtset, gstore%cryst, pawtab, psps, wfd%mpi_enreg, mpw, wfd%ngfft)
6624 [ - + + - : 24 : ABI_MALLOC(cg_work, (2, mpw*wfd%nspinor))
+ - + - -
+ - + ]
6625 : :
6626 : 8 : usecprj = gstore%dtset%usepaw
6627 [ - + + - : 32 : ABI_MALLOC(cwaveprj0, (gstore%cryst%natom, wfd%nspinor*usecprj))
+ - - - +
- - + - +
- + - + -
- ]
6628 : :
6629 [ + + ]: 16 : do my_is=1,gstore%my_nspins
6630 : 8 : associate (gqk => gstore%gqk(my_is))
6631 : 8 : spin = gstore%my_spins(my_is); nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
6632 : :
6633 : : ! Be careful as wavefunctions might be replicated.
6634 : : ! Use count_bk to count how many states have been computed in parallel in order to rescale the results.
6635 : 8 : if (gstore%with_vk == 1) then
6636 [ - + + - : 1285 : ABI_CALLOC(vnk_cart_ibz, (3, nb_k, gstore%nkibz))
- + + - +
- + - - +
- + - + +
+ + + +
+ ]
6637 [ - + + - : 445 : ABI_ICALLOC(count_bk, (nb_k, gstore%nkibz))
- + + - +
- + - - +
- + - + +
+ + + ]
6638 : : else
6639 : 0 : ABI_ERROR("gstore%with_vk 2 not implemented")
6640 : : end if
6641 : :
6642 [ - + ]: 8 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6643 [ - + ]: 8 : NCF_CHECK(nctk_prepare_mpiio(spin_ncid, "vk_cart_ibz"))
6644 : :
6645 [ + + ]: 319 : do my_ik=1,gqk%my_nk
6646 : : ! The k-point and the symmetries relating the BZ k-point to the IBZ.
6647 [ + + ]: 1244 : kk = gqk%my_kpts(:, my_ik)
6648 : 311 : ik_ibz = gqk%my_k2ibz(1, my_ik) ; isym_k = gqk%my_k2ibz(2, my_ik)
6649 [ + + ]: 1244 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5,my_ik)
6650 [ + + + + : 1149 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
+ + + - ]
6651 : : if (.not. isirr_k) cycle
6652 : :
6653 : : ! parallelize inside (q, pert) so that only one proc in the 3D grid
6654 : : ! computes v_nk for this kpt in the BZ and we can use xmpi_sum_master.
6655 : : !cnt = cnt + 1
6656 : : !if (gqk%qpt_pert_comm%skip(cnt)) cycle
6657 : :
6658 : 36 : npw_k = wfd%npwarr(ik_ibz); istwf_k = wfd%istwfk(ik_ibz)
6659 : 36 : call ddkop%setup_spin_kpoint(gstore%dtset, gstore%cryst, psps, spin, kk, istwf_k, npw_k, wfd%kdata(ik_ibz)%kg_k)
6660 : :
6661 [ + + ]: 150 : do band=gqk%bstart_k, gqk%bstop_k
6662 : 106 : call wfd%copy_cg(band, ik_ibz, spin, cg_work)
6663 : 106 : eig0nk = ebands%eig(band, ik_ibz, spin)
6664 : 106 : in_k = band - gqk%bstart_k + 1
6665 : 106 : vnk_cart_ibz(:, in_k, ik_ibz) = ddkop%get_vdiag(eig0nk, istwf_k, npw_k, wfd%nspinor, cg_work, cwaveprj0)
6666 : 142 : count_bk(in_k, ik_ibz) = count_bk(in_k, ik_ibz) + 1
6667 : : end do
6668 : : end do ! my_ik
6669 : :
6670 : 8 : call xmpi_sum(count_bk, gqk%comm%value, ierr)
6671 : 8 : call xmpi_sum(vnk_cart_ibz, gqk%comm%value, ierr)
6672 : :
6673 [ + + ]: 141 : do ik_ibz=1, gstore%nkibz
6674 [ + + ]: 421 : do band=gqk%bstart_k, gqk%bstop_k
6675 : 280 : in_k = band - gqk%bstart_k + 1
6676 [ + + ]: 280 : if (count_bk(in_k, ik_ibz) == 0) cycle
6677 [ + + ]: 557 : do ii=1,3
6678 : 598 : vnk_cart_ibz(ii,in_k,ik_ibz) = vnk_cart_ibz(ii,in_k,ik_ibz) / count_bk(in_k, ik_ibz)
6679 : : end do
6680 : : end do
6681 : : end do
6682 : :
6683 : : ! Write v_nk to disk.
6684 : : !if (gqk%comm%me == master) then
6685 [ - + ]: 8 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("vk_cart_ibz"), vnk_cart_ibz))
6686 : : !end if
6687 : :
6688 [ - + ]: 8 : ABI_FREE(vnk_cart_ibz)
6689 [ + - - + ]: 16 : ABI_FREE(count_bk)
6690 : : end associate
6691 : : end do ! my_is
6692 : :
6693 [ - + ]: 8 : ABI_FREE(cg_work)
6694 : 8 : call ddkop%free()
6695 : :
6696 : 8 : call pawcprj_free(cwaveprj0)
6697 [ + - - + : 8 : ABI_FREE(cwaveprj0)
- - - - -
+ ]
6698 : :
6699 [ - + + + : 96 : call cwtime_report(sjoin(" Computation of v_k group velocities with with_vk:", itoa(gstore%with_vk)), cpu_kk, wall_kk, gflops_kk)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + + +
- + - + +
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + ]
6700 : :
6701 : : contains
6702 : :
6703 : 8 : integer function spin_vid(var_name)
6704 : : character(len=*),intent(in) :: var_name
6705 : 8 : spin_vid = nctk_idname(spin_ncid, var_name)
6706 : : end function spin_vid
6707 : :
6708 : : end subroutine gstore_compute_and_write_vk
6709 : : !!***
6710 : :
6711 : : !!****f* m_gstore/gstore_compute_and_write_commutator
6712 : : !! NAME
6713 : : !! gstore_compute_and_write_commutator
6714 : : !!
6715 : : !! FUNCTION
6716 : : !! Compute matrix elements i <psi_mk|[V1_q0ka, p]|psi_nk> in the full BZ in reduced coordinates.
6717 : : !! Write results to disk.
6718 : : !! See [[cite:Lihm2020]], PhysRevB.101.121102
6719 : : !!
6720 : : !! SOURCE
6721 : :
6722 : 0 : subroutine gstore_compute_and_write_commutator(gstore, mpw, gmax, ngfft, ngfftf, dtset, cryst, pawfgr, psps, &
6723 : 0 : wfd, mpi_enreg, kg_k, ebands, dvdb, gs_ham_kq, root_ncid)
6724 : :
6725 : : !Arguments ------------------------------------
6726 : : class(gstore_t), intent(in) :: gstore
6727 : : integer,intent(in) :: gmax(3), mpw
6728 : : integer,intent(in) :: ngfft(18),ngfftf(18)
6729 : : type(dvdb_t),intent(inout) :: dvdb
6730 : : type(gs_hamiltonian_type),intent(inout) :: gs_ham_kq
6731 : : type(dataset_type),intent(in) :: dtset
6732 : : type(crystal_t),intent(in) :: cryst
6733 : : type(wfd_t),intent(in) :: wfd
6734 : : type(mpi_type),intent(in) :: mpi_enreg
6735 : : type(ebands_t),intent(in) :: ebands
6736 : : type(pawfgr_type),intent(in) :: pawfgr
6737 : : type(pseudopotential_type),intent(in) :: psps
6738 : : integer,intent(in) :: root_ncid
6739 : : !arrays
6740 : : integer,intent(inout) :: kg_k(3,mpw)
6741 : :
6742 : : !Local variables-------------------------------
6743 : : !scalars
6744 : : integer,parameter :: tim_getgh1c = 1, berryopt0 = 0, master = 0
6745 : : 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,
6746 : : integer :: cplex, db_iqpt, idir, ipert, ipc, my_ip, natom, natom3, n1, n2, n3, n4, n5, n6, nsppol, nspinor, nspden
6747 : : integer :: nfft, nfftf, mgfftf, my_npert, nkpg_k, band_k !, glob_nk mgfft,
6748 : : integer :: sij_opt,usecprj,usevnl,optlocal,optnl,opt_gvnlx1, ncerr, ik_glob, ierr
6749 : : real(dp) :: cpu_kk, wall_kk, gflops_kk
6750 : : logical :: gen_eigenpb
6751 : 0 : type(rf_hamiltonian_type) :: rf_ham_kq
6752 : : !arrays
6753 : : integer :: units(2), work_ngfft(18) ! g0_k(3)
6754 : : !integer,allocatable :: count_bk(:,:)
6755 : : real(dp) :: kk_ibz(3), kk_bz(3), gamma_point(3)
6756 : 0 : real(dp),allocatable :: v1scf(:,:,:,:), work(:,:,:,:), p_kets_k(:,:,:,:), gs1c_kq(:,:), dmat(:,:,:,:)
6757 : 0 : real(dp),allocatable :: kets_k(:,:,:), h1_kets_kq(:,:,:), iv1p_comm(:,:,:,:,:)
6758 : 0 : real(dp),allocatable :: ffnl_k(:,:,:,:), ph3d_k(:,:,:), grad_berry(:,:), kinpw_k(:), kpg_k(:,:)
6759 : 0 : real(dp),allocatable :: vlocal(:,:,:,:), vlocal1(:,:,:,:,:), dummy_vtrial(:,:), gvnlx1(:,:,:), lambda(:)
6760 : 0 : type(pawcprj_type),allocatable :: cwaveprj0(:,:)
6761 : : !----------------------------------------------------------------------
6762 : :
6763 [ # # ]: 0 : units = [std_out, ab_out]
6764 : 0 : call wrtout(units, " Computing and writing i <psi_mk| [V1, p]| psi_nk> ...")
6765 : 0 : call cwtime(cpu_kk, wall_kk, gflops_kk, "start")
6766 : :
6767 : : ! Copy important dimensions
6768 : 0 : natom = cryst%natom; natom3 = 3 * natom; nsppol = ebands%nsppol; nspinor = ebands%nspinor; nspden = dtset%nspden
6769 : :
6770 : 0 : n1 = ngfftf(1); n2 = ngfftf(2); n3 = ngfftf(3); n4 = ngfftf(4); n5 = ngfftf(5); n6 = ngfftf(6)
6771 [ # # ]: 0 : nfftf = product(ngfftf(1:3)); mgfftf = maxval(ngfftf(1:3))
6772 : :
6773 : 0 : call ngfft_seq(work_ngfft, gmax)
6774 [ # # # # : 0 : ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
# # # # #
# # # # #
# # # # #
# ]
6775 : :
6776 : : ! Read the dvscf potentials at qq=Gamma for all 3*natom perturbations.
6777 : : ! This call allocates v1scf(cplex, nfftf, nspden, 3*natom)
6778 : 0 : gamma_point(:) = zero; db_iqpt = dvdb%findq(gamma_point)
6779 : 0 : call dvdb%readsym_allv1(db_iqpt, cplex, nfftf, ngfftf, v1scf, gstore%comm)
6780 [ # # ]: 0 : ABI_CHECK_IEQ(cplex, 1, "cplex should be zero when q == 0")
6781 : :
6782 : : ! Allocate vlocal. Note nvloc
6783 : : ! I set vlocal to huge to trigger possible bugs (DFPT routines should not access the data)
6784 : 0 : usecprj = gstore%dtset%usepaw
6785 [ # # # # : 0 : ABI_MALLOC(vlocal, (n4, n5, n6, gs_ham_kq%nvloc))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
6786 [ # # # # : 0 : vlocal = huge(one)
# # # # ]
6787 [ # # # # : 0 : ABI_CALLOC(dummy_vtrial, (nfftf, nspden))
# # # # #
# # # # #
# # # # #
# ]
6788 [ # # # # : 0 : ABI_MALLOC(cwaveprj0, (gstore%cryst%natom, wfd%nspinor*usecprj))
# # # # #
# # # # #
# # # # #
# # # ]
6789 : :
6790 : : ! Prepare call to getgh1c
6791 : 0 : usevnl = 0
6792 : 0 : optlocal = 1 ! local part of H^(1) is computed in gh1c=<G|H^(1)|C>
6793 : 0 : optnl = 2 ! non-local part of H^(1) is totally computed in gh1c=<G|H^(1)|C>
6794 : 0 : opt_gvnlx1 = 0 ! gvnlx1 is output
6795 : :
6796 [ # # ]: 0 : ABI_MALLOC(grad_berry, (2, nspinor*(berryopt0/4)))
6797 : :
6798 : : ! Since v1(q=0) and p are Hermitian operators, we have:
6799 : : !
6800 : : ! i <psi_mk| [v1, p] |psi_nk> = i <v1 psi_mk | p psi_nk> -i <p psi_mk | v1 psi_nk>
6801 : : !
6802 : : ! Note that in the present implementation both m and n indices run from bstart_k to bstop_k.
6803 : :
6804 : : ! if PAW, one has to solve a generalized eigenproblem
6805 [ # # ]: 0 : gen_eigenpb = psps%usepaw == 1; sij_opt = 0; if (gen_eigenpb) sij_opt = 1
6806 : :
6807 : : ! Define netcdf arrays inside the spin group.
6808 [ # # ]: 0 : do spin=1, nsppol
6809 [ # # ]: 0 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6810 : : ncerr = nctk_def_arrays(spin_ncid, [ &
6811 : : nctkarr_t("iv1p_comm", "dp", "two, nb_k, nb_k, three, natom3, glob_nk") &
6812 [ # # ]: 0 : ], defmode=.True.)
6813 [ # # ]: 0 : NCF_CHECK(ncerr)
6814 : :
6815 [ # # ]: 0 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("iv1p_comm"), NF90_FILL, -huge(one)))
6816 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(spin_ncid))
6817 : : end do
6818 : : !NCF_CHECK(nctk_set_datamode(root_ncid))
6819 : :
6820 [ # # ]: 0 : do my_is=1,gstore%my_nspins
6821 : 0 : associate (gqk => gstore%gqk(my_is))
6822 : 0 : spin = gstore%my_spins(my_is); nb_k = gqk%nb_k; nb_kq = gqk%nb_kq; my_npert = gqk%my_npert
6823 : :
6824 : : ! Be careful as wavefunctions might be replicated.
6825 : : ! Use count_bk to count how many states have been computed in parallel in order to rescale the results.
6826 : : !ABI_ICALLOC(count_bk, (nb_k, gstore%nkibz))
6827 [ # # ]: 0 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6828 [ # # ]: 0 : NCF_CHECK(nctk_prepare_mpiio(spin_ncid, "iv1p_comm"))
6829 : :
6830 : : ! Allocate vlocal1 with correct cplex. Note nvloc and my_npert.
6831 [ # # # # : 0 : ABI_MALLOC(vlocal1, (cplex*n4, n5, n6, gs_ham_kq%nvloc, my_npert))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
6832 [ # # # # : 0 : ABI_MALLOC(lambda, (nb_k))
# # # # #
# # # ]
6833 : :
6834 [ # # # # : 0 : ABI_CALLOC(iv1p_comm, (2, nb_k, nb_k, 3, natom3))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # #
# ]
6835 [ # # # # : 0 : ABI_MALLOC(dmat, (2, nb_k, nb_k, 3))
# # # # #
# # # # #
# # ]
6836 : :
6837 : : ! Set up local potential vlocal1 with proper dimensioning from vtrial1 taking into account the spin.
6838 : : ! Note that here v1scf contains all 3 natom perturbations as we called dvdb%readsym_allv1.
6839 [ # # ]: 0 : do my_ip=1,my_npert
6840 : 0 : idir = dvdb%my_pinfo(1, my_ip); ipert = dvdb%my_pinfo(2, my_ip); ipc = dvdb%my_pinfo(3, my_ip)
6841 : : call rf_transgrid_and_pack(spin, nspden, psps%usepaw, cplex, nfftf, nfft, ngfft, gs_ham_kq%nvloc,&
6842 : 0 : pawfgr, mpi_enreg, dummy_vtrial, v1scf(:,:,:,ipc), vlocal, vlocal1(:,:,:,:,my_ip))
6843 : : end do
6844 : :
6845 : : ! Continue to initialize the GS Hamiltonian
6846 : 0 : call gs_ham_kq%load_spin(spin, vlocal=vlocal, with_nonlocal=.true.)
6847 : :
6848 [ # # ]: 0 : do my_ik=1,gqk%my_nk
6849 : : ! Parallelism inside q-point communicator.
6850 [ # # ]: 0 : if (gqk%qpt_comm%skip(my_ik)) cycle
6851 : :
6852 : : ! The k-point and the symmetries relating the BZ k-point to the IBZ.
6853 [ # # ]: 0 : kk_bz = gqk%my_kpts(:, my_ik)
6854 : 0 : ik_ibz = gqk%my_k2ibz(1, my_ik)
6855 [ # # ]: 0 : kk_ibz = ebands%kptns(:,ik_ibz)
6856 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
6857 : :
6858 : : ! Get npw_k, kg_k and symmetrize wavefunctions from the IBZ (if needed).
6859 : : call wfd%sym_ug_kg_npw(dtset%ecut, kk_bz, kk_ibz, gqk%bstart_k, nb_k, spin, gqk%my_k2ibz(:, my_ik), cryst, &
6860 [ # # ]: 0 : work_ngfft, work, istwf_k, npw_k, kg_k, kets_k)
6861 : :
6862 : : call gs_ham_kq%eph_setup_k("k", kk_bz, istwf_k, npw_k, kg_k, dtset, cryst, psps, & ! in
6863 [ # # # # : 0 : nkpg_k, kpg_k, ffnl_k, kinpw_k, ph3d_k, gqk%pert_comm%value) ! out
# # # # ]
6864 : :
6865 : 0 : npwsp_k = npw_k * nspinor
6866 [ # # # # : 0 : ABI_MALLOC(h1_kets_kq, (2, npwsp_k, nb_k))
# # # # #
# # # # #
# # ]
6867 [ # # # # : 0 : ABI_MALLOC(gs1c_kq, (2, npwsp_k*nb_k*((sij_opt+1)/2)))
# # # # #
# # # ]
6868 [ # # # # : 0 : ABI_MALLOC(gvnlx1, (2, npwsp_k,nb_k))
# # # # #
# # # ]
6869 : :
6870 : : ! Compute <g|-i\Nabla |psi_nk>.
6871 [ # # # # : 0 : ABI_MALLOC(p_kets_k, (2, npwsp_k, nb_k, 3))
# # # # #
# # # # #
# # # # ]
6872 : 0 : call cg_p_psi(npw_k, nspinor, nb_k, kk_bz, kg_k, kets_k, p_kets_k)
6873 : :
6874 [ # # # # : 0 : iv1p_comm = zero
# # # # #
# ]
6875 [ # # ]: 0 : do my_ip=1,my_npert
6876 : 0 : idir = dvdb%my_pinfo(1, my_ip); ipert = dvdb%my_pinfo(2, my_ip); ipc = dvdb%my_pinfo(3, my_ip)
6877 : :
6878 : : ! Prepare application of the NL part.
6879 : 0 : call rf_ham_kq%init(cplex, gs_ham_kq, ipert, has_e1kbsc=.true.)
6880 : 0 : call rf_ham_kq%load_spin(spin, vlocal1=vlocal1(:,:,:,:,my_ip), with_nonlocal=.true.)
6881 : :
6882 [ # # ]: 0 : do in_k=1,nb_k
6883 : : ! Use scissor shift on 0-order eigenvalue
6884 : 0 : band_k = in_k + gqk%bstart_k - 1
6885 : 0 : lambda(in_k) = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
6886 : : end do
6887 : : !call ebands%get_dfpt_eshifted(gqk%bstart_k, nb_k, ik_ibz, spin, dtset%dfpt_sciss, lambda)
6888 : :
6889 : : ! Calculate dvscf * psi_k, results stored in h1_kets_kq on the k+q sphere.
6890 : : ! Compute H(1) applied to GS wavefunction Psi(0).
6891 : : call getgh1c(berryopt0, kets_k, cwaveprj0, h1_kets_kq, &
6892 : : grad_berry, gs1c_kq, gs_ham_kq, gvnlx1, idir, ipert, lambda, mpi_enreg, nb_k, optlocal, &
6893 : 0 : optnl, opt_gvnlx1, rf_ham_kq, sij_opt, tim_getgh1c, usevnl)
6894 : :
6895 : 0 : call rf_ham_kq%free()
6896 : :
6897 : : ! Here we compute: i <u_mk| [v1, p] u_nk> = i <v1 u_mk | p u_nk> -i <p u_mk | v1 u_nk>
6898 : : ! p_kets_k(:, npwsp_k, nb_k, 3)
6899 : : ! h1_kets_kq, (2, npw_k*nspinor, nb_k))
6900 [ # # # # : 0 : dmat = zero
# # # # ]
6901 [ # # ]: 0 : do ii=1,3
6902 : : call ZGEMM('C', 'N', nb_k, nb_k, npwsp_k, j_dpc, h1_kets_kq, npwsp_k, &
6903 : 0 : p_kets_k(:,:,:,ii), npwsp_k, cone, dmat(:,:,:,ii), nb_k)
6904 : :
6905 : : call ZGEMM('C', 'N', nb_k, nb_k, npwsp_k, -j_dpc, p_kets_k(:,:,:,ii), npwsp_k, &
6906 : 0 : h1_kets_kq, npwsp_k, cone, dmat(:,:,:,ii), nb_k)
6907 : : end do
6908 : :
6909 [ # # # # : 0 : iv1p_comm(:,:,:,:,ipc) = dmat
# # # # ]
6910 : : end do ! my_ip
6911 : :
6912 : 0 : call xmpi_sum(iv1p_comm, gqk%pert_comm%value, ierr)
6913 [ # # ]: 0 : if (gqk%pert_comm%me == 0) then
6914 [ # # # # : 0 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("iv1p_comm"), iv1p_comm, start=[1,1,1,1,1,ik_glob]))
# # ]
6915 : : end if
6916 : :
6917 [ # # ]: 0 : ABI_FREE(ffnl_k)
6918 [ # # ]: 0 : ABI_FREE(kinpw_k)
6919 [ # # ]: 0 : ABI_FREE(ph3d_k)
6920 [ # # ]: 0 : ABI_FREE(kpg_k)
6921 [ # # ]: 0 : ABI_FREE(kets_k)
6922 [ # # ]: 0 : ABI_FREE(p_kets_k)
6923 [ # # ]: 0 : ABI_FREE(gs1c_kq)
6924 [ # # ]: 0 : ABI_FREE(h1_kets_kq)
6925 [ # # ]: 0 : ABI_FREE(gvnlx1)
6926 : : end do ! my_ik
6927 : :
6928 [ # # ]: 0 : ABI_FREE(vlocal1)
6929 [ # # ]: 0 : ABI_FREE(lambda)
6930 [ # # ]: 0 : ABI_FREE(dmat)
6931 : :
6932 : : !call xmpi_sum(count_bk, gqk%comm%value, ierr)
6933 : :
6934 : : !do ik_ibz=1, gstore%nkibz
6935 : : ! do band=gqk%bstart_k, gqk%bstop_k
6936 : : ! in_k = band - gqk%bstart_k + 1
6937 : : ! if (count_bk(in_k, ik_ibz) == 0) cycle
6938 : : ! do ii=1,3
6939 : : ! vnk_cart_ibz(ii,in_k,ik_ibz) = vnk_cart_ibz(ii,in_k,ik_ibz) / count_bk(in_k, ik_ibz)
6940 : : ! end do
6941 : : ! end do
6942 : : !end do
6943 : : !ABI_FREE(count_bk)
6944 : :
6945 [ # # ]: 0 : ABI_FREE(iv1p_comm)
6946 : : end associate
6947 : : end do ! my_is
6948 : :
6949 [ # # ]: 0 : ABI_FREE(vlocal)
6950 [ # # ]: 0 : ABI_FREE(dummy_vtrial)
6951 [ # # ]: 0 : ABI_FREE(v1scf)
6952 [ # # ]: 0 : ABI_FREE(work)
6953 [ # # ]: 0 : ABI_FREE(grad_berry)
6954 : :
6955 : 0 : call pawcprj_free(cwaveprj0)
6956 [ # # # # : 0 : ABI_FREE(cwaveprj0)
# # # # #
# ]
6957 : :
6958 : 0 : call xmpi_barrier(gstore%comm)
6959 [ # # # # : 0 : call cwtime_report(" Computation of commutator:", cpu_kk, wall_kk, gflops_kk)
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
6960 : :
6961 : : contains
6962 : :
6963 : 0 : integer function spin_vid(var_name)
6964 : : character(len=*),intent(in) :: var_name
6965 : 0 : spin_vid = nctk_idname(spin_ncid, var_name)
6966 : : end function spin_vid
6967 : :
6968 : : end subroutine gstore_compute_and_write_commutator
6969 : : !!***
6970 : :
6971 : : !!****f* m_gstore/gstore_nc_has_iv1p_comm
6972 : : !! NAME
6973 : : !! gstore_nc_has_iv1p_comm
6974 : : !!
6975 : : !! FUNCTION
6976 : : !! Return True if GSTORE.nc contains commutator matrix elements.
6977 : : !!
6978 : : !! SOURCE
6979 : :
6980 : 24 : logical function gstore_nc_has_iv1p_comm(gstore, root_ncid) result (has_iv1p_comm)
6981 : :
6982 : : !Arguments ------------------------------------
6983 : : class(gstore_t),target, intent(in) :: gstore
6984 : : integer,intent(in) :: root_ncid
6985 : :
6986 : : !Local variables-------------------------------
6987 : : integer :: spin, ncerr, spin_ncid, varid
6988 : : ! *************************************************************************
6989 : :
6990 : 24 : has_iv1p_comm = .True.
6991 [ + - ]: 24 : do spin=1,gstore%nsppol
6992 [ - + ]: 24 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6993 : 24 : ncerr = nf90_inq_varid(spin_ncid, "iv1p_comm", varid)
6994 [ - + ]: 24 : if (ncerr /= nf90_noerr) then
6995 : : has_iv1p_comm = .False.; exit
6996 : : end if
6997 : : end do
6998 : :
6999 : 24 : end function gstore_nc_has_iv1p_comm
7000 : : !!***
7001 : :
7002 : : !!****f* m_gstore/gstore_read_gtype
7003 : : !! NAME
7004 : : !! gstore_read_gtype
7005 : : !!
7006 : : !! FUNCTION
7007 : : !! Read the value of "gstore_gtype" from the NetCDF file.
7008 : : !! Only the master process reads the value and broadcasts it to all processes in comm.
7009 : : !!
7010 : : !! INPUTS
7011 : : !! ncid: NetCDF file ID (open for reading).
7012 : : !! comm: MPI communicator.
7013 : : !!
7014 : : !! OUTPUTS
7015 : : !! gtype: The value of gstore_gtype read from the file.
7016 : : !!
7017 : : !! SOURCE
7018 : :
7019 : 7 : subroutine gstore_read_gtype(path, gtype, comm, &
7020 [ - + - - : 7 : brange_k_spin, brange_kq_spin) ! optional
- - - + -
- - - ]
7021 : :
7022 : : !Arguments ------------------------------------
7023 : : character(len=*), intent(in) :: path
7024 : : character(len=abi_slen), intent(out) :: gtype
7025 : : integer, intent(in) :: comm
7026 : : integer,optional,intent(out) :: brange_k_spin(:,:)
7027 : : integer,optional,intent(out) :: brange_kq_spin(:,:)
7028 : :
7029 : : !Local variables-------------------------------
7030 : : integer, parameter :: master = 0
7031 : : integer :: my_rank, nproc, ierr, varid, ncerr, ncid
7032 : : ! *************************************************************************
7033 : :
7034 : 7 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
7035 : :
7036 [ + - ]: 7 : if (my_rank == master) then
7037 [ - + ]: 7 : NCF_CHECK(nf90_open(path, nf90_nowrite, ncid))
7038 : 7 : gtype = GSTORE_GTYPE_KS
7039 : 7 : ncerr = nf90_inq_varid(ncid, "gstore_gtype", varid)
7040 [ + - ]: 7 : if (ncerr == nf90_noerr) then
7041 [ - + ]: 7 : NCF_CHECK(nf90_get_var(ncid, varid, gtype))
7042 : 7 : call replace_ch0(gtype)
7043 : : end if
7044 [ - + ]: 7 : if (present(brange_k_spin)) then
7045 [ # # ]: 0 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_k_spin"), brange_k_spin))
7046 : : end if
7047 [ - + ]: 7 : if (present(brange_kq_spin)) then
7048 [ # # ]: 0 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_kq_spin"), brange_kq_spin))
7049 : : end if
7050 [ - + ]: 7 : NCF_CHECK(nf90_close(ncid))
7051 : : end if
7052 : :
7053 [ - + ]: 7 : if (nproc > 1) then
7054 : 0 : call xmpi_bcast(gtype, master, comm, ierr)
7055 [ # # ]: 0 : if (present(brange_k_spin)) call xmpi_bcast(brange_k_spin, master, comm, ierr)
7056 [ # # ]: 0 : if (present(brange_kq_spin)) call xmpi_bcast(brange_kq_spin, master, comm, ierr)
7057 : : end if
7058 : :
7059 : : contains
7060 : :
7061 : 0 : integer function vid(var_name)
7062 : : character(len=*),intent(in) :: var_name
7063 : 0 : vid = nctk_idname(ncid, var_name)
7064 : : end function vid
7065 : :
7066 : : end subroutine gstore_read_gtype
7067 : : !!***
7068 : :
7069 : : !----------------------------------------------------------------------
7070 : :
7071 : : !!****f* m_gstore/gstore_symmetrize
7072 : : !! NAME
7073 : : !! gstore_symmetrize
7074 : : !!
7075 : : !! FUNCTION
7076 : : !! Reconstruct the electron-phonon matrix elements g(k,q) in the full
7077 : : !! Brillouin Zone (BZ) using the values stored in the IBZ for k and the IBZ_k for q.
7078 : : !! Uses the NetCDF API for in-place modification of the GSTORE file
7079 : : !! and wfd_t to fetch wavefunctions and compute unitary matrices.
7080 : : !!
7081 : : !! SOURCE
7082 : :
7083 : 0 : subroutine gstore_symmetrize(gstore_path, wfk_path, ngfft, dtset, dtfil, cryst, psps, pawtab, ebands, ifc, comm)
7084 : :
7085 : : !Arguments ------------------------------------
7086 : : !scalars
7087 : : character(len=*),intent(in) :: gstore_path
7088 : : character(len=*),intent(in) :: wfk_path
7089 : : integer,intent(in) :: ngfft(18)
7090 : : type(dataset_type),intent(in) :: dtset
7091 : : type(datafiles_type),intent(in) :: dtfil
7092 : : class(crystal_t),target,intent(in) :: cryst
7093 : : class(ebands_t),target,intent(in) :: ebands
7094 : : class(ifc_type),target,intent(in) :: ifc
7095 : : type(pseudopotential_type),intent(in) :: psps
7096 : : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
7097 : : integer,intent(in) :: comm
7098 : :
7099 : : !Local variables-------------------------------
7100 : : !scalars
7101 : : integer :: with_cplex, my_is, spin, my_ik, my_iq, ik_glob, iq_glob, units(2)
7102 : : integer :: ncid, spin_ncid, nprocs, my_rank, ncerr, this_state, ierr
7103 : : integer :: nb, nkbz, nkibz, nqbz, nqibz, nsym, itime_k
7104 : : integer :: ik_ibz, isym_k, trev_k, tsign_k, g0_k(3), g0_q(3)
7105 : : integer :: ik_ibz_file, isym_lg, itime_lg, isym_combined, c1_gs, n_gv, igv
7106 : : integer :: n_lg, ii_lg, tsign_lg !, isym_lg, itime_lg,
7107 : : integer :: idir, iat, idir_eq, iat_eq, mu, mu_eq, iq_sym
7108 : : integer :: symrec_eq(3,3), symrec_eq_kspace(3,3), l0(3), mat_tmp(3,3)
7109 : : real(dp) :: weight_qq, phase
7110 : : complex(dp) :: cphase
7111 : : logical :: with_g2dw, isirr_k, found_lg
7112 : : character(len=abi_slen) :: with_gmode, gtype, gvals_name, gv_names(2)
7113 : : character(len=5000) :: msg
7114 [ # # ]: 0 : type(gstore_t) :: gstore
7115 : 0 : type(dmats_t) :: dmats
7116 : : integer :: isym_kqS, isym_kqT, ikq_ibz_s, ikq_ibz_t, h_isym, itime_h, h_isym_inv, trev_kqS, trev_kqT
7117 : : integer :: indkk_s(6,1), indkk_t(6,1)
7118 : : real(dp) :: L_h_gs(3), kq_ibz_pt(3)
7119 : : complex(dp) :: phase_h_gs, phase_ket_gs
7120 : : logical,parameter :: DEBUG_DUMP_DH = .False.
7121 : : real(dp) :: kk_lg_test(3)
7122 : : !!arrays
7123 : 0 : integer :: brange_kq_spin(2, dtset%nsppol)
7124 : 0 : integer,allocatable :: state_kq(:,:), kibz2bz(:) !, qibz2bz(:), qglob2bz(:,:), ! kmesh_map(:,:), my_kqmap(:,:),
7125 : 0 : integer,allocatable :: lg_isym(:), lg_itime(:)
7126 : : real(dp) :: kk_bz(3), kk_ibz(3), qpt(3), qpt_tmp(3), kq_bz_source(3), kq_bz_target(3)
7127 : 0 : real(dp),allocatable :: qbz(:,:)
7128 : 0 : real(dp),contiguous,pointer :: gkq_rot_ptr(:,:,:,:,:), gkq_base_ptr(:,:,:,:,:)
7129 : 0 : complex(dp),target,allocatable :: gkq_rot(:,:,:,:,:), gkq_base(:,:,:,:,:)
7130 : 0 : complex(dp),allocatable :: gtmp(:,:), dh_mat(:,:), ket_mat(:,:)
7131 : : !----------------------------------------------------------------------
7132 : :
7133 : 0 : nprocs = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
7134 : :
7135 [ # # ]: 0 : units = [std_out, ab_out]
7136 : 0 : call wrtout(units, " Entering gstore_symmetrize...")
7137 : 0 : call wrtout(units, sjoin(" GSTORE file: ", gstore_path))
7138 : :
7139 : 0 : call gstore_read_gtype(gstore_path, gtype, comm, brange_kq_spin=brange_kq_spin)
7140 : :
7141 : : ! Compute the D-matrices D_mn(S) = <psi_m,S kq_ibz|S|psi_n,kq_ibz>.
7142 : : ! These are used below (as dh_mat) to correct the extra rotation the bra (electron state
7143 : : ! at k+q) picks up when its own already-computed BZ representative differs from the one
7144 : : ! obtained by applying isym_k directly. dh_mat is applied to the (k+q)/bra band index only
7145 : : ! (gvals' first band dimension, nb_kq) -- never to the k/ket index (nb_k) -- so dmats must be
7146 : : ! built with brange_kq_spin (bstart_kq:bstop_kq), NOT brange_k_spin: the two band windows are
7147 : : ! only required to have the SAME COUNT (gstore%same_nbands, checked below) but may start at a
7148 : : ! different absolute band (bstart_k need not equal bstart_kq, and neither needs to start at 1).
7149 : : ! All MPI ranks participate here since dmats%init distributes the work internally over comm.
7150 : : !
7151 : : ! NOTE: dmats_init also computes genuine (WFK-derived) D-matrices for symmetries S that do
7152 : : ! NOT stabilize a given IBZ k-point (S.k /= k+G), not just little-group elements -- this
7153 : : ! routine (gstore_symmetrize) is UNAFFECTED by that generalization and needs no changes
7154 : : ! because it never reads a non-little-group slot: every dmats%for_spin(...) lookup below
7155 : : ! uses either h_isym/h_isym_inv (searched for specifically as a stabilizer of ikq_ibz_t --
7156 : : ! see "Cannot find little-group element h for the k+q leg" below) or isym_k (drawn directly
7157 : : ! from lg_isym, the explicitly-enumerated little group of kk_ibz in Pass A). Both are
7158 : : ! guaranteed, by construction, to land on the little-group branch of dmats_init, which is
7159 : : ! untouched by the generalization -- confirmed by byte-identical validation numbers on
7160 : : ! diamond/AlAs before and after. See gstore_symmetrize_status memory for the full story.
7161 : 0 : call dmats%init(wfk_path, dtset, cryst, brange_kq_spin, ngfft, pawtab, psps, comm)
7162 : :
7163 : : ! Only master processor performs the symmetrization of the e-ph matrix elements.
7164 : : ! Performance is not crucial and the algorithm is IO-bound.
7165 [ # # ]: 0 : if (my_rank /= 0) goto 100
7166 : :
7167 : : ! GWPT files store two sets of e-ph matrix elements: "gvals" (g^Sigma) and "gvals_ks" (g^KS),
7168 : : ! written at the same (k,q) grid positions (see m_gwpt.F90's dump_my_gbuf). Symmetrize both.
7169 : 0 : n_gv = 1; gv_names(1) = "gvals"
7170 [ # # ]: 0 : if (gtype == GSTORE_GTYPE_GWPT) then
7171 : 0 : n_gv = 2; gv_names(2) = "gvals_ks"
7172 : : end if
7173 : :
7174 : : ! Read GSTORE.nc dimensions and metadata from file, without allocating gvals buffer.
7175 : 0 : with_cplex = 0; with_gmode = GSTORE_GMODE_ATOM; with_g2dw = .False.; gvals_name = "gvals"
7176 : : call gstore%from_ncpath(gstore_path, with_cplex, dtset, dtfil, cryst, ebands, ifc, &
7177 : 0 : with_gmode, gvals_name, with_g2dw, xmpi_comm_self)
7178 : :
7179 : : ! We need the same number of bands for m and n. Also, k and q must be in the BZ without any filter.
7180 [ # # ]: 0 : ABI_CHECK(gstore%same_nbands(msg), msg)
7181 [ # # ]: 0 : if (gstore%check_cplex_qkzone_gmode(2, "bz", "bz", "atom", kfilter="none", check_alloc=.False.) /= 0) then
7182 : 0 : ABI_ERROR("GSTORE.nc should have both k and q in the full BZ. See messages above.")
7183 : : end if
7184 : :
7185 : : ! has_used_lgk is supported via the gstore_sym == 2 "Pass A" reconstruction below.
7186 : : ! has_used_lgq remains unsupported: it is a structurally different restriction
7187 : : ! (k filtered by the little group of q), out of scope for gstore_sym.
7188 [ # # ]: 0 : ABI_CHECK_IEQ(gstore%has_used_lgq, 0, "Symmetrization of g(k,q) with use_lgq /= 0 is not coded")
7189 : :
7190 : : ! Useful dimensions.
7191 : 0 : nkbz = gstore%nkbz; nkibz = gstore%nkibz
7192 : 0 : nqbz = gstore%nqbz; nqibz = gstore%nqibz
7193 : 0 : nsym = cryst%nsym
7194 : :
7195 : : ! Need to know the position of the IBZ k-points in the netcdf array..
7196 [ # # ]: 0 : call get_ibz2bz(gstore%nkibz, gstore%nkbz, gstore%kbz2ibz, kibz2bz, msg, ierr)
7197 [ # # ]: 0 : ABI_CHECK(ierr == 0, sjoin("Something wrong in symmetry tables for k-points", ch10, msg))
7198 : :
7199 [ # # ]: 0 : NCF_CHECK(nctk_open_modify(ncid, gstore_path, xmpi_comm_self))
7200 : :
7201 : : if (DEBUG_DUMP_DH) open(unit=789, file="dh_debug.csv", status="replace", action="write")
7202 : : if (DEBUG_DUMP_DH) open(unit=790, file="dh_mat_full_debug.csv", status="replace", action="write")
7203 : : if (DEBUG_DUMP_DH) open(unit=791, file="gtmp_debug.csv", status="replace", action="write")
7204 : : if (DEBUG_DUMP_DH) open(unit=792, file="mu_debug.csv", status="replace", action="write")
7205 : :
7206 : : ! Loop over collinear spins.
7207 [ # # ]: 0 : do my_is=1,gstore%my_nspins
7208 : 0 : spin = gstore%my_spins(my_is)
7209 : : associate (gqk => gstore%gqk(my_is))
7210 : : ! nb_k == nb_kq is enforced by gstore%same_nbands above, so either count can be used here for
7211 : : ! sizing; the absolute band offsets (bstart_k vs bstart_kq, handled via brange_kq_spin passed
7212 : : ! to dmats%init above) are what actually differ and matter for correctness.
7213 : 0 : nb = gqk%nb_k
7214 : 0 : ABI_CHECK_IEQ(gqk%bstart_kq, brange_kq_spin(1, spin), "gqk%bstart_kq != brange_kq_spin(1, spin)")
7215 [ # # ]: 0 : ABI_CHECK_IEQ(gqk%bstop_kq, brange_kq_spin(2, spin), "gqk%bstop_kq != brange_kq_spin(2, spin)")
7216 : :
7217 : : ! Get the group id for this spin.
7218 [ # # ]: 0 : NCF_CHECK(nf90_inq_ncid(ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
7219 : :
7220 : : ! Read table with status of the (k, q) entry.
7221 [ # # # # : 0 : ABI_MALLOC(state_kq, (gqk%glob_nk, gqk%glob_nq))
# # # # #
# # # # #
# # # # ]
7222 [ # # ]: 0 : ncerr = nf90_get_var(ncid, nctk_idname(ncid, "gstore_glob_state_kqs"), state_kq, start=[1,1,spin])
7223 [ # # ]: 0 : NCF_CHECK(ncerr)
7224 : :
7225 [ # # # # : 0 : ABI_MALLOC(gkq_base, (nb, nb, gqk%natom3, gqk%my_nq, n_gv))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
7226 [ # # # # : 0 : ABI_MALLOC(gkq_rot, (nb, nb, gqk%natom3, gqk%my_nq, n_gv))
# # # # #
# # # # #
# # # # #
# # # #
# ]
7227 [ # # # # : 0 : ABI_MALLOC(gtmp, (nb, nb))
# # # # #
# # # # #
# # # # ]
7228 [ # # # # : 0 : ABI_MALLOC(dh_mat, (nb, nb))
# # # # #
# # # #
# ]
7229 [ # # # # : 0 : ABI_MALLOC(ket_mat, (nb, nb))
# # # # #
# # # #
# ]
7230 : :
7231 : : ! Build q-points in the BZ.
7232 [ # # # # : 0 : ABI_MALLOC(qbz, (3, gqk%my_nq))
# # # # #
# # # ]
7233 [ # # ]: 0 : do my_iq=1, gqk%my_nq
7234 : 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qbz(:,my_iq))
7235 : : end do
7236 : :
7237 : : ! =====================================================================
7238 : : ! Pass A (gstore_sym == 2 only): if gstore_use_lgk restricted the q's
7239 : : ! actually computed directly for k in the IBZ, an IBZ row may have some
7240 : : ! q entries GSTORE_KQ_COMPUTED (q in IBZ_k) and others GSTORE_KQ_MISSING
7241 : : ! (q outside IBZ_k). Fill the MISSING ones here, using ONLY the little
7242 : : ! group of kk_ibz itself (k never moves in this pass -- the degenerate
7243 : : ! case of the k-star formula below, kk_bz := kk_ibz). Once every IBZ row
7244 : : ! is fully populated, the k-star loop below runs completely unchanged
7245 : : ! for the non-IBZ rows, exactly as it always has when gstore_use_lgk == 0.
7246 : : ! =====================================================================
7247 [ # # ]: 0 : if (dtset%gstore_sym == 2) then
7248 [ # # ]: 0 : do ik_ibz=1,nkibz
7249 : 0 : ik_glob = kibz2bz(ik_ibz)
7250 [ # # # # : 0 : if (all(state_kq(ik_glob, :) /= GSTORE_KQ_MISSING)) cycle
# # ]
7251 : :
7252 [ # # ]: 0 : kk_ibz = ebands%kptns(:, ik_ibz)
7253 : 0 : ik_ibz_file = ik_glob
7254 : 0 : kk_bz = kk_ibz ! degenerate case: k never moves in Pass A
7255 : :
7256 : : ! Enumerate the little group of kk_ibz once per row: symrel^T membership
7257 : : ! test, mirroring dmats_get_star_dmats (m_classify_bands.F90:2048-2061).
7258 : : ! Deliberately NOT lgroup_t/littlegroup_q here: those use the symrec
7259 : : ! convention, which can disagree with the symrel^T convention used
7260 : : ! throughout dmats/gstore_symmetrize for non-orthogonal symrel.
7261 [ # # # # : 0 : ABI_MALLOC(lg_isym, (2*nsym))
# # # # #
# # # #
# ]
7262 [ # # # # : 0 : ABI_MALLOC(lg_itime, (2*nsym))
# # # # ]
7263 : 0 : n_lg = 0
7264 [ # # ]: 0 : do itime_lg=1,2
7265 [ # # ]: 0 : do isym_lg=1,nsym
7266 [ # # ]: 0 : tsign_lg = 1; if (itime_lg == 2) tsign_lg = -1
7267 [ # # # # : 0 : kk_lg_test = tsign_lg * matmul(transpose(cryst%symrel(:,:,isym_lg)), kk_ibz)
# # # # #
# # # ]
7268 [ # # ]: 0 : if (isamek(kk_ibz, kk_lg_test, g0_q)) then
7269 : 0 : n_lg = n_lg + 1
7270 : 0 : lg_isym(n_lg) = isym_lg; lg_itime(n_lg) = itime_lg
7271 : : end if
7272 : : end do
7273 : : end do
7274 [ # # ]: 0 : ABI_CHECK(n_lg > 0, "Little group of kk_ibz is empty (should at least contain the identity)")
7275 : :
7276 : : ! Read g(k_ibz, q) for all q already available (same read pattern as below).
7277 [ # # ]: 0 : do igv=1,n_gv
7278 [ # # ]: 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])
7279 : : ncerr = nf90_get_var(spin_ncid, spin_vid(gv_names(igv)), gkq_base_ptr, &
7280 : : start=[1, 1, 1, 1, ik_ibz_file, 1], &
7281 [ # # # # ]: 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7282 [ # # ]: 0 : NCF_CHECK(ncerr)
7283 : : end do
7284 : :
7285 [ # # ]: 0 : do my_iq=1, gqk%my_nq
7286 : 0 : iq_glob = my_iq + gqk%my_qstart - 1
7287 : :
7288 [ # # ]: 0 : if (state_kq(ik_glob, iq_glob) /= GSTORE_KQ_MISSING) then
7289 : : ! Already GSTORE_KQ_COMPUTED (q in IBZ_k): keep the on-disk value unchanged.
7290 [ # # # # : 0 : gkq_rot(:,:,:,iq_glob,:) = gkq_base(:,:,:,iq_glob,:)
# # # # ]
7291 : 0 : cycle
7292 : : end if
7293 : :
7294 [ # # ]: 0 : qpt = qbz(:, my_iq)
7295 : :
7296 : : ! Search the little group x the row's own COMPUTED q entries for a source match.
7297 : : found_lg = .False.
7298 [ # # ]: 0 : do ii_lg=1,n_lg
7299 : 0 : isym_k = lg_isym(ii_lg); trev_k = lg_itime(ii_lg) - 1
7300 [ # # ]: 0 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
7301 [ # # # # ]: 0 : symrec_eq = transpose(cryst%symrel(:,:,isym_k))
7302 [ # # # # ]: 0 : symrec_eq_kspace = tsign_k * symrec_eq
7303 [ # # ]: 0 : do iq_sym=1, gqk%my_nq
7304 [ # # ]: 0 : if (state_kq(ik_glob, iq_sym + gqk%my_qstart - 1) /= GSTORE_KQ_COMPUTED) cycle
7305 [ # # # # : 0 : qpt_tmp = matmul(symrec_eq_kspace, qbz(:, iq_sym))
# # # # ]
7306 [ # # ]: 0 : if (isamek(qpt, qpt_tmp, g0_q)) then
7307 : 0 : found_lg = .True.; exit
7308 : : end if
7309 : : end do
7310 : 0 : if (found_lg) exit
7311 : : end do
7312 : :
7313 : : msg = sjoin("Pass A: no little-group image of q found among GSTORE_KQ_COMPUTED", &
7314 [ # # ]: 0 : " entries for ik_ibz=", itoa(ik_ibz), " -- IBZ_k does not cover this q's star")
7315 [ # # ]: 0 : ABI_CHECK(found_lg, msg)
7316 : :
7317 [ # # ]: 0 : do isym_combined=1,nsym
7318 [ # # # # : 0 : if (all(cryst%symrec(:,:,isym_combined) == symrec_eq)) exit
# # # # ]
7319 : : end do
7320 [ # # ]: 0 : ABI_CHECK(isym_combined /= nsym + 1, "Cannot find symrec_eq")
7321 : :
7322 : : ! Note on non-uniqueness of (isym_k, iq_sym): when kk_ibz has a non-trivial little group
7323 : : ! (the typical case, not a rare corner case -- measured on the reference test systems
7324 : : ! below, EVERY Pass-A point in diamond and most in AlAs have more than one valid
7325 : : ! candidate, up to ~96 at Gamma), the found_lg search above can match several different
7326 : : ! (isym,itime,iq_sym) triples for the same target q; "first found" is taken arbitrarily.
7327 : : ! Verified this does NOT introduce a gauge/correctness bug: a dedicated diagnostic
7328 : : ! (temporarily instrumented, then removed) recomputed the full reconstruction using EVERY
7329 : : ! valid candidate for a set of known-redundant points on both diamond (4 points, 2-4
7330 : : ! candidates each) and AlAs (2 points), and all candidates agreed with each other to
7331 : : ! numerical noise (~1e-7 to 1e-10) in every case -- i.e. the formula is empirically
7332 : : ! gauge-invariant to this choice, the same way the bra leg's h_isym/phase_h_gs/L_h_gs
7333 : : ! machinery is already known (and was originally designed) to be invariant to which
7334 : : ! (isym_kqS,isym_kqT) kpts_map happens to return. See gstore_symmetrize_status memory for
7335 : : ! the full data. Contrast with dmats_get_star_dmats_at_kpt (m_classify_bands.F90), a
7336 : : ! DIAGNOSTIC-only routine with a structurally identical first-match-wins search that its
7337 : : ! own authors flag as an unverified risk -- that routine has NOT been checked this way and
7338 : : ! is a separate, lower-priority open item (never reached by production gstore_symmetrize).
7339 : :
7340 : : ! -----------------------------------------------------------------
7341 : : ! From here on, reused VERBATIM from the k-star loop below (Bug A /
7342 : : ! h_isym / phase_h_gs / phase_ket_gs / itime_h / dh_mat / mu-rotation
7343 : : ! -- kk_bz == kk_ibz here, the degenerate case, so the formula
7344 : : ! derived for the general k-star case applies unchanged). See the
7345 : : ! k-star loop's own comments for the full derivation.
7346 [ # # ]: 0 : kq_bz_source = kk_ibz + qbz(:, iq_sym)
7347 [ # # ]: 0 : kq_bz_target = kk_bz + qpt
7348 : 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_source, indkk_s)
7349 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (source)")
7350 : 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_target, indkk_t)
7351 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (target)")
7352 : 0 : ikq_ibz_s = indkk_s(1,1); isym_kqS = indkk_s(2,1)
7353 : 0 : ikq_ibz_t = indkk_t(1,1); isym_kqT = indkk_t(2,1)
7354 : 0 : trev_kqS = indkk_s(6,1); trev_kqT = indkk_t(6,1)
7355 [ # # ]: 0 : ABI_CHECK(ikq_ibz_s == ikq_ibz_t, "Source and target k+q map to different IBZ points!")
7356 : :
7357 [ # # ]: 0 : mat_tmp = matmul(transpose(cryst%symrel(:,:,dmats%toinv(1,isym_kqT))), &
7358 [ # # # # : 0 : matmul(symrec_eq, transpose(cryst%symrel(:,:,isym_kqS))))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
7359 [ # # ]: 0 : do h_isym=1,nsym
7360 [ # # # # : 0 : if (all(transpose(cryst%symrel(:,:,h_isym)) == mat_tmp)) exit
# # # # ]
7361 : : end do
7362 [ # # ]: 0 : ABI_CHECK(h_isym /= nsym + 1, "Cannot find little-group element h for the k+q leg")
7363 : :
7364 : 0 : c1_gs = dmats%multable(1, isym_kqS, isym_k)
7365 : : L_h_gs = real(dmats%multable(2:4, isym_kqS, isym_k), dp) &
7366 : : + real(dmats%multable(2:4, c1_gs, dmats%toinv(1,isym_kqT)), dp) &
7367 [ # # # # : 0 : - matmul(real(cryst%symrel(:,:,h_isym), dp), real(dmats%toinv(2:4,isym_kqT), dp))
# # # # #
# # # #
# ]
7368 [ # # ]: 0 : kq_ibz_pt = ebands%kptns(:, ikq_ibz_t)
7369 [ # # ]: 0 : phase_h_gs = exp(cmplx(zero, two_pi * sum(kq_ibz_pt * L_h_gs), dp))
7370 : :
7371 : : ! Pass-A-only companion to phase_ket_gs. The k-star formula below (kk_bz generally
7372 : : ! != kk_ibz) was validated to 100% exact match WITHOUT this extra term. In Pass A,
7373 : : ! kk_bz == kk_ibz identically (the degenerate case), and an extra residual survived
7374 : : ! even after the ket_mat fix: isolated (h_isym==1, scalar-only residual, i.e. exactly
7375 : : ! reproducible by a single global phase -- see gstore_symmetrize_status memory) to be
7376 : : ! a clean function of isym_k and kk_ibz alone: exp(-i*2pi*kk_ibz.w(isym_k)) for an
7377 : : ! integer vector w. Empirically fit w(isym_k) exactly (32/32 points, zero exceptions,
7378 : : ! all 3 distinct ik_ibz/isym_k combinations in the reference test) to
7379 : : ! toinv(2:4,isym_k) -- the SAME single-inverse convention used for L_h_gs's own
7380 : : ! toinv(1,isym_kqT) term, and notably NOT the double-inverse toinv(2:4,toinv(1,isym_k))
7381 : : ! used by the qpt term just above. Plausible reading: the qpt-term's
7382 : : ! toinv(2:4,toinv(1,isym_k)) is the companion to kk_bz = symrec_eq.kk_ibz (the k-star's
7383 : : ! moved k), which in Pass A degenerates to kk_ibz itself, making this term newly
7384 : : ! separate and nonzero instead of staying absorbed into the k-star's single term.
7385 : : phase_ket_gs = exp(cmplx(zero, -two_pi * sum(qpt * real(dmats%toinv(2:4, dmats%toinv(1,isym_k)), dp)), dp)) &
7386 [ # # # # ]: 0 : * exp(cmplx(zero, -two_pi * sum(kk_ibz * real(dmats%toinv(2:4, isym_k), dp)), dp))
7387 : :
7388 : 0 : itime_h = 1 + mod(trev_k + trev_kqS + trev_kqT, 2)
7389 : :
7390 : 0 : h_isym_inv = dmats%toinv(1, h_isym)
7391 [ # # ]: 0 : if (itime_h == 2) then
7392 [ # # # # : 0 : dh_mat = conjg(phase_h_gs) * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
# # # # #
# # # ]
7393 : : else
7394 [ # # # # : 0 : dh_mat = phase_h_gs * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
# # # # #
# # # ]
7395 : : end if
7396 : :
7397 [ # # # # : 0 : if (trev_kqT == 1) dh_mat = conjg(dh_mat)
# # ]
7398 : :
7399 : : ! Ket-leg correction (Pass A only -- k-star never needs this, see below). Unlike k-star
7400 : : ! reconstruction, whose ket is always *derived* via cgtk_rotate from the IBZ wavefunction
7401 : : ! (so ground truth and reconstruction structurally share the same gauge for any degenerate
7402 : : ! ket subspace), Pass A's ket lives AT kk_ibz itself and is read directly from the WFK for
7403 : : ! every q processed there. Ground truth's own independent direct e-ph calculations at
7404 : : ! different q (same k) do not share a common internal gauge for a degenerate ket subspace.
7405 : : ! isym_k stabilizes kk_ibz (drawn from its own little group, by construction), so
7406 : : ! dmats%for_spin(...)(isym_k,...) is a genuine, tabulated (non-placeholder) D-matrix here
7407 : : ! -- unlike the general k-star case, where isym_k need not stabilize anything.
7408 : : !
7409 : : ! Convention: read dmats%for_spin(...)(isym_k,...) DIRECTLY, not the toinv(1,isym_k) slot.
7410 : : ! isym_k here is found purely via the symrel^T convention (little-group membership test),
7411 : : ! and dmats's own array is indexed the same way (symrel^T, per dmats_init's own little-group
7412 : : ! check), so isym_k already names the exact tabulated operation that rotates the ket -- no
7413 : : ! inversion is needed or correct. (Contrast with the BRA correction above, dh_mat: h_isym
7414 : : ! there is defined as a genuine COMPOSITE/residual little-group element of kq_ibz whose
7415 : : ! natural tabulated slot -- per dmats_init's own toinv/multable bookkeeping around
7416 : : ! cgtk_rotate's isym_inv=toinv(isym) workaround -- is toinv(1,h_isym), not h_isym itself;
7417 : : ! that is a property of how h_isym's OWN definition composes with dmats_init's internal
7418 : : ! convention, not a general rule that every dmats lookup needs a toinv step.) The original
7419 : : ! implementation used toinv(1,isym_k) "by analogy" with dh_mat and was validated only on an
7420 : : ! involutory isym_k (toinv(1,isym_k)==isym_k), which cannot distinguish the two conventions.
7421 : : ! Diagnosed by finding a 100%/0% clean split: EVERY point with non-involutory isym_k was
7422 : : ! wrong (needing a genuine unitary matrix fix, not a scalar) while every involutory-isym_k
7423 : : ! point was already exact -- direct, decisive evidence the toinv(1,.) step was the bug.
7424 : 0 : itime_k = trev_k + 1
7425 [ # # # # : 0 : ket_mat = dmats%for_spin(spin)%value(:,:,isym_k,itime_k,ik_ibz)
# # # # #
# # # ]
7426 [ # # # # : 0 : if (trev_k == 1) ket_mat = conjg(ket_mat)
# # ]
7427 : : ! -----------------------------------------------------------------
7428 : :
7429 : : ! Perform symmetrization.
7430 [ # # ]: 0 : do mu=1,gqk%natom3
7431 : 0 : idir = mod(mu-1, 3) + 1; iat = (mu - idir) / 3 + 1
7432 : :
7433 : 0 : iat_eq = cryst%indsym(4, isym_combined, iat)
7434 [ # # ]: 0 : l0 = cryst%indsym(1:3, isym_combined, iat)
7435 [ # # ]: 0 : phase = -two_pi * dot_product(qbz(:, iq_sym), l0)
7436 : 0 : cphase = cmplx(cos(phase), sin(phase), dp)
7437 : :
7438 [ # # ]: 0 : do igv=1,n_gv
7439 [ # # # # ]: 0 : gtmp = zero
7440 [ # # ]: 0 : do idir_eq=1,3
7441 : 0 : mu_eq = idir_eq + (iat_eq - 1) * 3
7442 [ # # # # : 0 : gtmp = gtmp + cphase * symrec_eq(idir, idir_eq) * gkq_base(:,:,mu_eq,iq_sym,igv)
# # ]
7443 : : end do
7444 [ # # # # : 0 : if (trev_k == 1) gtmp = conjg(gtmp)
# # ]
7445 [ # # # # : 0 : gkq_rot(:,:,mu,iq_glob,igv) = matmul(matmul(dh_mat, gtmp), ket_mat)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
7446 : : end do
7447 : : end do
7448 : :
7449 : : end do ! my_iq
7450 : :
7451 : : ! Write the newly reconstructed + copied-through rows back to the netcdf file.
7452 [ # # ]: 0 : do igv=1,n_gv
7453 [ # # ]: 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])
7454 : : ncerr = nf90_put_var(spin_ncid, spin_vid(gv_names(igv)), gkq_rot_ptr, &
7455 : : start=[1, 1, 1, 1, ik_glob, 1], &
7456 [ # # # # ]: 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7457 [ # # ]: 0 : NCF_CHECK(ncerr)
7458 : : end do
7459 [ # # # # ]: 0 : where (state_kq(ik_glob, :) == GSTORE_KQ_MISSING) state_kq(ik_glob, :) = GSTORE_KQ_SYMMETRIZED
7460 : :
7461 [ # # ]: 0 : ABI_FREE(lg_isym)
7462 [ # # ]: 0 : ABI_FREE(lg_itime)
7463 : : end do ! ik_ibz
7464 : : end if ! gstore_sym == 2
7465 : :
7466 [ # # ]: 0 : NCF_CHECK(nf90_sync(spin_ncid))
7467 : :
7468 : : ! Loop over k-points in the IBZ.
7469 [ # # # # ]: 0 : do my_ik=1,gqk%my_nk
7470 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
7471 [ # # ]: 0 : kk_bz = gqk%my_kpts(:, my_ik)
7472 : :
7473 [ # # ]: 0 : if (state_kq(ik_glob, 1) /= GSTORE_KQ_MISSING) then
7474 : : ! Row already fully resolved: either directly COMPUTED (gstore_use_lgk == 0), or
7475 : : ! filled by Pass A above (gstore_sym == 2, mix of COMPUTED and SYMMETRIZED).
7476 [ # # # # : 0 : ABI_CHECK(all(state_kq(ik_glob, :) /= GSTORE_KQ_MISSING), "all state")
# # ]
7477 : 0 : cycle
7478 : : end if
7479 : :
7480 : : ! Symmetry tables for k-point. Using symrel^T convention for k..
7481 : 0 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
7482 : 0 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5, my_ik)
7483 : : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
7484 [ # # ]: 0 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
7485 : 0 : itime_k = trev_k + 1
7486 [ # # ]: 0 : kk_ibz = ebands%kptns(:,ik_ibz)
7487 : :
7488 : : ! Index of the IBZ k-point on disk.
7489 : 0 : ik_ibz_file = kibz2bz(ik_ibz)
7490 : :
7491 : : ! symrec_eq is the SPATIAL rotation (used for atomic-perturbation-direction
7492 : : ! bookkeeping below, which is TR-blind: time reversal does not move atoms.
7493 : : ! symrec_eq_kspace additionally carries the TR sign and is the one that actually relates k-space
7494 : : ! vectors (kk_bz, q) to their IBZ images
7495 [ # # # # ]: 0 : symrec_eq = transpose(cryst%symrel(:,:,isym_k))
7496 [ # # # # ]: 0 : symrec_eq_kspace = tsign_k * symrec_eq
7497 [ # # # # : 0 : ABI_CHECK(isamek(kk_bz, matmul(symrec_eq_kspace, kk_ibz), g0_q), "kk_bz != symrec_eq_kspace kk_ibz")
# # # # #
# ]
7498 : :
7499 [ # # ]: 0 : do isym_combined=1,nsym
7500 [ # # # # : 0 : if (all(cryst%symrec(:,:,isym_combined) == symrec_eq)) exit
# # # # ]
7501 : : end do
7502 [ # # ]: 0 : ABI_CHECK(isym_combined /= nsym + 1, "Cannot find symrec_eq")
7503 : :
7504 : : ! Read g(k_ibz, q) for all q-point in the BZ, for each gvals stream ("gvals", and "gvals_ks" too when gtype == "gwpt").
7505 [ # # ]: 0 : do igv=1,n_gv
7506 [ # # ]: 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])
7507 : : ncerr = nf90_get_var(spin_ncid, spin_vid(gv_names(igv)), gkq_base_ptr, &
7508 : : start=[1, 1, 1, 1, ik_ibz_file, 1], &
7509 [ # # # # ]: 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7510 [ # # ]: 0 : NCF_CHECK(ncerr)
7511 : : end do
7512 : :
7513 : : ! Loop over q-points in the BZ.
7514 [ # # ]: 0 : do my_iq=1, gqk%my_nq
7515 : 0 : iq_glob = my_iq + gqk%my_qstart - 1
7516 : 0 : this_state = state_kq(ik_glob, iq_glob)
7517 [ # # ]: 0 : if (this_state /= GSTORE_KQ_MISSING) cycle
7518 : :
7519 : : ! Symmetry tables for q-point. NB: Using symrec convention for q.
7520 : : !iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
7521 : : !trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5, my_iq)
7522 : : !isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
7523 : : !tsign_q = 1; if (trev_q == 1) tsign_q = -1
7524 : : !qq_ibz = gstore%qibz(:, iq_ibz)
7525 [ # # ]: 0 : qpt = qbz(:, my_iq)
7526 : :
7527 : : ! Find q. Uses symrec_eq_kspace (not symrec_eq): q, like k, is a genuine k-space vector
7528 : : ! that picks up the TR sign under the same combined operation mapping kk_ibz -> kk_bz.
7529 [ # # ]: 0 : do iq_sym=1, gqk%my_nq
7530 : : ! qpt = qpt_tmp + G0_q
7531 [ # # # # : 0 : qpt_tmp = matmul(symrec_eq_kspace, qbz(:, iq_sym)); if (isamek(qpt, qpt_tmp, g0_q)) exit
# # # # #
# ]
7532 : : end do
7533 [ # # ]: 0 : ABI_CHECK(iq_sym /= gqk%my_nq + 1, sjoin("Cannot find:", ktoa(qpt)))
7534 : :
7535 : : ! -----------------------------------------------------------------
7536 : : ! Bug A fix: the bra (electron state at k+q) reaches its target BZ
7537 : : ! point via two composed rotations (isym_k applied to the SOURCE
7538 : : ! bra's own rotation from kq_ibz), while the "true" bra is obtained
7539 : : ! by a single direct rotation from kq_ibz. The two differ by U(h),
7540 : : ! h being the residual element of the little group (stabilizer) of
7541 : : ! kq_ibz. h always stabilizes kq_ibz by construction (never an
7542 : : ! out-of-domain little-group lookup), so the D-matrices already
7543 : : ! tabulated by dmats are valid here. See gstore_symmetrize_status
7544 : : ! memory (session 10) for the full derivation.
7545 [ # # ]: 0 : kq_bz_source = kk_ibz + qbz(:, iq_sym)
7546 [ # # ]: 0 : kq_bz_target = kk_bz + qpt
7547 : 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_source, indkk_s)
7548 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (source)")
7549 : 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_target, indkk_t)
7550 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (target)")
7551 : 0 : ikq_ibz_s = indkk_s(1,1); isym_kqS = indkk_s(2,1)
7552 : 0 : ikq_ibz_t = indkk_t(1,1); isym_kqT = indkk_t(2,1)
7553 : 0 : trev_kqS = indkk_s(6,1); trev_kqT = indkk_t(6,1)
7554 [ # # ]: 0 : ABI_CHECK(ikq_ibz_s == ikq_ibz_t, "Source and target k+q map to different IBZ points!")
7555 : :
7556 : : ! mat_tmp = Srel(toinv(isym_kqT)) . Srel(isym_k) . Srel(isym_kqS), with Srel(S) := symrel(S)^T
7557 : : ! (same k/kq convention as symrec_eq above, i.e. NOT cryst%symrec). h_isym is the isym s.t.
7558 : : ! Srel(h_isym) == mat_tmp.
7559 [ # # ]: 0 : mat_tmp = matmul(transpose(cryst%symrel(:,:,dmats%toinv(1,isym_kqT))), &
7560 [ # # # # : 0 : matmul(symrec_eq, transpose(cryst%symrel(:,:,isym_kqS))))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
7561 [ # # ]: 0 : do h_isym=1,nsym
7562 [ # # # # : 0 : if (all(transpose(cryst%symrel(:,:,h_isym)) == mat_tmp)) exit
# # # # ]
7563 : : end do
7564 [ # # ]: 0 : ABI_CHECK(h_isym /= nsym + 1, "Cannot find little-group element h for the k+q leg")
7565 : :
7566 : : ! Lattice-vector-phase companion to h_isym (bra leg). The rotation-only h_isym search above
7567 : : ! finds the correct isym s.t. Srel(h_isym) matches the literal 3-way rotation product, but
7568 : : ! (analogous to dmats_get_star_dmats's validated S0.g.S0^{-1} + L_h construction) the literal
7569 : : ! Seitz composition Tab(isym_kqS).Tab(isym_k).Tab(isym_kqT)^{-1} generally differs from
7570 : : ! Tab(h_isym) by a residual lattice vector L_h_gs whenever any of isym_kqS/isym_k/isym_kqT is
7571 : : ! non-symmorphic, even when h_isym is the identity rotation. Derived by substituting
7572 : : ! Tab(c1)=T_{-L1}.Tab(isym_kqS).Tab(isym_k) [c1=multable(1,isym_kqS,isym_k), the SAME rotation
7573 : : ! recipe already validated for h_isym itself] into Tab(c1).Tab(toinv(isym_kqT))=T_{L2}.Tab(h_isym),
7574 : : ! then Tab(toinv(isym_kqT)) = Tab(isym_kqT)^{-1}.T_{L0} (L0=toinv(2:4,isym_kqT)), and pushing
7575 : : ! T_{-L0} through Tab(h_isym) (Tab(h).T_v = T_{R(h).v}.Tab(h)). Verified EXACTLY (3000/3000
7576 : : ! random (isym_k,isym_kqS,isym_kqT) triples, zero umklapp) against the literal 3-operator
7577 : : ! Seitz composition computed independently with the EXACT (non-tabulated) group inverse. The
7578 : : ! overall sign was pinned down against a hand-verified counterexample (h_isym=1, needing a
7579 : : ! missing factor of exactly +i).
7580 : 0 : c1_gs = dmats%multable(1, isym_kqS, isym_k)
7581 : : L_h_gs = real(dmats%multable(2:4, isym_kqS, isym_k), dp) &
7582 : : + real(dmats%multable(2:4, c1_gs, dmats%toinv(1,isym_kqT)), dp) &
7583 [ # # # # : 0 : - matmul(real(cryst%symrel(:,:,h_isym), dp), real(dmats%toinv(2:4,isym_kqT), dp))
# # # # #
# # # #
# ]
7584 [ # # ]: 0 : kq_ibz_pt = ebands%kptns(:, ikq_ibz_t)
7585 [ # # ]: 0 : phase_h_gs = exp(cmplx(zero, two_pi * sum(kq_ibz_pt * L_h_gs), dp))
7586 : :
7587 : : ! Companion phase on the KET leg. Even with phase_h_gs above, a residual remained, isolated
7588 : : ! (via h_isym==1 points, where dh_mat=I so phase_h_gs is the only other active correction) to
7589 : : ! be a clean function of isym_k and the TARGET q alone: exp(-i*2pi*qpt.v(isym_k)) for an
7590 : : ! integer vector v. Empirically fit v(isym_k) exactly (100% across all isym_k appearing in
7591 : : ! the reference test, zero exceptions) to toinv(2:4, toinv(1,isym_k)) -- i.e. the
7592 : : ! lattice-vector residual of composing isym_k with its OWN inverse in the OTHER order from
7593 : : ! toinv's own convention (toinv(2:4,isym_k) is for S(isym_k).S(isym_k^{-1}); this needs
7594 : : ! S(isym_k^{-1}).S(isym_k) instead, which only coincides with the former when isym_k is
7595 : : ! self-inverse -- the same class of composition-order mixup fixed in dmats_check_one_k and in
7596 : : ! deriving L_h_gs above). Physical origin not fully pinned down: isym_k plays a role in BOTH
7597 : : ! the ket rotation (kk_bz = symrec_eq.kk_ibz) AND the atomic-perturbation-direction rotation
7598 : : ! via the SAME symrec_eq in the mu-loop below (whose existing cphase/l0 term is dotted with
7599 : : ! the SOURCE q, not the target) -- plausibly this is the missing lattice-vector companion to
7600 : : ! THAT term, evaluated at the target q instead, but this is a plausible reading of the
7601 : : ! empirical formula, not an independently re-derived physical proof (unlike L_h_gs above,
7602 : : ! which was verified against the literal Seitz composition directly). Trust the formula
7603 : : ! (exhaustively validated below); treat the physical narrative as informed conjecture only.
7604 : : !
7605 : : ! Effect of phase_h_gs+phase_ket_gs alone on the gstore_brange 1 4 reference test: raw
7606 : : ! exact-match rate 60.4% -> 91.7%, gauge-invariant unchanged at 100%. NOTE: the remaining 8.3%
7607 : : ! was INITIALLY (wrongly) attributed entirely to expected degenerate-band gauge freedom per
7608 : : ! AGENTS.md -- this was corrected later (see the THIRD correction right below): a Procrustes
7609 : : ! best-fit-unitary check proved EXACT reconstruction is achievable for within-range-degenerate
7610 : : ! bra multiplets, so that mismatch was a real, fixable bug, not gauge freedom. Do not repeat
7611 : : ! that mistake: eigenvalue-degeneracy alone never proves a mismatch is harmless -- check
7612 : : ! whether a single matrix can exactly relate reconstruction to truth first.
7613 [ # # ]: 0 : phase_ket_gs = exp(cmplx(zero, -two_pi * sum(qpt * real(dmats%toinv(2:4, dmats%toinv(1,isym_k)), dp)), dp))
7614 : :
7615 : : ! THIRD correction: dmats%for_spin(h_isym) is the WRONG tabulated matrix for the bra whenever
7616 : : ! h_isym is a non-self-inverse symmetry. Root cause: dmats_init computes D(isym) by calling
7617 : : ! cgtk_rotate with isym_inv=toinv(isym) and a separately-recomputed umklapp g0_inv (a
7618 : : ! documented workaround for cgtk_rotate silently returning D_true(S)^{-1} for non-involutions).
7619 : : ! D(h) and D(toinv(h)) are unitary inverses of each other only up to an EXTRA phase that
7620 : : ! dmats_init's own toinv/multable bookkeeping already knows about (this is exactly what
7621 : : ! dmats_check_one_k's "inv_phase"/"phase_analytic" diagnostic measures and validates) --
7622 : : ! reconstructing D(toinv(h)) from D(h) via a bare conjugate-transpose silently drops that
7623 : : ! phase. Looking up dmats%for_spin(toinv(h_isym)) directly sidesteps this entirely, since
7624 : : ! dmats_init already computed that matrix independently and self-consistently under its own
7625 : : ! label: there is nothing to reconstruct.
7626 : : !
7627 : : ! Earlier sessions gated this substitution behind an empirical "is a correction needed at
7628 : : ! all" heuristic (g0-mismatch OR non-self-inverse-and-degenerate-bra), applying toinv(h_isym)
7629 : : ! only when it fired and h_isym unmodified otherwise. That heuristic is UNNECESSARY: applying
7630 : : ! dmats%for_spin(toinv(h_isym)) unconditionally (i.e. always, regardless of degeneracy or g0)
7631 : : ! reproduces the exact same result on every point where the heuristic previously used
7632 : : ! h_isym directly -- because on the reference test system, no such point exists: every
7633 : : ! non-self-inverse h_isym already satisfied the heuristic's trigger condition. (For
7634 : : ! self-inverse h_isym, toinv(1,h_isym)==h_isym, so the two forms are trivially identical
7635 : : ! regardless.) Verified end-to-end against check_symm.py: byte-for-byte identical results to
7636 : : ! the old conditional form -- 3584/3584 (100.0%) raw+gauge-invariant exact matches on
7637 : : ! gstore_brange 1 4 (max diff 3.66e-7, noise level), 3533/3584 (98.6%) raw==gauge-invariant on
7638 : : ! gstore_brange 1 2 (the residual there is the known, inherent out-of-range-degeneracy
7639 : : ! limitation of truncating the band range, not a bug). See gstore_symmetrize_status memory
7640 : : ! (sessions 14-15) for the full derivation history and this final unconditional-formula
7641 : : ! confirmation.
7642 : : ! TIME-REVERSAL generalization of itime_h (was hardcoded to 1, i.e. always the pure-spatial
7643 : : ! D-matrix slice). The unitary/antiunitary character of a composed operator is a Z2
7644 : : ! homomorphism (same rule dmats_check_one_k's group-multiplication test uses:
7645 : : ! itime3 = 1 + mod((itime1-1)+(itime2-1), 2), Bradley & Cracknell sec. 7.3), extended here
7646 : : ! by associativity to h's three-fold composition toinv(isym_kqT).isym_k.isym_kqS
7647 : : ! (itime(A^{-1}) = itime(A), so toinv(isym_kqT) contributes trev_kqT unchanged). High
7648 : : ! confidence, not yet empirically validated on a TR-nonzero system.
7649 : 0 : itime_h = 1 + mod(trev_k + trev_kqS + trev_kqT, 2)
7650 : :
7651 : : ! HYPOTHESIS (open question, validate empirically -- see gstore_symmetrize_status memory):
7652 : : ! phase_h_gs's lattice-vector phase is built from dmats%multable/toinv, which are
7653 : : ! itime-independent by construction, so its formula should carry over unchanged. But the
7654 : : ! closest validated analogue, dmats_get_star_dmats (m_classify_bands.F90), needs an EXTRA
7655 : : ! conjugation on its own analogous phase whenever itime==2. Applying the same pattern here
7656 : : ! as a first hypothesis; h's composition shape differs from that routine's, so this is not
7657 : : ! a proof, only a well-motivated starting point.
7658 : 0 : h_isym_inv = dmats%toinv(1, h_isym)
7659 [ # # ]: 0 : if (itime_h == 2) then
7660 [ # # # # : 0 : dh_mat = conjg(phase_h_gs) * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
# # # # #
# # # ]
7661 : : else
7662 [ # # # # : 0 : dh_mat = phase_h_gs * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
# # # # #
# # # ]
7663 : : end if
7664 : :
7665 : : ! HYPOTHESIS (open question, validate empirically): pulling D(h) through the outer operator
7666 : : ! that maps ikq_ibz -> kq_bz_target picks up a conjugate exactly when that operator
7667 : : ! (governed by isym_kqT/trev_kqT) is antiunitary -- a flag logically independent of trev_k
7668 : : ! (see 2.4's gtmp conjugation below) and of itime_h (which only selects WHICH tabulated
7669 : : ! matrix to read, not whether the whole assembled dh_mat needs conjugating on top).
7670 [ # # # # : 0 : if (trev_kqT == 1) dh_mat = conjg(dh_mat)
# # ]
7671 : :
7672 : : if (DEBUG_DUMP_DH) then
7673 : : 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, &
7674 : : 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, &
7675 : : qpt, kk_ibz
7676 : : write(790,*) ik_glob, iq_glob, nb, isym_k, h_isym, ikq_ibz_t, isym_kqS, isym_kqT, g0_q, &
7677 : : trev_k, trev_kqS, trev_kqT, itime_h, &
7678 : : real(phase_h_gs), aimag(phase_h_gs), real(phase_ket_gs), aimag(phase_ket_gs), &
7679 : : dmats%for_spin(spin)%value(:,:,h_isym,itime_h,ikq_ibz_t)
7680 : : end if
7681 : : ! -----------------------------------------------------------------
7682 : :
7683 : : ! Perform symmetrization.
7684 [ # # ]: 0 : do mu=1,gqk%natom3
7685 : 0 : idir = mod(mu-1, 3) + 1; iat = (mu - idir) / 3 + 1
7686 : :
7687 : 0 : iat_eq = cryst%indsym(4, isym_combined, iat)
7688 [ # # ]: 0 : l0 = cryst%indsym(1:3, isym_combined, iat)
7689 [ # # ]: 0 : phase = -two_pi * dot_product(qbz(:, iq_sym), l0)
7690 : 0 : cphase = cmplx(cos(phase), sin(phase), dp)
7691 : :
7692 : : ! Per-mu atomic-mapping/phase diagnostic (iat_eq, l0, symrec_eq row, cphase, iq_sym):
7693 : : ! reusable general-purpose dump, not tied to any specific (ik_glob,iq_glob) -- add a
7694 : : ! filter here (e.g. "if (ik_glob==... .and. iq_glob==...)") when tracing one point on a
7695 : : ! large system, to keep mu_debug.csv a manageable size.
7696 : : if (DEBUG_DUMP_DH) then
7697 : : write(792,*) ik_glob, iq_glob, mu, iat, iat_eq, isym_combined, isym_k, ik_ibz, iq_sym, &
7698 : : l0, symrec_eq(idir,1), symrec_eq(idir,2), symrec_eq(idir,3), idir, ik_ibz_file, cphase
7699 : : end if
7700 : :
7701 : : ! Apply the same geometric rotation (cphase/symrec_eq/dh_mat, all independent of which
7702 : : ! gvals stream is being processed) to each stream separately, since gtmp's accumulation
7703 : : ! reads actual matrix-element values from gkq_base.
7704 [ # # ]: 0 : do igv=1,n_gv
7705 [ # # # # ]: 0 : gtmp = zero
7706 [ # # ]: 0 : do idir_eq=1,3
7707 : 0 : mu_eq = idir_eq + (iat_eq - 1) * 3
7708 [ # # # # : 0 : gtmp = gtmp + cphase * symrec_eq(idir, idir_eq) * gkq_base(:,:,mu_eq,iq_sym,igv)
# # ]
7709 : : end do
7710 : : ! HYPOTHESIS (open question, validate empirically): conjugate gtmp before the dh_mat
7711 : : ! multiply whenever the ket leg's own operation (isym_k, trev_k) is antiunitary. Matches
7712 : : ! the "rotate spatially first, conjugate as the last step" pattern used identically by
7713 : : ! cgtk_rotate, pheigvec_rotate, rotate_fqg and dmats_init elsewhere in this codebase.
7714 : : ! Order matters: conjugate gtmp itself, not matmul(dh_mat,gtmp), since dh_mat is complex.
7715 [ # # # # : 0 : if (trev_k == 1) gtmp = conjg(gtmp)
# # ]
7716 : : ! Apply the Bug A correction: left-multiply by D(h) on the bra (m) index.
7717 [ # # # # : 0 : gkq_rot(:,:,mu,iq_glob,igv) = matmul(dh_mat, gtmp)
# # # # #
# # # # #
# # # # #
# # # #
# ]
7718 : 0 : if (DEBUG_DUMP_DH) write(791,*) ik_glob, iq_glob, mu, nb, trev_k, trim(gv_names(igv)), gtmp
7719 : : end do
7720 : : end do
7721 : :
7722 : : end do ! my_iq
7723 : :
7724 : : ! Write the newly computed g_{mn, nu} back to the netcdf file (in-place modification),
7725 : : ! for each gvals stream, and update the entry in state_kq.
7726 [ # # ]: 0 : do igv=1,n_gv
7727 [ # # ]: 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])
7728 : : ncerr = nf90_put_var(spin_ncid, spin_vid(gv_names(igv)), gkq_rot_ptr, &
7729 : : start=[1, 1, 1, 1, ik_glob, 1], &
7730 [ # # # # ]: 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7731 [ # # ]: 0 : NCF_CHECK(ncerr)
7732 : : end do
7733 [ # # ]: 0 : state_kq(ik_glob, :) = GSTORE_KQ_SYMMETRIZED
7734 : : end do ! my_ik
7735 : : end associate
7736 : :
7737 : : ! Update state_kq for this spin.
7738 [ # # ]: 0 : ncerr = nf90_put_var(ncid, vid("gstore_glob_state_kqs"), state_kq, start=[1,1,spin])
7739 [ # # ]: 0 : NCF_CHECK(ncerr)
7740 : :
7741 [ # # ]: 0 : ABI_FREE(qbz)
7742 [ # # ]: 0 : ABI_FREE(gkq_base)
7743 [ # # ]: 0 : ABI_FREE(gkq_rot)
7744 [ # # ]: 0 : ABI_FREE(state_kq)
7745 [ # # ]: 0 : ABI_FREE(gtmp)
7746 [ # # ]: 0 : ABI_FREE(dh_mat)
7747 [ # # ]: 0 : ABI_FREE(ket_mat)
7748 : : end do ! my_is
7749 : :
7750 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
7751 : : if (DEBUG_DUMP_DH) close(789)
7752 : : if (DEBUG_DUMP_DH) close(790)
7753 : : if (DEBUG_DUMP_DH) close(791)
7754 : : if (DEBUG_DUMP_DH) close(792)
7755 : :
7756 [ # # ]: 0 : ABI_FREE(kibz2bz)
7757 : 0 : call gstore%free()
7758 : :
7759 : 0 : 100 call dmats%free()
7760 : 0 : call xmpi_barrier(comm)
7761 [ # # # # : 0 : call wrtout(units, " Symmetrization completed successfully.")
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
7762 : :
7763 : : contains
7764 : 0 : integer function vid(var_name)
7765 : : character(len=*),intent(in) :: var_name
7766 : 0 : vid = nctk_idname(ncid, var_name)
7767 : : end function vid
7768 : :
7769 : 0 : integer function spin_vid(var_name)
7770 : : character(len=*),intent(in) :: var_name
7771 : 0 : spin_vid = nctk_idname(spin_ncid, var_name)
7772 : : end function spin_vid
7773 : :
7774 : : end subroutine gstore_symmetrize
7775 : : !!***
7776 : :
7777 [ - + - - : 78498 : end module m_gstore
+ + - + +
- - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - + ]
7778 : : !!***
|
