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 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_rpt"), ifc%rpt))
1237 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_wghatm"), ifc%wghatm))
1238 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_dynmat"), ifc%dynmat))
1239 [ - + ]: 8 : NCF_CHECK(nf90_put_var(ncid, vid("ifc_short_atmfrc"), ifc%short_atmfrc))
1240 : : end if
1241 : :
1242 [ - + ]: 8 : if (allocated(gstore%delta_ef_kibz_spin)) then
1243 [ # # ]: 0 : NCF_CHECK(nf90_put_var(ncid, vid("gstore_delta_ef_kibz_spin"), gstore%delta_ef_kibz_spin))
1244 : : end if
1245 : :
1246 [ + + ]: 16 : do spin=1,gstore%nsppol
1247 : : ! Create hdf group for this spin.
1248 [ - + ]: 8 : NCF_CHECK(nf90_def_grp(ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
1249 : :
1250 : : ! Dimensions in gqk_spin group
1251 : : ncerr = nctk_def_dims(spin_ncid, [ &
1252 : : nctkdim_t("nb_k", gstore%brange_k_spin(2, spin) - gstore%brange_k_spin(1, spin) + 1), &
1253 : : nctkdim_t("nb_kq", gstore%brange_kq_spin(2, spin) - gstore%brange_kq_spin(1, spin) + 1), &
1254 : : nctkdim_t("glob_nk", gstore%glob_nk_spin(spin)), &
1255 : : nctkdim_t("glob_nq", gstore%glob_nq_spin(spin)) &
1256 [ + + ]: 40 : ], defmode=.True.)
1257 [ - + ]: 8 : NCF_CHECK(ncerr)
1258 : :
1259 : : ! Define scalars
1260 [ + + ]: 24 : ncerr = nctk_def_iscalars(spin_ncid, [character(len=nctk_slen) :: "bstart_k", "bstart_kq"])
1261 [ - + ]: 8 : NCF_CHECK(ncerr)
1262 : :
1263 : : ! arrays in gqk_spin group with the precious stuff. Note global dimensions.
1264 : : ncerr = nctk_def_arrays(spin_ncid, [ &
1265 : : nctkarr_t("gvals", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq") &
1266 [ + + ]: 16 : ])
1267 [ - + ]: 8 : NCF_CHECK(ncerr)
1268 : :
1269 : : ! Compress gvals to reduce size on disk.
1270 : : !NCF_CHECK(nf90_def_var_deflate(spin_ncid, spin_vid("gvals"), shuffle=1, deflate=1, deflate_level=5))
1271 : :
1272 : : ! IMPORTANT: Init gvals with zeros.
1273 : : ! Default value for entries in gvals, vnk_cart_ibz and vnk_mat_cart_ibz arrays that have not been written.
1274 : : ! This can happen only if we have filtered wavevectors.
1275 : 8 : gstore_fill_dp = zero
1276 [ + + ]: 8 : if (gstore%kfilter == "none") gstore_fill_dp = -huge(one)
1277 [ - + ]: 8 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("gvals"), NF90_FILL, gstore_fill_dp))
1278 : :
1279 : : ! In GWPT gvals is used for g^Sigma so we declare another array to store g^KS.
1280 [ + + ]: 8 : if (dtset%eph_task == 17) then
1281 : : ncerr = nctk_def_arrays(spin_ncid, [ &
1282 : : nctkarr_t("gvals_ks", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq") &
1283 [ + + ]: 6 : ])
1284 [ - + ]: 3 : NCF_CHECK(ncerr)
1285 : : ! Compress gvals to reduce size on disk.
1286 : : !NCF_CHECK(nf90_def_var_deflate(spin_ncid, spin_vid("gvals_ks"), shuffle=1, deflate=1, deflate_level=5))
1287 [ - + ]: 3 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("gvals_ks"), NF90_FILL, gstore_fill_dp))
1288 : : end if
1289 : :
1290 : 16 : select case(gstore%with_vk)
1291 : : case (1)
1292 : : ! Diagonal terms only
1293 [ - + ]: 8 : NCF_CHECK(nctk_def_arrays(spin_ncid, nctkarr_t("vk_cart_ibz", "dp", "three, nb_k, gstore_nkibz")))
1294 [ - + ]: 8 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("vk_cart_ibz"), NF90_FILL, gstore_fill_dp))
1295 : :
1296 : : case (2)
1297 : : ! Full (nb_k x nb_k) matrix.
1298 [ # # ]: 0 : NCF_CHECK(nctk_def_arrays(spin_ncid, nctkarr_t("vnk_mat_cart_ibz", "dp", "two, three, nb_k, nb_k, gstore_nkibz")))
1299 [ + - - - : 8 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("vnk_mat_cart_ibz"), NF90_FILL, gstore_fill_dp))
- ]
1300 : : end select
1301 : :
1302 : : ! Write (small) data
1303 [ - + ]: 8 : NCF_CHECK(nctk_set_datamode(spin_ncid))
1304 [ - + ]: 8 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("bstart_k"), gstore%brange_k_spin(1, spin)))
1305 [ - + ]: 16 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("bstart_kq"), gstore%brange_kq_spin(1, spin)))
1306 : : end do ! spin
1307 : :
1308 [ - + ]: 8 : NCF_CHECK(nf90_close(ncid))
1309 : : end if ! master
1310 : :
1311 : : ! Make sure GSTORE.nc has been written by master.
1312 : 8 : call xmpi_barrier(gstore%comm)
1313 : :
1314 [ - + ]: 8 : ABI_FREE(wtk)
1315 [ - + ]: 8 : ABI_FREE(qibz2bz)
1316 [ - + ]: 8 : ABI_FREE(kibz2bz)
1317 [ - + ]: 8 : ABI_FREE(select_qbz_spin)
1318 [ - + ]: 8 : ABI_FREE(select_kbz_spin)
1319 [ - + ]: 8 : ABI_FREE(qglob2bz)
1320 [ - + ]: 8 : ABI_FREE(qbz2ibz)
1321 : :
1322 : 8 : call cwtime_report(" gstore_init:", cpu, wall, gflops)
1323 [ - + - + : 32 : call pstat_proc%print(_PSTAT_ARGS_)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + -
+ ]
1324 : :
1325 : : ! NOTE: When has_gwan is True, gqk%my_g/my_g2 have been allocated above (gqk_cplex) but are not
1326 : : ! filled here. The actual Wannier interpolation of the e-ph matrix elements is performed by the
1327 : : ! caller, gstore_init_or_from_ncpath, where with_gmode/gvals_name/with_g2dw are available.
1328 : :
1329 : : contains
1330 : 304 : integer function vid(var_name)
1331 : : character(len=*),intent(in) :: var_name
1332 : 304 : vid = nctk_idname(ncid, var_name)
1333 : : end function vid
1334 : 35 : integer function spin_vid(var_name)
1335 : : character(len=*),intent(in) :: var_name
1336 : 35 : spin_vid = nctk_idname(spin_ncid, var_name)
1337 : : end function spin_vid
1338 : :
1339 : : end subroutine gstore_init
1340 : : !!***
1341 : :
1342 : : !----------------------------------------------------------------------
1343 : :
1344 : : !!****f* m_gstore/gstore_init_or_from_ncpath
1345 : : !! NAME
1346 : : !! gstore_init_or_from_ncpath
1347 : : !!
1348 : : !! FUNCTION
1349 : : !! Build a gstore_t object either by reading a pre-existent GSTORE.nc file
1350 : : !! (getgstore_filepath) or, alternatively, by interpolating e-ph matrix elements
1351 : : !! on the fly from ABIWAN.nc + GWAN.nc (getabiwan_filepath + getgwan_filepath),
1352 : : !! e.g. on a k/q-mesh denser than the one used to compute the GWAN.nc file.
1353 : : !! In the latter case, no GSTORE.nc file is read or written: gqk%my_g is filled
1354 : : !! entirely in memory (see the has_gwan branch in gstore_init).
1355 : : !!
1356 : : !! from_file (output): set to .True. if gstore was built from a
1357 : : !! pre-existent GSTORE.nc file, .False. if built on the fly via Wannier
1358 : : !! interpolation. Callers can use this to report which path was taken.
1359 : : !!
1360 : : !! SOURCE
1361 : :
1362 : 16 : subroutine gstore_init_or_from_ncpath(gstore, with_cplex, dtset, dtfil, wfk0_hdr, cryst, ebands, ifc, &
1363 : : with_gmode, gvals_name, with_g2dw, comm, from_file)
1364 : :
1365 : : !Arguments ------------------------------------
1366 : : !scalars
1367 : : class(gstore_t),target,intent(out) :: gstore
1368 : : integer,intent(in) :: with_cplex
1369 : : type(dataset_type),target,intent(in) :: dtset
1370 : : type(datafiles_type),intent(in) :: dtfil
1371 : : type(hdr_type),intent(in) :: wfk0_hdr
1372 : : class(crystal_t),target,intent(in) :: cryst
1373 : : class(ebands_t),target,intent(in) :: ebands
1374 : : class(ifc_type),target,intent(in) :: ifc
1375 : : character(len=*),intent(in) :: with_gmode, gvals_name
1376 : : logical,intent(in) :: with_g2dw
1377 : : integer,intent(in) :: comm
1378 : : logical,intent(out) :: from_file
1379 : :
1380 : : !Local variables-------------------------------
1381 : : !scalars
1382 : : integer :: natom, natom3, spin, my_is, my_ik, my_iq, iq_ibz, isym_q, trev_q, ipc, nu, nwan, ierr
1383 : : integer :: ik_start, ik_stop, ikb, nkb, nk_batch
1384 : : real(dp) :: weight_q, cpu, wall, gflops
1385 : : character(len=500) :: msg
1386 : : character(len=fnlen) :: gstore_path
1387 : : type(gqk_t),pointer :: gqk
1388 : : !arrays
1389 : : real(dp) :: qpt(3)
1390 : 16 : real(dp),allocatable :: phfrq_ibz(:,:), displ_cart_dum(:,:,:,:), gatm_real(:,:,:,:), gnu_real(:,:,:,:)
1391 : 16 : real(dp),allocatable :: eigvec_ibz(:,:,:,:,:), eigvec_qbz(:,:,:,:), displ_cart_qbz(:,:,:,:), displ_red_qbz(:,:,:,:)
1392 [ + - ]: 16 : complex(dp),allocatable :: intp_gatm(:,:,:,:), gatm_full(:,:,:,:), g_req(:,:,:,:)
1393 : : !----------------------------------------------------------------------
1394 : :
1395 [ + - ]: 16 : if (dtfil%filgstorein /= ABI_NOFILE) then
1396 : : call gstore%from_ncpath(dtfil%filgstorein, with_cplex, dtset, dtfil, cryst, ebands, ifc, &
1397 : 16 : with_gmode, gvals_name, with_g2dw, comm)
1398 : 16 : from_file = .True.
1399 : :
1400 [ # # # # ]: 0 : else if (dtfil%filabiwanin /= ABI_NOFILE .and. dtfil%filgwanin /= ABI_NOFILE) then
1401 : : ! Build gstore on the fly via Wannier interpolation from ABIWAN.nc + GWAN.nc.
1402 : 0 : call cwtime(cpu, wall, gflops, "start")
1403 : : ! with_cplex=0 prepares the Wannier interpolator and gstore metadata without materializing g(k,q).
1404 : : ! with_cplex=1/2 stores |g|^2/complex g, respectively. Debye-Waller and gvals_ks are unsupported.
1405 [ # # ]: 0 : msg = sjoin("Invalid with_cplex:", itoa(with_cplex), "only 0, 1 or 2 are supported")
1406 [ # # ]: 0 : ABI_CHECK(with_cplex >= 0 .and. with_cplex <= 2, msg)
1407 [ # # ]: 0 : if (with_g2dw) then
1408 : 0 : ABI_ERROR("with_g2dw = .True. is not yet supported when building gstore via Wannier interpolation (ABIWAN.nc + GWAN.nc)")
1409 : : end if
1410 [ # # ]: 0 : if (gvals_name == "gvals_ks") then
1411 : 0 : ABI_ERROR("gvals_name = 'gvals_ks' is not supported when building gstore via Wannier interpolation (ABIWAN.nc + GWAN.nc)")
1412 : : end if
1413 [ # # ]: 0 : if (with_gmode /= GSTORE_GMODE_PHONON) then
1414 : 0 : ABI_ERROR(sjoin("with_gmode:", with_gmode, "is not yet supported when building gstore via Wannier"))
1415 : : end if
1416 : :
1417 [ # # ]: 0 : gstore_path = strcat(dtfil%filnam_ds(4), "_GSTORE.nc")
1418 : 0 : call gstore%init(gstore_path, dtset, dtfil, wfk0_hdr, cryst, ebands, ifc, comm, with_cplex=with_cplex)
1419 : :
1420 [ # # ]: 0 : if (with_cplex == 0) then
1421 [ # # ]: 0 : call wrtout([std_out, ab_out], " Preparing on-demand Wannier interpolation of e-ph matrix elements ...", pre_newlines=1)
1422 : : else
1423 [ # # ]: 0 : call wrtout([std_out, ab_out], " Using Wannier interpolation to compute and store e-ph matrix elements ...", pre_newlines=1)
1424 : : end if
1425 : 0 : from_file = .False.
1426 : 0 : natom = cryst%natom; natom3 = 3 * natom
1427 : :
1428 : : ! Precompute phonon frequencies/eigenvectors in the IBZ once (spin-independent).
1429 : : ! NB: The phonon eigenvector gauge must be fixed from a single IBZ representative + symmetry
1430 : : ! rotation (pheigvec_rotate), exactly as done when g(k,q) is read from a pre-existent GSTORE.nc
1431 : : ! file (see gstore_from_ncpath). Calling ifc%fourq directly at each interpolated BZ q would give
1432 : : ! an independently-diagonalized (and hence potentially differently gauged) eigenbasis for
1433 : : ! degenerate modes and would break the e(-q) = e(q)^* convention used elsewhere in the code.
1434 [ # # # # : 0 : ABI_MALLOC(phfrq_ibz, (natom3, gstore%nqibz))
# # # # #
# # # # #
# # ]
1435 [ # # # # : 0 : ABI_MALLOC(eigvec_ibz, (2, 3, natom, natom3, gstore%nqibz))
# # # # #
# # # # #
# # # # #
# ]
1436 [ # # # # : 0 : ABI_MALLOC(displ_cart_dum, (2, 3, natom, natom3))
# # # # #
# # # # #
# # ]
1437 [ # # ]: 0 : do iq_ibz=1,gstore%nqibz
1438 : : call ifc%fourq(cryst, gstore%qibz(:,iq_ibz), phfrq_ibz(:,iq_ibz), displ_cart_dum, &
1439 : 0 : out_eigvec=eigvec_ibz(:,:,:,:,iq_ibz))
1440 : : end do
1441 [ # # ]: 0 : ABI_FREE(displ_cart_dum)
1442 : :
1443 [ # # # # : 0 : ABI_MALLOC(eigvec_qbz, (2, 3, natom, natom3))
# # # # #
# # # # #
# # ]
1444 [ # # # # : 0 : ABI_MALLOC(displ_cart_qbz, (2, 3, natom, natom3))
# # # # #
# # # ]
1445 [ # # # # : 0 : ABI_MALLOC(displ_red_qbz, (2, 3, natom, natom3))
# # # # #
# # # ]
1446 : :
1447 : : ! Interpolate g(k,q) and store data in memory.
1448 [ # # ]: 0 : do my_is=1,gstore%my_nspins
1449 : 0 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is); nwan = gqk%nb_k
1450 : :
1451 : : ! Build gqk%wan for this spin from the ABIWAN.nc file and load g(R_e, R_p) from GWAN.nc.
1452 : 0 : call gqk%wan%from_abiwan(dtfil%filabiwanin, spin, gstore%nsppol, .False., "", gqk%comm%value)
1453 : 0 : gqk%wan%my_pert_start = gqk%my_pert_start; gqk%wan%my_npert = gqk%my_npert; gqk%wan%pert_comm => gqk%pert_comm
1454 : 0 : call gqk%wan%load_gwan(dtfil%filgwanin, cryst, spin, gstore%nsppol, gqk%comm)
1455 : :
1456 [ # # # # : 0 : ABI_MALLOC(gqk%my_wnuq, (gqk%my_npert, gqk%my_nq))
# # # # #
# # # # #
# # # # ]
1457 [ # # # # : 0 : ABI_MALLOC(gqk%my_displ_cart, (2, 3, natom, gqk%my_npert, gqk%my_nq))
# # # # #
# # # # #
# # # # #
# # # ]
1458 : :
1459 [ # # ]: 0 : if (with_cplex > 0) then
1460 : : ! Bound the two temporary complex atomic-vertex arrays to the default
1461 : : ! 64 MiB workspace. The low-level selector also accepts a custom limit.
1462 : 0 : nk_batch = gqk%wan%eph_kbatch_size(gqk%my_nk, natom3)
1463 [ # # # # : 0 : ABI_MALLOC(intp_gatm, (nwan, nwan, gqk%my_npert, nk_batch))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1464 [ # # # # : 0 : ABI_MALLOC(gatm_full, (nwan, nwan, natom3, nk_batch))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1465 [ # # # # : 0 : ABI_MALLOC(g_req, (gqk%wan%nr_e, nwan, nwan, gqk%my_npert))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1466 [ # # # # : 0 : ABI_MALLOC(gatm_real, (2, nwan, nwan, natom3))
# # # # #
# # # # #
# # # # #
# # # ]
1467 [ # # # # : 0 : ABI_MALLOC(gnu_real, (2, nwan, nwan, natom3))
# # # # #
# # # # #
# # # # ]
1468 : : end if
1469 : :
1470 [ # # ]: 0 : do my_iq=1,gqk%my_nq
1471 : 0 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
1472 : 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)
1473 : :
1474 : : ! Rotate the phonon eigenvector from the IBZ to this BZ q-point (fixes the gauge).
1475 : : call pheigvec_rotate(cryst, gstore%qibz(:,iq_ibz), isym_q, trev_q, eigvec_ibz(:,:,:,:,iq_ibz), &
1476 : 0 : eigvec_qbz, displ_cart_qbz, displ_red_qbz=displ_red_qbz)
1477 : :
1478 : : ! Fill my arrays with ph data.
1479 [ # # # # : 0 : gqk%my_wnuq(:,my_iq) = phfrq_ibz(gqk%my_pertcases(:), iq_ibz)
# # ]
1480 [ # # # # : 0 : gqk%my_displ_cart(:,:,:,:,my_iq) = displ_cart_qbz(:,:,:,gqk%my_pertcases(:))
# # # # #
# ]
1481 : :
1482 [ # # ]: 0 : if (with_cplex == 0) cycle
1483 : :
1484 : : ! The R_p -> q transform is independent of k and is reused by every
1485 : : ! bounded k block below.
1486 : 0 : call gqk%wan%prepare_eph_q(qpt, g_req)
1487 : :
1488 [ # # # # : 0 : do ik_start=1,gqk%my_nk,nk_batch
# # # # ]
1489 : 0 : ik_stop = min(gqk%my_nk, ik_start + nk_batch - 1); nkb = ik_stop - ik_start + 1
1490 : :
1491 : : call gqk%wan%interp_eph_manyk_from_q(cryst, nkb, gqk%my_kpts(:,ik_start:ik_stop), qpt, &
1492 : 0 : g_req, intp_gatm(:,:,:,1:nkb))
1493 : :
1494 : : ! Complete all atomic perturbations for the block with one collective
1495 : : ! instead of one pert_comm reduction per k point.
1496 [ # # # # : 0 : gatm_full(:,:,:,1:nkb) = czero
# # # # ]
1497 [ # # ]: 0 : do ikb=1,nkb
1498 [ # # ]: 0 : do ipc=1,gqk%my_npert
1499 [ # # # # ]: 0 : gatm_full(:,:,gqk%my_pertcases(ipc),ikb) = intp_gatm(:,:,ipc,ikb)
1500 : : end do
1501 : : end do
1502 [ # # ]: 0 : if (gqk%pert_comm%nproc > 1) call xmpi_sum(gatm_full(:,:,:,1:nkb), gqk%pert_comm%value, ierr)
1503 : :
1504 [ # # ]: 0 : do ikb=1,nkb
1505 : 0 : my_ik = ik_start + ikb - 1
1506 [ # # # # : 0 : gatm_real(1,:,:,:) = real(gatm_full(:,:,:,ikb), kind=dp)
# # ]
1507 [ # # # # : 0 : gatm_real(2,:,:,:) = aimag(gatm_full(:,:,:,ikb))
# # ]
1508 : 0 : call ephtk_gkknu_from_atm(nwan, nwan, 1, natom, gatm_real, phfrq_ibz(:,iq_ibz), displ_red_qbz, gnu_real)
1509 : :
1510 [ # # ]: 0 : do ipc=1,gqk%my_npert
1511 : 0 : nu = gqk%my_pertcases(ipc)
1512 [ # # ]: 0 : if (with_cplex == 2) then
1513 [ # # # # ]: 0 : gqk%my_g(ipc,:,my_iq,:,my_ik) = gnu_real(1,:,:,nu) + j_dpc * gnu_real(2,:,:,nu)
1514 : : else
1515 [ # # # # ]: 0 : gqk%my_g2(ipc,:,my_iq,:,my_ik) = gnu_real(1,:,:,nu)**2 + gnu_real(2,:,:,nu)**2
1516 : : end if
1517 : : end do
1518 : : end do ! ikb
1519 : : end do ! ik_start
1520 : : end do ! my_iq
1521 : :
1522 [ # # ]: 0 : if (with_cplex > 0) then
1523 [ # # ]: 0 : ABI_FREE(intp_gatm)
1524 [ # # ]: 0 : ABI_FREE(gatm_full)
1525 [ # # ]: 0 : ABI_FREE(g_req)
1526 [ # # ]: 0 : ABI_FREE(gatm_real)
1527 [ # # ]: 0 : ABI_FREE(gnu_real)
1528 : : end if
1529 : : end do ! my_is
1530 : :
1531 [ # # ]: 0 : ABI_FREE(phfrq_ibz)
1532 [ # # ]: 0 : ABI_FREE(eigvec_ibz)
1533 [ # # ]: 0 : ABI_FREE(eigvec_qbz)
1534 [ # # ]: 0 : ABI_FREE(displ_cart_qbz)
1535 [ # # ]: 0 : ABI_FREE(displ_red_qbz)
1536 : :
1537 : : ! We interpolated (and converted to) the phonon representation.
1538 : 0 : gstore%gmode = GSTORE_GMODE_PHONON
1539 : 0 : call cwtime_report(" Wannier interpolation of GSTORE matrix elements", cpu, wall, gflops)
1540 : :
1541 : : else
1542 : : write(msg, "(3a)") &
1543 : 0 : "Cannot build gstore object: either getgstore_filepath or both ", &
1544 : 0 : "getabiwan_filepath and getgwan_filepath must be provided in the input file.", ch10
1545 : 0 : ABI_ERROR(msg)
1546 : : end if
1547 : :
1548 [ - + - + : 16 : end subroutine gstore_init_or_from_ncpath
- + - + -
+ ]
1549 : : !!***
1550 : :
1551 : : !----------------------------------------------------------------------
1552 : :
1553 : 0 : logical function gstore_has_matrix_elements(gstore) result(has_g)
1554 : :
1555 : : class(gstore_t),intent(in) :: gstore
1556 : :
1557 : 0 : has_g = gstore%with_cplex > 0
1558 : :
1559 : 0 : end function gstore_has_matrix_elements
1560 : :
1561 : : !----------------------------------------------------------------------
1562 : :
1563 : 0 : logical function gstore_has_complex_matrix_elements(gstore) result(has_complex_g)
1564 : :
1565 : : class(gstore_t),intent(in) :: gstore
1566 : :
1567 : 0 : has_complex_g = gstore%with_cplex == 2
1568 : :
1569 : 0 : end function gstore_has_complex_matrix_elements
1570 : :
1571 : : !----------------------------------------------------------------------
1572 : :
1573 : : !!****f* m_gstore/gstore_same_nbands
1574 : : !! NAME
1575 : : !! gstore_same_nbands
1576 : : !!
1577 : : !! FUNCTION
1578 : : !! True if nb_k == nb_kq.
1579 : : !!
1580 : : !! SOURCE
1581 : :
1582 : 9 : logical function gstore_same_nbands(gstore, msg) result(same)
1583 : :
1584 : : class(gstore_t),intent(in) :: gstore
1585 : : character(len=*),intent(out) :: msg
1586 : :
1587 : : !Local variables-------------------------------
1588 : : integer :: my_is
1589 : : !----------------------------------------------------------------------
1590 : :
1591 : 9 : same = .True.; msg = ""
1592 [ + + ]: 18 : do my_is=1,gstore%my_nspins
1593 : 9 : associate (gqk => gstore%gqk(my_is))
1594 [ - + ]: 9 : if (gqk%nb_k /= gqk%nb_kq) then
1595 [ # # # # ]: 0 : same = .False.; msg = sjoin("gstore has different nb_kq, nb_k", itoa(gqk%nb_kq), itoa(gqk%nb_k))
1596 : : end if
1597 : : end associate
1598 : : end do
1599 : :
1600 [ + - ]: 9 : end function gstore_same_nbands
1601 : : !!***
1602 : :
1603 : : !----------------------------------------------------------------------
1604 : :
1605 : : !!****f* m_gstore/gstore_distribute_spins
1606 : : !! NAME
1607 : : !! gstore_distribute_spins
1608 : : !!
1609 : : !! FUNCTION
1610 : : !! Distribute spins. Also create and return indirect mapping to spin index and init %brange_k_spin
1611 : : !!
1612 : : !! INPUTS
1613 : : !!
1614 : : !! OUTPUT
1615 : : !!
1616 : : !! NOTES
1617 : : !! What works:
1618 : : !!
1619 : : !! - Setting gstore_kfilter = "qprange" works.
1620 : : !! With this, bands (nb_k) and k-points are automatically filtered, including only the VBM and CBM.
1621 : : !! This is useful for calculating the ZPR of the fundamental gap.
1622 : : !! Manual specification of bands (nb_k) and k-points also works by setting gstore_kfilter = "none" (default)
1623 : : !! and providing the values via kptgw and bdgw.
1624 : : !!
1625 : : !! What does not work:
1626 : : !!
1627 : : !! - There is currently no effective way to control nb_kq directly.
1628 : : !! The only workaround is using gstore_brange. For example, gstore_brange = '1, 8' sets nb_k = nb_kq = 8.
1629 : : !! However, gstore_brange has the lowest priority: if gstore_kfilter
1630 : : !! is set or kptgw/bdgw are provided, gstore_brange is ignored and nb_kq defaults to nband.
1631 : : !!
1632 : : !! Notes on use cases:
1633 : : !! For ZPR calculations, the current schemes are sufficient.
1634 : : !! For tasks comparing g between GWPT and FD, the current schemes are not very convenient.
1635 : : !! For instance, to compare g at k=q=Gamma for the first 8 bands of diamond,
1636 : : !! ideally we would restrict the calculation to nb_k = nb_kq = {1..8} and k=q=Gamma. But currently
1637 : : !!
1638 : : !! Using gstore_brange triggers unnecessary k-point calculations (ngkpt is usually a dense k-grid).
1639 : : !!
1640 : : !! Using kptgw and bdgw triggers unnecessary band calculations (nb_kq = nband is usually a big number).
1641 : : !!
1642 : : !! Potential improvement (?):
1643 : : !! Maybe we could give gstore_brange higher priority to control nb_kq(?). To avoid conflicts:
1644 : : !! If gstore_brange is provided and gstore_kfilter = "none", we do
1645 : : !! bstart_k = bdgw[1], nb_k = min(nband, bdgw[2] - bdgw[1])
1646 : : !! bstart_kq = gstore_brange[1], nb_kq = min(nband, gstore_brange[2] - gstore_brange[1])
1647 : : !! If gstore_brange is NOT provided and gstore_kfilter = "none", we do
1648 : : !! bstart_kq = bstart_k = bdgw[1], nb_kq = nb_k = max(nband, bdgw[2] - bdgw[1])
1649 : : !!
1650 : : !! SOURCE
1651 : :
1652 : 24 : subroutine gstore_distribute_spins(gstore, mband, brange_kq, brange_k, nproc_spin, comm_spin, comm)
1653 : :
1654 : : !Arguments ------------------------------------
1655 : : !scalars
1656 : : class(gstore_t),target,intent(inout) :: gstore
1657 : : integer,intent(in) :: mband, comm, brange_kq(2, gstore%nsppol), brange_k(2, gstore%nsppol)
1658 : : integer,intent(out) :: nproc_spin(gstore%nsppol), comm_spin(gstore%nsppol)
1659 : :
1660 : : !Local variables-------------------------------
1661 : : !scalars
1662 : : integer :: spin, my_rank, ierr, color, nsppol, nprocs
1663 : : !arrays
1664 : : integer :: buff_spin(2)
1665 : : !----------------------------------------------------------------------
1666 : :
1667 : 24 : nprocs = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
1668 : 24 : nsppol = gstore%nsppol
1669 : :
1670 : 24 : gstore%my_nspins = 0
1671 [ - + + - : 72 : ABI_MALLOC(gstore%brange_k_spin, (2, nsppol))
+ - + - -
+ - + -
+ ]
1672 [ - + + - : 48 : ABI_MALLOC(gstore%brange_kq_spin, (2, nsppol))
- + - + -
+ ]
1673 : :
1674 [ + + ]: 48 : do spin=1,nsppol
1675 : : ! NB: If MPI_UNDEFINED is passed as the colour value, the subgroup in which
1676 : : ! the calling MPI process will be placed is MPI_COMM_NULL
1677 : 24 : color = 1
1678 [ - + ]: 24 : if (nsppol == 2 .and. nprocs > 1) then
1679 : 0 : color = xmpi_undefined
1680 [ # # # # ]: 0 : if (spin == 1 .and. my_rank <= (nprocs - 1) / 2) color = 1
1681 [ # # # # ]: 0 : if (spin == 2 .and. my_rank > (nprocs - 1) / 2) color = 1
1682 : : end if
1683 : :
1684 : 24 : call xmpi_comm_split(comm, color, my_rank, comm_spin(spin), ierr)
1685 [ + - ]: 24 : if (comm_spin(spin) /= xmpi_comm_null) then
1686 : 24 : gstore%my_nspins = gstore%my_nspins + 1
1687 : 24 : buff_spin(gstore%my_nspins) = spin
1688 : : end if
1689 : :
1690 : 24 : nproc_spin(spin) = xmpi_comm_size(comm_spin(spin))
1691 : :
1692 : : ! Default values for brange at k, k+q from mband
1693 [ + + ]: 72 : gstore%brange_k_spin(:, spin) = [1, mband]
1694 [ + + ]: 72 : gstore%brange_kq_spin(:, spin) = [1, mband]
1695 : :
1696 : : ! Optionally take values from input brange_k, brange_kq
1697 [ + + + + : 139 : if (all(brange_k /= 0)) gstore%brange_k_spin(:, spin) = brange_k(:, spin)
+ + + + +
+ ]
1698 [ + + + + : 139 : if (all(brange_kq /= 0)) gstore%brange_kq_spin(:, spin) = brange_kq(:, spin)
+ + + + +
+ ]
1699 : :
1700 : : ! Validate against input mband.
1701 [ + - - + ]: 24 : ABI_CHECK_IRANGE(gstore%brange_k_spin(1, spin), 1, mband, "brange_k(1, spin)")
1702 [ + - - + ]: 24 : ABI_CHECK_IRANGE(gstore%brange_k_spin(2, spin), 1, mband, "brange_k(2, spin)")
1703 [ - + ]: 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)")
1704 : :
1705 [ + - - + ]: 24 : ABI_CHECK_IRANGE(gstore%brange_kq_spin(1, spin), 1, mband, "brange_k(1, spin)")
1706 [ + - - + ]: 24 : ABI_CHECK_IRANGE(gstore%brange_kq_spin(2, spin), 1, mband, "brange_k(2, spin)")
1707 [ - + ]: 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)")
1708 : : end do
1709 : :
1710 [ - + + - : 72 : ABI_MALLOC(gstore%my_spins, (gstore%my_nspins))
+ - + - -
+ - + -
+ ]
1711 [ - + + + ]: 72 : gstore%my_spins = buff_spin(1:gstore%my_nspins)
1712 [ - + + - : 384 : ABI_MALLOC(gstore%gqk, (gstore%my_nspins))
+ - + - -
+ - + - +
+ + + + +
+ + + ]
1713 : :
1714 : 24 : end subroutine gstore_distribute_spins
1715 : : !!***
1716 : :
1717 : : !----------------------------------------------------------------------
1718 : :
1719 : : !!****f* m_gstore/gstore_set_mpi_grid__
1720 : : !! NAME
1721 : : !! gstore_set_mpi_grid__
1722 : : !!
1723 : : !! FUNCTION
1724 : : !!
1725 : : !! INPUTS
1726 : : !!
1727 : : !! OUTPUT
1728 : : !!
1729 : : !! SOURCE
1730 : :
1731 : 24 : subroutine gstore_set_mpi_grid__(gstore, dtfil, nproc_spin, comm_spin)
1732 : :
1733 : : !Arguments ------------------------------------
1734 : : !scalars
1735 : : class(gstore_t),target,intent(inout) :: gstore
1736 : : type(datafiles_type),intent(in) :: dtfil
1737 : : integer,intent(in) :: nproc_spin(gstore%nsppol)
1738 : : integer,intent(inout) :: comm_spin(gstore%nsppol)
1739 : : !Local variables-------------------------------
1740 : : !scalars
1741 : : integer,parameter :: master = 0
1742 : : integer :: spin, my_is, np, my_rank, ierr, npp_bz, units(2), bstart_k, bstop_k, nb_k, bstart_kq, bstop_kq, nb_kq
1743 : : integer :: comm_cart, me_cart, dims(ndims)
1744 : : type(gqk_t),pointer :: gqk
1745 : : character(len=5000) :: msg
1746 : : character(len=10) :: order, priority
1747 : : character(len=fnlen) :: screen_filepath
1748 : : logical :: reorder, periods(ndims), keepdim(ndims)
1749 [ + + + + ]: 312 : type(kmesh_t) :: pp_mesh
1750 : 24 : type(gsphere_t) :: gsph_c
1751 : 24 : real(dp),allocatable :: qlwl(:,:)
1752 [ + + ]: 96 : type(hscr_t),target :: hscr
1753 : : !----------------------------------------------------------------------
1754 : :
1755 [ + + ]: 72 : units = [std_out, ab_out]
1756 : :
1757 : : associate (dtset => gstore%dtset)
1758 : 48 : my_rank = xmpi_comm_rank(gstore%comm)
1759 : :
1760 [ + + ]: 48 : do my_is=1,gstore%my_nspins
1761 : 24 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is)
1762 : 24 : gqk%spin = spin; gqk%natom3 = 3 * gstore%cryst%natom; gqk%cplex = 2
1763 : :
1764 : : ! Compute bstart_k and nb_k for this spin.
1765 : 24 : bstart_k = gstore%brange_k_spin(1, spin)
1766 : 24 : bstop_k = gstore%brange_k_spin(2, spin)
1767 : 24 : nb_k = gstore%brange_k_spin(2, spin) - gstore%brange_k_spin(1, spin) + 1
1768 : :
1769 : : ! Compute bstart_kq and nb_kq for this spin.
1770 : 24 : bstart_kq = gstore%brange_kq_spin(1, spin)
1771 : 24 : bstop_kq = gstore%brange_kq_spin(2, spin)
1772 : 24 : nb_kq = gstore%brange_kq_spin(2, spin) - gstore%brange_kq_spin(1, spin) + 1
1773 : :
1774 : : ! Here we set nb_k and nb_kq
1775 : 24 : gqk%nb_k = nb_k; gqk%bstart_k = bstart_k; gqk%bstop_k = bstop_k
1776 : 24 : gqk%nb_kq = nb_kq; gqk%bstart_kq = bstart_kq; gqk%bstop_kq = bstop_kq
1777 : :
1778 : : ! Store global shape of the q/k matrix for this spin.
1779 : 24 : gqk%glob_nq = gstore%glob_nq_spin(spin)
1780 : 48 : gqk%glob_nk = gstore%glob_nk_spin(spin)
1781 : : end do
1782 : :
1783 [ + + ]: 48 : do my_is=1,gstore%my_nspins
1784 : 24 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is)
1785 : :
1786 : : ! Init for sequential execution.
1787 : 24 : gqk%my_npert = gqk%natom3
1788 : 24 : gqk%qpt_comm%nproc = 1; gqk%kpt_comm%nproc = 1; gqk%pert_comm%nproc = 1; gqk%band_comm%nproc = 1
1789 : : ! NB: The communicators below are only used in GWPT.
1790 : 24 : gqk%bsum_comm%nproc = 1; gqk%pp_sum_comm%nproc = 1
1791 : :
1792 : 24 : np = nproc_spin(spin)
1793 : :
1794 [ + + ]: 24 : if (dtset%eph_task /= 17) then
1795 : : ! =============================
1796 : : ! For all eph_tasks except GWPT
1797 : : ! =============================
1798 : :
1799 [ + + + - : 126 : if (any(dtset%eph_np_pqbks /= 0)) then
- + ]
1800 : : ! Use parameters from input file. Need to perform sanity check though.
1801 : 0 : gqk%pert_comm%nproc = dtset%eph_np_pqbks(1)
1802 : 0 : gqk%qpt_comm%nproc = dtset%eph_np_pqbks(2)
1803 : 0 : gqk%band_comm%nproc = dtset%eph_np_pqbks(3)
1804 [ # # ]: 0 : ABI_CHECK(dtset%eph_np_pqbks(3) == 1, "Band parallelism not yet implemented in gstore")
1805 : 0 : gqk%kpt_comm%nproc = dtset%eph_np_pqbks(4)
1806 : : !gqk%spin_comm%nproc = dtset%eph_np_pqbks(5)
1807 : 0 : gqk%my_npert = gqk%natom3 / gqk%pert_comm%nproc
1808 [ # # ]: 0 : ABI_CHECK(gqk%my_npert > 0, "pert_comm_nproc cannot be greater than 3*natom.")
1809 [ # # ]: 0 : ABI_CHECK(mod(gqk%natom3, gqk%pert_comm%nproc) == 0, "pert_comm_nproc must divide 3*natom.")
1810 : :
1811 : : else
1812 : : ! Automatic grid generation (hopefully smart)
1813 : : ! Keep in mind that in gstore_compute, the first loop is over q-points
1814 : : ! in order to reduce the number of interpolations of the DFPT potentials in q-space
1815 : : ! hence the q-point parallelism is expected to be more efficient.
1816 : : ! On the other hand, the k-point parallelism and the perturbation parallelism
1817 : : ! allow one to reduce the memory requirements associated to the wavefunctions (kpt) and
1818 : : ! the scattering potentials in the supercell (perturbations).
1819 : : ! Here we try to optimize performance but it's clear that for large systems the user
1820 : : ! should specify dtset%eph_np_pqbks in the input file.
1821 : :
1822 : 5 : select case (dtset%eph_task)
1823 : : case (11)
1824 : 5 : priority = "qk"
1825 : : case (12, -12)
1826 : 0 : priority = "q"
1827 : : case (13)
1828 : 9 : priority = "q"
1829 : : case (14, 17)
1830 : 0 : priority = "kq"
1831 : : case (24)
1832 : 7 : priority = "qk"
1833 : : case default
1834 [ + - + - : 21 : ABI_ERROR(sjoin("Please register default priority for eph_task:", itoa(dtset%eph_task)))
+ - ]
1835 : : end select
1836 : :
1837 : 9 : select case (priority)
1838 : : case ("q")
1839 : 9 : order = "1"
1840 : : case ("k")
1841 : 0 : order = "2"
1842 : : case ("kq")
1843 : 0 : order = "21"
1844 : : case ("qk")
1845 : 12 : order = "12"
1846 : : case default
1847 [ + - - + : 21 : ABI_ERROR(sjoin("Wrong priority:", priority))
- ]
1848 : : end select
1849 : :
1850 [ + + ]: 21 : if (gqk%glob_nk == 1) order = "21"
1851 [ - + ]: 21 : if (gqk%glob_nq == 1) order = "12"
1852 : 21 : call xmpi_distrib_2d(np, order, gqk%glob_nq, gqk%glob_nk, gqk%qpt_comm%nproc, gqk%kpt_comm%nproc, ierr)
1853 [ - + ]: 21 : ABI_CHECK(ierr == 0, sjoin("Cannot distribute nprocs:", itoa(np), " with priority: ", priority))
1854 : : end if
1855 : :
1856 : : else if (dtset%eph_task == 17) then
1857 : : ! =========================
1858 : : ! MPI distribution for GWPT
1859 : : ! =========================
1860 : :
1861 [ + + + - : 21 : if (any(dtset%gwpt_np_wpqbks /= 0)) then
- + ]
1862 : : ! Use parameters from input file. Need to perform sanity check though.
1863 : 0 : gqk%pp_sum_comm%nproc = dtset%gwpt_np_wpqbks(1)
1864 : 0 : gqk%pert_comm%nproc = dtset%gwpt_np_wpqbks(2)
1865 : 0 : gqk%qpt_comm%nproc = dtset%gwpt_np_wpqbks(3)
1866 : 0 : gqk%bsum_comm%nproc = dtset%gwpt_np_wpqbks(4)
1867 : 0 : gqk%kpt_comm%nproc = dtset%gwpt_np_wpqbks(5)
1868 : : !gqk%spin_comm%nproc = dtset%gwpt_np_wpqbks(6)
1869 : 0 : gqk%my_npert = gqk%natom3 / gqk%pert_comm%nproc
1870 [ # # ]: 0 : ABI_CHECK(gqk%my_npert > 0, "pert_comm_nproc cannot be greater than 3*natom.")
1871 [ # # ]: 0 : ABI_CHECK(mod(gqk%natom3, gqk%pert_comm%nproc) == 0, "pert_comm_nproc must divide 3*natom.")
1872 : :
1873 : : else
1874 : : ! Automatic grid generation for GWPT (hopefully smart)
1875 : :
1876 : : ! In GWPT, the loop over pp-wavevectors is always in the BZ and is expected to be the most efficient
1877 : : ! Note however that the p-mesh is not necessarly equal to the k-mesh hence we have to read it from the SCR file.
1878 : : !npp_bz = product(get_diag(gstore%dtset%kptrlatt))
1879 : :
1880 : 3 : screen_filepath = dtfil%fnameabi_scr
1881 [ - + ]: 3 : ABI_CHECK(dtfil%fnameabi_scr /= ABI_NOFILE, "SCR file must be specified")
1882 [ - + ]: 3 : call get_hscr_qmesh_gsph(screen_filepath, gstore%dtset, gstore%cryst, hscr, pp_mesh, gsph_c, qlwl, comm_spin(spin))
1883 : 3 : npp_bz = pp_mesh%nbz
1884 : 3 : call hscr%free(); call pp_mesh%free(); call gsph_c%free()
1885 [ + - ]: 3 : ABI_SFREE(qlwl)
1886 : :
1887 [ + - ]: 3 : if (np <= npp_bz * gqk%natom3) then
1888 : : ! "Small" np. Give higher priority to npp_bz and then perturbations.
1889 : 3 : order = "12"
1890 : 3 : call xmpi_distrib_2d(np, order, npp_bz, gqk%natom3, gqk%pp_sum_comm%nproc, gqk%pert_comm%nproc, ierr)
1891 [ - + ]: 3 : ABI_CHECK(ierr == 0, sjoin("Cannot distribute nprocs:", itoa(np), " with priority: ", priority, " Please use gwpt_np_wpqbks"))
1892 : : else
1893 : : ! "Large" np. Activate parallelism over k-points or q-points depending on gstore input variables.
1894 : 0 : ABI_ERROR("Your number of MPI procs is too large for the automatic GWPT parallelization. Please use gwpt_np_wpqbks")
1895 : : end if
1896 : : end if
1897 : :
1898 : : else
1899 : : ABI_ERROR(sjoin("Invalid eph_task", itoa(dtset%eph_task)))
1900 : : end if
1901 : :
1902 : : ! Consistency check.
1903 [ - + ]: 24 : if (gqk%pert_comm%nproc * gqk%qpt_comm%nproc * gqk%kpt_comm%nproc * gqk%band_comm%nproc * &
1904 : 24 : gqk%bsum_comm%nproc * gqk%pp_sum_comm%nproc /= nproc_spin(spin)) then
1905 : : write(msg, "(a,i0,3a, 7(a,1x,i0))") &
1906 : 0 : "Cannot create Cartesian grid with total nproc: ", nproc_spin(spin), ch10, &
1907 : 0 : "Idle processes are not supported. The product of the `nproc_*` vars should be equal to nproc.", ch10, &
1908 : 0 : "qpt_nproc (", gqk%qpt_comm%nproc, ") x kpt_nproc (", gqk%kpt_comm%nproc, ") x pert_nproc", gqk%pert_comm%nproc, &
1909 : 0 : "x band_nproc (", gqk%band_comm%nproc, "x bsum_nproc (", gqk%bsum_comm%nproc, ") x psum_nproc (", gqk%pp_sum_comm%nproc, &
1910 : 0 : ") != ", nproc_spin(spin)
1911 : 0 : ABI_ERROR(msg)
1912 : : end if
1913 : :
1914 : : end do ! my_is
1915 : :
1916 : : ! For each spin treated by this rank, create Cartesian communicator of rank ndims.
1917 : 24 : periods(:) = .False.; reorder = .False.
1918 : :
1919 [ + + ]: 48 : do my_is=1,gstore%my_nspins
1920 : 24 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is)
1921 : :
1922 : : ! TODO: Should change order for GWPT.
1923 : : dims = [gqk%qpt_comm%nproc, gqk%kpt_comm%nproc, gqk%pert_comm%nproc, gqk%band_comm%nproc, &
1924 [ + + ]: 168 : gqk%bsum_comm%nproc, gqk%pp_sum_comm%nproc]
1925 : :
1926 : : ! Note comm_spin(spin).
1927 : 24 : gqk%comm = xcomm_from_mpi_int(comm_spin(spin))
1928 [ + + ]: 168 : gqk%coords_qkpb_sumbp = 0
1929 : :
1930 : : #ifdef HAVE_MPI
1931 : 24 : call MPI_CART_CREATE(gqk%comm, ndims, dims, periods, reorder, comm_cart, ierr)
1932 : : ! Find the index and coordinates of the current processor
1933 : 24 : call MPI_COMM_RANK(comm_cart, me_cart, ierr)
1934 : 24 : call MPI_CART_COORDS(comm_cart, me_cart, ndims, gqk%coords_qkpb_sumbp, ierr)
1935 : :
1936 : : ! Communicator for q-points in g(k,q)
1937 : 24 : keepdim = .False.; keepdim(1) = .True.; call gqk%qpt_comm%from_cart_sub(comm_cart, keepdim)
1938 : : ! Communicator for k-points in g(k,q)
1939 : 24 : keepdim = .False.; keepdim(2) = .True.; call gqk%kpt_comm%from_cart_sub(comm_cart, keepdim)
1940 : : ! Communicator for the (qpt, kpt) 2D grid
1941 : 24 : keepdim = .False.; keepdim(1) = .True.; keepdim(2) = .True.; call gqk%qpt_kpt_comm%from_cart_sub(comm_cart, keepdim)
1942 : : ! Communicator for perturbations in g(k,q)
1943 : 24 : keepdim = .False.; keepdim(3) = .True.; call gqk%pert_comm%from_cart_sub(comm_cart, keepdim)
1944 : : ! 2d Communicator for the (qpt, pert) grid
1945 : 24 : keepdim = .False.; keepdim(1) = .True.; keepdim(3) = .True.; call gqk%qpt_pert_comm%from_cart_sub(comm_cart, keepdim)
1946 : : ! Communicator for band in g(k,q)
1947 : 24 : keepdim = .False.; keepdim(4) = .True.; call gqk%band_comm%from_cart_sub(comm_cart, keepdim)
1948 : : ! Communicator for bsum (GWPT mode)
1949 : 24 : keepdim = .False.; keepdim(5) = .True.; call gqk%bsum_comm%from_cart_sub(comm_cart, keepdim)
1950 : : ! Communicator for pp_sum (GWPT mode)
1951 : 24 : keepdim = .False.; keepdim(6) = .True.; call gqk%pp_sum_comm%from_cart_sub(comm_cart, keepdim)
1952 : : ! 2d Communicator for the (pert, pp_sum) 2D grid
1953 : 24 : keepdim = .False.; keepdim(3) = .True.; keepdim(6) = .True.; call gqk%pert_ppsum_comm%from_cart_sub(comm_cart, keepdim)
1954 : : ! 3d Communicator for the (pert, pp_sum, band_sum) 3D grid (GWPT mode)
1955 : 24 : keepdim = .False.; keepdim(3) = .True.; keepdim(5) = .True.; keepdim(6) = .True.
1956 : 24 : call gqk%pert_ppsum_bsum_comm%from_cart_sub(comm_cart, keepdim)
1957 : 24 : call xmpi_comm_free(comm_cart)
1958 : : #endif
1959 : :
1960 : : ! Distribute perturbations inside pert_comm using block distribution.
1961 [ - + ]: 24 : call xmpi_split_block(gqk%natom3, gqk%pert_comm%value, gqk%my_npert, gqk%my_pertcases)
1962 : 24 : gqk%my_pert_start = gqk%my_pertcases(1)
1963 : :
1964 : 24 : call wrtout(units, sjoin("P qpt_comm can use shmem:", yesno(gqk%qpt_comm%can_use_shmem())))
1965 : 24 : call wrtout(units, sjoin("P kpt_comm can use shmem:", yesno(gqk%kpt_comm%can_use_shmem())))
1966 : 24 : call wrtout(units, sjoin("P bsum_comm can use shmem:", yesno(gqk%bsum_comm%can_use_shmem())))
1967 : 48 : call wrtout(units, sjoin("P pp_sum_comm can use shmem:", yesno(gqk%pp_sum_comm%can_use_shmem())), newlines=1)
1968 : : end do ! my_is
1969 : :
1970 [ + - + + ]: 96 : if (my_rank == master) call gstore%print([std_out, ab_out])
1971 : :
1972 : : end associate
1973 : :
1974 [ - + - + : 24 : end subroutine gstore_set_mpi_grid__
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - - -
- - - - -
- - - - -
- - + - +
- + - + -
+ - + - +
- + - + ]
1975 : : !!***
1976 : :
1977 : : !----------------------------------------------------------------------
1978 : :
1979 : : !!****f* m_gstore/gstore_print
1980 : : !! NAME
1981 : : !! gstore_print
1982 : : !!
1983 : : !! FUNCTION
1984 : : !! Print info on the gstore object.
1985 : : !!
1986 : : !! INPUTS
1987 : : !! units: Unit numbers.
1988 : : !! [header]: header string
1989 : : !! [prtvol]: Verbosity level.
1990 : : !!
1991 : : !! SOURCE
1992 : :
1993 [ - + ]: 32 : subroutine gstore_print(gstore, units, header, prtvol)
1994 : :
1995 : : !Arguments ------------------------------------
1996 : : class(gstore_t),intent(inout) :: gstore
1997 : : integer,intent(in) :: units(:)
1998 : : character(len=*),optional,intent(in) :: header
1999 : : integer,optional,intent(in) :: prtvol
2000 : :
2001 : : !Local variables ------------------------------
2002 : : integer,parameter :: max_nk=10
2003 : : integer :: my_is, my_prtvol, ik_calc, ik_bz, ik_ibz !, iq_calc, iq_bz, iq_ibz
2004 : : real(dp) :: rtot_num_g
2005 : : character(len=500) :: msg
2006 : : !----------------------------------------------------------------------
2007 : :
2008 [ - + ]: 32 : my_prtvol = 0; if (present(prtvol)) my_prtvol = prtvol
2009 : :
2010 [ - + ]: 32 : if (present(header)) then
2011 : 0 : call wrtout(units, header)
2012 : : else
2013 : 32 : call wrtout(units, " === Gstore parameters ===")
2014 : : end if
2015 : :
2016 : 32 : call wrtout(units, sjoin(" kzone:", gstore%kzone))
2017 : 32 : call wrtout(units, sjoin(" kfilter:", gstore%kfilter))
2018 : 32 : call wrtout(units, sjoin(" nkibz:", itoa(gstore%nkibz)))
2019 : 32 : call wrtout(units, sjoin(" nkbz:", itoa(gstore%nkbz)))
2020 : 32 : call wrtout(units, sjoin(" glob_nk_spin:", ltoa(gstore%glob_nk_spin)))
2021 : 32 : call wrtout(units, sjoin(" qzone:", gstore%qzone))
2022 : 32 : call wrtout(units, sjoin(" nqibz:", itoa(gstore%nqibz)))
2023 : 32 : call wrtout(units, sjoin(" nqbz:", itoa(gstore%nqbz)))
2024 : 32 : call wrtout(units, sjoin(" glob_nq_spin:", ltoa(gstore%glob_nq_spin)))
2025 : 32 : call wrtout(units, sjoin(" kptopt:", itoa(gstore%ebands%kptopt)))
2026 : 32 : call wrtout(units, sjoin(" qptopt:", itoa(gstore%qptopt)))
2027 : 32 : call wrtout(units, sjoin(" has_used_lgk:", itoa(gstore%has_used_lgk)))
2028 : 32 : call wrtout(units, sjoin(" has_used_lgq:", itoa(gstore%has_used_lgq)))
2029 : 32 : call wrtout(units, sjoin(" with_vk:", itoa(gstore%with_vk)))
2030 : :
2031 [ + + ]: 64 : do my_is=1,gstore%my_nspins
2032 : 32 : associate (spin => gstore%my_spins(my_is), gqk => gstore%gqk(my_is))
2033 : 32 : call wrtout(units, sjoin(" gqk_cplex:", itoa(gqk%cplex)), pre_newlines=1)
2034 : 32 : call wrtout(units, sjoin(" gqk_bstart_k:", itoa(gqk%bstart_k)))
2035 : 32 : call wrtout(units, sjoin(" gqk_bstart_kq:", itoa(gqk%bstart_kq)))
2036 : 32 : call wrtout(units, sjoin(" gqk_bstop_k:", itoa(gqk%bstop_k)))
2037 : 32 : call wrtout(units, sjoin(" gqk_bstop_kq:", itoa(gqk%bstop_kq)))
2038 : 32 : call wrtout(units, sjoin(" gqk_nb_k:", itoa(gqk%nb_k)))
2039 : 32 : call wrtout(units, sjoin(" gqk_nb_kq:", itoa(gqk%nb_kq)))
2040 : 32 : rtot_num_g = (one * gqk%nb_kq * gqk%nb_k) * (gqk%glob_nk * gqk%glob_nq * one) * gqk%natom3
2041 : : !call wrtout(units, sjoin(" total number of g(k,q) elements:", ftoa(rtot_num_g)))
2042 : 32 : call wrtout(units, sjoin("P gqk_my_npert:", itoa(gqk%my_npert)))
2043 : 32 : call wrtout(units, sjoin("P gqk_my_nk:", itoa(gqk%my_nk)))
2044 : 32 : call wrtout(units, sjoin("P gqk_my_nq:", itoa(gqk%my_nq)))
2045 : 32 : call wrtout(units, sjoin(ch10, " === MPI distribution ==="))
2046 : 32 : call wrtout(units, sjoin("P Number of CPUs for parallelism over perturbations: ", itoa(gqk%pert_comm%nproc)))
2047 : 32 : call wrtout(units, sjoin("P Number of perturbations treated by this CPU: ", itoa(gqk%my_npert)))
2048 : 32 : call wrtout(units, sjoin("P Number of CPUs for parallelism over q-points: ", itoa(gqk%qpt_comm%nproc)))
2049 : 32 : call wrtout(units, sjoin("P Number of CPUs for parallelism over k-points: ", itoa(gqk%kpt_comm%nproc)))
2050 : : ! This only for GWPT calculations.
2051 [ - + ]: 32 : if (gqk%bsum_comm%nproc /= 1) then
2052 : 0 : call wrtout(units, sjoin("P Number of CPUs for parallelism over band summation: ", itoa(gqk%bsum_comm%nproc)))
2053 : : end if
2054 [ - + ]: 32 : if (gqk%pp_sum_comm%nproc /= 1) then
2055 : 0 : call wrtout(units, sjoin("P Number of CPUs for parallelism over wavevector summation: ", itoa(gqk%pp_sum_comm%nproc)))
2056 : : end if
2057 : :
2058 : : ! Print k-points
2059 : 32 : call wrtout(units, " k-points included in gstore:")
2060 [ + + ]: 226 : do ik_calc=1,gqk%glob_nk
2061 : 211 : ik_bz = gstore%kglob2bz(ik_calc, spin)
2062 : 211 : ik_ibz = gstore%kbz2ibz(1, ik_bz)
2063 : 211 : call wrtout(units, sjoin(itoa(ik_calc), ":", ktoa(gstore%kbz(:, ik_bz))))
2064 [ + + + - ]: 226 : if (ik_calc > max_nk .and. my_prtvol == 0) then
2065 : 17 : call wrtout(units, sjoin(" Max", itoa(max_nk), " k-points will be written. Use prtvol > 0 to print all of them."))
2066 : 17 : exit
2067 : : end if
2068 : : end do
2069 : : !call wrtout(units, " ")
2070 : :
2071 : : ! Print q-points
2072 : : !call wrtout(units, " q-points included in gstore:")
2073 : : !do iq_calc=1,gqk%glob_nq
2074 : : ! iq_bz = gstore%qglob2bz(iq_calc, spin)
2075 : : ! iq_ibz = gstore%qbz2ibz(1, iq_bz)
2076 : : ! call wrtout(units, sjoin(itoa(iq_calc), ":", ktoa(gstore%qbz(:, iq_bz))))
2077 : : ! if (iq_calc > max_nk .and. my_prtvol == 0) then
2078 : : ! call wrtout(units, sjoin(" Max", itoa(max_nk), " q-points will be written. Use prtvol > 0 to print all of them."))
2079 : : ! exit
2080 : : ! end if
2081 : : !end do
2082 : :
2083 : : ! Print memory
2084 [ - + ]: 32 : if (allocated(gqk%my_g2)) then
2085 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for |g|^2 array: ',ABI_MEM_MB(gqk%my_g2),' [mb] <<< mem'
2086 : 0 : call wrtout(units, msg)
2087 : : end if
2088 [ + + - + ]: 32 : if (gqk%has_both_g .and. associated(gqk%my_g2_ks)) then
2089 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for |g_KS|^2 array: ',ABI_MEM_MB(gqk%my_g2_ks),' [mb] <<< mem'
2090 : 0 : call wrtout(units, msg)
2091 : : end if
2092 [ - + ]: 32 : if (allocated(gqk%my_g)) then
2093 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for g array: ',ABI_MEM_MB(gqk%my_g),' [Mb] <<< MEM'
2094 : 0 : call wrtout(units, msg)
2095 : : end if
2096 [ + + - + ]: 32 : if (gqk%has_both_g .and. associated(gqk%my_g_ks)) then
2097 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for g_KS array: ',ABI_MEM_MB(gqk%my_g_ks),' [Mb] <<< MEM'
2098 : 0 : call wrtout(units, msg)
2099 : : end if
2100 [ - + ]: 32 : if (allocated(gqk%my_gdw2)) then
2101 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for gDW^2 array: ',ABI_MEM_MB(gqk%my_gdw2),' [mb] <<< mem'
2102 : : end if
2103 [ + + - + ]: 32 : if (gqk%has_both_g .and. associated(gqk%my_gdw2_ks)) then
2104 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for gDW^2_KS array: ',ABI_MEM_MB(gqk%my_gdw2_ks),' [mb] <<< mem'
2105 : : end if
2106 : :
2107 [ - + ]: 32 : if (allocated(gqk%vnk_cart_ibz)) then
2108 [ # # ]: 0 : write(msg,'(a,f8.1,a)')'- Local memory allocated for vnk_cart_ibz: ',ABI_MEM_MB(gqk%vnk_cart_ibz),' [Mb] <<< MEM'
2109 : 0 : call wrtout(units, msg)
2110 : : end if
2111 [ - + ]: 32 : if (allocated(gqk%vnk_mat_cart_ibz)) then
2112 [ # # ]: 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'
2113 : 0 : call wrtout(units, msg)
2114 : : end if
2115 [ - + ]: 64 : if (allocated(gqk%my_iv1p_comm)) then
2116 [ # # ]: 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'
2117 : : end if
2118 : : end associate
2119 : : end do
2120 : :
2121 [ - + ]: 32 : if (my_prtvol > 0) then
2122 : 0 : call gstore%ebands%print(units, header="Electron bands in GSTORE", prtvol=my_prtvol)
2123 : : end if
2124 : 32 : call wrtout(units, " ")
2125 : :
2126 : 32 : end subroutine gstore_print
2127 : : !!***
2128 : :
2129 : : !!****f* m_gstore/gstore_check_little_group
2130 : : !! NAME
2131 : : !! gstore_check_little_group
2132 : : !!
2133 : : !! FUNCTION
2134 : : !! Check consistency between little group options read from file and from input.
2135 : : !!
2136 : : !! INPUTS
2137 : : !!
2138 : : !! SOURCE
2139 : :
2140 : 7 : integer function gstore_check_little_group(gstore, dtset, msg) result(ierr)
2141 : :
2142 : : !Arguments ------------------------------------
2143 : : class(gstore_t),intent(in) :: gstore
2144 : : type(dataset_type),intent(in) :: dtset
2145 : : character(len=*),intent(out) :: msg
2146 : : !----------------------------------------------------------------------
2147 : :
2148 : 7 : ierr = 0; msg = ""
2149 : :
2150 [ - + ]: 7 : if (dtset%gstore_use_lgk /= 0) then
2151 : : ! Cannot use IBZ_k if we have used IBZ_q.
2152 [ # # ]: 0 : if (gstore%has_used_lgq /= 0) then
2153 [ # # # # ]: 0 : msg = sjoin("Input var gstore_use_lgq: ", itoa(dtset%gstore_use_lgq), ", but GSTORE file has:", itoa(gstore%has_used_lgq))
2154 : 0 : ABI_ERROR_NOSTOP(msg, ierr)
2155 : : end if
2156 : : ! Using IBZ_k when GSTORE has full BZ is OK but inefficient.
2157 [ # # ]: 0 : if (gstore%has_used_lgk == 0) then
2158 [ # # # # ]: 0 : msg = sjoin("Input var gstore_use_lgk: ", itoa(dtset%gstore_use_lgk), ", but GSTORE file has:", itoa(gstore%has_used_lgk))
2159 : 0 : ABI_COMMENT(msg)
2160 : : end if
2161 : : end if
2162 : :
2163 [ - + ]: 7 : if (dtset%gstore_use_lgq /= 0) then
2164 : : ! Cannot use IBZ_q if we have used IBZ_k.
2165 [ # # ]: 0 : if (gstore%has_used_lgk /= 0) then
2166 [ # # # # ]: 0 : msg = sjoin("Input var gstore_use_lgk: ", itoa(dtset%gstore_use_lgk), ", but GSTORE file has:", itoa(gstore%has_used_lgk))
2167 : 0 : ABI_ERROR_NOSTOP(msg, ierr)
2168 : : end if
2169 : : ! Using IBZ_q when GSTORE has full BZ is OK but inefficient.
2170 [ # # ]: 0 : if (gstore%has_used_lgq == 0) then
2171 [ # # # # ]: 0 : msg = sjoin("Input var gstore_use_lgq: ", itoa(dtset%gstore_use_lgq), ", but GSTORE file has:", itoa(gstore%has_used_lgq))
2172 : 0 : ABI_COMMENT(msg)
2173 : : end if
2174 : : end if
2175 : :
2176 [ + - ]: 7 : end function gstore_check_little_group
2177 : : !!***
2178 : :
2179 : : !----------------------------------------------------------------------
2180 : :
2181 : : !!****f* m_gstore/gstore_malloc__
2182 : : !! NAME
2183 : : !! gstore_malloc__
2184 : : !!
2185 : : !! FUNCTION
2186 : : !! Allocate local buffers once the MPI grid has been initialized.
2187 : : !!
2188 : : !! INPUTS
2189 : : !!
2190 : : !! OUTPUT
2191 : : !!
2192 : : !! SOURCE
2193 : :
2194 : 24 : subroutine gstore_malloc__(gstore, with_cplex, has_both_g, max_nq, qglob2bz, max_nk, kglob2bz, qbz2ibz, kbz2ibz)
2195 : :
2196 : : !Arguments ------------------------------------
2197 : : !scalars
2198 : : class(gstore_t),target,intent(inout) :: gstore
2199 : : integer,intent(in) :: with_cplex, max_nq, max_nk
2200 : : logical,intent(in) :: has_both_g
2201 : : integer,intent(in) :: qglob2bz(max_nq, gstore%nsppol), kglob2bz(max_nk, gstore%nsppol)
2202 : : integer,intent(in) :: qbz2ibz(6, gstore%nqbz), kbz2ibz(6, gstore%nkbz)
2203 : :
2204 : : !Local variables-------------------------------
2205 : : !scalars
2206 : : integer :: my_is, ierr, my_iq, my_ik, iq_glob, iq_bz, ik_glob, ik_bz
2207 : : integer :: ik_ibz, isym_k, trev_k, tsign_k, g0_k(3), nb_k, nb_kq
2208 : : logical :: isirr_k
2209 : : real(dp) :: mem_mb
2210 : : type(gqk_t), pointer :: gqk
2211 : : !----------------------------------------------------------------------
2212 : :
2213 [ - + ]: 24 : ABI_CHECK(with_cplex >= 0 .and. with_cplex <= 2, sjoin("Invalid with_cplex:", itoa(with_cplex)))
2214 : 24 : gstore%with_cplex = with_cplex
2215 : :
2216 [ + + ]: 48 : do my_is=1,gstore%my_nspins
2217 : 24 : associate (spin => gstore%my_spins(my_is))
2218 : 24 : gqk => gstore%gqk(my_is)
2219 : 24 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
2220 : 24 : gqk%has_both_g = has_both_g
2221 : :
2222 : : ! Split q-points and transfer symmetry tables.
2223 : : ! Note that glob_nq and glob_nk does not necessarily correspond to the size of the BZ
2224 : : ! First of all we have to consider kzone
2225 : : ! Even if kzone == "bz" we may have filtered the wavevectors e.g. Fermi surface.
2226 : 24 : call xmpi_split_block(gqk%glob_nq, gqk%qpt_comm%value, gqk%my_nq, gqk%my_q2glob)
2227 [ - + ]: 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"))
2228 : 24 : gqk%my_qstart = gqk%my_q2glob(1)
2229 : :
2230 [ - + + - : 72 : ABI_MALLOC(gqk%my_q2ibz, (6, gqk%my_nq))
+ - + - -
+ - + -
+ ]
2231 [ - + + - : 72 : ABI_MALLOC(gqk%my_q2bz, (gqk%my_nq))
+ - + - -
+ - + -
+ ]
2232 : :
2233 [ + + ]: 2330 : do my_iq=1,gqk%my_nq
2234 : 2306 : iq_glob = my_iq + gqk%my_qstart - 1
2235 : 2306 : iq_bz = qglob2bz(iq_glob, spin)
2236 [ + + ]: 16142 : gqk%my_q2ibz(:, my_iq) = qbz2ibz(:, iq_bz)
2237 : 2330 : gqk%my_q2bz(my_iq) = iq_bz
2238 : : end do
2239 : :
2240 : : ! Split k-points and transfer symmetry tables
2241 [ - + ]: 24 : call xmpi_split_block(gqk%glob_nk, gqk%kpt_comm%value, gqk%my_nk, gqk%my_k2glob)
2242 [ - + ]: 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"))
2243 : 24 : gqk%my_kstart = gqk%my_k2glob(1)
2244 : :
2245 [ - + + - : 72 : ABI_MALLOC(gqk%my_k2ibz, (6, gqk%my_nk))
+ - + - -
+ - + -
+ ]
2246 : : !ABI_MALLOC(gqk%my_k2bz, (gqk%my_nk))
2247 [ - + + - : 72 : ABI_MALLOC(gqk%my_kpts, (3, gqk%my_nk))
+ - + - -
+ - + -
+ ]
2248 [ - + + - : 72 : ABI_MALLOC(gqk%my_wtk, (gqk%my_nk))
+ - + - -
+ - + -
+ ]
2249 : :
2250 [ + + ]: 1020 : do my_ik=1,gqk%my_nk
2251 : 996 : ik_glob = my_ik + gqk%my_kstart - 1
2252 : 996 : ik_bz = kglob2bz(ik_glob, spin)
2253 [ + + ]: 6972 : gqk%my_k2ibz(:, my_ik) = kbz2ibz(:, ik_bz)
2254 : : !gqk%my_k2bz(my_ik) = ik_bz
2255 : :
2256 : 996 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
2257 [ + + ]: 3984 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5, my_ik)
2258 : : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
2259 [ - + ]: 996 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
2260 : :
2261 : : ! Note symrel^T convention for k
2262 [ + + + + : 30876 : gqk%my_kpts(:, my_ik) = tsign_k * matmul(transpose(gstore%cryst%symrel(:,:,isym_k)), gstore%kibz(:, ik_ibz)) + g0_k
+ + + + +
+ + - + -
+ + ]
2263 : :
2264 : 24 : select case(gstore%kzone)
2265 : : case ("ibz")
2266 : 18 : gqk%my_wtk(my_ik) = gstore%ebands%wtk(ik_ibz)
2267 : : case ("bz")
2268 [ + + - ]: 996 : gqk%my_wtk(my_ik) = one / gstore%nkbz
2269 : : end select
2270 : : end do
2271 : :
2272 : : ! Allocate storage for MPI-distributed e-ph matrix elements.
2273 [ - + + + ]: 48 : if (with_cplex > 0) then
2274 : 16 : mem_mb = (one * with_cplex * gqk%my_npert) * gqk%my_nq * gqk%my_nk * nb_kq * nb_k * eight * b2Mb
2275 : 16 : call wrtout(std_out, sjoin(" Local memory for e-ph matrix elements:", ftoa(mem_mb, fmt="f8.1"), " [Mb] <<< MEM"))
2276 : :
2277 : : ! The initialization with zero is important as not all the g are computed when we filter in k-space.
2278 : : ! Abinit postprocessing tools will operate of the full my_g array
2279 : : ! and we don't want to trigger floating point exceptions.
2280 : 6 : select case (with_cplex)
2281 : : case (1)
2282 [ - + + - : 42 : ABI_MALLOC_OR_DIE(gqk%my_g2, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - -
+ + - -
+ ]
2283 [ + + + + : 76305 : gqk%my_g2 = zero
+ + + + +
+ ]
2284 : :
2285 : 6 : gqk%my_g2_ks => gqk%my_g2
2286 [ + + ]: 6 : if (gqk%has_both_g) then
2287 [ - + + - : 35 : ABI_MALLOC_OR_DIE(gqk%my_g2_ks, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - ]
2288 [ + + + + : 40203 : gqk%my_g2_ks = zero
+ + + + +
+ ]
2289 : : end if
2290 : : case (2)
2291 [ - + + - : 70 : ABI_MALLOC_OR_DIE(gqk%my_g, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - -
+ + - -
+ ]
2292 [ + + + + : 4224533 : gqk%my_g = zero
+ + + + +
+ ]
2293 : :
2294 : 10 : gqk%my_g_ks => gqk%my_g
2295 [ + + ]: 10 : if (gqk%has_both_g) then
2296 : : !call wrtout(std_out, "Allocating my_g_ks") !; stop
2297 [ - + + - : 7 : ABI_MALLOC_OR_DIE(gqk%my_g_ks, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - ]
2298 [ + + + + : 18182 : gqk%my_g_ks = zero
+ + + + +
+ ]
2299 : : end if
2300 : : case default
2301 [ + + - ]: 16 : ABI_ERROR(sjoin("Wrong with_cplex:", itoa(with_cplex)))
2302 : : end select
2303 : :
2304 : : ! Allocate storage for MPI-distributed dH/dk matrix elements.
2305 [ + - ]: 16 : if (any(gstore%with_vk == [1, 2])) then
2306 : 16 : mem_mb = 3 * gqk%nb_k * gqk%my_nk * eight * b2Mb
2307 : 16 : call wrtout(std_out, sjoin(" Memory for diagonal vnk_cart_ibz:", ftoa(mem_mb, fmt="f8.1"), " [Mb] <<< MEM"))
2308 [ - + + - : 64 : ABI_MALLOC_OR_DIE(gqk%vnk_cart_ibz, (3, gqk%nb_k, gstore%nkibz), ierr)
- + + - +
- + - + -
+ - - + +
- - + ]
2309 [ + + + + : 2087 : gqk%vnk_cart_ibz = zero
+ + ]
2310 : : end if
2311 : :
2312 [ - + ]: 16 : if (gstore%with_vk == 2) then
2313 : 0 : mem_mb = two * 3 * gqk%nb_k**2 * gqk%my_nk * eight * b2Mb
2314 : 0 : call wrtout(std_out, sjoin(" Memory for vnk_mat_cart_ibz:", ftoa(mem_mb, fmt="f8.1"), " [Mb] <<< MEM"))
2315 [ # # # # : 0 : ABI_MALLOC_OR_DIE(gqk%vnk_mat_cart_ibz, (2, 3, gqk%nb_k, gqk%nb_k, gstore%nkibz), ierr)
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
2316 [ # # # # : 0 : gqk%vnk_mat_cart_ibz = zero
# # # # #
# ]
2317 : : end if
2318 : : end if
2319 : :
2320 : : end associate
2321 : : end do ! my_is
2322 : :
2323 : 24 : end subroutine gstore_malloc__
2324 : : !!***
2325 : :
2326 : : !----------------------------------------------------------------------
2327 : :
2328 : : !!****f* m_gstore/gstore_filter_fs_tetra__
2329 : : !! NAME
2330 : : !! gstore_filter_fs_tetra__
2331 : : !!
2332 : : !! FUNCTION
2333 : : !! Compute delta(e_k - e_F) with the tetrahedron method. Use weights to filter k-points.
2334 : : !! Include only those q-points such that there exists at least one k on the FS with k + q on the FS.
2335 : : !! Also, store and precompute gstore%delta_ef_kibz_spin(max_nb, gstore%nkibz, nsppol)
2336 : : !! to be used to filter inside gstore%compute.
2337 : : !!
2338 : : !! INPUTS
2339 : : !!
2340 : : !! OUTPUT
2341 : : !!
2342 : : !! SOURCE
2343 : :
2344 : 0 : subroutine gstore_filter_fs_tetra__(gstore, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
2345 : :
2346 : : !Arguments ------------------------------------
2347 : : !scalars
2348 : : class(gstore_t),intent(inout) :: gstore
2349 : : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2350 : : integer,intent(in) :: kibz2bz(gstore%nkibz)
2351 : : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2352 : : integer,intent(out) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2353 : :
2354 : : !Local variables-------------------------------
2355 : : !scalars
2356 : : integer,parameter :: tetra_opt0 = 0
2357 : : integer :: nsppol, ierr, cnt, spin, band, ib, ii, max_nb, all_nproc, my_rank, comm
2358 : : integer :: ik_bz, ik_ibz, iflag, nk_in_star
2359 : : real(dp) :: max_occ
2360 : : character(len=80) :: error_string
2361 : 0 : type(htetra_t) :: ktetra
2362 : : !arrays
2363 : 0 : integer,allocatable :: indkk(:), kstar_bz_inds(:)
2364 : : real(dp):: rlatt(3,3), klatt(3,3), delta_theta_ef(2) !, qpt(3)
2365 : 0 : real(dp),allocatable :: eig_ibz(:)
2366 : : !----------------------------------------------------------------------
2367 : :
2368 : : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2369 : :
2370 : 0 : comm = gstore%comm; all_nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
2371 : 0 : nsppol = gstore%nsppol
2372 : :
2373 : : !ABI_CHECK(gstore%same_nbands(msg), sjoin("VarPEq requires nb_k == nb_kq.", msg))
2374 : :
2375 : : ! Use the tetrahedron method to filter k- and k+q points on the FS in metals
2376 : : ! and define gstore%brange_k_spin automatically.
2377 : 0 : call wrtout(std_out, sjoin(" Filtering k-points using:", gstore%kfilter))
2378 : :
2379 : : ! NB: here we precompute brange_k_spin
2380 : : ! nb_kq == nb_k when FS filtering with tetra is used.
2381 : 0 : call ebands%get_bands_e0(ebands%fermie, gstore%brange_k_spin, ierr)
2382 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Error in ebands_get_bands_e0")
2383 [ # # # # : 0 : gstore%brange_kq_spin = gstore%brange_k_spin
# # # # #
# # # # #
# # ]
2384 : :
2385 [ # # # # : 0 : ABI_MALLOC(indkk, (gstore%nkbz))
# # # # #
# # # ]
2386 [ # # ]: 0 : indkk(:) = gstore%kbz2ibz(1, :)
2387 : :
2388 [ # # # # ]: 0 : rlatt = ebands%kptrlatt; call matr3inv(rlatt, klatt)
2389 : : call ktetra%init(indkk, gstore%cryst%gprimd, klatt, gstore%kbz, gstore%nkbz, gstore%kibz, gstore%nkibz, &
2390 [ # # # # : 0 : ierr, error_string, gstore%comm)
# # # # #
# ]
2391 [ # # ]: 0 : ABI_CHECK(ierr == 0, error_string)
2392 : :
2393 [ # # # # : 0 : ABI_MALLOC(eig_ibz, (gstore%nkibz))
# # # # #
# # # ]
2394 : 0 : max_occ = two / (ebands%nspinor * nsppol)
2395 [ # # # # ]: 0 : select_kbz_spin = 0
2396 : :
2397 [ # # ]: 0 : max_nb = maxval(gstore%brange_k_spin(2, :) - gstore%brange_k_spin(1, :) + 1)
2398 [ # # # # : 0 : ABI_CALLOC(gstore%delta_ef_kibz_spin, (max_nb, gstore%nkibz, gstore%nsppol))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
2399 : :
2400 : : cnt = 0
2401 [ # # ]: 0 : do spin=1,nsppol
2402 [ # # ]: 0 : do band=gstore%brange_k_spin(1, spin), gstore%brange_k_spin(2, spin)
2403 : 0 : ib = band - gstore%brange_k_spin(1, spin) + 1
2404 [ # # # # : 0 : eig_ibz = ebands%eig(band, :, spin)
# # # # ]
2405 : :
2406 [ # # ]: 0 : do ik_ibz=1,gstore%nkibz
2407 [ # # ]: 0 : cnt = cnt + 1; if (mod(cnt, all_nproc) /= my_rank) cycle ! MPI parallelism inside comm
2408 : :
2409 : : call ktetra%get_onewk_wvals(ik_ibz, tetra_opt0, 1, [ebands%fermie], max_occ, &
2410 [ # # ]: 0 : gstore%nkibz, eig_ibz, delta_theta_ef)
2411 : :
2412 : 0 : gstore%delta_ef_kibz_spin(ib, ik_ibz, spin) = delta_theta_ef(1)
2413 : :
2414 [ # # ]: 0 : iflag = merge(1, 0, abs(delta_theta_ef(1)) > zero)
2415 : :
2416 : : ! Use iflag to filter k-points.
2417 : 0 : select case (gstore%kzone)
2418 : : case ("ibz")
2419 : 0 : ik_bz = kibz2bz(ik_ibz)
2420 : 0 : select_kbz_spin(ik_bz, spin) = select_kbz_spin(ik_bz, spin) + iflag
2421 : :
2422 : : case ("bz")
2423 [ # # ]: 0 : call star_from_ibz_idx(ik_ibz, gstore%nkbz, gstore%kbz2ibz, nk_in_star, kstar_bz_inds)
2424 [ # # ]: 0 : ABI_CHECK(nk_in_star > 0, "Something wrong in star_from_ibz_idx")
2425 [ # # ]: 0 : do ii=1,nk_in_star
2426 : 0 : ik_bz = kstar_bz_inds(ii)
2427 : 0 : select_kbz_spin(ik_bz, spin) = select_kbz_spin(ik_bz, spin) + iflag
2428 : : end do
2429 [ # # # # : 0 : ABI_FREE(kstar_bz_inds)
# ]
2430 : : end select
2431 : : end do
2432 : :
2433 : : end do
2434 : : end do
2435 : :
2436 : : !call ktetra%print(std_out)
2437 : 0 : call xmpi_sum(select_kbz_spin, comm, ierr)
2438 : 0 : call xmpi_sum(gstore%delta_ef_kibz_spin, comm, ierr)
2439 : :
2440 : : ! Now the tricky part as we want to remove q-points that
2441 : : ! do not lead to any scattering process between two states on the FS
2442 : : ! Remember that k+q is always a sub-mesh of the input ebands k-mesh.
2443 : :
2444 : : call recompute_select_qbz_spin(gstore, gstore%qbz, qbz2ibz, qibz2bz, gstore%kbz, gstore%kibz, gstore%kbz2ibz, kibz2bz, &
2445 [ # # # # : 0 : select_kbz_spin, select_qbz_spin)
# # # # #
# ]
2446 : :
2447 [ # # ]: 0 : ABI_FREE(eig_ibz)
2448 [ # # ]: 0 : ABI_FREE(indkk)
2449 : 0 : call ktetra%free()
2450 : : end associate
2451 : :
2452 [ # # # # : 0 : end subroutine gstore_filter_fs_tetra__
# # # # #
# # # # #
# # # # #
# ]
2453 : : !!***
2454 : :
2455 : : !----------------------------------------------------------------------
2456 : :
2457 : : !!****f* m_gstore/gstore_filter_kptgw__
2458 : : !! NAME
2459 : : !! gstore_gw_filter_kptgw__
2460 : : !!
2461 : : !! FUNCTION
2462 : : !! Filter k-points according to the input variable kptgw. Useful for ZPR for user-specified k-points.
2463 : : !!
2464 : : !! INPUTS
2465 : : !!
2466 : : !! OUTPUT
2467 : : !!
2468 : : !! SOURCE
2469 : :
2470 : 0 : subroutine gstore_filter_kptgw__(gstore, dtset, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
2471 : :
2472 : : !Arguments ------------------------------------
2473 : : !scalars
2474 : : class(gstore_t),intent(inout) :: gstore
2475 : : type(dataset_type),intent(in) :: dtset
2476 : : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2477 : : integer,intent(in) :: kibz2bz(gstore%nkibz)
2478 : : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2479 : : integer,intent(out) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2480 : :
2481 : : !Local variables-------------------------------
2482 : : !scalars
2483 : : integer :: spin, ik_bz, ik_ibz, ik_calc, nkcalc, mapl_kk(6), my_rank
2484 : : !arrays
2485 : 0 : integer,allocatable :: bstart_ks(:,:), nbcalc_ks(:,:)
2486 : 0 : real(dp),allocatable :: kcalc(:,:)
2487 : : !----------------------------------------------------------------------
2488 : :
2489 : : ABI_UNUSED(qbz2ibz)
2490 : : ABI_UNUSED(qibz2bz)
2491 : :
2492 : : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2493 : :
2494 : 0 : my_rank = xmpi_comm_rank(gstore%comm)
2495 : :
2496 : 0 : call wrtout(std_out, sjoin(" Filtering k-points using nkptgw:", itoa(dtset%nkptgw)))
2497 [ # # ]: 0 : if (gstore%qzone /= "bz") then
2498 : 0 : ABI_ERROR(sjoin('kptgw filtering requires gstore_qzone = "bz" while it is: ', gstore%qzone))
2499 : : end if
2500 : :
2501 : : ! Compute nkcalc, kcalc, bstart_ks, nbcalc_ks
2502 : 0 : call sigtk_kcalc_from_nkptgw(dtset, dtset%mband, nkcalc, kcalc, bstart_ks, nbcalc_ks)
2503 : :
2504 : : ! TODO: kcalc should be spin-dependent to handle magnetic semiconductors.
2505 [ # # # # ]: 0 : select_kbz_spin = 0
2506 [ # # ]: 0 : do spin=1,gstore%nsppol
2507 [ # # ]: 0 : do ik_calc=1,nkcalc
2508 [ # # ]: 0 : if (kpts_map("symrel", ebands%kptopt, gstore%cryst, gstore%krank_ibz, 1, kcalc(:,ik_calc), mapl_kk) /= 0) then
2509 : 0 : ABI_ERROR(sjoin("Cannot map kcalc to IBZ with kcalc:", ktoa(kcalc(:,ik_calc))))
2510 : : end if
2511 : : ! Change select_kbz_spin
2512 : 0 : ik_ibz = mapl_kk(1)
2513 : 0 : ik_bz = kibz2bz(ik_ibz); select_kbz_spin(ik_bz, spin) = 1
2514 : : end do
2515 : : end do ! spin
2516 : :
2517 : : !call recompute_select_qbz_spin(gstore, gstore%qbz, qbz2ibz, qibz2bz, gstore%kbz, gstore%kibz, gstore%kbz2ibz, gstore%kibz2bz, &
2518 : : ! select_kbz_spin, select_qbz_spin)
2519 : :
2520 [ # # ]: 0 : ABI_FREE(kcalc)
2521 [ # # ]: 0 : ABI_FREE(bstart_ks)
2522 [ # # ]: 0 : ABI_FREE(nbcalc_ks)
2523 : : end associate
2524 : :
2525 : 0 : end subroutine gstore_filter_kptgw__
2526 : : !!***
2527 : :
2528 : : !----------------------------------------------------------------------
2529 : :
2530 : : !!****f* m_gstore/gstore_filter_erange__
2531 : : !! NAME
2532 : : !! gstore_filter_erange__
2533 : : !!
2534 : : !! FUNCTION
2535 : : !! Filter k-points and q-points according to an energy range.
2536 : : !!
2537 : : !! INPUTS
2538 : : !!
2539 : : !! OUTPUT
2540 : : !!
2541 : : !! SOURCE
2542 : :
2543 : 1 : subroutine gstore_filter_erange__(gstore, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
2544 : :
2545 : : !Arguments ------------------------------------
2546 : : !scalars
2547 : : class(gstore_t),intent(inout) :: gstore
2548 : : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2549 : : integer,intent(in) :: kibz2bz(gstore%nkibz)
2550 : : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2551 : : integer,intent(out) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2552 : :
2553 : : !Local variables-------------------------------
2554 : : !scalars
2555 : : integer,parameter :: tetra_opt0 = 0
2556 : : integer :: nsppol, cnt, spin, ii, all_nproc, my_rank, comm, band ! ierr,
2557 : : integer :: ik_bz, ik_ibz, iflag, nk_in_star, gap_err
2558 : : logical :: assume_gap
2559 : : real(dp) :: ee, abs_erange1, abs_erange2, vmax, cmin
2560 : : type(gaps_t) :: gaps
2561 : : !arrays
2562 : 1 : integer,allocatable :: kstar_bz_inds(:)
2563 : : !----------------------------------------------------------------------
2564 : :
2565 : : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2566 : :
2567 : 1 : comm = gstore%comm; all_nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
2568 : 1 : nsppol = gstore%nsppol
2569 : :
2570 : : ! filter k and k + q points according to erange and define gstore%brange_spin_k automatically.
2571 : : ! NB: here we recompute brange_k_spin
2572 : : call wrtout(std_out, sjoin(" Filtering k-points using gstore_erange:", &
2573 [ + + + - : 4 : ltoa(reshape(gstore%erange_spin, [2 * gstore%nsppol]) * Ha_eV), "(eV)"))
+ + ]
2574 : :
2575 [ + - + - : 1 : assume_gap = .not. all(gstore%erange_spin < zero)
- + ]
2576 : 1 : gaps = ebands%get_gaps(gap_err)
2577 [ + - + + ]: 2 : if (assume_gap) call gaps%print([std_out])
2578 : :
2579 [ + + + + ]: 2199 : select_kbz_spin = 0; cnt = 0
2580 : :
2581 [ + + ]: 2 : do spin=1,nsppol
2582 : : ! Init brange. NB: nb_kq == nb_k when erange filtering is used.
2583 [ + + ]: 3 : gstore%brange_k_spin(:, spin) = [huge(1), -huge(1)]
2584 [ + + ]: 3 : gstore%brange_kq_spin(:, spin) = [huge(1), -huge(1)]
2585 : 1 : abs_erange1 = abs(gstore%erange_spin(1, spin))
2586 : 1 : abs_erange2 = abs(gstore%erange_spin(2, spin))
2587 : :
2588 [ + - ]: 1 : if (assume_gap) then
2589 : : ! Get CBM and VBM with some tolerance
2590 : 1 : vmax = gaps%vb_max(spin) + tol2 * eV_Ha
2591 : 1 : cmin = gaps%cb_min(spin) - tol2 * eV_Ha
2592 : : else
2593 : 0 : vmax = ebands%fermie
2594 : 0 : cmin = ebands%fermie
2595 : : end if
2596 : :
2597 [ + + ]: 7 : do band=1, ebands%mband
2598 [ + + ]: 511 : do ik_ibz=1,gstore%nkibz
2599 : : !cnt = cnt + 1; if (mod(cnt, all_nproc) /= my_rank) cycle ! MPI parallelism inside comm
2600 : :
2601 : : ! Use iflag to filter k-points.
2602 : 504 : ee = ebands%eig(band, ik_ibz, spin)
2603 : 504 : iflag = 0
2604 : :
2605 [ + - ]: 504 : if (abs_erange1 > zero) then
2606 : : ! Filter valence states.
2607 [ # # # # ]: 0 : if (ee <= vmax .and. vmax - ee <= abs_erange1) then
2608 : 504 : iflag = 1 !; write(std_out, *), "Adding valence band", band, " with ee [eV]: ", ee * Ha_eV
2609 : : end if
2610 : : end if
2611 [ + - ]: 504 : if (abs_erange2 > zero) then
2612 : : ! Filter conduction states.
2613 [ + + + + ]: 504 : if (ee >= cmin .and. ee - cmin <= abs_erange2) then
2614 : : iflag = 1 !; write(std_out, *)"Adding conduction band", band, " with ee [eV]: ", ee * Ha_eV
2615 : : end if
2616 : : end if
2617 : :
2618 [ - + ]: 502 : if (iflag == 1) then
2619 : 8 : gstore%brange_k_spin(1, spin) = min(gstore%brange_k_spin(1, spin), band)
2620 : 8 : gstore%brange_k_spin(2, spin) = max(gstore%brange_k_spin(2, spin), band)
2621 : 8 : gstore%brange_kq_spin(1, spin) = min(gstore%brange_kq_spin(1, spin), band)
2622 : 8 : gstore%brange_kq_spin(2, spin) = max(gstore%brange_kq_spin(2, spin), band)
2623 : :
2624 : 0 : select case (gstore%kzone)
2625 : : case ("ibz")
2626 : 0 : ik_bz = kibz2bz(ik_ibz)
2627 : 0 : select_kbz_spin(ik_bz, spin) = iflag
2628 : :
2629 : : case ("bz")
2630 [ - + ]: 8 : call star_from_ibz_idx(ik_ibz, gstore%nkbz, gstore%kbz2ibz, nk_in_star, kstar_bz_inds)
2631 [ - + ]: 8 : ABI_CHECK(nk_in_star > 0, "Something wrong in star_from_ibz_idx")
2632 [ + + ]: 97 : do ii=1,nk_in_star
2633 : 89 : ik_bz = kstar_bz_inds(ii)
2634 : 97 : select_kbz_spin(ik_bz, spin) = iflag
2635 : : end do
2636 [ - + - - : 16 : ABI_FREE(kstar_bz_inds)
+ ]
2637 : : end select
2638 : : end if
2639 : :
2640 : : end do ! band
2641 : : end do ! ik_ibz
2642 : :
2643 : : !call wrtout(std_out, sjoin("brange_k_spin:", ltoa(gstore%brange_k_spin(:, spin))))
2644 : : !call wrtout(std_out, sjoin("count_select_kbz:", itoa(count(select_kbz_spin == 1))))
2645 : : !call wrtout(std_out, sjoin("brange_kq_spin:", ltoa(gstore%brange_k_qspin(:, spin))))
2646 : : !call wrtout(std_out, sjoin("count_select_kbz:", itoa(count(select_kbz_spin == 1))))
2647 : :
2648 [ + + + - : 3 : if (any(gstore%brange_k_spin(:, spin) == [huge(1), -huge(1)])) then
- + ]
2649 : 0 : ABI_ERROR("Empty list of states inside gstore_erange")
2650 : : end if
2651 [ + + + - : 4 : if (any(gstore%brange_kq_spin(:, spin) == [huge(1), -huge(1)])) then
- + ]
2652 : 0 : ABI_ERROR("Empty list of states inside gstore_erange")
2653 : : end if
2654 : :
2655 : : end do ! spin
2656 : :
2657 : : !call xmpi_sum(select_kbz_spin, comm, ierr)
2658 : : call recompute_select_qbz_spin(gstore, gstore%qbz, qbz2ibz, qibz2bz, gstore%kbz, gstore%kibz, gstore%kbz2ibz, kibz2bz, &
2659 [ + - - - : 1 : select_kbz_spin, select_qbz_spin)
- - - - -
+ ]
2660 : :
2661 : 2 : call gaps%free()
2662 : : end associate
2663 : :
2664 [ - + - + : 1 : end subroutine gstore_filter_erange__
- + - + -
+ - + - +
- + - + ]
2665 : : !!***
2666 : :
2667 : : !----------------------------------------------------------------------
2668 : :
2669 : : !!****f* m_gstore/gstore_filter_gw_qprange__
2670 : : !! NAME
2671 : : !! gstore_gw_filter_qprange__
2672 : : !!
2673 : : !! FUNCTION
2674 : : !! Filter k-points according to the input variable gw_qprange. Useful for ZPR.
2675 : : !!
2676 : : !! INPUTS
2677 : : !!
2678 : : !! OUTPUT
2679 : : !!
2680 : : !! SOURCE
2681 : :
2682 : 4 : subroutine gstore_filter_gw_qprange__(gstore, dtset, qbz2ibz, qibz2bz, kibz2bz, select_qbz_spin, select_kbz_spin)
2683 : :
2684 : : !Arguments ------------------------------------
2685 : : !scalars
2686 : : class(gstore_t),intent(inout) :: gstore
2687 : : type(dataset_type),intent(in) :: dtset
2688 : : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2689 : : integer,intent(in) :: kibz2bz(gstore%nkibz)
2690 : : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2691 : : integer,intent(out) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2692 : :
2693 : : !Local variables-------------------------------
2694 : : !scalars
2695 : : integer :: spin, ik_bz, ik_ibz, gap_err, ik_calc, nkcalc, mapl_kk(6), my_rank
2696 : 4 : type(gaps_t) :: gaps
2697 : : !arrays
2698 : 4 : integer,allocatable :: bstart_ks(:,:), nbcalc_ks(:,:)
2699 : 4 : real(dp),allocatable :: kcalc(:,:)
2700 : : !----------------------------------------------------------------------
2701 : :
2702 : : ABI_UNUSED(qbz2ibz)
2703 : : ABI_UNUSED(qibz2bz)
2704 : :
2705 : : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2706 : :
2707 : 8 : my_rank = xmpi_comm_rank(gstore%comm)
2708 : :
2709 : 4 : call wrtout(std_out, sjoin(" Filtering k-points using gw_qprange:", itoa(dtset%gw_qprange)))
2710 [ - + ]: 4 : if (gstore%qzone /= "bz") then
2711 : 0 : ABI_ERROR(sjoin('gw_qprange filtering requires gstore_qzone = "bz" while it is: ', gstore%qzone))
2712 : : end if
2713 : :
2714 : 4 : gaps = ebands%get_gaps(gap_err)
2715 [ + - + + ]: 8 : if (my_rank == 0) call gaps%print([std_out])
2716 [ - + ]: 4 : if (gap_err /= 0) then
2717 : 0 : ABI_ERROR("Cannot compute fundamental and direct gap (likely metal).")
2718 : : end if
2719 : :
2720 : : ! Use gw_qprange to select the interesting k-points and the corresponding bands.
2721 : : !
2722 : : ! 0 --> Compute the QP corrections only for the fundamental and the direct gap.
2723 : : ! +num --> Compute the QP corrections for all the k-points in the irreducible zone and include `num`
2724 : : ! bands above and below the Fermi level.
2725 : : ! -num --> Compute the QP corrections for all the k-points in the irreducible zone.
2726 : : ! Include all occupied states and `num` empty states.
2727 : :
2728 : : ! Compute nkcalc, kcalc, bstart_ks, nbcalc_ks
2729 [ - + ]: 4 : if (dtset%gw_qprange /= 0) then
2730 : 0 : call sigtk_kcalc_from_qprange(dtset, gstore%cryst, ebands, dtset%gw_qprange, nkcalc, kcalc, bstart_ks, nbcalc_ks)
2731 : : else
2732 : : ! gw_qprange is not specified in the input.
2733 : : ! Include direct and fundamental KS gap or include states depending on the position wrt band edges.
2734 : 4 : call sigtk_kcalc_from_gaps(dtset, ebands, gaps, nkcalc, kcalc, bstart_ks, nbcalc_ks)
2735 : : end if
2736 : :
2737 : : ! TODO: kcalc should be spin-dependent to handle magnetic semiconductors.
2738 [ + + + + ]: 152 : select_kbz_spin = 0
2739 [ + + ]: 8 : do spin=1,gstore%nsppol
2740 [ + + ]: 14 : do ik_calc=1,nkcalc
2741 [ - + ]: 6 : if (kpts_map("symrel", ebands%kptopt, gstore%cryst, gstore%krank_ibz, 1, kcalc(:,ik_calc), mapl_kk) /= 0) then
2742 : 0 : ABI_ERROR(sjoin("Cannot map kcalc to IBZ with kcalc:", ktoa(kcalc(:,ik_calc))))
2743 : : end if
2744 : : ! Change select_kbz_spin
2745 : 6 : ik_ibz = mapl_kk(1)
2746 : 10 : ik_bz = kibz2bz(ik_ibz); select_kbz_spin(ik_bz, spin) = 1
2747 : : end do
2748 : : end do ! spin
2749 : :
2750 : : !call recompute_select_qbz_spin(gstore, gstore%qbz, qbz2ibz, qibz2bz, gstore%kbz, gstore%kibz, gstore%kbz2ibz, gstore%kibz2bz, &
2751 : : ! select_kbz_spin, select_qbz_spin)
2752 : :
2753 [ - + ]: 4 : ABI_FREE(kcalc)
2754 [ - + ]: 4 : ABI_FREE(bstart_ks)
2755 [ - + ]: 4 : ABI_FREE(nbcalc_ks)
2756 : 8 : call gaps%free()
2757 : : end associate
2758 : :
2759 [ - + - + : 4 : end subroutine gstore_filter_gw_qprange__
- + - + -
+ - + - +
- + ]
2760 : : !!***
2761 : :
2762 : : !!****f* m_gstore/recompute_select_qbz_spin
2763 : : !! NAME
2764 : : !! recompute_select_qbz_spin
2765 : : !!
2766 : : !! FUNCTION
2767 : : !! Recompute select_qbz_spin table after the filtering on the k-points.
2768 : : !!
2769 : : !! INPUTS
2770 : : !!
2771 : : !! OUTPUT
2772 : : !!
2773 : : !! SOURCE
2774 : :
2775 : 1 : subroutine recompute_select_qbz_spin(gstore, qbz, qbz2ibz, qibz2bz, kbz, kibz, kbz2ibz, kibz2bz, &
2776 : 1 : select_kbz_spin, select_qbz_spin)
2777 : :
2778 : : !Arguments ------------------------------------
2779 : : !scalars
2780 : : class(gstore_t),intent(inout) :: gstore
2781 : : !arrays
2782 : : real(dp),intent(in) :: qbz(3, gstore%nqbz)
2783 : : integer,intent(in) :: qbz2ibz(6,gstore%nqbz), qibz2bz(gstore%nqibz)
2784 : : integer,intent(in) :: kbz2ibz(6,gstore%nkbz), kibz2bz(gstore%nkibz)
2785 : : real(dp),target,intent(in) :: kibz(3, gstore%nkibz), kbz(3, gstore%nkbz)
2786 : : integer,intent(in) :: select_kbz_spin(gstore%nkbz, gstore%nsppol)
2787 : : integer,intent(out) :: select_qbz_spin(gstore%nqbz, gstore%nsppol)
2788 : :
2789 : : !Local variables-------------------------------
2790 : : !scalars
2791 : : integer :: all_nproc, my_rank, ierr, ii, ik_bz, iq_bz, iq_ibz, ikq_ibz, ikq_bz, len_kpts_ptr, ebands_kptopt, spin
2792 : : !arrays
2793 : 1 : integer,allocatable :: map_kq(:,:)
2794 : : real(dp) :: qpt(3)
2795 : 1 : real(dp),contiguous, pointer :: kpts_ptr(:,:)
2796 : : ! *************************************************************************
2797 : :
2798 : : ABI_UNUSED(kbz2ibz)
2799 : : ABI_UNUSED(qbz2ibz)
2800 : :
2801 : 1 : all_nproc = xmpi_comm_size(gstore%comm); my_rank = xmpi_comm_rank(gstore%comm)
2802 : 1 : ebands_kptopt = gstore%ebands%kptopt
2803 : :
2804 [ + + + + ]: 2199 : select_qbz_spin = 0
2805 : :
2806 [ - + ]: 1 : if (gstore%kzone == "ibz") kpts_ptr => kibz
2807 [ + - ]: 1 : if (gstore%kzone == "bz") kpts_ptr => kbz
2808 : 1 : len_kpts_ptr = size(kpts_ptr, dim=2)
2809 [ - + + - : 3 : ABI_MALLOC(map_kq, (6, len_kpts_ptr))
+ - + - -
+ - + ]
2810 : :
2811 : 0 : select case (gstore%qzone)
2812 : : case ("ibz")
2813 [ # # ]: 0 : do iq_ibz=1,gstore%nqibz
2814 [ # # ]: 0 : if (mod(iq_ibz, all_nproc) /= my_rank) cycle ! MPI parallelism.
2815 [ # # ]: 0 : qpt = gstore%qibz(:, iq_ibz)
2816 : 0 : iq_bz = qibz2bz(iq_ibz)
2817 : : ! k + q_ibz --> k IBZ --> k BZ
2818 : :
2819 [ # # ]: 0 : if (kpts_map("symrel", ebands_kptopt, gstore%cryst, gstore%krank_ibz, len_kpts_ptr, kpts_ptr, map_kq, qpt=qpt) /= 0) then
2820 : 0 : ABI_ERROR("Cannot map k+q to IBZ!")
2821 : : end if
2822 : :
2823 [ # # ]: 0 : do ii=1,len_kpts_ptr
2824 : : ! get the k-index in BZ
2825 : 0 : select case (gstore%kzone)
2826 : : case ("bz")
2827 : 0 : ik_bz = ii
2828 : : case ("ibz")
2829 [ # # # ]: 0 : ik_bz = kibz2bz(ii)
2830 : : end select
2831 : :
2832 [ # # ]: 0 : do spin=1,gstore%nsppol
2833 [ # # ]: 0 : if (select_kbz_spin(ik_bz, spin) /= 0) then
2834 : : ! now, see if q-point connects k-points inside the filtered zone
2835 : 0 : ikq_ibz = map_kq(1, ii)
2836 : 0 : ikq_bz = kibz2bz(ikq_ibz)
2837 [ # # ]: 0 : select_qbz_spin(iq_bz, :) = select_qbz_spin(iq_bz, :) + select_kbz_spin(ikq_bz, :)
2838 : : end if
2839 : : end do
2840 : : end do
2841 : : end do ! iq_ibz
2842 : :
2843 : : case ("bz")
2844 [ - + - + : 2198 : do iq_bz=1,gstore%nqbz
+ ]
2845 [ + - ]: 2197 : if (mod(iq_bz, all_nproc) /= my_rank) cycle ! MPI parallelism.
2846 [ + + ]: 8788 : qpt = qbz(:, iq_bz)
2847 : : !iq_ibz = qbz2ibz(1, iq_bz)
2848 : : ! k + q_bz --> k IBZ --> k BZ
2849 : :
2850 [ - + ]: 2197 : if (kpts_map("symrel", ebands_kptopt, gstore%cryst, gstore%krank_ibz, len_kpts_ptr, kpts_ptr, map_kq, qpt=qpt) /= 0) then
2851 : 0 : ABI_ERROR("Cannot map k+q to IBZ!")
2852 : : end if
2853 : :
2854 : : ! here we loop over all k-points in iBZ (kzone="ibz") or BZ (kzone="bz")
2855 [ + + ]: 4829007 : do ii=1,len_kpts_ptr
2856 : : ! but for each spin, we have to loop only over e-range filtered kpts
2857 : :
2858 : : ! get the k-index in BZ
2859 : 9653618 : select case (gstore%kzone)
2860 : : case ("bz")
2861 : 4826809 : ik_bz = ii
2862 : : case ("ibz")
2863 [ + - - ]: 4826809 : ik_bz = kibz2bz(ii)
2864 : : end select
2865 : :
2866 [ + + ]: 9655815 : do spin=1,gstore%nsppol
2867 : : ! Now, see if q-point connects k-points inside the filtered zone
2868 [ + + ]: 9653618 : if (select_kbz_spin(ik_bz, spin) /= 0) then
2869 : 195533 : ikq_ibz = map_kq(1, ii)
2870 : 195533 : ikq_bz = kibz2bz(ikq_ibz)
2871 : 195533 : select_qbz_spin(iq_bz, spin) = select_qbz_spin(iq_bz, spin) + select_kbz_spin(ikq_bz, spin)
2872 : : end if
2873 : : end do
2874 : :
2875 : : end do
2876 : : end do
2877 : : end select
2878 : :
2879 : 1 : call xmpi_sum(select_qbz_spin, gstore%comm, ierr)
2880 : :
2881 [ - + ]: 1 : ABI_FREE(map_kq)
2882 : :
2883 : 1 : end subroutine recompute_select_qbz_spin
2884 : : !!***
2885 : :
2886 : : !!****f* m_gstore/gstore_spin2my_is
2887 : : !! NAME
2888 : : !! gstore_spin2my_is
2889 : : !!
2890 : : !! FUNCTION
2891 : : !! Return the local spin index from the global spin index.
2892 : : !! 0 if this spin is not treated by this MPI proc.
2893 : : !!
2894 : : !! SOURCE
2895 : :
2896 : 16 : integer pure function gstore_spin2my_is(gstore, spin) result(my_is)
2897 : :
2898 : : !Arguments ------------------------------------
2899 : : class(gstore_t),intent(in) :: gstore
2900 : : integer,intent(in) :: spin
2901 : : !----------------------------------------------------------------------
2902 : :
2903 [ + - ]: 16 : do my_is=1,gstore%my_nspins
2904 [ - + ]: 16 : if (gstore%my_spins(my_is) == spin) return
2905 : : end do
2906 : 16 : my_is = 0
2907 : :
2908 : : end function gstore_spin2my_is
2909 : : !!***
2910 : :
2911 : : !----------------------------------------------------------------------
2912 : :
2913 : : !!****f* m_gstore/gstore_fill_bks_mask
2914 : : !! NAME
2915 : : !! gstore_fill_bks_mask
2916 : : !!
2917 : : !! FUNCTION
2918 : : !! Fills the bks_mask array defining the set of wavefunctions that should be read
2919 : : !! from the WFK file by this MPI rank when computing the KS e-ph matrix elements.
2920 : : !!
2921 : : !! INPUTS
2922 : : !!
2923 : : !! OUTPUT
2924 : : !!
2925 : : !! SOURCE
2926 : :
2927 : 12 : subroutine gstore_fill_bks_mask(gstore, mband, nkibz, nsppol, bks_mask)
2928 : :
2929 : : !Arguments ------------------------------------
2930 : : class(gstore_t),intent(inout) :: gstore
2931 : : integer,intent(in) :: mband, nkibz, nsppol
2932 : : logical,intent(out) :: bks_mask(mband, nkibz, nsppol)
2933 : :
2934 : : !Local variables-------------------------------
2935 : : !scalars
2936 : : integer :: my_is, my_ik, my_iq, spin, ik_ibz, ikq_ibz, ebands_kptopt, bstart_k, bstop_k, bstart_kq, bstop_kq
2937 : : real(dp) :: weight_q, cpu, wall, gflops
2938 : : !arrays
2939 : 12 : integer,allocatable :: map_kq(:,:)
2940 : : real(dp) :: qpt(3)
2941 : : !----------------------------------------------------------------------
2942 : :
2943 : 12 : call cwtime(cpu, wall, gflops, "start")
2944 : : associate (cryst => gstore%cryst, ebands => gstore%ebands)
2945 : :
2946 [ + + + + : 1992 : bks_mask = .False.; ebands_kptopt = gstore%ebands%kptopt
+ + ]
2947 : :
2948 [ + + ]: 24 : do my_is=1,gstore%my_nspins
2949 : 12 : associate (gqk => gstore%gqk(my_is))
2950 : 12 : spin = gstore%my_spins(my_is)
2951 : 12 : bstart_k = gqk%bstart_k; bstop_k = gqk%bstop_k
2952 : 12 : bstart_kq = gqk%bstart_kq; bstop_kq = gqk%bstop_kq
2953 : :
2954 : : ! Stop if dtset%nband < gstore%nband before sigfaulting.
2955 : 0 : ABI_CHECK_ILEQ(bstop_k, mband, "bstop_k should be smaller that mband present in WFK")
2956 [ - + ]: 12 : ABI_CHECK_ILEQ(bstop_kq, mband, "bstop_kq should be smaller that mband present in WFK")
2957 : :
2958 : : ! We need the image of this k-point in the IBZ.
2959 [ + + ]: 330 : do my_ik=1,gqk%my_nk
2960 : 318 : ik_ibz = gqk%my_k2ibz(1, my_ik)
2961 [ + + ]: 1139 : bks_mask(bstart_k:bstop_k, ik_ibz, spin) = .True.
2962 : : end do
2963 : :
2964 : : ! As well as the image of k+q in the IBZ.
2965 [ - + + - : 36 : ABI_MALLOC(map_kq, (6, gqk%my_nk))
+ - + - -
+ - + ]
2966 : :
2967 [ + + ]: 1057 : do my_iq=1,gqk%my_nq
2968 : 1045 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
2969 : :
2970 [ - + ]: 1045 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, map_kq, qpt=qpt) /= 0) then
2971 : 0 : ABI_ERROR(sjoin("Cannot map k+q to IBZ with qpt:", ktoa(qpt)))
2972 : : end if
2973 : :
2974 [ + + ]: 74912 : do my_ik=1,gqk%my_nk
2975 : 73855 : ikq_ibz = map_kq(1, my_ik)
2976 [ + + ]: 193527 : bks_mask(bstart_kq:bstop_kq, ikq_ibz, spin) = .True.
2977 : : end do
2978 : : end do
2979 : :
2980 [ - + - + ]: 24 : ABI_FREE(map_kq)
2981 : : end associate
2982 : : end do ! my_is
2983 : :
2984 : 12 : call cwtime_report(" gstore_fill_bks_mask", cpu, wall, gflops)
2985 : : end associate
2986 : :
2987 : 24 : end subroutine gstore_fill_bks_mask
2988 : : !!***
2989 : :
2990 : : !----------------------------------------------------------------------
2991 : :
2992 : : !!****f* m_gstore/gstore_fill_bks_mask_with_pp
2993 : : !! NAME
2994 : : !! gstore_fill_bks_mask_with_pp
2995 : : !!
2996 : : !! FUNCTION
2997 : : !! Fill the bks_mask array defining the set of states that should be read from the WFK file
2998 : : !! by this MPI rank when computing the GWPT e-ph matrix elements in which we have
2999 : : !! to consider k+q, k-q and k+q-p as well as the sum over states (bsum).
3000 : : !!
3001 : : !! INPUTS
3002 : : !!
3003 : : !! OUTPUT
3004 : : !!
3005 : : !! SOURCE
3006 : :
3007 : 3 : subroutine gstore_fill_bks_mask_pp_mesh(gstore, ecut, mband, nkibz, nsppol, my_pp_start_spin, my_pp_stop_spin, pp_mesh, &
3008 : 3 : my_bsum_start, my_bsum_stop, bks_mask, mpw, gmax)
3009 : :
3010 : : !Arguments ------------------------------------
3011 : : class(gstore_t),target,intent(inout) :: gstore
3012 : : real(dp),intent(in) :: ecut
3013 : : integer,intent(in) :: mband, nkibz, nsppol
3014 : : integer :: my_pp_start_spin(nsppol), my_pp_stop_spin(nsppol)
3015 : : type(kmesh_t),intent(in) :: pp_mesh
3016 : : integer,intent(in) :: my_bsum_start(nsppol), my_bsum_stop(nsppol)
3017 : : logical,intent(out) :: bks_mask(mband, nkibz, nsppol)
3018 : : integer,intent(out) :: mpw, gmax(3)
3019 : :
3020 : : !Local variables-------------------------------
3021 : : !scalars
3022 : : integer,parameter :: istwfk1 = 1
3023 : : 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)
3024 : : real(dp) :: weight_q, cpu, wall, gflops
3025 : : type(gqk_t),pointer :: gqk
3026 : : type(crystal_t),pointer :: cryst
3027 : : !arrays
3028 : 3 : integer,allocatable :: map_kq(:,:), gtmp(:,:)
3029 : : real(dp) :: qpt(3), pp(3), kk(3)
3030 : : !----------------------------------------------------------------------
3031 : :
3032 : 3 : call cwtime(cpu, wall, gflops, "start")
3033 : :
3034 : : ! TODO: These loops can be parallelized using bsum_comm and pert_comm if needed.
3035 [ + + + + : 237 : bks_mask = .False.; cryst => gstore%cryst
+ + ]
3036 : 3 : ebands_kptopt = gstore%ebands%kptopt
3037 : 3 : mpw = 0; gmax = 0
3038 : :
3039 [ + + ]: 6 : do my_is=1,gstore%my_nspins
3040 : 3 : gqk => gstore%gqk(my_is); spin = gstore%my_spins(my_is)
3041 : :
3042 : : ! These are the first and last band indices used in the sum over states (possibly MPI-distributed)
3043 : 3 : b1 = my_bsum_start(spin); b2 = my_bsum_stop(spin)
3044 : :
3045 : : ! Stop if dtset%nband < gstore%nband before sigfaulting.
3046 [ - + ]: 3 : ABI_CHECK_ILEQ(gqk%bstop_k, mband, "bstop_k should be smaller that mband present in WFK")
3047 [ - + ]: 3 : ABI_CHECK_ILEQ(gqk%bstop_kq, mband, "bstop_kq should be smaller that mband present in WFK")
3048 [ - + ]: 3 : ABI_CHECK_ILEQ(b2, mband, "max band index in sum should be smaller that mband present in WFK")
3049 : :
3050 [ - + + - : 9 : ABI_MALLOC(map_kq, (6, gqk%my_nk))
+ - + - -
+ - + ]
3051 : :
3052 [ + + ]: 8 : do my_ik=1,gqk%my_nk
3053 [ + + ]: 20 : kk = gqk%my_kpts(:, my_ik); ik_ibz = gqk%my_k2ibz(1, my_ik)
3054 : :
3055 : : ! We need the image of this k-point in the IBZ for the incoming state |psi_nk>.
3056 [ + + ]: 33 : bks_mask(gqk%bstart_k:gqk%bstop_k, ik_ibz, spin) = .True.
3057 : :
3058 : : ! We also need the image of k+q in the IBZ for the outgoing state <psi_mkq|.
3059 [ + + ]: 104 : do my_iq=1,gqk%my_nq
3060 : 96 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3061 [ - + ]: 96 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, 1, kk, map_kq, qpt=qpt) /= 0) then
3062 : 0 : ABI_ERROR(sjoin("Cannot map k+q to IBZ with qpt:", ktoa(qpt)))
3063 : : end if
3064 : 96 : ikq_ibz = map_kq(1, 1)
3065 [ + + ]: 1125 : bks_mask(gqk%bstart_kq:gqk%bstop_kq, ikq_ibz, spin) = .True.
3066 : : end do ! my_iq
3067 : :
3068 : : end do ! my_ok
3069 : :
3070 : : ! We also need the image of k-p in the IBZ for the pp wavevectors treated by this MPI rank.
3071 : : ! These states are summed over so use b1 and b2.
3072 [ + + ]: 83 : do ipp_bz=my_pp_start_spin(spin), my_pp_stop_spin(spin)
3073 [ + + ]: 320 : pp = pp_mesh%bz(:,ipp_bz)
3074 [ + + - + ]: 320 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, map_kq, qpt=-pp) /= 0) then
3075 : 0 : ABI_ERROR(sjoin("Cannot map k-p to IBZ with qpt:", ktoa(qpt), "and pp:", ktoa(pp)))
3076 : : end if
3077 : :
3078 [ + + ]: 179 : do my_ik=1,gqk%my_nk
3079 : 96 : ikq_ibz = map_kq(1, my_ik)
3080 [ + + ]: 1120 : bks_mask(b1:b2, ikq_ibz, spin) = .True.
3081 : : ! Compute g-sphere, returns onpw. Note istwfk == 1.
3082 [ + + ]: 384 : kk = gqk%my_kpts(:, my_ik)
3083 [ + + - + ]: 384 : call get_kg(kk-pp, istwfk1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3084 [ - + ]: 176 : ABI_FREE(gtmp)
3085 : : end do
3086 : : end do ! ipp_bz
3087 : :
3088 : : ! We also need the image of k+q-p in the IBZ for the pp wavevectors treated by this MPI rank.
3089 : : ! These states are summed over so use b1 and b2.
3090 [ + + ]: 83 : do my_iq=1,gqk%my_nq
3091 : 80 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3092 : :
3093 [ + + ]: 4307 : do ipp_bz=my_pp_start_spin(spin), my_pp_stop_spin(spin)
3094 [ + + ]: 16896 : pp = pp_mesh%bz(:,ipp_bz)
3095 : :
3096 [ + + - + ]: 16896 : if (kpts_map("symrel", ebands_kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, map_kq, qpt=qpt-pp) /= 0) then
3097 : 0 : ABI_ERROR(sjoin("Cannot map k+q-p to IBZ with qpt:", ktoa(qpt), "and pp:", ktoa(pp)))
3098 : : end if
3099 : :
3100 [ + + ]: 8656 : do my_ik=1,gqk%my_nk
3101 : 4352 : ikq_ibz = map_kq(1, my_ik)
3102 [ + + ]: 48384 : bks_mask(b1:b2, ikq_ibz, spin) = .True.
3103 : : ! Compute g-sphere, returns onpw. Note istwfk = 1.
3104 [ + + ]: 17408 : kk = gqk%my_kpts(:, my_ik)
3105 [ + + - + ]: 17408 : call get_kg(kk+qpt-pp, istwfk1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3106 [ - + ]: 8576 : ABI_FREE(gtmp)
3107 : : end do
3108 : : end do ! ipp_bz
3109 : :
3110 : : end do ! my_iq
3111 : :
3112 [ - + ]: 6 : ABI_FREE(map_kq)
3113 : : end do ! my_is
3114 : :
3115 : 3 : my_mpw = mpw; call xmpi_max(my_mpw, mpw, gstore%comm, ierr)
3116 : 3 : my_gmax = gmax; call xmpi_max(my_gmax, gmax, gstore%comm, ierr)
3117 : :
3118 : : ! TODO
3119 : : !call gstore%get_mpw_gmax(ecut, mpw, gmax, pp_max=)
3120 : :
3121 : 3 : call wrtout(std_out, sjoin(' Optimal value of mpw: ', itoa(mpw)))
3122 : 3 : call cwtime_report(" gstore_fill_bks_mask_pp_mesh", cpu, wall, gflops)
3123 : :
3124 [ - + ]: 3 : end subroutine gstore_fill_bks_mask_pp_mesh
3125 : : !!***
3126 : :
3127 : : !----------------------------------------------------------------------
3128 : :
3129 : : !!****f* m_gstore/gstore_get_mpw_gmax
3130 : : !! NAME
3131 : : !! gstore_get_mpw_gmax
3132 : : !!
3133 : : !! FUNCTION
3134 : : !! Compute the maximum number of PWs for all possible k+q treated.
3135 : : !!
3136 : : !! INPUTS
3137 : : !!
3138 : : !! OUTPUT
3139 : : !!
3140 : : !! SOURCE
3141 : :
3142 : 12 : subroutine gstore_get_mpw_gmax(gstore, ecut, mpw, gmax, pp_max)
3143 : :
3144 : : !Arguments ------------------------------------
3145 : : class(gstore_t),intent(in) :: gstore
3146 : : real(dp),intent(in) :: ecut
3147 : : integer,intent(out) :: mpw, gmax(3)
3148 : : integer,optional,intent(in) :: pp_max
3149 : :
3150 : : !Local variables-------------------------------
3151 : : integer,parameter :: istwfk1 = 1
3152 : : integer :: my_is, my_ik, my_iq, spin, onpw, ierr, my_mpw, ipx, ipy, ipz, nprocs, my_rank, pp_max__ !, cnt, i1, i2, i3,
3153 : : real(dp) :: weight_q, cpu, wall, gflops
3154 : : !arrays
3155 : : integer :: my_gmax(3)
3156 : 12 : integer,allocatable :: gtmp(:,:)
3157 : : real(dp) :: kk(3), kq(3), qpt(3), pp(3) !, kq_max(3)
3158 : : !----------------------------------------------------------------------
3159 : :
3160 : : ! TODO: This is an hotspot due to the double loop over k and q. Should use a geometrical approach to compute mpw and gmax.
3161 : 12 : call wrtout(std_out, " Computing mpw. This may take some time for dense k/q meshes...", pre_newlines=1)
3162 : 12 : call cwtime(cpu, wall, gflops, "start")
3163 : :
3164 : 12 : nprocs = xmpi_comm_size(gstore%comm); my_rank = xmpi_comm_rank(gstore%comm)
3165 : 12 : mpw = 0; gmax = 0
3166 [ - + ]: 12 : pp_max__ = 0; if (present(pp_max)) pp_max__ = pp_max
3167 : :
3168 [ + + ]: 24 : do my_is=1,gstore%my_nspins
3169 : 12 : associate (gqk => gstore%gqk(my_is))
3170 : 12 : spin = gstore%my_spins(my_is)
3171 [ + + ]: 330 : do my_ik=1,gqk%my_nk
3172 [ + + ]: 1272 : kk = gqk%my_kpts(:, my_ik)
3173 : :
3174 : : ! Compute g-sphere, returns onpw. Note istwfk == 1.
3175 [ - + ]: 318 : call get_kg(kk, istwfk1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3176 [ - + ]: 318 : ABI_FREE(gtmp)
3177 : :
3178 [ + + ]: 74185 : do my_iq=1,gqk%my_nq
3179 : 73855 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3180 [ + + ]: 295420 : kq = kk + qpt
3181 : :
3182 : : ! TODO: g0 umklapp here can enter into play! gmax could not be large enough!
3183 [ + + ]: 148028 : do ipz=-pp_max__,pp_max__
3184 [ + + ]: 221565 : do ipy=-pp_max__,pp_max__
3185 [ + + ]: 221565 : do ipx=-pp_max__,pp_max__
3186 [ + + ]: 295420 : pp = [ipx, ipy, ipz] * half
3187 [ + + - + ]: 295420 : call get_kg(kq - pp, 1, ecut, gstore%cryst%gmet, onpw, gtmp, mpw=mpw, gmax=gmax)
3188 [ - + ]: 147710 : ABI_FREE(gtmp)
3189 : : end do
3190 : : end do
3191 : : end do
3192 : : end do ! my_iq
3193 : :
3194 : : end do ! my_ik
3195 : : end associate
3196 : : end do ! my_is
3197 : :
3198 : 12 : my_mpw = mpw; call xmpi_max(my_mpw, mpw, gstore%comm, ierr)
3199 : 12 : my_gmax = gmax; call xmpi_max(my_gmax, gmax, gstore%comm, ierr)
3200 : :
3201 : 12 : call wrtout(std_out, sjoin(' Optimal value of mpw: ', itoa(mpw), "with gmax:", ltoa(gmax)))
3202 : 12 : call cwtime_report(" gstore_get_mpw_gmax", cpu, wall, gflops)
3203 : :
3204 [ - + ]: 12 : end subroutine gstore_get_mpw_gmax
3205 : : !!***
3206 : :
3207 : : !----------------------------------------------------------------------
3208 : :
3209 : : !!****f* m_gstore/gstore_free
3210 : : !! NAME
3211 : : !! gstore_free
3212 : : !!
3213 : : !! FUNCTION
3214 : : !! Free dynamic memory in gstore_t.
3215 : : !!
3216 : : !! SOURCE
3217 : :
3218 : 24 : subroutine gstore_free(gstore)
3219 : :
3220 : : !Arguments ------------------------------------
3221 : : class(gstore_t),intent(inout) :: gstore
3222 : :
3223 : : !Local variables-------------------------------
3224 : : integer :: my_is
3225 : : !----------------------------------------------------------------------
3226 : :
3227 [ + + ]: 48 : do my_is=1,gstore%my_nspins
3228 : 48 : call gstore%gqk(my_is)%free()
3229 : : end do
3230 [ + - + + : 48 : ABI_SFREE(gstore%gqk)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ ]
3231 : :
3232 [ - + ]: 24 : ABI_SFREE(gstore%delta_ef_kibz_spin)
3233 [ + - ]: 24 : ABI_SFREE(gstore%qibz)
3234 [ + - ]: 24 : ABI_SFREE(gstore%wtq)
3235 [ + - ]: 24 : ABI_SFREE(gstore%my_spins)
3236 [ + - ]: 24 : ABI_SFREE(gstore%brange_k_spin)
3237 [ + - ]: 24 : ABI_SFREE(gstore%brange_kq_spin)
3238 [ + - ]: 24 : ABI_SFREE(gstore%glob_nk_spin)
3239 [ + - ]: 24 : ABI_SFREE(gstore%glob_nq_spin)
3240 [ + - ]: 24 : ABI_SFREE(gstore%kglob2bz)
3241 [ + - ]: 24 : ABI_SFREE(gstore%kbz2ibz)
3242 [ + - ]: 24 : ABI_SFREE(gstore%erange_spin)
3243 [ + - ]: 24 : ABI_SFREE(gstore%qbz)
3244 [ + - ]: 24 : ABI_SFREE(gstore%kbz)
3245 : :
3246 [ - + ]: 24 : if (gstore%has_wannier) then
3247 : 0 : call gstore%ebands%free()
3248 [ # # # # : 0 : ABI_FREE_SCALAR(gstore%ebands)
# # # # #
# # # # #
# # # # #
# # # #
# ]
3249 : : nullify(gstore%ebands)
3250 : : end if
3251 : :
3252 : 24 : call gstore%krank_ibz%free()
3253 : 24 : call gstore%qrank_ibz%free()
3254 : 24 : gstore%with_cplex = -1
3255 : :
3256 : 24 : end subroutine gstore_free
3257 : : !!***
3258 : :
3259 : : !----------------------------------------------------------------------
3260 : :
3261 : : !!****f* m_gstore/gqk_myqpt
3262 : : !! NAME
3263 : : !! gqk_myqpt
3264 : : !!
3265 : : !! FUNCTION
3266 : : !! Return the weight_q and the reduced coordinates of the q-point from the local index my_iq.
3267 : : !!
3268 : : !! INPUTS
3269 : : !!
3270 : : !! OUTPUT
3271 : : !!
3272 : : !! SOURCE
3273 : :
3274 : 77422 : pure subroutine gqk_myqpt(gqk, my_iq, gstore, weight_q, qpt)
3275 : :
3276 : : !Arguments ------------------------------------
3277 : : class(gqk_t),intent(in) :: gqk
3278 : : class(gstore_t),intent(in) :: gstore
3279 : : integer,intent(in) :: my_iq
3280 : : real(dp),intent(out) :: weight_q, qpt(3)
3281 : :
3282 : : !Local variables ------------------------------
3283 : : integer :: iq_ibz, isym_q, trev_q, tsign_q, g0_q(3)
3284 : : logical :: isirr_q
3285 : : !----------------------------------------------------------------------
3286 : :
3287 : : ! Symmetry tables for q-points.
3288 : 77422 : iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
3289 [ + + ]: 309688 : trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5, my_iq)
3290 : : isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
3291 [ - + ]: 77422 : tsign_q = 1; if (trev_q == 1) tsign_q = -1
3292 : :
3293 : : ! NB: Use symrec convention for q
3294 [ + + + + : 2167816 : qpt = tsign_q * matmul(gstore%cryst%symrec(:,:,isym_q), gstore%qibz(:, iq_ibz)) + g0_q
+ + + + +
- + - +
+ ]
3295 : :
3296 : 0 : select case(gstore%qzone)
3297 : : case ("ibz")
3298 : 0 : weight_q = gstore%wtq(iq_ibz)
3299 : : case ("bz")
3300 [ - + - ]: 77422 : weight_q = one / gstore%nqbz
3301 : : end select
3302 : :
3303 : 77422 : end subroutine gqk_myqpt
3304 : : !!***
3305 : :
3306 : : !----------------------------------------------------------------------
3307 : :
3308 : : !!****f* m_gstore/gqk_dbldelta_qpt
3309 : : !! NAME
3310 : : !! gqk_dbldelta_qpt
3311 : : !!
3312 : : !! FUNCTION
3313 : : !! Note that k/q weights are not included in dbl_delta_q
3314 : : !!
3315 : : !! INPUTS
3316 : : !!
3317 : : !! OUTPUT
3318 : : !!
3319 : : !! SOURCE
3320 : :
3321 : 0 : subroutine gqk_dbldelta_qpt(gqk, my_iq, gstore, eph_intmeth, eph_fsmear, qpt, weight_q, dbl_delta_q)
3322 : :
3323 : : !Arguments ------------------------------------
3324 : : class(gqk_t),intent(in) :: gqk
3325 : : class(gstore_t),target,intent(inout) :: gstore
3326 : : integer,intent(in) :: my_iq, eph_intmeth
3327 : : real(dp),intent(in) :: eph_fsmear
3328 : : real(dp),intent(out) :: qpt(3), weight_q, dbl_delta_q(gqk%nb_kq, gqk%nb_k, gqk%my_nk)
3329 : :
3330 : : !Local variables ------------------------------
3331 : : !scalars
3332 : : real(dp), parameter :: min_smear = tol9
3333 : : integer :: nb_k, nb_kq, nkbz, spin, my_ik, ib, ib1, ib2, band1, band2, nesting
3334 : : integer :: ik_ibz, isym_k, trev_k, tsign_k, g0_k(3)
3335 : : integer :: ikq_ibz, isym_kq, trev_kq, tsign_kq, g0_kq(3), ii, i1, i2, i3, cnt, ik_bz, ltetra
3336 : : real(dp) :: g1, g2, sigma !, weight_k !, cpu, wall, gflops
3337 : : logical :: isirr_k, isirr_kq, use_adaptive
3338 : : type(ebands_t), pointer :: ebands
3339 : : type(crystal_t), pointer :: cryst
3340 : 0 : type(krank_t) :: my_krank
3341 : : !arrays
3342 : : integer :: nge(3), ngw(3)
3343 : 0 : integer,allocatable :: my_kqmap(:,:), kmesh_map(:,:)
3344 : 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)
3345 : 0 : real(dp),allocatable :: eig_k(:,:), eig_kq(:,:), kmesh(:,:), wght_bz(:,:,:)
3346 : : !----------------------------------------------------------------------
3347 : :
3348 : 0 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq; nkbz = gstore%nkbz; spin = gqk%spin
3349 : 0 : ebands => gstore%ebands; cryst => gstore%cryst
3350 : :
3351 [ # # ]: 0 : ABI_CHECK_IEQ(nb_k, nb_kq, "gqk_dbldelta_qpt does not support nb_k != nb_kq")
3352 : :
3353 : 0 : call gqk%myqpt(my_iq, gstore, weight_q, qpt)
3354 : :
3355 : : ! The double delta with tetra is ill-defined for q == 0. In this case we fall back to gaussian.
3356 [ # # # # : 0 : nesting = merge(1, 0, abs(eph_intmeth) == 2 .and. all(abs(qpt) < tol12))
# # # # ]
3357 : :
3358 [ # # # # ]: 0 : rlatt = gstore%ebands%kptrlatt; call matr3inv(rlatt, klatt)
3359 [ # # ]: 0 : kmesh_cartvec(:, 1) = cryst%gprimd(:,1)*klatt(1,1) + cryst%gprimd(:,2)*klatt(2,1) + cryst%gprimd(:,3)*klatt(3,1)
3360 [ # # ]: 0 : kmesh_cartvec(:, 2) = cryst%gprimd(:,1)*klatt(1,2) + cryst%gprimd(:,2)*klatt(2,2) + cryst%gprimd(:,3)*klatt(3,2)
3361 [ # # ]: 0 : kmesh_cartvec(:, 3) = cryst%gprimd(:,1)*klatt(1,3) + cryst%gprimd(:,2)*klatt(2,3) + cryst%gprimd(:,3)*klatt(3,3)
3362 : : ! TODO: It seems that two_pi is not needed here!
3363 : :
3364 [ # # # # ]: 0 : if (abs(eph_intmeth) == 1 .or. nesting /= 0) then
3365 [ # # # # ]: 0 : use_adaptive = eph_fsmear < zero .or. abs(eph_intmeth) == 2
3366 : : if (use_adaptive) then
3367 [ # # ]: 0 : ABI_CHECK(allocated(gqk%vnk_cart_ibz), "vnk_cart_ibz should be allocated when use_adaptive is .True.")
3368 : : end if
3369 : :
3370 : : ! Find k + q in the IBZ for all my k-points.
3371 [ # # # # : 0 : ABI_MALLOC(my_kqmap, (6, gqk%my_nk))
# # # # #
# # # ]
3372 [ # # ]: 0 : if (kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, gqk%my_nk, gqk%my_kpts, my_kqmap, qpt=qpt) /= 0) then
3373 : 0 : ABI_ERROR(sjoin("Cannot map k+q to IBZ with qpt:", ktoa(qpt)))
3374 : : end if
3375 : :
3376 : : ! Init default sigma
3377 : 0 : sigma = eph_fsmear
3378 : :
3379 [ # # ]: 0 : do my_ik=1,gqk%my_nk
3380 : 0 : kk = gqk%my_kpts(:, my_ik)
3381 : :
3382 : 0 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
3383 [ # # ]: 0 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5, my_ik)
3384 [ # # # # : 0 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
# # # # ]
3385 [ # # ]: 0 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
3386 : :
3387 : 0 : ikq_ibz = my_kqmap(1, my_ik); isym_kq = my_kqmap(2, my_ik)
3388 [ # # ]: 0 : trev_kq = my_kqmap(6, my_ik); g0_kq = my_kqmap(3:5, my_ik)
3389 [ # # # # : 0 : isirr_kq = (isym_kq == 1 .and. trev_kq == 0 .and. all(g0_kq == 0))
# # # # ]
3390 [ # # ]: 0 : tsign_kq = 1; if (trev_kq == 1) tsign_kq = -1
3391 : :
3392 [ # # ]: 0 : if (use_adaptive) then
3393 : : ! If k or k+q is not in the IBZ, we need to recostruct the value by symmetry using v(Sq) = S v(q).
3394 : : ! Use transpose(R) because we are using the tables for the wavefunctions
3395 : : ! In this case listkk has been called with symrec and use_symrec=False
3396 : : ! so q_bz = S^T q_ibz where S is the isym_kq symmetry
3397 [ # # # # ]: 0 : vb_k = gqk%vnk_cart_ibz(:,:,ik_ibz)
3398 [ # # # # ]: 0 : vb_kq = gqk%vnk_cart_ibz(:,:,ikq_ibz)
3399 : :
3400 [ # # ]: 0 : if (.not. isirr_k) then
3401 [ # # ]: 0 : do ib=1,nb_k
3402 [ # # # # ]: 0 : vb_k(:,ib) = tsign_k * matmul(transpose(cryst%symrel_cart(:,:,isym_k)), vb_k(:,ib))
3403 : : end do
3404 : : end if
3405 [ # # ]: 0 : if (.not. isirr_kq) then
3406 [ # # ]: 0 : do ib=1,nb_kq
3407 [ # # # # ]: 0 : vb_kq(:,ib) = tsign_kq * matmul(transpose(cryst%symrel_cart(:,:,isym_kq)), vb_kq(:,ib))
3408 : : end do
3409 : : end if
3410 : : end if
3411 : :
3412 [ # # ]: 0 : do ib2=1,nb_k
3413 : 0 : band2 = ib2 + gqk%bstart_k - 1
3414 [ # # ]: 0 : if (use_adaptive) then
3415 [ # # # # : 0 : sigma = max(maxval([(abs(dot_product(vb_k(:, ib2), kmesh_cartvec(:,ii))), ii=1,3)]), min_smear)
# # # # #
# ]
3416 : : !write(std_out, *)"sigma:", sigma * Ha_eV
3417 : : end if
3418 : 0 : g2 = gaussian(ebands%eig(band2, ik_ibz, spin) - ebands%fermie, sigma)
3419 : :
3420 [ # # ]: 0 : do ib1=1,nb_kq
3421 : 0 : band1 = ib1 + gqk%bstart_kq - 1
3422 [ # # ]: 0 : if (use_adaptive) then
3423 [ # # # # : 0 : sigma = max(maxval([(abs(dot_product(vb_kq(:, ib1), kmesh_cartvec(:,ii))), ii=1,3)]), min_smear)
# # # # #
# ]
3424 : : end if
3425 : 0 : g1 = gaussian(ebands%eig(band1, ikq_ibz, spin) - ebands%fermie, sigma)
3426 : 0 : dbl_delta_q(ib1, ib2, my_ik) = g1 * g2 ! / fs%nktot
3427 : : end do
3428 : :
3429 : : end do
3430 : : end do
3431 : :
3432 [ # # ]: 0 : ABI_FREE(my_kqmap)
3433 : :
3434 [ # # ]: 0 : else if (abs(eph_intmeth) == 2) then
3435 : :
3436 [ # # ]: 0 : ABI_CHECK(isdiagmat(ebands%kptrlatt), "kptrlatt must be diagonal when tetra is used.")
3437 [ # # ]: 0 : ABI_CHECK(ebands%nshiftk == 1, "nshiftk must be 1 when tetra is used")
3438 : 0 : nge = get_diag(ebands%kptrlatt); ngw = nge
3439 [ # # # # : 0 : ABI_CHECK_IEQ(nkbz, product(nge(1:3)), "Wrong nge")
# # ]
3440 : :
3441 : : ! Compute eig_k and eig_kq in full BZ for the relevant bands around Ef.
3442 [ # # # # : 0 : ABI_MALLOC(kmesh, (3, nkbz))
# # # # #
# # # ]
3443 [ # # # # : 0 : ABI_MALLOC(eig_k, (nb_k, nkbz))
# # # # #
# # # # #
# # ]
3444 [ # # # # : 0 : ABI_MALLOC(eig_kq, (nb_kq, nkbz))
# # # # #
# # # # #
# # ]
3445 : :
3446 : : ! Technical problems:
3447 : : !
3448 : : ! 1) libtetrabz works with the BZ and assumes a certaing ordering of the k-points (see below)
3449 : : ! so we have to fill the array with eig_k and eig_kq from the IBZ by remapping the libtetra kk
3450 : : ! to the Abinit IBZ
3451 : :
3452 : : ! 2) The dbldelta weights are given in the BZ, while the caller requires weights for k in the IBZ
3453 : : ! and moreover only for the IBZ k-point treated by this MPI proc.
3454 : :
3455 : 0 : ik_bz = 0
3456 [ # # ]: 0 : do i3=0,nge(3) - 1
3457 [ # # ]: 0 : do i2=0,nge(2) - 1
3458 [ # # ]: 0 : do i1=0,nge(1) - 1
3459 : 0 : ik_bz = ik_bz + 1
3460 [ # # ]: 0 : kk = ([i1, i2, i3] + ebands%shiftk(:, 1)) / nge(:)
3461 [ # # ]: 0 : kmesh(:, ik_bz) = kk
3462 : : end do
3463 : : end do
3464 : : end do
3465 : :
3466 : : ! Map libtetra BZ mesh to IBZ and fill eig_k
3467 : : !call cwtime(cpu, wall, gflops, "start")
3468 [ # # # # : 0 : ABI_MALLOC(kmesh_map, (6, nkbz))
# # # # #
# # # ]
3469 : :
3470 : : ! Find correspondence between libtetra mesh and the IBZ.
3471 [ # # ]: 0 : if (kpts_map("symrec", ebands%kptopt, cryst, gstore%krank_ibz, nkbz, kmesh, kmesh_map) /= 0) then
3472 : 0 : ABI_ERROR("Cannot map libtetra mesh to IBZ")
3473 : : end if
3474 : :
3475 [ # # ]: 0 : do ik_bz=1,nkbz
3476 : 0 : ik_ibz = kmesh_map(1, ik_bz)
3477 [ # # ]: 0 : eig_k(:, ik_bz) = ebands%eig(gqk%bstart_k:gqk%bstop_k, ik_ibz, spin) - ebands%fermie
3478 : : end do
3479 : :
3480 : : ! Map libtetra BZ mesh + q to IBZ and fill eig_kq.
3481 [ # # ]: 0 : if (kpts_map("symrec", ebands%kptopt, cryst, gstore%krank_ibz, nkbz, kmesh, kmesh_map, qpt=qpt) /= 0) then
3482 : 0 : ABI_ERROR(sjoin("Cannot map libtetra k+q to IBZ with qpt:", ktoa(qpt)))
3483 : : end if
3484 : :
3485 [ # # ]: 0 : do ik_bz=1,nkbz
3486 : 0 : ikq_ibz = kmesh_map(1, ik_bz)
3487 [ # # ]: 0 : eig_kq(:, ik_bz) = ebands%eig(gqk%bstart_kq:gqk%bstop_kq, ikq_ibz, spin) - ebands%fermie
3488 : : end do
3489 : :
3490 [ # # ]: 0 : ABI_FREE(kmesh_map)
3491 : : !call cwtime_report(" kmesh_map", cpu, wall, gflops)
3492 : :
3493 : : ! Call libtetra routine to compute weights for double delta integration.
3494 : : ! Note that libtetra assumes Ef set to zero.
3495 : : ! TODO: Average weights over degenerate states?
3496 : : ! NB: This is a bottleneck, can pass comm_kp
3497 : :
3498 : : ! Select option for double delta with tetra.
3499 : : ! 2 for the optimized tetrahedron method.
3500 : : ! -2 for the linear tetrahedron method.
3501 : 0 : ltetra = 0
3502 [ # # ]: 0 : if (eph_intmeth == 2) ltetra = 2
3503 [ # # ]: 0 : if (eph_intmeth == -2) ltetra = 1
3504 : :
3505 [ # # # # : 0 : ABI_MALLOC(wght_bz, (nb_k, nb_kq, nkbz))
# # # # #
# # # # #
# # # # #
# ]
3506 : 0 : call libtetrabz_dbldelta(ltetra, gstore%cryst%gprimd, nb_k, nge, eig_k, eig_kq, ngw, wght_bz) !, comm=comm)
3507 : : !call cwtime_report(" libtetrabz_dbldelta", cpu, wall, gflops)
3508 : :
3509 : 0 : call my_krank%init(gqk%my_nk, gqk%my_kpts)
3510 : :
3511 : : ! Reindex from full BZ to my set of kpoints and rescale weights.
3512 : 0 : cnt = 0
3513 [ # # ]: 0 : do ik_bz=1,nkbz
3514 : 0 : my_ik = my_krank%get_index(kmesh(:, ik_bz))
3515 [ # # ]: 0 : if (my_ik /= -1) then
3516 [ # # # # ]: 0 : dbl_delta_q(:,:,my_ik) = wght_bz(:,:,ik_bz) * gstore%nkbz
3517 : 0 : cnt = cnt + 1
3518 : : end if
3519 : : end do
3520 : :
3521 : : ! FIXME: BUG if k-point (and q-point) parallelism.
3522 [ # # ]: 0 : ABI_CHECK_IEQ(cnt, gqk%my_nk, sjoin("cnt != my_nk, ", itoa(cnt), itoa(gqk%my_nk)))
3523 : 0 : call my_krank%free()
3524 : : !call cwtime_report(" transfer", cpu, wall, gflops)
3525 : :
3526 [ # # ]: 0 : ABI_FREE(wght_bz)
3527 [ # # ]: 0 : ABI_FREE(kmesh)
3528 [ # # ]: 0 : ABI_FREE(eig_k)
3529 [ # # ]: 0 : ABI_FREE(eig_kq)
3530 : :
3531 : : else
3532 : 0 : ABI_ERROR(sjoin("Invalid eph_intmeth:", itoa(eph_intmeth)))
3533 : : end if
3534 : :
3535 [ # # # # : 0 : end subroutine gqk_dbldelta_qpt
# # ]
3536 : : !!***
3537 : : !----------------------------------------------------------------------
3538 : :
3539 : : !!****f* m_gstore/gqk_free
3540 : : !! NAME
3541 : : !! gqk_free
3542 : : !!
3543 : : !! FUNCTION
3544 : : !! Free dynamic memory in gqk_t instance.
3545 : : !!
3546 : : !! SOURCE
3547 : :
3548 : 24 : subroutine gqk_free(gqk)
3549 : :
3550 : : !Arguments ------------------------------------
3551 : : class(gqk_t),intent(inout) :: gqk
3552 : : !----------------------------------------------------------------------
3553 : :
3554 [ + - ]: 24 : ABI_SFREE(gqk%my_k2ibz)
3555 [ + - ]: 24 : ABI_SFREE(gqk%my_kpts)
3556 [ + - ]: 24 : ABI_SFREE(gqk%my_wtk)
3557 [ + - ]: 24 : ABI_SFREE(gqk%my_q2ibz)
3558 [ + - ]: 24 : ABI_SFREE(gqk%my_q2bz)
3559 [ + - ]: 24 : ABI_SFREE(gqk%my_k2glob)
3560 [ + - ]: 24 : ABI_SFREE(gqk%my_q2glob)
3561 [ + + ]: 24 : ABI_SFREE(gqk%my_wnuq)
3562 [ + + ]: 24 : ABI_SFREE(gqk%my_displ_cart)
3563 [ - + ]: 24 : ABI_SFREE(gqk%my_iv1p_comm)
3564 [ + - ]: 24 : ABI_SFREE(gqk%my_pertcases)
3565 [ + + ]: 24 : ABI_SFREE(gqk%vnk_cart_ibz)
3566 [ - + ]: 24 : ABI_SFREE(gqk%vnk_mat_cart_ibz)
3567 : :
3568 [ + + ]: 24 : ABI_SFREE(gqk%my_g)
3569 [ + + ]: 24 : ABI_SFREE(gqk%my_g2)
3570 [ + + ]: 24 : ABI_SFREE(gqk%my_gdw2)
3571 [ + + ]: 24 : if (gqk%has_both_g) then
3572 [ + + ]: 9 : ABI_SFREE_PTR(gqk%my_g_ks)
3573 [ + + ]: 9 : ABI_SFREE_PTR(gqk%my_g2_ks)
3574 [ + + ]: 9 : ABI_SFREE_PTR(gqk%my_gdw2_ks)
3575 : : end if
3576 : :
3577 : 24 : call gqk%wan%free()
3578 : :
3579 : : ! Free MPI communicators
3580 : 24 : call gqk%kpt_comm%free(); call gqk%qpt_comm%free(); call gqk%qpt_kpt_comm%free()
3581 : 24 : call gqk%pert_comm%free(); call gqk%band_comm%free(); call gqk%qpt_pert_comm%free()
3582 : 24 : call gqk%pert_ppsum_comm%free(); call gqk%pert_ppsum_bsum_comm%free()
3583 : 24 : call gqk%comm%free(); call gqk%bsum_comm%free(); call gqk%pp_sum_comm%free()
3584 : :
3585 : 24 : end subroutine gqk_free
3586 : : !!***
3587 : :
3588 : : !!****f* m_gstore/gstore_get_missing_qbz_spin
3589 : : !! NAME
3590 : : !! gstore_get_missing_qbz_spin
3591 : : !!
3592 : : !! FUNCTION
3593 : : !! Return the number of (q-points, spin) entries that have been computed.
3594 : : !!
3595 : : !! SOURCE
3596 : :
3597 : 9 : subroutine gstore_get_missing_qbz_spin(gstore, done_qbz_spin, ndone, nmiss)
3598 : :
3599 : : !Arguments ------------------------------------
3600 : : class(gstore_t),intent(in) :: gstore
3601 : : integer,intent(in) :: done_qbz_spin(gstore%nqbz, gstore%nsppol)
3602 : : integer,intent(out) :: ndone, nmiss
3603 : :
3604 : : !Local variables ------------------------------
3605 : : integer :: my_is, my_iq, iq_bz, spin, ierr, nscale
3606 : : !----------------------------------------------------------------------
3607 : :
3608 : 3 : ndone = 0; nmiss = 0
3609 [ + + ]: 6 : do my_is=1,gstore%my_nspins
3610 : 3 : associate (gqk => gstore%gqk(my_is))
3611 : 3 : spin = gstore%my_spins(my_is)
3612 [ + + ]: 83 : do my_iq=1,gqk%my_nq
3613 : 80 : iq_bz = gqk%my_q2bz(my_iq)
3614 [ + - ]: 80 : if (done_qbz_spin(iq_bz, spin) == 0) nmiss = nmiss + 1
3615 [ - + ]: 83 : if (done_qbz_spin(iq_bz, spin) == 1) ndone = ndone + 1
3616 : : end do ! my_iq
3617 : : ! Rescale to avoid overcounting in xmpi_summ
3618 : 3 : nscale = (gqk%pert_comm%nproc * gqk%bsum_comm%nproc * gqk%pp_sum_comm%nproc)
3619 : 3 : nmiss = nmiss / nscale
3620 : 6 : ndone = ndone / nscale
3621 : : end associate
3622 : : end do ! my_is
3623 : :
3624 : 3 : call xmpi_sum(ndone, gstore%comm, ierr)
3625 : 3 : call xmpi_sum(nmiss, gstore%comm, ierr)
3626 : :
3627 : 3 : end subroutine gstore_get_missing_qbz_spin
3628 : : !!***
3629 : :
3630 : : !!****f* m_gstore/gstore_set_perts_distrib
3631 : : !! NAME
3632 : : !! gstore_set_perts_distrib
3633 : : !!
3634 : : !! FUNCTION
3635 : : !! Activate parallelism over perturbations at the level of the DVDB file.
3636 : : !!
3637 : : !! SOURCE
3638 : :
3639 : 18 : subroutine gstore_set_perts_distrib(gstore, cryst, dvdb, my_npert)
3640 : :
3641 : : !Arguments ------------------------------------
3642 : : class(gstore_t),intent(in) :: gstore
3643 : : type(crystal_t),intent(in) :: cryst
3644 : : type(dvdb_t),intent(inout) :: dvdb
3645 : : integer,intent(out) :: my_npert
3646 : :
3647 : : !Local variables ------------------------------
3648 : : !scalars
3649 : : integer :: my_is, spin
3650 : : !arrays
3651 : 18 : integer,allocatable :: my_pinfo(:,:), pert_table(:,:)
3652 : : !----------------------------------------------------------------------
3653 : :
3654 : 18 : my_npert = cryst%natom * 3
3655 [ + + ]: 36 : do my_is=1,gstore%my_nspins
3656 : 18 : associate (gqk => gstore%gqk(my_is))
3657 : 18 : spin = gstore%my_spins(my_is)
3658 [ - + ]: 18 : if (gqk%pert_comm%nproc > 1) then
3659 : : ! Activate parallelism over perturbations
3660 : : ! Build table with list of perturbations treated by this MPI rank inside pert_comm.
3661 : : !ABI_WARNING("GSTORE with pert_comm%nproc > 1 not tested")
3662 : 0 : my_npert = gqk%my_npert
3663 [ # # # # ]: 0 : call ephtk_set_pertables(cryst%natom, my_npert, pert_table, my_pinfo, gqk%pert_comm%value)
3664 : 0 : call dvdb%set_pert_distrib(my_npert, cryst%natom * 3, my_pinfo, pert_table, gqk%pert_comm%value)
3665 [ # # # # : 0 : ABI_CHECK(all(my_pinfo(3, :) == gqk%my_pertcases), "my_pinfo(3, :) != gqk%my_pertcases")
# # ]
3666 : :
3667 [ # # ]: 0 : ABI_FREE(my_pinfo)
3668 [ # # ]: 0 : ABI_FREE(pert_table)
3669 : : end if
3670 : : end associate
3671 : : end do
3672 : :
3673 [ - + - + ]: 18 : end subroutine gstore_set_perts_distrib
3674 : : !!***
3675 : :
3676 : : !----------------------------------------------------------------------
3677 : :
3678 : : !!****f* m_gstore/gstore_compute
3679 : : !! NAME
3680 : : !! gstore_compute
3681 : : !!
3682 : : !! FUNCTION
3683 : : !! Compute MPI-distributed e-ph matrix elements
3684 : : !!
3685 : : !! INPUTS
3686 : : !! wk0_path=String with the path to the GS unperturbed WFK file.
3687 : : !! ngfft(18),ngfftf(18)=Coarse and Fine FFT meshes.
3688 : : !! dtset<dataset_type>=All input variables for this dataset.
3689 : : !! ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...)
3690 : : !! dvdb<dbdb_type>=Database with the DFPT SCF potentials.
3691 : : !! pawfgr <type(pawfgr_type)>=fine grid parameters and related data
3692 : : !! pawang<pawang_type)>=PAW angular mesh and related data.
3693 : : !! pawrad(ntypat*usepaw)<pawrad_type>=Paw radial mesh and related data.
3694 : : !! pawtab(ntypat*usepaw)<pawtab_type>=Paw tabulated starting data.
3695 : : !! psps<pseudopotential_type>=Variables related to pseudopotentials.
3696 : : !! comm=MPI communicator.
3697 : : !!
3698 : : !! OUTPUT
3699 : : !! GSTORE.nc file
3700 : : !!
3701 : : !! SOURCE
3702 : :
3703 : 5 : subroutine gstore_compute(gstore, wfk0_path, ngfft, ngfftf, dtset, dtfil, cryst, ebands, ifc, dvdb, &
3704 : 5 : pawfgr, pawang, pawrad, pawtab, psps, mpi_enreg, comm)
3705 : :
3706 : : !Arguments ------------------------------------
3707 : : !scalars
3708 : : class(gstore_t),target,intent(inout) :: gstore
3709 : : character(len=*),intent(in) :: wfk0_path
3710 : : integer,intent(in) :: comm
3711 : : type(dataset_type),intent(in) :: dtset
3712 : : type(datafiles_type),intent(in) :: dtfil
3713 : : type(crystal_t),intent(in) :: cryst
3714 : : type(ebands_t),intent(in) :: ebands
3715 : : class(ifc_type),intent(in) :: ifc
3716 : : type(dvdb_t),intent(inout) :: dvdb
3717 : : type(pawang_type),intent(in) :: pawang
3718 : : type(pseudopotential_type),intent(in) :: psps
3719 : : type(pawfgr_type),intent(in) :: pawfgr
3720 : : type(mpi_type),intent(in) :: mpi_enreg
3721 : : !arrays
3722 : : integer,intent(in) :: ngfft(18),ngfftf(18)
3723 : : type(pawrad_type),intent(in) :: pawrad(psps%ntypat*psps%usepaw)
3724 : : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
3725 : :
3726 : : !Local variables ------------------------------
3727 : : !scalars
3728 : : integer,parameter :: tim_getgh1c = 1, berryopt0 = 0, ider0 = 0, idir0 = 0, LOG_MODQ = 5, master = 0, ndat1 = 1
3729 : : integer :: my_rank,nproc,mband,nsppol,nkibz,idir,ipert, iq_bz
3730 : : integer :: cplex,natom,natom3,ipc,nspinor, nskip_tetra_kq, timrev_k, timrev_q
3731 : : integer :: band_k, in_k, ik_ibz,ikq_ibz,isym_k,isym_kq,trev_k,trev_kq, nb_k, nb_kq ! im_kq,
3732 : : integer :: my_ik, my_is, comm_rpt, my_npert, my_ip, my_iq, spin,istwf_k,istwf_kq,npw_k,npw_kq
3733 : : integer :: mpw, ierr, n1,n2,n3,n4,n5,n6,nspden,ndone, db_iqpt
3734 : : integer :: sij_opt,usecprj,usevnl,optlocal,optnl,opt_gvnlx1
3735 : : integer :: nfft,nfftf,mgfft,mgfftf, nkpg_k, nkpg_kq, qbuf_size, iqbuf_cnt, root_ncid, spin_ncid, ncerr
3736 : : integer :: ii, iq_ibz, isym_q, trev_q
3737 : : real(dp) :: cpu_q, wall_q, gflops_q, cpu_all, wall_all, gflops_all ! cpu, wall, gflops,
3738 : : real(dp) :: ecut, weight_q, weight_k ! eshift,
3739 : : logical :: gen_eigenpb, isirr_k, isirr_kq, isirr_q, print_time, need_ftinterp, qq_is_gamma, symmetrize, use_lgk
3740 : 5 : type(wfd_t) :: wfd
3741 : 5 : type(gs_hamiltonian_type) :: gs_ham_kq
3742 : 5 : type(rf_hamiltonian_type) :: rf_ham_kq
3743 : : type(gqk_t),pointer :: gqk
3744 : 5 : type(lgroup_t) :: lg_myq
3745 : : character(len=5000) :: msg, qq_bz_string, kk_string
3746 : : !arrays
3747 : : integer :: g0_k(3), g0_kq(3), g0_q(3), work_ngfft(18),gmax(3),indkk_kq(6,1), units(2), qbz2dvdb(6)
3748 : 5 : integer,allocatable :: kg_k(:,:), kg_kq(:,:), nband(:,:), wfd_istwfk(:), qmap_symrec(:,:)
3749 : 5 : integer,allocatable :: iq_buf(:,:), done_qbz_spin(:,:), state_kq(:,:)
3750 : : !integer,allocatable :: qibz2dvdb(:) !, displs(:), recvcounts(:)
3751 : : real(dp) :: kk_bz(3),kq_bz(3),kk_ibz(3),kq_ibz(3), qq_bz(3), qq_ibz(3) !, v_nk(3)
3752 : 5 : real(dp),allocatable :: displ_cart_qibz(:,:,:,:), lambda(:)
3753 : 5 : real(dp),allocatable :: grad_berry(:,:), kinpw_k(:), kinpw_kq(:), kpg_kq(:,:), kpg_k(:,:)
3754 : 5 : real(dp),allocatable :: ffnl_k(:,:,:,:), ffnl_kq(:,:,:,:), ph3d_k(:,:,:), ph3d_kq(:,:,:)
3755 : 5 : real(dp),allocatable :: v1scf(:,:,:,:), gkq_atm(:,:,:,:), gkq_atm_ipc(:,:,:)
3756 : 5 : real(dp),allocatable :: bras_kq(:,:,:), kets_k(:,:,:), h1_kets_kq(:,:,:) !, cgwork(:,:)
3757 : 5 : real(dp),allocatable :: ph1d(:,:), vlocal(:,:,:,:), vlocal1(:,:,:,:,:)
3758 : 5 : real(dp),allocatable :: dummy_vtrial(:,:), gvnlx1(:,:,:), work(:,:,:,:)
3759 : 5 : real(dp),allocatable :: gs1c_kq(:,:) !, vnk_cart_ibz(:,:,:) !, vkq_cart_ibz(:,:,:) !, vnk_mat_cart_ibz(:,:,:,:)
3760 : 5 : real(dp),allocatable :: my_gbuf(:,:,:,:,:,:)
3761 : 5 : logical,allocatable :: bks_mask(:,:,:),keep_ur(:,:,:)
3762 : 5 : type(pawcprj_type),allocatable :: cwaveprj0(:,:)
3763 : 5 : type(lgroup_t),allocatable :: lg_myk(:)
3764 : : !************************************************************************
3765 : :
3766 : 5 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
3767 [ + + ]: 15 : units = [std_out, ab_out]
3768 : :
3769 [ - + ]: 5 : if (psps%usepaw == 1) then
3770 : 0 : ABI_ERROR("PAW not implemented")
3771 : : ABI_UNUSED((/pawang%nsym, pawrad(1)%mesh_size/))
3772 : : end if
3773 : :
3774 : : ! Check MPI distribution: abort if there are any idle processes in the loops over k and q.
3775 : : ! NOTE that we have to perform this check only at the level of gstore%compute.
3776 : : ! The k- and q-points distributed inside kpt_comm and qpt_comm are the glob_nk and glob_nq points of the gstore
3777 : : ! (e.g. q in the full BZ), not the IBZ points. The IBZ-based steps (phonons, velocities) support nproc > nqibz.
3778 [ + + ]: 10 : do my_is=1,gstore%my_nspins
3779 : 5 : gqk => gstore%gqk(my_is)
3780 [ + - - + ]: 10 : if (gqk%kpt_comm%nproc > gqk%glob_nk .or. gqk%qpt_comm%nproc > gqk%glob_nq) then
3781 : 0 : write(msg, "(4(a,i0),4a)") "gstore%compute: kpt_comm%nproc=", gqk%kpt_comm%nproc, " > glob_nk=", gqk%glob_nk, &
3782 : 0 : " or qpt_comm%nproc=", gqk%qpt_comm%nproc, " > glob_nq=", gqk%glob_nq, ch10, &
3783 : 0 : "This will lead to idle processes, which are not supported.", ch10, &
3784 : 0 : "Please decrease the number of CPUs for k-points or q-points (eph_np_pqbks)"
3785 : 0 : ABI_ERROR(msg)
3786 : : endif
3787 : : enddo
3788 : :
3789 : : ! This parameter defines the size of the q-buffer used to store the g(k, q) e-ph matrix elements
3790 : : ! for all the k-point treated by this MPI rank.
3791 : : ! Increasing the buffer size increases the memory requirements
3792 : : ! but it leads to better performance as the number of IO operations is decreased.
3793 : : ! TODO: Should compute it on the basis of my_nkpt and my_nqpt
3794 : 5 : qbuf_size = 16
3795 : 5 : call wrtout(std_out, sjoin(" Begin computation of e-ph matrix elements with qbuf_size:", itoa(qbuf_size)), pre_newlines=1)
3796 : 5 : call pstat_proc%print(_PSTAT_ARGS_)
3797 : 5 : call cwtime(cpu_all, wall_all, gflops_all, "start")
3798 : :
3799 : : ! If True, only k-points in the IBZ and q-points in the IBZ_k are computed.
3800 : : ! Matrix elements in full BZs are then reconstructed by symmetry at the end of the run by calling
3801 : : ! gstore_symmetrize.
3802 : : symmetrize = (dtset%gstore_kzone == "bz" .and. dtset%gstore_qzone == "bz" &
3803 : : .and. dtset%gstore_sym > 0 &
3804 [ + + + - : 5 : )
+ - ]
3805 : : !if (symmetrize) call wrtout(units, " Computing g(k, q) with k in the IBZ and q in the BZ + final reconstruction")
3806 : :
3807 : : ! Copy important dimensions
3808 : 5 : natom = cryst%natom; natom3 = 3 * natom; nsppol = ebands%nsppol; nspinor = ebands%nspinor; nspden = dtset%nspden
3809 : 5 : nkibz = ebands%nkpt; mband = ebands%mband
3810 : :
3811 : : ! FFT meshes
3812 [ + + ]: 20 : nfftf = product(ngfftf(1:3)); mgfftf = maxval(ngfftf(1:3))
3813 [ + + + + ]: 35 : nfft = product(ngfft(1:3)) ; mgfft = maxval(ngfft(1:3))
3814 : 5 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3); n4 = ngfft(4); n5 = ngfft(5); n6 = ngfft(6)
3815 : :
3816 : : ! Open the DVDB file
3817 : 5 : call dvdb%open_read(ngfftf, xmpi_comm_self)
3818 [ - + ]: 5 : ABI_CHECK(dvdb%has_fields("pot1", msg), msg)
3819 : :
3820 : : ! Activate parallelism over perturbations at the level of the DVDB
3821 : 5 : call gstore%set_perts_distrib(cryst, dvdb, my_npert)
3822 : :
3823 : : ! Prepare Fourier interpolation of DFPT potentials.
3824 : 5 : comm_rpt = xmpi_comm_self
3825 : : !comm_rpt = bqs_comm%value
3826 : :
3827 : : ! qmap_symrec gives the mapping gstore%ibz --> dvdb%ibz
3828 [ - + ]: 5 : call dvdb%need_ftinterp(gstore%nqibz, gstore%qibz, gstore%qptopt, qmap_symrec, need_ftinterp)
3829 [ - + ]: 5 : ABI_FREE(qmap_symrec)
3830 : : !need_ftinterp = .True.
3831 : :
3832 [ + + - + ]: 5 : if (.not. need_ftinterp .and. dtset%eph_use_ftinterp /= 0) then
3833 : 0 : ABI_WARNING("Enforcing FT interpolation for q-points even if it's not strictly needed.")
3834 : 0 : need_ftinterp = .True.
3835 : : end if
3836 : :
3837 [ + + ]: 5 : if (need_ftinterp) then
3838 : 3 : call wrtout(units, " Cannot find all IBZ q-points in the DVDB --> Activating Fourier interpolation.")
3839 : 3 : call dvdb%ftinterp_setup(dtset%ddb_ngqpt, gstore%qptopt, 1, dtset%ddb_shiftq, nfftf, ngfftf, comm_rpt)
3840 : : else
3841 : 2 : call wrtout(units, " DVDB file contains all q-points in the IBZ --> Reading DFPT potentials from file.")
3842 : : end if
3843 : :
3844 : : ! Initialize the wave function descriptor.
3845 : : ! Only wavefunctions for the symmetrical image of the k/k+q wavevectors treated by this MPI rank are stored.
3846 [ - + + - : 20 : ABI_MALLOC(nband, (nkibz, nsppol))
- + + - +
- + - - +
- + ]
3847 [ - + + - : 25 : ABI_MALLOC(bks_mask, (mband, nkibz, nsppol))
- + + - -
+ + - + -
+ - - + -
+ ]
3848 [ - + + - : 20 : ABI_MALLOC(keep_ur, (mband, nkibz, nsppol))
- + + - -
+ + - - +
- + ]
3849 [ + + + + : 2754 : nband = mband; bks_mask = .False.; keep_ur = .False.
+ + + + +
+ + + + +
+ + ]
3850 : :
3851 : 5 : call gstore%fill_bks_mask(mband, nkibz, nsppol, bks_mask)
3852 : :
3853 : : ! Impose istwfk = 1 for all k-points. This is also done in respfn (see inkpts)
3854 : : ! wfd_read_wfk will handle a possible conversion if WFK contains istwfk /= 1.
3855 [ - + + - : 15 : ABI_MALLOC(wfd_istwfk, (nkibz))
+ - + - -
+ - + ]
3856 [ + + ]: 119 : wfd_istwfk = 1
3857 : 5 : ecut = dtset%ecut
3858 : :
3859 : : call wfd%init(cryst, pawtab, psps, keep_ur, mband, nband, nkibz, nsppol, bks_mask,&
3860 : : nspden, nspinor, ecut, dtset%ecutsm, dtset%dilatmx, wfd_istwfk, ebands%kptns, ngfft,&
3861 : 5 : dtset%nloalg, dtset%prtvol, dtset%pawprtvol, comm)
3862 : :
3863 [ + + ]: 10 : call wfd%print([std_out], header="Wavefunctions for GSTORE calculation")
3864 : :
3865 [ - + ]: 5 : ABI_FREE(nband)
3866 [ - + ]: 5 : ABI_FREE(keep_ur)
3867 [ - + ]: 5 : ABI_FREE(wfd_istwfk)
3868 [ - + ]: 5 : ABI_FREE(bks_mask)
3869 : :
3870 : : ! Read wavefunctions.
3871 : 5 : call wfd%read_wfk(wfk0_path, iomode_from_fname(wfk0_path))
3872 : 5 : call pstat_proc%print(_PSTAT_ARGS_)
3873 : :
3874 : : ! one-dimensional structure factor information on the coarse grid.
3875 [ + - - + : 15 : ABI_MALLOC(ph1d, (2, 3*(2*mgfft+1)*natom))
+ - + - +
- - + - +
- + ]
3876 : 5 : call getph(cryst%atindx, natom, n1, n2, n3, ph1d, cryst%xred)
3877 : :
3878 : : ! mpw is the maximum number of plane-waves over k and k+q where k and k+q are in the BZ.
3879 : : ! we also need the max components of the G-spheres (k, k+q) in order to allocate the workspace array work
3880 : : ! that will be used to symmetrize the wavefunctions in G-space.
3881 : 5 : call gstore%get_mpw_gmax(ecut, mpw, gmax)
3882 : :
3883 : : ! Init work_ngfft
3884 [ + + ]: 20 : gmax = gmax + 4 ! FIXME: this is to account for umklapp
3885 [ + + ]: 20 : gmax = 2*gmax + 1
3886 : 5 : call ngfft_seq(work_ngfft, gmax)
3887 : : !write(std_out,*)"work_ngfft(1:3): ",work_ngfft(1:3)
3888 [ - + + - : 25 : ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
- + + - -
+ + - + -
+ - - + -
+ ]
3889 : :
3890 : : ! Allow PW-arrays dimensioned with mpw
3891 [ - + + - : 15 : ABI_MALLOC(kg_k, (3, mpw))
+ - + - -
+ - + -
+ ]
3892 [ - + + - : 10 : ABI_MALLOC(kg_kq, (3, mpw))
- + - + -
+ ]
3893 : :
3894 : 5 : usecprj = 0
3895 [ - + + - : 10 : ABI_MALLOC(cwaveprj0, (natom, nspinor*usecprj))
- + - + -
+ ]
3896 : :
3897 : : ! Prepare call to getgh1c
3898 : 5 : usevnl = 0
3899 : 5 : optlocal = 1 ! local part of H^(1) is computed in gh1c=<G|H^(1)|C>
3900 : 5 : optnl = 2 ! non-local part of H^(1) is totally computed in gh1c=<G|H^(1)|C>
3901 : 5 : opt_gvnlx1 = 0 ! gvnlx1 is output
3902 [ - + - + ]: 5 : ABI_MALLOC(grad_berry, (2, nspinor*(berryopt0/4)))
3903 : :
3904 : : ! This part is taken from dfpt_vtorho
3905 : : !==== Initialize most of the Hamiltonian (and derivative) ====
3906 : : !1) Allocate all arrays and initialize quantities that do not depend on k and spin.
3907 : : !2) Perform the setup needed for the non-local factors:
3908 : : ! Norm-conserving: Constant kleimann-Bylander energies are copied from psps to gs_hamk.
3909 : : ! PAW: Initialize the overlap coefficients and allocate the Dij coefficients.
3910 : :
3911 : : call gs_ham_kq%init(psps, pawtab, nspinor, nsppol, nspden, natom, &
3912 : : dtset%typat, cryst%xred, nfft, mgfft, ngfft, cryst%rprimd, dtset%nloalg, &
3913 : : comm_atom=mpi_enreg%comm_atom, mpi_atmtab=mpi_enreg%my_atmtab, mpi_spintab=mpi_enreg%my_isppoltab, &
3914 : 5 : usecprj=usecprj, ph1d=ph1d, nucdipmom=dtset%nucdipmom, gpu_option=dtset%gpu_option)
3915 : :
3916 : : ! Allocate vlocal. Note nvloc
3917 : : ! I set vlocal to huge to trigger possible bugs (DFPT routines should not access the data)
3918 [ - + + - : 30 : ABI_MALLOC(vlocal, (n4, n5, n6, gs_ham_kq%nvloc))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
3919 [ + + + + : 26516 : vlocal = huge(one)
+ + + + ]
3920 : :
3921 : : ! Allocate work space arrays.
3922 [ - + + - : 20 : ABI_MALLOC(displ_cart_qibz, (2, 3, cryst%natom, natom3))
- + + - +
- + - - +
- + ]
3923 [ - + + - : 22241 : ABI_CALLOC(dummy_vtrial, (nfftf, nspden))
- + + - +
- + - - +
- + + + +
+ ]
3924 : :
3925 : : ! Open GSTORE file, and read table used for restarting.
3926 : : ! TODO: Fix problem with IO (some q-points are not written)
3927 : : !if (dtset%useria == 888) then
3928 : : ! ! use xmpi_comm_self otherwise there will be a deadlock on lemaitre4
3929 : : ! NCF_CHECK(nctk_open_modify(root_ncid, gstore%path, xmpi_comm_self))
3930 : : !else
3931 [ - + ]: 5 : NCF_CHECK(nctk_open_modify(root_ncid, gstore%path, gstore%comm))
3932 : : !end if
3933 : :
3934 : : ! integer scalars
3935 : : ncerr = nctk_def_iscalars(root_ncid, [character(len=nctk_slen) :: &
3936 : : "used_ftinterp" &
3937 [ + + ]: 10 : ])
3938 [ - + ]: 5 : NCF_CHECK(ncerr)
3939 : :
3940 [ - + + - : 20 : ABI_MALLOC(done_qbz_spin, (gstore%nqbz, nsppol))
- + + - +
- + - - +
- + - + ]
3941 [ - + ]: 5 : NCF_CHECK(nf90_get_var(root_ncid, nctk_idname(root_ncid, "gstore_done_qbz_spin"), done_qbz_spin))
3942 : :
3943 [ - + ]: 5 : gstore%wfk0_path = wfk0_path
3944 : :
3945 : : !if (my_rank == master) then
3946 [ + + ]: 5 : ii = merge(1, 0, need_ftinterp)
3947 : : ncerr = nctk_write_iscalars(root_ncid, [character(len=nctk_slen) :: &
3948 : : "used_ftinterp"], &
3949 : : [ii &
3950 [ + + + + ]: 15 : ])
3951 [ - + ]: 5 : NCF_CHECK(ncerr)
3952 : :
3953 [ - + - - ]: 5 : NCF_CHECK(nf90_put_var(root_ncid, root_vid("gstore_wfk0_path"), trim(gstore%wfk0_path)))
3954 : : !end if
3955 : :
3956 : : ! SC: The writes below are done by a subset of the procs (dump_my_gbuf) and a lazy collective read
3957 : : ! triggered by this subset would deadlock. Therefore, we load the metadata of all the variables here
3958 : : ! with all the procs of gstore%comm.
3959 : 5 : call gstore_prepare_mpiio(root_ncid, gstore%nsppol)
3960 : :
3961 [ + - + + ]: 10 : if (my_rank == master) call gstore%print([std_out])
3962 [ + + + + : 2487 : ndone = count(done_qbz_spin == 1)
- + ]
3963 : :
3964 [ + - ]: 5 : if (ndone == 0) then
3965 : : ! Write phonon data here as we are not guaranteed to have all the IBZ q-points
3966 : : ! inside the loop over my_iq if filtering has been used.
3967 : : ! Make sure internal table with gstore_done_qbz_spin is properly filled.
3968 : 5 : call gstore%compute_and_write_ph(root_ncid)
3969 : : else
3970 : 0 : call wrtout(units, sjoin("- Restarting GSTORE calculation from file:", gstore%path))
3971 : 0 : call wrtout(units, sjoin(" Found: ", itoa(ndone), " (qpt, spin) entries already computed"))
3972 : : end if
3973 : :
3974 : : ! Create ddkop object to compute group velocities (if needed)
3975 [ + - + - ]: 5 : if (gstore%with_vk /= 0 .and. ndone == 0) then
3976 : 5 : call gstore%compute_and_write_vk(mpw, wfd, ebands, psps, pawtab, root_ncid)
3977 : : end if
3978 : :
3979 [ - + ]: 5 : if (dtset%gstore_iv1p_comm /= 0) then
3980 : : call gstore%compute_and_write_commutator(mpw, gmax, ngfft, ngfftf, dtset, cryst, pawfgr, psps, &
3981 : 0 : wfd, mpi_enreg, kg_k, ebands, dvdb, gs_ham_kq, root_ncid)
3982 : : end if
3983 : :
3984 : 5 : call wrtout(std_out, " Begin computation of e-ph matrix elements...", pre_newlines=1)
3985 : :
3986 : : ! TODO: Exchange the q/k loops so that one can reduce the number of calls to _k dependente routines
3987 : : ! 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)>
3988 : : ! The price to pay is an increase in the number of calls to get_ftqbz but for small systems this part does not dominate
3989 : : ! Alternatively, one cah have two versions that will be invoked depending on my_nk, my_nq
3990 : :
3991 : : ! Here we decide if the q-points can be reduced to the IBZ(k)
3992 [ + + + - ]: 5 : use_lgk = (dtset%gstore_use_lgk /= 0 .or. dtset%gstore_sym == 2)
3993 : : if (use_lgk) then
3994 : 1 : call wrtout(units, " Only q-points in the IBZ_k will be computed.")
3995 [ - + ]: 4 : else if (dtset%gstore_use_lgq /= 0) then
3996 : 0 : call wrtout(units, " Only k-points in the IBZ_q will be computed.")
3997 : : else
3998 : 4 : call wrtout(units, " Little group operations won't be used")
3999 : : end if
4000 : :
4001 : : ! if PAW, one has to solve a generalized eigenproblem
4002 [ - + ]: 5 : gen_eigenpb = psps%usepaw == 1; sij_opt = 0; if (gen_eigenpb) sij_opt = 1
4003 : :
4004 : : ! Loop over my spins.
4005 [ + + ]: 10 : do my_is=1,gstore%my_nspins
4006 : 5 : spin = gstore%my_spins(my_is); gqk => gstore%gqk(my_is); my_npert = gqk%my_npert
4007 : :
4008 [ - + ]: 5 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
4009 : : ! SC: these nctk_prepare_mpiio are not needed anymore. gstore_prepare_mpiio has accessed all the variables after the open,
4010 : : ! and netcdf reads the metadata of a variable only at the first access, so these calls would do nothing.
4011 : : !NCF_CHECK(nctk_prepare_mpiio(spin_ncid, "gvals"))
4012 : : !NCF_CHECK(nctk_prepare_mpiio(root_ncid, "gstore_done_qbz_spin"))
4013 : :
4014 : 5 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
4015 : :
4016 [ - + + - : 15 : ABI_MALLOC(iq_buf, (2, qbuf_size))
+ - + - -
+ - + -
+ ]
4017 [ + + + + ]: 245 : iq_buf = 0
4018 [ - + + - : 15 : ABI_MALLOC(lambda, (nb_k))
+ - + - -
+ - + ]
4019 [ - + + - : 25 : ABI_MALLOC(gkq_atm, (2, nb_kq, nb_k, natom3))
- + + - -
+ + - + -
+ - - + -
+ - + ]
4020 [ - + + - : 20 : ABI_MALLOC(gkq_atm_ipc, (2, nb_kq, nb_k))
- + + - +
- + - - +
- + ]
4021 : : #ifdef HAVE_OPENMP_OFFLOAD
4022 : : !$OMP TARGET ENTER DATA MAP(alloc:gkq_atm_ipc) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4023 : : #endif
4024 : :
4025 : : ! Inside the loops we compute gkq_atm(2, nb_kq, nb_k, natom3)
4026 [ - + + - : 40 : ABI_MALLOC_OR_DIE(my_gbuf, (gqk%cplex, nb_kq, nb_k, natom3, gqk%my_nk, qbuf_size), ierr)
- + + - -
+ + - - +
+ - - + +
- - + + -
+ - + - +
- + - - +
+ - - + ]
4027 : 5 : call pstat_proc%print(_PSTAT_ARGS_)
4028 : :
4029 : : ! Compute the little group of the k-point so that we can compute g(k,q) only for q in the IBZ_k
4030 [ + + ]: 5 : if (use_lgk) then
4031 : 1 : timrev_k = kpts_timrev_from_kptopt(ebands%kptopt)
4032 [ - + + - : 4 : ABI_MALLOC(lg_myk, (gqk%my_nk))
+ - + - -
+ - + - +
+ + + - -
+ - + - +
- + - + -
+ - + ]
4033 [ + + ]: 2 : do my_ik=1,gqk%my_nk
4034 [ + + ]: 4 : kk_bz = gqk%my_kpts(:, my_ik)
4035 : 2 : call lg_myk(my_ik)%init(cryst, kk_bz, timrev_k, gstore%nqbz, gstore%qbz, gstore%nqibz, gstore%qibz, xmpi_comm_self)
4036 : : end do
4037 : : end if
4038 : :
4039 [ - + + - : 20 : ABI_MALLOC(state_kq, (gqk%my_nk, qbuf_size))
- + + - +
- + - - +
- + - + ]
4040 [ + + + + ]: 4981 : state_kq = GSTORE_KQ_MISSING
4041 : :
4042 : : ! SC: iqbuf_cnt is set only for the q-points that are computed, so is has to be initialized. Otherwise a
4043 : : ! proc whose q-points are all done (restart) would read an undefined value in "if (iqbuf_cnt /= 0)" later.
4044 : 5 : iqbuf_cnt = 0
4045 : :
4046 : : ! Loop over my set of q-points
4047 [ + + ]: 882 : do my_iq=1,gqk%my_nq
4048 [ + - + + : 877 : print_time = my_rank == 0 .and. (my_iq <= LOG_MODQ .or. mod(my_iq, LOG_MODQ) == 0)
+ + ]
4049 : 193 : if (print_time) call cwtime(cpu_q, wall_q, gflops_q, "start")
4050 : 877 : iq_bz = gqk%my_q2bz(my_iq)
4051 : :
4052 : 877 : call gqk%myqpt(my_iq, gstore, weight_q, qq_bz)
4053 : : qq_is_gamma = sum(qq_bz**2) < tol14
4054 : 877 : qq_bz_string = ktoa(qq_bz)
4055 : :
4056 : : ! Handle possible restart.
4057 [ - + ]: 877 : if (done_qbz_spin(iq_bz, spin) == 1) then
4058 : 0 : call wrtout(std_out, sjoin(" iq_bz:", itoa(iq_bz), ", spin: ", itoa(spin), " already computed --> skipping iteration"))
4059 : 0 : cycle
4060 : : end if
4061 : :
4062 : : ! Compute the little group of the q-point so that we can compute g(k,q) only for k in the IBZ_q
4063 [ - + ]: 877 : if (dtset%gstore_use_lgq /= 0) then
4064 : 0 : timrev_q = kpts_timrev_from_kptopt(gstore%qptopt)
4065 [ # # # # : 0 : call lg_myq%init(cryst, qq_bz, timrev_q, gstore%nkbz, gstore%kbz, gstore%nkibz, gstore%kibz, xmpi_comm_self)
# # # # #
# ]
4066 : : end if
4067 : :
4068 : 877 : iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
4069 : 877 : trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5,my_iq)
4070 : : ! Don't test if umklapp == 0 because we use the periodic gauge:
4071 : : !
4072 : : ! phfreq(q+G) = phfreq(q) and eigvec(q) = eigvec(q+G)
4073 : : !
4074 : : !isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
4075 : 877 : isirr_q = (isym_q == 1 .and. trev_q == 0)
4076 [ + + ]: 3508 : qq_ibz = gstore%qibz(:, iq_ibz)
4077 : :
4078 : 877 : nskip_tetra_kq = 0
4079 : 877 : iqbuf_cnt = 1 + mod(my_iq - 1, qbuf_size)
4080 [ + + ]: 2631 : iq_buf(:, iqbuf_cnt) = [my_iq, iq_bz]
4081 : :
4082 [ + + ]: 877 : if (need_ftinterp) then
4083 : : ! Fourier interpolation.
4084 [ - + ]: 786 : call dvdb%get_ftqbz(qq_bz, cplex, nfftf, ngfftf, v1scf, gqk%pert_comm%value)
4085 : : else
4086 : : ! Read and reconstruct the dvscf potentials for qpt and my_npert perturbations.
4087 : 91 : db_iqpt = dvdb%findq(qq_ibz)
4088 [ - + ]: 91 : ABI_CHECK(db_iqpt /= -1, sjoin("Could not find symmetric of q-point:", ktoa(qq_bz), "in DVDB file."))
4089 : : ! The first entry in qbz2dvdb gives the index in dvdb%qpts.
4090 : : ! The other entries in mapc_qq are OK as they refer to symmetries.
4091 [ + + ]: 637 : qbz2dvdb = gqk%my_q2ibz(:, my_iq); qbz2dvdb(1) = db_iqpt
4092 [ - + ]: 91 : call dvdb%readsym_qbz(cryst, qq_bz, qbz2dvdb, cplex, nfftf, ngfftf, v1scf, gqk%pert_comm%value)
4093 : : end if
4094 : :
4095 : : ! Allocate vlocal1 with correct cplex. Note nvloc and my_npert.
4096 [ - + + - : 6139 : ABI_MALLOC(vlocal1, (cplex*n4, n5, n6, gs_ham_kq%nvloc, my_npert))
- + + - -
+ + - - +
+ - - + +
- + - + -
- + - + ]
4097 : :
4098 : : ! Set up local potential vlocal1 with proper dimensioning from vtrial1 taking into account the spin.
4099 [ + + ]: 6139 : do my_ip=1,my_npert
4100 : : call rf_transgrid_and_pack(spin, nspden, psps%usepaw, cplex, nfftf, nfft, ngfft, gs_ham_kq%nvloc,&
4101 : 6139 : pawfgr, mpi_enreg, dummy_vtrial, v1scf(:,:,:,my_ip), vlocal, vlocal1(:,:,:,:,my_ip))
4102 : : #ifdef HAVE_OPENMP_OFFLOAD
4103 : : !$OMP TARGET ENTER DATA MAP(to:vlocal1(:,:,:,:,my_ip)) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4104 : : #endif
4105 : : end do
4106 : : !$OMP TASKWAIT
4107 : :
4108 : : ! Continue to initialize the GS Hamiltonian
4109 : 877 : call gs_ham_kq%load_spin(spin, vlocal=vlocal, with_nonlocal=.true.)
4110 : :
4111 : : ! Loop over my k-points
4112 [ + + ]: 74524 : do my_ik=1,gqk%my_nk
4113 : : ! The k-point and the symmetries relating the BZ k-point to the IBZ.
4114 [ + + ]: 294588 : kk_bz = gqk%my_kpts(:, my_ik)
4115 : 73647 : weight_k = gqk%my_wtk(my_ik)
4116 : 73647 : kk_string = ktoa(kk_bz)
4117 : :
4118 : 73647 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
4119 [ + + ]: 294588 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5,my_ik)
4120 [ + + + + : 282012 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
+ + - + ]
4121 [ + + ]: 294588 : kk_ibz = ebands%kptns(:,ik_ibz)
4122 : :
4123 : : ! Set entry to zero. Important as there are cycle instructions inside these loops
4124 : : ! and we don't want random numbers written to disk.
4125 [ + + + + : 5565417 : my_gbuf(:,:,:,:, my_ik, iqbuf_cnt) = zero
+ + + + ]
4126 : :
4127 [ - + ]: 73647 : if (symmetrize .and. .not. isirr_k) then
4128 : 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4129 : : end if
4130 : :
4131 [ + + ]: 73647 : if (use_lgk) then
4132 : 64 : ii = lg_myk(my_ik)%findq_ibzk(qq_bz)
4133 [ + + ]: 64 : if (ii == -1) then
4134 : 56 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4135 : : end if
4136 : : end if
4137 : :
4138 [ - + ]: 73591 : if (dtset%gstore_use_lgq /= 0) then
4139 : 0 : ii = lg_myq%findq_ibzk(kk_bz)
4140 [ # # ]: 0 : if (ii == -1) then
4141 : 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4142 : : end if
4143 : : end if
4144 : :
4145 : : ! =========================================
4146 : : ! Find symmetrical image of k+q in the kIBZ
4147 : : ! =========================================
4148 [ + + ]: 294364 : kq_bz = kk_bz + qq_bz
4149 [ - + ]: 73591 : if (kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz, indkk_kq) /= 0) then
4150 : : write(msg, '(3a)' ) &
4151 : 0 : "Cannot find k+q in k-mesh", ch10, 'Check your WFK file and the (k,q) point input variables.'
4152 : 0 : ABI_ERROR(msg)
4153 : : end if
4154 : :
4155 : 73591 : ikq_ibz = indkk_kq(1, 1); isym_kq = indkk_kq(2, 1)
4156 : 73591 : trev_kq = indkk_kq(6, 1); g0_kq = indkk_kq(3:5, 1)
4157 : : isirr_kq = (isym_kq == 1 .and. trev_kq == 0 .and. all(g0_kq == 0))
4158 [ + + ]: 294364 : kq_ibz = ebands%kptns(:, ikq_ibz)
4159 : :
4160 : : ! If we have used the KERANGE trick, we may have k or k+q points with just one G component set to zero
4161 : : ! so we skip this transition immediately. This should happen only if fsewin > sigma_erange.
4162 [ + - - + ]: 73591 : if (wfd%npwarr(ik_ibz) == 1 .or. wfd%npwarr(ikq_ibz) == 1) then
4163 : 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4164 : : end if
4165 : :
4166 [ - + ]: 73591 : if (gstore%kfilter == "fs_tetra") then
4167 : : ! Check tetra delta(e_{k+q}) and cycle if all the weights at k+q are zero.
4168 [ # # # # : 0 : if (all(abs(gstore%delta_ef_kibz_spin(:, ikq_ibz, spin)) == zero)) then
# # ]
4169 : 0 : nskip_tetra_kq = nskip_tetra_kq + 1
4170 : 0 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_MISSING; cycle
4171 : : end if
4172 : : end if
4173 : :
4174 : : ! Get npw_k, kg_k and symmetrize wavefunctions from the IBZ (if needed).
4175 : : call wfd%sym_ug_kg_npw(ecut, kk_bz, kk_ibz, gqk%bstart_k, nb_k, spin, gqk%my_k2ibz(:, my_ik), cryst, &
4176 [ - + ]: 73591 : work_ngfft, work, istwf_k, npw_k, kg_k, kets_k)
4177 : :
4178 : : #ifdef HAVE_OPENMP_OFFLOAD
4179 : : !$OMP TARGET ENTER DATA MAP(to:kets_k) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4180 : : #endif
4181 : :
4182 : : ! Get npw_kq, kg_kq and symmetrize wavefunctions from the IBZ (if needed).
4183 : : call wfd%sym_ug_kg_npw(ecut, kq_bz, kq_ibz, gqk%bstart_kq, nb_kq, spin, indkk_kq(:,1), cryst, &
4184 [ - + ]: 73591 : work_ngfft, work, istwf_kq, npw_kq, kg_kq, bras_kq)
4185 : :
4186 : : #ifdef HAVE_OPENMP_OFFLOAD
4187 : : !$OMP TARGET ENTER DATA MAP(to:bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4188 : : #endif
4189 : :
4190 [ - + + - : 294364 : ABI_MALLOC(h1_kets_kq, (2, npw_kq*nspinor, nb_k))
- + + - +
- + - - +
- + ]
4191 [ + - - - : 220773 : ABI_MALLOC(gs1c_kq, (2, npw_kq*nspinor*nb_k*((sij_opt+1)/2)))
+ - - + -
+ - + ]
4192 [ - + + - : 220773 : ABI_MALLOC(gvnlx1, (2, npw_kq*nspinor,nb_k))
- + + - -
+ - + ]
4193 : : #ifdef HAVE_OPENMP_OFFLOAD
4194 : : !$OMP TARGET ENTER DATA MAP(alloc:h1_kets_kq, gvnlx1, kets_k, bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4195 : : !$OMP TARGET ENTER DATA MAP(alloc:gs1c_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP .and. sij_opt /= 0) NOWAIT
4196 : : #endif
4197 : :
4198 : : call gs_ham_kq%eph_setup_k("k" , kk_bz, istwf_k, npw_k, kg_k, dtset, cryst, psps, &
4199 [ - + - + : 73591 : nkpg_k, kpg_k, ffnl_k, kinpw_k, ph3d_k, gqk%pert_comm%value)
- + - + ]
4200 : :
4201 : : #ifdef HAVE_OPENMP_OFFLOAD
4202 : : !$OMP TARGET ENTER DATA MAP(to:kpg_k, ffnl_k, kinpw_k, ph3d_k) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4203 : : #endif
4204 : :
4205 : : call gs_ham_kq%eph_setup_k("kq", kq_bz, istwf_k, npw_kq, kg_kq, dtset, cryst, psps, &
4206 [ - + - + : 73591 : nkpg_kq, kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq, gqk%pert_comm%value)
- + - + ]
4207 : :
4208 : : #ifdef HAVE_OPENMP_OFFLOAD
4209 : : !$OMP TARGET ENTER DATA MAP(to:kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP) NOWAIT
4210 : : #endif
4211 : :
4212 : : !$OMP TASKWAIT
4213 : :
4214 : : ! Loop over my atomic perturbations and compute gkq_atm_ipc.
4215 [ + + + + : 5483041 : gkq_atm = zero
+ + + + ]
4216 [ + + ]: 515137 : do my_ip=1,my_npert
4217 : 441546 : idir = dvdb%my_pinfo(1, my_ip); ipert = dvdb%my_pinfo(2, my_ip); ipc = dvdb%my_pinfo(3, my_ip)
4218 : :
4219 : : ! Prepare application of the NL part.
4220 : 441546 : call rf_ham_kq%init(cplex, gs_ham_kq, ipert, has_e1kbsc=.true.)
4221 : 441546 : call rf_ham_kq%load_spin(spin, vlocal1=vlocal1(:,:,:,:,my_ip), with_nonlocal=.true.)
4222 : :
4223 : : #if 1
4224 : : ! Calculate dvscf * psi_k, results stored in h1_kets_kq on the k+q sphere.
4225 : : ! Compute H(1) applied to GS wavefunction Psi(0)
4226 [ + + ]: 1128636 : do in_k=1,nb_k
4227 : : ! Use scissor shift on 0-order eigenvalue
4228 : 687090 : band_k = in_k + gqk%bstart_k - 1
4229 : 1128636 : lambda(in_k) = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
4230 : : end do
4231 : : !call ebands%get_dfpt_eshifted(gqk%bstart_k, nb_k, ik_ibz, spin, dtset%dfpt_sciss, lambda)
4232 : :
4233 : : call getgh1c(berryopt0, kets_k, cwaveprj0, h1_kets_kq, &
4234 : : grad_berry, gs1c_kq, gs_ham_kq, gvnlx1, idir, ipert, lambda, mpi_enreg, nb_k, optlocal, &
4235 : 441546 : optnl, opt_gvnlx1, rf_ham_kq, sij_opt, tim_getgh1c, usevnl)
4236 : :
4237 : : #else
4238 : : do in_k=1,nb_k
4239 : : ! Use scissor shift on 0-order eigenvalue
4240 : : band_k = in_k + gqk%bstart_k - 1
4241 : : eshift = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
4242 : :
4243 : : call getgh1c(berryopt0, kets_k(:,:,in_k), cwaveprj0, h1_kets_kq(:,:,in_k), &
4244 : : grad_berry, gs1c_kq, gs_ham_kq, gvnlx1, idir, ipert, [eshift], mpi_enreg, ndat1, optlocal, &
4245 : : optnl, opt_gvnlx1, rf_ham_kq, sij_opt, tim_getgh1c, usevnl)
4246 : : end do ! in_k
4247 : : #endif
4248 : :
4249 : 441546 : call rf_ham_kq%free()
4250 : :
4251 : : ! Calculate <psi_{k+q,j}|dvscf_q*psi_{k,i}> for this perturbation. No need to handle istwf_kq because it's always 1.
4252 [ - + ]: 441546 : if (dtset%gpu_option == ABI_GPU_OPENMP) then
4253 : : call abi_gpu_xgemm_d(2, 'C', 'N', nb_kq, nb_k, npw_kq*nspinor, cone, bras_kq, npw_kq*nspinor, &
4254 : 0 : h1_kets_kq, npw_kq*nspinor, czero, gkq_atm_ipc, nb_kq)
4255 : : #ifdef HAVE_OPENMP_OFFLOAD
4256 : : !$OMP TARGET UPDATE FROM(gkq_atm_ipc)
4257 : : #endif
4258 : : else
4259 : : call ZGEMM('C', 'N', nb_kq, nb_k, npw_kq*nspinor, cone, bras_kq, npw_kq*nspinor, &
4260 : 441546 : h1_kets_kq, npw_kq*nspinor, czero, gkq_atm_ipc, nb_kq)
4261 : : end if
4262 : :
4263 : : ! Transfer data
4264 [ + + + + : 5483041 : gkq_atm(:,:,:,ipc) = gkq_atm_ipc
+ + ]
4265 : : end do ! my_ip
4266 : :
4267 : : ! Collect gkq_atm inside pert_comm so that all procs can operate on the data.
4268 [ - + ]: 73591 : if (gqk%pert_comm%nproc > 1) call xmpi_sum(gkq_atm, gqk%pert_comm%value, ierr)
4269 : :
4270 : : ! Save e-ph matrix elements in the buffer.
4271 [ + + + + : 5483041 : my_gbuf(:,:,:,:, my_ik, iqbuf_cnt) = gkq_atm
+ + + + ]
4272 : 73591 : state_kq(my_ik, iqbuf_cnt) = GSTORE_KQ_COMPUTED
4273 : :
4274 : : #ifdef HAVE_OPENMP_OFFLOAD
4275 : : !$OMP TARGET EXIT DATA MAP(delete:kpg_k, ffnl_k, kinpw_k, ph3d_k) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4276 : : !$OMP TARGET EXIT DATA MAP(delete:kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4277 : : !$OMP TARGET EXIT DATA MAP(delete:h1_kets_kq, gvnlx1, kets_k, bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4278 : : !$OMP TARGET EXIT DATA MAP(delete:gs1c_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP .and. sij_opt /= 0)
4279 : : #endif
4280 [ - + ]: 73591 : ABI_FREE(ffnl_k)
4281 [ - + ]: 73591 : ABI_FREE(ffnl_kq)
4282 [ - + ]: 73591 : ABI_FREE(kpg_k)
4283 [ - + ]: 73591 : ABI_FREE(kpg_kq)
4284 [ - + ]: 73591 : ABI_FREE(ph3d_k)
4285 [ - + ]: 73591 : ABI_FREE(ph3d_kq)
4286 [ - + ]: 73591 : ABI_FREE(kinpw_k)
4287 [ - + ]: 73591 : ABI_FREE(kinpw_kq)
4288 [ - + ]: 73591 : ABI_FREE(kets_k)
4289 [ - + ]: 73591 : ABI_FREE(bras_kq)
4290 [ - + ]: 73591 : ABI_FREE(h1_kets_kq)
4291 [ - + ]: 73591 : ABI_FREE(gs1c_kq)
4292 [ - + ]: 74468 : ABI_FREE(gvnlx1)
4293 : : end do ! my_ik
4294 : :
4295 [ - + ]: 877 : ABI_FREE(v1scf)
4296 : :
4297 : : #ifdef HAVE_OPENMP_OFFLOAD
4298 : : do my_ip=1,my_npert
4299 : : !$OMP TARGET EXIT DATA MAP(delete:vlocal1(:,:,:,:,my_ip)) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4300 : : end do
4301 : : #endif
4302 [ - + ]: 877 : ABI_FREE(vlocal1)
4303 : :
4304 : : ! Dump buffer
4305 [ + + ]: 877 : if (iqbuf_cnt == qbuf_size) call dump_my_gbuf()
4306 : :
4307 [ + + ]: 877 : if (print_time) then
4308 : 193 : write(msg,'(2(a,i0),a)')" My q-point [", my_iq, "/", gqk%my_nq, "]"
4309 [ + + ]: 193 : call cwtime_report(msg, cpu_q, wall_q, gflops_q); if (my_iq == LOG_MODQ) call wrtout(std_out, "...", do_flush=.True.)
4310 : : end if
4311 : 882 : call lg_myq%free()
4312 : : end do ! my_iq
4313 : :
4314 : : ! Dump the remainder.
4315 [ + + ]: 5 : if (iqbuf_cnt /= 0) call dump_my_gbuf()
4316 : :
4317 [ - + ]: 5 : ABI_FREE(state_kq)
4318 [ - + ]: 5 : ABI_FREE(iq_buf)
4319 [ - + ]: 5 : ABI_FREE(my_gbuf)
4320 [ - + ]: 5 : ABI_FREE(lambda)
4321 [ - + ]: 5 : ABI_FREE(gkq_atm)
4322 : : #ifdef HAVE_OPENMP_OFFLOAD
4323 : : !$OMP TARGET EXIT DATA MAP(delete:gkq_atm_ipc) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4324 : : #endif
4325 [ - + ]: 5 : ABI_FREE(gkq_atm_ipc)
4326 : :
4327 [ + + ]: 10 : if (use_lgk) then
4328 [ + + ]: 2 : do my_ik=1,gqk%my_nk
4329 : 2 : call lg_myk(my_ik)%free()
4330 : : end do
4331 [ + - + + : 2 : ABI_FREE(lg_myk)
- + - + -
+ - + - +
- + - + -
+ ]
4332 : : end if
4333 : : end do ! my_is
4334 : :
4335 : 5 : call cwtime_report(" GSTORE computation done", cpu_all, wall_all, gflops_all, pre_str=ch10, end_str=ch10) !, comm=gstore%comm)
4336 : : !call gstore%print([std_out], header="GSTORE at the end of gstore%compute")
4337 : :
4338 : : ! Set gstore_completed to 1 so that we can easily check if restarted is needed.
4339 : : !if (my_rank == master) then
4340 [ - + ]: 5 : NCF_CHECK(nf90_put_var(root_ncid, root_vid("gstore_completed"), 1))
4341 : : !end if
4342 : : ! nf90_sync can deadlock on lemaitre4 for some MPI decompositions.
4343 : : !if (dtset%useria /= 888) then
4344 [ - + ]: 5 : NCF_CHECK(nf90_sync(root_ncid))
4345 : : !end if
4346 [ - + ]: 5 : NCF_CHECK(nf90_close(root_ncid))
4347 : 5 : call xmpi_barrier(gstore%comm)
4348 : :
4349 : : ! Free memory
4350 [ - + ]: 5 : ABI_FREE(grad_berry)
4351 [ - + ]: 5 : ABI_FREE(dummy_vtrial)
4352 [ - + ]: 5 : ABI_FREE(work)
4353 [ - + ]: 5 : ABI_FREE(ph1d)
4354 [ - + ]: 5 : ABI_FREE(vlocal)
4355 [ - + ]: 5 : ABI_FREE(kg_k)
4356 [ - + ]: 5 : ABI_FREE(kg_kq)
4357 [ - + ]: 5 : ABI_FREE(displ_cart_qibz)
4358 [ - + ]: 5 : ABI_FREE(done_qbz_spin)
4359 : :
4360 : 5 : call gs_ham_kq%free(); call wfd%free()
4361 : 5 : call pawcprj_free(cwaveprj0)
4362 [ + - - + : 5 : ABI_FREE(cwaveprj0)
- - - - -
+ ]
4363 : :
4364 : : ! Reconstruct g(k,q) matrix elements in the full BZ by symmetry.
4365 [ - + ]: 5 : if (symmetrize) then
4366 : 0 : call gstore_symmetrize(gstore%path, wfk0_path, ngfft, dtset, dtfil, cryst, psps, pawtab, ebands, ifc, comm)
4367 : : end if
4368 : :
4369 : : ! Output some of the results to ab_out for testing purposes
4370 [ - + - + : 30 : call gstore%print_for_abitests(dtset, ebands, .True.)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - - - -
- - - - -
- - - - -
- + - - -
- - - - -
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
+ - + - +
- + ]
4371 : :
4372 : : contains
4373 : :
4374 : 56 : subroutine dump_my_gbuf()
4375 : :
4376 : : ! This function is called inside the double loop over (my_is, my_iq) or when we exit
4377 : : ! from the my_iq loop to dump the remainder that is still in the q-buffer,
4378 : : ! All the MPI procs in the (kpt_comm x pert_comm) grid shall call this contained routine
4379 : : ! as we have side-effects i.e. iqbuf_cnt set to 0.
4380 : :
4381 : : ! On disk we have the global arrays:
4382 : : !
4383 : : ! nctkarr_t("gvals", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq")
4384 : : !
4385 : : ! while the local MPI buffers are dimensioned as follows:
4386 : : !
4387 : : ! my_gbuf(2, nb_kq, nb_k, natom3, gqk%my_nk, qbuf_size)
4388 : :
4389 : : ! If parallelism over perturbation is activated, only the procs treating the first perturbation
4390 : : ! i.e. the procs treating different k-points for this q are involved in IO
4391 : : ! as all the local buffers store results for all natom3 perturbations.
4392 : :
4393 : : ! NOTE: A similar routine is used in m_gstore. The two implementations should be kept in synch.
4394 : :
4395 : : integer :: ii, iq_bz, iq_glob, my_iq
4396 : : logical :: iscontiguous
4397 : :
4398 : : ! All the procs in pert_comm write the same data (my_gbuf is summed inside pert_comm): the procs with
4399 : : ! coords_qkpb_sumbp(3) /= 0 used to skip the writes, but then the nf90_sync below, called by all the procs,
4400 : : ! fails with "NetCDF: Can't add HDF5 file metadata" when GSTORE.nc is opened with gstore%comm.
4401 : : ! SC: The GOTO was not the cause: the first access to gstore_glob_state_kqs, which was not prepared,
4402 : : ! triggered a collective metadata read done by the writers only, while the other procs were in nf90_sync.
4403 : : ! All the variables are now prepared after the open (gstore_prepare_mpiio), so the GOTO is restored:
4404 : : ! only the procs with coords_qkpb_sumbp(3) == 0 write.
4405 [ + - ]: 56 : if (gqk%coords_qkpb_sumbp(3) /= 0) goto 10 ! Yes, I'm very proud of this GOTO.
4406 : :
4407 : : !if (dtset%prtvol > 5) then
4408 : : !print *, "in dump_my_gbuf with start: ", [1, 1, 1, 1, gqk%my_kstart, iq_glob]
4409 : : !print *, " count; ", [2, gqk%nb_kq, gqk%nb_k, gqk%natom3, gqk%my_nk, iqbuf_cnt]
4410 : : !end if
4411 : :
4412 : : ! Check if the q-points in the buffer are perfectly contiguous (no cycles/holes)
4413 : 56 : iscontiguous = .True.
4414 [ + + ]: 933 : do ii=1, iqbuf_cnt
4415 : 877 : my_iq = iq_buf(1, ii)
4416 [ + - ]: 877 : if (my_iq == 0) then
4417 : : iscontiguous = .False.; exit
4418 : : end if
4419 [ + + ]: 933 : if (ii > 1) then
4420 [ + - ]: 821 : if (my_iq /= iq_buf(1, ii-1) + 1) then
4421 : : iscontiguous = .False.; exit
4422 : : end if
4423 : : end if
4424 : : end do
4425 : :
4426 [ - + ]: 56 : if (iscontiguous) then
4427 : : ! Fast path: Write slabs directly
4428 : 56 : my_iq = iq_buf(1, 1)
4429 : 56 : iq_glob = my_iq + gqk%my_qstart - 1
4430 : :
4431 : : ncerr = nf90_put_var(spin_ncid, spin_vid("gvals"), my_gbuf(:,:,:,:,:, 1:iqbuf_cnt), &
4432 : : start=[1, 1, 1, 1, gqk%my_kstart, iq_glob], &
4433 [ + + + + ]: 728 : count=[2, gqk%nb_kq, gqk%nb_k, gqk%natom3, gqk%my_nk, iqbuf_cnt])
4434 [ - + ]: 56 : NCF_CHECK(ncerr)
4435 : :
4436 : : ncerr = nf90_put_var(root_ncid, root_vid("gstore_glob_state_kqs"), state_kq(:, 1:iqbuf_cnt), &
4437 : : start=[gqk%my_kstart, iq_glob, spin], &
4438 [ + + + + ]: 392 : count=[gqk%my_nk, iqbuf_cnt, 1])
4439 [ - + ]: 56 : NCF_CHECK(ncerr)
4440 : : else
4441 : : ! Slow path: Q-points were filtered, write slice by slice avoiding holes
4442 [ # # ]: 0 : do ii=1, iqbuf_cnt
4443 : 0 : my_iq = iq_buf(1, ii)
4444 [ # # ]: 0 : if (my_iq == 0) cycle
4445 : 0 : iq_glob = my_iq + gqk%my_qstart - 1
4446 : :
4447 : : ncerr = nf90_put_var(spin_ncid, spin_vid("gvals"), my_gbuf(:,:,:,:,:, ii), &
4448 : : start=[1, 1, 1, 1, gqk%my_kstart, iq_glob], &
4449 [ # # # # ]: 0 : count=[2, gqk%nb_kq, gqk%nb_k, gqk%natom3, gqk%my_nk, 1])
4450 [ # # ]: 0 : NCF_CHECK(ncerr)
4451 : :
4452 : : ncerr = nf90_put_var(root_ncid, root_vid("gstore_glob_state_kqs"), state_kq(:, ii), &
4453 : : start=[gqk%my_kstart, iq_glob, spin], &
4454 [ # # # # ]: 0 : count=[gqk%my_nk, 1, 1])
4455 [ # # ]: 0 : NCF_CHECK(ncerr)
4456 : : end do
4457 : : end if
4458 : :
4459 : : ! Only one proc sets the entry in done_qbz_spin to 1 for all the q-points in the buffer.
4460 : : !if (all(gqk%coords_qkpb_sumbp(2:3) == [0, 0])) then
4461 [ + + ]: 933 : do ii=1,iqbuf_cnt
4462 : 877 : my_iq = iq_buf(1, ii)
4463 [ - + ]: 877 : if (my_iq == 0) cycle
4464 : 877 : iq_bz = iq_buf(2, ii)
4465 [ + + - + : 2687 : NCF_CHECK(nf90_put_var(root_ncid, root_vid("gstore_done_qbz_spin"), 1, start=[iq_bz, spin]))
- - ]
4466 : : end do
4467 : : !end if
4468 : :
4469 : : ! Zero the counter before returning
4470 : 56 : 10 iqbuf_cnt = 0
4471 [ + + + + ]: 2744 : iq_buf = 0
4472 [ + + + + ]: 76088 : state_kq = GSTORE_KQ_MISSING
4473 : :
4474 : : ! These syncs can deadlock on lemaitre4 for some MPI decompositions.
4475 : : ! SC: nf90_sync is collective on a file opened with gstore%comm (HDF5 flush of the metadata cache), so all
4476 : : ! the procs must call it the same number of times. dump_my_gbuf is called a number of times that depends on
4477 : : ! the proc (my_nq differs when nqbz is not a multiple of the number of q-blocks, q-points done in a previous
4478 : : ! run are skipped on restart), hence these syncs deadlock on the machine. The file is synced once by all
4479 : : ! the procs after the loops. The syncs are not needed for restart as the q-points written before a kill are
4480 : : ! in the file (checked with kill -9 in gwpt_run, which writes GSTORE.nc in the same way).
4481 : : !if (dtset%useria /= 888) then
4482 : : ! NCF_CHECK(nf90_sync(spin_ncid))
4483 : : ! NCF_CHECK(nf90_sync(root_ncid))
4484 : : !end if
4485 : :
4486 : 56 : end subroutine dump_my_gbuf
4487 : :
4488 : 943 : integer function root_vid(var_name)
4489 : : character(len=*),intent(in) :: var_name
4490 : 943 : root_vid = nctk_idname(root_ncid, var_name)
4491 : : end function root_vid
4492 : :
4493 : 56 : integer function spin_vid(var_name)
4494 : : character(len=*),intent(in) :: var_name
4495 : 56 : spin_vid = nctk_idname(spin_ncid, var_name)
4496 : : end function spin_vid
4497 : :
4498 : : end subroutine gstore_compute
4499 : : !!***
4500 : :
4501 : : !----------------------------------------------------------------------
4502 : :
4503 : : !!****f* m_gstore/gstore_check_qkzone_gmode
4504 : : !! NAME
4505 : : !! gstore_check_cplex_qkzone_gmode
4506 : : !!
4507 : : !! FUNCTION
4508 : : !! Perform consistency checks
4509 : : !!
4510 : : !! INPUTS
4511 : : !!
4512 : : !! SOURCE
4513 : :
4514 : 9 : integer function gstore_check_cplex_qkzone_gmode(gstore, cplex, qzone, kzone, gmode, &
4515 : : kfilter, check_alloc) result(ierr) ! optional
4516 : :
4517 : : !Arguments ------------------------------------
4518 : : class(gstore_t),target,intent(in) :: gstore
4519 : : integer,intent(in) :: cplex
4520 : : character(len=*),intent(in) :: qzone, kzone, gmode
4521 : : character(len=*),optional,intent(in) :: kfilter
4522 : : logical,optional,intent(in) :: check_alloc
4523 : :
4524 : : !Local variables-------------------------------
4525 : : integer :: my_is
4526 : : logical :: check_alloc__
4527 : : ! *************************************************************************
4528 : :
4529 : 9 : ierr = 0
4530 [ - + ]: 9 : ABI_CHECK_NOSTOP(gstore%qzone == qzone, sjoin("qzone: ", qzone, "required but got: ", gstore%qzone), ierr)
4531 [ - + ]: 9 : ABI_CHECK_NOSTOP(gstore%kzone == kzone, sjoin("kzone: ", kzone, "required but got: ", gstore%kzone), ierr)
4532 [ - + ]: 9 : ABI_CHECK_NOSTOP(gstore%gmode == gmode, sjoin("gmode: ", gmode, "required but got: ", gstore%gmode), ierr)
4533 [ - + ]: 9 : if (present(kfilter)) then
4534 [ # # ]: 0 : ABI_CHECK_NOSTOP(gstore%kfilter == kfilter, sjoin("kfilter: ", kfilter, "required but got: ", gstore%kfilter), ierr)
4535 : : end if
4536 : :
4537 [ - + ]: 9 : check_alloc__ = .True.; if (present(check_alloc)) check_alloc__ = check_alloc
4538 : :
4539 [ + + ]: 18 : do my_is=1,gstore%my_nspins
4540 : 9 : associate (gqk => gstore%gqk(my_is))
4541 : 0 : ABI_CHECK_NOSTOP(gqk%cplex == cplex, sjoin("cplex:", itoa(cplex), "required but got: ", itoa(gqk%cplex)), ierr)
4542 [ - + + - ]: 9 : if (check_alloc__) then
4543 [ - + ]: 9 : if (cplex == 1) then
4544 [ # # ]: 0 : ABI_CHECK_NOSTOP(allocated(gqk%my_g2), "my_g2 array is not allocated", ierr)
4545 [ + - ]: 9 : else if (cplex == 2) then
4546 [ - + ]: 9 : ABI_CHECK_NOSTOP(allocated(gqk%my_g), "my_g array is not allocated", ierr)
4547 : : end if
4548 : : end if
4549 : : end associate
4550 : : end do
4551 : :
4552 : 9 : end function gstore_check_cplex_qkzone_gmode
4553 : : !!***
4554 : :
4555 : : !----------------------------------------------------------------------
4556 : :
4557 : : !!****f* m_gstore/gstore_from_ncpath
4558 : : !! NAME
4559 : : !! gstore_from_ncpath
4560 : : !!
4561 : : !! FUNCTION
4562 : : !! Reconstruct a gstore_t instance from a netcdf file.
4563 : : !!
4564 : : !! INPUTS
4565 : : !! path: Path to the GSTORE file.
4566 : : !! with_cplex: 0 to read no matrix elements, 1 for |g|^2, 2 for complex g.
4567 : : !! with_gmode defines the representation.
4568 : : !! dtset: Input variables
4569 : : !! cryst: crystalline structure
4570 : : !! ebands: KS energies
4571 : : !! ifc: interatomic force constants
4572 : : !! with_gmode: "phonon" to have g in the phonon representation or "atom" to have them in atom representation.
4573 : : !! gvals_name: "gvals" or "gvals_ks" to read the KS gs produced by the GWPT code.
4574 : : !! This option is valid only for gstore files produced by the GWPT code.
4575 : : !! with_g2dw: True if Debye-Waller g2 in the RIA should be computed and stored in memory.
4576 : : !! comm: MPI communicator.
4577 : : !!
4578 : : !! SOURCE
4579 : :
4580 : 16 : subroutine gstore_from_ncpath(gstore, path, with_cplex, dtset, dtfil, cryst, ebands, ifc, &
4581 : : with_gmode, gvals_name, with_g2dw, comm)
4582 : :
4583 : : !Arguments ------------------------------------
4584 : : class(gstore_t),target,intent(out) :: gstore
4585 : : character(len=*),intent(in) :: path
4586 : : integer,intent(in) :: with_cplex
4587 : : type(dataset_type),target,intent(in) :: dtset
4588 : : type(datafiles_type),intent(in) :: dtfil
4589 : : class(crystal_t),target,intent(in) :: cryst
4590 : : class(ebands_t),target,intent(in) :: ebands
4591 : : class(ifc_type),target,intent(in) :: ifc
4592 : : character(len=*),intent(in) :: with_gmode, gvals_name
4593 : : logical,intent(in) :: with_g2dw
4594 : : integer,intent(in) :: comm
4595 : :
4596 : : !Local variables-------------------------------
4597 : : !scalars
4598 : : integer,parameter :: master = 0
4599 : : integer :: my_rank, ncid, spin, spin_ncid, nproc, ierr, fform, max_nb, ib, natom, natom3, ib_m, ib_n !, varid
4600 : : integer :: max_nq, max_nk, ncerr, my_is, my_iq, iq_glob, my_ik, ik_glob
4601 : : integer :: nb_k, nb_kq, nb_k_file, nb_kq_file, gstore_cplex, ib_kq_start, file_fnlen !, ip1, ip2
4602 : : integer :: my_ip, ipert, iq_ibz, iq_bz, isym_q, trev_q, tsign_q, ii !, im_kq
4603 : : real(dp),parameter :: G_SMALL = tol8
4604 : : real(dp) :: cpu, wall, gflops, wqnu
4605 : : logical :: isirr_q, from_atm_to_nu, has_iv1p_comm, read_ks, has_both_g
4606 : 16 : type(hdr_type) :: wfk0_hdr
4607 [ + + + + : 832 : type(crystal_t) :: gstore_cryst
+ + + + +
+ + + + +
+ + + + ]
4608 : : type(gqk_t),pointer :: gqk
4609 : : character(len=500) :: msg
4610 : : !arrays
4611 : 64 : integer :: units(2), ibuffer(9), nproc_spin(ebands%nsppol), comm_spin(ebands%nsppol)
4612 : 32 : integer :: brange_k_spin(2, ebands%nsppol), brange_kq_spin(2, ebands%nsppol), file_brange_kq_spin(2, ebands%nsppol), g0_q(3)
4613 : 16 : integer,allocatable :: qglob2bz(:,:), qbz2ibz(:,:)
4614 : : real(dp) :: qq_ibz(3)
4615 : 32 : real(dp) :: displ_nu_red(2, 3, cryst%natom)
4616 : 16 : real(dp),allocatable :: gwork_q(:,:,:,:,:), slice_bb(:,:,:), iv1p_comm(:,:,:,:,:)
4617 : 16 : real(dp),allocatable :: ks_gwork_q(:,:,:,:,:), ks_slice_bb(:,:,:)
4618 : 16 : real(dp),allocatable :: phfreqs_ibz(:,:), pheigvec_cart_ibz(:,:,:,:,:), pheigvec_cart_qbz(:,:,:,:)
4619 : 16 : real(dp),allocatable :: displ_cart_qbz(:,:,:,:), displ_red_qbz(:,:,:,:), gmn_nu(:,:,:,:)
4620 [ + - ]: 16 : complex(dp),allocatable :: tpp_red(:,:), my_gq0nm_atm(:,:,:,:), ks_my_gq0nm_atm(:,:,:,:)
4621 : : ! *************************************************************************
4622 : :
4623 : 16 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
4624 : :
4625 [ - + ]: 16 : ABI_CHECK(with_cplex >= 0 .and. with_cplex <= 2, sjoin("Invalid with_cplex:", itoa(with_cplex)))
4626 : :
4627 [ + + ]: 48 : units = [std_out, ab_out]
4628 : 16 : call wrtout(units, sjoin("- Reading e-ph matrix elements from: ", path), pre_newlines=1)
4629 : 16 : call wrtout(units, sjoin(" Asking for with_cplex: ", itoa(with_cplex)))
4630 [ + - ]: 16 : call wrtout(units, sjoin(" Asking for with_gmode: ", trim(with_gmode)))
4631 [ + - ]: 16 : call wrtout(units, sjoin(" Asking for gvals_name: ", trim(gvals_name)))
4632 : 16 : call wrtout(units, sjoin(" Asking for g2dw: ", yesno(with_g2dw)))
4633 : :
4634 : : ! Set basic parameters.
4635 [ - + ]: 16 : gstore%comm = comm; gstore%nsppol = dtset%nsppol; gstore%path = path
4636 : :
4637 : : ! Get references to other data structures.
4638 : 16 : gstore%dtset => dtset; gstore%cryst => cryst; gstore%ebands => ebands; gstore%ifc => ifc; gstore%kibz => ebands%kptns
4639 : :
4640 : 16 : natom = cryst%natom; natom3 = cryst%natom * 3
4641 : :
4642 [ - + + - : 96 : ABI_CALLOC(gstore%erange_spin, (2, gstore%nsppol))
+ - + - -
+ - + - +
+ + + + ]
4643 [ - + + - : 48 : ABI_MALLOC(gstore%glob_nk_spin, (gstore%nsppol))
+ - + - -
+ - + -
+ ]
4644 [ - + + - : 48 : ABI_MALLOC(gstore%glob_nq_spin, (gstore%nsppol))
+ - + - -
+ - + -
+ ]
4645 : :
4646 : : ! =====================================================
4647 : : ! Master node reads basic objects and gstore dimensions
4648 : : ! =====================================================
4649 : :
4650 [ + - ]: 16 : if (my_rank == master) then
4651 : 16 : call wrtout(units, sjoin(" Initializing gstore object from:", path, ch10))
4652 [ - + ]: 16 : ABI_CHECK(path /= ABI_NOFILE, "Use getgstore_filepath to specify the path to GSTORE.nc")
4653 [ - + ]: 16 : NCF_CHECK(nctk_open_read(ncid, path, xmpi_comm_self))
4654 : :
4655 : 16 : call wfk0_hdr%ncread(ncid, fform)
4656 [ - + ]: 16 : ABI_CHECK(fform /= 0, sjoin("Error while reading:", path))
4657 : :
4658 : : ! Read gstore dimensions
4659 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_cplex", gstore_cplex))
4660 [ - + ]: 16 : ABI_CHECK_IEQ(gstore_cplex, 2, "gstore_cplex 1 from file not supported")
4661 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nkibz", gstore%nkibz))
4662 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nkbz", gstore%nkbz))
4663 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nqibz", gstore%nqibz))
4664 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_nqbz", gstore%nqbz))
4665 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_max_nq", max_nq))
4666 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_max_nk", max_nk))
4667 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "gstore_max_nb", max_nb))
4668 : :
4669 : : ! Read gstore variables
4670 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_with_vk"), gstore%with_vk))
4671 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qptopt"), gstore%qptopt))
4672 : :
4673 : : ! little group variables were added in Abinit v10.5.6.
4674 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_use_lgk"), gstore%has_used_lgk))
4675 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_use_lgq"), gstore%has_used_lgq))
4676 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kzone"), gstore%kzone))
4677 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qzone"), gstore%qzone))
4678 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kfilter"), gstore%kfilter))
4679 : : ! SC: GSTORE.nc files written before fnlen was raised from 264 to 400 have a shorter fnlen dimension.
4680 : : ! Read only the characters present in the file so that these old files can still be read.
4681 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(ncid, "fnlen", file_fnlen))
4682 : 16 : gstore%wfk0_path = ""
4683 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_wfk0_path"), gstore%wfk0_path(1:min(fnlen, file_fnlen))))
4684 : 16 : call replace_ch0(gstore%kzone); call replace_ch0(gstore%qzone); call replace_ch0(gstore%kfilter)
4685 : 16 : call replace_ch0(gstore%wfk0_path)
4686 : :
4687 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_gtype"), gstore%gtype))
4688 : 16 : call replace_ch0(gstore%gtype)
4689 : : !print *, "gstore%gtype:", gstore%gtype
4690 : :
4691 [ + + ]: 16 : if (gvals_name == "gvals_ks") then
4692 : 2 : call wrtout(units, " Reading KS e-ph matrix elements")
4693 [ + - ]: 14 : else if (gvals_name == "gvals") then
4694 [ + + ]: 14 : if (gstore%gtype == GSTORE_GTYPE_GWPT) then
4695 : 4 : call wrtout(units, " Reading GWPT e-ph matrix elements")
4696 : : else
4697 : 10 : call wrtout(units, " Reading KS e-ph matrix elements")
4698 : : end if
4699 : : end if
4700 : :
4701 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_ngqpt"), gstore%ngqpt))
4702 : :
4703 [ - + + - : 48 : ABI_MALLOC(gstore%qibz, (3, gstore%nqibz))
+ - + - -
+ - + -
+ ]
4704 [ - + + - : 48 : ABI_MALLOC(gstore%wtq, (gstore%nqibz))
+ - + - -
+ - + -
+ ]
4705 [ - + + - : 48 : ABI_MALLOC(gstore%qbz, (3, gstore%nqbz))
+ - + - -
+ - + -
+ ]
4706 [ - + + - : 48 : ABI_MALLOC(gstore%kbz, (3, gstore%nkbz))
+ - + - -
+ - + -
+ ]
4707 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_k_spin"), brange_k_spin))
4708 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_kq_spin"), brange_kq_spin))
4709 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_erange_spin"), gstore%erange_spin))
4710 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qibz"), gstore%qibz))
4711 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_wtq"), gstore%wtq))
4712 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qbz"), gstore%qbz))
4713 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kbz"), gstore%kbz))
4714 : :
4715 [ - + + - : 48 : ABI_MALLOC(qbz2ibz, (6, gstore%nqbz))
+ - + - -
+ - + -
+ ]
4716 [ - + + - : 48 : ABI_MALLOC(gstore%kbz2ibz, (6, gstore%nkbz))
+ - + - -
+ - + -
+ ]
4717 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qbz2ibz"), qbz2ibz))
4718 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kbz2ibz"), gstore%kbz2ibz))
4719 : :
4720 [ - + + - : 64 : ABI_MALLOC(qglob2bz, (max_nq, gstore%nsppol))
- + + - +
- + - - +
- + - + ]
4721 [ - + + - : 64 : ABI_MALLOC(gstore%kglob2bz, (max_nk, gstore%nsppol))
- + + - +
- + - - +
- + - + ]
4722 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_qglob2bz"), qglob2bz))
4723 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_kglob2bz"), gstore%kglob2bz))
4724 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_glob_nq_spin"), gstore%glob_nq_spin))
4725 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_glob_nk_spin"), gstore%glob_nk_spin))
4726 : :
4727 : : ! Read optional variables:
4728 [ - + ]: 16 : if (gstore%kfilter == "fs_tetra") then
4729 [ # # # # : 0 : ABI_MALLOC(gstore%delta_ef_kibz_spin, (max_nb, gstore%nkibz, gstore%nsppol))
# # # # #
# # # # #
# # # # #
# # # ]
4730 [ # # ]: 0 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_delta_ef_kibz_spin"), gstore%delta_ef_kibz_spin))
4731 : : end if
4732 : :
4733 [ - + ]: 16 : NCF_CHECK(nf90_close(ncid))
4734 : :
4735 : : ! =================
4736 : : ! Consistency check
4737 : : ! =================
4738 [ - + - + : 16 : gstore_cryst = wfk0_hdr%get_crystal()
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + ]
4739 [ - + ]: 16 : if (cryst%compare(gstore_cryst, header=" Comparing input crystal with the one from GSTORE file") /= 0) then
4740 : 0 : ABI_ERROR("Crystal structure from input and GSTORE do not agree! Check messages above!")
4741 : : end if
4742 : 16 : call gstore_cryst%free()
4743 : : end if ! master
4744 : :
4745 [ - + ]: 16 : if (nproc > 1) then
4746 : : ! Broadcast the header.
4747 : 0 : call wfk0_hdr%bcast(master, my_rank, comm)
4748 : :
4749 : : ! Broadcast dimensions.
4750 [ # # ]: 0 : if (my_rank == master) then
4751 [ # # ]: 0 : ibuffer = [gstore_cplex, gstore%nkibz, gstore%nkbz, gstore%nqibz, gstore%nqbz, gstore%with_vk, max_nq, max_nk, max_nb]
4752 : : end if
4753 : 0 : call xmpi_bcast(ibuffer, master, comm, ierr)
4754 : :
4755 [ # # ]: 0 : if (my_rank /= master) then
4756 : : ! Other MPI procs need to store dims and allocate memory before the bcast.
4757 : 0 : gstore_cplex = ibuffer(1)
4758 : 0 : gstore%nkibz = ibuffer(2)
4759 : 0 : gstore%nkbz = ibuffer(3)
4760 : 0 : gstore%nqibz = ibuffer(4)
4761 : 0 : gstore%nqbz = ibuffer(5)
4762 : 0 : gstore%with_vk = ibuffer(6)
4763 : 0 : max_nq = ibuffer(7)
4764 : 0 : max_nk = ibuffer(8)
4765 : 0 : max_nb = ibuffer(9)
4766 : :
4767 [ # # # # : 0 : ABI_MALLOC(gstore%qibz, (3, gstore%nqibz))
# # # # #
# # # #
# ]
4768 [ # # # # : 0 : ABI_MALLOC(gstore%wtq, (gstore%nqibz))
# # # # #
# # # #
# ]
4769 [ # # # # : 0 : ABI_MALLOC(gstore%qbz, (3, gstore%nqbz))
# # # # #
# # # #
# ]
4770 [ # # # # : 0 : ABI_MALLOC(gstore%kbz, (3, gstore%nkbz))
# # # # #
# # # #
# ]
4771 [ # # # # : 0 : ABI_MALLOC(qbz2ibz, (6, gstore%nqbz))
# # # # #
# # # #
# ]
4772 [ # # # # : 0 : ABI_MALLOC(gstore%kbz2ibz, (6, gstore%nkbz))
# # # # #
# # # #
# ]
4773 [ # # # # : 0 : ABI_MALLOC(qglob2bz, (max_nq, gstore%nsppol))
# # # # #
# # # # #
# # # # ]
4774 [ # # # # : 0 : ABI_MALLOC(gstore%kglob2bz, (max_nk, gstore%nsppol))
# # # # #
# # # # #
# # # # ]
4775 : : end if
4776 : :
4777 : 0 : call xmpi_bcast(gstore%qptopt, master, comm, ierr)
4778 : 0 : call xmpi_bcast(gstore%has_used_lgk, master, comm, ierr)
4779 : 0 : call xmpi_bcast(gstore%has_used_lgq, master, comm, ierr)
4780 : 0 : call xmpi_bcast(gstore%kzone, master, comm, ierr)
4781 : 0 : call xmpi_bcast(gstore%qzone, master, comm, ierr)
4782 : 0 : call xmpi_bcast(gstore%kfilter, master, comm, ierr)
4783 : 0 : call xmpi_bcast(gstore%gmode, master, comm, ierr)
4784 : 0 : call xmpi_bcast(gstore%gtype, master, comm, ierr)
4785 : 0 : call xmpi_bcast(gstore%ngqpt, master, comm, ierr)
4786 : 0 : call xmpi_bcast(gstore%wfk0_path, master, comm, ierr)
4787 : 0 : call xmpi_bcast(brange_k_spin, master, comm, ierr)
4788 : 0 : call xmpi_bcast(brange_kq_spin, master, comm, ierr)
4789 : 0 : call xmpi_bcast(gstore%erange_spin, master, comm, ierr)
4790 : 0 : call xmpi_bcast(gstore%qibz, master, comm, ierr)
4791 : 0 : call xmpi_bcast(gstore%wtq, master, comm, ierr)
4792 : 0 : call xmpi_bcast(gstore%qbz, master, comm, ierr)
4793 : 0 : call xmpi_bcast(gstore%kbz, master, comm, ierr)
4794 : 0 : call xmpi_bcast(qbz2ibz, master, comm, ierr)
4795 : 0 : call xmpi_bcast(gstore%kbz2ibz, master, comm, ierr)
4796 : 0 : call xmpi_bcast(qglob2bz, master, comm, ierr)
4797 : 0 : call xmpi_bcast(gstore%kglob2bz, master, comm, ierr)
4798 : 0 : call xmpi_bcast(gstore%glob_nq_spin, master, comm, ierr)
4799 : 0 : call xmpi_bcast(gstore%glob_nk_spin, master, comm, ierr)
4800 : :
4801 [ # # ]: 0 : if (gstore%kfilter == "fs_tetra") then
4802 [ # # ]: 0 : if (my_rank /= master) then
4803 [ # # # # : 0 : ABI_MALLOC(gstore%delta_ef_kibz_spin, (max_nb, gstore%nkibz, gstore%nsppol))
# # # # #
# # # # #
# # # # #
# # # ]
4804 : : end if
4805 : 0 : call xmpi_bcast(gstore%delta_ef_kibz_spin, master, comm, ierr)
4806 : : end if
4807 : : end if ! nproc > 1.
4808 : :
4809 : : ! Consistency check
4810 : 16 : call wfk0_hdr%vs_dtset(dtset); call wfk0_hdr%free()
4811 : :
4812 : : ! When reading an existing GSTORE file, gstore_brange selects a smaller window of
4813 : : ! intermediate states at k+q. The external-state window at k is always the one on disk.
4814 : : ! Keep the file range to compute the offset in the NetCDF nb_kq dimension below.
4815 [ + + + + ]: 64 : file_brange_kq_spin = brange_kq_spin
4816 [ + + ]: 32 : do spin=1,gstore%nsppol
4817 [ + + + + : 62 : if (any(dtset%gstore_brange(:, spin) /= 0)) then
+ + ]
4818 [ + + + - : 3 : ABI_CHECK(all(dtset%gstore_brange(:, spin) /= 0), "Both entries of gstore_brange must be specified")
- + ]
4819 [ - + ]: 1 : ABI_CHECK_IEQ(dtset%gstore_brange(2, spin), dtset%mband, "gstore_brange(2, spin) must be equal to nband")
4820 [ + - ]: 1 : if (dtset%eph_stern /= 0) then
4821 [ - + ]: 1 : ABI_CHECK_IEQ(dtset%gstore_brange(1, spin), 1, "gstore_brange(1, spin) must be 1 when eph_stern is enabled")
4822 : : end if
4823 : : msg = sjoin("Requested gstore_brange:", ltoa(dtset%gstore_brange(:, spin)), "is not contained in the k+q band range stored in GSTORE.nc:", &
4824 [ + - ]: 1 : ltoa(file_brange_kq_spin(:, spin)))
4825 [ + - - + ]: 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)
4826 [ + + ]: 3 : brange_kq_spin(:, spin) = dtset%gstore_brange(:, spin)
4827 : : call wrtout(units, sjoin(" Restricting k+q states for spin", itoa(spin), "to gstore_brange:", &
4828 : 1 : ltoa(brange_kq_spin(:, spin))))
4829 : : end if
4830 : : end do
4831 : :
4832 : : ! If has_both_g is true, we allocate and read both the KS and the GWPT matrix elements.
4833 : 16 : read_ks = gstore%gtype == GSTORE_GTYPE_GWPT
4834 : 16 : has_both_g = gstore%gtype == GSTORE_GTYPE_GWPT
4835 : :
4836 : : ! Distribute spins, create indirect mapping to spin index and init gstore%brange_k_spin
4837 : 16 : call gstore%distribute_spins__(ebands%mband, brange_kq_spin, brange_k_spin, nproc_spin, comm_spin, comm)
4838 : :
4839 : : ! Compute krank
4840 [ + - - - : 16 : call gstore%krank_ibz%from_kptrlatt(gstore%nkibz, gstore%kibz, ebands%kptrlatt, compute_invrank=.False.)
- - - - -
+ ]
4841 : :
4842 : 16 : call gstore%set_mpi_grid__(dtfil, nproc_spin, comm_spin)
4843 : :
4844 : : ! At this point, we have the Cartesian grid (one per spin if any) and we can finally allocate and distribute other arrays.
4845 : 16 : call gstore%malloc__(with_cplex, has_both_g, max_nq, qglob2bz, max_nk, gstore%kglob2bz, qbz2ibz, gstore%kbz2ibz)
4846 : :
4847 : 16 : call xmpi_comm_free(comm_spin)
4848 : :
4849 : : ! Now we read the big arrays with MPI-IO and hdf5 groups.
4850 : : ! Note the loop over spin as each gqk has its own dimensions.
4851 : : ! Recall the shape of the arrays:
4852 : : !
4853 : : ! In memory, we have allocated:
4854 : : !
4855 : : ! my_g(my_npert, nb_kq, my_nq, nb_k, my_nk) if with_cplex == 2 (complex array)
4856 : : !
4857 : : ! or
4858 : : !
4859 : : ! my_g2(my_npert, nb_kq, my_nq, nb_k, my_nk) if with_cplex == 1
4860 : : !
4861 : : ! On disk, we have:
4862 : : !
4863 : : ! nctkarr_t("gvals", "dp", "two, nb_kq_disk, nb_k_disk, natom3, glob_nk, glob_nq")
4864 : : !
4865 : 16 : call cwtime(cpu, wall, gflops, "start")
4866 : :
4867 : : ! ===================================================
4868 : : ! Load phonon frequencies and eigenvectors in the IBZ
4869 : : ! ===================================================
4870 : :
4871 : : ! nctkarr_t("phfreqs_ibz", "dp", "natom3, gstore_nqibz")
4872 : : ! nctkarr_t("pheigvec_cart_ibz", "dp", "two, three, natom, natom3, gstore_nqibz")
4873 [ - + + - : 64 : ABI_MALLOC(phfreqs_ibz, (natom3, gstore%nqibz))
- + + - +
- + - - +
- + - + ]
4874 [ - + + - : 80 : ABI_MALLOC(pheigvec_cart_ibz, (2, 3, cryst%natom, cryst%natom * 3, gstore%nqibz))
+ - - + +
- - + + -
+ - + - -
+ - + -
+ ]
4875 [ - + + - : 64 : ABI_MALLOC(pheigvec_cart_qbz, (2, 3, cryst%natom, cryst%natom * 3))
- + + - +
- + - - +
- + ]
4876 [ - + + - : 48 : ABI_MALLOC(displ_cart_qbz, (2, 3, cryst%natom, cryst%natom * 3))
- + + - -
+ - + ]
4877 [ - + + - : 64 : ABI_MALLOC(displ_red_qbz, (2, 3, cryst%natom, natom3))
- + + - +
- + - - +
- + ]
4878 : :
4879 : : !NCF_CHECK(nctk_open_read(ncid, gstore%path, gstore%comm))
4880 : : ! SC: Open with xmpi_comm_self (independent IO) instead of gqk%comm, otherwise there will be a deadlock on lemaitre4
4881 [ - + ]: 16 : NCF_CHECK(nctk_open_read(ncid, gstore%path, xmpi_comm_self))
4882 : 16 : has_iv1p_comm = gstore_nc_has_iv1p_comm(gstore, ncid)
4883 : : ! SC: nctk_set_collective can cause a deadlock on lemaitre4
4884 : : !if (nproc > 1) then
4885 : : ! NCF_CHECK(nctk_set_collective(ncid, vid("phfreqs_ibz")))
4886 : : ! NCF_CHECK(nctk_set_collective(ncid, vid("pheigvec_cart_ibz")))
4887 : : !end if
4888 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("phfreqs_ibz"), phfreqs_ibz))
4889 [ - + ]: 16 : NCF_CHECK(nf90_get_var(ncid, vid("pheigvec_cart_ibz"), pheigvec_cart_ibz))
4890 [ - + ]: 16 : NCF_CHECK(nf90_close(ncid))
4891 : :
4892 : : ! =========================
4893 : : ! Load e-ph matrix elements
4894 : : ! =========================
4895 : 16 : call pstat_proc%print(_PSTAT_ARGS_)
4896 : :
4897 : 16 : from_atm_to_nu = .False.
4898 : : ! Compare with_gmode with the one on disk. The only conversion I can think of is: atom --> phonon.
4899 [ - + ]: 16 : if (gstore%gmode /= with_gmode) then
4900 [ + - + - ]: 16 : if (gstore%gmode == GSTORE_GMODE_ATOM .and. with_gmode == GSTORE_GMODE_PHONON) then
4901 : 16 : from_atm_to_nu = .True.; gstore%gmode = GSTORE_GMODE_PHONON ! Change gstore%gmode here
4902 : : else
4903 : 0 : ABI_ERROR(sjoin("Conversion from gstore%gmode: ", gstore%gmode, "to:", with_gmode, " is not yet supported"))
4904 : : end if
4905 : : end if
4906 [ + - ]: 16 : gstore%gmode = with_gmode
4907 : :
4908 [ + + ]: 16 : if (with_g2dw) then
4909 [ - + ]: 7 : ABI_CHECK(with_gmode == GSTORE_GMODE_PHONON, "g2dw in the atom representation is not coded")
4910 [ - + + - : 28 : ABI_MALLOC(tpp_red, (natom3, natom3))
- + + - +
- + - - +
- + ]
4911 : : end if
4912 : :
4913 [ + + ]: 32 : do spin=1,gstore%nsppol
4914 : 16 : my_is = gstore%spin2my_is(spin)
4915 : :
4916 [ + - ]: 32 : if (my_is /= 0) then
4917 : 16 : gqk => gstore%gqk(my_is)
4918 : :
4919 [ - + + - : 64 : ABI_MALLOC(gqk%my_wnuq, (gqk%my_npert, gqk%my_nq))
- + + - +
- + - - +
- + - + ]
4920 [ - + + - : 80 : ABI_MALLOC(gqk%my_displ_cart, (2, 3, cryst%natom, gqk%my_npert, gqk%my_nq))
- + + - -
+ + - + -
+ - - + -
+ - + ]
4921 : :
4922 : : !NCF_CHECK(nctk_open_read(ncid, gstore%path, gqk%comm%value))
4923 : : ! SC: Open with xmpi_comm_self (independent IO) instead of gqk%comm, otherwise there will be a deadlock on lemaitre4
4924 [ - + ]: 16 : NCF_CHECK(nctk_open_read(ncid, gstore%path, xmpi_comm_self))
4925 [ - + ]: 16 : NCF_CHECK(nf90_inq_ncid(ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
4926 : :
4927 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_k", nb_k_file))
4928 [ - + ]: 16 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_kq", nb_kq_file))
4929 : :
4930 : : ! Note that these dimensions should be compatible with what is stored on disk.
4931 : 16 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
4932 [ - + ]: 16 : ABI_CHECK_IEQ(nb_k, nb_k_file, "nb_k !/ nb_k_file")
4933 [ - + ]: 16 : ABI_CHECK_ILEQ(nb_kq, nb_kq_file, "nb_kq > nb_kq_file")
4934 : 16 : ib_kq_start = gqk%bstart_kq - file_brange_kq_spin(1, spin) + 1
4935 [ + - - + ]: 16 : ABI_CHECK_IRANGE(ib_kq_start, 1, nb_kq_file, "Invalid k+q band offset in GSTORE.nc")
4936 [ - + ]: 16 : ABI_CHECK_ILEQ(ib_kq_start + nb_kq - 1, nb_kq_file, "Requested k+q band window exceeds GSTORE.nc")
4937 : :
4938 : : ! gstore_cplex defines the data on disk while cplex defines what we want to store in memory
4939 [ - + + - : 112 : ABI_MALLOC_OR_DIE(gwork_q, (gstore_cplex, nb_kq, nb_k, gqk%natom3, gqk%glob_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - -
+ + - -
+ ]
4940 [ - + + - : 80 : ABI_MALLOC(slice_bb, (gstore_cplex, nb_kq, nb_k))
- + + - -
+ + - + -
+ - - + -
+ ]
4941 [ + + ]: 16 : if (read_ks) then
4942 [ - + + - : 42 : ABI_MALLOC_OR_DIE(ks_gwork_q, (gstore_cplex, nb_kq, nb_k, gqk%natom3, gqk%glob_nk), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - -
+ + - -
+ ]
4943 [ - + + - : 30 : ABI_MALLOC(ks_slice_bb, (gstore_cplex, nb_kq, nb_k))
- + + - -
+ + - + -
+ - - + -
+ - + ]
4944 : : end if
4945 : :
4946 [ + + ]: 16 : if (with_g2dw) then
4947 : : ! Read my_gq0nm_atm matrix elements for DW in the RIA. Find the index of q = 0.
4948 : 7 : iq_glob = -1
4949 [ + - ]: 7 : do ii=1, gstore%glob_nq_spin(spin)
4950 : 7 : iq_bz = qglob2bz(ii, spin)
4951 [ + + + - ]: 28 : if (sum(gstore%qbz(:, iq_bz)**2) < tol4) then
4952 : 7 : iq_glob = ii; exit
4953 : : end if
4954 : : end do
4955 [ - + ]: 7 : ABI_CHECK_INEQ(iq_glob, -1, "Cannot finq q=0 in g(k,q)!")
4956 : 7 : call wrtout(std_out, sjoin(" Reading g_atm(k,q=0) for Debye-Waller with iq_glob:", itoa(iq_glob)))
4957 : :
4958 : : ! Read q-slice of the e-ph matrix elements (individual IO).
4959 : : ! Note gvals_name so that we can read either g^KS or g^Sigma.
4960 [ + + ]: 49 : ncerr = nf90_get_var(spin_ncid, spin_vid(gvals_name), gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
4961 [ - + ]: 7 : NCF_CHECK(ncerr)
4962 : :
4963 [ + + ]: 7 : if (read_ks) then
4964 [ + + ]: 42 : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals_ks"), ks_gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
4965 [ - + ]: 6 : NCF_CHECK(ncerr)
4966 : : ! Here we set g_GWPT g to g_KS if g_KS is smaller than a certain threshold as GWPT breaks symmetries.
4967 [ + + + + : 13931 : where (abs(ks_gwork_q) < G_SMALL)
+ + + + +
+ + + ]
4968 : : gwork_q = ks_gwork_q
4969 : : end where
4970 : : end if
4971 : :
4972 : : ! Allocate gdw2
4973 [ - + + - : 49 : ABI_MALLOC(gqk%my_gdw2, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk))
- + + - -
+ + - - +
+ - - + +
- + - + -
- + - + -
+ ]
4974 : 7 : gqk%my_gdw2_ks => gqk%my_gdw2
4975 : : ! Allocate my_gq0nm_atm and transfer data. Note TRANSPOSITION in (m, n) indices.
4976 [ - + + - : 42 : ABI_MALLOC(my_gq0nm_atm, (nb_k, nb_kq, natom3, gqk%my_nk))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
4977 : :
4978 [ + + ]: 7 : if (gqk%has_both_g) then
4979 [ - + + - : 36 : ABI_MALLOC(gqk%my_gdw2_ks, (gqk%my_npert, nb_kq, gqk%my_nq, nb_k, gqk%my_nk))
- + + - -
+ + - - +
+ - - + +
- - + -
+ ]
4980 [ - + + - : 30 : ABI_MALLOC(ks_my_gq0nm_atm, (nb_k, nb_kq, natom3, gqk%my_nk))
- + + - -
+ + - - +
+ - - + -
+ - + ]
4981 : : end if
4982 : :
4983 [ + + ]: 19 : do my_ik=1,gqk%my_nk
4984 : 12 : ik_glob = my_ik + gqk%my_kstart - 1
4985 [ + + ]: 167 : do ib_m=1,nb_kq
4986 [ + + ]: 988 : do ib_n=1,nb_k
4987 [ + + ]: 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)
4988 [ + + ]: 976 : if (gqk%has_both_g) then
4989 [ + + ]: 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)
4990 : : end if
4991 : : end do
4992 : : end do
4993 : : end do
4994 : : end if ! with_g2dw
4995 : :
4996 [ - + ]: 16 : if (has_iv1p_comm) then
4997 : : ! Read matrix elements of commutator [iv, p].
4998 [ # # # # : 0 : ABI_MALLOC(gqk%my_iv1p_comm, (nb_k, nb_k, 3, gqk%my_npert, gqk%my_nk))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
4999 [ # # # # : 0 : ABI_MALLOC(iv1p_comm, (2, nb_k, nb_k, 3, natom3))
# # # # #
# # # # #
# # # # #
# # # #
# ]
5000 : : ! nctkarr_t("iv1p_comm", "dp", "two, nb_k, nb_k, three, natom3, glob_nk")
5001 : :
5002 [ # # ]: 0 : do my_ik=1,gqk%my_nk
5003 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
5004 [ # # ]: 0 : ncerr = nf90_get_var(spin_ncid, spin_vid("iv1p_comm"), iv1p_comm, start=[1,1,1,1,1, ik_glob])
5005 [ # # ]: 0 : NCF_CHECK(ncerr)
5006 : :
5007 : : ! Save my perturbations for this k-point.
5008 [ # # ]: 0 : do my_ip=1,gqk%my_npert
5009 : 0 : ipert = gqk%my_pertcases(my_ip)
5010 [ # # # # : 0 : gqk%my_iv1p_comm(:,:,:,my_ip, my_ik) = r2c(iv1p_comm(:,:,:,:,ipert))
# # # # ]
5011 : : end do
5012 : : end do
5013 [ # # ]: 0 : ABI_FREE(iv1p_comm)
5014 : : end if
5015 : :
5016 [ + - ]: 16 : if (from_atm_to_nu) then
5017 [ - + + - : 80 : ABI_MALLOC(gmn_nu, (2, nb_kq, nb_k, 3*natom))
- + + - +
- - + + -
+ - + - -
+ - + -
+ ]
5018 : : end if
5019 : :
5020 : : ! Read my e-ph matrix elements.
5021 [ + + ]: 1365 : do my_iq=1,gqk%my_nq
5022 : 1349 : iq_glob = my_iq + gqk%my_qstart - 1
5023 : :
5024 : : !call wrtout(std_out, " Computing and storing phonons in the full BZ by rotating the data in the IBZ...")
5025 : 1349 : iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
5026 : 1349 : trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5, my_iq)
5027 : : !isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
5028 : 1349 : isirr_q = (isym_q == 1 .and. trev_q == 0)
5029 : 1349 : tsign_q = 1; if (trev_q == 1) tsign_q = -1
5030 [ + + ]: 5396 : qq_ibz = gstore%qibz(:, iq_ibz)
5031 : :
5032 : : ! Here we get the ph displacement for this q-point in the BZ from the image in the IBZ.
5033 : : ! This is important for complex g as we have to enforce the gauge in the ph eigenvectors, including e(-q) = e(q)^*.
5034 : : call pheigvec_rotate(cryst, qq_ibz, isym_q, trev_q, pheigvec_cart_ibz(:,:,:,:,iq_ibz), pheigvec_cart_qbz, displ_cart_qbz, &
5035 : 1349 : displ_red_qbz=displ_red_qbz)
5036 : :
5037 : : ! Save my frequencies and my phonon displacements.
5038 [ + - + + : 17537 : gqk%my_wnuq(:, my_iq) = phfreqs_ibz(gqk%my_pertcases(:), iq_ibz)
+ + ]
5039 [ + - + + : 179417 : gqk%my_displ_cart(:,:,:,:,my_iq) = displ_cart_qbz(:,:,:,gqk%my_pertcases(:))
+ + + + +
+ + + ]
5040 : :
5041 [ + + ]: 1349 : if (with_g2dw) then
5042 [ + + ]: 1176 : do my_ip=1,gqk%my_npert
5043 : : ! Compute T_pp'(q,nu) matrix in reduced coordinates for DW.
5044 : 1008 : call phdispl_cart2red_nmodes(natom, 1, cryst%gprimd, gqk%my_displ_cart(:,:,:,my_ip,my_iq), displ_nu_red)
5045 : 1008 : call sigtk_dw_tpp_red(natom, displ_nu_red, tpp_red)
5046 : 1008 : wqnu = gqk%my_wnuq(my_ip, my_iq)
5047 : :
5048 [ + + ]: 2424 : do my_ik=1,gqk%my_nk
5049 [ + + + + ]: 2256 : if (.not. gqk%has_both_g .or. dtset%gwpt_g2mode == 1) then
5050 : : call calc_and_store_gdw2(gqk, my_ik, my_iq, my_ip, wqnu, tpp_red, &
5051 : 864 : my_gq0nm_atm(:,:,:,my_ik), my_gq0nm_atm(:,:,:,my_ik))
5052 : : else
5053 : : !print *, "Computing g2dw with both g^KS g_GWPT"
5054 : : call calc_and_store_gdw2(gqk, my_ik, my_iq, my_ip, wqnu, tpp_red, &
5055 : 384 : ks_my_gq0nm_atm(:,:,:,my_ik), my_gq0nm_atm(:,:,:,my_ik))
5056 : : end if
5057 : : end do ! my_ik
5058 : :
5059 : : end do ! my_ip
5060 : : end if
5061 : :
5062 : : ! Read q-slice of g(k,q) in the atom representation. (individual IO).
5063 [ + + ]: 9443 : ncerr = nf90_get_var(spin_ncid, spin_vid(gvals_name), gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
5064 [ - + ]: 1349 : NCF_CHECK(ncerr)
5065 : :
5066 [ + + ]: 1349 : if (read_ks) then
5067 [ + + ]: 728 : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals_ks"), ks_gwork_q, start=[1, ib_kq_start, 1, 1, 1, iq_glob])
5068 [ - + ]: 104 : NCF_CHECK(ncerr)
5069 : : ! Here we set g_GWPT g to g_KS if g_KS is smaller than a certain threshold as GWPT breaks symmetries.
5070 [ + + + + : 153560 : where (abs(ks_gwork_q) < G_SMALL)
+ + + + +
+ + + ]
5071 : : gwork_q = ks_gwork_q
5072 : : end where
5073 : : end if
5074 : :
5075 [ + + ]: 111960 : do my_ik=1,gqk%my_nk
5076 : 110595 : ik_glob = my_ik + gqk%my_kstart - 1
5077 [ + - ]: 110595 : if (from_atm_to_nu) then
5078 : : ! Here we convert from g(k,q)_atom to g(k,q)_phonon and replace data in gwork_q at ik_glob
5079 : : call ephtk_gkknu_from_atm(nb_kq, nb_k, 1, natom, gwork_q(:,:,:,:, ik_glob), &
5080 : 110595 : phfreqs_ibz(:, iq_ibz), displ_red_qbz, gmn_nu)
5081 [ + + + + : 12601221 : gwork_q(:,:,:,:, ik_glob) = gmn_nu
+ + + + ]
5082 : :
5083 [ + + ]: 110595 : if (gqk%has_both_g) then
5084 : : call ephtk_gkknu_from_atm(nb_kq, nb_k, 1, natom, ks_gwork_q(:,:,:,:, ik_glob), &
5085 : 144 : phfreqs_ibz(:, iq_ibz), displ_red_qbz, gmn_nu)
5086 [ + + + + : 153456 : ks_gwork_q(:,:,:,:, ik_glob) = gmn_nu
+ + + + ]
5087 : : end if
5088 : : end if
5089 : :
5090 [ + + ]: 775514 : do my_ip=1,gqk%my_npert
5091 : 663570 : ipert = gqk%my_pertcases(my_ip)
5092 [ + - + - : 13154196 : slice_bb = gwork_q(:,:,:, ipert, ik_glob)
+ - - + -
- + + + +
+ + ]
5093 [ + + ]: 663570 : if (read_ks) then
5094 [ + - + - : 154176 : ks_slice_bb = ks_gwork_q(:,:,:, ipert, ik_glob)
+ - - + -
- + + + +
+ + ]
5095 : : end if
5096 : :
5097 : : ! Put data in the right place and handle conversion g --> |g|^2.
5098 [ + + ]: 774165 : if (with_cplex == gstore_cplex) then
5099 [ - + ]: 662706 : if (with_cplex == 1) then
5100 [ # # # # ]: 0 : gqk%my_g2(my_ip,:,my_iq,:,my_ik) = slice_bb(1,:,:)
5101 [ # # # # ]: 0 : if (read_ks .and. gqk%has_both_g) then
5102 [ # # # # ]: 0 : gqk%my_g2_ks(my_ip,:,my_iq,:,my_ik) = ks_slice_bb(1,:,:)
5103 : : end if
5104 : : end if
5105 [ + - ]: 662706 : if (with_cplex == 2) then
5106 [ + + + + ]: 5439486 : gqk%my_g(my_ip,:,my_iq,:,my_ik) = slice_bb(1,:,:) + j_dpc * slice_bb(2,:,:)
5107 [ + + + - ]: 662706 : if (read_ks .and. gqk%has_both_g) then
5108 [ + + + + ]: 17280 : gqk%my_g_ks(my_ip,:,my_iq,:,my_ik) = ks_slice_bb(1,:,:) + j_dpc * ks_slice_bb(2,:,:)
5109 : : end if
5110 : : end if
5111 : :
5112 : : else
5113 [ + - + - ]: 864 : if (with_cplex == 1 .and. gstore_cplex == 2) then
5114 [ + + + + ]: 69984 : gqk%my_g2(my_ip, :, my_iq, :, my_ik) = slice_bb(1,:,:) ** 2 + slice_bb(2,:,:) ** 2
5115 [ + + + - ]: 864 : if (read_ks .and. gqk%has_both_g) then
5116 [ + + + + ]: 37344 : gqk%my_g2_ks(my_ip, :, my_iq, :, my_ik) = ks_slice_bb(1,:,:) ** 2 + ks_slice_bb(2,:,:) ** 2
5117 : : end if
5118 [ # # ]: 0 : else if (with_cplex == 0) then
5119 : : continue
5120 : : else
5121 : 0 : ABI_ERROR("Conversion from g2 on file to g_complex in memory is not possible!")
5122 : : end if
5123 : : end if
5124 : : end do ! my_ip
5125 : : end do ! my_ik
5126 : :
5127 : : end do ! my_iq
5128 : :
5129 [ - + ]: 16 : ABI_FREE(gwork_q)
5130 [ - + ]: 16 : ABI_FREE(slice_bb)
5131 [ + + ]: 16 : if (read_ks) then
5132 [ - + ]: 6 : ABI_FREE(ks_gwork_q)
5133 [ - + ]: 6 : ABI_FREE(ks_slice_bb)
5134 : : end if
5135 : :
5136 [ + - ]: 16 : ABI_SFREE(gmn_nu)
5137 [ + + ]: 16 : ABI_SFREE(my_gq0nm_atm)
5138 [ + + ]: 16 : ABI_SFREE(ks_my_gq0nm_atm)
5139 : :
5140 : : ! =========================================
5141 : : ! Read matrix elements of velocity operator
5142 : : ! =========================================
5143 : : ! SC: nctk_set_collective can cause a deadlock on lemaitre4
5144 [ + - ]: 16 : if (gstore%with_vk == 1) then
5145 : : !if (gqk%comm%nproc > 1) then
5146 : : ! NCF_CHECK(nctk_set_collective(spin_ncid, spin_vid("vk_cart_ibz")))
5147 : : !end if
5148 [ - + ]: 16 : NCF_CHECK(nf90_get_var(spin_ncid, spin_vid("vk_cart_ibz"), gqk%vnk_cart_ibz))
5149 : :
5150 [ # # ]: 0 : else if (gstore%with_vk == 2) then
5151 : : !if (gqk%comm%nproc > 1) then
5152 : : ! NCF_CHECK(nctk_set_collective(spin_ncid, spin_vid("vnk_mat_cart_ibz")))
5153 : : !end if
5154 [ # # ]: 0 : NCF_CHECK(nf90_get_var(spin_ncid, spin_vid("vnk_mat_cart_ibz"), gqk%vnk_mat_cart_ibz))
5155 : :
5156 : : ! Transfer diagonal terms to vnk_cart_ibz.
5157 [ # # ]: 0 : do ib=1,gqk%nb_k
5158 [ # # # # ]: 0 : gqk%vnk_cart_ibz(:, ib, :) = gqk%vnk_mat_cart_ibz(1, :, ib, ib, :)
5159 : : end do
5160 : : end if
5161 : :
5162 [ - + ]: 16 : NCF_CHECK(nf90_close(ncid))
5163 : : end if
5164 : : end do ! spin
5165 : :
5166 [ - + ]: 16 : ABI_FREE(qglob2bz)
5167 [ - + ]: 16 : ABI_FREE(qbz2ibz)
5168 [ - + ]: 16 : ABI_FREE(phfreqs_ibz)
5169 [ - + ]: 16 : ABI_FREE(pheigvec_cart_ibz)
5170 [ - + ]: 16 : ABI_FREE(displ_cart_qbz)
5171 [ - + ]: 16 : ABI_FREE(displ_red_qbz)
5172 [ - + ]: 16 : ABI_FREE(pheigvec_cart_qbz)
5173 [ + + ]: 16 : ABI_SFREE(tpp_red)
5174 : :
5175 : 16 : call pstat_proc%print(_PSTAT_ARGS_)
5176 : 16 : call xmpi_barrier(gstore%comm)
5177 [ - + - + : 48 : call cwtime_report(" gstore_from_ncpath", cpu, wall, gflops)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
5178 : :
5179 : : !stop
5180 : :
5181 : : contains
5182 : 400 : integer function vid(var_name)
5183 : : character(len=*),intent(in) :: var_name
5184 : 400 : vid = nctk_idname(ncid, var_name)
5185 : : end function vid
5186 : :
5187 : 1482 : integer function spin_vid(var_name)
5188 : : character(len=*),intent(in) :: var_name
5189 : 1482 : spin_vid = nctk_idname(spin_ncid, var_name)
5190 : : end function spin_vid
5191 : :
5192 : : end subroutine gstore_from_ncpath
5193 : : !!***
5194 : :
5195 : 1248 : subroutine calc_and_store_gdw2(gqk, my_ik, my_iq, my_ip, wqnu, tpp_red, gq0l_atm, gq0r_atm)
5196 : :
5197 : : type(gqk_t), intent(inout) :: gqk
5198 : : integer,intent(in) :: my_ik, my_iq, my_ip
5199 : : real(dp),intent(in) :: wqnu
5200 : : complex(dp),intent(in) :: tpp_red(gqk%natom3, gqk%natom3)
5201 : : complex(dp),intent(in) :: gq0l_atm(gqk%nb_k, gqk%nb_kq, gqk%natom3)
5202 : : complex(dp),intent(in) :: gq0r_atm(gqk%nb_k, gqk%nb_kq, gqk%natom3)
5203 : :
5204 : : !Local variables-------------------------------
5205 : : !scalars
5206 : : integer :: im_kq, in_k, ip2, ip1
5207 : : real(dp) :: gdw2
5208 : : complex(dp) :: cfact
5209 : : ! *************************************************************************
5210 : :
5211 : : ! Loop over bands in |m,k+q>
5212 [ + + ]: 18432 : do im_kq=1,gqk%nb_kq
5213 : : ! Loop over the n index in |n,k>.
5214 [ + + ]: 98496 : do in_k=1,gqk%nb_k
5215 : : ! Compute DW term following XG paper. Check prefactor.
5216 : : gdw2 = zero
5217 [ + + ]: 560448 : do ip2=1,gqk%natom3
5218 [ + + ]: 3442752 : do ip1=1,gqk%natom3
5219 : : cfact = ( &
5220 : : + real(gq0l_atm(in_k, im_kq, ip1)) * real(gq0r_atm(in_k, im_kq, ip2)) &
5221 : : + aimag(gq0l_atm(in_k, im_kq, ip1)) * aimag(gq0r_atm(in_k, im_kq, ip2)) &
5222 : : + real(gq0l_atm(in_k, im_kq, ip2)) * real(gq0r_atm(in_k, im_kq, ip1)) &
5223 : : + aimag(gq0l_atm(in_k, im_kq, ip2)) * aimag(gq0r_atm(in_k, im_kq, ip1)) &
5224 : 2882304 : )
5225 : 3362688 : gdw2 = gdw2 + real(tpp_red(ip1,ip2) * cfact)
5226 : : end do
5227 : : end do
5228 : :
5229 [ + + ]: 80064 : if (wqnu < EPHTK_WTOL) then
5230 : : gdw2 = zero
5231 : : else
5232 : 77580 : gdw2 = gdw2 / (four * two * wqnu)
5233 : : end if
5234 : :
5235 : : !print *, "gdw2", gdw2
5236 : 97248 : gqk%my_gdw2(my_ip, im_kq, my_iq, in_k, my_ik) = gdw2
5237 : : end do ! in_k
5238 : : end do ! im_kq
5239 : :
5240 : 1248 : end subroutine calc_and_store_gdw2
5241 : :
5242 : : !----------------------------------------------------------------------
5243 : :
5244 : : !!****f* m_gstore/gstore_check_restart
5245 : : !! NAME
5246 : : !! gstore_check_restart
5247 : : !!
5248 : : !! FUNCTION
5249 : : !! Check whether restart from a previous GSTORE.nc is possible.
5250 : : !!
5251 : : !! INPUTS
5252 : : !!
5253 : : !! SOURCE
5254 : :
5255 : 3 : subroutine gstore_check_restart(filepath, dtset, nqbz, done_qbz_spin, restart, comm)
5256 : :
5257 : : !Arguments ------------------------------------
5258 : : character(len=*),intent(in) :: filepath
5259 : : type(dataset_type),intent(in) :: dtset
5260 : : integer,intent(out) :: nqbz, restart
5261 : : integer,allocatable,intent(out) :: done_qbz_spin(:,:)
5262 : : integer,intent(in) :: comm
5263 : :
5264 : : !Local variables-------------------------------
5265 : : !scalars
5266 : : integer,parameter :: master = 0
5267 : : integer :: my_rank, root_ncid, ierr, gstore_completed, gstore_fform, units(2) ! fform
5268 : : character(len=500) :: msg
5269 : 3 : type(hdr_type) :: gstore_hdr
5270 : : ! *************************************************************************
5271 : :
5272 [ + + ]: 9 : my_rank = xmpi_comm_rank(comm); units = [std_out, ab_out]
5273 : :
5274 : : !print *, "eph_restart:", dtset%eph_restart
5275 : :
5276 : 3 : restart = 0; nqbz = 0
5277 [ + - + - ]: 3 : if (my_rank == master .and. dtset%eph_restart == 1) then
5278 [ - + ]: 3 : if (file_exists(filepath)) then
5279 [ # # ]: 0 : call wrtout(units, sjoin("- Found pre-existent GSTORE file:", trim(filepath)))
5280 : 0 : call wrtout(units, " Testing if all e-ph terms have been computed...")
5281 : : ! Use gstore_completed to understand if the previous GSTORE run completed else we need to restart.
5282 [ # # ]: 0 : NCF_CHECK(nctk_open_read(root_ncid, filepath, xmpi_comm_self))
5283 [ # # ]: 0 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_completed"), gstore_completed))
5284 : 0 : call gstore_hdr%ncread(root_ncid, gstore_fform)
5285 [ # # ]: 0 : ABI_CHECK_INEQ(gstore_fform, 0, "Wrong gstore_fform")
5286 : 0 : call gstore_hdr%vs_dtset(dtset); call gstore_hdr%free()
5287 : :
5288 [ # # ]: 0 : NCF_CHECK(nctk_get_dim(root_ncid, "gstore_nqbz", nqbz))
5289 [ # # # # : 0 : ABI_MALLOC(done_qbz_spin, (nqbz, dtset%nsppol))
# # # # #
# # # # #
# # # # ]
5290 [ # # ]: 0 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_done_qbz_spin"), done_qbz_spin))
5291 [ # # ]: 0 : NCF_CHECK(nf90_close(root_ncid))
5292 : : !print *, "done_qbz_spin:", done_qbz_spin
5293 : :
5294 : : ! FIXME: done_qbz_spin is dimensioned with the q-points in the BZ but we
5295 : : ! should set to 1 the q-points in the BZ else we never restart
5296 : : ! Perhaps can can set to -1 if q = TS q_ibz if q_ibz is done.
5297 [ # # ]: 0 : if (gstore_completed /= 0) then
5298 : : ! Previous computation completed, keep a backup of the file and start from scratch.
5299 [ # # # # ]: 0 : restart = 0; done_qbz_spin = 0
5300 : : msg = sjoin("- WARNING: Found GSTORE.nc file with all entries already computed.", ch10, &
5301 [ # # ]: 0 : "- Will overwrite:", trim(filepath), ch10, "Keeping backup copy in:", strcat(filepath, ".bkp"))
5302 : 0 : call wrtout(units, msg)
5303 [ # # ]: 0 : ABI_CHECK(clib_rename(trim(filepath), strcat(filepath, ".bkp")) == 0, "Failed to rename GSTORE file.")
5304 : : else
5305 : 0 : restart = 1
5306 : 0 : call wrtout(units, "- Restarting from a previous GSTORE.nc file")
5307 : : end if
5308 : : else
5309 [ + - ]: 3 : call wrtout(units, sjoin("- Cannot find pre-existent GSTORE file:", trim(filepath)))
5310 : : end if
5311 : : end if
5312 : :
5313 : 3 : call xmpi_bcast(restart, master, comm, ierr)
5314 : 3 : call xmpi_bcast(nqbz, master, comm, ierr)
5315 : :
5316 [ - + ]: 3 : if (my_rank /= master) then
5317 [ # # # # : 0 : ABI_MALLOC(done_qbz_spin, (nqbz, dtset%nsppol))
# # # # #
# # # # #
# # # # ]
5318 : : end if
5319 [ - + - + : 3 : if (nqbz /= 0) call xmpi_bcast(done_qbz_spin, master, comm, ierr)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- - - - -
- - - - -
- - - - ]
5320 : : !stop
5321 : :
5322 : : contains
5323 : 0 : integer function root_vid(var_name)
5324 : : character(len=*),intent(in) :: var_name
5325 : 0 : root_vid = nctk_idname(root_ncid, var_name)
5326 : : end function root_vid
5327 : :
5328 : : end subroutine gstore_check_restart
5329 : : !!***
5330 : :
5331 : : !----------------------------------------------------------------------
5332 : :
5333 : : !!****f* m_gstore/gstore_prepare_mpiio
5334 : : !! NAME
5335 : : !! gstore_prepare_mpiio
5336 : : !!
5337 : : !! FUNCTION
5338 : : !! Access all the variables of GSTORE.nc (root group and gqk_spin groups) with all the procs that opened the file.
5339 : : !! With a file opened in parallel, netcdf reads the metadata of a variable the first time the variable is accessed
5340 : : !! and, with parallel HDF5, this read is collective. If a subset of the procs accesses a variable first
5341 : : !! (e.g. a single writer per (q, k) block), the other procs do not take part in the read and the run deadlocks
5342 : : !! or aborts with "NetCDF: Can't add HDF5 file metadata".
5343 : : !! This generalizes nctk_prepare_mpiio to all the variables of the file, so that new variables cannot be forgotten.
5344 : : !! Must be called by all the procs that opened the file, in data mode, before any access by a subset of the procs.
5345 : : !!
5346 : : !! INPUTS
5347 : : !! root_ncid=Netcdf identifier of the root group of GSTORE.nc.
5348 : : !! nsppol=Number of gqk_spin groups in the file.
5349 : : !!
5350 : : !! SOURCE
5351 : :
5352 : 8 : subroutine gstore_prepare_mpiio(root_ncid, nsppol)
5353 : :
5354 : : !Arguments ------------------------------------
5355 : : integer,intent(in) :: root_ncid, nsppol
5356 : :
5357 : : !Local variables-------------------------------
5358 : : integer :: spin, spin_ncid
5359 : : ! *************************************************************************
5360 : :
5361 : 8 : call prepare_group(root_ncid)
5362 [ + + ]: 16 : do spin=1,nsppol
5363 [ - + ]: 8 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
5364 : 16 : call prepare_group(spin_ncid)
5365 : : end do
5366 : :
5367 : : contains
5368 : :
5369 : 16 : subroutine prepare_group(ncid)
5370 : : integer,intent(in) :: ncid
5371 : : integer :: nvars, varid
5372 : : character(len=nf90_max_name) :: varname
5373 : :
5374 [ - + ]: 16 : NCF_CHECK(nf90_inquire(ncid, nVariables=nvars))
5375 [ + + ]: 979 : do varid=1,nvars
5376 [ - + ]: 979 : NCF_CHECK(nf90_inquire_variable(ncid, varid, varname))
5377 : : end do
5378 : :
5379 : 16 : end subroutine prepare_group
5380 : :
5381 : : end subroutine gstore_prepare_mpiio
5382 : : !!***
5383 : :
5384 : : !----------------------------------------------------------------------
5385 : :
5386 : : !!****f* m_gstore/gstore_print_for_abitests
5387 : : !! NAME
5388 : : !! gstore_print_for_abitests
5389 : : !!
5390 : : !! FUNCTION
5391 : : !! Print subset of results to ab_out for testing purposes.
5392 : : !! This routine should be called when the output of the GSTORE.nc file is completed
5393 : : !!
5394 : : !! INPUTS
5395 : : !! dtset<type(dataset_type)>=all input variables for this dataset
5396 : : !! [with_ks]: if True, read "gvals" as well as "gvals_ks". This options is used in GWPT
5397 : : !! in which "gvals" are the GWPT matrix elements and ""gvals_ks" are the KS ones.
5398 : : !!
5399 : : !! SOURCE
5400 : :
5401 : 8 : subroutine gstore_print_for_abitests(gstore, dtset, ebands, do_avg, with_ks)
5402 : :
5403 : : !Arguments ------------------------------------
5404 : : class(gstore_t),intent(inout) :: gstore
5405 : : type(dataset_type),intent(in) :: dtset
5406 : : type(ebands_t),intent(in) :: ebands
5407 : : logical,intent(in) :: do_avg
5408 : : logical,optional,intent(in) :: with_ks
5409 : :
5410 : : !Local variables-------------------------------
5411 : : !scalars
5412 : : integer,parameter :: master = 0
5413 : : integer :: root_ncid, spin_ncid, gstore_completed, spin, ik_glob, iq_glob, ipc, ncerr, natom3
5414 : : integer :: glob_nq, glob_nk, im_kq, in_k, m_kq, n_k, nb_k, nb_kq, ii ! ib_k,
5415 : : integer :: bstart_k, bstop_k, bstart_kq, bstop_kq, max_nk, max_nq, idir
5416 : : integer :: ik_bz, ik_ibz, ib_min_k, ib_max_k, iq_bz, ikq_ibz, ib_min_kq, ib_max_kq, nn
5417 : : logical :: with_ks__, changed_k, changed_kq, all_gs, has_iv1p_comm
5418 : : real(dp) :: gg, gg_ks, g_ratio, min_g_ratio, max_g_ratio, mean_g_ratio, stdev_g_ratio !, vnk
5419 : : character(len=abi_slen) :: gstore_gmode
5420 : : character(len=500) :: msg
5421 : : !arrays
5422 : : integer :: mapl_kq(6)
5423 : 8 : integer,allocatable :: done_qbz_spin(:,:), qglob2bz(:,:), degblock_k(:,:), degblock_kq(:,:)
5424 : : real(dp) :: kk(3), qq(3), kq(3), rtmp(2)
5425 : 8 : real(dp),allocatable :: gslice_mn(:,:,:), gslice_ks_mn(:,:,:), g2_mn(:,:), g2ks_mn(:,:), iv1p_comm(:,:,:,:,:)
5426 : : !real(dp),allocatable :: vnk_cart_ibz(:,:) !, vnk_mat_cart_ibz(:,:,:,:)
5427 : : ! *************************************************************************
5428 : :
5429 : : ! Only master prints to ab_out
5430 [ + - ]: 8 : if (xmpi_comm_rank(gstore%comm) /= master) return
5431 : :
5432 [ + + ]: 8 : with_ks__ = .False.; if (present(with_ks)) with_ks__ = with_ks
5433 [ - + ]: 8 : all_gs = .False. ; if (dtset%prtvol >= 10) all_gs = .True.
5434 : :
5435 : 8 : natom3 = dtset%natom * 3
5436 [ + + ]: 16 : max_nq = maxval(gstore%glob_nq_spin) ! Max dim over spin
5437 : : max_nk = maxval(gstore%glob_nk_spin)
5438 : :
5439 [ - + ]: 8 : NCF_CHECK(nctk_open_read(root_ncid, gstore%path, xmpi_comm_self))
5440 : :
5441 [ - + ]: 8 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_completed"), gstore_completed))
5442 : 8 : write(ab_out, *)""
5443 : 8 : write(ab_out, "(a,i0)")" gstore_completed: ", gstore_completed
5444 : :
5445 [ - + + - : 32 : ABI_MALLOC(done_qbz_spin, (gstore%nqbz, dtset%nsppol))
- + + - +
- + - - +
- + ]
5446 [ - + ]: 8 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_done_qbz_spin"), done_qbz_spin))
5447 [ + + + + : 2573 : write(ab_out, "(a,*(i0,1x))")" gstore_done_qbz_spin: ", count(done_qbz_spin == 1)
+ + ]
5448 [ - + ]: 8 : ABI_FREE(done_qbz_spin)
5449 : :
5450 [ - + + - : 997 : ABI_CALLOC(qglob2bz, (max_nq, dtset%nsppol))
- + + - +
- + - - +
- + + + +
+ ]
5451 [ - + ]: 8 : NCF_CHECK(nf90_get_var(root_ncid, root_vid("gstore_qglob2bz"), qglob2bz))
5452 : :
5453 : : gstore_gmode = GSTORE_GMODE_ATOM
5454 : :
5455 [ + + ]: 16 : do spin=1,gstore%nsppol
5456 [ - + ]: 8 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
5457 [ - + ]: 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "glob_nq", glob_nq))
5458 [ - + ]: 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "glob_nk", glob_nk))
5459 [ - + ]: 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_k", nb_k))
5460 [ - + ]: 8 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_kq", nb_kq))
5461 : :
5462 : 8 : bstart_k = gstore%brange_k_spin(1, spin)
5463 : 8 : bstop_k = gstore%brange_k_spin(2, spin)
5464 : 8 : bstart_kq = gstore%brange_kq_spin(1, spin)
5465 : 8 : bstop_kq = gstore%brange_kq_spin(2, spin)
5466 : :
5467 : 8 : write(ab_out, "(a,i0)")" nb_k: ", nb_k
5468 : 8 : write(ab_out, "(a,i0)")" bstart_k: ", bstart_k
5469 : 8 : write(ab_out, "(a,i0)")" nb_kq: ", nb_kq
5470 : 8 : write(ab_out, "(a,i0)")" bstart_kq: ", bstart_kq
5471 : 8 : write(ab_out, "(a,i0)")" glob_nq: ", glob_nq
5472 : 8 : write(ab_out, "(a,i0)")" glob_nk: ", glob_nk
5473 : :
5474 : : ! Handle the output of group velocities. On disk, we have:
5475 : : !
5476 : : ! nctkarr_t("vk_cart_ibz", "dp", "three, nb_k, gstore_nkibz"))
5477 : : ! or
5478 : : ! nctkarr_t("vnk_mat_cart_ibz", "dp", "two, three, nb_k, nb_k, gstore_nkibz")))
5479 : :
5480 : 8 : select case (gstore%with_vk)
5481 : : case (0)
5482 : : continue
5483 : :
5484 : : case (1)
5485 : 0 : continue
5486 : : !write(ab_out,"(2a)") ch10," Group velocities |v_nk| in atomic units:"
5487 : :
5488 : : !ABI_MALLOC(vnk_cart_ibz, (3, nb_k))
5489 : : !do ik_ibz=1,gstore%nkibz
5490 : : ! ! Only a subset of k-points are written to ab_out.
5491 : : ! if (all(ik_ibz /= [1, 2, gstore%nkibz - 1, gstore%nkibz])) cycle
5492 : : ! 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]))
5493 : :
5494 : : ! write(ab_out, "(a)")sjoin(" For k-point:", ktoa(gstore%kibz(:,ik_ibz)), ", spin", itoa(spin))
5495 : : ! do ib_k=1,min(nb_k, 10)
5496 : : ! vnk = sqrt(norm2(vnk_cart_ibz(:,ib_k)))
5497 : : ! write(ab_out, "(a,i0,1x,es16.6)")" ib_k: ", ib_k, vnk
5498 : : ! end do
5499 : : !end do
5500 : : !ABI_FREE(vnk_cart_ibz)
5501 : : !write(ab_out, "(a)")" "
5502 : :
5503 : : case (2)
5504 [ - + ]: 8 : ABI_ERROR(" TEXT output of vkmat is not coded yet!")
5505 : : end select
5506 : :
5507 : : ! Handle the output of the e-ph matrix elements. On disk we have the global array:
5508 : : !
5509 : : ! nctkarr_t("gvals", "dp", "gstore_cplex, nb_kq, nb_k, natom3, glob_nk, glob_nq")
5510 : :
5511 : : ! These e-ph matrix elements are ALWAYS in the atom representation.
5512 [ - + + - : 32 : ABI_MALLOC(gslice_mn, (2, nb_kq, nb_k))
- + + - +
- + - - +
- + - + ]
5513 [ - + + - : 24 : ABI_MALLOC(gslice_ks_mn, (2, nb_kq, nb_k))
- + + - -
+ - + -
+ ]
5514 [ - + + - : 32 : ABI_MALLOC(g2_mn, (nb_kq, nb_k))
- + + - +
- + - - +
- + ]
5515 [ - + + - : 24 : ABI_MALLOC(g2ks_mn, (nb_kq, nb_k))
- + + - -
+ - + ]
5516 : :
5517 : 8 : write(ab_out,"(a)") " E-PH matrix elements in the atom representation: pcase = (idir, iatom)"
5518 [ + - ]: 8 : if (do_avg) then
5519 : 8 : write(ab_out,"(a)") " NB: Values are averaged over e_mk+q, and e_nk degenerate states."
5520 : : else
5521 : 0 : write(ab_out,"(a)") " NB: Values are NOT averaged over e_mk+q, and e_nk degenerate states."
5522 : : end if
5523 : :
5524 [ + + ]: 8 : if (with_ks__) then
5525 : 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"
5526 : : else
5527 : 5 : write(ab_out, "(1x,5(a5,1x),a16)") "iq", "ik", "pcase", "m_kq", "n_k", "|g| in Ha"
5528 : : end if
5529 : :
5530 [ + + ]: 319 : do ik_glob=1,glob_nk
5531 : : ! Write the first and the last k-point.
5532 [ + + + + : 311 : if ((ik_glob /= 1 .and. ik_glob /= glob_nk) .and. .not. all_gs) cycle
+ - ]
5533 : :
5534 : 14 : ik_bz = gstore%kglob2bz(ik_glob, spin)
5535 : 14 : ik_ibz = gstore%kbz2ibz(1, ik_bz)
5536 : : !ik_ibz = gstore%bz2ibz(1, ik_bz); isym_k = gstore%bz2ibz(2, ik_bz)
5537 : : !trev_k = gstore%bz2ibz(6, ik_bz); g0_k = gstore%bz2ibz(3:5, ik_bz)
5538 : : !isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
5539 : :
5540 [ + + ]: 56 : kk = ebands%kptns(:,ik_ibz)
5541 : 14 : ib_min_k = bstart_k; ib_max_k = bstop_k
5542 : :
5543 : : call ebands%enclose_degbands(ik_ibz, spin, ib_min_k, ib_max_k, changed_k, dtset%symsigma_de, &
5544 [ - + ]: 14 : degblock=degblock_k)
5545 [ + + ]: 14 : if (changed_k) then
5546 : : !write(ab_out, "(a)")" Non all the degenerate bands at k were included. This should not happen!"
5547 [ + + ]: 10 : do ii=1,size(degblock_k, dim=2)
5548 : 8 : degblock_k(1, ii) = max(degblock_k(1, ii), bstart_k)
5549 : 10 : degblock_k(2, ii) = min(degblock_k(2, ii), bstop_k)
5550 : : end do
5551 : : end if
5552 : :
5553 [ + + ]: 1800 : do iq_glob=1,glob_nq
5554 : : ! Write the first and the last q-point.
5555 [ + + + + : 1786 : if ((iq_glob /= 1 .and. iq_glob /= glob_nq) .and. .not. all_gs) cycle
+ - ]
5556 : :
5557 : : ! Find k+q image in the IBZ.
5558 : 28 : iq_bz = qglob2bz(iq_glob, spin)
5559 [ + + ]: 112 : qq = gstore%qbz(:, iq_bz)
5560 [ + + ]: 112 : kq = kk + qq
5561 [ - + ]: 28 : if (kpts_map("symrel", ebands%kptopt, gstore%cryst, gstore%krank_ibz, 1, kq, mapl_kq) /= 0) then
5562 [ # # ]: 0 : write(msg, '(4a)' )"k-mesh is not closed!",ch10, "k+q could not be generated from a symmetrical one.",trim(ltoa(kq))
5563 : 0 : ABI_ERROR(msg)
5564 : : end if
5565 : 28 : ikq_ibz = mapl_kq(1)
5566 : 28 : ib_min_kq = bstart_kq; ib_max_kq = bstop_kq
5567 : :
5568 : : call ebands%enclose_degbands(ikq_ibz, spin, ib_min_kq, ib_max_kq, changed_kq, dtset%symsigma_de, &
5569 [ - + ]: 28 : degblock=degblock_kq)
5570 : :
5571 [ + + ]: 28 : if (changed_kq) then
5572 : : !write(ab_out, "(a)")" Non all the degenerate bands at k+q were included. This should not happen!"
5573 [ + + ]: 34 : do ii=1,size(degblock_kq, dim=2)
5574 : 30 : degblock_kq(1, ii) = max(degblock_kq(1, ii), bstart_kq)
5575 : 34 : degblock_kq(2, ii) = min(degblock_kq(2, ii), bstop_kq)
5576 : : end do
5577 : : end if
5578 : :
5579 [ + + ]: 196 : do ipc=1,natom3
5580 : : ! Write the 4th and the last perturbation.
5581 [ + + - + ]: 168 : if ((ipc /= 4 .and. ipc /= natom3) .and. .not. all_gs) cycle
5582 : : ! TODO: Write that pcase is filtered
5583 : : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals"), gslice_mn, &
5584 [ + + + + ]: 728 : start=[1,1,1,ipc,ik_glob,iq_glob], count=[2,nb_kq,nb_k,1,1,1])
5585 [ - + ]: 56 : NCF_CHECK(ncerr)
5586 : 56 : call average_g2_mn(do_avg, nb_kq, nb_k, bstart_kq, bstart_k, degblock_kq, degblock_k, gslice_mn, g2_mn)
5587 : :
5588 : 56 : write(ab_out, "(3(a,1x,i0,1x))")" |g(k,q)| in Ha for iq:", iq_glob, "ik:", ik_glob, "pcase:", ipc
5589 : :
5590 [ + + ]: 84 : if (.not. with_ks__) then
5591 : : ! gvals only.
5592 : 36 : write(ab_out, "(1x,5(a5,1x),a16)")"iq", "ik", "pcase", "m_kq", "n_k", "|g|"
5593 [ + + ]: 196 : do im_kq=1,nb_kq
5594 : 160 : m_kq = im_kq + bstart_kq - 1
5595 [ + + ]: 740 : do in_k=1,nb_k
5596 : 544 : n_k = in_k + bstart_k - 1
5597 : 544 : gg = sqrt(g2_mn(im_kq, in_k))
5598 : 704 : write(ab_out, "(a1,5(i5,1x),es16.6)")"-", iq_glob, ik_glob, ipc, m_kq, n_k, gg
5599 : : end do
5600 : : end do
5601 : : else
5602 : : ! GW/KS ratio, g^GW, g^KS
5603 : : ncerr = nf90_get_var(spin_ncid, spin_vid("gvals_ks"), gslice_ks_mn, &
5604 [ + + + + ]: 260 : start=[1,1,1,ipc,ik_glob,iq_glob], count=[2,nb_kq,nb_k,1,1,1])
5605 [ - + ]: 20 : NCF_CHECK(ncerr)
5606 : 20 : call average_g2_mn(do_avg, nb_kq, nb_k, bstart_kq, bstart_k, degblock_kq, degblock_k, gslice_ks_mn, g2ks_mn)
5607 : :
5608 : 20 : write(ab_out, "(1x,5(a5,1x),3a16)")"iq", "ik", "pcase", "m_kq", "n_k", "GW/KS", "|g^GW|", "|g^KS|"
5609 : 20 : min_g_ratio = +huge(one); max_g_ratio = -huge(one); mean_g_ratio = zero; stdev_g_ratio = zero; nn = 0
5610 : :
5611 [ + + ]: 252 : do im_kq=1,nb_kq
5612 : 232 : m_kq = im_kq + bstart_kq - 1
5613 [ + + ]: 1564 : do in_k=1,nb_k
5614 : 1312 : n_k = in_k + bstart_k - 1
5615 : 1312 : gg = sqrt(g2_mn(im_kq, in_k))
5616 : 1312 : gg_ks = sqrt(g2ks_mn(im_kq, in_k))
5617 : 1312 : call safe_div(gg, gg_ks, -one, g_ratio)
5618 [ + + ]: 1312 : if (g_ratio /= -one) then
5619 : 944 : nn = nn + 1
5620 : 944 : min_g_ratio = min(g_ratio, min_g_ratio)
5621 : 944 : max_g_ratio = max(g_ratio, max_g_ratio)
5622 : 944 : mean_g_ratio = mean_g_ratio + g_ratio
5623 : 944 : stdev_g_ratio = stdev_g_ratio + g_ratio ** 2
5624 : : end if
5625 : 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
5626 : : end do
5627 : : end do
5628 : :
5629 [ + + ]: 20 : if (nn /= 0) then
5630 : 14 : mean_g_ratio = mean_g_ratio / nn
5631 : 14 : write(ab_out, "(a,es16.6)")"- mean_g_ratio:", mean_g_ratio
5632 : : ! \sigma^{2} = \langle x^{2} \rangle - \langle x \rangle^{2}
5633 : 14 : write(ab_out, "(a,es16.6)")"- stdev_g_ratio:", sqrt((stdev_g_ratio / nn) - (mean_g_ratio ** 2))
5634 : 14 : write(ab_out, "(a,es16.6)")"- min_g_ratio:", min_g_ratio
5635 : 14 : write(ab_out, "(a,es16.6)")"- max_g_ratio:", max_g_ratio
5636 : : end if
5637 : : end if
5638 : :
5639 : : end do ! ipc
5640 : :
5641 [ - + ]: 1800 : ABI_FREE(degblock_kq)
5642 : : end do ! iq_glob
5643 [ - + ]: 319 : ABI_FREE(degblock_k)
5644 : : end do ! ik_glob
5645 : :
5646 [ - + ]: 8 : ABI_FREE(gslice_mn)
5647 [ - + ]: 8 : ABI_FREE(gslice_ks_mn)
5648 [ - + ]: 8 : ABI_FREE(g2_mn)
5649 [ - + ]: 16 : ABI_FREE(g2ks_mn)
5650 : : end do ! spin
5651 : :
5652 [ - + ]: 8 : ABI_FREE(qglob2bz)
5653 : :
5654 : : ! Here we read the matrix elements of i[V1, p] if present on disk.
5655 : 8 : has_iv1p_comm = gstore_nc_has_iv1p_comm(gstore, root_ncid)
5656 : :
5657 [ - + ]: 8 : if (has_iv1p_comm) then
5658 [ # # ]: 0 : do spin=1,gstore%nsppol
5659 [ # # ]: 0 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
5660 [ # # ]: 0 : NCF_CHECK(nctk_get_dim(spin_ncid, "glob_nk", glob_nk))
5661 [ # # ]: 0 : NCF_CHECK(nctk_get_dim(spin_ncid, "nb_k", nb_k))
5662 : :
5663 : 0 : bstart_k = gstore%brange_k_spin(1, spin)
5664 : 0 : bstop_k = gstore%brange_k_spin(2, spin)
5665 : :
5666 [ # # # # : 0 : ABI_CALLOC(iv1p_comm, (2, nb_k, nb_k, 3, natom3))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # #
# ]
5667 : :
5668 [ # # ]: 0 : do ik_glob=1,glob_nk
5669 : : ! Write the first and the last k-point.
5670 [ # # # # : 0 : if ((ik_glob /= 1 .and. ik_glob /= glob_nk) .and. .not. all_gs) cycle
# # ]
5671 : :
5672 : : !ik_bz = gstore%kglob2bz(ik_glob, spin)
5673 : : !ik_ibz = gstore%kbz2ibz(1, ik_bz)
5674 : : !kk_ibz = ebands%kptns(:,ik_ibz)
5675 : :
5676 : : ! nctkarr_t("iv1p_comm", "dp", "two, nb_k, nb_k, three, natom3, glob_nk")
5677 : : ncerr = nf90_get_var(spin_ncid, spin_vid("iv1p_comm"), iv1p_comm, &
5678 [ # # # # ]: 0 : start=[1,1,1,1,1,ik_glob], count=[2,nb_k,nb_k,3,natom3,1])
5679 [ # # ]: 0 : NCF_CHECK(ncerr)
5680 : :
5681 : : ! Only n_nk states are included in the matrix.
5682 : 0 : write(ab_out, "(1x,5(a5,1x),a16)")"ik", "pcase", "m_k", "n_k", "idir", "i[V1,p]"
5683 [ # # ]: 0 : do im_kq=1,nb_k
5684 : 0 : m_kq = im_kq + bstart_k - 1
5685 [ # # ]: 0 : do in_k=1,nb_k
5686 : 0 : n_k = in_k + bstart_k - 1
5687 [ # # ]: 0 : do ipc=1,natom3
5688 [ # # # # : 0 : if ((ipc /= 4 .and. ipc /= natom3) .and. .not. all_gs) cycle
# # ]
5689 [ # # ]: 0 : do idir=1,3
5690 [ # # ]: 0 : rtmp = iv1p_comm(:, im_kq, in_k, idir, ipc)
5691 : 0 : write(ab_out, "(a1,5(i5,1x),2es16.6)") "-", ik_glob, ipc, m_kq, n_k, idir, rtmp(1), rtmp(2)
5692 : : end do ! idir
5693 : : end do ! ipc
5694 : : end do ! in_k
5695 : : end do ! im_kq
5696 : :
5697 : : end do ! ik_glob
5698 : :
5699 [ # # ]: 0 : ABI_FREE(iv1p_comm)
5700 : : end do ! spin
5701 : : end if
5702 : :
5703 [ - + - + : 16 : NCF_CHECK(nf90_close(root_ncid))
- + - + -
+ - + - +
- + ]
5704 : :
5705 : : contains
5706 : 24 : integer function root_vid(var_name)
5707 : : character(len=*),intent(in) :: var_name
5708 : 24 : root_vid = nctk_idname(root_ncid, var_name)
5709 : : end function root_vid
5710 : :
5711 : 76 : integer function spin_vid(var_name)
5712 : : character(len=*),intent(in) :: var_name
5713 : 76 : spin_vid = nctk_idname(spin_ncid, var_name)
5714 : : end function spin_vid
5715 : :
5716 : : end subroutine gstore_print_for_abitests
5717 : : !!***
5718 : :
5719 [ - + - + ]: 76 : subroutine average_g2_mn(do_avg, nb_kq, nb_k, bstart_kq, bstart_k, degblock_kq, degblock_k, g_mn, g2_mn)
5720 : :
5721 : : !Arguments ------------------------------------
5722 : : logical,intent(in) :: do_avg
5723 : : integer,intent(in) :: nb_kq, nb_k, bstart_kq, bstart_k
5724 : : integer,intent(in) :: degblock_kq(:,:), degblock_k(:,:)
5725 : : real(dp),intent(in) :: g_mn(2, nb_kq, nb_k)
5726 : : real(dp),intent(out) :: g2_mn(nb_kq, nb_k)
5727 : :
5728 : : !Local variables-------------------------------
5729 : : integer :: im_group, in_group, count, m_kq, im_kq, n_k, in_k
5730 : : real(dp) :: g2_avg
5731 : : !----------------------------------------------------------------------
5732 : :
5733 [ - + ]: 76 : if (do_avg) then
5734 : : ! Average over electronic degenerate states at k and k+q
5735 [ + + + + ]: 3564 : g2_mn = -one
5736 [ + + ]: 460 : do im_group = 1, size(degblock_kq, dim=2)
5737 [ + + ]: 1414 : do in_group = 1, size(degblock_k, dim=2)
5738 : 954 : g2_avg = zero; count = 0
5739 [ + + ]: 2542 : do m_kq = degblock_kq(1, im_group), degblock_kq(2, im_group)
5740 : 1588 : im_kq = m_kq - bstart_kq + 1
5741 [ + + ]: 5710 : do n_k = degblock_k(1, in_group), degblock_k(2, in_group)
5742 : 3168 : in_k = n_k - bstart_k + 1
5743 : 3168 : g2_avg = g2_avg + g_mn(1, im_kq, in_k)**2 + g_mn(2, im_kq, in_k)**2
5744 : 4756 : count = count + 1
5745 : : end do
5746 : : end do
5747 : 954 : g2_avg = g2_avg / count
5748 : :
5749 : : ! Loop again over degenerate bands and copy average.
5750 [ + + ]: 2926 : do m_kq = degblock_kq(1, im_group), degblock_kq(2, im_group)
5751 : 1588 : im_kq = m_kq - bstart_kq + 1
5752 [ + + ]: 5710 : do n_k = degblock_k(1, in_group), degblock_k(2, in_group)
5753 : 3168 : in_k = n_k - bstart_k + 1
5754 : 4756 : g2_mn(im_kq, in_k) = g2_avg
5755 : : end do
5756 : : end do
5757 : :
5758 : : end do ! in_group
5759 : : end do ! im_group
5760 : :
5761 : : else
5762 : : ! No average here.
5763 [ # # ]: 0 : do im_kq=1, nb_kq
5764 [ # # ]: 0 : do in_k=1, nb_k
5765 : 0 : g2_mn(im_kq, in_k) = g_mn(1, im_kq, in_k)**2 + g_mn(2, im_kq, in_k)**2
5766 : : end do
5767 : : end do
5768 : : end if
5769 : :
5770 : 76 : end subroutine average_g2_mn
5771 : : !!***
5772 : :
5773 : : !----------------------------------------------------------------------
5774 : :
5775 : : !!****f* m_gstore/gqk_gather
5776 : : !! NAME
5777 : : !! gqk_gather
5778 : : !!
5779 : : !! FUNCTION
5780 : : !! Gather the MPI-distributed matrix elements for a given k/q-point index.
5781 : : !! Once one reciprocal dimension is fixed, the gathering is performed across the other one.
5782 : : !!
5783 : : !! INPUTS
5784 : : !! mode = String controlling the choice of the fixed dimension ("k" or "q")
5785 : : !! fixed_pt = Index of the fixed k/q-point
5786 : : !!
5787 : : !! OUTPUT
5788 : : !! g_gathered(:,:,:,:) = Matrix elements for the given k/q-point, ordered as
5789 : : !! (my_npert, nb, nb, glob_nq) - k-point is fixed
5790 : : !! (my_npert, nb, nb, glob_nk) - q-point is fixed
5791 : : !!
5792 : : !! SOURCE
5793 : :
5794 : 555656 : subroutine gqk_gather(gqk, mode, fixed_pt, g_gathered)
5795 : :
5796 : : !Arguments ------------------------------------
5797 : : !scalars
5798 : : class(gqk_t), target, intent(in) :: gqk
5799 : : character(len=*),intent(in) :: mode
5800 : : integer,intent(in) :: fixed_pt
5801 : : !arrays
5802 : : complex(dp), allocatable, intent(out) :: g_gathered(:,:,:,:)
5803 : :
5804 : : !Local variables-------------------------------
5805 : : !scalars
5806 : : integer :: comm, ierr, ipt_glob, ngather, my_ipt, my_ngather, my_ptstart, my_pert, ib, jb
5807 : : !arrays
5808 : 277828 : complex(dp), pointer :: my_g(:,:,:,:)
5809 : : !----------------------------------------------------------------------
5810 : :
5811 : 0 : ABI_CHECK_IEQ(gqk%nb_kq, gqk%nb_k, "nb_kq != nb_k not tested")
5812 : :
5813 : 0 : select case (mode)
5814 : : case ("k")
5815 : 0 : comm = gqk%qpt_comm%value
5816 : 0 : ngather = gqk%glob_nq
5817 : 0 : my_ngather = gqk%my_nq
5818 : 0 : my_ptstart = gqk%my_qstart
5819 : 0 : my_g => gqk%my_g(:,:,:,:,fixed_pt)
5820 [ # # # # : 0 : ABI_CALLOC(g_gathered, (gqk%my_npert, gqk%nb_kq, gqk%nb_k, ngather))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # #
# ]
5821 : :
5822 : : case ("q")
5823 : 277828 : comm = gqk%kpt_comm%value
5824 : 277828 : ngather = gqk%glob_nk
5825 : 277828 : my_ngather = gqk%my_nk
5826 : 277828 : my_ptstart = gqk%my_kstart
5827 : 277828 : my_g => gqk%my_g(:,:,fixed_pt,:,:)
5828 [ - + + - : 2150164396 : ABI_CALLOC(g_gathered, (gqk%my_npert, gqk%nb_k, gqk%nb_kq, ngather))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + + + +
+ + + +
+ ]
5829 : :
5830 : : case default
5831 [ - + - ]: 277828 : ABI_ERROR(sjoin("Gathering MPI-distributed matrix elements, unsupported mode: ", mode))
5832 : : end select
5833 : :
5834 [ + + ]: 33678830 : do my_ipt=1,my_ngather
5835 : 33401002 : ipt_glob = my_ipt + my_ptstart - 1
5836 : :
5837 : : ! FIXME: can the rearrangement be done in the select case statement?
5838 [ + + ]: 130800122 : do ib=1,gqk%nb_k
5839 [ + + ]: 418804456 : do jb=1,gqk%nb_kq
5840 [ + + ]: 2115096426 : do my_pert=1,gqk%my_npert
5841 [ - + ]: 2017975134 : if (mode == "k") then
5842 : 0 : g_gathered(my_pert, jb, ib, ipt_glob) = my_g(my_pert, jb, my_ipt, ib)
5843 : : else
5844 : 1729692972 : g_gathered(my_pert, jb, ib, ipt_glob) = my_g(my_pert, jb, ib, my_ipt)
5845 : : endif
5846 : : enddo
5847 : : enddo
5848 : : enddo
5849 : : enddo
5850 : :
5851 : 277828 : call xmpi_sum(g_gathered, comm, ierr)
5852 : :
5853 [ - + ]: 277828 : end subroutine gqk_gather
5854 : : !!***
5855 : :
5856 : : !----------------------------------------------------------------------
5857 : :
5858 : : !!****f* m_gstore/gstore_wannierize_and_write_gwan
5859 : : !! NAME
5860 : : !! gstore_wannierize_and_write_gwan
5861 : : !!
5862 : : !! FUNCTION
5863 : : !! Compute g(R_e,R_ph) from g(k,q). Save results to GWAN.nc file
5864 : : !!
5865 : : !! INPUTS
5866 : : !!
5867 : : !! SOURCE
5868 : :
5869 : 0 : subroutine gstore_wannierize_and_write_gwan(gstore, dvdb, dtfil)
5870 : :
5871 : : !Arguments ------------------------------------
5872 : : class(gstore_t),target, intent(in) :: gstore
5873 : : type(dvdb_t),intent(in) :: dvdb
5874 : : type(datafiles_type),intent(in) :: dtfil
5875 : :
5876 : : !Local variables-------------------------------
5877 : : !scalars
5878 : : integer,parameter :: master = 0
5879 : : integer,parameter :: wan_ntest = 4
5880 : : integer,parameter :: wan_nperiod = 3
5881 : : real(dp),parameter :: WAN_CLOSURE_TOL = tol8
5882 : : real(dp),parameter :: WAN_VELOCITY_FD_STEP = 1.0d-5
5883 : : real(dp),parameter :: WAN_VELOCITY_DEGEN_TOL = 1.0d-5
5884 : : real(dp),parameter :: WAN_VELOCITY_TOL = tol6
5885 : : integer :: nr_e, nr_p, nwan, iwan, jwan, spin, my_is, my_ip, ir, irp, my_ik, my_iq, nb_k, nb_kq
5886 : : integer :: my_nk, my_nq, ierr, ik, ikq, my_npert, nwin_k, nwin_kq, ii, jj, band_kq, band_k, ib_k, ib_kq
5887 : : integer :: itest, ip_loc, ik_glob, iq_glob, ntest_found, iperiod, idir, ib, nvelocity_tested
5888 : : real(dp) :: max_err, ref_scale, max_period_eig_err, period_eig_scale, max_period_g2_err, period_g2_scale
5889 : : real(dp) :: max_velocity_err, velocity_scale, band_gap, velocity_fd
5890 : : character(len=500) :: msg
5891 : : logical :: keep_umats, test_found(wan_ntest)
5892 : : type(wan_t),pointer :: wan
5893 : : type(gqk_t),pointer :: gqk
5894 : : !arrays
5895 : : integer :: qptrlatt_(3,3), units(2)
5896 : : integer :: test_ik(wan_ntest), test_iq(wan_ntest)
5897 : : integer :: period_gk(3,wan_nperiod), period_gq(3,wan_nperiod)
5898 : : real(dp) :: weight_qq, qpt(3), kpt(3), kq(3), dkred(3), cpu, wall, gflops
5899 : 0 : real(dp),allocatable :: eigens_k_test(:), eigens_kq_test(:), eigens_k_period(:), eigens_kq_period(:)
5900 : 0 : real(dp),allocatable :: eigens_k_plus(:), eigens_k_minus(:), vcart_test(:,:)
5901 : 0 : complex(dp),allocatable :: emikr(:), emiqr(:), u_k(:,:), u_kq(:,:), gww_epq(:,:,:,:,:), gww_pk(:,:,:,:), g_bb(:,:), tmp_mat(:,:)
5902 : 0 : complex(dp),allocatable :: test_gref(:,:,:,:), u_k_test(:,:), u_kq_test(:,:), cmat_test(:,:), g_expected(:,:)
5903 : 0 : complex(dp),allocatable :: g_atm_test(:,:,:,:), g_atm_period(:,:,:,:)
5904 : : ! *************************************************************************
5905 : :
5906 [ # # ]: 0 : units = [std_out, ab_out]
5907 : 0 : period_gk = reshape([1,0,0, 0,0,0, -1,1,0], shape(period_gk))
5908 : 0 : period_gq = reshape([0,0,0, 0,1,0, 0,0,1], shape(period_gq))
5909 : 0 : call wrtout(units, " Computing g(R_e,R_ph) in the Wannier representation...", pre_newlines=1)
5910 : 0 : call cwtime(cpu, wall, gflops, "start")
5911 : :
5912 [ # # ]: 0 : if (gstore%check_cplex_qkzone_gmode(2, "bz", "bz", "atom", kfilter="none") /= 0) then
5913 : 0 : ABI_ERROR("The gstore object is inconsistent with gstore_wannierize_and_write_gwan. See messages above.")
5914 : : end if
5915 : :
5916 : : ! TODO: Handle long-range part.
5917 [ # # # # ]: 0 : if (dvdb%has_zeff .or. dvdb%has_quadrupoles) then
5918 : 0 : ABI_WARNING("Treatment of long-range part not yet coded in gstore_wannierize_and_write_gwan!")
5919 : : end if
5920 : :
5921 [ # # ]: 0 : do my_is=1,gstore%my_nspins
5922 : 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
5923 : 0 : nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
5924 : :
5925 : : ! Initialize gkq%wan from ABIWAN.nc for this spin.
5926 : 0 : keep_umats = .False.
5927 : 0 : call gqk%wan%from_abiwan(dtfil%filabiwanin, spin, gstore%nsppol, keep_umats, dtfil%filnam_ds(4), gqk%comm%value)
5928 : 0 : wan => gqk%wan
5929 : :
5930 : : ! Compute Wigner-Seitz lattice vectors and llocate grpe_wwp with shape: (nr_p, nr_e, nwan, nwan, my_npert).
5931 : 0 : call kptrlatt_from_ngkpt(gstore%ngqpt, qptrlatt_)
5932 : : call wan%setup_eph_ws_kq(gstore%cryst, gstore%ebands%shiftk(:,1), gstore%ebands%kptrlatt, qptrlatt_, &
5933 : 0 : gqk%my_pert_start, my_npert, gqk%pert_comm)
5934 : :
5935 : 0 : nr_p = wan%nr_p; nr_e = wan%nr_e; nwan = wan%nwan
5936 : : !if (gqk%comm%me == master) call wan%print(units)
5937 : :
5938 : : ! Cache the pre-FT ground truth at four fixed GLOBAL coarse-mesh points. Using
5939 : : ! local first/last indices would make the test points depend on the MPI grid.
5940 [ # # ]: 0 : test_ik = [1, gqk%glob_nk, 1, gqk%glob_nk]
5941 [ # # ]: 0 : test_iq = [1, 1, gqk%glob_nq, gqk%glob_nq]
5942 : 0 : test_found = .False.
5943 [ # # # # : 0 : ABI_CALLOC(test_gref, (nwan, nwan, my_npert, wan_ntest))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
5944 : :
5945 [ # # # # : 0 : ABI_MALLOC(emikr, (nr_e))
# # # # #
# # # ]
5946 [ # # # # : 0 : ABI_MALLOC(emiqr, (nr_p))
# # # # #
# # # ]
5947 [ # # # # : 0 : ABI_MALLOC(gww_pk, (nwan, nwan, my_npert, my_nk))
# # # # #
# # # # #
# # # # #
# # # #
# ]
5948 : : ! Intermediate buffer to store the sum over k-points. Note my_nq.
5949 [ # # # # : 0 : ABI_CALLOC(gww_epq, (nwan, nwan, nr_e, my_npert, my_nq))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
5950 : :
5951 : : ! Loop over my q-points (partial sum over q).
5952 [ # # ]: 0 : do my_iq=1,my_nq
5953 : 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qpt)
5954 : :
5955 : : !call get_kg(qpt, 1, ecut_lr, gstore%cryst%gmet, ng_q, gvec_q)
5956 : : !ABI_FREE(gvec_q)
5957 : :
5958 : : ! Loop over my k-points (partial sum over k).
5959 [ # # ]: 0 : do my_ik=1,my_nk
5960 [ # # # # ]: 0 : kpt = gqk%my_kpts(:,my_ik); kq = kpt + qpt
5961 : 0 : ik = wan%krank%get_index(kpt); ikq = wan%krank%get_index(kq)
5962 [ # # ]: 0 : ABI_CHECK(ik /= -1, sjoin("Cannot find kpt: ", ktoa(kpt)))
5963 [ # # ]: 0 : ABI_CHECK(ikq /= -1, sjoin("Cannot find k+q: ", ktoa(kq)))
5964 : :
5965 : : ! Get rotation matrices at k and k+q.
5966 : 0 : nwin_k = wan%dimwin(ik); nwin_kq = wan%dimwin(ikq)
5967 [ # # # # : 0 : ABI_MALLOC(g_bb, (nwin_kq, nwin_k))
# # # # #
# # # # #
# # ]
5968 [ # # # # : 0 : ABI_MALLOC(u_k, (1:nwin_k, 1:nwan))
# # # # #
# # # # #
# # ]
5969 [ # # # # : 0 : ABI_MALLOC(u_kq, (1:nwin_kq, 1:nwan))
# # # # #
# # # # #
# # ]
5970 [ # # # # : 0 : ABI_MALLOC(tmp_mat, (nwin_kq, nwan))
# # # # #
# # # # #
# # ]
5971 : :
5972 [ # # # # : 0 : u_k = wan%u_k(1:nwin_k, 1:nwan, ik)
# # ]
5973 [ # # # # : 0 : u_kq = wan%u_k(1:nwin_kq, 1:nwan, ikq)
# # ]
5974 : :
5975 [ # # ]: 0 : do my_ip=1,gqk%my_npert
5976 : : !----------------------------------------------------------
5977 : : ! STEP 1: rotation to optimally smooth Bloch states
5978 : : !----------------------------------------------------------
5979 : : ! [Eqn. 24 of PRB 76, 165108 (2007)]
5980 : : ! g~(k,q) = U(k+q)^\dagger * g(k,q) * U(k)
5981 : :
5982 : : ! gqk%nb = wan%bmax - wan%bmin + 1
5983 : : ! (my_npert, nb, my_nq, nb, my_nk)
5984 : : ! ( p, b1_kq, q, b2_k, k) --> <k+q, b1| D_{q,p}H |k, b2>
5985 : :
5986 : : ! Extract e-ph matrix elements from my_g buffer to align bands with the U matrices at k and k+q.
5987 : : jj = 0
5988 [ # # ]: 0 : do ib_k=1,nb_k
5989 [ # # ]: 0 : band_k = ib_k - wan%bmin + 1; if (.not. wan%lwindow(band_k, ik)) cycle
5990 : 0 : jj = jj + 1; ii = 0
5991 [ # # ]: 0 : do ib_kq=1,nb_kq
5992 [ # # ]: 0 : band_kq = ib_kq - wan%bmin + 1; if (.not. wan%lwindow(band_kq, ikq)) cycle
5993 : 0 : ii = ii + 1
5994 : 0 : g_bb(ii, jj) = gqk%my_g(my_ip, ib_kq, my_iq, ib_k, my_ik)
5995 : : end do
5996 : : end do
5997 : :
5998 : : ! TODO: Remove LR part.
5999 : : !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)
6000 : :
6001 : : ! the two zgemm calls perform: epmats = [ cu(ikq)^\dagger * epmatk ] * cu(ikk)
6002 : : ! [here we have a size-reduction from nbnd*nbnd to nwan*nwan]
6003 : : ! output stored in gww_pk(:,:, my_ip, my_ik)
6004 : :
6005 : : ! gww_pk(:,:, my_ip, my_ik) = MATMUL(CONJG(TRANSPOSE(u_kq)), MATMUL(g_bb, u_k))
6006 : : ! tmp_mat (nwin_kq x nwan) = g_bb (nwin_kq x nwin_k) . u_k (nwin_k x nwan)
6007 : 0 : call ZGEMM('N', 'N', nwin_kq, nwan, nwin_k, cone, g_bb, nwin_kq, u_k, nwin_k, czero, tmp_mat, nwin_kq)
6008 : : ! gww_pk (nwan x nwan) = u_kq^dagger (nwan x nwin_kq) . tmp_mat (nwin_kq x nwan)
6009 : 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)
6010 : :
6011 : : !call ZGEMM('C', 'N', nwan, nbnd, nbnd, cone, u_kq, nbnd, epmatk(:, :, ik, imode), nbnd, czero, eptmp, nwan)
6012 : : !call ZGEMM('N', 'N', nwan, nwan, nbnd, cone, eptmp, nwan, u_k, nbnd, czero, epmats(:, :, ik, imode), nwan)
6013 : : end do ! my_ip
6014 : :
6015 : : ! Cache gww_pk(:,:,:,my_ik) for the on-mesh closure self-check below, while it is still
6016 : : ! valid for THIS my_iq (it gets overwritten by the next my_iq iteration).
6017 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
6018 : 0 : iq_glob = my_iq + gqk%my_qstart - 1
6019 [ # # ]: 0 : do itest=1,wan_ntest
6020 [ # # # # ]: 0 : if (test_ik(itest) == ik_glob .and. test_iq(itest) == iq_glob) then
6021 [ # # # # : 0 : test_gref(:,:,:,itest) = gww_pk(:,:,:,my_ik)
# # ]
6022 : 0 : test_found(itest) = .True.
6023 : : end if
6024 : : end do
6025 : :
6026 [ # # ]: 0 : ABI_FREE(g_bb)
6027 [ # # ]: 0 : ABI_FREE(tmp_mat)
6028 : :
6029 : : !----------------------------------------------------------------------
6030 : : ! STEP 3: Fourier transform to obtain matrix elements in electron wannier basis
6031 : : !----------------------------------------------------------------------
6032 : : ! [Eqn. 24 of PRB 76, 165108 (2007)]
6033 : : ! g(R_e,q) = (1/nkc) sum_k e^{-ikR_e} g~(k,q)
6034 : : ! g(R_e,q) is epmatw (nwan,nwan,ir)
6035 : :
6036 [ # # ]: 0 : do ir=1,nr_e
6037 [ # # ]: 0 : emikr(ir) = exp(-j_dpc * two_pi * dot_product(kpt, wan%r_e(:, ir))) / dble(gstore%nkbz)
6038 : : end do
6039 : : ! gww_pk(nwan, nwan, my_npert,my_nk)
6040 [ # # ]: 0 : do my_ip=1,gqk%my_npert
6041 [ # # ]: 0 : do ir=1,nr_e
6042 [ # # # # ]: 0 : gww_epq(:,:,ir, my_ip, my_iq) = gww_epq(:,:,ir, my_ip, my_iq) + emikr(ir) * gww_pk(:,:,my_ip, my_ik)
6043 : : end do
6044 : : end do
6045 : :
6046 [ # # ]: 0 : ABI_FREE(u_k)
6047 [ # # ]: 0 : ABI_FREE(u_kq)
6048 : : end do ! my_ik
6049 : : end do ! my_iq
6050 : :
6051 : 0 : call xmpi_sum(gww_epq, gqk%kpt_comm%value, ierr)
6052 : :
6053 : : !------------------------------------------
6054 : : ! Fourier transform to go to Wannier basis
6055 : : !------------------------------------------
6056 : : ! [Eqn. 24 of PRB 76, 165108 (2007)]
6057 : : ! g(R_e,R_p) = (1/nq) sum_q e^{-iqR_p} g(R_e,q)
6058 : :
6059 : : ! Loop over my q-points (partial sum over q).
6060 [ # # ]: 0 : do my_iq=1,my_nq
6061 : 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qpt)
6062 [ # # ]: 0 : do irp=1,nr_p
6063 [ # # ]: 0 : emiqr(irp) = exp(-j_dpc * two_pi * dot_product(qpt, wan%r_p(:, irp))) / dble(gstore%nqbz)
6064 : : end do
6065 : :
6066 [ # # ]: 0 : do my_ip=1,my_npert
6067 [ # # ]: 0 : do jwan=1,nwan
6068 [ # # ]: 0 : do iwan=1,nwan
6069 [ # # ]: 0 : do ir=1,nr_e
6070 : : ! 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}
6071 : : wan%grpe_wwp(:, ir, iwan, jwan, my_ip) = wan%grpe_wwp(:, ir, iwan, jwan, my_ip) + &
6072 [ # # ]: 0 : gww_epq(iwan, jwan, ir, my_ip, my_iq) * emiqr(:)
6073 : : end do
6074 : : end do
6075 : : end do
6076 : : end do ! my_ip
6077 : : end do ! my_iq
6078 : :
6079 : 0 : call xmpi_sum(wan%grpe_wwp, gqk%qpt_kpt_comm%value, ierr)
6080 : :
6081 [ # # ]: 0 : if (gqk%comm%me == master) then
6082 : 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] '
6083 [ # # ]: 0 : do ir=1,nr_e
6084 [ # # # # : 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,:,:,:))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
6085 : : end do
6086 : : end if
6087 : :
6088 : : !--------------------------------------------------------------------------------
6089 : : ! Wannier on-mesh closure self-check: interpolating g(k,q) back at a handful of
6090 : : ! the SAME coarse (k,q) points used to build wan%grpe_wwp must reproduce the pre-FT
6091 : : ! gww_pk cached above, once rotated by the SAME wan%interp_ham-derived u_k/u_kq
6092 : : ! (interp_ham's gauge is generically different from the ABIWAN gauge used for gww_pk,
6093 : : ! even on-mesh, so we apply the identical rotation to both sides rather than comparing
6094 : : ! against raw gww_pk). This isolates the WS/ndegen bookkeeping and forward/backward FT
6095 : : ! consistency. Cheap (wan_ntest points only) and deterministic: a hard ABI_CHECK, not a
6096 : : ! Refs-compared print, since it is a precision-only mathematical identity.
6097 : : !--------------------------------------------------------------------------------
6098 [ # # # # : 0 : ABI_MALLOC(u_k_test, (nwan,nwan))
# # # # #
# # # # #
# # ]
6099 [ # # # # : 0 : ABI_MALLOC(u_kq_test, (nwan,nwan))
# # # # #
# # # ]
6100 [ # # # # : 0 : ABI_MALLOC(eigens_k_test, (nwan))
# # # # #
# # # ]
6101 [ # # # # : 0 : ABI_MALLOC(eigens_kq_test, (nwan))
# # # # ]
6102 [ # # # # : 0 : ABI_MALLOC(eigens_k_period, (nwan))
# # # # ]
6103 [ # # # # : 0 : ABI_MALLOC(eigens_kq_period, (nwan))
# # # # ]
6104 [ # # # # : 0 : ABI_MALLOC(eigens_k_plus, (nwan))
# # # # ]
6105 [ # # # # : 0 : ABI_MALLOC(eigens_k_minus, (nwan))
# # # # ]
6106 [ # # # # : 0 : ABI_MALLOC(vcart_test, (3,nwan))
# # # # #
# # # ]
6107 [ # # # # : 0 : ABI_MALLOC(cmat_test, (nwan,nwan))
# # # # #
# # # ]
6108 [ # # # # : 0 : ABI_MALLOC(g_expected, (nwan,nwan))
# # # # #
# # # ]
6109 [ # # # # : 0 : ABI_MALLOC(g_atm_test, (nwan, nwan, my_npert, 1))
# # # # #
# # # # #
# # # # #
# ]
6110 [ # # # # : 0 : ABI_MALLOC(g_atm_period, (nwan, nwan, my_npert, 1))
# # # # #
# # # # #
# # ]
6111 : :
6112 : 0 : max_err = zero; ref_scale = zero
6113 : 0 : max_period_eig_err = zero; period_eig_scale = zero
6114 : 0 : max_period_g2_err = zero; period_g2_scale = zero
6115 : 0 : max_velocity_err = zero; velocity_scale = zero; nvelocity_tested = 0
6116 [ # # ]: 0 : do itest=1,wan_ntest
6117 [ # # ]: 0 : if (.not. test_found(itest)) cycle
6118 : 0 : my_ik = test_ik(itest) - gqk%my_kstart + 1
6119 : 0 : my_iq = test_iq(itest) - gqk%my_qstart + 1
6120 [ # # ]: 0 : kpt = gqk%my_kpts(:,my_ik)
6121 : 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qpt)
6122 : 0 : call wan%interp_ham(gstore%cryst, kpt, u_k_test, eigens_k_test, vcart_test)
6123 [ # # ]: 0 : call wan%interp_ham(gstore%cryst, kpt + qpt, u_kq_test, eigens_kq_test)
6124 : 0 : call wan%interp_eph_manyq(gstore%cryst, 1, qpt, kpt, g_atm_test)
6125 [ # # # # : 0 : ref_scale = max(ref_scale, maxval(abs(test_gref(:,:,:,itest))))
# # # # #
# # # #
# ]
6126 [ # # ]: 0 : do ip_loc=1,my_npert
6127 : : ! Same order/dagger convention as wan_interp_eph_manyq (m_mlwfovlp.F90).
6128 : 0 : call ZGEMM('N', 'N', nwan, nwan, nwan, cone, u_kq_test, nwan, test_gref(:,:,ip_loc,itest), nwan, czero, cmat_test, nwan)
6129 : 0 : call ZGEMM('N', 'C', nwan, nwan, nwan, cone, cmat_test, nwan, u_k_test, nwan, czero, g_expected, nwan)
6130 [ # # # # : 0 : max_err = max(max_err, maxval(abs(g_expected - g_atm_test(:,:,ip_loc,1))))
# # # # #
# # # ]
6131 : : end do
6132 : :
6133 : : ! Validate analytic Cartesian group velocities against centered finite
6134 : : ! differences of the interpolated eigenvalues. Skip degenerate bands,
6135 : : ! whose individual diagonal velocities depend on the chosen subspace basis.
6136 : : ! These calls intentionally follow the closure comparison because the
6137 : : ! finite-difference diagonalizations reuse the u_kq_test work buffer.
6138 [ # # ]: 0 : do idir=1,3
6139 [ # # ]: 0 : dkred = WAN_VELOCITY_FD_STEP * gstore%cryst%rprimd(idir,:) / two_pi
6140 [ # # ]: 0 : call wan%interp_ham(gstore%cryst, kpt + dkred, u_kq_test, eigens_k_plus)
6141 [ # # ]: 0 : call wan%interp_ham(gstore%cryst, kpt - dkred, u_kq_test, eigens_k_minus)
6142 [ # # ]: 0 : do ib=1,nwan
6143 : 0 : band_gap = huge(one)
6144 [ # # ]: 0 : if (ib > 1) band_gap = min(band_gap, abs(eigens_k_test(ib) - eigens_k_test(ib-1)))
6145 [ # # ]: 0 : if (ib < nwan) band_gap = min(band_gap, abs(eigens_k_test(ib+1) - eigens_k_test(ib)))
6146 [ # # ]: 0 : if (band_gap < WAN_VELOCITY_DEGEN_TOL) cycle
6147 : 0 : velocity_fd = (eigens_k_plus(ib) - eigens_k_minus(ib)) / (two * WAN_VELOCITY_FD_STEP)
6148 : 0 : max_velocity_err = max(max_velocity_err, abs(vcart_test(idir,ib) - velocity_fd))
6149 : 0 : velocity_scale = max(velocity_scale, abs(vcart_test(idir,ib)), abs(velocity_fd))
6150 : 0 : nvelocity_tested = nvelocity_tested + 1
6151 : : end do
6152 : : end do
6153 : :
6154 : : ! Reciprocal-periodicity self-check. Integer shifts leave the real-space
6155 : : ! Fourier sums invariant. Compare eigenvalues and per-perturbation
6156 : : ! Frobenius norms, which remain well defined even if a tiny roundoff
6157 : : ! difference rotates eigenvectors inside a degenerate subspace.
6158 [ # # # # : 0 : period_eig_scale = max(period_eig_scale, maxval(abs(eigens_k_test)), maxval(abs(eigens_kq_test)))
# # # # #
# # # # #
# # ]
6159 [ # # ]: 0 : do ip_loc=1,my_npert
6160 [ # # # # ]: 0 : period_g2_scale = max(period_g2_scale, sum(abs(g_atm_test(:,:,ip_loc,1))**2))
6161 : : end do
6162 [ # # ]: 0 : do iperiod=1,wan_nperiod
6163 [ # # ]: 0 : call wan%interp_ham(gstore%cryst, kpt + period_gk(:,iperiod), u_k_test, eigens_k_period)
6164 : : call wan%interp_ham(gstore%cryst, kpt + qpt + period_gk(:,iperiod) + period_gq(:,iperiod), &
6165 [ # # ]: 0 : u_kq_test, eigens_kq_period)
6166 : : call wan%interp_eph_manyq(gstore%cryst, 1, qpt + period_gq(:,iperiod), &
6167 [ # # # # ]: 0 : kpt + period_gk(:,iperiod), g_atm_period)
6168 : : max_period_eig_err = max(max_period_eig_err, maxval(abs(eigens_k_period - eigens_k_test)), &
6169 [ # # # # : 0 : maxval(abs(eigens_kq_period - eigens_kq_test)))
# # # # #
# # # # #
# # ]
6170 [ # # ]: 0 : do ip_loc=1,my_npert
6171 : : max_period_g2_err = max(max_period_g2_err, abs( &
6172 [ # # # # : 0 : sum(abs(g_atm_period(:,:,ip_loc,1))**2) - sum(abs(g_atm_test(:,:,ip_loc,1))**2)))
# # # # ]
6173 : : end do
6174 : : end do
6175 : : end do
6176 : :
6177 : : ! Each fixed (k,q) pair must be owned exactly once within each perturbation
6178 : : ! slice. Reduce diagnostics over the complete spin communicator so every rank
6179 : : ! applies the same check and the printed result is MPI-decomposition invariant.
6180 [ # # # # ]: 0 : ntest_found = count(test_found)
6181 : 0 : call xmpi_sum(ntest_found, gqk%qpt_kpt_comm%value, ierr)
6182 [ # # ]: 0 : ABI_CHECK_IEQ(ntest_found, wan_ntest, "Wannier closure test did not find each fixed global (k,q) point exactly once")
6183 : 0 : call xmpi_max(max_err, gqk%comm%value, ierr)
6184 : 0 : call xmpi_max(ref_scale, gqk%comm%value, ierr)
6185 : 0 : call xmpi_max(max_period_eig_err, gqk%comm%value, ierr)
6186 : 0 : call xmpi_max(period_eig_scale, gqk%comm%value, ierr)
6187 : 0 : call xmpi_max(max_period_g2_err, gqk%comm%value, ierr)
6188 : 0 : call xmpi_max(period_g2_scale, gqk%comm%value, ierr)
6189 : 0 : call xmpi_max(max_velocity_err, gqk%comm%value, ierr)
6190 : 0 : call xmpi_max(velocity_scale, gqk%comm%value, ierr)
6191 : 0 : call xmpi_sum(nvelocity_tested, gqk%qpt_kpt_comm%value, ierr)
6192 : 0 : ref_scale = max(ref_scale, tol12)
6193 : 0 : period_eig_scale = max(period_eig_scale, tol12)
6194 : 0 : period_g2_scale = max(period_g2_scale, tol12)
6195 : 0 : velocity_scale = max(velocity_scale, one)
6196 : :
6197 [ # # ]: 0 : if (gqk%comm%me == master) then
6198 : 0 : write(std_out,'(a,es10.2,a,es10.2)') " Wannier on-mesh closure self-check: max_err=", max_err, " ref_scale=", ref_scale
6199 : 0 : write(std_out,'(a,es10.2,a,es10.2)') " Wannier reciprocal-periodicity self-check: max_eig_err=", &
6200 : 0 : max_period_eig_err, " max_g2_err=", max_period_g2_err
6201 : 0 : write(std_out,'(a,i0,a,es10.2)') " Wannier group-velocity self-check: nvalues=", &
6202 : 0 : nvelocity_tested, " max_err=", max_velocity_err
6203 : : end if
6204 : :
6205 [ # # ]: 0 : ABI_CHECK(max_err < WAN_CLOSURE_TOL * ref_scale, "Wannier on-mesh closure self-check failed")
6206 : 0 : msg = "Wannier reciprocal-periodicity self-check failed for interpolated electronic eigenvalues."
6207 [ # # ]: 0 : ABI_CHECK(max_period_eig_err < WAN_CLOSURE_TOL * period_eig_scale, msg)
6208 : 0 : msg = "Wannier reciprocal-periodicity self-check failed for gauge-invariant e-ph Frobenius norms."
6209 [ # # ]: 0 : ABI_CHECK(max_period_g2_err < WAN_CLOSURE_TOL * period_g2_scale, msg)
6210 [ # # ]: 0 : ABI_CHECK(nvelocity_tested > 0, "Wannier group-velocity self-check did not find a nondegenerate band")
6211 : 0 : msg = "Analytic Wannier group velocities do not agree with finite differences of the interpolated eigenvalues."
6212 [ # # ]: 0 : ABI_CHECK(max_velocity_err < WAN_VELOCITY_TOL * velocity_scale, msg)
6213 : :
6214 [ # # ]: 0 : ABI_FREE(u_k_test)
6215 [ # # ]: 0 : ABI_FREE(u_kq_test)
6216 [ # # ]: 0 : ABI_FREE(eigens_k_test)
6217 [ # # ]: 0 : ABI_FREE(eigens_kq_test)
6218 [ # # ]: 0 : ABI_FREE(eigens_k_period)
6219 [ # # ]: 0 : ABI_FREE(eigens_kq_period)
6220 [ # # ]: 0 : ABI_FREE(eigens_k_plus)
6221 [ # # ]: 0 : ABI_FREE(eigens_k_minus)
6222 [ # # ]: 0 : ABI_FREE(vcart_test)
6223 [ # # ]: 0 : ABI_FREE(cmat_test)
6224 [ # # ]: 0 : ABI_FREE(g_expected)
6225 [ # # ]: 0 : ABI_FREE(g_atm_test)
6226 [ # # ]: 0 : ABI_FREE(g_atm_period)
6227 [ # # ]: 0 : ABI_FREE(test_gref)
6228 : :
6229 : : ! Free memory for this spin.
6230 [ # # ]: 0 : ABI_FREE(emikr)
6231 [ # # ]: 0 : ABI_FREE(emiqr)
6232 [ # # ]: 0 : ABI_FREE(gww_pk)
6233 [ # # ]: 0 : ABI_FREE(gww_epq)
6234 : : end do ! my_is
6235 : :
6236 : : ! =====================
6237 : : ! Write data to GWAN.nc
6238 : : ! =====================
6239 [ # # ]: 0 : do spin=1,gstore%nsppol
6240 : 0 : my_is = gstore%spin2my_is(spin)
6241 [ # # ]: 0 : if (my_is /= 0) then
6242 : 0 : gqk => gstore%gqk(my_is)
6243 : : ! grpe_wwp has already been reduced over qpt_kpt_comm and is replicated
6244 : : ! across the q/k (and auxiliary sum/band) grid. Exactly one such slice
6245 : : ! must enter the writer; all ranks along its perturbation axis participate
6246 : : ! collectively because grpe_wwp remains distributed over perturbations.
6247 [ # # # # : 0 : if (all(gqk%coords_qkpb_sumbp([1,2,4,5,6]) == 0)) then
# # ]
6248 : 0 : call gqk%wan%ncwrite_gwan(dtfil, gstore%cryst, gstore%ebands, gqk%pert_comm)
6249 : : end if
6250 : : end if
6251 : 0 : call xmpi_barrier(gstore%comm)
6252 : : end do ! spin
6253 : :
6254 : 0 : call cwtime_report(" gstore_wannierize_and_write_gwan:", cpu, wall, gflops)
6255 : :
6256 [ # # ]: 0 : end subroutine gstore_wannierize_and_write_gwan
6257 : : !!***
6258 : :
6259 : : !!****f* m_gstore/handle_lr_term
6260 : : !! NAME
6261 : : !! handle_lr_term
6262 : : !!
6263 : : !! FUNCTION
6264 : : !! Add/Remove the long range term to/from the e-ph matrix elements.
6265 : : !!
6266 : : !! INPUTS
6267 : : !!
6268 : : !! SOURCE
6269 : :
6270 : : !subroutine handle_lr_term(cryst, qpt, ng, gvec, nwin_kq, nwin_k, nwan, u_kq, u_k, zeff, qstar, isgn, g_bb)
6271 : : !
6272 : : !!Arguments ------------------------------------
6273 : : ! type(crystal_t),intent(in) :: cryst
6274 : : ! real(dp),intent(in) :: qpt(3)
6275 : : ! integer,intent(in) :: ng, nwin_kq, nwin_k, nwan, isgn, gvec(3,ng)
6276 : : ! complex(dp),intent(in) :: u_kq(nwin_kq, nwan), u_k(nwin_k,nwan)
6277 : : ! real(dp),intent(in) :: zeff(3,3,cryst%natom), qstar(3,3,3,cryst%natom)
6278 : : ! complex(dp),intent(inout) :: g_bb(nwin_kq, nwin_k)
6279 : : !
6280 : : !!Local variables-------------------------------
6281 : : !!scalars
6282 : : ! !integer :: ig
6283 : : ! !character(len=500) :: msg
6284 : : !!arrays
6285 : : !! *************************************************************************
6286 : : !
6287 : : !end subroutine handle_lr_term
6288 : : !!***
6289 : :
6290 : : !----------------------------------------------------------------------
6291 : :
6292 : : !!****f* m_gstore/gqk_get_erange_mask
6293 : : !! NAME
6294 : : !! gqk_get_erange_mask
6295 : : !!
6296 : : !! FUNCTION
6297 : : !! Compute MPI-distributed and global masks for electronic states |n,k> allowed by erange.
6298 : : !!
6299 : : !! INPUTS
6300 : : !! gstore<gstore_t>=Electron-phonon object containing dimensions and related quantities.
6301 : : !! erange=Energy range:
6302 : : !! -- if both entries are negative, assume metal and include states within the
6303 : : !! [efermi-abs(erange(1)), efermi+abs(erange(2))] window;
6304 : : !! -- otherwise, erange(1) & erange(2) select window wrt VBM & CBM, respectively.
6305 : : !!
6306 : : !! OUTPUT
6307 : : !! my_states(gqk%nb_k, gqk%my_nk)=Mask for selected states at this MPI proc.
6308 : : !! glob_states(gqk%nb_k, gqk%my_nk)=Global mask for selected states.
6309 : : !!
6310 : : !! SOURCE
6311 : :
6312 : 0 : subroutine gqk_get_erange_mask(gqk, gstore, erange, my_states, glob_states)
6313 : :
6314 : : !Arguments ------------------------------------
6315 : : !scalars
6316 : : class(gqk_t), target, intent(inout) :: gqk
6317 : : class(gstore_t), target, intent(in) :: gstore
6318 : : !arrays
6319 : : real(dp), intent(in) :: erange(2)
6320 : : integer, intent(out) :: my_states(gqk%nb_k, gqk%my_nk), glob_states(gqk%nb_k, gqk%glob_nk)
6321 : :
6322 : : !Local variables-------------------------------
6323 : : !scalars
6324 : : class(ebands_t), pointer :: ebands
6325 : : type(gaps_t) :: gaps
6326 : : integer :: my_ik, ik_ibz, ik_glob, ib_k, bstart_k, gap_err, ierr
6327 : : real(dp) :: vmax, cmin, eig
6328 : : logical :: assume_gap
6329 : : !----------------------------------------------------------------------
6330 : :
6331 : 0 : ebands => gstore%ebands
6332 : :
6333 [ # # # # ]: 0 : assume_gap = .not. all(erange < tol12)
6334 : 0 : gaps = ebands%get_gaps(gap_err)
6335 : :
6336 [ # # ]: 0 : if (assume_gap) then
6337 [ # # ]: 0 : call gaps%print([std_out])
6338 : 0 : vmax = gaps%vb_max(gqk%spin) + tol2 * eV_Ha
6339 : 0 : cmin = gaps%cb_min(gqk%spin) - tol2 * eV_Ha
6340 : : else
6341 : 0 : vmax = ebands%fermie
6342 : 0 : cmin = ebands%fermie
6343 : : end if
6344 : :
6345 : : ! Fill the mask for allowed states
6346 [ # # # # ]: 0 : my_states(:,:) = 0
6347 [ # # # # ]: 0 : glob_states(:,:) = 0
6348 : 0 : bstart_k = gstore%brange_k_spin(1, gqk%spin)
6349 : :
6350 [ # # ]: 0 : do my_ik=1,gqk%my_nk
6351 : 0 : ik_ibz = gqk%my_k2ibz(1, my_ik)
6352 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
6353 : :
6354 [ # # ]: 0 : do ib_k=1,gqk%nb_k
6355 : 0 : eig = ebands%eig(bstart_k + ib_k - 1, ik_ibz, gqk%spin)
6356 : :
6357 [ # # ]: 0 : if (abs(erange(1)) > tol12) then
6358 : : ! Filter valence states.
6359 [ # # # # ]: 0 : if (eig <= vmax .and. vmax - eig <= abs(erange(1))) then
6360 : 0 : my_states(ib_k, my_ik) = 1; glob_states(ib_k, ik_glob) = 1
6361 : : end if
6362 : : end if
6363 : :
6364 [ # # ]: 0 : if (abs(erange(2)) > tol12) then
6365 : : ! Filter conduction states.
6366 [ # # # # ]: 0 : if (eig >= cmin .and. eig - cmin <= abs(erange(2))) then
6367 : 0 : my_states(ib_k, my_ik) = 1; glob_states(ib_k, ik_glob) = 1
6368 : : end if
6369 : : end if
6370 : :
6371 : : enddo
6372 : : enddo
6373 : :
6374 : 0 : call xmpi_sum(glob_states, gqk%kpt_comm%value, ierr)
6375 : 0 : call gaps%free()
6376 : :
6377 [ # # # # : 0 : end subroutine gqk_get_erange_mask
# # # # #
# # # # #
# # ]
6378 : : !!***
6379 : :
6380 : : !----------------------------------------------------------------------
6381 : :
6382 : : !!****f* m_gstore/gqk_filter_erange
6383 : : !! NAME
6384 : : !! gqk_filter_erange
6385 : : !!
6386 : : !! FUNCTION
6387 : : !! Nullify all matrix elements connecting electronic states excluded by energy range.
6388 : : !!
6389 : : !! INPUTS
6390 : : !! gstore<gstore_t>=Electron-phonon object containing dimensions and related quantities.
6391 : : !! erange=Energy range:
6392 : : !! -- if both entries are negative, assume metal and include states within the
6393 : : !! [efermi-abs(erange(1)), efermi+abs(erange(2))] window;
6394 : : !! -- otherwise, erange(1) & erange(2) select window wrt VBM & CBM, respectively.
6395 : : !!
6396 : : !! OUTPUT
6397 : : !!
6398 : : !! SOURCE
6399 : :
6400 : 0 : subroutine gqk_filter_erange(gqk, gstore, erange)
6401 : :
6402 : : !Arguments ------------------------------------
6403 : : !scalars
6404 : : class(gqk_t), target, intent(inout) :: gqk
6405 : : class(gstore_t), target, intent(in) :: gstore
6406 : : !arrays
6407 : : real(dp), intent(in) :: erange(2)
6408 : :
6409 : : !Local variables-------------------------------
6410 : : !scalars
6411 : : integer :: my_ik, ik_glob, my_iq, ikq, ipert, ierr, ib_k, jb_kq
6412 : : real(dp) :: wtq
6413 : : logical :: skip_nk, skip_mkq, skip_q
6414 : 0 : type(krank_t) :: krank_kpts
6415 : : type(ebands_t), pointer :: ebands
6416 : : !arrays
6417 : 0 : integer :: my_states(gqk%nb_k, gqk%my_nk), glob_states(gqk%nb_k, gqk%glob_nk)
6418 : 0 : real(dp) :: kpt(3), qpt(3), kpq(3), kpts(3, gqk%glob_nk), my_qpts(3, gqk%my_nq)
6419 : : !----------------------------------------------------------------------
6420 : :
6421 [ # # ]: 0 : ABI_CHECK_IEQ(gqk%nb_kq, gqk%nb_k, "nb_kq /= nk_k not tested")
6422 : :
6423 : 0 : ebands => gstore%ebands
6424 : :
6425 : : ! Compute masks
6426 : 0 : call gqk%get_erange_mask(gstore, erange, my_states, glob_states)
6427 : :
6428 : : ! Get global krank for k+q transitions
6429 [ # # # # ]: 0 : kpts(:, :) = zero
6430 [ # # ]: 0 : do my_ik=1,gqk%my_nk
6431 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
6432 [ # # ]: 0 : kpts(:, ik_glob) = gqk%my_kpts(:, my_ik)
6433 : : enddo
6434 : 0 : call xmpi_sum(kpts, gqk%kpt_comm%value, ierr)
6435 : :
6436 : 0 : call krank_kpts%from_kptrlatt(gqk%glob_nk, kpts, ebands%kptrlatt, compute_invrank=.True.)
6437 : :
6438 : : ! Get all q-points for this proc
6439 [ # # ]: 0 : do my_iq=1,gqk%my_nq
6440 : 0 : call gqk%myqpt(my_iq, gstore, wtq, my_qpts(:, my_iq))
6441 : : enddo
6442 : :
6443 : : ! Nullify matrix elements connecting the excluded states
6444 [ # # ]: 0 : do my_ik=1,gqk%my_nk
6445 [ # # ]: 0 : kpt(:) = gqk%my_kpts(:, my_ik)
6446 : :
6447 [ # # ]: 0 : do ib_k=1,gqk%nb_k
6448 : : ! |nk> is forbidden
6449 : 0 : skip_nk = .false.
6450 [ # # ]: 0 : if (my_states(ib_k, my_ik) == 0) skip_nk = .true.
6451 : :
6452 [ # # ]: 0 : do my_iq=1,gqk%my_nq
6453 [ # # ]: 0 : qpt(:) = my_qpts(:, my_iq)
6454 : :
6455 : : ! Find k+q --> k' index in krank_kpts
6456 [ # # ]: 0 : kpq(:) = kpt(:) + qpt(:)
6457 : 0 : ikq = krank_kpts%get_index(kpq)
6458 : :
6459 : : ! k+q falls outside the filtered kpts pool
6460 : 0 : skip_q = .false.
6461 [ # # ]: 0 : if (ikq == -1) skip_q = .true.
6462 : :
6463 [ # # ]: 0 : do jb_kq=1,gqk%nb_kq
6464 : : ! |mk+q> is forbidden
6465 : 0 : skip_mkq = .false.
6466 [ # # ]: 0 : if (glob_states(jb_kq, ikq) == 0) skip_mkq = .true.
6467 : :
6468 [ # # ]: 0 : do ipert=1,gqk%my_npert
6469 : :
6470 [ # # # # ]: 0 : if (skip_nk .or. skip_q .or. skip_mkq) then
6471 : 0 : select case (gqk%cplex)
6472 : : case (1)
6473 : 0 : gqk%my_g2(ipert, jb_kq, my_iq, ib_k, my_ik) = zero
6474 : : case (2)
6475 : 0 : gqk%my_g(ipert, jb_kq, my_iq, ib_k, my_ik) = czero
6476 : : case default
6477 [ # # # ]: 0 : ABI_ERROR(sjoin("Invalid gqk%cplex:", itoa(gqk%cplex)))
6478 : : end select
6479 : : end if
6480 : :
6481 : : enddo
6482 : : enddo
6483 : : enddo
6484 : : enddo
6485 : : enddo
6486 : :
6487 : 0 : call krank_kpts%free()
6488 : :
6489 [ # # # # : 0 : end subroutine gqk_filter_erange
# # ]
6490 : : !!***
6491 : :
6492 : : !----------------------------------------------------------------------
6493 : :
6494 : : !!****f* m_gstore/gstore_compute_and_write_ph
6495 : : !! NAME
6496 : : !! gstore_compute_and_write_ph
6497 : : !!
6498 : : !! FUNCTION
6499 : : !! Compute phonon frequencies and eigenvectors in the IBZ. Write results to disk
6500 : : !!
6501 : : !! SOURCE
6502 : :
6503 : 8 : subroutine gstore_compute_and_write_ph(gstore, root_ncid)
6504 : :
6505 : : !Arguments ------------------------------------
6506 : : !scalars
6507 : : class(gstore_t), intent(in) :: gstore
6508 : : integer,intent(in) :: root_ncid
6509 : :
6510 : : !Local variables-------------------------------
6511 : : !scalars
6512 : : integer :: natom, natom3, nproc, ii, iq_ibz, my_nqibz, iq_start, ncerr
6513 : : real(dp) :: cpu, wall, gflops
6514 : : !arrays
6515 : 8 : integer,allocatable :: my_iqibz_inds(:)
6516 : 8 : real(dp),allocatable :: buf_wqnu(:,:), buf_eigvec_cart(:,:,:,:,:), displ_cart_qibz(:,:,:,:)
6517 : : !----------------------------------------------------------------------
6518 : :
6519 : 8 : nproc = xmpi_comm_size(gstore%comm)
6520 : 8 : natom = gstore%cryst%natom; natom3 = 3 * natom
6521 : :
6522 : 8 : call wrtout(std_out, " Computing phonon frequencies and displacements in the IBZ ...", pre_newlines=1, do_flush=.True.)
6523 : 8 : call cwtime(cpu, wall, gflops, "start")
6524 : :
6525 : 8 : call xmpi_split_block(gstore%nqibz, gstore%comm, my_nqibz, my_iqibz_inds)
6526 [ - + + - : 32 : ABI_MALLOC(buf_wqnu, (natom3, my_nqibz))
- + + - +
- + - - +
- + ]
6527 [ - + + - : 40 : ABI_MALLOC(buf_eigvec_cart, (2, 3, natom, natom3, my_nqibz))
- + + - -
+ + - + -
+ - - + -
+ ]
6528 [ - + + - : 32 : ABI_MALLOC(displ_cart_qibz, (2, 3, natom, natom3))
- + + - +
- + - - +
- + ]
6529 : :
6530 [ - + ]: 8 : NCF_CHECK(nctk_prepare_mpiio(root_ncid, "phfreqs_ibz"))
6531 [ - + ]: 8 : NCF_CHECK(nctk_prepare_mpiio(root_ncid, "pheigvec_cart_ibz"))
6532 : :
6533 [ + + ]: 141 : do ii=1,my_nqibz
6534 : 133 : iq_ibz = my_iqibz_inds(ii)
6535 : : call gstore%ifc%fourq(gstore%cryst, gstore%qibz(:, iq_ibz), buf_wqnu(:,ii), displ_cart_qibz, &
6536 : 141 : out_eigvec=buf_eigvec_cart(:,:,:,:,ii))
6537 : : end do
6538 : :
6539 [ - + - - ]: 8 : if (nproc > 1 .and. gstore%nqibz >= nproc) then
6540 [ # # ]: 0 : NCF_CHECK(nctk_set_collective(root_ncid, root_vid("phfreqs_ibz")))
6541 [ # # ]: 0 : NCF_CHECK(nctk_set_collective(root_ncid, root_vid("pheigvec_cart_ibz")))
6542 : : end if
6543 : 8 : call xmpi_barrier(gstore%comm)
6544 : :
6545 [ + - ]: 8 : if (my_nqibz > 0) then
6546 : 8 : iq_start = my_iqibz_inds(1)
6547 : : ncerr = nf90_put_var(root_ncid, root_vid("phfreqs_ibz"), buf_wqnu, &
6548 [ + + + + ]: 40 : start=[1, iq_start], count=[natom3, my_nqibz])
6549 [ - + ]: 8 : NCF_CHECK(ncerr)
6550 : : ncerr = nf90_put_var(root_ncid, root_vid("pheigvec_cart_ibz"), buf_eigvec_cart, &
6551 [ + + + + ]: 88 : start=[1,1,1,1,iq_start], count=[2, 3, natom, natom3, my_nqibz])
6552 [ - + ]: 8 : NCF_CHECK(ncerr)
6553 : : end if
6554 : :
6555 [ - + ]: 8 : ABI_FREE(displ_cart_qibz)
6556 [ - + ]: 8 : ABI_FREE(my_iqibz_inds)
6557 [ - + ]: 8 : ABI_FREE(buf_wqnu)
6558 [ - + ]: 8 : ABI_FREE(buf_eigvec_cart)
6559 : 16 : call cwtime_report(" Phonon computation + output", cpu, wall, gflops)
6560 : :
6561 : : contains
6562 : :
6563 : 16 : integer function root_vid(var_name)
6564 : : character(len=*),intent(in) :: var_name
6565 : 16 : root_vid = nctk_idname(root_ncid, var_name)
6566 : : end function root_vid
6567 : :
6568 : : end subroutine gstore_compute_and_write_ph
6569 : : !!***
6570 : :
6571 : : !!****f* m_gstore/gstore_compute_and_write_vk
6572 : : !! NAME
6573 : : !! gstore_compute_and_write_vk
6574 : : !!
6575 : : !! FUNCTION
6576 : : !! Compute electronic group velocities in the IBZ.
6577 : : !! Write results to disk
6578 : : !!
6579 : : !! SOURCE
6580 : :
6581 : 8 : subroutine gstore_compute_and_write_vk(gstore, mpw, wfd, ebands, psps, pawtab, root_ncid)
6582 : :
6583 : : !Arguments ------------------------------------
6584 : : class(gstore_t), intent(in) :: gstore
6585 : : integer,intent(in) :: mpw
6586 : : type(wfd_t),intent(in) :: wfd
6587 : : type(ebands_t),target,intent(in) :: ebands
6588 : : type(pseudopotential_type),intent(in) :: psps
6589 : : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
6590 : : integer,intent(in) :: root_ncid
6591 : :
6592 : : !Local variables-------------------------------
6593 : : !scalars
6594 : : 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
6595 : : real(dp) :: cpu_kk, wall_kk, gflops_kk, eig0nk
6596 : : logical :: isirr_k
6597 [ + + + + : 80 : type(ddkop_t) :: ddkop
+ + ]
6598 : : !arrays
6599 : : integer :: g0_k(3)
6600 : 8 : integer,allocatable :: count_bk(:,:)
6601 : : real(dp) :: kk(3) !, kk_ibz(3)
6602 : 16 : real(dp),allocatable :: vnk_cart_ibz(:,:,:), cg_work(:,:)
6603 : 8 : type(pawcprj_type),allocatable :: cwaveprj0(:,:)
6604 : : !----------------------------------------------------------------------
6605 : :
6606 : 8 : call wrtout(std_out, " computing and writing velocity operator matrix elements in the ibz")
6607 : 8 : call wrtout(std_out, " note that not all the k-points in the ibz are computed when kfilter is activated!")
6608 : 8 : call cwtime(cpu_kk, wall_kk, gflops_kk, "start")
6609 : :
6610 : : ! On disk, we have:
6611 : : ! nctkarr_t("vk_cart_ibz", "dp", "three, nb_k, gstore_nkibz"))
6612 : : ! nctkarr_t("vkmat_cart_ibz", "dp", "two, three, nb, nb, gstore_nkibz")))
6613 : :
6614 : 8 : call ddkop%init(gstore%dtset, gstore%cryst, pawtab, psps, wfd%mpi_enreg, mpw, wfd%ngfft)
6615 [ - + + - : 24 : ABI_MALLOC(cg_work, (2, mpw*wfd%nspinor))
+ - + - -
+ - + ]
6616 : :
6617 : 8 : usecprj = gstore%dtset%usepaw
6618 [ - + + - : 32 : ABI_MALLOC(cwaveprj0, (gstore%cryst%natom, wfd%nspinor*usecprj))
+ - - - +
- - + - +
- + - + -
- ]
6619 : :
6620 [ + + ]: 16 : do my_is=1,gstore%my_nspins
6621 : 8 : associate (gqk => gstore%gqk(my_is))
6622 : 8 : spin = gstore%my_spins(my_is); nb_k = gqk%nb_k; nb_kq = gqk%nb_kq
6623 : :
6624 : : ! Be careful as wavefunctions might be replicated.
6625 : : ! Use count_bk to count how many states have been computed in parallel in order to rescale the results.
6626 : 8 : if (gstore%with_vk == 1) then
6627 [ - + + - : 1285 : ABI_CALLOC(vnk_cart_ibz, (3, nb_k, gstore%nkibz))
- + + - +
- + - - +
- + - + +
+ + + +
+ ]
6628 [ - + + - : 445 : ABI_ICALLOC(count_bk, (nb_k, gstore%nkibz))
- + + - +
- + - - +
- + - + +
+ + + ]
6629 : : else
6630 : 0 : ABI_ERROR("gstore%with_vk 2 not implemented")
6631 : : end if
6632 : :
6633 [ - + ]: 8 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6634 [ - + ]: 8 : NCF_CHECK(nctk_prepare_mpiio(spin_ncid, "vk_cart_ibz"))
6635 : :
6636 [ + + ]: 319 : do my_ik=1,gqk%my_nk
6637 : : ! The k-point and the symmetries relating the BZ k-point to the IBZ.
6638 [ + + ]: 1244 : kk = gqk%my_kpts(:, my_ik)
6639 : 311 : ik_ibz = gqk%my_k2ibz(1, my_ik) ; isym_k = gqk%my_k2ibz(2, my_ik)
6640 [ + + ]: 1244 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5,my_ik)
6641 [ + + + + : 1149 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
+ + + - ]
6642 : : if (.not. isirr_k) cycle
6643 : :
6644 : : ! parallelize inside (q, pert) so that only one proc in the 3D grid
6645 : : ! computes v_nk for this kpt in the BZ and we can use xmpi_sum_master.
6646 : : !cnt = cnt + 1
6647 : : !if (gqk%qpt_pert_comm%skip(cnt)) cycle
6648 : :
6649 : 36 : npw_k = wfd%npwarr(ik_ibz); istwf_k = wfd%istwfk(ik_ibz)
6650 : 36 : call ddkop%setup_spin_kpoint(gstore%dtset, gstore%cryst, psps, spin, kk, istwf_k, npw_k, wfd%kdata(ik_ibz)%kg_k)
6651 : :
6652 [ + + ]: 150 : do band=gqk%bstart_k, gqk%bstop_k
6653 : 106 : call wfd%copy_cg(band, ik_ibz, spin, cg_work)
6654 : 106 : eig0nk = ebands%eig(band, ik_ibz, spin)
6655 : 106 : in_k = band - gqk%bstart_k + 1
6656 : 106 : vnk_cart_ibz(:, in_k, ik_ibz) = ddkop%get_vdiag(eig0nk, istwf_k, npw_k, wfd%nspinor, cg_work, cwaveprj0)
6657 : 142 : count_bk(in_k, ik_ibz) = count_bk(in_k, ik_ibz) + 1
6658 : : end do
6659 : : end do ! my_ik
6660 : :
6661 : 8 : call xmpi_sum(count_bk, gqk%comm%value, ierr)
6662 : 8 : call xmpi_sum(vnk_cart_ibz, gqk%comm%value, ierr)
6663 : :
6664 [ + + ]: 141 : do ik_ibz=1, gstore%nkibz
6665 [ + + ]: 421 : do band=gqk%bstart_k, gqk%bstop_k
6666 : 280 : in_k = band - gqk%bstart_k + 1
6667 [ + + ]: 280 : if (count_bk(in_k, ik_ibz) == 0) cycle
6668 [ + + ]: 557 : do ii=1,3
6669 : 598 : vnk_cart_ibz(ii,in_k,ik_ibz) = vnk_cart_ibz(ii,in_k,ik_ibz) / count_bk(in_k, ik_ibz)
6670 : : end do
6671 : : end do
6672 : : end do
6673 : :
6674 : : ! Write v_nk to disk.
6675 : : !if (gqk%comm%me == master) then
6676 [ - + ]: 8 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("vk_cart_ibz"), vnk_cart_ibz))
6677 : : !end if
6678 : :
6679 [ - + ]: 8 : ABI_FREE(vnk_cart_ibz)
6680 [ + - - + ]: 16 : ABI_FREE(count_bk)
6681 : : end associate
6682 : : end do ! my_is
6683 : :
6684 [ - + ]: 8 : ABI_FREE(cg_work)
6685 : 8 : call ddkop%free()
6686 : :
6687 : 8 : call pawcprj_free(cwaveprj0)
6688 [ + - - + : 8 : ABI_FREE(cwaveprj0)
- - - - -
+ ]
6689 : :
6690 [ - + + + : 96 : call cwtime_report(sjoin(" Computation of v_k group velocities with with_vk:", itoa(gstore%with_vk)), cpu_kk, wall_kk, gflops_kk)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + + +
- + - + +
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + ]
6691 : :
6692 : : contains
6693 : :
6694 : 8 : integer function spin_vid(var_name)
6695 : : character(len=*),intent(in) :: var_name
6696 : 8 : spin_vid = nctk_idname(spin_ncid, var_name)
6697 : : end function spin_vid
6698 : :
6699 : : end subroutine gstore_compute_and_write_vk
6700 : : !!***
6701 : :
6702 : : !!****f* m_gstore/gstore_compute_and_write_commutator
6703 : : !! NAME
6704 : : !! gstore_compute_and_write_commutator
6705 : : !!
6706 : : !! FUNCTION
6707 : : !! Compute matrix elements i <psi_mk|[V1_q0ka, p]|psi_nk> in the full BZ in reduced coordinates.
6708 : : !! Write results to disk.
6709 : : !! See [[cite:Lihm2020]], PhysRevB.101.121102
6710 : : !!
6711 : : !! SOURCE
6712 : :
6713 : 0 : subroutine gstore_compute_and_write_commutator(gstore, mpw, gmax, ngfft, ngfftf, dtset, cryst, pawfgr, psps, &
6714 : 0 : wfd, mpi_enreg, kg_k, ebands, dvdb, gs_ham_kq, root_ncid)
6715 : :
6716 : : !Arguments ------------------------------------
6717 : : class(gstore_t), intent(in) :: gstore
6718 : : integer,intent(in) :: gmax(3), mpw
6719 : : integer,intent(in) :: ngfft(18),ngfftf(18)
6720 : : type(dvdb_t),intent(inout) :: dvdb
6721 : : type(gs_hamiltonian_type),intent(inout) :: gs_ham_kq
6722 : : type(dataset_type),intent(in) :: dtset
6723 : : type(crystal_t),intent(in) :: cryst
6724 : : type(wfd_t),intent(in) :: wfd
6725 : : type(mpi_type),intent(in) :: mpi_enreg
6726 : : type(ebands_t),intent(in) :: ebands
6727 : : type(pawfgr_type),intent(in) :: pawfgr
6728 : : type(pseudopotential_type),intent(in) :: psps
6729 : : integer,intent(in) :: root_ncid
6730 : : !arrays
6731 : : integer,intent(inout) :: kg_k(3,mpw)
6732 : :
6733 : : !Local variables-------------------------------
6734 : : !scalars
6735 : : integer,parameter :: tim_getgh1c = 1, berryopt0 = 0, master = 0
6736 : : 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,
6737 : : integer :: cplex, db_iqpt, idir, ipert, ipc, my_ip, natom, natom3, n1, n2, n3, n4, n5, n6, nsppol, nspinor, nspden
6738 : : integer :: nfft, nfftf, mgfftf, my_npert, nkpg_k, band_k !, glob_nk mgfft,
6739 : : integer :: sij_opt,usecprj,usevnl,optlocal,optnl,opt_gvnlx1, ncerr, ik_glob, ierr
6740 : : real(dp) :: cpu_kk, wall_kk, gflops_kk
6741 : : logical :: gen_eigenpb
6742 : 0 : type(rf_hamiltonian_type) :: rf_ham_kq
6743 : : !arrays
6744 : : integer :: units(2), work_ngfft(18) ! g0_k(3)
6745 : : !integer,allocatable :: count_bk(:,:)
6746 : : real(dp) :: kk_ibz(3), kk_bz(3), gamma_point(3)
6747 : 0 : real(dp),allocatable :: v1scf(:,:,:,:), work(:,:,:,:), p_kets_k(:,:,:,:), gs1c_kq(:,:), dmat(:,:,:,:)
6748 : 0 : real(dp),allocatable :: kets_k(:,:,:), h1_kets_kq(:,:,:), iv1p_comm(:,:,:,:,:)
6749 : 0 : real(dp),allocatable :: ffnl_k(:,:,:,:), ph3d_k(:,:,:), grad_berry(:,:), kinpw_k(:), kpg_k(:,:)
6750 : 0 : real(dp),allocatable :: vlocal(:,:,:,:), vlocal1(:,:,:,:,:), dummy_vtrial(:,:), gvnlx1(:,:,:), lambda(:)
6751 : 0 : type(pawcprj_type),allocatable :: cwaveprj0(:,:)
6752 : : !----------------------------------------------------------------------
6753 : :
6754 [ # # ]: 0 : units = [std_out, ab_out]
6755 : 0 : call wrtout(units, " Computing and writing i <psi_mk| [V1, p]| psi_nk> ...")
6756 : 0 : call cwtime(cpu_kk, wall_kk, gflops_kk, "start")
6757 : :
6758 : : ! Copy important dimensions
6759 : 0 : natom = cryst%natom; natom3 = 3 * natom; nsppol = ebands%nsppol; nspinor = ebands%nspinor; nspden = dtset%nspden
6760 : :
6761 : 0 : n1 = ngfftf(1); n2 = ngfftf(2); n3 = ngfftf(3); n4 = ngfftf(4); n5 = ngfftf(5); n6 = ngfftf(6)
6762 [ # # ]: 0 : nfftf = product(ngfftf(1:3)); mgfftf = maxval(ngfftf(1:3))
6763 : :
6764 : 0 : call ngfft_seq(work_ngfft, gmax)
6765 [ # # # # : 0 : ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
# # # # #
# # # # #
# # # # #
# ]
6766 : :
6767 : : ! Read the dvscf potentials at qq=Gamma for all 3*natom perturbations.
6768 : : ! This call allocates v1scf(cplex, nfftf, nspden, 3*natom)
6769 : 0 : gamma_point(:) = zero; db_iqpt = dvdb%findq(gamma_point)
6770 : 0 : call dvdb%readsym_allv1(db_iqpt, cplex, nfftf, ngfftf, v1scf, gstore%comm)
6771 [ # # ]: 0 : ABI_CHECK_IEQ(cplex, 1, "cplex should be zero when q == 0")
6772 : :
6773 : : ! Allocate vlocal. Note nvloc
6774 : : ! I set vlocal to huge to trigger possible bugs (DFPT routines should not access the data)
6775 : 0 : usecprj = gstore%dtset%usepaw
6776 [ # # # # : 0 : ABI_MALLOC(vlocal, (n4, n5, n6, gs_ham_kq%nvloc))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
6777 [ # # # # : 0 : vlocal = huge(one)
# # # # ]
6778 [ # # # # : 0 : ABI_CALLOC(dummy_vtrial, (nfftf, nspden))
# # # # #
# # # # #
# # # # #
# ]
6779 [ # # # # : 0 : ABI_MALLOC(cwaveprj0, (gstore%cryst%natom, wfd%nspinor*usecprj))
# # # # #
# # # # #
# # # # #
# # # ]
6780 : :
6781 : : ! Prepare call to getgh1c
6782 : 0 : usevnl = 0
6783 : 0 : optlocal = 1 ! local part of H^(1) is computed in gh1c=<G|H^(1)|C>
6784 : 0 : optnl = 2 ! non-local part of H^(1) is totally computed in gh1c=<G|H^(1)|C>
6785 : 0 : opt_gvnlx1 = 0 ! gvnlx1 is output
6786 : :
6787 [ # # ]: 0 : ABI_MALLOC(grad_berry, (2, nspinor*(berryopt0/4)))
6788 : :
6789 : : ! Since v1(q=0) and p are Hermitian operators, we have:
6790 : : !
6791 : : ! i <psi_mk| [v1, p] |psi_nk> = i <v1 psi_mk | p psi_nk> -i <p psi_mk | v1 psi_nk>
6792 : : !
6793 : : ! Note that in the present implementation both m and n indices run from bstart_k to bstop_k.
6794 : :
6795 : : ! if PAW, one has to solve a generalized eigenproblem
6796 [ # # ]: 0 : gen_eigenpb = psps%usepaw == 1; sij_opt = 0; if (gen_eigenpb) sij_opt = 1
6797 : :
6798 : : ! Define netcdf arrays inside the spin group.
6799 [ # # ]: 0 : do spin=1, nsppol
6800 [ # # ]: 0 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6801 : : ncerr = nctk_def_arrays(spin_ncid, [ &
6802 : : nctkarr_t("iv1p_comm", "dp", "two, nb_k, nb_k, three, natom3, glob_nk") &
6803 [ # # ]: 0 : ], defmode=.True.)
6804 [ # # ]: 0 : NCF_CHECK(ncerr)
6805 : :
6806 [ # # ]: 0 : NCF_CHECK(nf90_def_var_fill(spin_ncid, spin_vid("iv1p_comm"), NF90_FILL, -huge(one)))
6807 [ # # ]: 0 : NCF_CHECK(nctk_set_datamode(spin_ncid))
6808 : : end do
6809 : : !NCF_CHECK(nctk_set_datamode(root_ncid))
6810 : :
6811 [ # # ]: 0 : do my_is=1,gstore%my_nspins
6812 : 0 : associate (gqk => gstore%gqk(my_is))
6813 : 0 : spin = gstore%my_spins(my_is); nb_k = gqk%nb_k; nb_kq = gqk%nb_kq; my_npert = gqk%my_npert
6814 : :
6815 : : ! Be careful as wavefunctions might be replicated.
6816 : : ! Use count_bk to count how many states have been computed in parallel in order to rescale the results.
6817 : : !ABI_ICALLOC(count_bk, (nb_k, gstore%nkibz))
6818 [ # # ]: 0 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6819 [ # # ]: 0 : NCF_CHECK(nctk_prepare_mpiio(spin_ncid, "iv1p_comm"))
6820 : :
6821 : : ! Allocate vlocal1 with correct cplex. Note nvloc and my_npert.
6822 [ # # # # : 0 : ABI_MALLOC(vlocal1, (cplex*n4, n5, n6, gs_ham_kq%nvloc, my_npert))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
6823 [ # # # # : 0 : ABI_MALLOC(lambda, (nb_k))
# # # # #
# # # ]
6824 : :
6825 [ # # # # : 0 : ABI_CALLOC(iv1p_comm, (2, nb_k, nb_k, 3, natom3))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # #
# ]
6826 [ # # # # : 0 : ABI_MALLOC(dmat, (2, nb_k, nb_k, 3))
# # # # #
# # # # #
# # ]
6827 : :
6828 : : ! Set up local potential vlocal1 with proper dimensioning from vtrial1 taking into account the spin.
6829 : : ! Note that here v1scf contains all 3 natom perturbations as we called dvdb%readsym_allv1.
6830 [ # # ]: 0 : do my_ip=1,my_npert
6831 : 0 : idir = dvdb%my_pinfo(1, my_ip); ipert = dvdb%my_pinfo(2, my_ip); ipc = dvdb%my_pinfo(3, my_ip)
6832 : : call rf_transgrid_and_pack(spin, nspden, psps%usepaw, cplex, nfftf, nfft, ngfft, gs_ham_kq%nvloc,&
6833 : 0 : pawfgr, mpi_enreg, dummy_vtrial, v1scf(:,:,:,ipc), vlocal, vlocal1(:,:,:,:,my_ip))
6834 : : end do
6835 : :
6836 : : ! Continue to initialize the GS Hamiltonian
6837 : 0 : call gs_ham_kq%load_spin(spin, vlocal=vlocal, with_nonlocal=.true.)
6838 : :
6839 [ # # ]: 0 : do my_ik=1,gqk%my_nk
6840 : : ! Parallelism inside q-point communicator.
6841 [ # # ]: 0 : if (gqk%qpt_comm%skip(my_ik)) cycle
6842 : :
6843 : : ! The k-point and the symmetries relating the BZ k-point to the IBZ.
6844 [ # # ]: 0 : kk_bz = gqk%my_kpts(:, my_ik)
6845 : 0 : ik_ibz = gqk%my_k2ibz(1, my_ik)
6846 [ # # ]: 0 : kk_ibz = ebands%kptns(:,ik_ibz)
6847 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
6848 : :
6849 : : ! Get npw_k, kg_k and symmetrize wavefunctions from the IBZ (if needed).
6850 : : call wfd%sym_ug_kg_npw(dtset%ecut, kk_bz, kk_ibz, gqk%bstart_k, nb_k, spin, gqk%my_k2ibz(:, my_ik), cryst, &
6851 [ # # ]: 0 : work_ngfft, work, istwf_k, npw_k, kg_k, kets_k)
6852 : :
6853 : : call gs_ham_kq%eph_setup_k("k", kk_bz, istwf_k, npw_k, kg_k, dtset, cryst, psps, & ! in
6854 [ # # # # : 0 : nkpg_k, kpg_k, ffnl_k, kinpw_k, ph3d_k, gqk%pert_comm%value) ! out
# # # # ]
6855 : :
6856 : 0 : npwsp_k = npw_k * nspinor
6857 [ # # # # : 0 : ABI_MALLOC(h1_kets_kq, (2, npwsp_k, nb_k))
# # # # #
# # # # #
# # ]
6858 [ # # # # : 0 : ABI_MALLOC(gs1c_kq, (2, npwsp_k*nb_k*((sij_opt+1)/2)))
# # # # #
# # # ]
6859 [ # # # # : 0 : ABI_MALLOC(gvnlx1, (2, npwsp_k,nb_k))
# # # # #
# # # ]
6860 : :
6861 : : ! Compute <g|-i\Nabla |psi_nk>.
6862 [ # # # # : 0 : ABI_MALLOC(p_kets_k, (2, npwsp_k, nb_k, 3))
# # # # #
# # # # #
# # # # ]
6863 : 0 : call cg_p_psi(npw_k, nspinor, nb_k, kk_bz, kg_k, kets_k, p_kets_k)
6864 : :
6865 [ # # # # : 0 : iv1p_comm = zero
# # # # #
# ]
6866 [ # # ]: 0 : do my_ip=1,my_npert
6867 : 0 : idir = dvdb%my_pinfo(1, my_ip); ipert = dvdb%my_pinfo(2, my_ip); ipc = dvdb%my_pinfo(3, my_ip)
6868 : :
6869 : : ! Prepare application of the NL part.
6870 : 0 : call rf_ham_kq%init(cplex, gs_ham_kq, ipert, has_e1kbsc=.true.)
6871 : 0 : call rf_ham_kq%load_spin(spin, vlocal1=vlocal1(:,:,:,:,my_ip), with_nonlocal=.true.)
6872 : :
6873 [ # # ]: 0 : do in_k=1,nb_k
6874 : : ! Use scissor shift on 0-order eigenvalue
6875 : 0 : band_k = in_k + gqk%bstart_k - 1
6876 : 0 : lambda(in_k) = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
6877 : : end do
6878 : : !call ebands%get_dfpt_eshifted(gqk%bstart_k, nb_k, ik_ibz, spin, dtset%dfpt_sciss, lambda)
6879 : :
6880 : : ! Calculate dvscf * psi_k, results stored in h1_kets_kq on the k+q sphere.
6881 : : ! Compute H(1) applied to GS wavefunction Psi(0).
6882 : : call getgh1c(berryopt0, kets_k, cwaveprj0, h1_kets_kq, &
6883 : : grad_berry, gs1c_kq, gs_ham_kq, gvnlx1, idir, ipert, lambda, mpi_enreg, nb_k, optlocal, &
6884 : 0 : optnl, opt_gvnlx1, rf_ham_kq, sij_opt, tim_getgh1c, usevnl)
6885 : :
6886 : 0 : call rf_ham_kq%free()
6887 : :
6888 : : ! Here we compute: i <u_mk| [v1, p] u_nk> = i <v1 u_mk | p u_nk> -i <p u_mk | v1 u_nk>
6889 : : ! p_kets_k(:, npwsp_k, nb_k, 3)
6890 : : ! h1_kets_kq, (2, npw_k*nspinor, nb_k))
6891 [ # # # # : 0 : dmat = zero
# # # # ]
6892 [ # # ]: 0 : do ii=1,3
6893 : : call ZGEMM('C', 'N', nb_k, nb_k, npwsp_k, j_dpc, h1_kets_kq, npwsp_k, &
6894 : 0 : p_kets_k(:,:,:,ii), npwsp_k, cone, dmat(:,:,:,ii), nb_k)
6895 : :
6896 : : call ZGEMM('C', 'N', nb_k, nb_k, npwsp_k, -j_dpc, p_kets_k(:,:,:,ii), npwsp_k, &
6897 : 0 : h1_kets_kq, npwsp_k, cone, dmat(:,:,:,ii), nb_k)
6898 : : end do
6899 : :
6900 [ # # # # : 0 : iv1p_comm(:,:,:,:,ipc) = dmat
# # # # ]
6901 : : end do ! my_ip
6902 : :
6903 : 0 : call xmpi_sum(iv1p_comm, gqk%pert_comm%value, ierr)
6904 [ # # ]: 0 : if (gqk%pert_comm%me == 0) then
6905 [ # # # # : 0 : NCF_CHECK(nf90_put_var(spin_ncid, spin_vid("iv1p_comm"), iv1p_comm, start=[1,1,1,1,1,ik_glob]))
# # ]
6906 : : end if
6907 : :
6908 [ # # ]: 0 : ABI_FREE(ffnl_k)
6909 [ # # ]: 0 : ABI_FREE(kinpw_k)
6910 [ # # ]: 0 : ABI_FREE(ph3d_k)
6911 [ # # ]: 0 : ABI_FREE(kpg_k)
6912 [ # # ]: 0 : ABI_FREE(kets_k)
6913 [ # # ]: 0 : ABI_FREE(p_kets_k)
6914 [ # # ]: 0 : ABI_FREE(gs1c_kq)
6915 [ # # ]: 0 : ABI_FREE(h1_kets_kq)
6916 [ # # ]: 0 : ABI_FREE(gvnlx1)
6917 : : end do ! my_ik
6918 : :
6919 [ # # ]: 0 : ABI_FREE(vlocal1)
6920 [ # # ]: 0 : ABI_FREE(lambda)
6921 [ # # ]: 0 : ABI_FREE(dmat)
6922 : :
6923 : : !call xmpi_sum(count_bk, gqk%comm%value, ierr)
6924 : :
6925 : : !do ik_ibz=1, gstore%nkibz
6926 : : ! do band=gqk%bstart_k, gqk%bstop_k
6927 : : ! in_k = band - gqk%bstart_k + 1
6928 : : ! if (count_bk(in_k, ik_ibz) == 0) cycle
6929 : : ! do ii=1,3
6930 : : ! vnk_cart_ibz(ii,in_k,ik_ibz) = vnk_cart_ibz(ii,in_k,ik_ibz) / count_bk(in_k, ik_ibz)
6931 : : ! end do
6932 : : ! end do
6933 : : !end do
6934 : : !ABI_FREE(count_bk)
6935 : :
6936 [ # # ]: 0 : ABI_FREE(iv1p_comm)
6937 : : end associate
6938 : : end do ! my_is
6939 : :
6940 [ # # ]: 0 : ABI_FREE(vlocal)
6941 [ # # ]: 0 : ABI_FREE(dummy_vtrial)
6942 [ # # ]: 0 : ABI_FREE(v1scf)
6943 [ # # ]: 0 : ABI_FREE(work)
6944 [ # # ]: 0 : ABI_FREE(grad_berry)
6945 : :
6946 : 0 : call pawcprj_free(cwaveprj0)
6947 [ # # # # : 0 : ABI_FREE(cwaveprj0)
# # # # #
# ]
6948 : :
6949 : 0 : call xmpi_barrier(gstore%comm)
6950 [ # # # # : 0 : call cwtime_report(" Computation of commutator:", cpu_kk, wall_kk, gflops_kk)
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
6951 : :
6952 : : contains
6953 : :
6954 : 0 : integer function spin_vid(var_name)
6955 : : character(len=*),intent(in) :: var_name
6956 : 0 : spin_vid = nctk_idname(spin_ncid, var_name)
6957 : : end function spin_vid
6958 : :
6959 : : end subroutine gstore_compute_and_write_commutator
6960 : : !!***
6961 : :
6962 : : !!****f* m_gstore/gstore_nc_has_iv1p_comm
6963 : : !! NAME
6964 : : !! gstore_nc_has_iv1p_comm
6965 : : !!
6966 : : !! FUNCTION
6967 : : !! Return True if GSTORE.nc contains commutator matrix elements.
6968 : : !!
6969 : : !! SOURCE
6970 : :
6971 : 24 : logical function gstore_nc_has_iv1p_comm(gstore, root_ncid) result (has_iv1p_comm)
6972 : :
6973 : : !Arguments ------------------------------------
6974 : : class(gstore_t),target, intent(in) :: gstore
6975 : : integer,intent(in) :: root_ncid
6976 : :
6977 : : !Local variables-------------------------------
6978 : : integer :: spin, ncerr, spin_ncid, varid
6979 : : ! *************************************************************************
6980 : :
6981 : 24 : has_iv1p_comm = .True.
6982 [ + - ]: 24 : do spin=1,gstore%nsppol
6983 [ - + ]: 24 : NCF_CHECK(nf90_inq_ncid(root_ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
6984 : 24 : ncerr = nf90_inq_varid(spin_ncid, "iv1p_comm", varid)
6985 [ - + ]: 24 : if (ncerr /= nf90_noerr) then
6986 : : has_iv1p_comm = .False.; exit
6987 : : end if
6988 : : end do
6989 : :
6990 : 24 : end function gstore_nc_has_iv1p_comm
6991 : : !!***
6992 : :
6993 : : !!****f* m_gstore/gstore_read_gtype
6994 : : !! NAME
6995 : : !! gstore_read_gtype
6996 : : !!
6997 : : !! FUNCTION
6998 : : !! Read the value of "gstore_gtype" from the NetCDF file.
6999 : : !! Only the master process reads the value and broadcasts it to all processes in comm.
7000 : : !!
7001 : : !! INPUTS
7002 : : !! ncid: NetCDF file ID (open for reading).
7003 : : !! comm: MPI communicator.
7004 : : !!
7005 : : !! OUTPUTS
7006 : : !! gtype: The value of gstore_gtype read from the file.
7007 : : !!
7008 : : !! SOURCE
7009 : :
7010 : 7 : subroutine gstore_read_gtype(path, gtype, comm, &
7011 [ - + - - : 7 : brange_k_spin, brange_kq_spin) ! optional
- - - + -
- - - ]
7012 : :
7013 : : !Arguments ------------------------------------
7014 : : character(len=*), intent(in) :: path
7015 : : character(len=abi_slen), intent(out) :: gtype
7016 : : integer, intent(in) :: comm
7017 : : integer,optional,intent(out) :: brange_k_spin(:,:)
7018 : : integer,optional,intent(out) :: brange_kq_spin(:,:)
7019 : :
7020 : : !Local variables-------------------------------
7021 : : integer, parameter :: master = 0
7022 : : integer :: my_rank, nproc, ierr, varid, ncerr, ncid
7023 : : ! *************************************************************************
7024 : :
7025 : 7 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
7026 : :
7027 [ + - ]: 7 : if (my_rank == master) then
7028 [ - + ]: 7 : NCF_CHECK(nf90_open(path, nf90_nowrite, ncid))
7029 : 7 : gtype = GSTORE_GTYPE_KS
7030 : 7 : ncerr = nf90_inq_varid(ncid, "gstore_gtype", varid)
7031 [ + - ]: 7 : if (ncerr == nf90_noerr) then
7032 [ - + ]: 7 : NCF_CHECK(nf90_get_var(ncid, varid, gtype))
7033 : 7 : call replace_ch0(gtype)
7034 : : end if
7035 [ - + ]: 7 : if (present(brange_k_spin)) then
7036 [ # # ]: 0 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_k_spin"), brange_k_spin))
7037 : : end if
7038 [ - + ]: 7 : if (present(brange_kq_spin)) then
7039 [ # # ]: 0 : NCF_CHECK(nf90_get_var(ncid, vid("gstore_brange_kq_spin"), brange_kq_spin))
7040 : : end if
7041 [ - + ]: 7 : NCF_CHECK(nf90_close(ncid))
7042 : : end if
7043 : :
7044 [ - + ]: 7 : if (nproc > 1) then
7045 : 0 : call xmpi_bcast(gtype, master, comm, ierr)
7046 [ # # ]: 0 : if (present(brange_k_spin)) call xmpi_bcast(brange_k_spin, master, comm, ierr)
7047 [ # # ]: 0 : if (present(brange_kq_spin)) call xmpi_bcast(brange_kq_spin, master, comm, ierr)
7048 : : end if
7049 : :
7050 : : contains
7051 : :
7052 : 0 : integer function vid(var_name)
7053 : : character(len=*),intent(in) :: var_name
7054 : 0 : vid = nctk_idname(ncid, var_name)
7055 : : end function vid
7056 : :
7057 : : end subroutine gstore_read_gtype
7058 : : !!***
7059 : :
7060 : : !----------------------------------------------------------------------
7061 : :
7062 : : !!****f* m_gstore/gstore_symmetrize
7063 : : !! NAME
7064 : : !! gstore_symmetrize
7065 : : !!
7066 : : !! FUNCTION
7067 : : !! Reconstruct the electron-phonon matrix elements g(k,q) in the full
7068 : : !! Brillouin Zone (BZ) using the values stored in the IBZ for k and the IBZ_k for q.
7069 : : !! Uses the NetCDF API for in-place modification of the GSTORE file
7070 : : !! and wfd_t to fetch wavefunctions and compute unitary matrices.
7071 : : !!
7072 : : !! SOURCE
7073 : :
7074 : 0 : subroutine gstore_symmetrize(gstore_path, wfk_path, ngfft, dtset, dtfil, cryst, psps, pawtab, ebands, ifc, comm)
7075 : :
7076 : : !Arguments ------------------------------------
7077 : : !scalars
7078 : : character(len=*),intent(in) :: gstore_path
7079 : : character(len=*),intent(in) :: wfk_path
7080 : : integer,intent(in) :: ngfft(18)
7081 : : type(dataset_type),intent(in) :: dtset
7082 : : type(datafiles_type),intent(in) :: dtfil
7083 : : class(crystal_t),target,intent(in) :: cryst
7084 : : class(ebands_t),target,intent(in) :: ebands
7085 : : class(ifc_type),target,intent(in) :: ifc
7086 : : type(pseudopotential_type),intent(in) :: psps
7087 : : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
7088 : : integer,intent(in) :: comm
7089 : :
7090 : : !Local variables-------------------------------
7091 : : !scalars
7092 : : integer :: with_cplex, my_is, spin, my_ik, my_iq, ik_glob, iq_glob, units(2)
7093 : : integer :: ncid, spin_ncid, nprocs, my_rank, ncerr, this_state, ierr
7094 : : integer :: nb, nkbz, nkibz, nqbz, nqibz, nsym, itime_k
7095 : : integer :: ik_ibz, isym_k, trev_k, tsign_k, g0_k(3), g0_q(3)
7096 : : integer :: ik_ibz_file, isym_lg, itime_lg, isym_combined, c1_gs, n_gv, igv
7097 : : integer :: n_lg, ii_lg, tsign_lg !, isym_lg, itime_lg,
7098 : : integer :: idir, iat, idir_eq, iat_eq, mu, mu_eq, iq_sym
7099 : : integer :: symrec_eq(3,3), symrec_eq_kspace(3,3), l0(3), mat_tmp(3,3)
7100 : : real(dp) :: weight_qq, phase
7101 : : complex(dp) :: cphase
7102 : : logical :: with_g2dw, isirr_k, found_lg
7103 : : character(len=abi_slen) :: with_gmode, gtype, gvals_name, gv_names(2)
7104 : : character(len=5000) :: msg
7105 [ # # ]: 0 : type(gstore_t) :: gstore
7106 : 0 : type(dmats_t) :: dmats
7107 : : integer :: isym_kqS, isym_kqT, ikq_ibz_s, ikq_ibz_t, h_isym, itime_h, h_isym_inv, trev_kqS, trev_kqT
7108 : : integer :: indkk_s(6,1), indkk_t(6,1)
7109 : : real(dp) :: L_h_gs(3), kq_ibz_pt(3)
7110 : : complex(dp) :: phase_h_gs, phase_ket_gs
7111 : : logical,parameter :: DEBUG_DUMP_DH = .False.
7112 : : real(dp) :: kk_lg_test(3)
7113 : : !!arrays
7114 : 0 : integer :: brange_kq_spin(2, dtset%nsppol)
7115 : 0 : integer,allocatable :: state_kq(:,:), kibz2bz(:) !, qibz2bz(:), qglob2bz(:,:), ! kmesh_map(:,:), my_kqmap(:,:),
7116 : 0 : integer,allocatable :: lg_isym(:), lg_itime(:)
7117 : : real(dp) :: kk_bz(3), kk_ibz(3), qpt(3), qpt_tmp(3), kq_bz_source(3), kq_bz_target(3)
7118 : 0 : real(dp),allocatable :: qbz(:,:)
7119 : 0 : real(dp),contiguous,pointer :: gkq_rot_ptr(:,:,:,:,:), gkq_base_ptr(:,:,:,:,:)
7120 : 0 : complex(dp),target,allocatable :: gkq_rot(:,:,:,:,:), gkq_base(:,:,:,:,:)
7121 : 0 : complex(dp),allocatable :: gtmp(:,:), dh_mat(:,:), ket_mat(:,:)
7122 : : !----------------------------------------------------------------------
7123 : :
7124 : 0 : nprocs = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
7125 : :
7126 [ # # ]: 0 : units = [std_out, ab_out]
7127 : 0 : call wrtout(units, " Entering gstore_symmetrize...")
7128 : 0 : call wrtout(units, sjoin(" GSTORE file: ", gstore_path))
7129 : :
7130 : 0 : call gstore_read_gtype(gstore_path, gtype, comm, brange_kq_spin=brange_kq_spin)
7131 : :
7132 : : ! Compute the D-matrices D_mn(S) = <psi_m,S kq_ibz|S|psi_n,kq_ibz>.
7133 : : ! These are used below (as dh_mat) to correct the extra rotation the bra (electron state
7134 : : ! at k+q) picks up when its own already-computed BZ representative differs from the one
7135 : : ! obtained by applying isym_k directly. dh_mat is applied to the (k+q)/bra band index only
7136 : : ! (gvals' first band dimension, nb_kq) -- never to the k/ket index (nb_k) -- so dmats must be
7137 : : ! built with brange_kq_spin (bstart_kq:bstop_kq), NOT brange_k_spin: the two band windows are
7138 : : ! only required to have the SAME COUNT (gstore%same_nbands, checked below) but may start at a
7139 : : ! different absolute band (bstart_k need not equal bstart_kq, and neither needs to start at 1).
7140 : : ! All MPI ranks participate here since dmats%init distributes the work internally over comm.
7141 : : !
7142 : : ! NOTE: dmats_init also computes genuine (WFK-derived) D-matrices for symmetries S that do
7143 : : ! NOT stabilize a given IBZ k-point (S.k /= k+G), not just little-group elements -- this
7144 : : ! routine (gstore_symmetrize) is UNAFFECTED by that generalization and needs no changes
7145 : : ! because it never reads a non-little-group slot: every dmats%for_spin(...) lookup below
7146 : : ! uses either h_isym/h_isym_inv (searched for specifically as a stabilizer of ikq_ibz_t --
7147 : : ! see "Cannot find little-group element h for the k+q leg" below) or isym_k (drawn directly
7148 : : ! from lg_isym, the explicitly-enumerated little group of kk_ibz in Pass A). Both are
7149 : : ! guaranteed, by construction, to land on the little-group branch of dmats_init, which is
7150 : : ! untouched by the generalization -- confirmed by byte-identical validation numbers on
7151 : : ! diamond/AlAs before and after. See gstore_symmetrize_status memory for the full story.
7152 : 0 : call dmats%init(wfk_path, dtset, cryst, brange_kq_spin, ngfft, pawtab, psps, comm)
7153 : :
7154 : : ! Only master processor performs the symmetrization of the e-ph matrix elements.
7155 : : ! Performance is not crucial and the algorithm is IO-bound.
7156 [ # # ]: 0 : if (my_rank /= 0) goto 100
7157 : :
7158 : : ! GWPT files store two sets of e-ph matrix elements: "gvals" (g^Sigma) and "gvals_ks" (g^KS),
7159 : : ! written at the same (k,q) grid positions (see m_gwpt.F90's dump_my_gbuf). Symmetrize both.
7160 : 0 : n_gv = 1; gv_names(1) = "gvals"
7161 [ # # ]: 0 : if (gtype == GSTORE_GTYPE_GWPT) then
7162 : 0 : n_gv = 2; gv_names(2) = "gvals_ks"
7163 : : end if
7164 : :
7165 : : ! Read GSTORE.nc dimensions and metadata from file, without allocating gvals buffer.
7166 : 0 : with_cplex = 0; with_gmode = GSTORE_GMODE_ATOM; with_g2dw = .False.; gvals_name = "gvals"
7167 : : call gstore%from_ncpath(gstore_path, with_cplex, dtset, dtfil, cryst, ebands, ifc, &
7168 : 0 : with_gmode, gvals_name, with_g2dw, xmpi_comm_self)
7169 : :
7170 : : ! We need the same number of bands for m and n. Also, k and q must be in the BZ without any filter.
7171 [ # # ]: 0 : ABI_CHECK(gstore%same_nbands(msg), msg)
7172 [ # # ]: 0 : if (gstore%check_cplex_qkzone_gmode(2, "bz", "bz", "atom", kfilter="none", check_alloc=.False.) /= 0) then
7173 : 0 : ABI_ERROR("GSTORE.nc should have both k and q in the full BZ. See messages above.")
7174 : : end if
7175 : :
7176 : : ! has_used_lgk is supported via the gstore_sym == 2 "Pass A" reconstruction below.
7177 : : ! has_used_lgq remains unsupported: it is a structurally different restriction
7178 : : ! (k filtered by the little group of q), out of scope for gstore_sym.
7179 [ # # ]: 0 : ABI_CHECK_IEQ(gstore%has_used_lgq, 0, "Symmetrization of g(k,q) with use_lgq /= 0 is not coded")
7180 : :
7181 : : ! Useful dimensions.
7182 : 0 : nkbz = gstore%nkbz; nkibz = gstore%nkibz
7183 : 0 : nqbz = gstore%nqbz; nqibz = gstore%nqibz
7184 : 0 : nsym = cryst%nsym
7185 : :
7186 : : ! Need to know the position of the IBZ k-points in the netcdf array..
7187 [ # # ]: 0 : call get_ibz2bz(gstore%nkibz, gstore%nkbz, gstore%kbz2ibz, kibz2bz, msg, ierr)
7188 [ # # ]: 0 : ABI_CHECK(ierr == 0, sjoin("Something wrong in symmetry tables for k-points", ch10, msg))
7189 : :
7190 [ # # ]: 0 : NCF_CHECK(nctk_open_modify(ncid, gstore_path, xmpi_comm_self))
7191 : :
7192 : : if (DEBUG_DUMP_DH) open(unit=789, file="dh_debug.csv", status="replace", action="write")
7193 : : if (DEBUG_DUMP_DH) open(unit=790, file="dh_mat_full_debug.csv", status="replace", action="write")
7194 : : if (DEBUG_DUMP_DH) open(unit=791, file="gtmp_debug.csv", status="replace", action="write")
7195 : : if (DEBUG_DUMP_DH) open(unit=792, file="mu_debug.csv", status="replace", action="write")
7196 : :
7197 : : ! Loop over collinear spins.
7198 [ # # ]: 0 : do my_is=1,gstore%my_nspins
7199 : 0 : spin = gstore%my_spins(my_is)
7200 : : associate (gqk => gstore%gqk(my_is))
7201 : : ! nb_k == nb_kq is enforced by gstore%same_nbands above, so either count can be used here for
7202 : : ! sizing; the absolute band offsets (bstart_k vs bstart_kq, handled via brange_kq_spin passed
7203 : : ! to dmats%init above) are what actually differ and matter for correctness.
7204 : 0 : nb = gqk%nb_k
7205 : 0 : ABI_CHECK_IEQ(gqk%bstart_kq, brange_kq_spin(1, spin), "gqk%bstart_kq != brange_kq_spin(1, spin)")
7206 [ # # ]: 0 : ABI_CHECK_IEQ(gqk%bstop_kq, brange_kq_spin(2, spin), "gqk%bstop_kq != brange_kq_spin(2, spin)")
7207 : :
7208 : : ! Get the group id for this spin.
7209 [ # # ]: 0 : NCF_CHECK(nf90_inq_ncid(ncid, strcat("gqk", "_spin", itoa(spin)), spin_ncid))
7210 : :
7211 : : ! Read table with status of the (k, q) entry.
7212 [ # # # # : 0 : ABI_MALLOC(state_kq, (gqk%glob_nk, gqk%glob_nq))
# # # # #
# # # # #
# # # # ]
7213 [ # # ]: 0 : ncerr = nf90_get_var(ncid, nctk_idname(ncid, "gstore_glob_state_kqs"), state_kq, start=[1,1,spin])
7214 [ # # ]: 0 : NCF_CHECK(ncerr)
7215 : :
7216 [ # # # # : 0 : ABI_MALLOC(gkq_base, (nb, nb, gqk%natom3, gqk%my_nq, n_gv))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
7217 [ # # # # : 0 : ABI_MALLOC(gkq_rot, (nb, nb, gqk%natom3, gqk%my_nq, n_gv))
# # # # #
# # # # #
# # # # #
# # # #
# ]
7218 [ # # # # : 0 : ABI_MALLOC(gtmp, (nb, nb))
# # # # #
# # # # #
# # # # ]
7219 [ # # # # : 0 : ABI_MALLOC(dh_mat, (nb, nb))
# # # # #
# # # #
# ]
7220 [ # # # # : 0 : ABI_MALLOC(ket_mat, (nb, nb))
# # # # #
# # # #
# ]
7221 : :
7222 : : ! Build q-points in the BZ.
7223 [ # # # # : 0 : ABI_MALLOC(qbz, (3, gqk%my_nq))
# # # # #
# # # ]
7224 [ # # ]: 0 : do my_iq=1, gqk%my_nq
7225 : 0 : call gqk%myqpt(my_iq, gstore, weight_qq, qbz(:,my_iq))
7226 : : end do
7227 : :
7228 : : ! =====================================================================
7229 : : ! Pass A (gstore_sym == 2 only): if gstore_use_lgk restricted the q's
7230 : : ! actually computed directly for k in the IBZ, an IBZ row may have some
7231 : : ! q entries GSTORE_KQ_COMPUTED (q in IBZ_k) and others GSTORE_KQ_MISSING
7232 : : ! (q outside IBZ_k). Fill the MISSING ones here, using ONLY the little
7233 : : ! group of kk_ibz itself (k never moves in this pass -- the degenerate
7234 : : ! case of the k-star formula below, kk_bz := kk_ibz). Once every IBZ row
7235 : : ! is fully populated, the k-star loop below runs completely unchanged
7236 : : ! for the non-IBZ rows, exactly as it always has when gstore_use_lgk == 0.
7237 : : ! =====================================================================
7238 [ # # ]: 0 : if (dtset%gstore_sym == 2) then
7239 [ # # ]: 0 : do ik_ibz=1,nkibz
7240 : 0 : ik_glob = kibz2bz(ik_ibz)
7241 [ # # # # : 0 : if (all(state_kq(ik_glob, :) /= GSTORE_KQ_MISSING)) cycle
# # ]
7242 : :
7243 [ # # ]: 0 : kk_ibz = ebands%kptns(:, ik_ibz)
7244 : 0 : ik_ibz_file = ik_glob
7245 : 0 : kk_bz = kk_ibz ! degenerate case: k never moves in Pass A
7246 : :
7247 : : ! Enumerate the little group of kk_ibz once per row: symrel^T membership
7248 : : ! test, mirroring dmats_get_star_dmats (m_classify_bands.F90:2048-2061).
7249 : : ! Deliberately NOT lgroup_t/littlegroup_q here: those use the symrec
7250 : : ! convention, which can disagree with the symrel^T convention used
7251 : : ! throughout dmats/gstore_symmetrize for non-orthogonal symrel.
7252 [ # # # # : 0 : ABI_MALLOC(lg_isym, (2*nsym))
# # # # #
# # # #
# ]
7253 [ # # # # : 0 : ABI_MALLOC(lg_itime, (2*nsym))
# # # # ]
7254 : 0 : n_lg = 0
7255 [ # # ]: 0 : do itime_lg=1,2
7256 [ # # ]: 0 : do isym_lg=1,nsym
7257 [ # # ]: 0 : tsign_lg = 1; if (itime_lg == 2) tsign_lg = -1
7258 [ # # # # : 0 : kk_lg_test = tsign_lg * matmul(transpose(cryst%symrel(:,:,isym_lg)), kk_ibz)
# # # # #
# # # ]
7259 [ # # ]: 0 : if (isamek(kk_ibz, kk_lg_test, g0_q)) then
7260 : 0 : n_lg = n_lg + 1
7261 : 0 : lg_isym(n_lg) = isym_lg; lg_itime(n_lg) = itime_lg
7262 : : end if
7263 : : end do
7264 : : end do
7265 [ # # ]: 0 : ABI_CHECK(n_lg > 0, "Little group of kk_ibz is empty (should at least contain the identity)")
7266 : :
7267 : : ! Read g(k_ibz, q) for all q already available (same read pattern as below).
7268 [ # # ]: 0 : do igv=1,n_gv
7269 [ # # ]: 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])
7270 : : ncerr = nf90_get_var(spin_ncid, spin_vid(gv_names(igv)), gkq_base_ptr, &
7271 : : start=[1, 1, 1, 1, ik_ibz_file, 1], &
7272 [ # # # # ]: 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7273 [ # # ]: 0 : NCF_CHECK(ncerr)
7274 : : end do
7275 : :
7276 [ # # ]: 0 : do my_iq=1, gqk%my_nq
7277 : 0 : iq_glob = my_iq + gqk%my_qstart - 1
7278 : :
7279 [ # # ]: 0 : if (state_kq(ik_glob, iq_glob) /= GSTORE_KQ_MISSING) then
7280 : : ! Already GSTORE_KQ_COMPUTED (q in IBZ_k): keep the on-disk value unchanged.
7281 [ # # # # : 0 : gkq_rot(:,:,:,iq_glob,:) = gkq_base(:,:,:,iq_glob,:)
# # # # ]
7282 : 0 : cycle
7283 : : end if
7284 : :
7285 [ # # ]: 0 : qpt = qbz(:, my_iq)
7286 : :
7287 : : ! Search the little group x the row's own COMPUTED q entries for a source match.
7288 : : found_lg = .False.
7289 [ # # ]: 0 : do ii_lg=1,n_lg
7290 : 0 : isym_k = lg_isym(ii_lg); trev_k = lg_itime(ii_lg) - 1
7291 [ # # ]: 0 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
7292 [ # # # # ]: 0 : symrec_eq = transpose(cryst%symrel(:,:,isym_k))
7293 [ # # # # ]: 0 : symrec_eq_kspace = tsign_k * symrec_eq
7294 [ # # ]: 0 : do iq_sym=1, gqk%my_nq
7295 [ # # ]: 0 : if (state_kq(ik_glob, iq_sym + gqk%my_qstart - 1) /= GSTORE_KQ_COMPUTED) cycle
7296 [ # # # # : 0 : qpt_tmp = matmul(symrec_eq_kspace, qbz(:, iq_sym))
# # # # ]
7297 [ # # ]: 0 : if (isamek(qpt, qpt_tmp, g0_q)) then
7298 : 0 : found_lg = .True.; exit
7299 : : end if
7300 : : end do
7301 : 0 : if (found_lg) exit
7302 : : end do
7303 : :
7304 : : msg = sjoin("Pass A: no little-group image of q found among GSTORE_KQ_COMPUTED", &
7305 [ # # ]: 0 : " entries for ik_ibz=", itoa(ik_ibz), " -- IBZ_k does not cover this q's star")
7306 [ # # ]: 0 : ABI_CHECK(found_lg, msg)
7307 : :
7308 [ # # ]: 0 : do isym_combined=1,nsym
7309 [ # # # # : 0 : if (all(cryst%symrec(:,:,isym_combined) == symrec_eq)) exit
# # # # ]
7310 : : end do
7311 [ # # ]: 0 : ABI_CHECK(isym_combined /= nsym + 1, "Cannot find symrec_eq")
7312 : :
7313 : : ! Note on non-uniqueness of (isym_k, iq_sym): when kk_ibz has a non-trivial little group
7314 : : ! (the typical case, not a rare corner case -- measured on the reference test systems
7315 : : ! below, EVERY Pass-A point in diamond and most in AlAs have more than one valid
7316 : : ! candidate, up to ~96 at Gamma), the found_lg search above can match several different
7317 : : ! (isym,itime,iq_sym) triples for the same target q; "first found" is taken arbitrarily.
7318 : : ! Verified this does NOT introduce a gauge/correctness bug: a dedicated diagnostic
7319 : : ! (temporarily instrumented, then removed) recomputed the full reconstruction using EVERY
7320 : : ! valid candidate for a set of known-redundant points on both diamond (4 points, 2-4
7321 : : ! candidates each) and AlAs (2 points), and all candidates agreed with each other to
7322 : : ! numerical noise (~1e-7 to 1e-10) in every case -- i.e. the formula is empirically
7323 : : ! gauge-invariant to this choice, the same way the bra leg's h_isym/phase_h_gs/L_h_gs
7324 : : ! machinery is already known (and was originally designed) to be invariant to which
7325 : : ! (isym_kqS,isym_kqT) kpts_map happens to return. See gstore_symmetrize_status memory for
7326 : : ! the full data. Contrast with dmats_get_star_dmats_at_kpt (m_classify_bands.F90), a
7327 : : ! DIAGNOSTIC-only routine with a structurally identical first-match-wins search that its
7328 : : ! own authors flag as an unverified risk -- that routine has NOT been checked this way and
7329 : : ! is a separate, lower-priority open item (never reached by production gstore_symmetrize).
7330 : :
7331 : : ! -----------------------------------------------------------------
7332 : : ! From here on, reused VERBATIM from the k-star loop below (Bug A /
7333 : : ! h_isym / phase_h_gs / phase_ket_gs / itime_h / dh_mat / mu-rotation
7334 : : ! -- kk_bz == kk_ibz here, the degenerate case, so the formula
7335 : : ! derived for the general k-star case applies unchanged). See the
7336 : : ! k-star loop's own comments for the full derivation.
7337 [ # # ]: 0 : kq_bz_source = kk_ibz + qbz(:, iq_sym)
7338 [ # # ]: 0 : kq_bz_target = kk_bz + qpt
7339 : 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_source, indkk_s)
7340 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (source)")
7341 : 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_target, indkk_t)
7342 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (target)")
7343 : 0 : ikq_ibz_s = indkk_s(1,1); isym_kqS = indkk_s(2,1)
7344 : 0 : ikq_ibz_t = indkk_t(1,1); isym_kqT = indkk_t(2,1)
7345 : 0 : trev_kqS = indkk_s(6,1); trev_kqT = indkk_t(6,1)
7346 [ # # ]: 0 : ABI_CHECK(ikq_ibz_s == ikq_ibz_t, "Source and target k+q map to different IBZ points!")
7347 : :
7348 [ # # ]: 0 : mat_tmp = matmul(transpose(cryst%symrel(:,:,dmats%toinv(1,isym_kqT))), &
7349 [ # # # # : 0 : matmul(symrec_eq, transpose(cryst%symrel(:,:,isym_kqS))))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
7350 [ # # ]: 0 : do h_isym=1,nsym
7351 [ # # # # : 0 : if (all(transpose(cryst%symrel(:,:,h_isym)) == mat_tmp)) exit
# # # # ]
7352 : : end do
7353 [ # # ]: 0 : ABI_CHECK(h_isym /= nsym + 1, "Cannot find little-group element h for the k+q leg")
7354 : :
7355 : 0 : c1_gs = dmats%multable(1, isym_kqS, isym_k)
7356 : : L_h_gs = real(dmats%multable(2:4, isym_kqS, isym_k), dp) &
7357 : : + real(dmats%multable(2:4, c1_gs, dmats%toinv(1,isym_kqT)), dp) &
7358 [ # # # # : 0 : - matmul(real(cryst%symrel(:,:,h_isym), dp), real(dmats%toinv(2:4,isym_kqT), dp))
# # # # #
# # # #
# ]
7359 [ # # ]: 0 : kq_ibz_pt = ebands%kptns(:, ikq_ibz_t)
7360 [ # # ]: 0 : phase_h_gs = exp(cmplx(zero, two_pi * sum(kq_ibz_pt * L_h_gs), dp))
7361 : :
7362 : : ! Pass-A-only companion to phase_ket_gs. The k-star formula below (kk_bz generally
7363 : : ! != kk_ibz) was validated to 100% exact match WITHOUT this extra term. In Pass A,
7364 : : ! kk_bz == kk_ibz identically (the degenerate case), and an extra residual survived
7365 : : ! even after the ket_mat fix: isolated (h_isym==1, scalar-only residual, i.e. exactly
7366 : : ! reproducible by a single global phase -- see gstore_symmetrize_status memory) to be
7367 : : ! a clean function of isym_k and kk_ibz alone: exp(-i*2pi*kk_ibz.w(isym_k)) for an
7368 : : ! integer vector w. Empirically fit w(isym_k) exactly (32/32 points, zero exceptions,
7369 : : ! all 3 distinct ik_ibz/isym_k combinations in the reference test) to
7370 : : ! toinv(2:4,isym_k) -- the SAME single-inverse convention used for L_h_gs's own
7371 : : ! toinv(1,isym_kqT) term, and notably NOT the double-inverse toinv(2:4,toinv(1,isym_k))
7372 : : ! used by the qpt term just above. Plausible reading: the qpt-term's
7373 : : ! toinv(2:4,toinv(1,isym_k)) is the companion to kk_bz = symrec_eq.kk_ibz (the k-star's
7374 : : ! moved k), which in Pass A degenerates to kk_ibz itself, making this term newly
7375 : : ! separate and nonzero instead of staying absorbed into the k-star's single term.
7376 : : phase_ket_gs = exp(cmplx(zero, -two_pi * sum(qpt * real(dmats%toinv(2:4, dmats%toinv(1,isym_k)), dp)), dp)) &
7377 [ # # # # ]: 0 : * exp(cmplx(zero, -two_pi * sum(kk_ibz * real(dmats%toinv(2:4, isym_k), dp)), dp))
7378 : :
7379 : 0 : itime_h = 1 + mod(trev_k + trev_kqS + trev_kqT, 2)
7380 : :
7381 : 0 : h_isym_inv = dmats%toinv(1, h_isym)
7382 [ # # ]: 0 : if (itime_h == 2) then
7383 [ # # # # : 0 : dh_mat = conjg(phase_h_gs) * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
# # # # #
# # # ]
7384 : : else
7385 [ # # # # : 0 : dh_mat = phase_h_gs * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
# # # # #
# # # ]
7386 : : end if
7387 : :
7388 [ # # # # : 0 : if (trev_kqT == 1) dh_mat = conjg(dh_mat)
# # ]
7389 : :
7390 : : ! Ket-leg correction (Pass A only -- k-star never needs this, see below). Unlike k-star
7391 : : ! reconstruction, whose ket is always *derived* via cgtk_rotate from the IBZ wavefunction
7392 : : ! (so ground truth and reconstruction structurally share the same gauge for any degenerate
7393 : : ! ket subspace), Pass A's ket lives AT kk_ibz itself and is read directly from the WFK for
7394 : : ! every q processed there. Ground truth's own independent direct e-ph calculations at
7395 : : ! different q (same k) do not share a common internal gauge for a degenerate ket subspace.
7396 : : ! isym_k stabilizes kk_ibz (drawn from its own little group, by construction), so
7397 : : ! dmats%for_spin(...)(isym_k,...) is a genuine, tabulated (non-placeholder) D-matrix here
7398 : : ! -- unlike the general k-star case, where isym_k need not stabilize anything.
7399 : : !
7400 : : ! Convention: read dmats%for_spin(...)(isym_k,...) DIRECTLY, not the toinv(1,isym_k) slot.
7401 : : ! isym_k here is found purely via the symrel^T convention (little-group membership test),
7402 : : ! and dmats's own array is indexed the same way (symrel^T, per dmats_init's own little-group
7403 : : ! check), so isym_k already names the exact tabulated operation that rotates the ket -- no
7404 : : ! inversion is needed or correct. (Contrast with the BRA correction above, dh_mat: h_isym
7405 : : ! there is defined as a genuine COMPOSITE/residual little-group element of kq_ibz whose
7406 : : ! natural tabulated slot -- per dmats_init's own toinv/multable bookkeeping around
7407 : : ! cgtk_rotate's isym_inv=toinv(isym) workaround -- is toinv(1,h_isym), not h_isym itself;
7408 : : ! that is a property of how h_isym's OWN definition composes with dmats_init's internal
7409 : : ! convention, not a general rule that every dmats lookup needs a toinv step.) The original
7410 : : ! implementation used toinv(1,isym_k) "by analogy" with dh_mat and was validated only on an
7411 : : ! involutory isym_k (toinv(1,isym_k)==isym_k), which cannot distinguish the two conventions.
7412 : : ! Diagnosed by finding a 100%/0% clean split: EVERY point with non-involutory isym_k was
7413 : : ! wrong (needing a genuine unitary matrix fix, not a scalar) while every involutory-isym_k
7414 : : ! point was already exact -- direct, decisive evidence the toinv(1,.) step was the bug.
7415 : 0 : itime_k = trev_k + 1
7416 [ # # # # : 0 : ket_mat = dmats%for_spin(spin)%value(:,:,isym_k,itime_k,ik_ibz)
# # # # #
# # # ]
7417 [ # # # # : 0 : if (trev_k == 1) ket_mat = conjg(ket_mat)
# # ]
7418 : : ! -----------------------------------------------------------------
7419 : :
7420 : : ! Perform symmetrization.
7421 [ # # ]: 0 : do mu=1,gqk%natom3
7422 : 0 : idir = mod(mu-1, 3) + 1; iat = (mu - idir) / 3 + 1
7423 : :
7424 : 0 : iat_eq = cryst%indsym(4, isym_combined, iat)
7425 [ # # ]: 0 : l0 = cryst%indsym(1:3, isym_combined, iat)
7426 [ # # ]: 0 : phase = -two_pi * dot_product(qbz(:, iq_sym), l0)
7427 : 0 : cphase = cmplx(cos(phase), sin(phase), dp)
7428 : :
7429 [ # # ]: 0 : do igv=1,n_gv
7430 [ # # # # ]: 0 : gtmp = zero
7431 [ # # ]: 0 : do idir_eq=1,3
7432 : 0 : mu_eq = idir_eq + (iat_eq - 1) * 3
7433 [ # # # # : 0 : gtmp = gtmp + cphase * symrec_eq(idir, idir_eq) * gkq_base(:,:,mu_eq,iq_sym,igv)
# # ]
7434 : : end do
7435 [ # # # # : 0 : if (trev_k == 1) gtmp = conjg(gtmp)
# # ]
7436 [ # # # # : 0 : gkq_rot(:,:,mu,iq_glob,igv) = matmul(matmul(dh_mat, gtmp), ket_mat)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
7437 : : end do
7438 : : end do
7439 : :
7440 : : end do ! my_iq
7441 : :
7442 : : ! Write the newly reconstructed + copied-through rows back to the netcdf file.
7443 [ # # ]: 0 : do igv=1,n_gv
7444 [ # # ]: 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])
7445 : : ncerr = nf90_put_var(spin_ncid, spin_vid(gv_names(igv)), gkq_rot_ptr, &
7446 : : start=[1, 1, 1, 1, ik_glob, 1], &
7447 [ # # # # ]: 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7448 [ # # ]: 0 : NCF_CHECK(ncerr)
7449 : : end do
7450 [ # # # # ]: 0 : where (state_kq(ik_glob, :) == GSTORE_KQ_MISSING) state_kq(ik_glob, :) = GSTORE_KQ_SYMMETRIZED
7451 : :
7452 [ # # ]: 0 : ABI_FREE(lg_isym)
7453 [ # # ]: 0 : ABI_FREE(lg_itime)
7454 : : end do ! ik_ibz
7455 : : end if ! gstore_sym == 2
7456 : :
7457 [ # # ]: 0 : NCF_CHECK(nf90_sync(spin_ncid))
7458 : :
7459 : : ! Loop over k-points in the IBZ.
7460 [ # # # # ]: 0 : do my_ik=1,gqk%my_nk
7461 : 0 : ik_glob = my_ik + gqk%my_kstart - 1
7462 [ # # ]: 0 : kk_bz = gqk%my_kpts(:, my_ik)
7463 : :
7464 [ # # ]: 0 : if (state_kq(ik_glob, 1) /= GSTORE_KQ_MISSING) then
7465 : : ! Row already fully resolved: either directly COMPUTED (gstore_use_lgk == 0), or
7466 : : ! filled by Pass A above (gstore_sym == 2, mix of COMPUTED and SYMMETRIZED).
7467 [ # # # # : 0 : ABI_CHECK(all(state_kq(ik_glob, :) /= GSTORE_KQ_MISSING), "all state")
# # ]
7468 : 0 : cycle
7469 : : end if
7470 : :
7471 : : ! Symmetry tables for k-point. Using symrel^T convention for k..
7472 : 0 : ik_ibz = gqk%my_k2ibz(1, my_ik); isym_k = gqk%my_k2ibz(2, my_ik)
7473 : 0 : trev_k = gqk%my_k2ibz(6, my_ik); g0_k = gqk%my_k2ibz(3:5, my_ik)
7474 : : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
7475 [ # # ]: 0 : tsign_k = 1; if (trev_k == 1) tsign_k = -1
7476 : 0 : itime_k = trev_k + 1
7477 [ # # ]: 0 : kk_ibz = ebands%kptns(:,ik_ibz)
7478 : :
7479 : : ! Index of the IBZ k-point on disk.
7480 : 0 : ik_ibz_file = kibz2bz(ik_ibz)
7481 : :
7482 : : ! symrec_eq is the SPATIAL rotation (used for atomic-perturbation-direction
7483 : : ! bookkeeping below, which is TR-blind: time reversal does not move atoms.
7484 : : ! symrec_eq_kspace additionally carries the TR sign and is the one that actually relates k-space
7485 : : ! vectors (kk_bz, q) to their IBZ images
7486 [ # # # # ]: 0 : symrec_eq = transpose(cryst%symrel(:,:,isym_k))
7487 [ # # # # ]: 0 : symrec_eq_kspace = tsign_k * symrec_eq
7488 [ # # # # : 0 : ABI_CHECK(isamek(kk_bz, matmul(symrec_eq_kspace, kk_ibz), g0_q), "kk_bz != symrec_eq_kspace kk_ibz")
# # # # #
# ]
7489 : :
7490 [ # # ]: 0 : do isym_combined=1,nsym
7491 [ # # # # : 0 : if (all(cryst%symrec(:,:,isym_combined) == symrec_eq)) exit
# # # # ]
7492 : : end do
7493 [ # # ]: 0 : ABI_CHECK(isym_combined /= nsym + 1, "Cannot find symrec_eq")
7494 : :
7495 : : ! Read g(k_ibz, q) for all q-point in the BZ, for each gvals stream ("gvals", and "gvals_ks" too when gtype == "gwpt").
7496 [ # # ]: 0 : do igv=1,n_gv
7497 [ # # ]: 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])
7498 : : ncerr = nf90_get_var(spin_ncid, spin_vid(gv_names(igv)), gkq_base_ptr, &
7499 : : start=[1, 1, 1, 1, ik_ibz_file, 1], &
7500 [ # # # # ]: 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7501 [ # # ]: 0 : NCF_CHECK(ncerr)
7502 : : end do
7503 : :
7504 : : ! Loop over q-points in the BZ.
7505 [ # # ]: 0 : do my_iq=1, gqk%my_nq
7506 : 0 : iq_glob = my_iq + gqk%my_qstart - 1
7507 : 0 : this_state = state_kq(ik_glob, iq_glob)
7508 [ # # ]: 0 : if (this_state /= GSTORE_KQ_MISSING) cycle
7509 : :
7510 : : ! Symmetry tables for q-point. NB: Using symrec convention for q.
7511 : : !iq_ibz = gqk%my_q2ibz(1, my_iq); isym_q = gqk%my_q2ibz(2, my_iq)
7512 : : !trev_q = gqk%my_q2ibz(6, my_iq); g0_q = gqk%my_q2ibz(3:5, my_iq)
7513 : : !isirr_q = (isym_q == 1 .and. trev_q == 0 .and. all(g0_q == 0))
7514 : : !tsign_q = 1; if (trev_q == 1) tsign_q = -1
7515 : : !qq_ibz = gstore%qibz(:, iq_ibz)
7516 [ # # ]: 0 : qpt = qbz(:, my_iq)
7517 : :
7518 : : ! Find q. Uses symrec_eq_kspace (not symrec_eq): q, like k, is a genuine k-space vector
7519 : : ! that picks up the TR sign under the same combined operation mapping kk_ibz -> kk_bz.
7520 [ # # ]: 0 : do iq_sym=1, gqk%my_nq
7521 : : ! qpt = qpt_tmp + G0_q
7522 [ # # # # : 0 : qpt_tmp = matmul(symrec_eq_kspace, qbz(:, iq_sym)); if (isamek(qpt, qpt_tmp, g0_q)) exit
# # # # #
# ]
7523 : : end do
7524 [ # # ]: 0 : ABI_CHECK(iq_sym /= gqk%my_nq + 1, sjoin("Cannot find:", ktoa(qpt)))
7525 : :
7526 : : ! -----------------------------------------------------------------
7527 : : ! Bug A fix: the bra (electron state at k+q) reaches its target BZ
7528 : : ! point via two composed rotations (isym_k applied to the SOURCE
7529 : : ! bra's own rotation from kq_ibz), while the "true" bra is obtained
7530 : : ! by a single direct rotation from kq_ibz. The two differ by U(h),
7531 : : ! h being the residual element of the little group (stabilizer) of
7532 : : ! kq_ibz. h always stabilizes kq_ibz by construction (never an
7533 : : ! out-of-domain little-group lookup), so the D-matrices already
7534 : : ! tabulated by dmats are valid here. See gstore_symmetrize_status
7535 : : ! memory (session 10) for the full derivation.
7536 [ # # ]: 0 : kq_bz_source = kk_ibz + qbz(:, iq_sym)
7537 [ # # ]: 0 : kq_bz_target = kk_bz + qpt
7538 : 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_source, indkk_s)
7539 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (source)")
7540 : 0 : ierr = kpts_map("symrel", ebands%kptopt, cryst, gstore%krank_ibz, 1, kq_bz_target, indkk_t)
7541 [ # # ]: 0 : ABI_CHECK(ierr == 0, "Cannot find symmetric image of k+q (target)")
7542 : 0 : ikq_ibz_s = indkk_s(1,1); isym_kqS = indkk_s(2,1)
7543 : 0 : ikq_ibz_t = indkk_t(1,1); isym_kqT = indkk_t(2,1)
7544 : 0 : trev_kqS = indkk_s(6,1); trev_kqT = indkk_t(6,1)
7545 [ # # ]: 0 : ABI_CHECK(ikq_ibz_s == ikq_ibz_t, "Source and target k+q map to different IBZ points!")
7546 : :
7547 : : ! mat_tmp = Srel(toinv(isym_kqT)) . Srel(isym_k) . Srel(isym_kqS), with Srel(S) := symrel(S)^T
7548 : : ! (same k/kq convention as symrec_eq above, i.e. NOT cryst%symrec). h_isym is the isym s.t.
7549 : : ! Srel(h_isym) == mat_tmp.
7550 [ # # ]: 0 : mat_tmp = matmul(transpose(cryst%symrel(:,:,dmats%toinv(1,isym_kqT))), &
7551 [ # # # # : 0 : matmul(symrec_eq, transpose(cryst%symrel(:,:,isym_kqS))))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
7552 [ # # ]: 0 : do h_isym=1,nsym
7553 [ # # # # : 0 : if (all(transpose(cryst%symrel(:,:,h_isym)) == mat_tmp)) exit
# # # # ]
7554 : : end do
7555 [ # # ]: 0 : ABI_CHECK(h_isym /= nsym + 1, "Cannot find little-group element h for the k+q leg")
7556 : :
7557 : : ! Lattice-vector-phase companion to h_isym (bra leg). The rotation-only h_isym search above
7558 : : ! finds the correct isym s.t. Srel(h_isym) matches the literal 3-way rotation product, but
7559 : : ! (analogous to dmats_get_star_dmats's validated S0.g.S0^{-1} + L_h construction) the literal
7560 : : ! Seitz composition Tab(isym_kqS).Tab(isym_k).Tab(isym_kqT)^{-1} generally differs from
7561 : : ! Tab(h_isym) by a residual lattice vector L_h_gs whenever any of isym_kqS/isym_k/isym_kqT is
7562 : : ! non-symmorphic, even when h_isym is the identity rotation. Derived by substituting
7563 : : ! Tab(c1)=T_{-L1}.Tab(isym_kqS).Tab(isym_k) [c1=multable(1,isym_kqS,isym_k), the SAME rotation
7564 : : ! recipe already validated for h_isym itself] into Tab(c1).Tab(toinv(isym_kqT))=T_{L2}.Tab(h_isym),
7565 : : ! then Tab(toinv(isym_kqT)) = Tab(isym_kqT)^{-1}.T_{L0} (L0=toinv(2:4,isym_kqT)), and pushing
7566 : : ! T_{-L0} through Tab(h_isym) (Tab(h).T_v = T_{R(h).v}.Tab(h)). Verified EXACTLY (3000/3000
7567 : : ! random (isym_k,isym_kqS,isym_kqT) triples, zero umklapp) against the literal 3-operator
7568 : : ! Seitz composition computed independently with the EXACT (non-tabulated) group inverse. The
7569 : : ! overall sign was pinned down against a hand-verified counterexample (h_isym=1, needing a
7570 : : ! missing factor of exactly +i).
7571 : 0 : c1_gs = dmats%multable(1, isym_kqS, isym_k)
7572 : : L_h_gs = real(dmats%multable(2:4, isym_kqS, isym_k), dp) &
7573 : : + real(dmats%multable(2:4, c1_gs, dmats%toinv(1,isym_kqT)), dp) &
7574 [ # # # # : 0 : - matmul(real(cryst%symrel(:,:,h_isym), dp), real(dmats%toinv(2:4,isym_kqT), dp))
# # # # #
# # # #
# ]
7575 [ # # ]: 0 : kq_ibz_pt = ebands%kptns(:, ikq_ibz_t)
7576 [ # # ]: 0 : phase_h_gs = exp(cmplx(zero, two_pi * sum(kq_ibz_pt * L_h_gs), dp))
7577 : :
7578 : : ! Companion phase on the KET leg. Even with phase_h_gs above, a residual remained, isolated
7579 : : ! (via h_isym==1 points, where dh_mat=I so phase_h_gs is the only other active correction) to
7580 : : ! be a clean function of isym_k and the TARGET q alone: exp(-i*2pi*qpt.v(isym_k)) for an
7581 : : ! integer vector v. Empirically fit v(isym_k) exactly (100% across all isym_k appearing in
7582 : : ! the reference test, zero exceptions) to toinv(2:4, toinv(1,isym_k)) -- i.e. the
7583 : : ! lattice-vector residual of composing isym_k with its OWN inverse in the OTHER order from
7584 : : ! toinv's own convention (toinv(2:4,isym_k) is for S(isym_k).S(isym_k^{-1}); this needs
7585 : : ! S(isym_k^{-1}).S(isym_k) instead, which only coincides with the former when isym_k is
7586 : : ! self-inverse -- the same class of composition-order mixup fixed in dmats_check_one_k and in
7587 : : ! deriving L_h_gs above). Physical origin not fully pinned down: isym_k plays a role in BOTH
7588 : : ! the ket rotation (kk_bz = symrec_eq.kk_ibz) AND the atomic-perturbation-direction rotation
7589 : : ! via the SAME symrec_eq in the mu-loop below (whose existing cphase/l0 term is dotted with
7590 : : ! the SOURCE q, not the target) -- plausibly this is the missing lattice-vector companion to
7591 : : ! THAT term, evaluated at the target q instead, but this is a plausible reading of the
7592 : : ! empirical formula, not an independently re-derived physical proof (unlike L_h_gs above,
7593 : : ! which was verified against the literal Seitz composition directly). Trust the formula
7594 : : ! (exhaustively validated below); treat the physical narrative as informed conjecture only.
7595 : : !
7596 : : ! Effect of phase_h_gs+phase_ket_gs alone on the gstore_brange 1 4 reference test: raw
7597 : : ! exact-match rate 60.4% -> 91.7%, gauge-invariant unchanged at 100%. NOTE: the remaining 8.3%
7598 : : ! was INITIALLY (wrongly) attributed entirely to expected degenerate-band gauge freedom per
7599 : : ! AGENTS.md -- this was corrected later (see the THIRD correction right below): a Procrustes
7600 : : ! best-fit-unitary check proved EXACT reconstruction is achievable for within-range-degenerate
7601 : : ! bra multiplets, so that mismatch was a real, fixable bug, not gauge freedom. Do not repeat
7602 : : ! that mistake: eigenvalue-degeneracy alone never proves a mismatch is harmless -- check
7603 : : ! whether a single matrix can exactly relate reconstruction to truth first.
7604 [ # # ]: 0 : phase_ket_gs = exp(cmplx(zero, -two_pi * sum(qpt * real(dmats%toinv(2:4, dmats%toinv(1,isym_k)), dp)), dp))
7605 : :
7606 : : ! THIRD correction: dmats%for_spin(h_isym) is the WRONG tabulated matrix for the bra whenever
7607 : : ! h_isym is a non-self-inverse symmetry. Root cause: dmats_init computes D(isym) by calling
7608 : : ! cgtk_rotate with isym_inv=toinv(isym) and a separately-recomputed umklapp g0_inv (a
7609 : : ! documented workaround for cgtk_rotate silently returning D_true(S)^{-1} for non-involutions).
7610 : : ! D(h) and D(toinv(h)) are unitary inverses of each other only up to an EXTRA phase that
7611 : : ! dmats_init's own toinv/multable bookkeeping already knows about (this is exactly what
7612 : : ! dmats_check_one_k's "inv_phase"/"phase_analytic" diagnostic measures and validates) --
7613 : : ! reconstructing D(toinv(h)) from D(h) via a bare conjugate-transpose silently drops that
7614 : : ! phase. Looking up dmats%for_spin(toinv(h_isym)) directly sidesteps this entirely, since
7615 : : ! dmats_init already computed that matrix independently and self-consistently under its own
7616 : : ! label: there is nothing to reconstruct.
7617 : : !
7618 : : ! Earlier sessions gated this substitution behind an empirical "is a correction needed at
7619 : : ! all" heuristic (g0-mismatch OR non-self-inverse-and-degenerate-bra), applying toinv(h_isym)
7620 : : ! only when it fired and h_isym unmodified otherwise. That heuristic is UNNECESSARY: applying
7621 : : ! dmats%for_spin(toinv(h_isym)) unconditionally (i.e. always, regardless of degeneracy or g0)
7622 : : ! reproduces the exact same result on every point where the heuristic previously used
7623 : : ! h_isym directly -- because on the reference test system, no such point exists: every
7624 : : ! non-self-inverse h_isym already satisfied the heuristic's trigger condition. (For
7625 : : ! self-inverse h_isym, toinv(1,h_isym)==h_isym, so the two forms are trivially identical
7626 : : ! regardless.) Verified end-to-end against check_symm.py: byte-for-byte identical results to
7627 : : ! the old conditional form -- 3584/3584 (100.0%) raw+gauge-invariant exact matches on
7628 : : ! gstore_brange 1 4 (max diff 3.66e-7, noise level), 3533/3584 (98.6%) raw==gauge-invariant on
7629 : : ! gstore_brange 1 2 (the residual there is the known, inherent out-of-range-degeneracy
7630 : : ! limitation of truncating the band range, not a bug). See gstore_symmetrize_status memory
7631 : : ! (sessions 14-15) for the full derivation history and this final unconditional-formula
7632 : : ! confirmation.
7633 : : ! TIME-REVERSAL generalization of itime_h (was hardcoded to 1, i.e. always the pure-spatial
7634 : : ! D-matrix slice). The unitary/antiunitary character of a composed operator is a Z2
7635 : : ! homomorphism (same rule dmats_check_one_k's group-multiplication test uses:
7636 : : ! itime3 = 1 + mod((itime1-1)+(itime2-1), 2), Bradley & Cracknell sec. 7.3), extended here
7637 : : ! by associativity to h's three-fold composition toinv(isym_kqT).isym_k.isym_kqS
7638 : : ! (itime(A^{-1}) = itime(A), so toinv(isym_kqT) contributes trev_kqT unchanged). High
7639 : : ! confidence, not yet empirically validated on a TR-nonzero system.
7640 : 0 : itime_h = 1 + mod(trev_k + trev_kqS + trev_kqT, 2)
7641 : :
7642 : : ! HYPOTHESIS (open question, validate empirically -- see gstore_symmetrize_status memory):
7643 : : ! phase_h_gs's lattice-vector phase is built from dmats%multable/toinv, which are
7644 : : ! itime-independent by construction, so its formula should carry over unchanged. But the
7645 : : ! closest validated analogue, dmats_get_star_dmats (m_classify_bands.F90), needs an EXTRA
7646 : : ! conjugation on its own analogous phase whenever itime==2. Applying the same pattern here
7647 : : ! as a first hypothesis; h's composition shape differs from that routine's, so this is not
7648 : : ! a proof, only a well-motivated starting point.
7649 : 0 : h_isym_inv = dmats%toinv(1, h_isym)
7650 [ # # ]: 0 : if (itime_h == 2) then
7651 [ # # # # : 0 : dh_mat = conjg(phase_h_gs) * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
# # # # #
# # # ]
7652 : : else
7653 [ # # # # : 0 : dh_mat = phase_h_gs * phase_ket_gs * dmats%for_spin(spin)%value(:,:,h_isym_inv,itime_h,ikq_ibz_t)
# # # # #
# # # ]
7654 : : end if
7655 : :
7656 : : ! HYPOTHESIS (open question, validate empirically): pulling D(h) through the outer operator
7657 : : ! that maps ikq_ibz -> kq_bz_target picks up a conjugate exactly when that operator
7658 : : ! (governed by isym_kqT/trev_kqT) is antiunitary -- a flag logically independent of trev_k
7659 : : ! (see 2.4's gtmp conjugation below) and of itime_h (which only selects WHICH tabulated
7660 : : ! matrix to read, not whether the whole assembled dh_mat needs conjugating on top).
7661 [ # # # # : 0 : if (trev_kqT == 1) dh_mat = conjg(dh_mat)
# # ]
7662 : :
7663 : : if (DEBUG_DUMP_DH) then
7664 : : 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, &
7665 : : 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, &
7666 : : qpt, kk_ibz
7667 : : write(790,*) ik_glob, iq_glob, nb, isym_k, h_isym, ikq_ibz_t, isym_kqS, isym_kqT, g0_q, &
7668 : : trev_k, trev_kqS, trev_kqT, itime_h, &
7669 : : real(phase_h_gs), aimag(phase_h_gs), real(phase_ket_gs), aimag(phase_ket_gs), &
7670 : : dmats%for_spin(spin)%value(:,:,h_isym,itime_h,ikq_ibz_t)
7671 : : end if
7672 : : ! -----------------------------------------------------------------
7673 : :
7674 : : ! Perform symmetrization.
7675 [ # # ]: 0 : do mu=1,gqk%natom3
7676 : 0 : idir = mod(mu-1, 3) + 1; iat = (mu - idir) / 3 + 1
7677 : :
7678 : 0 : iat_eq = cryst%indsym(4, isym_combined, iat)
7679 [ # # ]: 0 : l0 = cryst%indsym(1:3, isym_combined, iat)
7680 [ # # ]: 0 : phase = -two_pi * dot_product(qbz(:, iq_sym), l0)
7681 : 0 : cphase = cmplx(cos(phase), sin(phase), dp)
7682 : :
7683 : : ! Per-mu atomic-mapping/phase diagnostic (iat_eq, l0, symrec_eq row, cphase, iq_sym):
7684 : : ! reusable general-purpose dump, not tied to any specific (ik_glob,iq_glob) -- add a
7685 : : ! filter here (e.g. "if (ik_glob==... .and. iq_glob==...)") when tracing one point on a
7686 : : ! large system, to keep mu_debug.csv a manageable size.
7687 : : if (DEBUG_DUMP_DH) then
7688 : : write(792,*) ik_glob, iq_glob, mu, iat, iat_eq, isym_combined, isym_k, ik_ibz, iq_sym, &
7689 : : l0, symrec_eq(idir,1), symrec_eq(idir,2), symrec_eq(idir,3), idir, ik_ibz_file, cphase
7690 : : end if
7691 : :
7692 : : ! Apply the same geometric rotation (cphase/symrec_eq/dh_mat, all independent of which
7693 : : ! gvals stream is being processed) to each stream separately, since gtmp's accumulation
7694 : : ! reads actual matrix-element values from gkq_base.
7695 [ # # ]: 0 : do igv=1,n_gv
7696 [ # # # # ]: 0 : gtmp = zero
7697 [ # # ]: 0 : do idir_eq=1,3
7698 : 0 : mu_eq = idir_eq + (iat_eq - 1) * 3
7699 [ # # # # : 0 : gtmp = gtmp + cphase * symrec_eq(idir, idir_eq) * gkq_base(:,:,mu_eq,iq_sym,igv)
# # ]
7700 : : end do
7701 : : ! HYPOTHESIS (open question, validate empirically): conjugate gtmp before the dh_mat
7702 : : ! multiply whenever the ket leg's own operation (isym_k, trev_k) is antiunitary. Matches
7703 : : ! the "rotate spatially first, conjugate as the last step" pattern used identically by
7704 : : ! cgtk_rotate, pheigvec_rotate, rotate_fqg and dmats_init elsewhere in this codebase.
7705 : : ! Order matters: conjugate gtmp itself, not matmul(dh_mat,gtmp), since dh_mat is complex.
7706 [ # # # # : 0 : if (trev_k == 1) gtmp = conjg(gtmp)
# # ]
7707 : : ! Apply the Bug A correction: left-multiply by D(h) on the bra (m) index.
7708 [ # # # # : 0 : gkq_rot(:,:,mu,iq_glob,igv) = matmul(dh_mat, gtmp)
# # # # #
# # # # #
# # # # #
# # # #
# ]
7709 : 0 : if (DEBUG_DUMP_DH) write(791,*) ik_glob, iq_glob, mu, nb, trev_k, trim(gv_names(igv)), gtmp
7710 : : end do
7711 : : end do
7712 : :
7713 : : end do ! my_iq
7714 : :
7715 : : ! Write the newly computed g_{mn, nu} back to the netcdf file (in-place modification),
7716 : : ! for each gvals stream, and update the entry in state_kq.
7717 [ # # ]: 0 : do igv=1,n_gv
7718 [ # # ]: 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])
7719 : : ncerr = nf90_put_var(spin_ncid, spin_vid(gv_names(igv)), gkq_rot_ptr, &
7720 : : start=[1, 1, 1, 1, ik_glob, 1], &
7721 [ # # # # ]: 0 : count=[2, nb, nb, gqk%natom3, 1, gqk%my_nq])
7722 [ # # ]: 0 : NCF_CHECK(ncerr)
7723 : : end do
7724 [ # # ]: 0 : state_kq(ik_glob, :) = GSTORE_KQ_SYMMETRIZED
7725 : : end do ! my_ik
7726 : : end associate
7727 : :
7728 : : ! Update state_kq for this spin.
7729 [ # # ]: 0 : ncerr = nf90_put_var(ncid, vid("gstore_glob_state_kqs"), state_kq, start=[1,1,spin])
7730 [ # # ]: 0 : NCF_CHECK(ncerr)
7731 : :
7732 [ # # ]: 0 : ABI_FREE(qbz)
7733 [ # # ]: 0 : ABI_FREE(gkq_base)
7734 [ # # ]: 0 : ABI_FREE(gkq_rot)
7735 [ # # ]: 0 : ABI_FREE(state_kq)
7736 [ # # ]: 0 : ABI_FREE(gtmp)
7737 [ # # ]: 0 : ABI_FREE(dh_mat)
7738 [ # # ]: 0 : ABI_FREE(ket_mat)
7739 : : end do ! my_is
7740 : :
7741 [ # # ]: 0 : NCF_CHECK(nf90_close(ncid))
7742 : : if (DEBUG_DUMP_DH) close(789)
7743 : : if (DEBUG_DUMP_DH) close(790)
7744 : : if (DEBUG_DUMP_DH) close(791)
7745 : : if (DEBUG_DUMP_DH) close(792)
7746 : :
7747 [ # # ]: 0 : ABI_FREE(kibz2bz)
7748 : 0 : call gstore%free()
7749 : :
7750 : 0 : 100 call dmats%free()
7751 : 0 : call xmpi_barrier(comm)
7752 [ # # # # : 0 : call wrtout(units, " Symmetrization completed successfully.")
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
7753 : :
7754 : : contains
7755 : 0 : integer function vid(var_name)
7756 : : character(len=*),intent(in) :: var_name
7757 : 0 : vid = nctk_idname(ncid, var_name)
7758 : : end function vid
7759 : :
7760 : 0 : integer function spin_vid(var_name)
7761 : : character(len=*),intent(in) :: var_name
7762 : 0 : spin_vid = nctk_idname(spin_ncid, var_name)
7763 : : end function spin_vid
7764 : :
7765 : : end subroutine gstore_symmetrize
7766 : : !!***
7767 : :
7768 [ - + - - : 78498 : end module m_gstore
+ + - + +
- - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - - -
- - - + ]
7769 : : !!***
|
