Branch data 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. abs(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"), & ! 1 if the results for (kcalc, spin) are in the file (restart).
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,kse_val,kse_cond,qpe_oms,qpe_oms_val,qpe_oms_cond
4581 : : real(dp) :: ks_gap
4582 : : ! Direct KS gap at this k-point: eKS(ib_cond) - eKS(ib_val) with ib_val = nint(nelect / (2 / nspinor))
4583 : : ! and ib_cond = ib_val + 1 (non-magnetic semiconductor). -1 if one of the two bands is not computed. Ha units.
4584 : : real(dp) :: cpu, wall, gflops, invsig2fmts, tau, ravg2
4585 : : complex(dp) :: sig0c,zc,qpe,qpe_prev,qpe_val,qpe_cond,cavg1,cavg2,cavg3,cavg4,cavg5,cavg6
4586 : : !character(len=5000) :: msg
4587 : : integer :: grp_ncid, ncerr
4588 : : !arrays
4589 : 182 : integer, allocatable :: recvcounts(:), displs(:), nq_rank(:), kq_symtab(:,:), my_kq_symtab(:,:)
4590 : 182 : integer, contiguous, pointer :: bids(:)
4591 : 364 : real(dp) :: qp_gaps(self%ntemp), qpoms_gaps(self%ntemp)
4592 : : ! (ntemp) Direct QP gap at this k-point: eQP(ib_cond) - eQP(ib_val) (see ks_gap) computed with the linearized
4593 : : ! QP energies (qp_gaps) or with the on-the-mass-shell ones (qpoms_gaps).
4594 : : ! -1 if one of the two bands is not computed. Ha units.
4595 : 182 : real(dp),allocatable :: aw(:,:,:)
4596 : : ! aw(nwr, ntemp, max_nbcalc)
4597 : : ! Spectral function A(w) = -1/pi Im Sigma(w) / ((w - eKS - Re Sigma(w))**2 + Im Sigma(w)**2)
4598 : : ! on the frequency mesh wrmesh_b. 1/Ha units.
4599 : 182 : real(dp),allocatable :: a2few_avg(:,:), gather_srate(:,:,:,:), grp_srate(:,:,:,:)
4600 : : ! Work arrays.
4601 : 364 : real(dp) :: ks_enes(self%max_nbcalc)
4602 : : ! (max_nbcalc) KS energies of the bands bstart_ks + ibc - 1 with ibc = 1, nbcalc_ks. Ha units.
4603 : : ! The entries beyond nbcalc_ks are set to huge(one) * tol6.
4604 : 364 : real(dp) :: ze0_vals(self%ntemp, self%max_nbcalc)
4605 : : ! (ntemp, max_nbcalc) Renormalization factor Z = 1 / (1 - d Re Sigma(omega) / d omega) at omega = eKS.
4606 : : ! The entries beyond nbcalc_ks are set to huge(one) * tol6.
4607 : 364 : real(dp) :: gfw_avg(self%phmesh_size, 3)
4608 : : ! Eliashberg functions averaged over the degenerate states.
4609 : 364 : complex(dp) :: qpoms_enes(self%ntemp, self%max_nbcalc)
4610 : : ! (ntemp, max_nbcalc) QP energies in the on-the-mass-shell approximation: eKS + Re Sigma(eKS).
4611 : : ! Complex with zero imaginary part. The entries beyond nbcalc_ks are set to huge(one) * tol6. Ha units.
4612 : 364 : complex(dp) :: qp_enes(self%ntemp, self%max_nbcalc)
4613 : : ! (ntemp, max_nbcalc) Linearized QP energies: eKS + Z * Re Sigma(eKS) with Z = ze0_vals.
4614 : : ! Complex with zero imaginary part. The entries beyond nbcalc_ks are set to huge(one) * tol6. Ha units.
4615 : : ! *************************************************************************
4616 : :
4617 : : ! Could use non-blocking communications and double buffer technique to reduce synchronisation cost...
4618 : 182 : call cwtime(cpu, wall, gflops, "start", msg=" Gathering results. Waiting for other MPI processes...")
4619 : :
4620 : : ! Here comm corresponds to sigma%pqb_comm%value
4621 : 182 : my_rank = xmpi_comm_rank(comm)
4622 : 182 : iwrite = self%ncwrite_comm%value /= xmpi_comm_null
4623 : 182 : call xmpi_sum_master(self%vals_e0ks, master, comm, ierr)
4624 : 182 : call xmpi_sum_master(self%fan_vals, master, comm, ierr)
4625 : 182 : call xmpi_sum_master(self%E4_vals, master, comm, ierr)
4626 : 182 : call xmpi_sum_master(self%E4_vals2, master, comm, ierr)
4627 : 182 : call xmpi_sum_master(self%fan_stern_vals, master, comm, ierr)
4628 : 182 : call xmpi_sum_master(self%dvals_de0ks, master, comm, ierr)
4629 : 182 : call xmpi_sum_master(self%dw_vals, master, comm, ierr)
4630 : 182 : call xmpi_sum_master(self%dw_stern_vals, master, comm, ierr)
4631 [ + + ]: 182 : if (self%nwr > 0) call xmpi_sum_master(self%vals_wr, master, comm, ierr)
4632 [ + + ]: 182 : if (self%mrta > 0) call xmpi_sum_master(self%linewidth_mrta, master, comm, ierr)
4633 [ + + ]: 182 : if (dtset%eph_prtscratew == 1) then
4634 : : ! Collect spectral decomposition of scattering rates, multiply by two since so far we have stored Imag(Sigma) (ph_w)
4635 : 3 : call xmpi_sum_master(self%scratew, master, comm, ierr)
4636 [ + + + + : 90999 : self%scratew = two * self%scratew
+ + + + ]
4637 : : end if
4638 : :
4639 [ + + ]: 182 : if (dtset%ibte_prep > 0) then
4640 : : ! FIXME: Handle kpoint/spin parallelism.
4641 : : ! (%bsum_start:%bsum_stop, %nbcalc_ks(ikcalc, spin), %ntemp, %nqibz_k))
4642 : : ! Sum over phonon modes
4643 : 6 : call xmpi_sum(self%srate, self%pert_comm%value, ierr)
4644 : : !call xmpi_sum(self%srate, self%pb_comm%value), ierr)
4645 : :
4646 : : ! Use gatherv to collect data and tables on the IO proc i.e. the master proc in qpt_comm.
4647 : : ! Only the number of q-points changes across the qpt-procs and this is the last dimension.
4648 : : ! nq_ibzk_eff is the total number of effective q-points in the IBZ(k).
4649 [ - + + - : 24 : ABI_CALLOC(nq_rank, (self%qpt_comm%nproc))
+ - + - -
+ - + +
+ ]
4650 : 6 : call xmpi_allgather(self%my_nqibz_k, nq_rank, self%qpt_comm%value, ierr)
4651 : :
4652 [ + + ]: 12 : nq_ibzk_eff = sum(nq_rank)
4653 : 6 : nelem = self%nbsum * self%nbcalc_ks(ikcalc, spin) * self%ntemp
4654 : : !call self%qpt_comm%prep_gatherv(nelem, nq_rank, recvcounts, displs)
4655 [ - + + - : 18 : ABI_MALLOC(recvcounts, (self%qpt_comm%nproc))
+ - + - -
+ - + ]
4656 [ - + + - : 12 : ABI_MALLOC(displs, (self%qpt_comm%nproc))
- + - + ]
4657 : :
4658 [ + - - + : 18 : recvcounts = nelem * nq_rank(:)
- - + + ]
4659 : 6 : displs(1) = 0
4660 [ - + ]: 6 : do ii=2,self%qpt_comm%nproc
4661 [ - - ]: 6 : displs(ii) = sum(nq_rank(1:ii-1)) * nelem
4662 : : end do
4663 : :
4664 [ - + + - : 36 : ABI_MALLOC(gather_srate, (self%bsum_start:self%bsum_stop, self%nbcalc_ks(ikcalc, spin), self%ntemp, nq_ibzk_eff))
- + + - -
+ + - - +
+ - + - +
- - + -
+ ]
4665 : :
4666 : 6 : call xmpi_gatherv(self%srate, nelem * self%my_nqibz_k, gather_srate, recvcounts, displs, master, self%qpt_comm%value, ierr)
4667 : : !ABI_CHECK(all(abs(gather_srate - self%srate) < tol12), "This only if nproc == 1")
4668 : : !ABI_CHECK(nq_ibzk_eff == self%my_nqibz_k, "This only if nproc == 1")
4669 : :
4670 [ - + ]: 6 : if (.not. iwrite) then
4671 [ # # ]: 0 : ABI_FREE(gather_srate)
4672 : : end if
4673 : :
4674 [ - + + - : 18 : ABI_MALLOC(my_kq_symtab, (6, self%my_nqibz_k))
+ - + - -
+ - + ]
4675 [ + + ]: 9187 : do imyq=1,self%my_nqibz_k
4676 : 9181 : iq_ibz_k = self%myq2ibz_k(imyq)
4677 [ + + ]: 64273 : my_kq_symtab(:, imyq) = self%indkk_kq(:, iq_ibz_k)
4678 : : end do
4679 : :
4680 : : !call self%qpt_comm%prep_gatherv(nelem, nq_rank, recvcounts, displs)
4681 : 6 : displs(1) = 0; nelem = 6
4682 [ - + ]: 6 : do ii=2,self%qpt_comm%nproc
4683 [ - - ]: 6 : displs(ii) = sum(nq_rank(1:ii-1)) * nelem
4684 : : end do
4685 [ + - - + : 18 : recvcounts = nq_rank * nelem
- - + + ]
4686 : :
4687 [ - + + - : 18 : ABI_MALLOC(kq_symtab, (nelem, nq_ibzk_eff))
+ - + - -
+ - + ]
4688 : 6 : call xmpi_gatherv(my_kq_symtab, nelem * self%my_nqibz_k, kq_symtab, recvcounts, displs, master, self%qpt_comm%value, ierr)
4689 : : !ABI_CHECK(all(abs(kq_symtab - my_kq_symtab) < tol12), "kq_symtab")
4690 : :
4691 [ - + ]: 6 : if (.not. iwrite) then
4692 [ # # ]: 0 : ABI_FREE(kq_symtab)
4693 : : end if
4694 : :
4695 [ - + ]: 6 : ABI_FREE(nq_rank)
4696 [ - + ]: 6 : ABI_FREE(my_kq_symtab)
4697 [ - + ]: 6 : ABI_FREE(recvcounts)
4698 : 18 : ABI_FREE(displs)
4699 : : end if
4700 : :
4701 : 182 : call cwtime_report(" Sigma_nk gather", cpu, wall, gflops, comm=comm)
4702 : :
4703 : : ! Only procs inside ncwrite_comm perform IO (ab_out and ncid)
4704 [ + - ]: 182 : if (.not. iwrite) return
4705 : :
4706 : 182 : ik_ibz = self%kcalc2ibz(ikcalc, 1)
4707 : :
4708 [ - + ]: 182 : if (self%a2f_ne > 0) then
4709 [ # # # # : 0 : ABI_MALLOC(a2few_avg, (self%a2f_ne, self%phmesh_size))
# # # # #
# # # # #
# # ]
4710 : : end if
4711 : :
4712 [ + + ]: 182 : if (self%symsigma == +1) then
4713 : : ! Average self-energy matrix elements in the degenerate subspace.
4714 [ + + ]: 630 : do ideg=1,size(self%degtab(ikcalc, spin)%bids)
4715 : 458 : bids => self%degtab(ikcalc, spin)%bids(ideg)%vals
4716 : 458 : nstates = size(bids)
4717 : :
4718 : : ! Symmetrize Eliashberg function
4719 [ + + ]: 458 : if (dtset%prteliash > 0) then
4720 [ + + + + : 1603855 : gfw_avg = sum(self%gfw_vals(:, :, bids(:)), dim=3) / nstates
+ + ]
4721 [ + + ]: 463 : do ii=1,nstates
4722 [ + + + + ]: 993697 : self%gfw_vals(:, :, bids(ii)) = gfw_avg
4723 : : end do
4724 [ - + ]: 175 : if (self%a2f_ne > 0) then
4725 [ # # # # : 0 : a2few_avg = sum(self%a2few(:, :, bids(:)), dim=3) / nstates
# # # # #
# # # #
# ]
4726 [ # # ]: 0 : do ii=1,nstates
4727 [ # # # # ]: 0 : self%a2few(:, :, bids(ii)) = a2few_avg
4728 : : end do
4729 : : end if
4730 : : end if
4731 : :
4732 [ + + ]: 2066 : do it=1,self%ntemp
4733 : : ! Average QP(T) and Z(T).
4734 [ + + ]: 3708 : cavg1 = sum(self%vals_e0ks(it, bids(:))) / nstates
4735 [ + + ]: 3708 : cavg2 = sum(self%dvals_de0ks(it, bids(:))) / nstates
4736 [ + + ]: 3708 : cavg3 = sum(self%fan_vals(it, bids(:))) / nstates
4737 [ + + ]: 3708 : cavg4 = sum(self%fan_stern_vals(it, bids(:))) / nstates
4738 [ + + ]: 3708 : cavg5 = sum(self%E4_vals(it, bids(:))) / nstates
4739 [ + + ]: 3708 : cavg6 = sum(self%E4_vals2(it, bids(:))) / nstates
4740 [ + + ]: 3708 : ravg = sum(self%dw_vals(it, bids(:))) / nstates
4741 [ + + ]: 3708 : ravg2 = sum(self%dw_stern_vals(it, bids(:))) / nstates
4742 [ + + ]: 3708 : do ii=1,nstates
4743 : 2272 : self%vals_e0ks(it, bids(ii)) = cavg1
4744 : 2272 : self%dvals_de0ks(it, bids(ii)) = cavg2
4745 : 2272 : self%fan_vals(it, bids(ii)) = cavg3
4746 : 2272 : self%fan_stern_vals(it, bids(ii)) = cavg4
4747 : 2272 : self%E4_vals(it, bids(ii)) = cavg5
4748 : 2272 : self%E4_vals2(it, bids(ii)) = cavg6
4749 : 2272 : self%dw_vals(it, bids(ii)) = ravg
4750 : 3708 : self%dw_stern_vals(it, bids(ii)) = ravg2
4751 : : end do
4752 : :
4753 : : ! Average TAU_MRTA
4754 [ + + ]: 1436 : if (self%mrta > 0) then
4755 [ + + ]: 1958 : ravg = sum(self%linewidth_mrta(it, bids(:))) / nstates
4756 [ + + ]: 1958 : do ii=1,nstates
4757 : 1958 : self%linewidth_mrta(it, bids(ii)) = ravg
4758 : : end do
4759 : : end if
4760 : :
4761 [ + + ]: 1894 : if (self%nwr > 0) then
4762 : : ! Average Sigma(omega, T)
4763 [ + + ]: 60964 : do iw=1,self%nwr
4764 [ + + ]: 158541 : cavg1 = sum(self%vals_wr(iw, it, bids(:))) / nstates
4765 [ + + ]: 159064 : do ii=1,nstates
4766 : 158541 : self%vals_wr(iw, it, bids(ii)) = cavg1
4767 : : end do
4768 : : end do ! iw
4769 : : end if
4770 : :
4771 : : end do ! it
4772 : : end do ! ideg
4773 : : end if ! symsigma == +1
4774 : :
4775 [ - + ]: 182 : ABI_SFREE(a2few_avg)
4776 : :
4777 : : ! Compute QP energies and Gaps (Note that I'm assuming a non-magnetic semiconductor!)
4778 : 182 : ib_val = nint(ebands%nelect / (two / ebands%nspinor)); ib_cond = ib_val + 1
4779 : 182 : kse_val = huge(one) * tol6; kse_cond = huge(one) * tol6
4780 [ + + + + : 7098 : qp_enes = huge(one) * tol6; qpoms_enes = huge(one) * tol6
+ + + + ]
4781 [ + + + + : 4510 : ks_enes = huge(one) * tol6; ze0_vals = huge(one) * tol6
+ + ]
4782 [ + + + + ]: 1352 : ks_gap = -one; qpoms_gaps = -one; qp_gaps = -one
4783 : :
4784 : : ! Write legend.
4785 [ + + + - ]: 182 : if (ikcalc == 1 .and. spin == 1) then
4786 : 58 : write(ab_out,"(a)")repeat("=", 80)
4787 : 58 : write(ab_out,"(a)")" Final results in eV."
4788 : 58 : write(ab_out,"(a)")" Notations:"
4789 : 58 : write(ab_out,"(a)")" eKS: Kohn-Sham energy. eQP: quasi-particle energy."
4790 : 58 : write(ab_out,"(a)")" eQP - eKS: Difference between the QP and the KS energy."
4791 : 58 : write(ab_out,"(a)")" SE1(eKS): Real part of the self-energy computed at the KS energy, SE2 for imaginary part."
4792 : 58 : write(ab_out,"(a)")" Z(eKS): Renormalization factor."
4793 : 58 : write(ab_out,"(a)")" FAN: Real part of the Fan term at eKS. DW: Debye-Waller term."
4794 : 58 : write(ab_out,"(a)")" DeKS: KS energy difference between this band and band-1, DeQP same meaning but for eQP."
4795 : 58 : write(ab_out,"(a)")" OTMS: On-the-mass-shell approximation with eQP ~= eKS + Sigma(omega=eKS)"
4796 : 58 : write(ab_out,"(a)")" TAU(eKS): Lifetime in femtoseconds computed at the KS energy."
4797 : 58 : write(ab_out,"(a)")" mu_e: Fermi level for given (T, nelect)"
4798 : 58 : write(ab_out,"(a)")" "
4799 : 58 : write(ab_out,"(a)")" "
4800 : : end if
4801 : :
4802 [ + + ]: 767 : do it=1,self%ntemp
4803 : :
4804 : : ! Write header.
4805 [ + - ]: 585 : if (it <= max_ntemp) then
4806 [ + - ]: 585 : if (self%nsppol == 1) then
4807 : : write(ab_out,"(3a,f6.1,a,f8.3)") &
4808 [ + - ]: 585 : "K-point: ", trim(ktoa(self%kcalc(:,ikcalc))), ", T: ", self%kTmesh(it) / kb_HaK, &
4809 : 1170 : " [K], mu_e: ", self%mu_e(it) * Ha_eV
4810 : : else
4811 : : write(ab_out,"(3a,i1,a,f6.1,a,f8.3)") &
4812 [ # # ]: 0 : "K-point: ", trim(ktoa(self%kcalc(:,ikcalc))), ", spin: ", spin, ", T: ",self%kTmesh(it) / kb_HaK, &
4813 : 0 : " [K], mu_e: ", self%mu_e(it) * Ha_eV
4814 : : end if
4815 [ + + ]: 585 : if (self%imag_only) then
4816 : 387 : write(ab_out,"(a)")" B eKS SE2(eKS) TAU(eKS) DeKS"
4817 : : else
4818 : 198 : write(ab_out,"(a)")" B eKS eQP eQP-eKS SE1(eKS) SE2(eKS) Z(eKS) FAN(eKS) DW DeKS DeQP"
4819 : : end if
4820 : : end if
4821 : :
4822 : : ! Loop over bands for this k-point and spin
4823 [ + + ]: 3033 : do ibc=1,self%nbcalc_ks(ikcalc, spin)
4824 : 2448 : band_ks = self%bstart_ks(ikcalc, spin) + ibc - 1
4825 : 2448 : kse = ebands%eig(band_ks, ik_ibz, spin)
4826 : 2448 : ks_enes(ibc) = kse
4827 : 2448 : sig0c = self%vals_e0ks(it, ibc)
4828 : 2448 : dw = self%dw_vals(it, ibc)
4829 : 2448 : fan0 = real(sig0c) - dw
4830 : : ! Compute QP energies with On-the-Mass-Shell approximation and first renormalization i.e. Z(eKS)
4831 : : ! TODO: Note that here I use the full Sigma including the imaginary part
4832 : : !zc = one / (one - self%dvals_de0ks(it, ibc))
4833 : 2448 : zc = one / (one - real(self%dvals_de0ks(it, ibc)))
4834 : 2448 : ze0_vals(it, ibc) = real(zc)
4835 : 2448 : qpe = kse + real(zc) * real(sig0c)
4836 : 2448 : qpe_oms = kse + real(sig0c)
4837 : 2448 : if (ibc == 1) then
4838 : 585 : kse_prev = kse; qpe_prev = qpe
4839 : : end if
4840 [ + + ]: 2448 : if (band_ks == ib_val) then
4841 : 389 : kse_val = kse; qpe_val = qpe; qpe_oms_val = qpe_oms
4842 : : end if
4843 [ + + ]: 2448 : if (band_ks == ib_cond) then
4844 : 532 : kse_cond = kse; qpe_cond = qpe; qpe_oms_cond = qpe_oms
4845 : : end if
4846 : :
4847 [ + - ]: 2448 : if (it <= max_ntemp) then
4848 [ + + ]: 2448 : if (self%imag_only) then
4849 : : ! 1/tau = 2 Imag(Sigma)
4850 : 1258 : invsig2fmts = Time_Sec * 1e+15 / two
4851 : 1258 : tau = 999999.0_dp
4852 [ + + ]: 1258 : if (abs(aimag(sig0c)) > tol16) tau = invsig2fmts / abs(aimag(sig0c))
4853 : 1258 : tau = min(tau, 999999.0_dp)
4854 : : write(ab_out, "(i4,2(f8.3,1x),f8.1,1x,f8.3)") &
4855 : 1258 : band_ks, kse * Ha_eV, aimag(sig0c) * Ha_eV, tau, (kse - kse_prev) * Ha_eV
4856 : : else
4857 : : write(ab_out, "(i4, 10(f8.3,1x))") &
4858 : 1190 : band_ks, kse * Ha_eV, real(qpe) * Ha_eV, (real(qpe) - kse) * Ha_eV, &
4859 [ + + ]: 3638 : real(sig0c) * Ha_eV, aimag(sig0c) * Ha_eV, real(zc), &
4860 : 2380 : fan0 * Ha_eV, dw * Ha_eV, (kse - kse_prev) * Ha_eV, real(qpe - qpe_prev) * Ha_eV
4861 : : end if
4862 : : end if
4863 : :
4864 [ + + ]: 2448 : if (ibc > 1) then
4865 : 1863 : kse_prev = kse; qpe_prev = qpe
4866 : : end if
4867 : 2448 : qpoms_enes(it, ibc) = qpe_oms
4868 : 2448 : qp_enes(it, ibc) = qpe
4869 [ + + ]: 3033 : if (kse_val /= huge(one) * tol6 .and. kse_cond /= huge(one) * tol6) then
4870 : : ! We have enough states to compute the gap.
4871 [ + + ]: 1739 : if (it == 1) ks_gap = kse_cond - kse_val
4872 : 1739 : qpoms_gaps(it) = qpe_oms_cond - qpe_oms_val
4873 : 1739 : qp_gaps(it) = real(qpe_cond - qpe_val)
4874 : : end if
4875 : : end do ! ibc
4876 : :
4877 : : ! Print KS and QP gaps.
4878 [ + - ]: 767 : if (it <= max_ntemp) then
4879 [ + + ]: 585 : if (.not. self%imag_only) then
4880 [ + + ]: 198 : if (kse_val /= huge(one) * tol6 .and. kse_cond /= huge(one) * tol6) then
4881 : 167 : write(ab_out, "(a)")" "
4882 : 167 : write(ab_out, "(a,f8.3,1x,2(a,i0),a)")" KS gap: ",ks_gap * Ha_eV, &
4883 : 334 : "(assuming bval:", ib_val, " ==> bcond:", ib_cond, ")"
4884 : 167 : write(ab_out, "(2(a,f8.3),a)")" QP gap: ",qp_gaps(it) * Ha_eV," (OTMS: ",qpoms_gaps(it) * Ha_eV, ")"
4885 : 167 : write(ab_out, "(2(a,f8.3),a)")" QP_gap - KS_gap: ",(qp_gaps(it) - ks_gap) * Ha_eV,&
4886 : 334 : " (OTMS: ",(qpoms_gaps(it) - ks_gap) * Ha_eV, ")"
4887 : 167 : write(ab_out, "(a)")" "
4888 : : end if
4889 : : else
4890 [ + + ]: 387 : if (kse_val /= huge(one) * tol6 .and. kse_cond /= huge(one) * tol6) then
4891 : 169 : write(ab_out, "(a)")" "
4892 : 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,")"
4893 : 169 : write(ab_out, "(a)")" "
4894 : : end if
4895 : : end if
4896 : :
4897 : 585 : write(ab_out, "(a)")repeat("=", 92)
4898 : : end if
4899 : :
4900 : : end do ! it
4901 : :
4902 [ - + - - : 182 : if (self%ntemp > max_ntemp .and. (ikcalc == 1 .and. spin == 1)) then
- - ]
4903 : 0 : write(ab_out, "(a,i0,a)")" No more than ", max_ntemp, " temperatures are written to the main output file."
4904 : 0 : write(ab_out, "(2a)")" Please use SIGEPH.nc file and AbiPy to analyze the results.",ch10
4905 : : end if
4906 : :
4907 [ + + + + : 182 : if (dtset%prtvol > 0 .and. (ikcalc == 1 .and. spin == 1)) then
+ - ]
4908 [ + + ]: 15 : if (allocated(self%gfw_vals)) then
4909 : 13 : write(ab_out, "(2a)")" omega and Eliashberg function gf_{nk}(omega) for testing purposes:"
4910 : 13 : iw = (self%phmesh_size / 2)
4911 [ + + ]: 73 : do ib=1,min(self%nbcalc_ks(ikcalc, spin), 5)
4912 : 60 : band_ks = self%bstart_ks(ikcalc, spin) + ib - 1
4913 : 60 : write(ab_out, "(a, i0)")"For band:", band_ks
4914 [ + + ]: 193 : do jj=0,1
4915 [ + - + + ]: 540 : write(ab_out, "(4(f8.3,2x))")self%phmesh(iw+jj), (self%gfw_vals(iw+jj, ii, ib), ii=1,3)
4916 : : end do
4917 : : end do
4918 : 13 : write(ab_out, "(a)")ch10
4919 : : end if
4920 : :
4921 [ + + ]: 15 : if (self%nwr >= 3) then
4922 : 14 : write(ab_out, "(2a)")ch10," omega and Sigma_nk(omega, T=1) in eV for testing purposes:"
4923 : 14 : it = 1; iw = (self%nwr / 2)
4924 [ + + ]: 77 : do ib=1,min(self%nbcalc_ks(ikcalc, spin), 5)
4925 : 63 : band_ks = self%bstart_ks(ikcalc, spin) + ib - 1
4926 : 63 : write(ab_out, "(a, i0)")"For band:", band_ks
4927 [ + + ]: 203 : do ii=0,1
4928 : 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
4929 : : end do
4930 : : end do
4931 : 14 : write(ab_out, "(a)")ch10
4932 : : end if
4933 : : end if
4934 : :
4935 : 182 : call flush_unit(ab_out)
4936 : :
4937 : : ! Write self-energy matrix elements for this (kpt, spin). NB: Only master writes
4938 [ + - + + : 1092 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "vals_e0ks"), c2r(self%vals_e0ks), start=[1,1,1,ikcalc,spin]))
- + - - -
- ]
4939 [ + - + + : 1092 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "fan_vals"), c2r(self%fan_vals), start=[1,1,1,ikcalc,spin]))
- + - - -
- ]
4940 [ + - + + : 1092 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "E4_vals"), c2r(self%E4_vals), start=[1,1,1,ikcalc,spin]))
- + - - -
- ]
4941 [ + - + + : 1092 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "E4_vals2"), c2r(self%E4_vals2), start=[1,1,1,ikcalc,spin]))
- + - - -
- ]
4942 [ + - + + : 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]))
- + - - -
- ]
4943 [ + - + + : 1092 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "dvals_de0ks"), c2r(self%dvals_de0ks), start=[1,1,1,ikcalc,spin]))
- + - - -
- ]
4944 [ + + - + : 910 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "dw_vals"), self%dw_vals, start=[1,1,ikcalc,spin]))
- - ]
4945 [ + + - + : 910 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "dw_stern_vals"), self%dw_stern_vals, start=[1,1,ikcalc,spin]))
- - ]
4946 : : ! Dump QP energies and gaps for this (kpt, spin)
4947 [ + - + + : 1092 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "qpoms_enes"), c2r(qpoms_enes), start=[1,1,1,ikcalc,spin]))
- + - - ]
4948 : :
4949 [ - + ]: 182 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "E2"), self%E2, start=[1]))
4950 [ + + - + : 1092 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "qp_enes"), c2r(qp_enes), start=[1,1,1,ikcalc,spin]))
- - ]
4951 [ + + - + : 910 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "ze0_vals"), ze0_vals, start=[1,1,ikcalc,spin]))
- - ]
4952 [ + + - + : 728 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "ks_enes"), ks_enes, start=[1,ikcalc,spin]))
- - ]
4953 [ + + - + : 546 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "ks_gaps"), ks_gap, start=[ikcalc,spin]))
- - ]
4954 [ + + - + : 728 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "qpoms_gaps"), qpoms_gaps, start=[1,ikcalc,spin]))
- - ]
4955 [ + + - + : 728 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "qp_gaps"), qp_gaps, start=[1,ikcalc,spin]))
- - ]
4956 : :
4957 [ + + ]: 182 : if (self%mrta > 0) then
4958 [ + + - + : 560 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "linewidth_mrta"), self%linewidth_mrta, start=[1,1,ikcalc,spin]))
- - ]
4959 : : end if
4960 : :
4961 [ + + ]: 182 : if (dtset%eph_prtscratew == 1) then
4962 [ + + - + : 21 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "scratew"), self%scratew, start=[1,1,1,1,ikcalc,spin]))
- - ]
4963 : : end if
4964 : :
4965 : : !if (self%frohl_model == 1 .and. self%imag_only) then
4966 : : ! ncerr = nf90_put_var(self%ncid, nctk_idname(self%ncid, "frohl_deltas_sphcorr"), &
4967 : : ! self%frohl_deltas_sphcorr, start=[1,1,1,1, ikcalc, spin])
4968 : : ! NCF_CHECK(ncerr)
4969 : : !end if
4970 : :
4971 : : ! Write frequency dependent data.
4972 [ + + ]: 182 : if (self%nwr > 0) then
4973 [ + + - + : 260 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "wrmesh_b"), self%wrmesh_b, start=[1,1,ikcalc,spin]))
- - ]
4974 [ + - + + : 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]))
- + - - -
- ]
4975 : :
4976 : : ! Compute spectral function. A = -1/pi [Im Sigma(ww)] / ([ww - ee - Re Sigma(ww)] ** 2 + Im Sigma(ww) ** 2])
4977 [ - + + - : 260 : ABI_MALLOC(aw, (self%nwr, self%ntemp, self%max_nbcalc))
- + + - -
+ + - + -
+ - - + -
+ - + ]
4978 [ + + ]: 336 : do ib=1,self%nbcalc_ks(ikcalc, spin)
4979 : 284 : band_ks = self%bstart_ks(ikcalc, spin) + ib - 1
4980 : 284 : kse = ebands%eig(band_ks, ik_ibz, spin)
4981 [ + + ]: 1276 : do it=1,self%ntemp
4982 : : aw(:, it, ib) = -piinv * aimag(self%vals_wr(:, it, ib)) / &
4983 [ + + ]: 109020 : ((self%wrmesh_b(:, ib) - kse - real(self%vals_wr(:, it, ib))) ** 2 + aimag(self%vals_wr(:, it, ib)) ** 2)
4984 : : end do
4985 : : end do
4986 [ + + - + : 312 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "spfunc_wr"), aw, start=[1, 1, 1, ikcalc, spin]))
- - ]
4987 [ - + ]: 52 : ABI_FREE(aw)
4988 : : end if
4989 : :
4990 : : ! Write Eliashberg functions
4991 [ + + ]: 182 : if (allocated(self%gfw_vals)) then
4992 [ + + - + : 348 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "gfw_vals"), self%gfw_vals, start=[1, 1, 1, ikcalc, spin]))
- - ]
4993 : : end if
4994 [ - + ]: 182 : if (allocated(self%a2few)) then
4995 [ # # # # : 0 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "a2few"), self%a2few, start=[1, 1, 1, ikcalc, spin]))
# # ]
4996 : : end if
4997 : :
4998 [ + + ]: 182 : if (dtset%ibte_prep > 0) then
4999 : 6 : call wrtout(std_out, " Writing scattering matrix elements to disk...")
5000 : : ! Get ncid of group used to store scattering rate (ragged array implemented with netcdf groups).
5001 : : ! FIXME: Unfortunately, this algo cannot be used if parallelism over kcalc/spin is on since
5002 : : ! we have to change the metadata at runtime.
5003 : 6 : sr_ncid = self%ncid
5004 [ - + ]: 6 : NCF_CHECK(nf90_inq_ncid(sr_ncid, strcat("srate_k", itoa(ikcalc), "_s", itoa(spin)), grp_ncid))
5005 : :
5006 : : ! Define dimensions and arrays inside group at runtime
5007 : : ncerr = nctk_def_dims(grp_ncid, [ &
5008 : : nctkdim_t("lgk_nsym", self%lgk_nsym), &
5009 : : nctkdim_t("nbcalc", self%nbcalc_ks(ikcalc, spin)), &
5010 : : nctkdim_t("nbsum", self%bsum_stop - self%bsum_start + 1), &
5011 : : nctkdim_t("nq_ibzk_eff", nq_ibzk_eff) &
5012 [ + + ]: 30 : ], defmode=.True.)
5013 [ - + ]: 6 : NCF_CHECK(ncerr)
5014 : :
5015 : : ncerr = nctk_def_arrays(grp_ncid, [ &
5016 : : nctkarr_t("lgk_sym2glob", "int", "two, lgk_nsym"), &
5017 : : nctkarr_t("kq_symtab", "int", "six, nq_ibzk_eff"), &
5018 : : nctkarr_t("srate", "dp", "nq_ibzk_eff, nbsum, nbcalc, ntemp") &
5019 [ + + ]: 24 : ])
5020 [ - + ]: 6 : NCF_CHECK(ncerr)
5021 : :
5022 : : ! Write data.
5023 [ - + ]: 6 : NCF_CHECK(nctk_set_datamode(sr_ncid))
5024 [ - + ]: 6 : NCF_CHECK(nf90_put_var(grp_ncid, nctk_idname(grp_ncid, "lgk_sym2glob"), self%lgk_sym2glob))
5025 [ - + ]: 6 : NCF_CHECK(nf90_put_var(grp_ncid, nctk_idname(grp_ncid, "kq_symtab"), kq_symtab))
5026 [ - + ]: 6 : ABI_FREE(kq_symtab)
5027 : :
5028 : : ! Move q-points to first dimensions before writing.
5029 [ - + + - : 36 : ABI_MALLOC(grp_srate, (nq_ibzk_eff, self%bsum_start:self%bsum_stop, self%nbcalc_ks(ikcalc, spin), self%ntemp))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
5030 [ + + ]: 9187 : do ii=1,nq_ibzk_eff
5031 [ + + + + : 64273 : grp_srate(ii,:,:,:) = gather_srate(:,:,:,ii)
+ + ]
5032 : : end do
5033 [ - + ]: 6 : NCF_CHECK(nf90_put_var(grp_ncid, nctk_idname(grp_ncid, "srate"), grp_srate))
5034 [ - + ]: 6 : ABI_FREE(gather_srate)
5035 [ - + ]: 6 : ABI_FREE(grp_srate)
5036 : : end if
5037 : :
5038 : : ! Write restart flag
5039 : 182 : self%qp_done(ikcalc, spin) = 1
5040 [ + + - + : 546 : NCF_CHECK(nf90_put_var(self%ncid, nctk_idname(self%ncid, "qp_done"), 1, start=[ikcalc, spin]))
- - ]
5041 : :
5042 : : ! Dump the cache to file. This is necessary to ensure we can restart.
5043 [ - + ]: 182 : NCF_CHECK(nf90_sync(self%ncid))
5044 : :
5045 : 182 : call cwtime_report(" Sigma_nk netcdf output", cpu, wall, gflops)
5046 : :
5047 [ - + - + : 364 : end subroutine sigmaph_gather_and_write
- + - + -
+ - + - +
- + ]
5048 : : !!***
5049 : :
5050 : : !!****f* m_sigmaph/sigmaph_print
5051 : : !! NAME
5052 : : !! sigmaph_print
5053 : : !!
5054 : : !! FUNCTION
5055 : : !! Print self-energy and QP corrections for given (k-point, spin).
5056 : : !!
5057 : : !! INPUTS
5058 : : !! dtset<dataset_type>=All input variables for this dataset.
5059 : : !! unt=Fortran unit number
5060 : : !!
5061 : : !! SOURCE
5062 : :
5063 : 116 : subroutine sigmaph_print(self, dtset, unt)
5064 : :
5065 : : !Arguments ------------------------------------
5066 : : integer,intent(in) :: unt
5067 : : type(dataset_type),intent(in) :: dtset
5068 : : class(sigmaph_t),intent(in) :: self
5069 : :
5070 : : !Local variables-------------------------------
5071 : : integer :: ikc, is, ndiv
5072 : : character(len=5000) :: msg
5073 : : ! *************************************************************************
5074 : :
5075 [ - + ]: 116 : if (unt == dev_null) return
5076 : :
5077 : : ! Write dimensions
5078 : 116 : write(unt,"(/,a)")sjoin(" Number of bands in e-ph self-energy sum:", itoa(self%nbsum))
5079 : 116 : write(unt,"(a)")sjoin(" From bsum_start:", itoa(self%bsum_start), "to bsum_stop:", itoa(self%bsum_stop))
5080 [ + + + - ]: 116 : if (dtset%eph_stern /= 0 .and. .not. self%imag_only) then
5081 : 34 : write(unt, "(a)")" Treating high-energy bands with Sternheimer and static self-energy."
5082 : 34 : write(unt, "(a, es16.6, a, i0)")" Tolwfr:", dtset%tolwfr, ", nline: ", dtset%nline
5083 : : end if
5084 : 116 : write(unt,"(a)")sjoin(" Symsigma: ",itoa(self%symsigma), "Timrev:", itoa(self%timrev))
5085 [ + + + + ]: 116 : if (.not. (self%qint_method == 1 .and. self%imag_only)) then
5086 : 84 : write(unt,"(a)")sjoin(" Imaginary shift in the denominator (zcut): ", ftoa(aimag(self%ieta) * Ha_eV, fmt="f5.3"), "[eV]")
5087 : : end if
5088 [ + + ]: 116 : msg = " Standard quadrature"; if (self%qint_method == 1) msg = " Tetrahedron method"
5089 : 116 : write(unt, "(2a)")sjoin(" Method for q-space integration:", msg)
5090 [ + + ]: 116 : if (self%qint_method == 1) then
5091 [ + + ]: 38 : ndiv = 1; if (self%use_doublegrid) ndiv = self%eph_doublegrid%ndiv
5092 [ + + ]: 114 : write(unt, "(a, 2(es16.6,1x))")" Tolerance for integration weights < ", dtset%eph_tols_idelta(:) / ndiv
5093 : 38 : write(unt, "(a, (f5.2,1x))")" eph_phwinfact: ", self%phwinfact
5094 : : end if
5095 [ + + ]: 116 : if (self%use_doublegrid) write(unt, "(a, i0)")" Using double grid technique with ndiv: ", self%eph_doublegrid%ndiv
5096 [ + + ]: 116 : if (self%imag_only) write(unt, "(a)")" Only the Imaginary part of Sigma will be computed."
5097 [ + + ]: 116 : if (.not. self%imag_only) write(unt, "(a)")" Both Real and Imaginary part of Sigma will be computed."
5098 : : write(unt,"(a)")sjoin(" Number of frequencies along the real axis:", itoa(self%nwr), &
5099 : 116 : ", Step:", ftoa(self%wr_step * Ha_eV, fmt="f5.3"), "[eV]")
5100 [ + + ]: 116 : if (dtset%prteliash /= 0) then
5101 : 42 : write(unt, "(a)")sjoin(" Number of frequency in generalized Eliashberg functions:", itoa(self%phmesh_size))
5102 : : else
5103 : 74 : write(unt, "(a)")" Number of frequency in generalized Eliashberg functions: 0"
5104 : : end if
5105 : : write(unt,"(a)")sjoin(" Number of temperatures:", itoa(self%ntemp), &
5106 : 116 : "From:", ftoa(self%kTmesh(1) / kb_HaK), "to", ftoa(self%kTmesh(self%ntemp) / kb_HaK), "[K]")
5107 : 116 : write(unt,"(a)")sjoin(" Ab-initio q-mesh from DDB file:", ltoa(dtset%ddb_ngqpt))
5108 : 116 : write(unt,"(a)")sjoin(" Q-mesh used for self-energy integration [ngqpt]:", ltoa(self%ngqpt))
5109 : 116 : write(unt,"(a)")sjoin(" Number of q-points in the IBZ:", itoa(self%nqibz))
5110 : 116 : write(unt,"(a)")sjoin(" asr:", itoa(dtset%asr), "chneut:", itoa(dtset%chneut))
5111 : 116 : write(unt,"(a)")sjoin(" dipdip:", itoa(dtset%dipdip), "symdynmat:", itoa(dtset%symdynmat))
5112 : :
5113 [ + + ]: 116 : if (.not. self%imag_only) then
5114 : 66 : select case (self%frohl_model)
5115 : : case (0)
5116 : : !write(unt,"(a)")" No special treatment for the integration of the Frohlich divergence in the microzone around Gamma"
5117 : : case (1)
5118 : 0 : write(unt,"(a)")" Integrating Frohlich model in small sphere around Gamma to accelerate qpt convergence"
5119 : 0 : write(unt,"(2(a,i0,1x))")" Spherical integration performed with: ntheta: ", self%ntheta, ", nphi: ", self%nphi
5120 : : case default
5121 [ - - + ]: 66 : ABI_ERROR(sjoin("Invalid value of frohl_mode:", itoa(self%frohl_model)))
5122 : : end select
5123 : : end if
5124 : :
5125 : 116 : write(unt,"(a, i0)")" Number of k-points for self-energy corrections: ", self%nkcalc
5126 [ + + + + : 310 : if (any(abs(dtset%sigma_erange) /= zero)) then
+ + ]
5127 [ + + ]: 84 : write(unt, "(a, 2(f6.3, 1x), a)")" sigma_erange: ", dtset%sigma_erange(:) * Ha_eV, " (eV)"
5128 : : end if
5129 [ + + + + ]: 116 : if (self%imag_only .and. self%qint_method == 1) then
5130 : 32 : write(unt,"(a, 2(f5.3, 1x), a)")" Including all final {mk+q} states inside energy window: [", &
5131 : 64 : self%elow * Ha_eV, self%ehigh * Ha_eV, "] [eV]"
5132 : : end if
5133 : 116 : write(unt,"(a)")" List of k-points for self-energy corrections:"
5134 [ + + ]: 480 : do ikc=1,self%nkcalc
5135 [ - + ]: 364 : if (ikc > 10) then
5136 : 0 : write(unt, "(2a)")" nkcalc > 10. Stop printing more k-point information.",ch10
5137 : 0 : exit
5138 : : end if
5139 [ + + ]: 844 : do is=1,self%nsppol
5140 [ - + ]: 364 : if (self%nsppol == 2) write(unt,"(a,i1,a)")" For spin: ",is, ", ikcalc, spin, kpt, bstart, bstop"
5141 : : write(unt, "(2(i4,2x),a,2(i4,1x))") &
5142 [ + - ]: 728 : ikc, is, trim(ktoa(self%kcalc(:,ikc))), self%bstart_ks(ikc,is), self%bstart_ks(ikc,is) + self%nbcalc_ks(ikc,is) - 1
5143 : : end do
5144 : : end do
5145 : :
5146 : 116 : write(unt, "(/,a)")" === MPI parallelism ==="
5147 : 116 : write(unt, "(2(a,i0))")"P Allocating and summing bands from my_bsum_start: ", self%my_bsum_start, &
5148 : 232 : " up to my_bsum_stop: ", self%my_bsum_stop
5149 : 116 : write(unt, "(a,i0)")"P Number of CPUs for parallelism over perturbations: ", self%pert_comm%nproc
5150 : 116 : write(unt, "(a,i0)")"P Number of perturbations treated by this CPU: ", self%my_npert
5151 : 116 : write(unt, "(a,i0)")"P Number of CPUs for parallelism over q-points: ", self%qpt_comm%nproc
5152 : 116 : write(unt, "(2(a,i0))")"P Number of q-points in the IBZ treated by this proc: " , &
5153 [ + + + - ]: 8212 : count(self%itreat_qibz == 1), " of ", self%nqibz
5154 : 116 : write(unt, "(a,i0)")"P Number of CPUs for parallelism over bands: ", self%bsum_comm%nproc
5155 : 116 : write(unt, "(a,i0)")"P Number of CPUs for parallelism over spins: ", self%spin_comm%nproc
5156 : 116 : write(unt, "(a,i0)")"P Number of CPUs for parallelism over k-points: ", self%kcalc_comm%nproc
5157 : 116 : write(unt, "(2(a,i0),/)")"P Number of k-point in Sigma_nk treated by this proc: ", self%my_nkcalc, " of ", self%nkcalc
5158 : :
5159 : : end subroutine sigmaph_print
5160 : : !!***
5161 : :
5162 : : !----------------------------------------------------------------------
5163 : :
5164 : : !!****f* m_sigmaph/sigmaph_get_all_qweights
5165 : : !! NAME
5166 : : !! sigmaph_get_all_qweights
5167 : : !!
5168 : : !! FUNCTION
5169 : : !! Compute all the weights for q-space integration using the tetrahedron method
5170 : : !!
5171 : : !! INPUTS
5172 : : !! cryst<crystal_t>=Crystalline structure
5173 : : !! ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...)
5174 : : !! spin: Spin index
5175 : : !! ikcalc: Index of the self-energy k-point in the kcalc array.
5176 : : !! comm: MPI communicator
5177 : : !!
5178 : : !! OUTPUT
5179 : : !!
5180 : : !! SOURCE
5181 : :
5182 : 156 : subroutine sigmaph_get_all_qweights(sigma, cryst, ebands, spin, ikcalc, comm)
5183 : :
5184 : : !Arguments ------------------------------------
5185 : : !scalars
5186 : : class(sigmaph_t),intent(inout) :: sigma
5187 : : type(ebands_t),intent(in) :: ebands
5188 : : type(crystal_t),intent(in) :: cryst
5189 : : integer,intent(in) :: ikcalc, spin, comm
5190 : :
5191 : : !Local variables ------------------------------
5192 : : !scalars
5193 : : integer :: nu, ibsum_kq, ik_ibz, bstart_ks, nbcalc_ks, my_rank, natom3
5194 : : integer :: nprocs, imyp, imyq, ndiv, bsum_start, bsum_stop, ib_k, band_ks
5195 : : integer :: iq_ibz_fine,iq_bz_fine,iq_ibz,jj, nz
5196 : : real(dp) :: weight, cpu,wall, gflops, eig0nk
5197 : : !arrays
5198 : : real(dp) :: kk(3), kq(3), qpt(3), dpm(2)
5199 : 156 : real(dp),allocatable :: tmp_deltaw_pm(:,:,:)
5200 : 156 : complex(dp),allocatable :: zvals(:,:), tmp_cweights(:,:,:,:)
5201 : : ! *************************************************************************
5202 : :
5203 : 156 : call cwtime(cpu, wall, gflops, "start")
5204 : :
5205 : 156 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
5206 : :
5207 [ + + ]: 624 : kk = sigma%kcalc(:, ikcalc)
5208 : 156 : ik_ibz = sigma%kcalc2ibz(ikcalc, 1)
5209 : 156 : nbcalc_ks = sigma%nbcalc_ks(ikcalc, spin)
5210 : 156 : bstart_ks = sigma%bstart_ks(ikcalc, spin)
5211 : 156 : bsum_start = sigma%bsum_start; bsum_stop = sigma%bsum_stop
5212 : 156 : natom3 = 3 * cryst%natom
5213 [ + + ]: 156 : ndiv = 1; if (sigma%use_doublegrid) ndiv = sigma%eph_doublegrid%ndiv
5214 : :
5215 [ - + ]: 156 : ABI_CHECK(abs(sigma%symsigma) == 1, "symsigma 0 with tetra not implemented")
5216 : :
5217 [ + + ]: 156 : if (sigma%imag_only) then
5218 : : ! Weights for Im (tetrahedron, eta --> 0)
5219 [ + + - + : 1050 : ABI_REMALLOC(sigma%deltaw_pm, (2, nbcalc_ks, sigma%my_npert, bsum_start:bsum_stop, sigma%my_nqibz_k, ndiv))
+ - - + +
- - + + -
- + + - -
+ + - + -
+ - - + -
+ - + ]
5220 [ + + + + : 13743622 : sigma%deltaw_pm = zero
+ + + + +
+ + + ]
5221 : :
5222 : : ! Temporary weights (on the fine IBZ_k mesh if double grid is used)
5223 [ - + + - : 450 : ABI_MALLOC(tmp_deltaw_pm, (1, sigma%ephwg%nq_k, 2))
+ - + - -
+ - + ]
5224 : :
5225 : : ! Loop over bands to sum
5226 [ + + ]: 696 : do ibsum_kq=sigma%bsum_start, sigma%bsum_stop
5227 : : ! Loop over my phonon modes
5228 [ + + ]: 3936 : do imyp=1,sigma%my_npert
5229 : 3240 : nu = sigma%my_pinfo(3, imyp)
5230 : :
5231 : : ! HM: This one should be faster but uses more memory, I compute for each ib instead
5232 : : ! Compute weights inside qb_comm
5233 : : !call sigma%ephwg%get_deltas_wvals(ibsum_kq, spin, nu, nbcalc_ks, &
5234 : : ! ebands%eig(bstart_ks:bstart_ks+nbcalc_ks, ik_ibz, spin), &
5235 : : ! sigma%bcorr, tmp_deltaw_pm, sigma%qb_comm%value)
5236 : :
5237 : : ! loop over bands in self-energy matrix elements.
5238 [ + + ]: 18894 : do ib_k=1,nbcalc_ks
5239 : 15108 : band_ks = ib_k + bstart_ks - 1
5240 : 15108 : eig0nk = ebands%eig(band_ks, ik_ibz, spin)
5241 : :
5242 : : ! Compute weights inside qb_comm
5243 [ + + ]: 30216 : call sigma%ephwg%get_deltas_wvals(ibsum_kq, spin, nu, 1, [eig0nk], sigma%bcorr, tmp_deltaw_pm, sigma%qb_comm%value)
5244 : :
5245 : : ! For all the q-points that I am going to calculate
5246 [ + + ]: 986229 : do imyq=1,sigma%my_nqibz_k
5247 : 967881 : iq_ibz = sigma%myq2ibz_k(imyq)
5248 : :
5249 [ + + ]: 982989 : if (sigma%use_doublegrid) then
5250 : : ! For all the q-points in the microzone
5251 : : ! This is done again in the main sigmaph routine
5252 [ + + ]: 375480 : qpt = sigma%qibz_k(:,iq_ibz)
5253 [ + + ]: 375480 : kq = kk + qpt
5254 : 93870 : call sigma%eph_doublegrid%get_mapping(kk, kq, qpt)
5255 [ + + ]: 2628360 : do jj=1,sigma%eph_doublegrid%ndiv
5256 : 2534490 : iq_bz_fine = sigma%eph_doublegrid%mapping(3,jj)
5257 : 2534490 : iq_ibz_fine = sigma%eph_doublegrid%bz2lgkibz(iq_bz_fine)
5258 : 2534490 : weight = sigma%ephwg%lgk%weights(iq_ibz_fine)
5259 : : !dpm = tmp_deltaw_pm(ib_k, iq_ibz_fine, :)
5260 [ + + ]: 7603470 : dpm = tmp_deltaw_pm(1, iq_ibz_fine, :)
5261 [ + + ]: 7697340 : sigma%deltaw_pm(:, ib_k, imyp, ibsum_kq, imyq, jj) = dpm / weight
5262 : : end do
5263 : : else
5264 : 874011 : weight = sigma%ephwg%lgk%weights(iq_ibz)
5265 : : !dpm = tmp_deltaw_pm(ib_k, iq_ibz, :)
5266 [ + + ]: 2622033 : dpm = tmp_deltaw_pm(1, iq_ibz, :)
5267 [ + + ]: 2622033 : sigma%deltaw_pm(:, ib_k, imyp, ibsum_kq, imyq, 1) = dpm / weight
5268 : : end if
5269 : :
5270 : : end do
5271 : : end do
5272 : : end do
5273 : : end do
5274 : :
5275 [ - + ]: 150 : ABI_FREE(tmp_deltaw_pm)
5276 : :
5277 : : else
5278 : : ! Both real and imag part --> compute \int 1/z with tetrahedron.
5279 : : ! Note that we still need a finite i.eta in the expression (hopefully smaller than the default value).
5280 : : ! Besides we have to take into account the case in which the spectral function is wanted.
5281 : : ! Derivative wrt omega is still computed with finite i.eta, though.
5282 [ - + ]: 6 : ABI_CHECK(.not. sigma%use_doublegrid, "double grid for Re-Im not implemented")
5283 : :
5284 : : ! TODO: This part should be tested.
5285 [ + + ]: 6 : nz = 1; if (sigma%nwr > 0) nz = 1 + sigma%nwr
5286 [ + + - + : 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))
+ - - + +
- - + + -
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
5287 [ - + + - : 30 : ABI_MALLOC(tmp_cweights, (nz, 2, nbcalc_ks, sigma%nqibz_k))
- + + - -
+ + - + -
+ - - + -
+ ]
5288 : :
5289 : : ! Initialize z-points for Sigma_{nk} for different n bands.
5290 [ - + + - : 24 : ABI_MALLOC(zvals, (nz, nbcalc_ks))
- + + - +
- + - - +
- + ]
5291 [ + + ]: 54 : zvals(1, :) = sigma%e0vals + sigma%ieta
5292 [ + + + + : 3270 : if (sigma%nwr > 0) zvals(2:sigma%nwr+1, :) = sigma%wrmesh_b(:, 1:nbcalc_ks) + sigma%ieta
+ + ]
5293 : :
5294 : : ! Loop over my bands in self-energy sum.
5295 : : ! TODO: Really slow if nz >> 1. Possible solutions:
5296 : : ! 1) reduce the number of ibsum_kq bands for which tetra must be used.
5297 : : ! 2) use spline with non-linear mesh
5298 : : ! 3) use asyntotic expansion at "large" z
5299 [ + + ]: 194 : do ibsum_kq=sigma%my_bsum_start, sigma%my_bsum_stop
5300 : : ! Loop over my phonon modes
5301 [ + + ]: 1322 : do imyp=1,sigma%my_npert
5302 : 1128 : nu = sigma%my_pinfo(3, imyp)
5303 : :
5304 : : ! cweights(nz, 2, nbsigma, self%nq_k)
5305 : : call sigma%ephwg%get_zinv_weights(nz, nbcalc_ks, zvals, ibsum_kq, spin, nu, sigma%zinv_opt, tmp_cweights, &
5306 : 1128 : xmpi_comm_self)
5307 : : !sigma%qpt_comm%value)
5308 : : !erange=
5309 : : !use_bzsum=sigma%symsigma == 0)
5310 : :
5311 : : ! Extract weights for all the q-points that I am going to calculate.
5312 [ + + ]: 13160 : do imyq=1,sigma%my_nqibz_k
5313 : 11844 : iq_ibz = sigma%myq2ibz_k(imyq)
5314 : 11844 : weight = sigma%ephwg%lgk%weights(iq_ibz)
5315 [ + + + + : 8631372 : sigma%cweights(:, :, :, imyp, ibsum_kq, imyq, 1) = tmp_cweights(:, :, :, iq_ibz) / weight
+ + ]
5316 : : end do
5317 : : end do
5318 : : end do
5319 : :
5320 [ - + ]: 6 : ABI_FREE(zvals)
5321 [ - + ]: 6 : ABI_FREE(tmp_cweights)
5322 : : end if
5323 : :
5324 : 156 : call cwtime_report(" get_all_qweights with tetrahedron", cpu, wall, gflops)
5325 : :
5326 : 156 : end subroutine sigmaph_get_all_qweights
5327 : : !!***
5328 : :
5329 : : !!****f* m_sigmaph/qpoints_oracle
5330 : : !! NAME
5331 : : !! qpoints_oracle
5332 : : !!
5333 : : !! FUNCTION
5334 : : !! This function tries to predict the **full** list of q-points in the BZ needed to compute the lifetimes
5335 : : !! once we know sigma%nkcalc.
5336 : : !! It uses an energy window computed from the max phonon frequency multiplied by sigma%phwinfact.
5337 : : !!
5338 : : !! INPUT
5339 : : !! cryst=Crystalline structure
5340 : : !! ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...)
5341 : : !! qpts(3, nqpt)=
5342 : : !! nqpt= Number of points in qpts
5343 : : !! nqbz=Number of q-points in BZ.
5344 : : !! qbz(3, nbz) = full BZ
5345 : : !! comm=MPI communicator.
5346 : : !!
5347 : : !! OUTPUT
5348 : : !! qselect(nqpt)
5349 : : !!
5350 : : !! SOURCE
5351 : :
5352 : 16 : subroutine qpoints_oracle(sigma, dtset, cryst, ebands, qpts, nqpt, nqbz, qbz, qselect, comm)
5353 : :
5354 : : !Arguments ------------------------------------
5355 : : !scalars
5356 : : class(sigmaph_t),intent(in) :: sigma
5357 : : type(dataset_type),intent(in) :: dtset
5358 : : type(crystal_t),intent(in) :: cryst
5359 : : type(ebands_t),intent(in) :: ebands
5360 : : integer,intent(in) :: nqpt, nqbz, comm
5361 : : !arrays
5362 : : real(dp),intent(in) :: qpts(3,nqpt), qbz(3,nqbz)
5363 : : integer,intent(out) :: qselect(nqpt)
5364 : :
5365 : : !Local variables ------------------------------
5366 : : !scalars
5367 : : integer,parameter :: master = 0
5368 : : integer :: spin, ikcalc, ik_ibz, iq_bz, ierr, db_iqpt, ibsum_kq, ikq_ibz, ikq_bz
5369 : : integer :: cnt, my_rank, nprocs, ib_k, band_ks, nkibz, nkbz, kq_rank, qptopt
5370 : : real(dp) :: eig0nk, eig0mkq, ediff, cpu, wall, gflops
5371 : : character(len=5000) :: msg
5372 : 16 : type(krank_t) :: krank, qrank
5373 : : !arrays
5374 : : integer :: g0(3), qptrlatt(3,3)
5375 : 16 : integer,allocatable :: qbz_count(:), qbz2qpt(:,:), bz2ibz(:,:)
5376 : : real(dp) :: kq(3), kk(3)
5377 : 16 : real(dp),allocatable :: wtk(:), kibz(:,:), kbz(:,:)
5378 : : ! *************************************************************************
5379 : :
5380 : 16 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
5381 : :
5382 : 16 : call cwtime(cpu, wall, gflops, "start")
5383 : : call wrtout(std_out, &
5384 : 16 : sjoin(" qpoints_oracle: predicting number q-points for tau with eph_phwinfact:", ftoa(sigma%phwinfact)))
5385 : :
5386 : : ! Get full BZ associated to ebands
5387 : : call kpts_ibz_from_kptrlatt(cryst, ebands%kptrlatt, ebands%kptopt, ebands%nshiftk, ebands%shiftk, &
5388 : 16 : nkibz, kibz, wtk, nkbz, kbz, bz2ibz=bz2ibz)
5389 : 16 : call cwtime_report(" kpts_ibz_from_kptrlatt", cpu, wall, gflops)
5390 : :
5391 [ - + ]: 16 : ABI_FREE(wtk)
5392 [ - + ]: 16 : ABI_FREE(kibz)
5393 [ - + ]: 16 : ABI_CHECK(nkibz == ebands%nkpt, "nkibz != ebands%nkpt")
5394 : :
5395 : : ! Make full k-point rank arrays
5396 : 16 : call krank%init(nkbz, kbz)
5397 : 16 : call cwtime_report(" krank_new", cpu, wall, gflops)
5398 : :
5399 : : ! This loop is Expensive with a 288^3
5400 : : ! qbz_count_loop completed. cpu: 03:16 [minutes] , wall: 03:16 [minutes] <<< TIME
5401 : : ! qbz_count completed. cpu: 04:41 [minutes] , wall: 04:40 [minutes] <<< TIME
5402 [ - + + - : 115520 : ABI_ICALLOC(qbz_count, (nqbz))
+ - + - -
+ - + +
+ ]
5403 : 16 : cnt = 0
5404 [ + + ]: 32 : do spin=1,sigma%nsppol
5405 [ + + ]: 107 : do ikcalc=1,sigma%nkcalc
5406 [ + - ]: 75 : cnt = cnt + 1; if (mod(cnt, nprocs) /= my_rank) cycle ! MPI parallelism inside comm
5407 [ + + ]: 300 : kk = sigma%kcalc(:, ikcalc)
5408 : 75 : ik_ibz = sigma%kcalc2ibz(ikcalc, 1)
5409 [ + + ]: 471195 : do iq_bz=1,nqbz
5410 [ + + ]: 471104 : if (qbz_count(iq_bz) /= 0) cycle ! No need to check this q-point again.
5411 [ + + ]: 1869788 : kq = kk + qbz(:, iq_bz)
5412 : 467447 : kq_rank = krank%get_rank(kq)
5413 : 467447 : ikq_bz = krank%invrank(kq_rank)
5414 [ - + ]: 467447 : ABI_CHECK(ikq_bz > 0, sjoin("Cannot find kq: ", ktoa(kq)))
5415 [ - + ]: 467447 : ABI_CHECK(isamek(kq, kbz(:, ikq_bz), g0), "Wrong invrank")
5416 : : !ikq_ibz = bz2ibz(ikq_bz,1)
5417 : 467447 : ikq_ibz = bz2ibz(1, ikq_bz)
5418 [ + + ]: 940445 : do ib_k=1,sigma%nbcalc_ks(ikcalc, spin)
5419 : 472923 : band_ks = ib_k + sigma%bstart_ks(ikcalc, spin) - 1
5420 : 472923 : eig0nk = ebands%eig(band_ks, ik_ibz, spin)
5421 [ + + ]: 1452855 : do ibsum_kq=sigma%bsum_start, sigma%bsum_stop
5422 : 508828 : eig0mkq = ebands%eig(ibsum_kq, ikq_ibz, spin)
5423 : 508828 : ediff = eig0nk - eig0mkq
5424 : : ! Perform check on the energy difference to exclude this q-point.
5425 [ + + ]: 981751 : if (abs(ediff) <= sigma%phwinfact * sigma%wmax) qbz_count(iq_bz) = qbz_count(iq_bz) + 1
5426 : : end do
5427 : : end do
5428 : : end do
5429 : : end do
5430 : : end do
5431 : 16 : call cwtime_report(" qbz_count_loop", cpu, wall, gflops)
5432 : :
5433 [ - + ]: 16 : ABI_FREE(kbz)
5434 [ - + ]: 16 : ABI_FREE(bz2ibz)
5435 : 16 : call krank%free()
5436 : :
5437 : 16 : call xmpi_sum(qbz_count, comm, ierr)
5438 : 16 : call cwtime_report(" qbz_count", cpu, wall, gflops)
5439 : :
5440 : : ! Get mapping QBZ --> List of q-points involved in e-ph scattering for e/h in pockets.
5441 : : ! Assume qptopt == kptopt unless value is specified in input
5442 [ - + + - : 48 : ABI_MALLOC(qbz2qpt, (6, nqbz))
+ - + - -
+ - + ]
5443 : :
5444 : 16 : qptrlatt = 0; qptrlatt(1,1) = sigma%ngqpt(1); qptrlatt(2,2) = sigma%ngqpt(2); qptrlatt(3,3) = sigma%ngqpt(3)
5445 : 16 : call qrank%from_kptrlatt(nqpt, qpts, qptrlatt, compute_invrank=.False.)
5446 [ - + ]: 16 : qptopt = ebands%kptopt; if (dtset%qptopt /= 0) qptopt = dtset%qptopt
5447 : :
5448 [ - + ]: 16 : if (kpts_map("symrec", qptopt, cryst, qrank, nqbz, qbz, qbz2qpt) /= 0) then
5449 : : write(msg, '(3a)' )&
5450 : 0 : "At least one of the q-points could not be generated from a symmetrical one in the DVDB.", ch10, &
5451 : 0 : "Action: check your DVDB file and use eph_task to interpolate the potentials on a denser q-mesh."
5452 : 0 : ABI_ERROR(msg)
5453 : : end if
5454 : 16 : call qrank%free()
5455 : :
5456 : 16 : call cwtime_report(" oracle_listkk_qbz_qpts", cpu, wall, gflops)
5457 : :
5458 : : ! Compute qselect using qbz2qpt.
5459 [ + + ]: 3532 : qselect = 0
5460 [ + + ]: 115488 : do iq_bz=1,nqbz
5461 [ + + ]: 115472 : if (qbz_count(iq_bz) == 0) cycle
5462 : 1477 : db_iqpt = qbz2qpt(1, iq_bz)
5463 : 115488 : qselect(db_iqpt) = qselect(db_iqpt) + 1
5464 : : end do
5465 : :
5466 [ - + ]: 16 : ABI_FREE(qbz_count)
5467 [ - + ]: 16 : ABI_FREE(qbz2qpt)
5468 : :
5469 [ + - ]: 16 : if (my_rank == master) then
5470 [ + + + + ]: 3532 : cnt = count(qselect /= 0)
5471 : 16 : write(std_out, "(a, i0, a, f5.1, a)")" qpoints_oracle: calculation of tau_nk will need: ", cnt, &
5472 : 32 : " q-points in the IBZ. (nqibz_eff / nqibz): ", (100.0_dp * cnt) / sigma%nqibz, " [%]"
5473 : : end if
5474 : :
5475 [ - + - + : 112 : end subroutine qpoints_oracle
- + - + -
+ - + ]
5476 : : !!***
5477 : :
5478 : : !!****f* m_epthk/frohl_integrator_init
5479 : : !! FUNCTION
5480 : : !! Initialize the Frohlich integrator.
5481 : : !!
5482 : : !! INPUTS
5483 : : !!
5484 : : !! SOURCE
5485 : :
5486 [ # # ]: 0 : subroutine frohl_integrator_init(new, cryst, ifc, ntheta, comm)
5487 : :
5488 : : use m_lebedev, only : lebedev_t
5489 : :
5490 : : !Arguments ------------------------------------
5491 : : class(frohl_integrator_t),intent(out) :: new
5492 : : type(crystal_t),intent(in) :: cryst
5493 : : type(ifc_type),intent(in) :: ifc
5494 : : integer,intent(in) :: ntheta, comm
5495 : :
5496 : : !Local variables ------------------------------
5497 : : integer :: iang, my_rank, nprocs
5498 : : !************************************************************************
5499 : :
5500 : : ! Set angular mesh for numerical integration inside micro BZ around Gamma.
5501 : 0 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
5502 : 0 : new%ntheta = ntheta; new%nphi = 2 * new%ntheta
5503 : : !write(std_out,"(a)")" Activating computation of Frohlich self-energy:"
5504 : : !write(std_out,"(2(a,i0,1x))")" ntheta: ", new%ntheta, "nphi: ", new%nphi
5505 : :
5506 : : ! Initialize angular mesh qvers_cart and angwgth
5507 : : ! NB: summing over f * angwgth gives the spherical average 1/(4pi) \int domega f(omega)
5508 [ # # # # ]: 0 : call ylm_angular_mesh(new%ntheta, new%nphi, new%angl_size, new%qvers_cart, new%angwgth)
5509 [ # # ]: 0 : write(std_out, *) sum(new%angwgth) * four_pi, "should be one"
5510 [ # # ]: 0 : write(std_out, *) sum(new%angwgth), "should be one"
5511 : 0 : stop
5512 : :
5513 : : !call lebedev%from_npts(npts, ierr)
5514 : : !ABI_CHECK(ierr = 0, "Error while initializing lebedev mesh.")
5515 : :
5516 : : ! Precompute ph frequencies and displacement including NAC terms.
5517 : : ABI_MALLOC(new%phfrq, (cryst%natom * 3, new%angl_size))
5518 : : ABI_MALLOC(new%displ_cart, (2, 3, cryst%natom, cryst%natom * 3, new%angl_size))
5519 : :
5520 : : do iang=1,new%angl_size
5521 : : !if (mod(iang, nprocs) /= my_rank) cycle ! MPI parallelism
5522 : : call ifc%fourq(cryst, new%qvers_cart(:, iang) , new%phfrq(:,iang), new%displ_cart(:,:,:,:,iang), nanaqdir="cart")
5523 : : end do
5524 : :
5525 : : end subroutine frohl_integrator_init
5526 : : !!***
5527 : :
5528 : 0 : subroutine frohl_integrator_eval_isotropic_avg(self, cryst, ifc, comm, avg_value)
5529 : : class(frohl_integrator_t),intent(in) :: self
5530 : : type(crystal_t),intent(in) :: cryst
5531 : : type(ifc_type),intent(in) :: ifc
5532 : : integer,intent(in) :: comm
5533 : : real(dp),intent(out) :: avg_value(cryst%natom * 3)
5534 : :
5535 : : !Local variables ------------------------------
5536 : : integer :: iang, iatom, nu, natom3, my_rank, nprocs, ierr
5537 : : real(dp) :: inv_qepsq2, wqnu, qzd2, inv_wqnu2
5538 : : complex(dp) :: cnum, cp3(3)
5539 : : !************************************************************************
5540 : :
5541 : 0 : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
5542 : 0 : natom3 = 3 * cryst%natom
5543 [ # # ]: 0 : avg_value = zero
5544 : :
5545 [ # # ]: 0 : do iang=1,self%angl_size
5546 [ # # ]: 0 : if (mod(iang, nprocs) /= my_rank) cycle ! MPI parallelism
5547 : 0 : associate (qpt_cart => self%qvers_cart(:, iang), displ_cart => self%displ_cart(:,:,:,:,iang))
5548 [ # # # # : 0 : inv_qepsq2 = (one / dot_product(qpt_cart, matmul(ifc%dielt, qpt_cart))) ** 2
# # ]
5549 : :
5550 : : ! NB: Acoustic modes are ignored here
5551 [ # # ]: 0 : do nu=4,natom3
5552 : 0 : wqnu = self%phfrq(nu, iang); inv_wqnu2 = one / wqnu ** 2
5553 : : ! cnum = q.\sum_k Z_k.d(q,nu)
5554 : 0 : cp3 = czero
5555 [ # # ]: 0 : do iatom=1, cryst%natom
5556 [ # # # # : 0 : cp3 = cp3 + matmul(ifc%zeff(:, :, iatom), cmplx(displ_cart(1,:,iatom, nu), displ_cart(2,:,iatom, nu), kind=dp))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # ]
5557 : : end do
5558 [ # # ]: 0 : cnum = dot_product(qpt_cart, cp3); qzd2 = abs(cnum) ** 2
5559 : 0 : avg_value(nu) = avg_value(nu) + self%angwgth(iang) * qzd2 * inv_qepsq2 * inv_wqnu2
5560 : : end do
5561 : : end associate
5562 : : end do ! iang
5563 : 0 : call xmpi_sum(avg_value, comm, ierr)
5564 : :
5565 : 0 : end subroutine frohl_integrator_eval_isotropic_avg
5566 : : !!***
5567 : :
5568 : : !!****f* m_epthk/frohl_integrator_find_mesh
5569 : : !! NAME
5570 : : !!
5571 : : !! FUNCTION
5572 : : !! Find mesh size needed to converge the angular integrals
5573 : : !!
5574 : : !! SOURCE
5575 : :
5576 : : subroutine frohl_integrator_find_mesh(cryst, ifc, ntheta, comm)
5577 : :
5578 : : !Arguments ------------------------------------
5579 : : type(crystal_t),intent(in) :: cryst
5580 : : type(ifc_type),intent(in) :: ifc
5581 : : integer,intent(out) :: ntheta
5582 : : integer,intent(in) :: comm
5583 : :
5584 : : !Local variables ------------------------------
5585 : : integer :: iter, my_rank, nprocs
5586 : : integer, parameter :: max_iter = 20
5587 : : type(frohl_integrator_t) :: frohl
5588 : : real(dp) :: REL_TOL = 0.02_dp
5589 : : real(dp) :: new_value, old_value, avg_value_ph(3*cryst%natom)
5590 : : logical :: converged
5591 : : !************************************************************************
5592 : :
5593 : : ! Increment ntheta by 50 at each iteration. Stop when the value of the integral changes less than REL_TOL.
5594 : : my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
5595 : :
5596 : : if (my_rank == 0) then
5597 : : call wrtout(std_out, " frohl_integrator_find_mesh: find angular mesh to converge spherical average of Frohlich divergence...")
5598 : : end if
5599 : : converged = .False.; iter = 0; old_value = huge(old_value)
5600 : :
5601 : : outer_loop: do while (.not. converged .and. iter < max_iter)
5602 : : iter = iter + 1
5603 : : ntheta = iter * 2
5604 : : call frohl%init(cryst, ifc, ntheta, comm)
5605 : :
5606 : : call frohl%eval_isotropic_avg(cryst, ifc, comm, avg_value_ph)
5607 : : new_value = sum(avg_value_ph)
5608 : :
5609 : : if (my_rank == 0) then
5610 : : write(std_out, "(a,i0,a,i0,a,i0,a,es16.8)") &
5611 : : " frohl_integrator_find_mesh: iter: ", iter, " ntheta: ", ntheta, " angl_size: ", frohl%angl_size, " value: ", new_value
5612 : : end if
5613 : :
5614 : : if (iter > 1) then
5615 : : converged = (abs(new_value - old_value) <= (old_value * REL_TOL))
5616 : : end if
5617 : : old_value = new_value
5618 : : call frohl%free()
5619 : : end do outer_loop
5620 : :
5621 : : call frohl%free()
5622 : :
5623 : : if (.not. converged) then
5624 : : ABI_ERROR("frohl_integrator_find_mesh didn't converge")
5625 : : end if
5626 : :
5627 : : end subroutine frohl_integrator_find_mesh
5628 : : !!***
5629 : :
5630 : : !!****f* m_epthk/frohl_integrator_eval
5631 : : !! NAME
5632 : : !!
5633 : : !! FUNCTION
5634 : : !!
5635 : : !! INPUTS
5636 : : !!
5637 : : !! OUTPUT
5638 : : !!
5639 : : !! SOURCE
5640 : :
5641 : : !! subroutine frohl_integrator_eval(self, cryst, ifc, nqbz, nwr, ntemp, nk_size, e_nk, f_nk, kTmesh, sig0_nk, z0_nk, comm)
5642 : : !!
5643 : : !! !Arguments ------------------------------------
5644 : : !! class(frohl_integrator_t),intent(in) :: self
5645 : : !! type(crystal_t),intent(in) :: cryst
5646 : : !! type(ifc_type),intent(in) :: ifc
5647 : : !! integer,intent(in) :: nqbz, nwr, ntemp, nk_size
5648 : : !! real(dp),intent(in) :: kTmesh(ntemp)
5649 : : !! real(dp),intent(in) :: e_nk(nk_size), f_nk(nk_size, ntemp)
5650 : : !! real(dp),intent(out) :: sig0_nk(nk_size, ntemp), z0_nk(nk_size, ntemp) !, fm(nwr, ntemp, nk_size)
5651 : : !! integer,intent(in) :: comm
5652 : : !!
5653 : : !! !Local variables ------------------------------
5654 : : !! !scalars
5655 : : !! integer,parameter :: master = 0
5656 : : !! integer :: iang, nu, iatom, ierr, my_rank, nprocs, natom3, ink, itemp
5657 : : !! real(dp) :: inv_qepsq2, q0rad, wqnu, inv_wqnu2, qzd2
5658 : : !! complex(dp) :: cnum
5659 : : !! !arrays
5660 : : !! complex(dp) :: cp3(3)
5661 : : !! !************************************************************************
5662 : : !!
5663 : : !! my_rank = xmpi_comm_rank(comm); nprocs = xmpi_comm_size(comm)
5664 : : !! natom3 = 3 * cryst%natom
5665 : : !!
5666 : : !! ! Radius of sphere with volume equivalent to the micro zone.
5667 : : !! q0rad = two_pi * (three / (four_pi * cryst%ucvol * nqbz)) ** third
5668 : : !! !bz_vol = two_pi**3 / cryst%ucvol
5669 : : !!
5670 : : !! sig0_nk = zero; z0_nk = zero
5671 : : !!
5672 : : !! ! Angular integration
5673 : : !! do iang=1,self%angl_size
5674 : : !! if (mod(iang, nprocs) /= my_rank) cycle ! MPI parallelism
5675 : : !! associate (qpt_cart => self%qvers_cart(:, iang), displ_cart => self%displ_cart(:,:,:,:,iang))
5676 : : !! inv_qepsq2 = (one / dot_product(qpt_cart, matmul(ifc%dielt, qpt_cart))) ** 2
5677 : : !! !call ifc%fourq(cryst, qpt_cart, phfrq, displ_cart, nanaqdir="cart")
5678 : : !!
5679 : : !! ! NB: Acoustic modes are ignored here
5680 : : !! do nu=4,natom3
5681 : : !! wqnu = self%phfrq(nu, iang) !; if (ephtk_skip_phmode(nu, wqnu, self%phmodes_skip, dtset%eph_phrange_w)) cycle
5682 : : !! inv_wqnu2 = one / wqnu ** 2
5683 : : !!
5684 : : !! ! cnum = q.\sum_k Z_k.d(q,nu)
5685 : : !! cp3 = czero
5686 : : !! do iatom=1, cryst%natom
5687 : : !! cp3 = cp3 + matmul(ifc%zeff(:, :, iatom), cmplx(displ_cart(1,:,iatom, nu), displ_cart(2,:,iatom, nu), kind=dp))
5688 : : !! end do
5689 : : !! cnum = dot_product(qpt_cart, cp3); qzd2 = abs(cnum) ** 2
5690 : : !!
5691 : : !! ! Compute spherical average.
5692 : : !! !zpr_frohl_sphcorr(nu) = zpr_frohl_sphcorr(nu) + self%angwgth(iang) * abs(cnum) ** 2 * inv_qepsq2 / wqnu ** 2
5693 : : !!
5694 : : !! do ink=1,nk_size
5695 : : !! do itemp=1,ntemp
5696 : : !! sig0_nk(ink, itemp) = sig0_nk(ink, itemp) + self%angwgth(iang) * qzd2 * inv_qepsq2 * inv_wqnu2
5697 : : !! !z0_nk(ink, itemp) = z0_nk(ink, itemp) +
5698 : : !! end do ! itemp
5699 : : !! end do ! ink
5700 : : !!
5701 : : !! ! Get phonon occupation for all temperatures.
5702 : : !! !nqnu_tlist = occ_be(wqnu, kTmesh(:), zero)
5703 : : !!
5704 : : !! if (nwr > 0) then
5705 : : !! ! ! NB: summing over f * angwgth gives the spherical average 1/(4pi) \int domega f(omega)
5706 : : !! ! weight = four_pi * self%angwgth(iang) * abs(cnum) ** 2 * inv_qepsq2 / wqnu
5707 : : !! ! do ib_k=1,nbcalc_ks
5708 : : !! ! band_ks = ib_k + bstart_ks - 1; eig0nk = ebands%eig(band_ks, ik_ibz, spin)
5709 : : !! ! do it=1,sigma%ntemp
5710 : : !! ! f_nk = f_tlist_b(it,ib_k)
5711 : : !! ! nqnu = nqnu_tlist(it)
5712 : : !! ! fmw_frohl_sphcorr(:,nu,it,ib_k) = fmw_frohl_sphcorr(:,nu,it,ib_k) + &
5713 : : !! ! ((nqnu + f_nk ) / (sigma%wrmesh_b(:,ib_k) - eig0nk + wqnu + sigma%ieta) + &
5714 : : !! ! (nqnu - f_nk + one) / (sigma%wrmesh_b(:,ib_k) - eig0nk - wqnu + sigma%ieta) ) * weight
5715 : : !! ! end do ! it
5716 : : !! ! end do ! ib_k
5717 : : !! end if
5718 : : !!
5719 : : !! end do
5720 : : !! end associate
5721 : : !! end do ! iang
5722 : : !!
5723 : : !! do ink=1,nk_size
5724 : : !! do itemp=1,ntemp
5725 : : !! sig0_nk(ink, itemp) = sig0_nk(ink, itemp) * q0rad / (pi * cryst%ucvol) * (two * f_nk(ink, itemp) - one)
5726 : : !! !z0_nk(ink, itemp) = z0_nk(ink, itemp) +
5727 : : !! end do ! itemp
5728 : : !! end do ! ink
5729 : : !!
5730 : : !! call xmpi_sum(sig0_nk, comm, ierr)
5731 : : !! call xmpi_sum(z0_nk, comm, ierr)
5732 : : !!
5733 : : !! end subroutine frohl_integrator_eval
5734 : : !!***
5735 : :
5736 : : !!****f* m_epthk/frohl_integrator_free
5737 : : !! NAME
5738 : : !!
5739 : : !! FUNCTION
5740 : : !! Free dynamical memory
5741 : : !!
5742 : : !! SOURCE
5743 : :
5744 : 0 : subroutine frohl_integrator_free(self)
5745 : :
5746 : : !Arguments ------------------------------------
5747 : : class(frohl_integrator_t),intent(inout) :: self
5748 : : !************************************************************************
5749 : :
5750 [ # # ]: 0 : ABI_SFREE(self%qvers_cart)
5751 [ # # ]: 0 : ABI_SFREE(self%angwgth)
5752 [ # # ]: 0 : ABI_SFREE(self%phfrq)
5753 [ # # ]: 0 : ABI_SFREE(self%displ_cart)
5754 : :
5755 : 0 : end subroutine frohl_integrator_free
5756 : : !!***
5757 : :
5758 [ # # # # : 0 : end module m_sigmaph
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
5759 : : !!***
|
