Branch data Line data Source code
1 : : !!****m* ABINIT/m_phgamma
2 : : !! NAME
3 : : !!
4 : : !! FUNCTION
5 : : !! Computation of phonon linewidths, isotropic superconducting properties,
6 : : !! and transport properties in metals within the LOVA approximation
7 : : !! to the linearized Boltzmann equation.
8 : : !!
9 : : !! COPYRIGHT
10 : : !! Copyright (C) 2008-2026 ABINIT group (MG)
11 : : !! This file is distributed under the terms of the
12 : : !! GNU General Public License, see ~abinit/COPYING
13 : : !! or http://www.gnu.org/copyleft/gpl.txt .
14 : : !!
15 : : !! TODO
16 : : !! 1) Implement restart capabilities (eph_restart).
17 : : !! 2) Sum over the IBZ(q) on the FS instead of full BZ.
18 : : !! 3) Gaussian adaptive smearing for double delta (tetra version from libtetrabz really slow!).
19 : : !! 4) Automatic detections of energy window, improve filtering techniques.
20 : : !! 5) Interface with KERANGE trick
21 : : !! 6) More examples and tutorials (using precomputed Netcdf files).
22 : : !! 7) Implement SKW interpolation for ph linewidths and/or linear interpolation (I don't trust plain Fourier interpolation).
23 : : !! 8) Perform more benchmarks with dense meshes to detect hotspots and memory bottlenecks.
24 : : !! 9) Test spin and SOC.
25 : : !!
26 : : !! SOURCE
27 : :
28 : : #if defined HAVE_CONFIG_H
29 : : #include "config.h"
30 : : #endif
31 : :
32 : : #include "abi_common.h"
33 : :
34 : : module m_phgamma
35 : :
36 : : use, intrinsic :: iso_c_binding
37 : : use defs_basis
38 : : use m_abicore
39 : : use m_xmpi
40 : : use m_errors
41 : : use m_krank
42 : : use m_htetra
43 : : use m_tetrahedron
44 : : use libtetrabz
45 : : use m_ifc
46 : : use m_ebands
47 : : use m_fstab
48 : : use m_nctk
49 : : use netcdf
50 : : use m_wfk
51 : : use m_ddb
52 : : use m_ddk
53 : : use m_dvdb
54 : : use m_crystal
55 : : use m_fft
56 : : use m_hamiltonian
57 : : use m_pawcprj
58 : : use m_dtset
59 : : use m_dtfil
60 : : use m_ephtk
61 : : use m_mkffnl
62 : :
63 : : use defs_abitypes, only : mpi_type
64 : : use defs_datatypes, only : pseudopotential_type
65 : : use m_time, only : cwtime, cwtime_report
66 : : use m_fstrings, only : toupper, itoa, sjoin, ktoa, ltoa, strcat
67 : : use m_numeric_tools, only : arth, wrap2_pmhalf, simpson_int, simpson, mkherm, get_diag, isdiagmat
68 : : use m_io_tools, only : open_file, iomode_from_fname
69 : : use m_symtk, only : littlegroup_q
70 : : use m_geometry, only : normv
71 : : use m_special_funcs, only : gaussian
72 : : use m_fftcore, only : ngfft_seq, get_kg
73 : : use m_cgtools, only : cg_zdotc
74 : : use m_kg, only : getph, mkkpg
75 : : use m_dynmat, only : symdyma, ftgam_init, ftgam, asrif9
76 : : use m_bz_mesh, only : kpath_t
77 : : use m_special_funcs, only : fermi_dirac
78 : : use m_kpts, only : kpts_ibz_from_kptrlatt, tetra_from_kptrlatt, kpts_timrev_from_kptopt, kpts_map
79 : : use defs_elphon, only : complete_gamma !, complete_gamma_tr
80 : : use m_getgh1c, only : getgh1c, rf_transgrid_and_pack
81 : : use m_pawang, only : pawang_type
82 : : use m_pawrad, only : pawrad_type
83 : : use m_pawtab, only : pawtab_type
84 : : use m_pawfgr, only : pawfgr_type
85 : : use m_wfd, only : wfd_t
86 : : use m_pstat, only : pstat_proc
87 : : use m_lgroup, only : lgroup_t
88 : : use m_abi_linalg, only : abi_gpu_xgemm_d
89 : :
90 : : implicit none
91 : :
92 : : private
93 : : !!***
94 : :
95 : : public :: eph_phgamma
96 : : public :: find_ewin
97 : :
98 : : !----------------------------------------------------------------------
99 : :
100 : : !!****t* m_phgamma/phgamma_t
101 : : !! NAME
102 : : !! phgamma_t
103 : : !!
104 : : !! FUNCTION
105 : : !! Provides methods for computing phonon linewidths, interpolating the results
106 : : !! in q-space and evaluate superconducting properties within the isotropic formalism.
107 : : !!
108 : : !! SOURCE
109 : :
110 : : type,public :: phgamma_t
111 : :
112 : : integer :: natom = -1
113 : : ! Number of atoms per unit cell.
114 : :
115 : : integer :: natom3 = -1
116 : : ! Number of phonon branches i.e. 3*natom.
117 : :
118 : : integer :: nsppol = -1
119 : : ! Number of independent spin polarizations.
120 : :
121 : : integer :: nspinor = -1
122 : : ! Number of spinorial components.
123 : :
124 : : integer :: nqibz = -1
125 : : ! Number of q-points in the IBZ.
126 : :
127 : : integer :: my_nqibz = -1
128 : : ! Number of q-points in the IBZ treated by the current MPI processor
129 : :
130 : : integer :: nqbz = -1
131 : : ! Number of q-points in the BZ.
132 : :
133 : : integer :: eph_scalprod = 0
134 : : ! This to call anaddb routines. Note that eph_scalprod 1 is not supported in eph.
135 : :
136 : : integer :: bcorr = 0
137 : : ! 1 to include Blochl correction in the tetrahedron method else 0.
138 : :
139 : : integer :: prteliash = 0
140 : : ! This flag activates the computation of the Eliashberg function.
141 : :
142 : : integer :: nrpt = -1
143 : : ! Number of R-points in the real space representation of the gamma matrices.
144 : :
145 : : integer :: symgamma
146 : : ! 1 if gamma matrices should be symmetrized by symdyma when using Fourier interpolation
147 : :
148 : : integer :: asr
149 : : ! If the "Acoustic rule" at Gamma should be enforced.
150 : :
151 : : integer :: ndir_transp = 0
152 : : ! 0 if no transport, otherwise 3.
153 : :
154 : : integer :: ngqpt(3)
155 : : ! Number of divisions in the q-mesh.
156 : :
157 : : integer :: nene = -1
158 : : ! Number of chemical potential values used for inelastic integration
159 : :
160 : : !integer :: my_nqpt
161 : : !integer,allocatable :: my_iqpt(:)
162 : :
163 : : integer :: my_nfsk_q = -1
164 : : ! Number of k-points in the FS treated by this MPI processor for a given q.
165 : : ! Computed in phgamma_setup_qpoint.
166 : :
167 : : integer,allocatable :: my_ifsk_q(:)
168 : : ! Index of the FS k-points treated by this processor for a given q
169 : : ! Computed in phgamma_setup_qpoint.
170 : :
171 : : integer :: my_nspins = -1
172 : : ! Number of spins treated by the MPI rank.
173 : :
174 : : integer,allocatable :: my_spins(:)
175 : : ! my_spins(my_nspins)
176 : : ! Indirect table giving the spin indices treated by this rank.
177 : : ! Used only the collinear case with nspinor == 1
178 : :
179 : : !integer :: my_npert
180 : : ! Number of atomic perturbations or phonon modes treated by this MPI rank.
181 : :
182 : : !integer(i1b),allocatable :: itreat_qibz(:)
183 : : ! itreat_qibz(nqibz)
184 : : ! Table used to distribute potentials over q-points in the IBZ.
185 : : ! The loop over qpts in the IBZ(k) is MPI distributed inside qpt_comm accordinging to this table.
186 : : ! 0 if this IBZ point is not treated by this proc.
187 : : ! 1 if this IBZ is treated.
188 : :
189 : : !integer,allocatable :: my_pinfo(:,:)
190 : : ! my_pinfo(3, my_npert)
191 : : ! my_pinfo(1, ip) gives the `idir` index of the ip-th perturbation.
192 : : ! my_pinfo(2, ip) gives the `ipert` index of the ip-th perturbation.
193 : : ! my_pinfo(3, ip) gives `pertcase`=idir + (ipert-1)*3
194 : :
195 : : !integer,allocatable :: pert_table(:,:)
196 : : ! pert_table(2, natom3)
197 : : ! pert_table(1, npert): rank of the processor treating this atomic perturbation.
198 : : ! pert_table(2, npert): my_ip index in my_pinfo table, -1 if this rank is not treating ipert.
199 : :
200 : : integer, allocatable :: my_iqibz(:)
201 : : ! indices of ibz iq in local array. -1 if iq does not belong to current proc
202 : :
203 : : integer, allocatable :: my_iqbz(:)
204 : : ! List of iq_ibz indices treated by current proc
205 : :
206 : : real(dp) :: enemin
207 : : ! Minimal chemical potential value used for inelastic integration Copied from fstab
208 : :
209 : : real(dp) :: deltaene
210 : : ! Chemical potential increment for inelastic integration Copied from fstab
211 : : ! for simplicity could be made equal to phonon frequency step
212 : :
213 : : real(dp) :: gprim(3,3)
214 : : ! Needed for Fourier interpolation.
215 : : ! NOTE: gprim (not gprimd) is used for all FT interpolations,
216 : : ! to be consistent with the dimensions of the rpt, which come from anaddb.
217 : :
218 : : real(dp),allocatable :: n0(:)
219 : : ! (%nsppol)
220 : : ! Density of states at the Fermi level per spin in a.u.
221 : :
222 : : real(dp),allocatable :: qibz(:,:)
223 : : ! qibz(3,nqibz)
224 : : ! Reduced coordinates of the q-points in the IBZ.
225 : :
226 : : real(dp),allocatable :: wtq(:)
227 : : ! wtq(nqibz)
228 : : ! Weights of the q-points in the IBZ (normalized to one)
229 : :
230 : : real(dp),allocatable :: qbz(:,:)
231 : : ! qbz(3,nqbz)
232 : : ! Reduced coordinates of the q-points in the BZ.
233 : :
234 : : real(dp),allocatable :: rpt(:,:)
235 : : ! rpt(3,nrpt)
236 : : ! Reduced coordinates ***in terms of rprim*** of the lattice points used
237 : : ! for the Fourier transform of the phonon linewidths.
238 : :
239 : : real(dp),allocatable :: wghatm(:,:,:)
240 : : ! wghatm(natom,natom,nrpt)
241 : : ! Weights used in the FT of the phonon linewidths.
242 : :
243 : : real(dp),allocatable :: vals_qibz(:,:,:,:,:)
244 : : ! vals_qibz(2,natom3,natom3,nqibz,nsppol)) in reduced coordinates for each q-point in the IBZ.
245 : : ! vals_qibz {\tau'\alpha',\tau\alpha} = sum over k, im_kq, in_k
246 : : ! <psi_{k+q,im_kq} | H(1)_{\tau'\alpha'} | psi_{k,in_k}>* \cdot
247 : : ! <psi_{k+q,im_kq} | H(1)_{\tau \alpha } | psi_{k,in_k}>
248 : :
249 : : !NOTE: choice to put nsppol before or after nqbz is a bit arbitrary
250 : : ! abinit uses nband,nkpt,nsppol, but here for convenience nkpt_phon,nsppol,nqbz interpolation is on qpt
251 : : !MG: I think that nsppol should be the last dimension set call to ftgam.
252 : :
253 : : real(dp),allocatable :: vals_rpt(:,:,:,:)
254 : : ! vals_rpt(2,natom3**2,nrpt,nsppol)
255 : : ! tgamma matrices in real space in reduced coordinates. Used for the Fourier interpolation.
256 : :
257 : : ! transport stuff with velocity factors
258 : : real(dp),allocatable :: vals_in_qibz(:,:,:,:,:,:)
259 : : real(dp),allocatable :: vals_out_qibz(:,:,:,:,:,:)
260 : : ! vals_XX_qibz(2,9,natom3,natom3,nqibz,nsppol)) in reduced coordinates for each q-point in the IBZ.
261 : :
262 : : real(dp),allocatable :: vals_in_rpt(:,:,:,:,:)
263 : : real(dp),allocatable :: vals_out_rpt(:,:,:,:,:)
264 : : ! vals_XX_rpt(2,9,natom3**2,nrpt,nsppol)
265 : : ! tgamma matrices in real space in reduced coordinates.
266 : :
267 : : ! gamma matrices keeping full electron energy dependency
268 : : real(dp),allocatable :: vals_ee(:,:,:,:,:,:,:)
269 : : ! vals_eew(2, nene, nene, natom3, natom3, nqibz, nsppol)
270 : :
271 : : contains
272 : :
273 : : procedure :: free => phgamma_free
274 : : ! Free memory.
275 : :
276 : : procedure :: interp => phgamma_interp
277 : : ! Interpolates the phonon linewidths.
278 : :
279 : : procedure :: eval_qibz => phgamma_eval_qibz
280 : : ! Evaluate phonon linewidths without Fourier interpolation.
281 : :
282 : : procedure :: interp_setup => phgamma_interp_setup
283 : : ! Compute the tables used for the interpolation in q-space.
284 : :
285 : : procedure :: linwid => phgamma_linwid
286 : : ! Interpolate linewidths along an arbitrary q-path.
287 : :
288 : : end type phgamma_t
289 : :
290 : : public :: phgamma_init ! Creation method.
291 : : !!***
292 : :
293 : : !----------------------------------------------------------------------
294 : :
295 : : !!****t* m_phgamma/a2fw_t
296 : : !! NAME
297 : : !! a2fw_t
298 : : !!
299 : : !! FUNCTION
300 : : !! Store the Eliashberg function a2F(w).
301 : : !!
302 : : !! SOURCE
303 : :
304 : : type,public :: a2fw_t
305 : :
306 : : integer :: nomega
307 : : ! Number of frequency points in a2f(w).
308 : :
309 : : integer :: nsppol
310 : : ! Number of independent spin polarizations.
311 : :
312 : : integer :: natom3
313 : : ! Number of phonon modes.
314 : :
315 : : integer :: nene
316 : : ! Number of chemical potential values used for inelastic integration
317 : :
318 : : real(dp) :: enemin
319 : : ! Minimal chemical potential value used for inelastic integration Copied from fstab
320 : :
321 : : real(dp) :: deltaene
322 : : ! Chemical potential increment for inelastic integration Copied from fstab
323 : : ! for simplicity could be made equal to phonon frequency step
324 : :
325 : : real(dp) :: omega_min, omega_max
326 : : ! min and Max frequency (Ha) in the linear mesh.
327 : :
328 : : real(dp) :: wstep
329 : : ! Step of the linear mesh
330 : :
331 : : real(dp) :: smear
332 : : ! Gaussian broadening used to approximated the Dirac distribution.
333 : :
334 : : integer :: nqshift
335 : : ! Number of shifts in the q-mesh
336 : :
337 : : integer :: ngqpt(3)
338 : : ! The q-mesh used for calculating vals(w).
339 : :
340 : : real(dp),allocatable :: qshift(:,:)
341 : : ! qshift(3,nqshift)
342 : : ! The shifts used to generate the q-mesh.
343 : :
344 : : real(dp),allocatable :: n0(:)
345 : : ! n0(nsppol)
346 : : ! Electronic DOS at the Fermi level.
347 : :
348 : : real(dp),allocatable :: omega(:)
349 : : ! omega(nomega)
350 : : ! Frequency mesh in Hartree (linear).
351 : :
352 : : real(dp),allocatable :: vals(:,:,:)
353 : : ! vals(nomega, 0:natom3, nsppol)
354 : : ! Eliashberg function
355 : : ! vals(w, 1:natom3, 1:nsppol): a2f(w) decomposed per phonon branch and spin
356 : : ! vals(w, 0 , 1:nsppol): a2f(w) summed over phonons modes, decomposed in spin
357 : :
358 : : real(dp),allocatable :: vals_ee(:,:,:,:)
359 : : ! vals_ee(nene,nene,nomega,nsppol)
360 : : ! Eliashberg function
361 : : ! vals(e,e',w,0,1:nsppol): a2f(e,e',w) summed over phonons modes, decomposed in spin
362 : :
363 : : real(dp),allocatable :: lambdaw(:,:,:)
364 : : ! lambda(nomega,0:natom3,nsppol)
365 : :
366 : : contains
367 : :
368 : : procedure :: init => a2fw_init !
369 : : ! Calculates the FS averaged alpha^2F(w) function.
370 : :
371 : : procedure :: free => a2fw_free
372 : : ! Free the memory allocated in the structure.
373 : :
374 : : procedure :: write => a2fw_write
375 : : ! Write alpha^2F(w) to an external file in text/netcdf format
376 : :
377 : : procedure :: get_moment => a2fw_get_moment
378 : : ! Compute moments of alpha^2F(w)/w .
379 : : end type a2fw_t
380 : : !!***
381 : :
382 : : !!****t* m_phgamma/a2fw_tr_t
383 : : !! NAME
384 : : !! a2fw_tr_t
385 : : !!
386 : : !! FUNCTION
387 : : !! Store the Eliashberg transport spectral functions:
388 : : !! a2F_trin(w, x, x')
389 : : !! a2F_trout(w, x, x')
390 : : !! a2F_tr(w, x, x') = in - out
391 : : !! a2F_tr_gen(e, e', w, x, x')
392 : : !!
393 : : !! SOURCE
394 : :
395 : : type,public :: a2fw_tr_t
396 : :
397 : : integer :: nomega
398 : : ! Number of frequency points in a2f_tr(w).
399 : :
400 : : integer :: nene
401 : : ! Number of chemical potential values used for inelastic integration
402 : : ! Number of electron points in a2f_tr_gen(e,e',w).
403 : :
404 : : integer :: nsppol
405 : : ! Number of independent spin polarizations.
406 : :
407 : : integer :: natom3
408 : : ! Number of phonon modes.
409 : :
410 : : real(dp) :: enemin
411 : : ! Minimal chemical potential value used for inelastic integration
412 : :
413 : : real(dp) :: deltaene
414 : : ! Chemical potential increment for inelastic integration
415 : :
416 : : real(dp) :: omega_min,omega_max
417 : : ! min and Max frequency (Ha) in the linear mesh.
418 : :
419 : : real(dp) :: wstep
420 : : ! Step of the linear mesh
421 : :
422 : : real(dp) :: smear
423 : : ! Gaussian broadening used to approximated the Dirac distribution.
424 : :
425 : : integer :: nqshift
426 : : ! Number of shifts in the q-mesh
427 : :
428 : : integer :: ngqpt(3)
429 : : ! The q-mesh used for calculating vals(w).
430 : :
431 : : real(dp),allocatable :: qshift(:,:)
432 : : ! qshift(3,nqshift)
433 : : ! The shifts used to generate the q-mesh.
434 : :
435 : : real(dp),allocatable :: n0(:)
436 : : ! n0(nsppol)
437 : : ! Electronic DOS at the Fermi level.
438 : :
439 : : real(dp),allocatable :: omega(:)
440 : : ! omega(nomega)
441 : : ! Frequency mesh in Hartree (linear).
442 : :
443 : : real(dp),allocatable :: vals_in(:,:,:,:,:)
444 : : real(dp),allocatable :: vals_out(:,:,:,:,:)
445 : : ! vals_in(nomega,3,3,0:natom3,nsppol)
446 : : ! Eliashberg transport functions for in and out scattering
447 : : ! vals_in(w,3,3,1:natom3,1:nsppol): a2f_tr(w) decomposed per phonon branch and spin
448 : : ! vals_in(w,3,3,0,1:nsppol): a2f_tr(w) summed over phonons modes, decomposed in spin
449 : :
450 : : real(dp),allocatable :: vals_tr(:,:,:,:,:)
451 : : ! vals_tr(nomega,3,3,0:natom3,nsppol)
452 : : ! transport spectral function = in-out
453 : :
454 : : real(dp),allocatable :: vals_tr_gen(:,:,:,:,:,:,:)
455 : : ! vals(nene,nene,nomega,3,3,nsppol)
456 : : ! generalized transport spectral function from PB Allen Phys. Rev. Lett. 59, 1460 (1987) [[cite:Allen1987]]
457 : :
458 : : real(dp),allocatable :: lambdaw_tr(:,:,:,:,:)
459 : : ! lambda(nomega,3,3,0:natom3,nsppol)
460 : :
461 : : contains
462 : :
463 : : procedure :: init => a2fw_tr_init
464 : : ! Calculates the FS averaged alpha^2F_tr,in,out(w, x, x') functions.
465 : :
466 : : procedure :: free => a2fw_tr_free
467 : : ! Free the memory allocated in the structure.
468 : :
469 : : procedure :: write => a2fw_tr_write
470 : : ! Write alpha^2F(w) to an external file in text/netcdf format
471 : :
472 : : end type a2fw_tr_t
473 : : !!***
474 : :
475 : : real(dp),private,parameter :: EPH_Q0TOL = 0.01_dp
476 : :
477 : : contains !=====================================================
478 : : !!***
479 : :
480 : : !----------------------------------------------------------------------
481 : :
482 : : !!****f* m_phgamma/phgamma_free
483 : : !! NAME
484 : : !! phgamma_free
485 : : !!
486 : : !! FUNCTION
487 : : !! Free the dynamic memory
488 : : !!
489 : : !! SOURCE
490 : :
491 : 5 : subroutine phgamma_free(gams)
492 : :
493 : : !Arguments ------------------------------------
494 : : class(phgamma_t),intent(inout) :: gams
495 : : ! *************************************************************************
496 : :
497 : : !real
498 [ + - ]: 5 : ABI_SFREE(gams%n0)
499 [ + - ]: 5 : ABI_SFREE(gams%qibz)
500 [ + - ]: 5 : ABI_SFREE(gams%wtq)
501 [ + - ]: 5 : ABI_SFREE(gams%qbz)
502 [ + - ]: 5 : ABI_SFREE(gams%rpt)
503 [ + - ]: 5 : ABI_SFREE(gams%wghatm)
504 [ + - ]: 5 : ABI_SFREE(gams%vals_qibz)
505 [ + - ]: 5 : ABI_SFREE(gams%vals_rpt)
506 [ + - ]: 5 : ABI_SFREE(gams%vals_in_qibz)
507 [ + - ]: 5 : ABI_SFREE(gams%vals_in_rpt)
508 [ + - ]: 5 : ABI_SFREE(gams%vals_out_qibz)
509 [ + - ]: 5 : ABI_SFREE(gams%vals_out_rpt)
510 [ - + ]: 5 : ABI_SFREE(gams%vals_ee)
511 [ + - ]: 5 : ABI_SFREE(gams%my_iqibz)
512 [ + - ]: 5 : ABI_SFREE(gams%my_ifsk_q)
513 [ + - ]: 5 : ABI_SFREE(gams%my_spins)
514 : :
515 : 5 : end subroutine phgamma_free
516 : : !!***
517 : :
518 : : !----------------------------------------------------------------------
519 : :
520 : : !!****f* m_phgamma/phgamma_init
521 : : !! NAME
522 : : !! phgamma_init
523 : : !!
524 : : !! FUNCTION
525 : : !! Creation method for the phgamma_t datatype.
526 : : !!
527 : : !! INPUTS
528 : : !! cryst<crystal_t>
529 : : !! ifc<ifc_type>=Interatomic force constants.
530 : : !! symdynmat=1 to activa symmetrization of gamma matrices.
531 : : !! ngqpt(3)=Q-mesh divisions
532 : : !! n0(dtset%nsppol)=Density of states at the Fermi level per spin.
533 : : !!
534 : : !! OUTPUT
535 : : !! gams<phgamma_t>
536 : : !!
537 : : !! SOURCE
538 : :
539 [ + - ]: 5 : subroutine phgamma_init(gams, cryst, ifc, ebands, fstab, dtset, eph_scalprod, ngqpt, n0, comm)
540 : :
541 : : !Arguments ------------------------------------
542 : : !scalars
543 : : class(phgamma_t),intent(out) :: gams
544 : : integer,intent(in) :: eph_scalprod, comm
545 : : type(crystal_t),intent(in) :: cryst
546 : : type(ifc_type),intent(in) :: ifc
547 : : type(ebands_t),intent(in) :: ebands
548 : : type(fstab_t), intent(in) :: fstab
549 : : type(dataset_type),intent(in) :: dtset
550 : : !arrays
551 : : integer,intent(in) :: ngqpt(3)
552 : : real(dp),intent(in) :: n0(dtset%nsppol)
553 : :
554 : : !Local variables-------------------------------
555 : : !scalars
556 : : integer :: my_rank, nproc, ierr, nsppol, natom3, qptopt, qtimrev
557 : : !arrays
558 : : integer :: qptrlatt(3,3)
559 : : ! *************************************************************************
560 : :
561 : 5 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
562 : :
563 : : ! Set basic dimensions.
564 : 5 : nsppol = dtset%nsppol; gams%nsppol = nsppol; gams%nspinor = dtset%nspinor
565 : :
566 : 5 : gams%natom = cryst%natom; gams%natom3 = 3*cryst%natom; natom3 = gams%natom3
567 : :
568 : 5 : gams%symgamma = dtset%symdynmat; gams%eph_scalprod = eph_scalprod
569 : : !gams%asr = ifc%asr
570 : 5 : gams%asr = 0
571 : 5 : gams%prteliash = dtset%prteliash
572 : :
573 [ + - ]: 5 : gams%ndir_transp = 0; if (dtset%eph_transport > 0) gams%ndir_transp = 3
574 : :
575 : : ! Copy DOS.
576 [ - + + - : 15 : ABI_MALLOC(gams%n0, (nsppol))
+ - + - -
+ - + -
+ ]
577 [ - + + + ]: 15 : gams%n0 = n0
578 : :
579 : 5 : gams%nene = fstab%nene
580 : 5 : gams%enemin = fstab%enemin
581 : 5 : gams%deltaene = fstab%deltaene
582 : :
583 : : ! Setup IBZ, weights and BZ. Always use q --> -q symmetry for phonons even in systems wo inversion
584 [ + + ]: 20 : gams%ngqpt = ngqpt
585 : 5 : qptrlatt = 0; qptrlatt(1,1) = ngqpt(1); qptrlatt(2,2) = ngqpt(2); qptrlatt(3,3) = ngqpt(3)
586 [ - + ]: 5 : qptopt = ebands%kptopt; if (dtset%qptopt /= 0) qptopt = dtset%qptopt
587 : : qtimrev = kpts_timrev_from_kptopt(qptopt)
588 : :
589 : : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, qptopt, 1, [zero, zero, zero], &
590 [ - + - + : 5 : gams%nqibz, gams%qibz, gams%wtq, gams%nqbz, gams%qbz)
- + ]
591 : :
592 : : ! Allocate matrices in the IBZ.
593 [ - + + - : 30 : ABI_MALLOC_OR_DIE(gams%vals_qibz, (2, natom3, natom3, gams%nqibz, nsppol), ierr)
- + + - -
+ + - - +
+ - + - +
- + - + -
- + + - -
+ ]
594 [ + + + + : 1901 : gams%vals_qibz = zero
+ + + + +
+ ]
595 : :
596 [ + - ]: 5 : if (dtset%eph_transport > 0) then
597 [ - + + - : 30 : ABI_MALLOC_OR_DIE(gams%vals_in_qibz, (2, 9, natom3, natom3, gams%nqibz, nsppol), ierr)
- + + - -
+ + - - +
+ - + - +
- + - + -
- + + - -
+ ]
598 [ + + + + : 15626 : gams%vals_in_qibz = zero
+ + + + +
+ + + ]
599 [ - + + - : 30 : ABI_MALLOC_OR_DIE(gams%vals_out_qibz, (2, 9, natom3, natom3, gams%nqibz, nsppol), ierr)
- + + - -
+ + - - +
+ - + - +
- + - + -
- + + - -
+ ]
600 [ + + + + : 15626 : gams%vals_out_qibz = zero
+ + + + +
+ + + ]
601 : : end if
602 : :
603 [ - + ]: 5 : if (gams%prteliash == 3) then
604 [ # # # # : 0 : ABI_MALLOC_OR_DIE(gams%vals_ee, (2, gams%nene, gams%nene, natom3, natom3, gams%nqibz, nsppol), ierr)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
605 [ # # # # : 0 : gams%vals_ee = zero
# # # # #
# # # #
# ]
606 : : end if
607 : :
608 : : ! Prepare Fourier interpolation. gams%gprim actually holds Ifc%gprimd
609 : : ! (renamed to gprimd would ripple through this type's other uses; the
610 : : ! important invariant is that it stays paired with gams%rpt, which is
611 : : ! Ifc%rpt -- now cartesian, dual to gprimd, not the historical gprim).
612 [ + + + + ]: 65 : gams%gprim = ifc%gprimd
613 : 5 : gams%nrpt = ifc%nrpt
614 [ - + + - : 15 : ABI_MALLOC(gams%rpt, (3, gams%nrpt))
+ - + - -
+ - + -
+ ]
615 [ + - + - : 1870 : gams%rpt = ifc%rpt
- + - - -
- - - + +
+ + ]
616 [ - + + - : 25 : ABI_MALLOC(gams%wghatm, (gams%natom, gams%natom, gams%nrpt))
- + + - -
+ + - + -
+ - - + -
+ - + ]
617 [ + - + - : 1405 : gams%wghatm = ifc%wghatm
+ - - + -
- - - - -
- - + + +
+ + + ]
618 : :
619 : 5 : end subroutine phgamma_init
620 : : !!***
621 : :
622 : : !----------------------------------------------------------------------
623 : :
624 : : !!****f* m_phgamma/phgamma_ncwrite
625 : : !! NAME
626 : : !! phgamma_ncwrite
627 : : !!
628 : : !! FUNCTION
629 : : !! Write the results stored in the phgamma_t datatype to netcdf file.
630 : : !!
631 : : !! INPUTS
632 : : !! cryst<crystal_t>=Crystalline structure.
633 : : !! ifc<ifc_type>=Interatomic force constants.
634 : : !! ncid=Netcdf file handler (already open in the caller).
635 : : !!
636 : : !! SOURCE
637 : :
638 : 5 : subroutine phgamma_ncwrite(gams, cryst, ifc, ncid)
639 : :
640 : : !Arguments ------------------------------------
641 : : !scalars
642 : : class(phgamma_t),intent(inout) :: gams
643 : : type(crystal_t),intent(in) :: cryst
644 : : type(ifc_type),intent(in) :: ifc
645 : : integer,intent(in) :: ncid
646 : :
647 : : !Local variables-------------------------------
648 : : !scalars
649 : : integer :: max_nqpt = 50
650 : : integer :: iq_ibz,spin,mu, units(2)
651 : : real(dp) :: lambda_tot, cpu, wall, gflops
652 : : character(len=500) :: msg
653 : : !arrays
654 : 10 : real(dp) :: phfrq(3*cryst%natom), gamma_ph(3*cryst%natom), lambda_ph(3*cryst%natom)
655 : 10 : real(dp) :: displ_cart(2,3*cryst%natom,3*cryst%natom)
656 : : ! *************************************************************************
657 : :
658 [ + + ]: 15 : units = [std_out, ab_out]
659 : 5 : call cwtime(cpu, wall, gflops, "start")
660 : :
661 : : ! Write data to files for each q point, also compute total lambda.
662 : 5 : lambda_tot = zero
663 [ + + ]: 10 : do spin=1,gams%nsppol
664 [ + + ]: 66 : do iq_ibz=1,gams%nqibz
665 : :
666 : : ! Get phonon frequencies, gamma(q,nu) and lambda(q,nu).
667 : : ! Quantities are already summed over (collinear) spin channels if nsppol == 1.
668 : 61 : call gams%eval_qibz(cryst, ifc, iq_ibz, spin, phfrq, gamma_ph, lambda_ph, displ_cart)
669 : :
670 [ + + ]: 244 : do mu=1,gams%natom3
671 : 244 : lambda_tot = lambda_tot + lambda_ph(mu) * gams%wtq(iq_ibz)
672 : : end do
673 : :
674 : : ! Write data to netcdf file
675 [ + - ]: 61 : if (ncid /= nctk_noid) then
676 [ + - ]: 61 : if (spin == 1) then
677 [ + + - + : 183 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "phfreq_qibz"), phfrq, start=[1, iq_ibz]))
- - ]
678 [ + + - + : 305 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, 'phdispl_cart_qibz'), displ_cart, start=[1, 1, 1, iq_ibz]))
- - ]
679 : : end if
680 [ + + - + : 244 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, 'phgamma_qibz'), gamma_ph, start=[1, iq_ibz, spin]))
- - ]
681 [ + + - + : 244 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, 'phlambda_qibz'), lambda_ph, start=[1, iq_ibz, spin]))
- - ]
682 : : end if
683 : :
684 : : ! Output to the main output file
685 [ + - ]: 66 : if (iq_ibz <= max_nqpt) then
686 [ - + ]: 61 : if (gams%nsppol == 2) then
687 : 0 : write(msg,'(2a,3es16.6,a,i1,a,a)')ch10,&
688 : 0 : ' q-point =',gams%qibz(:, iq_ibz),' spin = ',spin,ch10,&
689 : 0 : ' Mode number Frequency (Ha) Linewidth (Ha) Lambda(q,n)'
690 : : else
691 : 61 : write(msg,'(2a,3es16.6,a,a)')ch10,&
692 : 61 : ' q-point =',gams%qibz(:, iq_ibz),ch10,&
693 : 122 : ' Mode number Frequency (Ha) Linewidth (Ha) Lambda(q,n)'
694 : : end if
695 : 61 : call wrtout(units, msg)
696 [ + + ]: 244 : do mu=1,gams%natom3
697 : 183 : write(msg,'(i5,es20.6,2es16.6)')mu, phfrq(mu), gamma_ph(mu), lambda_ph(mu)
698 : 244 : call wrtout(units, msg)
699 : : end do
700 : : else
701 [ # # ]: 0 : if (iq_ibz == max_nqpt + 1) then
702 : 0 : call wrtout(units, sjoin(" No more that:", itoa(max_nqpt), " q-points are reported in the main output file"))
703 : 0 : call wrtout(units, " Use A2f.nc and AbiPy to analyze the results.")
704 : : end if
705 : : end if
706 : :
707 : : end do
708 : : ! Add blank lines to output files between spins
709 : 10 : call wrtout(units, "", do_flush=.True.)
710 : : end do
711 : :
712 : 5 : write(ab_out,"(a,f8.4)")" lambda= ",lambda_tot
713 : : !write(ab_out,"(a,f8.4)")" omega_log= ",omega_log
714 : :
715 : 5 : call cwtime_report(" phgamma_ncwrite:", cpu, wall, gflops)
716 : :
717 : 5 : end subroutine phgamma_ncwrite
718 : : !!***
719 : :
720 : : !----------------------------------------------------------------------
721 : :
722 : : !!****f* m_phgamma/tgamma_symm
723 : : !! NAME
724 : : !! tgamma_symm
725 : : !!
726 : : !! FUNCTION
727 : : !! Symmetrize the tgamma matrix
728 : : !!
729 : : !! INPUTS
730 : : !! qpt(3)=phonon wavevector in reduced coordinates.
731 : : !! cryst<crystal_t>=Crystalline structure.
732 : : !!
733 : : !! SOURCE
734 : :
735 : 14809 : subroutine tgamma_symm(cryst, qpt, tgamma)
736 : :
737 : : !Arguments ------------------------------------
738 : : !scalars
739 : : type(crystal_t),intent(in) :: cryst
740 : : !arrays
741 : : real(dp),intent(in) :: qpt(3)
742 : : real(dp),intent(inout) :: tgamma(2,3*cryst%natom,3*cryst%natom)
743 : :
744 : : !Local variables-------------------------------
745 : : !scalars
746 : : integer :: ii,natom3,k
747 : : !arrays
748 : 29618 : real(dp) :: tgcart(2,3*cryst%natom,3*cryst%natom)
749 : 14809 : real(dp) :: umat(2,3*cryst%natom,3*cryst%natom),tmp_mat(2,3*cryst%natom,3*cryst%natom)
750 : : ! *********************************************************************
751 : :
752 : : ! Build U matrix.
753 [ + + + + : 459079 : umat = zero; k = 1
+ + ]
754 [ + + ]: 29618 : do ii=1,cryst%natom
755 [ + + + + ]: 192517 : umat(1,k:k+2, k:k+2) = cryst%gprimd
756 : 29618 : k = k + 3
757 : : end do
758 : :
759 : 14809 : natom3 = 3 * cryst%natom
760 : :
761 : : ! Reduced --> Cartesian
762 : 14809 : call zgemm('N', 'N', natom3, natom3, natom3, cone, tgamma, natom3, umat, natom3, czero, tmp_mat, natom3)
763 : 14809 : call zgemm('T', 'N', natom3, natom3, natom3, cone, umat, natom3, tmp_mat, natom3, czero, tgcart, natom3)
764 : :
765 : : ! Make the matrix hermitian
766 : 14809 : call mkherm(tgcart, 3*cryst%natom)
767 : :
768 : : ! Symmetrize tgamma matrix.
769 : 14809 : call symdyma(tgcart, cryst%indsym, cryst%natom, cryst%nsym, qpt, cryst%rprimd, cryst%symrel, cryst%symafm)
770 : :
771 [ + + + + : 459079 : umat = zero; k = 1
+ + ]
772 [ + + ]: 29618 : do ii=0,cryst%natom-1
773 [ + + + + ]: 192517 : umat(1,k:k+2, k:k+2) = cryst%rprimd
774 : 29618 : k = k + 3
775 : : end do
776 : :
777 : : ! Cartesian --> Reduced
778 : 14809 : call zgemm('N', 'N', natom3, natom3, natom3, cone, tgcart, natom3, umat, natom3, czero, tmp_mat, natom3)
779 : 14809 : call zgemm('T', 'N', natom3, natom3, natom3, cone, umat, natom3, tmp_mat, natom3, czero, tgamma, natom3)
780 : :
781 : 14809 : end subroutine tgamma_symm
782 : : !!***
783 : :
784 : : !----------------------------------------------------------------------
785 : :
786 : : !!****f* m_phgamma/phgamma_eval_qibz
787 : : !! NAME
788 : : !! phgamma_eval_qibz
789 : : !!
790 : : !! FUNCTION
791 : : !! Compute the phonon linewidths for q-points in the IBZ without performing the interpolation.
792 : : !!
793 : : !! INPUTS
794 : : !! cryst<crystal_t>=Crystal structure.
795 : : !! ifc<ifc_type>=Interatomic force constants.
796 : : !! iq_ibz=Index of the q-point in the IBZ array.
797 : : !! spin=Spin index. See notes below.
798 : : !!
799 : : !! OUTPUT
800 : : !! phfrq(gams%natom3)=Phonon frequencies
801 : : !! gamma_ph(gams%natom3)=Phonon linewidths.
802 : : !! lambda_ph(gams%natom3)=coupling strength coefficients
803 : : !! displ_cart(2,3,cry%natom,3*cryst%natom)=Phonon displacement in cartesian coordinates.
804 : : !! [gamma_ph_ee]
805 : : !!
806 : : !! NOTES
807 : : !! If nsppol == 1 and nspinor == 1, lambda and gamma are already summed over the two equivalent spin channels.
808 : : !! If nsppol == 2, lambda and gamma are the particular contributions given by the input spin index.
809 : : !! Client code is responsible for assembling the final observables by summing over spins.
810 : : !!
811 : : !! SOURCE
812 : :
813 : 0 : subroutine phgamma_eval_qibz(gams, cryst, ifc, iq_ibz, spin, phfrq, gamma_ph, lambda_ph, displ_cart, gamma_ph_ee)
814 : :
815 : : !Arguments ------------------------------------
816 : : !scalars
817 : : class(phgamma_t),intent(inout) :: gams
818 : : integer,intent(in) :: iq_ibz,spin
819 : : type(crystal_t),intent(in) :: cryst
820 : : type(ifc_type),intent(in) :: ifc
821 : : !arrays
822 : : real(dp),intent(out) :: phfrq(gams%natom3),gamma_ph(gams%natom3),lambda_ph(gams%natom3)
823 : : real(dp),intent(out) :: displ_cart(2,3,cryst%natom,3*cryst%natom)
824 : : real(dp),intent(out),optional :: gamma_ph_ee(gams%nene,gams%nene,gams%natom3)
825 : :
826 : : !Local variables-------------------------------
827 : : !scalars
828 : : integer :: natom3, nu1, iene, jene
829 : : real(dp) :: spinfact
830 : : !character(len=500) :: msg
831 : : !arrays
832 : 244 : real(dp) :: displ_red(2,gams%natom3,gams%natom3), work_qnu(gams%natom3), gam_atm(2,gams%natom3,gams%natom3)
833 : : ! *************************************************************************
834 : :
835 : 122 : natom3 = gams%natom3
836 : :
837 : : ! Get phonon frequencies and eigenvectors.
838 : 122 : call ifc%fourq(cryst, gams%qibz(:,iq_ibz), phfrq, displ_cart, out_displ_red=displ_red)
839 : :
840 : : ! Scalar product with the displ_red vectors.
841 : : ! Note that the factor 1 / (2 * omega_qnu) coming from |g|^2 is absorbed in the expressions below.
842 [ + + ]: 488 : gam_atm = reshape(gams%vals_qibz(:,:,:,iq_ibz,spin), [2, natom3, natom3])
843 : 122 : call ephtk_gam_atm2qnu(natom3, displ_red, gam_atm, gamma_ph)
844 : :
845 [ - + - - ]: 122 : if (present(gamma_ph_ee) .and. gams%my_iqibz(iq_ibz) /= -1) then
846 [ # # ]: 0 : do iene = 1, gams%nene
847 [ # # ]: 0 : do jene = 1, gams%nene
848 [ # # ]: 0 : gam_atm = reshape(gams%vals_ee(:,jene,iene,:,:,iq_ibz,spin), [2, natom3, natom3])
849 : 0 : call ephtk_gam_atm2qnu(natom3, displ_red, gam_atm, work_qnu)
850 [ # # ]: 0 : gamma_ph_ee(jene, iene, :) = work_qnu
851 : : end do
852 : : end do
853 : : end if
854 : :
855 : : ! Compute lambda
856 : : ! TODO: check this - looks like a factor of 2 wrt the inline documentation!
857 : : ! NB: one factor of 2 comes from the phonon propagator and BE factor,
858 : : ! then you have to be careful with the convention for the Fermi level DOS
859 : : !
860 : : ! spinfact should be 1 for a normal non sppol calculation without spinorbit
861 : : ! for spinors it should also be 1 as bands are twice as numerous but n0 has been divided by 2
862 : : ! for nsppol 2 it should be 0.5 as we have 2 spin channels to sum
863 : 122 : spinfact = two / (gams%nsppol * gams%nspinor)
864 : :
865 [ + + ]: 488 : do nu1=1,gams%natom3
866 : 366 : gamma_ph(nu1) = gamma_ph(nu1) * pi * spinfact
867 : 366 : lambda_ph(nu1) = zero
868 [ + + ]: 366 : if (abs(phfrq(nu1)) > EPHTK_WTOL) lambda_ph(nu1) = gamma_ph(nu1) / (two * pi * gams%n0(spin) * phfrq(nu1)**2)
869 : : !if (abs(phfrq(nu1)) > EPHTK_WTOL) lambda_ph(nu1) = gamma_ph(nu1) / (two * pi * sum(gams%n0(:)) * phfrq(nu1)**2)
870 [ - + - - : 488 : if (present(gamma_ph_ee)) gamma_ph_ee(:,:,nu1) = gamma_ph_ee(:,:,nu1) * pi * spinfact
- - ]
871 : : end do
872 : :
873 : : ! This to avoid spurious results for the acoustic modes as gamma(q) --> 0 and lambda(q) --> 0 for q --> 0.
874 : : ! Here we set everything to zero when we are inside a sphere of radius EPH_Q0TOL as this acoustic rule
875 : : ! is not fulfilled due to numerical inaccuracies.
876 [ + + ]: 122 : if (normv(gams%qibz(:,iq_ibz), cryst%gmet, "G") < EPH_Q0TOL) then
877 [ + + ]: 40 : gamma_ph(1:3) = zero
878 [ + + ]: 40 : lambda_ph(1:3) = zero
879 : : end if
880 : :
881 [ - + ]: 122 : end subroutine phgamma_eval_qibz
882 : : !!***
883 : :
884 : : !----------------------------------------------------------------------
885 : :
886 : : !!****f* m_phgamma/phgamma_interp
887 : : !! NAME
888 : : !! phgamma_interp
889 : : !!
890 : : !! FUNCTION
891 : : !! Interpolate the phonon linewidths at a given q-point.
892 : : !!
893 : : !! INPUTS
894 : : !! cryst<crystal_t>=crystalline structure.
895 : : !! ifc<ifc_type>=Interatomic force constants.
896 : : !! spin=Spin index
897 : : !! qpt(3)=q-point in reduced coordinates
898 : : !! gamma_ph(3*natom)=Phonon linewidths
899 : : !!
900 : : !! OUTPUT
901 : : !! gamma_ph(gams%natom3)=Interpolated Phonon linewidths.
902 : : !! lamda_ph(3*natom)=Lambda coefficients for the different phonon modes.
903 : : !! phfrq(3*natom)=phonon frequencies at current q
904 : : !! displ_cart(2,3,natom,3*natom) = Phonon displacement in Cartesian coordinates
905 : : !!
906 : : !! SOURCE
907 : :
908 : 0 : subroutine phgamma_interp(gams, cryst, ifc, spin, qpt, phfrq, gamma_ph, lambda_ph, displ_cart, gamma_ph_ee)
909 : :
910 : : !Arguments ------------------------------------
911 : : !scalars
912 : : class(phgamma_t),intent(inout) :: gams
913 : : integer,intent(in) :: spin
914 : : type(crystal_t),intent(in) :: cryst
915 : : type(ifc_type),intent(in) :: ifc
916 : : !arrays
917 : : real(dp),intent(in) :: qpt(3)
918 : : real(dp),intent(out) :: phfrq(gams%natom3),gamma_ph(gams%natom3),lambda_ph(gams%natom3)
919 : : real(dp),intent(out) :: displ_cart(2,3,cryst%natom,3*cryst%natom)
920 : : real(dp),intent(out),optional :: gamma_ph_ee(gams%nene,gams%nene,gams%natom3)
921 : :
922 : : !Local variables-------------------------------
923 : : !scalars
924 : : integer,parameter :: qtor0 = 0
925 : : integer, save :: icall=0
926 : : integer :: natom3,nu1
927 : : real(dp) :: spinfact
928 : : character(len=500) :: msg
929 : : !arrays
930 : 1860 : real(dp) :: displ_red(2,gams%natom3,gams%natom3), gam_now(2,gams%natom3**2), gam_atm(2,gams%natom3,gams%natom3)
931 : 930 : real(dp),allocatable :: coskr(:,:),sinkr(:,:)
932 : : ! *************************************************************************
933 : :
934 : : ! Compute internal tables used for Fourier interpolation.
935 [ + + ]: 930 : if (.not. allocated(gams%vals_rpt)) call gams%interp_setup(cryst)
936 : :
937 [ - + - - ]: 930 : if (present(gamma_ph_ee) .and. icall == 0) then
938 [ # # # # : 0 : gamma_ph_ee = zero
# # ]
939 : : write (msg,'(3a)')&
940 : 0 : " For the moment gams_ee matrix elements are not FT interpolated wrt q,",ch10,&
941 : 0 : " only evaluated on the electron k grid. The resulting a2feew will be 0"
942 : 0 : ABI_WARNING(msg)
943 : 0 : icall = 1
944 : : end if
945 : :
946 : 930 : natom3 = gams%natom3
947 : :
948 : : ! Taken from mkph_linwid
949 : : ! This reduced version of ftgkk supposes the kpoints have been integrated
950 : : ! in integrate_gamma. Do FT from real-space gamma grid to 1 qpt.
951 [ - + + - : 2790 : ABI_MALLOC(coskr, (1, gams%nrpt))
+ - + - -
+ - + ]
952 [ - + + - : 1860 : ABI_MALLOC(sinkr, (1, gams%nrpt))
- + - + ]
953 : : ! TODO: This is not optimal
954 : 930 : call ftgam_init(gams%gprim, 1, gams%nrpt, qpt, gams%rpt, coskr, sinkr)
955 : :
956 : 930 : call ftgam(gams%wghatm, gam_now, gams%vals_rpt(:,:,:,spin), gams%natom, 1, gams%nrpt, qtor0, coskr, sinkr)
957 : :
958 : : ! This call is not executed in elphon!
959 [ + - ]: 930 : if (gams%symgamma == 1) call tgamma_symm(cryst, qpt, gam_now)
960 : :
961 [ - + ]: 930 : ABI_FREE(coskr)
962 [ - + ]: 930 : ABI_FREE(sinkr)
963 : :
964 : : ! Get phonon frequencies and eigenvectors.
965 : 930 : call ifc%fourq(cryst, qpt, phfrq, displ_cart, out_displ_red=displ_red)
966 : :
967 : : ! Scalar product with the displ_red
968 [ + + ]: 3720 : gam_atm = reshape(gam_now, [2, natom3, natom3])
969 : 930 : call ephtk_gam_atm2qnu(natom3, displ_red, gam_atm, gamma_ph)
970 : :
971 : : ! Compute lambda
972 : : ! spinfact should be 1 for a normal non sppol calculation without spinorbit
973 : : ! for spinors it should also be 1 as bands are twice as numerous but n0 has been divided by 2
974 : : ! for nsppol 2 it should be 0.5 as we have 2 spin channels to sum
975 : 930 : spinfact = two / (gams%nsppol * gams%nspinor)
976 : :
977 : : ! Compute lambda
978 [ + + ]: 3720 : do nu1=1,gams%natom3
979 : 2790 : gamma_ph(nu1) = gamma_ph(nu1) * pi * spinfact
980 : 2790 : lambda_ph(nu1) = zero
981 [ + + ]: 3720 : if (abs(phfrq(nu1)) > EPHTK_WTOL) lambda_ph(nu1) = gamma_ph(nu1) / (two * pi * gams%n0(spin) * phfrq(nu1)**2)
982 : : end do
983 : :
984 : : ! This to avoid spurious results for the acoustic modes.
985 : : ! In principle, gamma(q) --> 0 and lambda(q) --> 0 for q --> 0
986 : : ! but the Fourier interpolated gammas do not fulfill this property so we set everything
987 : : ! to zero when we are inside a sphere or radius
988 [ + + ]: 930 : if (normv(qpt, cryst%gmet, "G") < EPH_Q0TOL) then
989 : : !write(std_out,*)"Setting values to zero."
990 [ + + ]: 40 : gamma_ph(1:3) = zero
991 [ + + ]: 40 : lambda_ph(1:3) = zero
992 : : end if
993 : :
994 [ - + ]: 930 : end subroutine phgamma_interp
995 : : !!***
996 : :
997 : : !----------------------------------------------------------------------
998 : :
999 : : !!****f* m_phgamma/phgamma_interp_setup
1000 : : !! NAME
1001 : : !! phgamma_interp_setup
1002 : : !!
1003 : : !! FUNCTION
1004 : : !! This routines prepares the internal tables used to interpolate the linewidths in q-space
1005 : : !!
1006 : : !! INPUTS
1007 : : !!
1008 : : !! SOURCE
1009 : :
1010 : 5 : subroutine phgamma_interp_setup(gams, cryst)
1011 : :
1012 : : !Arguments ------------------------------------
1013 : : !scalars
1014 : : class(phgamma_t),intent(inout) :: gams
1015 : : type(crystal_t),intent(in) :: cryst
1016 : :
1017 : : !Local variables-------------------------------
1018 : : !scalars
1019 : : integer,parameter :: qtor1 = 1
1020 : : integer :: iq_bz,iq_ibz,spin,ierr,ii
1021 : : !character(len=500) :: msg
1022 : : !arrays
1023 : 5 : integer,allocatable :: qirredtofull(:),qpttoqpt(:,:,:)
1024 : 5 : real(dp),allocatable :: coskr(:,:),sinkr(:,:), gamma_qpt(:,:,:,:),atmfrc(:,:), vals_bz(:,:,:,:)
1025 : : ! *************************************************************************
1026 : :
1027 [ - + + - : 25 : ABI_MALLOC_OR_DIE(vals_bz, (2, gams%natom3**2, gams%nqbz, gams%nsppol), ierr)
- + + - -
+ + - + -
+ - + - -
+ - + ]
1028 [ + + + + : 21514 : vals_bz = zero
+ + + + ]
1029 : :
1030 : : ! Build tables needed by complete_gamma.
1031 : 5 : call ephtk_mkqtabs(cryst, gams%nqibz, gams%qibz, gams%nqbz, gams%qbz, qirredtofull, qpttoqpt)
1032 : :
1033 : : ! Fill BZ array with IBZ data.
1034 [ + + ]: 10 : do spin=1,gams%nsppol
1035 [ + + ]: 71 : do iq_ibz=1,gams%nqibz
1036 : 61 : iq_bz = qirredtofull(iq_ibz)
1037 [ + + ]: 188 : vals_bz(:,:,iq_bz,spin) = reshape(gams%vals_qibz(:,:,:,iq_ibz,spin), [2, gams%natom3**2])
1038 : : end do
1039 : : end do
1040 : :
1041 : : ! Complete vals_bz in the full BZ.
1042 : : ! FIXME: Change complete_gamma API to pass (..., nsppol)
1043 [ - + + - : 25 : ABI_MALLOC(gamma_qpt, (2, gams%natom3**2, gams%nsppol, gams%nqbz))
- + + - -
+ + - + -
+ - - + -
+ ]
1044 [ + + ]: 10 : do spin=1,gams%nsppol
1045 [ + + + + : 21514 : gamma_qpt(:, :, spin, :) = vals_bz(:, :, :, spin)
+ + ]
1046 : : end do
1047 : :
1048 : : call complete_gamma(cryst, gams%natom3, gams%nsppol, gams%nqibz, gams%nqbz, &
1049 : 5 : gams%eph_scalprod, qirredtofull, qpttoqpt, gamma_qpt)
1050 : :
1051 [ + + ]: 10 : do spin=1,gams%nsppol
1052 [ + + + + : 21514 : vals_bz(:, :, :, spin) = gamma_qpt(:, :, spin, :)
+ + ]
1053 : : end do
1054 : :
1055 [ - + ]: 5 : ABI_FREE(gamma_qpt)
1056 [ - + ]: 5 : ABI_FREE(qirredtofull)
1057 [ - + ]: 5 : ABI_FREE(qpttoqpt)
1058 : :
1059 : : ! This call is not executed in elphon!
1060 [ + - ]: 5 : if (gams%symgamma == 1) then
1061 [ + + ]: 10 : do spin=1,gams%nsppol
1062 [ + + ]: 778 : do iq_bz=1,gams%nqbz
1063 : 773 : call tgamma_symm(cryst, gams%qbz(:,iq_bz), vals_bz(:,:,iq_bz,spin))
1064 : : end do
1065 : : end do
1066 : : end if
1067 : :
1068 : : ! Now FT to real space too
1069 : : ! NOTE: gprim (not gprimd) is used for all FT interpolations,
1070 : : ! to be consistent with the dimensions of the rpt, which come from anaddb.
1071 [ - + + - : 25 : ABI_MALLOC_OR_DIE(gams%vals_rpt, (2, gams%natom3**2, gams%nrpt, gams%nsppol), ierr)
- + + - -
+ + - + -
+ - + - +
- - + + -
- + ]
1072 [ + + + + : 13030 : gams%vals_rpt = zero
+ + + + ]
1073 : :
1074 : : ! q --> r
1075 [ - + + - : 20 : ABI_MALLOC(coskr, (gams%nqbz, gams%nrpt))
- + + - +
- + - - +
- + ]
1076 [ - + + - : 15 : ABI_MALLOC(sinkr, (gams%nqbz, gams%nrpt))
- + + - -
+ - + ]
1077 : 5 : call ftgam_init(gams%gprim, gams%nqbz, gams%nrpt, gams%qbz, gams%rpt, coskr, sinkr)
1078 : :
1079 [ + + ]: 10 : do spin=1,gams%nsppol
1080 : : call ftgam(gams%wghatm, vals_bz(:,:,:,spin), gams%vals_rpt(:,:,:,spin), gams%natom, gams%nqbz,&
1081 : 5 : gams%nrpt, qtor1, coskr, sinkr)
1082 : :
1083 : : ! Enforce "acoustic" rule on vals_rpt. NB: This call is not executed in elphon!
1084 [ - + ]: 10 : if (gams%asr /= 0) then
1085 [ # # # # : 0 : ABI_MALLOC(atmfrc, (3*gams%natom*3*gams%natom, gams%nrpt))
# # # # #
# # # # #
# # # # ]
1086 [ # # ]: 0 : do ii=1,2
1087 [ # # # # : 0 : atmfrc = gams%vals_rpt(ii,:,:,spin)
# # # # #
# # # ]
1088 : : !gals%vals_rpt(2,:,,spin) = zero
1089 : 0 : call asrif9(gams%asr, atmfrc, gams%natom, gams%nrpt, gams%rpt, gams%wghatm)
1090 [ # # # # ]: 0 : gams%vals_rpt(ii,:,:,spin) = atmfrc
1091 : : end do
1092 [ # # ]: 0 : ABI_FREE(atmfrc)
1093 : : end if
1094 : : end do
1095 : :
1096 [ - + ]: 5 : ABI_FREE(vals_bz)
1097 [ - + ]: 5 : ABI_FREE(coskr)
1098 [ - + ]: 5 : ABI_FREE(sinkr)
1099 : :
1100 : 5 : end subroutine phgamma_interp_setup
1101 : : !!***
1102 : :
1103 : : !----------------------------------------------------------------------
1104 : :
1105 : : !!****f* m_phgamma/phgamma_vv_eval_qibz
1106 : : !! NAME
1107 : : !! phgamma_vv_eval_qibz
1108 : : !!
1109 : : !! FUNCTION
1110 : : !! Compute the phonon linewidths times velocity squared, for q-points in the IBZ without performing interpolation.
1111 : : !!
1112 : : !! INPUTS
1113 : : !! gams<phgamma_t>
1114 : : !! cryst<crystal_t>=Crystal structure.
1115 : : !! ifc<ifc_type>=Interatomic force constants.
1116 : : !! iq_ibz=Index of the q-point in the IBZ array.
1117 : : !! spin=Spin index
1118 : : !!
1119 : : !! OUTPUT
1120 : : !! phfrq(gams%natom3)=Phonon frequencies
1121 : : !! gamma_in_ph(gams%natom3)=Phonon linewidths.
1122 : : !! gamma_out_ph(gams%natom3)=Phonon linewidths.
1123 : : !! lambda_in_ph(gams%natom3)=Phonon linewidths.
1124 : : !! lambda_out_ph(gams%natom3)=Phonon linewidths.
1125 : : !!
1126 : : !! SOURCE
1127 : :
1128 : 61 : subroutine phgamma_vv_eval_qibz(gams, cryst, ifc, iq_ibz, spin, phfrq, gamma_in_ph, gamma_out_ph, lambda_in_ph, lambda_out_ph)
1129 : :
1130 : : !Arguments ------------------------------------
1131 : : !scalars
1132 : : class(phgamma_t),intent(inout) :: gams
1133 : : integer,intent(in) :: iq_ibz,spin
1134 : : type(crystal_t),intent(in) :: cryst
1135 : : type(ifc_type),intent(in) :: ifc
1136 : : !arrays
1137 : : real(dp),intent(out) :: phfrq(gams%natom3)
1138 : : real(dp),intent(out) :: gamma_in_ph(3,3,gams%natom3),lambda_in_ph(3,3,gams%natom3)
1139 : : real(dp),intent(out) :: gamma_out_ph(3,3,gams%natom3),lambda_out_ph(3,3,gams%natom3)
1140 : :
1141 : : !Local variables-------------------------------
1142 : : !scalars
1143 : : integer,parameter :: qtor0 = 0
1144 : : integer :: natom3, nu1, idir, jdir, ii
1145 : : real(dp) :: spinfact
1146 : : !character(len=500) :: msg
1147 : : !arrays
1148 : 122 : real(dp) :: displ_cart(2,3,cryst%natom,3*cryst%natom), displ_red(2,gams%natom3,gams%natom3)
1149 : 122 : real(dp) :: work_qnu(gams%natom3), gam_atm(2,gams%natom3,gams%natom3)
1150 : : ! *************************************************************************
1151 : :
1152 : 61 : natom3 = gams%natom3
1153 : :
1154 : : ! Get phonon frequencies and eigenvectors.
1155 : 61 : call ifc%fourq(cryst, gams%qibz(:,iq_ibz), phfrq, displ_cart, out_displ_red=displ_red)
1156 : :
1157 [ + + ]: 244 : do jdir=1,3
1158 [ + + ]: 793 : do idir=1,3
1159 : 549 : ii = idir + gams%ndir_transp * (jdir - 1)
1160 : :
1161 : : ! Scalar product with the displ_red vectors.
1162 [ + + ]: 2196 : gam_atm = reshape(gams%vals_in_qibz(:,ii,:,:,iq_ibz,spin), [2, natom3, natom3])
1163 : 549 : call ephtk_gam_atm2qnu(natom3, displ_red, gam_atm, work_qnu)
1164 [ + + ]: 2196 : gamma_in_ph(idir,jdir,:) = work_qnu
1165 : :
1166 [ + + ]: 2196 : gam_atm = reshape(gams%vals_out_qibz(:,ii,:,:,iq_ibz,spin), [2, natom3, natom3])
1167 : 549 : call ephtk_gam_atm2qnu(natom3, displ_red, gam_atm, work_qnu)
1168 [ + + ]: 2379 : gamma_out_ph(idir,jdir,:) = work_qnu
1169 : : end do ! idir
1170 : : end do ! jdir
1171 : :
1172 : : ! TODO : check this - looks like a factor of 2 wrt the inline documentation!
1173 : : !spinfact should be 1 for a normal non sppol calculation without spinorbit
1174 : : !for spinors it should also be 1 as bands are twice as numerous but n0 has been divided by 2
1175 : : !for sppol 2 it should be 0.5 as we have 2 spin channels to sum
1176 : 61 : spinfact = two / (gams%nsppol*gams%nspinor)
1177 : :
1178 : : ! Compute lambda transport.
1179 [ + + ]: 244 : do jdir =1,3
1180 [ + + ]: 793 : do idir =1,3
1181 [ + + ]: 2379 : do nu1=1,gams%natom3
1182 : 1647 : gamma_in_ph(idir,jdir,nu1) = gamma_in_ph(idir,jdir,nu1) * pi * spinfact
1183 : 1647 : gamma_out_ph(idir,jdir,nu1) = gamma_out_ph(idir,jdir,nu1) * pi * spinfact
1184 : 1647 : lambda_in_ph(idir,jdir,nu1) = zero
1185 : 1647 : lambda_out_ph(idir,jdir,nu1) = zero
1186 [ + + ]: 2196 : if (abs(phfrq(nu1)) > EPHTK_WTOL) then
1187 : 1512 : lambda_in_ph(idir,jdir,nu1) = gamma_in_ph(idir,jdir,nu1) / (two * pi * gams%n0(spin) * phfrq(nu1)**2)
1188 : 1512 : lambda_out_ph(idir,jdir,nu1) = gamma_out_ph(idir,jdir,nu1) / (two * pi * gams%n0(spin) * phfrq(nu1)**2)
1189 : : end if
1190 : : end do
1191 : : end do ! idir
1192 : : end do ! jdir
1193 : :
1194 : 61 : end subroutine phgamma_vv_eval_qibz
1195 : : !!***
1196 : :
1197 : : !----------------------------------------------------------------------
1198 : :
1199 : : !!****f* m_phgamma/phgamma_vv_interp
1200 : : !! NAME
1201 : : !! phgamma_vv_interp
1202 : : !!
1203 : : !! FUNCTION
1204 : : !! Interpolate the linewidths at a given q-point.
1205 : : !!
1206 : : !! INPUTS
1207 : : !! cryst<crystal_t>=crystalline structure.
1208 : : !! ifc<ifc_type>=Interatomic force constants.
1209 : : !! spin=Spin index
1210 : : !! qpt(3)=q-point in reduced coordinates
1211 : : !! gamma_ph(3*natom)=Phonon linewidths
1212 : : !! displ_cart(2,3,cryst%natom,3*cryst%natom)=Phonon displacement in cartesian coordinates.
1213 : : !!
1214 : : !! OUTPUT
1215 : : !! phfrq(3*natom)=phonon frequencies at current q
1216 : : !! gamma_out_ph(gams%natom3)=Interpolated Phonon linewidths.
1217 : : !! lambda_in_ph(3*natom)=Lambda coefficients for the different phonon modes.
1218 : : !! lambda_out_ph(3*natom)=Lambda coefficients for the different phonon modes.
1219 : : !!
1220 : : !! SOURCE
1221 : :
1222 : 725 : subroutine phgamma_vv_interp(gams, cryst, ifc, spin, qpt, phfrq, gamma_in_ph, gamma_out_ph, lambda_in_ph, lambda_out_ph)
1223 : :
1224 : : !Arguments ------------------------------------
1225 : : !scalars
1226 : : class(phgamma_t),intent(inout) :: gams
1227 : : type(crystal_t),intent(in) :: cryst
1228 : : type(ifc_type),intent(in) :: ifc
1229 : : integer,intent(in) :: spin
1230 : : !arrays
1231 : : real(dp),intent(in) :: qpt(3)
1232 : : real(dp),intent(out) :: phfrq(gams%natom3)
1233 : : real(dp),intent(out) :: gamma_in_ph(3,3,gams%natom3),lambda_in_ph(3,3,gams%natom3)
1234 : : real(dp),intent(out) :: gamma_out_ph(3,3,gams%natom3),lambda_out_ph(3,3,gams%natom3)
1235 : :
1236 : : !Local variables-------------------------------
1237 : : !scalars
1238 : : integer,parameter :: qtor0 = 0
1239 : : integer :: natom3, nu1, idir,jdir,ii
1240 : : real(dp) :: spinfact
1241 : : !character(len=500) :: msg
1242 : : !arrays
1243 : 1450 : real(dp) :: displ_cart(2,3,cryst%natom,3*cryst%natom), displ_red(2,gams%natom3,gams%natom3),work_qnu(gams%natom3)
1244 : 1450 : real(dp) :: gam_in_now(2,3,3,gams%natom3**2), gam_out_now(2,3,3,gams%natom3**2), gam_atm(2,gams%natom3,gams%natom3)
1245 : 725 : real(dp),allocatable :: coskr(:,:),sinkr(:,:)
1246 : : ! *************************************************************************
1247 : :
1248 : : ! Compute internal tables used for Fourier interpolation.
1249 [ + + ]: 725 : if (.not.allocated(gams%vals_in_rpt)) call phgamma_vv_interp_setup(gams, cryst)
1250 : :
1251 : 725 : natom3 = gams%natom3
1252 : :
1253 : : ! Get phonon frequencies and eigenvectors.
1254 : 725 : call ifc%fourq(cryst, qpt, phfrq, displ_cart, out_displ_red=displ_red)
1255 : :
1256 : : ! Taken from mkph_linwid
1257 : : ! This reduced version of ftgkk supposes the kpoints have been integrated
1258 : : ! in integrate_gamma. Do FT from real-space gamma grid to 1 qpt.
1259 [ - + + - : 2175 : ABI_MALLOC(coskr, (1,gams%nrpt))
+ - + - -
+ - + ]
1260 [ - + + - : 1450 : ABI_MALLOC(sinkr, (1,gams%nrpt))
- + - + ]
1261 : : ! TODO: This is not optimal
1262 : 725 : call ftgam_init(gams%gprim, 1, gams%nrpt, qpt, gams%rpt, coskr, sinkr)
1263 : :
1264 [ + + ]: 2900 : do idir=1,3
1265 [ + + ]: 9425 : do jdir=1,3
1266 : 6525 : ii = idir+gams%ndir_transp*(jdir-1)
1267 : :
1268 [ + - + - : 33988725 : call ftgam(gams%wghatm, gam_in_now, gams%vals_in_rpt(:,ii,:,:,spin), gams%natom, 1, gams%nrpt, qtor0, coskr, sinkr)
+ + + + +
+ + - + +
+ + + + ]
1269 [ + - + - : 33988725 : call ftgam(gams%wghatm, gam_out_now, gams%vals_out_rpt(:,ii,:,:,spin), gams%natom, 1, gams%nrpt, qtor0, coskr, sinkr)
+ + + + +
+ + - + +
+ + + + ]
1270 : :
1271 : : ! This call is not executed in elphon!
1272 : : ! TODO: needs to take into account the matrix nature of _in_ and _out_ gammas
1273 [ + - ]: 6525 : if (gams%symgamma == 1) then
1274 : 6525 : call tgamma_symm(cryst, qpt, gam_in_now)
1275 : 6525 : call tgamma_symm(cryst, qpt, gam_out_now)
1276 : : end if
1277 : :
1278 : : ! Scalar product with the displ_red
1279 [ + + ]: 26100 : gam_atm = reshape(gam_in_now, [2, natom3, natom3])
1280 : 6525 : call ephtk_gam_atm2qnu(natom3, displ_red, gam_atm, work_qnu)
1281 [ + + ]: 26100 : gamma_in_ph(idir,jdir,:) = work_qnu
1282 : :
1283 [ + + ]: 26100 : gam_atm = reshape(gam_out_now, [2, natom3, natom3])
1284 : 6525 : call ephtk_gam_atm2qnu(natom3, displ_red, gam_atm, work_qnu)
1285 [ + + ]: 28275 : gamma_out_ph(idir,jdir,:) = work_qnu
1286 : : end do
1287 : : end do
1288 : :
1289 [ - + ]: 725 : ABI_FREE(coskr)
1290 [ - + ]: 725 : ABI_FREE(sinkr)
1291 : :
1292 : : ! Compute lambda
1293 : : ! spinfact should be 1 for a normal non sppol calculation without spinorbit
1294 : : ! for spinors it should also be 1 as bands are twice as numerous but n0 has been divided by 2
1295 : : ! for sppol 2 it should be 0.5 as we have 2 spin channels to sum
1296 : 725 : spinfact = two / (gams%nsppol * gams%nspinor)
1297 : :
1298 : : ! Compute lambda
1299 [ + + ]: 2900 : do nu1=1,gams%natom3
1300 [ + + ]: 9425 : do idir=1,3
1301 [ + + ]: 28275 : do jdir=1,3
1302 : 19575 : gamma_in_ph(idir,jdir,nu1) = gamma_in_ph(idir,jdir,nu1) * pi * spinfact
1303 : 19575 : gamma_out_ph(idir,jdir,nu1) = gamma_out_ph(idir,jdir,nu1) * pi * spinfact
1304 : 19575 : lambda_in_ph(idir,jdir,nu1) = zero
1305 : 19575 : lambda_out_ph(idir,jdir,nu1) = zero
1306 [ + + ]: 26100 : if (abs(phfrq(nu1)) > EPHTK_WTOL) then
1307 : 19440 : lambda_in_ph(idir,jdir,nu1) = gamma_in_ph(idir,jdir,nu1) / (two * pi * gams%n0(spin) * phfrq(nu1)**2)
1308 : 19440 : lambda_out_ph(idir,jdir,nu1) = gamma_out_ph(idir,jdir,nu1) / (two * pi * gams%n0(spin) * phfrq(nu1)**2)
1309 : : end if
1310 : : end do
1311 : : end do
1312 : : end do
1313 : :
1314 : 725 : end subroutine phgamma_vv_interp
1315 : : !!***
1316 : :
1317 : : !----------------------------------------------------------------------
1318 : :
1319 : : !!****f* m_phgamma/phgamma_vv_interp_setup
1320 : : !! NAME
1321 : : !! phgamma_vv_interp_setup
1322 : : !!
1323 : : !! FUNCTION
1324 : : !! This routines prepare the internal tables used to interpolate the vv_linewidths in q-space
1325 : : !!
1326 : : !! INPUTS
1327 : : !! action =
1328 : : !! "INIT" to allocate and compute the internal tables (default)
1329 : : !! "FREE" to deallocate the internal tables.
1330 : : !!
1331 : : !! SOURCE
1332 : :
1333 : 5 : subroutine phgamma_vv_interp_setup(gams, cryst)
1334 : :
1335 : : !Arguments ------------------------------------
1336 : : class(phgamma_t),intent(inout) :: gams
1337 : : type(crystal_t),intent(in) :: cryst
1338 : :
1339 : : !Local variables-------------------------------
1340 : : !scalars
1341 : : integer,parameter :: qtor1 = 1
1342 : : integer :: iq_bz,iq_ibz,spin,ierr, ii, idir, jdir
1343 : : !character(len=500) :: msg
1344 : : !arrays
1345 : 5 : integer,allocatable :: qirredtofull(:),qpttoqpt(:,:,:)
1346 : 5 : real(dp),allocatable :: coskr(:,:),sinkr(:,:), vals_in_bz(:,:,:,:,:), vals_out_bz(:,:,:,:,:)
1347 : : ! *************************************************************************
1348 : :
1349 [ - + + - : 25 : ABI_MALLOC_OR_DIE(vals_in_bz,(2, 9, gams%natom3**2, gams%nqbz, gams%nsppol), ierr)
- + + - -
+ + - + -
+ - + - -
+ - + ]
1350 [ - + + - : 25 : ABI_MALLOC_OR_DIE(vals_out_bz,(2, 9, gams%natom3**2, gams%nqbz, gams%nsppol), ierr)
- + + - -
+ + - + -
+ - + - -
+ - + ]
1351 [ + + + + : 194314 : vals_in_bz = zero
+ + + + +
+ ]
1352 [ + + + + : 194314 : vals_out_bz = zero
+ + + + +
+ ]
1353 : :
1354 : : ! Build tables needed by complete_gamma.
1355 : 5 : call ephtk_mkqtabs(cryst, gams%nqibz, gams%qibz, gams%nqbz, gams%qbz, qirredtofull, qpttoqpt)
1356 : :
1357 : : ! Fill BZ array with IBZ data.
1358 [ + + ]: 10 : do spin=1,gams%nsppol
1359 [ + + ]: 71 : do iq_ibz=1,gams%nqibz
1360 : 61 : iq_bz = qirredtofull(iq_ibz)
1361 [ + + ]: 244 : vals_in_bz(:,:,:,iq_bz,spin) = reshape(gams%vals_in_qibz(:,:,:,:,iq_ibz,spin), [2, 9, gams%natom3**2])
1362 [ + + ]: 249 : vals_out_bz(:,:,:,iq_bz,spin) = reshape(gams%vals_out_qibz(:,:,:,:,iq_ibz,spin), [2, 9, gams%natom3**2])
1363 : : end do
1364 : : end do
1365 : :
1366 : : ! Complete vals_bz in the full BZ.
1367 : : !TODO!!! rotate the vv in and out matrices, according to the symmetry operation, instead of just copying them
1368 : : !call complete_gamma_vv(cryst, gams%natom3, gams%nsppol, gams%nqibz, gams%nqbz,&
1369 : : ! gams%eph_scalprod, qirredtofull, qpttoqpt, vals_in_bz(:,:,:,:,spin))
1370 : : !call complete_gamma_vv(cryst, gams%natom3, gams%nsppol, gams%nqibz, gams%nqbz,&
1371 : : ! gams%eph_scalprod, qirredtofull, qpttoqpt, vals_out_bz(:,:,:,:,spin))
1372 : :
1373 : : ! TODO: replace the above with these calls from anaddb
1374 : : !call complete_gamma_tr(cryst,elph_ds%ep_scalprod,elph_ds%nbranch,elph_ds%nqptirred,&
1375 : : !& elph_ds%nqpt_full,elph_ds%nsppol,elph_tr_ds%gamma_qpt_trout,elph_ds%qirredtofull,qpttoqpt)
1376 : :
1377 : : ! TODO: idem for vv_vals 3x3 matrices
1378 : :
1379 [ - + ]: 5 : ABI_FREE(qirredtofull)
1380 [ - + ]: 5 : ABI_FREE(qpttoqpt)
1381 : :
1382 : : !! This call is not executed in elphon!
1383 : : !if (gams%symgamma == 1) then
1384 : : ! do spin=1,gams%nsppol
1385 : : ! do iq_bz=1,gams%nqbz
1386 : : ! call tgamma_symm_vv(cryst, gams%qbz(:,iq_bz), vals_in_bz(:,:,:,iq_bz,spin))
1387 : : ! call tgamma_symm_vv(cryst, gams%qbz(:,iq_bz), vals_out_bz(:,:,:,iq_bz,spin))
1388 : : ! end do
1389 : : ! end do
1390 : : !end if
1391 : :
1392 : : ! Now FT to real space
1393 : : ! NOTE: gprim (not gprimd) is used for all FT interpolations,
1394 : : ! to be consistent with the dimensions of the rpt, which come from anaddb.
1395 : : ! TODO: this is needed only if FT is used, not when the linear interpolation is employed.
1396 : : !if (.not. allocated(gams%vals_in_rpt)) then
1397 [ - + + - : 25 : ABI_MALLOC_OR_DIE(gams%vals_in_rpt, (2, 9, gams%natom3**2, gams%nrpt, gams%nsppol), ierr)
- + + - -
+ + - + -
+ - + - +
- - + + -
- + ]
1398 [ - + + - : 25 : ABI_MALLOC_OR_DIE(gams%vals_out_rpt, (2, 9, gams%natom3**2, gams%nrpt, gams%nsppol), ierr)
- + + - -
+ + - + -
+ - + - +
- - + + -
- + ]
1399 [ + + + + : 117655 : gams%vals_in_rpt = zero
+ + + + +
+ ]
1400 [ + + + + : 117655 : gams%vals_out_rpt = zero
+ + + + +
+ ]
1401 : :
1402 : : ! q --> r
1403 [ - + + - : 20 : ABI_MALLOC(coskr, (gams%nqbz,gams%nrpt))
- + + - +
- + - - +
- + ]
1404 [ - + + - : 15 : ABI_MALLOC(sinkr, (gams%nqbz,gams%nrpt))
- + + - -
+ - + ]
1405 : 5 : call ftgam_init(gams%gprim, gams%nqbz, gams%nrpt, gams%qbz, gams%rpt, coskr, sinkr)
1406 : :
1407 [ + + ]: 10 : do spin=1,gams%nsppol
1408 [ + + ]: 25 : do idir=1,3
1409 [ + + ]: 65 : do jdir=1,3
1410 : 45 : ii = idir+gams%ndir_transp*(jdir-1)
1411 : : ! TODO: this is no contiguous in memory and will be slow. Make adapted ftgam?
1412 : : call ftgam(gams%wghatm, vals_in_bz(:,ii,:,:,spin), gams%vals_in_rpt(:,ii,:,:,spin), gams%natom, gams%nqbz,&
1413 [ + - + + : 621477 : gams%nrpt, qtor1, coskr, sinkr)
+ + + + +
- + - + +
+ + + + +
+ + + + +
+ - + + +
+ + + ]
1414 : : call ftgam(gams%wghatm, vals_out_bz(:,ii,:,:,spin), gams%vals_out_rpt(:,ii,:,:,spin), gams%natom, gams%nqbz,&
1415 [ + - + + : 621492 : gams%nrpt, qtor1, coskr, sinkr)
+ + + + +
- + - + +
+ + + + +
+ + + + +
+ - + + +
+ + + ]
1416 : : end do
1417 : : end do
1418 : : end do
1419 : :
1420 [ - + ]: 5 : ABI_FREE(vals_in_bz)
1421 [ - + ]: 5 : ABI_FREE(vals_out_bz)
1422 [ - + ]: 5 : ABI_FREE(coskr)
1423 [ - + ]: 5 : ABI_FREE(sinkr)
1424 : :
1425 : 5 : end subroutine phgamma_vv_interp_setup
1426 : : !!***
1427 : : !----------------------------------------------------------------------
1428 : :
1429 : : !!****f* m_phgamma/phgamma_linwid
1430 : : !! NAME
1431 : : !! phgamma_linwid
1432 : : !!
1433 : : !! FUNCTION
1434 : : !! Interpolate the phonon linewidths along an arbitrary q-path (use Fourier interpolation).
1435 : : !!
1436 : : !! INPUTS
1437 : : !! cryst<crystal_t>=Info on the unit cell and symmetries.
1438 : : !! ifc<ifc_type>=Interatomic force constants.
1439 : : !! ndivsm=Number of points used to sample the smallest segment
1440 : : !! nvert = Number of extrema in qverts
1441 : : !! qverts(3,nvert) = vertices of reciprocal space trajectory
1442 : : !! basename=name used to create the different output files (text format).
1443 : : !! ncid=Netcdf file handler (already open in the caller).
1444 : : !! comm=MPI communicator
1445 : : !!
1446 : : !! OUTPUT
1447 : : !! wminmax=Minimum and max phonon frequency obtained on the path (Hartree units)
1448 : : !!
1449 : : !! SOURCE
1450 : :
1451 : 5 : subroutine phgamma_linwid(gams, cryst, ifc, ndivsm, nvert, qverts, basename, ncid, wminmax, comm)
1452 : :
1453 : : !Arguments ------------------------------------
1454 : : !scalars
1455 : : class(phgamma_t),intent(inout) :: gams
1456 : : integer,intent(in) :: nvert,ndivsm,comm,ncid
1457 : : type(crystal_t),intent(in) :: cryst
1458 : : type(ifc_type),intent(in) :: ifc
1459 : : character(len=*),intent(in) :: basename
1460 : : !arrays
1461 : : real(dp),intent(in) :: qverts(3,nvert)
1462 : : real(dp),intent(out) :: wminmax(2)
1463 : :
1464 : : !Local variables-------------------------------
1465 : : !scalars
1466 : : integer,parameter :: master = 0
1467 : : integer :: natom,ii,mu,iqpt,natom3,nsppol,ierr, spin,unt,nqpt,nrpt,cnt,nproc,my_rank, ncerr
1468 : : real(dp) :: omega_min,omega_max,wtmp,omega
1469 : : character(len=500) :: msg
1470 : 5 : type(kpath_t) :: qpath
1471 : : !arrays
1472 : 10 : real(dp) :: gamma_spin(gams%nsppol),lambda_spin(gams%nsppol)
1473 : 10 : real(dp) :: displ_cart(2,3*cryst%natom,3*cryst%natom)
1474 : 10 : real(dp) :: phfrq(3*cryst%natom),gamma_ph(3*cryst%natom),lambda_ph(3*cryst%natom), qpt(3),shift(3)
1475 : 5 : real(dp),allocatable :: all_phfreq(:,:),all_gammaq(:,:,:),all_lambdaq(:,:,:),all_displ_cart(:,:,:,:)
1476 : : ! *********************************************************************
1477 : :
1478 : 5 : nproc = xmpi_comm_size(comm); my_rank = xmpi_comm_rank(comm)
1479 : 5 : natom = cryst%natom; natom3 = gams%natom3; nsppol = gams%nsppol; nrpt = gams%nrpt
1480 : :
1481 : : ! Define the q-path along which phonon linwid will be interpolated.
1482 : 5 : call qpath%init(qverts, cryst%gprimd, ndivsm)
1483 : 5 : nqpt = qpath%npts
1484 : :
1485 : : ! Allocate workspace arrays for MPI.
1486 [ - + + - : 840 : ABI_CALLOC(all_phfreq, (natom3, nqpt))
- + + - +
- + - - +
- + + + +
+ ]
1487 [ - + + - : 850 : ABI_CALLOC(all_gammaq, (natom3, nqpt, nsppol))
- + + - -
+ + - + -
+ - - + -
+ + + + +
+ + ]
1488 [ - + + - : 845 : ABI_CALLOC(all_lambdaq, (natom3, nqpt, nsppol))
- + + - -
+ + - - +
- + + + +
+ + + ]
1489 [ - + + - : 6380 : ABI_CALLOC(all_displ_cart, (2, natom3, natom3, nqpt))
- + + - -
+ + - + -
+ - - + -
+ + + + +
+ + + + ]
1490 : :
1491 : : ! initialize the minimum and maximum phonon frequency
1492 : 5 : omega_min = huge(one); omega_max = -huge(one)
1493 : :
1494 : : ! Interpolation along specified path in q space (keep spin dep.)
1495 : 5 : cnt = 0
1496 [ + + ]: 10 : do spin=1,nsppol
1497 [ + + ]: 215 : do iqpt=1,nqpt
1498 [ - + ]: 205 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle
1499 [ + + ]: 820 : call wrap2_pmhalf(qpath%points(:,iqpt), qpt, shift)
1500 : :
1501 : : ! Get phgamma
1502 : 205 : call gams%interp(cryst, ifc, spin, qpt, phfrq, gamma_ph, lambda_ph, displ_cart)
1503 [ + + ]: 820 : all_gammaq(:, iqpt, spin) = gamma_ph
1504 [ + + ]: 820 : all_lambdaq(:, iqpt, spin) = lambda_ph
1505 [ + - ]: 205 : if (spin == 1) then
1506 [ + + ]: 820 : all_phfreq(:, iqpt) = phfrq
1507 [ + + + + : 6355 : all_displ_cart(:, :, :, iqpt) = displ_cart
+ + ]
1508 : : end if
1509 : :
1510 : : ! Find max/min phonon frequency along path chosen
1511 : : ! presumed to be representative of full BZ to within 10 percent
1512 : 205 : omega_min = min(omega_min, phfrq(1))
1513 : 210 : omega_max = max(omega_max, phfrq(natom3))
1514 : : end do ! end iqpt do
1515 : : end do ! spin
1516 : :
1517 : : ! Collect results
1518 [ - + ]: 5 : if (omega_min > tol12) omega_min = zero
1519 : 5 : wtmp = omega_min; call xmpi_min(wtmp, omega_min, comm, ierr)
1520 : 5 : wtmp = omega_max; call xmpi_max(wtmp, omega_max, comm, ierr)
1521 [ + + ]: 15 : wminmax = [omega_min, omega_max]
1522 : :
1523 : 5 : call xmpi_sum_master(all_gammaq, master, comm, ierr)
1524 : 5 : call xmpi_sum_master(all_lambdaq, master, comm, ierr)
1525 : 5 : call xmpi_sum_master(all_phfreq, master, comm, ierr)
1526 : 5 : call xmpi_sum_master(all_displ_cart, master, comm, ierr)
1527 : :
1528 : : ! Master writes text file with final results.
1529 : : ! 3 * natom blocks, one block for each phonon mode.
1530 : : ! Each block contains:
1531 : : ! iqpt omega_(q) gamma(q) lambda(q) nesting(q) ....
1532 : :
1533 [ + - ]: 5 : if (xmpi_comm_rank(comm) == master) then
1534 [ - + ]: 5 : if (open_file(strcat(basename, '_PHGAMMA'), msg, newunit=unt, action="write", form="formatted", status="unknown") /= 0) then
1535 : 5 : ABI_ERROR(msg)
1536 : : end if
1537 : :
1538 : 5 : write(unt,'(a)') '#'
1539 : 5 : write(unt,'(a)') '# ABINIT package: E-PH band structure file. Hartree units'
1540 : 5 : write(unt,'(a)') '#'
1541 : 5 : write(unt,'(a,i0,a)')'# Phonon frequencies, ph linewidths and lambda calculated on ',nqpt,' q-points'
1542 [ + + ]: 10 : call qpath%print([unt], header="Description of the q-path:", pre="#")
1543 [ + + ]: 15 : do ii=1,2; write(unt,'(a)') "# "; end do
1544 : :
1545 [ + + ]: 10 : write(unt,'(a,e16.6)')"# Total DOS at Fermi level ",sum(gams%n0)
1546 [ + + ]: 10 : do spin=1,nsppol
1547 : 10 : write(unt,"(a,i0,a,e16.6)")"# The DOS at Fermi level for spin ",spin," is ",gams%n0(spin)
1548 : : end do
1549 : :
1550 [ + + ]: 20 : do mu=1,natom3
1551 : 15 : write(unt,'(a)')"#"
1552 [ + - ]: 15 : if (nsppol == 1) write(unt,'(a,i0,a)')"# phonon mode [",mu,"] q-index omega gamma lambda"
1553 [ - + ]: 15 : if (nsppol == 2) write(unt,'(a,i0,a)')&
1554 : 0 : "# phonon mode [",mu,"] q-index omega gamma_tot lambda_tot gamma[spin=1] lambda[spin=1] gamma[2] lambda[2]"
1555 : 15 : write(unt,'(a)')"#"
1556 [ + + ]: 635 : do iqpt=1,nqpt
1557 : 615 : omega = all_phfreq(mu, iqpt)
1558 [ + + ]: 1230 : gamma_spin = all_gammaq(mu, iqpt, :)
1559 [ + + ]: 1230 : lambda_spin = all_lambdaq(mu, iqpt, :)
1560 [ + - ]: 630 : if (nsppol == 1) then
1561 : 615 : write(unt,'(i8,3es16.6)' )iqpt,omega,gamma_spin(1),lambda_spin(1)
1562 : : else
1563 : 0 : write(unt,'(i8,es20.6,6es16.6)' )iqpt,omega,&
1564 [ # # # # ]: 0 : sum(gamma_spin),sum(lambda_spin),gamma_spin(1),lambda_spin(1),gamma_spin(2),lambda_spin(2)
1565 : : end if
1566 : : end do
1567 : : end do
1568 : :
1569 : 5 : close(unt)
1570 : :
1571 : : ! Write data to netcdf file
1572 [ + - ]: 5 : if (ncid /= nctk_noid) then
1573 : : ncerr = nctk_def_dims(ncid, [&
1574 : : nctkdim_t("natom3", 3*natom), nctkdim_t("nqpath", nqpt), nctkdim_t("number_of_spins", nsppol) &
1575 [ + + ]: 20 : ], defmode=.True.)
1576 [ - + ]: 5 : NCF_CHECK(ncerr)
1577 : :
1578 : : ncerr = nctk_def_arrays(ncid, [&
1579 : : nctkarr_t('qpath', "dp", "number_of_reduced_dimensions, nqpath"), &
1580 : : nctkarr_t('phfreq_qpath', "dp", "natom3, nqpath"), &
1581 : : nctkarr_t('phdispl_cart_qpath', "dp", "two, natom3, natom3, nqpath"), &
1582 : : nctkarr_t('phgamma_qpath', "dp", "natom3, nqpath, number_of_spins"), &
1583 [ + + ]: 30 : nctkarr_t('phlambda_qpath', "dp", "natom3, nqpath, number_of_spins")])
1584 [ - + ]: 5 : NCF_CHECK(ncerr)
1585 : :
1586 [ - + ]: 5 : NCF_CHECK(nctk_set_datamode(ncid))
1587 [ - + ]: 5 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "qpath"), qpath%points))
1588 [ - + ]: 5 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "phfreq_qpath"), all_phfreq))
1589 [ - + ]: 5 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "phdispl_cart_qpath"), all_displ_cart))
1590 [ - + ]: 5 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "phgamma_qpath"), all_gammaq))
1591 [ - + ]: 5 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "phlambda_qpath"), all_lambdaq))
1592 : : end if
1593 : : end if ! master
1594 : :
1595 [ - + ]: 5 : ABI_FREE(all_phfreq)
1596 [ - + ]: 5 : ABI_FREE(all_gammaq)
1597 [ - + ]: 5 : ABI_FREE(all_lambdaq)
1598 [ - + ]: 5 : ABI_FREE(all_displ_cart)
1599 : :
1600 : 5 : call qpath%free()
1601 : :
1602 [ - + - + : 10 : end subroutine phgamma_linwid
- + - + -
+ ]
1603 : : !!***
1604 : :
1605 : : !----------------------------------------------------------------------
1606 : :
1607 : : !!****f* m_phgamma/a2fw_free
1608 : : !! NAME
1609 : : !! a2fw_free
1610 : : !!
1611 : : !! FUNCTION
1612 : : !! Free the memory allocated in a2f
1613 : : !!
1614 : : !! SOURCE
1615 : :
1616 : 10 : subroutine a2fw_free(a2f)
1617 : :
1618 : : !Arguments ------------------------------------
1619 : : class(a2fw_t),intent(inout) :: a2f
1620 : : ! *********************************************************************
1621 : :
1622 : : ! integer
1623 [ + - ]: 10 : ABI_SFREE(a2f%qshift)
1624 : :
1625 : : ! real
1626 [ + - ]: 10 : ABI_SFREE(a2f%n0)
1627 [ + - ]: 10 : ABI_SFREE(a2f%omega)
1628 [ + - ]: 10 : ABI_SFREE(a2f%vals)
1629 [ - + ]: 10 : ABI_SFREE(a2f%vals_ee)
1630 [ + - ]: 10 : ABI_SFREE(a2f%lambdaw)
1631 : :
1632 : 10 : end subroutine a2fw_free
1633 : : !!***
1634 : :
1635 : : !----------------------------------------------------------------------
1636 : :
1637 : : !!****f* m_phgamma/a2fw_init
1638 : : !! NAME
1639 : : !! a2fw_init
1640 : : !!
1641 : : !! FUNCTION
1642 : : !! Calculates the FS averaged alpha^2F(w) function
1643 : : !!
1644 : : !! INPUTS
1645 : : !! cryst<crystal_t>=Info on the unit cell.
1646 : : !! ifc<ifc_type>=Interatomic force constants.
1647 : : !! gams<phgamma_t>=Structure storing the phonon linewidths.
1648 : : !! wstep=Step for linear frequency mesh in Ha.
1649 : : !! wminmax(2)=Minimum and maximum phonon frequency. Used to construct the linear mesh for A2F(w).
1650 : : !! ph_intmeth=Integration method for phonons: 1 for gaussian, 2 for tetrahedra
1651 : : !! smear=Gaussian broadening used to approximate the Dirac delta.
1652 : : !! ngqpt(3)=Divisions of the Q-mesh used for interpolating the phonon linewidths (see also nqshift and qshift).
1653 : : !! nqshift=Number of shifts used to generated the Q-mesh.
1654 : : !! qshift(3,nqshift)=The shifts.
1655 : : !! comm=MPI communicator
1656 : : !! [qintp]=If set to False, ngqgpt, nqshift, qshift and qptop are ignored and
1657 : : !! A2F(w) is computed from the IBZ values stored in gams. Default: True i.e use Fourier interpolation.
1658 : : !! [qptopt]=Controls the generation of the q-points. If not specified, the routine takes fully into account
1659 : : !! the symmetries of the system to generate the q points in the IBZone i.e. qptopt=1
1660 : : !! Other values of qptopt can be used for debugging purpose.
1661 : : !!
1662 : : !! OUTPUT
1663 : : !! a2f<a2fw_t>=Structure storing the Eliashberg function a2F(w).
1664 : : !!
1665 : : !! SOURCE
1666 : :
1667 : 10 : subroutine a2fw_init(a2f, gams, cryst, ifc, ph_intmeth, wstep, wminmax, smear, ngqpt, nqshift, qshift, comm, &
1668 : : qintp, qptopt) ! optional
1669 : :
1670 : : !Arguments ------------------------------------
1671 : : !scalars
1672 : : class(a2fw_t),target,intent(out) :: a2f
1673 : : integer,intent(in) :: ph_intmeth,nqshift,comm
1674 : : integer,intent(in),optional :: qptopt
1675 : : real(dp),intent(in) :: wstep,smear
1676 : : logical,optional,intent(in) :: qintp
1677 : : type(phgamma_t),intent(inout) :: gams
1678 : : type(ifc_type),intent(in) :: ifc
1679 : : type(crystal_t),intent(in) :: cryst
1680 : : !arrays
1681 : : integer,intent(in) :: ngqpt(3)
1682 : : real(dp),intent(in) :: wminmax(2),qshift(3,nqshift)
1683 : :
1684 : : !Local variables -------------------------
1685 : : !scalars
1686 : : integer,parameter :: master = 0
1687 : : integer :: my_qptopt,iq_ibz,nqibz,ount,my_rank,nproc,cnt
1688 : : integer :: mu,iw,natom3,nsppol,spin,ierr,nomega,nqbz
1689 : : integer :: iene, jene, itemp, ntemp, jene_jump, spinfactor
1690 : : real(dp) :: cpu,wall,gflops
1691 : : real(dp) :: lambda_iso,omega,omega_log,xx,omega_min,omega_max,ww,mustar,tc_macmill
1692 : : real(dp) :: temp_el, min_temp, delta_temp, chempot, ene1, ene2, G0
1693 : : logical :: do_qintp
1694 : : character(len=500) :: msg
1695 : 10 : type(htetra_t) :: tetra_q
1696 : : !arrays
1697 : : integer :: qptrlatt(3,3),new_qptrlatt(3,3)
1698 : 20 : real(dp) :: displ_cart(2,3,cryst%natom,3*cryst%natom)
1699 : 40 : real(dp) :: phfrq(gams%natom3),gamma_ph(gams%natom3),lambda_ph(gams%natom3), invphfrq(gams%natom3)
1700 : 10 : real(dp),allocatable :: my_qshift(:,:), gamma_ph_ee(:,:,:,:), tmp_a2f(:)
1701 : 10 : real(dp),contiguous, pointer :: a2f_1d(:)
1702 : 10 : real(dp),allocatable :: qibz(:,:),wtq(:),qbz(:,:), a2f_1mom(:),a2flogmom(:),a2flogmom_int(:),wdt(:,:)
1703 : 10 : real(dp),allocatable :: lambda_tetra(:,:,:),phfreq_tetra(:,:), tmp_gaussian(:,:)
1704 : 10 : real(dp),allocatable :: a2feew_partial(:), a2feew_partial_int(:), a2feew_w(:), a2feew_w_int(:)
1705 : : ! *********************************************************************
1706 : :
1707 : 10 : call cwtime(cpu, wall, gflops, "start")
1708 : 10 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
1709 : :
1710 [ + - ]: 10 : my_qptopt = 1; if (present(qptopt)) my_qptopt = qptopt
1711 [ + + ]: 10 : do_qintp = .True.; if (present(qintp)) do_qintp = qintp
1712 : 10 : nsppol = gams%nsppol; natom3 = gams%natom3
1713 : :
1714 [ - + ]: 10 : if (gams%prteliash == 3) then
1715 [ # # # # : 0 : ABI_MALLOC(gamma_ph_ee, (gams%nene, gams%nene, gams%natom3, gams%nsppol))
# # # # #
# # # # #
# # # # #
# # # #
# ]
1716 : : end if
1717 : :
1718 [ + + ]: 10 : if (do_qintp) then
1719 : : ! Generate fine q-mesh, find the IBZ and the corresponding weights.
1720 : 5 : qptrlatt = 0; qptrlatt(1,1) = ngqpt(1); qptrlatt(2,2) = ngqpt(2); qptrlatt(3,3) = ngqpt(3)
1721 : :
1722 : : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, my_qptopt, nqshift, qshift, nqibz, qibz, wtq, nqbz, qbz, &
1723 : 5 : new_kptrlatt=new_qptrlatt, new_shiftk=my_qshift)
1724 [ - + ]: 5 : ABI_FREE(qbz)
1725 : :
1726 : : ! Store quantities that cannot be easily (and safely) calculated if we only know the IBZ.
1727 [ + + ]: 20 : a2f%ngqpt = ngqpt; a2f%nqshift = size(my_qshift, dim=2)
1728 [ - + + - : 15 : ABI_MALLOC(a2f%qshift, (3, a2f%nqshift))
+ - + - -
+ - + -
+ ]
1729 [ + - + - : 30 : a2f%qshift = my_qshift
- + - - -
- - - + +
+ + ]
1730 [ - + ]: 5 : ABI_FREE(my_qshift)
1731 : :
1732 : : else
1733 : : ! No interpolation. Use q-mesh parameters from gams%
1734 [ + + ]: 20 : a2f%ngqpt = gams%ngqpt; a2f%nqshift = 1
1735 : 5 : nqibz = gams%nqibz
1736 [ - + + - : 15 : ABI_MALLOC(qibz, (3, nqibz))
+ - + - -
+ - + ]
1737 [ - + + - : 15 : ABI_MALLOC(wtq, (nqibz))
+ - + - -
+ - + ]
1738 [ - + - + ]: 5 : ABI_MALLOC(a2f%qshift, (3, a2f%nqshift))
1739 [ + - + - : 320 : qibz = gams%qibz; wtq = gams%wtq
- + - - -
- - - + +
+ + + - -
+ - - - -
+ + ]
1740 [ + + + + ]: 25 : a2f%qshift = zero ! Note: assuming q-mesh centered on Gamma.
1741 : : end if
1742 : :
1743 : 10 : call cwtime_report(" a2fw_init, q-setup:", cpu, wall, gflops)
1744 : :
1745 : : ! Define Min and max frequency for the mesh (enlarge it a bit)
1746 : 10 : omega_min = wminmax(1); omega_max = wminmax(2)
1747 : 10 : omega_min = omega_min - 0.1*abs(omega_min)
1748 [ - + ]: 10 : if (omega_min >= zero) omega_min = one/Ha_meV
1749 : 10 : omega_max = omega_max + 0.1*abs(omega_max)
1750 : :
1751 : 10 : a2f%nsppol = nsppol; a2f%natom3 = gams%natom3; a2f%smear = smear
1752 : 10 : a2f%omega_min = omega_min; a2f%omega_max = omega_max
1753 : 10 : nomega = int((omega_max - omega_min) / wstep); a2f%nomega = nomega; a2f%wstep = wstep
1754 : 10 : a2f%nene = gams%nene
1755 : 10 : a2f%enemin = gams%enemin
1756 : 10 : a2f%deltaene = gams%deltaene
1757 : :
1758 [ - + + - : 30 : ABI_MALLOC(a2f%n0, (nsppol))
+ - + - -
+ - + -
+ ]
1759 [ + - - + : 30 : a2f%n0 = gams%n0
- - - - -
- + + ]
1760 : : ! Build linear mesh.
1761 [ - + + - : 30 : ABI_MALLOC(a2f%omega, (nomega))
+ - + - -
+ - + -
+ ]
1762 [ + - + - : 4750 : a2f%omega = arth(omega_min, wstep, nomega)
- + - - +
+ ]
1763 : :
1764 [ - + + - : 19020 : ABI_CALLOC(a2f%vals, (nomega,0:natom3, nsppol))
- + + - -
+ + - + -
+ - - + -
+ - + + +
+ + + + ]
1765 [ - + + - : 19010 : ABI_CALLOC(a2f%lambdaw, (nomega,0:natom3, nsppol))
- + + - -
+ + - - +
- + - + +
+ + + +
+ ]
1766 : :
1767 [ - + ]: 10 : if (gams%prteliash == 3) then
1768 [ # # # # : 0 : ABI_CALLOC(a2f%vals_ee, (gams%nene, gams%nene, nomega, nsppol))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # #
# ]
1769 : : end if
1770 : :
1771 [ - + + - : 20 : ABI_MALLOC(tmp_a2f, (nomega))
- + - + ]
1772 : :
1773 [ + + ]: 10 : if (ph_intmeth == 2) then
1774 : : ! Prepare tetrahedron integration.
1775 : 8 : call cwtime(cpu, wall, gflops, "start")
1776 : :
1777 : 8 : qptrlatt = 0; qptrlatt(1, 1) = a2f%ngqpt(1); qptrlatt(2, 2) = a2f%ngqpt(2); qptrlatt(3, 3) = a2f%ngqpt(3)
1778 : 8 : tetra_q = tetra_from_kptrlatt(cryst, my_qptopt, qptrlatt, a2f%nqshift, a2f%qshift, nqibz, qibz, comm, msg, ierr)
1779 [ - + ]: 8 : if (ierr /= 0) ABI_ERROR(msg)
1780 : :
1781 [ - + + - : 1971 : ABI_CALLOC(lambda_tetra, (nqibz, natom3, nsppol))
- + + - -
+ + - + -
+ - - + -
+ + + + +
+ + ]
1782 [ - + + - : 1955 : ABI_CALLOC(phfreq_tetra, (nqibz, natom3))
- + + - +
- + - - +
- + + + +
+ ]
1783 : 8 : cnt = 0
1784 [ + + ]: 641 : do iq_ibz = 1, nqibz
1785 [ + - ]: 633 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI parallelism.
1786 : 633 : call ifc%fourq(cryst, qibz(:,iq_ibz), phfrq, displ_cart)
1787 : : ! save for tetrahedron interpolation
1788 [ + + ]: 2540 : phfreq_tetra(iq_ibz,:) = phfrq(:)
1789 : : end do
1790 : 8 : call xmpi_sum(phfreq_tetra, comm, ierr)
1791 : 16 : call cwtime_report(" a2fw_init%tetra", cpu, wall, gflops)
1792 : : end if
1793 : :
1794 : 10 : call cwtime(cpu, wall, gflops, "start")
1795 : :
1796 : : ! DEV_MJV
1797 : : !open(unit=900, file="a2fvals_ee.dat"); write (900,*) '# do_qintp ', do_qintp
1798 : :
1799 : : ! Loop over spins and q-points in the IBZ. For the moment parallelize over iq_ibz
1800 [ + + ]: 20 : do spin=1,nsppol
1801 : 10 : cnt = 0
1802 [ + + ]: 806 : do iq_ibz=1,nqibz
1803 : : ! TODO: for the moment the memory is not distributed, only the calculation exception is vals_ee
1804 [ - + ]: 786 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI parallelism.
1805 : :
1806 : : ! Interpolate or evaluate gamma directly.
1807 [ + + ]: 786 : if (do_qintp) then
1808 [ - + ]: 725 : if (gams%prteliash == 3) then
1809 : 0 : call gams%interp(cryst,ifc,spin,qibz(:,iq_ibz),phfrq,gamma_ph,lambda_ph,displ_cart,gamma_ph_ee=gamma_ph_ee(:,:,:,spin))
1810 : : else
1811 : 725 : call gams%interp(cryst,ifc,spin,qibz(:,iq_ibz),phfrq,gamma_ph,lambda_ph,displ_cart)
1812 : : end if
1813 : : else
1814 [ - + ]: 61 : if (gams%prteliash == 3) then
1815 : 0 : call gams%eval_qibz(cryst,ifc,iq_ibz,spin,phfrq,gamma_ph,lambda_ph,displ_cart,gamma_ph_ee=gamma_ph_ee(:,:,:,spin))
1816 : : else
1817 : 61 : call gams%eval_qibz(cryst,ifc,iq_ibz,spin,phfrq,gamma_ph,lambda_ph, displ_cart)
1818 : : end if
1819 : : end if
1820 : :
1821 : 10 : select case (ph_intmeth)
1822 : : case (1)
1823 : : ! Gaussian: Add all contributions from the phonon modes at this qpoint to a2f
1824 : : ! (note that unstable modes are included).
1825 [ - + + - : 612 : ABI_MALLOC(tmp_gaussian, (nomega, natom3))
- + + - +
- + - - +
- + ]
1826 [ + + ]: 612 : do mu=1,natom3
1827 [ + + ]: 217566 : tmp_a2f = zero
1828 [ + + ]: 217566 : do iw=1,nomega
1829 : 217107 : xx = a2f%omega(iw) - phfrq(mu)
1830 : 217107 : tmp_gaussian(iw, mu) = gaussian(xx, smear)
1831 : 217566 : tmp_a2f(iw) = tmp_a2f(iw) + tmp_gaussian(iw,mu) * lambda_ph(mu) * abs(phfrq(mu))
1832 : : end do
1833 [ + + ]: 217719 : a2f%vals(:,mu,spin) = a2f%vals(:,mu,spin) + tmp_a2f * wtq(iq_ibz)
1834 : : end do
1835 : :
1836 [ - + ]: 153 : if (gams%prteliash == 3) then
1837 : : ! reset phfrq for low freq modes
1838 [ # # ]: 0 : invphfrq = zero
1839 [ # # ]: 0 : do mu=1,natom3
1840 [ # # ]: 0 : if (abs(phfrq(mu)) > EPHTK_WTOL) invphfrq(mu) = one / abs(phfrq(mu))
1841 : : end do
1842 : :
1843 [ # # ]: 0 : do iene= 1, gams%nene
1844 [ # # ]: 0 : do jene= 1, gams%nene
1845 [ # # ]: 0 : tmp_a2f = zero
1846 : : ! TODO: following block is just a GEMM
1847 [ # # ]: 0 : do mu=1,natom3
1848 [ # # ]: 0 : do iw=1,nomega
1849 : 0 : tmp_a2f(iw) = tmp_a2f(iw) + tmp_gaussian(iw,mu) * gamma_ph_ee(jene,iene,mu,spin) * invphfrq(mu)
1850 : : end do
1851 : : end do
1852 : :
1853 [ # # ]: 0 : a2f%vals_ee(jene, iene, :, spin) = a2f%vals_ee(jene, iene, :, spin) + tmp_a2f(:) * wtq(iq_ibz)
1854 : : !if (iene == gams%nene/2 .and. jene == gams%nene/2) then
1855 : : ! write (900, '(a,E20.10,2x,2x,I6,3E20.10)') '#', wtq(iq_ibz), iq_ibz, invphfrq(1:3)
1856 : : ! do iw=1,nomega
1857 : : ! write (900, '(i6,2x,E20.10,2x,3E20.10,2x,3E20.10)') iw, a2f%vals_ee(jene, iene, iw, spin), &
1858 : : ! gamma_ph_ee(jene,iene,:,spin), tmp_gaussian(iw,1:3)
1859 : : ! end do
1860 : : ! write (900,*)
1861 : : !end if
1862 : : end do
1863 : : end do
1864 : : end if
1865 : :
1866 [ - + ]: 153 : ABI_FREE(tmp_gaussian)
1867 : :
1868 : : case (2)
1869 : : ! Tetra: store data.
1870 [ + + ]: 2532 : do mu=1,natom3
1871 : 2532 : lambda_tetra(iq_ibz, mu, spin) = lambda_ph(mu) * abs(phfrq(mu))
1872 : : end do
1873 : :
1874 [ - + ]: 633 : if (gams%prteliash == 3) then
1875 : 0 : ABI_ERROR("Eliashberg function with tetra not coded")
1876 : : end if
1877 : :
1878 : : case default
1879 [ + + - ]: 786 : ABI_ERROR(sjoin("Wrong ph_intmeth:", itoa(ph_intmeth)))
1880 : : end select
1881 : :
1882 : : end do ! iq_ibz
1883 : : end do ! spin
1884 : :
1885 : : !DEV_MJV
1886 : : !close(900)
1887 : :
1888 [ + + ]: 10 : if (ph_intmeth == 2) then
1889 : : ! workspace for tetra.
1890 [ - + + - : 24 : ABI_MALLOC(wdt, (nomega, 2))
+ - + - -
+ - + ]
1891 : :
1892 : : ! For each mode get its contribution
1893 [ + + ]: 16 : do spin=1,nsppol
1894 [ + + ]: 40 : do mu=1,natom3
1895 : 24 : cnt = 0
1896 [ + + ]: 1931 : do iq_ibz=1,nqibz
1897 : : ! NB: if we are interpolating the gamma, nqibz > gams%nqibz
1898 [ + - ]: 1899 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI parallelism.
1899 : :
1900 : 1899 : call tetra_q%get_onewk(iq_ibz, gams%bcorr, nomega, nqibz, phfreq_tetra(:,mu), omega_min, omega_max, one, wdt)
1901 [ + + + + ]: 1802151 : wdt = wdt * wtq(iq_ibz)
1902 : :
1903 : : ! Accumulate (Integral of a2F is computed afterwards)
1904 [ + + ]: 900150 : a2f%vals(:,mu,spin) = a2f%vals(:,mu,spin) + wdt(:,1) * lambda_tetra(iq_ibz,mu,spin)
1905 : : !a2f%lambdaw(:,mu,spin) = a2f%lambdaw(:,mu,spin) + wdt(:,2) * lambda_tetra(iq_ibz, mu, spin)
1906 : : end do
1907 : : end do
1908 : : end do
1909 : :
1910 : : ! Free memory allocated for tetra.
1911 [ - + ]: 8 : ABI_FREE(wdt)
1912 [ - + ]: 8 : ABI_FREE(lambda_tetra)
1913 [ - + ]: 8 : ABI_FREE(phfreq_tetra)
1914 : 8 : call tetra_q%free()
1915 : : end if
1916 : :
1917 : : ! Collect final results on each node
1918 : 10 : call xmpi_sum(a2f%vals, comm, ierr)
1919 [ + + ]: 20 : do spin=1,nsppol
1920 [ + + + + ]: 18940 : a2f%vals(:,0,spin) = sum(a2f%vals(:,1:natom3,spin), dim=2)
1921 : : ! previously would divide by g(eF, spin)
1922 : : !a2f%vals(:,:,spin) = a2f%vals(:,:,spin) / (two_pi*a2f%n0(spin))
1923 : : end do
1924 : :
1925 [ - + ]: 10 : if (gams%prteliash == 3) then
1926 : : ! For the moment vals_ee only works with gaussians
1927 : 0 : call xmpi_sum(a2f%vals_ee, comm, ierr)
1928 [ # # ]: 0 : do spin=1,nsppol
1929 [ # # # # : 0 : a2f%vals_ee(:,:,:,spin) = a2f%vals_ee(:,:,:,spin) / (two * pi * gams%n0(spin))
# # ]
1930 : : end do
1931 : : end if
1932 : :
1933 : 10 : call cwtime_report(" a2fw_init, a2f_eval:", cpu, wall, gflops)
1934 : :
1935 [ - + + - : 20 : ABI_MALLOC(a2f_1mom, (nomega))
- + - + ]
1936 [ - + + - : 20 : ABI_MALLOC(a2flogmom, (nomega))
- + - + ]
1937 [ - + + - : 20 : ABI_MALLOC(a2flogmom_int, (nomega))
- + - + ]
1938 : :
1939 : : !call a2fw_print_info()
1940 : :
1941 : : ! Compute lambda(w) resolved in spin and phonon mode.
1942 : : ! lambda(w) = int a2F(w')/w' dw'
1943 [ + + ]: 20 : do spin=1,nsppol
1944 [ + + ]: 60 : do mu=0,natom3
1945 : :
1946 [ + + ]: 18960 : do iw=1,nomega
1947 : 18920 : ww = a2f%omega(iw)
1948 [ + - ]: 18960 : if (abs(ww) > EPHTK_WTOL) then
1949 : 18920 : a2f_1mom(iw) = a2f%vals(iw, mu, spin) / abs(ww)
1950 : : else
1951 : 0 : a2f_1mom(iw) = zero
1952 : : end if
1953 : : end do
1954 : :
1955 : 50 : call simpson_int(nomega, wstep, a2f_1mom, a2f%lambdaw(:, mu, spin))
1956 : : end do
1957 : : end do
1958 : :
1959 : : ! print log moments of the alpha^2 F function (for each spin, note degeneracy factor).
1960 : 10 : spinfactor = int(2 / nsppol / gams%nspinor)
1961 [ + + ]: 20 : do spin=1,nsppol
1962 : 10 : a2f_1d => a2f%vals(:,0,spin)
1963 : :
1964 : 10 : lambda_iso = a2f%get_moment(0, spin)
1965 : :
1966 : : ! Get log moment of alpha^2F.
1967 [ + + ]: 4740 : a2flogmom = zero
1968 [ + + ]: 4740 : do iw=1,nomega
1969 : 4730 : omega = a2f%omega(iw)
1970 [ + - ]: 4740 : if (abs(omega) > EPHTK_WTOL) then
1971 : : !a2flogmom(iw) = (two / lambda_iso) * a2f_1d(iw) * log(abs(omega)) / abs(omega)
1972 : : ! I (WHO??? GMATTEO?) think this is the correct expression.
1973 : 4730 : a2flogmom(iw) = (spinfactor / lambda_iso) * a2f_1d(iw) * log(abs(omega)) / abs(omega)
1974 : : end if
1975 : : end do
1976 : 10 : call simpson_int(nomega, wstep, a2flogmom, a2flogmom_int)
1977 : 10 : omega_log = exp(a2flogmom_int(nomega))
1978 : :
1979 : 10 : mustar = 0.12
1980 : 10 : tc_macmill = omega_log/1.2_dp * exp((-1.04_dp*(one+lambda_iso)) / (lambda_iso-mustar*(one+0.62_dp*lambda_iso)))
1981 : :
1982 [ + - ]: 20 : if (my_rank == master) then
1983 : 10 : ount = std_out
1984 [ - + ]: 10 : if (nsppol > 1) then
1985 : 0 : write(msg,'(3a)') ch10,' Warning: some of the following quantities should be integrated over spin', ch10
1986 : 0 : call wrtout(ount, msg)
1987 : : end if
1988 : :
1989 [ + + ]: 10 : if (do_qintp) then
1990 : 5 : write(ount,'(a,i3)') ' Superconductivity: isotropic evaluation of parameters from electron-phonon coupling (interpolated) for spin ', spin
1991 : : else
1992 : 5 : write(ount,'(a,i3)') ' Superconductivity: isotropic evaluation of parameters from electron-phonon coupling (coarse grid) for spin ', spin
1993 : : endif
1994 : 10 : write(ount,'(a,es16.6)') ' isotropic lambda = ',lambda_iso
1995 : 10 : write(ount,'(a,es16.6,a,es16.6,a)' )' omegalog = ',omega_log,' (Ha) ', omega_log * Ha_K, ' (Kelvin) '
1996 : 10 : write(ount,'(a,es16.6,a,es16.6,a)') ' MacMillan Tc = ',tc_macmill,' (Ha) ', tc_macmill * Ha_K, ' (Kelvin) '
1997 : 10 : write(ount,"(a)") ' Positive moments of alpha2F:'
1998 : 10 : write(ount,'(a,es16.6)' ) ' lambda <omega^2> = ',a2f%get_moment(2, spin)
1999 : 10 : write(ount,'(a,es16.6)' ) ' lambda <omega^3> = ',a2f%get_moment(3, spin)
2000 : 10 : write(ount,'(a,es16.6)' ) ' lambda <omega^4> = ',a2f%get_moment(4, spin)
2001 : 10 : write(ount,'(a,es16.6)' ) ' lambda <omega^5> = ',a2f%get_moment(5, spin)
2002 : : end if
2003 : : end do
2004 : :
2005 : : ! Calculate the temperature dependence of the a2f(e,e',w) integrals (G_0(T_e)
2006 : : ! as in PRL 110 016405 (2013) [[cite:Arnaud2013]])
2007 [ - + - - ]: 10 : if (gams%prteliash == 3 .and. my_rank == master) then
2008 : 0 : ntemp = 100
2009 : 0 : min_temp = zero
2010 : 0 : delta_temp = 40._dp ! Kelvin
2011 [ # # # # : 0 : ABI_MALLOC(a2feew_partial, (a2f%nene))
# # # # #
# # # ]
2012 [ # # # # : 0 : ABI_MALLOC(a2feew_partial_int, (a2f%nene))
# # # # ]
2013 [ # # # # : 0 : ABI_MALLOC(a2feew_w, (nomega))
# # # # ]
2014 [ # # # # : 0 : ABI_MALLOC(a2feew_w_int, (nomega))
# # # # ]
2015 : :
2016 [ # # ]: 0 : if (open_file("EPC_strength_aafo_T.dat", msg, newunit=ount, form="formatted", action="write", status="unknown") /= 0) then
2017 : 0 : ABI_ERROR(msg)
2018 : : end if
2019 : :
2020 : 0 : write(ount, "(a)")"# temp_el, G_0(T_e) in W/m^3/K, spin"
2021 [ # # ]: 0 : do spin=1,nsppol
2022 [ # # ]: 0 : do itemp = 1, ntemp
2023 : 0 : temp_el = min_temp + (itemp-1)*delta_temp
2024 : :
2025 : : ! TODO: need to evolve the chemical potential with T, but I do not have access to the full DOS here!!
2026 : : ! possible fix using local information on DOS variation near E_F...
2027 : 0 : chempot = a2f%enemin + half * a2f%nene * a2f%deltaene
2028 : :
2029 [ # # ]: 0 : do iw=1,nomega
2030 : 0 : omega = a2f%omega(iw)
2031 : 0 : jene_jump = nint(omega/a2f%deltaene)
2032 [ # # ]: 0 : a2feew_partial = zero
2033 [ # # ]: 0 : do iene=1,a2f%nene
2034 : 0 : ene1 = a2f%enemin + (iene-1)*a2f%deltaene
2035 : 0 : ene2 = ene1 + omega
2036 : : a2feew_partial(iene) = a2f%vals_ee(min(a2f%nene,iene+jene_jump), iene, iw, spin) * &
2037 : 0 : (fermi_dirac(ene1, chempot, temp_el/Ha_K) - fermi_dirac(ene2, chempot, temp_el/Ha_K))
2038 : : end do
2039 : 0 : call simpson_int(a2f%nene, a2f%deltaene, a2feew_partial, a2feew_partial_int)
2040 : 0 : a2feew_w(iw) = a2feew_partial_int(a2f%nene)
2041 : : end do
2042 : 0 : call simpson_int(nomega, wstep, a2feew_w, a2feew_w_int)
2043 : 0 : G0 = a2feew_w_int(nomega) * two_pi * a2f%n0(spin) / cryst%ucvol
2044 : : ! conversion factor for G0 to SI units = Ha_J / Time_Sec / (Bohr_meter)**3 ~ 1.2163049915755545e+30
2045 : 0 : write(ount, "(2(e20.10,2x),i5)") temp_el, G0 * kb_HaK / Time_Sec / (Bohr_meter)**3, spin !* Ha_J???
2046 : : end do
2047 : : end do
2048 : 0 : close(ount)
2049 : :
2050 [ # # ]: 0 : ABI_FREE(a2feew_partial)
2051 [ # # ]: 0 : ABI_FREE(a2feew_partial_int)
2052 [ # # ]: 0 : ABI_FREE(a2feew_w)
2053 [ # # ]: 0 : ABI_FREE(a2feew_w_int)
2054 [ # # ]: 0 : ABI_FREE(gamma_ph_ee)
2055 : : end if
2056 : :
2057 [ - + ]: 10 : ABI_FREE(tmp_a2f)
2058 [ - + ]: 10 : ABI_FREE(a2f_1mom)
2059 [ - + ]: 10 : ABI_FREE(a2flogmom)
2060 [ - + ]: 10 : ABI_FREE(a2flogmom_int)
2061 [ - + ]: 10 : ABI_FREE(qibz)
2062 [ - + ]: 10 : ABI_FREE(wtq)
2063 : :
2064 [ + - - + : 70 : end subroutine a2fw_init
- + - + -
+ - - - -
- + - - -
- - + - +
- + - + -
+ ]
2065 : : !!***
2066 : :
2067 : : !----------------------------------------------------------------------
2068 : :
2069 : : !!****f* m_phgamma/a2fw_get_moment
2070 : : !! NAME
2071 : : !! a2fw_get_moment
2072 : : !!
2073 : : !! FUNCTION
2074 : : !! Compute \int dw [a2F(w)/w] w^n. From Allen PRL 59 1460 [[cite:Allen1987]].
2075 : : !! See also [[cite:Grimvall1981]], Eq 6.72 page 175)
2076 : : !!
2077 : : !! INPUTS
2078 : : !! nn=Value of n
2079 : : !! spin=The spin component. 0 to sum over spins.
2080 : : !!
2081 : : !! OUTPUT
2082 : : !! a2fw_get_moment = \int dw [a2F(w)/w] w^n
2083 : : !! [out_int(x)] = \int^{x} dw [a2F(w)/w] w^n
2084 : : !!
2085 : : !! SOURCE
2086 : :
2087 : 50 : real(dp) function a2fw_get_moment(a2f, nn, spin, out_int)
2088 : :
2089 : : !Arguments ------------------------------------
2090 : : class(a2fw_t),intent(in) :: a2f
2091 : : integer,intent(in) :: spin,nn
2092 : : !arrays
2093 : : real(dp),intent(out),optional :: out_int(a2f%nomega)
2094 : :
2095 : : !Local variables -------------------------
2096 : : !scalars
2097 : : integer :: iw
2098 : : real(dp) :: omg, omg_nm1
2099 : : !arrays
2100 : 50 : real(dp) :: ff(a2f%nomega), int_ff(a2f%nomega), values(a2f%nomega)
2101 : : ! *********************************************************************
2102 : :
2103 : : ! Construct the integrand function. [a2F(w)/w] w^n
2104 [ + + + + ]: 47350 : ff = zero; int_ff = zero
2105 : :
2106 [ - + ]: 50 : if (spin == 0) then
2107 [ # # ]: 0 : if (a2f%nsppol == 1) then
2108 [ # # ]: 0 : values = a2f%vals(:, 0, 1)
2109 : : !if (a2f%nspinor == 1) values = two * values
2110 [ # # ]: 0 : else if (a2f%nsppol == 2) then
2111 [ # # # # ]: 0 : values = sum(a2f%vals(:, 0, :), dim=2)
2112 : : end if
2113 : :
2114 : : else
2115 [ + + ]: 23700 : values = a2f%vals(:, 0, spin)
2116 : : end if
2117 : :
2118 [ + + ]: 50 : if (nn - 1 >= 0) then
2119 [ + + ]: 18960 : do iw=1,a2f%nomega
2120 : 18920 : omg = a2f%omega(iw)
2121 : 18920 : omg_nm1 = omg ** (nn - 1)
2122 : 18960 : ff(iw) = values(iw) * omg_nm1
2123 : : end do
2124 : : else
2125 [ + + ]: 4740 : do iw=1,a2f%nomega
2126 : 4730 : omg = a2f%omega(iw)
2127 [ + - ]: 4730 : omg_nm1 = zero; if (abs(omg) > EPHTK_WTOL) omg_nm1 = omg**(nn-1)
2128 : 4740 : ff(iw) = values(iw) * omg_nm1
2129 : : end do
2130 : : end if
2131 : :
2132 : : ! Integration with simpson rule on a linear mesh.
2133 : 50 : call simpson_int(a2f%nomega, a2f%wstep, ff, int_ff)
2134 : :
2135 : 50 : a2fw_get_moment = int_ff(a2f%nomega)
2136 [ - + - - ]: 50 : if (present(out_int)) out_int = int_ff
2137 : :
2138 : 50 : end function a2fw_get_moment
2139 : : !!***
2140 : :
2141 : : !----------------------------------------------------------------------
2142 : :
2143 : : !!****f* m_phgamma/a2fw_tr_moment
2144 : : !! NAME
2145 : : !! a2fw_tr_moment
2146 : : !!
2147 : : !! FUNCTION
2148 : : !! Compute \int dw [a2F_tr(w)/w] w^n
2149 : : !! From Allen PRL 59 1460 [[cite:Allen1987]] and later PRB papers.
2150 : : !! See also [[cite:Grimvall1981]] book.
2151 : : !!
2152 : : !! INPUTS
2153 : : !! nn=Value of n
2154 : : !! spin=The spin component
2155 : : !!
2156 : : !! OUTPUT
2157 : : !! a2fw_tr_moment = \int dw [a2F_tr(w)/w] w^n
2158 : : !! [out_int(x)] = \int^{x} dw [a2F_tr(w)/w] w^n
2159 : : !!
2160 : : !! SOURCE
2161 : :
2162 [ - + ]: 50 : function a2fw_tr_moment(a2f_tr, nn, spin, out_int)
2163 : :
2164 : : !Arguments ------------------------------------
2165 : : !scalars
2166 : : class(a2fw_tr_t),intent(in) :: a2f_tr
2167 : : integer,intent(in) :: spin,nn
2168 : : !arrays
2169 : : real(dp),intent(out),optional :: out_int(a2f_tr%nomega,3,3)
2170 : : real(dp) :: a2fw_tr_moment(3,3)
2171 : :
2172 : : !Local variables -------------------------
2173 : : !scalars
2174 : : integer :: iw, idir, jdir
2175 : : real(dp) :: omg,omg_nm1
2176 : : !arrays
2177 [ - + ]: 50 : real(dp) :: ff(a2f_tr%nomega),int_ff(a2f_tr%nomega)
2178 : : ! *********************************************************************
2179 : :
2180 [ + + ]: 200 : do jdir = 1, 3
2181 [ + + ]: 650 : do idir = 1, 3
2182 : : ! Construct the integrand function. [a2F_tr(w)/w] w^n
2183 [ + + + + ]: 426150 : ff = zero; int_ff = zero
2184 : :
2185 [ + + ]: 450 : if (nn-1 >= 0) then
2186 [ + + ]: 170640 : do iw=1,a2f_tr%nomega
2187 : 170280 : omg = a2f_tr%omega(iw)
2188 : 170280 : omg_nm1 = omg ** (nn-1)
2189 : 170640 : ff(iw) = a2f_tr%vals_tr(iw,idir,jdir,0,spin) * omg_nm1
2190 : : end do
2191 : : else
2192 [ + + ]: 42660 : do iw=1,a2f_tr%nomega
2193 : 42570 : omg = a2f_tr%omega(iw)
2194 [ + - ]: 42570 : omg_nm1 = zero; if (abs(omg) > EPHTK_WTOL) omg_nm1 = omg**(nn-1)
2195 : 42660 : ff(iw) = a2f_tr%vals_tr(iw,idir,jdir,0,spin) * omg_nm1
2196 : : end do
2197 : : end if
2198 : :
2199 : : ! Integration with simpson rule on a linear mesh.
2200 : 450 : call simpson_int(a2f_tr%nomega, a2f_tr%wstep, ff, int_ff)
2201 : :
2202 : 450 : a2fw_tr_moment(idir, jdir) = int_ff(a2f_tr%nomega)
2203 [ - + - - ]: 600 : if (present(out_int)) out_int(:,idir,jdir) = int_ff(:)
2204 : : end do
2205 : : end do
2206 : :
2207 : : end function a2fw_tr_moment
2208 : : !!***
2209 : :
2210 : : !----------------------------------------------------------------------
2211 : :
2212 : : !!****f* m_phgamma/a2fw_write
2213 : : !! NAME
2214 : : !! a2fw_write
2215 : : !!
2216 : : !! FUNCTION
2217 : : !! Write alpha^2F(w) to an external file in text form
2218 : : !!
2219 : : !! INPUTS
2220 : : !! basename=Filename for output.
2221 : : !! post=String appended to netcdf variables e.g. _qcoarse, _qintp
2222 : : !! ncid=Netcdf file handler. Set it to nctk_noid to disable output.
2223 : : !!
2224 : : !! OUTPUT
2225 : : !! Output is written to file. This routine should be called by one MPI proc.
2226 : : !!
2227 : : !! SOURCE
2228 : :
2229 : 10 : subroutine a2fw_write(a2f, basename, post, ncid)
2230 : :
2231 : : !Arguments ------------------------------------
2232 : : !scalars
2233 : : class(a2fw_t),intent(in) :: a2f
2234 : : character(len=*),intent(in) :: basename, post
2235 : : integer,intent(in) :: ncid
2236 : :
2237 : : !Local variables -------------------------
2238 : : !scalars
2239 : : integer :: iw,spin,unt,ii,mu, ncerr
2240 : : character(len=500) :: dim1_name, msg
2241 : : character(len=fnlen) :: path
2242 : : ! *********************************************************************
2243 : :
2244 : : ! Write spin-resolved a2F(w)
2245 [ + - ]: 10 : path = strcat(basename, "_A2FW")
2246 [ - + ]: 10 : if (open_file(path, msg, newunit=unt, form="formatted", action="write", status="unknown") /= 0) then
2247 : 0 : ABI_ERROR(msg)
2248 : : end if
2249 : :
2250 : 10 : call write_a2fw_header()
2251 : :
2252 [ + - ]: 10 : if (a2f%nsppol == 1) then
2253 : 10 : write(unt,'(a)')"# Frequency, a2F(w), lambda(w)"
2254 [ + + ]: 4740 : do iw=1,a2f%nomega
2255 : 4740 : write(unt,*) a2f%omega(iw), a2f%vals(iw,0,1), a2f%lambdaw(iw,0,1)
2256 : : end do
2257 : :
2258 : : else
2259 : 0 : write(unt,'(a)')"# Frequency, a2F_tot(w), lambda_tot(w)dw, a2F_spin1(w), lambda_spin1(w) ..."
2260 [ # # ]: 0 : do iw=1,a2f%nomega
2261 : 0 : write(unt,'(E20.10,3x,3(2E20.10, 2x))') a2f%omega(iw), &
2262 [ # # # # ]: 0 : sum(a2f%vals(iw,0,:)) , sum(a2f%lambdaw(iw,0,:)), & ! TOT
2263 : 0 : a2f%vals(iw,0,1) , a2f%lambdaw(iw,0,1), & ! UP
2264 : 0 : a2f%vals(iw,0,2) , a2f%lambdaw(iw,0,2) ! DOWN
2265 : : end do
2266 : : end if
2267 : :
2268 : 10 : close(unt)
2269 : :
2270 : : ! Write phonon contributions to a2F(w)
2271 [ + - ]: 10 : path = strcat(basename, "_PH_A2FW")
2272 [ - + ]: 10 : if (open_file(path, msg, newunit=unt, form="formatted", action="write", status="unknown") /= 0) then
2273 : 0 : ABI_ERROR(msg)
2274 : : end if
2275 : 10 : call write_a2fw_header()
2276 : :
2277 [ + - ]: 10 : if (a2f%nsppol == 1) then
2278 [ + + ]: 50 : do mu=0,a2f%natom3
2279 : 40 : write(unt,'(a,i0)')"# Phonon mode ",mu
2280 : 40 : write(unt,'(a)')"# Frequency, a2F(w), lambda(w)"
2281 [ + + ]: 18960 : do iw=1,a2f%nomega
2282 : 18960 : write(unt,*) a2f%omega(iw), a2f%vals(iw,mu,1), a2f%lambdaw(iw,mu,1)
2283 : : end do
2284 [ + + ]: 130 : do ii=1,2; write(unt,'(a)')""; end do
2285 : : end do
2286 : :
2287 : : else
2288 [ # # ]: 0 : do mu=0,a2f%natom3
2289 : 0 : write(unt,'(a,i0)')"# Phonon mode ",mu
2290 : 0 : write(unt,'(a)')"# Frequency, a2F_tot(w), lambda_tot(w)dw, a2F_spin1(w), lambda_spin1(w) ..."
2291 [ # # ]: 0 : do iw=1,a2f%nomega
2292 : 0 : write(unt,'(E20.10,3x,3(2E20.10, 2x))') a2f%omega(iw), &
2293 [ # # # # ]: 0 : sum(a2f%vals(iw,mu,:)), sum(a2f%lambdaw(iw,mu,:)), & ! TOT
2294 : 0 : a2f%vals(iw,mu,1) , a2f%lambdaw(iw,mu,1), & ! UP
2295 : 0 : a2f%vals(iw,mu,2) , a2f%lambdaw(iw,mu,2) ! DOWN
2296 : : end do
2297 : : end do
2298 : : end if
2299 : :
2300 : 10 : close(unt)
2301 : :
2302 [ + - ]: 10 : if (ncid /= nctk_noid) then
2303 : : ! Define dimensions.
2304 [ + - ]: 10 : dim1_name = strcat("a2f_nomega", post)
2305 : : ncerr = nctk_def_dims(ncid, [ &
2306 : : nctkdim_t(dim1_name, a2f%nomega), &
2307 : : nctkdim_t("natom3p1", a2f%natom3 + 1), nctkdim_t("number_of_spins", a2f%nsppol) &
2308 [ + + ]: 40 : ], defmode=.True.)
2309 [ - + ]: 10 : NCF_CHECK(ncerr)
2310 : :
2311 : : ncerr = nctk_def_arrays(ncid, [ &
2312 : : nctkarr_t(strcat('a2f_mesh', post), "dp", dim1_name), &
2313 : : nctkarr_t(strcat('a2f_values', post), "dp", strcat(dim1_name, ", natom3p1, number_of_spins")), &
2314 : : nctkarr_t(strcat('a2f_lambdaw', post), "dp", strcat(dim1_name, ", natom3p1, number_of_spins")) &
2315 [ + - + - : 40 : ])
+ - + - +
- + + ]
2316 [ - + ]: 10 : NCF_CHECK(ncerr)
2317 : :
2318 [ - + ]: 10 : NCF_CHECK(nctk_set_datamode(ncid))
2319 [ - + ]: 10 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, strcat("a2f_mesh", post)), a2f%omega))
2320 [ - + ]: 10 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, strcat("a2f_values", post)), a2f%vals))
2321 [ - + ]: 10 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, strcat("a2f_lambdaw", post)), a2f%lambdaw))
2322 : : end if
2323 : :
2324 : : contains
2325 : :
2326 : 20 : subroutine write_a2fw_header()
2327 : :
2328 : : ! Output the header.
2329 : 20 : write(unt,'(a)') '#'
2330 : 20 : write(unt,'(a)') '# ABINIT package: a2F(w) file'
2331 : 20 : write(unt,'(a)') '#'
2332 : 20 : write(unt,'(a)') '# a2F(w) function integrated over the FS. omega in a.u.'
2333 [ + - ]: 20 : write(unt,'(2a)') '# ngqpt: ',trim(ltoa(a2f%ngqpt))
2334 : 20 : write(unt,'(a,i0,3(a,e16.6))')'# number of frequencies: ',a2f%nomega," between omega_min: ",a2f%omega_min,&
2335 : 40 : ' Ha and omega_max: ',a2f%omega_max,' Ha with step:',a2f%wstep
2336 : 20 : write(unt,'(a,e16.6)') '# the smearing width for gaussians is ',a2f%smear
2337 [ + + ]: 40 : write(unt,'(a,e16.6)')"# Total DOS at Fermi level ",sum(a2f%n0)
2338 [ + + ]: 40 : do spin=1,a2f%nsppol
2339 : 40 : write(unt,"(a,i0,a,e16.6)")"# The DOS at Fermi level for spin ",spin," is ",a2f%n0(spin)
2340 : : end do
2341 [ + + ]: 60 : do ii=1,2; write(unt,'(a)') "# "; end do
2342 : :
2343 : 20 : end subroutine write_a2fw_header
2344 : :
2345 : : end subroutine a2fw_write
2346 : : !!***
2347 : :
2348 : : !----------------------------------------------------------------------
2349 : : !!****f* m_phgamma/a2fw_ee_write
2350 : : !! NAME
2351 : : !! a2fw_ee_write
2352 : : !!
2353 : : !! FUNCTION
2354 : : !! Write alpha^2F(e,e',w) to an external file in text form
2355 : : !!
2356 : : !! INPUTS
2357 : : !! basename=Filename for output.
2358 : : !!
2359 : : !! OUTPUT
2360 : : !! Output is written to file. This routine should be called by one MPI proc.
2361 : : !!
2362 : : !! SOURCE
2363 : :
2364 : 0 : subroutine a2fw_ee_write(a2f, basename)
2365 : :
2366 : : !Arguments ------------------------------------
2367 : : class(a2fw_t),intent(in) :: a2f
2368 : : character(len=*),intent(in) :: basename
2369 : :
2370 : : !Local variables -------------------------
2371 : : !scalars
2372 : : integer :: iw, spin, unt, ii, iene, jene
2373 : : real(dp) :: ene1, ene2
2374 : : character(len=500) :: msg
2375 : : character(len=fnlen) :: path
2376 : : ! *********************************************************************
2377 : :
2378 : : ! Write spin-resolved a2F(e,e',w)
2379 [ # # ]: 0 : path = strcat(basename, "_A2FEEW")
2380 [ # # ]: 0 : if (open_file(path, msg, newunit=unt, form="formatted", action="write", status="unknown") /= 0) then
2381 : 0 : ABI_ERROR(msg)
2382 : : end if
2383 : :
2384 : 0 : call write_a2fw_header()
2385 : :
2386 : 0 : write(unt,'(a)')"# en2, en1, Frequency, a2F_tot(w) (presently summed over spin)"
2387 [ # # ]: 0 : do iw=1,a2f%nomega
2388 [ # # ]: 0 : do iene=1,a2f%nene
2389 : 0 : ene1 = a2f%enemin + (iene-1)*a2f%deltaene
2390 [ # # ]: 0 : do jene=1,a2f%nene
2391 : 0 : ene2 = a2f%enemin + (jene-1)*a2f%deltaene
2392 [ # # ]: 0 : write(unt,'(3E20.10,2x,E20.10)') ene2, ene1, a2f%omega(iw), sum(a2f%vals_ee(jene,iene,iw,:)) ! TOT
2393 : : end do
2394 : : end do
2395 : : end do
2396 : :
2397 : 0 : close(unt)
2398 : :
2399 : : ! Write spin-resolved a2F(ef, ef, w)
2400 [ # # ]: 0 : path = strcat(basename, "_A2FW_reference")
2401 [ # # ]: 0 : if (open_file(path, msg, newunit=unt, form="formatted", status="unknown") /= 0) then
2402 : 0 : ABI_ERROR(msg)
2403 : : end if
2404 : :
2405 : 0 : call write_a2fw_header()
2406 : :
2407 : 0 : write(unt,'(a)')"# Frequency, a2F_tot(ef,ef,w) for comparison with normal a2F(w) (presently summed over spin)"
2408 : 0 : iene = int(a2f%nene/2)
2409 : 0 : jene = int(a2f%nene/2)
2410 [ # # ]: 0 : do iw=1,a2f%nomega
2411 [ # # ]: 0 : write(unt,'(E20.10,2x,E20.10)') a2f%omega(iw), sum(a2f%vals_ee(jene,iene,iw,:)) ! TOT
2412 : : end do
2413 : :
2414 : 0 : close(unt)
2415 : :
2416 : : contains
2417 : :
2418 : 0 : subroutine write_a2fw_header()
2419 : :
2420 : : ! Output the header.
2421 : 0 : write(unt,'(a)') '#'
2422 : 0 : write(unt,'(a)') '# ABINIT package: a2F(e,eprime,w) file'
2423 : 0 : write(unt,'(a)') '#'
2424 : 0 : write(unt,'(a)') '# a2F(e,eprime,w) function integrated over the FS. omega in a.u.'
2425 [ # # ]: 0 : write(unt,'(2a)') '# ngqpt: ',trim(ltoa(a2f%ngqpt))
2426 : 0 : write(unt,'(a,i0,2(a,e16.6))')'# number of energies: ',a2f%nene," from enemin: ",a2f%enemin,' Ha with step ', a2f%deltaene
2427 : 0 : write(unt,'(a,i0,3(a,e16.6))')'# number of frequencies: ',a2f%nomega," between omega_min: ",a2f%omega_min, &
2428 : 0 : ' Ha and omega_max: ',a2f%omega_max,' Ha with step:',a2f%wstep
2429 : 0 : write(unt,'(a,e16.6)') '# the smearing width for gaussians is ',a2f%smear
2430 [ # # ]: 0 : write(unt,'(a,e16.6)')"# Total DOS at Fermi level ",sum(a2f%n0)
2431 [ # # ]: 0 : do spin=1,a2f%nsppol
2432 : 0 : write(unt,"(a,i0,a,e16.6)")"# The DOS at Fermi level for spin ",spin," is ",a2f%n0(spin)
2433 : : end do
2434 [ # # ]: 0 : do ii=1,2
2435 : 0 : write(unt,'(a)') "# "
2436 : : end do
2437 : :
2438 : 0 : end subroutine write_a2fw_header
2439 : :
2440 : : end subroutine a2fw_ee_write
2441 : : !!***
2442 : :
2443 : : !----------------------------------------------------------------------
2444 : :
2445 : : !!****f* m_phgamma/a2fw_tr_free
2446 : : !! NAME
2447 : : !! a2fw_tr_free
2448 : : !!
2449 : : !! FUNCTION
2450 : : !! Free the memory allocated in a2fw_tr_t
2451 : : !!
2452 : : !! SOURCE
2453 : :
2454 : 10 : subroutine a2fw_tr_free(a2f_tr)
2455 : :
2456 : : !Arguments ------------------------------------
2457 : : class(a2fw_tr_t),intent(inout) :: a2f_tr
2458 : : ! *********************************************************************
2459 : :
2460 : : ! integer
2461 [ + - ]: 10 : ABI_SFREE(a2f_tr%qshift)
2462 : :
2463 : : ! real
2464 [ + - ]: 10 : ABI_SFREE(a2f_tr%n0)
2465 [ + - ]: 10 : ABI_SFREE(a2f_tr%omega)
2466 [ + - ]: 10 : ABI_SFREE(a2f_tr%vals_in)
2467 [ + - ]: 10 : ABI_SFREE(a2f_tr%vals_out)
2468 [ + - ]: 10 : ABI_SFREE(a2f_tr%vals_tr)
2469 [ - + ]: 10 : ABI_SFREE(a2f_tr%vals_tr_gen)
2470 [ + - ]: 10 : ABI_SFREE(a2f_tr%lambdaw_tr)
2471 : :
2472 : 10 : end subroutine a2fw_tr_free
2473 : : !!***
2474 : :
2475 : : !----------------------------------------------------------------------
2476 : :
2477 : : !!****f* m_phgamma/a2fw_tr_init
2478 : : !! NAME
2479 : : !! a2fw_tr_init
2480 : : !!
2481 : : !! FUNCTION
2482 : : !! Calculates the FS averaged alpha^2F_tr,in,out(w) functions
2483 : : !!
2484 : : !! INPUTS
2485 : : !! cryst<crystal_t>=Info on the unit cell.
2486 : : !! ifc<ifc_type>=Interatomic force constants.
2487 : : !! gams<phgamma_t>=Structure storing the phonon linewidths.
2488 : : !! wstep=Step for linear frequency mesh in Ha.
2489 : : !! wminmax(2)=Minimum and maximum phonon frequency. Used to construct the linear mesh for A2F(w).
2490 : : !! ph_intmeth=Integration method for phonons: 1 for gaussian, 2 for tetrahedra
2491 : : !! smear=Gaussian broadening used to approximate the Dirac delta.
2492 : : !! ngqpt(3)=Divisions of the Q-mesh used for interpolating the phonon linewidths (see also nqshift and qshift).
2493 : : !! nqshift=Number of shifts used to generated the Q-mesh.
2494 : : !! qshift(3,nqshift)=The shifts.
2495 : : !! comm=MPI communicator
2496 : : !! [qintp]=If set to False, ngqgpt, nqshift, qshift and qptop are ignored and
2497 : : !! A2F(w) is computed from the IBZ values stored in gams. Default: True i.e use Fourier interpolation.
2498 : : !! [qptopt]=Controls the generation of the q-points. If not specified, the routine takes fully into account
2499 : : !! the symmetries of the system to generate the q points in the IBZone i.e. qptopt=1
2500 : : !! Other values of qptopt can be used for debugging purpose.
2501 : : !!
2502 : : !! OUTPUT
2503 : : !! a2f_tr<a2fw_tr_t>=Structure storing the Eliashberg transport function a2F_tr(w).
2504 : : !!
2505 : : !! SOURCE
2506 : :
2507 : 10 : subroutine a2fw_tr_init(a2f_tr, gams, cryst, ifc, ph_intmeth, wstep, wminmax, smear, ngqpt, nqshift, qshift, comm,&
2508 : : qintp, qptopt) ! optional
2509 : :
2510 : : !Arguments ------------------------------------
2511 : : !scalars
2512 : : class(a2fw_tr_t),target,intent(out) :: a2f_tr
2513 : : integer,intent(in) :: ph_intmeth,nqshift,comm
2514 : : integer,intent(in),optional :: qptopt
2515 : : real(dp),intent(in) :: wstep,smear
2516 : : logical,optional,intent(in) :: qintp
2517 : : type(phgamma_t),intent(inout) :: gams
2518 : : type(ifc_type),intent(in) :: ifc
2519 : : type(crystal_t),intent(in) :: cryst
2520 : : !arrays
2521 : : integer,intent(in) :: ngqpt(3)
2522 : : real(dp),intent(in) :: wminmax(2),qshift(3,nqshift)
2523 : :
2524 : : !Local variables -------------------------
2525 : : !scalars
2526 : : integer,parameter :: master = 0
2527 : : integer :: my_qptopt,iq_ibz,nqibz,ount,my_rank,nproc,cnt
2528 : : integer :: mu,iw,natom3,nsppol,spin,ierr,nomega,nqbz, idir, jdir
2529 : : real(dp) :: omega,xx,omega_min,omega_max,ww, cpu, wall, gflops
2530 : : logical :: do_qintp
2531 : : character(len=500) :: msg
2532 : 10 : type(htetra_t) :: tetra_q
2533 : : !arrays
2534 : : integer :: qptrlatt(3,3),new_qptrlatt(3,3)
2535 : 20 : real(dp) :: lambda_iso(3,3), omega_log(3,3), phfrq(gams%natom3)
2536 : 20 : real(dp) :: gamma_in_ph(3,3,gams%natom3), gamma_out_ph(3,3,gams%natom3)
2537 : 30 : real(dp) :: lambda_in_ph(3,3,gams%natom3), lambda_out_ph(3,3,gams%natom3)
2538 : 10 : real(dp),allocatable :: tmp_a2f_in(:,:,:), tmp_a2f_out(:,:,:), my_qshift(:,:)
2539 : 10 : real(dp), contiguous, pointer :: a2f_tr_1d(:)
2540 : 10 : real(dp),allocatable :: qibz(:,:),wtq(:),qbz(:,:)
2541 : 10 : real(dp),allocatable :: a2f_tr_1mom(:),a2f_tr_logmom(:),a2f_tr_logmom_int(:),wdt(:,:)
2542 : 10 : real(dp),allocatable :: lambda_in_tetra(:,:,:,:,:),phfreq_tetra(:,:,:), lambda_out_tetra(:,:,:,:,:)
2543 : : ! *********************************************************************
2544 : :
2545 [ + - ]: 10 : my_qptopt = 1; if (present(qptopt)) my_qptopt = qptopt
2546 [ + + ]: 10 : do_qintp = .True.; if (present(qintp)) do_qintp = qintp
2547 : :
2548 : 10 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
2549 : 10 : nsppol = gams%nsppol; natom3 = gams%natom3
2550 : :
2551 : 10 : call cwtime(cpu, wall, gflops, "start")
2552 : :
2553 [ + + ]: 10 : if (do_qintp) then
2554 : : ! Generate the q-mesh by finding the IBZ and the corresponding weights.
2555 : 5 : qptrlatt = 0; qptrlatt(1,1) = ngqpt(1); qptrlatt(2,2) = ngqpt(2); qptrlatt(3,3) = ngqpt(3)
2556 : :
2557 : : call kpts_ibz_from_kptrlatt(cryst, qptrlatt, my_qptopt, nqshift, qshift, nqibz, qibz, wtq, nqbz, qbz, &
2558 : 5 : new_kptrlatt=new_qptrlatt, new_shiftk=my_qshift)
2559 [ - + ]: 5 : ABI_FREE(qbz)
2560 : :
2561 : : ! Store quantities that cannot be easily (and safely) calculated if we only know the IBZ.
2562 [ + + ]: 20 : a2f_tr%ngqpt = ngqpt; a2f_tr%nqshift = size(my_qshift, dim=2)
2563 [ - + + - : 15 : ABI_MALLOC(a2f_tr%qshift, (3, a2f_tr%nqshift))
+ - + - -
+ - + -
+ ]
2564 [ + - + - : 30 : a2f_tr%qshift = my_qshift
- + - - -
- - - + +
+ + ]
2565 [ - + ]: 5 : ABI_FREE(my_qshift)
2566 : :
2567 : : else
2568 : : ! No interpolation. Use q-mesh parameters from gams%
2569 [ + + ]: 20 : a2f_tr%ngqpt = gams%ngqpt; a2f_tr%nqshift = 1
2570 : 5 : nqibz = gams%nqibz
2571 [ - + + - : 15 : ABI_MALLOC(qibz, (3,nqibz))
+ - + - -
+ - + ]
2572 [ - + + - : 15 : ABI_MALLOC(wtq, (nqibz))
+ - + - -
+ - + ]
2573 [ - + - + ]: 5 : ABI_MALLOC(a2f_tr%qshift, (3, a2f_tr%nqshift))
2574 [ + - + - : 320 : qibz = gams%qibz; wtq = gams%wtq
- + - - -
- - - + +
+ + + - -
+ - - - -
+ + ]
2575 [ + + + + ]: 25 : a2f_tr%qshift = zero ! Note: assuming q-mesh centered on Gamma.
2576 : : end if
2577 : :
2578 : 10 : call cwtime_report(" a2fw_tr_init, q-setup", cpu, wall, gflops)
2579 : :
2580 : : ! Define Min and max frequency for the mesh (enlarge it a bit)
2581 : 10 : omega_min = wminmax(1); omega_max = wminmax(2)
2582 : 10 : omega_min = omega_min - 0.1*abs(omega_min)
2583 [ - + ]: 10 : if (omega_min >= zero) omega_min = one/Ha_meV
2584 : 10 : omega_max = omega_max + 0.1*abs(omega_max)
2585 : :
2586 : 10 : a2f_tr%nsppol = nsppol; a2f_tr%natom3 = gams%natom3; a2f_tr%smear = smear
2587 : 10 : a2f_tr%omega_min = omega_min; a2f_tr%omega_max = omega_max
2588 : 10 : nomega = int((omega_max - omega_min) / wstep); a2f_tr%nomega = nomega; a2f_tr%wstep = wstep
2589 : :
2590 [ - + + - : 30 : ABI_MALLOC(a2f_tr%n0, (nsppol))
+ - + - -
+ - + -
+ ]
2591 [ + - - + : 30 : a2f_tr%n0 = gams%n0
- - - - -
- + + ]
2592 : : ! Build linear mesh.
2593 [ - + + - : 30 : ABI_MALLOC(a2f_tr%omega, (nomega))
+ - + - -
+ - + -
+ ]
2594 [ + - + - : 4750 : a2f_tr%omega = arth(omega_min, wstep, nomega)
- + - - +
+ ]
2595 : :
2596 [ - + + - : 170870 : ABI_CALLOC(a2f_tr%vals_in, (nomega, 3, 3, 0:natom3, nsppol))
+ - - + +
- - + + -
+ - + - -
+ - + - +
+ + + + +
+ + + +
+ ]
2597 [ - + + - : 170850 : ABI_CALLOC(a2f_tr%vals_out, (nomega,3, 3, 0:natom3, nsppol))
- + + - -
+ + - - +
- + - + +
+ + + + +
+ + + + ]
2598 [ - + + - : 170850 : ABI_CALLOC(a2f_tr%vals_tr, (nomega,3, 3, 0:natom3, nsppol))
- + + - -
+ + - - +
- + - + +
+ + + + +
+ + + + ]
2599 [ - + + - : 170850 : ABI_CALLOC(a2f_tr%lambdaw_tr, (nomega, 3, 3, 0:natom3, nsppol))
- + + - -
+ + - - +
- + - + +
+ + + + +
+ + + + ]
2600 [ - + + - : 30 : ABI_MALLOC(tmp_a2f_in, (nomega, 3, 3))
+ - + - -
+ - + ]
2601 [ - + + - : 20 : ABI_MALLOC(tmp_a2f_out, (nomega, 3, 3))
- + - + ]
2602 : :
2603 [ + + ]: 10 : if (ph_intmeth == 2) then
2604 : 8 : call cwtime(cpu, wall, gflops, "start")
2605 : :
2606 : : ! Prepare tetrahedron integration.
2607 : 8 : qptrlatt = 0; qptrlatt(1, 1) = a2f_tr%ngqpt(1); qptrlatt(2, 2) = a2f_tr%ngqpt(2); qptrlatt(3, 3) = a2f_tr%ngqpt(3)
2608 : 8 : tetra_q = tetra_from_kptrlatt(cryst, my_qptopt, qptrlatt, a2f_tr%nqshift, a2f_tr%qshift, nqibz, qibz, comm, msg, ierr)
2609 [ - + ]: 8 : if (ierr/=0) ABI_ERROR(msg)
2610 : :
2611 [ - + + - : 48 : ABI_MALLOC_OR_DIE(lambda_in_tetra, (nqibz, 3, 3, natom3, nsppol), ierr)
+ - - + +
- - + + -
+ - + - +
- - + -
+ ]
2612 [ - + + - : 32 : ABI_MALLOC_OR_DIE(lambda_out_tetra, (nqibz, 3, 3, natom3, nsppol), ierr)
- + + - -
+ + - + -
- + - + ]
2613 [ + + + + : 17419 : lambda_in_tetra = zero
+ + + + +
+ ]
2614 [ + + + + : 17419 : lambda_out_tetra = zero
+ + + + +
+ ]
2615 : :
2616 [ - + + - : 40 : ABI_MALLOC_OR_DIE(phfreq_tetra, (nqibz, natom3, nsppol), ierr)
- + + - -
+ + - + -
+ - + - -
+ - + ]
2617 [ + + + + : 1939 : phfreq_tetra = zero
+ + ]
2618 : :
2619 : 16 : call cwtime_report(" a2fw_tr_init%tetra,", cpu, wall, gflops)
2620 : : end if
2621 : :
2622 : 10 : call cwtime(cpu, wall, gflops, "start")
2623 : :
2624 : : ! Loop over spins and qpoints in the IBZ
2625 : 10 : cnt = 0
2626 [ + + ]: 20 : do spin=1,nsppol
2627 [ + + ]: 806 : do iq_ibz=1,nqibz
2628 [ + - ]: 786 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle
2629 : :
2630 : : ! Interpolate or evaluate lambda transport coefficients.
2631 [ + + ]: 786 : if (do_qintp) then
2632 : 725 : call phgamma_vv_interp(gams,cryst,ifc,spin,qibz(:,iq_ibz),phfrq,gamma_in_ph,gamma_out_ph,lambda_in_ph,lambda_out_ph)
2633 : : else
2634 : 61 : call phgamma_vv_eval_qibz(gams,cryst,ifc,iq_ibz,spin,phfrq,gamma_in_ph,gamma_out_ph,lambda_in_ph,lambda_out_ph)
2635 : : end if
2636 : :
2637 : 10 : select case (ph_intmeth)
2638 : : case (1)
2639 : : ! Gaussian: Add all contributions from the phonon modes at this qpoint to a2f_tr
2640 : : ! (note that unstable modes are included).
2641 [ + + ]: 612 : do mu=1,natom3
2642 [ + + + + : 1959930 : tmp_a2f_in = zero
+ + ]
2643 [ + + + + : 1959930 : tmp_a2f_out = zero
+ + ]
2644 [ + + ]: 217566 : do iw=1,nomega
2645 : 217107 : xx = a2f_tr%omega(iw) - phfrq(mu)
2646 [ + + + + ]: 2822391 : tmp_a2f_in(iw,:,:) = tmp_a2f_in(iw,:,:) + gaussian(xx, smear) * lambda_in_ph(:,:,mu) * abs(phfrq(mu))
2647 [ + + + + ]: 2822850 : tmp_a2f_out(iw,:,:) = tmp_a2f_out(iw,:,:) + gaussian(xx, smear) * lambda_out_ph(:,:,mu) * abs(phfrq(mu))
2648 : : end do
2649 [ + + + + : 1959930 : a2f_tr%vals_in(:,:,:,mu,spin) = a2f_tr%vals_in(:,:,:,mu,spin) + tmp_a2f_in(:,:,:) * wtq(iq_ibz)
+ + ]
2650 [ + + + + : 1960083 : a2f_tr%vals_out(:,:,:,mu,spin) = a2f_tr%vals_out(:,:,:,mu,spin) + tmp_a2f_out(:,:,:) * wtq(iq_ibz)
+ + ]
2651 : : end do
2652 : :
2653 : : case (2)
2654 : : ! Tetra: store data.
2655 [ + + - + : 2685 : do mu=1,natom3
+ ]
2656 [ + + + + ]: 24687 : lambda_in_tetra(iq_ibz, :,:, mu, spin) = lambda_in_ph(:,:,mu) * abs(phfrq(mu))
2657 [ + + + + ]: 24687 : lambda_out_tetra(iq_ibz, :,:, mu, spin) = lambda_out_ph(:,:,mu) * abs(phfrq(mu))
2658 : 2532 : phfreq_tetra(iq_ibz, mu, spin) = phfrq(mu)
2659 : : end do
2660 : : end select
2661 : :
2662 : : end do ! iq_ibz
2663 : : end do ! spin
2664 : :
2665 [ + + ]: 10 : if (ph_intmeth == 2) then
2666 : : ! Collect results on each node.
2667 : 8 : call xmpi_sum(lambda_in_tetra, comm, ierr)
2668 : 8 : call xmpi_sum(lambda_out_tetra, comm, ierr)
2669 : 8 : call xmpi_sum(phfreq_tetra, comm, ierr)
2670 : :
2671 : : ! workspace for tetra.
2672 [ - + + - : 24 : ABI_MALLOC(wdt, (nomega, 2))
+ - + - -
+ - + ]
2673 : :
2674 : : ! TODO: with the tetra_get_onewk call we can integrate this above
2675 : : ! and avoid allocating all of lambda_in_tetra and phfreq_tetra!!!
2676 : : ! For each mode get its contribution
2677 : 8 : cnt = 0
2678 [ + + ]: 16 : do spin=1,nsppol
2679 [ + + ]: 40 : do mu=1,natom3
2680 [ + + ]: 1931 : do iq_ibz=1,nqibz
2681 [ + - ]: 1899 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! mpi-parallelism
2682 : :
2683 : 1899 : call tetra_q%get_onewk(iq_ibz, gams%bcorr, nomega, nqibz, phfreq_tetra(:,mu,spin), omega_min, omega_max, one, wdt)
2684 [ + + + + ]: 1802151 : wdt = wdt * wtq(iq_ibz)
2685 : :
2686 : : ! Accumulate (Integral of a2F_tr is computed afterwards)
2687 [ + + ]: 7620 : do idir=1,3
2688 [ + + ]: 24687 : do jdir=1,3
2689 : : a2f_tr%vals_in(:,idir,jdir,mu,spin) = a2f_tr%vals_in(:,idir,jdir,mu,spin) &
2690 [ + + ]: 8101134 : + wdt(:,1) * lambda_in_tetra(iq_ibz,idir,jdir,mu,spin)
2691 : : a2f_tr%vals_out(:,idir,jdir,mu,spin) = a2f_tr%vals_out(:,idir,jdir,mu,spin) &
2692 [ + + ]: 8106831 : + wdt(:,1) * lambda_out_tetra(iq_ibz,idir,jdir,mu,spin)
2693 : : !a2f_tr%lambdaw(:,mu,spin) = a2f_tr%lambdaw(:,mu,spin) + wdt(:,2) * lambda_XX_tetra(iq_ibz, mu, spin)
2694 : : end do
2695 : : end do
2696 : : end do
2697 : : end do
2698 : : end do
2699 : :
2700 [ - + ]: 8 : ABI_FREE(wdt)
2701 [ - + ]: 8 : ABI_FREE(lambda_in_tetra)
2702 [ - + ]: 8 : ABI_FREE(lambda_out_tetra)
2703 [ - + ]: 8 : ABI_FREE(phfreq_tetra)
2704 : 16 : call tetra_q%free()
2705 : : end if
2706 : :
2707 : : ! Collect final results on each node
2708 : 10 : call xmpi_sum(a2f_tr%vals_in, comm, ierr)
2709 : 10 : call xmpi_sum(a2f_tr%vals_out, comm, ierr)
2710 : :
2711 : : ! TODO: divide by g(eF, spin)
2712 : : ! check normalization with N(0) and <v^2> from Savrasov eq 20
2713 [ + + ]: 20 : do spin=1,nsppol
2714 [ + + + + : 170410 : a2f_tr%vals_in(:,:,:,0,spin) = sum(a2f_tr%vals_in(:,:,:,1:natom3,spin), dim=4)
+ + + + ]
2715 [ + + + + : 170420 : a2f_tr%vals_out(:,:,:,0,spin) = sum(a2f_tr%vals_out(:,:,:,1:natom3,spin), dim=4)
+ + + + ]
2716 : : !a2f_tr%vals(:,:,spin) = a2f_tr%vals(:,:,spin) / (two_pi * a2f_tr%n0(spin))
2717 : : end do
2718 : :
2719 [ + - + - : 170830 : a2f_tr%vals_tr = a2f_tr%vals_out - a2f_tr%vals_in
+ - + - +
- - + - -
+ + + + +
+ + + +
+ ]
2720 : :
2721 : 10 : call cwtime_report(" a2fw_tr_init, a2f_eval", cpu, wall, gflops)
2722 : :
2723 : : ! NOTE: for the moment calculate the log moms etc on just the trace of the a2f functions
2724 [ - + + - : 20 : ABI_MALLOC(a2f_tr_1mom, (nomega))
- + - + ]
2725 [ - + + - : 20 : ABI_MALLOC(a2f_tr_logmom, (nomega))
- + - + ]
2726 [ - + + - : 20 : ABI_MALLOC(a2f_tr_logmom_int, (nomega))
- + - + ]
2727 : :
2728 : : !call a2fw_tr_print_info()
2729 : :
2730 : : ! Compute lambda_tr(w) (resolved in spin mode and directions)
2731 [ + + ]: 20 : do spin=1,nsppol
2732 [ + + ]: 60 : do mu=0,natom3
2733 [ + + ]: 170 : do idir=1,3
2734 [ + + ]: 520 : do jdir=1,3
2735 : :
2736 [ + + ]: 170640 : do iw=1,nomega
2737 : 170280 : ww = a2f_tr%omega(iw)
2738 [ + - ]: 170640 : if (abs(ww) > EPHTK_WTOL) then
2739 : 170280 : a2f_tr_1mom(iw) = a2f_tr%vals_tr(iw,idir,jdir,mu,spin) / abs(ww)
2740 : : else
2741 : 0 : a2f_tr_1mom(iw) = zero
2742 : : end if
2743 : : ! TODO: Strange that the first value of int(f) is not set to zero!
2744 : : ! FIXME: The frequency integration overestimates lambda if there are negative phonon frequencies!
2745 : : end do
2746 : :
2747 : 480 : call simpson_int(nomega, wstep, a2f_tr_1mom, a2f_tr%lambdaw_tr(:,idir,jdir,mu,spin))
2748 : : end do ! jdir
2749 : : end do ! idir
2750 : : end do ! mu
2751 : : end do ! spin
2752 : :
2753 [ + - ]: 10 : if (my_rank == master) then
2754 : 10 : ount = std_out
2755 [ - + ]: 10 : if (nsppol > 1) then
2756 : 0 : write(msg,'(3a)') ch10,'Comment: some of the following quantities should be integrated over spin', ch10
2757 : 0 : call wrtout(ount, msg)
2758 : : end if
2759 : : end if
2760 : :
2761 [ + + ]: 20 : do spin=1,nsppol
2762 : 10 : lambda_iso = a2fw_tr_moment(a2f_tr, 0, spin)
2763 : :
2764 [ + + ]: 40 : do idir=1,3
2765 [ + + ]: 130 : do jdir=1,3
2766 : 90 : a2f_tr_1d => a2f_tr%vals_tr(:,idir,jdir,0,spin)
2767 : :
2768 : : ! Get log moment of alpha^2F.
2769 [ + + ]: 42660 : a2f_tr_logmom = zero
2770 [ + + ]: 42660 : do iw=1,nomega
2771 : 42570 : omega = a2f_tr%omega(iw)
2772 [ + - + - ]: 42660 : if (abs(omega) > EPHTK_WTOL .and. abs(lambda_iso(idir,jdir)) > EPHTK_WTOL) then
2773 : 42570 : a2f_tr_logmom(iw) = (two/lambda_iso(idir,jdir)) * a2f_tr_1d(iw)*log(abs(omega))/abs(omega)
2774 : : end if
2775 : : end do
2776 : 90 : call simpson_int(nomega, wstep, a2f_tr_logmom, a2f_tr_logmom_int)
2777 : : !write(std_out,*)' iw,nomega,greatest_real,a2f_tr_logmom_int(nomega)=',& iw,nomega,greatest_real,a2f_tr_logmom_int(nomega)
2778 [ + - ]: 120 : if(abs(a2f_tr_logmom_int(nomega)) < log(greatest_real*tol6)) then
2779 : 90 : omega_log(idir,jdir) = exp(a2f_tr_logmom_int(nomega))
2780 : : else
2781 : 0 : omega_log(idir,jdir)=greatest_real*tol6
2782 : : endif
2783 : : end do
2784 : : end do
2785 : :
2786 : : ! TODO: make output only for irred values xx yy zz and top half of matrix
2787 [ + - ]: 20 : if (my_rank == master) then
2788 [ + + ]: 10 : if (do_qintp) then
2789 : 5 : write(ount,'(a)')' Evaluation of parameters analogous to electron-phonon coupling for 3x3 directions (interpolated) '
2790 : : else
2791 : 5 : write(ount,'(a)')' Evaluation of parameters analogous to electron-phonon coupling for 3x3 directions (coarse grid) '
2792 : : endif
2793 : 10 : write(ount,'(a,3(3es10.3,2x))') ' lambda = ',lambda_iso
2794 : 10 : write(ount,'(a,3(3es10.3,2x),a)' )' omegalog = ',omega_log,' (Ha) '
2795 [ + + + + ]: 130 : write(ount,'(a,3(3es10.3,2x),a)' )' ',omega_log*Ha_K, ' (Kelvin) '
2796 : 10 : write(ount,"(a)")' positive moments of alpha2Ftr:'
2797 [ + + + + ]: 130 : write(ount,'(a,9(es10.3,2x))' )' lambda <omega^2> = ',a2fw_tr_moment(a2f_tr, 2, spin)
2798 [ + + + + ]: 130 : write(ount,'(a,9(es10.3,2x))' )' lambda <omega^3> = ',a2fw_tr_moment(a2f_tr, 3, spin)
2799 [ + + + + ]: 130 : write(ount,'(a,9(es10.3,2x))' )' lambda <omega^4> = ',a2fw_tr_moment(a2f_tr, 4, spin)
2800 [ + + + + ]: 130 : write(ount,'(a,9(es10.3,2x))' )' lambda <omega^5> = ',a2fw_tr_moment(a2f_tr, 5, spin)
2801 : : end if
2802 : : end do
2803 : :
2804 [ - + ]: 10 : ABI_FREE(tmp_a2f_in)
2805 [ - + ]: 10 : ABI_FREE(tmp_a2f_out)
2806 [ - + ]: 10 : ABI_FREE(a2f_tr_1mom)
2807 [ - + ]: 10 : ABI_FREE(a2f_tr_logmom)
2808 [ - + ]: 10 : ABI_FREE(a2f_tr_logmom_int)
2809 [ - + ]: 10 : ABI_FREE(qibz)
2810 [ - + ]: 10 : ABI_FREE(wtq)
2811 : :
2812 [ + - - + : 70 : end subroutine a2fw_tr_init
- + - + -
+ - - - -
- + - - -
- - + - +
- + - + -
+ ]
2813 : : !!***
2814 : :
2815 : : !----------------------------------------------------------------------
2816 : :
2817 : : !!****f* m_phgamma/a2fw_tr_write
2818 : : !! NAME
2819 : : !! a2fw_tr_write
2820 : : !!
2821 : : !! FUNCTION
2822 : : !! Write alpha^2F_tr(w) to an external file in text form
2823 : : !!
2824 : : !! INPUTS
2825 : : !! basename=Filename for output.
2826 : : !! post=String appended to netcdf variables e.g. _qcoarse, _qintp
2827 : : !! ncid=Netcdf file handler. Set it to nctk_noid to disable output.
2828 : : !!
2829 : : !! OUTPUT
2830 : : !! Output is written to file. This routine should be called by one MPI proc.
2831 : : !!
2832 : : !! SOURCE
2833 : :
2834 : 10 : subroutine a2fw_tr_write(a2f_tr, basename, post, ncid)
2835 : :
2836 : : !Arguments ------------------------------------
2837 : : !scalars
2838 : : class(a2fw_tr_t),intent(in) :: a2f_tr
2839 : : integer,intent(in) :: ncid
2840 : : character(len=*),intent(in) :: basename, post
2841 : :
2842 : : !Local variables -------------------------
2843 : : !scalars
2844 : : integer :: iw,spin,unt,ii,mu,idir, jdir, ncerr
2845 : : character(len=500) :: dim1_name, msg
2846 : : character(len=fnlen) :: path
2847 : : ! *********************************************************************
2848 : :
2849 : : ! Write spin-resolved a2F_tr(w)
2850 [ + - ]: 10 : path = strcat(basename, "_A2FW_tr")
2851 [ - + ]: 10 : if (open_file(path, msg, newunit=unt, form="formatted", action="write", status="unknown") /= 0) then
2852 : 0 : ABI_ERROR(msg)
2853 : : end if
2854 : :
2855 : 10 : call write_a2fw_tr_header()
2856 : :
2857 : : ! Reminder: vals_tr(nomega,3,3,0:natom3,nsppol)
2858 : :
2859 [ + - ]: 10 : if (a2f_tr%nsppol == 1) then
2860 : 10 : write(unt,'(a)')"# Frequency, a2F_tr(w,i,j)"
2861 [ + + ]: 4740 : do iw=1,a2f_tr%nomega
2862 : 4740 : write(unt,'(e16.6, 2x, 3(3e16.6,1x))') a2f_tr%omega(iw), a2f_tr%vals_tr(iw,:,:,0,1)
2863 : : end do
2864 : 10 : write(unt,'(3a)')ch10, ch10, "# Frequency, lambda(w,i,j)"
2865 [ + + ]: 4740 : do iw=1,a2f_tr%nomega
2866 : 4740 : write(unt,'(e16.6, 2x, 3(3e16.6,1x))') a2f_tr%omega(iw), a2f_tr%lambdaw_tr(iw,:,:,0,1)
2867 : : end do
2868 : :
2869 : : else
2870 : 0 : write(unt,'(a)')"# Frequency, a2F_tr_tot(w,i,j), a2F_tr_spin1(w,i,j) ..."
2871 [ # # ]: 0 : do iw=1,a2f_tr%nomega
2872 : 0 : write(unt,'(e16.6, 2x, 3(3e16.6,1x), 2x, 3(3e16.6,1x), 2x, 3(3e16.6,1x))') a2f_tr%omega(iw), &
2873 [ # # # # : 0 : ((sum(a2f_tr%vals_tr(iw,idir,jdir,0,:)), idir=1,3), jdir=1,3) , &
# # ]
2874 : 0 : a2f_tr%vals_tr(iw,:,:,0,1), & ! UP
2875 [ # # # # ]: 0 : a2f_tr%vals_tr(iw,:,:,0,2) ! DOWN
2876 : : end do
2877 : 0 : write(unt,'(3a)') ch10, ch10, "# Frequency, lambda_tr_tot(w,i,j)dw, lambda_tr_spin1(w,i,j) ..."
2878 [ # # ]: 0 : do iw=1,a2f_tr%nomega
2879 : 0 : write(unt,'(e16.6, 2x, 3(3e16.6,1x), 2x, 3(3e16.6,1x), 2x, 3(3e16.6,1x), 2x, 3(3e16.6,1x))') a2f_tr%omega(iw), &
2880 [ # # # # : 0 : ((sum(a2f_tr%lambdaw_tr(iw,idir,jdir,0,:)), idir=1,3), jdir=1,3) , & ! TOT
# # ]
2881 : 0 : a2f_tr%lambdaw_tr(iw,:,:,0,1), & ! UP
2882 [ # # # # ]: 0 : a2f_tr%lambdaw_tr(iw,:,:,0,2) ! DOWN
2883 : : end do
2884 : : end if
2885 : :
2886 : 10 : close(unt)
2887 : :
2888 : : ! Write phonon mode contributions to a2F_tr(w,i,j)
2889 [ + - ]: 10 : path = strcat(basename, "_PH_A2FW_tr")
2890 [ - + ]: 10 : if (open_file(path, msg, newunit=unt, form="formatted", action="write", status="unknown") /= 0) then
2891 : 0 : ABI_ERROR(msg)
2892 : : end if
2893 : 10 : call write_a2fw_tr_header()
2894 : :
2895 : : ! Reminder: vals_tr(nomega,3,3,0:natom3,nsppol)
2896 [ + - ]: 10 : if (a2f_tr%nsppol == 1) then
2897 [ + + ]: 50 : do mu=0,a2f_tr%natom3
2898 : 40 : write(unt,'(a,i0)')"# Phonon mode ",mu
2899 : 40 : write(unt,'(a)')"# Frequency, a2F_tr(w)"
2900 [ + + ]: 18960 : do iw=1,a2f_tr%nomega
2901 : 18960 : write(unt,'(e16.6,2x,3(3e16.6,1x))') a2f_tr%omega(iw), a2f_tr%vals_tr(iw,:,:,mu,1)
2902 : : end do
2903 [ + + ]: 120 : do ii=1,2; write(unt,'(a)')""; end do
2904 : 40 : write(unt,'(a)')"# Frequency, lambda_tr(w)"
2905 [ + + ]: 18960 : do iw=1,a2f_tr%nomega
2906 : 18960 : write(unt,'(e16.6,2x,3(3e16.6,1x))') a2f_tr%omega(iw), a2f_tr%lambdaw_tr(iw,:,:,mu,1)
2907 : : end do
2908 [ + + ]: 130 : do ii=1,2; write(unt,'(a)')""; end do
2909 : : end do
2910 : :
2911 : : else
2912 [ # # ]: 0 : do mu=0,a2f_tr%natom3
2913 : 0 : write(unt,'(a,i0)')"# Phonon mode ",mu
2914 : 0 : write(unt,'(a)')"# Frequency, a2F_tot(w), a2F_spin1(w) ..."
2915 [ # # ]: 0 : do iw=1,a2f_tr%nomega
2916 : 0 : write(unt,*) a2f_tr%omega(iw), &
2917 [ # # # # : 0 : sum(a2f_tr%vals_tr(iw,:,:,mu,:)), & ! TOT
# # ]
2918 : 0 : a2f_tr%vals_tr(iw,:,:,mu,1) , & ! UP
2919 : 0 : a2f_tr%vals_tr(iw,:,:,mu,2) ! DOWN
2920 : : end do
2921 : 0 : write(unt,'(3a)')ch10,ch10,"# Frequency, lambda_tot(w)dw, lambda_spin1(w) ..."
2922 [ # # ]: 0 : do iw=1,a2f_tr%nomega
2923 : 0 : write(unt,*) a2f_tr%omega(iw), &
2924 [ # # # # : 0 : sum(a2f_tr%lambdaw_tr(iw,:,:,mu,:)), & ! TOT
# # ]
2925 : 0 : a2f_tr%lambdaw_tr(iw,:,:,mu,1), & ! UP
2926 : 0 : a2f_tr%lambdaw_tr(iw,:,:,mu,2) ! DOWN
2927 : : end do
2928 : : end do
2929 : : end if
2930 : :
2931 : 10 : close(unt)
2932 : :
2933 [ + - ]: 10 : if (ncid /= nctk_noid) then
2934 : : ! Define dimensions.
2935 [ + - ]: 10 : dim1_name = strcat("a2ftr_nomega", post)
2936 : : ncerr = nctk_def_dims(ncid, [ &
2937 : : nctkdim_t(dim1_name, a2f_tr%nomega), &
2938 : : nctkdim_t("natom3p1", a2f_tr%natom3 + 1), nctkdim_t("number_of_spins", a2f_tr%nsppol) &
2939 [ + + ]: 40 : ], defmode=.True.)
2940 [ - + ]: 10 : NCF_CHECK(ncerr)
2941 : :
2942 : : ncerr = nctk_def_arrays(ncid, [ &
2943 : : nctkarr_t(strcat('a2ftr_mesh', post), "dp", dim1_name), &
2944 : : nctkarr_t(strcat('a2ftr_values', post), "dp", strcat(dim1_name, ", three, three, natom3p1, number_of_spins")), &
2945 : : nctkarr_t(strcat('a2ftr_lambdaw', post), "dp", strcat(dim1_name, ", three, three, natom3p1, number_of_spins")) &
2946 [ + - + - : 40 : ])
+ - + - +
- + + ]
2947 [ - + ]: 10 : NCF_CHECK(ncerr)
2948 : :
2949 [ - + ]: 10 : NCF_CHECK(nctk_set_datamode(ncid))
2950 [ - + ]: 10 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, strcat("a2ftr_mesh", post)), a2f_tr%omega))
2951 [ - + ]: 10 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, strcat("a2ftr_values", post)), a2f_tr%vals_tr))
2952 [ - + ]: 10 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, strcat("a2ftr_lambdaw", post)), a2f_tr%lambdaw_tr))
2953 : : end if
2954 : :
2955 : : contains
2956 : :
2957 : 20 : subroutine write_a2fw_tr_header()
2958 : :
2959 : : ! Output the header.
2960 : 20 : write(unt,'(a)') '#'
2961 : 20 : write(unt,'(a)') '# ABINIT package: a2F_tr(w) file'
2962 : 20 : write(unt,'(a)') '#'
2963 : 20 : write(unt,'(a)') '# a2F_tr(w) function integrated over the FS. omega in a.u.'
2964 [ + - ]: 20 : write(unt,'(2a)') '# ngqpt: ',trim(ltoa(a2f_tr%ngqpt))
2965 : 20 : write(unt,'(a,i0,3(a,e16.6))')'# number of frequencies: ',a2f_tr%nomega," between omega_min: ",a2f_tr%omega_min,&
2966 : 40 : ' Ha and omega_max: ',a2f_tr%omega_max,' Ha with step:',a2f_tr%wstep
2967 : 20 : write(unt,'(a,e16.6)') '# the smearing width for gaussians is ',a2f_tr%smear
2968 [ - + ]: 20 : if (a2f_tr%nsppol == 2) then
2969 [ # # ]: 0 : write(unt,'(a,e16.6)')"# Total DOS at Fermi level ",sum(a2f_tr%n0)
2970 : : end if
2971 [ + + ]: 40 : do spin=1,a2f_tr%nsppol
2972 : 40 : write(unt,"(a,i0,a,e16.6)")"# The DOS at Fermi level for spin ",spin," is ",a2f_tr%n0(spin)
2973 : : end do
2974 [ + + ]: 60 : do ii=1,2; write(unt,'(a)') "# "; end do
2975 : :
2976 : 20 : end subroutine write_a2fw_tr_header
2977 : :
2978 : : end subroutine a2fw_tr_write
2979 : : !!***
2980 : :
2981 : : !----------------------------------------------------------------------
2982 : :
2983 : : !!****f* m_phgamma/eph_phgamma
2984 : : !! NAME
2985 : : !! eph_phgamma
2986 : : !!
2987 : : !! FUNCTION
2988 : : !! Compute phonon linewidths in metals.
2989 : : !!
2990 : : !! INPUTS
2991 : : !! wk0_path=String with the path to the GS unperturbed WFK file.
2992 : : !! ngfft(18),ngfftf(18)=Coarse and Fine FFT meshes.
2993 : : !! dtset<dataset_type>=All input variables for this dataset.
2994 : : !! ebands<ebands_t>=The GS KS band structure (energies, occupancies, k-weights...)
2995 : : !! dvdb<dbdb_type>=Database with the DFPT SCF potentials.
2996 : : !! ifc<ifc_type>=interatomic force constants and corresponding real space grid info.
2997 : : !! pawfgr <type(pawfgr_type)>=fine grid parameters and related data
2998 : : !! pawang<pawang_type)>=PAW angular mesh and related data.
2999 : : !! pawrad(ntypat*usepaw)<pawrad_type>=Paw radial mesh and related data.
3000 : : !! pawtab(ntypat*usepaw)<pawtab_type>=Paw tabulated starting data.
3001 : : !! psps<pseudopotential_type>=Variables related to pseudopotentials.
3002 : : !! comm=MPI communicator.
3003 : : !!
3004 : : !! OUTPUT
3005 : : !!
3006 : : !! SOURCE
3007 : :
3008 : 5 : subroutine eph_phgamma(wfk0_path, dtfil, ngfft, ngfftf, dtset, cryst, ebands, dvdb, ifc, &
3009 : 5 : pawfgr, pawang, pawrad, pawtab, psps, mpi_enreg, comm)
3010 : :
3011 : : !Arguments ------------------------------------
3012 : : !scalars
3013 : : character(len=*),intent(in) :: wfk0_path
3014 : : integer,intent(in) :: comm
3015 : : type(datafiles_type),intent(in) :: dtfil
3016 : : type(dataset_type),intent(in) :: dtset
3017 : : type(crystal_t),intent(in) :: cryst
3018 : : type(ebands_t),intent(in) :: ebands
3019 : : type(dvdb_t),intent(inout) :: dvdb
3020 : : type(pawang_type),intent(in) :: pawang
3021 : : type(pseudopotential_type),intent(in) :: psps
3022 : : type(pawfgr_type),intent(in) :: pawfgr
3023 : : type(ifc_type),intent(in) :: ifc
3024 : : type(mpi_type),intent(in) :: mpi_enreg
3025 : : !arrays
3026 : : integer,intent(in) :: ngfft(18),ngfftf(18)
3027 : : type(pawrad_type),intent(in) :: pawrad(psps%ntypat*psps%usepaw)
3028 : : type(pawtab_type),intent(in) :: pawtab(psps%ntypat*psps%usepaw)
3029 : :
3030 : : !Local variables ------------------------------
3031 : : !scalars
3032 : : integer,parameter :: tim_getgh1c = 1, berryopt0 = 0, qptopt1 = 1, master = 0, ndat1 = 1, eph_scalprod0 = 0
3033 : : integer :: my_rank,nproc,mband,nsppol,nkibz,idir,ipert,iq_ibz
3034 : : integer :: cplex,db_iqpt,natom,natom3,ipc,ipc1,ipc2,nspinor,onpw
3035 : : integer :: bstart_k,bstart_kq,nb_k,nb_kq,band_k, band_kq, in_k, im_kq
3036 : : integer :: ik_ibz,ik_bz,ikq_bz,ikq_ibz,isym_k,isym_kq,trev_k,trev_kq !,timrev_q
3037 : : integer :: ik_fs, my_ik, my_is, spin, istwf_k, istwf_kq, npw_k, npw_kq
3038 : : integer :: ii,jj,ipw,mpw,my_mpw,mnb,ierr,cnt,ncid
3039 : : integer :: n1, n2, n3, n4, n5, n6, nspden, ltetra
3040 : : integer :: sij_opt, usecprj, usevnl, optlocal, optnl, opt_gvnlx1
3041 : : integer :: nfft,nfftf,mgfft,mgfftf,nkpg
3042 : : integer :: jene, iene, comm_rpt, nesting, my_npert, my_ip, my_iq, ncerr, edos_intmeth
3043 : : real(dp) :: cpu, wall, gflops, cpu_q, wall_q, gflops_q, cpu_k, wall_k, gflops_k, cpu_all, wall_all, gflops_all
3044 : : real(dp) :: edos_step, edos_broad, sigma, ecut, eig0nk ! eshift,
3045 : : logical :: gen_eigenpb, need_velocities, isirr_k, isirr_kq, print_time_k, need_ftinterp
3046 : 5 : type(wfd_t) :: wfd
3047 : : type(fstab_t),pointer :: fs
3048 : 5 : type(gs_hamiltonian_type) :: gs_hamkq
3049 : 5 : type(rf_hamiltonian_type) :: rf_hamkq
3050 : 5 : type(edos_t) :: edos
3051 : 5 : type(phgamma_t) :: gams
3052 : 5 : type(a2fw_t) :: a2fw
3053 : 5 : type(a2fw_tr_t) :: a2fw_tr
3054 [ + + - + : 50 : type(ddkop_t) :: ddkop
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ + + - +
- + + + -
+ - + - +
- + - + -
+ - + -
+ ]
3055 : : type(xcomm_t) :: pert_comm, qs_comm, qpt_comm, bsum_comm, kpt_comm, spin_comm, pkb_comm !, ncwrite_comm
3056 : 5 : type(krank_t) :: krank
3057 : 5 : type(htetra_t) :: tetra
3058 : : !type(lgroup_t) :: lg_q
3059 : : character(len=500) :: msg
3060 : : character(len=fnlen) :: path
3061 : : !arrays
3062 : : integer :: g0_k(3),g0bz_kq(3),g0_kq(3),units(2)
3063 : : integer :: indkk_kq(6,1), work_ngfft(18),gmax(3),my_gmax(3),gamma_ngqpt(3) !g0ibz_kq(3),
3064 : 5 : integer,allocatable :: kg_k(:,:),kg_kq(:,:),gtmp(:,:),nband(:,:),wfd_istwfk(:), my_pinfo(:,:), pert_table(:,:) !, qibz_done(:)
3065 : 10 : real(dp) :: kk(3),kq(3),kk_ibz(3),kq_ibz(3),qpt(3), lf(2),rg(2),res(2), vk(3), vkq(3), wminmax(2), n0(ebands%nsppol)
3066 : 10 : real(dp) :: resvv_in(2,9), resvv_out(2,9), phfrq(3*cryst%natom), abc(3)
3067 : 5 : real(dp),allocatable :: kinpw_k(:), kinpw_kq(:), displ_cart(:,:,:,:), displ_red(:,:,:,:)
3068 : 5 : real(dp),allocatable :: grad_berry(:,:), kpg_kq(:,:), kpg_k(:,:)
3069 : 5 : real(dp),allocatable :: ffnl_k(:,:,:,:), ffnl_kq(:,:,:,:), ph3d_k(:,:,:), ph3d_kq(:,:,:)
3070 : 5 : real(dp),allocatable :: v1scf(:,:,:,:), tgam(:,:,:), gkq_atm(:,:,:,:), gkq_atm_ipc(:,:,:), lambda(:)
3071 : 10 : real(dp),allocatable :: bras_kq(:,:,:), kets_k(:,:,:), h1_kets_kq(:,:,:), cg_work(:,:)
3072 : 5 : real(dp),allocatable :: ph1d(:,:), vlocal(:,:,:,:), vlocal1(:,:,:,:,:)
3073 : 5 : real(dp),allocatable :: dummy_vtrial(:,:), gvnlx1(:,:,:), work(:,:,:,:)
3074 : 5 : real(dp),allocatable :: gs1c_kq(:,:), v1_work(:,:,:,:), vcart_ibz(:,:,:,:)
3075 : 10 : real(dp),allocatable :: wt_ek(:,:), wt_ekq(:,:), dbldelta_wts(:,:)
3076 : 5 : real(dp),allocatable :: tgamvv_in(:,:,:,:), vv_kk(:,:,:), tgamvv_out(:,:,:,:), vv_kkq(:,:,:), tmp_vals_ee(:,:,:,:,:), emesh(:)
3077 : 10 : logical,allocatable :: bks_mask(:,:,:),keep_ur(:,:,:)
3078 : 5 : type(fstab_t),target,allocatable :: fstab(:)
3079 : 5 : type(pawcprj_type),allocatable :: cwaveprj0(:,:)
3080 : : #ifdef HAVE_MPI
3081 : : integer :: ndims, comm_cart, me_cart, coords(5)
3082 : : logical :: reorder
3083 : 5 : integer,allocatable :: dims(:)
3084 : 5 : logical,allocatable :: periods(:), keepdim(:)
3085 : : #endif
3086 : : !************************************************************************
3087 : :
3088 : 5 : if (psps%usepaw == 1) then
3089 : 0 : ABI_ERROR("PAW not implemented")
3090 : : ABI_UNUSED((/pawang%nsym, pawrad(1)%mesh_size/))
3091 : : end if
3092 : :
3093 : 5 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
3094 [ + + ]: 15 : units = [std_out, ab_out]
3095 : 5 : call wrtout(std_out, " Computing ph linewidths in metals.")
3096 : 5 : call cwtime(cpu_all, wall_all, gflops_all, "start")
3097 : 5 : call pstat_proc%print(_PSTAT_ARGS_)
3098 : :
3099 : : ! Copy important dimensions
3100 : 5 : natom = cryst%natom; natom3 = 3 * natom; nsppol = ebands%nsppol; nspinor = ebands%nspinor; nspden = dtset%nspden
3101 : 5 : nkibz = ebands%nkpt; mband = ebands%mband
3102 : :
3103 : : ! FFT meshes
3104 [ + + ]: 20 : nfftf = product(ngfftf(1:3)); mgfftf = maxval(ngfftf(1:3))
3105 [ + + + + ]: 35 : nfft = product(ngfft(1:3)) ; mgfft = maxval(ngfft(1:3))
3106 : 5 : n1 = ngfft(1); n2 = ngfft(2); n3 = ngfft(3)
3107 : 5 : n4 = ngfft(4); n5 = ngfft(5); n6 = ngfft(6)
3108 : :
3109 : : ! Compute electron DOS.
3110 : : !call dtset%get_edos_params(edos_intmeth, edos_step, edos_broad)
3111 [ - + ]: 5 : edos_intmeth = 2; if (dtset%prtdos /= 0) edos_intmeth = dtset%prtdos
3112 : : edos_step = dtset%dosdeltae; edos_broad = dtset%tsmear
3113 : 5 : edos_step = 0.01 * eV_Ha; edos_broad = 0.3 * eV_Ha
3114 [ - + - + : 5 : edos = ebands%get_edos(cryst, edos_intmeth, edos_step, edos_broad, comm)
- + - + -
+ ]
3115 : :
3116 : : ! Store DOS per spin channel.
3117 [ + + ]: 10 : n0(:) = edos%gef(1:edos%nsppol)
3118 [ + - ]: 5 : if (my_rank == master) then
3119 : 5 : call edos%print(units)
3120 : 5 : call edos%write(strcat(dtfil%filnam_ds(4), "_EDOS"))
3121 : : end if
3122 : :
3123 : : ! Find Fermi surface k-points
3124 : : ! TODO: support kptopt, change setup of k-points if tetra: fist tetra weights then k-points on the Fermi surface!
3125 [ - + + - : 20 : ABI_MALLOC(fstab, (nsppol))
+ - + - -
+ - + + +
+ - - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
3126 : 5 : call fstab_init(fstab, ebands, cryst, dtset, tetra, comm)
3127 : 5 : call tetra%free()
3128 : :
3129 : : ! Define q-mesh. eph_ngqpt_fine activates the Fourier interpolation of the DFPT potentials.
3130 [ + + + + : 16 : gamma_ngqpt = get_diag(ifc%qptrlatt); if (all(dtset%eph_ngqpt_fine /= 0)) gamma_ngqpt = dtset%eph_ngqpt_fine
+ + + + ]
3131 : :
3132 : 5 : call phgamma_init(gams, cryst, ifc, ebands, fstab(1), dtset, eph_scalprod0, gamma_ngqpt, n0, comm)
3133 : :
3134 : 5 : call wrtout(std_out, sjoin(" q-mesh for phonon linewidths:", ltoa(gamma_ngqpt)))
3135 : 5 : call wrtout(std_out, sjoin(" Will compute:", itoa(gams%nqibz), "q-points in the IBZ"))
3136 : 5 : call pstat_proc%print(_PSTAT_ARGS_)
3137 : :
3138 : : ! Select option for double delta with tetra.
3139 : : ! 2 for the optimized tetrahedron method.
3140 : : ! -2 for the linear tetrahedron method.
3141 : 5 : ltetra = 0
3142 [ + + ]: 5 : if (dtset%eph_intmeth == 2) ltetra = 2
3143 [ - + ]: 5 : if (dtset%eph_intmeth == -2) ltetra = 1
3144 : :
3145 : : ! Compute optimal energy window for tetra.
3146 : : !call find_ewin(gams%nqibz, gams%qibz, cryst, ebands, ltetra, sigma, comm)
3147 : :
3148 : : ! ========================
3149 : : ! === MPI DISTRIBUTION ===
3150 : : ! ========================
3151 : : ! Init for sequential execution.
3152 : 5 : my_npert = natom3
3153 : :
3154 [ + + + - : 30 : if (any(dtset%eph_np_pqbks /= 0)) then
- + ]
3155 : : ! Use parameters from input file.
3156 : 0 : pert_comm%nproc = dtset%eph_np_pqbks(1)
3157 : 0 : qpt_comm%nproc = dtset%eph_np_pqbks(2)
3158 : 0 : bsum_comm%nproc = dtset%eph_np_pqbks(3)
3159 : 0 : kpt_comm%nproc = dtset%eph_np_pqbks(4)
3160 : 0 : spin_comm%nproc = dtset%eph_np_pqbks(5)
3161 : 0 : my_npert = natom3 / pert_comm%nproc
3162 [ # # ]: 0 : ABI_CHECK(my_npert > 0, "pert_comm_nproc cannot be greater than 3 * natom.")
3163 [ # # ]: 0 : ABI_CHECK(mod(natom3, pert_comm%nproc) == 0, "pert_comm_nproc must divide 3 * natom.")
3164 : : else
3165 : : ! Automatic grid generation
3166 : : ! Not the most efficient distribution if large number of MPI procs.
3167 : : ! TODO: Add parallelism over perturbations although it's less efficient than the parallelism over k
3168 : : ! It starts to be interesting if we implement symmetries in the k-integration though.
3169 : :
3170 : : ! TODO: Spin
3171 : : ! Automatic grid generation over q-points and spins.
3172 : : !if (new%nsppol == 2 .and. mod(nprocs, 2) == 0) then
3173 : : ! spin_comm%nproc = 2
3174 : : ! new%qpt_comm%nproc = nprocs / 2
3175 : : !else
3176 : : ! new%qpt_comm%nproc = nprocs
3177 : : !end if
3178 : :
3179 : : ! Handle parallelism over perturbations first.
3180 : : ! Use MPI communicator to distribute the 3 * natom perturbations to reduce memory requirements for DFPT potentials.
3181 : : ! Ideally, perturbations are equally distributed --> total number of CPUs should be divisible by 3 * natom.
3182 : : ! or at least, divisible by one integer i for i in [2, 3 * natom - 1].
3183 : :
3184 [ - + - - ]: 5 : if (nsppol == 2 .and. mod(nproc, 2) == 0) then
3185 : 0 : spin_comm%nproc = 2
3186 : 0 : kpt_comm%nproc = nproc / 2
3187 : : else
3188 : : ! Try to have 3 perts per proc first because the q-point parallelism is more efficient.
3189 : : ! The memory for W(R,r,ipert) will increase though.
3190 : : !do cnt=natom,2,-1
3191 : : ! if (mod(nprocs, cnt) == 0 .and. mod(natom3, cnt) == 0) then
3192 : : ! pert_comm%nproc = cnt; new%my_npert = natom3 / cnt; exit
3193 : : ! end if
3194 : : !end do
3195 : :
3196 : : !if (pert_comm%nproc == 1) then
3197 : : ! ! Try again with more procs.
3198 : : ! do cnt=natom3,2,-1
3199 : : ! if (mod(nprocs, cnt) == 0 .and. mod(natom3, cnt) == 0) then
3200 : : ! pert_comm%nproc = cnt; new%my_npert = natom3 / cnt; exit
3201 : : ! end if
3202 : : ! end do
3203 : : !end if
3204 : :
3205 : : !if (new%my_npert == natom3 .and. nprocs > 1) then
3206 : : ! ABI_WARNING("The number of MPI procs should be divisible by 3*natom to reduce memory requirements!")
3207 : : !end if
3208 : :
3209 : 5 : kpt_comm%nproc = nproc
3210 : : end if
3211 : : end if
3212 : :
3213 : : ! Consistency check.
3214 [ - + ]: 5 : if (pert_comm%nproc * qpt_comm%nproc * bsum_comm%nproc * kpt_comm%nproc * spin_comm%nproc /= nproc) then
3215 : : write(msg, "(a,i0,3a, 6(a,1x,i0))") &
3216 : 0 : "Cannot create 5d Cartesian grid with total nproc: ", nproc, ch10, &
3217 : 0 : "Idle processes are not supported. The product of the `nproc_*` vars should be equal to nproc.", ch10, &
3218 : 0 : "pert_nproc (", pert_comm%nproc, ") x qpt_nproc (", qpt_comm%nproc, ") x bsum_nproc (", bsum_comm%nproc, &
3219 : 0 : ") x kcalc_nproc (", kpt_comm%nproc, ") x spin_nproc (", spin_comm%nproc, ") != ", &
3220 : 0 : pert_comm%nproc * qpt_comm%nproc * bsum_comm%nproc * kpt_comm%nproc * spin_comm%nproc
3221 : 0 : ABI_ERROR(msg)
3222 : : end if
3223 : :
3224 [ - + ]: 5 : ABI_CHECK(bsum_comm%nproc == 1, "Band parallelism not implemented in m_phgamma")
3225 : :
3226 : : #ifdef HAVE_MPI
3227 : : ! Create 5d cartesian communicator: 3*natom perturbations, q-points in IBZ, bands in FS, kpoints in FS, spins
3228 : 5 : ndims = 5
3229 [ - + ]: 5 : ABI_MALLOC(dims, (ndims))
3230 [ - + ]: 5 : ABI_MALLOC(periods, (ndims))
3231 [ - + ]: 5 : ABI_MALLOC(keepdim, (ndims))
3232 [ + + ]: 30 : periods(:) = .False.; reorder = .False.
3233 [ - + + + ]: 35 : dims = [pert_comm%nproc, qpt_comm%nproc, bsum_comm%nproc, kpt_comm%nproc, spin_comm%nproc]
3234 : :
3235 : 5 : call MPI_CART_CREATE(comm, ndims, dims, periods, reorder, comm_cart, ierr)
3236 : : ! Find the index and coordinates of the current processor
3237 : 5 : call MPI_COMM_RANK(comm_cart, me_cart, ierr)
3238 : 5 : call MPI_CART_COORDS(comm_cart, me_cart, ndims, coords, ierr)
3239 : :
3240 : : ! Create communicator to distribute natom3 perturbations.
3241 [ + + ]: 30 : keepdim = .False.; keepdim(1) = .True.
3242 : 5 : call MPI_CART_SUB(comm_cart, keepdim, pert_comm%value, ierr); pert_comm%me = xmpi_comm_rank(pert_comm%value)
3243 : : ! Create communicator for qpoints in self-energy integration.
3244 [ + + ]: 30 : keepdim = .False.; keepdim(2) = .True.
3245 : 5 : call MPI_CART_SUB(comm_cart, keepdim, qpt_comm%value, ierr); qpt_comm%me = xmpi_comm_rank(qpt_comm%value)
3246 : : ! Create communicator for bands for band summation
3247 [ + + ]: 30 : keepdim = .False.; keepdim(3) = .True.
3248 : 5 : call MPI_CART_SUB(comm_cart, keepdim, bsum_comm%value, ierr); bsum_comm%me = xmpi_comm_rank(bsum_comm%value)
3249 : : ! Create communicator for kpoints.
3250 [ + + ]: 30 : keepdim = .False.; keepdim(4) = .True.
3251 : 5 : call MPI_CART_SUB(comm_cart, keepdim, kpt_comm%value, ierr); kpt_comm%me = xmpi_comm_rank(kpt_comm%value)
3252 : : ! Create communicator for spins.
3253 [ + + ]: 30 : keepdim = .False.; keepdim(5) = .True.
3254 : 5 : call MPI_CART_SUB(comm_cart, keepdim, spin_comm%value, ierr); spin_comm%me = xmpi_comm_rank(spin_comm%value)
3255 : : ! Create communicator for the (qpoint, spin) loops
3256 [ + + ]: 30 : keepdim = .False.; keepdim(2) = .True.; keepdim(5) = .True.
3257 : 5 : call MPI_CART_SUB(comm_cart, keepdim, qs_comm%value, ierr); qs_comm%me = xmpi_comm_rank(qs_comm%value)
3258 : : ! Create communicator for the (perturbation, k-point, band_sum)
3259 [ + + + + ]: 40 : keepdim = .False.; keepdim(1) = .True.; keepdim(3:4) = .True.
3260 : 5 : call MPI_CART_SUB(comm_cart, keepdim, pkb_comm%value, ierr); pkb_comm%me = xmpi_comm_rank(pkb_comm%value)
3261 : :
3262 [ - + ]: 5 : ABI_FREE(dims)
3263 [ - + ]: 5 : ABI_FREE(periods)
3264 : 5 : ABI_FREE(keepdim)
3265 : 5 : call xmpi_comm_free(comm_cart)
3266 : : #endif
3267 : :
3268 : : ! Distribute spins and q-points in IBZ.
3269 [ - + ]: 5 : call xmpi_split_cyclic(nsppol, spin_comm%value, gams%my_nspins, gams%my_spins)
3270 [ - + ]: 5 : ABI_CHECK(gams%my_nspins > 0, sjoin("nsppol (", itoa(nsppol), ") < spin_comm_nproc (", itoa(spin_comm%nproc), ")"))
3271 : :
3272 [ - + ]: 5 : call xmpi_split_cyclic(gams%nqibz, qpt_comm%value, gams%my_nqibz, gams%my_iqibz)
3273 [ - + ]: 5 : ABI_CHECK(gams%my_nqibz > 0, sjoin("nqibz (", itoa(gams%nqibz), ") < qpt_comm_nproc (", itoa(qpt_comm%nproc), ")"))
3274 : :
3275 : : !ABI_CALLOC(qibz_done, (gams%nqibz))
3276 [ + - ]: 5 : path = strcat(dtfil%filnam_ds(4), "_A2F.nc")
3277 : 5 : ncid = nctk_noid
3278 : :
3279 [ + - ]: 5 : if (my_rank == master) then
3280 : 5 : call cwtime(cpu, wall, gflops, "start")
3281 : :
3282 : 5 : write(std_out, "(/,a)")" === MPI parallelism ==="
3283 : : !write(std_out, "(2(a,i0))")"P Allocating and summing bands from my_bsum_start: ", self%my_bsum_start, &
3284 : : ! " up to my_bsum_stop: ", self%my_bsum_stop
3285 : 5 : write(std_out, "(a,i0)")"P Number of CPUs for parallelism over perturbations: ", pert_comm%nproc
3286 : 5 : write(std_out, "(a,i0)")"P Number of perturbations treated by this CPU: ", my_npert
3287 : 5 : write(std_out, "(a,i0)")"P Number of CPUs for parallelism over q-points: ", qpt_comm%nproc
3288 : : !write(std_out, "(2(a,i0))")"P Number of q-points in the IBZ treated by this proc: " , &
3289 : : ! count(self%itreat_qibz == 1), " of ", self%nqibz
3290 : 5 : write(std_out, "(a,i0)")"P Number of CPUs for parallelism over bands: ", bsum_comm%nproc
3291 : 5 : write(std_out, "(a,i0)")"P Number of CPUs for parallelism over spins: ", spin_comm%nproc
3292 : 5 : write(std_out, "(a,i0)")"P Number of CPUs for parallelism over k-points: ", kpt_comm%nproc
3293 : : !write(std_out, "(2(a,i0),/)")"P Number of k-point in Sigma_nk treated by this proc: ", self%my_nkcalc, " of ", self%nkcalc
3294 : :
3295 : : ! Master creates the netcdf file used to store the results of the calculation.
3296 [ - + ]: 5 : NCF_CHECK(nctk_open_create(ncid, path, xmpi_comm_self))
3297 [ - + ]: 5 : NCF_CHECK(cryst%ncwrite(ncid))
3298 [ - + ]: 5 : NCF_CHECK(ebands%ncwrite(ncid))
3299 [ - + ]: 5 : NCF_CHECK(edos%ncwrite(ncid))
3300 : :
3301 : : ! Add dimensions.
3302 [ + + ]: 15 : ncerr = nctk_def_dims(ncid, [nctkdim_t("nqibz", gams%nqibz), nctkdim_t("natom3", natom3)], defmode=.True.)
3303 [ - + ]: 5 : NCF_CHECK(ncerr)
3304 [ + + ]: 20 : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: "eph_intmeth", "eph_transport", "symdynmat"])
3305 [ - + ]: 5 : NCF_CHECK(ncerr)
3306 [ + + ]: 10 : ncerr = nctk_def_iscalars(ncid, [character(len=nctk_slen) :: "ph_intmeth"])
3307 [ - + ]: 5 : NCF_CHECK(ncerr)
3308 [ + + ]: 25 : ncerr = nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: "eph_fsewin", "eph_fsmear", "eph_extrael", "eph_fermie"])
3309 [ - + ]: 5 : NCF_CHECK(ncerr)
3310 [ + + ]: 15 : ncerr = nctk_def_dpscalars(ncid, [character(len=nctk_slen) :: "ph_wstep", "ph_smear"])
3311 [ - + ]: 5 : NCF_CHECK(ncerr)
3312 : :
3313 : : ! Define arrays for results.
3314 : : ncerr = nctk_def_arrays(ncid, [ &
3315 : : nctkarr_t("ngqpt", "int", "three"), &
3316 : : nctkarr_t("eph_ngqpt_fine", "int", "three"), &
3317 : : nctkarr_t("ddb_ngqpt", "int", "three"), &
3318 : : nctkarr_t("ph_ngqpt", "int", "three"), &
3319 : : nctkarr_t('qibz', "dp", "number_of_reduced_dimensions, nqibz"), &
3320 : : nctkarr_t('wtq', "dp", "nqibz"), &
3321 : : !nctkarr_t('qibz_done', "int", "nqibz"), &
3322 : : nctkarr_t('phfreq_qibz', "dp", "natom3, nqibz"), &
3323 : : nctkarr_t('phdispl_cart_qibz', "dp", "two, natom3, natom3, nqibz"), &
3324 : : nctkarr_t('phgamma_qibz', "dp", "natom3, nqibz, number_of_spins"), &
3325 : : nctkarr_t('phlambda_qibz', "dp", "natom3, nqibz, number_of_spins") &
3326 [ + + ]: 55 : ])
3327 [ - + ]: 5 : NCF_CHECK(ncerr)
3328 : :
3329 : : ! ======================================================
3330 : : ! Write data that do not depend on the (kpt, spin) loop.
3331 : : ! ======================================================
3332 [ - + ]: 5 : NCF_CHECK(nctk_set_datamode(ncid))
3333 : :
3334 : : ncerr = nctk_write_iscalars(ncid, &
3335 : : [character(len=nctk_slen) :: "eph_intmeth", "eph_transport", "symdynmat", "ph_intmeth"], &
3336 [ + + + + ]: 45 : [dtset%eph_intmeth, dtset%eph_transport, dtset%symdynmat, dtset%ph_intmeth])
3337 [ - + ]: 5 : NCF_CHECK(ncerr)
3338 : : ncerr = nctk_write_dpscalars(ncid, &
3339 : : [character(len=nctk_slen) :: "eph_fsewin", "eph_fsmear", "eph_extrael", "eph_fermie", "ph_wstep", "ph_smear"], &
3340 [ + + + + ]: 65 : [dtset%eph_fsewin, dtset%eph_fsmear, dtset%eph_extrael, dtset%eph_fermie, dtset%ph_wstep, dtset%ph_smear])
3341 [ - + ]: 5 : NCF_CHECK(ncerr)
3342 : :
3343 [ - + ]: 5 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, 'qibz'), gams%qibz))
3344 [ - + ]: 5 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, 'wtq'), gams%wtq))
3345 : : !NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, 'qibz_done'), qibz_done))
3346 [ - + ]: 5 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ngqpt"), gamma_ngqpt))
3347 [ - + ]: 5 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "eph_ngqpt_fine"), dtset%eph_ngqpt_fine))
3348 [ - + ]: 5 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ph_ngqpt"), dtset%ph_ngqpt))
3349 [ - + ]: 5 : NCF_CHECK(nf90_put_var(ncid, nctk_idname(ncid, "ddb_ngqpt"), dtset%ddb_ngqpt))
3350 : : !NCF_CHECK(nf90_close(ncid))
3351 : 5 : call cwtime_report(" Creation of A2F.nc", cpu, wall, gflops, end_str=ch10)
3352 : : end if
3353 : : !call xmpi_barrier(comm)
3354 : :
3355 : : ! Now reopen the file inside ncwrite_comm to perform parallel-IO (required for q-point parallelism).
3356 : : !if (self%ncwrite_comm%value /= xmpi_comm_null) then
3357 : : ! NCF_CHECK(nctk_open_modify(self%ncid, path, self%ncwrite_comm%value))
3358 : : ! NCF_CHECK(nctk_set_datamode(self%ncid))
3359 : : !end if
3360 : 5 : call edos%free()
3361 : :
3362 : : ! Open the DVDB file
3363 : 5 : call dvdb%open_read(ngfftf, xmpi_comm_self)
3364 [ - + ]: 5 : ABI_CHECK(dvdb%has_fields("pot1", msg), msg)
3365 : :
3366 [ - + ]: 5 : if (pert_comm%nproc > 1) then
3367 : : ! Activate parallelism over perturbations
3368 : : ! Build table with list of perturbations treated by this CPU inside pert_comm
3369 [ # # # # ]: 0 : call ephtk_set_pertables(cryst%natom, my_npert, pert_table, my_pinfo, pert_comm%value)
3370 : 0 : call dvdb%set_pert_distrib(my_npert, natom3, my_pinfo, pert_table, pert_comm%value)
3371 [ # # ]: 0 : ABI_FREE(my_pinfo)
3372 [ # # ]: 0 : ABI_FREE(pert_table)
3373 : : end if
3374 : :
3375 : : ! Check whether all q-points are available in the input DVDB file.
3376 : 5 : need_ftinterp = .False.
3377 [ + + ]: 66 : do iq_ibz=1,gams%nqibz
3378 [ - + ]: 66 : if (dvdb%findq(gams%qibz(:,iq_ibz) ) == -1) then
3379 : 0 : need_ftinterp = .True.; exit
3380 : : end if
3381 : : end do
3382 : 5 : call wrtout(std_out, " ", do_flush=.True.)
3383 : :
3384 : : ! Find correspondence IBZ --> set of q-points in DVDB.
3385 : : ! Activate FT interpolation automatically if required q-points in the IBZ are not found in the DVDB.
3386 : : !need_ftinterp = .False.
3387 : : !ABI_MALLOC(qibz2dvdb, (sigma%nqibz))
3388 : : !if (dvdb%find_qpts(sigma%nqibz, sigma%qibz, qibz2dvdb, comm) /= 0) then
3389 : : ! call wrtout(units, " Cannot find eph_ngqpt_fine q-points in DVDB --> Activating Fourier interpolation.")
3390 : : ! need_ftinterp = .True.
3391 : : !else
3392 : : ! call wrtout(units, " DVDB file contains all q-points in the IBZ --> Reading DFPT potentials from file.")
3393 : : ! need_ftinterp = .False.
3394 : : !end if
3395 : :
3396 : : !if (.not. need_ftinterp .and. dtset%eph_use_ftinterp /= 0) then
3397 : : ! ABI_WARNING("Enforcing FT interpolation for q-points even if it's not strictly needed.")
3398 : : ! need_ftinterp = .True.
3399 : : !end if
3400 : :
3401 [ - + ]: 5 : if (need_ftinterp) then
3402 : 0 : call wrtout(units, " Cannot find eph_ngqpt_fine q-points in DVDB --> Activating Fourier interpolation.")
3403 : : ! Prepare Fourier interpolation of DFPT potentials.
3404 : 0 : comm_rpt = xmpi_comm_self
3405 : : !comm_rpt = bqs_comm%value
3406 : 0 : call dvdb%ftinterp_setup(dtset%ddb_ngqpt, qptopt1, 1, dtset%ddb_shiftq, nfftf, ngfftf, comm_rpt)
3407 : : end if
3408 : :
3409 : : ! Initialize the wave function descriptor.
3410 : : ! Only wavefunctions on the FS are stored in wfd.
3411 : : ! Need all k-points on the FS because of k+q, spin is not distributed for the time being.
3412 : : ! It would be possible to reduce the memory allocated per MPI-rank via OpenMP.
3413 : :
3414 [ - + + - : 20 : ABI_MALLOC(nband, (nkibz, nsppol))
- + + - +
- + - - +
- + ]
3415 [ - + + - : 25 : ABI_MALLOC(bks_mask, (mband, nkibz, nsppol))
- + + - -
+ + - + -
+ - - + -
+ ]
3416 [ - + + - : 20 : ABI_MALLOC(keep_ur, (mband, nkibz ,nsppol))
- + + - -
+ + - - +
- + ]
3417 [ + + + + : 1905 : nband = mband; bks_mask = .False.; keep_ur = .False.
+ + + + +
+ + + + +
+ + ]
3418 : :
3419 [ + + ]: 10 : do my_is=1,gams%my_nspins
3420 : 5 : spin = gams%my_spins(my_is); fs => fstab(spin)
3421 [ + + ]: 700 : do ik_bz=1,fs%nkfs
3422 : 690 : ik_ibz = fs%indkk_fs(1, ik_bz)
3423 : 690 : bstart_k = fs%bstart_cnt_ibz(1, ik_ibz); nb_k = fs%bstart_cnt_ibz(2, ik_ibz)
3424 [ + + ]: 1385 : bks_mask(bstart_k:bstart_k+nb_k-1, ik_ibz, spin) = .True.
3425 : : end do
3426 : : end do
3427 : : !bks_mask(1:mband,:,:) = .True. ! no memory distribution, each node has the full set of states.
3428 : :
3429 : : ! Impose istwfk = 1 for all k-points. This is also done in respfn (see inkpts)
3430 : : ! wfd_read_wfk will handle a possible conversion if WFK contains istwfk /= 1.
3431 [ - + + - : 15 : ABI_MALLOC(wfd_istwfk, (nkibz))
+ - + - -
+ - + ]
3432 [ + + ]: 150 : wfd_istwfk = 1
3433 : :
3434 : 5 : ecut = dtset%ecut ! dtset%dilatmx
3435 : : call wfd%init(cryst, pawtab, psps, keep_ur, mband, nband, nkibz, nsppol, bks_mask,&
3436 : : nspden, nspinor, ecut, dtset%ecutsm, dtset%dilatmx, wfd_istwfk, ebands%kptns, ngfft,&
3437 : 5 : dtset%nloalg, dtset%prtvol, dtset%pawprtvol, comm)
3438 : :
3439 [ + + ]: 10 : call wfd%print([std_out], header="Wavefunctions on the Fermi surface")
3440 : :
3441 [ - + ]: 5 : ABI_FREE(nband)
3442 [ - + ]: 5 : ABI_FREE(keep_ur)
3443 [ - + ]: 5 : ABI_FREE(wfd_istwfk)
3444 : :
3445 : : ! Read wavefunctions.
3446 : 5 : call wfd%read_wfk(wfk0_path, iomode_from_fname(wfk0_path))
3447 : :
3448 : : ! one-dimensional structure factor information on the coarse grid.
3449 [ + - - + : 15 : ABI_MALLOC(ph1d, (2, 3*(2*mgfft+1)*natom))
+ - + - +
- - + - +
- + ]
3450 : 5 : call getph(cryst%atindx, natom, n1, n2, n3, ph1d, cryst%xred)
3451 : :
3452 : : ! mpw is the maximum number of plane-waves over k and k+q where k and k+q are in the BZ.
3453 : : ! we also need the max components of the G-spheres (k, k+q) in order to allocate the workspace array work
3454 : : ! that will be used to symmetrize the wavefunctions in G-space.
3455 : 5 : call cwtime(cpu, wall, gflops, "start")
3456 : 5 : call wrtout(std_out, " Computing mpw. This may take some time for dense k/q meshes...")
3457 : : !call fstab_get_mpw_gmax(nsppol, fstab, mpw, gmax, comm)
3458 : 5 : mpw = 0; gmax = 0; cnt = 0
3459 : :
3460 : : ! FIXME: This is an hotspot due to the loop over nkfs.
3461 : : ! Should use a geometric approach to compute mpw gmax.
3462 [ + + ]: 10 : do spin=1,nsppol
3463 : 5 : fs => fstab(spin)
3464 [ + + ]: 700 : do ik_bz=1,fs%nkfs
3465 [ + - ]: 690 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI parallelism inside comm
3466 [ + + ]: 2760 : kk = fs%kpts(:, ik_bz)
3467 : : ! Compute G sphere, returning npw. Note istwfk == 1.
3468 [ - + ]: 690 : call get_kg(kk, 1, ecut, cryst%gmet, onpw, gtmp)
3469 : 690 : mpw = max(mpw, onpw)
3470 [ + + ]: 52350 : do ipw=1,onpw
3471 [ + + ]: 207330 : do ii=1,3
3472 : 206640 : gmax(ii) = max(gmax(ii), abs(gtmp(ii,ipw)))
3473 : : end do
3474 : : end do
3475 [ - + ]: 690 : ABI_FREE(gtmp)
3476 : :
3477 [ + + ]: 9113 : do iq_ibz=1,gams%nqibz
3478 [ + + ]: 33672 : qpt = gams%qibz(:,iq_ibz)
3479 : : ! TODO: g0 umklapp here can enter into play!
3480 : : ! fstab should contains the max of the umlapp G-vectors.
3481 : : ! gmax could not be large enough!
3482 [ + + ]: 33672 : kq = kk + qpt
3483 [ - + ]: 8418 : call get_kg(kq, 1, ecut, cryst%gmet, onpw, gtmp)
3484 : 8418 : mpw = max(mpw, onpw)
3485 [ + + ]: 633595 : do ipw=1,onpw
3486 [ + + ]: 2509126 : do ii=1,3
3487 : 2500708 : gmax(ii) = max(gmax(ii), abs(gtmp(ii,ipw)))
3488 : : end do
3489 : : end do
3490 [ - + ]: 9108 : ABI_FREE(gtmp)
3491 : : end do
3492 : :
3493 : : end do ! ik_bz
3494 : : end do ! spin
3495 : :
3496 : 5 : my_mpw = mpw; call xmpi_max(my_mpw, mpw, comm, ierr)
3497 : 5 : my_gmax = gmax; call xmpi_max(my_gmax, gmax, comm, ierr)
3498 : 5 : call wrtout(std_out, sjoin(' Optimal value of mpw: ', itoa(mpw)))
3499 : 5 : call cwtime_report(" Computation of gmax and mpw:", cpu, wall, gflops)
3500 : :
3501 : : ! Init work_ngfft
3502 [ + + ]: 20 : gmax = gmax + 4 ! FIXME: this is to account for umklapp
3503 [ + + ]: 20 : gmax = 2*gmax + 1
3504 : 5 : call ngfft_seq(work_ngfft, gmax)
3505 : : !write(std_out,*)"work_ngfft(1:3): ",work_ngfft(1:3)
3506 [ - + + - : 25 : ABI_MALLOC(work, (2, work_ngfft(4), work_ngfft(5), work_ngfft(6)))
- + + - -
+ + - + -
+ - - + -
+ ]
3507 : :
3508 : : ! Allow PW-arrays dimensioned with mpw
3509 [ - + + - : 15 : ABI_MALLOC(kg_k, (3, mpw))
+ - + - -
+ - + -
+ ]
3510 [ - + + - : 10 : ABI_MALLOC(kg_kq, (3, mpw))
- + - + -
+ ]
3511 : :
3512 : : ! TODO FOR PAW
3513 : 5 : usecprj = 0
3514 [ - + + - : 10 : ABI_MALLOC(cwaveprj0, (natom, nspinor*usecprj))
- + - + -
+ ]
3515 : :
3516 : : ! Prepare call to getgh1c
3517 : 5 : usevnl = 0
3518 : 5 : optlocal = 1 ! local part of H^(1) is computed in gh1c=<G|H^(1)|C>
3519 : 5 : optnl = 2 ! non-local part of H^(1) is totally computed in gh1c=<G|H^(1)|C>
3520 : 5 : opt_gvnlx1 = 0 ! gvnlx1 is output
3521 : :
3522 [ - + - + ]: 5 : ABI_MALLOC(grad_berry, (2, nspinor*(berryopt0/4)))
3523 : :
3524 : : ! This part is taken from dfpt_vtorho
3525 : : !==== Initialize most of the Hamiltonian (and derivative) ====
3526 : : !1) Allocate all arrays and initialize quantities that do not depend on k and spin.
3527 : : !2) Perform the setup needed for the non-local factors:
3528 : : ! Norm-conserving: Constant kleimann-Bylander energies are copied from psps to gs_hamk.
3529 : : ! PAW: Initialize the overlap coefficients and allocate the Dij coefficients.
3530 : :
3531 : : call gs_hamkq%init(psps, pawtab, nspinor, nsppol, nspden, natom, &
3532 : : dtset%typat, cryst%xred, nfft, mgfft, ngfft, cryst%rprimd, dtset%nloalg, &
3533 : : comm_atom=mpi_enreg%comm_atom, mpi_atmtab=mpi_enreg%my_atmtab, mpi_spintab=mpi_enreg%my_isppoltab, &
3534 : 5 : usecprj=usecprj, ph1d=ph1d, nucdipmom=dtset%nucdipmom, gpu_option=dtset%gpu_option)
3535 : :
3536 : : ! Allocate vlocal. Note nvloc
3537 : : ! I set vlocal to huge to trigger possible bugs (DFPT routines should not access the data)
3538 [ - + + - : 30 : ABI_MALLOC(vlocal, (n4, n5, n6, gs_hamkq%nvloc))
- + + - -
+ + - - +
+ - + - +
- - + - +
- + ]
3539 [ + + + + : 10990 : vlocal = huge(one)
+ + + + ]
3540 : :
3541 : : ! Allocate work space arrays.
3542 [ - + + - : 20 : ABI_MALLOC(tgam, (2, natom3, natom3))
- + + - +
- + - - +
- + - + ]
3543 [ - + + - : 20 : ABI_MALLOC(displ_cart, (2, 3, cryst%natom, natom3))
- + + - +
- + - - +
- + ]
3544 [ - + + - : 15 : ABI_MALLOC(displ_red, (2, 3, cryst%natom, natom3))
- + + - -
+ - + ]
3545 [ - + + - : 8665 : ABI_CALLOC(dummy_vtrial, (nfftf, nspden))
- + + - +
- + - - +
- + + + +
+ ]
3546 : :
3547 : : ! TODO: Save data to netcdf file for each q in IBZ and then read data to build a2Fw once all big
3548 : : ! datastructures (wfd, dvdb) have been deallocated.
3549 : : ! As a side effect, one can also implement restart over q-points
3550 : :
3551 : : ! Create ddkop object to compute group velocities if needed.
3552 : : !
3553 : : ! 1) precompute group velocities in the IBZ and the ihave_ikibz_spin file (common to all procs)
3554 : : ! 2) Use symmetries to reconstruct v_kq from vcart_ibz
3555 : : !
3556 : : ! NB: All procs store in memory the same set of Bloch states inside the energy window.
3557 : :
3558 : 5 : call ddkop%init(dtset, cryst, pawtab, psps, wfd%mpi_enreg, mpw, wfd%ngfft)
3559 : :
3560 : 5 : call cwtime(cpu, wall, gflops, "start", msg=" Computing v_nk matrix elements for all states on the FS...")
3561 : 5 : ii = huge(1); jj = -1
3562 [ + + ]: 10 : do spin=1,nsppol
3563 : 5 : ii = min(ii, fstab(spin)%bmin)
3564 : 10 : jj = max(jj, fstab(spin)%bmax)
3565 : : end do
3566 [ - + + - : 1335 : ABI_CALLOC(vcart_ibz, (3, ii:jj, nkibz, nsppol))
- + + - -
+ + - + -
+ - - + -
+ - + + +
+ + + + +
+ ]
3567 [ - + + - : 15 : ABI_MALLOC(cg_work, (2, mpw * wfd%nspinor))
+ - + - -
+ - + ]
3568 : :
3569 : 5 : cnt = 0
3570 [ + + ]: 10 : do spin=1,nsppol
3571 : 5 : fs => fstab(spin)
3572 [ + + ]: 155 : do ik_ibz=1,ebands%nkpt
3573 [ + + ]: 580 : kk = ebands%kptns(:, ik_ibz); npw_k = wfd%npwarr(ik_ibz); istwf_k = wfd%istwfk(ik_ibz)
3574 : : ! NB: The two checks below are global --> all procs will cycle.
3575 [ + + + + : 760 : if (all(bks_mask(:, ik_ibz, spin) .eqv. .False.)) cycle
+ + ]
3576 [ - + ]: 30 : if (npw_k == 1) cycle
3577 [ - + ]: 30 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI parallelism.
3578 : :
3579 : 30 : call ddkop%setup_spin_kpoint(dtset, cryst, psps, spin, kk, istwf_k, npw_k, wfd%kdata(ik_ibz)%kg_k)
3580 : :
3581 [ + + ]: 95 : do band_k=fs%bmin,fs%bmax
3582 [ + + ]: 60 : if (.not. bks_mask(band_k, ik_ibz, spin)) cycle
3583 : 30 : call wfd%copy_cg(band_k, ik_ibz, spin, cg_work)
3584 : 30 : eig0nk = ebands%eig(band_k, ik_ibz, spin)
3585 : 30 : vk = ddkop%get_vdiag(eig0nk, istwf_k, npw_k, wfd%nspinor, cg_work, cwaveprj0)
3586 [ + + ]: 265 : vcart_ibz(:, band_k, ik_ibz, spin) = vk
3587 : :
3588 : : ! TODO: Use ebands_get_edos_matrix_elements
3589 : : ! reald(dp) :: vv_fs(3,3,nsppol)
3590 : : !vv_fs = zero
3591 : : !sigma = fs%eph_fsmear
3592 : : !if (fs%eph_fsmear < zero) then
3593 : : ! sigma = max(maxval([(abs(dot_product(fs%vk(:, ib2), fs%kmesh_cartvec(:,ii))), ii=1,3)]), fs%min_smear)
3594 : : !end if
3595 : : !fs_wtk = gaussian(emesh - ebands%eig(band_k, ik_ibz, spin), sigma) / (one * fs%nktot)
3596 : : !do ii=1,3
3597 : : ! do jj=1,3
3598 : : ! vv_fs(ii,jj,spin) = vv_fs(ii,jj,spin) + vk(ii) * vk(jj) * fs_wtk
3599 : : ! end do
3600 : : !end do
3601 : : !call xmpi_sum(vv_fs, comm, ierr)
3602 : : end do
3603 : : end do
3604 : : end do ! spin
3605 : :
3606 : 5 : call xmpi_sum(vcart_ibz, comm, ierr)
3607 [ - + ]: 5 : ABI_FREE(cg_work)
3608 : 5 : call cwtime_report(" Computation of group velocities", cpu, wall, gflops)
3609 : :
3610 [ - + ]: 5 : ABI_FREE(bks_mask)
3611 : :
3612 : : !Write v_nk to disk.
3613 : : !if (my_rank == master) then
3614 : : ! NCF_CHECK(nf90_put_var(sigma%ncid, nctk_idname(sigma%ncid, "vcart_ibz"), vcart_ibz))
3615 : : !end if
3616 : :
3617 [ + - ]: 5 : if (dtset%eph_transport > 0) then
3618 [ - + + - : 20 : ABI_MALLOC(tgamvv_in, (2, 9, natom3, natom3))
- + + - +
- + - - +
- + - + ]
3619 [ - + + - : 15 : ABI_MALLOC(tgamvv_out, (2, 9, natom3, natom3))
- + + - -
+ - + -
+ ]
3620 : : end if
3621 : :
3622 : : ! Build krank object to find k-points
3623 : 5 : call krank%from_kptrlatt(ebands%nkpt, ebands%kptns, ebands%kptrlatt, compute_invrank=.False.)
3624 : 5 : call pstat_proc%print(_PSTAT_ARGS_)
3625 : :
3626 : : ! Loop over my q-points in the IBZ.
3627 [ + + ]: 66 : do my_iq=1,gams%my_nqibz
3628 : 61 : iq_ibz = gams%my_iqibz(my_iq)
3629 : :
3630 : : ! TODO: Restart capabilities
3631 : : ! Check if this (kpoint, spin) was already calculated
3632 : : !if (all(qibz_done(iq_ibz, :) == 1)) cycle
3633 : :
3634 : 61 : call cwtime(cpu_q, wall_q, gflops_q, "start")
3635 : :
3636 [ + + ]: 244 : qpt = gams%qibz(:, iq_ibz)
3637 [ + - ]: 61 : msg = sjoin("[", itoa(iq_ibz), "/", itoa(gams%nqibz), "]")
3638 : 61 : call wrtout(std_out, sjoin(" Computing ph linewidths for IBZ q-point:", ktoa(qpt), msg))
3639 : :
3640 [ + + + + : 1891 : tgam = zero
+ + ]
3641 [ + - ]: 61 : if (dtset%eph_transport > 0) then
3642 [ + + + + : 31171 : tgamvv_in = zero; tgamvv_out = zero
+ + + + +
+ + + + +
+ + ]
3643 : : end if
3644 : :
3645 [ + - ]: 61 : if (.not. need_ftinterp) then
3646 : : ! No interpolation --> find the index of the q-point in the DVDB.
3647 : 61 : db_iqpt = dvdb%findq(qpt)
3648 : :
3649 [ + - ]: 61 : if (db_iqpt /= -1) then
3650 : : ! Read and reconstruct the dvscf potentials for all 3*natom perturbations.
3651 : : ! This call allocates v1scf(cplex, nfftf, nspden, 3*natom))
3652 [ - + ]: 61 : call dvdb%readsym_allv1(db_iqpt, cplex, nfftf, ngfftf, v1scf, pkb_comm%value)
3653 : :
3654 [ - + ]: 61 : if (dvdb%my_npert /= natom3) then
3655 : : ! Extract my npert from v1scf
3656 [ # # # # : 0 : ABI_MALLOC(v1_work, (cplex, nfftf, nspden, dvdb%my_npert))
# # # # #
# # # # #
# # # # #
# # # #
# ]
3657 [ # # ]: 0 : do my_ip=1,dvdb%my_npert
3658 [ # # # # : 0 : v1_work(:,:,:,my_ip) = v1scf(:,:,:,dvdb%my_pinfo(3, my_ip))
# # ]
3659 : : end do
3660 [ # # ]: 0 : ABI_MOVE_ALLOC(v1_work, v1scf)
3661 : : end if
3662 : :
3663 : : else
3664 : 0 : ABI_ERROR(sjoin("Cannot find q-point:", ktoa(qpt), "in the DVDB file."))
3665 : : end if
3666 : :
3667 : : else
3668 : : ! Use Fourier interpolation of DFPT potentials to get my_npert potentials.
3669 : 0 : cplex = 2
3670 [ # # # # : 0 : ABI_MALLOC(v1scf, (cplex, nfft, nspden, dvdb%my_npert))
# # # # #
# # # # #
# # # # #
# # # ]
3671 : 0 : call dvdb%ftinterp_qpt(qpt, nfftf, ngfftf, v1scf, dvdb%comm_rpt)
3672 : : end if
3673 : :
3674 : : ! Compute the little group of the q-point so that we can compute g(k,q) only for k in the IBZ_q
3675 : : !if (dtset%symsigma /= 0) then
3676 : : ! timrev_q = kpts_timrev_from_kptopt(my_qptopt)
3677 : : ! call lg_q%init(cryst, qpt, timrev_q, gstore%nkbz, gstore%kbz, gstore%nkibz, gstore%kibz, xmpi_comm_self)
3678 : : !end if
3679 : :
3680 : : !if (dtset%symsigma /= 0) then
3681 : : ! ii = lg_q%findq_ibzk(kk)
3682 : : ! if (ii == -1) then
3683 : : ! call wrtout(std_out, sjoin(" my_ik:", itoa(my_ik), kk_string, " not in IBZ_q --> skipping iteration"))
3684 : : ! cycle
3685 : : ! ! TODO: Check fillvalue (should be zero)
3686 : : ! end if
3687 : : ! weight_k = lg_q%weights(ii)
3688 : : !end if
3689 : : !call lg_q%free()
3690 : :
3691 : : ! Get phonon frequencies and eigenvectors for this q-point.
3692 : 61 : call ifc%fourq(cryst, qpt, phfrq, displ_cart, out_displ_red=displ_red)
3693 : 61 : wminmax(1) = min(wminmax(1), phfrq(1))
3694 : 61 : wminmax(2) = max(wminmax(2), phfrq(3*cryst%natom))
3695 : :
3696 : : ! Allocate vlocal1 with correct cplex. Note nvloc and my_npert.
3697 [ - + + - : 427 : ABI_MALLOC(vlocal1, (cplex*n4, n5, n6, gs_hamkq%nvloc, my_npert))
- + + - -
+ + - - +
+ - - + +
- + - + -
- + - + ]
3698 : :
3699 : : ! Loop over my spins.
3700 [ + + ]: 122 : do my_is=1,gams%my_nspins
3701 : 61 : spin = gams%my_spins(my_is); fs => fstab(spin)
3702 : :
3703 [ - + ]: 61 : if (dtset%prteliash == 3) then
3704 [ # # # # : 0 : ABI_CALLOC_OR_DIE(tmp_vals_ee, (2, gams%nene, gams%nene, natom3, natom3), ierr)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
3705 : : ! Energy mesh for electrons in a2F(e,e',w) NB: It depends on the spin through enemin
3706 [ # # # # : 0 : ABI_MALLOC(emesh, (gams%nene))
# # # # #
# # # #
# ]
3707 [ # # ]: 0 : emesh = arth(fs%enemin, fs%deltaene, gams%nene)
3708 : : end if
3709 : :
3710 : : ! Set up local potential vlocal1 with proper dimensioning from vtrial1 taking into account the spin.
3711 [ + + ]: 244 : do my_ip=1,my_npert
3712 : : call rf_transgrid_and_pack(spin, nspden, psps%usepaw, cplex, nfftf, nfft, ngfft, gs_hamkq%nvloc,&
3713 : 244 : pawfgr, mpi_enreg, dummy_vtrial, v1scf(:,:,:,my_ip), vlocal, vlocal1(:,:,:,:,my_ip))
3714 : : end do
3715 : :
3716 : : ! Continue to initialize the GS Hamiltonian
3717 : 61 : call gs_hamkq%load_spin(spin, vlocal=vlocal, with_nonlocal=.true.)
3718 : :
3719 : : ! Allocate workspace for wavefunctions. Make npw larger than expected.
3720 : : ! maxnb is the maximum number of bands crossing the FS, used to dimension arrays.
3721 : 61 : mnb = fs%maxnb
3722 : : ! The weights for the integration of the double-delta.
3723 [ - + + - : 244 : ABI_MALLOC(dbldelta_wts, (mnb, mnb))
- + + - +
- + - - +
- + - + ]
3724 : :
3725 [ + - ]: 61 : if (dtset%eph_transport > 0) then
3726 [ - + + - : 244 : ABI_MALLOC(vv_kk, (9, mnb, mnb))
- + + - +
- + - - +
- + - + ]
3727 [ - + + - : 183 : ABI_MALLOC(vv_kkq, (9, mnb, mnb))
- + + - -
+ - + -
+ ]
3728 : : end if
3729 : :
3730 [ - + ]: 61 : if (dtset%prteliash == 3) then
3731 [ # # # # : 0 : ABI_MALLOC(wt_ek, (gams%nene, mnb))
# # # # #
# # # # #
# # # # ]
3732 [ # # # # : 0 : ABI_MALLOC(wt_ekq, (gams%nene, mnb))
# # # # #
# # # #
# ]
3733 : : end if
3734 : :
3735 : : ! =====================================
3736 : : ! Integration over the FS for this spin
3737 : : ! =====================================
3738 : : ! Compute integration weights and distribute k-points (gams%my_nfsk_q) inside kpt_comm
3739 : 61 : call phgamma_setup_qpoint(gams, fs, cryst, ebands, spin, ltetra, qpt, nesting, kpt_comm%value)
3740 : :
3741 [ + + ]: 6265 : do my_ik=1,gams%my_nfsk_q
3742 [ + + + - : 6204 : print_time_k = (my_ik <= 2 .or. (fs%nkfs > 100 .and. mod(my_ik, 200) == 0))
- + ]
3743 : 122 : if (print_time_k) call cwtime(cpu_k, wall_k, gflops_k, "start")
3744 : :
3745 : : ! The k-point and the symmetries relating the BZ k-point to the IBZ.
3746 : 6204 : ik_fs = gams%my_ifsk_q(my_ik)
3747 [ + + ]: 24816 : kk = fs%kpts(:, ik_fs)
3748 : 6204 : ik_ibz = fs%indkk_fs(1, ik_fs); isym_k = fs%indkk_fs(2, ik_fs)
3749 [ + + ]: 24816 : trev_k = fs%indkk_fs(6, ik_fs); g0_k = fs%indkk_fs(3:5,ik_fs)
3750 [ + + + + : 19906 : isirr_k = (isym_k == 1 .and. trev_k == 0 .and. all(g0_k == 0))
+ + - + ]
3751 [ + + ]: 24816 : kk_ibz = ebands%kptns(:,ik_ibz)
3752 : :
3753 : : ! Number of bands crossing the Fermi level at k.
3754 : 6204 : bstart_k = fs%bstart_cnt_ibz(1, ik_ibz); nb_k = fs%bstart_cnt_ibz(2, ik_ibz)
3755 : :
3756 : : ! Find k+q in the extended zone and extract symmetry info. cycle if k+q not in FS.
3757 : : ! Be careful here because there are two umklapp vectors to be considered:
3758 : : !
3759 : : ! k + q = k_bz + g0_bz = IS(k_ibz) + g0_ibz + g0_bz
3760 : : !
3761 [ + + ]: 24816 : kq = kk + qpt; ikq_bz = fs%findkg0(kq, g0bz_kq)
3762 : :
3763 : : ! Skip this point if kq does not belong to the FS window.
3764 [ + + ]: 6204 : if (ikq_bz == -1) cycle
3765 : :
3766 [ - + ]: 2864 : if (kpts_map("symrel", ebands%kptopt, cryst, krank, 1, kq, indkk_kq) /= 0) then
3767 : : write(msg, '(9a)' ) &
3768 : 0 : "The WFK file cannot be used to compute phonon linewidths.",ch10, &
3769 : 0 : "At least one of the k-points on the FS could not be generated from a symmetrical one.", ch10, &
3770 [ # # # # ]: 0 : "q-mesh: ", trim(ltoa(gamma_ngqpt)), ", k-mesh (from kptrlatt) ", trim(ltoa(get_diag(ebands%kptrlatt))), &
3771 : 0 : 'Action: check your WFK file and the (k, q) point input variables.'
3772 : 0 : ABI_ERROR(msg)
3773 : : end if
3774 : :
3775 : : ! The k+q point and the symmetries relating it to the IBZ.
3776 : 2864 : ikq_ibz = indkk_kq(1, 1); isym_kq = indkk_kq(2, 1)
3777 [ + + ]: 11456 : trev_kq = indkk_kq(6, 1); g0_kq = indkk_kq(3:5, 1)
3778 [ + + + + : 6934 : isirr_kq = (isym_kq == 1 .and. trev_kq == 0 .and. all(g0_kq == 0))
+ + + + ]
3779 [ + + ]: 11456 : kq_ibz = ebands%kptns(:, ikq_ibz)
3780 : :
3781 : : ! If we have used the KERANGE trick, we may have k or k+q points with just one G component set to zero
3782 : : ! so we skip this transition immediately. This should happen only if fsewin > sigma_erange.
3783 [ + - + - ]: 2864 : if (wfd%npwarr(ik_ibz) == 1 .or. wfd%npwarr(ikq_ibz) == 1) cycle
3784 : :
3785 : : ! Number of bands crossing the Fermi level at k+q.
3786 : 2864 : bstart_kq = fs%bstart_cnt_ibz(1, ikq_ibz); nb_kq = fs%bstart_cnt_ibz(2, ikq_ibz)
3787 [ - + ]: 2864 : ABI_CHECK(nb_k <= mnb .and. nb_kq <= mnb, "wrong nband")
3788 : :
3789 : : ! Get npw_k, kg_k and symmetrize wavefunctions from IBZ (if needed).
3790 : : call wfd%sym_ug_kg_npw(ecut, kk, kk_ibz, bstart_k, nb_k, spin, fs%indkk_fs(:,ik_fs), cryst, &
3791 [ - + ]: 2864 : work_ngfft, work, istwf_k, npw_k, kg_k, kets_k)
3792 : :
3793 : : ! Get npw_kq, kg_kq and symmetrize wavefunctions from IBZ (if needed).
3794 : : call wfd%sym_ug_kg_npw(ecut, kq, kq_ibz, bstart_kq, nb_kq, spin, indkk_kq(:,1), cryst, &
3795 [ - + ]: 2864 : work_ngfft, work, istwf_kq, npw_kq, kg_kq, bras_kq)
3796 : :
3797 : : call gs_hamkq%eph_setup_k("k" , kk, istwf_k, npw_k, kg_k, dtset, cryst, psps, & ! in
3798 [ - + - + : 2864 : nkpg, kpg_k, ffnl_k, kinpw_k, ph3d_k, pert_comm%value) ! out
- + - + ]
3799 : :
3800 : : call gs_hamkq%eph_setup_k("kq", kq, istwf_k, npw_kq, kg_kq, dtset, cryst, psps, & ! in
3801 [ - + - + : 2864 : nkpg, kpg_kq, ffnl_kq, kinpw_kq, ph3d_kq, pert_comm%value) ! out
- + - + ]
3802 : :
3803 : : ! If PAW, one has to solve a generalized eigenproblem
3804 [ - + ]: 2864 : gen_eigenpb = psps%usepaw == 1; sij_opt = 0; if (gen_eigenpb) sij_opt = 1
3805 : :
3806 [ - + + - : 8592 : ABI_MALLOC(lambda, (nb_k))
+ - + - -
+ - + -
+ ]
3807 [ - + + - : 14320 : ABI_MALLOC(gkq_atm, (2, nb_kq, nb_k, natom3))
- + + - -
+ + - + -
+ - - + -
+ - + ]
3808 [ - + + - : 11456 : ABI_MALLOC(h1_kets_kq, (2, npw_kq*nspinor, nb_k))
- + + - +
- + - - +
- + - + ]
3809 [ - + + - : 8592 : ABI_MALLOC(gvnlx1, (2, npw_kq*nspinor, nb_k))
- + + - -
+ - + -
+ ]
3810 [ + - - - : 8592 : ABI_MALLOC(gs1c_kq, (2, npw_kq*nspinor*nb_k*((sij_opt+1)/2)))
+ - - + -
+ - + -
+ ]
3811 [ - + + - : 11456 : ABI_MALLOC(gkq_atm_ipc, (2, nb_kq, nb_k))
- + + - +
- + - - +
- + - + ]
3812 : : #ifdef HAVE_OPENMP_OFFLOAD
3813 : : !$OMP TARGET ENTER DATA MAP(alloc:gkq_atm_ipc) IF (dtset%gpu_option == ABI_GPU_OPENMP)
3814 : : !$OMP TARGET ENTER DATA MAP(to:kets_k, bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP)
3815 : : !$OMP TARGET ENTER DATA MAP(alloc:h1_kets_kq, gvnlx1, kets_k, bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP)
3816 : : !$OMP TARGET ENTER DATA MAP(alloc:gs1c_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP .and. sij_opt /= 0)
3817 : : #endif
3818 : :
3819 : : ! Loop over all my atomic perturbations and compute gkq_atm.
3820 [ + + ]: 11456 : do my_ip=1,my_npert
3821 : 8592 : idir = dvdb%my_pinfo(1, my_ip); ipert = dvdb%my_pinfo(2, my_ip); ipc = dvdb%my_pinfo(3, my_ip)
3822 : :
3823 : : ! Prepare application of the NL part.
3824 : 8592 : call rf_hamkq%init(cplex, gs_hamkq, ipert, has_e1kbsc=.true.)
3825 : 8592 : call rf_hamkq%load_spin(spin, vlocal1=vlocal1(:,:,:,:,my_ip), with_nonlocal=.true.)
3826 : :
3827 : : #if 1
3828 : : ! Calculate dvscf * psi_k, results stored in h1_kets_kq on the k+q sphere.
3829 : : ! Compute H(1) applied to GS wavefunction Psi(0)
3830 [ + + ]: 17184 : do in_k=1,nb_k
3831 : : ! Use scissor shift on 0-order eigenvalue
3832 : 8592 : band_k = in_k + bstart_k - 1
3833 : 17184 : lambda(in_k) = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
3834 : : end do
3835 : : !call ebands%get_dfpt_eshifted(gqk%bstart_k, nb_k, ik_ibz, spin, dtset%dfpt_sciss, lambda)
3836 : :
3837 : : call getgh1c(berryopt0, kets_k, cwaveprj0, h1_kets_kq, &
3838 : : grad_berry, gs1c_kq, gs_hamkq, gvnlx1, idir, ipert, lambda, mpi_enreg, nb_k, optlocal, &
3839 : 8592 : optnl, opt_gvnlx1, rf_hamkq, sij_opt, tim_getgh1c, usevnl)
3840 : :
3841 : : #else
3842 : : do in_k=1,nb_k
3843 : : ! Use scissor shift on 0-order eigenvalue
3844 : : band_k = in_k + bstart_k - 1
3845 : : eshift = ebands%eig(band_k, ik_ibz, spin) - dtset%dfpt_sciss
3846 : :
3847 : : call getgh1c(berryopt0, kets_k(:,:,in_k), cwaveprj0, h1_kets_kq(:,:,in_k), &
3848 : : grad_berry, gs1c_kq, gs_hamkq, gvnlx1, idir, ipert, [eshift], mpi_enreg, ndat1, optlocal, &
3849 : : optnl, opt_gvnlx1, rf_hamkq, sij_opt, tim_getgh1c, usevnl)
3850 : : end do ! in_k
3851 : : #endif
3852 : :
3853 : 8592 : call rf_hamkq%free()
3854 : :
3855 : : ! Calculate <psi_{k+q,m}|dvscf_q|psi_{k,n}> for this perturbation.
3856 : : ! No need to handle istwf_kq because it's always 1.
3857 [ - + ]: 8592 : if (dtset%gpu_option == ABI_GPU_OPENMP) then
3858 : : call abi_gpu_xgemm_d(2, 'C', 'N', nb_kq, nb_k, npw_kq*nspinor, cone, bras_kq, npw_kq*nspinor, &
3859 : 0 : h1_kets_kq, npw_kq*nspinor, czero, gkq_atm_ipc, nb_kq)
3860 : : #ifdef HAVE_OPENMP_OFFLOAD
3861 : : !$OMP TARGET UPDATE FROM(gkq_atm_ipc)
3862 : : #endif
3863 : :
3864 : : else
3865 : : call ZGEMM('C', 'N', nb_kq, nb_k, npw_kq*nspinor, cone, bras_kq, npw_kq*nspinor, &
3866 : 8592 : h1_kets_kq, npw_kq*nspinor, czero, gkq_atm_ipc, nb_kq)
3867 : : end if
3868 : :
3869 : : ! Transfer data
3870 [ + + + + : 45824 : gkq_atm(:,:,:,ipc) = gkq_atm_ipc
+ + ]
3871 : : end do ! my_ip (loop over my_npert atomic perturbations)
3872 : :
3873 : : ! Collect gkq_atm inside pert_comm so that all procs can operate on the data.
3874 [ - + ]: 2864 : if (pert_comm%nproc > 1) call xmpi_sum(gkq_atm, pert_comm%value, ierr)
3875 : :
3876 [ - + ]: 2864 : ABI_FREE(ffnl_k)
3877 [ - + ]: 2864 : ABI_FREE(ffnl_kq)
3878 [ - + ]: 2864 : ABI_FREE(kpg_kq)
3879 [ - + ]: 2864 : ABI_FREE(kpg_k)
3880 [ - + ]: 2864 : ABI_FREE(kinpw_k)
3881 [ - + ]: 2864 : ABI_FREE(kinpw_kq)
3882 [ - + ]: 2864 : ABI_FREE(ph3d_k)
3883 [ - + ]: 2864 : ABI_FREE(ph3d_kq)
3884 : :
3885 : : #ifdef HAVE_OPENMP_OFFLOAD
3886 : : !$OMP TARGET EXIT DATA MAP(delete:h1_kets_kq, gvnlx1, kets_k, bras_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP)
3887 : : !$OMP TARGET EXIT DATA MAP(delete:gs1c_kq) IF (dtset%gpu_option == ABI_GPU_OPENMP .and. sij_opt /= 0)
3888 : : #endif
3889 [ - + ]: 2864 : ABI_FREE(kets_k)
3890 [ - + ]: 2864 : ABI_FREE(bras_kq)
3891 [ - + ]: 2864 : ABI_FREE(h1_kets_kq)
3892 [ - + ]: 2864 : ABI_FREE(gs1c_kq)
3893 [ - + ]: 2864 : ABI_FREE(gvnlx1)
3894 : :
3895 : : ! Compute group velocities if we are in transport mode or adaptive gaussian or
3896 : : ! tetrahedron with libtetrabz returning nesting condition.
3897 [ - + - - : 2864 : need_velocities = dtset%eph_transport > 0 .or. fs%eph_fsmear < zero .or. nesting /= 0
- - ]
3898 : :
3899 : : if (need_velocities) then
3900 : : ! Compute diagonal matrix elements of velocity operator with DFPT routines
3901 : : ! Velocities are in Cartesian coordinates.
3902 : : !
3903 : : ! If k+q is not in the IBZ, we need to recostruct the value by symmetry using v(Sq) = S v(q).
3904 : : ! Use transpose(R) because we are using the tables for the wavefunctions
3905 : : ! In this case listkk has been called with symrec and use_symrec=False
3906 : : ! so q_bz = S^T q_ibz where S is the isym_kq symmetry
3907 : :
3908 : : !call ddkop%setup_spin_kpoint(dtset, cryst, psps, spin, kk, istwf_k, npw_k, kg_k)
3909 [ + + ]: 5728 : do in_k=1,nb_k
3910 : 2864 : band_k = in_k + bstart_k - 1
3911 [ + + ]: 11456 : vk = vcart_ibz(:, band_k, ik_ibz, spin)
3912 [ + + ]: 2864 : if (.not. isirr_k) then
3913 : 2754 : vk = matmul(transpose(cryst%symrel_cart(:,:,isym_k)), vk)
3914 [ - + - - ]: 2754 : if (trev_k /= 0) vk = -vk
3915 : : end if
3916 : : !vk = ddkop%get_vdiag(ebands%eig(band_k, ik_ibz, spin), &
3917 : : ! istwf_k, npw_k, wfd%nspinor, kets_k(:,:,in_k), cwaveprj0)
3918 [ + + ]: 14320 : fs%vk(:,in_k) = vk
3919 : : end do
3920 : :
3921 : : !call ddkop%setup_spin_kpoint(dtset, cryst, psps, spin, kq, istwf_kq, npw_kq, kg_kq)
3922 [ + + ]: 5728 : do im_kq=1,nb_kq
3923 : 2864 : band_kq = im_kq + bstart_kq - 1
3924 [ + + ]: 11456 : vkq = vcart_ibz(:, band_kq, ikq_ibz, spin)
3925 [ + + ]: 2864 : if (.not. isirr_kq) then
3926 : 2833 : vkq = matmul(transpose(cryst%symrel_cart(:,:,isym_kq)), vkq)
3927 [ - + - - ]: 2833 : if (trev_kq /= 0) vkq = -vkq
3928 : : end if
3929 : : !vkq = ddkop%get_vdiag(ebands%eig(band_kq, ikq_ibz, spin), &
3930 : : ! istwf_kq, npw_kq, wfd%nspinor, bras_kq(:,:,im_kq), cwaveprj0)
3931 [ + + ]: 14320 : fs%vkq(:,im_kq) = vkq
3932 : : end do
3933 : : end if
3934 : :
3935 : : ! Compute weights for double delta integration at the Fermi level.
3936 : : ! Note that we have to call the routine here after the initialization of fs%vk and fs%vkq
3937 : : ! TODO: Could precompute weights before entering the loop, apply filter and compute MPI-distribution
3938 : 2864 : call fs%get_dbldelta_weights(ebands, ik_fs, ik_ibz, ikq_ibz, spin, nesting, dbldelta_wts)
3939 : : ! Multiply by the weight of the q-point if we are summing over the IBZ(q).
3940 : : !dbldelta_wts = dbldelta_wts * wtk_lgq
3941 : :
3942 : : ! Accumulate results in tgam (sum over FS k-points and bands for this spin).
3943 [ + + ]: 11456 : do ipc2=1,natom3
3944 [ + + ]: 37232 : do ipc1=1,natom3
3945 [ + + ]: 60144 : do in_k=1,nb_k
3946 [ + + ]: 77328 : do im_kq=1,nb_kq
3947 [ + + ]: 77328 : lf = gkq_atm(:, im_kq, in_k, ipc1)
3948 [ + + ]: 77328 : rg = gkq_atm(:, im_kq, in_k, ipc2)
3949 : 25776 : res(1) = lf(1) * rg(1) + lf(2) * rg(2)
3950 : 25776 : res(2) = lf(1) * rg(2) - lf(2) * rg(1)
3951 [ + + ]: 103104 : tgam(:,ipc1,ipc2) = tgam(:,ipc1,ipc2) + res(:) * dbldelta_wts(im_kq, in_k)
3952 : : end do
3953 : : end do
3954 : : end do
3955 : : end do
3956 : :
3957 [ + - ]: 2864 : if (dtset%eph_transport > 0) then
3958 : : ! TODO: could almost make this a BLAS call plus a reshape...
3959 [ + + ]: 5728 : do in_k = 1,nb_k
3960 [ + + ]: 8592 : do im_kq = 1,nb_kq
3961 [ + + ]: 14320 : do ipc2 = 1,3
3962 [ + + ]: 37232 : do ipc1 = 1,3
3963 : : ! vk x vk
3964 : 25776 : vv_kk(ipc1 + (ipc2-1)*3, im_kq, in_k) = fs%vk(ipc1, im_kq) * fs%vk(ipc2, in_k)
3965 : : ! vk x vk+q
3966 : 34368 : vv_kkq(ipc1 + (ipc2-1)*3, im_kq, in_k) = fs%vkq(ipc1, im_kq) * fs%vk(ipc2, in_k)
3967 : : end do
3968 : : end do
3969 : : end do
3970 : : end do
3971 : :
3972 : : ! Accumulate results (sum over FS and bands).
3973 [ + + ]: 11456 : do ipc2=1,natom3
3974 [ + + ]: 37232 : do ipc1=1,natom3
3975 [ + + ]: 60144 : do in_k=1,nb_k
3976 [ + + ]: 77328 : do im_kq=1,nb_kq
3977 [ + + ]: 77328 : lf = gkq_atm(:, im_kq, in_k, ipc1)
3978 [ + + ]: 77328 : rg = gkq_atm(:, im_kq, in_k, ipc2)
3979 : : ! res was missing in MJV version!
3980 : 25776 : res(1) = lf(1) * rg(1) + lf(2) * rg(2)
3981 : 25776 : res(2) = lf(1) * rg(2) - lf(2) * rg(1)
3982 [ + + ]: 257760 : resvv_in(1,:) = res(1) * vv_kkq(:,im_kq, in_k)
3983 [ + + ]: 257760 : resvv_in(2,:) = res(2) * vv_kkq(:,im_kq, in_k)
3984 [ + + ]: 257760 : resvv_out(1,:) = res(1) * vv_kk(:,im_kq, in_k)
3985 [ + + ]: 257760 : resvv_out(2,:) = res(2) * vv_kk(:,im_kq, in_k)
3986 [ + + + + ]: 721728 : tgamvv_in(:,:,ipc1, ipc2) = tgamvv_in(:,:,ipc1,ipc2) + resvv_in * dbldelta_wts(im_kq, in_k)
3987 [ + + + + ]: 747504 : tgamvv_out(:,:,ipc1, ipc2) = tgamvv_out(:,:,ipc1,ipc2) + resvv_out * dbldelta_wts(im_kq, in_k)
3988 : : end do
3989 : : end do
3990 : : end do
3991 : : end do
3992 : : end if ! add transport things
3993 : :
3994 [ - + ]: 2864 : if (dtset%prteliash == 3) then
3995 : : ! Precompute deltas with gaussian (tetra is not supported here
3996 : : ! also because one should allocate (nene, nene, mband, mband)
3997 : : !call get_dbldelta_weights_emesh()
3998 [ # # ]: 0 : do in_k=1,nb_k
3999 : 0 : band_k = in_k + bstart_k - 1
4000 : 0 : sigma = fs%eph_fsmear
4001 [ # # ]: 0 : if (fs%eph_fsmear < zero) then
4002 [ # # ]: 0 : do ii=1,3
4003 [ # # ]: 0 : abc(ii) = abs(dot_product(fs%vk(:, in_k), fs%kmesh_cartvec(:,ii)))
4004 : : end do
4005 [ # # # # : 0 : sigma = max(maxval(abc), fs%min_smear)
# # ]
4006 : : end if
4007 [ # # ]: 0 : wt_ek(:, in_k) = gaussian(emesh - ebands%eig(band_k, ik_ibz, spin), sigma) / sqrt(one * fs%nktot)
4008 : : end do
4009 : :
4010 [ # # ]: 0 : do im_kq=1,nb_kq
4011 : 0 : band_kq = im_kq + bstart_kq - 1
4012 : 0 : sigma = fs%eph_fsmear
4013 [ # # ]: 0 : if (fs%eph_fsmear < zero) then
4014 [ # # ]: 0 : do ii=1,3
4015 [ # # ]: 0 : abc(ii) = abs(dot_product(fs%vkq(:, im_kq), fs%kmesh_cartvec(:,ii)))
4016 : : end do
4017 [ # # # # : 0 : sigma = max(maxval(abc), fs%min_smear)
# # ]
4018 : : end if
4019 [ # # ]: 0 : wt_ekq(:, im_kq) = gaussian(emesh - ebands%eig(band_kq, ikq_ibz, spin), sigma) / sqrt(one * fs%nktot)
4020 : : end do
4021 : :
4022 [ # # ]: 0 : do in_k=1,nb_k
4023 [ # # ]: 0 : do im_kq=1,nb_kq
4024 [ # # ]: 0 : do ipc2=1,natom3
4025 [ # # ]: 0 : do ipc1=1,natom3
4026 [ # # ]: 0 : lf = gkq_atm(:, im_kq, in_k, ipc1)
4027 [ # # ]: 0 : rg = gkq_atm(:, im_kq, in_k, ipc2)
4028 : 0 : res(1) = lf(1) * rg(1) + lf(2) * rg(2)
4029 : 0 : res(2) = lf(1) * rg(2) - lf(2) * rg(1)
4030 [ # # ]: 0 : do jene = 1, gams%nene
4031 [ # # ]: 0 : do iene = 1, gams%nene
4032 : : ! TODO: distribute this in procs over q. Make a temp array here for 1 q
4033 : : ! then mpi sync it and save it only on 1 processor below after mpisum over k
4034 : : tmp_vals_ee(:,iene,jene,ipc1,ipc2) = tmp_vals_ee(:,iene,jene,ipc1,ipc2) + &
4035 [ # # ]: 0 : res(:) * wt_ekq(iene, im_kq) * wt_ek(jene, in_k)
4036 : : end do
4037 : : end do
4038 : : end do
4039 : : end do
4040 : : end do
4041 : : end do
4042 : : end if ! prteliash == 3
4043 : :
4044 [ - + ]: 2864 : ABI_FREE(lambda)
4045 [ - + ]: 2864 : ABI_FREE(gkq_atm)
4046 : : #ifdef HAVE_OPENMP_OFFLOAD
4047 : : !$OMP TARGET EXIT DATA MAP(delete:gkq_atm_ipc) IF (dtset%gpu_option == ABI_GPU_OPENMP)
4048 : : #endif
4049 [ - + ]: 2864 : ABI_FREE(gkq_atm_ipc)
4050 : :
4051 [ + + ]: 2925 : if (print_time_k) then
4052 : 66 : write(msg,'(5x,2(a,i0),a)')"k-point [", my_ik, "/", gams%my_nfsk_q, "]"
4053 : 66 : call cwtime_report(msg, cpu_k, wall_k, gflops_k)
4054 : : end if
4055 : : end do ! imyk: sum over k-points on the BZ FS for this spin.
4056 : :
4057 [ - + ]: 61 : ABI_FREE(dbldelta_wts)
4058 [ - + ]: 61 : ABI_SFREE(wt_ek)
4059 [ - + ]: 61 : ABI_SFREE(wt_ekq)
4060 : :
4061 : : ! Collect tgam values inside kpt comm and divide by the total number of k-points in the full mesh.
4062 : 61 : call xmpi_sum(tgam, kpt_comm%value, ierr)
4063 : :
4064 : : ! Symmetrize gamma matrices (default). Note that this call is not executed in elphon!
4065 [ + - ]: 61 : if (gams%symgamma == 1) call tgamma_symm(cryst, gams%qibz(:,iq_ibz), tgam)
4066 : :
4067 : : ! Save results in gams.
4068 [ + + + + : 1891 : gams%vals_qibz(:,:,:,iq_ibz, spin) = tgam
+ + ]
4069 : :
4070 [ + - ]: 61 : if (dtset%eph_transport > 0) then
4071 [ - + ]: 61 : ABI_FREE(vv_kk)
4072 [ - + ]: 61 : ABI_FREE(vv_kkq)
4073 : 61 : call xmpi_sum(tgamvv_in, kpt_comm%value, ierr)
4074 : 61 : call xmpi_sum(tgamvv_out, kpt_comm%value, ierr)
4075 [ + + + + : 15616 : gams%vals_in_qibz(:,:,:,:,iq_ibz,spin) = tgamvv_in
+ + + + ]
4076 [ + + + + : 15616 : gams%vals_out_qibz(:,:,:,:,iq_ibz,spin) = tgamvv_out
+ + + + ]
4077 : : end if
4078 : :
4079 [ - + ]: 183 : if (dtset%prteliash == 3) then
4080 : 0 : call xmpi_sum(tmp_vals_ee, kpt_comm%value, ierr)
4081 : : !TODO: write arrays to ncfile.
4082 [ # # # # : 0 : gams%vals_ee(:,:,:,:,:, iq_ibz, spin) = tmp_vals_ee
# # # # #
# ]
4083 [ # # ]: 0 : ABI_FREE(tmp_vals_ee)
4084 [ # # ]: 0 : ABI_FREE(emesh)
4085 : : end if
4086 : : end do ! spin
4087 : :
4088 [ - + ]: 61 : ABI_FREE(v1scf)
4089 [ - + ]: 61 : ABI_FREE(vlocal1)
4090 : :
4091 : 61 : write(msg,'(2(a,i0),a)')" Computation of q-point [", iq_ibz, "/", gams%nqibz, "]"
4092 : 127 : call cwtime_report(msg, cpu_q, wall_q, gflops_q, end_str=ch10)
4093 : : end do ! iq_ibz
4094 : :
4095 : 5 : call cwtime_report(" phonon linewidths q-loop", cpu_all, wall_all, gflops_all, end_str=ch10)
4096 : :
4097 : : ! Free memory
4098 [ - + ]: 5 : ABI_FREE(grad_berry)
4099 [ - + ]: 5 : ABI_FREE(dummy_vtrial)
4100 [ - + ]: 5 : ABI_FREE(work)
4101 [ - + ]: 5 : ABI_FREE(ph1d)
4102 [ - + ]: 5 : ABI_FREE(vlocal)
4103 [ - + ]: 5 : ABI_FREE(kg_k)
4104 [ - + ]: 5 : ABI_FREE(kg_kq)
4105 [ - + ]: 5 : ABI_FREE(tgam)
4106 [ - + ]: 5 : ABI_FREE(displ_cart)
4107 [ - + ]: 5 : ABI_FREE(displ_red)
4108 : : !ABI_FREE(qibz_done)
4109 [ + - ]: 5 : ABI_SFREE(vcart_ibz)
4110 : 5 : call krank%free()
4111 : :
4112 [ + - ]: 5 : ABI_SFREE(tgamvv_in)
4113 [ + - ]: 5 : ABI_SFREE(tgamvv_out)
4114 : 5 : call ddkop%free(); call gs_hamkq%free(); call wfd%free()
4115 [ + + ]: 10 : do spin=1,ebands%nsppol
4116 : 10 : call fstab(spin)%free()
4117 : : end do
4118 [ + - + + : 10 : ABI_FREE(fstab)
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + ]
4119 : 5 : call pawcprj_free(cwaveprj0)
4120 [ + - - + : 5 : ABI_FREE(cwaveprj0)
- - - - -
+ ]
4121 : :
4122 : : ! Collect results on each node
4123 : 5 : call cwtime(cpu_all, wall_all, gflops_all, "start")
4124 : 5 : call xmpi_sum(gams%vals_qibz, qs_comm%value, ierr)
4125 [ + - ]: 5 : if (dtset%eph_transport > 0) then
4126 : 5 : call xmpi_sum(gams%vals_in_qibz, qs_comm%value, ierr)
4127 : 5 : call xmpi_sum(gams%vals_out_qibz, qs_comm%value, ierr)
4128 : : end if
4129 [ - + ]: 5 : if (dtset%prteliash == 3) call xmpi_sum(gams%vals_ee, qs_comm%value, ierr)
4130 : 5 : call cwtime_report(" xmpi_sum", cpu_all, wall_all, gflops_all)
4131 : :
4132 : : ! Deallocate MPI communicators.
4133 : 5 : call pert_comm%free(); call qpt_comm%free(); call bsum_comm%free(); call qs_comm%free()
4134 : 5 : call kpt_comm%free(); call spin_comm%free(); call pkb_comm%free()
4135 : : !call ncwrite_comm%free()
4136 : :
4137 : : ! Print gamma(IBZ) to ab_out and ncid.
4138 [ + - ]: 5 : if (my_rank == master) call phgamma_ncwrite(gams, cryst, ifc, ncid)
4139 : :
4140 : : ! Interpolate linewidths along the q-path.
4141 [ - + ]: 5 : if (dtset%ph_nqpath <= 0) then
4142 : : write(msg, '(7a,es16.6,4a)' ) &
4143 : 0 : 'You have not specified a path for the linewidth calculation - no interpolation or output will be done ',ch10,&
4144 : 0 : 'Action: check your input variables ph_nqpath and ph_qpath'
4145 : 0 : ABI_WARNING(msg)
4146 : : else
4147 : 5 : call gams%linwid(cryst, ifc, dtset%ph_ndivsm, dtset%ph_nqpath, dtset%ph_qpath, dtfil%filnam_ds(4), ncid, wminmax, comm)
4148 : : end if
4149 : :
4150 : : ! Compute a2Fw using the ab-initio q-points (no interpolation here)
4151 : : call a2fw%init(gams, cryst, ifc, dtset%ph_intmeth, dtset%ph_wstep, wminmax, dtset%ph_smear, &
4152 : 5 : dtset%ph_ngqpt, dtset%ph_nqshift, dtset%ph_qshift, comm, qintp=.False., qptopt=1)
4153 : :
4154 [ + - ]: 5 : if (my_rank == master) then
4155 : 5 : call a2fw%write(strcat(dtfil%filnam_ds(4), "_NOINTP"), "_qcoarse", ncid)
4156 [ - + ]: 5 : if (dtset%prteliash == 3) call a2fw_ee_write(a2fw, strcat(dtfil%filnam_ds(4), "_NOINTP"))
4157 : : end if
4158 : 5 : call a2fw%free()
4159 : :
4160 : : ! Compute a2Fw using Fourier interpolation (R -> q) and ph_ngqpt grid.
4161 : : call a2fw%init(gams, cryst, ifc, dtset%ph_intmeth, dtset%ph_wstep, wminmax, dtset%ph_smear, &
4162 : 5 : dtset%ph_ngqpt, dtset%ph_nqshift, dtset%ph_qshift, comm, qptopt=1)
4163 : :
4164 [ + - ]: 5 : if (my_rank == master) then
4165 : 5 : call a2fw%write(dtfil%filnam_ds(4), "_qintp", ncid)
4166 [ - + ]: 5 : if (dtset%prteliash == 3) call a2fw_ee_write(a2fw, dtfil%filnam_ds(4))
4167 : : end if
4168 : :
4169 : 5 : call a2fw%free()
4170 : :
4171 : : ! Compute A2fw using Fourier interpolation and full BZ for debugging purposes.
4172 : : !call a2fw%init(gams, cryst, ifc, dtset%ph_intmeth, dtset%ph_wstep, wminmax, dtset%ph_smear,&
4173 : : ! dtset%ph_ngqpt, dtset%ph_nqshift, dtset%ph_qshift, comm, qptopt=3)
4174 : : !if (my_rank == master) call a2fw%write(strcat(dtfil%filnam_ds(4), "_A2FW_QPTOPT3"), "fake", nctk_noid)
4175 : : !call a2fw%free()
4176 : :
4177 [ + - ]: 5 : if (dtset%eph_transport == 1) then
4178 : : ! Calculate and output transport quantities
4179 : :
4180 : : ! Compute a2Fw_tr using ab-initio q-points (no interpolation)
4181 : : call a2fw_tr%init(gams, cryst, ifc, dtset%ph_intmeth, dtset%ph_wstep, wminmax, dtset%ph_smear,&
4182 : 5 : dtset%ph_ngqpt, dtset%ph_nqshift, dtset%ph_qshift, comm, qintp=.False., qptopt=1)
4183 : :
4184 [ + - ]: 5 : if (my_rank == master) call a2fw_tr%write(strcat(dtfil%filnam_ds(4), "_NOINTP"), "_qcoarse", ncid)
4185 : 5 : call a2fw_tr%free()
4186 : :
4187 : : ! Compute a2Fw_tr using Fourier interpolation (R --> q) and ph_ngqpt grid
4188 : : call a2fw_tr%init(gams, cryst, ifc, dtset%ph_intmeth, dtset%ph_wstep, wminmax, dtset%ph_smear,&
4189 : 5 : dtset%ph_ngqpt, dtset%ph_nqshift, dtset%ph_qshift, comm, qptopt=1)
4190 : :
4191 [ + - ]: 5 : if (my_rank == master) call a2fw_tr%write(dtfil%filnam_ds(4), "_qintp", ncid)
4192 : 5 : call a2fw_tr%free()
4193 : :
4194 : : ! Compute A2fw_tr using Fourier interpolation and full BZ for debugging purposes.
4195 : : !call a2fw_tr%init(gams, cryst, ifc, dtset%ph_intmeth, dtset%ph_wstep, wminmax, dtset%ph_smear,&
4196 : : ! dtset%ph_ngqpt, dtset%ph_nqshift, dtset%ph_qshift, comm, qptopt=3)
4197 : : !if (my_rank == master) call a2fw_tr%write(strcat(dtfil%filnam_ds(4), "_A2FWTR_QPTOPT3"), "fake", nctk_noid)
4198 : : !call a2fw_tr%free()
4199 : : end if
4200 : :
4201 [ + - ]: 5 : if (my_rank == master) then
4202 [ - + ]: 5 : NCF_CHECK(nf90_close(ncid))
4203 : : end if
4204 : :
4205 : 5 : call gams%free()
4206 : :
4207 [ - + - + : 115 : end subroutine eph_phgamma
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - -
- - - - -
- - - - -
- - - + -
- - - - -
- - - - -
- - - - -
- - - - -
- - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
- - - - +
- - - - -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + + + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + + + -
+ - + + +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - - -
- - - - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + ]
4208 : : !!***
4209 : :
4210 : : !----------------------------------------------------------------------
4211 : :
4212 : : !!****f* m_phgamma/phgamma_setup_qpoint
4213 : : !! NAME
4214 : : !! phgamma_setup_qpoint
4215 : : !!
4216 : : !! FUNCTION
4217 : : !!
4218 : : !! SOURCE
4219 : :
4220 : 61 : subroutine phgamma_setup_qpoint(gams, fs, cryst, ebands, spin, ltetra, qpt, nesting, comm)
4221 : :
4222 : : !Arguments ------------------------------------
4223 : : class(phgamma_t),intent(inout) :: gams
4224 : : type(fstab_t),intent(inout) :: fs
4225 : : type(crystal_t),intent(in) :: cryst
4226 : : type(ebands_t),intent(in) :: ebands
4227 : : integer,intent(in) :: spin, ltetra, comm
4228 : : integer,intent(out) :: nesting
4229 : : !arrays
4230 : : real(dp),intent(in) :: qpt(3)
4231 : :
4232 : : !Local variables-------------------------------
4233 : : !scalars
4234 : : integer,parameter :: enough = 5
4235 : : integer :: nkbz, ierr, nb, ik_bz, ik_ibz, ikq_ibz, ikq_fs, ik_fs, i1, i2, i3, nkfs_q, nene, ib1, ib2 ! band_k, band_kq
4236 : : real(dp),parameter :: max_occ1 = one
4237 : : real(dp) :: cpu, wall, gflops, enemin, enemax
4238 : : character(len=500) :: msg
4239 : 61 : type(krank_t) :: ibz_krank
4240 : 61 : type(t_tetrahedron) :: tetra
4241 : : character(len=80) :: errorstring
4242 : : !arrays
4243 : : integer :: nge(3), ngw(3), g0bz_kq(3)
4244 : 61 : integer,allocatable :: select_ikfs(:), indkpt(:), kbz2fs(:) !, symrecfm(:,:,:)
4245 : : real(dp) :: kk(3), kq(3)
4246 : 61 : real(dp),allocatable :: eig_k(:,:), eig_kq(:,:), wght_bz(:,:,:), kbz(:,:)
4247 : 61 : real(dp),allocatable :: work_k(:), work_kq(:), dtweightde(:,:,:), tweight(:,:,:)
4248 : : ! *************************************************************************
4249 : :
4250 : 61 : call cwtime(cpu, wall, gflops, "start")
4251 : :
4252 : : ! The double delta with tetra is ill-defined for q == 0. Set nesting to 1 and return
4253 : 61 : nesting = 0
4254 [ + + + + : 76 : if (abs(fs%eph_intmeth) == 2 .and. all(abs(qpt) < tol12)) then
+ + + + ]
4255 : 2 : ABI_COMMENT("Tetrahedron for double grid with q = 0 is ill-defined. Using adaptive gaussian.")
4256 : 2 : nesting = 1
4257 : : end if
4258 : :
4259 [ + + + + ]: 61 : if (fs%eph_intmeth == 1 .or. nesting == 1) then
4260 : : ! Gaussian method:
4261 : : ! Distribute k-points within the FS window inside comm.
4262 : : ! 1) Select k-points such that k+q is still inside the FS window
4263 : : ! 2) Distribute effective k-points assuming all procs in comm have all FS k-points (no filtering).
4264 [ - + + - : 78 : ABI_MALLOC(select_ikfs, (fs%nkfs))
+ - + - -
+ - + ]
4265 : 26 : nkfs_q = 0
4266 [ + + ]: 3614 : do ik_fs=1,fs%nkfs
4267 [ + + ]: 14352 : kq = fs%kpts(:, ik_fs) + qpt
4268 [ + + ]: 3588 : ikq_fs = fs%findkg0(kq, g0bz_kq); if (ikq_fs == -1) cycle
4269 : 1536 : nkfs_q = nkfs_q + 1
4270 : 3614 : select_ikfs(nkfs_q) = ik_fs
4271 : : end do
4272 [ + + ]: 26 : ABI_SFREE(gams%my_ifsk_q)
4273 [ - + ]: 26 : call xmpi_split_list(nkfs_q, select_ikfs, comm, gams%my_nfsk_q, gams%my_ifsk_q)
4274 [ - + ]: 26 : ABI_FREE(select_ikfs)
4275 : 26 : call cwtime_report(" phgamma_setup_qpoint", cpu, wall, gflops)
4276 : 26 : return
4277 : : end if
4278 : :
4279 : : ! Tetrahedron method:
4280 : : ! 1) Compute weights for double delta integration.
4281 : : ! 2) Filter k-points according to the weights (k must be in FS window with non-zero weight)
4282 : : ! 3) Distribute effective k-points assuming all procs have all FS k-points.
4283 : :
4284 [ + + + + : 33845 : fs%dbldelta_tetra_weights_kfs = zero
+ + ]
4285 : :
4286 [ - + ]: 35 : ABI_CHECK(isdiagmat(ebands%kptrlatt), "kptrlatt must be diagonal when tetra is used.")
4287 [ - + ]: 35 : ABI_CHECK(ebands%nshiftk == 1, "nshiftk must be 1 when tetra is used")
4288 : 35 : nge = get_diag(ebands%kptrlatt); ngw = nge
4289 [ + + ]: 140 : nkbz = product(nge(1:3))
4290 : :
4291 : : ! TODO: Handle symmetries in a cleaner way. Change API of krank_new to pass symafm and kptopt
4292 : : call ibz_krank%init(ebands%nkpt, ebands%kptns, nsym=cryst%nsym, symrec=cryst%symrec, &
4293 : 35 : time_reversal=kpts_timrev_from_kptopt(ebands%kptopt) == 1)
4294 : :
4295 : : ! Compute eig_k and eig_kq in full BZ for the relevant bands around Ef.
4296 : 35 : nb = fs%maxnb
4297 [ - + + - : 105 : ABI_MALLOC(kbz, (3, nkbz))
+ - + - -
+ - + ]
4298 [ - + + - : 105 : ABI_MALLOC(indkpt, (nkbz))
+ - + - -
+ - + ]
4299 [ - + + - : 140 : ABI_MALLOC(eig_k, (nb, nkbz))
- + + - +
- + - - +
- + ]
4300 [ - + + - : 105 : ABI_MALLOC(eig_kq, (nb, nkbz))
- + + - -
+ - + ]
4301 [ - + + - : 70 : ABI_MALLOC(kbz2fs, (nkbz))
- + - + ]
4302 : :
4303 [ + + ]: 17955 : kbz2fs = -1; ierr = 0; ik_bz = 0
4304 [ + + ]: 315 : do i3=0,nge(3) - 1
4305 [ + + ]: 2555 : do i2=0,nge(2) - 1
4306 [ + + ]: 20440 : do i1=0,nge(1) - 1
4307 : 17920 : ik_bz = ik_bz + 1
4308 : 17920 : indkpt(ik_bz) = ik_bz
4309 : :
4310 : : ! Find correspondence between libtetra mesh and the IBZ.
4311 [ + + ]: 71680 : kk = ([i1, i2, i3] + ebands%shiftk(:, 1)) / nge(:)
4312 [ + + ]: 71680 : kbz(:, ik_bz) = kk
4313 : :
4314 : 17920 : ik_fs = fs%krank%get_index(kk)
4315 [ + + ]: 17920 : if (ik_fs /= -1) then
4316 : 4830 : kbz2fs(ik_bz) = ik_fs
4317 : : else
4318 : : !ABI_ERROR(sjoin('kpt:', trim(ktoa(kk)), 'is not in FS!!'))
4319 : : end if
4320 : :
4321 : 17920 : ik_ibz = ibz_krank%get_index(kk)
4322 [ - + ]: 17920 : if (ik_ibz < 1) then
4323 [ # # ]: 0 : if (ierr <= enough) then
4324 [ # # ]: 0 : ABI_WARNING(sjoin('kpt:', trim(ktoa(kk)), 'has no symmetric among the k-points!'))
4325 : : end if
4326 : 0 : ierr = ierr + 1; cycle
4327 : : end if
4328 : :
4329 [ + + ]: 53760 : eig_k(:, ik_bz) = ebands%eig(fs%bmin:fs%bmax, ik_ibz, spin)
4330 : :
4331 : : ! Find correspondence between k+q in the BZ and the IBZ image.
4332 [ + + ]: 71680 : kq = kk + qpt
4333 : 17920 : ikq_ibz = ibz_krank%get_index(kq)
4334 : :
4335 [ - + ]: 17920 : if (ikq_ibz < 1) then
4336 [ # # ]: 0 : if (ierr <= enough) then
4337 [ # # ]: 0 : ABI_WARNING(sjoin('kpt + qpt:', trim(ktoa(kq)), 'has no symmetric among the k-points!'))
4338 : : end if
4339 : 0 : ierr = ierr + 1; cycle
4340 : : end if
4341 : :
4342 [ + + ]: 56000 : eig_kq(:, ik_bz) = ebands%eig(fs%bmin:fs%bmax, ikq_ibz, spin)
4343 : : end do
4344 : : end do
4345 : : end do
4346 : :
4347 [ - + ]: 35 : ABI_CHECK(ierr == 0, "See above warnings")
4348 : 35 : call ibz_krank%free()
4349 : :
4350 : 70 : select case (ltetra)
4351 : : case (1, 2)
4352 : : ! Use libtetra routines.
4353 : : ! Compute weights for double delta integration. Note that libtetra assumes Ef set to zero.
4354 : : ! TODO: Average weights over degenerate states?
4355 [ - + ]: 35 : if (ltetra == 1) call wrtout(std_out, " Using linear tetrahedron method from libtetrabz (ltetra: 1)")
4356 [ + - ]: 35 : if (ltetra == 2) call wrtout(std_out, " Using optimized tetrahedron method from libtetrabz (ltetra: 2)")
4357 [ + + + + : 107555 : eig_k = eig_k - ebands%fermie; eig_kq = eig_kq - ebands%fermie
+ + + + ]
4358 [ - + + - : 175 : ABI_MALLOC(wght_bz, (nb, nb, nkbz))
- + + - -
+ + - + -
+ - - + -
+ ]
4359 : 35 : call libtetrabz_dbldelta(ltetra, cryst%gprimd, nb, nge, eig_k, eig_kq, ngw, wght_bz, comm=comm)
4360 : : ! Revert changes to eig arrays
4361 [ + + + + ]: 53795 : eig_k = eig_k + ebands%fermie !; eig_kq = eig_kq + ebands%fermie
4362 : :
4363 : : ! Reindex from full BZ to fs% kpoints.
4364 [ + + ]: 17955 : do ik_bz=1,nkbz
4365 : 17920 : ik_fs = kbz2fs(ik_bz)
4366 [ + + ]: 17955 : if (ik_fs /= -1) then
4367 [ + + + + ]: 33810 : fs%dbldelta_tetra_weights_kfs(:,:,ik_fs) = wght_bz(:,:,ik_bz)
4368 : : else
4369 : : !write(std_out,*)"should be zero :", wght_bz(:,:,ik_bz)
4370 : : end if
4371 : : end do
4372 [ - + ]: 35 : ABI_FREE(wght_bz)
4373 : :
4374 : : case (3)
4375 : : ! Tetrahedron method with Allen's approach for double delta.
4376 : : ! WARNING: wrong results maybe bug somewhere.
4377 : 0 : call wrtout(std_out, " Calling Allen's version for q-point")
4378 : 0 : nene = 3
4379 : 0 : enemin = ebands%fermie - tol6
4380 : 0 : enemax = ebands%fermie + tol6
4381 : :
4382 [ # # # # : 0 : ABI_MALLOC(dtweightde, (nkbz, nene, nene))
# # # # #
# # # # #
# # ]
4383 [ # # # # : 0 : ABI_MALLOC(tweight, (nkbz, nene, nene))
# # # # #
# # # ]
4384 [ # # # # : 0 : ABI_MALLOC(work_k, (nkbz))
# # # # #
# # # ]
4385 [ # # # # : 0 : ABI_MALLOC(work_kq, (nkbz))
# # # # ]
4386 : :
4387 : 0 : call init_tetra(indkpt, cryst%gprimd, fs%klatt, kbz, nkbz, tetra, ierr, errorstring, comm)
4388 [ # # ]: 0 : ABI_CHECK(ierr == 0, "init_tetra returned ierr /= 0")
4389 : :
4390 [ # # # # : 0 : fs%dbldelta_tetra_weights_kfs = zero
# # ]
4391 [ # # ]: 0 : do ib2=1,nb
4392 [ # # # # ]: 0 : work_k = eig_k(ib2, :)
4393 [ # # ]: 0 : do ib1=1,nb
4394 [ # # # # ]: 0 : work_kq = eig_kq(ib1, :)
4395 : : ! TODO: Average weights over degenerate states?
4396 : : call get_dbl_tetra_weight(work_k, work_kq, enemin, enemax, enemin, enemax, &
4397 : 0 : max_occ1, nene, nene, nkbz, tetra, tweight, dtweightde, ierr)
4398 [ # # ]: 0 : ABI_CHECK(ierr == 0, "get_dbldelta_weights returned ierr /= 0")
4399 : :
4400 : : ! Reindex from full BZ to fs% kpoints.
4401 [ # # ]: 0 : do ik_bz=1,nkbz
4402 : 0 : ik_fs = kbz2fs(ik_bz)
4403 [ # # ]: 0 : if (ik_fs /= -1) then
4404 : 0 : fs%dbldelta_tetra_weights_kfs(ib1,ib2,ik_fs) = dtweightde(ik_bz, 2, 2) ! / nkbz
4405 : : else
4406 : : !write(std_out,*)"should be zero :", wght_bz(:,:,ik_bz)
4407 : : end if
4408 : : end do
4409 : : end do
4410 : : end do
4411 : :
4412 : 0 : call destroy_tetra(tetra)
4413 [ # # ]: 0 : ABI_FREE(work_k)
4414 [ # # ]: 0 : ABI_FREE(work_kq)
4415 [ # # ]: 0 : ABI_FREE(dtweightde)
4416 [ # # ]: 0 : ABI_FREE(tweight)
4417 : :
4418 : : case default
4419 [ + - - ]: 35 : ABI_ERROR(sjoin("Invalid value of ltetra:", itoa(ltetra)))
4420 : : end select
4421 : :
4422 : : ! Now we can filter the k-points according to the tetra weights and distribute them inside comm.
4423 : : ! Assuming all procs in comm have all k-points in the IBZ.
4424 : : ! nkfs_q is the total number of BZ k-points on the FS contributing for this q-point.
4425 [ - + + - : 105 : ABI_MALLOC(select_ikfs, (fs%nkfs))
+ - + - -
+ - + ]
4426 : 35 : nkfs_q = 0
4427 [ + + ]: 4865 : do ik_fs=1,fs%nkfs
4428 [ + + + + : 6079 : if (any(abs(fs%dbldelta_tetra_weights_kfs(:,:,ik_fs)) > zero)) then
+ + + + ]
4429 : 4668 : nkfs_q = nkfs_q + 1; select_ikfs(nkfs_q) = ik_fs
4430 : : end if
4431 : : end do
4432 : :
4433 : : ! Here we compute my_ifsk_q.
4434 [ + - ]: 35 : ABI_SFREE(gams%my_ifsk_q)
4435 [ - + ]: 35 : call xmpi_split_list(nkfs_q, select_ikfs, comm, gams%my_nfsk_q, gams%my_ifsk_q)
4436 [ - + ]: 35 : ABI_FREE(select_ikfs)
4437 : :
4438 : : !write(std_out,"(2(a,i0),/)")" Treating ", gams%my_nfsk_q, " my k-points in the FS window over total nkfs: ", fs%nkfs
4439 : :
4440 : : write(msg, "(2(a,i0),a)") &
4441 : 35 : " Number of k-points in the FS window treated by me: ", gams%my_nfsk_q, " over: ", nkfs_q, ch10
4442 : : !" Number of MPI procs in kpt_comm: ", gams%kpt_comm%nproc
4443 : 35 : call wrtout(std_out, msg)
4444 : :
4445 [ - + ]: 35 : ABI_FREE(kbz2fs)
4446 [ - + ]: 35 : ABI_FREE(indkpt)
4447 [ - + ]: 35 : ABI_FREE(kbz)
4448 [ - + ]: 35 : ABI_FREE(eig_k)
4449 [ - + ]: 35 : ABI_FREE(eig_kq)
4450 : :
4451 : 35 : call cwtime_report(sjoin(" phgamma_setup_qpoint for spin:", itoa(spin)), cpu, wall, gflops)
4452 : :
4453 [ - + - + : 122 : end subroutine phgamma_setup_qpoint
- + - + -
+ - + - +
- + ]
4454 : : !!***
4455 : :
4456 : : !----------------------------------------------------------------------
4457 : :
4458 : : !!****f* m_phgamma/find_ewin
4459 : : !! NAME
4460 : : !! find_ewin
4461 : : !!
4462 : : !! FUNCTION
4463 : : !! Use bisection to find the optimal energy window around the Fermi level
4464 : : !!
4465 : : !! SOURCE
4466 : :
4467 : 0 : subroutine find_ewin(nqibz, qibz, cryst, ebands, ltetra, fs_ewin, comm)
4468 : :
4469 : : !Arguments ------------------------------------
4470 : : integer,intent(in) :: nqibz
4471 : : type(crystal_t),intent(in) :: cryst
4472 : : type(ebands_t),intent(in) :: ebands
4473 : : integer,intent(in) :: ltetra, comm
4474 : : real(dp),intent(out) :: fs_ewin
4475 : : !arrays
4476 : : real(dp),intent(in) :: qibz(3, nqibz)
4477 : :
4478 : : !Local variables-------------------------------
4479 : : !scalars
4480 : : integer,parameter :: master = 0
4481 : : integer :: my_rank, iq_ibz, spin, ii, unt
4482 : : real(dp) :: cpu, wall, gflops
4483 : : character(len=500) :: msg
4484 : : !arrays
4485 : : integer :: bstarts(3), bstops(3)
4486 : : real(dp) :: elows(3), ehighs(3), ewins(3), qsums(3)
4487 : 0 : real(dp), allocatable :: wtqs(:,:,:)
4488 : : ! *************************************************************************
4489 : :
4490 : 0 : call cwtime(cpu, wall, gflops, "start")
4491 : 0 : my_rank = xmpi_comm_rank(comm)
4492 : :
4493 : 0 : unt = -1
4494 [ # # ]: 0 : if (xmpi_comm_rank(comm) == master) then
4495 [ # # ]: 0 : if (open_file("tetra.dat", msg, newunit=unt, action="write", form="formatted", status="unknown") /= 0) then
4496 : 0 : ABI_ERROR(msg)
4497 : : end if
4498 : : end if
4499 : :
4500 : : ! 1 is low, 2 is high, 3 is for the workspace
4501 [ # # # # : 0 : ABI_MALLOC(wtqs, (nqibz, ebands%nsppol, 3))
# # # # #
# # # # #
# # # # ]
4502 : 0 : ewins(1) = half * eV_Ha; elows(1) = ebands%fermie - ewins(1); ehighs(1) = ebands%fermie + ewins(1)
4503 : 0 : call ebands%get_bands_from_erange(elows(1), ehighs(1), bstarts(1), bstops(1))
4504 : 0 : call calc_dbldelta(cryst, ebands, ltetra, bstarts(1), bstops(1), nqibz, qibz, wtqs(:,:,1), comm)
4505 [ # # ]: 0 : if (unt /= -1) write(unt, *) wtqs(:,:,1)
4506 : :
4507 : : !ewins(2) = five * eV_Ha; elows(2) = ebands%fermie - ewins(2); ehighs(2) = ebands%fermie + ewins(2)
4508 : : ewins(2) = two * eV_Ha; elows(2) = ebands%fermie - ewins(2); ehighs(2) = ebands%fermie + ewins(2)
4509 : 0 : ewins(2) = one * eV_Ha; elows(2) = ebands%fermie - ewins(2); ehighs(2) = ebands%fermie + ewins(2)
4510 : 0 : call ebands%get_bands_from_erange(elows(2), ehighs(2), bstarts(2), bstops(2))
4511 : 0 : call calc_dbldelta(cryst, ebands, ltetra, bstarts(2), bstops(2), nqibz, qibz, wtqs(:,:,2), comm)
4512 [ # # ]: 0 : if (unt /= -1) write(unt, *) wtqs(:,:,2)
4513 : :
4514 [ # # # # : 0 : if (abs(sum(abs(wtqs(:,:,1)) - sum(abs(wtqs(:,:,2))))) / sum(abs(wtqs(:,:,2))) < tol2) then
# # # # #
# # # #
# ]
4515 : 0 : fs_ewin = ewins(1)
4516 : 0 : call print_weights_index(1); goto 100
4517 : : end if
4518 : :
4519 : : ! Bisection part.
4520 : 0 : do
4521 : 0 : ewins(3) = (ewins(1) + ewins(2)) / two; elows(3) = ebands%fermie - ewins(3); ehighs(3) = ebands%fermie + ewins(3)
4522 : 0 : call ebands%get_bands_from_erange(elows(3), ehighs(3), bstarts(3), bstops(3))
4523 : 0 : call calc_dbldelta(cryst, ebands, ltetra, bstarts(3), bstops(3), nqibz, qibz, wtqs(:,:,3), comm)
4524 [ # # ]: 0 : if (unt /= -1) write(unt, *) wtqs(:,:,3)
4525 : :
4526 [ # # ]: 0 : do ii=1,3
4527 [ # # # # ]: 0 : qsums(ii) = sum(abs(wtqs(:,:,ii))) / nqibz
4528 : : end do
4529 : :
4530 : 0 : write(std_out,*)qsums(1), ", for ewins(1)_eV", ewins(1) * Ha_eV, " bstart(1)", bstarts(1), " bstopt(1)", bstops(1)
4531 : 0 : write(std_out,*)qsums(2), ", for ewins(2)_eV", ewins(2) * Ha_eV, " bstart(1)", bstarts(2), " bstopt(1)", bstops(2)
4532 : 0 : write(std_out,*)qsums(3), ", for ewins(3)_eV", ewins(3) * Ha_eV, " bstart(1)", bstarts(3), " bstopt(1)", bstops(3)
4533 : :
4534 : : !if (abs(sum(abs(wtqs(:,:,3)) - sum(abs(wtqs(:,:,2))))) / sum(abs(wtqs(:,:,2))) < tol3) then
4535 : : ! ! If 3 is close to 2, try to reduce the window by moving towards 1
4536 : : ! ewins(2) = ewins(3); elows(2) = elows(3); ehighs(2) = ehighs(3)
4537 : :
4538 [ # # ]: 0 : if (abs(qsums(3) - qsums(2)) / qsums(2) < tol2) then
4539 : 0 : fs_ewin = ewins(3)
4540 : 0 : call print_weights_index(3)
4541 : 0 : exit
4542 : :
4543 : : else
4544 : 0 : ewins(1) = ewins(3); elows(1) = elows(3); ehighs(1) = ehighs(3)
4545 : : end if
4546 : :
4547 : : end do
4548 : :
4549 : : 100 continue
4550 [ # # ]: 0 : ABI_FREE(wtqs)
4551 [ # # ]: 0 : if (unt /= -1) close(unt)
4552 : :
4553 : 0 : call cwtime_report(" find_ewin", cpu, wall, gflops)
4554 : :
4555 : : contains
4556 : :
4557 : 0 : subroutine print_weights_index(ind)
4558 : :
4559 : : integer,intent(in) :: ind
4560 : :
4561 [ # # ]: 0 : if (my_rank == master) then
4562 : 0 : write(std_out, "(a, f8.3, a)")" Optimal FS energy window: ", fs_ewin * Ha_eV, " (eV)"
4563 [ # # ]: 0 : do iq_ibz=1,nqibz
4564 [ # # ]: 0 : write(std_out, "(2a)")" For q-point:", trim(ktoa(qibz(:, iq_ibz)))
4565 [ # # ]: 0 : do spin=1,ebands%nsppol
4566 : 0 : write(std_out, *) wtqs(iq_ibz, spin, ind)
4567 : : end do
4568 : : end do
4569 : : end if
4570 : :
4571 : 0 : end subroutine print_weights_index
4572 : :
4573 : : end subroutine find_ewin
4574 : : !!***
4575 : :
4576 : : !----------------------------------------------------------------------
4577 : :
4578 : : !!****f* m_phgamma/calc_dbldelta
4579 : : !! NAME
4580 : : !! calc_dbldelta
4581 : : !!
4582 : : !! FUNCTION
4583 : : !! Compute Tetrahedron weights for the double delta.
4584 : : !!
4585 : : !! SOURCE
4586 : :
4587 : 0 : subroutine calc_dbldelta(cryst, ebands, ltetra, bstart, bstop, nqibz, qibz, wtqs, comm)
4588 : :
4589 : : !Arguments ------------------------------------
4590 : : type(crystal_t),intent(in) :: cryst
4591 : : type(ebands_t),intent(in) :: ebands
4592 : : integer,intent(in) :: ltetra, bstart, bstop, nqibz, comm
4593 : : !arrays
4594 : : real(dp),intent(in) :: qibz(3,nqibz)
4595 : : real(dp),intent(out) :: wtqs(nqibz, ebands%nsppol)
4596 : :
4597 : : !Local variables-------------------------------
4598 : : !scalars
4599 : : integer,parameter :: enough = 50
4600 : : integer :: nkbz, ierr, nb, ik_bz, ik_ibz, ikq_ibz, i1, i2, i3, nene, spin, iq_ibz
4601 : : integer :: ib1, ib2, my_rank, nproc, cnt
4602 : : real(dp),parameter :: max_occ1 = one
4603 : : real(dp) :: enemin, enemax !cpu, wall, gflops,
4604 : : !character(len=500) :: msg
4605 : 0 : type(krank_t) :: ibz_krank
4606 : 0 : type(t_tetrahedron) :: tetra
4607 : : !character(len=80) :: errorstring
4608 : : !arrays
4609 : : integer :: nge(3), ngw(3)
4610 : 0 : integer,allocatable :: indkpt(:) !, symrecfm(:,:,:)
4611 : : real(dp) :: qpt(3), kk(3), kq(3)
4612 : 0 : real(dp),allocatable :: eig_k(:,:), eig_kq(:,:), wght_bz(:,:,:), kbz(:,:)
4613 : 0 : real(dp),allocatable :: work_k(:), work_kq(:), dtweightde(:,:,:), tweight(:,:,:)
4614 : : ! *************************************************************************
4615 : :
4616 : 0 : my_rank = xmpi_comm_rank(comm); nproc = xmpi_comm_size(comm)
4617 : : !call cwtime(cpu, wall, gflops, "start")
4618 : :
4619 [ # # ]: 0 : ABI_CHECK(nqibz > 1, "Need more that 1 q-point")
4620 [ # # ]: 0 : ABI_CHECK(isdiagmat(ebands%kptrlatt), "kptrlatt must be diagonal when tetra is used.")
4621 [ # # ]: 0 : ABI_CHECK(ebands%nshiftk == 1, "nshiftk must be 1 when tetra is used")
4622 : 0 : nge = get_diag(ebands%kptrlatt); ngw = nge
4623 [ # # ]: 0 : nkbz = product(nge(1:3))
4624 : :
4625 : : ! TODO: Handle symmetries in a cleaner way. Change API of krank_new to pass symafm and kptopt
4626 : : call ibz_krank%init(ebands%nkpt, ebands%kptns, nsym=cryst%nsym, symrec=cryst%symrec, &
4627 : 0 : time_reversal=kpts_timrev_from_kptopt(ebands%kptopt) == 1)
4628 : :
4629 : 0 : nb = bstop - bstart + 1
4630 [ # # # # : 0 : ABI_MALLOC(kbz, (3, nkbz))
# # # # #
# # # ]
4631 [ # # # # : 0 : ABI_MALLOC(indkpt, (nkbz))
# # # # #
# # # ]
4632 [ # # # # : 0 : ABI_MALLOC(eig_k, (nb, nkbz))
# # # # #
# # # # #
# # ]
4633 [ # # # # : 0 : ABI_MALLOC(eig_kq, (nb, nkbz))
# # # # #
# # # ]
4634 : :
4635 [ # # # # ]: 0 : wtqs = zero; cnt = 0
4636 [ # # ]: 0 : do spin=1,ebands%nsppol
4637 [ # # ]: 0 : do iq_ibz=1,nqibz
4638 [ # # ]: 0 : cnt = cnt + 1; if (mod(cnt, nproc) /= my_rank) cycle ! MPI parallelism.
4639 [ # # ]: 0 : qpt = qibz(:, iq_ibz)
4640 : :
4641 : : ! The double delta is ill-defined for q == 0
4642 [ # # # # : 0 : if (all(abs(qpt) < tol12)) cycle
# # ]
4643 : :
4644 : 0 : ierr = 0; ik_bz = 0
4645 [ # # ]: 0 : do i3=0,nge(3) - 1
4646 [ # # ]: 0 : do i2=0,nge(2) - 1
4647 [ # # ]: 0 : do i1=0,nge(1) - 1
4648 : 0 : ik_bz = ik_bz + 1
4649 : 0 : indkpt(ik_bz) = ik_bz
4650 : :
4651 : : ! Find correspondence between the grid and the IBZ
4652 [ # # ]: 0 : kk = ([i1, i2, i3] + ebands%shiftk(:, 1)) / nge(:)
4653 [ # # ]: 0 : kbz(:, ik_bz) = kk
4654 : :
4655 : 0 : ik_ibz = ibz_krank%get_index(kk)
4656 [ # # ]: 0 : if (ik_ibz < 1) then
4657 [ # # ]: 0 : if (ierr <= enough) then
4658 [ # # ]: 0 : ABI_WARNING(sjoin('kpt:', trim(ktoa(kk)), 'has no symmetric among the k-points!'))
4659 : : end if
4660 : 0 : ierr = ierr + 1; cycle
4661 : : end if
4662 : :
4663 [ # # ]: 0 : eig_k(:, ik_bz) = ebands%eig(bstart:bstop, ik_ibz, spin)
4664 : :
4665 : : ! Find correspondence between the BZ grid and the IBZ.
4666 [ # # ]: 0 : kq = kk + qpt
4667 : 0 : ikq_ibz = ibz_krank%get_index(kq)
4668 : :
4669 [ # # ]: 0 : if (ikq_ibz < 1) then
4670 [ # # ]: 0 : if (ierr <= enough) then
4671 [ # # ]: 0 : ABI_WARNING(sjoin('kpt + qpt:', trim(ktoa(kq)), 'has no symmetric among the k-points!'))
4672 : : end if
4673 : 0 : ierr = ierr + 1; cycle
4674 : : end if
4675 : :
4676 [ # # ]: 0 : eig_kq(:, ik_bz) = ebands%eig(bstart:bstop, ikq_ibz, spin)
4677 : : end do
4678 : : end do
4679 : : end do
4680 [ # # ]: 0 : ABI_CHECK(ierr == 0, "See above warnings")
4681 : :
4682 [ # # ]: 0 : if (any(ltetra == [1, 2])) then
4683 : : ! Compute weights for double delta integration. Note that libtetra assumes Ef set to zero.
4684 : : ! TODO: Average weights over degenerate states?
4685 : : !write(std_out,"(a,i0,2a)")" Calling libtetrabz_dbldelta with ltetra: ", ltetra, " for q-point:", trim(ktoa(qpt))
4686 [ # # # # : 0 : eig_k = eig_k - ebands%fermie; eig_kq = eig_kq - ebands%fermie
# # # # ]
4687 [ # # # # : 0 : ABI_MALLOC(wght_bz, (nb, nb, nkbz))
# # # # #
# # # # #
# # # # #
# ]
4688 : 0 : call libtetrabz_dbldelta(ltetra, cryst%gprimd, nb, nge, eig_k, eig_kq, ngw, wght_bz, comm=comm)
4689 [ # # # # ]: 0 : eig_k = eig_k + ebands%fermie !; eig_kq = eig_kq + ebands%fermie
4690 : :
4691 [ # # # # : 0 : wtqs(iq_ibz, spin) = sum(abs(wght_bz))
# # ]
4692 [ # # ]: 0 : ABI_FREE(wght_bz)
4693 : :
4694 [ # # ]: 0 : else if (ltetra == 3) then
4695 : : ! Tetrahedron method with Allen's approach for double delta.
4696 : : !write(std_out,"(2a)")" Calling Allen's version for q-point: ", trim(ktoa(qpt))
4697 : 0 : nene = 3
4698 : 0 : enemin = ebands%fermie - tol6
4699 : 0 : enemax = ebands%fermie + tol6
4700 : :
4701 [ # # # # : 0 : ABI_MALLOC(dtweightde, (nkbz, nene, nene))
# # # # #
# # # # #
# # ]
4702 [ # # # # : 0 : ABI_MALLOC(tweight, (nkbz, nene, nene))
# # # # #
# # # ]
4703 [ # # # # : 0 : ABI_MALLOC(work_k, (nkbz))
# # # # #
# # # ]
4704 [ # # # # : 0 : ABI_MALLOC(work_kq, (nkbz))
# # # # ]
4705 : :
4706 : : ! TODO
4707 : 0 : ABI_ERROR("Not Implemented")
4708 : : !call init_tetra(indkpt, cryst%gprimd, fs%klatt, kbz, nkbz, tetra, ierr, errorstring, comm)
4709 [ # # ]: 0 : ABI_CHECK(ierr == 0, "init_tetra returned ierr /= 0")
4710 : :
4711 : : !fs%dbldelta_tetra_weights_kfs = zero
4712 [ # # ]: 0 : do ib2=1,nb
4713 [ # # # # ]: 0 : work_k = eig_k(ib2, :)
4714 [ # # ]: 0 : do ib1=1,nb
4715 [ # # # # ]: 0 : work_kq = eig_kq(ib1, :)
4716 : : ! TODO: Average weights over degenerate states?
4717 : : call get_dbl_tetra_weight(work_k, work_kq, enemin, enemax, enemin, enemax, &
4718 : 0 : max_occ1, nene, nene, nkbz, tetra, tweight, dtweightde, ierr)
4719 [ # # ]: 0 : ABI_CHECK(ierr == 0, "get_dbldelta_weights returned ierr /= 0")
4720 : :
4721 [ # # ]: 0 : wtqs(iq_ibz, spin) = wtqs(iq_ibz, spin) + sum(abs(dtweightde(:, 2, 2)))
4722 : : end do
4723 : : end do
4724 : :
4725 : 0 : call destroy_tetra(tetra)
4726 [ # # ]: 0 : ABI_FREE(work_k)
4727 [ # # ]: 0 : ABI_FREE(work_kq)
4728 [ # # ]: 0 : ABI_FREE(dtweightde)
4729 [ # # ]: 0 : ABI_FREE(tweight)
4730 : : else
4731 : 0 : ABI_ERROR(sjoin("Invalid value of ltetra:", itoa(ltetra)))
4732 : : end if
4733 : : end do ! iq_ibz
4734 : : end do ! spin
4735 : :
4736 [ # # ]: 0 : ABI_FREE(indkpt)
4737 [ # # ]: 0 : ABI_FREE(kbz)
4738 [ # # ]: 0 : ABI_FREE(eig_k)
4739 [ # # ]: 0 : ABI_FREE(eig_kq)
4740 : :
4741 : 0 : call ibz_krank%free()
4742 : 0 : call xmpi_sum(wtqs, comm, ierr)
4743 : : !call cwtime_report(" calc_dbldelta", cpu, wall, gflops)
4744 : :
4745 [ # # # # : 0 : end subroutine calc_dbldelta
# # # # #
# # # # #
# # ]
4746 : : !!***
4747 : :
4748 [ - + - - : 75 : end module m_phgamma
+ + - + +
- - + - +
+ - - + -
+ - + - +
- + - + -
+ - + - +
- + - + -
+ - + - +
- + ]
4749 : : !!***
|
