Line data Source code
1 : !!****m* ABINIT/m_sigmaph
2 : !! NAME
3 : !! m_sigmaph
4 : !!
5 : !! FUNCTION
6 : !! Compute the matrix elements of the Fan-Migdal Debye-Waller self-energy in the KS basis set.
7 : !!
8 : !! COPYRIGHT
9 : !! Copyright (C) 2008-2026 ABINIT group (MG, HM)
10 : !! This file is distributed under the terms of the
11 : !! GNU General Public License, see ~abinit/COPYING
12 : !! or http://www.gnu.org/copyleft/gpl.txt .
13 : !!
14 : !! SOURCE
15 :
16 : #if defined HAVE_CONFIG_H
17 : #include "config.h"
18 : #endif
19 :
20 : #include "abi_common.h"
21 :
22 : module m_sigmaph
23 :
24 : use, intrinsic :: iso_c_binding
25 : use defs_basis
26 : use m_abicore
27 : USE_MPI
28 : use m_xmpi
29 : use m_mpinfo
30 : use m_errors
31 : use m_hide_blas
32 : use m_copy
33 : use m_ifc
34 : use m_ebands
35 : use m_ddk
36 : use m_dvdb, only : dvdb_t
37 : use m_fft
38 : use m_hamiltonian, only : gs_hamiltonian_type, rf_hamiltonian_type
39 : use m_pawcprj, only : pawcprj_type, pawcprj_free
40 : use m_wfd, only : wfd_t, u1_cache_t
41 : use m_wfk
42 : use m_skw
43 : use m_krank, only : krank_t
44 : use m_lgroup
45 : use m_ephwg
46 : use m_sort
47 : use m_hdr
48 : use m_sigtk
49 : use m_ephtk
50 : use m_eph_double_grid
51 : use netcdf
52 : use m_nctk
53 : use m_rf2
54 : use m_clib
55 : use m_mkffnl
56 :
57 : use defs_abitypes, only : mpi_type
58 : use m_dtfil, only : datafiles_type
59 : use m_dtset, only : dataset_type
60 : use defs_datatypes, only : pseudopotential_type
61 : use m_time, only : cwtime, cwtime_report, timab, sec2str
62 : use m_fstrings, only : itoa, ftoa, sjoin, ktoa, ltoa, strcat
63 : use m_numeric_tools, only : arth, c2r, get_diag, linfit, iseven, simpson_cplx, simpson, print_arr, inrange
64 : use m_io_tools, only : iomode_from_fname, file_exists, is_open, open_file, flush_unit
65 : use m_special_funcs, only : gaussian
66 : use m_fftcore, only : ngfft_seq, sphereboundary, get_kg, kgindex
67 : use m_cgtk, only : cgtk_rotate, cgtk_change_gsphere
68 : use m_cgtools, only : cg_zdotc, cg_real_zdotc, cg_zgemm
69 : use m_crystal, only : crystal_t
70 : use m_kpts, only : kpts_ibz_from_kptrlatt, kpts_timrev_from_kptopt, kpts_map
71 : use m_occ, only : occ_fd, occ_be
72 : use m_kg, only : getph, mkkpg
73 : use m_bz_mesh, only : isamek
74 : use m_getgh1c, only : getgh1c, rf_transgrid_and_pack
75 : use m_ioarr, only : read_rhor
76 : use m_paw_sphharm, only : ylm_angular_mesh
77 : use m_pawang, only : pawang_type
78 : use m_pawrad, only : pawrad_type
79 : use m_pawtab, only : pawtab_type
80 : use m_pawrhoij, only : pawrhoij_type
81 : use m_pawfgr, only : pawfgr_type
82 : use m_dfpt_cgwf, only : stern_t
83 : use m_phonons, only : phstore_t
84 : use m_pstat, only : pstat_proc
85 :
86 : implicit none
87 :
88 : private
89 : !!***
90 :
91 : #ifdef HAVE_MPI1
92 : include 'mpif.h'
93 : #endif
94 :
95 : ! Store the weights in single or double precision
96 : integer,private,parameter :: DELTAW_KIND = dp
97 : !integer,private,parameter :: DELTAW_KIND = sp
98 :
99 : !----------------------------------------------------------------------
100 :
101 : !!****t* m_sigmaph/sigmaph_t
102 : !! NAME
103 : !! sigmaph_t
104 : !!
105 : !! FUNCTION
106 : !! Container for the (diagonal) matrix elements of the electron-phonon self-energy
107 : !! in the KS representation i.e. Sigma_eph(omega, T, band, k, spin).
108 : !! Provides methods to compute QP corrections, spectral functions, QP linewidths and
109 : !! save the results to netcdf file.
110 : !!
111 : !! SOURCE
112 :
113 : type,public :: sigmaph_t
114 :
115 : integer :: nkcalc
116 : ! Number of k-points computed (inside energy window)
117 :
118 : integer :: max_nbcalc
119 : ! Maximum number of bands computed (max over nkcalc and spin).
120 :
121 : integer :: nsppol
122 : ! Number of independent spin polarizations.
123 :
124 : integer :: nspinor
125 : ! Number of spinor components.
126 :
127 : integer :: nwr
128 : ! Number of frequency points along the real axis for Sigma(w) and spectral function A(w)
129 : ! Odd number so that the mesh is centered on the KS energy.
130 : ! The spectral function is computed only if nwr > 0 (taken from dtset%nfreqsp)
131 :
132 : integer :: ntemp
133 : ! Number of temperatures.
134 :
135 : integer :: symsigma
136 : ! 1 if matrix elements should be symmetrized.
137 : ! Required when the sum over q in the BZ is replaced by IBZ(k).
138 :
139 : integer :: timrev
140 : ! timrev = 1 if the use of time-reversal is allowed; 0 otherwise
141 :
142 : integer :: nbsum
143 : ! Total number of bands used in sum over states without taking into account MPI distribution.
144 :
145 : integer :: bsum_start, bsum_stop
146 : ! First and last band included in self-energy sum without taking into account MPI distribution inside bsum_comm
147 : ! nbsum = bsum_stop - bsum_start + 1
148 :
149 : integer :: my_bsum_start, my_bsum_stop
150 : ! Initial and final band index included in self-energy sum
151 : ! Processor-dependent if Re-Im calculation.
152 : ! Processor-independent and computed at runtime on the basis of the nk states in Sigma_{nk} if imag_only
153 :
154 : integer :: my_npert
155 : ! Number of atomic perturbations or phonon modes treated by this MPI rank.
156 : ! Note that natom3 are equally distributed. This allows us to use allgather instead of allgatherv
157 :
158 : type(xcomm_t) :: pert_comm
159 : ! MPI communicator for parallelism over atomic perturbations.
160 :
161 : type(xcomm_t) :: qb_comm
162 : ! MPI communicator used to distribute (band_sum, q-points)
163 :
164 : type(xcomm_t) :: qpt_comm
165 : ! MPI communicator for q-points
166 :
167 : type(xcomm_t) :: bsum_comm
168 : ! MPI communicator for bands in self-energy sum
169 :
170 : type(xcomm_t) :: kcalc_comm
171 : ! MPI communicator for parallelism over k-points (high-level)
172 :
173 : type(xcomm_t) :: spin_comm
174 : ! MPI communicator for parallelism over spins (high-level)
175 :
176 : type(xcomm_t) :: pqb_comm
177 : ! MPI communicator for the (perturbation, band_sum, qpoint_sum)
178 :
179 : type(xcomm_t) :: ncwrite_comm
180 : ! MPI communicator for parallel netcdf IO used to write results for the different k-points/spins
181 :
182 : integer :: coords_pqbks(5)
183 : ! Cartesian coordinates of this processor in the Cartesian grid.
184 :
185 : integer :: nqbz
186 : ! Number of q-points in the (dense) BZ for sigma integration
187 :
188 : integer :: nqibz
189 : ! Number of q-points in the (dense) IBZ for sigma integration
190 :
191 : integer :: nqibz_k
192 : ! Number of q-points in the IBZ(k). Depends on ikcalc.
193 :
194 : integer :: my_nqibz_k
195 : ! Number of q-points in the IBZ(k) treated by this MPI proc. Depends on ikcalc.
196 : ! Differs from nqibz_k only if imag with tetra because in this case we can introduce a cutoff on the weights
197 :
198 : integer :: lgk_nsym
199 : ! Number of symmetries in the little group of k. Depends on ikcalc.
200 :
201 : integer :: ncid = nctk_noid
202 : ! Netcdf file handle used to save results.
203 :
204 : integer :: mpw
205 : ! Maximum number of PWs for all possible k+q
206 :
207 : integer :: bcorr = 0
208 : ! 1 to include Blochl correction in the tetrahedron method else 0.
209 :
210 : integer :: zinv_opt = 1
211 : ! Defines the algorithm used to compute the tetrahedron weights for 1/z if re-im computation
212 : ! 1 for S. Kaprzyk routines,
213 : ! 2 for Lambin-Vigneron.
214 :
215 : integer :: ntheta = 0, nphi = 0
216 : ! Number of division for spherical integration of Frohlich term.
217 :
218 : integer :: angl_size = 0
219 : ! Dimension of angular mesh for spherical integration of the Frohlich self-energy
220 : ! angl_size = ntheta * nphi
221 :
222 : complex(dp) :: ieta
223 : ! Used to shift the poles in the complex plane (Ha units)
224 : ! Corresponds to `i eta` term in equations.
225 :
226 : real(dp) :: elow, ehigh
227 : ! min and Max KS energy treated in self-energy +- max phonon energy
228 : ! Used to select bands in self-energy sum if imag_only and select q-points in qpoints_oracle
229 :
230 : real(dp) :: phwinfact = four
231 : ! phwinfact * wmax is used to define the energy window for filtering electronic states
232 : ! in the computation of electron lifetimes.
233 :
234 : real(dp) :: wr_step
235 : ! Step of the linear mesh along the real axis (Ha units).
236 :
237 : real(dp) :: wmax
238 : ! Max phonon energy + buffer. Used to select the bands to sum for the imaginary part
239 : ! and filter q-points on the basis of electron energy difference.
240 :
241 : integer :: qint_method
242 : ! Defines the method used for the q-space integration
243 : ! 0 -> Standard quadrature (one point per micro zone).
244 : ! 1 -> Use tetrahedron method.
245 :
246 : integer :: frohl_model = 0
247 : ! > 0 to treat the q --> 0 divergence and accelerate convergence in polar semiconductors.
248 : ! 1: Use spherical integration inside the micro zone around the Gamma point
249 :
250 : integer :: mrta = 0
251 : ! 0 to disable MRTA.
252 : ! > 0 if linewidths in the energy-momentum relaxation time approximation should be computed
253 :
254 : real(dp),allocatable :: scratew(:,:,:,:)
255 : ! (%phmesh_size, %ntemp, %max_nbcalc, 2)
256 :
257 : logical :: use_doublegrid = .False.
258 : ! whether to use double grid or not
259 :
260 : logical :: need_ftinterp = .False.
261 : ! whether DFPT potentials should be read from the DVDB or Fourier-interpolated on the fly.
262 :
263 : type(eph_double_grid_t) :: eph_doublegrid
264 : ! store the double grid related object
265 :
266 : logical :: imag_only
267 : ! True if only the imaginary part of the self-energy must be computed
268 :
269 : integer :: gmax(3)
270 :
271 : integer :: ngqpt(3)
272 : ! Number of divisions in the Q mesh in the BZ.
273 :
274 : integer,allocatable :: bstart_ks(:,:)
275 : ! bstart_ks(nkcalc, nsppol)
276 : ! Initial KS band index included in self-energy matrix elements for each k-point in kcalc.
277 : ! Depends on spin because all degenerate states should be included when symmetries are used.
278 :
279 : integer,allocatable :: bstop_ks(:,:)
280 : ! bstop_ks(nkcalc, nsppol)
281 :
282 : integer,allocatable :: nbcalc_ks(:,:)
283 : ! nbcalc_ks(nkcalc, nsppol)
284 : ! Number of bands included in self-energy matrix elements for each k-point in kcalc.
285 : ! Depends on spin because all degenerate states should be included when symmetries are used.
286 :
287 : integer,allocatable :: kcalc2ibz(:,:)
288 : !kcalc2ibz(nkcalc, 6))
289 : ! Mapping ikcalc --> IBZ as reported by listkk.
290 :
291 : integer :: my_nspins
292 : ! Number of spins treated by this MPI rank
293 :
294 : integer,allocatable :: my_spins(:)
295 : ! my_spins(my_nspins)
296 : ! Indirect table giving the spin indices treated by this MPI rank.
297 : ! Used only in the collinear case with nsppol = 2 and nspinor == 1
298 :
299 : integer :: my_nkcalc
300 : ! Number of k-points treated by this MPI rank
301 :
302 : integer,allocatable :: my_ikcalc(:)
303 : ! my_ikcalc(my_nkcalc)
304 : ! List of ikcalc indices treated by this pool if k-point parallelism is activated.
305 :
306 : integer,allocatable :: myq2ibz_k(:)
307 : ! myq2ibz_k(my_nqibz_k)
308 : ! Mapping my q-point index --> index in nqibz_k arrays (IBZ_k)
309 : ! Differs from nqibz_k only if imag with tetra because in this case we can introduce a cutoff.
310 :
311 : integer(i1b),allocatable :: itreat_qibz(:)
312 : ! itreat_qibz(nqibz)
313 : ! Table used to distribute potentials over q-points in the IBZ.
314 : ! The loop over qpts in the IBZ(k) is MPI distributed inside qpt_comm according to this table.
315 : ! 0 if this IBZ point is not treated by this proc.
316 : ! 1 if this IBZ is treated.
317 :
318 : integer,allocatable :: my_pinfo(:,:)
319 : ! my_pinfo(3, my_npert)
320 : ! my_pinfo(1, ip) gives the `idir` index of the ip-th perturbation.
321 : ! my_pinfo(2, ip) gives the `ipert` index of the ip-th perturbation.
322 : ! my_pinfo(3, ip) gives `pertcase`=idir + (ipert-1)*3
323 :
324 : integer,allocatable :: pert_table(:,:)
325 : ! pert_table(2, natom3)
326 : ! pert_table(1, npert): rank of the processor treating this atomic perturbation.
327 : ! pert_table(2, npert): imyp index in my_pinfo table, -1 if this rank is not treating ipert.
328 :
329 : integer,allocatable :: phmodes_skip(:)
330 : ! (natom3)
331 : ! A mask to skip accumulating the contribution of certain phonon modes
332 :
333 : integer,allocatable:: ind_qbz2ibz(:,:)
334 : ! (6, %nqibz)
335 : ! Mapping qBZ to IBZ
336 :
337 : integer,allocatable:: indkk_kq(:, :)
338 : ! (6, %nqibz_k))
339 : ! Mapping k+q --> initial IBZ. Depends on ikcalc.
340 : ! These table used the conventions for the symmetrization of the wavefunctions expected by cgtk_rotate.
341 : ! In this case listkk has been called with symrel and use_symrec=False
342 :
343 : integer,allocatable :: ind_q2dvdb_k(:,:)
344 : ! (6, %nqibz_k))
345 : ! Mapping qibz_k --> IBZ found in DVDB file.
346 : ! Used when DFPT potentials are read from DVDB file so that we know how to access/symmetrize v1scf
347 : ! Depends on ikcalc.
348 :
349 : integer,allocatable :: ind_ibzk2ibz(:,:)
350 : ! (6, %nqibz_k))
351 : ! Mapping qibz_k --> IBZ defined by eph_ngqpt_fine.
352 : ! Depends on ikcalc.
353 :
354 : integer,allocatable :: qibz2dvdb(:)
355 : ! (%nqibz))
356 : ! Mapping dvdb%ibz --> %ibz
357 :
358 : integer, allocatable :: lgk_sym2glob(:, :)
359 : ! lgk_sym2glob(2, lgk_nsym)
360 : ! Mapping isym_lg --> [isym, itime]
361 : ! where isym is the index of the operation in the global array **crystal%symrec**
362 : ! and itim is 2 if time-reversal T must be included else 1. Depends on ikcalc
363 :
364 : integer,allocatable :: nbsum_rank(:,:)
365 : ! (%bsum_comm%nproc, 2)
366 : ! (rank+1, 1): Number of bands treated by rank in %bsum_comm.
367 : ! (rank+1, 2): bsum_start of MPI rank
368 : ! Available only if .not. imag_only
369 :
370 : real(dp),allocatable :: kcalc(:,:)
371 : ! kcalc(3, nkcalc)
372 : ! List of k-points where the self-energy is computed.
373 :
374 : real(dp),allocatable :: qbz(:,:)
375 : ! qbz(3, nqbz)
376 : ! Reduced coordinates of the q-points in the full BZ.
377 :
378 : real(dp),allocatable :: qibz(:,:)
379 : ! qibz(3, nqibz)
380 : ! Reduced coordinates of the q-points in the IBZ (full symmetry of the system).
381 :
382 : real(dp),allocatable :: wtq(:)
383 : ! wtq(nqibz)
384 : ! Weights of the q-points in the IBZ (normalized to one).
385 :
386 : real(dp),allocatable :: qibz_k(:,:)
387 : ! qibz(3, nqibz_k)
388 : ! Reduced coordinates of the q-points in the IBZ(k). Depends on ikcalc.
389 :
390 : real(dp),allocatable :: wtq_k(:)
391 : ! wtq(nqibz_k)
392 : ! Weights of the q-points in the IBZ(k) (normalized to one). Depends on ikcalc.
393 :
394 : real(dp),allocatable :: srate(:,:,:,:)
395 : ! (%bsum_start:%bsum_stop, %nbcalc_ks(ikcalc, spin), %ntemp, %my_nqibz_k))
396 : ! This array is initialized inside the (ikcalc, spin) loop
397 :
398 : real(dp),allocatable :: kTmesh(:)
399 : ! kTmesh(ntemp)
400 : ! List of temperatures (kT units).
401 :
402 : real(dp),allocatable :: mu_e(:)
403 : ! mu_e(ntemp)
404 : ! chemical potential of electrons for the different temperatures.
405 :
406 : real(dp),allocatable :: e0vals(:)
407 : ! (nbcalc_ks)
408 : ! KS energies where QP corrections are wantend
409 : ! This array is initialized inside the (ikcalc, spin) loop
410 :
411 : real(dp),allocatable :: vcar_calc(:,:,:,:)
412 : ! (3, max_nbcalc, nkcalc, nsppol))
413 : ! Diagonal elements of velocity operator in cartesian coordinates for all states in Sigma_nk.
414 :
415 : real(dp),allocatable :: linewidth_mrta(:,:)
416 : ! linewidth_mrta(ntemp, max_nbcalc)
417 : ! Linewidths computed within the momentum relaxation time approximation
418 : ! for given (ikcalc, spin). Only if imag_only
419 :
420 : complex(dp),allocatable :: cweights(:,:,:,:,:,:,:)
421 : ! (nz, 2, nbcalc_ks, my_npert, my_bsum_start:my_bsum_stop, my_nqibz_k, ndiv))
422 : ! Weights for the q-integration of 1 / (e1 - e2 \pm w_{q, nu} + i.eta)
423 : ! This array is initialized inside the (ikcalc, spin) loop
424 :
425 : real(kind=DELTAW_KIND),allocatable :: deltaw_pm(:,:,:,:,:,:)
426 : ! (2, nbcalc_ks, my_npert, bsum_start:bsum_stop, my_nqibz_k, ndiv))
427 : ! Weights for the q-integration of the two delta (abs/emission) if imag_only
428 : ! This array is initialized inside the (ikcalc, spin) loop
429 :
430 : real(dp),allocatable :: wrmesh_b(:,:)
431 : ! wrmesh_b(nwr, max_nbcalc)
432 : ! Frequency mesh along the real axis (Ha units) used for the different bands
433 : ! Each mesh is **centered** on the corresponding KS energy.
434 : ! This array depends on (ikcalc, spin)
435 :
436 : real(dp), allocatable :: qvers_cart(:,:)
437 : ! qvers_cart(3, angl_size)
438 : ! For each point of the angular mesh, gives the Cartesian coordinates
439 : ! of the corresponding point on an unitary sphere (Frohlich self-energy)
440 :
441 : real(dp), allocatable :: angwgth(:)
442 : ! angwgth(angl_size)
443 : ! For each point of the angular mesh, gives the weight
444 : ! of the corresponding point on an unitary sphere (Frohlich self-energy)
445 :
446 : real(dp),allocatable :: frohl_deltas_sphcorr(:,:,:,:)
447 : ! (2, ntemp, max_nbcalc, natom3))
448 : ! Integration of the imaginary part inside the small sphere around Gamma
449 : ! computed numerically with the Frohlich model by Verdi and angular integration.
450 : ! The first dimension stores the contributions due to +/- omega_qn
451 : ! Used if frohl_model == 1 and imag_only. This array depend on (ikcalc, spin)
452 : ! TODO: Finalize implementation
453 :
454 : real(dp),allocatable :: E2(:)
455 : ! E2(ntemp)
456 : ! Second-order contribution to total energy
457 :
458 : integer, allocatable :: qp_done(:,:)
459 : ! qp_done(kcalc, spin)
460 : ! Keep track of the QP states already computed for restart of the calculation
461 :
462 : complex(dp),allocatable :: vals_e0ks(:,:)
463 : ! vals_e0ks(ntemp, max_nbcalc)
464 : ! Sigma_eph(omega=eKS, kT, band) for given (ikcalc, spin).
465 : ! Fan-Migdal + Debye-Waller
466 :
467 : complex(dp),allocatable :: fan_vals(:,:)
468 : ! fan_vals(ntemp, max_nbcalc)
469 : ! Fan-Migdal
470 :
471 : complex(dp),allocatable :: E4_vals(:,:)
472 : ! E4_vals(ntemp, max_nbcalc)
473 : ! nk resolved 4th order contribution to total energy
474 :
475 : complex(dp),allocatable :: E4_vals2(:,:)
476 : ! E4_vals2(ntemp, max_nbcalc)
477 : ! nk resolved 4th order contribution to total energy, alternative derivation with g^2
478 :
479 : complex(dp),allocatable :: fan_stern_vals(:,:)
480 : ! fan_stern_vals(ntemp, max_nbcalc)
481 : ! Fan-Migdal adiabatic Sternheimer part
482 :
483 : complex(dp),allocatable :: dvals_de0ks(:,:)
484 : ! dvals_de0ks(ntemp, max_nbcalc) for given (ikcalc, spin)
485 : ! d Re Sigma_eph(omega, kT, band, kcalc, spin) / d omega (omega=eKS)
486 :
487 : complex(dp),allocatable :: frohl_dvals_de0ks(:,:)
488 : ! frohl_dvals_de0ks(ntemp, max_nbcalc) for given (ikcalc, spin)
489 : ! d Re Sigma_frohl(omega, kT, band, kcalc, spin) / d omega (omega=eKS)
490 :
491 : real(dp),allocatable :: dw_vals(:,:)
492 : ! dw_vals(ntemp, max_nbcalc) for given (ikcalc, spin)
493 : ! Debye-Waller term (static).
494 :
495 : real(dp),allocatable :: dw_stern_vals(:,:)
496 : ! dw_stern_vals(ntemp, max_nbcalc) for given (ikcalc, spin)
497 : ! Debye-Waller Sternheimer term (static) .
498 :
499 : complex(dp),allocatable :: vals_wr(:,:,:)
500 : ! vals_wr(nwr, ntemp, max_nbcalc)
501 : ! Sigma_eph(omega, kT, band) for given (ikcalc, spin).
502 : ! enk_KS corresponds to nwr/2 + 1.
503 : ! This array depends on (ikcalc, spin)
504 :
505 : integer :: phmesh_size
506 : ! Number of phonon frequencies in phonon mesh used for Eliashberg functions and
507 : ! and other omega-resolved quantities.
508 :
509 : real(dp),allocatable :: phmesh(:)
510 : ! phmesh(phmesh_size)
511 : ! phonon mesh in Ha.
512 :
513 : real(dp),allocatable :: gf_nnuq(:,:,:,:)
514 : ! (nbcalc_ks, natom3, %nqibz_k, 3)
515 : ! Quantities needed to compute the generalized Eliashberg functions (gkq2/Fan-Migdal/DW terms)
516 : ! This array depends on (ikcalc, spin)
517 : ! NB: q-weights for integration are not included.
518 :
519 : real(dp),allocatable :: gfw_vals(:,:,:)
520 : ! gfw_vals(phmesh_size, 3, max_nbcalc)
521 : ! Generalized Eliashberg function a2F_{n,k,spin}(w)
522 : ! 1: |g(k,q)|^2 with delta(e_\nk - e_{m\kq})
523 : ! 2: Fan-Migdal in the adiabatic approximation
524 : ! 3: DW contribution in the adiabatic approximation.
525 : ! This array depends on (ikcalc, spin)
526 :
527 : integer :: a2f_ne = 0
528 : ! Number of points in a2f_emesh
529 :
530 : real(dp),allocatable :: a2f_emesh(:)
531 : ! a2f_emesh(a2f_ne)
532 : ! Energy mesh for electrons
533 :
534 : real(dp),allocatable :: a2few(:,:,:)
535 : ! a2few(a2f_ne, phmesh_size, max_nbcalc)
536 : ! FM Eliashberg function a2f_\nk(e, w) = \sum_{mq} |g(k,q)|^2 delta(e - e_{m\kq}) delta(w - w_\qnu}
537 : ! This array depends on (ikcalc, spin) and is computed only if prteliash == 3
538 :
539 : type(ephwg_t) :: ephwg
540 : ! This object computes the weights for the BZ integration in q-space if qint_method > 0
541 :
542 : type(degtab_t),allocatable :: degtab(:,:)
543 : ! (nkcalc, nsppol)
544 : ! Table used to average QP results in the degenerate subspace if symsigma == 1
545 :
546 : contains
547 :
548 : procedure :: write => sigmaph_write
549 : ! Write main dimensions and header of sigmaph on a netcdf file.
550 :
551 : procedure :: compare => sigmaph_compare
552 : ! Compare two instances of sigmaph raise error if different
553 :
554 : procedure :: setup_kcalc => sigmaph_setup_kcalc
555 : ! Return tables used to perform the sum over q-points for given k-point.
556 :
557 : procedure :: gather_and_write => sigmaph_gather_and_write
558 : ! Compute the QP corrections.
559 :
560 : procedure :: print => sigmaph_print
561 : ! Print results to main output file.
562 :
563 : procedure :: free => sigmaph_free
564 : ! Free sigmaph object
565 :
566 : procedure :: get_ebands => sigmaph_get_ebands
567 : ! Fill in values in ebands from the sigmaph structure and netcdf file
568 :
569 : !procedure :: skip_phmode => sigmaph_skip_phmode
570 : ! Ignore contribution of phonon mode depending on phonon frequency value or mode index.
571 :
572 : end type sigmaph_t
573 : !!***
574 :
575 : public :: sigmaph ! Main entry point to compute self-energy matrix elements
576 : public :: sigmaph_read ! Read main dimensions and header of sigmaph from a netcdf file.
577 : private :: sigmaph_new ! Creation method (allocates memory, initialize data from input vars).
578 :
579 : real(dp),private,parameter :: TOL_EDIFF = 0.001_dp * eV_Ha
580 :
581 : type frohl_integrator_t
582 : integer :: ntheta = 0, nphi = 0
583 : ! Number of division for spherical integration of Frohlich term.
584 :
585 : integer :: angl_size = 0
586 : ! Dimension of angular mesh for spherical integration of the Frohlich self-energy
587 : ! angl_size = ntheta * nphi
588 :
589 : real(dp), allocatable :: qvers_cart(:,:)
590 : ! qvers_cart(3, angl_size)
591 : ! For each point of the angular mesh, gives the Cartesian coordinates
592 : ! of the corresponding point on an unitary sphere (Frohlich self-energy)
593 :
594 : real(dp), allocatable :: angwgth(:)
595 : ! angwgth(angl_size)
596 : ! For each point of the angular mesh, gives the weight
597 : ! of the corresponding point on an unitary sphere (Frohlich self-energy)
598 :
599 : real(dp), allocatable :: phfrq(:,:)
600 : real(dp), allocatable :: displ_cart(:,:,:,:,:)
601 :
602 : contains
603 : procedure :: init => frohl_integrator_init
604 : procedure :: free => frohl_integrator_free
605 : !procedure :: eval => frohl_integrator_eval
606 : procedure :: eval_isotropic_avg => frohl_integrator_eval_isotropic_avg
607 : end type frohl_integrator_t
608 :
609 : !----------------------------------------------------------------------
610 :
611 : contains !=====================================================
612 : !!***
613 :
614 : !----------------------------------------------------------------------
615 :
616 : !!****f* m_sigmaph/sigmaph
617 : !! NAME
618 : !! sigmaph
619 : !!
620 : !! FUNCTION
621 : !! Compute phonon-contribution to the electron self-energy.
622 : !!
623 : !! INPUTS
624 : !! wfk0_path=String with the path to the GS unperturbed WFK file.
625 : !! dtfil<datafiles_type>=Variables related to files.
626 : !! ngfft(18),ngfftf(18)=Coarse and Fine FFT meshes.
627 : !! dtset<dataset_type>=All input variables for this dataset.
628 : !! cryst: Crystalline structure
629 : !! ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...)
630 : !! dvdb<dbdb_type>=Database with the DFPT SCF potentials.
631 : !! ifc<ifc_type>=interatomic force constants and corresponding real space grid info.
632 : !! wfk_hdr=Header of the WFK file.
633 : !! pawfgr <type(pawfgr_type)>=fine grid parameters and related data
634 : !! pawang<pawang_type)>=PAW angular mesh and related data.
635 : !! pawrad(ntypat*usepaw)<pawrad_type>=Paw radial mesh and related data.
636 : !! pawtab(ntypat*usepaw)<pawtab_type>=Paw tabulated starting data.
637 : !! psps<pseudopotential_type>=Variables related to pseudopotentials.
638 : !! comm=MPI communicator.
639 : !!
640 : !! OUTPUT
641 : !!
642 : !! SOURCE
643 :
644 58 : subroutine sigmaph(wfk0_path, dtfil, ngfft, ngfftf, dtset, cryst, ebands, dvdb, ifc, wfk_hdr, &
645 58 : pawfgr, pawang, pawrad, pawtab, psps, mpi_enreg, comm)
646 :
647 : !Arguments ------------------------------------
648 : !scalars
649 : character(len=*),intent(in) :: wfk0_path
650 : integer,intent(in) :: comm
651 : type(datafiles_type),intent(in) :: dtfil
652 : type(dataset_type),intent(in) :: dtset
653 : type(crystal_t),intent(in) :: cryst
654 : type(ebands_t),intent(in) :: ebands
655 : type(dvdb_t),intent(inout) :: dvdb
656 : type(pawang_type),intent(in) :: pawang
657 : type(pseudopotential_type),intent(in) :: psps
658 : type(pawfgr_type),intent(in) :: pawfgr
659 : type(ifc_type),intent(in) :: ifc
660 : type(hdr_type),intent(in) :: wfk_hdr
661 : type(mpi_type),intent(inout) :: mpi_enreg
662 : !arrays
663 : integer,intent(in) :: ngfft(18),ngfftf(18)
664 : type(pawrad_type),intent(in) :: pawrad(psps%ntypat*psps%usepaw)
665 : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
666 :
667 : !Local variables ------------------------------
668 : !scalars
669 : integer,parameter :: tim_getgh1c1 = 1, berryopt0 = 0, ider0 = 0, idir0 = 0, istwfk_1 = 1
670 : integer,parameter :: useylmgr0 = 0, master = 0, ndat1 = 1, cplex1 = 1, pawread0 = 0, optder0 = 0
671 : integer :: band_me, nband_me
672 : integer :: my_rank,nsppol,nkpt,iq_ibz,iq_ibz_k,my_npert ! iq_ibz_frohl,iq_bz_frohl,
673 : integer :: cplex,db_iqpt,natom,natom3,ipc,nspinor,nprocs, qptopt ! = 1
674 : integer :: ibsum_kq, ib_k, u1c_ib_k, band_ks, u1_band, ibsum, ii, jj, iw !ib_kq,
675 : integer :: u1_master, ip, sfact
676 : integer :: ig, ispinor, ifft !nband_kq,
677 : integer :: idir,ipert,ip1,ip2 !,idir1,ipert1,idir2,ipert2
678 : integer :: ik_ibz,ikq_ibz,isym_k,isym_kq,trev_k,trev_kq, isym_q, trev_q
679 : integer :: iq_ibz_fine,ikq_ibz_fine,ikq_bz_fine
680 : integer :: my_spin, spin, istwf_k, istwf_kq, istwf_kqirr, npw_k, npw_kq, npw_kqirr
681 : integer :: mpw,ierr,it,imyq,band, ignore_kq, ignore_ibsum_kq
682 : integer :: n1,n2,n3,n4,n5,n6,nspden,nu, iang
683 : integer :: sij_opt,usecprj,usevnl,optlocal,optnl,opt_gvnlx1
684 : integer :: nfft,nfftf,mgfft,mgfftf,nkpg,nkpg_kq,nq,cnt,imyp, q_start, q_stop, restart, enough_stern
685 : integer :: nbcalc_ks,nbsum,bsum_start, bsum_stop, bstart_ks,my_ikcalc,ikcalc,bstart,bstop,iatom, sendcount
686 : integer :: comm_rpt, osc_npw, stern_comm !, ntheta
687 : integer :: nelem, cgq_request ! ffnl_k_request, ffnl_kq_request,
688 : real(dp) :: cpu,wall,gflops,cpu_all,wall_all,gflops_all,cpu_ks,wall_ks,gflops_ks,cpu_dw,wall_dw,gflops_dw
689 : real(dp) :: cpu_setk, wall_setk, gflops_setk, cpu_qloop, wall_qloop, gflops_qloop, gf_val
690 : real(dp) :: ecut,eshift,weight_q,rfact,gmod2,hmod2,ediff,weight, inv_qepsq, simag, q0rad
691 : real(dp) :: vkk_norm, vkq_norm, osc_ecut, bz_vol
692 : complex(dp) :: cfact,cnum, sig_cplx, cfact2 ! dka,dkap,dkpa,dkpap,
693 : logical :: isirr_k, isirr_kq, gen_eigenpb, q_is_gamma, isirr_q, use_ifc_fourq, stern_use_cache, intra_band, same_band
694 : logical :: zpr_frohl_sphcorr_done, stern_has_band_para
695 58 : type(wfd_t) :: wfd
696 58 : type(gs_hamiltonian_type) :: gs_ham_kq
697 58 : type(rf_hamiltonian_type) :: rf_ham_kq
698 58 : type(sigmaph_t) :: sigma, sigma_restart
699 580 : type(ddkop_t) :: ddkop
700 3016 : type(crystal_t) :: pot_cryst
701 58 : type(hdr_type) :: pot_hdr
702 58 : type(phstore_t) :: phstore
703 58 : type(u1_cache_t) :: u1c
704 58 : type(stern_t) :: stern
705 : !type(frohl_integrator_t) :: frohl
706 : character(len=5000) :: msg
707 : character(len=fnlen) :: sigeph_filepath
708 : !arrays
709 : integer :: g0_k(3),g0_kq(3), units(2), work_ngfft(18), gmax(3)
710 58 : integer(i1b),allocatable :: itreatq_dvdb(:)
711 116 : integer,allocatable :: kg_k(:,:),kg_kq(:,:),nband(:,:), qselect(:), wfd_istwfk(:)
712 116 : integer,allocatable :: gbound_kq(:,:), osc_gbound_q(:,:), osc_gvecq(:,:), osc_indpw(:), root_bcalc(:)
713 58 : integer,allocatable :: ibzspin_2ikcalc(:,:)
714 116 : integer, allocatable :: recvcounts(:), displs(:)
715 116 : real(dp) :: kk(3),kq(3),kk_ibz(3),kq_ibz(3),qpt(3),qpt_cart(3),phfrq(3*cryst%natom), dotri(2),qq_ibz(3)
716 : real(dp) :: vk(3), vkq(3), tsec(2), eminmax(2), etot
717 174 : real(dp) :: zpr_frohl_sphcorr(3*cryst%natom), vec_natom3(2, 3*cryst%natom)
718 : real(dp) :: wqnu,nqnu,gkq2,gkq2_pf,eig0nk,eig0mk,eig0mkq,f_mkq,f_nk, gdw2, gdw2_stern, rtmp
719 116 : real(dp) :: fermie1_idir_ipert(3,cryst%natom)
720 58 : real(dp),allocatable :: displ_cart(:,:,:,:),displ_red(:,:,:,:)
721 58 : real(dp),allocatable :: grad_berry(:,:),kinpw_k(:), kinpw_kq(:),kpg_kq(:,:),kpg_k(:,:)
722 116 : real(dp),allocatable :: ffnl_k(:,:,:,:),ffnl_kq(:,:,:,:),ph3d_k(:,:,:),ph3d_kq(:,:,:),v1scf(:,:,:,:)
723 58 : real(dp),allocatable :: gkq_atm(:,:,:),gkq_nu(:,:,:),gkq0_atm(:,:,:,:), gaussw_qnu(:)
724 116 : real(dp),allocatable :: cg1s_kq(:,:,:,:), h1kets_kq_allperts(:,:,:,:)
725 58 : real(dp),allocatable :: stern_ppb(:,:,:,:), stern_dw(:,:,:,:)
726 116 : logical,allocatable :: ihave_ikibz_spin(:,:), bks_mask(:,:,:),keep_ur(:,:,:), osc_mask(:)
727 58 : real(dp),allocatable :: E4stern_nk(:,:,:,:)
728 116 : real(dp),allocatable :: bra_kq(:,:),kets_k(:,:,:),h1kets_kq(:,:,:,:),cgwork(:,:)
729 116 : real(dp),allocatable :: ph1d(:,:),vlocal(:,:,:,:),vlocal1(:,:,:,:,:)
730 116 : real(dp),allocatable :: vtrial(:,:),gvnlx1(:,:),work(:,:,:,:), vcar_ibz(:,:,:,:)
731 116 : real(dp),allocatable :: gs1c(:,:),nqnu_tlist(:),dtw_weights(:,:),dt_tetra_weights(:,:,:),dwargs(:),alpha_mrta(:)
732 58 : real(dp),allocatable :: delta_e_minus_emkq(:), gkq_allgather(:,:,:),f_tlist_b(:,:)
733 : !real(dp),allocatable :: phfreqs_qibz(:,:), pheigvec_qibz(:,:,:,:), eigvec_qpt(:,:,:)
734 58 : real(dp),allocatable :: gkq2_lr(:,:,:), E4(:)
735 : complex(dp) :: cp3(3)
736 58 : complex(dp),allocatable :: osc_ks(:,:), fmw_frohl_sphcorr(:,:,:,:), cfact_wr(:), tpp_red(:,:)
737 58 : complex(gwp),allocatable :: ur_k(:,:), ur_kq(:), work_ur(:), workq_ug(:)
738 58 : type(pawcprj_type),allocatable :: cwaveprj0(:,:), cwaveprj(:,:)
739 58 : type(pawrhoij_type),allocatable :: pot_pawrhoij(:)
740 : #if defined HAVE_MPI && !defined HAVE_MPI2_INPLACE
741 : integer :: me
742 : real(dp),allocatable :: cgq_buf(:)
743 : real(dp),pointer :: cgq_ptr(:)
744 : #endif
745 : !************************************************************************
746 :
747 58 : if (psps%usepaw == 1) then
748 0 : ABI_ERROR("PAW not implemented")
749 : ABI_UNUSED((/pawang%nsym, pawrad(1)%mesh_size/))
750 : end if
751 :
752 58 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
753 58 : call cwtime(cpu_all, wall_all, gflops_all, "start")
754 :
755 174 : units = [std_out, ab_out]
756 :
757 58 : call pstat_proc%print(_PSTAT_ARGS_)
758 :
759 : ! Copy important dimensions
760 58 : natom = cryst%natom; natom3 = 3 * natom; nsppol = ebands%nsppol; nspinor = ebands%nspinor
761 58 : nspden = dtset%nspden; nkpt = ebands%nkpt
762 :
763 518 : stern_has_band_para = .False.; fermie1_idir_ipert = zero
764 :
765 : ! FFT meshes from input file, not necessarily equal to the ones found in the external files.
766 232 : nfftf = product(ngfftf(1:3)); mgfftf = maxval(ngfftf(1:3))
767 406 : nfft = product(ngfft(1:3)) ; mgfft = maxval(ngfft(1:3))
768 58 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
769 58 : n4 = ngfft(4); n5 = ngfft(5); n6 = ngfft(6)
770 :
771 : ! Get one-dimensional structure factor information on the coarse grid.
772 174 : ABI_MALLOC(ph1d, (2,3*(2*mgfft+1)*natom))
773 58 : call getph(cryst%atindx, natom, n1, n2, n3, ph1d, cryst%xred)
774 :
775 58 : ecut = dtset%ecut ! dtset%dilatmx
776 :
777 : ! Check if a previous netcdf file is present and restart the calculation
778 : ! Here we try to read an existing SIGEPH file if eph_restart == 1.
779 : ! and we compare the variables with the state of the code (i.e. new sigmaph generated in sigmaph_new)
780 58 : restart = 0; ierr = 1; sigeph_filepath = strcat(dtfil%filnam_ds(4), "_SIGEPH.nc")
781 58 : if (my_rank == master .and. dtset%eph_restart == 1) then
782 58 : sigma_restart = sigmaph_read(sigeph_filepath, dtset, xmpi_comm_self, msg, ierr)
783 : end if
784 :
785 : ! Construct object to store final results.
786 58 : sigma = sigmaph_new(dtset, ecut, cryst, ebands, ifc, dtfil, comm)
787 :
788 58 : if (my_rank == master .and. dtset%eph_restart == 1) then
789 58 : if (ierr == 0) then
790 0 : if (any(sigma_restart%qp_done /= 1)) then
791 0 : call sigma%compare(sigma_restart)
792 : ! Get list of QP states that have been computed.
793 0 : sigma%qp_done = sigma_restart%qp_done
794 0 : restart = 1
795 0 : call wrtout(units, "- Restarting from previous SIGEPH.nc file")
796 0 : call wrtout(units, sjoin("- Number of k-points completed:", itoa(count(sigma%qp_done == 1)), "/", itoa(sigma%nkcalc)))
797 : else
798 : ! Previous computation completed, keep a backup of the file and start from scratch.
799 0 : restart = 0; sigma%qp_done = 0
800 : msg = sjoin("Found SIGEPH.nc file with all QP entries already computed.", ch10, &
801 : "Will overwrite:", sigeph_filepath, ch10, &
802 0 : "Keeping backup copy in:", strcat(sigeph_filepath, ".bkp"))
803 0 : call wrtout(ab_out, sjoin("WARNING: ", msg))
804 0 : ABI_WARNING(msg)
805 : ! Keep backup copy
806 0 : ABI_CHECK(clib_rename(sigeph_filepath, strcat(sigeph_filepath, ".bkp")) == 0, "Failed to rename SIGPEPH file.")
807 : end if
808 : end if
809 58 : call sigma_restart%free()
810 : end if
811 :
812 58 : call xmpi_bcast(restart, master, comm, ierr)
813 58 : call xmpi_bcast(sigma%qp_done, master, comm, ierr)
814 :
815 58 : if (restart == 0) then
816 58 : call sigma%write(dtset, cryst, ebands, wfk_hdr, dtfil, comm)
817 : else
818 : ! Open file inside ncwrite_comm to perform parallel IO if kpt parallelism.
819 0 : if (sigma%ncwrite_comm%value /= xmpi_comm_null) then
820 0 : NCF_CHECK(nctk_open_modify(sigma%ncid, sigeph_filepath, sigma%ncwrite_comm%value))
821 0 : NCF_CHECK(nctk_set_datamode(sigma%ncid))
822 : end if
823 : end if
824 :
825 58 : if (.not. sigma%imag_only .and. sigma%frohl_model /= 0 .and. .not. dvdb%has_zeff) sigma%frohl_model = 0
826 :
827 58 : if (my_rank == master) then
828 58 : call sigma%print(dtset, ab_out)
829 58 : call sigma%print(dtset, std_out)
830 : end if
831 58 : my_npert = sigma%my_npert
832 :
833 : ! This is the maximum number of PWs for all possible k+q treated.
834 232 : mpw = sigma%mpw; gmax = sigma%gmax
835 :
836 : ! Init work_ngfft
837 232 : gmax = gmax + 4 ! FIXME: this is to account for umklapp, should also consider Gamma-only and istwfk
838 232 : gmax = 2*gmax + 1
839 58 : call ngfft_seq(work_ngfft, gmax)
840 : !write(std_out,*)"work_ngfft(1:3): ",work_ngfft(1:3)
841 290 : ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
842 :
843 : ! Initialize the wave function descriptor.
844 : ! Each node has all k-points and spins and bands between my_bsum_start and my_bsum_stop
845 232 : ABI_MALLOC(nband, (nkpt, nsppol))
846 290 : ABI_MALLOC(bks_mask, (dtset%mband, nkpt, nsppol))
847 232 : ABI_MALLOC(keep_ur, (dtset%mband, nkpt ,nsppol))
848 :
849 95990 : nband = dtset%mband; bks_mask = .False.; keep_ur = .False.
850 :
851 : ! Mapping Sigma_{k,s} states to IBZ. -1 if not computed
852 174 : ABI_MALLOC(ibzspin_2ikcalc, (nkpt, nsppol))
853 4186 : ibzspin_2ikcalc = -1
854 :
855 : ! Each node needs the wavefunctions for Sigma_{nk}
856 : ! TODO: kcalc should depend on the spin!
857 :
858 116 : do spin=1,sigma%nsppol
859 298 : do ikcalc=1,sigma%nkcalc
860 182 : ik_ibz = sigma%kcalc2ibz(ikcalc, 1)
861 182 : bstart = sigma%bstart_ks(ikcalc, spin)
862 182 : bstop = bstart + sigma%nbcalc_ks(ikcalc, spin) - 1
863 966 : bks_mask(bstart:bstop, ik_ibz, spin) = .True.
864 240 : ibzspin_2ikcalc(ik_ibz, spin) = ikcalc
865 : end do
866 : end do
867 :
868 : ! For the imaginay part, add bands outside the energy window to account for ph absorption/emission
869 58 : if (sigma%imag_only .and. sigma%qint_method == 1) then
870 16 : call wrtout(std_out, " Including restricted set of states within energy window around relevant states.", newlines=1)
871 32 : do spin=1,sigma%nsppol
872 3558 : do ik_ibz=1,ebands%nkpt
873 7411 : do band=sigma%my_bsum_start, sigma%my_bsum_stop
874 3869 : eig0mk = ebands%eig(band, ik_ibz, spin)
875 3869 : if (eig0mk >= sigma%elow - sigma%phwinfact * sigma%wmax .and. &
876 3526 : eig0mk <= sigma%ehigh + sigma%phwinfact * sigma%wmax) then
877 317 : bks_mask(band, ik_ibz ,spin) = .True.
878 : end if
879 : end do
880 : end do
881 : end do
882 : ! Uncomment these lines to disable energy window trick and allocate all bands.
883 : !if (dtset%userie == 123) then
884 : ! call wrtout(std_out, " Storing all bands between my_bsum_start and my_bsum_stop.")
885 : ! bks_mask(sigma%my_bsum_start:sigma%my_bsum_stop, : ,:) = .True.
886 : !end if
887 : else
888 11836 : bks_mask(sigma%my_bsum_start:sigma%my_bsum_stop, : ,:) = .True.
889 : endif
890 :
891 : !if (dtset%userie == 124) then
892 : ! ! Uncomment this line to have all states on each MPI rank.
893 : ! bks_mask = .True.; call wrtout(std_out, " Storing all bands for debugging purposes.")
894 : !end if
895 :
896 : ! This table is needed when computing the imaginary part:
897 : ! k+q states outside the energy window are not read hence their contribution won't be included.
898 : ! Error is small provided calculation is close to convergence.
899 : ! To reduce the error one should increase the value of phwinfact
900 232 : ABI_MALLOC(ihave_ikibz_spin, (nkpt, nsppol))
901 4186 : ihave_ikibz_spin = .False.
902 116 : do spin=1,sigma%nsppol
903 4186 : do ik_ibz=1,ebands%nkpt
904 33448 : if (any(bks_mask(:, ik_ibz, spin))) ihave_ikibz_spin(ik_ibz, spin) = .True.
905 : end do
906 : end do
907 :
908 : ! Impose istwfk=1 for all k points. This is also done in respfn (see inkpts)
909 : ! wfd_read_wfk will handle a possible conversion if WFK contains istwfk /= 1.
910 174 : ABI_MALLOC(wfd_istwfk, (nkpt))
911 4128 : wfd_istwfk = 1
912 :
913 : call wfd%init(cryst, pawtab, psps, keep_ur, dtset%mband, nband, nkpt, nsppol, bks_mask,&
914 : nspden, nspinor, ecut, dtset%ecutsm, dtset%dilatmx, wfd_istwfk, ebands%kptns, ngfft,&
915 58 : dtset%nloalg, dtset%prtvol, dtset%pawprtvol, comm)
916 :
917 116 : call wfd%print([std_out], header="Wavefunctions for self-energy calculation.")
918 :
919 58 : ABI_FREE(nband)
920 58 : ABI_FREE(bks_mask)
921 58 : ABI_FREE(keep_ur)
922 58 : ABI_FREE(wfd_istwfk)
923 :
924 : ! Read wavefunctions.
925 58 : call wfd%read_wfk(wfk0_path, iomode_from_fname(wfk0_path))
926 :
927 : ! if PAW, one has to solve a generalized eigenproblem
928 58 : usecprj = 0; gen_eigenpb = psps%usepaw == 1; sij_opt = 0; if (gen_eigenpb) sij_opt = 1
929 :
930 116 : ABI_MALLOC(cwaveprj0, (natom, nspinor*usecprj))
931 116 : ABI_MALLOC(cwaveprj, (natom, nspinor*usecprj))
932 232 : ABI_MALLOC(displ_cart, (2, 3, cryst%natom, natom3))
933 174 : ABI_MALLOC(displ_red, (2, 3, cryst%natom, natom3))
934 232 : ABI_MALLOC(tpp_red, (natom3, natom3))
935 232 : ABI_MALLOC(gbound_kq, (2*wfd%mgfft+8, 2))
936 116 : ABI_MALLOC(osc_gbound_q, (2*wfd%mgfft+8, 2))
937 :
938 58 : osc_ecut = dtset%eph_ecutosc
939 58 : if (osc_ecut > zero) then
940 0 : call wrtout(std_out, sjoin("Computing oscillator matrix elements with ecut.", ftoa(osc_ecut)))
941 0 : ABI_CHECK(osc_ecut <= wfd%ecut, "osc_ecut cannot be greater than dtset%ecut")
942 58 : else if (osc_ecut < zero) then
943 0 : call wrtout(std_out, sjoin("Including G vectors inside a sphere with ecut.", ftoa(osc_ecut)))
944 : end if
945 :
946 : ! ============================
947 : ! Compute vnk matrix elements
948 : ! ============================
949 174 : ABI_MALLOC(cgwork, (2, mpw*wfd%nspinor))
950 4010 : ABI_CALLOC(sigma%vcar_calc, (3, sigma%max_nbcalc, sigma%nkcalc, nsppol))
951 :
952 58 : call ddkop%init(dtset, cryst, pawtab, psps, wfd%mpi_enreg, mpw, wfd%ngfft)
953 :
954 58 : if (sigma%mrta == 0) then
955 33 : call cwtime(cpu_ks, wall_ks, gflops_ks, "start", msg=" Computing v_nk matrix elements for all states in Sigma_nk...")
956 : ! Consider only the nk states in Sigma_nk
957 : ! All sigma_nk states are available on each node so MPI parallelization is easy.
958 33 : cnt = 0
959 66 : do spin=1,nsppol
960 136 : do ikcalc=1,sigma%nkcalc
961 280 : kk = sigma%kcalc(:, ikcalc)
962 70 : bstart_ks = sigma%bstart_ks(ikcalc, spin)
963 70 : ik_ibz = sigma%kcalc2ibz(ikcalc, 1)
964 70 : npw_k = wfd%npwarr(ik_ibz); istwf_k = wfd%istwfk(ik_ibz)
965 70 : call ddkop%setup_spin_kpoint(dtset, cryst, psps, spin, kk, istwf_k, npw_k, wfd%kdata(ik_ibz)%kg_k)
966 :
967 462 : do ib_k=1,sigma%nbcalc_ks(ikcalc, spin)
968 359 : cnt = cnt + 1; if (mod(cnt, nprocs) /= my_rank) cycle ! MPI parallelism.
969 359 : band_ks = ib_k + bstart_ks - 1
970 359 : call wfd%copy_cg(band_ks, ik_ibz, spin, cgwork)
971 359 : eig0nk = ebands%eig(band_ks, ik_ibz, spin)
972 1506 : sigma%vcar_calc(:, ib_k, ikcalc, spin) = ddkop%get_vdiag(eig0nk, istwf_k, npw_k, wfd%nspinor, cgwork, cwaveprj0)
973 : end do
974 :
975 : end do
976 : end do
977 33 : call xmpi_sum(sigma%vcar_calc, comm, ierr)
978 :
979 : else
980 25 : call cwtime(cpu_ks, wall_ks, gflops_ks, "start", msg=" Computing v_nk matrix elements for all states in the IBZ...")
981 :
982 : ! Imaginary part with MRTA. Here we need v_kq as well.
983 : ! Usually kq is one of the kcalc points except when nk is close to the edge of the sigma_erange window.
984 : ! due to ph absorption/emission.
985 : ! In this case, indeed, we may need a kq state that is not in the initial kcalc set.
986 : !
987 : ! Solution:
988 : ! 1) precompute group velocities in the IBZ and the ihave_ikibz_spin file (common to all procs)
989 : ! 2) Fill sigma%vcar_calc needed by the transport driver from the vcar_ibz array
990 : ! 3) Use symmetries to reconstruct v_kq from vcar_ibz
991 : !
992 : ! NB: All procs store in memory the same set of Bloch states.
993 :
994 21528 : ABI_CALLOC(vcar_ibz, (3, sigma%bsum_start:sigma%bsum_stop, nkpt, nsppol))
995 :
996 25 : cnt = 0
997 50 : do spin=1,nsppol
998 3648 : do ik_ibz=1,ebands%nkpt
999 14392 : kk = ebands%kptns(:, ik_ibz)
1000 3598 : npw_k = wfd%npwarr(ik_ibz); istwf_k = wfd%istwfk(ik_ibz)
1001 3598 : ikcalc = ibzspin_2ikcalc(ik_ibz, spin)
1002 3598 : if (.not. ihave_ikibz_spin(ik_ibz, spin)) cycle
1003 195 : if (npw_k == 1) cycle
1004 195 : cnt = cnt + 1; if (mod(cnt, nprocs) /= my_rank) cycle ! MPI parallelism.
1005 :
1006 195 : call ddkop%setup_spin_kpoint(dtset, cryst, psps, spin, kk, istwf_k, npw_k, wfd%kdata(ik_ibz)%kg_k)
1007 :
1008 1199 : do band_ks=sigma%bsum_start,sigma%bsum_stop
1009 979 : if (.not. wfd%ihave_ug(band_ks, ik_ibz, spin)) cycle
1010 893 : call wfd%copy_cg(band_ks, ik_ibz, spin, cgwork)
1011 893 : eig0nk = ebands%eig(band_ks, ik_ibz, spin)
1012 893 : vk = ddkop%get_vdiag(eig0nk, istwf_k, npw_k, wfd%nspinor, cgwork, cwaveprj0)
1013 3572 : vcar_ibz(:, band_ks, ik_ibz, spin) = vk
1014 4491 : if (ikcalc /= -1) then
1015 : ! This IBZ k-point is in the kcalc set --> Store vk in vcar_calc
1016 522 : bstart_ks = sigma%bstart_ks(ikcalc, spin)
1017 522 : bstop = bstart_ks + sigma%nbcalc_ks(ikcalc, spin) - 1
1018 522 : if (band_ks >= bstart_ks .and. band_ks <= bstop) then
1019 425 : ib_k = band_ks - bstart_ks + 1
1020 1700 : sigma%vcar_calc(:, ib_k, ikcalc, spin) = vk
1021 : end if
1022 : end if
1023 : end do
1024 : end do
1025 : end do
1026 25 : call xmpi_sum(sigma%vcar_calc, comm, ierr)
1027 50 : call xmpi_sum(vcar_ibz, comm, ierr)
1028 : endif
1029 :
1030 : ! Write v_nk to disk.
1031 58 : if (my_rank == master) then
1032 58 : NCF_CHECK(nf90_put_var(sigma%ncid, nctk_idname(sigma%ncid, "vcar_calc"), sigma%vcar_calc))
1033 : end if
1034 :
1035 58 : ABI_FREE(cgwork)
1036 58 : call ddkop%free()
1037 58 : call cwtime_report(" Velocities", cpu_ks, wall_ks, gflops_ks)
1038 :
1039 : ! Precompute phonon frequencies and eigenvectors in the IBZ.
1040 : ! These quantities are then used to symmetrize quantities for q in the IBZ(k) in order
1041 : ! to reduce the number of calls to ifc%fourq (expensive if dipdip == 1).
1042 :
1043 58 : use_ifc_fourq = .False. !use_ifc_fourq = .True. !use_ifc_fourq = dtset%userib == 123
1044 58 : call phstore%init(cryst, ifc, sigma%nqibz, sigma%qibz, use_ifc_fourq, sigma%pert_comm%value)
1045 58 : call cwtime_report(" phonons in the IBZ", cpu_ks, wall_ks, gflops_ks)
1046 :
1047 : ! Radius of sphere with volume equivalent to the micro zone.
1048 58 : q0rad = two_pi * (three / (four_pi * cryst%ucvol * sigma%nqbz)) ** third
1049 58 : bz_vol = two_pi**3 / cryst%ucvol
1050 :
1051 : ! Prepare call to getgh1c
1052 58 : usevnl = 0
1053 58 : optlocal = 1 ! local part of H^(1) is computed in gh1c=<G|H^(1)|C>
1054 58 : optnl = 2 ! non-local part of H^(1) is totally computed in gh1c=<G|H^(1)|C>
1055 58 : opt_gvnlx1 = 0 ! gvnlx1 is output
1056 :
1057 58 : ABI_MALLOC(grad_berry, (2, nspinor*(berryopt0/4)))
1058 :
1059 : ! This part is taken from dfpt_vtorho
1060 : !==== Initialize most of the Hamiltonian (and derivative) ====
1061 : ! 1) Allocate all arrays and initialize quantities that do not depend on k and spin.
1062 : ! 2) Perform the setup needed for the non-local factors:
1063 : !
1064 : ! Norm-conserving: Constant kleimann-Bylander energies are copied from psps to gs_hamk.
1065 : ! PAW: Initialize the overlap coefficients and allocate the Dij coefficients.
1066 :
1067 : call gs_ham_kq%init(psps, pawtab, nspinor, nsppol, nspden, natom,&
1068 : dtset%typat, cryst%xred, nfft, mgfft, ngfft, cryst%rprimd, dtset%nloalg,&
1069 : comm_atom=mpi_enreg%comm_atom, mpi_atmtab=mpi_enreg%my_atmtab, mpi_spintab=mpi_enreg%my_isppoltab,&
1070 58 : usecprj=usecprj, ph1d=ph1d, nucdipmom=dtset%nucdipmom, gpu_option=dtset%gpu_option)
1071 :
1072 : ! Allocate work space arrays.
1073 : ! vtrial and vlocal are required for Sternheimer (H0). DFPT routines do not need it.
1074 : ! Note nvloc in vlocal (we will select one/four spin components afterwards)
1075 786301 : ABI_CALLOC(vtrial, (nfftf, nspden))
1076 874419 : ABI_CALLOC(vlocal, (n4, n5, n6, gs_ham_kq%nvloc))
1077 :
1078 : ! DBSP
1079 58 : etot = zero
1080 58 : if (dtset%eph_stern /= 0) then
1081 : ! Read the GS potential (vtrial) from input POT file.
1082 : ! In principle one may store vtrial in the DVDB but getpot_filepath is simpler to implement.
1083 17 : call wrtout(units, sjoin(" Reading GS KS potential for Sternheimer from: ", dtfil%filpotin))
1084 : call read_rhor(dtfil%filpotin, cplex1, nspden, nfftf, ngfftf, pawread0, mpi_enreg, vtrial, pot_hdr, pot_pawrhoij, comm, &
1085 17 : allow_interp=.True., want_varname="vtrial")
1086 17 : pot_cryst = pot_hdr%get_crystal()
1087 17 : if (cryst%compare(pot_cryst, header=" Comparing input crystal with POT crystal") /= 0) then
1088 0 : ABI_ERROR("Crystal structure from WFK and POT do not agree! Check messages above!")
1089 : end if
1090 17 : etot = pot_hdr%etot
1091 17 : call pot_cryst%free(); call pot_hdr%free()
1092 : end if
1093 :
1094 58 : if (sigma%nwr > 0) then
1095 63 : ABI_MALLOC(cfact_wr, (sigma%nwr))
1096 : end if
1097 174 : ABI_MALLOC(nqnu_tlist, (sigma%ntemp))
1098 :
1099 : ! Allocate workspace arrays for Eliashberg functions
1100 58 : if (dtset%prteliash /= 0) then
1101 63 : ABI_MALLOC(dtw_weights, (sigma%phmesh_size, 2))
1102 63 : ABI_MALLOC(dwargs, (sigma%phmesh_size))
1103 21 : if (sigma%a2f_ne > 0) then
1104 0 : ABI_MALLOC(delta_e_minus_emkq, (sigma%a2f_ne))
1105 : end if
1106 : end if
1107 :
1108 : ! Array used to store delta(w - w_{q\nu}) with delta replaced by gaussian.
1109 174 : ABI_MALLOC(gaussw_qnu, (sigma%phmesh_size))
1110 :
1111 58 : if (dtset%eph_prtscratew == 1) then
1112 6 : ABI_MALLOC(sigma%scratew, (sigma%phmesh_size, sigma%ntemp, sigma%max_nbcalc, 2))
1113 : end if
1114 :
1115 : ! Open the DVDB file
1116 58 : call dvdb%open_read(ngfftf, xmpi_comm_self)
1117 58 : ABI_CHECK(dvdb%has_fields("pot1", msg), msg)
1118 :
1119 58 : if (sigma%pert_comm%nproc > 1) then
1120 : ! Activate parallelism over perturbations
1121 0 : call dvdb%set_pert_distrib(sigma%my_npert, natom3, sigma%my_pinfo, sigma%pert_table, sigma%pert_comm%value)
1122 : end if
1123 :
1124 : ! Find correspondence IBZ --> set of q-points in DVDB.
1125 : ! Activate FT interpolation automatically if required q-points in the IBZ are not found in the DVDB.
1126 58 : sigma%need_ftinterp = .False.
1127 174 : ABI_MALLOC(sigma%qibz2dvdb, (sigma%nqibz))
1128 58 : if (dvdb%find_qpts(sigma%nqibz, sigma%qibz, sigma%qibz2dvdb, comm) /= 0) then
1129 23 : call wrtout(units, " Cannot find eph_ngqpt_fine q-points in DVDB --> Activating Fourier interpolation.")
1130 23 : sigma%need_ftinterp = .True.
1131 : else
1132 35 : call wrtout(units, " DVDB file contains all q-points in the IBZ --> Reading DFPT potentials from file.")
1133 35 : sigma%need_ftinterp = .False.
1134 : end if
1135 :
1136 58 : if (.not. sigma%need_ftinterp .and. dtset%eph_use_ftinterp /= 0) then
1137 0 : ABI_WARNING("Enforcing FT interpolation for q-points even if it's not strictly needed.")
1138 0 : sigma%need_ftinterp = .True.
1139 : end if
1140 :
1141 58 : if (sigma%need_ftinterp) then
1142 : ! Use ddb_ngqpt q-mesh to compute the real-space representation of DFPT v1scf potentials to prepare Fourier interpolation.
1143 : ! R-points are distributed inside comm_rpt
1144 : ! Note that when R-points are distributed inside qpt_comm we cannot interpolate potentials on-the-fly
1145 : ! inside the loop over q-points.
1146 : ! In this case, indeed, the interpolation must be done in sigma_setup_qloop once we know the q-points contributing
1147 : ! to the integral and the potentials must be cached.
1148 : !FIXME: qpt_comm is buggy.
1149 : !if (sigma%imag_only) comm_rpt = xmpi_comm_self
1150 : !comm_rpt = sigma%bsum_comm%value
1151 23 : comm_rpt = xmpi_comm_self
1152 23 : qptopt = ebands%kptopt; if (dtset%qptopt /= 0) qptopt = dtset%qptopt
1153 23 : call dvdb%ftinterp_setup(dtset%ddb_ngqpt, qptopt, 1, dtset%ddb_shiftq, nfftf, ngfftf, comm_rpt)
1154 :
1155 : ! Build q-cache in the *dense* IBZ using the global mask qselect and itreat_qibz.
1156 69 : ABI_MALLOC(qselect, (sigma%nqibz))
1157 3797 : qselect = 1
1158 23 : if (sigma%imag_only .and. sigma%qint_method == 1) then
1159 10 : call qpoints_oracle(sigma, dtset, cryst, ebands, sigma%qibz, sigma%nqibz, sigma%nqbz, sigma%qbz, qselect, comm)
1160 : end if
1161 :
1162 : else
1163 105 : ABI_MALLOC(qselect, (dvdb%nqpt))
1164 251 : qselect = 1
1165 : ! Try to predict the q-points required to compute tau.
1166 35 : if (sigma%imag_only .and. sigma%qint_method == 1) then
1167 6 : call qpoints_oracle(sigma, dtset, cryst, ebands, dvdb%qpts, dvdb%nqpt, sigma%nqbz, sigma%qbz, qselect, comm)
1168 : end if
1169 : end if
1170 :
1171 116 : call dvdb%print([std_out], "", dtset%prtvol)
1172 :
1173 58 : if (.not. sigma%need_ftinterp) then
1174 : ! Need to translate itreat_qibz into itreatq_dvdb.
1175 321 : ABI_ICALLOC(itreatq_dvdb, (dvdb%nqpt))
1176 251 : do iq_ibz=1,sigma%nqibz
1177 216 : if (sigma%itreat_qibz(iq_ibz) == 0) cycle
1178 216 : db_iqpt = sigma%qibz2dvdb(iq_ibz)
1179 216 : ABI_CHECK(db_iqpt /= -1, sjoin("Could not find IBZ q-point:", ktoa(sigma%qibz(:, iq_ibz)), "in the DVDB file."))
1180 251 : itreatq_dvdb(db_iqpt) = 1
1181 : end do
1182 35 : ABI_FREE(itreatq_dvdb)
1183 : end if
1184 :
1185 58 : ABI_FREE(qselect)
1186 403 : zpr_frohl_sphcorr = zero; zpr_frohl_sphcorr_done = .False.
1187 :
1188 58 : call pstat_proc%print(_PSTAT_ARGS_)
1189 :
1190 : !if (sigma%frohl_model == 1 .and. .not. sigma%imag_only) then
1191 : ! call frohl_integrator_find_mesh(cryst, ifc, ntheta, comm)
1192 : ! call frohl%init(cryst, ifc, ntheta, comm)
1193 : ! call frohl%eval_isotropic_avg(cryst, ifc, comm, zpr_frohl_sphcorr)
1194 : ! call frohl%free()
1195 : !end if
1196 : !stop
1197 :
1198 : ! Temperature resolved 4th order contribution to total energy
1199 406 : ABI_CALLOC(E4, (sigma%ntemp))
1200 : !
1201 : ! Loop over k-points in Sigma_nk. Loop over spin is internal as we operate on nspden components at once.
1202 240 : do my_ikcalc=1,sigma%my_nkcalc
1203 : !if (my_ikcalc > 1) exit
1204 182 : ikcalc = sigma%my_ikcalc(my_ikcalc)
1205 :
1206 : ! Check if this (kpoint, spin) was already calculated
1207 182 : if (all(sigma%qp_done(ikcalc, :) == 1)) cycle
1208 182 : call cwtime(cpu_ks, wall_ks, gflops_ks, "start")
1209 :
1210 : ! Find IBZ(k) for q-point integration.
1211 182 : call cwtime(cpu_setk, wall_setk, gflops_setk, "start")
1212 : ! FIXME invert spin but checks shape of the different arrays!
1213 182 : call sigma%setup_kcalc(dtset, cryst, ebands, ikcalc, dtset%prtvol, sigma%pqb_comm%value)
1214 :
1215 : ! Symmetry indices for kk.
1216 728 : kk = sigma%kcalc(:, ikcalc)
1217 182 : ik_ibz = sigma%kcalc2ibz(ikcalc, 1); isym_k = sigma%kcalc2ibz(ikcalc, 2)
1218 728 : trev_k = sigma%kcalc2ibz(ikcalc, 6); g0_k = sigma%kcalc2ibz(ikcalc, 3:5)
1219 728 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
1220 0 : ABI_CHECK(isirr_k, "For the time being the k-point in Sigma_{nk} must be in the IBZ")
1221 182 : kk_ibz = ebands%kptns(:,ik_ibz)
1222 182 : npw_k = wfd%npwarr(ik_ibz); istwf_k = wfd%istwfk(ik_ibz)
1223 :
1224 : ! Allocate PW-arrays. Note mpw in kg_kq
1225 546 : ABI_MALLOC(kg_k, (3, npw_k))
1226 479600 : kg_k = wfd%kdata(ik_ibz)%kg_k
1227 546 : ABI_MALLOC(kg_kq, (3, mpw))
1228 :
1229 : call gs_ham_kq%eph_setup_k("k", kk, istwfk_1, npw_k, kg_k, dtset, cryst, psps, &
1230 182 : nkpg, kpg_k, ffnl_k, kinpw_k, ph3d_k, sigma%pert_comm%value)
1231 :
1232 182 : call cwtime_report(" Setup kcalc", cpu_setk, wall_setk, gflops_setk)
1233 :
1234 : ! TODO: Spin should be treated in a more flexible and scalable way --> kcalc and bdgw should depend on spin.
1235 : ! Introduce other comm and cartesian dimension for spin
1236 364 : do my_spin=1,sigma%my_nspins
1237 182 : spin = sigma%my_spins(my_spin)
1238 :
1239 : ! Check if this kpoint and spin was already calculated
1240 182 : if (sigma%qp_done(ikcalc, spin) == 1) cycle
1241 :
1242 : !call timab(1900, 1, tsec)
1243 : ! Bands in Sigma_nk to compute and number of bands in sum over states.
1244 182 : bstart_ks = sigma%bstart_ks(ikcalc, spin)
1245 182 : nbcalc_ks = sigma%nbcalc_ks(ikcalc, spin)
1246 182 : bsum_start = sigma%bsum_start; bsum_stop = sigma%bsum_stop
1247 182 : nbsum = sigma%nbsum
1248 546 : ABI_MALLOC(root_bcalc, (nbcalc_ks))
1249 :
1250 : ! Zero self-energy matrix elements. Build frequency mesh for nk states.
1251 10556 : sigma%vals_e0ks = zero; sigma%dvals_de0ks = zero; sigma%dw_vals = zero
1252 10556 : sigma%fan_vals = zero; sigma%fan_stern_vals = zero; sigma%dw_stern_vals = zero
1253 767 : sigma%E2 = zero
1254 3640 : sigma%E4_vals = zero
1255 3640 : sigma%E4_vals2 = zero
1256 182 : if (sigma%mrta > 0) then
1257 1939 : sigma%linewidth_mrta = zero
1258 336 : ABI_MALLOC(alpha_mrta, (nbcalc_ks))
1259 : end if
1260 :
1261 182 : if (sigma%nwr > 0) then
1262 : ! Prepare computation of Sigma_{nk}(w) and spectral function.
1263 : ! Build linear mesh **centered** around the KS energy.
1264 116184 : sigma%vals_wr = zero
1265 336 : do ib_k=1,nbcalc_ks
1266 284 : band_ks = ib_k + bstart_ks - 1
1267 284 : eig0nk = ebands%eig(band_ks, ik_ibz, spin) - sigma%wr_step * (sigma%nwr / 2)
1268 35668 : sigma%wrmesh_b(:,ib_k) = arth(eig0nk, sigma%wr_step, sigma%nwr)
1269 : end do
1270 : end if
1271 :
1272 : ! Prepare Eliasberg functions.
1273 182 : if (dtset%prteliash /= 0) then
1274 58 : ABI_SFREE(sigma%gf_nnuq)
1275 102789 : ABI_CALLOC(sigma%gf_nnuq, (nbcalc_ks, natom3, sigma%nqibz_k, 3))
1276 58 : if (dtset%prteliash == 3) sigma%a2few = zero
1277 : end if
1278 :
1279 : ! Zeroing array used to compute spectral decomposition of 1/tau as a function of ph omega.
1280 91178 : if (dtset%eph_prtscratew == 1) sigma%scratew = zero
1281 :
1282 : ! Allocate eph matrix elements.
1283 728 : ABI_MALLOC(gkq_atm, (2, nbcalc_ks, natom3))
1284 546 : ABI_MALLOC(gkq_nu, (2, nbcalc_ks, natom3))
1285 728 : ABI_MALLOC(gkq_allgather, (2, nbcalc_ks * natom3, 2))
1286 :
1287 : ! Allocate arrays for Debye-Waller
1288 182 : if (.not. sigma%imag_only) then
1289 154766 : ABI_CALLOC_OR_DIE(gkq0_atm, (2, nbcalc_ks, sigma%my_bsum_start:sigma%my_bsum_stop, natom3), ierr)
1290 70 : if (dtset%eph_stern /= 0) then
1291 17995 : ABI_CALLOC(stern_dw, (2, natom3, natom3, nbcalc_ks))
1292 : enough_stern = 0
1293 : end if
1294 : end if
1295 :
1296 182 : if (sigma%frohl_model == 1 .and. .not. sigma%imag_only) then
1297 0 : call wrtout(std_out, " Computing spherical average to treat Frohlich divergence in Sigma^{FM}")
1298 0 : ABI_MALLOC(f_tlist_b, (sigma%ntemp, nbcalc_ks))
1299 :
1300 0 : if (sigma%nwr > 0) then
1301 0 : do ib_k=1,nbcalc_ks
1302 0 : band_ks = ib_k + bstart_ks - 1; eig0nk = ebands%eig(band_ks, ik_ibz, spin)
1303 0 : do it=1,sigma%ntemp
1304 0 : f_tlist_b(it,ib_k) = occ_fd(eig0nk, sigma%kTmesh(it), sigma%mu_e(it))
1305 : end do
1306 : end do
1307 : ! This integral depends on the (n, k) state
1308 0 : ABI_CALLOC(fmw_frohl_sphcorr, (sigma%nwr, natom3, sigma%ntemp, nbcalc_ks))
1309 : end if
1310 :
1311 : ! Angular integration.
1312 0 : if (.not. zpr_frohl_sphcorr_done) zpr_frohl_sphcorr = zero
1313 :
1314 0 : do iang=1,sigma%angl_size
1315 0 : if (sigma%kcalc_comm%skip(iang)) cycle ! MPI parallelism inside kcalc_comm
1316 0 : qpt_cart = sigma%qvers_cart(:, iang); inv_qepsq = one / dot_product(qpt_cart, matmul(ifc%dielt, qpt_cart))
1317 0 : call ifc%fourq(cryst, qpt_cart, phfrq, displ_cart, nanaqdir="cart")
1318 :
1319 : ! Acoustic modes are ignored here.
1320 0 : do nu=4,natom3
1321 0 : wqnu = phfrq(nu); if (ephtk_skip_phmode(nu, wqnu, sigma%phmodes_skip, dtset%eph_phrange_w)) cycle
1322 : ! Get phonon occupation for all temperatures.
1323 0 : nqnu_tlist = occ_be(wqnu, sigma%kTmesh(:), zero)
1324 :
1325 : ! cnum = q.\sum_k Z_k.d_k(q,nu)
1326 0 : cp3 = czero
1327 0 : do iatom=1, natom
1328 0 : cp3 = cp3 + matmul(ifc%zeff(:, :, iatom), cmplx(displ_cart(1,:,iatom, nu), displ_cart(2,:,iatom, nu), kind=dp))
1329 : end do
1330 0 : cnum = dot_product(qpt_cart, cp3); if (abs(cnum) < tol12) cycle
1331 :
1332 : ! Compute spherical average for ZPR
1333 0 : if (.not. zpr_frohl_sphcorr_done) then
1334 0 : zpr_frohl_sphcorr(nu) = zpr_frohl_sphcorr(nu) + sigma%angwgth(iang) * abs(cnum) ** 2 * inv_qepsq ** 2 / wqnu ** 2
1335 : end if
1336 :
1337 0 : if (sigma%nwr > 0) then
1338 : ! NB: summing over f * angwgth gives the spherical average 1/(4pi) \int domega f(omega)
1339 0 : weight = four_pi * sigma%angwgth(iang) * abs(cnum) ** 2 * inv_qepsq ** 2 / wqnu
1340 0 : do ib_k=1,nbcalc_ks
1341 0 : band_ks = ib_k + bstart_ks - 1; eig0nk = ebands%eig(band_ks, ik_ibz, spin)
1342 0 : do it=1,sigma%ntemp
1343 0 : f_nk = f_tlist_b(it,ib_k)
1344 0 : nqnu = nqnu_tlist(it)
1345 : fmw_frohl_sphcorr(:,nu,it,ib_k) = fmw_frohl_sphcorr(:,nu,it,ib_k) + &
1346 : ((nqnu + f_nk ) / (sigma%wrmesh_b(:,ib_k) - eig0nk + wqnu + sigma%ieta) + &
1347 0 : (nqnu - f_nk + one) / (sigma%wrmesh_b(:,ib_k) - eig0nk - wqnu + sigma%ieta) ) * weight
1348 : end do ! it
1349 : end do ! ib_k
1350 : end if
1351 : end do ! nu
1352 : end do ! iang
1353 0 : ABI_FREE(f_tlist_b)
1354 :
1355 0 : if (.not. zpr_frohl_sphcorr_done) then
1356 0 : call xmpi_sum(zpr_frohl_sphcorr, sigma%kcalc_comm%value, ierr)
1357 : zpr_frohl_sphcorr = zpr_frohl_sphcorr * eight * pi / cryst%ucvol * &
1358 0 : (three / (four_pi * cryst%ucvol * sigma%nqbz)) ** third
1359 : !zpr_frohl_sphcorr = zpr_frohl_sphcorr * q0rad / (pi * cryst%ucvol)
1360 : zpr_frohl_sphcorr_done = .True.
1361 : end if
1362 :
1363 0 : if (sigma%nwr > 0) then
1364 0 : call xmpi_sum(fmw_frohl_sphcorr, sigma%kcalc_comm%value, ierr)
1365 0 : fmw_frohl_sphcorr = fmw_frohl_sphcorr * (four_pi/cryst%ucvol)**2 * q0rad * half / bz_vol
1366 : end if
1367 :
1368 0 : if (my_rank == master .and. is_open(ab_out)) then
1369 0 : write(ab_out, "(/,a)")" Frohlich model integrated inside the small q-sphere around Gamma."
1370 0 : write(ab_out,"(2(a,i0,1x),/)")" Angular mesh with ntheta: ", sigma%ntheta, ", nphi: ", sigma%nphi
1371 0 : write(ab_out, "(2a)")" Phonon-resolved contributions to Sigma^{FM}(w=e_KS):", ch10
1372 0 : do nu=1,natom3
1373 0 : if (abs(zpr_frohl_sphcorr(nu)) < tol12) cycle
1374 0 : write(ab_out, "(1x,f8.1,a,i0)")zpr_frohl_sphcorr(nu) * Ha_meV, " (meV) for ph-mode: ", nu
1375 : end do
1376 0 : write(ab_out, "(a)")ch10
1377 : end if
1378 : end if
1379 :
1380 : ! Load ground-state wavefunctions for which corrections are wanted (available on each node)
1381 : ! and save KS energies in sigma%e0vals
1382 : ! Note: One should rotate the wavefunctions if kk is not in the IBZ (not implemented)
1383 728 : ABI_MALLOC(kets_k, (2, npw_k*nspinor, nbcalc_ks))
1384 546 : ABI_MALLOC(sigma%e0vals, (nbcalc_ks))
1385 :
1386 182 : if (osc_ecut /= zero) then
1387 0 : ABI_MALLOC(ur_k, (wfd%nfft*nspinor, nbcalc_ks))
1388 0 : ABI_MALLOC(ur_kq, (wfd%nfft*nspinor))
1389 0 : ABI_MALLOC(work_ur, (wfd%nfft*nspinor))
1390 0 : ABI_MALLOC(gkq2_lr, (sigma%eph_doublegrid%ndiv, nbcalc_ks, sigma%my_npert))
1391 : end if
1392 :
1393 966 : do ib_k=1,nbcalc_ks
1394 784 : band_ks = ib_k + bstart_ks - 1
1395 784 : call wfd%copy_cg(band_ks, ik_ibz, spin, kets_k(1, 1, ib_k))
1396 784 : sigma%e0vals(ib_k) = ebands%eig(band_ks, ik_ibz, spin)
1397 966 : if (osc_ecut > zero) call wfd%get_ur(band_ks, ik_ibz, spin, ur_k(1, ib_k))
1398 : end do
1399 :
1400 : ! Distribute q-points, compute tetra weights.
1401 182 : call sigmaph_setup_qloop(sigma, dtset, cryst, ebands, dvdb, spin, ikcalc, sigma%pqb_comm%value)
1402 : !call timab(1900, 2, tsec)
1403 :
1404 : ! ==========================================
1405 : ! Integration over my q-points in the IBZ(k)
1406 : ! ==========================================
1407 182 : call cwtime(cpu_qloop, wall_qloop, gflops_qloop, "start")
1408 182 : ignore_kq = 0; ignore_ibsum_kq = 0
1409 :
1410 14654 : do imyq=1,sigma%my_nqibz_k
1411 14472 : call cwtime(cpu, wall, gflops, "start")
1412 14472 : iq_ibz_k = sigma%myq2ibz_k(imyq)
1413 57888 : qpt = sigma%qibz_k(:, iq_ibz_k)
1414 57888 : q_is_gamma = sum(qpt**2) < tol14
1415 :
1416 14472 : iq_ibz = sigma%ind_ibzk2ibz(1, iq_ibz_k)
1417 14472 : isym_q = sigma%ind_ibzk2ibz(2, iq_ibz_k)
1418 14472 : trev_q = sigma%ind_ibzk2ibz(6, iq_ibz_k)
1419 : ! Don't test if umklapp == 0 because we use the periodic gauge: phfreq(q+G) = phfreq(q) and eigvec(q) = eigvec(q+G)
1420 14472 : isirr_q = (isym_q == 1 .and. trev_q == 0)
1421 : !qq_ibz = sigma%qibz(:, iq_ibz)
1422 :
1423 : ! Find k + q in the extended zone and extract symmetry info.
1424 : ! Be careful here because there are two umklapp vectors to be considered as:
1425 : !
1426 : ! k + q = k_bz + g0_bz = IS(k_ibz) + g0_ibz + g0_bz
1427 : !
1428 57888 : kq = kk + qpt
1429 14472 : ikq_ibz = sigma%indkk_kq(1, iq_ibz_k); isym_kq = sigma%indkk_kq(2, iq_ibz_k)
1430 57888 : trev_kq = sigma%indkk_kq(6, iq_ibz_k); g0_kq = sigma%indkk_kq(3:5, iq_ibz_k)
1431 34778 : isirr_kq = (isym_kq == 1 .and. trev_kq == 0 .and. all(g0_kq == 0))
1432 57888 : kq_ibz = ebands%kptns(:, ikq_ibz)
1433 : !nband_kq = ebands%nband(ikq_ibz + (spin-1) * ebands%nkpt)
1434 :
1435 : ! This can happen if we have loaded the wavefunctions inside the energy range.
1436 14472 : if (sigma%imag_only .and. .not. ihave_ikibz_spin(ikq_ibz, spin)) then
1437 10620 : ignore_kq = ignore_kq + 1; cycle
1438 : end if
1439 :
1440 : ! ====================================
1441 : ! Get DFPT potentials for this q-point
1442 : ! ====================================
1443 : ! After this branch we have allocated v1scf(cplex, nfftf, nspden, my_npert))
1444 3852 : if (sigma%need_ftinterp) then
1445 : ! Use Fourier interpolation to get DFPT potentials for this qpt (hopefully in cache).
1446 2818 : db_iqpt = sigma%ind_ibzk2ibz(1, iq_ibz_k)
1447 : qq_ibz = sigma%qibz(:, db_iqpt)
1448 2818 : call dvdb%get_ftqbz(qpt, cplex, nfftf, ngfftf, v1scf, sigma%pert_comm%value)
1449 : else
1450 : ! Read and reconstruct the dvscf potentials for qpt and my_npert perturbations.
1451 1034 : db_iqpt = sigma%ind_q2dvdb_k(1, iq_ibz_k)
1452 1034 : ABI_CHECK(db_iqpt /= -1, sjoin("Could not find symmetric of q-point:", ktoa(qpt), "in DVDB file."))
1453 1034 : call dvdb%readsym_qbz(cryst, qpt, sigma%ind_q2dvdb_k(:,iq_ibz_k), cplex, nfftf, ngfftf, v1scf, sigma%pert_comm%value)
1454 : end if
1455 :
1456 : ! Rotate phonon frequencies and displacements for q in BZ. Non-blocking operation inside pert_comm
1457 : !call timab(1901, 1, tsec)
1458 :
1459 3852 : call phstore%async_rotate(cryst, ifc, iq_ibz, sigma%qibz(:, iq_ibz), qpt, isym_q, trev_q)
1460 :
1461 : ! Double grid stuff
1462 3852 : if (sigma%use_doublegrid) then
1463 238 : call sigma%eph_doublegrid%get_mapping(kk, kq, qpt)
1464 : !iq_bz_frohl = sigma%eph_doublegrid%get_index(qpt, 2)
1465 : !iq_ibz_frohl = sigma%eph_doublegrid%bz2ibz_dense(iq_bz_frohl)
1466 : end if
1467 :
1468 : ! Map q to qibz for tetrahedron
1469 3852 : if (sigma%qint_method > 0) then
1470 2718 : if (.not. sigma%use_doublegrid) then
1471 2554 : iq_ibz_fine = iq_ibz_k
1472 2554 : if (sigma%symsigma == 0) iq_ibz_fine = sigma%ephwg%lgk%find_ibzimage(qpt)
1473 2554 : ABI_CHECK(iq_ibz_fine /= -1, sjoin("Cannot find q-point in IBZ(k):", ktoa(qpt)))
1474 2554 : if (abs(sigma%symsigma) == 1) then
1475 10216 : if (.not. all(abs(sigma%qibz_k(:, iq_ibz_fine) - sigma%ephwg%lgk%ibz(:, iq_ibz_fine)) < tol12)) then
1476 0 : ABI_ERROR("Mismatch in qpoints.")
1477 : end if
1478 : end if
1479 : endif
1480 : end if
1481 :
1482 : ! Get istwf_kq, npw_kq, kg_kq for k+q.
1483 : call wfd%get_gvec_gbound(cryst%gmet, ecut, kq, ikq_ibz, isirr_kq, dtset%nloalg, & ! in
1484 3852 : istwf_kq, npw_kq, kg_kq, nkpg_kq, kpg_kq, gbound_kq) ! out
1485 :
1486 : !call timab(1901, 2, tsec)
1487 : !call timab(1902, 1, tsec)
1488 :
1489 3852 : istwf_kqirr = wfd%istwfk(ikq_ibz); npw_kqirr = wfd%npwarr(ikq_ibz)
1490 11556 : ABI_MALLOC(bra_kq, (2, npw_kq*nspinor))
1491 11556 : ABI_MALLOC(cgwork, (2, npw_kqirr*nspinor))
1492 :
1493 3852 : if (osc_ecut /= zero) then
1494 : ! Compute "small" G-sphere centered on qpt and gbound for zero-padded FFT for oscillators.
1495 0 : call get_kg(qpt, istwfk_1, abs(osc_ecut), cryst%gmet, osc_npw, osc_gvecq)
1496 0 : call sphereboundary(osc_gbound_q, istwfk_1, osc_gvecq, wfd%mgfft, osc_npw)
1497 :
1498 : ! Compute correspondence G-sphere --> FFT mesh.
1499 0 : ABI_MALLOC(osc_indpw, (osc_npw))
1500 0 : ABI_MALLOC(osc_mask, (osc_npw))
1501 0 : call kgindex(osc_indpw, osc_gvecq, osc_mask, wfd%mpi_enreg, ngfft, osc_npw)
1502 0 : ABI_FREE(osc_mask)
1503 :
1504 0 : ABI_MALLOC(workq_ug, (npw_kq*nspinor))
1505 0 : ABI_MALLOC(osc_ks, (osc_npw*nspinor, nbcalc_ks))
1506 : end if
1507 :
1508 : ! Allocate array to store H1 |psi_nk> for all 3*natom perturbations
1509 19260 : ABI_MALLOC_OR_DIE(h1kets_kq, (2, npw_kq*nspinor, my_npert, nbcalc_ks), ierr)
1510 :
1511 : ! Allocate vlocal1 with correct cplex. Note nvloc
1512 26964 : ABI_MALLOC_OR_DIE(vlocal1, (cplex*n4, n5, n6, gs_ham_kq%nvloc, my_npert), ierr)
1513 :
1514 11556 : ABI_MALLOC(gs1c, (2, npw_kq*nspinor*((sij_opt+1)/2)))
1515 11556 : ABI_MALLOC(gvnlx1, (2, npw_kq*nspinor))
1516 :
1517 : call gs_ham_kq%eph_setup_k("kq", kq, istwfk_1, npw_kq, kg_kq, dtset, cryst, psps, &
1518 3852 : nkpg, kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq, sigma%pert_comm%value)
1519 :
1520 3852 : if (dtset%eph_stern /= 0 .and. .not. sigma%imag_only) then
1521 : ! Build global array with GS wavefunctions cg_kq at k+q to prepare call to dfpt_cgwf.
1522 : ! NB: bsum_range is not compatible with Sternheimer.
1523 : ! There's a check at the level of the parser in chkinp.
1524 :
1525 : ! The static correction to FM_nk is:
1526 : ! \sum_{qnu} (2n_qnu + 1) <H^1_{qnu} psi_nk| psi^1_{nk; qnu}>
1527 :
1528 579 : call timab(1908, 1, tsec)
1529 38669334 : ABI_CALLOC(cg1s_kq, (2, npw_kq*nspinor, natom3, nbcalc_ks))
1530 :
1531 : ! NOTE: in the present version, we need to gather all nbsum bands on each core before calling dfpt_cgwf.
1532 : ! In principle one can call dfpt_cgwf in band-para mode but then
1533 : ! we are obliged to call the sternheimer solver with one psi1 and all procs in bsum_comm
1534 : ! just to to be able to apply the projector operator.
1535 : ! The present version is not memory efficient and leads to a big load imbalance if
1536 : ! bsum%comm%nproc > nband_calc_ks
1537 :
1538 : if (stern_has_band_para) then
1539 : nband_me = sigma%my_bsum_stop - sigma%my_bsum_start + 1
1540 : stern_comm = sigma%bsum_comm%value
1541 : else
1542 579 : nband_me = nbsum
1543 579 : stern_comm = xmpi_comm_self
1544 : end if
1545 :
1546 579 : stern_use_cache = merge(.True., .False., dtset%eph_stern == 1)
1547 : call stern%init(dtset, npw_k, npw_kq, nspinor, nbsum, nband_me, fermie1_idir_ipert, &
1548 579 : stern_use_cache, work_ngfft, mpi_enreg, stern_comm)
1549 :
1550 9335 : do ibsum_kq=sigma%my_bsum_start, sigma%my_bsum_stop
1551 :
1552 : ! Reconstruct u_kq(G) from the IBZ image.
1553 : call wfd%rotate_cg(ibsum_kq, ndat1, spin, kq_ibz, npw_kq, kg_kq, istwf_kq, &
1554 8756 : cryst, sigma%indkk_kq(:,iq_ibz_k), gbound_kq, work_ngfft, work, bra_kq)
1555 :
1556 9335 : if (stern%has_band_para) then
1557 0 : ii = ibsum_kq - sigma%my_bsum_start + 1
1558 0 : stern%cgq(:,:,ii) = bra_kq
1559 : else
1560 37029800 : stern%cgq(:, :, ibsum_kq) = bra_kq
1561 : end if
1562 : end do ! ibsum_kq
1563 :
1564 579 : cgq_request = xmpi_request_null
1565 :
1566 579 : if (.not. stern%has_band_para) then
1567 579 : if (sigma%bsum_comm%nproc > 1) then
1568 : ! If band parallelism, need to gather all bands nbsum bands.
1569 : ! FIXME: This part is network intensive, one can avoid it by calling dfpt_cgwf in band-para mode.
1570 : !call xmpi_sum(stern%cgq, sigma%bsum_comm%value, ierr)
1571 : !call xmpi_isum_ip(stern%cgq, sigma%bsum_comm%value, cgq_request, ierr)
1572 :
1573 0 : nelem = 2 * npw_kq * nspinor
1574 0 : call sigma%bsum_comm%prep_gatherv(nelem, sigma%nbsum_rank(:,1), sendcount, recvcounts, displs)
1575 : #ifdef HAVE_MPI
1576 : !call MPI_ALLGATHERV(MPI_IN_PLACE, sendcount, MPI_DOUBLE_PRECISION, stern%cgq, recvcounts, displs, &
1577 : ! MPI_DOUBLE_PRECISION, sigma%bsum_comm%value, ierr)
1578 :
1579 : #if defined HAVE_MPI2_INPLACE
1580 : call MPI_IALLGATHERV(MPI_IN_PLACE, sendcount, MPI_DOUBLE_PRECISION, stern%cgq, recvcounts, displs, &
1581 0 : MPI_DOUBLE_PRECISION, sigma%bsum_comm%value, cgq_request, ierr)
1582 : #else
1583 : ABI_MALLOC(cgq_buf,(sendcount))
1584 : me=1+xmpi_comm_rank(sigma%bsum_comm%value)
1585 : cgq_buf(1:sendcount)=cgq_ptr(displs(me)+1:displs(me)+sendcount)
1586 : call c_f_pointer(c_loc(stern%cgq), cgq_ptr, [2*npw_kq*nspinor*nband_me])
1587 : call MPI_IALLGATHERV(cgq_buf, sendcount, MPI_DOUBLE_PRECISION, cgq_ptr, recvcounts, displs, &
1588 : MPI_DOUBLE_PRECISION, sigma%bsum_comm%value, cgq_request, ierr)
1589 : ABI_FREE(cgq_buf)
1590 : #endif
1591 0 : call xmpi_requests_add(+1)
1592 : #endif
1593 :
1594 0 : ABI_FREE(recvcounts)
1595 0 : ABI_FREE(displs)
1596 : end if
1597 : end if
1598 579 : call timab(1908, 2, tsec)
1599 : end if ! eph_stern
1600 :
1601 : ! Loop over all 3*natom perturbations (Each core prepares its own potentials)
1602 : ! In the inner loop, we calculate H1 * psi_k, stored in h1kets_kq on the k+q sphere.
1603 24408 : do imyp=1,my_npert
1604 20556 : idir = sigma%my_pinfo(1, imyp); ipert = sigma%my_pinfo(2, imyp); ipc = sigma%my_pinfo(3, imyp)
1605 :
1606 : ! Set up local potential vlocal1 with proper dimensioning, from vtrial1 taking into account the spin.
1607 : ! Each CPU prepares its own potentials.
1608 : call rf_transgrid_and_pack(spin, nspden, psps%usepaw, cplex, nfftf, nfft, ngfft, gs_ham_kq%nvloc, &
1609 20556 : pawfgr, mpi_enreg, vtrial, v1scf(:,:,:,imyp), vlocal, vlocal1(:,:,:,:,imyp))
1610 :
1611 : ! Continue to initialize the Hamiltonian (call it here to support dfpt_cgwf Sternheimer).
1612 20556 : call gs_ham_kq%load_spin(spin, vlocal=vlocal, with_nonlocal=.true.)
1613 :
1614 : ! Prepare application of the NL part.
1615 20556 : call rf_ham_kq%init(cplex, gs_ham_kq, ipert, has_e1kbsc=.true.)
1616 20556 : call rf_ham_kq%load_spin(spin, vlocal1=vlocal1(:,:,:,:,imyp), with_nonlocal=.true.)
1617 :
1618 : ! Compute H(1) applied to GS wavefunction Psi_nk(0)
1619 74646 : do ib_k=1,nbcalc_ks
1620 54090 : if (sigma%bsum_comm%skip(ib_k, root=root_bcalc(ib_k))) cycle ! MPI parallelism inside bsum_comm
1621 : ! Store rank treating ib_k in root_bcalc
1622 54090 : band_ks = ib_k + bstart_ks - 1
1623 54090 : eig0nk = ebands%eig(band_ks, ik_ibz, spin)
1624 : ! Use scissor shift on 0-order eigenvalue
1625 54090 : eshift = eig0nk - dtset%dfpt_sciss
1626 :
1627 : call getgh1c(berryopt0, kets_k(:,:,ib_k), cwaveprj0, h1kets_kq(:,:,imyp, ib_k), &
1628 : grad_berry, gs1c, gs_ham_kq, gvnlx1, idir, ipert, (/eshift/), mpi_enreg, 1, optlocal, &
1629 128736 : optnl, opt_gvnlx1, rf_ham_kq, sij_opt, tim_getgh1c1, usevnl)
1630 : end do
1631 :
1632 74646 : do ib_k=1,nbcalc_ks
1633 74646 : call xmpi_bcast(h1kets_kq(:,:,imyp,ib_k), root_bcalc(ib_k), sigma%bsum_comm%value, ierr)
1634 : end do
1635 :
1636 20556 : if (dtset%eph_stern /= 0 .and. .not. sigma%imag_only) then
1637 3474 : call timab(1909, 1, tsec)
1638 : ! Activate Sternheimer. Note that we are still inside the MPI loop over my_npert.
1639 : ! NB: Assume adiabatic AHC expression to compute the contribution of states above nbsum.
1640 :
1641 : ! Wait for gatherv operation
1642 3474 : if (.not. stern%has_band_para .and. cgq_request /= xmpi_request_null) call xmpi_wait(cgq_request, ierr)
1643 :
1644 17676 : do ib_k=1,nbcalc_ks
1645 14202 : band_ks = ib_k + bstart_ks - 1
1646 229410 : stern%bands_treated_now(:) = 0; stern%bands_treated_now(band_ks) = 1
1647 :
1648 14202 : if (stern%has_band_para) then
1649 : ! Init rank_band and band_me from nbsum_rank.
1650 0 : stern%rank_band = -1; band_me = 1
1651 0 : do ip=1,sigma%bsum_comm%nproc
1652 0 : ii = sigma%nbsum_rank(ip,2)
1653 0 : jj = sigma%nbsum_rank(ip,2) + sigma%nbsum_rank(ip,1) -1
1654 0 : stern%rank_band(ii:jj) = ip - 1
1655 0 : if (inrange(band_ks, [ii, jj])) u1_master = ip - 1
1656 : end do
1657 0 : if (inrange(band_ks, [sigma%my_bsum_start, sigma%my_bsum_stop])) then
1658 0 : band_me = band_ks - sigma%my_bsum_start + 1
1659 0 : u1_band = band_ks
1660 : else
1661 0 : band_me = 1
1662 0 : u1_band = -band_ks
1663 : end if
1664 : else
1665 229410 : stern%rank_band = 0; u1_band = band_ks; band_me = band_ks
1666 14202 : if (sigma%bsum_comm%skip(ib_k)) cycle ! MPI parallelism inside bsum_comm
1667 : end if
1668 :
1669 : ! Init entry in cg1s_kq, either from cache or with zeros.
1670 14202 : if (stern%use_cache) then
1671 14202 : u1c_ib_k = u1c%find_band(band_ks)
1672 14202 : if (u1c_ib_k /= -1) then
1673 : call cgtk_change_gsphere(nspinor, &
1674 : u1c%prev_npw_kq, istwfk_1, u1c%prev_kg_kq, u1c%prev_cg1s_kq(1,1,ipc,u1c_ib_k), &
1675 13698 : npw_kq, istwfk_1, kg_kq, cg1s_kq(1,1,ipc,ib_k), work_ngfft, work)
1676 : else
1677 1532232 : cg1s_kq(:,:,ipc,ib_k) = zero
1678 : end if
1679 :
1680 : else
1681 0 : cg1s_kq(:,:,ipc,ib_k) = zero
1682 : end if
1683 :
1684 14202 : call timab(1909, 2, tsec)
1685 :
1686 : call stern%solve(u1_band, band_me, idir, ipert, qpt, gs_ham_kq, rf_ham_kq, &
1687 : ebands%eig(:,ik_ibz,spin), ebands%eig(:,ikq_ibz,spin), &
1688 14202 : kets_k(:,:,ib_k), cwaveprj0, cg1s_kq(:,:,ipc,ib_k), cwaveprj, msg, ierr)
1689 14202 : ABI_CHECK(ierr == 0, msg)
1690 17676 : if (stern%has_band_para) call xmpi_bcast(cg1s_kq(:,:,ipc,ib_k), u1_master, sigma%bsum_comm%value, ierr)
1691 : end do ! ib_k
1692 :
1693 : !call timab(1909, 2, tsec)
1694 : end if ! sternheimer
1695 :
1696 24408 : call rf_ham_kq%free()
1697 : end do ! imyp (loop over perturbations)
1698 :
1699 : !call timab(1902, 2, tsec)
1700 3852 : ABI_FREE(gs1c)
1701 3852 : ABI_FREE(gvnlx1)
1702 3852 : ABI_FREE(vlocal1)
1703 3852 : ABI_FREE(v1scf)
1704 3852 : call stern%free()
1705 :
1706 : ! Wait from phonon frequencies and displacements inside pert_comm
1707 3852 : call phstore%wait(cryst, phfrq, displ_cart, displ_red)
1708 :
1709 3852 : if (dtset%eph_stern /= 0 .and. .not. sigma%imag_only) then
1710 579 : call timab(1910, 1, tsec)
1711 : ! Add contribution to Fan-Migdal self-energy coming from Sternheimer.
1712 : ! NB: All procs inside (bsum_comm x pert_comm) enter here!
1713 :
1714 : ! Store |Psi_1> to init Sternheimer solver for the next q-point.
1715 579 : call u1c%store(qpt, npw_kq, nspinor, natom3, bstart_ks, nbcalc_ks, kg_kq, cg1s_kq)
1716 :
1717 : ! h1kets_kq are MPI distributed inside pert_comm but we need off-diagonal pp' terms --> collect results.
1718 38669334 : ABI_CALLOC(h1kets_kq_allperts, (2, npw_kq*nspinor, natom3, nbcalc_ks))
1719 :
1720 : ! Compute S_pp' = <D_{qp} vscf u_nk|u'_{nk+q p'}>
1721 275100 : ABI_CALLOC(stern_ppb, (2, natom3, natom3, nbcalc_ks))
1722 :
1723 : ! Compute <Psi_1|Psi_1>
1724 274521 : ABI_CALLOC(E4stern_nk, (2, natom3, natom3, nbcalc_ks))
1725 :
1726 2946 : do ib_k=1,nbcalc_ks
1727 2367 : if (sigma%bsum_comm%skip(ib_k)) cycle ! MPI parallelism inside bsum_comm
1728 :
1729 2367 : call xmpi_sum(cg1s_kq(:,:,:,ib_k), sigma%pert_comm%value, ierr)
1730 :
1731 : ! TODO
1732 : !nelem = 2*npw_kq*nspinor*sigma%my_npert
1733 : !call MPI_ALLGATHER(MPI_IN_PLACE, nelem, MPI_DOUBLE_PRECISION, cg1s_kq(:,:,:,ib_k), nelem, &
1734 : ! MPI_DOUBLE_PRECISION, sigma%pert_comm%value, ierr)
1735 :
1736 : call xmpi_allgather(h1kets_kq(:,:,:,ib_k), 2*npw_kq*nspinor*sigma%my_npert, &
1737 2367 : h1kets_kq_allperts(:,:,:,ib_k), sigma%pert_comm%value, ierr)
1738 :
1739 : call cg_zgemm("C", "N", npw_kq*nspinor, natom3, natom3, &
1740 2367 : h1kets_kq_allperts(:,:,:,ib_k), cg1s_kq(:,:,:,ib_k), stern_ppb(:,:,:,ib_k))
1741 : !
1742 : ! We now compute <Psi_1|Psi_1>
1743 : call cg_zgemm("C", "N", npw_kq*nspinor, natom3, natom3, &
1744 2367 : cg1s_kq(:,:,:,ib_k), cg1s_kq(:,:,:,ib_k), E4stern_nk(:,:,:,ib_k))
1745 :
1746 : ! Save data for Debye-Waller that is performed outside the q-loop.
1747 20616 : if (q_is_gamma) stern_dw(:,:,:,ib_k) = stern_ppb(:,:,:,ib_k)
1748 : end do ! ib_k
1749 :
1750 579 : ABI_FREE(cg1s_kq)
1751 579 : ABI_FREE(h1kets_kq_allperts)
1752 :
1753 579 : if (q_is_gamma) call xmpi_sum(stern_dw, sigma%bsum_comm%value, ierr)
1754 :
1755 : ! Compute contribution to Fan-Migdal for M > sigma%nbsum
1756 4053 : do imyp=1,my_npert
1757 3474 : nu = sigma%my_pinfo(3, imyp)
1758 3474 : wqnu = phfrq(nu); if (ephtk_skip_phmode(nu, wqnu, sigma%phmodes_skip, dtset%eph_phrange_w)) cycle
1759 :
1760 : ! Get phonon occupation for all temperatures.
1761 15816 : nqnu_tlist = occ_be(wqnu, sigma%kTmesh(:), zero)
1762 :
1763 16339 : do ib_k=1,nbcalc_ks
1764 13121 : if (sigma%bsum_comm%skip(ib_k)) cycle ! MPI parallelism inside bsum_comm
1765 :
1766 : ! sum_{pp'} d_p* Stern_{pp'} d_p' with d = displ_red(:,:,:,nu) and S = stern_ppb(:,:,:,ib_k)
1767 249299 : vec_natom3 = zero
1768 13121 : call cg_zgemm("N", "N", natom3, natom3, 1, stern_ppb(:,:,:,ib_k), displ_red(:,:,:,nu), vec_natom3)
1769 13121 : dotri = cg_zdotc(natom3, displ_red(:,:,:,nu), vec_natom3)
1770 : !write(std_out, *)"dotri:", dotri
1771 13121 : rfact = dotri(1)
1772 : !rfact = cg_real_zdotc(natom3, displ_red(:,:,:,nu), vec_natom3)
1773 13121 : rfact = rfact * sigma%wtq_k(iq_ibz_k) / (two * wqnu)
1774 :
1775 58090 : do it=1,sigma%ntemp
1776 44969 : rtmp = (two * nqnu_tlist(it) + one) * rfact
1777 44969 : sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + rtmp
1778 44969 : sigma%fan_vals(it, ib_k) = sigma%fan_vals(it, ib_k) + rtmp
1779 44969 : sigma%fan_stern_vals(it, ib_k) = sigma%fan_stern_vals(it, ib_k) + rtmp
1780 : ! Add static term from Sternheimer to Sigma(w) as well.
1781 3627409 : if (sigma%nwr > 0) sigma%vals_wr(:, it, ib_k) = sigma%vals_wr(:, it, ib_k) + rtmp
1782 : end do
1783 :
1784 : ! Calculation of the 4th-order contribution to total energy due to electron-phonon interaction
1785 : ! SP - For E4 we multipy with eigendiplacement vectors
1786 249299 : vec_natom3 = zero
1787 13121 : call cg_zgemm("N", "N", natom3, natom3, 1, E4stern_nk(:,:,:,ib_k), displ_red(:,:,:,nu), vec_natom3)
1788 13121 : dotri = cg_zdotc(natom3, displ_red(:,:,:,nu), vec_natom3)
1789 13121 : rfact = dotri(1)
1790 13121 : rfact = rfact * sigma%wtq_k(iq_ibz_k) / two
1791 : !
1792 61308 : do it=1, sigma%ntemp
1793 44969 : rtmp = (two * nqnu_tlist(it) + one) * rfact
1794 58090 : sigma%E4_vals(it, ib_k) = sigma%E4_vals(it, ib_k) + rtmp
1795 : end do
1796 :
1797 : ! TODO Eliashberg functions with Sternheimer
1798 : !if (dtset%prteliash /= 0) then
1799 : !end if
1800 : end do
1801 : !
1802 : ! Second-order contribution to the total energy.
1803 : ! This is he phonon contribution (\hbar\omega/2)
1804 13177 : do it=1, sigma%ntemp
1805 9380 : rtmp = (two * nqnu_tlist(it) + one) * wqnu * sigma%wtq_k(iq_ibz_k) / two
1806 12598 : sigma%E2(it) = sigma%E2(it) + rtmp
1807 : enddo
1808 : end do ! imyp
1809 :
1810 579 : ABI_FREE(stern_ppb)
1811 579 : ABI_FREE(E4stern_nk)
1812 579 : call timab(1910, 2, tsec)
1813 : end if ! eph_stern /= 0
1814 :
1815 : ! ==============================================
1816 : ! Sum over m bands parallelized inside bsum_comm
1817 : ! ==============================================
1818 3852 : call timab(1903, 1, tsec)
1819 :
1820 29770 : do ibsum_kq=sigma%my_bsum_start, sigma%my_bsum_stop
1821 25918 : call timab(1904, 1, tsec)
1822 : ! This can happen if we have loaded the wavefunctions inside the energy range.
1823 25918 : if (sigma%imag_only .and. sigma%qint_method == 1) then
1824 5360 : if (.not. wfd%ihave_ug(ibsum_kq, ikq_ibz, spin)) then
1825 1248 : ignore_ibsum_kq = ignore_ibsum_kq + 1; cycle
1826 : end if
1827 : end if
1828 :
1829 : ! Reconstruct u_kq(G) from the IBZ image.
1830 : call wfd%rotate_cg(ibsum_kq, ndat1, spin, kq_ibz, npw_kq, kg_kq, istwf_kq, &
1831 24670 : cryst, sigma%indkk_kq(:,iq_ibz_k), gbound_kq, work_ngfft, work, bra_kq)
1832 :
1833 : ! Get gkk(kcalc, q, idir_ipert) in the atomic representation.
1834 : ! No need to handle istwf_kq because it's always 1.
1835 2071114 : gkq_atm = zero; cnt = 0
1836 170134 : do imyp=1,my_npert
1837 145464 : ipc = sigma%my_pinfo(3, imyp)
1838 : ! Calculate <u_(band,k+q)^(0)|H_(k+q,k)^(1)|u_(band,k)^(0)> for this pert (NC psps) istwf_k always 1
1839 803794 : do ib_k=1,nbcalc_ks
1840 633660 : gkq_atm(:, ib_k, ipc) = cg_zdotc(npw_kq*nspinor, bra_kq, h1kets_kq(:,:,imyp,ib_k))
1841 633660 : cnt = cnt + 1
1842 2046444 : gkq_allgather(:,cnt, 1) = gkq_atm(:, ib_k, ipc)
1843 : end do
1844 : !call cg_zgemv("C", npw_kq*nspinor, nbcalc_ks, h1kets_kq(:,:,:,imyp), bra_kq, gkq_atm(:,:,ipc))
1845 : end do
1846 24670 : call timab(1904, 2, tsec)
1847 24670 : call timab(1905, 1, tsec)
1848 : !ii = nbcalc_ks * my_npert
1849 : !call cg_zgemm("H", "N", npw_kq*nspinor, ii, ii, h1kets_kq, bra_kq, gkq_atm)
1850 : !call cg_zgemm("H", "N", npw_kq*nspinor, ii, ii, bra_kq, h1kets_kq, gkq_atm)
1851 :
1852 : ! Get gkk(kcalc, q, nu) in the phonon representation.
1853 : ! Need to gather all perts distributed in pert_comm
1854 24670 : if (sigma%pert_comm%nproc > 1) then
1855 : call xmpi_allgather(gkq_allgather(:,:,1), 2 * nbcalc_ks * my_npert, gkq_allgather(:,:,2), &
1856 0 : sigma%pert_comm%value, ierr)
1857 0 : do cnt=1,nbcalc_ks*natom3
1858 0 : ipc = 1 + (cnt - 1) / nbcalc_ks
1859 0 : ib_k = 1 + mod(cnt - 1, nbcalc_ks)
1860 0 : gkq_atm(:, ib_k, ipc) = gkq_allgather(:, cnt, 2)
1861 : end do
1862 : end if
1863 :
1864 24670 : call ephtk_gkknu_from_atm(1, nbcalc_ks, 1, natom, gkq_atm, phfrq, displ_red, gkq_nu)
1865 :
1866 : ! bsum_2 and bsum_3 are hotspots.
1867 24670 : call timab(1905, 2, tsec)
1868 24670 : call timab(1906, 1, tsec)
1869 :
1870 : ! Save e-ph matrix elements for Debye-Waller computation that will be performed outside the q-loop.
1871 : ! gkq0_atm(2, nbcalc_ks, bsum_start:bsum_stop, natom3)
1872 178666 : if (q_is_gamma .and. .not. sigma%imag_only) gkq0_atm(:, :, ibsum_kq, :) = gkq_atm
1873 :
1874 24670 : if (osc_ecut > zero) then
1875 0 : workq_ug = cmplx(bra_kq(1, :), bra_kq(2, :), kind=gwp)
1876 : call fft_ug(npw_kq, wfd%nfft, nspinor, ndat1, wfd%mgfft, wfd%ngfft, &
1877 0 : istwf_kq, kg_kq, gbound_kq, workq_ug, ur_kq)
1878 :
1879 : ! We need <k+q| e^{iq+G}|k> --> compute <k| e^{-i(q+G)}|k+q> with FFT and take CC.
1880 0 : do ib_k=1,nbcalc_ks
1881 0 : work_ur = ur_kq * conjg(ur_k(:, ib_k))
1882 : ! Call zero-padded FFT routine.
1883 0 : call fftpad(work_ur, ngfft, n1, n2, n3, n1, n2, n3, nspinor, wfd%mgfft, -1, osc_gbound_q)
1884 :
1885 : ! Need results on the G-sphere --> Transfer data from FFT to G-sphere.
1886 0 : do ispinor=1,nspinor
1887 0 : do ig=1,osc_npw
1888 0 : ifft = osc_indpw(ig) + (ispinor-1) * wfd%nfft
1889 0 : osc_ks(ig + (ispinor -1) * osc_npw, ib_k) = conjg(work_ur(ifft))
1890 : end do
1891 : end do
1892 :
1893 : !band_ks = ib_k + bstart_ks - 1
1894 : !if (ibsum_kq == band_ks) then
1895 : !if (ibsum_kq == band_ks .and. all(abs(qpt) < tol12)) then
1896 : ! write(std_out,"(a,i0,2a)")" Ene and Oscillator for band: ", band_ks, ", and q-point: ", trim(ktoa(qpt))
1897 : ! write(std_out,*)ebands%eig(band_ks, ik_ibz, spin) * Ha_eV, osc_ks(:2,ib_k)
1898 : !end if
1899 : end do
1900 : end if
1901 :
1902 24670 : eig0mkq = ebands%eig(ibsum_kq, ikq_ibz, spin)
1903 :
1904 : ! q-weight for naive integration
1905 24670 : weight_q = sigma%wtq_k(iq_ibz_k)
1906 :
1907 24670 : if (sigma%mrta > 0) then
1908 : ! Compute v_kq
1909 : ! If k+q is not in the IBZ, we need to recostruct the value by symmetry using v(Sq) = S v(q).
1910 : ! Use transpose(R) because we are using the tables for the wavefunctions
1911 : ! In this case listkk has been called with symrel and use_symrec=False
1912 : ! so q_bz = S^T q_ibz where S is the isym_kq symmetry
1913 22240 : vkq = vcar_ibz(:, ibsum_kq, ikq_ibz, spin)
1914 5560 : if (.not. isirr_kq) then
1915 4334 : vkq = matmul(transpose(cryst%symrel_cart(:,:,isym_kq)), vkq)
1916 5108 : if (trev_kq /= 0) vkq = -vkq
1917 : vkq_norm = sqrt(dot_product(vk, vk))
1918 : end if
1919 :
1920 : ! Precompute alpha MRTA coefficients for all nk states.
1921 25338 : do ib_k=1,nbcalc_ks
1922 79112 : vk = sigma%vcar_calc(:, ib_k, ikcalc, spin)
1923 79112 : vkk_norm = sqrt(dot_product(vk, vk))
1924 19778 : alpha_mrta(ib_k) = one ! zero
1925 61785 : if (vkk_norm > tol6) alpha_mrta(ib_k) = one - dot_product(vkq, vk) / vkk_norm ** 2
1926 : !if (vkk_norm > tol6 .and. vkq_norm > tol6) then
1927 : ! alpha_mrta(ib_k) = one - dot_product(vkq, vk) / (vkk_norm * vk_norm)
1928 : !end if
1929 : end do
1930 : end if
1931 24670 : call timab(1906, 2, tsec)
1932 24670 : call timab(1907, 1, tsec)
1933 :
1934 : ! Accumulate contribution to the FM self-energy
1935 170134 : do imyp=1,my_npert
1936 145464 : nu = sigma%my_pinfo(3, imyp)
1937 : ! Ignore unstable modes or modes that should be skipped.
1938 145464 : wqnu = phfrq(nu); if (ephtk_skip_phmode(nu, wqnu, sigma%phmodes_skip, dtset%eph_phrange_w)) cycle
1939 :
1940 137610 : if (dtset%eph_prtscratew == 1) then
1941 : ! Precompute delta(w-w_qnu)
1942 1383363 : gaussw_qnu = gaussian(sigma%phmesh - wqnu, dtset%ph_smear)
1943 : end if
1944 :
1945 : ! For each band in Sigma_{nk}
1946 759808 : do ib_k=1,nbcalc_ks
1947 597528 : band_ks = ib_k + bstart_ks - 1
1948 597528 : eig0nk = ebands%eig(band_ks, ik_ibz, spin)
1949 597528 : gkq2 = weight_q * (gkq_nu(1,ib_k,nu) ** 2 + gkq_nu(2,ib_k,nu) ** 2)
1950 597528 : ediff = eig0nk - eig0mkq
1951 597528 : intra_band = q_is_gamma .and. ediff <= TOL_EDIFF
1952 597528 : same_band = ibsum_kq == band_ks
1953 :
1954 : ! Optionally, accumulate contribution to Eliashberg functions
1955 597528 : if (dtset%prteliash /= 0) then
1956 : ! EPH strength with delta(e_{nk} - e_{m\kq})
1957 325314 : rfact = gaussian(eig0nk - eig0mkq, dtset%tsmear)
1958 : sigma%gf_nnuq(ib_k, nu, iq_ibz_k, 1) = sigma%gf_nnuq(ib_k, nu, iq_ibz_k, 1) + &
1959 325314 : rfact * (gkq_nu(1, ib_k, nu) ** 2 + gkq_nu(2, ib_k, nu) ** 2)
1960 :
1961 : ! Treat contribution to Eliashberg function due to Fan term.
1962 325314 : if (ediff > wqnu) then
1963 55493 : rfact = one / ediff
1964 : else
1965 : ! Non adiabatic regime --> Add complex shift.
1966 : ! Note however that the expression for this flavor of Eliashberg function relies on adiabaticity.
1967 269821 : rfact = real(one / (ediff + sigma%ieta))
1968 : end if
1969 :
1970 325314 : gf_val = gkq_nu(1, ib_k, nu) ** 2 + gkq_nu(2, ib_k, nu) ** 2
1971 325314 : if (intra_band .and. sigma%frohl_model == 1) then
1972 0 : gf_val = zero; if (same_band) gf_val = zpr_frohl_sphcorr(nu) * (four_pi / three * q0rad ** 3)
1973 : end if
1974 :
1975 325314 : sigma%gf_nnuq(ib_k, nu, iq_ibz_k, 2) = sigma%gf_nnuq(ib_k, nu, iq_ibz_k, 2) + gf_val * rfact
1976 : ! TODO: Add Sternheimer contribution
1977 :
1978 325314 : if (dtset%prteliash == 3) then
1979 : ! Accumulate: |g(k,q)|^2 delta(e - e_{m\kq}) delta(w - w_\qnu}
1980 0 : delta_e_minus_emkq = gaussian(sigma%a2f_emesh - eig0mkq, dtset%tsmear)
1981 0 : dwargs = sigma%phmesh - phfrq(nu)
1982 0 : dtw_weights(:, 1) = gaussian(dwargs, dtset%ph_smear)
1983 0 : do iw=1,sigma%phmesh_size
1984 : sigma%a2few(:, iw, ib_k) = sigma%a2few(:, iw, ib_k) + &
1985 0 : delta_e_minus_emkq(:) * dtw_weights(iw, 1) * gf_val * sigma%wtq_k(iq_ibz_k)
1986 : end do
1987 : end if
1988 : end if ! prteliash /= 0
1989 :
1990 3104074 : do it = 1, sigma%ntemp
1991 : ! Compute electronic occ for this T (note mu_e(it) Fermi level)
1992 2368936 : nqnu = occ_be(wqnu, sigma%kTmesh(it), zero)
1993 2368936 : f_nk = occ_fd(eig0nk, sigma%kTmesh(it), sigma%mu_e(it))
1994 : ! SP - the + 1E-6 is needed because eig0mkq is not perfectly degenerate at \Gamma
1995 2368936 : f_mkq = occ_fd(eig0mkq, sigma%kTmesh(it), sigma%mu_e(it) + 1E-6)
1996 : !
1997 : ! Here we have to handle 3 different logical values leading to 9 different cases:
1998 : !
1999 : ! qint_method 0 1
2000 : ! use_doublegrid .true. .false.
2001 : ! imag_only .true. .false.
2002 : !
2003 : ! We will write this with nested conditionals using the order above
2004 :
2005 2368936 : if (sigma%qint_method == 0) then
2006 : ! =========
2007 : ! zcut mode
2008 : ! =========
2009 :
2010 1670612 : if (sigma%use_doublegrid) then
2011 51744 : cfact = zero
2012 1448832 : do jj=1,sigma%eph_doublegrid%ndiv
2013 : ! Double Grid shared points weights
2014 1397088 : ikq_bz_fine = sigma%eph_doublegrid%mapping(2, jj)
2015 1397088 : weight = sigma%eph_doublegrid%weights_dense(ikq_bz_fine)
2016 :
2017 : ! Electronic eigenvalue
2018 1397088 : ikq_ibz_fine = sigma%eph_doublegrid%mapping(5, jj)
2019 1397088 : eig0mkq = sigma%eph_doublegrid%ebands_dense%eig(ibsum_kq, ikq_ibz_fine, spin)
2020 1397088 : f_mkq = occ_fd(eig0mkq, sigma%kTmesh(it), sigma%mu_e(it))
2021 :
2022 : ! Phonon frequency
2023 1397088 : iq_ibz_fine = sigma%eph_doublegrid%mapping(6, jj)
2024 1397088 : wqnu = sigma%ephwg%phfrq_ibz(iq_ibz_fine, nu)
2025 1397088 : nqnu = occ_be(wqnu, sigma%kTmesh(it), zero)
2026 :
2027 1448832 : if (dtset%eph_ahc_type == 1) then
2028 : cfact = cfact + &
2029 : ((nqnu + f_mkq ) / (eig0nk - eig0mkq + wqnu + sigma%ieta) + &
2030 1397088 : (nqnu - f_mkq + one) / (eig0nk - eig0mkq - wqnu + sigma%ieta) ) * weight
2031 : else
2032 0 : cfact = cfact + ((two * nqnu + one) / (eig0nk - eig0mkq + sigma%ieta)) * weight
2033 : end if
2034 : end do
2035 : else
2036 : ! No double-grid.
2037 1618868 : if (dtset%eph_ahc_type == 1) then
2038 : cfact = (nqnu + f_mkq ) / (eig0nk - eig0mkq + wqnu + sigma%ieta) + &
2039 1491732 : (nqnu - f_mkq + one) / (eig0nk - eig0mkq - wqnu + sigma%ieta)
2040 : else
2041 127136 : cfact = (two * nqnu + one) / (eig0nk - eig0mkq + sigma%ieta)
2042 : end if
2043 : endif
2044 :
2045 1670612 : if (sigma%imag_only) then
2046 117936 : simag = gkq2 * aimag(cfact)
2047 117936 : sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + j_dpc * simag
2048 117936 : if (sigma%mrta > 0) then
2049 117936 : sigma%linewidth_mrta(it, ib_k) = sigma%linewidth_mrta(it, ib_k) + simag * alpha_mrta(ib_k)
2050 : end if
2051 :
2052 117936 : if (dtset%eph_prtscratew == 1) then
2053 0 : sigma%scratew(:, it, ib_k, 1) = sigma%scratew(:, it, ib_k, 1) + simag * gaussw_qnu
2054 0 : sigma%scratew(:, it, ib_k, 2) = sigma%scratew(:, it, ib_k, 2) + simag * gaussw_qnu * alpha_mrta(ib_k)
2055 : end if
2056 :
2057 : else
2058 : ! Re + Im self-energy
2059 1552676 : sig_cplx = gkq2 * cfact
2060 1552676 : if (intra_band .and. sigma%frohl_model == 1) then
2061 : ! Treat Frohlich divergence with spherical integration around the Gamma point.
2062 : ! In principle one should rescale by the number of degenerate states but it's
2063 : ! easier to move all the weight to a single band.
2064 0 : sig_cplx = czero; if (same_band) sig_cplx = zpr_frohl_sphcorr(nu) * (two * f_mkq - one)
2065 : end if
2066 :
2067 1552676 : sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + sig_cplx
2068 1552676 : sigma%fan_vals(it, ib_k) = sigma%fan_vals(it, ib_k) + sig_cplx
2069 : !
2070 : ! SP - Dec 2025
2071 : ! Alternative way to compute E4 with sum-over-state.
2072 : ! Note that the temperature factor (two * nqnu + one) is the logical extension but only the 0 K expression has
2073 : ! been derived explicitely in https://arxiv.org/abs/2512.04897
2074 : ! No eta is needed since we compute it for n=occ and m=unocc (on active space)
2075 1552676 : if (f_nk > 1E-6 .and. f_mkq < 1E-6) then
2076 : sigma%E4_vals2(it, ib_k) = sigma%E4_vals2(it, ib_k) + &
2077 718668 : 0.5d0 * gkq2 * (two * nqnu + one) * two * wqnu / (eig0mkq - eig0nk)**2
2078 : end if
2079 : end if
2080 : !
2081 : else
2082 :
2083 : ! ===================
2084 : ! Tetrahedron method
2085 : ! ===================
2086 698324 : if (sigma%use_doublegrid) then
2087 : ! Tetra + double grid
2088 :
2089 704088 : do jj=1,sigma%eph_doublegrid%ndiv
2090 : ! Double Grid shared points weights
2091 678942 : ikq_bz_fine = sigma%eph_doublegrid%mapping(2, jj)
2092 678942 : weight = sigma%eph_doublegrid%weights_dense(ikq_bz_fine)
2093 :
2094 : ! Electronic eigenvalue
2095 678942 : ikq_ibz_fine = sigma%eph_doublegrid%mapping(5, jj)
2096 678942 : eig0mkq = sigma%eph_doublegrid%ebands_dense%eig(ibsum_kq, ikq_ibz_fine, spin)
2097 678942 : f_mkq = occ_fd(eig0mkq, sigma%kTmesh(it), sigma%mu_e(it))
2098 :
2099 : ! Phonon frequency
2100 678942 : iq_ibz_fine = sigma%eph_doublegrid%mapping(6, jj)
2101 678942 : wqnu = sigma%ephwg%phfrq_ibz(iq_ibz_fine,nu)
2102 678942 : nqnu = occ_be(wqnu, sigma%kTmesh(it), zero)
2103 :
2104 : ! Add Frohlich contribution
2105 678942 : gkq2_pf = gkq2
2106 678942 : if (osc_ecut /= zero) gkq2_pf = gkq2_pf + weight_q * gkq2_lr(jj,ib_k,imyp)
2107 :
2108 704088 : if (sigma%imag_only) then
2109 : ! Note pi factor from Sokhotski-Plemelj theorem.
2110 : simag = gkq2_pf * pi * ( &
2111 : (nqnu + f_mkq ) * sigma%deltaw_pm(1, ib_k, imyp, ibsum_kq, imyq, jj) + &
2112 678942 : (nqnu - f_mkq + one) * sigma%deltaw_pm(2, ib_k, imyp, ibsum_kq, imyq, jj) ) * weight
2113 678942 : sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + j_dpc * simag
2114 678942 : if (sigma%mrta > 0) then
2115 678942 : sigma%linewidth_mrta(it, ib_k) = sigma%linewidth_mrta(it, ib_k) + simag * alpha_mrta(ib_k)
2116 : end if
2117 :
2118 678942 : if (dtset%eph_prtscratew == 1) then
2119 0 : sigma%scratew(:, it, ib_k, 1) = sigma%scratew(:, it, ib_k, 1) + simag * gaussw_qnu
2120 0 : sigma%scratew(:, it, ib_k, 2) = sigma%scratew(:, it, ib_k, 2) + simag * gaussw_qnu * alpha_mrta(ib_k)
2121 : end if
2122 :
2123 : else
2124 : ! Re + Sigma with tetra and double grid
2125 : sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + gkq2_pf * ( &
2126 : (nqnu + f_mkq ) * sigma%cweights(1, 1, ib_k, imyp, ibsum_kq, imyq, jj) + &
2127 0 : (nqnu - f_mkq + one) * sigma%cweights(1, 2, ib_k, imyp, ibsum_kq, imyq, jj) ) * weight
2128 : end if
2129 : end do
2130 :
2131 : else
2132 :
2133 : ! Tetrahedron method WITHOUT double grid.
2134 673178 : if (sigma%imag_only) then
2135 : ! Imag part
2136 : simag = gkq2 * pi * ( &
2137 : (nqnu + f_mkq ) * sigma%deltaw_pm(1, ib_k, imyp, ibsum_kq, imyq, 1) + &
2138 131738 : (nqnu - f_mkq + one) * sigma%deltaw_pm(2, ib_k, imyp, ibsum_kq, imyq, 1) )
2139 :
2140 131738 : if (intra_band .and. sigma%frohl_model == 1) then
2141 : ! Treat Frohlich divergence with spherical integration of deltas around the Gamma point.
2142 : ! In principle one should rescale by the number of degenerate states but it's
2143 : ! easier to move all the weight to a single band
2144 : ! TODO: Check the sign, use convention for retarded function
2145 0 : simag = zero
2146 0 : if (same_band) simag = -pi * sum(sigma%frohl_deltas_sphcorr(1:2, it, ib_k, nu), dim=1)
2147 : end if
2148 :
2149 131738 : sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + j_dpc * simag
2150 131738 : if (sigma%mrta > 0) then
2151 131738 : sigma%linewidth_mrta(it, ib_k) = sigma%linewidth_mrta(it, ib_k) + simag * alpha_mrta(ib_k)
2152 : end if
2153 :
2154 131738 : if (dtset%eph_prtscratew == 1) then
2155 23173524 : sigma%scratew(:, it, ib_k, 1) = sigma%scratew(:, it, ib_k, 1) + simag * gaussw_qnu
2156 23173524 : sigma%scratew(:, it, ib_k, 2) = sigma%scratew(:, it, ib_k, 2) + simag * gaussw_qnu * alpha_mrta(ib_k)
2157 : end if
2158 :
2159 131738 : if (dtset%ibte_prep > 0) then
2160 : ! Save scattering rates.
2161 : sigma%srate(ibsum_kq, ib_k, it, imyq) = sigma%srate(ibsum_kq, ib_k, it, imyq) + &
2162 : gkq2 * two_pi * ( &
2163 : (nqnu - f_nk + one) * sigma%deltaw_pm(1, ib_k, imyp, ibsum_kq, imyq, 1) + &
2164 2540 : (nqnu + f_nk ) * sigma%deltaw_pm(2, ib_k, imyp, ibsum_kq, imyq, 1) )
2165 : end if
2166 :
2167 : else
2168 : ! Re + Sigma with tetra and WITHOUT double grid
2169 : sig_cplx = gkq2 * ( &
2170 : (nqnu + f_mkq ) * sigma%cweights(1, 1, ib_k, imyp, ibsum_kq, imyq, 1) + &
2171 541440 : (nqnu - f_mkq + one) * sigma%cweights(1, 2, ib_k, imyp, ibsum_kq, imyq, 1) )
2172 :
2173 541440 : if (intra_band .and. sigma%frohl_model == 1) then
2174 : ! Treat Frohlich divergence with spherical integration around the Gamma point.
2175 : ! In principle one should rescale by the number of degenerate states but it's
2176 : ! easier to move all the weight to a single band
2177 0 : sig_cplx = czero; if (same_band) sig_cplx = zpr_frohl_sphcorr(nu) * (two * f_mkq - one)
2178 : end if
2179 :
2180 541440 : sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + sig_cplx
2181 : endif
2182 : end if
2183 : end if
2184 :
2185 : ! Derivative of sigma
2186 : ! TODO: should calculate this with the double grid as well
2187 2966464 : if (.not. sigma%imag_only) then
2188 : ! Accumulate d(Re Sigma) / dw(w=eKS) for state ib_k
2189 : !cfact(x) = (nqnu + f_mkq ) / (x - eig0mkq + wqnu + sigma%ieta) + &
2190 : ! (nqnu - f_mkq + one) / (x - eig0mkq - wqnu + sigma%ieta)
2191 2094116 : gmod2 = (eig0nk - eig0mkq + wqnu) ** 2
2192 2094116 : hmod2 = (eig0nk - eig0mkq - wqnu) ** 2
2193 : rfact = (nqnu + f_mkq ) * (-gmod2 + aimag(sigma%ieta)**2) / (gmod2 + aimag(sigma%ieta)**2) ** 2 + &
2194 2094116 : (nqnu - f_mkq + one) * (-hmod2 + aimag(sigma%ieta)**2) / (hmod2 + aimag(sigma%ieta)**2) ** 2
2195 2094116 : sigma%dvals_de0ks(it, ib_k) = sigma%dvals_de0ks(it, ib_k) + gkq2 * rfact
2196 : !cfact = (nqnu + f_mkq ) / (eig0nk - eig0mkq + wqnu + sigma%ieta) + &
2197 : ! (nqnu - f_mkq + one) / (eig0nk - eig0mkq - wqnu + sigma%ieta)
2198 : !sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + gkq2 * cfact
2199 :
2200 : !cfact = (eig0nk - eig0mkq + wqnu + sigma%ieta)
2201 : !gmod2 = cfact * dconjg(cfact)
2202 : !cfact = (eig0nk - eig0mkq - wqnu + sigma%ieta)
2203 : !hmod2 = cfact * dconjg(cfact)
2204 : !sigma%dvals_de0ks(it, ib_k) = sigma%dvals_de0ks(it, ib_k) + gkq2 * ( &
2205 : ! (nqnu + f_mkq) * (gmod2 - two * (eig0nk - eig0mkq + wqnu) ** 2) / gmod2 ** 2 + &
2206 : ! (nqnu - f_mkq + one) * (hmod2 - two * (eig0nk - eig0mkq - wqnu) ** 2) / hmod2 ** 2 &
2207 : !)
2208 :
2209 : ! Accumulate Sigma(w) for state ib_k if spectral function is wanted.
2210 2094116 : if (sigma%nwr > 0) then
2211 1377252 : if (sigma%qint_method == 1) then
2212 : ! Tetra
2213 : cfact_wr(:) = (nqnu + f_mkq ) * sigma%cweights(2:, 1, ib_k, imyp, ibsum_kq, imyq, 1) + &
2214 23500800 : (nqnu - f_mkq + one) * sigma%cweights(2:, 2, ib_k, imyp, ibsum_kq, imyq, 1)
2215 : else
2216 : ! Zcut
2217 : cfact_wr(:) = (nqnu + f_mkq ) / (sigma%wrmesh_b(:,ib_k) - eig0mkq + wqnu + sigma%ieta) + &
2218 148104864 : (nqnu - f_mkq + one) / (sigma%wrmesh_b(:,ib_k) - eig0mkq - wqnu + sigma%ieta)
2219 : end if
2220 171605664 : cfact_wr(:) = gkq2 * cfact_wr(:)
2221 :
2222 1377252 : if (intra_band .and. sigma%frohl_model == 1) then
2223 : ! Add Frohlich correction to Sigma_nk(w)
2224 0 : cfact_wr(:) = zero; if (same_band) cfact_wr(:) = fmw_frohl_sphcorr(:,nu,it,ib_k)
2225 : end if
2226 :
2227 171605664 : sigma%vals_wr(:,it,ib_k) = sigma%vals_wr(:,it,ib_k) + cfact_wr(:)
2228 : end if ! nwr > 0
2229 : end if
2230 :
2231 : end do ! it
2232 : end do ! ib_k
2233 : end do ! imyp
2234 28522 : call timab(1907, 2, tsec)
2235 :
2236 : end do ! ibsum_kq (sum over bands at k+q)
2237 3852 : call timab(1903, 2, tsec)
2238 :
2239 3852 : ABI_FREE(bra_kq)
2240 3852 : ABI_FREE(cgwork)
2241 3852 : ABI_FREE(h1kets_kq)
2242 3852 : ABI_FREE(kpg_kq)
2243 3852 : ABI_FREE(ffnl_kq)
2244 3852 : ABI_FREE(kinpw_kq)
2245 3852 : ABI_FREE(ph3d_kq)
2246 :
2247 3852 : if (osc_ecut /= zero) then
2248 0 : ABI_FREE(osc_gvecq)
2249 0 : ABI_FREE(osc_indpw)
2250 0 : ABI_FREE(osc_ks)
2251 0 : ABI_FREE(workq_ug)
2252 : end if
2253 :
2254 18506 : if (imyq <= 10 .or. mod(imyq, 100) == 0) then
2255 1269 : write(msg,'(4(a,i0),a)') " k-point [",my_ikcalc,"/",sigma%my_nkcalc, "] q-point [",imyq,"/",sigma%my_nqibz_k,"]"
2256 1269 : call cwtime_report(msg, cpu, wall, gflops)
2257 : end if
2258 : end do ! imyq (sum over q-points in IBZ_k)
2259 :
2260 182 : call cwtime_report(" Fan-Migdal q-loop", cpu_qloop, wall_qloop, gflops_qloop)
2261 :
2262 182 : ABI_FREE(sigma%e0vals)
2263 182 : ABI_FREE(kets_k)
2264 182 : ABI_FREE(gkq_atm)
2265 182 : ABI_FREE(gkq_nu)
2266 182 : ABI_FREE(gkq_allgather)
2267 182 : ABI_SFREE(fmw_frohl_sphcorr)
2268 :
2269 182 : if (osc_ecut /= zero) then
2270 0 : ABI_FREE(ur_k)
2271 0 : ABI_FREE(ur_kq)
2272 0 : ABI_FREE(work_ur)
2273 0 : ABI_FREE(gkq2_lr)
2274 : end if
2275 :
2276 : ! =========================
2277 : ! Compute Debye-Waller term
2278 : ! =========================
2279 182 : if (.not. sigma%imag_only) then
2280 70 : call cwtime(cpu_dw, wall_dw, gflops_dw, "start", msg=" Computing Debye-Waller within the rigid ion approximation...")
2281 : ! Collect gkq0_atm inside qpt_comm
2282 : ! FIXME: In principle it's sufficient to broadcast from itreated_q0 inside qpt_comm
2283 : ! Yet, q-points are not equally distributed so this synch is detrimental.
2284 :
2285 70 : call cwtime(cpu, wall, gflops, "start")
2286 70 : call xmpi_sum(gkq0_atm, sigma%qpt_comm%value, ierr)
2287 70 : if (dtset%eph_stern /= 0) call xmpi_sum(stern_dw, sigma%qpt_comm%value, ierr)
2288 70 : call cwtime_report(" DW MPI synch before q-loop", cpu, wall, gflops)
2289 :
2290 : ! Integral over IBZ(k) distributed inside qpt_comm
2291 70 : nq = sigma%nqibz; if (sigma%symsigma == 0) nq = sigma%nqbz
2292 70 : if (abs(sigma%symsigma) == +1) nq = sigma%nqibz_k
2293 70 : call xmpi_split_work(nq, sigma%qpt_comm%value, q_start, q_stop)
2294 :
2295 1086 : do iq_ibz_k=q_start,q_stop
2296 1016 : call cwtime(cpu, wall, gflops, "start")
2297 :
2298 1016 : if (abs(sigma%symsigma) == 1) then
2299 : ! Sum over IBZ_k
2300 4000 : qpt = sigma%qibz_k(:, iq_ibz_k); weight_q = sigma%wtq_k(iq_ibz_k)
2301 1000 : iq_ibz = sigma%ind_ibzk2ibz(1, iq_ibz_k)
2302 1000 : isym_q = sigma%ind_ibzk2ibz(2, iq_ibz_k)
2303 1000 : trev_q = sigma%ind_ibzk2ibz(6, iq_ibz_k)
2304 : ! Don't test if umklapp == 0 because we use the periodic gauge: phfreq(q+G) = phfreq(q) and eigvec(q) = eigvec(q+G)
2305 1000 : isirr_q = (isym_q == 1 .and. trev_q == 0)
2306 :
2307 : ! Sum over IBZ
2308 : ! TODO: This should be much faster but it should be tested.
2309 : !qpt = sigma%qibz(:,iq_ibz_k); weight_q = sigma%wtq(iq_ibz_k)
2310 :
2311 1000 : call phstore%async_rotate(cryst, ifc, iq_ibz, sigma%qibz(:, iq_ibz), qpt, isym_q, trev_q)
2312 1000 : call phstore%wait(cryst, phfrq, displ_cart, displ_red)
2313 :
2314 : ! Get phonons for this q-point.
2315 : !call ifc%fourq(cryst, qpt, phfrq, displ_cart, out_displ_red=displ_red, comm=sigma%pert_comm%value)
2316 :
2317 : else
2318 : ! Sum over full BZ
2319 64 : qpt = sigma%qbz(:, iq_ibz_k); weight_q = one / sigma%nqbz
2320 :
2321 : ! Get phonons for this q-point.
2322 16 : call ifc%fourq(cryst, qpt, phfrq, displ_cart, out_displ_red=displ_red, comm=sigma%pert_comm%value)
2323 : end if
2324 :
2325 : ! Sum over my phonon modes for this q-point.
2326 7112 : do imyp=1,my_npert
2327 6096 : nu = sigma%my_pinfo(3, imyp)
2328 : ! Ignore acoustic or unstable modes.
2329 6096 : wqnu = phfrq(nu); if (ephtk_skip_phmode(nu, wqnu, sigma%phmodes_skip, dtset%eph_phrange_w)) cycle
2330 :
2331 : ! Get phonon occupation for all temperatures.
2332 27462 : nqnu_tlist = occ_be(wqnu, sigma%kTmesh(:), zero)
2333 :
2334 : ! Compute T_pp'(q,nu) matrix in reduced coordinates.
2335 5732 : call sigtk_dw_tpp_red(natom, displ_red(:,:,:,nu), tpp_red)
2336 :
2337 : ! Sum over my bands and add (static) DW contribution for the different temperatures.
2338 116388 : do ibsum=sigma%my_bsum_start, sigma%my_bsum_stop
2339 109640 : eig0mk = ebands%eig(ibsum, ik_ibz, spin)
2340 :
2341 : ! For each n in Sigma_nk
2342 606258 : do ib_k=1,nbcalc_ks
2343 490886 : band_ks = ib_k + bstart_ks - 1
2344 490886 : eig0nk = ebands%eig(band_ks, ik_ibz, spin)
2345 : !
2346 : ! Compute DW term following XG paper. Check prefactor.
2347 : ! gkq0_atm(2, nbcalc_ks, bsum_start:bsum_stop, natom3)
2348 490886 : gdw2 = zero
2349 3436202 : do ip2=1,natom3
2350 21108098 : do ip1=1,natom3
2351 : cfact = ( &
2352 : + gkq0_atm(1, ib_k, ibsum, ip1) * gkq0_atm(1, ib_k, ibsum, ip2) &
2353 : + gkq0_atm(2, ib_k, ibsum, ip1) * gkq0_atm(2, ib_k, ibsum, ip2) &
2354 : + gkq0_atm(1, ib_k, ibsum, ip2) * gkq0_atm(1, ib_k, ibsum, ip1) &
2355 : + gkq0_atm(2, ib_k, ibsum, ip2) * gkq0_atm(2, ib_k, ibsum, ip1) &
2356 17671896 : )
2357 : !
2358 20617212 : gdw2 = gdw2 + real(tpp_red(ip1,ip2) * cfact)
2359 : end do
2360 : end do
2361 490886 : gdw2 = gdw2 / (four * two * wqnu)
2362 : !
2363 490886 : if (dtset%eph_stern /= 0 .and. ibsum == bsum_stop) then
2364 : ! Compute DW term for m > nband
2365 : cfact = zero
2366 91847 : do ip2=1,natom3
2367 564203 : do ip1=1,natom3
2368 551082 : cfact = cfact + tpp_red(ip1, ip2) * cmplx(stern_dw(1,ip1,ip2,ib_k), stern_dw(2,ip1,ip2,ib_k), kind=dp)
2369 : end do
2370 : end do
2371 : ! There's no 1/two here because I don't symmetrize the expression.
2372 : ! TODO: Test symmetrization, real quantity? add support for the different Eliashberg functions with Stern
2373 13121 : gdw2_stern = real(cfact) / (four * wqnu)
2374 : end if
2375 : !
2376 : ! Handle n == m and degenerate states.
2377 490886 : ediff = eig0nk - eig0mk ! SP: one cannot cycle here because the Sternheimer contribution needs to be computed
2378 : !
2379 : ! Optionally, accumulate DW contribution to Eliashberg functions.
2380 490886 : if (dtset%prteliash /= 0) then
2381 306222 : if (abs(ediff) > EPHTK_WTOL) then
2382 284361 : sigma%gf_nnuq(ib_k, nu, iq_ibz_k, 3) = sigma%gf_nnuq(ib_k, nu, iq_ibz_k, 3) - gdw2 / ediff
2383 : end if
2384 : end if
2385 : !
2386 : ! Accumulate DW for each T, add it to Sigma(e0) and Sigma(w) as well
2387 : ! - (2 n_{q\nu} + 1) * gdw2 / (e_nk - e_mk)
2388 2694642 : do it = 1, sigma%ntemp
2389 2094116 : if (abs(ediff) > EPHTK_WTOL) then
2390 1929272 : cfact = - weight_q * gdw2 * (two * nqnu_tlist(it) + one) / (ediff + sigma%ieta)
2391 : else
2392 : cfact = zero
2393 : endif
2394 2094116 : if (dtset%eph_stern /= 0 .and. ibsum == bsum_stop) then
2395 : ! Add contribution due to the Sternheimer. ediff is absorbed in Sternheimer.
2396 44969 : cfact = cfact - weight_q * gdw2_stern * (two * nqnu_tlist(it) + one)
2397 44969 : cfact2 = - weight_q * gdw2_stern * (two * nqnu_tlist(it) + one)
2398 44969 : rfact = real(cfact2)
2399 44969 : sigma%dw_stern_vals(it, ib_k) = sigma%dw_stern_vals(it, ib_k) + rfact
2400 : end if
2401 2094116 : rfact = real(cfact)
2402 2094116 : sigma%dw_vals(it, ib_k) = sigma%dw_vals(it, ib_k) + rfact
2403 2094116 : sigma%vals_e0ks(it, ib_k) = sigma%vals_e0ks(it, ib_k) + rfact
2404 172813414 : if (sigma%nwr > 0) sigma%vals_wr(:, it, ib_k) = sigma%vals_wr(:, it, ib_k) + rfact
2405 : end do
2406 :
2407 : end do ! ib_k
2408 : end do ! ibsum
2409 :
2410 : end do ! nu
2411 :
2412 : !if (nq < 1000 .or. (nq > 1000 .and. mod(iq_ibz_k, 200) == 0) .or. iq_ibz_k <= nprocs) then
2413 1016 : ii = iq_ibz_k - q_start
2414 2102 : if (ii <= 5 .or. mod(ii, 100) == 0) then
2415 393 : write(msg,'(4(a,i0),a,f8.2)') " k-point [",my_ikcalc,"/",sigma%my_nkcalc, "] q-point [",iq_ibz_k,"/",nq,"]"
2416 393 : call cwtime_report(msg, cpu, wall, gflops)
2417 : end if
2418 : end do ! iq_ibz_k
2419 :
2420 70 : ABI_FREE(gkq0_atm)
2421 70 : ABI_SFREE(stern_dw)
2422 70 : call cwtime_report(" Debye-Waller", cpu_dw, wall_dw, gflops_dw, end_str=ch10)
2423 : end if ! not %imag_only
2424 :
2425 182 : if (dtset%prteliash /= 0) then
2426 : ! Compute Eliashberg function.
2427 : call cwtime(cpu, wall, gflops, "start", msg=sjoin(" Computing Eliashberg function with nomega: ", &
2428 58 : itoa(sigma%phmesh_size)))
2429 :
2430 58 : if (dtset%prteliash == 3) call xmpi_sum(sigma%a2few, sigma%pqb_comm%value, ierr)
2431 :
2432 : ! Collect all terms on each node so that we can MPI-parallelize easily inside pqb_comm
2433 : ! Note that: gf_nnuq does not include the q-weights from the integration.
2434 58 : call xmpi_sum(sigma%gf_nnuq, sigma%pqb_comm%value, ierr)
2435 1204710 : sigma%gfw_vals = zero
2436 :
2437 58 : if (sigma%qint_method == 0 .or. sigma%symsigma == 0) then
2438 : ! Compute Eliashberg function with gaussian method and ph_smear smearing.
2439 498 : do iq_ibz_k=1,sigma%nqibz_k
2440 459 : if (sigma%pqb_comm%skip(iq_ibz_k)) cycle ! MPI parallelism inside pqb_comm
2441 :
2442 : ! Recompute phonons (cannot use sigma%ephwg in this case)
2443 459 : call ifc%fourq(cryst, sigma%qibz_k(:,iq_ibz_k), phfrq, displ_cart)
2444 3252 : do nu=1,natom3
2445 2680950 : dwargs = sigma%phmesh - phfrq(nu)
2446 2678196 : dtw_weights(:, 1) = gaussian(dwargs, dtset%ph_smear)
2447 14451 : do ib_k=1,nbcalc_ks
2448 47706 : do ii=1,3
2449 : sigma%gfw_vals(:, ii, ib_k) = sigma%gfw_vals(:, ii, ib_k) + &
2450 37416102 : sigma%gf_nnuq(ib_k, nu, iq_ibz_k, ii) * dtw_weights(:, 1) * sigma%wtq_k(iq_ibz_k)
2451 : end do
2452 : end do
2453 : end do
2454 : end do
2455 :
2456 : else
2457 : ! Compute Eliashberg function with tetrahedron method.
2458 57 : eminmax = [sigma%phmesh(1), sigma%phmesh(sigma%phmesh_size)]
2459 95 : ABI_MALLOC(dt_tetra_weights, (sigma%phmesh_size, sigma%nqibz_k, 2))
2460 133 : do nu=1,natom3
2461 : ! All procs compute weights.
2462 : call sigma%ephwg%get_deltas_qibzk(nu, sigma%phmesh_size, eminmax, sigma%bcorr, dt_tetra_weights, &
2463 114 : sigma%pqb_comm%value, with_qweights=.True.)
2464 :
2465 5893 : do iq_ibz_k=1,sigma%nqibz_k
2466 5760 : if (sigma%pqb_comm%skip(iq_ibz_k)) cycle ! MPI parallelism inside pqb_comm
2467 18792 : do ib_k=1,nbcalc_ks
2468 57432 : do ii=1,3
2469 : sigma%gfw_vals(:, ii, ib_k) = sigma%gfw_vals(:, ii, ib_k) + &
2470 40881162 : sigma%gf_nnuq(ib_k, nu, iq_ibz_k, ii) * dt_tetra_weights(:, iq_ibz_k, 1)
2471 : end do
2472 : end do
2473 : end do
2474 : end do
2475 19 : ABI_FREE(dt_tetra_weights)
2476 : end if
2477 :
2478 : ! Collect final results.
2479 58 : call xmpi_sum(sigma%gfw_vals, sigma%pqb_comm%value, ierr)
2480 58 : call cwtime_report(" Eliashberg function", cpu, wall, gflops)
2481 : end if
2482 :
2483 : !ivals2 = [ignore_ks, ignore_ibsum_kq]
2484 : !call xmpi_sum_master(ivals, master, sigma%pqb_comm%value)
2485 182 : if (my_rank == master) then
2486 182 : if (ignore_kq /= 0) write(std_out, "(a, 1x, i0)")" Number of ignored k+q points:", ignore_kq
2487 182 : if (ignore_ibsum_kq /= 0) write(std_out, "(a, 1x, i0)")" Number of ignored (k+q, m) states:", ignore_ibsum_kq
2488 : end if
2489 :
2490 : ! Reduce E2 over perturbations and q-points only (E2 does not depend on bands)
2491 182 : call xmpi_sum(sigma%E2, sigma%pert_comm%value, ierr)
2492 182 : call xmpi_sum(sigma%E2, sigma%qpt_comm%value, ierr)
2493 : ! Collect results inside pqb_comm and write results for this (k-point, spin) to NETCDF file.
2494 182 : call sigma%gather_and_write(dtset, ebands, ikcalc, spin, sigma%pqb_comm%value)
2495 :
2496 182 : ABI_SFREE(alpha_mrta)
2497 910 : ABI_SFREE(root_bcalc)
2498 : end do ! spin
2499 :
2500 : ! Gather total energies
2501 182 : ikcalc = sigma%my_ikcalc(my_ikcalc)
2502 182 : ik_ibz = sigma%kcalc2ibz(ikcalc, 1)
2503 364 : do spin=1,sigma%nsppol
2504 1148 : do ib_k=1,nbcalc_ks
2505 3414 : do it = 1, sigma%ntemp
2506 3232 : E4(it) = E4(it) + sigma%E4_vals(it, ib_k) * ebands%wtk(ik_ibz)
2507 : end do
2508 : end do
2509 : end do
2510 :
2511 182 : ABI_FREE(kg_k)
2512 182 : ABI_FREE(kg_kq)
2513 182 : ABI_SFREE(kpg_kq)
2514 182 : ABI_FREE(kpg_k)
2515 182 : ABI_FREE(ffnl_k)
2516 182 : ABI_FREE(kinpw_k)
2517 182 : ABI_FREE(ph3d_k)
2518 :
2519 182 : call cwtime_report(" One ikcalc k-point", cpu_ks, wall_ks, gflops_ks)
2520 604 : call pstat_proc%print(_PSTAT_ARGS_)
2521 : end do ! my_ikcalc
2522 :
2523 : ! --------------------
2524 : ! Print total energies
2525 : ! SP - 01/26 - Note that this way of computing total energies requires computing E4 on a k-point grid that is
2526 : ! the same as the interpolated q-point grid. This might not always be the best.
2527 : ! In that case, it is recommended to read E4 from the _SIGEPH.nc file and perform the k-integral
2528 : ! with a post-processing script.
2529 : ! --------------------
2530 58 : call xmpi_sum_master(E4, master, comm, ierr)
2531 58 : if (my_rank == master .and. dtset%eph_task == 4 .and. dtset%eph_stern /= 0 .and. .not. sigma%imag_only ) then
2532 : ! Spin factor
2533 17 : if (dtset%nsppol == 1 .and. dtset%nspinor == 1) then
2534 : sfact = two
2535 : else
2536 0 : sfact = one
2537 : endif
2538 : !
2539 17 : write(ab_out,"(a)")" "
2540 17 : write(ab_out,"(a)")" ========================================================= "
2541 17 : write(ab_out,"(a)")" Contributions to total energies (in meV) "
2542 17 : write(ab_out,"(a)")" See Table II of S. Ponce and X. Gonze, arXiv:2512.04897 "
2543 17 : write(ab_out,"(a)")" for additional information. "
2544 17 : write(ab_out,"(a)")" ========================================================= "
2545 17 : write(ab_out,"(a)")" "
2546 78 : do it = 1, sigma%ntemp
2547 61 : write(ab_out, "(2(a,f12.6),a)")" Temperature = ", sigma%kTmesh(it) / kb_HaK, " K"
2548 61 : write(ab_out, "(2(a,f20.6),a)")" E^(BO) = ", etot * Ha_eV * 1000
2549 61 : write(ab_out, "(2(a,f20.6),a)")" E^(ph) = ", sigma%E2(it) * Ha_eV * 1000
2550 : ! We need the spin factor.
2551 78 : write(ab_out, "(2(a,f20.6),a)")" E^(elph) = ", sfact * E4(it) * Ha_eV * 1000
2552 : end do
2553 : end if
2554 :
2555 58 : call cwtime_report(" Sigma_eph full calculation", cpu_all, wall_all, gflops_all, end_str=ch10)
2556 :
2557 : ! Free memory
2558 58 : ABI_FREE(E4)
2559 58 : ABI_FREE(ihave_ikibz_spin)
2560 58 : ABI_FREE(grad_berry)
2561 58 : ABI_FREE(vtrial)
2562 58 : ABI_FREE(work)
2563 58 : ABI_FREE(ph1d)
2564 58 : ABI_FREE(vlocal)
2565 58 : ABI_FREE(nqnu_tlist)
2566 58 : ABI_FREE(displ_cart)
2567 58 : ABI_FREE(displ_red)
2568 58 : ABI_FREE(tpp_red)
2569 58 : ABI_SFREE(cfact_wr)
2570 58 : ABI_SFREE(dwargs)
2571 58 : ABI_SFREE(dtw_weights)
2572 58 : ABI_SFREE(delta_e_minus_emkq)
2573 58 : ABI_FREE(gbound_kq)
2574 58 : ABI_FREE(osc_gbound_q)
2575 58 : ABI_FREE(ibzspin_2ikcalc)
2576 58 : ABI_FREE(gaussw_qnu)
2577 58 : ABI_SFREE(vcar_ibz)
2578 :
2579 58 : call gs_ham_kq%free(); call wfd%free(); call phstore%free(); call u1c%free(); call sigma%free()
2580 58 : call pawcprj_free(cwaveprj0)
2581 58 : ABI_FREE(cwaveprj0)
2582 58 : call pawcprj_free(cwaveprj)
2583 58 : ABI_FREE(cwaveprj)
2584 :
2585 : ! This to make sure that the parallel output of SIGEPH is completed
2586 58 : call xmpi_barrier(comm)
2587 58 : call cwtime_report(" sigmaph: MPI barrier before returning.", cpu_all, wall_all, gflops_all, end_str=ch10, comm=comm)
2588 :
2589 870 : end subroutine sigmaph
2590 : !!***
2591 :
2592 : !----------------------------------------------------------------------
2593 :
2594 : !!****f* m_sigmaph/sigmaph_new
2595 : !! NAME
2596 : !! sigmaph_new
2597 : !!
2598 : !! FUNCTION
2599 : !! Creation method (allocates memory, initialize data from input vars).
2600 : !!
2601 : !! INPUTS
2602 : !! dtset<dataset_type>=All input variables for this dataset.
2603 : !! ecut=Cutoff energy for wavefunctions.
2604 : !! cryst<crystal_t>=Crystalline structure
2605 : !! ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...)
2606 : !! ifc<ifc_type>=interatomic force constants and corresponding real space grid info.
2607 : !! dtfil<datafiles_type>=variables related to files.
2608 : !! comm=MPI communicator
2609 : !!
2610 : !! SOURCE
2611 :
2612 58 : type(sigmaph_t) function sigmaph_new(dtset, ecut, cryst, ebands, ifc, dtfil, comm) result(new)
2613 :
2614 : !Arguments ------------------------------------
2615 : integer,intent(in) :: comm
2616 : real(dp),intent(in) :: ecut
2617 : type(crystal_t),intent(in) :: cryst
2618 : type(dataset_type),intent(in) :: dtset
2619 : type(ebands_t),intent(in) :: ebands
2620 : type(ifc_type),intent(in) :: ifc
2621 : type(datafiles_type),intent(in) :: dtfil
2622 :
2623 : !Local variables ------------------------------
2624 : !scalars
2625 : integer,parameter :: master = 0, istwfk_1 = 1
2626 : integer :: my_rank,my_nshiftq,cnt,nprocs,ik_ibz,ndeg, iq_ibz, qptopt, qtimrev
2627 : integer :: ii, ierr, spin, gap_err, ikcalc, qprange_, bstop !it,
2628 : integer :: jj, bstart, natom, natom3 !, ip, iatom, idir, pertcase,
2629 : integer :: isym_k, trev_k, mband, nrest, color, kptopt
2630 : logical :: downsample
2631 : character(len=fnlen) :: wfk_fname_dense
2632 : character(len=5000) :: msg
2633 : real(dp) :: estep, cpu_all, wall_all, gflops_all, cpu, wall, gflops
2634 : logical :: changed, isirr_k
2635 58 : type(ebands_t) :: tmp_ebands, ebands_dense
2636 58 : type(gaps_t) :: gaps
2637 58 : type(krank_t) :: krank, qrank
2638 : !arrays
2639 : integer :: intp_nshiftk
2640 : integer :: intp_kptrlatt(3,3), g0_k(3), units(2), indkk_k(6,1), band_block(2), qptrlatt(3,3)
2641 58 : integer,allocatable :: temp(:,:), degblock(:,:), degblock_all(:,:,:,:), ndeg_all(:,:), iperm(:)
2642 : real(dp):: params(4), my_shiftq(3,1), kk(3), intp_shiftk(3)
2643 : #ifdef HAVE_MPI
2644 : integer,parameter :: ndims = 5
2645 : integer :: comm_cart, me_cart
2646 : logical :: reorder
2647 : integer :: dims(ndims)
2648 : logical :: periods(ndims), keepdim(ndims)
2649 : #endif
2650 : ! *************************************************************************
2651 :
2652 58 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
2653 :
2654 58 : call cwtime(cpu_all, wall_all, gflops_all, "start")
2655 58 : call cwtime(cpu, wall, gflops, "start")
2656 :
2657 174 : units = [std_out, ab_out]
2658 :
2659 : ! Copy important dimensions.
2660 58 : new%nsppol = ebands%nsppol; new%nspinor = ebands%nspinor; mband = dtset%mband
2661 58 : natom = cryst%natom; natom3 = cryst%natom * 3
2662 :
2663 : ! Re-Im or Im only?
2664 58 : new%imag_only = .False.
2665 58 : if (dtset%eph_task == -4) then
2666 25 : new%imag_only = .True.
2667 25 : new%mrta = 1 ! Compute lifetimes in the MRTA approximation? Default is yes
2668 : !if (dtset%userie == 1) new%mrta = 0
2669 : end if
2670 :
2671 : ! TODO: Remove qint_method, use eph_intmeth or perhaps dtset%qint_method dtset%kint_method
2672 : ! FIXME: Tetra gives positive SIGE2 while zcut gives negative (retarded)
2673 : ! Decide default behaviour for Re-Im/Im
2674 58 : new%qint_method = dtset%eph_intmeth - 1
2675 58 : new%phwinfact = dtset%eph_phwinfact
2676 :
2677 : ! Define option for integration of 1/z with tetrahedron method.
2678 58 : new%zinv_opt = 1; if (dtset%userie /= 0) new%zinv_opt = dtset%userie
2679 :
2680 : ! Broadening parameter from zcut
2681 58 : new%ieta = + j_dpc * dtset%zcut
2682 :
2683 : ! Define q-mesh for integration of the self-energy.
2684 : ! Either q-mesh from DVDB (no interpolation) or eph_ngqpt_fine (Fourier interpolation if q not in DDB)
2685 406 : new%ngqpt = dtset%ddb_ngqpt; my_nshiftq = 1; my_shiftq(:,1) = dtset%ddb_shiftq
2686 154 : if (all(dtset%eph_ngqpt_fine /= 0)) then
2687 128 : new%ngqpt = dtset%eph_ngqpt_fine; my_shiftq = 0
2688 : end if
2689 :
2690 : ! Setup IBZ, weights and BZ.
2691 : ! Assume qptopt == kptopt unless value is specified in input
2692 58 : qptrlatt = 0; qptrlatt(1, 1) = new%ngqpt(1); qptrlatt(2, 2) = new%ngqpt(2); qptrlatt(3, 3) = new%ngqpt(3)
2693 : !my_shiftq(:,1) = [0.1, 0, 0]
2694 58 : qptopt = ebands%kptopt; if (dtset%qptopt /= 0) qptopt = dtset%qptopt
2695 : qtimrev = kpts_timrev_from_kptopt(qptopt)
2696 : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt, my_nshiftq, my_shiftq, &
2697 58 : new%nqibz, new%qibz, new%wtq, new%nqbz, new%qbz, bz2ibz=new%ind_qbz2ibz)
2698 :
2699 : ! HM: the bz2ibz produced above is incomplete, I do it here using listkk
2700 174 : ABI_MALLOC(temp, (6, new%nqbz))
2701 :
2702 58 : call qrank%from_kptrlatt(new%nqibz, new%qibz, qptrlatt, compute_invrank=.False.)
2703 58 : if (kpts_map("symrec", qptopt, cryst, qrank, new%nqbz, new%qbz, temp) /= 0) then
2704 0 : ABI_ERROR("Cannot map qBZ to qIBZ!")
2705 : end if
2706 :
2707 58 : call qrank%free()
2708 :
2709 122762 : new%ind_qbz2ibz(1,:) = temp(1,:)
2710 122762 : new%ind_qbz2ibz(2,:) = temp(2,:)
2711 122762 : new%ind_qbz2ibz(3,:) = temp(6,:)
2712 122762 : new%ind_qbz2ibz(4,:) = temp(3,:)
2713 122762 : new%ind_qbz2ibz(5,:) = temp(4,:)
2714 122762 : new%ind_qbz2ibz(6,:) = temp(5,:)
2715 58 : ABI_FREE(temp)
2716 : !END DEBUG
2717 :
2718 : ! Build (linear) mesh of K * temperatures. tsmesh(1:3) = [start, step, num]
2719 58 : call dtset%get_ktmesh(new%ntemp, new%kTmesh)
2720 :
2721 58 : gaps = ebands%get_gaps(gap_err)
2722 :
2723 : ! Frequency mesh for sigma(w) and spectral functions.
2724 58 : call dtset%get_wrmesh_for_sigeph(new%nwr, new%wr_step)
2725 :
2726 : ! ======================================================
2727 : ! Select k-point and bands where corrections are wanted
2728 : ! ======================================================
2729 : !
2730 : ! if symsigma == +1, we have to include all degenerate states in the set
2731 : ! because the final QP corrections will be obtained by averaging the results in the degenerate subspace.
2732 : ! We initialize IBZ(k) here so that we have all the basic dimensions of the run and it's possible
2733 : ! to distribute the calculations among processors.
2734 58 : new%symsigma = dtset%symsigma; new%timrev = kpts_timrev_from_kptopt(ebands%kptopt)
2735 :
2736 58 : call cwtime_report(" sigmaph_new: k-points", cpu, wall, gflops)
2737 :
2738 : ! TODO: nkcalc should be spin dependent (similar piece of code in m_gwr).
2739 58 : if (dtset%nkptgw /= 0) then
2740 : ! Treat the k-points and bands specified in the input file via kptgw and bdgw.
2741 27 : call sigtk_kcalc_from_nkptgw(dtset, mband, new%nkcalc, new%kcalc, new%bstart_ks, new%nbcalc_ks)
2742 :
2743 : else
2744 74 : if (any(abs(dtset%sigma_erange) > zero)) then
2745 : ! Use sigma_erange and (optionally) sigma_ngkpt
2746 14 : call sigtk_kcalc_from_erange(dtset, cryst, ebands, gaps, new%nkcalc, new%kcalc, new%bstart_ks, new%nbcalc_ks, comm)
2747 :
2748 : else
2749 : ! Use qp_range to select the interesting k-points and the corresponding bands.
2750 : !
2751 : ! 0 --> Compute the QP corrections only for the fundamental and the direct gap.
2752 : ! +num --> Compute the QP corrections for all the k-points in the irreducible zone and include `num`
2753 : ! bands above and below the Fermi level.
2754 : ! -num --> Compute the QP corrections for all the k-points in the irreducible zone.
2755 : ! Include all occupied states and `num` empty states.
2756 :
2757 17 : qprange_ = dtset%gw_qprange
2758 17 : if (gap_err /= 0 .and. qprange_ == 0) then
2759 0 : ABI_WARNING("Cannot compute fundamental and direct gap (likely metal). Will replace qprange 0 with qprange 1")
2760 0 : qprange_ = 1
2761 : end if
2762 :
2763 17 : if (qprange_ /= 0) then
2764 11 : call sigtk_kcalc_from_qprange(dtset, cryst, ebands, qprange_, new%nkcalc, new%kcalc, new%bstart_ks, new%nbcalc_ks)
2765 : else
2766 : ! qprange is not specified in the input.
2767 : ! Include direct and fundamental KS gap or include states depending on the position wrt band edges.
2768 6 : call sigtk_kcalc_from_gaps(dtset, ebands, gaps, new%nkcalc, new%kcalc, new%bstart_ks, new%nbcalc_ks)
2769 : end if
2770 : end if
2771 :
2772 : end if ! nkptgw /= 0
2773 :
2774 : ! The k-point and the symmetries connecting the BZ k-point to the IBZ.
2775 174 : ABI_MALLOC(new%kcalc2ibz, (new%nkcalc, 6))
2776 58 : if (abs(new%symsigma) == 1) then
2777 452 : ABI_MALLOC(new%degtab, (new%nkcalc, new%nsppol))
2778 : end if
2779 :
2780 : ! Workspace arrays used to compute degeneracy tables.
2781 8432 : ABI_ICALLOC(degblock_all, (2, mband, new%nkcalc, new%nsppol))
2782 472 : ABI_ICALLOC(ndeg_all, (new%nkcalc, new%nsppol))
2783 :
2784 58 : call krank%from_kptrlatt(ebands%nkpt, ebands%kptns, ebands%kptrlatt, compute_invrank=.False.)
2785 58 : ierr = 0
2786 :
2787 240 : do ikcalc=1,new%nkcalc
2788 182 : if (mod(ikcalc, nprocs) /= my_rank) then
2789 0 : new%kcalc2ibz(ikcalc, :) = 0
2790 0 : new%bstart_ks(ikcalc, :) = 0
2791 0 : new%nbcalc_ks(ikcalc, :) = 0
2792 : cycle ! MPI parallelism inside comm
2793 : end if
2794 :
2795 : ! Note symrel and use_symrel.
2796 : ! These are the conventions for the symmetrization of the wavefunctions used in cgtk_rotate.
2797 728 : kk = new%kcalc(:, ikcalc)
2798 182 : if (new%timrev == 1) then
2799 182 : kptopt=1
2800 : else
2801 0 : kptopt=4
2802 : end if
2803 182 : if (kpts_map("symrel", kptopt, cryst, krank, 1, kk, indkk_k) /= 0) then
2804 : write(msg, '(11a)' )&
2805 0 : "The WFK file cannot be used to compute self-energy corrections at k-point: ",trim(ktoa(kk)),ch10,&
2806 0 : "The k-point cannot be generated from a symmetrical one.", ch10,&
2807 0 : "q-mesh: ",trim(ltoa(new%ngqpt)),", k-mesh (from kptrlatt): ",trim(ltoa(get_diag(dtset%kptrlatt))),ch10, &
2808 0 : 'Action: check your WFK file and the (k, q) point input variables.'
2809 0 : ABI_ERROR(msg)
2810 : end if
2811 :
2812 : ! TODO: Invert dims and update abipy
2813 1274 : new%kcalc2ibz(ikcalc, :) = indkk_k(:, 1)
2814 :
2815 182 : ik_ibz = indkk_k(1,1); isym_k = indkk_k(2,1)
2816 728 : trev_k = indkk_k(6, 1); g0_k = indkk_k(3:5,1)
2817 728 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
2818 : !kk_ibz = ebands%kptns(:,ik_ibz)
2819 : if (.not. isirr_k) then
2820 0 : ABI_WARNING(sjoin("The k-point in Sigma_{nk} must be in the IBZ but got:", ktoa(kk)))
2821 0 : ierr = ierr + 1
2822 : end if
2823 :
2824 : ! We will have to average the QP corrections over degenerate states if symsigma=1 is used.
2825 : ! Here we make sure that all the degenerate states are included.
2826 : ! Store also band indices of the degenerate sets, used to average final results.
2827 240 : if (abs(new%symsigma) == 1) then
2828 172 : cnt = 0
2829 344 : do spin=1,new%nsppol
2830 172 : bstop = new%bstart_ks(ikcalc, spin) + new%nbcalc_ks(ikcalc, spin) - 1
2831 : call ebands%enclose_degbands(ik_ibz, spin, new%bstart_ks(ikcalc, spin), bstop, changed, dtset%symsigma_de, &
2832 172 : degblock=degblock)
2833 172 : if (changed) then
2834 35 : new%nbcalc_ks(ikcalc, spin) = bstop - new%bstart_ks(ikcalc, spin) + 1
2835 35 : cnt = cnt + 1
2836 35 : if (cnt < 5) then
2837 : write(msg,'(2(a,i0),2a,2(1x,i0))') &
2838 35 : "Not all the degenerate states for ikcalc: ",ikcalc,", spin: ",spin,ch10, &
2839 70 : "were included in the bdgw set. bdgw has been automatically changed to: ",new%bstart_ks(ikcalc, spin), bstop
2840 35 : ABI_COMMENT(msg)
2841 : end if
2842 : write(msg,'(2(a,i0),2a)') &
2843 35 : "The number of included states: ", bstop, &
2844 35 : " is larger than the number of bands in the input ",dtset%nband(ik_ibz + (spin-1)*ebands%nkpt),ch10,&
2845 70 : "Action: Increase nband."
2846 35 : ABI_CHECK(bstop <= dtset%nband(ik_ibz + (spin-1)*ebands%nkpt), msg)
2847 : end if
2848 :
2849 : ! Store band indices used for averaging (shifted by bstart_ks)
2850 172 : ndeg = size(degblock, dim=2)
2851 172 : ndeg_all(ikcalc, spin) = ndeg
2852 1546 : degblock_all(:, 1:ndeg, ikcalc, spin) = degblock(:, 1:ndeg)
2853 :
2854 344 : ABI_FREE(degblock)
2855 : end do
2856 : end if ! symsigma
2857 : end do ! ikcalc
2858 :
2859 58 : call krank%free()
2860 58 : ABI_CHECK(ierr == 0, "kptgw wavevectors must be in the IBZ read from the WFK file.")
2861 :
2862 : ! Collect data
2863 58 : call xmpi_sum(new%kcalc2ibz, comm, ierr)
2864 58 : call xmpi_sum(new%bstart_ks, comm, ierr)
2865 58 : call xmpi_sum(new%nbcalc_ks, comm, ierr)
2866 :
2867 : ! Build degtab tables.
2868 58 : if (abs(new%symsigma) == 1) then
2869 56 : call xmpi_sum(ndeg_all, comm, ierr)
2870 56 : call xmpi_sum(degblock_all, comm, ierr)
2871 228 : do ikcalc=1,new%nkcalc
2872 400 : do spin=1,new%nsppol
2873 172 : ndeg = ndeg_all(ikcalc, spin)
2874 974 : ABI_MALLOC(new%degtab(ikcalc, spin)%bids, (ndeg))
2875 802 : do ii=1,ndeg
2876 458 : cnt = degblock_all(2, ii, ikcalc, spin) - degblock_all(1, ii, ikcalc, spin) + 1
2877 1374 : ABI_MALLOC(new%degtab(ikcalc, spin)%bids(ii)%vals, (cnt))
2878 : new%degtab(ikcalc, spin)%bids(ii)%vals = [(jj, jj= &
2879 : degblock_all(1, ii, ikcalc, spin) - new%bstart_ks(ikcalc, spin) + 1, &
2880 3272 : degblock_all(2, ii, ikcalc, spin) - new%bstart_ks(ikcalc, spin) + 1)]
2881 : end do
2882 : end do
2883 : end do
2884 : end if
2885 58 : ABI_FREE(degblock_all)
2886 58 : ABI_FREE(ndeg_all)
2887 :
2888 58 : call cwtime_report(" sigmaph_new: kptgw", cpu, wall, gflops)
2889 :
2890 : ! Now we can finally compute max_nbcalc
2891 298 : new%max_nbcalc = maxval(new%nbcalc_ks)
2892 :
2893 232 : ABI_MALLOC(new%bstop_ks, (new%nkcalc, new%nsppol))
2894 356 : new%bstop_ks = new%bstart_ks + new%nbcalc_ks - 1
2895 :
2896 : ! Compute mpw and gmax
2897 58 : call ephtk_get_mpw_gmax(new%nkcalc, new%kcalc, ecut, cryst%gmet, new%mpw, new%gmax, comm)
2898 58 : call wrtout(std_out, sjoin(' Optimal value of mpw:', itoa(new%mpw), "gmax:", ltoa(new%gmax)))
2899 58 : call cwtime_report(" sigmaph_new: mpw", cpu, wall, gflops)
2900 :
2901 : ! Define number of bands included in self-energy summation as well as the band range.
2902 : ! This value depends on the kind of calculation as imag_only can take advantage of
2903 : ! the energy window around the band edges.
2904 : !
2905 : ! Notes about MPI version.
2906 : ! If eph_task == -4:
2907 : ! Loops are MPI parallelized over bands so that we can distribute memory for wavefunctions over nband.
2908 : ! perturbations and q-points in the IBZ can also be distributed.
2909 : !
2910 : ! If eph_task == -4:
2911 : ! Loops are MPI parallelized over q-points
2912 : ! wavefunctions are NOT distributed but only states between my_bsum_start and my_bsum_stop
2913 : ! are allocated and read from file.
2914 : ! perturbations and q-points in the IBZ can also be distributed.
2915 :
2916 58 : new%wmax = 1.1_dp * abs(ifc%omega_minmax(2))
2917 58 : if (new%qint_method == 0) new%wmax = new%wmax + five * dtset%zcut
2918 : ! TODO: One should be consistent with tolerances when using tetra + q-point filtering.
2919 : !if (new%qint_method == 1) new%wmax = new%wmax + five * dtset%zcut
2920 : !new%wmax = new%wmax + five * dtset%zcut
2921 : !write(std_out,*)"wmax:", new%wmax * Ha_eV, " (eV)"
2922 :
2923 58 : new%elow = huge(one); new%ehigh = - huge(one)
2924 116 : do spin=1,new%nsppol
2925 298 : do ikcalc=1,new%nkcalc
2926 182 : ik_ibz = new%kcalc2ibz(ikcalc, 1)
2927 182 : bstart = new%bstart_ks(ikcalc, spin)
2928 182 : bstop = new%bstart_ks(ikcalc, spin) + new%nbcalc_ks(ikcalc, spin) - 1
2929 1148 : new%ehigh = max(new%ehigh, maxval(ebands%eig(bstart:bstop, ik_ibz, spin)) + new%wmax)
2930 1206 : new%elow = min(new%elow, minval(ebands%eig(bstart:bstop, ik_ibz, spin)) - new%wmax)
2931 : end do
2932 : end do
2933 : !call wrtout(std_out, sjoin("elow:", ftoa(elow), "ehigh:", ftoa(ehigh), "[Ha]"))
2934 :
2935 58 : if (new%imag_only) then
2936 :
2937 25 : if (all(dtset%sigma_bsum_range /= 0)) then
2938 0 : new%bsum_start = max(dtset%sigma_bsum_range(1), 1)
2939 0 : new%bsum_stop = min(dtset%sigma_bsum_range(2), mband)
2940 0 : new%nbsum = new%bsum_stop - new%bsum_start + 1
2941 0 : new%my_bsum_start = new%bsum_start; new%my_bsum_stop = new%bsum_stop
2942 : else
2943 : ! Compute the min/max KS energy to be included in the imaginary part.
2944 : ! ifc%omega_minmax(2) comes from the coarse Q-mesh of the DDB so increase it by 10%.
2945 : ! Also take into account the Lorentzian function if zcut is used.
2946 : ! In principle this should be large enough but it seems that the linewidths in v8[160] are slightly affected.
2947 : ! Select indices for energy window.
2948 :
2949 25 : call ebands%get_bands_from_erange(new%elow, new%ehigh, new%bsum_start, new%bsum_stop)
2950 25 : new%bsum_stop = min(new%bsum_stop, mband)
2951 25 : ABI_CHECK(new%bsum_start <= new%bsum_stop, "bsum_start > bsum_bstop")
2952 25 : new%nbsum = new%bsum_stop - new%bsum_start + 1
2953 25 : new%my_bsum_start = new%bsum_start; new%my_bsum_stop = new%bsum_stop
2954 : end if
2955 :
2956 : !if (dtset%useria == 567) then
2957 : ! ! Uncomment this part to use all states to debug.
2958 : ! call wrtout(units, "- Setting bstart to 1 and bstop to nband for debugging purposes")
2959 : ! new%nbsum = mband; new%bsum_start = 1; new%bsum_stop = new%bsum_start + new%nbsum - 1
2960 : ! new%my_bsum_start = new%bsum_start; new%my_bsum_stop = new%bsum_stop
2961 : !end if
2962 :
2963 : else
2964 : ! Re + Im
2965 33 : new%bsum_start = 1; new%bsum_stop = mband
2966 37 : if (all(dtset%sigma_bsum_range /= 0)) then
2967 2 : new%bsum_start = max(dtset%sigma_bsum_range(1), 1)
2968 2 : new%bsum_stop = min(dtset%sigma_bsum_range(2), mband)
2969 : end if
2970 33 : new%nbsum = new%bsum_stop - new%bsum_start + 1
2971 : end if
2972 :
2973 : ! ========================
2974 : ! === MPI DISTRIBUTION ===
2975 : ! ========================
2976 : ! Init for sequential execution.
2977 58 : new%my_npert = natom3
2978 :
2979 348 : if (any(dtset%eph_np_pqbks /= 0)) then
2980 : ! Use parameters from input file.
2981 0 : new%pert_comm%nproc = dtset%eph_np_pqbks(1)
2982 0 : new%qpt_comm%nproc = dtset%eph_np_pqbks(2)
2983 0 : new%bsum_comm%nproc = dtset%eph_np_pqbks(3)
2984 0 : new%kcalc_comm%nproc = dtset%eph_np_pqbks(4)
2985 0 : new%spin_comm%nproc = dtset%eph_np_pqbks(5)
2986 0 : new%my_npert = natom3 / new%pert_comm%nproc
2987 0 : ABI_CHECK(new%my_npert > 0, "pert_comm_nproc cannot be greater than 3 * natom.")
2988 0 : ABI_CHECK(mod(natom3, new%pert_comm%nproc) == 0, "pert_comm_nproc must divide 3 * natom.")
2989 0 : if (new%imag_only .and. new%bsum_comm%nproc /= 1) then
2990 0 : ABI_ERROR("Nprocs in bsum_comm should be 1 when computing Imag(Sigma)")
2991 : end if
2992 : else
2993 : ! Automatic grid generation.
2994 :
2995 : ! TODO: Spin
2996 : ! Automatic grid generation over q-points and spins.
2997 : !if (new%nsppol == 2 .and. mod(nprocs, 2) == 0) then
2998 : ! spin_comm%nproc = 2
2999 : ! new%qpt_comm%nproc = nprocs / 2
3000 : !else
3001 : ! new%qpt_comm%nproc = nprocs
3002 : !end if
3003 :
3004 : ! Handle parallelism over perturbations first.
3005 : ! Use MPI communicator to distribute the 3 * natom perturbations to reduce memory requirements for DFPT potentials.
3006 : ! Ideally, perturbations are equally distributed --> total number of CPUs should be divisible by 3 * natom.
3007 : ! or at least, divisible by one integer i for i in [2, 3 * natom - 1].
3008 :
3009 : ! Try to have 3 perts per proc first because the q-point parallelism is more efficient.
3010 : ! The memory for W(R,r,ipert) will increase though.
3011 : !do cnt=natom,2,-1
3012 : ! if (mod(nprocs, cnt) == 0 .and. mod(natom3, cnt) == 0) then
3013 : ! new%pert_comm%nproc = cnt; new%my_npert = natom3 / cnt; exit
3014 : ! end if
3015 : !end do
3016 :
3017 58 : if (new%pert_comm%nproc == 1) then
3018 : ! Try again with more procs.
3019 345 : do cnt=natom3,2,-1
3020 345 : if (mod(nprocs, cnt) == 0 .and. mod(natom3, cnt) == 0) then
3021 0 : new%pert_comm%nproc = cnt; new%my_npert = natom3 / cnt; exit
3022 : end if
3023 : end do
3024 : end if
3025 :
3026 58 : if (new%my_npert == natom3 .and. nprocs > 1) then
3027 0 : ABI_WARNING("The number of MPI procs should be divisible by 3*natom to reduce memory requirements!")
3028 : end if
3029 :
3030 : ! Define number of procs for q-points and bands. nprocs is divisible by pert_comm%nproc.
3031 58 : if (new%imag_only) then
3032 : ! Just one extra MPI level for q-points.
3033 25 : new%qpt_comm%nproc = nprocs / new%pert_comm%nproc
3034 : else
3035 : ! Try to distribute equally nbsum first.
3036 33 : nrest = nprocs / new%pert_comm%nproc
3037 33 : do bstop=nrest,1,-1
3038 33 : if (mod(new%nbsum, bstop) == 0 .and. mod(nprocs, new%pert_comm%nproc * bstop) == 0) then
3039 33 : new%bsum_comm%nproc = bstop; new%qpt_comm%nproc = nrest / new%bsum_comm%nproc
3040 33 : exit
3041 : end if
3042 : end do
3043 : end if
3044 : end if
3045 :
3046 : ! Consistency check.
3047 58 : if (new%pert_comm%nproc * new%qpt_comm%nproc * new%bsum_comm%nproc * new%kcalc_comm%nproc * new%spin_comm%nproc /= nprocs) then
3048 : write(msg, "(a,i0,3a, 6(a,1x,i0))") &
3049 0 : "Cannot create 5d Cartesian grid with total nprocs: ", nprocs, ch10, &
3050 0 : "Idle processes are not supported. The product of the `nprocs_*` vars should be equal to nprocs.", ch10, &
3051 0 : "pert_nproc (", new%pert_comm%nproc, ") x qpt_nproc (", new%qpt_comm%nproc, ") x bsum_nproc (", new%bsum_comm%nproc, &
3052 0 : ") x kcalc_nproc (", new%kcalc_comm%nproc, ") x spin_nproc (", new%spin_comm%nproc, ") != ", nprocs
3053 0 : ABI_ERROR(msg)
3054 : end if
3055 :
3056 348 : new%coords_pqbks = 0
3057 : #ifdef HAVE_MPI
3058 : ! Create 5d cartesian communicator: 3*natom perturbations, q-points in IBZ, bands in Sigma sum, kpoints in Sigma_k, spins
3059 : ! FIXME: Fix spin
3060 58 : periods(:) = .False.; reorder = .False.
3061 348 : dims = [new%pert_comm%nproc, new%qpt_comm%nproc, new%bsum_comm%nproc, new%kcalc_comm%nproc, new%spin_comm%nproc]
3062 : ! Try New distrib ?
3063 : !dims = [new%pert_comm%nproc, new%bsum_comm%nproc, new%qpt_comm%nproc, new%kcalc_comm%nproc, new%spin_comm%nproc]
3064 :
3065 58 : call MPI_CART_CREATE(comm, ndims, dims, periods, reorder, comm_cart, ierr)
3066 : ! Find the index and coordinates of the current processor
3067 58 : call MPI_COMM_RANK(comm_cart, me_cart, ierr)
3068 58 : call MPI_CART_COORDS(comm_cart, me_cart, ndims, new%coords_pqbks, ierr)
3069 :
3070 : ! Create communicator to distribute natom3 perturbations.
3071 58 : keepdim = .False.; keepdim(1) = .True.; call new%pert_comm%from_cart_sub(comm_cart, keepdim)
3072 : ! Create communicator for qpoints in self-energy integration.
3073 58 : keepdim = .False.; keepdim(2) = .True.; call new%qpt_comm%from_cart_sub(comm_cart, keepdim)
3074 : ! Create communicator for bands for self-energy summation
3075 58 : keepdim = .False.; keepdim(3) = .True.; call new%bsum_comm%from_cart_sub(comm_cart, keepdim)
3076 : ! Create communicator for kpoints.
3077 58 : keepdim = .False.; keepdim(4) = .True.; call new%kcalc_comm%from_cart_sub(comm_cart, keepdim)
3078 : ! Create communicator for spins.
3079 58 : keepdim = .False.; keepdim(5) = .True.; call new%spin_comm%from_cart_sub(comm_cart, keepdim)
3080 : ! Create communicator for the (band_sum, qpoint_sum) loops
3081 174 : keepdim = .False.; keepdim(2:3) = .True.; call new%qb_comm%from_cart_sub(comm_cart, keepdim)
3082 : ! Create communicator for the (perturbation, band_sum, qpoint_sum)
3083 232 : keepdim = .False.; keepdim(1:3) = .True.; call new%pqb_comm%from_cart_sub(comm_cart, keepdim)
3084 :
3085 58 : call xmpi_comm_free(comm_cart)
3086 : #endif
3087 :
3088 : ! Distribute k-points and create mapping to ikcalc index.
3089 58 : call xmpi_split_cyclic(new%nkcalc, new%kcalc_comm%value, new%my_nkcalc, new%my_ikcalc)
3090 58 : ABI_CHECK(new%my_nkcalc > 0, sjoin("nkcalc (", itoa(new%nkcalc), ") < kcalc_comm_nproc (", itoa(new%kcalc_comm%nproc), ")"))
3091 :
3092 : ! Distribute spins and create mapping to spin index.
3093 58 : if (new%nsppol == 2) then
3094 0 : call xmpi_split_block(new%nsppol, new%spin_comm%value, new%my_nspins, new%my_spins)
3095 0 : ABI_CHECK(new%my_nspins > 0, sjoin("nsppol (", itoa(new%nsppol), ") < spin_comm_nproc (", itoa(new%spin_comm%nproc), ")"))
3096 : else
3097 : ! No nsppol parallelism DOH!
3098 58 : new%my_nspins = 1
3099 58 : ABI_MALLOC(new%my_spins, (new%my_nspins))
3100 116 : new%my_spins = 1
3101 : end if
3102 :
3103 : ! Create MPI communicator for parallel netcdf IO used to write results for the different k-points.
3104 : ! This communicator is defined only on the processes that will perform IO.
3105 58 : call new%ncwrite_comm%set_to_null()
3106 :
3107 58 : if (new%kcalc_comm%nproc == 1 .and. new%spin_comm%nproc == 1) then
3108 : ! Easy-peasy: only master in comm_world performs IO.
3109 58 : if (my_rank == master) call new%ncwrite_comm%set_to_self()
3110 : else
3111 : ! Create subcommunicator by selecting one proc per kpoint-spin subgrid.
3112 : ! Since we write to ab_out in sigmaph_gather_and_write, make sure that ab_out is connected!
3113 : ! This means Sigma_nk results will be spread among multiple ab_out files.
3114 : ! Only SIGPEPH.nc will contain all the results.
3115 : ! Remember that now all nc define operations must be done inside ncwrite_comm
3116 : ! Obviously I'm assuming HDF5 + MPI-IO
3117 : !
3118 : ! NB: If MPI_UNDEFINED is passed as the colour value, the subgroup in which the calling
3119 : ! MPI process will be placed is MPI_COMM_NULL
3120 :
3121 0 : color = xmpi_undefined; if (all(new%coords_pqbks(1:3) == 0)) color = 1
3122 0 : call xmpi_comm_split(comm, color, my_rank, new%ncwrite_comm%value, ierr)
3123 0 : if (color == 1) then
3124 0 : new%ncwrite_comm%me = xmpi_comm_rank(new%ncwrite_comm%value)
3125 0 : new%ncwrite_comm%nproc = xmpi_comm_size(new%ncwrite_comm%value)
3126 0 : if (my_rank == master) then
3127 : call wrtout(units, &
3128 : sjoin("- Using parallelism over k-points/spins. Cannot write full results to main output", ch10, &
3129 0 : "- All procs except master will write to dev_null. Use SIGEPH.nc to analyze results."))
3130 : !write(std_out, *)"ncwrite_comm_me:", new%ncwrite_comm%me, "ncwrite_comm%nproc:", new%ncwrite_comm%nproc
3131 : end if
3132 0 : if (.not. is_open(ab_out)) then
3133 : !if (open_file(strcat(dtfil%filnam_ds(2), "_rank_", itoa(new%ncwrite_comm%me)), msg, unit=ab_out, &
3134 0 : if (open_file(NULL_FILE, msg, unit=ab_out, form="formatted", action="write", status='unknown') /= 0) then
3135 0 : ABI_ERROR(msg)
3136 : end if
3137 : end if
3138 : else
3139 0 : call new%ncwrite_comm%set_to_null()
3140 : end if
3141 : end if
3142 :
3143 : ! Build table with list of perturbations treated by this CPU inside pert_comm
3144 58 : call ephtk_set_pertables(cryst%natom, new%my_npert, new%pert_table, new%my_pinfo, new%pert_comm%value)
3145 :
3146 : ! Setup a mask to skip accumulating the contribution of certain phonon modes.
3147 58 : call ephtk_set_phmodes_skip(dtset%natom, dtset%eph_phrange, new%phmodes_skip)
3148 :
3149 58 : if (.not. new%imag_only) then
3150 : ! Split bands among the procs inside bsum_comm using block distribution.
3151 33 : call xmpi_split_work(new%nbsum, new%bsum_comm%value, new%my_bsum_start, new%my_bsum_stop)
3152 33 : if (new%my_bsum_start == new%nbsum + 1) then
3153 0 : ABI_ERROR("sigmaph code does not support idle processes! Decrease ncpus or increase nband or use eph_np_pqbks input var.")
3154 : end if
3155 33 : new%my_bsum_start = new%bsum_start + new%my_bsum_start - 1
3156 33 : new%my_bsum_stop = new%bsum_start + new%my_bsum_stop - 1
3157 99 : ABI_MALLOC(new%nbsum_rank, (new%bsum_comm%nproc, 3))
3158 33 : ii = new%my_bsum_stop - new%my_bsum_start + 1
3159 33 : call xmpi_allgather(ii, new%nbsum_rank(:,1), new%bsum_comm%value, ierr)
3160 33 : ii = new%my_bsum_start
3161 33 : call xmpi_allgather(ii, new%nbsum_rank(:,2), new%bsum_comm%value, ierr)
3162 : end if
3163 :
3164 : call wrtout(std_out, sjoin(" Global bands for self-energy sum, bsum_start: ", itoa(new%bsum_start), &
3165 58 : " bsum_bstop:", itoa(new%bsum_stop)))
3166 : call wrtout(std_out, sjoin(" Allocating and treating bands from my_bsum_start: ", itoa(new%my_bsum_start), &
3167 58 : " up to my_bsum_stop:", itoa(new%my_bsum_stop)))
3168 :
3169 : ! Distribute DFPT potentials (IBZ q-points) inside qpt_comm.
3170 : ! Note that we distribute IBZ instead of the full BZ or the IBZ_k inside the loop over ikcalc.
3171 : ! This means that the load won't be equally distributed but memory will scale with qpt_comm%nproc.
3172 : ! To reduce load imbalance, we sort the qibz points by norm and use cyclic distribution inside qpt_comm
3173 4164 : ABI_ICALLOC(new%itreat_qibz, (new%nqibz))
3174 58 : call sort_rpts(new%nqibz, new%qibz, cryst%gmet, iperm)
3175 4048 : do ii=1,new%nqibz
3176 3990 : iq_ibz = iperm(ii)
3177 4048 : if (mod(ii, new%qpt_comm%nproc) == new%qpt_comm%me) new%itreat_qibz(iq_ibz) = 1
3178 : end do
3179 58 : ABI_FREE(iperm)
3180 :
3181 4048 : call wrtout(std_out, sjoin("P Number of q-points in the IBZ treated by this proc: " ,itoa(count(new%itreat_qibz == 1))))
3182 :
3183 : ! ================================================================
3184 : ! Allocate arrays used to store final results and set them to zero
3185 : ! ================================================================
3186 472 : ABI_ICALLOC(new%qp_done, (new%nkcalc, new%nsppol))
3187 1730 : ABI_CALLOC(new%vals_e0ks, (new%ntemp, new%max_nbcalc))
3188 1672 : ABI_CALLOC(new%fan_vals, (new%ntemp, new%max_nbcalc))
3189 406 : ABI_CALLOC(new%E2, (new%ntemp))
3190 1672 : ABI_CALLOC(new%E4_vals, (new%ntemp, new%max_nbcalc))
3191 1672 : ABI_CALLOC(new%E4_vals2, (new%ntemp, new%max_nbcalc))
3192 1672 : ABI_CALLOC(new%fan_stern_vals, (new%ntemp, new%max_nbcalc))
3193 1672 : ABI_CALLOC(new%dvals_de0ks, (new%ntemp, new%max_nbcalc))
3194 1730 : ABI_CALLOC(new%dw_vals, (new%ntemp, new%max_nbcalc))
3195 1672 : ABI_CALLOC(new%dw_stern_vals, (new%ntemp, new%max_nbcalc))
3196 :
3197 : ! Frequency dependent stuff
3198 58 : if (new%nwr > 0) then
3199 54575 : ABI_CALLOC(new%vals_wr, (new%nwr, new%ntemp, new%max_nbcalc))
3200 17068 : ABI_CALLOC(new%wrmesh_b, (new%nwr, new%max_nbcalc))
3201 : end if
3202 :
3203 : ! Compute phonon frequency mesh.
3204 58 : call ifc%get_phmesh(dtset%ph_wstep, new%phmesh_size, new%phmesh)
3205 :
3206 : ! Prepare calculation of generalized Eliashberg functions
3207 : ! prteliash == 0 deactivates computation (default).
3208 58 : if (dtset%prteliash /= 0) then
3209 84 : ABI_MALLOC(new%gfw_vals, (new%phmesh_size, 3, new%max_nbcalc))
3210 : end if
3211 :
3212 58 : new%a2f_ne = 0
3213 58 : if (dtset%prteliash == 3) then
3214 : ! TODO: dosdeltae should have a default value.
3215 : ! TODO: Use logmesh/double mesh for electrons?
3216 0 : estep = dtset%dosdeltae; if (estep <= zero) estep = 0.05 * eV_Ha
3217 0 : new%a2f_ne = nint((maxval(ebands%eig) - minval(ebands%eig)) / estep) + 1
3218 0 : if (my_rank == master) then
3219 0 : write(std_out, *)" Computing a2f with ", new%a2f_ne, " points for electrons and ", new%phmesh_size, " points for phonons."
3220 0 : write(std_out, *)" doseltae:", estep, ", tsmear:", dtset%tsmear
3221 : end if
3222 0 : ABI_MALLOC(new%a2f_emesh, (new%a2f_ne))
3223 0 : new%a2f_emesh = arth(minval(ebands%eig), estep, new%a2f_ne)
3224 0 : ABI_CALLOC(new%a2few, (new%a2f_ne, new%phmesh_size, new%max_nbcalc))
3225 : end if
3226 :
3227 58 : call cwtime_report(" MPI setup", cpu, wall, gflops)
3228 :
3229 : ! Initialize object for the computation of integration weights (integration in q-space).
3230 : ! Weights can be obtained in different ways:
3231 : !
3232 : ! 1. Computed from eigens on the same coarse q-mesh as the one used for the self-energy.
3233 : ! 2. Obtained from eigens on a denser q-mesh and then transferred to the coarse q-mesh.
3234 : ! In this case the eigens on the dense mesh are either read from an external file (ab-initio)
3235 : ! or interpolated on the fly with star-functions.
3236 : !
3237 : ! NB: The routines assume that the k-mesh for electrons and the q-mesh for phonons are the same.
3238 : ! Thus we need to downsample the k-mesh if it's denser that the q-mesh.
3239 :
3240 58 : new%use_doublegrid = .False.
3241 :
3242 : ! ================================================================================================
3243 : ! Here we construct ebands_dense for the double grid either from WFK file or via SKW interpolation
3244 : ! ================================================================================================
3245 :
3246 58 : if (dtset%getwfkfine /= 0 .or. dtset%irdwfkfine /= 0 .or. dtset%getwfkfine_filepath /= ABI_NOFILE) then
3247 :
3248 : ! In principle only getwfkfine_filepath is used
3249 5 : wfk_fname_dense = trim(dtfil%fnameabi_wfkfine)
3250 5 : ABI_CHECK(nctk_try_fort_or_ncfile(wfk_fname_dense, msg) == 0, msg)
3251 5 : call wrtout(units, "- EPH double grid interpolation: will read energies from: "//trim(wfk_fname_dense), newlines=1)
3252 :
3253 5 : ebands_dense = wfk_read_ebands(wfk_fname_dense, comm)
3254 :
3255 : ! TODO add consistency check: number of bands and kpoints (commensurability)
3256 : !if (ebands_dense%is_commensurate(msg) /= 0)
3257 5 : ABI_CHECK_IEQ(ebands_dense%mband, ebands%mband, "Inconsistent number of bands for the fine and dense grid:")
3258 5 : new%use_doublegrid = .True.
3259 :
3260 206 : else if (any(dtset%bs_interp_kmult /= 0)) then
3261 :
3262 : ! Read bs_interpmult
3263 2 : call wrtout(units, " EPH interpolation: will use star functions interpolation.", newlines=1)
3264 : ! Interpolate band energies with star-functions
3265 2 : params = 0; params(1) = 1; params(2) = 5
3266 2 : if (nint(dtset%einterp(1)) == 1) params = dtset%einterp
3267 : !write(std_out, "(a, 4(f5.2, 2x))")" SKW parameters for double-grid:", params
3268 :
3269 : !TODO: mband should be min of nband
3270 6 : band_block = [1, ebands%mband]
3271 : ! TODO: Now we should use this band range.
3272 : ! Note that we start from 1 because we are gonna use ebands_dense to compute the Fermi level.
3273 : !band_block = [1, new%bsum_stop]
3274 8 : intp_kptrlatt(:,1) = [ebands%kptrlatt(1,1)*dtset%bs_interp_kmult(1), 0, 0]
3275 8 : intp_kptrlatt(:,2) = [0, ebands%kptrlatt(2,2)*dtset%bs_interp_kmult(2), 0]
3276 8 : intp_kptrlatt(:,3) = [0, 0, ebands%kptrlatt(3,3)*dtset%bs_interp_kmult(3)]
3277 :
3278 2 : intp_nshiftk = 1; intp_shiftk = zero
3279 : ebands_dense = ebands%interp_kmesh(cryst, params, intp_kptrlatt, &
3280 2 : intp_nshiftk, intp_shiftk, band_block, comm)
3281 2 : new%use_doublegrid = .True.
3282 : end if
3283 :
3284 58 : if (new%use_doublegrid) then
3285 : ! Note that we don't recompute %fermie and %occ in ebands_dense, only %nelect must be consistent with the
3286 : ! input ebands to handle possible doping
3287 7 : ebands_dense%nelect = ebands%nelect
3288 7 : ebands_dense%fermie = ebands%fermie
3289 7 : if (abs(dtset%mbpt_sciss) > tol6) then
3290 : ! Apply the scissor operator to the dense mesh
3291 0 : call wrtout(std_out, sjoin(" Apply the scissor operator to the dense CB with:",ftoa(dtset%mbpt_sciss)))
3292 0 : call ebands_dense%apply_scissors(dtset%mbpt_sciss)
3293 : end if
3294 : end if
3295 :
3296 : ! Build object used to compute integration weights taking into account double-grid.
3297 : ! Note that we compute the weights only for the states included in the sum
3298 : ! bstart and new%bsum_comm select the band range.
3299 : ! TODO:
3300 : ! 1) Should recheck the case bstart > 1 with star functions as I got weird results.
3301 : ! 2) Should refactor ephwg so that only my_npert phonons are stored in the datatype.
3302 58 : bstart = new%bsum_start
3303 :
3304 58 : if (new%qint_method > 0) then
3305 : ! Tetra
3306 19 : if (new%use_doublegrid) then
3307 : ! Double-grid technique from ab-initio energies or star-function interpolation.
3308 3 : new%ephwg = ephwg_from_ebands(cryst, ifc, ebands_dense, bstart, new%nbsum, comm)
3309 3 : new%eph_doublegrid = eph_double_grid_new(cryst, ebands_dense, ebands%kptrlatt, ebands_dense%kptrlatt)
3310 : else
3311 208 : downsample = any(ebands%kptrlatt /= qptrlatt) .or. ebands%nshiftk /= my_nshiftq
3312 80 : if (ebands%nshiftk == my_nshiftq) downsample = downsample .or. any(ebands%shiftk /= my_shiftq)
3313 16 : if (downsample) then
3314 0 : ABI_COMMENT("K-mesh != Q-mesh for self-energy. Will downsample electron energies.")
3315 0 : tmp_ebands = ebands%downsample(cryst, qptrlatt, my_nshiftq, my_shiftq)
3316 0 : new%ephwg = ephwg_from_ebands(cryst, ifc, tmp_ebands, bstart, new%nbsum, comm)
3317 0 : call tmp_ebands%free()
3318 : else
3319 16 : new%ephwg = ephwg_from_ebands(cryst, ifc, ebands, bstart, new%nbsum, comm)
3320 : end if
3321 : end if
3322 :
3323 : else
3324 : ! Standard quadrature.
3325 39 : if (new%use_doublegrid) then
3326 4 : new%eph_doublegrid = eph_double_grid_new(cryst, ebands_dense, ebands%kptrlatt, ebands_dense%kptrlatt)
3327 4 : new%ephwg = ephwg_from_ebands(cryst, ifc, ebands_dense, bstart, new%nbsum, comm)
3328 : endif
3329 : end if
3330 :
3331 58 : call cwtime_report(" sigmaph_new: after doublegrid", cpu, wall, gflops)
3332 :
3333 : ! Compute the chemical potential at the different physical temperatures with Fermi-Dirac.
3334 174 : ABI_MALLOC(new%mu_e, (new%ntemp))
3335 290 : new%mu_e(:) = ebands%fermie
3336 :
3337 58 : if (dtset%eph_fermie == zero) then
3338 57 : if (new%use_doublegrid) then
3339 7 : call ebands_dense%get_muT_with_fd(new%ntemp, new%ktmesh, dtset%spinmagntarget, dtset%prtvol, new%mu_e, comm)
3340 : else
3341 50 : call ebands%get_muT_with_fd(new%ntemp, new%ktmesh, dtset%spinmagntarget, dtset%prtvol, new%mu_e, comm)
3342 : end if
3343 : endif
3344 :
3345 58 : call ebands_dense%free()
3346 :
3347 58 : if (my_rank == master) then
3348 58 : call gaps%print(units, kTmesh=new%ktmesh, mu_e=new%mu_e, header="Gaps, band edges and relative position wrt Fermi level")
3349 : end if
3350 58 : call gaps%free()
3351 :
3352 : ! Prepare computation of Frohlich self-energy
3353 : ! TODO: Reintegrate at least frohl_model 1 for the full self-energy
3354 58 : new%frohl_model = 0
3355 58 : new%ntheta = abs(dtset%eph_frohl_ntheta)
3356 58 : if (.not. new%imag_only .and. new%ntheta > 0) then
3357 0 : new%frohl_model = 1
3358 : !if (.not. dvdb%has_zeff) new%frohl_model = 0
3359 : end if
3360 :
3361 58 : if (new%frohl_model /= 0) then
3362 : ! Set angular mesh for numerical integration inside micro BZ around Gamma.
3363 0 : new%nphi = 2 * new%ntheta
3364 0 : if (my_rank == master) then
3365 0 : write(std_out,"(a)")" Activating computation the of Frohlich self-energy:"
3366 0 : write(std_out,"(2(a,i0,1x))")" ntheta: ", new%ntheta, "nphi: ", new%nphi
3367 : end if
3368 :
3369 : ! Initialize angular mesh qvers_cart and angwgth
3370 : ! NB: summing over f * angwgth gives the spherical average 1/(4pi) \int domega f(omega)
3371 0 : call ylm_angular_mesh(new%ntheta, new%nphi, new%angl_size, new%qvers_cart, new%angwgth)
3372 : end if
3373 :
3374 58 : if (new%mrta > 0) then
3375 745 : ABI_CALLOC(new%linewidth_mrta, (new%ntemp, new%max_nbcalc))
3376 : end if
3377 :
3378 58 : call cwtime_report(" sigmaph_new: all", cpu_all, wall_all, gflops_all)
3379 :
3380 522 : end function sigmaph_new
3381 : !!***
3382 :
3383 : !----------------------------------------------------------------------
3384 :
3385 : !!****f* m_sigmaph/sigmaph_write
3386 : !! NAME
3387 : !! sigmaph_write
3388 : !!
3389 : !! FUNCTION
3390 : !! Define dimensions and netcdf arrays in SIGEPH file.
3391 : !!
3392 : !! INPUTS
3393 : !! dtset<dataset_type>=All input variables for this dataset.
3394 : !! cryst<crystal_t>=Crystalline structure
3395 : !! ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...)
3396 : !! wfk_hdr=Header of the WFK file.
3397 : !! ifc<ifc_type>=interatomic force constants and corresponding real space grid info.
3398 : !! dtfil<datafiles_type>=variables related to files.
3399 : !! comm=MPI communicator
3400 : !!
3401 : !! SOURCE
3402 :
3403 58 : subroutine sigmaph_write(self, dtset, cryst, ebands, wfk_hdr, dtfil, comm)
3404 :
3405 : !Arguments ------------------------------------
3406 : integer,intent(in) :: comm
3407 : class(sigmaph_t),intent(inout) :: self
3408 : type(crystal_t),intent(in) :: cryst
3409 : type(dataset_type),intent(in) :: dtset
3410 : type(ebands_t),intent(in) :: ebands
3411 : type(hdr_type),intent(in) :: wfk_hdr
3412 : type(datafiles_type),intent(in) :: dtfil
3413 :
3414 : !Local variables ------------------------------
3415 : !scalars
3416 : integer,parameter :: master = 0
3417 : integer :: my_rank, ii, edos_intmeth, spin, ikcalc
3418 : integer :: ncid, ncerr, grp_ncid
3419 : !character(len=5000) :: msg
3420 : real(dp) :: edos_broad, edos_step, cpu_all, wall_all, gflops_all, cpu, wall, gflops
3421 : character(len=fnlen) :: path
3422 58 : type(edos_t) :: edos
3423 : ! *************************************************************************
3424 :
3425 58 : my_rank = xmpi_comm_rank(comm)
3426 :
3427 58 : call cwtime(cpu_all, wall_all, gflops_all, "start")
3428 :
3429 58 : if (dtset%prtdos /= 0) then
3430 0 : call cwtime(cpu, wall, gflops, "start")
3431 : ! Compute electron DOS.
3432 0 : edos_intmeth = 2; if (self%bcorr == 1) edos_intmeth = -2
3433 0 : if (dtset%prtdos == 1) edos_intmeth = 1
3434 0 : edos_step = dtset%dosdeltae; edos_broad = dtset%tsmear
3435 0 : call wrtout(std_out, " Computing electron dos. Use prtdos 0 to disable this part...", do_flush=.True.)
3436 0 : edos = ebands%get_edos(cryst, edos_intmeth, edos_step, edos_broad, comm)
3437 0 : if (my_rank == master) then
3438 0 : path = strcat(dtfil%filnam_ds(4), "_EDOS")
3439 0 : call wrtout(ab_out, sjoin("- Writing electron DOS to file:", path))
3440 0 : call edos%write(path)
3441 0 : call edos%print([std_out])
3442 : end if
3443 0 : call cwtime_report(" sigmaph_new: ebands", cpu, wall, gflops)
3444 : end if
3445 :
3446 : ! Create netcdf file (only master works, HDF5 + MPI-IO is handled afterwards by reopening the file inside ncwrite_comm)
3447 58 : path = strcat(dtfil%filnam_ds(4), "_SIGEPH.nc")
3448 58 : if (my_rank == master) then
3449 : ! Master creates the netcdf file used to store the results of the calculation.
3450 58 : NCF_CHECK(nctk_open_create(self%ncid, path, xmpi_comm_self))
3451 58 : ncid = self%ncid
3452 58 : NCF_CHECK(wfk_hdr%ncwrite(ncid, fform_from_ext("SIGEPH.nc"), nc_define=.True.))
3453 58 : NCF_CHECK(cryst%ncwrite(ncid))
3454 58 : NCF_CHECK(ebands%ncwrite(ncid))
3455 58 : if (dtset%prtdos /= 0) then
3456 0 : NCF_CHECK(edos%ncwrite(ncid))
3457 : end if
3458 :
3459 : ! Add dimensions.
3460 : ncerr = nctk_def_dims(ncid, [ &
3461 : nctkdim_t("nkcalc", self%nkcalc), nctkdim_t("max_nbcalc", self%max_nbcalc), &
3462 : nctkdim_t("nsppol", self%nsppol), nctkdim_t("ntemp", self%ntemp), nctkdim_t("natom3", 3 * cryst%natom), &
3463 : nctkdim_t("phmesh_size", self%phmesh_size), &
3464 : nctkdim_t("nqibz", self%nqibz), nctkdim_t("nqbz", self%nqbz)], &
3465 522 : defmode=.True.)
3466 58 : NCF_CHECK(ncerr)
3467 :
3468 58 : if (self%nwr > 0) then
3469 42 : NCF_CHECK(nctk_def_dims(ncid, [nctkdim_t("nwr", self%nwr)]))
3470 : end if
3471 58 : if (dtset%prteliash == 3) then
3472 0 : NCF_CHECK(nctk_def_dims(ncid, [nctkdim_t("a2f_ne", self%a2f_ne)]))
3473 : end if
3474 :
3475 : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: &
3476 : "eph_task", "symsigma", "nbsum", "bsum_start", "bsum_stop", "symdynmat", &
3477 : "ph_intmeth", "eph_intmeth", "qint_method", "eph_transport", &
3478 1044 : "imag_only", "symv1scf", "dvdb_add_lr", "mrta", "ibte_prep", "eph_prtscratew", "eph_ahc_type"])
3479 58 : NCF_CHECK(ncerr)
3480 : ncerr = nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: &
3481 : "eta", "wr_step", "eph_fsewin", "eph_fsmear", "eph_extrael", "eph_fermie", &
3482 580 : "ph_wstep", "ph_smear", "eph_phwinfact"])
3483 58 : NCF_CHECK(ncerr)
3484 :
3485 : ! Define arrays with results.
3486 : ncerr = nctk_def_arrays(ncid, [ &
3487 : nctkarr_t("ngqpt", "int", "three"), &
3488 : nctkarr_t("eph_ngqpt_fine", "int", "three"), &
3489 : nctkarr_t("eph_phrange", "int", "two"), &
3490 : nctkarr_t("eph_phrange_w", "dp", "two"), &
3491 : nctkarr_t("ddb_ngqpt", "int", "three"), &
3492 : nctkarr_t("ph_ngqpt", "int", "three"), &
3493 : nctkarr_t("sigma_ngkpt", "int", "three"), &
3494 : nctkarr_t("sigma_erange", "dp", "two"), &
3495 : !nctkarr_t("frohl_params", "dp", "four"), &
3496 : nctkarr_t("bstart_ks", "int", "nkcalc, nsppol"), &
3497 : nctkarr_t("nbcalc_ks", "int", "nkcalc, nsppol"), &
3498 : nctkarr_t("kcalc", "dp", "three, nkcalc"), &
3499 : nctkarr_t("kcalc2ibz", "int", "nkcalc, six"), &
3500 : nctkarr_t("kTmesh", "dp", "ntemp"), &
3501 : nctkarr_t("mu_e", "dp", "ntemp"), &
3502 : nctkarr_t("qp_done", "int", "nkcalc, nsppol"), &
3503 : nctkarr_t("vals_e0ks", "dp", "two, ntemp, max_nbcalc, nkcalc, nsppol"), &
3504 : nctkarr_t("fan_vals", "dp", "two, ntemp, max_nbcalc, nkcalc, nsppol"), &
3505 : nctkarr_t("E2", "dp", "ntemp"), &
3506 : nctkarr_t("E4_vals", "dp", "two, ntemp, max_nbcalc, nkcalc, nsppol"), &
3507 : nctkarr_t("E4_vals2", "dp", "two, ntemp, max_nbcalc, nkcalc, nsppol"), &
3508 : nctkarr_t("fan_stern_vals", "dp", "two, ntemp, max_nbcalc, nkcalc, nsppol"), &
3509 : nctkarr_t("dvals_de0ks", "dp", "two, ntemp, max_nbcalc, nkcalc, nsppol"), &
3510 : nctkarr_t("dw_vals", "dp", "ntemp, max_nbcalc, nkcalc, nsppol"), &
3511 : nctkarr_t("dw_stern_vals", "dp", "ntemp, max_nbcalc, nkcalc, nsppol"), &
3512 : nctkarr_t("qpoms_enes", "dp", "two, ntemp, max_nbcalc, nkcalc, nsppol"), &
3513 : nctkarr_t("qp_enes", "dp", "two, ntemp, max_nbcalc, nkcalc, nsppol"), &
3514 : nctkarr_t("ze0_vals", "dp", "ntemp, max_nbcalc, nkcalc, nsppol"), &
3515 : nctkarr_t("ks_enes", "dp", "max_nbcalc, nkcalc, nsppol"), &
3516 : nctkarr_t("ks_gaps", "dp", "nkcalc, nsppol"), &
3517 : nctkarr_t("qpoms_gaps", "dp", "ntemp, nkcalc, nsppol"), &
3518 : nctkarr_t("qp_gaps", "dp", "ntemp, nkcalc, nsppol"), &
3519 : nctkarr_t("phmesh", "dp", "phmesh_size"), &
3520 : nctkarr_t("vcar_calc", "dp", "three, max_nbcalc, nkcalc, nsppol") &
3521 1972 : ])
3522 58 : NCF_CHECK(ncerr)
3523 :
3524 58 : if (self%mrta > 0) then
3525 : ncerr = nctk_def_arrays(ncid, [ &
3526 : nctkarr_t("linewidth_mrta", "dp", "ntemp, max_nbcalc, nkcalc, nsppol") &
3527 50 : ])
3528 25 : NCF_CHECK(ncerr)
3529 : end if
3530 :
3531 58 : if (dtset%eph_prtscratew == 1) then
3532 : ncerr = nctk_def_arrays(ncid, [ &
3533 : nctkarr_t("scratew", "dp", "phmesh_size, ntemp, max_nbcalc, two, nkcalc, nsppol") &
3534 2 : ])
3535 1 : NCF_CHECK(ncerr)
3536 : end if
3537 :
3538 : !if (self%frohl_model == 1) then
3539 : ! if (self%imag_only) then
3540 : ! ncerr = nctk_def_arrays(ncid, [ &
3541 : ! nctkarr_t("frohl_deltas_sphcorr", "dp", "two, ntemp, max_nbcalc, natom3, nkcalc, nsppol") &
3542 : ! ])
3543 : ! NCF_CHECK(ncerr)
3544 : ! end if
3545 : !end if
3546 :
3547 58 : if (self%nwr > 0) then
3548 : ! Make room for the spectral function. These arrays get two extra dimensions on file (nkcalc, nsppol).
3549 : ncerr = nctk_def_arrays(ncid, [ &
3550 : nctkarr_t("wrmesh_b", "dp", "nwr, max_nbcalc, nkcalc, nsppol"), &
3551 : nctkarr_t("vals_wr", "dp", "two, nwr, ntemp, max_nbcalc, nkcalc, nsppol"), &
3552 : nctkarr_t("spfunc_wr", "dp", "nwr, ntemp, max_nbcalc, nkcalc, nsppol") &
3553 84 : ])
3554 21 : NCF_CHECK(ncerr)
3555 : end if
3556 :
3557 58 : if (dtset%prteliash /= 0) then
3558 : ncerr = nctk_def_arrays(ncid, [ &
3559 : nctkarr_t("gfw_vals", "dp", "phmesh_size, three, max_nbcalc, nkcalc, nsppol") &
3560 42 : ])
3561 21 : NCF_CHECK(ncerr)
3562 21 : if (dtset%prteliash == 3) then
3563 : ncerr = nctk_def_arrays(ncid, [ &
3564 : nctkarr_t("a2f_emesh", "dp", "a2f_ne"), &
3565 : nctkarr_t("a2few", "dp", "a2f_ne, phmesh_size, max_nbcalc, nkcalc, nsppol") &
3566 0 : ])
3567 0 : NCF_CHECK(ncerr)
3568 : end if
3569 : end if
3570 :
3571 58 : if (dtset%ibte_prep > 0) then
3572 : ! Create groups to store scattering rates (ragged array).
3573 2 : do spin=1,self%nsppol
3574 8 : do ikcalc=1,self%nkcalc
3575 7 : NCF_CHECK(nf90_def_grp(ncid, strcat("srate_k", itoa(ikcalc), "_s", itoa(spin)), grp_ncid))
3576 : end do
3577 : end do
3578 : end if
3579 :
3580 : ! ======================================================
3581 : ! Write data that do not depend on the (kpt, spin) loop.
3582 : ! ======================================================
3583 58 : NCF_CHECK(nctk_set_datamode(ncid))
3584 58 : ii = 0; if (self%imag_only) ii = 1
3585 : ncerr = nctk_write_iscalars(ncid, [character(len=nctk_slen) :: &
3586 : "eph_task", "symsigma", "nbsum", "bsum_start", "bsum_stop", &
3587 : "symdynmat", "ph_intmeth", "eph_intmeth", "qint_method", &
3588 : "eph_transport", "imag_only", "symv1scf", "dvdb_add_lr", "mrta", "ibte_prep", "eph_prtscratew", "eph_ahc_type"], &
3589 : [dtset%eph_task, self%symsigma, self%nbsum, self%bsum_start, self%bsum_stop, &
3590 : dtset%symdynmat, dtset%ph_intmeth, dtset%eph_intmeth, self%qint_method, dtset%eph_transport, ii, &
3591 2030 : dtset%symv1scf, dtset%dvdb_add_lr, self%mrta, dtset%ibte_prep, dtset%eph_prtscratew, dtset%eph_ahc_type])
3592 58 : NCF_CHECK(ncerr)
3593 : ncerr = nctk_write_dpscalars(ncid, [character(len=nctk_slen) :: &
3594 : "eta", "wr_step", "eph_fsewin", "eph_fsmear", "eph_extrael", "eph_fermie", "ph_wstep", "ph_smear", "eph_phwinfact"], &
3595 : [aimag(self%ieta), self%wr_step, dtset%eph_fsewin, dtset%eph_fsmear, dtset%eph_extrael, dtset%eph_fermie, &
3596 1102 : dtset%ph_wstep, dtset%ph_smear, dtset%eph_phwinfact])
3597 58 : NCF_CHECK(ncerr)
3598 :
3599 58 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngqpt"), self%ngqpt))
3600 58 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "eph_ngqpt_fine"), dtset%eph_ngqpt_fine))
3601 58 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ddb_ngqpt"), dtset%ddb_ngqpt))
3602 58 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ph_ngqpt"), dtset%ph_ngqpt))
3603 58 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "sigma_ngkpt"), dtset%sigma_ngkpt))
3604 58 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "sigma_erange"), dtset%sigma_erange))
3605 : !NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "frohl_params"), dtset%frohl_params))
3606 58 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "eph_phrange"), dtset%eph_phrange))
3607 58 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "eph_phrange_w"), dtset%eph_phrange_w))
3608 58 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "bstart_ks"), self%bstart_ks))
3609 58 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "nbcalc_ks"), self%nbcalc_ks))
3610 58 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "kcalc"), self%kcalc))
3611 58 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "kcalc2ibz"), self%kcalc2ibz))
3612 58 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "kTmesh"), self%kTmesh))
3613 58 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "mu_e"), self%mu_e))
3614 58 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "eta"), aimag(self%ieta)))
3615 58 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "phmesh"), self%phmesh))
3616 58 : if (dtset%prteliash == 3) then
3617 0 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "a2f_emesh"), self%a2f_emesh))
3618 : end if
3619 58 : NCF_CHECK(nf90_close(ncid))
3620 : end if ! master
3621 :
3622 58 : call xmpi_barrier(comm)
3623 :
3624 : ! Now reopen the file inside ncwrite_comm to perform parallel-IO (required for k-point parallelism).
3625 58 : if (self%ncwrite_comm%value /= xmpi_comm_null) then
3626 58 : NCF_CHECK(nctk_open_modify(self%ncid, path, self%ncwrite_comm%value))
3627 58 : NCF_CHECK(nctk_set_datamode(self%ncid))
3628 : end if
3629 :
3630 58 : call edos%free()
3631 58 : call cwtime_report(" sigmaph_new: netcdf", cpu_all, wall_all, gflops_all)
3632 :
3633 58 : end subroutine sigmaph_write
3634 : !!***
3635 :
3636 : !----------------------------------------------------------------------
3637 :
3638 : !!****f* m_sigmaph/sigmaph_read
3639 : !! NAME
3640 : !! sigmaph_read
3641 : !!
3642 : !! FUNCTION
3643 : !! Start an (incomplete) sigmaph instance from a netcdf file.
3644 : !! This routine serves only to read some basic dimensions and parameters from the SIGEPH.nc file to
3645 : !!
3646 : !! 1. Verify whether a restart in sigmaph is possible when eph_restart == 1
3647 : !! 2. Use these metadata in the RTA module to prepare the calculation of transport properties.
3648 : !!
3649 : !! INPUTS
3650 : !! path= SIGEPH Filename.
3651 : !! dtset<dataset_type>=All input variables for this dataset.
3652 : !! comm=MPI communicator
3653 : !! msg=Error message if ierr /= 0
3654 : !! ierr = Exit status
3655 : !! [keep_open]=True to keep the Nc file handle open for further reading. Default: False.
3656 : !! [extrael_fermie]: Return the value of (eph_extrael, eph_fermie) read from file.
3657 : !! [sigma_ngkpt] = Value read from the ncfile (used in m_rta)
3658 : !! [sigma_erange] = Value read from the ncfile (used in m_rta)
3659 : !!
3660 : !! SOURCE
3661 :
3662 73 : type(sigmaph_t) function sigmaph_read(path, dtset, comm, msg, ierr, keep_open, &
3663 : extrael_fermie, sigma_ngkpt, sigma_erange) result(new)
3664 :
3665 : !Arguments ------------------------------------
3666 : integer,intent(in) :: comm
3667 : integer,intent(out) :: ierr
3668 : type(dataset_type),intent(in) :: dtset
3669 : character(len=500),intent(out) :: msg
3670 : real(dp), optional, intent(out) :: extrael_fermie(2)
3671 : logical,optional,intent(in) :: keep_open
3672 : integer,optional, intent(out) :: sigma_ngkpt(3)
3673 : real(dp),optional,intent(out) :: sigma_erange(2)
3674 :
3675 : !Local variables ------------------------------
3676 : !scalars
3677 : integer :: imag_only, eph_task, symdynmat, ph_intmeth, eph_intmeth, eph_transport
3678 : integer :: ncid !, varid !, ncerr
3679 : real(dp) :: eph_fermie, eph_fsewin, ph_wstep, ph_smear, eta, eph_extrael, eph_fsmear, cpu, wall, gflops
3680 : character(len=fnlen) :: path
3681 : !arrays
3682 : integer :: eph_ngqpt_fine(3), ddb_ngqpt(3), ph_ngqpt(3), my_sigma_ngkpt(3)
3683 : real(dp) :: my_sigma_erange(2)
3684 : ! *************************************************************************
3685 :
3686 73 : call cwtime(cpu, wall, gflops, "start")
3687 :
3688 73 : msg = ""; ierr = 0
3689 73 : if (.not. file_exists(path)) then
3690 58 : msg = sjoin("Cannot find file", path); ierr = 1; return
3691 : end if
3692 :
3693 : ! Open netcdf file
3694 15 : NCF_CHECK(nctk_open_read(ncid, path, comm))
3695 :
3696 : !TODO?
3697 : !NCF_CHECK(cryst%ncread(ncid))
3698 : !NCF_CHECK(ebands_ncread(ebands, ncid))
3699 :
3700 : ! Read sigma_eph dimensions.
3701 15 : NCF_CHECK(nctk_get_dim(ncid, "nkcalc", new%nkcalc))
3702 15 : NCF_CHECK(nctk_get_dim(ncid, "max_nbcalc", new%max_nbcalc))
3703 15 : NCF_CHECK(nctk_get_dim(ncid, "nsppol", new%nsppol))
3704 15 : NCF_CHECK(nctk_get_dim(ncid, "ntemp", new%ntemp))
3705 15 : NCF_CHECK(nctk_get_dim(ncid, "nqibz", new%nqibz))
3706 15 : NCF_CHECK(nctk_get_dim(ncid, "nqbz", new%nqbz))
3707 : !NCF_CHECK(nctk_get_dim(ncid, "nwr", new%nwr))
3708 : !NCF_CHECK(nctk_get_dim(ncid, "phmesh_size", new%phmesh_size))
3709 :
3710 : ! ======================================================
3711 : ! Read data that does not depend on the (kpt, spin) loop.
3712 : ! ======================================================
3713 15 : NCF_CHECK(nf90_get_var(ncid, vid("symsigma"), new%symsigma))
3714 15 : NCF_CHECK(nf90_get_var(ncid, vid("nbsum"), new%nbsum))
3715 15 : NCF_CHECK(nf90_get_var(ncid, vid("bsum_start"), new%bsum_start))
3716 15 : NCF_CHECK(nf90_get_var(ncid, vid("bsum_stop"), new%bsum_stop))
3717 :
3718 15 : NCF_CHECK(nf90_get_var(ncid, vid("qint_method"), new%qint_method))
3719 : !NCF_CHECK(nf90_get_var(ncid, vid("frohl_model"), new%frohl_model))
3720 15 : NCF_CHECK(nf90_get_var(ncid, vid("imag_only"), imag_only))
3721 15 : new%imag_only = (imag_only == 1)
3722 15 : NCF_CHECK(nf90_get_var(ncid, vid("mrta"), new%mrta))
3723 :
3724 45 : ABI_MALLOC(new%kcalc, (3, new%nkcalc))
3725 60 : ABI_MALLOC(new%bstart_ks, (new%nkcalc, new%nsppol))
3726 45 : ABI_MALLOC(new%bstop_ks, (new%nkcalc, new%nsppol))
3727 45 : ABI_MALLOC(new%nbcalc_ks, (new%nkcalc, new%nsppol))
3728 45 : ABI_MALLOC(new%mu_e, (new%ntemp))
3729 30 : ABI_MALLOC(new%kTmesh, (new%ntemp))
3730 45 : ABI_MALLOC(new%kcalc2ibz, (new%nkcalc, 6))
3731 :
3732 15 : NCF_CHECK(nf90_get_var(ncid, vid("ngqpt"), new%ngqpt))
3733 15 : NCF_CHECK(nf90_get_var(ncid, vid("bstart_ks"), new%bstart_ks))
3734 15 : NCF_CHECK(nf90_get_var(ncid, vid("nbcalc_ks"), new%nbcalc_ks))
3735 108 : new%bstop_ks = new%bstart_ks + new%nbcalc_ks - 1
3736 :
3737 15 : NCF_CHECK(nf90_get_var(ncid, vid("kcalc"), new%kcalc))
3738 15 : NCF_CHECK(nf90_get_var(ncid, vid("kcalc2ibz"), new%kcalc2ibz))
3739 15 : NCF_CHECK(nf90_get_var(ncid, vid("kTmesh"), new%kTmesh))
3740 15 : NCF_CHECK(nf90_get_var(ncid, vid("wr_step"), new%wr_step))
3741 15 : NCF_CHECK(nf90_get_var(ncid, vid("mu_e"), new%mu_e))
3742 15 : NCF_CHECK(nf90_get_var(ncid, vid("eta"), eta))
3743 15 : new%ieta = j_dpc * eta
3744 :
3745 : ! Read the done array used to implement restart capabilities.
3746 138 : ABI_ICALLOC(new%qp_done, (new%nkcalc, new%nsppol))
3747 15 : NCF_CHECK(nf90_get_var(ncid, vid("qp_done"), new%qp_done))
3748 :
3749 : ! ============================================================
3750 : ! Read and check consistency against dtset
3751 : ! ============================================================
3752 15 : NCF_CHECK(nf90_get_var(ncid, vid("eph_fsewin"), eph_fsewin))
3753 15 : NCF_CHECK(nf90_get_var(ncid, vid("eph_fsmear"), eph_fsmear))
3754 15 : NCF_CHECK(nf90_get_var(ncid, vid("eph_extrael"), eph_extrael))
3755 15 : NCF_CHECK(nf90_get_var(ncid, vid("eph_fermie"), eph_fermie))
3756 15 : NCF_CHECK(nf90_get_var(ncid, vid("ph_wstep"), ph_wstep))
3757 15 : NCF_CHECK(nf90_get_var(ncid, vid("ph_smear"), ph_smear))
3758 15 : ABI_CHECK(eph_fsewin == dtset%eph_fsewin, "netcdf eph_fsewin != input file")
3759 15 : ABI_CHECK(eph_fsmear == dtset%eph_fsmear, "netcdf eph_fsmear != input file")
3760 15 : ABI_CHECK(ph_wstep == dtset%ph_wstep, "netcdf ph_wstep != input file")
3761 15 : ABI_CHECK(ph_smear == dtset%ph_smear, "netcdf ph_smear != input file")
3762 :
3763 15 : if (present(extrael_fermie)) then
3764 45 : extrael_fermie = [eph_extrael, eph_fermie]
3765 : else
3766 0 : ABI_CHECK_DEQ(eph_extrael, dtset%eph_extrael, "netcdf eph_extrael != input file")
3767 0 : ABI_CHECK_DEQ(eph_fermie, dtset%eph_fermie, "netcdf eph_feremie != input file")
3768 : end if
3769 :
3770 15 : NCF_CHECK(nf90_get_var(ncid, vid("eph_task"), eph_task))
3771 15 : NCF_CHECK(nf90_get_var(ncid, vid("symdynmat"), symdynmat))
3772 15 : NCF_CHECK(nf90_get_var(ncid, vid("ph_intmeth"), ph_intmeth))
3773 15 : NCF_CHECK(nf90_get_var(ncid, vid("eph_intmeth"), eph_intmeth))
3774 15 : NCF_CHECK(nf90_get_var(ncid, vid("eph_transport"), eph_transport))
3775 :
3776 15 : if (dtset%eph_task==-4 .or. dtset%eph_task==4) then
3777 12 : ABI_CHECK_IEQ(symdynmat, dtset%symdynmat, "netcdf symdynmat != input file")
3778 12 : ABI_CHECK_IEQ(ph_intmeth, dtset%ph_intmeth, "netcdf ph_intmeth != input file")
3779 12 : ABI_CHECK_IEQ(eph_intmeth, dtset%eph_intmeth, "netcdf eph_intmeth != input file")
3780 12 : ABI_CHECK_IEQ(eph_transport, dtset%eph_transport, "netcdf eph_transport != input file")
3781 : endif
3782 :
3783 : !NCF_CHECK(nf90_get_var(ncid, vid("frohl_params"), frohl_params))
3784 15 : NCF_CHECK(nf90_get_var(ncid, vid("eph_ngqpt_fine"), eph_ngqpt_fine))
3785 15 : NCF_CHECK(nf90_get_var(ncid, vid("ddb_ngqpt"), ddb_ngqpt))
3786 15 : NCF_CHECK(nf90_get_var(ncid, vid("ph_ngqpt"), ph_ngqpt))
3787 15 : NCF_CHECK(nf90_get_var(ncid, vid("sigma_ngkpt"), my_sigma_ngkpt))
3788 15 : if (present(sigma_ngkpt)) then
3789 15 : sigma_ngkpt = my_sigma_ngkpt
3790 : else
3791 0 : ABI_CHECK(all(dtset%sigma_ngkpt == my_sigma_ngkpt), "netcdf sigma_ngkpt != input file")
3792 : end if
3793 :
3794 15 : NCF_CHECK(nf90_get_var(ncid, vid("sigma_erange"), my_sigma_erange))
3795 15 : if (present(sigma_erange)) then
3796 15 : sigma_erange = my_sigma_erange
3797 : else
3798 0 : ABI_CHECK(all(dtset%sigma_erange == my_sigma_erange), "netcdf sigma_erange != input file")
3799 : end if
3800 :
3801 15 : if (present(keep_open)) then
3802 15 : new%ncid = ncid
3803 : else
3804 0 : NCF_CHECK(nf90_close(ncid))
3805 : ! so that the structure is properly freed
3806 0 : new%ncid = nctk_noid
3807 : end if
3808 :
3809 60 : ABI_CHECK(all(dtset%eph_ngqpt_fine == eph_ngqpt_fine),"netcdf eph_ngqpt_fine != input file")
3810 60 : ABI_CHECK(all(dtset%ddb_ngqpt == ddb_ngqpt), "netcdf ddb_ngqpt != input file")
3811 60 : ABI_CHECK(all(dtset%ph_ngqpt == ph_ngqpt), "netcdf ph_ngqpt != input file")
3812 : !ABI_CHECK(all(abs(dtset%frohl_params - frohl_params) < tol6), "netcdf frohl_params != input file")
3813 :
3814 88 : call cwtime_report(" sigmaph_read", cpu, wall, gflops)
3815 :
3816 : contains
3817 495 : integer function vid(var_name)
3818 : character(len=*),intent(in) :: var_name
3819 495 : vid = nctk_idname(ncid, var_name)
3820 : end function vid
3821 :
3822 : end function sigmaph_read
3823 : !!***
3824 :
3825 : !----------------------------------------------------------------------
3826 :
3827 : !!****f* m_sigmaph/sigmaph_get_ebands
3828 : !! NAME
3829 : !! sigmaph_get_ebands
3830 : !!
3831 : !! FUNCTION
3832 : !! Read quantities from the sigmaph to an ebands_t structure and return mapping
3833 : !!
3834 : !! INPUTS
3835 : !! ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...)
3836 : !! opt=integer option selecting what to read on the ebands object. 1-only mapping, 10+n-read n temperature linewidths
3837 : !!
3838 : !! SOURCE
3839 :
3840 15 : type(ebands_t) function sigmaph_get_ebands(self, cryst, ebands, brange, kcalc2ebands, linewidths, velocity, comm) result(new)
3841 :
3842 : !Arguments -----------------------------------------------
3843 : integer,intent(in) :: comm
3844 : class(sigmaph_t),intent(in) :: self
3845 : type(crystal_t),intent(in) :: cryst
3846 : type(ebands_t),intent(in) :: ebands
3847 : integer,intent(in) :: brange(2)
3848 : integer, allocatable, intent(out) :: kcalc2ebands(:,:)
3849 : real(dp), allocatable, intent(out) :: linewidths(:,:,:,:,:), velocity(:,:,:,:)
3850 :
3851 : !Local variables -----------------------------------------
3852 : !scalars
3853 : integer,parameter :: master = 0
3854 : integer :: spin, ikpt, ikcalc, iband, itemp, nsppol, nkpt, band_ks, bstart_ks, nbcalc_ks, mband
3855 : integer :: bmin, bmax, my_rank, ierr, ncerr
3856 15 : type(krank_t) :: krank
3857 : character(len=5000) :: msg
3858 : !arrays
3859 : !integer,allocatable :: kcalc2ebands(:,:)
3860 : ! *************************************************************************
3861 :
3862 30 : my_rank = xmpi_comm_rank(comm)
3863 :
3864 : ! copy useful dimensions
3865 15 : nsppol = self%nsppol; nkpt = ebands%nkpt
3866 :
3867 : ! Map input ebands kpoints to kcalc k-points stored in sigmaph file.
3868 45 : ABI_MALLOC(kcalc2ebands, (6, self%nkcalc))
3869 :
3870 15 : call krank%from_kptrlatt(ebands%nkpt, ebands%kptns, ebands%kptrlatt, compute_invrank=.False.)
3871 :
3872 15 : if (kpts_map("symrec", ebands%kptopt, cryst, krank, self%nkcalc, self%kcalc, kcalc2ebands) /= 0) then
3873 : write(msg, '(3a)' ) &
3874 0 : "Error mapping input ebands%kptns to sigmaph kcalc",ch10,&
3875 0 : "the k-point could not be generated from a symmetrical one"
3876 0 : ABI_ERROR(msg)
3877 : end if
3878 15 : call krank%free()
3879 :
3880 : ! store mapping to return
3881 : !if (present(kcalc2ebands)) then
3882 : ! ABI_MALLOC(kcalc2ebands, (self%nkcalc))
3883 : ! kcalc2ebands(:) = indkk(1, :)
3884 : !end if
3885 :
3886 : ! Allocate using only the relevant bands for transport
3887 : ! including valence states to allow to compute different doping
3888 : ! MG: TODO: Do we really need this!
3889 93 : mband = maxval(self%bstop_ks)
3890 15 : new = ebands%chop(1, mband)
3891 : !mband = ebands%mband
3892 : !call ebands_copy(ebands, new)
3893 : !bmin = 1; bmax = mband
3894 15 : bmin = brange(1); bmax = brange(2)
3895 :
3896 : ! Read linewidths from sigmaph file.
3897 : ! Use global array (mband, nkpt, nsppol) but keep in mind that results in SIGPEPH are packed
3898 : ! so that only the relevant k-points are stored on file.
3899 :
3900 20203 : ABI_CALLOC(velocity, (3, bmin:bmax, nkpt, nsppol))
3901 61931 : ABI_CALLOC(linewidths, (self%ntemp, bmin:bmax, nkpt, nsppol, 2))
3902 :
3903 15 : if (my_rank == master) then
3904 30 : do spin=1,nsppol
3905 93 : do ikcalc=1,self%nkcalc
3906 63 : bstart_ks = self%bstart_ks(ikcalc, spin)
3907 63 : nbcalc_ks = self%nbcalc_ks(ikcalc, spin)
3908 163 : do iband=1,nbcalc_ks
3909 : ! band index in global array.
3910 85 : band_ks = iband + bstart_ks - 1
3911 : ! kcalc --> ibz index
3912 85 : ikpt = kcalc2ebands(1, ikcalc)
3913 :
3914 375 : do itemp=1,self%ntemp
3915 : ! Read SERTA lifetimes
3916 : ncerr = nf90_get_var(self%ncid, nctk_idname(self%ncid, "vals_e0ks"), &
3917 1740 : linewidths(itemp, band_ks, ikpt, spin, 1), start=[2, itemp, iband, ikcalc, spin])
3918 290 : NCF_CHECK(ncerr)
3919 :
3920 : ! Read MRTA lifetimes
3921 : ! TODO: This should be called half_linewidth_mrta since
3922 : ! in m_rta we multiply by two to get tau = 1/(2 Imag(sigma))
3923 375 : if (self%mrta > 0) then
3924 : ncerr = nf90_get_var(self%ncid, nctk_idname(self%ncid, "linewidth_mrta"), &
3925 1350 : linewidths(itemp, band_ks, ikpt, spin, 2), start=[itemp, iband, ikcalc, spin])
3926 270 : NCF_CHECK(ncerr)
3927 : end if
3928 : end do
3929 :
3930 : ! Read band velocities computed only of the kcalc k-points.
3931 : ncerr = nf90_get_var(self%ncid, nctk_idname(self%ncid, "vcar_calc"), &
3932 425 : velocity(:, band_ks, ikpt, spin), start=[1, iband, ikcalc, spin])
3933 148 : NCF_CHECK(ncerr)
3934 : end do
3935 : end do
3936 : end do
3937 : end if
3938 :
3939 : !ABI_FREE(indkk)
3940 :
3941 : ! This so that output linewidths are always positive independently
3942 : ! of the kind of self-energy used (retarded or advanced)
3943 61841 : linewidths = abs(linewidths)
3944 :
3945 15 : call xmpi_bcast(linewidths, master, comm, ierr)
3946 15 : call xmpi_bcast(velocity, master, comm, ierr)
3947 :
3948 30 : end function sigmaph_get_ebands
3949 : !!***
3950 :
3951 : !----------------------------------------------------------------------
3952 :
3953 : !!****f* m_sigmaph/sigmaph_compare
3954 : !! NAME
3955 : !! sigmaph_compare
3956 : !!
3957 : !! FUNCTION
3958 : !! Compare the headers of two sigmaph_t instances
3959 : !!
3960 : !! SOURCE
3961 :
3962 0 : subroutine sigmaph_compare(self, other)
3963 :
3964 : !Arguments ------------------------------------
3965 : class(sigmaph_t),intent(in) :: self, other
3966 :
3967 : !Local variables-------------------------------
3968 : integer :: ierr
3969 : ! *************************************************************************
3970 0 : ierr = 0
3971 :
3972 0 : ABI_CHECK_NOSTOP(self%nkcalc == other%nkcalc, "Difference found in nkcalc.", ierr)
3973 0 : ABI_CHECK_NOSTOP(self%max_nbcalc == other%max_nbcalc, "Difference found in max_nbcalc.", ierr)
3974 0 : ABI_CHECK_NOSTOP(self%nsppol == other%nsppol, "Difference found in nsppol.", ierr)
3975 0 : ABI_CHECK_NOSTOP(self%ntemp == other%ntemp, "Difference found in ntemp.", ierr)
3976 0 : ABI_CHECK_NOSTOP(self%nqibz == other%nqibz, "Difference found in nqibz.", ierr)
3977 0 : ABI_CHECK_NOSTOP(self%nqbz == other%nqbz, "Difference found in nqbz.", ierr)
3978 :
3979 : ! ======================================================
3980 : ! Read data that does not depend on the (kpt, spin) loop.
3981 : ! ======================================================
3982 0 : ABI_CHECK_NOSTOP(self%symsigma == other%symsigma, "Different value found for symsigma.", ierr)
3983 0 : ABI_CHECK_NOSTOP(self%nbsum == other%nbsum, "Different value found for nbsum.", ierr)
3984 0 : ABI_CHECK_NOSTOP(self%bsum_start == other%bsum_start, "Different value found for bsum_start.", ierr)
3985 0 : ABI_CHECK_NOSTOP(self%bsum_stop == other%bsum_stop, "Different value found for bsum_stop.", ierr)
3986 0 : ABI_CHECK_NOSTOP(self%qint_method == other%qint_method, "Different value found for qint_method", ierr)
3987 : !ABI_CHECK_NOSTOP(self%frohl_model == other%frohl_model, "Different value found for frohl_model.", ierr)
3988 0 : ABI_CHECK_NOSTOP(self%imag_only .eqv. other%imag_only, "Difference found in imag_only", ierr)
3989 0 : ABI_CHECK_NOSTOP(self%wr_step == other%wr_step, "Different value found for wr_step", ierr)
3990 0 : ABI_CHECK_NOSTOP(self%ieta == other%ieta, "Different value found for zcut.", ierr)
3991 :
3992 0 : ABI_CHECK_NOSTOP(all(self%ngqpt == other%ngqpt), "Different value found for ngqpt", ierr)
3993 0 : ABI_CHECK_NOSTOP(all(self%bstart_ks == other%bstart_ks), "Different value found for bstart_ks", ierr)
3994 0 : ABI_CHECK_NOSTOP(all(self%nbcalc_ks == other%nbcalc_ks), "Different value found for bstop_ks", ierr)
3995 0 : ABI_CHECK_NOSTOP(all(self%kcalc == other%kcalc), "Different value found for kcalc", ierr)
3996 0 : ABI_CHECK_NOSTOP(all(self%kcalc2ibz == other%kcalc2ibz), "Different value found for kcalc2ibz", ierr)
3997 0 : ABI_CHECK_NOSTOP(all(self%kTmesh == other%kTmesh), "Different value found for kTmesh", ierr)
3998 0 : ABI_CHECK_NOSTOP(all(self%mu_e == other%mu_e), "Different value found for mu_e", ierr)
3999 :
4000 0 : ABI_CHECK(ierr == 0, "Fatal error in sigmaph_compare, see previous messages!")
4001 :
4002 0 : end subroutine sigmaph_compare
4003 : !!***
4004 :
4005 : !!****f* m_sigmaph/sigmaph_free
4006 : !! NAME
4007 : !! sigmaph_free
4008 : !!
4009 : !! FUNCTION
4010 : !! Deallocate dynamic memory
4011 : !!
4012 : !! SOURCE
4013 :
4014 131 : subroutine sigmaph_free(self)
4015 :
4016 : !Arguments ------------------------------------
4017 : class(sigmaph_t),intent(inout) :: self
4018 : ! *************************************************************************
4019 :
4020 : ! integer
4021 131 : ABI_SFREE(self%bstart_ks)
4022 131 : ABI_SFREE(self%bstop_ks)
4023 131 : ABI_SFREE(self%nbcalc_ks)
4024 131 : ABI_SFREE(self%kcalc2ibz)
4025 131 : ABI_SFREE(self%my_ikcalc)
4026 131 : ABI_SFREE(self%my_spins)
4027 131 : ABI_SFREE(self%myq2ibz_k)
4028 131 : ABI_SFREE(self%itreat_qibz)
4029 131 : ABI_SFREE(self%my_pinfo)
4030 131 : ABI_SFREE(self%pert_table)
4031 131 : ABI_SFREE(self%phmodes_skip)
4032 131 : ABI_SFREE(self%ind_qbz2ibz)
4033 131 : ABI_SFREE(self%indkk_kq)
4034 131 : ABI_SFREE(self%ind_q2dvdb_k)
4035 131 : ABI_SFREE(self%ind_ibzk2ibz)
4036 131 : ABI_SFREE(self%qibz2dvdb)
4037 131 : ABI_SFREE(self%lgk_sym2glob)
4038 131 : ABI_SFREE(self%nbsum_rank)
4039 :
4040 : ! real
4041 131 : ABI_SFREE(self%kcalc)
4042 131 : ABI_SFREE(self%kTmesh)
4043 131 : ABI_SFREE(self%mu_e)
4044 131 : ABI_SFREE(self%e0vals)
4045 131 : ABI_SFREE(self%vcar_calc)
4046 131 : ABI_SFREE(self%linewidth_mrta)
4047 131 : ABI_SFREE(self%cweights)
4048 131 : ABI_SFREE(self%deltaw_pm)
4049 131 : ABI_SFREE(self%wrmesh_b)
4050 131 : ABI_SFREE(self%qvers_cart)
4051 131 : ABI_SFREE(self%angwgth)
4052 131 : ABI_SFREE(self%frohl_deltas_sphcorr)
4053 131 : ABI_SFREE(self%qp_done)
4054 131 : ABI_SFREE(self%qbz)
4055 131 : ABI_SFREE(self%qibz)
4056 131 : ABI_SFREE(self%wtq)
4057 131 : ABI_SFREE(self%qibz_k)
4058 131 : ABI_SFREE(self%wtq_k)
4059 131 : ABI_SFREE(self%srate)
4060 131 : ABI_SFREE(self%phmesh)
4061 131 : ABI_SFREE(self%gf_nnuq)
4062 131 : ABI_SFREE(self%scratew)
4063 131 : ABI_SFREE(self%E2)
4064 :
4065 : ! complex
4066 131 : ABI_SFREE(self%vals_e0ks)
4067 131 : ABI_SFREE(self%fan_vals)
4068 131 : ABI_SFREE(self%E4_vals)
4069 131 : ABI_SFREE(self%E4_vals2)
4070 131 : ABI_SFREE(self%fan_stern_vals)
4071 131 : ABI_SFREE(self%dvals_de0ks)
4072 131 : ABI_SFREE(self%dw_vals)
4073 131 : ABI_SFREE(self%dw_stern_vals)
4074 131 : ABI_SFREE(self%vals_wr)
4075 131 : ABI_SFREE(self%gfw_vals)
4076 131 : ABI_SFREE(self%a2f_emesh)
4077 131 : ABI_SFREE(self%a2few)
4078 :
4079 : ! datatypes.
4080 131 : if (allocated(self%degtab)) then
4081 56 : call degtab_array_free(self%degtab)
4082 228 : ABI_FREE(self%degtab)
4083 : end if
4084 :
4085 131 : call self%ephwg%free()
4086 131 : call self%eph_doublegrid%free()
4087 :
4088 : ! Deallocate MPI communicators
4089 131 : call self%pert_comm%free(); call self%qpt_comm%free(); call self%bsum_comm%free()
4090 131 : call self%qb_comm%free(); call self%kcalc_comm%free(); call self%spin_comm%free()
4091 131 : call self%pqb_comm%free(); call self%ncwrite_comm%free()
4092 :
4093 : ! Close netcdf file.
4094 131 : if (self%ncid /= nctk_noid) then
4095 60 : NCF_CHECK(nf90_close(self%ncid))
4096 : end if
4097 :
4098 131 : end subroutine sigmaph_free
4099 : !!***
4100 :
4101 : !!****f* m_sigmaph/sigmaph_setup_kcalc
4102 : !! NAME
4103 : !! sigmaph_setup_kcalc
4104 : !!
4105 : !! FUNCTION
4106 : !! Prepare calculations of self-energy matrix elements for ikcalc index.
4107 : !!
4108 : !! INPUTS
4109 : !! dtset<dataset_type>=All input variables for this dataset.
4110 : !! cryst<crystal_t> = Crystal structure.
4111 : !! dvdb<dbdb_type>=Database with the DFPT SCF potentials.
4112 : !! ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...)
4113 : !! ikcalc=Index of the k-point to compute.
4114 : !! prtvol= Verbosity level
4115 : !! comm= MPI communicator
4116 : !!
4117 : !! SOURCE
4118 :
4119 182 : subroutine sigmaph_setup_kcalc(self, dtset, cryst, ebands, ikcalc, prtvol, comm)
4120 :
4121 : !Arguments ------------------------------------
4122 : integer,intent(in) :: ikcalc, prtvol, comm
4123 : type(dataset_type),intent(in) :: dtset
4124 : type(crystal_t),intent(in) :: cryst
4125 : class(sigmaph_t),target,intent(inout) :: self
4126 : type(ebands_t),intent(in) :: ebands
4127 :
4128 : !Local variables-------------------------------
4129 : integer,parameter :: master = 0
4130 : integer :: spin, my_rank, iq_ibz, nprocs, qptopt, kptopt !, nbcalc_ks !, bstart_ks
4131 : integer :: ikpt, ibz_k, isym_k, itim_k !isym_lgk,
4132 : real(dp) :: cpu, wall, gflops
4133 : character(len=5000) :: msg
4134 : logical :: compute_lgk
4135 182 : type(lgroup_t),target :: lgk
4136 : type(lgroup_t),pointer :: lgk_ptr
4137 182 : type(krank_t) :: krank, qrank
4138 : !arrays
4139 : integer :: qptrlatt(3,3)
4140 182 : integer,allocatable :: iqk2dvdb(:,:)
4141 : real(dp) :: kk(3)
4142 182 : real(dp),allocatable :: kq_list(:,:)
4143 : ! *************************************************************************
4144 :
4145 182 : ABI_SFREE(self%qibz_k)
4146 182 : ABI_SFREE(self%wtq_k)
4147 :
4148 182 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
4149 728 : kk = self%kcalc(:, ikcalc)
4150 :
4151 182 : call wrtout(std_out, sjoin(ch10, repeat("=", 92)))
4152 182 : msg = sjoin("[", itoa(ikcalc), "/", itoa(self%nkcalc), "]")
4153 182 : call wrtout(std_out, sjoin(" Computing self-energy matrix elements for k-point:", ktoa(kk), msg))
4154 : ! TODO Integrate with spin parallelism.
4155 182 : spin = 1
4156 182 : write(msg, "(3(a, i0))")" Treating ", self%nbcalc_ks(ikcalc, spin), " band(s) in Sigma_nk between: ", &
4157 364 : self%bstart_ks(ikcalc, spin)," and: ", self%bstart_ks(ikcalc, spin) + self%nbcalc_ks(ikcalc, spin) - 1
4158 182 : call wrtout(std_out, msg)
4159 182 : write(msg, "(2(a,i0))")"P Allocating and summing bands from my_bsum_start: ", self%my_bsum_start, &
4160 364 : " up to my_bsum_stop: ", self%my_bsum_stop
4161 182 : call wrtout(std_out, msg)
4162 182 : if (.not. self%imag_only .and. dtset%eph_stern /= 0) then
4163 34 : if (dtset%eph_stern == 1) call wrtout(std_out, " Sternheimer method activated with cache for u1_nk")
4164 34 : if (dtset%eph_stern == -1) call wrtout(std_out, " Sternheimer method activated WITHOUT cache for u1_nk!")
4165 : end if
4166 :
4167 : ! Prepare weights for BZ(k) integration
4168 182 : if (self%qint_method > 0) then
4169 81 : if (self%use_doublegrid) then
4170 19 : call self%ephwg%double_grid_setup_kpoint(self%eph_doublegrid, kk, prtvol, comm)
4171 : else
4172 62 : call self%ephwg%setup_kpoint(kk, prtvol, comm, skip_mapping=.true.)
4173 : end if
4174 81 : call self%ephwg%report_stats()
4175 : endif
4176 :
4177 182 : call cwtime(cpu, wall, gflops, "start")
4178 :
4179 182 : if (self%symsigma == 0) then
4180 : ! Do not use symmetries in BZ sum_q --> nqibz_k == nqbz
4181 10 : self%nqibz_k = self%nqbz
4182 30 : ABI_MALLOC(self%qibz_k, (3, self%nqibz_k))
4183 30 : ABI_MALLOC(self%wtq_k, (self%nqibz_k))
4184 420 : self%qibz_k = self%qbz; self%wtq_k = one / self%nqbz
4185 10 : call wrtout(std_out, sjoin(" symsigma = 0 --> Integration done over full BZ with nqbz:", itoa(self%nqibz_k)))
4186 :
4187 : ! Store little group symmetries (well, just 1)
4188 10 : self%lgk_nsym = 1
4189 30 : ABI_REMALLOC(self%lgk_sym2glob, (2, self%lgk_nsym))
4190 30 : self%lgk_sym2glob(:, 1) = [1, 1]
4191 :
4192 172 : else if (abs(self%symsigma) == 1) then
4193 : ! Use the symmetries of the little group of the k-point
4194 : ! Pack points in *shells* to minimise cache misses.
4195 172 : compute_lgk = .not. (self%qint_method > 0 .and. .not. self%use_doublegrid)
4196 : if (compute_lgk) then
4197 110 : call lgk%init(cryst, kk, self%timrev, self%nqbz, self%qbz, self%nqibz, self%qibz, comm)
4198 110 : lgk_ptr => lgk
4199 : else
4200 : ! Avoid this call to lgroup new. Use lgk already computed in self%ephwg
4201 62 : lgk_ptr => self%ephwg%lgk
4202 : end if
4203 :
4204 : ! Store little group symmetries.
4205 172 : self%lgk_nsym = lgk_ptr%nsym_lg
4206 516 : ABI_REMALLOC(self%lgk_sym2glob, (2, self%lgk_nsym))
4207 37676 : self%lgk_sym2glob = lgk_ptr%lgsym2glob
4208 :
4209 : call wrtout(std_out, sjoin(" Number of operations in little group(k):", itoa(lgk_ptr%nsym_lg), &
4210 172 : "(including time-reversal symmetry)"))
4211 172 : call wrtout(std_out, sjoin(" Number of q-points in the IBZ(k):", itoa(lgk_ptr%nibz)))
4212 :
4213 200 : if (dtset%prtvol > 0) call lgk_ptr%print([std_out], prtvol=dtset%prtvol)
4214 :
4215 : ! TODO: Pointers instead of copies to save space?
4216 172 : self%nqibz_k = lgk_ptr%nibz
4217 516 : ABI_MALLOC(self%qibz_k, (3, self%nqibz_k))
4218 516 : ABI_MALLOC(self%wtq_k, (self%nqibz_k))
4219 1338236 : self%qibz_k = lgk_ptr%ibz; self%wtq_k = lgk_ptr%weights
4220 : !if (compute_lgk) call lgk%free()
4221 : else
4222 0 : ABI_ERROR(sjoin("Wrong symsigma:", itoa(self%symsigma)))
4223 : end if
4224 :
4225 182 : call cwtime_report(" lgroup_symsigma", cpu, wall, gflops)
4226 :
4227 : ! TODO: Cleanup
4228 :
4229 182 : if (self%symsigma == 0) then
4230 : ! Find correspondence IBZ_k --> IBZ
4231 30 : ABI_MALLOC(iqk2dvdb, (6, self%nqibz_k))
4232 :
4233 : ! Assume qptopt == kptopt unless value is specified in input
4234 10 : qptopt = ebands%kptopt; if (dtset%qptopt /= 0) qptopt = dtset%qptopt
4235 10 : qptrlatt = 0; qptrlatt(1,1) = self%ngqpt(1); qptrlatt(2,2) = self%ngqpt(2); qptrlatt(3,3) = self%ngqpt(3)
4236 10 : call qrank%from_kptrlatt(self%nqibz, self%qibz, qptrlatt, compute_invrank=.False.)
4237 :
4238 10 : if (kpts_map("symrec", qptopt, cryst, qrank, self%nqibz_k, self%qibz_k, iqk2dvdb) /= 0) then
4239 : write(msg, '(3a)' )&
4240 0 : "At least one of the q points in the IBZ_k could not be generated from one in the IBZ.", ch10,&
4241 0 : "Action: check your DVDB file and use eph_task to interpolate the potentials on a denser q-mesh."
4242 0 : ABI_ERROR(msg)
4243 : end if
4244 10 : call qrank%free()
4245 :
4246 30 : ABI_REMALLOC(self%ind_ibzk2ibz, (6, self%nqibz_k))
4247 90 : do iq_ibz=1,self%nqibz_k
4248 570 : self%ind_ibzk2ibz(:, iq_ibz) = iqk2dvdb(:, iq_ibz)
4249 : end do
4250 10 : ABI_FREE(iqk2dvdb)
4251 :
4252 172 : else if (abs(self%symsigma) == 1) then
4253 :
4254 : ! IBZ_k --> BZ --> IBZ
4255 516 : ABI_REMALLOC(self%ind_ibzk2ibz, (6, self%nqibz_k))
4256 936576 : self%ind_ibzk2ibz = 0
4257 480572 : do ikpt=1,self%nqbz
4258 480400 : ibz_k = lgk_ptr%bz2ibz_smap(1,ikpt)
4259 : !isym_lgk = lgk_ptr%bz2ibz_smap(2,ikpt)
4260 : !isym_k = lgk_ptr%lgsym2glob(1,isym_lgk)
4261 : !itim_k = lgk_ptr%lgsym2glob(2,isym_lgk)
4262 480400 : isym_k = lgk_ptr%bz2ibz_smap(2,ikpt)
4263 480400 : itim_k = lgk_ptr%bz2ibz_smap(3,ikpt)
4264 : ! I assume that isym=1 and itim_k=0 is identity but still verify the kpoint
4265 1664913 : if (isym_k /= 1 .or. itim_k /= 1 .or. any(lgk_ptr%bz2ibz_smap(4:,ikpt) /= 0)) cycle
4266 : ! check IBZ_k --> BZ
4267 535088 : ABI_CHECK(sum(abs(self%qbz(:,ikpt) - self%qibz_k(:,ibz_k))) < tol8, 'Wrong mapping')
4268 : ! IBZ_k --> IBZ
4269 : !self%ind_ibzk2ibz(:, ibz_k) = self%ind_qbz2ibz(:,ikpt)
4270 133772 : self%ind_ibzk2ibz(1, ibz_k) = self%ind_qbz2ibz(1, ikpt)
4271 133772 : self%ind_ibzk2ibz(2, ibz_k) = self%ind_qbz2ibz(2, ikpt)
4272 133772 : self%ind_ibzk2ibz(6, ibz_k) = self%ind_qbz2ibz(3, ikpt)
4273 881888 : self%ind_ibzk2ibz(3:5, ibz_k) = self%ind_qbz2ibz(4:6, ikpt)
4274 : end do
4275 133944 : do ikpt=1,self%nqibz_k
4276 133944 : ABI_CHECK(self%ind_ibzk2ibz(1, ikpt) /= 0, 'Did not find mapping')
4277 : end do
4278 172 : if (compute_lgk) call lgk%free()
4279 : else
4280 0 : ABI_ERROR(sjoin("Wrong symsigma:", itoa(self%symsigma)))
4281 : endif
4282 :
4283 182 : call cwtime_report(" IBZ_k --> IBZ", cpu, wall, gflops)
4284 :
4285 182 : if (.not. self%need_ftinterp) then
4286 : ! Find correspondence IBZ_k --> set of q-points in DVDB.
4287 : ! Need to handle q_bz = S q_ibz by symmetrizing the potentials already available in the DVDB.
4288 : !
4289 : ! Note:
4290 : ! q --> -q symmetry is always used for phonons.
4291 : ! we use symrec instead of symrel (see also m_dvdb)
4292 : ! IBZ_K -> BZ -> IBZ -> DVDB
4293 315 : ABI_REMALLOC(self%ind_q2dvdb_k, (6, self%nqibz_k))
4294 10843 : self%ind_q2dvdb_k = self%ind_ibzk2ibz
4295 1624 : do ikpt=1,self%nqibz_k
4296 1624 : self%ind_q2dvdb_k(1, ikpt) = self%qibz2dvdb(self%ind_ibzk2ibz(1, ikpt))
4297 : end do
4298 105 : call cwtime_report(" IBZ_k --> DVDB", cpu, wall, gflops)
4299 : end if
4300 :
4301 : ! Find k+q in the extended zone and extract symmetry info.
4302 : ! Be careful here because there are two umklapp vectors to be considered:
4303 : !
4304 : ! k + q = k_bz + g0_bz = IS(k_ibz) + g0_ibz + g0_bz
4305 : !
4306 : ! Note symrel and use_symrec=.False. in get_mapping.
4307 : ! This means that this table can be used to symmetrize wavefunctions in cgtk_rotate.
4308 : !
4309 546 : ABI_MALLOC(kq_list, (3, self%nqibz_k))
4310 134034 : do iq_ibz=1,self%nqibz_k
4311 535590 : kq_list(:, iq_ibz) = kk + self%qibz_k(:,iq_ibz)
4312 : end do
4313 :
4314 : ! Use iqk2dvdb as workspace array.
4315 546 : ABI_MALLOC(iqk2dvdb, (6, self%nqibz_k))
4316 :
4317 182 : call krank%from_kptrlatt(ebands%nkpt, ebands%kptns, ebands%kptrlatt, compute_invrank=.False.)
4318 :
4319 182 : if (self%timrev == 1) then
4320 182 : kptopt=1
4321 : else
4322 0 : kptopt=4
4323 : end if
4324 :
4325 182 : if (kpts_map("symrel", kptopt, cryst, krank, self%nqibz_k, kq_list, iqk2dvdb) /= 0) then
4326 : write(msg, '(11a)' )&
4327 0 : "The WFK file cannot be used to compute self-energy corrections at k: ", trim(ktoa(kk)), ch10,&
4328 0 : "At least one of the k+q points could not be generated from a symmetrical one.", ch10,&
4329 0 : "Q-mesh: ",trim(ltoa(self%ngqpt)),", K-mesh (from kptrlatt) ",trim(ltoa(get_diag(dtset%kptrlatt))),ch10, &
4330 0 : "Action: check your WFK file and the k/q point input variables."
4331 0 : ABI_ERROR(msg)
4332 : end if
4333 :
4334 182 : call krank%free()
4335 :
4336 182 : ABI_FREE(kq_list)
4337 :
4338 546 : ABI_REMALLOC(self%indkk_kq, (6, self%nqibz_k))
4339 134034 : do iq_ibz=1,self%nqibz_k
4340 937146 : self%indkk_kq(:, iq_ibz) = iqk2dvdb(:,iq_ibz)
4341 : end do
4342 182 : ABI_FREE(iqk2dvdb)
4343 :
4344 182 : call cwtime_report(" k+q --> ebands", cpu, wall, gflops)
4345 :
4346 182 : if (self%qint_method > 0 .and. .not. self%use_doublegrid) then
4347 186 : ABI_REMALLOC(self%ephwg%lgk2ibz, (self%nqibz_k))
4348 122483 : self%ephwg%lgk2ibz = self%ind_ibzk2ibz(1, :)
4349 186 : ABI_REMALLOC(self%ephwg%kq2ibz, (self%nqibz_k))
4350 122483 : self%ephwg%kq2ibz = self%indkk_kq(1, :)
4351 : end if
4352 :
4353 910 : end subroutine sigmaph_setup_kcalc
4354 : !!***
4355 :
4356 : !!****f* m_sigmaph/sigmaph_setup_qloop
4357 : !! NAME
4358 : !! sigmaph_setup_qloop
4359 : !!
4360 : !! FUNCTION
4361 : !! Prepare integration of self-energy matrix in q-space for given (spin, ikcalc)
4362 : !! Distribute q-points and precompute weights if tetrahedron method and imag_only
4363 : !!
4364 : !! INPUTS
4365 : !! dtset<dataset_type>=All input variables for this dataset.
4366 : !! cryst<crystal_t> = Crystal structure.
4367 : !! ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...)
4368 : !! dvdb<dbdb_type>=Database with the DFPT SCF potentials.
4369 : !! spin: spin index.
4370 : !! ikcalc=Index of the k-point to compute.
4371 : !! comm= MPI communicator
4372 : !!
4373 : !! SOURCE
4374 :
4375 182 : subroutine sigmaph_setup_qloop(self, dtset, cryst, ebands, dvdb, spin, ikcalc, comm)
4376 :
4377 : !Arguments ------------------------------------
4378 : integer,intent(in) :: spin, ikcalc, comm
4379 : type(dataset_type),intent(in) :: dtset
4380 : type(crystal_t),intent(in) :: cryst
4381 : class(sigmaph_t),intent(inout) :: self
4382 : type(ebands_t),intent(in) :: ebands
4383 : type(dvdb_t),intent(inout) :: dvdb
4384 :
4385 : !Local variables-------------------------------
4386 : integer,parameter :: master = 0
4387 : integer :: my_rank, iq_ibz_k, iq_ibz, ierr, nprocs, imyq, iq_dvdb, ii, cnt, itreat, iq, nqeff, ndiv
4388 : integer :: min_nqibz_k, max_nqibz_k
4389 : real(dp) :: cpu, wall, gflops, efact_min, efact_max
4390 : logical :: qfilter
4391 : character(len=5000) :: msg
4392 : !arrays
4393 182 : integer,allocatable :: mask_qibz_k(:), imask(:), qtab(:), ineed_qibz(:), ineed_qdvdb(:)
4394 : ! *************************************************************************
4395 :
4396 182 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
4397 :
4398 182 : msg = "Standard quadrature"; if (self%qint_method == 1) msg = "tetrahedron method"
4399 182 : call wrtout(std_out, sjoin(" Preparing q-loop with integration method:", msg))
4400 182 : call cwtime(cpu, wall, gflops, "start")
4401 :
4402 252 : select case (dtset%eph_task)
4403 : case (4)
4404 : ! Computation of re-im
4405 70 : call distribute_nqibz_k_nofilter()
4406 70 : if (self%qint_method == 1) call sigmaph_get_all_qweights(self, cryst, ebands, spin, ikcalc, comm)
4407 :
4408 : case (-4)
4409 : ! Computation of imaginary part
4410 112 : if (self%qint_method == 0) then
4411 37 : call distribute_nqibz_k_nofilter()
4412 :
4413 75 : else if (self%qint_method == 1) then
4414 : ! Imag with tetra --> Precompute weights in IBZ_k.
4415 75 : call distribute_nqibz_k_nofilter()
4416 75 : call sigmaph_get_all_qweights(self, cryst, ebands, spin, ikcalc, comm)
4417 :
4418 75 : qfilter = any(dtset%eph_tols_idelta >= zero)
4419 :
4420 75 : if (qfilter) then
4421 : ! Two-pass algorithm:
4422 : ! Select q-points with significant contribution, recompute my_nqibz_k and myq2ibz_k.
4423 : ! Finally, recompute integration weights with new distribution.
4424 : ! NB: the two-pass algorithm could be replaced by a decimation algo and a single call to the tetrahedron routines
4425 : ! %deltaw_pm(2, nbcalc_ks, my_npert, bsum_start:bsum_stop, my_nqibz_k, ndiv)
4426 75 : ndiv = 1; if (self%use_doublegrid) ndiv = self%eph_doublegrid%ndiv
4427 132880 : ABI_ICALLOC(mask_qibz_k, (self%nqibz_k))
4428 132730 : do imyq=1,self%my_nqibz_k
4429 132655 : iq_ibz_k = self%myq2ibz_k(imyq)
4430 5476061 : if (any(abs(self%deltaw_pm(1,:,:,:,imyq,:)) >= dtset%eph_tols_idelta(1) / ndiv)) mask_qibz_k(iq_ibz_k) = 1
4431 5521355 : if (any(abs(self%deltaw_pm(2,:,:,:,imyq,:)) >= dtset%eph_tols_idelta(2) / ndiv)) mask_qibz_k(iq_ibz_k) = 1
4432 : end do
4433 :
4434 : ! Take max inside comm.
4435 75 : call alloc_copy(mask_qibz_k, imask)
4436 75 : call xmpi_max(imask, mask_qibz_k, comm, ierr)
4437 75 : ABI_FREE(imask)
4438 :
4439 : ! Find all qpts in the IBZ_k contributing to Im(Sigma).
4440 225 : ABI_MALLOC(qtab, (self%nqibz_k))
4441 75 : nqeff = 0
4442 132730 : do iq_ibz_k=1,self%nqibz_k
4443 132730 : if (mask_qibz_k(iq_ibz_k) == 1) then
4444 13275 : nqeff = nqeff + 1; qtab(nqeff) = iq_ibz_k
4445 : end if
4446 : end do
4447 75 : ABI_FREE(mask_qibz_k)
4448 :
4449 75 : if (my_rank == master) then
4450 : !write(std_out, "(a, 2(es16.6,1x))")" Removing q-points with integration weights < ", dtset%eph_tols_idelta / ndiv
4451 75 : write(std_out, "(a,i0,a,f5.1,a)")" Total number of q-points contributing to Im(Sigma(eKS)): ", nqeff, &
4452 150 : " (nqeff / nqibz_k): ", (100.0_dp * nqeff) / self%nqibz_k, " [%]"
4453 : end if
4454 :
4455 : ! Redistribute relevant q-points inside qpt_comm taking into account itreat_qibz
4456 : ! Must handle two cases: potentials from DVDB or Fourier-interpolated.
4457 75 : if (self%need_ftinterp) then
4458 14222 : ABI_ICALLOC(ineed_qibz, (self%nqibz))
4459 : else
4460 431 : ABI_ICALLOC(ineed_qdvdb, (dvdb%nqpt))
4461 : end if
4462 :
4463 75 : self%my_nqibz_k = 0
4464 225 : do ii=1,2
4465 150 : if (ii == 2) then
4466 225 : ABI_REMALLOC(self%myq2ibz_k, (self%my_nqibz_k))
4467 : end if
4468 150 : cnt = 0
4469 26775 : do iq=1,nqeff
4470 26550 : iq_ibz_k = qtab(iq)
4471 26550 : iq_ibz = self%ind_ibzk2ibz(1, iq_ibz_k)
4472 26550 : itreat = int(self%itreat_qibz(iq_ibz), kind=i4b)
4473 : if (.not. self%need_ftinterp) iq_dvdb = self%ind_q2dvdb_k(1, iq_ibz_k)
4474 26700 : if (itreat /= 0) then
4475 26550 : if (ii == 1) self%my_nqibz_k = self%my_nqibz_k + 1
4476 26550 : if (ii == 2) then
4477 13275 : cnt = cnt + 1
4478 13275 : self%myq2ibz_k(cnt) = qtab(iq)
4479 : end if
4480 : end if
4481 : end do
4482 : end do
4483 75 : ABI_FREE(qtab)
4484 :
4485 : ! Recompute weights with new q-point distribution.
4486 75 : call sigmaph_get_all_qweights(self, cryst, ebands, spin, ikcalc, comm)
4487 :
4488 75 : call xmpi_min(self%my_nqibz_k, min_nqibz_k, self%qpt_comm%value, ierr)
4489 75 : call xmpi_max(self%my_nqibz_k, max_nqibz_k, self%qpt_comm%value, ierr)
4490 : !efact = (one * self%my_nqibz_k * self%qpt_comm%nproc) / nqeff
4491 75 : efact_min = (one * min_nqibz_k * self%qpt_comm%nproc) / nqeff
4492 75 : efact_max = (one * max_nqibz_k * self%qpt_comm%nproc) / nqeff
4493 : write(msg, "(2(a,i0,a),a,2(f7.3,1x),a)") &
4494 75 : " Number of q-points in the IBZ(k) treated by this MPI proc: ", self%my_nqibz_k, ch10, &
4495 75 : " Number of MPI procs in qpt_comm: ", self%qpt_comm%nproc, ch10, &
4496 150 : " Load balance inside qpt_comm ranges between: [", efact_min, efact_max, "] (should be ~1)"
4497 75 : call wrtout(std_out, msg)
4498 75 : ABI_WARNING_IF(self%my_nqibz_k == 0, "my_nqibz_k == 0")
4499 :
4500 75 : ABI_SFREE(ineed_qibz)
4501 225 : ABI_SFREE(ineed_qdvdb)
4502 : end if ! qfilter
4503 :
4504 : else
4505 0 : ABI_ERROR(sjoin("Invalid eph_intmeth:", itoa(self%qint_method)))
4506 : end if ! intmeth
4507 :
4508 112 : if (dtset%ibte_prep > 0) then
4509 : ! Allocate array with scattering rate for IBTE.
4510 64303 : ABI_RECALLOC(self%srate, (self%bsum_start:self%bsum_stop, self%nbcalc_ks(ikcalc, spin), self%ntemp, self%my_nqibz_k))
4511 64273 : self%srate = zero
4512 : end if
4513 :
4514 : case default
4515 182 : ABI_ERROR(sjoin("Invalid eph_task:", itoa(dtset%eph_task)))
4516 : end select
4517 :
4518 182 : call cwtime_report(" Setup qloop", cpu, wall, gflops)
4519 :
4520 : contains
4521 :
4522 182 : subroutine distribute_nqibz_k_nofilter()
4523 : ! Find number of q-points in IBZ(k) treated by this MPI rank
4524 : ! taking into account itreat_qibz and build redirection table myq2ibz_k.
4525 : ! The distribution must be consistent with the WF distribution done with bks_mask
4526 :
4527 182 : self%my_nqibz_k = 0
4528 546 : do ii=1,2
4529 364 : if (ii == 2) then
4530 546 : ABI_REMALLOC(self%myq2ibz_k, (self%my_nqibz_k))
4531 : end if
4532 364 : cnt = 0
4533 268250 : do iq_ibz_k=1,self%nqibz_k
4534 267704 : iq_ibz = self%ind_ibzk2ibz(1, iq_ibz_k)
4535 267704 : if (self%itreat_qibz(iq_ibz) == 0) cycle
4536 267704 : if (ii == 1) self%my_nqibz_k = self%my_nqibz_k + 1
4537 268068 : if (ii == 2) then
4538 133852 : cnt = cnt + 1
4539 133852 : self%myq2ibz_k(cnt) = iq_ibz_k
4540 : end if
4541 : end do
4542 : end do
4543 :
4544 182 : end subroutine distribute_nqibz_k_nofilter
4545 :
4546 : end subroutine sigmaph_setup_qloop
4547 : !!***
4548 :
4549 : !!****f* m_sigmaph/sigmaph_gather_and_write
4550 : !! NAME
4551 : !! sigmaph_gather_and_write
4552 : !!
4553 : !! FUNCTION
4554 : !! Gather results from the MPI processes. Then master rank does:
4555 : !!
4556 : !! 1. Computes QP energies, Z factor and spectral function (if required).
4557 : !! 2. Saves results to file.
4558 : !!
4559 : !! INPUTS
4560 : !! ebands<ebands_t>=KS band energies.
4561 : !! ikcalc=Index of the computed k-point
4562 : !! spin=Spin index.
4563 : !! comm=MPI communicator.
4564 : !!
4565 : !! SOURCE
4566 :
4567 182 : subroutine sigmaph_gather_and_write(self, dtset, ebands, ikcalc, spin, comm)
4568 :
4569 : !Arguments ------------------------------------
4570 : type(dataset_type),intent(in) :: dtset
4571 : integer,intent(in) :: ikcalc, spin, comm
4572 : class(sigmaph_t),target,intent(inout) :: self
4573 : type(ebands_t),intent(in) :: ebands
4574 :
4575 : !Local variables-------------------------------
4576 : integer,parameter :: master = 0, max_ntemp = 50
4577 : integer :: ideg,ib,it,ii,iw,nstates,ierr,my_rank,band_ks,ik_ibz,ibc,ib_val,ib_cond,jj
4578 : integer :: nq_ibzk_eff, nelem, imyq, iq_ibz_k, sr_ncid
4579 : logical :: iwrite
4580 : real(dp) :: ravg,kse,kse_prev,dw,fan0,ks_gap,kse_val,kse_cond,qpe_oms,qpe_oms_val,qpe_oms_cond
4581 : real(dp) :: cpu, wall, gflops, invsig2fmts, tau, ravg2
4582 : complex(dp) :: sig0c,zc,qpe,qpe_prev,qpe_val,qpe_cond,cavg1,cavg2,cavg3,cavg4,cavg5,cavg6
4583 : !character(len=5000) :: msg
4584 : integer :: grp_ncid, ncerr
4585 : !arrays
4586 182 : integer, allocatable :: recvcounts(:), displs(:), nq_rank(:), kq_symtab(:,:), my_kq_symtab(:,:)
4587 182 : integer, contiguous, pointer :: bids(:)
4588 364 : real(dp) :: qp_gaps(self%ntemp),qpoms_gaps(self%ntemp)
4589 182 : real(dp),allocatable :: aw(:,:,:), a2few_avg(:,:), gather_srate(:,:,:,:), grp_srate(:,:,:,:)
4590 546 : real(dp) :: ks_enes(self%max_nbcalc), ze0_vals(self%ntemp, self%max_nbcalc)
4591 364 : real(dp) :: gfw_avg(self%phmesh_size, 3)
4592 364 : complex(dp) :: qpoms_enes(self%ntemp, self%max_nbcalc),qp_enes(self%ntemp, self%max_nbcalc)
4593 : ! *************************************************************************
4594 :
4595 : ! Could use non-blocking communications and double buffer technique to reduce synchronisation cost...
4596 182 : call cwtime(cpu, wall, gflops, "start", msg=" Gathering results. Waiting for other MPI processes...")
4597 :
4598 : ! Here comm corresponds to sigma%pqb_comm%value
4599 182 : my_rank = xmpi_comm_rank(comm)
4600 182 : iwrite = self%ncwrite_comm%value /= xmpi_comm_null
4601 182 : call xmpi_sum_master(self%vals_e0ks, master, comm, ierr)
4602 182 : call xmpi_sum_master(self%fan_vals, master, comm, ierr)
4603 182 : call xmpi_sum_master(self%E4_vals, master, comm, ierr)
4604 182 : call xmpi_sum_master(self%E4_vals2, master, comm, ierr)
4605 182 : call xmpi_sum_master(self%fan_stern_vals, master, comm, ierr)
4606 182 : call xmpi_sum_master(self%dvals_de0ks, master, comm, ierr)
4607 182 : call xmpi_sum_master(self%dw_vals, master, comm, ierr)
4608 182 : call xmpi_sum_master(self%dw_stern_vals, master, comm, ierr)
4609 182 : if (self%nwr > 0) call xmpi_sum_master(self%vals_wr, master, comm, ierr)
4610 182 : if (self%mrta > 0) call xmpi_sum_master(self%linewidth_mrta, master, comm, ierr)
4611 182 : if (dtset%eph_prtscratew == 1) then
4612 : ! Collect spectral decomposition of scattering rates, multiply by two since so far we have stored Imag(Sigma) (ph_w)
4613 3 : call xmpi_sum_master(self%scratew, master, comm, ierr)
4614 90999 : self%scratew = two * self%scratew
4615 : end if
4616 :
4617 182 : if (dtset%ibte_prep > 0) then
4618 : ! FIXME: Handle kpoint/spin parallelism.
4619 : ! (%bsum_start:%bsum_stop, %nbcalc_ks(ikcalc, spin), %ntemp, %nqibz_k))
4620 : ! Sum over phonon modes
4621 6 : call xmpi_sum(self%srate, self%pert_comm%value, ierr)
4622 : !call xmpi_sum(self%srate, self%pb_comm%value), ierr)
4623 :
4624 : ! Use gatherv to collect data and tables on the IO proc i.e. the master proc in qpt_comm.
4625 : ! Only the number of q-points changes across the qpt-procs and this is the last dimension.
4626 : ! nq_ibzk_eff is the total number of effective q-points in the IBZ(k).
4627 24 : ABI_CALLOC(nq_rank, (self%qpt_comm%nproc))
4628 6 : call xmpi_allgather(self%my_nqibz_k, nq_rank, self%qpt_comm%value, ierr)
4629 :
4630 12 : nq_ibzk_eff = sum(nq_rank)
4631 6 : nelem = self%nbsum * self%nbcalc_ks(ikcalc, spin) * self%ntemp
4632 : !call self%qpt_comm%prep_gatherv(nelem, nq_rank, recvcounts, displs)
4633 18 : ABI_MALLOC(recvcounts, (self%qpt_comm%nproc))
4634 12 : ABI_MALLOC(displs, (self%qpt_comm%nproc))
4635 :
4636 18 : recvcounts = nelem * nq_rank(:)
4637 6 : displs(1) = 0
4638 6 : do ii=2,self%qpt_comm%nproc
4639 6 : displs(ii) = sum(nq_rank(1:ii-1)) * nelem
4640 : end do
4641 :
4642 36 : ABI_MALLOC(gather_srate, (self%bsum_start:self%bsum_stop, self%nbcalc_ks(ikcalc, spin), self%ntemp, nq_ibzk_eff))
4643 :
4644 6 : call xmpi_gatherv(self%srate, nelem * self%my_nqibz_k, gather_srate, recvcounts, displs, master, self%qpt_comm%value, ierr)
4645 : !ABI_CHECK(all(abs(gather_srate - self%srate) < tol12), "This only if nproc == 1")
4646 : !ABI_CHECK(nq_ibzk_eff == self%my_nqibz_k, "This only if nproc == 1")
4647 :
4648 6 : if (.not. iwrite) then
4649 0 : ABI_FREE(gather_srate)
4650 : end if
4651 :
4652 18 : ABI_MALLOC(my_kq_symtab, (6, self%my_nqibz_k))
4653 9187 : do imyq=1,self%my_nqibz_k
4654 9181 : iq_ibz_k = self%myq2ibz_k(imyq)
4655 64273 : my_kq_symtab(:, imyq) = self%indkk_kq(:, iq_ibz_k)
4656 : end do
4657 :
4658 : !call self%qpt_comm%prep_gatherv(nelem, nq_rank, recvcounts, displs)
4659 6 : displs(1) = 0; nelem = 6
4660 6 : do ii=2,self%qpt_comm%nproc
4661 6 : displs(ii) = sum(nq_rank(1:ii-1)) * nelem
4662 : end do
4663 18 : recvcounts = nq_rank * nelem
4664 :
4665 18 : ABI_MALLOC(kq_symtab, (nelem, nq_ibzk_eff))
4666 6 : call xmpi_gatherv(my_kq_symtab, nelem * self%my_nqibz_k, kq_symtab, recvcounts, displs, master, self%qpt_comm%value, ierr)
4667 : !ABI_CHECK(all(abs(kq_symtab - my_kq_symtab) < tol12), "kq_symtab")
4668 :
4669 6 : if (.not. iwrite) then
4670 0 : ABI_FREE(kq_symtab)
4671 : end if
4672 :
4673 6 : ABI_FREE(nq_rank)
4674 6 : ABI_FREE(my_kq_symtab)
4675 6 : ABI_FREE(recvcounts)
4676 18 : ABI_FREE(displs)
4677 : end if
4678 :
4679 182 : call cwtime_report(" Sigma_nk gather", cpu, wall, gflops, comm=comm)
4680 :
4681 : ! Only procs inside ncwrite_comm perform IO (ab_out and ncid)
4682 182 : if (.not. iwrite) return
4683 :
4684 182 : ik_ibz = self%kcalc2ibz(ikcalc, 1)
4685 :
4686 182 : if (self%a2f_ne > 0) then
4687 0 : ABI_MALLOC(a2few_avg, (self%a2f_ne, self%phmesh_size))
4688 : end if
4689 :
4690 182 : if (self%symsigma == +1) then
4691 : ! Average self-energy matrix elements in the degenerate subspace.
4692 630 : do ideg=1,size(self%degtab(ikcalc, spin)%bids)
4693 458 : bids => self%degtab(ikcalc, spin)%bids(ideg)%vals
4694 458 : nstates = size(bids)
4695 :
4696 : ! Symmetrize Eliashberg function
4697 458 : if (dtset%prteliash > 0) then
4698 1603855 : gfw_avg = sum(self%gfw_vals(:, :, bids(:)), dim=3) / nstates
4699 463 : do ii=1,nstates
4700 993697 : self%gfw_vals(:, :, bids(ii)) = gfw_avg
4701 : end do
4702 175 : if (self%a2f_ne > 0) then
4703 0 : a2few_avg = sum(self%a2few(:, :, bids(:)), dim=3) / nstates
4704 0 : do ii=1,nstates
4705 0 : self%a2few(:, :, bids(ii)) = a2few_avg
4706 : end do
4707 : end if
4708 : end if
4709 :
4710 2066 : do it=1,self%ntemp
4711 : ! Average QP(T) and Z(T).
4712 3708 : cavg1 = sum(self%vals_e0ks(it, bids(:))) / nstates
4713 3708 : cavg2 = sum(self%dvals_de0ks(it, bids(:))) / nstates
4714 3708 : cavg3 = sum(self%fan_vals(it, bids(:))) / nstates
4715 3708 : cavg4 = sum(self%fan_stern_vals(it, bids(:))) / nstates
4716 3708 : cavg5 = sum(self%E4_vals(it, bids(:))) / nstates
4717 3708 : cavg6 = sum(self%E4_vals2(it, bids(:))) / nstates
4718 3708 : ravg = sum(self%dw_vals(it, bids(:))) / nstates
4719 3708 : ravg2 = sum(self%dw_stern_vals(it, bids(:))) / nstates
4720 3708 : do ii=1,nstates
4721 2272 : self%vals_e0ks(it, bids(ii)) = cavg1
4722 2272 : self%dvals_de0ks(it, bids(ii)) = cavg2
4723 2272 : self%fan_vals(it, bids(ii)) = cavg3
4724 2272 : self%fan_stern_vals(it, bids(ii)) = cavg4
4725 2272 : self%E4_vals(it, bids(ii)) = cavg5
4726 2272 : self%E4_vals2(it, bids(ii)) = cavg6
4727 2272 : self%dw_vals(it, bids(ii)) = ravg
4728 3708 : self%dw_stern_vals(it, bids(ii)) = ravg2
4729 : end do
4730 :
4731 : ! Average TAU_MRTA
4732 1436 : if (self%mrta > 0) then
4733 1958 : ravg = sum(self%linewidth_mrta(it, bids(:))) / nstates
4734 1958 : do ii=1,nstates
4735 1958 : self%linewidth_mrta(it, bids(ii)) = ravg
4736 : end do
4737 : end if
4738 :
4739 1894 : if (self%nwr > 0) then
4740 : ! Average Sigma(omega, T)
4741 60964 : do iw=1,self%nwr
4742 158541 : cavg1 = sum(self%vals_wr(iw, it, bids(:))) / nstates
4743 159064 : do ii=1,nstates
4744 158541 : self%vals_wr(iw, it, bids(ii)) = cavg1
4745 : end do
4746 : end do ! iw
4747 : end if
4748 :
4749 : end do ! it
4750 : end do ! ideg
4751 : end if ! symsigma == +1
4752 :
4753 182 : ABI_SFREE(a2few_avg)
4754 :
4755 : ! Compute QP energies and Gaps (Note that I'm assuming a non-magnetic semiconductor!)
4756 182 : ib_val = nint(ebands%nelect / (two / ebands%nspinor)); ib_cond = ib_val + 1
4757 182 : kse_val = huge(one) * tol6; kse_cond = huge(one) * tol6
4758 7098 : qp_enes = huge(one) * tol6; qpoms_enes = huge(one) * tol6
4759 4510 : ks_enes = huge(one) * tol6; ze0_vals = huge(one) * tol6
4760 1352 : ks_gap = -one; qpoms_gaps = -one; qp_gaps = -one
4761 :
4762 : ! Write legend.
4763 182 : if (ikcalc == 1 .and. spin == 1) then
4764 58 : write(ab_out,"(a)")repeat("=", 80)
4765 58 : write(ab_out,"(a)")" Final results in eV."
4766 58 : write(ab_out,"(a)")" Notations:"
4767 58 : write(ab_out,"(a)")" eKS: Kohn-Sham energy. eQP: quasi-particle energy."
4768 58 : write(ab_out,"(a)")" eQP - eKS: Difference between the QP and the KS energy."
4769 58 : write(ab_out,"(a)")" SE1(eKS): Real part of the self-energy computed at the KS energy, SE2 for imaginary part."
4770 58 : write(ab_out,"(a)")" Z(eKS): Renormalization factor."
4771 58 : write(ab_out,"(a)")" FAN: Real part of the Fan term at eKS. DW: Debye-Waller term."
4772 58 : write(ab_out,"(a)")" DeKS: KS energy difference between this band and band-1, DeQP same meaning but for eQP."
4773 58 : write(ab_out,"(a)")" OTMS: On-the-mass-shell approximation with eQP ~= eKS + Sigma(omega=eKS)"
4774 58 : write(ab_out,"(a)")" TAU(eKS): Lifetime in femtoseconds computed at the KS energy."
4775 58 : write(ab_out,"(a)")" mu_e: Fermi level for given (T, nelect)"
4776 58 : write(ab_out,"(a)")" "
4777 58 : write(ab_out,"(a)")" "
4778 : end if
4779 :
4780 767 : do it=1,self%ntemp
4781 :
4782 : ! Write header.
4783 585 : if (it <= max_ntemp) then
4784 585 : if (self%nsppol == 1) then
4785 : write(ab_out,"(3a,f6.1,a,f8.3)") &
4786 585 : "K-point: ", trim(ktoa(self%kcalc(:,ikcalc))), ", T: ", self%kTmesh(it) / kb_HaK, &
4787 1170 : " [K], mu_e: ", self%mu_e(it) * Ha_eV
4788 : else
4789 : write(ab_out,"(3a,i1,a,f6.1,a,f8.3)") &
4790 0 : "K-point: ", trim(ktoa(self%kcalc(:,ikcalc))), ", spin: ", spin, ", T: ",self%kTmesh(it) / kb_HaK, &
4791 0 : " [K], mu_e: ", self%mu_e(it) * Ha_eV
4792 : end if
4793 585 : if (self%imag_only) then
4794 387 : write(ab_out,"(a)")" B eKS SE2(eKS) TAU(eKS) DeKS"
4795 : else
4796 198 : write(ab_out,"(a)")" B eKS eQP eQP-eKS SE1(eKS) SE2(eKS) Z(eKS) FAN(eKS) DW DeKS DeQP"
4797 : end if
4798 : end if
4799 :
4800 : ! Loop over bands for this k-point and spin
4801 3033 : do ibc=1,self%nbcalc_ks(ikcalc, spin)
4802 2448 : band_ks = self%bstart_ks(ikcalc, spin) + ibc - 1
4803 2448 : kse = ebands%eig(band_ks, ik_ibz, spin)
4804 2448 : ks_enes(ibc) = kse
4805 2448 : sig0c = self%vals_e0ks(it, ibc)
4806 2448 : dw = self%dw_vals(it, ibc)
4807 2448 : fan0 = real(sig0c) - dw
4808 : ! Compute QP energies with On-the-Mass-Shell approximation and first renormalization i.e. Z(eKS)
4809 : ! TODO: Note that here I use the full Sigma including the imaginary part
4810 : !zc = one / (one - self%dvals_de0ks(it, ibc))
4811 2448 : zc = one / (one - real(self%dvals_de0ks(it, ibc)))
4812 2448 : ze0_vals(it, ibc) = real(zc)
4813 2448 : qpe = kse + real(zc) * real(sig0c)
4814 2448 : qpe_oms = kse + real(sig0c)
4815 2448 : if (ibc == 1) then
4816 585 : kse_prev = kse; qpe_prev = qpe
4817 : end if
4818 2448 : if (band_ks == ib_val) then
4819 389 : kse_val = kse; qpe_val = qpe; qpe_oms_val = qpe_oms
4820 : end if
4821 2448 : if (band_ks == ib_cond) then
4822 532 : kse_cond = kse; qpe_cond = qpe; qpe_oms_cond = qpe_oms
4823 : end if
4824 :
4825 2448 : if (it <= max_ntemp) then
4826 2448 : if (self%imag_only) then
4827 : ! 1/tau = 2 Imag(Sigma)
4828 1258 : invsig2fmts = Time_Sec * 1e+15 / two
4829 1258 : tau = 999999.0_dp
4830 1258 : if (abs(aimag(sig0c)) > tol16) tau = invsig2fmts / abs(aimag(sig0c))
4831 1258 : tau = min(tau, 999999.0_dp)
4832 : write(ab_out, "(i4,2(f8.3,1x),f8.1,1x,f8.3)") &
4833 1258 : band_ks, kse * Ha_eV, aimag(sig0c) * Ha_eV, tau, (kse - kse_prev) * Ha_eV
4834 : else
4835 : write(ab_out, "(i4, 10(f8.3,1x))") &
4836 1190 : band_ks, kse * Ha_eV, real(qpe) * Ha_eV, (real(qpe) - kse) * Ha_eV, &
4837 3638 : real(sig0c) * Ha_eV, aimag(sig0c) * Ha_eV, real(zc), &
4838 2380 : fan0 * Ha_eV, dw * Ha_eV, (kse - kse_prev) * Ha_eV, real(qpe - qpe_prev) * Ha_eV
4839 : end if
4840 : end if
4841 :
4842 2448 : if (ibc > 1) then
4843 1863 : kse_prev = kse; qpe_prev = qpe
4844 : end if
4845 2448 : qpoms_enes(it, ibc) = qpe_oms
4846 2448 : qp_enes(it, ibc) = qpe
4847 3033 : if (kse_val /= huge(one) * tol6 .and. kse_cond /= huge(one) * tol6) then
4848 : ! We have enough states to compute the gap.
4849 1739 : if (it == 1) ks_gap = kse_cond - kse_val
4850 1739 : qpoms_gaps(it) = qpe_oms_cond - qpe_oms_val
4851 1739 : qp_gaps(it) = real(qpe_cond - qpe_val)
4852 : end if
4853 : end do ! ibc
4854 :
4855 : ! Print KS and QP gaps.
4856 767 : if (it <= max_ntemp) then
4857 585 : if (.not. self%imag_only) then
4858 198 : if (kse_val /= huge(one) * tol6 .and. kse_cond /= huge(one) * tol6) then
4859 167 : write(ab_out, "(a)")" "
4860 167 : write(ab_out, "(a,f8.3,1x,2(a,i0),a)")" KS gap: ",ks_gap * Ha_eV, &
4861 334 : "(assuming bval:", ib_val, " ==> bcond:", ib_cond, ")"
4862 167 : write(ab_out, "(2(a,f8.3),a)")" QP gap: ",qp_gaps(it) * Ha_eV," (OTMS: ",qpoms_gaps(it) * Ha_eV, ")"
4863 167 : write(ab_out, "(2(a,f8.3),a)")" QP_gap - KS_gap: ",(qp_gaps(it) - ks_gap) * Ha_eV,&
4864 334 : " (OTMS: ",(qpoms_gaps(it) - ks_gap) * Ha_eV, ")"
4865 167 : write(ab_out, "(a)")" "
4866 : end if
4867 : else
4868 387 : if (kse_val /= huge(one) * tol6 .and. kse_cond /= huge(one) * tol6) then
4869 169 : write(ab_out, "(a)")" "
4870 169 : write(ab_out, "(a,f8.3,1x,2(a,i0),a)")" KS gap: ",ks_gap * Ha_eV, "(assuming bval:",ib_val," ==> bcond:",ib_cond,")"
4871 169 : write(ab_out, "(a)")" "
4872 : end if
4873 : end if
4874 :
4875 585 : write(ab_out, "(a)")repeat("=", 92)
4876 : end if
4877 :
4878 : end do ! it
4879 :
4880 182 : if (self%ntemp > max_ntemp .and. (ikcalc == 1 .and. spin == 1)) then
4881 0 : write(ab_out, "(a,i0,a)")" No more than ", max_ntemp, " temperatures are written to the main output file."
4882 0 : write(ab_out, "(2a)")" Please use SIGEPH.nc file and AbiPy to analyze the results.",ch10
4883 : end if
4884 :
4885 182 : if (dtset%prtvol > 0 .and. (ikcalc == 1 .and. spin == 1)) then
4886 15 : if (allocated(self%gfw_vals)) then
4887 13 : write(ab_out, "(2a)")" omega and Eliashberg function gf_{nk}(omega) for testing purposes:"
4888 13 : iw = (self%phmesh_size / 2)
4889 73 : do ib=1,min(self%nbcalc_ks(ikcalc, spin), 5)
4890 60 : band_ks = self%bstart_ks(ikcalc, spin) + ib - 1
4891 60 : write(ab_out, "(a, i0)")"For band:", band_ks
4892 193 : do jj=0,1
4893 540 : write(ab_out, "(4(f8.3,2x))")self%phmesh(iw+jj), (self%gfw_vals(iw+jj, ii, ib), ii=1,3)
4894 : end do
4895 : end do
4896 13 : write(ab_out, "(a)")ch10
4897 : end if
4898 :
4899 15 : if (self%nwr >= 3) then
4900 14 : write(ab_out, "(2a)")ch10," omega and Sigma_nk(omega, T=1) in eV for testing purposes:"
4901 14 : it = 1; iw = (self%nwr / 2)
4902 77 : do ib=1,min(self%nbcalc_ks(ikcalc, spin), 5)
4903 63 : band_ks = self%bstart_ks(ikcalc, spin) + ib - 1
4904 63 : write(ab_out, "(a, i0)")"For band:", band_ks
4905 203 : do ii=0,1
4906 189 : write(ab_out, "(3(f8.3,2x))")self%wrmesh_b(iw+ii, ib) * Ha_eV, self%vals_wr(iw+ii, it, ib) * Ha_eV
4907 : end do
4908 : end do
4909 14 : write(ab_out, "(a)")ch10
4910 : end if
4911 : end if
4912 :
4913 182 : call flush_unit(ab_out)
4914 :
4915 : ! Write self-energy matrix elements for this (kpt, spin). NB: Only master writes
4916 1092 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "vals_e0ks"), c2r(self%vals_e0ks), start=[1,1,1,ikcalc,spin]))
4917 1092 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "fan_vals"), c2r(self%fan_vals), start=[1,1,1,ikcalc,spin]))
4918 1092 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "E4_vals"), c2r(self%E4_vals), start=[1,1,1,ikcalc,spin]))
4919 1092 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "E4_vals2"), c2r(self%E4_vals2), start=[1,1,1,ikcalc,spin]))
4920 1092 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "fan_stern_vals"), c2r(self%fan_stern_vals), start=[1,1,1,ikcalc,spin]))
4921 1092 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "dvals_de0ks"), c2r(self%dvals_de0ks), start=[1,1,1,ikcalc,spin]))
4922 910 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "dw_vals"), self%dw_vals, start=[1,1,ikcalc,spin]))
4923 910 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "dw_stern_vals"), self%dw_stern_vals, start=[1,1,ikcalc,spin]))
4924 : ! Dump QP energies and gaps for this (kpt, spin)
4925 1092 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "qpoms_enes"), c2r(qpoms_enes), start=[1,1,1,ikcalc,spin]))
4926 :
4927 182 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "E2"), self%E2, start=[1]))
4928 1092 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "qp_enes"), c2r(qp_enes), start=[1,1,1,ikcalc,spin]))
4929 910 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "ze0_vals"), ze0_vals, start=[1,1,ikcalc,spin]))
4930 728 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "ks_enes"), ks_enes, start=[1,ikcalc,spin]))
4931 546 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "ks_gaps"), ks_gap, start=[ikcalc,spin]))
4932 728 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "qpoms_gaps"), qpoms_gaps, start=[1,ikcalc,spin]))
4933 728 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "qp_gaps"), qp_gaps, start=[1,ikcalc,spin]))
4934 :
4935 182 : if (self%mrta > 0) then
4936 560 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "linewidth_mrta"), self%linewidth_mrta, start=[1,1,ikcalc,spin]))
4937 : end if
4938 :
4939 182 : if (dtset%eph_prtscratew == 1) then
4940 21 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "scratew"), self%scratew, start=[1,1,1,1,ikcalc,spin]))
4941 : end if
4942 :
4943 : !if (self%frohl_model == 1 .and. self%imag_only) then
4944 : ! ncerr = nf90_put_var(self%ncid, nctk_idname(self%ncid, "frohl_deltas_sphcorr"), &
4945 : ! self%frohl_deltas_sphcorr, start=[1,1,1,1, ikcalc, spin])
4946 : ! NCF_CHECK(ncerr)
4947 : !end if
4948 :
4949 : ! Write frequency dependent data.
4950 182 : if (self%nwr > 0) then
4951 260 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "wrmesh_b"), self%wrmesh_b, start=[1,1,ikcalc,spin]))
4952 364 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "vals_wr"), c2r(self%vals_wr), start=[1,1,1,1,ikcalc,spin]))
4953 :
4954 : ! Compute spectral function. A = -1/pi [Im Sigma(ww)] / ([ww - ee - Re Sigma(ww)] ** 2 + Im Sigma(ww) ** 2])
4955 260 : ABI_MALLOC(aw, (self%nwr, self%ntemp, self%max_nbcalc))
4956 336 : do ib=1,self%nbcalc_ks(ikcalc, spin)
4957 284 : band_ks = self%bstart_ks(ikcalc, spin) + ib - 1
4958 284 : kse = ebands%eig(band_ks, ik_ibz, spin)
4959 1276 : do it=1,self%ntemp
4960 : aw(:, it, ib) = -piinv * aimag(self%vals_wr(:, it, ib)) / &
4961 109020 : ((self%wrmesh_b(:, ib) - kse - real(self%vals_wr(:, it, ib))) ** 2 + aimag(self%vals_wr(:, it, ib)) ** 2)
4962 : end do
4963 : end do
4964 312 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "spfunc_wr"), aw, start=[1, 1, 1, ikcalc, spin]))
4965 52 : ABI_FREE(aw)
4966 : end if
4967 :
4968 : ! Write Eliashberg functions
4969 182 : if (allocated(self%gfw_vals)) then
4970 348 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "gfw_vals"), self%gfw_vals, start=[1, 1, 1, ikcalc, spin]))
4971 : end if
4972 182 : if (allocated(self%a2few)) then
4973 0 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "a2few"), self%a2few, start=[1, 1, 1, ikcalc, spin]))
4974 : end if
4975 :
4976 182 : if (dtset%ibte_prep > 0) then
4977 6 : call wrtout(std_out, " Writing scattering matrix elements to disk...")
4978 : ! Get ncid of group used to store scattering rate (ragged array implemented with netcdf groups).
4979 : ! FIXME: Unfortunately, this algo cannot be used if parallelism over kcalc/spin is on since
4980 : ! we have to change the metadata at runtime.
4981 6 : sr_ncid = self%ncid
4982 6 : NCF_CHECK(nf90_inq_ncid(sr_ncid, strcat("srate_k", itoa(ikcalc), "_s", itoa(spin)), grp_ncid))
4983 :
4984 : ! Define dimensions and arrays inside group at runtime
4985 : ncerr = nctk_def_dims(grp_ncid, [ &
4986 : nctkdim_t("lgk_nsym", self%lgk_nsym), &
4987 : nctkdim_t("nbcalc", self%nbcalc_ks(ikcalc, spin)), &
4988 : nctkdim_t("nbsum", self%bsum_stop - self%bsum_start + 1), &
4989 : nctkdim_t("nq_ibzk_eff", nq_ibzk_eff) &
4990 30 : ], defmode=.True.)
4991 6 : NCF_CHECK(ncerr)
4992 :
4993 : ncerr = nctk_def_arrays(grp_ncid, [ &
4994 : nctkarr_t("lgk_sym2glob", "int", "two, lgk_nsym"), &
4995 : nctkarr_t("kq_symtab", "int", "six, nq_ibzk_eff"), &
4996 : nctkarr_t("srate", "dp", "nq_ibzk_eff, nbsum, nbcalc, ntemp") &
4997 24 : ])
4998 6 : NCF_CHECK(ncerr)
4999 :
5000 : ! Write data.
5001 6 : NCF_CHECK(nctk_set_datamode(sr_ncid))
5002 6 : NCF_CHECK(nf90_put_var(grp_ncid, nctk_idname(grp_ncid, "lgk_sym2glob"), self%lgk_sym2glob))
5003 6 : NCF_CHECK(nf90_put_var(grp_ncid, nctk_idname(grp_ncid, "kq_symtab"), kq_symtab))
5004 6 : ABI_FREE(kq_symtab)
5005 :
5006 : ! Move q-points to first dimensions before writing.
5007 36 : ABI_MALLOC(grp_srate, (nq_ibzk_eff, self%bsum_start:self%bsum_stop, self%nbcalc_ks(ikcalc, spin), self%ntemp))
5008 9187 : do ii=1,nq_ibzk_eff
5009 64273 : grp_srate(ii,:,:,:) = gather_srate(:,:,:,ii)
5010 : end do
5011 6 : NCF_CHECK(nf90_put_var(grp_ncid, nctk_idname(grp_ncid, "srate"), grp_srate))
5012 6 : ABI_FREE(gather_srate)
5013 6 : ABI_FREE(grp_srate)
5014 : end if
5015 :
5016 : ! Write restart flag
5017 182 : self%qp_done(ikcalc, spin) = 1
5018 546 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "qp_done"), 1, start=[ikcalc, spin]))
5019 :
5020 : ! Dump the cache to file. This is necessary to ensure we can restart.
5021 182 : NCF_CHECK(nf90_sync(self%ncid))
5022 :
5023 182 : call cwtime_report(" Sigma_nk netcdf output", cpu, wall, gflops)
5024 :
5025 364 : end subroutine sigmaph_gather_and_write
5026 : !!***
5027 :
5028 : !!****f* m_sigmaph/sigmaph_print
5029 : !! NAME
5030 : !! sigmaph_print
5031 : !!
5032 : !! FUNCTION
5033 : !! Print self-energy and QP corrections for given (k-point, spin).
5034 : !!
5035 : !! INPUTS
5036 : !! dtset<dataset_type>=All input variables for this dataset.
5037 : !! unt=Fortran unit number
5038 : !!
5039 : !! SOURCE
5040 :
5041 116 : subroutine sigmaph_print(self, dtset, unt)
5042 :
5043 : !Arguments ------------------------------------
5044 : integer,intent(in) :: unt
5045 : type(dataset_type),intent(in) :: dtset
5046 : class(sigmaph_t),intent(in) :: self
5047 :
5048 : !Local variables-------------------------------
5049 : integer :: ikc, is, ndiv
5050 : character(len=5000) :: msg
5051 : ! *************************************************************************
5052 :
5053 116 : if (unt == dev_null) return
5054 :
5055 : ! Write dimensions
5056 116 : write(unt,"(/,a)")sjoin(" Number of bands in e-ph self-energy sum:", itoa(self%nbsum))
5057 116 : write(unt,"(a)")sjoin(" From bsum_start:", itoa(self%bsum_start), "to bsum_stop:", itoa(self%bsum_stop))
5058 116 : if (dtset%eph_stern /= 0 .and. .not. self%imag_only) then
5059 34 : write(unt, "(a)")" Treating high-energy bands with Sternheimer and static self-energy."
5060 34 : write(unt, "(a, es16.6, a, i0)")" Tolwfr:", dtset%tolwfr, ", nline: ", dtset%nline
5061 : end if
5062 116 : write(unt,"(a)")sjoin(" Symsigma: ",itoa(self%symsigma), "Timrev:", itoa(self%timrev))
5063 116 : if (.not. (self%qint_method == 1 .and. self%imag_only)) then
5064 84 : write(unt,"(a)")sjoin(" Imaginary shift in the denominator (zcut): ", ftoa(aimag(self%ieta) * Ha_eV, fmt="f5.3"), "[eV]")
5065 : end if
5066 116 : msg = " Standard quadrature"; if (self%qint_method == 1) msg = " Tetrahedron method"
5067 116 : write(unt, "(2a)")sjoin(" Method for q-space integration:", msg)
5068 116 : if (self%qint_method == 1) then
5069 38 : ndiv = 1; if (self%use_doublegrid) ndiv = self%eph_doublegrid%ndiv
5070 114 : write(unt, "(a, 2(es16.6,1x))")" Tolerance for integration weights < ", dtset%eph_tols_idelta(:) / ndiv
5071 38 : write(unt, "(a, (f5.2,1x))")" eph_phwinfact: ", self%phwinfact
5072 : end if
5073 116 : if (self%use_doublegrid) write(unt, "(a, i0)")" Using double grid technique with ndiv: ", self%eph_doublegrid%ndiv
5074 116 : if (self%imag_only) write(unt, "(a)")" Only the Imaginary part of Sigma will be computed."
5075 116 : if (.not. self%imag_only) write(unt, "(a)")" Both Real and Imaginary part of Sigma will be computed."
5076 : write(unt,"(a)")sjoin(" Number of frequencies along the real axis:", itoa(self%nwr), &
5077 116 : ", Step:", ftoa(self%wr_step * Ha_eV, fmt="f5.3"), "[eV]")
5078 116 : if (dtset%prteliash /= 0) then
5079 42 : write(unt, "(a)")sjoin(" Number of frequency in generalized Eliashberg functions:", itoa(self%phmesh_size))
5080 : else
5081 74 : write(unt, "(a)")" Number of frequency in generalized Eliashberg functions: 0"
5082 : end if
5083 : write(unt,"(a)")sjoin(" Number of temperatures:", itoa(self%ntemp), &
5084 116 : "From:", ftoa(self%kTmesh(1) / kb_HaK), "to", ftoa(self%kTmesh(self%ntemp) / kb_HaK), "[K]")
5085 116 : write(unt,"(a)")sjoin(" Ab-initio q-mesh from DDB file:", ltoa(dtset%ddb_ngqpt))
5086 116 : write(unt,"(a)")sjoin(" Q-mesh used for self-energy integration [ngqpt]:", ltoa(self%ngqpt))
5087 116 : write(unt,"(a)")sjoin(" Number of q-points in the IBZ:", itoa(self%nqibz))
5088 116 : write(unt,"(a)")sjoin(" asr:", itoa(dtset%asr), "chneut:", itoa(dtset%chneut))
5089 116 : write(unt,"(a)")sjoin(" dipdip:", itoa(dtset%dipdip), "symdynmat:", itoa(dtset%symdynmat))
5090 :
5091 116 : if (.not. self%imag_only) then
5092 66 : select case (self%frohl_model)
5093 : case (0)
5094 : !write(unt,"(a)")" No special treatment for the integration of the Frohlich divergence in the microzone around Gamma"
5095 : case (1)
5096 0 : write(unt,"(a)")" Integrating Frohlich model in small sphere around Gamma to accelerate qpt convergence"
5097 0 : write(unt,"(2(a,i0,1x))")" Spherical integration performed with: ntheta: ", self%ntheta, ", nphi: ", self%nphi
5098 : case default
5099 66 : ABI_ERROR(sjoin("Invalid value of frohl_mode:", itoa(self%frohl_model)))
5100 : end select
5101 : end if
5102 :
5103 116 : write(unt,"(a, i0)")" Number of k-points for self-energy corrections: ", self%nkcalc
5104 310 : if (any(abs(dtset%sigma_erange) /= zero)) then
5105 84 : write(unt, "(a, 2(f6.3, 1x), a)")" sigma_erange: ", dtset%sigma_erange(:) * Ha_eV, " (eV)"
5106 : end if
5107 116 : if (self%imag_only .and. self%qint_method == 1) then
5108 32 : write(unt,"(a, 2(f5.3, 1x), a)")" Including all final {mk+q} states inside energy window: [", &
5109 64 : self%elow * Ha_eV, self%ehigh * Ha_eV, "] [eV]"
5110 : end if
5111 116 : write(unt,"(a)")" List of k-points for self-energy corrections:"
5112 480 : do ikc=1,self%nkcalc
5113 364 : if (ikc > 10) then
5114 0 : write(unt, "(2a)")" nkcalc > 10. Stop printing more k-point information.",ch10
5115 0 : exit
5116 : end if
5117 844 : do is=1,self%nsppol
5118 364 : if (self%nsppol == 2) write(unt,"(a,i1,a)")" For spin: ",is, ", ikcalc, spin, kpt, bstart, bstop"
5119 : write(unt, "(2(i4,2x),a,2(i4,1x))") &
5120 728 : ikc, is, trim(ktoa(self%kcalc(:,ikc))), self%bstart_ks(ikc,is), self%bstart_ks(ikc,is) + self%nbcalc_ks(ikc,is) - 1
5121 : end do
5122 : end do
5123 :
5124 116 : write(unt, "(/,a)")" === MPI parallelism ==="
5125 116 : write(unt, "(2(a,i0))")"P Allocating and summing bands from my_bsum_start: ", self%my_bsum_start, &
5126 232 : " up to my_bsum_stop: ", self%my_bsum_stop
5127 116 : write(unt, "(a,i0)")"P Number of CPUs for parallelism over perturbations: ", self%pert_comm%nproc
5128 116 : write(unt, "(a,i0)")"P Number of perturbations treated by this CPU: ", self%my_npert
5129 116 : write(unt, "(a,i0)")"P Number of CPUs for parallelism over q-points: ", self%qpt_comm%nproc
5130 116 : write(unt, "(2(a,i0))")"P Number of q-points in the IBZ treated by this proc: " , &
5131 8212 : count(self%itreat_qibz == 1), " of ", self%nqibz
5132 116 : write(unt, "(a,i0)")"P Number of CPUs for parallelism over bands: ", self%bsum_comm%nproc
5133 116 : write(unt, "(a,i0)")"P Number of CPUs for parallelism over spins: ", self%spin_comm%nproc
5134 116 : write(unt, "(a,i0)")"P Number of CPUs for parallelism over k-points: ", self%kcalc_comm%nproc
5135 116 : write(unt, "(2(a,i0),/)")"P Number of k-point in Sigma_nk treated by this proc: ", self%my_nkcalc, " of ", self%nkcalc
5136 :
5137 : end subroutine sigmaph_print
5138 : !!***
5139 :
5140 : !----------------------------------------------------------------------
5141 :
5142 : !!****f* m_sigmaph/sigmaph_get_all_qweights
5143 : !! NAME
5144 : !! sigmaph_get_all_qweights
5145 : !!
5146 : !! FUNCTION
5147 : !! Compute all the weights for q-space integration using the tetrahedron method
5148 : !!
5149 : !! INPUTS
5150 : !! cryst<crystal_t>=Crystalline structure
5151 : !! ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...)
5152 : !! spin: Spin index
5153 : !! ikcalc: Index of the self-energy k-point in the kcalc array.
5154 : !! comm: MPI communicator
5155 : !!
5156 : !! OUTPUT
5157 : !!
5158 : !! SOURCE
5159 :
5160 156 : subroutine sigmaph_get_all_qweights(sigma, cryst, ebands, spin, ikcalc, comm)
5161 :
5162 : !Arguments ------------------------------------
5163 : !scalars
5164 : class(sigmaph_t),intent(inout) :: sigma
5165 : type(ebands_t),intent(in) :: ebands
5166 : type(crystal_t),intent(in) :: cryst
5167 : integer,intent(in) :: ikcalc, spin, comm
5168 :
5169 : !Local variables ------------------------------
5170 : !scalars
5171 : integer :: nu, ibsum_kq, ik_ibz, bstart_ks, nbcalc_ks, my_rank, natom3
5172 : integer :: nprocs, imyp, imyq, ndiv, bsum_start, bsum_stop, ib_k, band_ks
5173 : integer :: iq_ibz_fine,iq_bz_fine,iq_ibz,jj, nz
5174 : real(dp) :: weight, cpu,wall, gflops, eig0nk
5175 : !arrays
5176 : real(dp) :: kk(3), kq(3), qpt(3), dpm(2)
5177 156 : real(dp),allocatable :: tmp_deltaw_pm(:,:,:)
5178 156 : complex(dp),allocatable :: zvals(:,:), tmp_cweights(:,:,:,:)
5179 : ! *************************************************************************
5180 :
5181 156 : call cwtime(cpu, wall, gflops, "start")
5182 :
5183 156 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
5184 :
5185 624 : kk = sigma%kcalc(:, ikcalc)
5186 156 : ik_ibz = sigma%kcalc2ibz(ikcalc, 1)
5187 156 : nbcalc_ks = sigma%nbcalc_ks(ikcalc, spin)
5188 156 : bstart_ks = sigma%bstart_ks(ikcalc, spin)
5189 156 : bsum_start = sigma%bsum_start; bsum_stop = sigma%bsum_stop
5190 156 : natom3 = 3 * cryst%natom
5191 156 : ndiv = 1; if (sigma%use_doublegrid) ndiv = sigma%eph_doublegrid%ndiv
5192 :
5193 156 : ABI_CHECK(abs(sigma%symsigma) == 1, "symsigma 0 with tetra not implemented")
5194 :
5195 156 : if (sigma%imag_only) then
5196 : ! Weights for Im (tetrahedron, eta --> 0)
5197 1050 : ABI_REMALLOC(sigma%deltaw_pm, (2, nbcalc_ks, sigma%my_npert, bsum_start:bsum_stop, sigma%my_nqibz_k, ndiv))
5198 13743622 : sigma%deltaw_pm = zero
5199 :
5200 : ! Temporary weights (on the fine IBZ_k mesh if double grid is used)
5201 450 : ABI_MALLOC(tmp_deltaw_pm, (1, sigma%ephwg%nq_k, 2))
5202 :
5203 : ! Loop over bands to sum
5204 696 : do ibsum_kq=sigma%bsum_start, sigma%bsum_stop
5205 : ! Loop over my phonon modes
5206 3936 : do imyp=1,sigma%my_npert
5207 3240 : nu = sigma%my_pinfo(3, imyp)
5208 :
5209 : ! HM: This one should be faster but uses more memory, I compute for each ib instead
5210 : ! Compute weights inside qb_comm
5211 : !call sigma%ephwg%get_deltas_wvals(ibsum_kq, spin, nu, nbcalc_ks, &
5212 : ! ebands%eig(bstart_ks:bstart_ks+nbcalc_ks, ik_ibz, spin), &
5213 : ! sigma%bcorr, tmp_deltaw_pm, sigma%qb_comm%value)
5214 :
5215 : ! loop over bands in self-energy matrix elements.
5216 18894 : do ib_k=1,nbcalc_ks
5217 15108 : band_ks = ib_k + bstart_ks - 1
5218 15108 : eig0nk = ebands%eig(band_ks, ik_ibz, spin)
5219 :
5220 : ! Compute weights inside qb_comm
5221 30216 : call sigma%ephwg%get_deltas_wvals(ibsum_kq, spin, nu, 1, [eig0nk], sigma%bcorr, tmp_deltaw_pm, sigma%qb_comm%value)
5222 :
5223 : ! For all the q-points that I am going to calculate
5224 986229 : do imyq=1,sigma%my_nqibz_k
5225 967881 : iq_ibz = sigma%myq2ibz_k(imyq)
5226 :
5227 982989 : if (sigma%use_doublegrid) then
5228 : ! For all the q-points in the microzone
5229 : ! This is done again in the main sigmaph routine
5230 375480 : qpt = sigma%qibz_k(:,iq_ibz)
5231 375480 : kq = kk + qpt
5232 93870 : call sigma%eph_doublegrid%get_mapping(kk, kq, qpt)
5233 2628360 : do jj=1,sigma%eph_doublegrid%ndiv
5234 2534490 : iq_bz_fine = sigma%eph_doublegrid%mapping(3,jj)
5235 2534490 : iq_ibz_fine = sigma%eph_doublegrid%bz2lgkibz(iq_bz_fine)
5236 2534490 : weight = sigma%ephwg%lgk%weights(iq_ibz_fine)
5237 : !dpm = tmp_deltaw_pm(ib_k, iq_ibz_fine, :)
5238 7603470 : dpm = tmp_deltaw_pm(1, iq_ibz_fine, :)
5239 7697340 : sigma%deltaw_pm(:, ib_k, imyp, ibsum_kq, imyq, jj) = dpm / weight
5240 : end do
5241 : else
5242 874011 : weight = sigma%ephwg%lgk%weights(iq_ibz)
5243 : !dpm = tmp_deltaw_pm(ib_k, iq_ibz, :)
5244 2622033 : dpm = tmp_deltaw_pm(1, iq_ibz, :)
5245 2622033 : sigma%deltaw_pm(:, ib_k, imyp, ibsum_kq, imyq, 1) = dpm / weight
5246 : end if
5247 :
5248 : end do
5249 : end do
5250 : end do
5251 : end do
5252 :
5253 150 : ABI_FREE(tmp_deltaw_pm)
5254 :
5255 : else
5256 : ! Both real and imag part --> compute \int 1/z with tetrahedron.
5257 : ! Note that we still need a finite i.eta in the expression (hopefully smaller than the default value).
5258 : ! Besides we have to take into account the case in which the spectral function is wanted.
5259 : ! Derivative wrt omega is still computed with finite i.eta, though.
5260 6 : ABI_CHECK(.not. sigma%use_doublegrid, "double grid for Re-Im not implemented")
5261 :
5262 : ! TODO: This part should be tested.
5263 6 : nz = 1; if (sigma%nwr > 0) nz = 1 + sigma%nwr
5264 48 : ABI_REMALLOC(sigma%cweights, (nz,2,nbcalc_ks,sigma%my_npert,sigma%my_bsum_start:sigma%my_bsum_stop,sigma%my_nqibz_k,ndiv))
5265 30 : ABI_MALLOC(tmp_cweights, (nz, 2, nbcalc_ks, sigma%nqibz_k))
5266 :
5267 : ! Initialize z-points for Sigma_{nk} for different n bands.
5268 24 : ABI_MALLOC(zvals, (nz, nbcalc_ks))
5269 54 : zvals(1, :) = sigma%e0vals + sigma%ieta
5270 3270 : if (sigma%nwr > 0) zvals(2:sigma%nwr+1, :) = sigma%wrmesh_b(:, 1:nbcalc_ks) + sigma%ieta
5271 :
5272 : ! Loop over my bands in self-energy sum.
5273 : ! TODO: Really slow if nz >> 1. Possible solutions:
5274 : ! 1) reduce the number of ibsum_kq bands for which tetra must be used.
5275 : ! 2) use spline with non-linear mesh
5276 : ! 3) use asyntotic expansion at "large" z
5277 194 : do ibsum_kq=sigma%my_bsum_start, sigma%my_bsum_stop
5278 : ! Loop over my phonon modes
5279 1322 : do imyp=1,sigma%my_npert
5280 1128 : nu = sigma%my_pinfo(3, imyp)
5281 :
5282 : ! cweights(nz, 2, nbsigma, self%nq_k)
5283 : call sigma%ephwg%get_zinv_weights(nz, nbcalc_ks, zvals, ibsum_kq, spin, nu, sigma%zinv_opt, tmp_cweights, &
5284 1128 : xmpi_comm_self)
5285 : !sigma%qpt_comm%value)
5286 : !erange=
5287 : !use_bzsum=sigma%symsigma == 0)
5288 :
5289 : ! Extract weights for all the q-points that I am going to calculate.
5290 13160 : do imyq=1,sigma%my_nqibz_k
5291 11844 : iq_ibz = sigma%myq2ibz_k(imyq)
5292 11844 : weight = sigma%ephwg%lgk%weights(iq_ibz)
5293 8631372 : sigma%cweights(:, :, :, imyp, ibsum_kq, imyq, 1) = tmp_cweights(:, :, :, iq_ibz) / weight
5294 : end do
5295 : end do
5296 : end do
5297 :
5298 6 : ABI_FREE(zvals)
5299 6 : ABI_FREE(tmp_cweights)
5300 : end if
5301 :
5302 156 : call cwtime_report(" get_all_qweights with tetrahedron", cpu, wall, gflops)
5303 :
5304 156 : end subroutine sigmaph_get_all_qweights
5305 : !!***
5306 :
5307 : !!****f* m_sigmaph/qpoints_oracle
5308 : !! NAME
5309 : !! qpoints_oracle
5310 : !!
5311 : !! FUNCTION
5312 : !! This function tries to predict the **full** list of q-points in the BZ needed to compute the lifetimes
5313 : !! once we know sigma%nkcalc.
5314 : !! It uses an energy window computed from the max phonon frequency multiplied by sigma%phwinfact.
5315 : !!
5316 : !! INPUT
5317 : !! cryst=Crystalline structure
5318 : !! ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...)
5319 : !! qpts(3, nqpt)=
5320 : !! nqpt= Number of points in qpts
5321 : !! nqbz=Number of q-points in BZ.
5322 : !! qbz(3, nbz) = full BZ
5323 : !! comm=MPI communicator.
5324 : !!
5325 : !! OUTPUT
5326 : !! qselect(nqpt)
5327 : !!
5328 : !! SOURCE
5329 :
5330 16 : subroutine qpoints_oracle(sigma, dtset, cryst, ebands, qpts, nqpt, nqbz, qbz, qselect, comm)
5331 :
5332 : !Arguments ------------------------------------
5333 : !scalars
5334 : class(sigmaph_t),intent(in) :: sigma
5335 : type(dataset_type),intent(in) :: dtset
5336 : type(crystal_t),intent(in) :: cryst
5337 : type(ebands_t),intent(in) :: ebands
5338 : integer,intent(in) :: nqpt, nqbz, comm
5339 : !arrays
5340 : real(dp),intent(in) :: qpts(3,nqpt), qbz(3,nqbz)
5341 : integer,intent(out) :: qselect(nqpt)
5342 :
5343 : !Local variables ------------------------------
5344 : !scalars
5345 : integer,parameter :: master = 0
5346 : integer :: spin, ikcalc, ik_ibz, iq_bz, ierr, db_iqpt, ibsum_kq, ikq_ibz, ikq_bz
5347 : integer :: cnt, my_rank, nprocs, ib_k, band_ks, nkibz, nkbz, kq_rank, qptopt
5348 : real(dp) :: eig0nk, eig0mkq, ediff, cpu, wall, gflops
5349 : character(len=5000) :: msg
5350 16 : type(krank_t) :: krank, qrank
5351 : !arrays
5352 : integer :: g0(3), qptrlatt(3,3)
5353 16 : integer,allocatable :: qbz_count(:), qbz2qpt(:,:), bz2ibz(:,:)
5354 : real(dp) :: kq(3), kk(3)
5355 16 : real(dp),allocatable :: wtk(:), kibz(:,:), kbz(:,:)
5356 : ! *************************************************************************
5357 :
5358 16 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
5359 :
5360 16 : call cwtime(cpu, wall, gflops, "start")
5361 : call wrtout(std_out, &
5362 16 : sjoin(" qpoints_oracle: predicting number q-points for tau with eph_phwinfact:", ftoa(sigma%phwinfact)))
5363 :
5364 : ! Get full BZ associated to ebands
5365 : call kpts_ibz_from_kptrlatt(cryst, ebands%kptrlatt, ebands%kptopt, ebands%nshiftk, ebands%shiftk, &
5366 16 : nkibz, kibz, wtk, nkbz, kbz, bz2ibz=bz2ibz)
5367 16 : call cwtime_report(" kpts_ibz_from_kptrlatt", cpu, wall, gflops)
5368 :
5369 16 : ABI_FREE(wtk)
5370 16 : ABI_FREE(kibz)
5371 16 : ABI_CHECK(nkibz == ebands%nkpt, "nkibz != ebands%nkpt")
5372 :
5373 : ! Make full k-point rank arrays
5374 16 : call krank%init(nkbz, kbz)
5375 16 : call cwtime_report(" krank_new", cpu, wall, gflops)
5376 :
5377 : ! This loop is Expensive with a 288^3
5378 : ! qbz_count_loop completed. cpu: 03:16 [minutes] , wall: 03:16 [minutes] <<< TIME
5379 : ! qbz_count completed. cpu: 04:41 [minutes] , wall: 04:40 [minutes] <<< TIME
5380 115520 : ABI_ICALLOC(qbz_count, (nqbz))
5381 16 : cnt = 0
5382 32 : do spin=1,sigma%nsppol
5383 107 : do ikcalc=1,sigma%nkcalc
5384 75 : cnt = cnt + 1; if (mod(cnt, nprocs) /= my_rank) cycle ! MPI parallelism inside comm
5385 300 : kk = sigma%kcalc(:, ikcalc)
5386 75 : ik_ibz = sigma%kcalc2ibz(ikcalc, 1)
5387 471195 : do iq_bz=1,nqbz
5388 471104 : if (qbz_count(iq_bz) /= 0) cycle ! No need to check this q-point again.
5389 1869788 : kq = kk + qbz(:, iq_bz)
5390 467447 : kq_rank = krank%get_rank(kq)
5391 467447 : ikq_bz = krank%invrank(kq_rank)
5392 467447 : ABI_CHECK(ikq_bz > 0, sjoin("Cannot find kq: ", ktoa(kq)))
5393 467447 : ABI_CHECK(isamek(kq, kbz(:, ikq_bz), g0), "Wrong invrank")
5394 : !ikq_ibz = bz2ibz(ikq_bz,1)
5395 467447 : ikq_ibz = bz2ibz(1, ikq_bz)
5396 940445 : do ib_k=1,sigma%nbcalc_ks(ikcalc, spin)
5397 472923 : band_ks = ib_k + sigma%bstart_ks(ikcalc, spin) - 1
5398 472923 : eig0nk = ebands%eig(band_ks, ik_ibz, spin)
5399 1452855 : do ibsum_kq=sigma%bsum_start, sigma%bsum_stop
5400 508828 : eig0mkq = ebands%eig(ibsum_kq, ikq_ibz, spin)
5401 508828 : ediff = eig0nk - eig0mkq
5402 : ! Perform check on the energy difference to exclude this q-point.
5403 981751 : if (abs(ediff) <= sigma%phwinfact * sigma%wmax) qbz_count(iq_bz) = qbz_count(iq_bz) + 1
5404 : end do
5405 : end do
5406 : end do
5407 : end do
5408 : end do
5409 16 : call cwtime_report(" qbz_count_loop", cpu, wall, gflops)
5410 :
5411 16 : ABI_FREE(kbz)
5412 16 : ABI_FREE(bz2ibz)
5413 16 : call krank%free()
5414 :
5415 16 : call xmpi_sum(qbz_count, comm, ierr)
5416 16 : call cwtime_report(" qbz_count", cpu, wall, gflops)
5417 :
5418 : ! Get mapping QBZ --> List of q-points involved in e-ph scattering for e/h in pockets.
5419 : ! Assume qptopt == kptopt unless value is specified in input
5420 48 : ABI_MALLOC(qbz2qpt, (6, nqbz))
5421 :
5422 16 : qptrlatt = 0; qptrlatt(1,1) = sigma%ngqpt(1); qptrlatt(2,2) = sigma%ngqpt(2); qptrlatt(3,3) = sigma%ngqpt(3)
5423 16 : call qrank%from_kptrlatt(nqpt, qpts, qptrlatt, compute_invrank=.False.)
5424 16 : qptopt = ebands%kptopt; if (dtset%qptopt /= 0) qptopt = dtset%qptopt
5425 :
5426 16 : if (kpts_map("symrec", qptopt, cryst, qrank, nqbz, qbz, qbz2qpt) /= 0) then
5427 : write(msg, '(3a)' )&
5428 0 : "At least one of the q-points could not be generated from a symmetrical one in the DVDB.", ch10, &
5429 0 : "Action: check your DVDB file and use eph_task to interpolate the potentials on a denser q-mesh."
5430 0 : ABI_ERROR(msg)
5431 : end if
5432 16 : call qrank%free()
5433 :
5434 16 : call cwtime_report(" oracle_listkk_qbz_qpts", cpu, wall, gflops)
5435 :
5436 : ! Compute qselect using qbz2qpt.
5437 3532 : qselect = 0
5438 115488 : do iq_bz=1,nqbz
5439 115472 : if (qbz_count(iq_bz) == 0) cycle
5440 1477 : db_iqpt = qbz2qpt(1, iq_bz)
5441 115488 : qselect(db_iqpt) = qselect(db_iqpt) + 1
5442 : end do
5443 :
5444 16 : ABI_FREE(qbz_count)
5445 16 : ABI_FREE(qbz2qpt)
5446 :
5447 16 : if (my_rank == master) then
5448 3532 : cnt = count(qselect /= 0)
5449 16 : write(std_out, "(a, i0, a, f5.1, a)")" qpoints_oracle: calculation of tau_nk will need: ", cnt, &
5450 32 : " q-points in the IBZ. (nqibz_eff / nqibz): ", (100.0_dp * cnt) / sigma%nqibz, " [%]"
5451 : end if
5452 :
5453 112 : end subroutine qpoints_oracle
5454 : !!***
5455 :
5456 : !!****f* m_epthk/frohl_integrator_init
5457 : !! FUNCTION
5458 : !! Initialize the Frohlich integrator.
5459 : !!
5460 : !! INPUTS
5461 : !!
5462 : !! SOURCE
5463 :
5464 0 : subroutine frohl_integrator_init(new, cryst, ifc, ntheta, comm)
5465 :
5466 : use m_lebedev, only : lebedev_t
5467 :
5468 : !Arguments ------------------------------------
5469 : class(frohl_integrator_t),intent(out) :: new
5470 : type(crystal_t),intent(in) :: cryst
5471 : type(ifc_type),intent(in) :: ifc
5472 : integer,intent(in) :: ntheta, comm
5473 :
5474 : !Local variables ------------------------------
5475 : integer :: iang, my_rank, nprocs
5476 : !************************************************************************
5477 :
5478 : ! Set angular mesh for numerical integration inside micro BZ around Gamma.
5479 0 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
5480 0 : new%ntheta = ntheta; new%nphi = 2 * new%ntheta
5481 : !write(std_out,"(a)")" Activating computation of Frohlich self-energy:"
5482 : !write(std_out,"(2(a,i0,1x))")" ntheta: ", new%ntheta, "nphi: ", new%nphi
5483 :
5484 : ! Initialize angular mesh qvers_cart and angwgth
5485 : ! NB: summing over f * angwgth gives the spherical average 1/(4pi) \int domega f(omega)
5486 0 : call ylm_angular_mesh(new%ntheta, new%nphi, new%angl_size, new%qvers_cart, new%angwgth)
5487 0 : write(std_out, *) sum(new%angwgth) * four_pi, "should be one"
5488 0 : write(std_out, *) sum(new%angwgth), "should be one"
5489 0 : stop
5490 :
5491 : !call lebedev%from_npts(npts, ierr)
5492 : !ABI_CHECK(ierr = 0, "Error while initializing lebedev mesh.")
5493 :
5494 : ! Precompute ph frequencies and displacement including NAC terms.
5495 : ABI_MALLOC(new%phfrq, (cryst%natom * 3, new%angl_size))
5496 : ABI_MALLOC(new%displ_cart, (2, 3, cryst%natom, cryst%natom * 3, new%angl_size))
5497 :
5498 : do iang=1,new%angl_size
5499 : !if (mod(iang, nprocs) /= my_rank) cycle ! MPI parallelism
5500 : call ifc%fourq(cryst, new%qvers_cart(:, iang) , new%phfrq(:,iang), new%displ_cart(:,:,:,:,iang), nanaqdir="cart")
5501 : end do
5502 :
5503 : end subroutine frohl_integrator_init
5504 : !!***
5505 :
5506 0 : subroutine frohl_integrator_eval_isotropic_avg(self, cryst, ifc, comm, avg_value)
5507 : class(frohl_integrator_t),intent(in) :: self
5508 : type(crystal_t),intent(in) :: cryst
5509 : type(ifc_type),intent(in) :: ifc
5510 : integer,intent(in) :: comm
5511 : real(dp),intent(out) :: avg_value(cryst%natom * 3)
5512 :
5513 : !Local variables ------------------------------
5514 : integer :: iang, iatom, nu, natom3, my_rank, nprocs, ierr
5515 : real(dp) :: inv_qepsq2, wqnu, qzd2, inv_wqnu2
5516 : complex(dp) :: cnum, cp3(3)
5517 : !************************************************************************
5518 :
5519 0 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
5520 0 : natom3 = 3 * cryst%natom
5521 0 : avg_value = zero
5522 :
5523 0 : do iang=1,self%angl_size
5524 0 : if (mod(iang, nprocs) /= my_rank) cycle ! MPI parallelism
5525 0 : associate (qpt_cart => self%qvers_cart(:, iang), displ_cart => self%displ_cart(:,:,:,:,iang))
5526 0 : inv_qepsq2 = (one / dot_product(qpt_cart, matmul(ifc%dielt, qpt_cart))) ** 2
5527 :
5528 : ! NB: Acoustic modes are ignored here
5529 0 : do nu=4,natom3
5530 0 : wqnu = self%phfrq(nu, iang); inv_wqnu2 = one / wqnu ** 2
5531 : ! cnum = q.\sum_k Z_k.d(q,nu)
5532 0 : cp3 = czero
5533 0 : do iatom=1, cryst%natom
5534 0 : cp3 = cp3 + matmul(ifc%zeff(:, :, iatom), cmplx(displ_cart(1,:,iatom, nu), displ_cart(2,:,iatom, nu), kind=dp))
5535 : end do
5536 0 : cnum = dot_product(qpt_cart, cp3); qzd2 = abs(cnum) ** 2
5537 0 : avg_value(nu) = avg_value(nu) + self%angwgth(iang) * qzd2 * inv_qepsq2 * inv_wqnu2
5538 : end do
5539 : end associate
5540 : end do ! iang
5541 0 : call xmpi_sum(avg_value, comm, ierr)
5542 :
5543 0 : end subroutine frohl_integrator_eval_isotropic_avg
5544 : !!***
5545 :
5546 : !!****f* m_epthk/frohl_integrator_find_mesh
5547 : !! NAME
5548 : !!
5549 : !! FUNCTION
5550 : !! Find mesh size needed to converge the angular integrals
5551 : !!
5552 : !! SOURCE
5553 :
5554 : subroutine frohl_integrator_find_mesh(cryst, ifc, ntheta, comm)
5555 :
5556 : !Arguments ------------------------------------
5557 : type(crystal_t),intent(in) :: cryst
5558 : type(ifc_type),intent(in) :: ifc
5559 : integer,intent(out) :: ntheta
5560 : integer,intent(in) :: comm
5561 :
5562 : !Local variables ------------------------------
5563 : integer :: iter, my_rank, nprocs
5564 : integer, parameter :: max_iter = 20
5565 : type(frohl_integrator_t) :: frohl
5566 : real(dp) :: REL_TOL = 0.02_dp
5567 : real(dp) :: new_value, old_value, avg_value_ph(3*cryst%natom)
5568 : logical :: converged
5569 : !************************************************************************
5570 :
5571 : ! Increment ntheta by 50 at each iteration. Stop when the value of the integral changes less than REL_TOL.
5572 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
5573 :
5574 : if (my_rank == 0) then
5575 : call wrtout(std_out, " frohl_integrator_find_mesh: find angular mesh to converge spherical average of Frohlich divergence...")
5576 : end if
5577 : converged = .False.; iter = 0; old_value = huge(old_value)
5578 :
5579 : outer_loop: do while (.not. converged .and. iter < max_iter)
5580 : iter = iter + 1
5581 : ntheta = iter * 2
5582 : call frohl%init(cryst, ifc, ntheta, comm)
5583 :
5584 : call frohl%eval_isotropic_avg(cryst, ifc, comm, avg_value_ph)
5585 : new_value = sum(avg_value_ph)
5586 :
5587 : if (my_rank == 0) then
5588 : write(std_out, "(a,i0,a,i0,a,i0,a,es16.8)") &
5589 : " frohl_integrator_find_mesh: iter: ", iter, " ntheta: ", ntheta, " angl_size: ", frohl%angl_size, " value: ", new_value
5590 : end if
5591 :
5592 : if (iter > 1) then
5593 : converged = (abs(new_value - old_value) <= (old_value * REL_TOL))
5594 : end if
5595 : old_value = new_value
5596 : call frohl%free()
5597 : end do outer_loop
5598 :
5599 : call frohl%free()
5600 :
5601 : if (.not. converged) then
5602 : ABI_ERROR("frohl_integrator_find_mesh didn't converge")
5603 : end if
5604 :
5605 : end subroutine frohl_integrator_find_mesh
5606 : !!***
5607 :
5608 : !!****f* m_epthk/frohl_integrator_eval
5609 : !! NAME
5610 : !!
5611 : !! FUNCTION
5612 : !!
5613 : !! INPUTS
5614 : !!
5615 : !! OUTPUT
5616 : !!
5617 : !! SOURCE
5618 :
5619 : !! subroutine frohl_integrator_eval(self, cryst, ifc, nqbz, nwr, ntemp, nk_size, e_nk, f_nk, kTmesh, sig0_nk, z0_nk, comm)
5620 : !!
5621 : !! !Arguments ------------------------------------
5622 : !! class(frohl_integrator_t),intent(in) :: self
5623 : !! type(crystal_t),intent(in) :: cryst
5624 : !! type(ifc_type),intent(in) :: ifc
5625 : !! integer,intent(in) :: nqbz, nwr, ntemp, nk_size
5626 : !! real(dp),intent(in) :: kTmesh(ntemp)
5627 : !! real(dp),intent(in) :: e_nk(nk_size), f_nk(nk_size, ntemp)
5628 : !! real(dp),intent(out) :: sig0_nk(nk_size, ntemp), z0_nk(nk_size, ntemp) !, fm(nwr, ntemp, nk_size)
5629 : !! integer,intent(in) :: comm
5630 : !!
5631 : !! !Local variables ------------------------------
5632 : !! !scalars
5633 : !! integer,parameter :: master = 0
5634 : !! integer :: iang, nu, iatom, ierr, my_rank, nprocs, natom3, ink, itemp
5635 : !! real(dp) :: inv_qepsq2, q0rad, wqnu, inv_wqnu2, qzd2
5636 : !! complex(dp) :: cnum
5637 : !! !arrays
5638 : !! complex(dp) :: cp3(3)
5639 : !! !************************************************************************
5640 : !!
5641 : !! my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
5642 : !! natom3 = 3 * cryst%natom
5643 : !!
5644 : !! ! Radius of sphere with volume equivalent to the micro zone.
5645 : !! q0rad = two_pi * (three / (four_pi * cryst%ucvol * nqbz)) ** third
5646 : !! !bz_vol = two_pi**3 / cryst%ucvol
5647 : !!
5648 : !! sig0_nk = zero; z0_nk = zero
5649 : !!
5650 : !! ! Angular integration
5651 : !! do iang=1,self%angl_size
5652 : !! if (mod(iang, nprocs) /= my_rank) cycle ! MPI parallelism
5653 : !! associate (qpt_cart => self%qvers_cart(:, iang), displ_cart => self%displ_cart(:,:,:,:,iang))
5654 : !! inv_qepsq2 = (one / dot_product(qpt_cart, matmul(ifc%dielt, qpt_cart))) ** 2
5655 : !! !call ifc%fourq(cryst, qpt_cart, phfrq, displ_cart, nanaqdir="cart")
5656 : !!
5657 : !! ! NB: Acoustic modes are ignored here
5658 : !! do nu=4,natom3
5659 : !! wqnu = self%phfrq(nu, iang) !; if (ephtk_skip_phmode(nu, wqnu, self%phmodes_skip, dtset%eph_phrange_w)) cycle
5660 : !! inv_wqnu2 = one / wqnu ** 2
5661 : !!
5662 : !! ! cnum = q.\sum_k Z_k.d(q,nu)
5663 : !! cp3 = czero
5664 : !! do iatom=1, cryst%natom
5665 : !! cp3 = cp3 + matmul(ifc%zeff(:, :, iatom), cmplx(displ_cart(1,:,iatom, nu), displ_cart(2,:,iatom, nu), kind=dp))
5666 : !! end do
5667 : !! cnum = dot_product(qpt_cart, cp3); qzd2 = abs(cnum) ** 2
5668 : !!
5669 : !! ! Compute spherical average.
5670 : !! !zpr_frohl_sphcorr(nu) = zpr_frohl_sphcorr(nu) + self%angwgth(iang) * abs(cnum) ** 2 * inv_qepsq2 / wqnu ** 2
5671 : !!
5672 : !! do ink=1,nk_size
5673 : !! do itemp=1,ntemp
5674 : !! sig0_nk(ink, itemp) = sig0_nk(ink, itemp) + self%angwgth(iang) * qzd2 * inv_qepsq2 * inv_wqnu2
5675 : !! !z0_nk(ink, itemp) = z0_nk(ink, itemp) +
5676 : !! end do ! itemp
5677 : !! end do ! ink
5678 : !!
5679 : !! ! Get phonon occupation for all temperatures.
5680 : !! !nqnu_tlist = occ_be(wqnu, kTmesh(:), zero)
5681 : !!
5682 : !! if (nwr > 0) then
5683 : !! ! ! NB: summing over f * angwgth gives the spherical average 1/(4pi) \int domega f(omega)
5684 : !! ! weight = four_pi * self%angwgth(iang) * abs(cnum) ** 2 * inv_qepsq2 / wqnu
5685 : !! ! do ib_k=1,nbcalc_ks
5686 : !! ! band_ks = ib_k + bstart_ks - 1; eig0nk = ebands%eig(band_ks, ik_ibz, spin)
5687 : !! ! do it=1,sigma%ntemp
5688 : !! ! f_nk = f_tlist_b(it,ib_k)
5689 : !! ! nqnu = nqnu_tlist(it)
5690 : !! ! fmw_frohl_sphcorr(:,nu,it,ib_k) = fmw_frohl_sphcorr(:,nu,it,ib_k) + &
5691 : !! ! ((nqnu + f_nk ) / (sigma%wrmesh_b(:,ib_k) - eig0nk + wqnu + sigma%ieta) + &
5692 : !! ! (nqnu - f_nk + one) / (sigma%wrmesh_b(:,ib_k) - eig0nk - wqnu + sigma%ieta) ) * weight
5693 : !! ! end do ! it
5694 : !! ! end do ! ib_k
5695 : !! end if
5696 : !!
5697 : !! end do
5698 : !! end associate
5699 : !! end do ! iang
5700 : !!
5701 : !! do ink=1,nk_size
5702 : !! do itemp=1,ntemp
5703 : !! sig0_nk(ink, itemp) = sig0_nk(ink, itemp) * q0rad / (pi * cryst%ucvol) * (two * f_nk(ink, itemp) - one)
5704 : !! !z0_nk(ink, itemp) = z0_nk(ink, itemp) +
5705 : !! end do ! itemp
5706 : !! end do ! ink
5707 : !!
5708 : !! call xmpi_sum(sig0_nk, comm, ierr)
5709 : !! call xmpi_sum(z0_nk, comm, ierr)
5710 : !!
5711 : !! end subroutine frohl_integrator_eval
5712 : !!***
5713 :
5714 : !!****f* m_epthk/frohl_integrator_free
5715 : !! NAME
5716 : !!
5717 : !! FUNCTION
5718 : !! Free dynamical memory
5719 : !!
5720 : !! SOURCE
5721 :
5722 0 : subroutine frohl_integrator_free(self)
5723 :
5724 : !Arguments ------------------------------------
5725 : class(frohl_integrator_t),intent(inout) :: self
5726 : !************************************************************************
5727 :
5728 0 : ABI_SFREE(self%qvers_cart)
5729 0 : ABI_SFREE(self%angwgth)
5730 0 : ABI_SFREE(self%phfrq)
5731 0 : ABI_SFREE(self%displ_cart)
5732 :
5733 0 : end subroutine frohl_integrator_free
5734 : !!***
5735 :
5736 0 : end module m_sigmaph
5737 : !!***
|
