Line data Source code
1 : !!****m* ABINIT/m_elphon
2 : !! NAME
3 : !! m_elphon
4 : !!
5 : !! FUNCTION
6 : !! This routine extracts the electron phonon coupling matrix
7 : !! elements and calculates related properties - Tc, phonon linewidths...
8 : !!
9 : !! COPYRIGHT
10 : !! Copyright (C) 2004-2026 ABINIT group (MVer, BXu, MG, JPC)
11 : !! This file is distributed under the terms of the
12 : !! GNU General Public Licence, see ~abinit/COPYING
13 : !! or http://www.gnu.org/copyleft/gpl.txt .
14 : !! For the initials of contributors, see ~abinit/doc/developers/contributors.txt .
15 : !!
16 : !! SOURCE
17 :
18 : #if defined HAVE_CONFIG_H
19 : #include "config.h"
20 : #endif
21 :
22 : #include "abi_common.h"
23 :
24 : module m_elphon
25 :
26 : use defs_basis
27 : use defs_elphon
28 : use m_abicore
29 : use m_krank
30 : use m_errors
31 : use m_xmpi
32 : use m_hdr
33 : use m_ebands
34 :
35 : use m_fstrings, only : int2char4
36 : use m_io_tools, only : open_file, is_open, get_unit
37 : use m_time, only : timein
38 : use m_numeric_tools, only : wrap2_pmhalf, simpson, simpson_int
39 : use m_pptools, only : printvtk
40 : use m_dynmat, only : ftgam_init, ftgam
41 : use m_geometry, only : phdispl_cart2red
42 : use m_kpts, only : getkgrid, smpbz
43 : use m_crystal, only : crystal_t
44 : use m_ifc, only : ifc_type
45 : use m_nesting, only : mknesting, bfactor
46 : use m_anaddb_dataset, only : anaddb_dataset_type
47 : use m_eliashberg_1d, only : eliashberg_1d
48 : use m_iogkk, only : read_el_veloc, read_gkk
49 : use m_bz_mesh, only : make_path
50 : use m_epweights, only : d2c_weights, ep_el_weights, ep_fs_weights
51 : use m_a2ftr, only : mka2f_tr, mka2f_tr_lova, get_tau_k
52 : use m_symkpt, only : symkpt
53 :
54 : implicit none
55 :
56 : private
57 : !!***
58 :
59 : public :: elphon
60 :
61 : contains
62 :
63 : !!****f* m_elphon/elphon
64 : !!
65 : !! NAME
66 : !! elphon
67 : !!
68 : !! FUNCTION
69 : !! This routine extracts the electron phonon coupling matrix
70 : !! elements and calculates related properties - Tc, phonon linewidths...
71 : !!
72 : !! INPUTS
73 : !! anaddb_dtset=dataset with input variables
74 : !! anaddb_dtset%a2fsmear = smearing for alpha2F function
75 : !! anaddb_dtset%brav = type of Bravais lattice
76 : !! anaddb_dtset%elphsmear = smearing width for gaussian integration
77 : !! or buffer in energy for calculations with tetrahedra (telphint=0)
78 : !! anaddb_dtset%elph_fermie = input value of Fermi energy
79 : !! 0 means use value from wfk file
80 : !! anaddb_dtset%enunit = governs the units to be used for the output of
81 : !! the phonon frequencies and e-ph quantities
82 : !! anaddb_dtset%gkk2write= flag to write out gkk2 matrix elements to disk
83 : !! anaddb_dtset%gkk_rptwrite= flag to write out real space gkk_rpt matrix elements to disk
84 : !! anaddb_dtset%gkqwrite= flag to write out gkq matrix elements to disk
85 : !! anaddb_dtset%ep_b_min= first band taken into account in FS integration (if telphint==2)
86 : !! anaddb_dtset%ep_b_max= last band taken into account in FS integration (if telphint==2)
87 : !! anaddb_dtset%prtfsurf = integer flag for the output of the Fermi surface (XCrysden file format)
88 : !! anaddb_dtset%prtnest = integer flag for the calculation of the nesting function
89 : !! anaddb_dtset%ifcflag = flag for IFC matrices in anaddb calling routine
90 : !! the IFCs are presumed to be known!
91 : !! anaddb_dtset%ifltransport= flag for transport properties (no=0: yes_LOVA=1; yes_nonLOVA=2 )
92 : !! anaddb_dtset%kptrlatt=kpoint grid generating vectors, as in abinit
93 : !! anaddb_dtset%kptrlatt_fine=kpoint grid generating vectors, for fine grid used in FS integration
94 : !! anaddb_dtset%mustar = parameter for Coulombic pseudo-potential in McMillan T_c calculation
95 : !! anaddb_dtset%ngqpt(3)=integers defining the number of points in the qpt sampling
96 : !! anaddb_dtset%nqpath=number of vertices in the path in reciprocal space, for band structure
97 : !! and phonon linewidth output
98 : !! anaddb_dtset%nqshft= number of shift vectors for defining the sampling of q points
99 : !! anaddb_dtset%ntemper = number of temperature points to calculate, from tempermin to
100 : !! tempermin+ntemper*temperinc
101 : !! anaddb_dtset%qpath=vertices in the path in reciprocal space, for band structure
102 : !! and phonon linewidth output
103 : !! anaddb_dtset%q1shft(3,4) =qpoint shifts considered
104 : !! anaddb_dtset%telphint = flag for integration over the FS with 0=tetrahedra 1=gaussians
105 : !! anaddb_dtset%tempermin = minimum temperature at which resistivity etc are calculated (in K)
106 : !! anaddb_dtset%temperinc = interval temperature grid on which resistivity etc are calculated (in K)
107 : !! anaddb_dtset%ep_keepbands = flag to keep gamma matrix dependence on electronic bands
108 : !! Cryst<crystal_t>=data type gathering info on the crystalline structure.
109 : !! Ifc<ifc_type>=Object containing the interatomic force constants.
110 : !! atmfrc = inter-atomic force constants from anaddb
111 : !! rpt(3,nprt) =canonical positions of R points in the unit cell
112 : !! nrpt =number of real space points used to integrate IFC (for interpolation of dynamical matrices)
113 : !! wghatm(natom,natom,nrpt) =Weight for the pair of atoms and the R vector
114 : !! anaddb_dtset%prefix_outdata=character strings giving file names
115 : !! comm=MPI communicator.
116 : !!
117 : !! OUTPUT
118 : !!
119 : !! NOTES
120 : !! inspired to a large extent by epcouple.f from the DecAFT package by J. Kay Dewhurst
121 : !! most inputs taken from mkifc.f
122 : !! in anaddb anaddb_dtset%ifcflag must be 1 such that the IFC are calculated in atmfrc prior to calling elphon
123 : !!
124 : !! brav not taken into account propely in all of the code. (MG?)
125 : !!
126 : !! could choose to make a full 3 dimensional kpt array (:,:,:). Easier for many operations
127 : !!
128 : !! SOURCE
129 :
130 15 : subroutine elphon(anaddb_dtset,Cryst,Ifc,comm)
131 :
132 : !Arguments ------------------------------------
133 : !scalars
134 : type(anaddb_dataset_type),intent(inout) :: anaddb_dtset
135 : type(crystal_t),intent(in) :: Cryst
136 : type(ifc_type),intent(inout) :: Ifc
137 : integer,intent(in) :: comm
138 :
139 : !Local variables-------------------------------
140 : !scalars
141 : integer,parameter :: timrev2=2,space_group0=0,master=0
142 : integer :: ikpt_fine,ierr,unitgkk, unit_epts,iband,ibandp,ii
143 : integer :: ikpt,jkpt,kkpt, ik1,ik2,ik3,nk1, nk2, nk3
144 : integer :: iqpt,isppol,n1wf,nband,natom,onegkksize
145 : integer :: timrev,unitfskgrid,qtor,idir,iFSkpq,symrankkpt,ikpt_irr
146 : integer :: ep_prt_wtk ! eventually to be made into an input variable
147 : integer :: fform,ie,ie1,ie2,i_start,i_end
148 : integer :: ssp,s1,s2,tmp_nenergy, top_vb,nproc,me
149 : integer :: nkpt_tmp
150 : real(dp) :: max_occ,realdp_ex,res !,ss
151 : real(dp) :: tcpu, twall, tcpui, twalli
152 : real(dp) :: e1, e2, btocm3,diff, omega_max
153 : real(dp) :: e_vb_max, e_cb_min, etemp_vb
154 : logical :: make_gkk2,use_afm,use_tr
155 : character(len=500) :: message
156 : character(len=fnlen) :: fname,elph_base_name,ddkfilename,gkk_fname
157 : character(len=fnlen) :: nestname
158 15 : type(elph_tr_type) :: elph_tr_ds
159 15 : type(elph_type) :: elph_ds
160 15 : type(hdr_type) :: hdr,hdr1
161 15 : type(ebands_t) :: Bst
162 : !arrays
163 : integer :: s1ofssp(4), s2ofssp(4)
164 : integer :: qptrlatt(3,3),kptrlatt_fine(3,3)
165 15 : integer,allocatable :: indkpt1(:)
166 15 : integer,allocatable :: FSfullpqtofull(:,:)
167 15 : integer,allocatable :: qpttoqpt(:,:,:)
168 15 : integer,allocatable :: pair2red(:,:), red2pair(:,:), bz2ibz_smap(:,:)
169 : !real(dp) :: acell_in(3),rprim_in(3,3),rprim(3,3),acell(3),
170 : real(dp) :: kpt(3),shiftk(3)
171 15 : real(dp),allocatable :: wtk_fullbz(:),wtk_folded(:)
172 15 : real(dp),allocatable :: a2f_1d(:),dos_phon(:)
173 15 : real(dp),allocatable :: eigenGS(:,:,:),eigenGS_fine(:,:,:)
174 15 : real(dp),allocatable :: gam_qpt(:,:,:),gam_rpt(:,:,:)
175 15 : real(dp),allocatable :: v_surf(:,:,:,:,:,:)
176 15 : real(dp),allocatable :: tmp_veloc_sq1(:,:), tmp_veloc_sq2(:,:)
177 15 : real(dp),allocatable :: coskr(:,:), sinkr(:,:)
178 : ! *************************************************************************
179 :
180 1230 : write(message, '(a,a,(80a),a,a,a,a)' ) ch10,('=',ii=1,80),ch10,ch10,&
181 1245 : & ' Properties based on electron-phonon coupling ',ch10
182 15 : call wrtout(std_out,message,'COLL')
183 15 : call wrtout(ab_out,message,'COLL')
184 :
185 15 : call timein(tcpui,twalli)
186 : write(message, '(a,f11.3,a,f11.3,a)' )&
187 15 : & '-begin elphon at tcpu',tcpui,' and twall',twalli,' sec'
188 15 : call wrtout(std_out,message,'COLL')
189 :
190 15 : nproc = xmpi_comm_size(comm); me = xmpi_comm_rank(comm)
191 :
192 15 : write(message, '(a,i0,a,i0)' )'- running on ', nproc,' cpus me = ', me
193 15 : call wrtout(std_out,message,'PERS')
194 15 : write(std_out,*) message
195 :
196 : !==================================
197 : !Initialization of some variables
198 : !==================================
199 :
200 15 : if (master == me) then
201 15 : gkk_fname = anaddb_dtset%filename_gkk
202 15 : ABI_CHECK(len_trim(gkk_fname) > 0, "gkk_fname is not defined")
203 15 : if (open_file(gkk_fname,message,newunit=unitgkk,form="unformatted",status="old",action="read") /=0) then
204 0 : ABI_ERROR(message)
205 : end if
206 : end if
207 :
208 15 : elph_base_name=trim(anaddb_dtset%prefix_outdata)//"_ep"
209 15 : ddkfilename=trim(anaddb_dtset%filename_ddk)
210 15 : ABI_CHECK(len_trim(ddkfilename) > 0, "ddkfilename is not defined")
211 :
212 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
213 :
214 15 : natom = Cryst%natom
215 15 : elph_ds%mustar = anaddb_dtset%mustar ! input mustar
216 15 : elph_ds%nbranch = 3*natom ! number of phonon modes = 3 * natom
217 15 : elph_ds%natom = natom !
218 15 : elph_ds%ep_keepbands = anaddb_dtset%ep_keepbands ! flag to sum over bands
219 15 : elph_ds%a2fsmear = anaddb_dtset%a2fsmear ! smearing for Eliashberg functions
220 15 : elph_ds%elphsmear = anaddb_dtset%elphsmear ! smearing for Eliashberg functions
221 15 : elph_ds%ep_b_min = anaddb_dtset%ep_b_min
222 15 : elph_ds%ep_b_max = anaddb_dtset%ep_b_max
223 15 : elph_ds%telphint = anaddb_dtset%telphint
224 195 : elph_ds%kptrlatt = anaddb_dtset%kptrlatt
225 195 : elph_ds%kptrlatt_fine= anaddb_dtset%kptrlatt_fine
226 15 : elph_ds%tempermin = anaddb_dtset%tempermin
227 15 : elph_ds%temperinc = anaddb_dtset%temperinc
228 15 : elph_ds%ntemper = anaddb_dtset%ntemper
229 15 : elph_ds%use_k_fine = anaddb_dtset%use_k_fine
230 15 : elph_ds%ep_int_gkk = anaddb_dtset%ep_int_gkk
231 15 : elph_ds%ep_nspline = anaddb_dtset%ep_nspline
232 15 : elph_ds%ep_scalprod = anaddb_dtset%ep_scalprod
233 15 : elph_ds%prtbltztrp = anaddb_dtset%prtbltztrp
234 :
235 15 : elph_ds%tuniformgrid = 1
236 15 : elph_ds%na2f = 400 ! maximum number of Matsubara frequencies.
237 15 : elph_ds%ep_lova = 0 ! 1 for lova and 0 for general
238 15 : elph_ds%nenergy = 8
239 15 : btocm3 = 1.4818474347690475d-25
240 :
241 : !The nenergy needs to be 1) large enough to converge the integral, 2) greater
242 : !than the max phonon energy.
243 : !elph_ds%nenergy = INT(8*(anaddb_dtset%tempermin+anaddb_dtset%ntemper*anaddb_dtset%temperinc)/ &
244 : !& (anaddb_dtset%tempermin+anaddb_dtset%temperinc)) ! number of energy levels
245 :
246 15 : write(message,'(a,i6)')' The initial number of energy levels above/below Ef is set to be :',elph_ds%nenergy
247 15 : call wrtout(std_out,message,'COLL')
248 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
249 :
250 : !The precise number used depends on the value of Tc:
251 : !they span $w_n = (2n+1) \pi T_c$ where $abs(w_n) < w_{cutoff}$
252 : !ie $|n| < n_{cutoff} = ( \frac{w_{cutoff}}{\pi T_c} ) / 2$
253 :
254 : !save gkk data for full kpoints to file on disk
255 :
256 15 : elph_ds%gkqwrite = anaddb_dtset%gkqwrite
257 15 : elph_ds%gkk_rptwrite = anaddb_dtset%gkk_rptwrite
258 15 : elph_ds%gkk2write = anaddb_dtset%gkk2write
259 :
260 : !This should never be turned off: symmetrization of elphon matrix elements in complete_gkk. See get_all_gkq
261 15 : elph_ds%symgkq=anaddb_dtset%symgkq
262 :
263 15 : elph_ds%elph_base_name = trim(elph_base_name)
264 :
265 : !MG: @Matthieu: Why this? Now we should always use the value of rprim and acell reported in IFC
266 : !rprim_in = Ifc%rprim
267 : !acell_in = Ifc%acell
268 :
269 : !normalize input rprim and acell.
270 : !do ii=1,3
271 : ! ss = sqrt(rprim_in(1,ii)**2+rprim_in(2,ii)**2+rprim_in(3,ii)**2)
272 : ! rprim(:,ii) = rprim_in(:,ii)/ss
273 : ! acell(ii) = acell_in(ii) * ss
274 : !end do
275 :
276 : !make dimension-ful rprimd and gprimd for transformation of derivatives to cartesian coordinates.
277 : !call mkrdim(acell,rprim,rprimd)
278 : !call matr3inv(rprimd,gprimd)
279 :
280 : !rprimd = cryst%rprimd
281 : !gprimd = cryst%gprimd
282 :
283 : !===================
284 : !Check some inputs
285 : !===================
286 15 : if (Cryst%nsym==1) then
287 0 : write (message,'(7a)')ch10,&
288 0 : & ' elphon: COMMENT- ',ch10,&
289 0 : & ' Symmetries are not used! ',ch10,&
290 0 : & ' Full matrix elements must be supplied for all perturbations and qpoints!',ch10
291 0 : call wrtout(std_out,message,'COLL')
292 0 : call wrtout(ab_out,message,'COLL')
293 0 : if ( ANY( ABS(Cryst%tnons(:,1)) > tol10) ) then
294 0 : ABI_ERROR('nsym==1 but the symmetry is not the identity')
295 : end if
296 : end if
297 :
298 15 : if (anaddb_dtset%ifcflag/=1) then
299 : write(message,'(a,i0)')&
300 0 : & ' ifcflag should be set to 1 since the IFC matrices are supposed to exist but ifcflag= ',anaddb_dtset%ifcflag
301 0 : ABI_ERROR(message)
302 : end if
303 :
304 15 : call timein(tcpu,twall)
305 : write(message, '(a,f11.3,a,f11.3,a)' )&
306 15 : & '-elphon begin setup after tcpu',tcpu-tcpui,' and twall',twall-twalli,' sec'
307 15 : call wrtout(std_out,message,'COLL')
308 15 : tcpui = tcpu
309 15 : twalli = twall
310 :
311 : !=================================
312 : !Set up the full grid of qpoints
313 : !=================================
314 : !use time reversal symmetry always when possible for kpoint reduction,
315 : !and suppose it has been used in WF generation
316 : !not used for the moment: values are always taken from input files.
317 15 : timrev = 1
318 15 : call ep_setupqpt(elph_ds,cryst,anaddb_dtset,qptrlatt,timrev)
319 :
320 : !====================================
321 : !Read the GS header of the GKK file
322 : !this will give the phon grid of k
323 : !and the Fermi surface integration weights
324 : !====================================
325 15 : call wrtout (std_out,' elphon: reading and checking the GS header of the GKK file','COLL')
326 :
327 15 : if (master == me) then
328 15 : call rchkGSheader(hdr,natom,nband,unitgkk)
329 : end if
330 :
331 : !the following is for the non master nodes
332 15 : call hdr%bcast(master, me, comm)
333 15 : call xmpi_bcast(nband, master,comm,ierr)
334 15 : elph_ds%nband = nband
335 :
336 15 : elph_ds%nsppol =hdr%nsppol
337 15 : elph_ds%nspinor=hdr%nspinor
338 :
339 : !in spinor or spin polarized case, orbitals have occupation <= 1 instead of 2
340 15 : max_occ = one
341 15 : if (hdr%nspinor == 2) max_occ = half ! this accounts for the doubling of the num of bands, even though spin channels are not well defined
342 15 : if (elph_ds%nsppol > 1) max_occ = one
343 15 : write (std_out,*) ' max_occ factor ', max_occ
344 :
345 15 : elph_ds%occ_factor = one
346 15 : if (hdr%nspinor == 1 .and. hdr%nsppol == 1) then
347 : elph_ds%occ_factor = one
348 1 : else if (hdr%nspinor == 2) then
349 0 : elph_ds%occ_factor = two
350 : else if (hdr%nsppol == 2) then
351 : elph_ds%occ_factor = one
352 : end if
353 :
354 : !==================================================
355 : !Read GS eigenvalues for each irreducible kpt and
356 : !number of 1WF files contributing to the GKK file
357 : !==================================================
358 :
359 75 : ABI_MALLOC(eigenGS,(nband,hdr%nkpt,elph_ds%nsppol))
360 :
361 15 : if (master == me) then
362 31 : do isppol=1,elph_ds%nsppol
363 1351 : do ikpt=1,hdr%nkpt
364 1336 : read(unitgkk) eigenGS(:,ikpt,isppol)
365 : end do
366 : end do
367 :
368 : ! read number of 1WF files contributing to the GKK file
369 15 : read(unitgkk) n1wf
370 15 : write(message,'(a,i0)')' elphon : number of perturbations in the gkk file = ',n1wf
371 15 : call wrtout(std_out,message,'COLL')
372 : end if
373 15 : call xmpi_bcast(n1wf, master, comm, ierr)
374 15 : call xmpi_bcast(eigenGS, master, comm, ierr)
375 :
376 : !==================================================
377 : !Set elph_ds%fermie: either comes from anaddb input file or from wfk file
378 : !==================================================
379 15 : elph_ds%fermie = hdr%fermie
380 : !elph_ds%nelect = hdr_get_nelect_byocc(Hdr)
381 15 : elph_ds%nelect = Hdr%nelect
382 15 : if (abs(anaddb_dtset%elph_fermie) > tol10) then
383 2 : elph_ds%fermie = anaddb_dtset%elph_fermie
384 2 : write(message,'(a,E20.12)')' Fermi level set by the user at :',elph_ds%fermie
385 2 : call wrtout(std_out,message,'COLL')
386 2 : call Bst%from_hdr(Hdr,nband,eigenGS)
387 13 : else if (abs(anaddb_dtset%ep_extrael) > tol10) then
388 1 : if (abs(anaddb_dtset%ep_extrael) > 1.0d2) then
389 0 : write(message,'(a,E20.12)')' Doping set by the user is (negative for el doping) :',&
390 0 : & anaddb_dtset%ep_extrael
391 0 : call wrtout(std_out,message,'COLL')
392 0 : anaddb_dtset%ep_extrael = anaddb_dtset%ep_extrael*cryst%ucvol*btocm3*(-1.0d0)
393 : end if
394 1 : write(message,'(a,E20.12)')' Additional electrons per unit cell set by the user at :',&
395 2 : & anaddb_dtset%ep_extrael
396 1 : call wrtout(std_out,message,'COLL')
397 1 : elph_ds%nelect = elph_ds%nelect + anaddb_dtset%ep_extrael
398 1 : call bst%from_hdr(Hdr,nband,eigenGS,nelect=elph_ds%nelect)
399 :
400 : ! set Bst to use FD occupations:
401 1 : Bst%occopt = 3
402 : ! Bst%tsmear = 0.00001_dp ! is this small etol9 Bst%tsmeatol90001_dp ! last used
403 1 : Bst%tsmear = tol9 ! is this small etol9 Bst%tsmeatol90001_dp ! last used
404 : ! Calculate occupation numbers.
405 1 : call Bst%update_occ(-99.99_dp)
406 1 : write(message,'(a,E20.12)')' Fermi level is now calculated to be :',Bst%fermie
407 1 : call wrtout(std_out,message,'COLL')
408 1 : elph_ds%fermie = BSt%fermie
409 : else
410 12 : call bst%from_hdr(Hdr,nband,eigenGS)
411 : end if
412 15 : call wrtout(std_out,message,'COLL')
413 :
414 : !====================================================================
415 : !Setup of the phon k-grid :
416 : !1) get bands near Ef
417 : !====================================================================
418 : call get_fs_bands(eigenGS,hdr,elph_ds%fermie,anaddb_dtset%ep_b_min, anaddb_dtset%ep_b_max,&
419 15 : & elph_ds%minFSband,elph_ds%maxFSband,elph_ds%k_phon%nkptirr)
420 :
421 15 : elph_ds%nFSband = elph_ds%maxFSband - elph_ds%minFSband + 1
422 :
423 15 : if (anaddb_dtset%ep_prt_yambo==1) then
424 1 : elph_ds%nFSband = nband
425 1 : elph_ds%minFSband = 1
426 1 : elph_ds%maxFSband = nband
427 : end if
428 :
429 : !Modify the band gap by sissor shift of the CB
430 15 : if (abs(anaddb_dtset%band_gap) < 10.0d0) then
431 0 : anaddb_dtset%band_gap = anaddb_dtset%band_gap*0.036749309 ! eV2Ha
432 0 : do isppol=1,elph_ds%nsppol
433 :
434 : !First find where the gap is
435 0 : etemp_vb = 999.0d0
436 0 : top_vb = elph_ds%minFSband
437 0 : do iband = elph_ds%minFSband, elph_ds%maxFSband
438 0 : e_vb_max = maxval(eigenGS(iband,:,isppol))
439 0 : if (dabs(e_vb_max-elph_ds%fermie) < etemp_vb) then
440 0 : etemp_vb = dabs(e_vb_max-elph_ds%fermie)
441 0 : top_vb = iband
442 : end if
443 : end do
444 0 : do iband = top_vb, elph_ds%maxFSband
445 0 : e_vb_max = maxval(eigenGS(iband,:,isppol))
446 0 : if (dabs(e_vb_max-maxval(eigenGS(top_vb,:,isppol))) < tol6) then
447 0 : etemp_vb = dabs(e_vb_max-elph_ds%fermie)
448 0 : top_vb = iband
449 : end if
450 : end do
451 0 : e_vb_max = maxval(eigenGS(top_vb,:,isppol))
452 0 : e_cb_min = minval(eigenGS(top_vb+1,:,isppol))
453 0 : write(message,'(a,E20.12,2x,E20.12)')' elphon : original fermi energy = ', elph_ds%fermie
454 0 : call wrtout(std_out,message,'COLL')
455 0 : write(message,'(a,E20.12,2x,E20.12)')' elphon : top of VB, bottom of CB = ',e_vb_max, e_cb_min
456 0 : call wrtout(std_out,message,'COLL')
457 :
458 0 : do iband = top_vb+1, elph_ds%maxFSband
459 0 : eigenGS(iband,:,isppol) = eigenGS(iband,:,isppol) + (anaddb_dtset%band_gap-(e_cb_min-e_vb_max))
460 : end do
461 : end do !nsppol
462 :
463 : !! recalculate Fermi level
464 : !elph_ds%nelect = hdr_get_nelect_byocc(Hdr)
465 0 : elph_ds%nelect = Hdr%nelect
466 0 : if (abs(anaddb_dtset%elph_fermie) > tol10) then
467 0 : elph_ds%fermie = anaddb_dtset%elph_fermie
468 0 : write(message,'(a,E20.12)')' Fermi level set by the user at :',elph_ds%fermie
469 0 : call wrtout(std_out,message,'COLL')
470 0 : call bst%from_hdr(Hdr,nband,eigenGS)
471 0 : else if (abs(anaddb_dtset%ep_extrael) > tol10) then
472 0 : write(message,'(a,E20.12)')' Additional electrons per unit cell set by the user at :',anaddb_dtset%ep_extrael
473 0 : call wrtout(std_out,message,'COLL')
474 0 : elph_ds%nelect = elph_ds%nelect + anaddb_dtset%ep_extrael
475 0 : call bst%from_hdr(Hdr,nband,eigenGS,nelect=elph_ds%nelect)
476 :
477 : ! set Bst to use FD occupations:
478 0 : Bst%occopt = 3
479 : ! Bst%tsmear = 0.00001_dp ! is this small etol9 Bst%tsmeatol90001_dp ! last used
480 0 : Bst%tsmear = tol9 ! is this small etol9 Bst%tsmeatol90001_dp ! last used
481 : ! Calculate occupation numbers.
482 0 : call Bst%update_occ(-99.99_dp)
483 0 : write(message,'(a,E20.12)')' Fermi level is now calculated to be :',Bst%fermie
484 0 : call wrtout(std_out,message,'COLL')
485 0 : elph_ds%fermie = BSt%fermie
486 : else
487 0 : call bst%from_hdr(Hdr,nband,eigenGS)
488 : end if
489 0 : call wrtout(std_out,message,'COLL')
490 : end if !modify band_gap
491 :
492 15 : if (elph_ds%ep_keepbands == 0) then !we are summing over bands
493 10 : elph_ds%ngkkband = 1
494 5 : else if (elph_ds%ep_keepbands == 1) then
495 : ! keep the band dependency btw elph_ds%minFSband and elph_ds%maxFSband
496 5 : elph_ds%ngkkband = elph_ds%nFSband
497 : else
498 0 : write(message,'(a,i0)')' ep_keepbands must be 0 or 1 while it is: ',elph_ds%ep_keepbands
499 0 : ABI_BUG(message)
500 : end if
501 :
502 15 : write(message,'(a,i0,2x,i0)')' elphon : minFSband, maxFSband = ',elph_ds%minFSband,elph_ds%maxFSband
503 15 : call wrtout(std_out,message,'COLL')
504 :
505 :
506 45 : ABI_MALLOC(elph_ds%k_phon%kptirr,(3,elph_ds%k_phon%nkptirr))
507 45 : ABI_MALLOC(elph_ds%k_phon%irredtoGS,(elph_ds%k_phon%nkptirr))
508 :
509 : !====================================================================
510 : !2) order irred k-points
511 : !====================================================================
512 15 : if (master == me) then
513 15 : call order_fs_kpts(hdr%kptns, hdr%nkpt, elph_ds%k_phon%kptirr,elph_ds%k_phon%nkptirr,elph_ds%k_phon%irredtoGS)
514 : end if
515 15 : call xmpi_bcast(elph_ds%k_phon%nkptirr, master, comm, ierr)
516 15 : call xmpi_bcast(elph_ds%k_phon%kptirr, master, comm, ierr)
517 15 : call xmpi_bcast(elph_ds%k_phon%irredtoGS, master, comm, ierr)
518 :
519 : !==========================================
520 : !3) reconstruct full kgrid from irred kpoints,
521 : !==========================================
522 15 : call mkFSkgrid (elph_ds%k_phon, Cryst%nsym, Cryst%symrec, timrev)
523 :
524 : ! check that kptrlatt is coherent with kpt found here
525 15 : nkpt_tmp = elph_ds%kptrlatt(1,1)*elph_ds%kptrlatt(2,2)*elph_ds%kptrlatt(3,3)
526 195 : if (sum(abs(elph_ds%kptrlatt(:,:))) /= nkpt_tmp) then
527 5 : ABI_WARNING(' the input kptrlatt is not diagonal... ')
528 : end if
529 15 : if (anaddb_dtset%ifltransport > 1 .and. nkpt_tmp /= elph_ds%k_phon%nkpt) then
530 : write(message,'(a,i0,a,i0)')&
531 0 : & ' the input kptrlatt is inconsistent ', nkpt_tmp, " /= ", elph_ds%k_phon%nkpt
532 0 : ABI_ERROR(message)
533 : end if
534 :
535 15 : if (anaddb_dtset%ifltransport==3 ) then
536 : !====================================================================
537 : ! The real irred kpt, now only used by get_tau_k
538 : !====================================================================
539 :
540 0 : ABI_MALLOC(indkpt1,(elph_ds%k_phon%nkpt))
541 0 : ABI_MALLOC(wtk_fullbz,(elph_ds%k_phon%nkpt))
542 0 : ABI_MALLOC(wtk_folded,(elph_ds%k_phon%nkpt))
543 0 : ABI_MALLOC(bz2ibz_smap, (6, elph_ds%k_phon%nkpt))
544 :
545 0 : wtk_fullbz(:) = one/dble(elph_ds%k_phon%nkpt) !weights normalized to unity
546 : call symkpt(0,cryst%gmet,indkpt1,0,elph_ds%k_phon%kpt,elph_ds%k_phon%nkpt,elph_ds%k_phon%new_nkptirr,&
547 0 : & Cryst%nsym,Cryst%symrec,timrev,wtk_fullbz,wtk_folded, bz2ibz_smap, xmpi_comm_self)
548 :
549 0 : ABI_FREE(bz2ibz_smap)
550 :
551 0 : write (message,'(2a,i0)')ch10,' Number of irreducible k-points = ',elph_ds%k_phon%new_nkptirr
552 0 : call wrtout(std_out,message,'COLL')
553 :
554 0 : ABI_MALLOC(elph_ds%k_phon%new_kptirr,(3,elph_ds%k_phon%new_nkptirr))
555 0 : ABI_MALLOC(elph_ds%k_phon%new_wtkirr,(elph_ds%k_phon%new_nkptirr))
556 0 : ABI_MALLOC(elph_ds%k_phon%new_irredtoGS,(elph_ds%k_phon%new_nkptirr))
557 :
558 0 : ikpt_irr = 0
559 0 : do ikpt=1,elph_ds%k_phon%nkpt
560 0 : if (wtk_folded(ikpt) /= zero) then
561 0 : ikpt_irr = ikpt_irr + 1
562 0 : elph_ds%k_phon%new_kptirr(:,ikpt_irr) = elph_ds%k_phon%kpt(:,ikpt)
563 0 : elph_ds%k_phon%new_wtkirr(ikpt_irr) = wtk_folded(ikpt)
564 0 : elph_ds%k_phon%new_irredtoGS(ikpt_irr) = ikpt
565 : end if
566 : end do
567 0 : if (ikpt_irr .ne. elph_ds%k_phon%new_nkptirr) then
568 0 : write (message,'(a)')' The number of irred nkpt does not match! '
569 0 : ABI_ERROR(message)
570 : end if
571 :
572 0 : ABI_FREE(indkpt1)
573 0 : ABI_FREE(wtk_fullbz)
574 0 : ABI_FREE(wtk_folded)
575 : end if
576 :
577 : !====================================================================
578 : !4) setup weights for integration (gaussian or tetrahedron method)
579 : !====================================================================
580 15 : elph_ds%k_phon%nband = elph_ds%nFSband
581 15 : elph_ds%k_phon%nsppol = elph_ds%nsppol
582 15 : elph_ds%k_phon%nsym = Cryst%nsym
583 75 : ABI_MALLOC(elph_ds%k_phon%wtk,(elph_ds%nFSband,elph_ds%k_phon%nkpt,elph_ds%k_phon%nsppol))
584 :
585 : call ep_fs_weights(anaddb_dtset%ep_b_min, anaddb_dtset%ep_b_max, eigenGS, anaddb_dtset%elphsmear, &
586 : & elph_ds%fermie, cryst%gprimd, elph_ds%k_phon%irredtoGS, elph_ds%kptrlatt, max_occ, elph_ds%minFSband, nband, elph_ds%nFSband, &
587 15 : & elph_ds%nsppol, anaddb_dtset%telphint, elph_ds%k_phon)
588 :
589 : !distribute k-points among processors, if any
590 15 : call elph_k_procs(nproc, elph_ds%k_phon)
591 :
592 : !=====================================================
593 : !get kpt info from the fine grid part
594 : !=====================================================
595 15 : if (anaddb_dtset%use_k_fine == 1) then
596 :
597 0 : if (abs(anaddb_dtset%band_gap) < 10.0d0) then
598 0 : write (message,'(a)')' Not coded yet when use_k_fine and band_gap are both used'
599 0 : ABI_ERROR(message)
600 : end if
601 :
602 0 : if (master == me) then
603 0 : if (open_file("densergrid_GKK",message,newunit=unitfskgrid,form="unformatted",status="old") /=0) then
604 0 : ABI_ERROR(message)
605 : end if
606 : !read the header of file
607 0 : call hdr1%fort_read(unitfskgrid, fform)
608 0 : ABI_CHECK(fform/=0,'denser grid GKK header was mis-read. fform == 0')
609 : end if
610 0 : call hdr1%bcast(master,me,comm)
611 :
612 0 : ABI_MALLOC(eigenGS_fine,(nband,hdr1%nkpt,elph_ds%nsppol))
613 :
614 0 : if (master == me) then
615 0 : do isppol=1,elph_ds%nsppol
616 0 : do ikpt=1,hdr1%nkpt
617 0 : read(unitfskgrid) eigenGS_fine(:,ikpt,isppol)
618 : end do
619 : end do
620 0 : close(unitfskgrid)
621 : end if
622 0 : call xmpi_bcast(eigenGS_fine, master, comm, ierr)
623 :
624 : ! Reinit the structure storing the eigevalues.
625 : ! Be careful. This part has not been tested.
626 0 : call Bst%free()
627 0 : call bst%from_hdr(hdr1,nband,eigenGS_fine)
628 :
629 0 : elph_ds%k_fine%nkptirr = hdr1%nkpt
630 0 : ABI_MALLOC(elph_ds%k_fine%kptirr,(3,elph_ds%k_fine%nkptirr))
631 0 : ABI_MALLOC(elph_ds%k_fine%irredtoGS,(elph_ds%k_fine%nkptirr))
632 :
633 : call order_fs_kpts(hdr1%kptns, hdr1%nkpt, elph_ds%k_fine%kptirr,&
634 0 : & elph_ds%k_fine%nkptirr,elph_ds%k_fine%irredtoGS)
635 :
636 0 : call hdr1%free()
637 :
638 0 : call mkFSkgrid (elph_ds%k_fine, Cryst%nsym, Cryst%symrec, timrev)
639 :
640 0 : elph_ds%k_fine%nband = elph_ds%nFSband
641 0 : elph_ds%k_fine%nsppol = elph_ds%nsppol
642 0 : elph_ds%k_fine%nsym = Cryst%nsym
643 :
644 0 : ABI_MALLOC(elph_ds%k_fine%wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol))
645 :
646 0 : kptrlatt_fine = elph_ds%kptrlatt_fine
647 :
648 : call ep_fs_weights(anaddb_dtset%ep_b_min, anaddb_dtset%ep_b_max, &
649 : & eigenGS_fine, anaddb_dtset%elphsmear, &
650 : & elph_ds%fermie, cryst%gprimd, elph_ds%k_fine%irredtoGS, kptrlatt_fine, &
651 : & max_occ, elph_ds%minFSband, nband, elph_ds%nFSband, &
652 0 : & elph_ds%nsppol, anaddb_dtset%telphint, elph_ds%k_fine)
653 :
654 : else ! not using k_fine
655 15 : elph_ds%k_fine%nband = elph_ds%k_phon%nband
656 15 : elph_ds%k_fine%nsppol = elph_ds%k_phon%nsppol
657 15 : elph_ds%k_fine%nsym = elph_ds%k_phon%nsym
658 :
659 15 : elph_ds%k_fine%nkpt = elph_ds%k_phon%nkpt
660 15 : elph_ds%k_fine%nkptirr = elph_ds%k_phon%nkptirr
661 :
662 15 : elph_ds%k_fine%my_nkpt = elph_ds%k_phon%my_nkpt
663 :
664 45 : ABI_MALLOC(elph_ds%k_fine%my_kpt,(elph_ds%k_fine%nkpt))
665 1342 : elph_ds%k_fine%my_kpt = elph_ds%k_phon%my_kpt
666 :
667 45 : ABI_MALLOC(elph_ds%k_fine%my_ikpt,(elph_ds%k_fine%my_nkpt))
668 1342 : elph_ds%k_fine%my_ikpt = elph_ds%k_phon%my_ikpt
669 :
670 45 : ABI_MALLOC(elph_ds%k_fine%kptirr,(3,elph_ds%k_fine%nkptirr))
671 5278 : elph_ds%k_fine%kptirr = elph_ds%k_phon%kptirr
672 45 : ABI_MALLOC(elph_ds%k_fine%wtkirr,(elph_ds%k_fine%nkptirr))
673 1342 : elph_ds%k_fine%wtkirr = elph_ds%k_phon%wtkirr
674 :
675 75 : ABI_MALLOC(elph_ds%k_fine%wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%k_fine%nsppol))
676 9734 : elph_ds%k_fine%wtk = elph_ds%k_phon%wtk
677 45 : ABI_MALLOC(elph_ds%k_fine%kpt,(3,elph_ds%k_fine%nkpt))
678 5278 : elph_ds%k_fine%kpt = elph_ds%k_phon%kpt
679 :
680 15 : elph_ds%k_fine%krank = elph_ds%k_phon%krank%copy()
681 :
682 45 : ABI_MALLOC(elph_ds%k_fine%irr2full,(elph_ds%k_fine%nkptirr))
683 1342 : elph_ds%k_fine%irr2full = elph_ds%k_phon%irr2full
684 45 : ABI_MALLOC(elph_ds%k_fine%full2irr,(3,elph_ds%k_fine%nkpt))
685 5278 : elph_ds%k_fine%full2irr = elph_ds%k_phon%full2irr
686 60 : ABI_MALLOC(elph_ds%k_fine%full2full,(2,elph_ds%k_fine%nsym,elph_ds%k_fine%nkpt))
687 179326 : elph_ds%k_fine%full2full = elph_ds%k_phon%full2full
688 :
689 45 : ABI_MALLOC(elph_ds%k_fine%irredtoGS,(elph_ds%k_fine%nkptirr))
690 1342 : elph_ds%k_fine%irredtoGS = elph_ds%k_phon%irredtoGS
691 :
692 : ! call elph_k_copy(elph_ds%k_phon, elph_ds%k_fine)
693 :
694 195 : kptrlatt_fine = elph_ds%kptrlatt
695 :
696 75 : ABI_MALLOC(eigenGS_fine,(nband,elph_ds%k_fine%nkptirr,elph_ds%nsppol))
697 :
698 14598 : eigenGS_fine = eigenGS
699 : end if ! k_fine or not
700 :
701 15 : if (elph_ds%kptrlatt_fine(1,1) == 0) then ! when there is not input for kptrlatt_fine
702 195 : elph_ds%kptrlatt_fine = kptrlatt_fine
703 : end if
704 :
705 15 : call timein(tcpu,twall)
706 : write(message, '(a,f11.3,a,f11.3,a)' )&
707 15 : & '-elphon k and q grids have been setup after tcpu',tcpu-tcpui,' and twall',twall-twalli,' sec'
708 15 : call wrtout(std_out,message,'COLL')
709 15 : tcpui = tcpu
710 15 : twalli = twall
711 :
712 : !====================================================================
713 : !5) calculate DOS at Ef
714 : !====================================================================
715 45 : ABI_MALLOC(elph_ds%n0,(elph_ds%nsppol))
716 :
717 : !SPPOL sum over spin channels to get total DOS
718 : !channels decoupled => use separate values for DOS_up(Ef) resp down
719 31 : do isppol=1,elph_ds%nsppol
720 9719 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
721 : end do
722 :
723 15 : if (elph_ds%nsppol == 1) then
724 14 : write (std_out,*) ' elphon : the estimated DOS(E_Fermi) = ', elph_ds%n0(1), ' states/Ha/spin '
725 9636 : write (std_out,*) ' elphon : the total FS weight and # of kpoints = ',sum(elph_ds%k_fine%wtk),elph_ds%k_fine%nkpt
726 1 : else if (elph_ds%nsppol == 2) then
727 1 : write (std_out,*) ' elphon : the spin up DOS(E_Fermi) = ', elph_ds%n0(1), ' states/Ha/spin '
728 1 : write (std_out,*) ' elphon : the spin down DOS(E_Fermi) = ', elph_ds%n0(2), ' states/Ha/spin '
729 1 : write (std_out,*) ' elphon : total DOS(E_Fermi) = ', elph_ds%n0(1)+elph_ds%n0(2), ' states/Ha '
730 1 : write (std_out,*) ' elphon : the spin up FS weight and # of kpoints = ',&
731 42 : & sum(elph_ds%k_fine%wtk(:,:,1)),elph_ds%k_fine%nkpt
732 1 : write (std_out,*) ' elphon : the spin down FS weight and # of kpoints = ',&
733 42 : & sum(elph_ds%k_fine%wtk(:,:,2)),elph_ds%k_fine%nkpt
734 : else
735 0 : write (message,'(a,i0)') 'bad value for nsppol ', elph_ds%nsppol
736 0 : ABI_ERROR(message)
737 : end if
738 :
739 75 : ABI_MALLOC(elph_ds%gkk_intweight,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,elph_ds%nsppol))
740 :
741 15 : if (elph_ds%ep_keepbands == 0) then
742 : ! use trivial integration weights for single band,
743 : ! since average over bands is done in normsq_gkk
744 917 : elph_ds%gkk_intweight(1,:,:) = one
745 :
746 5 : else if (elph_ds%ep_keepbands == 1) then
747 : ! use elph_ds%k_fine%wtk since average over bands is not done in normsq_gkk
748 5 : if (elph_ds%use_k_fine == 1) then
749 0 : call d2c_weights(elph_ds)
750 : end if
751 3202 : elph_ds%gkk_intweight(:,:,:) = elph_ds%k_phon%wtk(:,:,:)
752 : else
753 0 : write(message,'(a,i0)')' ep_keepbands must be 0 or 1 while it is : ',elph_ds%ep_keepbands
754 0 : ABI_ERROR(message)
755 : end if
756 :
757 15 : ep_prt_wtk = 0
758 : if (ep_prt_wtk == 1) then
759 : do iband=1, elph_ds%ngkkband
760 : do ikpt_fine=1, elph_ds%k_fine%nkpt
761 : write (300,*) ikpt_fine, elph_ds%gkk_intweight(iband,ikpt_fine,1)
762 : end do
763 : end do
764 : end if
765 :
766 :
767 15 : call timein(tcpu,twall)
768 : write(message, '(a,f11.3,a,f11.3,a)' )&
769 15 : & '-elphon weights and DOS setup after tcpu',tcpu-tcpui,' and twall',twall-twalli,' sec'
770 15 : call wrtout(std_out,message,'COLL')
771 15 : tcpui = tcpu
772 15 : twalli = twall
773 :
774 : !Output of the Fermi Surface
775 15 : if (anaddb_dtset%prtfsurf == 1 .and. master == me) then
776 0 : fname=trim(elph_ds%elph_base_name) // '_BXSF'
777 0 : if (bst%write_bxsf(Cryst, fname) /= 0) then
778 0 : ABI_WARNING("Cannot produce file for Fermi surface, check log file for more info")
779 : end if
780 : end if
781 :
782 : !=========================================================
783 : !Get equivalence between a kpt_phon pair and a qpt in qpt_full
784 : !only works if the qpt grid is complete (identical to
785 : !the kpt one, with a basic shift of (0,0,0)
786 : !=========================================================
787 :
788 : !mapping of k + q onto k' for k and k' in full BZ
789 60 : ABI_MALLOC(FSfullpqtofull,(elph_ds%k_phon%nkpt,elph_ds%nqpt_full))
790 :
791 : !qpttoqpt(itim,isym,iqpt) = qpoint index which transforms to iqpt under isym and with time reversal itim.
792 60 : ABI_MALLOC(qpttoqpt,(2,Cryst%nsym,elph_ds%nqpt_full))
793 :
794 15 : call wrtout(std_out,'elphon: calling mkqptequiv to set up the FS qpoint set',"COLL")
795 :
796 : call mkqptequiv (FSfullpqtofull,Cryst,elph_ds%k_phon%kpt,elph_ds%k_phon%nkpt,&
797 15 : & elph_ds%nqpt_full,qpttoqpt,elph_ds%qpt_full)
798 :
799 : !==========================================
800 : !Set up dataset for phonon interpolations
801 : !==========================================
802 :
803 : !transfer ifltransport flag to structure
804 15 : elph_tr_ds%ifltransport=anaddb_dtset%ifltransport
805 : !transfer name of files file for ddk
806 15 : elph_tr_ds%ddkfilename=ddkfilename
807 :
808 : !reduce qpt_full to correct zone
809 135 : do iqpt=1,elph_ds%nqpt_full
810 120 : call wrap2_pmhalf(elph_ds%qpt_full(1,iqpt),kpt(1),res)
811 120 : call wrap2_pmhalf(elph_ds%qpt_full(2,iqpt),kpt(2),res)
812 120 : call wrap2_pmhalf(elph_ds%qpt_full(3,iqpt),kpt(3),res)
813 495 : elph_ds%qpt_full(:,iqpt)=kpt
814 : end do
815 :
816 : !test density of k+q grid: the following should be close to n0 squared
817 : !FIXME: generalize for sppol
818 15 : res = zero
819 1327 : do ikpt_fine = 1, elph_ds%k_phon%nkpt
820 11823 : do iqpt = 1, elph_ds%nqpt_full
821 41984 : kpt = elph_ds%k_phon%kpt(:,ikpt_fine) + elph_ds%qpt_full(:,iqpt)
822 10496 : symrankkpt = elph_ds%k_phon%krank%get_rank (kpt)
823 10496 : iFSkpq = elph_ds%k_phon%krank%invrank(symrankkpt)
824 41056 : do iband = 1, elph_ds%ngkkband
825 195072 : do ibandp = 1, elph_ds%ngkkband
826 184576 : res = res + elph_ds%gkk_intweight(iband,ikpt_fine,1)*elph_ds%gkk_intweight(ibandp,iFSkpq,1)
827 : end do
828 : end do
829 : end do
830 : end do
831 15 : res = res / elph_ds%k_phon%nkpt/elph_ds%k_phon%nkpt
832 15 : write (std_out,*) 'elphon: integrated value of intweight for given k and q grid : ', res, res / elph_ds%n0(1)**2
833 :
834 15 : res = zero
835 1327 : do ikpt_fine = 1, elph_ds%k_phon%nkpt
836 182575 : do iqpt = 1, elph_ds%k_phon%nkpt
837 724992 : kpt = elph_ds%k_phon%kpt(:,ikpt_fine) + elph_ds%k_phon%kpt(:,iqpt)
838 181248 : symrankkpt = elph_ds%k_phon%krank%get_rank (kpt)
839 181248 : iFSkpq = elph_ds%k_phon%krank%invrank(symrankkpt)
840 675680 : do iband = 1, elph_ds%ngkkband
841 3151872 : do ibandp = 1, elph_ds%ngkkband
842 2970624 : res = res + elph_ds%gkk_intweight(iband,ikpt_fine,1)*elph_ds%gkk_intweight(ibandp,iFSkpq,1)
843 : end do
844 : end do
845 : end do
846 : end do
847 15 : res = res / elph_ds%k_phon%nkpt/elph_ds%k_phon%nkpt
848 15 : write (std_out,*) 'elphon: integrated value of intweight for double k grid : ', res, res / elph_ds%n0(1)**2
849 :
850 : !===================================================
851 : !Allocate all important arrays for FS integrations
852 : !===================================================
853 :
854 : !Record sizes for matrices on disk: complex and real versions (for real and recip space resp!)
855 : onegkksize = 2*elph_ds%nbranch*elph_ds%nbranch*&
856 : & elph_ds%ngkkband*elph_ds%ngkkband*&
857 15 : & elph_ds%nsppol*kind(realdp_ex)
858 :
859 15 : elph_tr_ds%onegkksize=onegkksize
860 :
861 : write (message,'(4a)')&
862 15 : & ' elphon : preliminary setup completed ',ch10,&
863 30 : & ' calling get_all_gkq to read in all the e-ph matrix elements',ch10
864 15 : call wrtout(std_out,message,'COLL')
865 :
866 : !flag to do scalar product in gkq before interpolation:
867 : !should also used in interpolate_gkk and mkph_linwid
868 15 : if (elph_ds%ep_scalprod==0) then
869 11 : write (std_out,*) ' elphon: will NOT perform scalar product with phonon'
870 11 : write (std_out,*) ' displacement vectors in read_gkk. ep_scalprod==0'
871 4 : else if (elph_ds%ep_scalprod==1) then
872 4 : write (std_out,*) ' elphon: will perform scalar product with phonon'
873 4 : write (std_out,*) ' displacement vectors in read_gkk. ep_scalprod==1'
874 : else
875 0 : ABI_ERROR('illegal value for ep_scalprod')
876 : end if
877 :
878 15 : call timein(tcpu,twall)
879 : write(message, '(a,f11.3,a,f11.3,a)' )&
880 15 : & '-elphon begin gkq construction after tcpu',tcpu-tcpui,' and twall',twall-twalli,' sec'
881 15 : call wrtout(std_out,message,'COLL')
882 15 : tcpui = tcpu
883 15 : twalli = twall
884 :
885 : call get_all_gkq (elph_ds,Cryst,ifc,Bst,FSfullpqtofull,nband,n1wf,onegkksize,&
886 15 : & qpttoqpt,anaddb_dtset%ep_prt_yambo,unitgkk,elph_tr_ds%ifltransport)
887 :
888 15 : if (master == me) then
889 15 : close (unitgkk)
890 : end if
891 :
892 15 : call timein(tcpu,twall)
893 : write(message, '(a,f11.3,a,f11.3,a)' )&
894 15 : & '-elphon end gkq construction after tcpu',tcpu-tcpui,' and twall',twall-twalli,' sec'
895 15 : call wrtout(std_out,message,'COLL')
896 15 : tcpui = tcpu
897 15 : twalli = twall
898 :
899 15 : if (elph_tr_ds%ifltransport==1 .or. elph_tr_ds%ifltransport==2 .or. elph_tr_ds%ifltransport==3)then
900 :
901 : ! check inputs
902 : ! TODO: should be done at earlier stage of initialization and checking
903 5 : if (elph_ds%ngkkband /= elph_ds%nFSband) then
904 0 : write (message,'(a)') 'need to keep electron band dependency in memory for transport calculations'
905 0 : ABI_ERROR(message)
906 : end if
907 :
908 : ! bxu, moved the allocation from get_veloc_tr to elphon
909 5 : if (anaddb_dtset%use_k_fine == 1) then
910 0 : ABI_MALLOC(elph_tr_ds%el_veloc,(elph_ds%k_fine%nkpt,nband,3,elph_ds%nsppol))
911 : else
912 30 : ABI_MALLOC(elph_tr_ds%el_veloc,(elph_ds%k_phon%nkpt,nband,3,elph_ds%nsppol))
913 : end if
914 15 : ABI_MALLOC(elph_tr_ds%FSelecveloc_sq,(3,elph_ds%nsppol))
915 :
916 : ! this only needs to be read in once - the fermi level average is later done many times with get_veloc_tr
917 5 : if (me == master) then
918 5 : if (anaddb_dtset%use_k_fine == 1) then
919 0 : call read_el_veloc(nband,elph_ds%k_fine%nkpt,elph_ds%k_fine%kpt,elph_ds%nsppol,elph_tr_ds)
920 : else
921 5 : call read_el_veloc(nband,elph_ds%k_phon%nkpt,elph_ds%k_phon%kpt,elph_ds%nsppol,elph_tr_ds)
922 : end if
923 : end if
924 5 : call xmpi_bcast (elph_tr_ds%el_veloc, master, comm, ierr)
925 :
926 5 : call get_veloc_tr(elph_ds,elph_tr_ds)
927 : end if
928 :
929 : !Output of the Fermi velocities
930 : !to be used for Mayavi visualization
931 15 : if (anaddb_dtset%prtfsurf == 1 .and. master == me) then
932 0 : fname = trim(elph_ds%elph_base_name) // '_VTK'
933 :
934 : ! FIXME
935 : ! shiftk is defined neither in the anaddb nor in the hdr data type
936 : ! an incorrect FS will be produced in case of a shifted k-grid used during the GS calculation
937 : ! check if we are using a unshifthed kgrid, obviously doesnt work in case
938 : ! of multiple shifts containg a zero translation but in this case prtbxsf should work
939 0 : shiftk=one
940 0 : do ii=1,hdr%nkpt
941 0 : if (all(hdr%kptns(:,ii) == zero)) shiftk=zero
942 : end do
943 :
944 0 : use_afm=(hdr%nsppol==1.and.hdr%nspden==2)
945 : ! MG FIXME warning time reversal is always assumed to be present.
946 : ! the header should report this information.
947 :
948 0 : use_tr=(timrev==1)
949 :
950 0 : nk1 = elph_ds%kptrlatt_fine(1,1)
951 0 : nk2 = elph_ds%kptrlatt_fine(2,2)
952 0 : nk3 = elph_ds%kptrlatt_fine(3,3)
953 :
954 0 : ABI_MALLOC(v_surf,(nband,nk1+1,nk2+1,nk3+1,3,elph_ds%nsppol))
955 0 : v_surf = zero
956 0 : do isppol=1,elph_ds%nsppol
957 0 : do iband=1,nband
958 0 : do ikpt = 1, nk1+1
959 0 : do jkpt = 1, nk2+1
960 0 : do kkpt = 1, nk3+1
961 0 : ik1 = ikpt
962 0 : ik2 = jkpt
963 0 : ik3 = kkpt
964 0 : if (ikpt > nk1) ik1 = ikpt - nk1
965 0 : if (jkpt > nk2) ik2 = jkpt - nk2
966 0 : if (kkpt > nk3) ik3 = kkpt - nk3
967 0 : ikpt_fine = (ik1-1)*nk2*nk3 + (ik2-1)*nk3 + ik3
968 : ! v_surf(iband,ikpt,jkpt,kkpt,:,isppol)=elph_tr_ds%el_veloc(ikpt_fine,iband,:,isppol)*elph_ds%k_fine%wtk(iband,ikpt_fine,isppol)
969 0 : v_surf(iband,ikpt,jkpt,kkpt,:,isppol)=elph_tr_ds%el_veloc(ikpt_fine,iband,:,isppol)
970 : end do
971 : end do
972 : end do
973 : end do
974 : end do
975 :
976 : call printvtk(eigenGS,v_surf,zero,elph_ds%fermie,Cryst%gprimd,&
977 : & elph_ds%kptrlatt_fine,nband,hdr%nkpt,hdr%kptns,&
978 0 : & Cryst%nsym,use_afm,Cryst%symrec,Cryst%symafm,use_tr,elph_ds%nsppol,shiftk,1,fname,ierr)
979 :
980 0 : ABI_FREE(v_surf)
981 :
982 : end if !anaddb_dtset%prtfsurf
983 :
984 : !============================================================================
985 : !Evaluate lambda and omega_log using the weighted sum over the irred q-points
986 : !found in the GKK file. All the data we need are stored in elph_ds%qgrid_data
987 : !============================================================================
988 :
989 15 : if (master == me) then
990 15 : fname=trim(elph_ds%elph_base_name) // '_QPTS'
991 15 : call outelph(elph_ds,anaddb_dtset%enunit,fname)
992 : end if
993 :
994 : !========================================================
995 : !Get FS averaged gamma matrices and Fourier transform to real space
996 : !========================================================
997 :
998 60 : ABI_MALLOC(coskr, (elph_ds%nqpt_full,Ifc%nrpt))
999 45 : ABI_MALLOC(sinkr, (elph_ds%nqpt_full,Ifc%nrpt))
1000 15 : call ftgam_init(ifc%gprim, elph_ds%nqpt_full,Ifc%nrpt, elph_ds%qpt_full, Ifc%rpt, coskr, sinkr)
1001 :
1002 15 : call timein(tcpu,twall)
1003 : write(message, '(a,f11.3,a,f11.3,a)' )&
1004 15 : & '-elphon begin integration of gkq after tcpu',tcpu-tcpui,' and twall',twall-twalli,' sec'
1005 15 : call wrtout(std_out,message,'COLL')
1006 15 : tcpui = tcpu
1007 15 : twalli = twall
1008 :
1009 15 : call integrate_gamma(elph_ds,FSfullpqtofull)
1010 :
1011 15 : if (elph_ds%symgkq ==1) then
1012 : ! complete the gamma_qpt here instead of the gkk previously
1013 : call complete_gamma(Cryst,elph_ds%nbranch,elph_ds%nsppol,elph_ds%nqptirred,elph_ds%nqpt_full,&
1014 14 : & elph_ds%ep_scalprod,elph_ds%qirredtofull,qpttoqpt,elph_ds%gamma_qpt)
1015 : end if
1016 :
1017 : !Now FT to real space too
1018 : !NOTE: gprim (not gprimd) is used for all FT interpolations,
1019 : !to be consistent with the dimensions of the rpt, which come from anaddb.
1020 75 : ABI_MALLOC(elph_ds%gamma_rpt, (2,elph_ds%nbranch**2,elph_ds%nsppol,Ifc%nrpt))
1021 15409 : elph_ds%gamma_rpt = zero
1022 :
1023 15 : qtor = 1 ! q --> r
1024 31 : do isppol=1,elph_ds%nsppol
1025 : call ftgam(Ifc%wghatm,elph_ds%gamma_qpt(:,:,isppol,:),elph_ds%gamma_rpt(:,:,isppol,:),natom,&
1026 3055 : & elph_ds%nqpt_full,Ifc%nrpt,qtor, coskr, sinkr)
1027 : end do
1028 :
1029 15 : call timein(tcpu,twall)
1030 : write(message, '(a,f11.3,a,f11.3,a)' )&
1031 15 : & '-elphon end integration and completion of gkq after tcpu',tcpu-tcpui,' and twall',twall-twalli,' sec'
1032 15 : call wrtout(std_out,message,'COLL')
1033 15 : tcpui = tcpu
1034 15 : twalli = twall
1035 :
1036 :
1037 : !==========================================================
1038 : !calculate transport matrix elements, integrated over FS
1039 : !==========================================================
1040 :
1041 15 : if (elph_tr_ds%ifltransport == 1)then ! LOVA
1042 :
1043 5 : call integrate_gamma_tr_lova(elph_ds,FSfullpqtofull,elph_tr_ds)
1044 :
1045 : call complete_gamma_tr(cryst,elph_ds%ep_scalprod,elph_ds%nbranch,elph_ds%nqptirred,&
1046 5 : & elph_ds%nqpt_full,elph_ds%nsppol,elph_tr_ds%gamma_qpt_trout,elph_ds%qirredtofull,qpttoqpt)
1047 :
1048 : call complete_gamma_tr(cryst,elph_ds%ep_scalprod,elph_ds%nbranch,elph_ds%nqptirred,&
1049 5 : & elph_ds%nqpt_full,elph_ds%nsppol,elph_tr_ds%gamma_qpt_trin,elph_ds%qirredtofull,qpttoqpt)
1050 :
1051 25 : ABI_MALLOC(elph_tr_ds%gamma_rpt_trout,(2,9,elph_ds%nbranch**2,elph_ds%nsppol,Ifc%nrpt))
1052 85407 : elph_tr_ds%gamma_rpt_trout = zero
1053 :
1054 20 : ABI_MALLOC(elph_tr_ds%gamma_rpt_trin,(2,9,elph_ds%nbranch**2,elph_ds%nsppol,Ifc%nrpt))
1055 85407 : elph_tr_ds%gamma_rpt_trin = zero
1056 :
1057 : ! Now FT to real space too
1058 5 : qtor = 1 ! q --> r
1059 10 : do isppol=1,elph_ds%nsppol
1060 55 : do idir=1,9
1061 : call ftgam(Ifc%wghatm,elph_tr_ds%gamma_qpt_trout(:,idir,:,isppol,:),&
1062 : & elph_tr_ds%gamma_rpt_trout(:,idir,:,isppol,:),natom,&
1063 221499 : & elph_ds%nqpt_full,Ifc%nrpt,qtor, coskr, sinkr)
1064 :
1065 : call ftgam(Ifc%wghatm,elph_tr_ds%gamma_qpt_trin(:,idir,:,isppol,:),&
1066 : & elph_tr_ds%gamma_rpt_trin(:,idir,:,isppol,:),natom,&
1067 221504 : & elph_ds%nqpt_full,Ifc%nrpt,qtor, coskr, sinkr)
1068 : end do
1069 : end do
1070 :
1071 10 : else if (elph_tr_ds%ifltransport==2) then ! non-LOVA case
1072 :
1073 : ! Get Ef, DOS(Ef), veloc(Ef) for looped temperatures
1074 0 : call get_nv_fs_temp(elph_ds,BSt,eigenGS_fine,cryst%gprimd,max_occ,elph_tr_ds)
1075 :
1076 : ! Get DOS(E), veloc(E) for looped energy levels
1077 0 : call get_nv_fs_en(cryst,ifc,elph_ds,eigenGS_fine,max_occ,elph_tr_ds,omega_max)
1078 :
1079 : ! Save the E, N(E), v^2(E), dE
1080 0 : if (master == me) then
1081 0 : fname = trim(elph_ds%elph_base_name) // '_EPTS'
1082 0 : if (open_file(fname,message,newunit=unit_epts,status="unknown") /=0) then
1083 0 : ABI_ERROR(message)
1084 : end if
1085 0 : do isppol = 1, elph_ds%nsppol
1086 0 : write(unit_epts,"(a,i6)") '# E, N(E), v^2(E), dE for spin channel ', isppol
1087 0 : do ie1 = 1, elph_ds%nenergy
1088 0 : write(unit_epts,"(4E20.12)") elph_tr_ds%en_all(isppol,ie1), elph_tr_ds%dos_n(ie1,isppol),&
1089 0 : & elph_tr_ds%veloc_sq(1,isppol,ie1), elph_tr_ds%de_all(isppol,ie1)
1090 : end do
1091 : end do
1092 0 : close(unit=unit_epts)
1093 : end if
1094 :
1095 0 : ABI_MALLOC(tmp_veloc_sq1,(3,elph_ds%nsppol))
1096 0 : ABI_MALLOC(tmp_veloc_sq2,(3,elph_ds%nsppol))
1097 0 : ABI_MALLOC(elph_tr_ds%tmp_gkk_intweight1,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,elph_ds%nsppol))
1098 0 : ABI_MALLOC(elph_tr_ds%tmp_gkk_intweight2,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,elph_ds%nsppol))
1099 0 : ABI_MALLOC(elph_tr_ds%tmp_velocwtk1,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,3,elph_ds%nsppol))
1100 0 : ABI_MALLOC(elph_tr_ds%tmp_velocwtk2,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,3,elph_ds%nsppol))
1101 0 : ABI_MALLOC(elph_tr_ds%tmp_vvelocwtk1,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,3,3,elph_ds%nsppol))
1102 0 : ABI_MALLOC(elph_tr_ds%tmp_vvelocwtk2,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,3,3,elph_ds%nsppol))
1103 :
1104 0 : tmp_veloc_sq1 = zero
1105 0 : tmp_veloc_sq2 = zero
1106 0 : elph_tr_ds%tmp_gkk_intweight1 = zero
1107 0 : elph_tr_ds%tmp_gkk_intweight2 = zero
1108 0 : elph_tr_ds%tmp_velocwtk1 = zero
1109 0 : elph_tr_ds%tmp_velocwtk2 = zero
1110 0 : elph_tr_ds%tmp_vvelocwtk1 = zero
1111 0 : elph_tr_ds%tmp_vvelocwtk2 = zero
1112 :
1113 0 : if (elph_ds%ep_lova .eq. 1) then
1114 : tmp_nenergy = 1
1115 0 : else if (elph_ds%ep_lova .eq. 0) then
1116 0 : tmp_nenergy = elph_ds%nenergy
1117 : else
1118 0 : write(message,'(a,i0)')' ep_lova must be 0 or 1 while it is : ', elph_ds%ep_lova
1119 0 : ABI_ERROR(message)
1120 : end if
1121 :
1122 : ! This only works for ONE temperature!! for test only
1123 0 : elph_ds%n0(:) = elph_tr_ds%dos_n0(1,:)
1124 :
1125 : ! bxu, no need for complete sets of ie1 and ie2
1126 : ! Only save those within the range of omega_max from Ef
1127 0 : ABI_MALLOC(pair2red,(tmp_nenergy,tmp_nenergy))
1128 0 : pair2red = 0
1129 :
1130 0 : elph_ds%n_pair = 0
1131 0 : do ie1=1,tmp_nenergy
1132 0 : e1 = elph_tr_ds%en_all(1,ie1)
1133 0 : e2 = e1 - omega_max
1134 0 : if (e2 .lt. elph_tr_ds%en_all(1,1)) then
1135 : i_start = 1
1136 : else
1137 0 : i_start = 1
1138 0 : diff = dabs(e2-elph_tr_ds%en_all(1,1))
1139 0 : do ie2 = 2, tmp_nenergy
1140 0 : if (dabs(e2-elph_tr_ds%en_all(1,ie2)) .lt. diff) then
1141 0 : diff = dabs(e2-elph_tr_ds%en_all(1,ie2))
1142 0 : i_start = ie2
1143 : end if
1144 : end do
1145 : end if
1146 0 : e2 = e1 + omega_max
1147 0 : if (e2 .gt. elph_tr_ds%en_all(1,tmp_nenergy)) then
1148 : i_end = tmp_nenergy
1149 : else
1150 0 : i_end = 1
1151 0 : diff = dabs(e2-elph_tr_ds%en_all(1,1))
1152 0 : do ie2 = 2, tmp_nenergy
1153 0 : if (dabs(e2-elph_tr_ds%en_all(1,ie2)) .lt. diff) then
1154 0 : diff = dabs(e2-elph_tr_ds%en_all(1,ie2))
1155 0 : i_end = ie2
1156 : end if
1157 : end do
1158 : end if
1159 0 : do ie2 = i_start, i_end
1160 0 : elph_ds%n_pair = elph_ds%n_pair + 1
1161 0 : pair2red(ie1,ie2) = elph_ds%n_pair
1162 : end do
1163 : end do
1164 :
1165 : ! symmetrize paire2red
1166 0 : elph_ds%n_pair = 0
1167 0 : do ie1 = 1, tmp_nenergy
1168 0 : do ie2 = 1, tmp_nenergy
1169 0 : if (pair2red(ie1,ie2) .ne. 0 .or. pair2red(ie2,ie1) .ne. 0) then
1170 0 : elph_ds%n_pair = elph_ds%n_pair + 1
1171 0 : pair2red(ie1,ie2) = elph_ds%n_pair
1172 : end if
1173 : end do
1174 : end do
1175 :
1176 0 : write(message,'(a,i3,a)')' There are ', elph_ds%n_pair, ' energy pairs. '
1177 0 : call wrtout(std_out,message,'COLL')
1178 :
1179 0 : ABI_MALLOC(red2pair,(2,elph_ds%n_pair))
1180 0 : red2pair = 0
1181 0 : elph_ds%n_pair = 0
1182 0 : do ie1 = 1, tmp_nenergy
1183 0 : do ie2 = 1, tmp_nenergy
1184 0 : if (pair2red(ie1,ie2) .ne. 0 .or. pair2red(ie2,ie1) .ne. 0) then
1185 0 : elph_ds%n_pair = elph_ds%n_pair + 1
1186 0 : red2pair(1,elph_ds%n_pair) = ie1
1187 0 : red2pair(2,elph_ds%n_pair) = ie2
1188 : end if
1189 : end do
1190 : end do
1191 :
1192 : ! moved from integrate_gamma_tr to here
1193 0 : ABI_MALLOC(elph_tr_ds%gamma_qpt_tr,(2,9,elph_ds%nbranch**2,elph_ds%nsppol,elph_ds%nqpt_full))
1194 0 : ABI_MALLOC(elph_tr_ds%gamma_rpt_tr,(2,9,elph_ds%nbranch**2,elph_ds%nsppol,Ifc%nrpt,4,elph_ds%n_pair))
1195 0 : elph_tr_ds%gamma_rpt_tr = zero
1196 :
1197 0 : s1ofssp = (/1,1,-1,-1/)
1198 0 : s2ofssp = (/1,-1,1,-1/)
1199 :
1200 : ! Get gamma
1201 0 : ABI_MALLOC(gam_qpt,(2,3*natom*3*natom,elph_ds%nqpt_full))
1202 0 : ABI_MALLOC(gam_rpt,(2,3*natom*3*natom,Ifc%nrpt))
1203 0 : do ie=1,elph_ds%n_pair
1204 0 : ie1 = red2pair(1,ie)
1205 0 : ie2 = red2pair(2,ie)
1206 :
1207 0 : tmp_veloc_sq1(:,:)=elph_tr_ds%veloc_sq(:,:,ie1)
1208 0 : elph_tr_ds%tmp_gkk_intweight1(:,:,:) = elph_tr_ds%tmp_gkk_intweight(:,:,:,ie1)
1209 0 : elph_tr_ds%tmp_velocwtk1(:,:,:,:) = elph_tr_ds%tmp_velocwtk(:,:,:,:,ie1)
1210 0 : elph_tr_ds%tmp_vvelocwtk1(:,:,:,:,:) = elph_tr_ds%tmp_vvelocwtk(:,:,:,:,:,ie1)
1211 :
1212 0 : tmp_veloc_sq2(:,:)=elph_tr_ds%veloc_sq(:,:,ie2)
1213 0 : elph_tr_ds%tmp_gkk_intweight2(:,:,:) = elph_tr_ds%tmp_gkk_intweight(:,:,:,ie2)
1214 0 : elph_tr_ds%tmp_velocwtk2(:,:,:,:) = elph_tr_ds%tmp_velocwtk(:,:,:,:,ie2)
1215 0 : elph_tr_ds%tmp_vvelocwtk2(:,:,:,:,:) = elph_tr_ds%tmp_vvelocwtk(:,:,:,:,:,ie2)
1216 :
1217 0 : do ssp=1,4 ! (s,s'=+/-1, condense the indices)
1218 0 : s1=s1ofssp(ssp)
1219 0 : s2=s2ofssp(ssp)
1220 0 : elph_tr_ds%gamma_qpt_tr = zero
1221 :
1222 : call integrate_gamma_tr(elph_ds,FSfullpqtofull,s1,s2, &
1223 0 : & tmp_veloc_sq1,tmp_veloc_sq2,elph_tr_ds)
1224 :
1225 : call complete_gamma_tr(cryst,elph_ds%ep_scalprod,elph_ds%nbranch,elph_ds%nqptirred,&
1226 0 : & elph_ds%nqpt_full,elph_ds%nsppol,elph_tr_ds%gamma_qpt_tr,elph_ds%qirredtofull,qpttoqpt)
1227 :
1228 : ! Now FT to real space too
1229 0 : qtor = 1 ! q --> r
1230 0 : do isppol=1,elph_ds%nsppol
1231 0 : do idir=1,9
1232 0 : gam_qpt(:,:,:)=elph_tr_ds%gamma_qpt_tr(:,idir,:,isppol,:)
1233 : call ftgam(Ifc%wghatm,elph_tr_ds%gamma_qpt_tr(:,idir,:,isppol,:),&
1234 : & elph_tr_ds%gamma_rpt_tr(:,idir,:,isppol,:,ssp,ie),natom,&
1235 0 : & elph_ds%nqpt_full,Ifc%nrpt,qtor,coskr, sinkr)
1236 0 : elph_tr_ds%gamma_rpt_tr(:,idir,:,isppol,:,ssp,ie)=gam_rpt(:,:,:)
1237 : end do
1238 : end do
1239 :
1240 : end do !ss
1241 : end do !ie
1242 :
1243 0 : ABI_FREE(gam_qpt)
1244 0 : ABI_FREE(gam_rpt)
1245 0 : ABI_FREE(tmp_veloc_sq1)
1246 0 : ABI_FREE(tmp_veloc_sq2)
1247 : end if ! ifltransport
1248 :
1249 15 : ABI_FREE(qpttoqpt)
1250 15 : ABI_FREE(FSfullpqtofull)
1251 :
1252 :
1253 : !==============================================================
1254 : !Calculate phonon linewidths, interpolating on chosen qpoints
1255 : !==============================================================
1256 :
1257 15 : call mkph_linwid(Cryst,ifc,elph_ds,anaddb_dtset%nqpath,anaddb_dtset%qpath)
1258 :
1259 : !==============================================================
1260 : !the nesting factor calculation
1261 : !FIXME: this could go higher up, before the call to get_all_gkq
1262 : !you only need the kpt and weight info
1263 : !==============================================================
1264 15 : if (any(anaddb_dtset%prtnest==[1,2])) then
1265 :
1266 3 : nestname = trim(elph_ds%elph_base_name) // "_NEST"
1267 : call mknesting(elph_ds%k_phon%nkpt,elph_ds%k_phon%kpt,elph_ds%kptrlatt,elph_ds%nFSband,&
1268 : & elph_ds%k_phon%wtk,anaddb_dtset%nqpath,anaddb_dtset%qpath,elph_ds%nqpt_full, &
1269 3 : & elph_ds%qpt_full,nestname,cryst%gprimd,cryst%gmet,anaddb_dtset%prtnest,qptrlatt)
1270 : end if
1271 :
1272 : !======================================================
1273 : !Calculate alpha^2 F integrating over fine kpt_phon grid
1274 : !======================================================
1275 :
1276 45 : ABI_MALLOC(a2f_1d,(elph_ds%na2f))
1277 30 : ABI_MALLOC(dos_phon,(elph_ds%na2f))
1278 :
1279 15 : call mka2f(Cryst,Ifc,a2f_1d,dos_phon,elph_ds,elph_ds%kptrlatt_fine,elph_ds%mustar)
1280 :
1281 : !calculate transport spectral function and coefficients
1282 15 : if (elph_tr_ds%ifltransport==1 )then ! LOVA
1283 :
1284 5 : call mka2f_tr_lova(cryst,ifc,elph_ds,elph_ds%ntemper,elph_ds%tempermin,elph_ds%temperinc,elph_tr_ds)
1285 :
1286 10 : else if (elph_tr_ds%ifltransport==2 )then ! non LOVA
1287 :
1288 0 : call mka2f_tr(cryst,ifc,elph_ds,elph_ds%ntemper,elph_ds%tempermin,elph_ds%temperinc,pair2red,elph_tr_ds)
1289 :
1290 0 : ABI_FREE(pair2red)
1291 0 : ABI_FREE(red2pair)
1292 :
1293 10 : else if (elph_tr_ds%ifltransport==3 )then ! get k-dependent tau
1294 :
1295 0 : call get_tau_k(Cryst,ifc,Bst,elph_ds,elph_tr_ds,eigenGS,max_occ)
1296 : !call trans_rta(elph_ds,elph_tr_ds,cryst%gprimd,eigenGS,max_occ,cryst%ucvol)
1297 : end if ! ifltransport
1298 :
1299 15 : ABI_FREE(eigenGS)
1300 15 : ABI_FREE(eigenGS_fine)
1301 :
1302 :
1303 : !evaluate a2F only using the input Q-grid (without using interpolated matrices)
1304 : !SCOPE: test the validity of the Fourier interpolation
1305 15 : call wrtout(std_out,' elphon : calling mka2fQgrid',"COLL")
1306 :
1307 15 : fname=trim(elph_ds%elph_base_name) // '_A2F_QGRID'
1308 15 : call mka2fQgrid(elph_ds,fname)
1309 :
1310 : !=============================================
1311 : !Eliashberg equation in 1-D (isotropic case)
1312 : !=============================================
1313 :
1314 15 : call eliashberg_1d(a2f_1d,elph_ds,anaddb_dtset%mustar)
1315 :
1316 15 : ABI_FREE(a2f_1d)
1317 15 : ABI_FREE(dos_phon)
1318 :
1319 : !MJV: 20070805 should exit here. None of the rest is tested or used yet to my knowledge
1320 :
1321 : !========================================================================
1322 : !Now gkk contains the matrix elements of dH(1)/dxi i=1,2,3
1323 : !for kpoints on the FS but qpoints only in the given grid {Q}.
1324 : !
1325 : !1.) Need to complete the gkk elements for q and k\prime=k+q not
1326 : !in the set of {k+Q} by Fourier interpolation on the Q.
1327 : !
1328 : !2.) Need to complete the dynamical matrices and phonon freqs for
1329 : !all q between points on the FS.
1330 : !
1331 : !3.) With the eigenvectors e_ph of the dyn mats, do the scalar product
1332 : !e_ph . gkk, which implies the gkk are turned to the eigenbasis of
1333 : !the phonons. Before the (non eigen-) modes are ordered
1334 : !atom1 xred1 atom1 xred2 atom1 xred3
1335 : !atom2 xred1 atom2 xred2 atom2 xred3 ...
1336 : !=======================================================================
1337 :
1338 15 : make_gkk2=.false.
1339 :
1340 : if (.not. make_gkk2) then
1341 15 : call wrtout(std_out,' elphon : skipping full g(k,k") interpolation ',"COLL")
1342 : else
1343 :
1344 : ! ==========================================================
1345 : ! FT of recip space gkk matrices to real space (gkk_rpt)
1346 : ! NOTE: could be made into FFT, couldnt it? If shifts are
1347 : ! used with a homogeneous grid
1348 : ! ==========================================================
1349 : write (message,'(2a,i0)')ch10,&
1350 : & ' elphon : Fourier transform (q --> r) of the gkk matrices using nrpt = ',Ifc%nrpt
1351 : call wrtout(std_out,message,'COLL')
1352 :
1353 : call get_all_gkr(elph_ds,ifc%gprim,natom,Ifc%nrpt,onegkksize,Ifc%rpt,elph_ds%qpt_full,Ifc%wghatm)
1354 :
1355 : ! =========================================================
1356 : ! complete gkk2 for all qpts between points
1357 : ! on full kpt grid (interpolation from real space values)
1358 : ! =========================================================
1359 :
1360 : write(message,'(2a)')ch10,&
1361 : & ' elphon : Calling get_all_gkk2 to calculate gkk2 for q points over the full k grid'
1362 : call wrtout(std_out,message,'COLL')
1363 :
1364 : call get_all_gkk2(cryst,ifc,elph_ds,elph_ds%k_phon%kptirr,elph_ds%k_phon%kpt)
1365 : end if
1366 :
1367 : !=====================================================
1368 : !Here should be the anisotropic Eliashberg equations.
1369 : !=====================================================
1370 :
1371 : !clean and deallocate junk
1372 15 : call Bst%free()
1373 15 : call elph_ds_clean(elph_ds)
1374 15 : call elph_tr_ds_clean(elph_tr_ds)
1375 15 : call hdr%free()
1376 :
1377 15 : ABI_FREE(coskr)
1378 15 : ABI_FREE(sinkr)
1379 :
1380 15 : if (is_open(elph_ds%unitgkq)) close(elph_ds%unitgkq)
1381 :
1382 135 : end subroutine elphon
1383 : !!***
1384 :
1385 : !!****f* m_elphon/outelph
1386 : !! NAME
1387 : !! outelph
1388 : !!
1389 : !! FUNCTION
1390 : !! Output to stdout and file the data for electron phonon coupling,
1391 : !! on the q-points which were really calculated by abinit (no interpolation yet)
1392 : !!
1393 : !! INPUTS
1394 : !! elph_ds the elph_type structured variable
1395 : !! enunit from the anaddb dataset 0 ==> Hartree and cm-1;
1396 : !! 1 ==> meV and Thz;
1397 : !!
1398 : !! OUTPUT
1399 : !! only write
1400 : !!
1401 : !! SOURCE
1402 :
1403 15 : subroutine outelph(elph_ds,enunit,fname)
1404 :
1405 : !Arguments ------------------------------------
1406 : !scalars
1407 : integer,intent(in) :: enunit
1408 : character(len=fnlen),intent(in) :: fname
1409 : type(elph_type),intent(in) :: elph_ds
1410 :
1411 : !Local variables-------------------------------
1412 : !scalars
1413 : integer :: ibranch,ii,iqfull,iqirr,isppol,jj,nfile,qmax,qnest_max,qnest_min
1414 : integer :: nbranch,nsppol,nqptirred
1415 : real(dp) :: lambda_q_max,lambda_qbranch_max,lambda_tot,nest_max,nest_min
1416 : real(dp) :: omegalog_q,omegalog_qgrid,tc_macmill
1417 : character(len=500) :: msg
1418 15 : type(krank_t) :: krank
1419 : !arrays
1420 : integer :: qbranch_max(2)
1421 15 : real(dp),allocatable :: lambda_q(:,:),nestfactor(:),qirred(:,:)
1422 : ! *************************************************************************
1423 :
1424 15 : if ( ALL (enunit /= (/0,1,2/)) ) then
1425 0 : write(msg,'(a,i0)')' enunit should be 0 or 1 or 2 while it is ',enunit
1426 0 : ABI_BUG(msg)
1427 : end if
1428 :
1429 15 : nbranch = elph_ds%nbranch
1430 15 : nsppol = elph_ds%nsppol
1431 15 : nqptirred = elph_ds%nqptirred
1432 :
1433 : !==========================================================
1434 : !write header
1435 : !==========================================================
1436 15 : if (open_file(fname,msg,newunit=nfile,form="formatted",status="unknown") /= 0) then
1437 0 : ABI_ERROR(msg)
1438 : end if
1439 :
1440 1230 : write(msg,'(2a,80a,4a,80a)')ch10,' ',('=',ii=1,80),ch10,&
1441 15 : & ' Values of the parameters that define the electron-phonon calculation',ch10,&
1442 2445 : & ' ',('=',ii=1,80)
1443 15 : call wrtout(nfile,msg,'COLL')
1444 :
1445 : write(msg,'(a,i10,a,i10,a,i10)')&
1446 15 : & ' nkpt_phon = ',elph_ds%k_phon%nkpt, ' nkpt_phonirred = ',elph_ds%k_phon%nkptirr,&
1447 30 : & ' nqpt = ',elph_ds%nqpt_full
1448 15 : call wrtout(nfile,msg,'COLL')
1449 :
1450 15 : if (nsppol==1) then
1451 14 : write(msg,'(2a,f10.7,a,f10.6,a,f10.7)')ch10,&
1452 14 : & ' Fermi DOS = ',elph_ds%n0(1), ' Fermi level = ',elph_ds%fermie,&
1453 28 : & ' mustar = ',elph_ds%mustar
1454 14 : call wrtout(nfile,msg,'COLL')
1455 1 : else if (nsppol==2) then
1456 1 : write(msg,'(2a,f10.7,f10.7,a,f10.6,a,f10.7)')ch10,&
1457 1 : & ' Fermi DOS (up/dn) = ',elph_ds%n0(1),elph_ds%n0(2), ' Fermi level = ',elph_ds%fermie,&
1458 2 : & ' mustar = ',elph_ds%mustar
1459 1 : call wrtout(nfile,msg,'COLL')
1460 : else
1461 0 : ABI_BUG("bad value for nsppol")
1462 : end if
1463 :
1464 15 : write(msg,'(2a,i10,a,i10,a,i10)')ch10,&
1465 15 : & ' minFSband = ',elph_ds%minFSband,' maxFSband = ',elph_ds%maxFSband,&
1466 30 : & ' ngkkband = ',elph_ds%ngkkband
1467 15 : call wrtout(nfile,msg,'COLL')
1468 :
1469 1215 : write(msg,'(80a,a)')('=',ii=1,80),ch10
1470 15 : call wrtout(nfile,msg,'COLL')
1471 :
1472 : !==========================================================
1473 : !evaluate lambda and omega_log as a weighted sum over the q grid
1474 : !NOTE: in this part of the code atomic units are used
1475 : !==========================================================
1476 :
1477 60 : ABI_MALLOC(lambda_q,(nqptirred,nsppol))
1478 82 : lambda_q=zero
1479 15 : lambda_tot=zero ; lambda_q_max=zero
1480 15 : qmax=0 ; lambda_qbranch_max=zero
1481 45 : qbranch_max(:)=1; omegalog_qgrid=zero
1482 :
1483 63 : do iqirr=1,nqptirred
1484 48 : omegalog_q=zero
1485 :
1486 114 : do isppol=1,nsppol
1487 240 : do ibranch=1,nbranch
1488 : ! find Max lambda(q,n)
1489 189 : if (elph_ds%qgrid_data(iqirr,ibranch,isppol,3) > lambda_qbranch_max) then
1490 43 : lambda_qbranch_max=elph_ds%qgrid_data(iqirr,ibranch,isppol,3)
1491 43 : qbranch_max(1)=iqirr
1492 43 : qbranch_max(2)=ibranch
1493 : end if
1494 189 : lambda_q(iqirr,isppol)=lambda_q(iqirr,isppol)+elph_ds%qgrid_data(iqirr,ibranch,isppol,3)
1495 189 : if (abs(elph_ds%qgrid_data(iqirr,ibranch,isppol,1)) <= tol10) cycle
1496 240 : omegalog_q=omegalog_q + elph_ds%qgrid_data(iqirr,ibranch,isppol,3)*log(abs(elph_ds%qgrid_data(iqirr,ibranch,isppol,1)))
1497 : end do
1498 :
1499 51 : lambda_tot=lambda_tot+elph_ds%wtq(elph_ds%qirredtofull(iqirr))*lambda_q(iqirr,isppol)
1500 51 : omegalog_qgrid=omegalog_qgrid+elph_ds%wtq(elph_ds%qirredtofull(iqirr))*omegalog_q
1501 :
1502 :
1503 : ! find Max lambda(q)
1504 99 : if (lambda_q(iqirr,isppol) > lambda_q_max) then
1505 29 : lambda_q_max=lambda_q(iqirr,isppol)
1506 29 : qmax=iqirr
1507 : end if
1508 : end do
1509 :
1510 : end do !iqirr
1511 :
1512 15 : omegalog_qgrid=exp(omegalog_qgrid/lambda_tot)
1513 :
1514 : write (msg,'(3a,2(a,es16.8))') &
1515 15 : & ' Values of Lambda, Omega_log and Tc obtained using the weighted sum over the input Q-grid',ch10,ch10,&
1516 30 : & ' Isotropic Lambda = ',lambda_tot,' Input mustar = ',elph_ds%mustar
1517 15 : call wrtout(nfile,msg,'COLL')
1518 :
1519 15 : if (enunit==0) then !use hartree and cm-1
1520 15 : write (msg,'(2a,es16.8,a,es16.8,a)')ch10,&
1521 30 : & ' Omega_log = ',omegalog_qgrid,' (Ha) ',omegalog_qgrid*Ha_cmm1,' (cm-1)'
1522 15 : call wrtout(nfile,msg,'COLL')
1523 0 : else if (enunit==1) then !mev Thz
1524 0 : write (msg,'(2a,es16.8,a,es16.8,a)')ch10,&
1525 0 : & ' Omega_log = ',omegalog_qgrid*Ha_eV/1000._dp,' (meV) ',omegalog_qgrid*Ha_THz,' (THz)'
1526 0 : call wrtout(nfile,msg,'COLL')
1527 : else !hartree,cm-1,mev,Thz,kelvin
1528 0 : write (msg,'(2a,es16.8,a,es16.8,3a,es16.8,a,es16.8,3a,es16.8,a)')ch10, &
1529 0 : & ' Omega_log = ',omegalog_qgrid,' (Ha) ',omegalog_qgrid*Ha_cmm1,' (cm-1)',ch10, &
1530 0 : & ' = ',omegalog_qgrid*Ha_eV/1000._dp,' (meV) ',omegalog_qgrid*Ha_THz,' (THz)',ch10,&
1531 0 : & ' = ',omegalog_qgrid*Ha_K,' (K) '
1532 0 : call wrtout(nfile,msg,'COLL')
1533 : end if
1534 :
1535 : tc_macmill = omegalog_qgrid/1.2_dp&
1536 15 : & *exp((-1.04_dp*(one+lambda_tot)) / (lambda_tot-elph_ds%mustar*(one+0.62_dp*lambda_tot)))
1537 :
1538 15 : if (enunit==0) then !use hartree and cm-1
1539 15 : write (msg,'(2a,es16.8,a,es16.8,2a)')ch10,&
1540 30 : & ' MacMillan Tc = ',tc_macmill,' (Ha) ',tc_macmill*Ha_cmm1,' (cm-1) ',ch10
1541 15 : call wrtout(nfile,msg,'COLL')
1542 0 : else if (enunit==1) then !use mev and Thz
1543 0 : write (msg,'(2a,es16.8,a,es16.8,2a)')ch10,&
1544 0 : & ' MacMillan Tc = ',tc_macmill*Ha_eV/1000._dp,' (meV) ',tc_macmill*Ha_THz,' (THz) ',ch10
1545 0 : call wrtout(nfile,msg,'COLL')
1546 : else !use hartree,cm-1,mev,Thz,kelvin
1547 0 : write (msg,'(2a,es16.8,a,es16.8,3a,es16.8,a,es16.8,3a,es16.8,2a)')ch10, &
1548 0 : & ' MacMillan Tc = ',tc_macmill,' (Ha) ',tc_macmill*Ha_cmm1,' (cm-1) ',ch10, &
1549 0 : & ' = ',tc_macmill*Ha_eV/1000._dp,' (meV) ',tc_macmill*Ha_THz,' (THz) ',ch10,&
1550 0 : & ' = ',tc_macmill*Ha_K,' (K) ',ch10
1551 0 : call wrtout(nfile,msg,'COLL')
1552 : end if
1553 :
1554 : !==========================================================
1555 : !output lambda(q) values for each q point in the irred grid
1556 : !==========================================================
1557 :
1558 15 : write(msg,'(2a)')' Irreducible q-points and corresponding Lambda(q)',ch10
1559 15 : call wrtout(nfile,msg,'COLL')
1560 :
1561 31 : do isppol=1,nsppol
1562 16 : write(msg,'(a,i3,2a)')' === isppol ', isppol,' === ',ch10
1563 16 : call wrtout(nfile,msg,'COLL')
1564 : !
1565 82 : do iqirr=1,nqptirred
1566 51 : iqfull=elph_ds%qirredtofull(iqirr)
1567 : write(msg,'(i5,a,3(es16.8,1x),a,es16.8,a)')&
1568 51 : & iqfull,') ',elph_ds%qpt_full(:,iqfull),'(',lambda_q(iqirr,isppol),' )'
1569 67 : call wrtout(nfile,msg,'COLL')
1570 : end do
1571 : !
1572 : end do
1573 :
1574 : !use same indexing as that used for the full q-grid
1575 15 : qmax=elph_ds%qirredtofull(qmax)
1576 15 : qbranch_max(1)=elph_ds%qirredtofull(qbranch_max(1))
1577 :
1578 15 : write (msg,'(2a,es16.8,a,i6,3a,es16.8,a,i6,a,i4)')ch10, &
1579 15 : & ' Max lambda(q) = ',lambda_q_max, ' at qpt ',qmax,')',ch10, &
1580 15 : & ' Max lambda(q,n) = ',lambda_qbranch_max,' at qpt ',qbranch_max(1),&
1581 30 : & ') and Mode number ',qbranch_max(2)
1582 15 : call wrtout(nfile,msg,'COLL')
1583 :
1584 : !==========================================================
1585 : !evaluation of the nesting-factor over the irreducible q grid.
1586 : !==========================================================
1587 :
1588 : !fill irreducile q-grid
1589 45 : ABI_MALLOC(qirred,(3,nqptirred))
1590 207 : qirred(:,:)=zero
1591 :
1592 63 : do iqirr=1,nqptirred
1593 207 : qirred(:,iqirr)=elph_ds%qpt_full(:,elph_ds%qirredtofull(iqirr))
1594 : end do
1595 :
1596 15 : call krank%init(elph_ds%k_phon%nkpt, elph_ds%k_phon%kpt)
1597 :
1598 45 : ABI_MALLOC(nestfactor,(nqptirred))
1599 :
1600 : !NOTE: weights are not normalised, the normalisation factor in reintroduced in bfactor
1601 : call bfactor(elph_ds%k_phon%nkpt,elph_ds%k_phon%kpt,nqptirred,qirred,krank,&
1602 15 : & elph_ds%k_phon%nkpt,elph_ds%k_phon%wtk,elph_ds%nFSband,nestfactor)
1603 :
1604 15 : ABI_FREE(qirred)
1605 15 : call krank%free()
1606 :
1607 :
1608 : !find Max and min of the nesting factor
1609 : !NOTE maxloc and minloc are arrays so they cannot be used in the formatted output
1610 : !anyway the size of nestfactor is not so huge!!!
1611 141 : nest_max=maxval(nestfactor); nest_min=minval(nestfactor)
1612 :
1613 15 : qnest_max=0
1614 15 : do iqirr=1,nqptirred
1615 15 : if (nestfactor(iqirr)==nest_max) then
1616 15 : qnest_max=iqirr
1617 15 : exit
1618 : end if
1619 : end do
1620 :
1621 15 : qnest_min=0
1622 34 : do iqirr=1,nqptirred
1623 34 : if (nestfactor(iqirr)==nest_min) then
1624 15 : qnest_min=iqirr
1625 15 : exit
1626 : end if
1627 : end do
1628 :
1629 141 : write (std_out,*) maxloc(nestfactor),minloc(nestfactor)
1630 15 : write(msg,'(a,(a,es16.8,a,i6,a),a,(a,es16.8,a,i6,a))')ch10, &
1631 15 : & ' Max nesting factor = ',nest_max,' at qpt ',qnest_max,') ',ch10,&
1632 30 : & ' min nesting factor = ',nest_min,' at qpt ',qnest_min,') '
1633 15 : call wrtout(nfile,msg,'COLL')
1634 :
1635 : !==========================================================
1636 : !Write ph-linewidths and lambda(q,n) obtained before the
1637 : !Fourier interpolation
1638 : !==========================================================
1639 :
1640 15 : write (msg,'(2a)')ch10,&
1641 30 : & ' Phonon frequencies, linewidths and e-ph coefficients for each irreducible q point '
1642 15 : call wrtout(nfile,msg,'COLL')
1643 :
1644 31 : do isppol=1,nsppol
1645 16 : write (msg,'(a,i3,a)') '========= quantities for isppol = ', isppol, ' ================='
1646 16 : call wrtout(nfile,msg,'COLL')
1647 82 : do iqirr=1,nqptirred
1648 : ! same numbering as that used for irred q points
1649 51 : iqfull=elph_ds%qirredtofull(iqirr)
1650 : ! write(std_out,*) 'iqfull = ', iqfull
1651 51 : write(msg,'(64a,i6,a,3(es16.8),3a,es16.8,a,es16.8,2a,es16.8,a,f8.3,65a)')ch10,&
1652 3162 : & ' ',('=',jj=1,60),ch10,&
1653 51 : & ' qpt ',iqfull,') ',elph_ds%qpt_full(:,iqfull),ch10,ch10,&
1654 51 : & ' Weight = ',elph_ds%wtq(iqfull),' Lambda(q,isppol) = ',lambda_q(iqirr,isppol),ch10,&
1655 51 : & ' Nest fact = ',nestfactor(iqirr),' (',100*nestfactor(iqirr)/nest_max,' % of max_value )',ch10,&
1656 6273 : & ' ',('=',jj=1,60),ch10,' Mode number Frequency Linewidth Lambda(q,n)'
1657 51 : call wrtout(nfile,msg,'COLL')
1658 :
1659 : ! use units according to enunit
1660 51 : if (enunit==0 .or. enunit==2) then !hartree and cm-1
1661 3162 : write(msg,'(63a)')' ',('-',jj=1,60),ch10,&
1662 3213 : ' (Ha) (Ha)'
1663 51 : call wrtout(nfile,msg,'COLL')
1664 240 : do ibranch=1,nbranch
1665 : ! branch index, frequency, linewidth, lamda(q,n) (hartree units)
1666 756 : write(msg,'(i6,5x,3(es16.8,1x))' )ibranch,(elph_ds%qgrid_data(iqirr,ibranch,isppol,jj),jj=1,3)
1667 240 : call wrtout(nfile,msg,'COLL')
1668 : end do
1669 3162 : write(msg,'(63a)')' ',('-',jj=1,60),ch10,&
1670 3213 : & ' (cm-1) (cm-1)'
1671 51 : call wrtout(nfile,msg,'COLL')
1672 240 : do ibranch=1,nbranch
1673 : ! branch index, frequency, linewidth (in cm-1)
1674 567 : write(msg,'(i6,5x,2(es16.8,1x))' )ibranch,(Ha_cmm1*elph_ds%qgrid_data(iqirr,ibranch,isppol,jj),jj=1,2)
1675 240 : call wrtout(nfile,msg,'COLL')
1676 : end do
1677 : end if !hartree and cm-1
1678 :
1679 51 : if (enunit==2 .or. enunit==1) then !write also meV Thz and Kelvin
1680 0 : write(msg,'(63a)')' ',('-',jj=1,60),ch10,&
1681 0 : & ' (meV) (meV)'
1682 0 : call wrtout(nfile,msg,'COLL')
1683 0 : if (enunit == 1 ) then !write also lambda values
1684 0 : do ibranch=1,nbranch
1685 : ! branch index, frequency, linewidth, lamda(q,n) (mev units)
1686 0 : write(msg,'(i6,5x,3(es16.8,1x))' )ibranch,((Ha_eV/1000._dp)*elph_ds%qgrid_data(iqirr,ibranch,isppol,jj),jj=1,2),&
1687 0 : & elph_ds%qgrid_data(iqirr,ibranch,isppol,3)
1688 0 : call wrtout(nfile,msg,'COLL')
1689 : end do
1690 : else !do not write lambda values
1691 0 : do ibranch=1,nbranch
1692 : ! branch index, frequency, linewidth (in meV)
1693 0 : write(msg,'(i6,5x,2(es16.8,1x))' )ibranch,((Ha_eV/1000._dp)*elph_ds%qgrid_data(iqirr,ibranch,isppol,jj),jj=1,2)
1694 0 : call wrtout(nfile,msg,'COLL')
1695 : end do
1696 : end if
1697 :
1698 0 : write(msg,'(63a)')' ',('-',jj=1,60),ch10,&
1699 0 : & ' (Thz) (Thz)'
1700 0 : call wrtout(nfile,msg,'COLL')
1701 0 : do ibranch=1,nbranch
1702 : ! branch index, frequency, linewidth (in Thz)
1703 0 : write(msg,'(i6,5x,2(es16.8,1x))' )ibranch,(Ha_THz*elph_ds%qgrid_data(iqirr,ibranch,isppol,jj),jj=1,2)
1704 0 : call wrtout(nfile,msg,'COLL')
1705 : end do
1706 :
1707 0 : if (enunit == 2 ) then !kelvin
1708 0 : write(msg,'(63a)')' ',('-',jj=1,60),ch10,&
1709 0 : & ' (K) (K)'
1710 0 : call wrtout(nfile,msg,'COLL')
1711 0 : do ibranch=1,nbranch
1712 : ! branch index, frequency, linewidth (in Kelvin)
1713 0 : write(msg,'(i6,5x,2(es16.8,1x))' )ibranch,(Ha_K*elph_ds%qgrid_data(iqirr,ibranch,isppol,jj),jj=1,2)
1714 0 : call wrtout(nfile,msg,'COLL')
1715 : end do
1716 : end if !kelvin
1717 :
1718 : end if !end write also meV Thz and Kelvin
1719 :
1720 3111 : write(msg,'(62a)')' ',('=',jj=1,60),ch10
1721 67 : call wrtout(nfile,msg,'COLL')
1722 :
1723 : end do !nqptirred
1724 : end do !nsppol
1725 :
1726 15 : ABI_FREE(nestfactor)
1727 15 : ABI_FREE(lambda_q)
1728 :
1729 15 : close (nfile)
1730 :
1731 15 : end subroutine outelph
1732 : !!***
1733 :
1734 : !!****f* m_elphon/rchkGSheader
1735 : !!
1736 : !! NAME
1737 : !! rchkGSheader
1738 : !!
1739 : !! FUNCTION
1740 : !! This routine reads the GS header information in the GKK file and checks it
1741 : !!
1742 : !! INPUTS
1743 : !! natom = number of atoms from DDB, for check
1744 : !! kptirr_phon = coordinates of the irreducible kpoints close to the FS
1745 : !!
1746 : !! OUTPUT
1747 : !! hdr = header information
1748 : !! nband = number of bands for rest of calculation
1749 : !! should be the same for all kpts
1750 : !!
1751 : !! SOURCE
1752 :
1753 15 : subroutine rchkGSheader (hdr,natom,nband,unitgkk)
1754 :
1755 : !Arguments ------------------------------------
1756 : !scalars
1757 : integer,intent(in) :: natom,unitgkk
1758 : integer,intent(out) :: nband
1759 : type(hdr_type),intent(inout) :: hdr
1760 :
1761 : !Local variables-------------------------------
1762 : !scalars
1763 : integer :: fform
1764 : character(len=500) :: message
1765 : ! *************************************************************************
1766 : !
1767 : !read in general header of _GKK file
1768 : !this is where we get nkpt, ngkpt(:,:)... which are also read in
1769 : !rdddb9 and inprep8. Probably should do some checking to avoid
1770 : !using ddb files from other configurations
1771 : !
1772 15 : rewind(unitgkk)
1773 15 : call hdr%fort_read(unitgkk, fform)
1774 15 : ABI_CHECK(fform/=0," GKK header mis-read. fform == 0")
1775 :
1776 15 : if (hdr%natom /= natom) then
1777 0 : ABI_ERROR('natom in gkk file is different from anaddb input')
1778 : end if
1779 :
1780 1335 : if (any(hdr%nband(:) /= hdr%nband(1))) then
1781 : write(message,'(3a)')&
1782 0 : & 'Use the same number of bands for all kpts: ',ch10,&
1783 0 : & 'could have spurious effects if efermi is too close to the last band '
1784 0 : ABI_ERROR(message)
1785 : end if
1786 :
1787 15 : call hdr%echo(fform, 4, unit=std_out)
1788 :
1789 15 : nband=hdr%nband(1)
1790 :
1791 15 : end subroutine rchkGSheader
1792 : !!***
1793 :
1794 : !!****f* m_elphon/mkfskgrid
1795 : !!
1796 : !! NAME
1797 : !! mkfskgrid
1798 : !!
1799 : !! FUNCTION
1800 : !! This routine sets up the full FS kpt grid by symmetry
1801 : !!
1802 : !! INPUTS
1803 : !! nsym = number of symmetries for the full system
1804 : !! symrec = reciprocal space symmetries (those for the kpts)
1805 : !! timrev = 1 if time reversal symmetry is to be used
1806 : !!
1807 : !! OUTPUT
1808 : !! elph_k datastructure:
1809 : !! elph_k%nkpt = full number of kpoints close to the FS
1810 : !! elph_k%kpt = full set of kpoints close to the FS
1811 : !! elph_k%wtkirr = weights of the irreducible kpoints
1812 : !! elph_k%kphon_irr2full = indices of irred kpoints in full array
1813 : !!
1814 : !! NOTES
1815 : !! WARNING: supposes kpt grid has full symmetry!! Not always true!!!
1816 : !! but should be for Monkhorst-Pack, efficient grids.
1817 : !! otherwise you get an error message in interpolate_gkk because
1818 : !! an FS kpt can not be found in the gkk file.
1819 : !!
1820 : !! SOURCE
1821 :
1822 15 : subroutine mkFSkgrid (elph_k, nsym, symrec, timrev)
1823 :
1824 : use m_sort
1825 :
1826 : !Arguments ------------------------------------
1827 : !scalars
1828 : integer,intent(in) :: nsym,timrev
1829 : type(elph_kgrid_type),intent(inout) :: elph_k
1830 : !arrays
1831 : integer,intent(in) :: symrec(3,3,nsym)
1832 :
1833 : !Local variables-------------------------------
1834 : !scalars
1835 : integer :: ikpt1,ikpt2,isym,itim,new,symrankkpt
1836 : real(dp) :: timsign, res
1837 : character(len=500) :: message
1838 :
1839 : !arrays
1840 : real(dp) :: kpt(3),redkpt(3)
1841 15 : integer, allocatable :: sortindexing(:), rankallk(:), tmpkphon_full2irr(:,:)
1842 15 : real(dp), allocatable :: tmpkpt(:,:)
1843 : ! *************************************************************************
1844 :
1845 15 : if(timrev /= 1 .and. timrev /= 0)then
1846 0 : write (message,'(a,i0)')' timrev must be 1 or 0 but found timrev= ',timrev
1847 0 : ABI_BUG(message)
1848 : end if
1849 :
1850 45 : ABI_MALLOC(tmpkphon_full2irr,(3,2*elph_k%nkptirr*nsym))
1851 474639 : tmpkphon_full2irr = -1
1852 :
1853 45 : ABI_MALLOC(tmpkpt,(3,2*elph_k%nkptirr*nsym))
1854 :
1855 45 : ABI_MALLOC(elph_k%wtkirr,(elph_k%nkptirr))
1856 1327 : elph_k%wtkirr(:) = zero
1857 :
1858 : !first allocation for irred kpoints - will be destroyed below
1859 15 : call elph_k%krank%init(elph_k%nkptirr, elph_k%kptirr)
1860 45 : ABI_MALLOC(rankallk,(elph_k%krank%max_rank))
1861 :
1862 : !elph_k%krank%invrank is used as a placeholder in the following loop
1863 2583 : rankallk = -1
1864 1742 : elph_k%krank%invrank = -1
1865 :
1866 : !replicate all irred kpts by symmetry to get the full k grid.
1867 15 : elph_k%nkpt=0 !zero k-points found so far
1868 651 : do isym=1,nsym
1869 1923 : do itim=0,1
1870 1272 : timsign = one-two*itim
1871 120564 : do ikpt1=1,elph_k%nkptirr
1872 : ! generate symmetrics of kpt ikpt1
1873 : kpt(:) = timsign*(symrec(:,1,isym)*elph_k%kptirr(1,ikpt1) + &
1874 : & symrec(:,2,isym)*elph_k%kptirr(2,ikpt1) + &
1875 474624 : & symrec(:,3,isym)*elph_k%kptirr(3,ikpt1))
1876 :
1877 118656 : symrankkpt = elph_k%krank%get_rank (kpt)
1878 :
1879 : ! is the kpt on the full grid (may have lower symmetry than full spgroup)
1880 : ! is kpt among the full FS kpts found already?
1881 119928 : if (elph_k%krank%invrank(symrankkpt) == -1) then
1882 1312 : elph_k%wtkirr(ikpt1)=elph_k%wtkirr(ikpt1)+1
1883 1312 : elph_k%nkpt=elph_k%nkpt+1
1884 :
1885 1312 : call wrap2_pmhalf(kpt(1),redkpt(1),res)
1886 1312 : call wrap2_pmhalf(kpt(2),redkpt(2),res)
1887 1312 : call wrap2_pmhalf(kpt(3),redkpt(3),res)
1888 5248 : tmpkpt(:,elph_k%nkpt) = redkpt
1889 1312 : tmpkphon_full2irr(1,elph_k%nkpt) = ikpt1
1890 : ! save sym that sends irred kpt ikpt1 onto full kpt
1891 1312 : tmpkphon_full2irr(2,elph_k%nkpt) = isym
1892 1312 : tmpkphon_full2irr(3,elph_k%nkpt) = itim
1893 :
1894 1312 : elph_k%krank%invrank(symrankkpt) = elph_k%nkpt
1895 1312 : rankallk(elph_k%nkpt) = symrankkpt
1896 : end if
1897 :
1898 : end do !end loop over irred k points
1899 : end do !end loop over timrev
1900 : end do !end loop over symmetry
1901 :
1902 15 : write(message,'(a,i0)')'mkfskgrid: after first evaluation, elph_k%nkpt= ', elph_k%nkpt
1903 15 : call wrtout(std_out,message,"COLL")
1904 :
1905 1327 : elph_k%wtkirr(:) = elph_k%wtkirr(:) / elph_k%nkpt
1906 :
1907 : !copy the kpoints and full --> irred kpt map
1908 : !reorder the kpts to get rank increasing monotonically with a sort
1909 : !also reorder tmpkphon_full2irr
1910 45 : ABI_MALLOC(elph_k%kpt,(3,elph_k%nkpt))
1911 45 : ABI_MALLOC(elph_k%full2irr,(3,elph_k%nkpt))
1912 45 : ABI_MALLOC(sortindexing,(elph_k%nkpt))
1913 :
1914 1327 : do ikpt1=1,elph_k%nkpt
1915 1327 : sortindexing(ikpt1)=ikpt1
1916 : end do
1917 15 : call sort_int(elph_k%nkpt, rankallk, sortindexing)
1918 1327 : do ikpt1=1,elph_k%nkpt
1919 1312 : if (sortindexing(ikpt1) < 1 .or. sortindexing(ikpt1) > elph_k%nkpt) then
1920 0 : ABI_BUG('sorted k ranks are out of bounds: 1 to nkpt')
1921 : end if
1922 5248 : elph_k%kpt(:,ikpt1) = tmpkpt(:,sortindexing(ikpt1))
1923 5263 : elph_k%full2irr(:,ikpt1) = tmpkphon_full2irr(:,sortindexing(ikpt1))
1924 : end do
1925 :
1926 15 : ABI_FREE(sortindexing)
1927 15 : ABI_FREE(rankallk)
1928 15 : ABI_FREE(tmpkphon_full2irr)
1929 15 : ABI_FREE(tmpkpt)
1930 15 : call elph_k%krank%free()
1931 :
1932 : !make proper full rank arrays
1933 15 : call elph_k%krank%init(elph_k%nkpt, elph_k%kpt)
1934 :
1935 : !find correspondence table between irred FS kpoints and a full one
1936 45 : ABI_MALLOC(elph_k%irr2full,(elph_k%nkptirr))
1937 1327 : elph_k%irr2full(:) = 0
1938 :
1939 1327 : do ikpt1=1,elph_k%nkptirr
1940 1312 : symrankkpt = elph_k%krank%get_rank (elph_k%kptirr(:,ikpt1))
1941 1327 : elph_k%irr2full(ikpt1) = elph_k%krank%invrank(symrankkpt)
1942 : end do
1943 :
1944 : !find correspondence table between FS kpoints under symmetry
1945 60 : ABI_MALLOC(elph_k%full2full,(2,nsym,elph_k%nkpt))
1946 179311 : elph_k%full2full(:,:,:) = -999
1947 :
1948 1327 : do ikpt1=1,elph_k%nkpt
1949 : ! generate symmetrics of kpt ikpt1
1950 60655 : do isym=1,nsym
1951 179296 : do itim=0,timrev
1952 118656 : timsign = one-two*itim
1953 : kpt(:) = timsign*(symrec(:,1,isym)*elph_k%kpt(1,ikpt1) + &
1954 : & symrec(:,2,isym)*elph_k%kpt(2,ikpt1) + &
1955 474624 : & symrec(:,3,isym)*elph_k%kpt(3,ikpt1))
1956 :
1957 : ! which kpt is it among the full FS kpts
1958 118656 : symrankkpt = elph_k%krank%get_rank (kpt)
1959 118656 : ikpt2 = elph_k%krank%invrank(symrankkpt)
1960 118656 : new=1
1961 118656 : if (ikpt2 /= -1) then
1962 118656 : elph_k%full2full(itim+1,isym,ikpt2) = ikpt1
1963 : new = 0
1964 : end if
1965 :
1966 59328 : if (new == 1) then
1967 0 : write(std_out,*) ' mkfskgrid Error: FS kpt ',ikpt1,' has no symmetric under sym', isym,' with itim ',itim
1968 0 : write(std_out,*) ' redkpt = ', redkpt
1969 0 : write(std_out,*) ' symrankkpt,ikpt2 = ', symrankkpt,ikpt2
1970 0 : ABI_ERROR("Fatal error, cannot continue")
1971 : end if
1972 : end do
1973 : end do
1974 : end do
1975 :
1976 : !got nkpt, tmpkpt, kphon_full2irr, kphon_full2full, and wtkirr
1977 :
1978 15 : end subroutine mkFSkgrid
1979 : !!***
1980 :
1981 : !!****f* m_elphon/mka2f
1982 : !!
1983 : !! NAME
1984 : !! mka2f
1985 : !!
1986 : !! FUNCTION
1987 : !! calculate the FS averaged alpha^2F function
1988 : !!
1989 : !! INPUTS
1990 : !! Cryst<crystal_t>=data type gathering info on the crystalline structure.
1991 : !! Ifc<ifc_type>=Object containing the interatomic force constants.
1992 : !! elph_ds
1993 : !! elph_ds%gkk2 = gkk2 matrix elements on full FS grid for each phonon mode
1994 : !! elph_ds%nbranch = number of phonon branches = 3*natom
1995 : !! elph_ds%nFSband = number of bands included in the FS integration
1996 : !! elph_ds%k_phon%nkpt = number of kpts included in the FS integration
1997 : !! elph_ds%k_phon%kpt = coordinates of all FS kpoints
1998 : !! elph_ds%k_phon%wtk = integration weights on the FS
1999 : !! elph_ds%n0 = DOS at the Fermi level calculated from the k_phon integration weights (event. 2 spin pol)
2000 : !! mustar = coulomb pseudopotential parameter
2001 : !! natom = number of atoms
2002 : !!
2003 : !! OUTPUT
2004 : !! a2f_1d = 1D alpha
2005 : !! dos_phon = density of states for phonons
2006 : !! elph_ds
2007 : !!
2008 : !! NOTES
2009 : !! copied from ftiaf9.f
2010 : !!
2011 : !! SOURCE
2012 :
2013 30 : subroutine mka2f(Cryst,ifc,a2f_1d,dos_phon,elph_ds,kptrlatt,mustar)
2014 :
2015 : use m_special_funcs, only : fermi_dirac, bose_einstein
2016 : use m_epweights, only : d2c_wtq, ep_ph_weights
2017 :
2018 : !Arguments ------------------------------------
2019 : !scalars
2020 : real(dp),intent(in) :: mustar
2021 : type(ifc_type),intent(in) :: ifc
2022 : type(crystal_t),intent(in) :: Cryst
2023 : type(elph_type),target,intent(inout) :: elph_ds
2024 : !arrays
2025 : integer, intent(in) :: kptrlatt(3,3)
2026 : real(dp),intent(out) :: a2f_1d(elph_ds%na2f),dos_phon(elph_ds%na2f)
2027 :
2028 : !Local variables -------------------------
2029 : !scalars
2030 : integer :: natom,iFSqpt,ibranch,iomega,nbranch,na2f,nsppol,nkpt,nrpt
2031 : integer :: isppol,jbranch,unit_a2f,unit_phdos,ep_scalprod
2032 : integer :: itemp, ntemp = 100
2033 : real(dp) :: temp
2034 : real(dp) :: a2fprefactor,avgelphg,avglambda,avgomlog,diagerr
2035 : real(dp) :: lambda_2,lambda_3,lambda_4,lambda_5
2036 : real(dp) :: spinfact
2037 30 : real(dp) :: lambda_iso(elph_ds%nsppol)
2038 : real(dp) :: lqn,omega
2039 30 : real(dp) :: omegalog(elph_ds%nsppol)
2040 : real(dp) :: omlog_qn
2041 : real(dp) :: tc_macmill,a2fsmear,domega,omega_min,omega_max
2042 : real(dp) :: gaussval, gaussprefactor, gaussfactor, gaussmaxval, xx
2043 : character(len=500) :: msg
2044 : character(len=fnlen) :: fname,base_name
2045 : !arrays
2046 30 : real(dp) :: displ_cart(2,elph_ds%nbranch,elph_ds%nbranch)
2047 30 : real(dp) :: displ_red(2,elph_ds%nbranch,elph_ds%nbranch)
2048 30 : real(dp) :: eigval(elph_ds%nbranch)
2049 30 : real(dp) :: gam_now(2,elph_ds%nbranch*elph_ds%nbranch)
2050 30 : real(dp) :: imeigval(elph_ds%nbranch)
2051 : ! real(dp) :: pheigvec(2*elph_ds%nbranch*elph_ds%nbranch),phfrq(elph_ds%nbranch)
2052 30 : real(dp) :: tmp_a2f(elph_ds%na2f)
2053 30 : real(dp) :: tmp_gam1(2,elph_ds%nbranch,elph_ds%nbranch)
2054 30 : real(dp) :: tmp_gam2(2,elph_ds%nbranch,elph_ds%nbranch)
2055 30 : real(dp) :: tmp_phondos(elph_ds%na2f),n0(elph_ds%nsppol)
2056 : real(dp),pointer :: kpt(:,:)
2057 15 : real(dp),allocatable :: phfrq(:,:)
2058 15 : real(dp),allocatable :: pheigvec(:,:)
2059 15 : real(dp),allocatable :: tmp_wtq(:,:,:)
2060 15 : real(dp),allocatable :: a2f1mom(:),a2f2mom(:),a2f3mom(:),a2f4mom(:)
2061 15 : real(dp),allocatable :: a2f_1mom(:),a2flogmom(:)
2062 15 : real(dp),allocatable :: a2flogmom_int(:)
2063 15 : real(dp),allocatable :: coskr(:,:)
2064 15 : real(dp),allocatable :: sinkr(:,:)
2065 15 : real(dp),allocatable :: linewidth_of_t(:)
2066 15 : real(dp),allocatable :: linewidth_integrand(:,:)
2067 :
2068 : ! *********************************************************************
2069 : !calculate a2f for frequencies between 0 and elph_ds%omega_max
2070 :
2071 : DBG_ENTER("COLL")
2072 :
2073 : !might need kptrlatt for finer interpolation later
2074 : ABI_UNUSED(kptrlatt(1,1))
2075 :
2076 : ! nrpt = number of real-space points for FT interpolation
2077 15 : nrpt = Ifc%nrpt
2078 15 : natom = Cryst%natom
2079 :
2080 15 : nbranch = elph_ds%nbranch
2081 15 : na2f = elph_ds%na2f
2082 15 : nsppol = elph_ds%nsppol
2083 15 : base_name = elph_ds%elph_base_name
2084 15 : a2fsmear = elph_ds%a2fsmear
2085 15 : nkpt = elph_ds%k_phon%nkpt
2086 15 : kpt => elph_ds%k_phon%kpt
2087 :
2088 15 : ep_scalprod = elph_ds%ep_scalprod
2089 31 : n0 = elph_ds%n0
2090 :
2091 : !spinfact should be 1 for a normal non sppol calculation without spinorbit
2092 : !for spinors it should also be 1 as bands are twice as numerous but n0 has been divided by 2
2093 : !for sppol 2 it should be 0.5 as we have 2 spin channels to sum
2094 15 : spinfact = one/elph_ds%nsppol !/elph_ds%nspinor
2095 :
2096 : !maximum value of frequency (a grid has to be chosen for the representation of alpha^2 F)
2097 : !WARNING! supposes this value has been set in mkelph_linwid.
2098 15 : domega = (elph_ds%omega_max-elph_ds%omega_min)/(na2f-one)
2099 15 : elph_ds%domega = domega ! MG Why do we need to store domega in elph_ds?
2100 15 : omega_min = elph_ds%omega_min
2101 15 : omega_max = elph_ds%omega_max
2102 :
2103 15 : gaussprefactor = sqrt(piinv) / a2fsmear
2104 15 : gaussfactor = one / a2fsmear
2105 15 : gaussmaxval = sqrt(-log(1.d-100))
2106 :
2107 : ! only open the file for the first sppol
2108 15 : fname = trim(base_name) // '_A2F'
2109 15 : if (open_file(fname,msg,newunit=unit_a2f,status="unknown") /= 0) then
2110 0 : ABI_ERROR(msg)
2111 : end if
2112 :
2113 : !write (std_out,*) ' a2f function integrated over the FS'
2114 :
2115 : !output the a2f_1d header
2116 15 : write (unit_a2f,'(a)') '#'
2117 15 : write (unit_a2f,'(a)') '# ABINIT package : a2f file'
2118 15 : write (unit_a2f,'(a)') '#'
2119 15 : write (unit_a2f,'(a)') '# a2f function integrated over the FS. omega in a.u.'
2120 15 : write (unit_a2f,'(a,I10)') '# number of kpoints integrated over : ',nkpt
2121 15 : write (unit_a2f,'(a,I10)') '# number of energy points : ',na2f
2122 15 : write (unit_a2f,'(a,E16.6,a,E16.6,a)') '# between omega_min = ',omega_min,' Ha and omega_max = ',omega_max,' Ha'
2123 15 : write (unit_a2f,'(a,E16.6)') '# and the smearing width for gaussians is ',a2fsmear
2124 :
2125 : ! Open file for PH DOS
2126 15 : fname = trim(base_name) // '_PDS'
2127 15 : if (open_file(fname,msg,newunit=unit_phdos,status="replace") /= 0) then
2128 0 : ABI_ERROR(msg)
2129 : end if
2130 :
2131 : ! output the phonon DOS header
2132 15 : write (unit_phdos,'(a)') '#'
2133 15 : write (unit_phdos,'(a)') '# ABINIT package : phonon DOS file'
2134 15 : write (unit_phdos,'(a)') '#'
2135 15 : write (unit_phdos,'(a)') '# Phonon DOS integrated over the FS. omega in a.u. EXPERIMENTAL!!!'
2136 15 : write (unit_phdos,'(a,I10)') '# number of kpoints integrated over : ',nkpt
2137 15 : write (unit_phdos,'(a,I10)') '# number of energy points : ',na2f
2138 15 : write (unit_phdos,'(a,E16.6,a,E16.6,a)')'# between omega_min = ',omega_min,' Ha and omega_max = ',omega_max,' Ha'
2139 15 : write (unit_phdos,'(a,i4,a,E16.6)') '# The DOS at Fermi level for spin ', 1, ' is ', n0(1)
2140 15 : if (nsppol==2) then
2141 1 : write (unit_phdos,'(a,i4,a,E16.6)') '# The DOS at Fermi level for spin ', 2, ' is ', n0(2)
2142 : end if
2143 15 : write (unit_phdos,'(a,E16.6)') '# and the smearing width for gaussians is ',a2fsmear
2144 15 : write (unit_phdos,'(a)') '#'
2145 :
2146 : !Get the integration weights, using tetrahedron method or gaussian
2147 75 : ABI_MALLOC(tmp_wtq,(nbranch,elph_ds%k_fine%nkpt,na2f+1))
2148 75 : ABI_MALLOC(elph_ds%k_fine%wtq,(nbranch,elph_ds%k_fine%nkpt,na2f))
2149 75 : ABI_MALLOC(elph_ds%k_phon%wtq,(nbranch,nkpt,na2f))
2150 :
2151 60 : ABI_MALLOC(phfrq,(nbranch,elph_ds%k_fine%nkpt))
2152 75 : ABI_MALLOC(pheigvec,(2*nbranch*nbranch,elph_ds%k_fine%nkpt))
2153 :
2154 1327 : do iFSqpt=1,elph_ds%k_fine%nkpt
2155 1327 : call ifc%fourq(cryst,elph_ds%k_fine%kpt(:,iFSqpt),phfrq(:,iFSqpt),displ_cart,out_eigvec=pheigvec(:,iFSqpt))
2156 : end do
2157 :
2158 15 : omega_min = omega_min - domega
2159 :
2160 : call ep_ph_weights(phfrq,elph_ds%a2fsmear,omega_min,omega_max,na2f+1,Cryst%gprimd,elph_ds%kptrlatt_fine, &
2161 15 : & elph_ds%nbranch,elph_ds%telphint,elph_ds%k_fine,tmp_wtq)
2162 : !call ep_ph_weights(phfrq,elph_ds%a2fsmear,omega_min,omega_max,na2f+1,Cryst%gprimd,elph_ds%kptrlatt_fine, &
2163 : !& elph_ds%nbranch,1,elph_ds%k_fine,tmp_wtq)
2164 15 : omega_min = omega_min + domega
2165 :
2166 6015 : do iomega = 1, na2f
2167 2278015 : elph_ds%k_fine%wtq(:,:,iomega) = tmp_wtq(:,:,iomega+1)
2168 : end do
2169 15 : ABI_FREE(tmp_wtq)
2170 :
2171 15 : if (elph_ds%use_k_fine == 1) then
2172 0 : call d2c_wtq(elph_ds)
2173 : end if
2174 :
2175 60 : ABI_MALLOC(coskr, (nkpt,nrpt))
2176 45 : ABI_MALLOC(sinkr, (nkpt,nrpt))
2177 15 : call ftgam_init(Ifc%gprim, nkpt, nrpt, kpt, Ifc%rpt, coskr, sinkr)
2178 :
2179 15 : ABI_FREE(phfrq)
2180 15 : ABI_FREE(pheigvec)
2181 :
2182 31 : do isppol=1,nsppol
2183 16 : write (std_out,*) '##############################################'
2184 16 : write (std_out,*) 'mka2f : Treating spin polarization ', isppol
2185 16 : write (std_out,*) '##############################################'
2186 :
2187 : ! Average of electron phonon coupling over the whole BZ
2188 16 : avgelphg = zero
2189 : ! MG20060607 Do the same for lambda and omega_log
2190 16 : avglambda = zero
2191 16 : avgomlog = zero
2192 :
2193 6416 : a2f_1d(:) = zero
2194 6416 : dos_phon(:) = zero
2195 :
2196 : ! reduce the dimenstion from fine to phon for phfrq and pheigvec
2197 64 : ABI_MALLOC(phfrq,(nbranch,elph_ds%k_phon%nkpt))
2198 64 : ABI_MALLOC(pheigvec,(2*nbranch*nbranch,elph_ds%k_phon%nkpt))
2199 :
2200 : ! loop over qpoint in full kpt grid (presumably dense)
2201 : ! MG TODO : This loop can be performed using the IBZ and appropriated weights.
2202 1336 : do iFSqpt=1,nkpt
2203 : !
2204 : ! This reduced version of ftgkk supposes the kpoints have been integrated
2205 : ! in integrate_gamma. Do FT from real-space gamma grid to 1 qpt.
2206 :
2207 1320 : if (elph_ds%ep_int_gkk == 1) then
2208 0 : gam_now(:,:) = elph_ds%gamma_qpt(:,:,isppol,iFSqpt)
2209 : else
2210 : call ftgam(Ifc%wghatm,gam_now,elph_ds%gamma_rpt(:,:,isppol,:),natom,1,nrpt,0, &
2211 70232 : & coskr(iFSqpt,:), sinkr(iFSqpt,:))
2212 : end if
2213 :
2214 1320 : call ifc%fourq(cryst,kpt(:,iFSqpt),phfrq(:,iFSqpt),displ_cart,out_eigvec=pheigvec)
2215 :
2216 : ! Diagonalize gamma matrix at qpoint (complex matrix).
2217 :
2218 : ! if ep_scalprod==0 we have to dot in the displacement vectors here
2219 1320 : if (ep_scalprod==0) then
2220 :
2221 1112 : call phdispl_cart2red(natom,Cryst%gprimd,displ_cart,displ_red)
2222 :
2223 4448 : tmp_gam2 = reshape (gam_now, (/2,nbranch,nbranch/))
2224 1112 : call gam_mult_displ(nbranch, displ_red, tmp_gam2, tmp_gam1)
2225 :
2226 4448 : do jbranch=1,nbranch
2227 3336 : eigval(jbranch) = tmp_gam1(1, jbranch, jbranch)
2228 3336 : imeigval(jbranch) = tmp_gam1(2, jbranch, jbranch)
2229 :
2230 4448 : if (abs(imeigval(jbranch)) > tol8) then
2231 0 : write (msg,'(a,i0,a,es16.8)')" imaginary values branch = ",jbranch,' imeigval = ',imeigval(jbranch)
2232 0 : ABI_WARNING(msg)
2233 : end if
2234 :
2235 : end do
2236 :
2237 : ! if ep_scalprod==1 we have to diagonalize the matrix we interpolated.
2238 208 : else if (ep_scalprod == 1) then
2239 :
2240 : ! MJV NOTE : gam_now is being recast as a (3*natom)**2 matrix here
2241 : call ZGEMM ( 'N', 'N', 3*natom, 3*natom, 3*natom, cone, gam_now, 3*natom,&
2242 208 : & pheigvec, 3*natom, czero, tmp_gam1, 3*natom)
2243 :
2244 : call ZGEMM ( 'C', 'N', 3*natom, 3*natom, 3*natom, cone, pheigvec, 3*natom,&
2245 208 : & tmp_gam1, 3*natom, czero, tmp_gam2, 3*natom)
2246 :
2247 208 : diagerr = zero
2248 1264 : do ibranch=1,nbranch
2249 1056 : eigval(ibranch) = tmp_gam2(1,ibranch,ibranch)
2250 3408 : do jbranch=1,ibranch-1
2251 3408 : diagerr = diagerr + abs(tmp_gam2(1,jbranch,ibranch))
2252 : end do
2253 3616 : do jbranch=ibranch+1,nbranch
2254 3408 : diagerr = diagerr + abs(tmp_gam2(1,jbranch,ibranch))
2255 : end do
2256 : end do
2257 :
2258 208 : if (diagerr > tol12) then
2259 168 : write(msg,'(a,es15.8)') 'mka2f: residual in diagonalization of gamma with phon eigenvectors: ', diagerr
2260 168 : ABI_WARNING(msg)
2261 : end if
2262 :
2263 : else
2264 0 : write (msg,'(a,i0)')' Wrong value for ep_scalprod = ',ep_scalprod
2265 0 : ABI_BUG(msg)
2266 : end if
2267 :
2268 : ! MG20060603MG
2269 : ! there was a bug in the calculation of the phonon DOS
2270 : ! since frequencies with small e-ph interaction were skipped inside the loop
2271 : ! In this new version all the frequencies (both positive and negative) are taken into account.
2272 : ! IDEA: it could be useful to calculate the PH-dos and the a2f
2273 : ! using several smearing values to perform a convergence study
2274 : ! Now the case ep_scalprod=1 is treated in the right way although it is not default anymore
2275 : ! FIXME to be checked
2276 : ! ENDMG
2277 :
2278 : ! Add all contributions from the phonon modes at this qpoint to a2f and the phonon dos.
2279 5728 : do ibranch=1,nbranch
2280 :
2281 : ! if (abs(phfrq(ibranch,iFSqpt)) < tol10) then
2282 4392 : if (abs(phfrq(ibranch,iFSqpt)) < tol7) then
2283 : a2fprefactor= zero
2284 : lqn = zero
2285 : omlog_qn = zero
2286 : else
2287 4344 : a2fprefactor = eigval(ibranch)/(two_pi*abs(phfrq(ibranch,iFSqpt))*n0(isppol))
2288 4344 : lqn = eigval(ibranch)/(pi*phfrq(ibranch,iFSqpt)**2*n0(isppol))
2289 4344 : omlog_qn = lqn*log(abs(phfrq(ibranch,iFSqpt)))
2290 : end if
2291 :
2292 : ! Add contribution to average elphon coupling
2293 : ! MANY ISSUES WITH FINITE T SUMS. THIS IS DEFINITELY
2294 : ! NOT A CORRECT FORMULATION YET.
2295 :
2296 : ! Added avglambda and avgomglog to calculate lamda and omega_log using the sum over the kpt-grid.
2297 : ! If the k-grid is dense enough, these values should be better than the corresponding quantities
2298 : ! evaluated through the integration over omega that depends on the a2fsmear
2299 :
2300 4392 : avgelphg = avgelphg + eigval(ibranch)
2301 4392 : avglambda = avglambda + lqn
2302 4392 : avgomlog= avgomlog + omlog_qn
2303 : ! ENDMG
2304 :
2305 4392 : omega = omega_min
2306 1761192 : tmp_a2f(:) = zero
2307 1761192 : tmp_phondos(:) = zero
2308 1761192 : do iomega=1,na2f
2309 1756800 : xx = (omega-phfrq(ibranch,iFSqpt))*gaussfactor
2310 1756800 : omega = omega + domega
2311 1756800 : if (abs(xx) > gaussmaxval) cycle
2312 :
2313 475202 : gaussval = gaussprefactor*exp(-xx*xx)
2314 475202 : tmp_a2f(iomega) = tmp_a2f(iomega) + gaussval*a2fprefactor
2315 1761192 : tmp_phondos(iomega) = tmp_phondos(iomega) + gaussval
2316 : end do
2317 :
2318 : ! tmp_a2f(:) = zero
2319 : ! tmp_phondos(:) = zero
2320 : ! do iomega=1,na2f
2321 : ! tmp_a2f(iomega) = tmp_a2f(iomega) + a2fprefactor*elph_ds%k_phon%wtq(ibranch,iFSqpt,iomega)
2322 : ! tmp_phondos(iomega) = tmp_phondos(iomega) + elph_ds%k_phon%wtq(ibranch,iFSqpt,iomega)
2323 : ! end do
2324 :
2325 1761192 : a2f_1d(:) = a2f_1d(:) + tmp_a2f(:)
2326 1762512 : dos_phon(:) = dos_phon(:) + tmp_phondos(:)
2327 :
2328 : end do ! ibranch
2329 : end do ! iFSqpt do
2330 :
2331 :
2332 : ! second 1 / nkpt factor for the integration weights
2333 6416 : a2f_1d(:) = a2f_1d(:) / nkpt
2334 6416 : dos_phon(:) = dos_phon(:) / nkpt
2335 :
2336 : ! MG
2337 16 : avglambda = avglambda/nkpt
2338 16 : avgomlog= avgomlog/nkpt
2339 16 : avgomlog = exp (avgomlog/avglambda)
2340 16 : write(std_out,*) ' from mka2f: for spin ', isppol
2341 16 : write(std_out,*) ' w/o interpolation lambda = ',avglambda,' omega_log= ',avgomlog
2342 : ! ENDMG
2343 :
2344 16 : write (std_out,'(a,I4,a,E16.6)') '# The DOS at Fermi level for spin ',isppol,' is ',n0(isppol)
2345 :
2346 16 : write (unit_a2f,'(a,I4,a,E16.6)') '# The DOS at Fermi level for spin ',isppol,' is ',n0(isppol)
2347 16 : write (unit_a2f,'(a)') '#'
2348 :
2349 16 : omega = omega_min
2350 6416 : do iomega=1,na2f
2351 6400 : write (unit_a2f,*) omega, a2f_1d(iomega)
2352 6416 : omega=omega + domega
2353 : end do
2354 16 : write (unit_a2f,*)
2355 : !
2356 : ! output the phonon DOS, but only for the first sppol case
2357 16 : if (isppol == 1) then
2358 15 : omega = omega_min
2359 6015 : do iomega=1,na2f
2360 6000 : write (unit_phdos,*) omega, dos_phon(iomega)
2361 6015 : omega=omega + domega
2362 : end do
2363 : end if
2364 : !
2365 : ! Do isotropic calculation of lambda and output lambda, Tc(MacMillan)
2366 : !
2367 48 : ABI_MALLOC(a2f_1mom,(na2f))
2368 32 : ABI_MALLOC(a2f1mom,(na2f))
2369 32 : ABI_MALLOC(a2f2mom,(na2f))
2370 32 : ABI_MALLOC(a2f3mom,(na2f))
2371 32 : ABI_MALLOC(a2f4mom,(na2f))
2372 64 : ABI_MALLOC(linewidth_integrand,(na2f,ntemp))
2373 48 : ABI_MALLOC(linewidth_of_t,(ntemp))
2374 :
2375 6416 : a2f_1mom=zero
2376 12816 : a2f1mom=zero; a2f2mom=zero
2377 12816 : a2f3mom=zero; a2f4mom=zero
2378 641616 : linewidth_integrand = zero
2379 :
2380 16 : omega = omega_min
2381 6416 : do iomega=1,na2f
2382 6400 : if (abs(omega) > tol10) then
2383 6393 : a2f_1mom(iomega) = two*spinfact*a2f_1d(iomega)/abs(omega) ! first inverse moment of alpha2F
2384 6393 : a2f1mom(iomega) = two*spinfact*a2f_1d(iomega)*abs(omega) ! first positive moment of alpha2F
2385 6393 : a2f2mom(iomega) = a2f1mom(iomega)*abs(omega) ! second positive moment of alpha2F
2386 6393 : a2f3mom(iomega) = a2f2mom(iomega)*abs(omega) ! third positive moment of alpha2F
2387 6393 : a2f4mom(iomega) = a2f3mom(iomega)*abs(omega) ! fourth positive moment of alpha2F
2388 : !
2389 : ! electron lifetimes eq 4.48 in [[cite:Grimvall1981]] electron phonon coupling in Metals (with T dependency). Also 5.69-5.72, 5.125, section 3.4
2390 : ! phonon lifetimes eq 19 in Savrasov PhysRevB.54.16487 [[cite:Savrasov1996]] (T=0)
2391 : ! a first T dependent expression in Allen PRB 6 2577 [[cite:Allen1972]] eq 10. Not sure about the units though
2392 : !
2393 645693 : do itemp = 1, ntemp
2394 639300 : temp = (itemp-1)*10._dp*kb_HaK
2395 645693 : linewidth_integrand(iomega, itemp) = a2f_1d(iomega) * (fermi_dirac(omega,zero,temp) + bose_einstein(omega,temp))
2396 : end do
2397 : end if
2398 6416 : omega=omega + domega
2399 : end do
2400 : !
2401 : ! From Allen PRL 59 1460 [[cite:Allen1987]]
2402 : ! \lambda <\omega^n> = 2 \int_0^{\infty} d\omega [\alpha^2F / \omega] \omega^n
2403 : !
2404 16 : lambda_iso(isppol) = simpson(domega,a2f_1mom)
2405 16 : lambda_2 = simpson(domega,a2f1mom)
2406 16 : lambda_3 = simpson(domega,a2f2mom)
2407 16 : lambda_4 = simpson(domega,a2f3mom)
2408 16 : lambda_5 = simpson(domega,a2f4mom)
2409 1616 : do itemp = 1, ntemp
2410 1600 : linewidth_of_t(itemp) = simpson(domega,linewidth_integrand(:,itemp))
2411 : ! print out gamma(T) here
2412 1600 : temp = (itemp-1)*10._dp*kb_HaK
2413 1616 : write (std_out,*) 'mka2f: T, average linewidth', temp, linewidth_of_t(itemp)
2414 : end do
2415 :
2416 :
2417 16 : ABI_FREE(phfrq)
2418 16 : ABI_FREE(pheigvec)
2419 16 : ABI_FREE(a2f_1mom)
2420 16 : ABI_FREE(a2f1mom)
2421 16 : ABI_FREE(a2f2mom)
2422 16 : ABI_FREE(a2f3mom)
2423 16 : ABI_FREE(a2f4mom)
2424 16 : ABI_FREE(linewidth_integrand)
2425 16 : ABI_FREE(linewidth_of_t)
2426 :
2427 16 : write (std_out,*) 'mka2f: elphon coupling lambdas for spin = ', isppol
2428 16 : write (std_out,*) 'mka2f: isotropic lambda', lambda_iso(isppol)
2429 16 : write (std_out,*) 'mka2f: positive moments of alpha2F:'
2430 16 : write (std_out,*) 'lambda <omega^2> = ', lambda_2
2431 16 : write (std_out,*) 'lambda <omega^3> = ', lambda_3
2432 16 : write (std_out,*) 'lambda <omega^4> = ', lambda_4
2433 16 : write (std_out,*) 'lambda <omega^5> = ', lambda_5
2434 : !
2435 : ! Get log moment of alpha^2F
2436 48 : ABI_MALLOC(a2flogmom,(na2f))
2437 32 : ABI_MALLOC(a2flogmom_int,(na2f))
2438 16 : omega = omega_min
2439 6416 : a2flogmom(:) = zero
2440 6416 : do iomega=1,na2f
2441 6400 : if (abs(omega) > tol10) then
2442 6393 : a2flogmom(iomega) = a2f_1d(iomega)*log(abs(omega))/abs(omega)
2443 : end if
2444 6416 : omega=omega + domega
2445 : end do
2446 16 : call simpson_int(na2f,domega,a2flogmom,a2flogmom_int)
2447 :
2448 : ! NOTE: omegalog actually stores the log moment of a2F, which is the quantity to sum over spins, instead of
2449 : ! exp(moment/lambda) which is an actual frequency
2450 16 : omegalog(isppol) = two*spinfact*a2flogmom_int(na2f)
2451 :
2452 16 : ABI_FREE(a2flogmom)
2453 16 : ABI_FREE(a2flogmom_int)
2454 :
2455 16 : if (nsppol > 1) then
2456 2 : write (msg, '(3a)' ) ch10,&
2457 4 : & ' Warning : some of the following quantities should be integrated over spin', ch10
2458 2 : call wrtout(std_out,msg,'COLL')
2459 2 : call wrtout(ab_out,msg,'COLL')
2460 : end if
2461 :
2462 16 : write (msg, '(3a)' ) ch10,&
2463 32 : & ' Superconductivity : isotropic evaluation of parameters from electron-phonon coupling.',ch10
2464 16 : call wrtout(std_out,msg,'COLL')
2465 16 : call wrtout(ab_out,msg,'COLL')
2466 :
2467 16 : if (elph_ds%nsppol > 1) then
2468 2 : write (msg, '(a,i6,a,es16.6)' )' mka2f: isotropic lambda for spin ', isppol, ' = ', lambda_iso(isppol)
2469 2 : call wrtout(std_out,msg,'COLL')
2470 2 : call wrtout(ab_out,msg,'COLL')
2471 : end if
2472 :
2473 16 : write (msg, '(a,es16.6)' )' mka2f: lambda <omega^2> = ', lambda_2
2474 16 : call wrtout(std_out,msg,'COLL')
2475 16 : call wrtout(ab_out,msg,'COLL')
2476 :
2477 16 : write (msg, '(a,es16.6)' )' mka2f: lambda <omega^3> = ', lambda_3
2478 16 : call wrtout(std_out,msg,'COLL')
2479 16 : call wrtout(ab_out,msg,'COLL')
2480 :
2481 16 : write (msg, '(a,es16.6)' )' mka2f: lambda <omega^4> = ', lambda_4
2482 16 : call wrtout(std_out,msg,'COLL')
2483 16 : call wrtout(ab_out,msg,'COLL')
2484 :
2485 16 : write (msg, '(a,es16.6)' )' mka2f: lambda <omega^5> = ', lambda_5
2486 16 : call wrtout(std_out,msg,'COLL')
2487 16 : call wrtout(ab_out,msg,'COLL')
2488 :
2489 31 : if (elph_ds%nsppol > 1) then
2490 2 : write (msg, '(a,i6,a,es16.6,a,es16.6,a)' )' mka2f: omegalog for spin ', isppol, ' = ',&
2491 4 : & exp(omegalog(isppol)/lambda_iso(isppol)), ' (Ha) ', exp(omegalog(isppol)/lambda_iso(isppol))/kb_HaK, ' (Kelvin) '
2492 2 : call wrtout(std_out,msg,'COLL')
2493 2 : call wrtout(ab_out,msg,'COLL')
2494 : end if
2495 :
2496 : end do ! isppol
2497 :
2498 :
2499 :
2500 : !also print out spin-summed quantities
2501 31 : lambda_2 = sum(lambda_iso(1:elph_ds%nsppol))
2502 15 : write (msg, '(a,es16.6)' )' mka2f: isotropic lambda = ', lambda_2
2503 15 : call wrtout(std_out,msg,'COLL')
2504 15 : call wrtout(ab_out,msg,'COLL')
2505 :
2506 31 : omega = exp( sum(omegalog(1:elph_ds%nsppol))/lambda_2 )
2507 15 : write (msg, '(a,es16.6,a,es16.6,a)' )' mka2f: omegalog = ', omega, ' (Ha) ', omega/kb_HaK, ' (Kelvin) '
2508 15 : call wrtout(std_out,msg,'COLL')
2509 15 : call wrtout(ab_out,msg,'COLL')
2510 :
2511 15 : write (msg, '(a,es16.6)' )' mka2f: input mustar = ', mustar
2512 15 : call wrtout(std_out,msg,'COLL')
2513 15 : call wrtout(ab_out,msg,'COLL')
2514 :
2515 15 : tc_macmill = omega/1.2_dp * exp((-1.04_dp*(one+lambda_2)) / (lambda_2-mustar*(one+0.62_dp*lambda_2)))
2516 15 : write ( msg, '(a,es16.6,a,es16.6,a)')'-mka2f: MacMillan Tc = ', tc_macmill, ' (Ha) ', tc_macmill/kb_HaK, ' (Kelvin) '
2517 15 : call wrtout(std_out,msg,'COLL')
2518 15 : call wrtout(ab_out,msg,'COLL')
2519 :
2520 15 : close(unit=unit_a2f)
2521 15 : close(unit=unit_phdos)
2522 :
2523 15 : ABI_FREE(elph_ds%k_fine%wtq)
2524 15 : ABI_FREE(elph_ds%k_phon%wtq)
2525 :
2526 15 : ABI_FREE(coskr)
2527 15 : ABI_FREE(sinkr)
2528 :
2529 : DBG_EXIT("COLL")
2530 :
2531 15 : end subroutine mka2f
2532 : !!***
2533 :
2534 : !!****f* m_elphon/mka2fQgrid
2535 : !! NAME
2536 : !! mka2fQgrid
2537 : !!
2538 : !! FUNCTION
2539 : !! Calculate the Eliashberg function only using the phonon linewidths evaluated
2540 : !! in the irreducible q-points of the coarse q-grid.
2541 : !! The obtained results are useful to check the validity of the Fourier interpolation
2542 : !!
2543 : !! INPUTS
2544 : !! elph_ds = electron-phonon dataset
2545 : !! nunit = integer number for the output file
2546 : !!
2547 : !! OUTPUT
2548 : !! Only write
2549 : !!
2550 : !! SIDE EFFECTS
2551 : !!
2552 : !! SOURCE
2553 :
2554 15 : subroutine mka2fQgrid(elph_ds,fname)
2555 :
2556 : !Arguments ------------------------------------
2557 : !scalars
2558 : character(len=fnlen),intent(in) :: fname
2559 : type(elph_type),intent(in) :: elph_ds
2560 :
2561 : !Local variables -------------------------
2562 : !scalars
2563 : integer :: ibranch,iomega,iost,ismear,isppol,nsmear,nunit,qptirred
2564 : real(dp) :: a2f_factor,estep,gaussfactor,gaussprefactor,gaussval,lambda_iso
2565 : real(dp) :: omega,omegalog,omegastep,smear,tc_macmill,weight,xx
2566 : character(len=500) :: msg
2567 : !arrays
2568 15 : real(dp),allocatable :: a2f_1d(:),a2f_1mom(:),a2f_1mom_int(:),a2flogmom(:)
2569 15 : real(dp),allocatable :: a2flogmom_int(:),eli_smear(:,:,:),tmpa2f(:)
2570 :
2571 : ! *********************************************************************
2572 :
2573 : !grid for the representation of alpha^2F (same as mka2f)
2574 : !WARNING : supposing that the maximum and minimum value of frequency
2575 : !have been defined in mkelph_linwid.
2576 :
2577 15 : omegastep = (elph_ds%omega_max-elph_ds%omega_min)/(elph_ds%na2f-one)
2578 :
2579 15 : nunit = get_unit()
2580 15 : open (unit=nunit,file=fname,form='formatted',status='unknown',iostat=iost)
2581 15 : if (iost /= 0) then
2582 0 : ABI_ERROR("Opening file: " //trim(fname))
2583 : end if
2584 :
2585 : write (msg,'(3a)')&
2586 15 : & '# Eliashberg function evaluated using only the irred q-points ',ch10,'#'
2587 15 : call wrtout(nunit,msg,'COLL')
2588 :
2589 : write (msg,'(a,i5,2a,es16.8,2a,es16.8,2a,es16.8,2a)')&
2590 15 : & '# number of frequencies = ',elph_ds%na2f,ch10, &
2591 15 : & '# omega_min = ',elph_ds%omega_min,ch10, &
2592 15 : & '# omega_max = ',elph_ds%omega_max,ch10, &
2593 30 : & '# step = ',omegastep,ch10,'#'
2594 15 : call wrtout(nunit,msg,'COLL')
2595 :
2596 :
2597 15 : nsmear=5
2598 15 : estep=0.00002_dp !0.54422767 meV
2599 :
2600 : write (msg,'(a,i5,3a,f10.6,3a,f10.6,3a)') &
2601 15 : & '# Using ',nsmear,' values for the gaussian smearing ',ch10,&
2602 15 : & '# starint from ',elph_ds%a2fsmear,' (Ha)',ch10, &
2603 30 : & '# energy step of ',estep,' (Ha)',ch10,'#'
2604 15 : call wrtout(nunit,msg,'COLL')
2605 :
2606 : !e-ph quantities will be calculated for nsmear gaussian smearing values
2607 : !starting from elph_ds%a2fsmearwith an energy step of estep Hartree
2608 :
2609 15 : write (msg,'(3a)')'# Smear(Ha) Lambda_Iso isppol <ln w> (K) Tc_McMill (K) ',ch10,'#'
2610 15 : call wrtout(nunit,msg,'COLL')
2611 :
2612 45 : ABI_MALLOC(a2f_1mom,(elph_ds%na2f))
2613 30 : ABI_MALLOC(a2f_1mom_int,(elph_ds%na2f))
2614 30 : ABI_MALLOC(a2flogmom,(elph_ds%na2f))
2615 30 : ABI_MALLOC(a2flogmom_int,(elph_ds%na2f))
2616 30 : ABI_MALLOC(a2f_1d,(elph_ds%na2f))
2617 30 : ABI_MALLOC(tmpa2f,(elph_ds%na2f))
2618 60 : ABI_MALLOC(eli_smear,(nsmear,elph_ds%nsppol,elph_ds%na2f))
2619 44415 : eli_smear(:,:,:)=zero
2620 :
2621 90 : do ismear=0,nsmear-1
2622 :
2623 75 : smear = elph_ds%a2fsmear+ismear*estep
2624 75 : gaussprefactor = sqrt(piinv) / smear
2625 75 : gaussfactor = one / smear
2626 :
2627 170 : do isppol=1,elph_ds%nsppol ! spin pol channels
2628 :
2629 32080 : a2f_1d(:) = zero
2630 32080 : tmpa2f(:) = zero
2631 :
2632 335 : do qptirred=1,elph_ds%nqptirred ! sum over irred qpoints
2633 1280 : do ibranch=1,elph_ds%nbranch
2634 :
2635 945 : if (abs(elph_ds%qgrid_data(qptirred,ibranch,isppol,1)) < tol10) cycle
2636 705 : omega = elph_ds%omega_min
2637 : ! MG the weights in elph_ds%wtq(qptirred) are relative to the full grid qpt_full,
2638 : ! we need the mapping qirredtofull
2639 705 : weight=elph_ds%wtq(elph_ds%qirredtofull(qptirred))
2640 705 : a2f_factor=weight*elph_ds%qgrid_data(qptirred,ibranch,isppol,2)/abs(elph_ds%qgrid_data(qptirred,ibranch,isppol,1))
2641 :
2642 282960 : do iomega=1,elph_ds%na2f
2643 282000 : xx = (omega-elph_ds%qgrid_data(qptirred,ibranch,isppol,1))*gaussfactor
2644 282000 : gaussval = gaussprefactor*exp(-xx*xx)
2645 282000 : tmpa2f(iomega) = tmpa2f(iomega) + gaussval*a2f_factor
2646 282945 : omega = omega+omegastep
2647 : end do
2648 :
2649 : end do !end ibranch do
2650 : end do !end qptirred
2651 :
2652 32080 : a2f_1d(:)= tmpa2f(:)/(2*pi*elph_ds%n0(isppol))
2653 32080 : eli_smear(ismear+1,isppol,:)=a2f_1d(:) !save values
2654 :
2655 : ! Do isotropic calculation of lambda and output lambda, Tc(MacMillan)
2656 32080 : a2f_1mom(:) = zero
2657 80 : omega = elph_ds%omega_min
2658 :
2659 32080 : do iomega=1,elph_ds%na2f
2660 32000 : if (abs(omega) > tol10) a2f_1mom(iomega) = two*a2f_1d(iomega)/abs(omega)
2661 32080 : omega=omega+omegastep
2662 : end do
2663 :
2664 80 : call simpson_int(elph_ds%na2f,omegastep,a2f_1mom,a2f_1mom_int)
2665 80 : lambda_iso = a2f_1mom_int(elph_ds%na2f)
2666 :
2667 : ! Get log moment of alpha^2F
2668 32080 : a2flogmom(:) = zero
2669 80 : omega = elph_ds%omega_min
2670 32080 : do iomega=1,elph_ds%na2f
2671 32000 : if (abs(omega) > tol10) then
2672 31965 : a2flogmom(iomega) = (two/lambda_iso)*a2f_1d(iomega)*log(abs(omega))/abs(omega)
2673 : end if
2674 32080 : omega=omega+omegastep
2675 : end do
2676 :
2677 80 : call simpson_int(elph_ds%na2f,omegastep,a2flogmom,a2flogmom_int)
2678 80 : omegalog = exp(a2flogmom_int(elph_ds%na2f))
2679 :
2680 : tc_macmill = (omegalog/1.2_dp) * &
2681 80 : & exp((-1.04_dp*(one+lambda_iso)) / (lambda_iso-elph_ds%mustar*(one+0.62_dp*lambda_iso)))
2682 :
2683 : ! write data
2684 : write(msg,'(a,5x,f10.6,f10.6,i5,2x,f12.7,2x,f12.6,2x,es16.8)')&
2685 80 : & '# ',smear,lambda_iso,isppol,omegalog/kb_HaK,tc_macmill/kb_HaK
2686 155 : call wrtout(nunit,msg,'COLL')
2687 :
2688 : end do !end isppol
2689 :
2690 : end do !ismear
2691 :
2692 15 : ABI_FREE(a2f_1mom)
2693 15 : ABI_FREE(a2f_1mom_int)
2694 15 : ABI_FREE(a2flogmom)
2695 15 : ABI_FREE(a2flogmom_int)
2696 :
2697 : !write to file
2698 15 : write(msg,'(4a)')'#',ch10,'# Eliashberg function calculated for different gaussian smearing values',ch10
2699 15 : call wrtout(nunit,msg,'COLL')
2700 :
2701 31 : do isppol=1,elph_ds%nsppol
2702 16 : omega = elph_ds%omega_min
2703 16 : write(nunit,'(a,i5)') '# smeared alpha2F for isppol = ',isppol
2704 6416 : do iomega=1,elph_ds%na2f
2705 6400 : write(nunit,'(6(f17.12,1x))')omega,eli_smear(:,isppol,iomega)
2706 6416 : omega=omega+omegastep
2707 : end do
2708 31 : write(nunit,*)
2709 : end do
2710 :
2711 15 : ABI_FREE(eli_smear)
2712 15 : ABI_FREE(a2f_1d)
2713 15 : ABI_FREE(tmpa2f)
2714 :
2715 15 : close (nunit)
2716 :
2717 15 : end subroutine mka2fQgrid
2718 : !!***
2719 :
2720 : !!****f* m_elphon/order_fs_kpts
2721 : !!
2722 : !! NAME
2723 : !! order_fs_kpts
2724 : !!
2725 : !! FUNCTION
2726 : !! This routine re-orders the kpoints on the standard grid which belong
2727 : !! to the Fermi surface: put them in increasing z, then y, then x
2728 : !!
2729 : !! INPUTS
2730 : !! nkptirr = number of irreducible FS kpoints
2731 : !! nkpt = input nkpt from header
2732 : !! kptns = input kpt from header
2733 : !!
2734 : !! OUTPUT
2735 : !! FSirredtoGS = mapping of irreducible kpoints to GS set
2736 : !! kptirr = irreducible FS kpoint coordinates
2737 : !!
2738 : !! SOURCE
2739 :
2740 15 : subroutine order_fs_kpts(kptns, nkpt, kptirr,nkptirr,FSirredtoGS)
2741 :
2742 : !Arguments ------------------------------------
2743 : !scalars
2744 : integer,intent(in) :: nkptirr
2745 : integer,intent(in) :: nkpt
2746 :
2747 : !arrays
2748 : integer,intent(out) :: FSirredtoGS(nkptirr)
2749 : real(dp),intent(in) :: kptns(3,nkpt)
2750 : real(dp),intent(out) :: kptirr(3,nkptirr)
2751 :
2752 : !Local variables-------------------------------
2753 : !scalars
2754 : integer :: irank,ikpt,jkpt,kkpt,new, ik
2755 : real(dp) :: res
2756 15 : type(krank_t) :: krank
2757 : !arrays
2758 30 : integer :: kptirrank(nkptirr)
2759 : ! *************************************************************************
2760 :
2761 : ! rank is used to order kpoints
2762 15 : call krank%init(nkpt, kptns)
2763 :
2764 15 : ik=1
2765 1327 : do ikpt=1,nkpt
2766 1312 : irank = krank%get_rank(kptns(:,ikpt))
2767 : ! add kpt to FS kpts, in order, increasing z, then y, then x !
2768 1312 : new = 1
2769 : ! look for position to insert kpt ikpt among irredkpts already found
2770 91280 : do jkpt=1,ik-1
2771 91280 : if (kptirrank(jkpt) > irank) then
2772 : ! shift all the others up
2773 0 : do kkpt=ik-1,jkpt,-1
2774 0 : kptirr(:,kkpt+1) = kptirr(:,kkpt)
2775 0 : kptirrank(kkpt+1) = kptirrank(kkpt)
2776 0 : FSirredtoGS(kkpt+1) = FSirredtoGS(kkpt)
2777 : end do
2778 : ! insert kpoint ikpt
2779 0 : call wrap2_pmhalf(kptns(1,ikpt),kptirr(1,jkpt),res)
2780 0 : call wrap2_pmhalf(kptns(2,ikpt),kptirr(2,jkpt),res)
2781 0 : call wrap2_pmhalf(kptns(3,ikpt),kptirr(3,jkpt),res)
2782 :
2783 0 : kptirrank(jkpt) = irank
2784 0 : FSirredtoGS(jkpt) = ikpt
2785 : new=0
2786 : exit
2787 : end if
2788 : end do
2789 : ! ikpt not counted yet and higher rank than all previous
2790 : if (new == 1) then
2791 1312 : call wrap2_pmhalf(kptns(1,ikpt),kptirr(1,ikpt),res)
2792 1312 : call wrap2_pmhalf(kptns(2,ikpt),kptirr(2,ikpt),res)
2793 1312 : call wrap2_pmhalf(kptns(3,ikpt),kptirr(3,ikpt),res)
2794 1312 : kptirrank(ik) = irank
2795 1312 : FSirredtoGS(ik) = ikpt
2796 : end if
2797 1327 : ik=ik+1
2798 : end do
2799 :
2800 15 : call krank%free()
2801 :
2802 15 : end subroutine order_fs_kpts
2803 : !!***
2804 :
2805 : !!****f* m_elphon/ep_setupqpt
2806 : !!
2807 : !! NAME
2808 : !! ep_setupqpt
2809 : !!
2810 : !! FUNCTION
2811 : !! set up qpoint grid for elphon.
2812 : !! 2 modes, either uniform grid from anaddb input nqpt
2813 : !! or take qpt from anaddb input (explicitly listed)
2814 : !!
2815 : !! INPUTS
2816 : !! crystal>crystal_t>=data type gathering info on the crystalline structure.
2817 : !! anaddb_dtset=dataset with input variables
2818 : !! %qgrid_type gives type of q grid 1=uniform 2=take from input
2819 : !! %ep_nqpt number of auxiliary qpoints
2820 : !! %ep_qptlist list of qpoints,
2821 : !!
2822 : !! OUTPUT
2823 : !!
2824 : !! NOTES
2825 : !!
2826 : !! SOURCE
2827 :
2828 15 : subroutine ep_setupqpt (elph_ds,crystal,anaddb_dtset,qptrlatt,timrev)
2829 :
2830 : !Arguments -------------------------------
2831 : !scalars
2832 : integer, intent(in) :: timrev
2833 : type(crystal_t),intent(in) :: crystal
2834 : type(anaddb_dataset_type), intent(in) :: anaddb_dtset
2835 : type(elph_type), intent(inout) :: elph_ds
2836 : !arrays
2837 : integer, intent(out) :: qptrlatt(3,3)
2838 :
2839 : !Local variables -------------------------
2840 : !scalars
2841 : integer :: nqshft,option,iqpt, nqpt1
2842 : integer :: iscf,mqpt,iout,berryopt,nqpt_computed
2843 : real(dp) :: qptrlen, res
2844 : character(len=500) :: message
2845 : !arrays
2846 : integer :: vacuum(3)
2847 15 : integer,allocatable :: indqpt1(:)
2848 : real(dp) :: kpt(3)
2849 15 : integer, allocatable :: bz2ibz_smap(:,:)
2850 15 : real(dp),allocatable :: wtq_folded(:)
2851 15 : real(dp), allocatable :: wtq(:),qpt_full(:,:),tmpshifts(:,:)
2852 :
2853 : ! *********************************************************************
2854 :
2855 : !default is to expect a uniform grid
2856 15 : elph_ds%tuniformgrid = 1
2857 :
2858 : !if we use the normal grid way of generating the qpoints:
2859 15 : if (anaddb_dtset%qgrid_type==1) then
2860 : ! qpoint lattice vectors (inverse, like kptrlatt)
2861 15 : qptrlatt(:,:)=0
2862 15 : qptrlatt(1,1)=anaddb_dtset%ngqpt(1)
2863 15 : qptrlatt(2,2)=anaddb_dtset%ngqpt(2)
2864 15 : qptrlatt(3,3)=anaddb_dtset%ngqpt(3)
2865 :
2866 15 : if (anaddb_dtset%nqshft /= 1) then
2867 : ! try to reduce the qpoint grid to a single qshift, otherwise stop
2868 : ! dummy args for call to getkgrid
2869 0 : vacuum(:) = 0
2870 0 : iscf = 3
2871 :
2872 0 : mqpt = anaddb_dtset%ngqpt(1)*anaddb_dtset%ngqpt(2)*anaddb_dtset%ngqpt(3)*anaddb_dtset%nqshft
2873 0 : ABI_MALLOC(qpt_full,(3,mqpt))
2874 0 : ABI_MALLOC(wtq,(mqpt))
2875 0 : ABI_MALLOC(tmpshifts,(3,MAX_NSHIFTK))
2876 :
2877 0 : wtq(:) = one
2878 :
2879 0 : tmpshifts(:,:) = zero
2880 0 : tmpshifts(:,1:4) = anaddb_dtset%q1shft(:,:)
2881 :
2882 : iout=6
2883 :
2884 0 : berryopt = 1
2885 :
2886 : ! just call with identity, to get full set of kpts in qpt_full, but
2887 : ! reduce qshfts
2888 :
2889 0 : nqshft=anaddb_dtset%nqshft
2890 : call getkgrid(0,0,iscf,qpt_full,3,qptrlatt,qptrlen, &
2891 : & 1,mqpt,nqpt_computed,nqshft,1,crystal%rprimd,tmpshifts,crystal%symafm, &
2892 0 : & crystal%symrel,vacuum,wtq)
2893 0 : ABI_FREE(qpt_full)
2894 0 : ABI_FREE(wtq)
2895 0 : ABI_FREE(tmpshifts)
2896 :
2897 : if (anaddb_dtset%nqshft /= 1) then
2898 : write (message,'(a,i0)')&
2899 0 : & ' multiple qpt shifts not treated yet (should be possible), nqshft= ', anaddb_dtset%nqshft
2900 0 : ABI_ERROR(message)
2901 : end if
2902 : end if ! end multiple shifted qgrid
2903 :
2904 :
2905 15 : write(message,'(a,9(i0,1x))')' elphon : enter smpbz with qptrlatt = ',qptrlatt
2906 15 : call wrtout(std_out,message,'COLL')
2907 :
2908 15 : option=1
2909 : ! mqpt=anaddb_dtset%ngqpt(1)*anaddb_dtset%ngqpt(2)*anaddb_dtset%ngqpt(3)*anaddb_dtset%nqshft
2910 : mqpt= qptrlatt(1,1)*qptrlatt(2,2)*qptrlatt(3,3) &
2911 : & +qptrlatt(1,2)*qptrlatt(2,3)*qptrlatt(3,1) &
2912 : & +qptrlatt(1,3)*qptrlatt(2,1)*qptrlatt(3,2) &
2913 : & -qptrlatt(1,2)*qptrlatt(2,1)*qptrlatt(3,3) &
2914 : & -qptrlatt(1,3)*qptrlatt(2,2)*qptrlatt(3,1) &
2915 15 : & -qptrlatt(1,1)*qptrlatt(2,3)*qptrlatt(3,2)
2916 :
2917 45 : ABI_MALLOC(qpt_full,(3,mqpt))
2918 15 : iout = 6
2919 15 : call smpbz(anaddb_dtset%brav,iout,qptrlatt,mqpt,elph_ds%nqpt_full,anaddb_dtset%nqshft,option,anaddb_dtset%q1shft,qpt_full)
2920 :
2921 :
2922 : ! save the q-grid for future reference
2923 45 : ABI_MALLOC(elph_ds%qpt_full,(3,elph_ds%nqpt_full))
2924 :
2925 : ! reduce qpt_full to correct zone
2926 135 : do iqpt=1,elph_ds%nqpt_full
2927 120 : call wrap2_pmhalf(qpt_full(1,iqpt),kpt(1),res)
2928 120 : call wrap2_pmhalf(qpt_full(2,iqpt),kpt(2),res)
2929 120 : call wrap2_pmhalf(qpt_full(3,iqpt),kpt(3),res)
2930 480 : qpt_full(:,iqpt) = kpt
2931 495 : elph_ds%qpt_full(:,iqpt)=kpt
2932 : end do
2933 15 : ABI_FREE(qpt_full)
2934 :
2935 0 : else if (anaddb_dtset%qgrid_type==2) then ! use explicit list of qpoints from anaddb input
2936 0 : qptrlatt(:,:)=0
2937 0 : qptrlatt(1,1)=1
2938 0 : qptrlatt(2,2)=1
2939 0 : qptrlatt(3,3)=1
2940 :
2941 0 : elph_ds%nqpt_full=anaddb_dtset%ep_nqpt
2942 0 : ABI_MALLOC(elph_ds%qpt_full,(3,elph_ds%nqpt_full))
2943 :
2944 0 : elph_ds%qpt_full = anaddb_dtset%ep_qptlist
2945 :
2946 0 : elph_ds%tuniformgrid = 0
2947 : end if ! type of qgrid for elphon
2948 :
2949 : !=================================================================
2950 : !Calculate weights, needed to estimate lambda using the weighted
2951 : !sum of the uninterpolated e-ph matrix elements
2952 : !=================================================================
2953 15 : call wrtout(std_out,' setqgrid : calling symkpt to find irred q points',"COLL")
2954 :
2955 45 : ABI_MALLOC(indqpt1,(elph_ds%nqpt_full))
2956 45 : ABI_MALLOC(wtq_folded,(elph_ds%nqpt_full))
2957 30 : ABI_MALLOC(wtq,(elph_ds%nqpt_full))
2958 45 : ABI_MALLOC(bz2ibz_smap, (6, elph_ds%nqpt_full))
2959 :
2960 135 : wtq(:) = one/dble(elph_ds%nqpt_full) !weights normalized to unity
2961 :
2962 : !
2963 : !NOTE: this reduction of irred qpt may not be identical to that in GKK file
2964 : !which would be more practical to use.
2965 : !
2966 15 : iout=0 !do not write to ab_out
2967 : !should we save indqpt1 for use inside elph_ds?
2968 : call symkpt(0,crystal%gmet,indqpt1,iout,elph_ds%qpt_full,elph_ds%nqpt_full,nqpt1,crystal%nsym,crystal%symrec,&
2969 15 : & timrev,wtq,wtq_folded, bz2ibz_smap, xmpi_comm_self)
2970 :
2971 15 : ABI_FREE(bz2ibz_smap)
2972 :
2973 15 : write (message,'(2a,i0)')ch10,' Number of irreducible q-points = ',nqpt1
2974 15 : call wrtout(std_out,message,'COLL')
2975 15 : elph_ds%nqptirred=nqpt1
2976 :
2977 15 : call wrtout(std_out,' === Irreducible q points with weights ==== ','COLL')
2978 :
2979 135 : do iqpt=1,elph_ds%nqpt_full
2980 135 : if (wtq_folded(iqpt) /= zero) then
2981 48 : write (message,'(1x,i4,a2,4es16.8)')iqpt,') ',elph_ds%qpt_full(:,iqpt),wtq_folded(iqpt)
2982 48 : call wrtout(std_out,message,'COLL')
2983 : end if
2984 : end do
2985 :
2986 15 : call wrtout(std_out,ch10,'COLL')
2987 :
2988 45 : ABI_MALLOC(elph_ds%wtq,(elph_ds%nqpt_full))
2989 :
2990 135 : elph_ds%wtq(:)=wtq_folded(:)
2991 : !MEMO indqpt could be useful to test the qgrid read by abinit
2992 15 : ABI_FREE(indqpt1)
2993 15 : ABI_FREE(wtq_folded)
2994 15 : ABI_FREE(wtq)
2995 :
2996 15 : end subroutine ep_setupqpt
2997 : !!***
2998 :
2999 : !!****f* ABINIT/mkph_linwid
3000 : !!
3001 : !! NAME
3002 : !! mkph_linwid
3003 : !!
3004 : !! FUNCTION
3005 : !! Calculate the phonon linewidths on a trajectory in q space
3006 : !!
3007 : !! INPUTS
3008 : !! Cryst<crystal_t>=Info on the unit cell and symmetries.
3009 : !! Ifc<ifc_type>=Object containing the interatomic force constants.
3010 : !! elph_ds = datastructure with phonon matrix elements
3011 : !! nqpath = dimension of qpath_vertices
3012 : !! qpath_vertices = vertices of reciprocal space trajectory
3013 : !!
3014 : !! OUTPUT
3015 : !!
3016 : !! SIDE EFFECTS
3017 : !!
3018 : !! SOURCE
3019 :
3020 15 : subroutine mkph_linwid(Cryst,ifc,elph_ds,nqpath,qpath_vertices)
3021 :
3022 : !Arguments ------------------------------------
3023 : !scalars
3024 : integer,intent(in) :: nqpath
3025 : type(crystal_t),intent(in) :: Cryst
3026 : type(ifc_type),intent(in) :: ifc
3027 : type(elph_type),intent(inout) :: elph_ds
3028 : !arrays
3029 : real(dp),intent(in) :: qpath_vertices(3,nqpath)
3030 :
3031 : !Local variables-------------------------------
3032 : !scalars
3033 : integer :: ibranch,natom,ii,indx,ipoint,nbranch,nqbz,nsppol,nrpt
3034 : integer :: isppol,jbranch,qtor,unit_bs,unit_lambda,unit_lwd,npt_tot
3035 : real(dp) :: diagerr,res
3036 : character(len=500) :: msg
3037 : character(len=fnlen) :: fname,base_name
3038 : !arrays
3039 30 : integer :: ndiv(nqpath-1)
3040 15 : integer, allocatable :: indxprtqpt(:)
3041 : complex(dp),parameter :: c0=dcmplx(0._dp,0._dp),c1=dcmplx(1._dp,0._dp)
3042 30 : real(dp) :: displ_cart(2,3*Cryst%natom,3*Cryst%natom)
3043 30 : real(dp) :: displ_red(2,3*Cryst%natom,3*Cryst%natom)
3044 30 : real(dp) :: eigval(3*Cryst%natom)
3045 30 : real(dp) :: gam_now(2,(3*Cryst%natom)**2)
3046 30 : real(dp) :: imeigval(3*Cryst%natom)
3047 30 : real(dp) :: lambda(3*Cryst%natom)
3048 30 : real(dp) :: pheigvec(2*3*Cryst%natom*3*Cryst%natom),phfrq_tmp(3*Cryst%natom)
3049 : real(dp) :: qpt(3),redkpt(3)
3050 30 : real(dp) :: tmpgam1(2,3*Cryst%natom,3*Cryst%natom)
3051 30 : real(dp) :: tmpgam2(2,3*Cryst%natom,3*Cryst%natom)
3052 15 : real(dp), allocatable :: coskr(:,:), sinkr(:,:),finepath(:,:)
3053 :
3054 : ! *********************************************************************
3055 :
3056 : DBG_ENTER("COLL")
3057 :
3058 15 : natom = Cryst%natom
3059 15 : nbranch = elph_ds%nbranch
3060 15 : nsppol = elph_ds%nsppol
3061 15 : base_name = elph_ds%elph_base_name
3062 15 : nrpt = ifc%nrpt
3063 :
3064 : !===================================================================
3065 : !Definition of the q path along which ph linwid will be interpolated
3066 : !===================================================================
3067 15 : call make_path(nqpath,qpath_vertices,Cryst%gmet,'G',20,ndiv,npt_tot,finepath)
3068 45 : ABI_MALLOC(indxprtqpt,(npt_tot))
3069 3564 : indxprtqpt = 0
3070 :
3071 : !==========================================================
3072 : !Open _LWD file and write header
3073 : !==========================================================
3074 15 : fname=trim(base_name) // '_LWD'
3075 15 : if (open_file(fname,msg,newunit=unit_lwd,status="unknown") /= 0) then
3076 0 : ABI_ERROR(msg)
3077 : end if
3078 :
3079 15 : write (unit_lwd,'(a)') '#'
3080 15 : write (unit_lwd,'(a)') '# ABINIT package : Phonon linewidth file'
3081 15 : write (unit_lwd,'(a)') '#'
3082 15 : write (unit_lwd,'(a,i10,a)') '# Phonon linewidths calculated on ',npt_tot,' points along the qpath'
3083 15 : write (unit_lwd,'(a)') '# Description of the Q-path :'
3084 15 : write (unit_lwd, '(a,i10)') '# Number of line segments = ',nqpath-1
3085 15 : write (unit_lwd,'(a)') '# Vertices of the Q-path and corresponding index = '
3086 :
3087 15 : indx=1
3088 15 : indxprtqpt(1) = 1
3089 15 : indxprtqpt(npt_tot) = 1
3090 :
3091 135 : do ii=1,nqpath
3092 120 : write (unit_lwd,'(a,3(e16.6,1x),i8)')'# ',qpath_vertices(:,ii),indx
3093 135 : if (ii<nqpath) then
3094 105 : indx=indx+ndiv(ii)
3095 105 : indxprtqpt(indx) = 1
3096 : end if
3097 : end do
3098 :
3099 15 : write (unit_lwd,'(a)')'#'
3100 :
3101 : !==========================================================
3102 : !Open _BST file and write header
3103 : !==========================================================
3104 15 : fname=trim(base_name) // '_BST'
3105 15 : if (open_file(fname,msg,newunit=unit_bs,status="unknown") /= 0) then
3106 0 : ABI_ERROR(msg)
3107 : end if
3108 :
3109 15 : write (unit_bs, '(a)') '#'
3110 15 : write (unit_bs, '(a)') '# ABINIT package : Phonon band structure file'
3111 15 : write (unit_bs, '(a)') '#'
3112 15 : write (unit_bs, '(a,i10,a)')'# Phonon BS calculated on ', npt_tot,' points along the qpath'
3113 15 : write (unit_bs, '(a,i10)') '# Number of line segments = ', nqpath-1
3114 15 : indx=1
3115 135 : do ii=1,nqpath
3116 120 : write (unit_bs,'(a,3(E16.6,1x),i8)')'# ',qpath_vertices(:,ii),indx
3117 135 : if (ii<nqpath) indx=indx+ndiv(ii)
3118 : end do
3119 15 : write (unit_bs,'(a)')'#'
3120 :
3121 : !MG20060606
3122 : !==========================================================
3123 : !open _LAMBDA file and write header
3124 : !contains \omega(q,n) and \lambda(q,n) and can be plotted using xmgrace
3125 : !==========================================================
3126 15 : fname=trim(base_name) // '_LAMBDA'
3127 15 : if (open_file(fname,msg,newunit=unit_lambda,status="unknown") /= 0) then
3128 0 : ABI_ERROR(msg)
3129 : end if
3130 :
3131 15 : write (unit_lambda,'(a)') '#'
3132 15 : write (unit_lambda,'(a)') '# ABINIT package : Lambda file'
3133 15 : write (unit_lambda,'(a)') '#'
3134 15 : write (unit_lambda,'(a,i10,a)')'# Lambda(q,nu) calculated on ',npt_tot,' Q-points'
3135 15 : write (unit_lambda,'(a)') '# Description of the Q-path :'
3136 15 : write (unit_lambda,'(a,i10)') '# Number of line segments = ',nqpath-1
3137 15 : write (unit_lambda,'(a)') '# Vertices of the Q-path and corresponding index = '
3138 :
3139 15 : indx=1
3140 135 : do ii=1,nqpath
3141 120 : write (unit_lambda,'(a,3(E16.6,1x),i8)')'# ',qpath_vertices(:,ii),indx
3142 135 : if (ii<nqpath) indx=indx+ndiv(ii)
3143 : end do
3144 15 : write (unit_lambda,'(a)')'#'
3145 15 : write (unit_lambda,'(a)')'# index frequency lambda(q,n) frequency lambda(q,n) .... lambda_tot'
3146 15 : write (unit_lambda,'(a)')'#'
3147 :
3148 : !real space to q space
3149 15 : qtor=0
3150 :
3151 : !initialize the maximum phonon frequency
3152 15 : elph_ds%omega_min = zero
3153 15 : elph_ds%omega_max = zero
3154 :
3155 60 : ABI_MALLOC(coskr, (npt_tot,nrpt))
3156 45 : ABI_MALLOC(sinkr, (npt_tot,nrpt))
3157 15 : call ftgam_init(ifc%gprim, npt_tot, nrpt, finepath, ifc%rpt, coskr, sinkr)
3158 :
3159 75 : write (std_out,*) ' mkph_linwid : shape(elph_ds%gamma_qpt) = ',shape(elph_ds%gamma_qpt)
3160 15 : nqbz = SIZE(elph_ds%gamma_qpt,DIM=4)
3161 15 : write(std_out,*) " nqbz = SIZE(elph_ds%gamma_qpt,DIM=4) = ",nqbz
3162 : !
3163 : !Big do loop over spin polarizations
3164 : !could put in locally, so phonon stuff is not done twice...
3165 : !
3166 31 : do isppol=1,nsppol
3167 16 : indx=1
3168 :
3169 : ! Output to the main output file
3170 16 : write(msg,'(a,a)')ch10,&
3171 32 : & ' Output of the linewidths for the first point of each segment. Linewidths are given in Hartree.'
3172 16 : call wrtout(std_out,msg,'COLL')
3173 16 : call wrtout(ab_out,msg,'COLL')
3174 :
3175 16 : write (std_out,*) ' mkph_linwid : elph_ds%ep_scalprod = ', elph_ds%ep_scalprod
3176 :
3177 : qtor = 0
3178 :
3179 : ! Interpolation along specified path in q space
3180 3781 : do ipoint=1,npt_tot
3181 :
3182 : ! Get qpoint along the path from qpath_vertices
3183 15060 : qpt(:) = finepath(:,ipoint)
3184 :
3185 3765 : call wrap2_pmhalf(qpt(1),redkpt(1),res)
3186 3765 : call wrap2_pmhalf(qpt(2),redkpt(2),res)
3187 3765 : call wrap2_pmhalf(qpt(3),redkpt(3),res)
3188 3765 : qpt(:) = redkpt(:)
3189 : !
3190 : ! This reduced version of ftgkk supposes the kpoints have been integrated
3191 : ! in integrate_gamma. Do FT from real-space gamma grid to 1 qpt.
3192 : call ftgam(ifc%wghatm,gam_now,elph_ds%gamma_rpt(:,:,isppol,:),natom,1,ifc%nrpt,qtor, &
3193 617967 : & coskr(ipoint,:), sinkr(ipoint,:))
3194 : !
3195 : ! get phonon freqs and eigenvectors anyway
3196 : !
3197 3765 : call ifc%fourq(cryst,qpt,phfrq_tmp,displ_cart,out_eigvec=pheigvec)
3198 : !
3199 : ! additional frequency factor for some cases
3200 : !
3201 : ! If the matrices do not contain the scalar product with the displ_cart vectors yet do it now
3202 3765 : if (elph_ds%ep_scalprod == 0) then
3203 :
3204 2592 : call phdispl_cart2red(natom,Cryst%gprimd,displ_cart,displ_red)
3205 :
3206 10368 : tmpgam2 = reshape (gam_now, (/2,nbranch,nbranch/))
3207 2592 : call gam_mult_displ(nbranch, displ_red, tmpgam2, tmpgam1)
3208 :
3209 10368 : do jbranch=1,nbranch
3210 7776 : eigval(jbranch) = tmpgam1(1, jbranch, jbranch)
3211 7776 : imeigval(jbranch) = tmpgam1(2, jbranch, jbranch)
3212 :
3213 10368 : if (abs(imeigval(jbranch)) > tol8) then
3214 0 : write (msg,'(a,i0,a,es16.8)')' imaginary values for branch = ',jbranch,' imeigval = ',imeigval(jbranch)
3215 0 : ABI_WARNING(msg)
3216 : end if
3217 : end do
3218 :
3219 1173 : else if (elph_ds%ep_scalprod == 1) then
3220 : !
3221 : ! Diagonalize gamma matrix at qpoint (complex matrix).
3222 : ! MJV NOTE: gam_now is recast implicitly here to matrix
3223 : call ZGEMM ( 'N', 'N', 3*natom, 3*natom, 3*natom, c1, gam_now, 3*natom,&
3224 1173 : & pheigvec, 3*natom, c0, tmpgam1, 3*natom)
3225 :
3226 : call ZGEMM ( 'C', 'N', 3*natom, 3*natom, 3*natom, c1, pheigvec, 3*natom,&
3227 1173 : & tmpgam1, 3*natom, c0, tmpgam2, 3*natom)
3228 :
3229 1173 : diagerr = zero
3230 7563 : do ibranch=1,nbranch
3231 :
3232 6390 : eigval(ibranch) = tmpgam2(1,ibranch,ibranch)
3233 :
3234 21393 : do jbranch=1,ibranch-1
3235 21393 : diagerr = diagerr + abs(tmpgam2(1,jbranch,ibranch))+abs(tmpgam2(2,jbranch,ibranch))
3236 : end do
3237 21393 : do jbranch=ibranch+1,nbranch
3238 21393 : diagerr = diagerr + abs(tmpgam2(1,jbranch,ibranch))+abs(tmpgam2(2,jbranch,ibranch))
3239 : end do
3240 7563 : diagerr = diagerr + abs(tmpgam2(2,ibranch,ibranch))
3241 : end do
3242 :
3243 1173 : if (diagerr > tol12) then
3244 1018 : write (msg,'(a,es14.6)')' Numerical error in diagonalization of gamma with phon eigenvectors: ', diagerr
3245 1018 : ABI_WARNING(msg)
3246 : end if
3247 :
3248 : else
3249 0 : write (msg,'(a,i0)')' Wrong value for elph_ds%ep_scalprod = ',elph_ds%ep_scalprod
3250 0 : ABI_BUG(msg)
3251 : end if ! end elph_ds%ep_scalprod if
3252 : !
3253 : ! ==========================================================
3254 : ! write data to files for each q point
3255 : ! ==========================================================
3256 3765 : write (unit_lwd,'(i5)', advance='no') indx
3257 17931 : do ii=1, nbranch
3258 17931 : write (unit_lwd,'(E16.5)',advance='no') eigval(ii)
3259 : end do
3260 3765 : write (unit_lwd,*)
3261 :
3262 : ! only print phonon BS for isppol 1: independent of electron spins
3263 3765 : if (isppol==1) then
3264 3549 : write (unit_bs,'(i5)', advance='no') indx
3265 17067 : do ii=1, nbranch
3266 17067 : write (unit_bs,'(E16.5)',advance='no') phfrq_tmp(ii)
3267 : end do
3268 3549 : write (unit_bs,*)
3269 : end if
3270 :
3271 3765 : write (unit_lambda,'(i5)', advance='no') indx
3272 17931 : do ii=1,nbranch
3273 14166 : lambda(ii)=zero
3274 14166 : if (abs(phfrq_tmp(ii)) > tol10) lambda(ii)=eigval(ii)/(pi*elph_ds%n0(isppol)*phfrq_tmp(ii)**2)
3275 17931 : write (unit_lambda,'(es16.8)',advance='no')phfrq_tmp(ii),lambda(ii)
3276 : end do
3277 17931 : write (unit_lambda,'(es16.8)',advance='no') sum(lambda)
3278 3765 : write (unit_lambda,*)
3279 :
3280 : ! MG NOTE: I wrote a piece of code to output all these quantities using units
3281 : ! chosen by the user, maybe in version 5.2?
3282 : ! In this version the output of lambda(q,\nu) has been added
3283 :
3284 : ! Output to the main output file, for first point in segment
3285 3765 : if(indxprtqpt(ipoint)==1)then
3286 127 : write(msg,'(a,a,3es16.6,a,i4,a,a)')ch10,&
3287 127 : & ' Q point =',qpt(:),' isppol = ',isppol,ch10,&
3288 254 : & ' Mode number Frequency (Ha) Linewidth (Ha) Lambda(q,n)'
3289 127 : call wrtout(std_out,msg,'COLL')
3290 127 : call wrtout(ab_out,msg,'COLL')
3291 616 : do ii=1,nbranch
3292 489 : write(msg,'(i8,es20.6,2es16.6)' )ii,phfrq_tmp(ii),eigval(ii),lambda(ii)
3293 489 : call wrtout(std_out,msg,'COLL')
3294 616 : call wrtout(ab_out,msg,'COLL')
3295 : end do
3296 : end if
3297 :
3298 : ! find max/min phonon frequency along path chosen
3299 : ! presumed to be representative of full BZ to within 10 percent
3300 3765 : elph_ds%omega_min = min(elph_ds%omega_min,1.1_dp*phfrq_tmp(1))
3301 3765 : elph_ds%omega_max = max(elph_ds%omega_max,1.1_dp*phfrq_tmp(nbranch))
3302 :
3303 3781 : indx = indx+1
3304 : end do ! end ipoint do
3305 :
3306 : ! add blank lines to output files between sppol
3307 16 : write(msg,'(a)' ) ''
3308 16 : call wrtout(unit_lwd,msg,'COLL')
3309 16 : call wrtout(unit_lambda,msg,'COLL')
3310 16 : call wrtout(std_out,msg,'COLL')
3311 31 : call wrtout(ab_out,msg,'COLL')
3312 : end do ! isppol
3313 :
3314 15 : ABI_FREE(coskr)
3315 15 : ABI_FREE(sinkr)
3316 :
3317 15 : close(unit=unit_lwd)
3318 15 : close(unit=unit_bs)
3319 15 : close(unit=unit_lambda)
3320 :
3321 15 : ABI_FREE(finepath)
3322 15 : ABI_FREE(indxprtqpt)
3323 :
3324 15 : write(std_out,*) ' elph_linwid : omega_min, omega_max = ',elph_ds%omega_min, elph_ds%omega_max
3325 :
3326 : DBG_EXIT("COLL")
3327 :
3328 15 : end subroutine mkph_linwid
3329 : !!***
3330 :
3331 : !!****f* ABINIT/get_fs_bands
3332 : !!
3333 : !! NAME
3334 : !! get_fs_bands
3335 : !!
3336 : !! FUNCTION
3337 : !! This routine determines the bands which contribute to the Fermi surface
3338 : !!
3339 : !! INPUTS
3340 : !! eigenGS = ground state eigenvalues
3341 : !! hdr = header from input GS file
3342 : !! ep_b_min, ep_b_max=A non-zero value is used to impose certain bands.
3343 : !! fermie=Fermi level.
3344 : !! eigenGS(hdr%nband(1),hdr%nkpt,hdr%nsppol)=Energies.
3345 : !!
3346 : !! OUTPUT
3347 : !! minFSband,maxFSband=Minimun and maximum index for the bands that cross the Fermi level
3348 : !! nkptirr=Number of irreducible points for which there exist at least one band that crosses the Fermi level.
3349 : !!
3350 : !! TODO
3351 : !! 1) Indeces and dimensions should should be spin dependent.
3352 : !! 2) In the present status of the code, all the k-points in the IBZ are used!
3353 : !!
3354 : !! SOURCE
3355 :
3356 15 : subroutine get_fs_bands(eigenGS,hdr,fermie,ep_b_min,ep_b_max,minFSband,maxFSband,nkptirr)
3357 :
3358 : !Arguments ------------------------------------
3359 : !scalars
3360 : integer, intent(in) :: ep_b_min, ep_b_max
3361 : integer,intent(out) :: minFSband,maxFSband,nkptirr
3362 : real(dp),intent(in) :: fermie
3363 : type(hdr_type),intent(in) :: hdr
3364 : !arrays
3365 : real(dp),intent(in) :: eigenGS(hdr%nband(1),hdr%nkpt,hdr%nsppol)
3366 :
3367 : !Local variables-------------------------------
3368 : !scalars
3369 : integer :: iband,ikpt,isppol,nband
3370 : real(dp) :: epsFS,gausstol,gaussig
3371 : character(len=500) :: message
3372 30 : integer :: kpt_phonflag(hdr%nkpt)
3373 : ! *************************************************************************
3374 :
3375 : !supposes nband is equal for all kpts
3376 15 : nband = hdr%nband(1)
3377 :
3378 : !gausstol = minimum weight value for integration weights on FS
3379 : !should be set to reproduce DOS at Ef (Ref. PRB 34, 5065 [[cite:Lam1986]] p. 5067)
3380 15 : gausstol = 1.0d-10
3381 :
3382 : !use same band indices in both spin channels
3383 15 : maxFSband=1
3384 15 : minFSband=nband
3385 :
3386 : !window of states around fermi Energy is contained in +/- epsFS
3387 : !should be adjusted to take into account a minimal but sufficient
3388 : !fraction of the kpoints: see the loop below.
3389 : !The 1000 is purely empirical!!!
3390 : !Should also take into account the density of kpoints.
3391 : !gaussig = width of gaussian energy window around fermi energy
3392 : !needed to get a good fraction of kpoints contributing to the FS
3393 :
3394 29166 : gaussig = (maxval(eigenGS)-minval(eigenGS))/1000.0_dp
3395 :
3396 15 : write (message,'(a,f11.8,2a)')' get_fs_bands : initial energy window = ',gaussig,ch10,&
3397 30 : & ' The window energy will be increased until the full k-grid is inside the range'
3398 15 : call wrtout(std_out,message,'COLL')
3399 :
3400 : !NOTE: could loop back to here and change gaussig until we have
3401 : !a certain fraction of the kpoints in the FS region...
3402 15 : nkptirr = 0
3403 :
3404 : !Do not use restricted fermi surface: include all kpts -> one
3405 1155 : do while (nkptirr < hdr%nkpt)
3406 1140 : gaussig = gaussig*1.05_dp
3407 :
3408 : ! we must take into account kpoints with states within epsFS:
3409 1140 : epsFS = gaussig*sqrt(log(one/(gaussig*sqrt(pi)*gausstol)))
3410 :
3411 : ! check if there are eigenvalues close to the Fermi surface
3412 : ! (less than epsFS from it)
3413 106564 : kpt_phonflag(:) = 0
3414 :
3415 : ! do for each sppol channel
3416 2308 : do isppol=1,hdr%nsppol
3417 107956 : do ikpt=1,hdr%nkpt
3418 1162848 : do iband=1,nband
3419 1161680 : if (abs(eigenGS(iband,ikpt,isppol) - fermie) < epsFS) then
3420 135941 : kpt_phonflag(ikpt) = 1
3421 135941 : if (iband > maxFSband) maxFSband = iband
3422 135941 : if (iband < minFSband) minFSband = iband
3423 : end if
3424 : end do
3425 : end do
3426 : end do ! isppol
3427 :
3428 : ! if user imposed certain bands for e-p, make sure they are kept
3429 1140 : if (ep_b_min /= 0 .and. ep_b_min < minFSband) then
3430 0 : minFSband = ep_b_min
3431 : end if
3432 1140 : if (ep_b_max /= 0 .and. ep_b_max > maxFSband) then
3433 1 : maxFSband = ep_b_max
3434 : end if
3435 :
3436 : ! number of irreducible kpoints (by all sym) contributing to the Fermi surface (to be completed by symops).
3437 106579 : nkptirr = sum(kpt_phonflag(:))
3438 : end do
3439 :
3440 15 : write(std_out,*) ' Energy window around Fermi level= ',epsFS,' nkptirr= ',nkptirr
3441 :
3442 15 : end subroutine get_fs_bands
3443 : !!***
3444 :
3445 : !!****f* ABINIT/get_all_gkk2
3446 : !! NAME
3447 : !! get_all_gkk2
3448 : !!
3449 : !! FUNCTION
3450 : !! This routine determines where to store gkk2 matrix elements (disk or RAM)
3451 : !! and calls interpolate_gkk to calculate them.
3452 : !! This is the most time consuming step.
3453 : !!
3454 : !! INPUTS
3455 : !! acell = lengths of unit cell vectors
3456 : !! amu = masses of atoms
3457 : !! atmfrc = atomic force constants
3458 : !! dielt = dielectric tensor
3459 : !! dipdip = dipole-dipole contribution flag
3460 : !! dyewq0 =
3461 : !! elph_ds = datastructure for elphon data and dimensions
3462 : !! kptirr_phon = irreducible set of fermi-surface kpoints
3463 : !! kpt_phon = full set of fermi-surface kpoints
3464 : !! ftwghtgkk = weights for FT of matrix elements
3465 : !! gmet = metric in reciprocal space
3466 : !! indsym = indirect mapping of atoms under symops
3467 : !! mpert = maximum number of perturbations
3468 : !! msym = maximum number of symmetries (usually nsym)
3469 : !! nsym = number of symmetries
3470 : !! ntypat = number of types of atoms
3471 : !! onegkksize = size of one gkk record, in bytes
3472 : !! rmet = real-space metric
3473 : !! rprim = unit cell lattice vectors (dimensionless)
3474 : !! rprimd = real-space unit-cell lattice vectors
3475 : !! rpt = points in real space for FT, in canonical coordinates
3476 : !! symrel = symmetry operations in reduced real space
3477 : !! trans = Atomic translations : xred = rcan + trans
3478 : !! typat = array of types of atoms
3479 : !! ucvol = unit cell volume
3480 : !! xred = reduced coordinates of atoms
3481 : !! zeff = Born effective charges
3482 : !!
3483 : !! OUTPUT
3484 : !! elph_ds = calculated |gkk|^2 are in elph_ds%gkk2
3485 : !!
3486 : !! SOURCE
3487 :
3488 : subroutine get_all_gkk2(crystal,ifc,elph_ds,kptirr_phon,kpt_phon)
3489 :
3490 : !Arguments ------------------------------------
3491 : !scalars
3492 : type(crystal_t),intent(in) :: crystal
3493 : type(ifc_type),intent(in) :: ifc
3494 : type(elph_type),intent(inout) :: elph_ds
3495 : !arrays
3496 : real(dp),intent(in) :: kpt_phon(3,elph_ds%k_phon%nkpt)
3497 : real(dp),intent(in) :: kptirr_phon(3,elph_ds%k_phon%nkptirr)
3498 :
3499 : !Local variables-------------------------------
3500 : !scalars
3501 : integer :: iost,onediaggkksize,sz1,sz2,sz3,sz4
3502 : real(dp) :: realdp_ex
3503 : !character(len=500) :: msg
3504 : ! *************************************************************************
3505 :
3506 : if (elph_ds%nsppol /= 1) then
3507 : ABI_ERROR('get_all_gkk2: nsppol>1 not coded yet!')
3508 : end if
3509 :
3510 : onediaggkksize = elph_ds%nbranch*elph_ds%k_phon%nkpt*kind(realdp_ex)
3511 :
3512 : elph_ds%unit_gkk2 = 37
3513 : if (elph_ds%gkk2write == 0) then
3514 : write(std_out,*) 'get_all_gkk2 : keep gkk2 in memory. Size = ',&
3515 : & 4.0*dble(elph_ds%k_phon%nkpt)*dble(onediaggkksize)/&
3516 : & 1024.0_dp/1024.0_dp, " Mb"
3517 : sz1=elph_ds%nbranch
3518 : sz2=elph_ds%ngkkband
3519 : sz3=elph_ds%ngkkband
3520 : sz4=elph_ds%k_phon%nkpt
3521 : ABI_MALLOC(elph_ds%gkk2,(sz1,sz2,sz3,sz4,elph_ds%k_phon%nkpt,1))
3522 : elph_ds%gkk2(:,:,:,:,:,:) = zero
3523 :
3524 : else if (elph_ds%gkk2write == 1) then
3525 : write(std_out,*) 'get_all_gkk2 : About to open gkk2 file : '
3526 : write(std_out,*) elph_ds%unit_gkk2,onediaggkksize
3527 : open (unit=elph_ds%unit_gkk2,file='gkk2file',access='direct',&
3528 : & recl=onediaggkksize,form='unformatted',status='new',iostat=iost)
3529 : if (iost /= 0) then
3530 : ABI_ERROR('error opening gkk2file as new')
3531 : end if
3532 : ! rewind (elph_ds%unit_gkk2)
3533 : write(std_out,*) 'get_all_gkk2 : disk file with gkk^2 created'
3534 : write(std_out,*) ' calculate from real space gkk and phonon modes'
3535 : write(std_out,*) ' gkk2write = 1 is forced: can take a lot of time! '
3536 : write(std_out,*) ' size = ', 4.0*dble(onediaggkksize)*dble(elph_ds%k_phon%nkpt)/&
3537 : & 1024.0_dp/1024.0_dp, ' Mb'
3538 : else
3539 : ABI_ERROR('bad value of gkk2write')
3540 : end if
3541 :
3542 : !here do the actual calculation of |g_kk|^2
3543 : ABI_ERROR("MGNOTE: interpolate_gkk is broken")
3544 : ABI_UNUSED(kptirr_phon(1,1))
3545 : call interpolate_gkk (crystal,ifc,elph_ds,kpt_phon)
3546 :
3547 : !MG: This was the old coding in version 7.6.2:
3548 :
3549 : ! call interpolate_gkk (elph_ds,kptirr_phon,kpt_phon,natom,nrpt,phon_ds,rcan,wghatm)
3550 : !
3551 : ! and interpolate_gkk had the prototype:
3552 : !
3553 : !subroutine interpolate_gkk(elph_ds,kpt_phon,gprim,natom,nrpt,phon_ds,rpt,wghatm)
3554 :
3555 : ! hence we were associating kpt_phon to gprim!
3556 :
3557 : end subroutine get_all_gkk2
3558 : !!***
3559 :
3560 : !!****f* ABINIT/interpolate_gkk
3561 : !! NAME
3562 : !! interpolate_gkk
3563 : !!
3564 : !! FUNCTION
3565 : !! This routine interpolates the gkk matrices for all q vectors
3566 : !! between points on the full kpt_phon grid.
3567 : !!
3568 : !! INPUTS
3569 : !! elph_ds = elphon datastructure with data and dimensions
3570 : !! kpt_phon = coordinates of all kpoints close to the FS
3571 : !!
3572 : !! OUTPUT
3573 : !! elph_ds = modified gkq
3574 : !!
3575 : !! NOTES
3576 : !! inspired to some extent by epcouple.f from the DecAFT package by J. Kay Dewhurst
3577 : !! most inputs taken from mkifc.f
3578 : !! in anaddb set ifcflag 1 such that the IFC are calculated in atmfrc prior to calling elphon
3579 : !!
3580 : !! SOURCE
3581 :
3582 : subroutine interpolate_gkk(crystal,ifc,elph_ds,kpt_phon)
3583 :
3584 : !Arguments ------------------------------------
3585 : !scalars
3586 : type(crystal_t),intent(in) :: crystal
3587 : type(ifc_type),intent(in) :: ifc
3588 : type(elph_type),intent(inout) :: elph_ds
3589 : !arrays
3590 : real(dp),intent(in) :: kpt_phon(3,elph_ds%k_phon%nkpt)
3591 :
3592 : !Local variables-------------------------------
3593 : ! output variables for dfpt_phfrq
3594 : ! variables for zhpev
3595 : ! variables for phonon interpolation
3596 : !scalars
3597 : integer :: i1,i2,ikpt_phon2,iFSqpt,ib1,ib2,ier,ii
3598 : integer :: iost,isppol,qtor,natom
3599 : integer :: sz1,sz2,sz3,sz4,unit_gkkp
3600 : real(dp) :: qphnrm,res
3601 : !character(len=500) :: msg
3602 : !arrays
3603 : real(dp) :: gprim(3,3)
3604 : real(dp) :: displ(2,elph_ds%nbranch,elph_ds%nbranch),eigval(3*crystal%natom)
3605 : real(dp) :: eigvec(3*3*crystal%natom*3*crystal%natom)
3606 : real(dp) :: pheigvec(2*elph_ds%nbranch*elph_ds%nbranch)
3607 : real(dp) :: phfrq_tmp(elph_ds%nbranch),qphon(3),redkpt(3)
3608 : real(dp),allocatable :: gkk2_diag_tmp(:,:,:,:),gkk2_tmp(:,:,:,:,:,:,:), matrx(:,:),zhpev1(:,:), zhpev2(:)
3609 : ! *************************************************************************
3610 :
3611 : !NOTE: mjv 18/5/2008 reverted to old style of ftgkk with all kpt done together.
3612 : !may want to modify this later to use the new cleaner format with 1 FT at a
3613 : !time.
3614 : !
3615 : write(std_out,*) 'interpolate_gkk : enter'
3616 :
3617 : natom = crystal%natom
3618 : gprim = ifc%gprim
3619 :
3620 : if (elph_ds%nsppol /= 1) then
3621 : ABI_ERROR("interpolate_gkk not coded with nsppol>1 yet")
3622 : end if
3623 : isppol = 1
3624 :
3625 :
3626 : !------------------------------------------------------
3627 : !complete dynamical matrices for all qpts between points
3628 : !on full kpt grid (interpolation from IFC)
3629 : !------------------------------------------------------
3630 :
3631 : sz1=elph_ds%ngkkband;sz2=elph_ds%nbranch
3632 : sz3=elph_ds%k_phon%nkpt;sz4=elph_ds%nFSband
3633 : !allocate (gkk_tmp(2,sz1,sz1,sz2,sz2,1,1))
3634 : !DEBUG
3635 : !allocate (gkk_tmp_full(2,sz1,sz1,sz2,elph_ds%nFSband,sz3))
3636 : !allocate (gkk_tmp_full(2,s2,sz4,sz4,sz3))
3637 : !ENDDEBUG
3638 : ABI_MALLOC(gkk2_tmp,(2,sz1,sz1,sz2,sz2,sz3,1))
3639 : ABI_MALLOC(gkk2_diag_tmp,(sz1,sz1,sz2,sz3))
3640 : ABI_MALLOC(zhpev1,(2,2*3*natom-1))
3641 : ABI_MALLOC(zhpev2,(3*3*natom-2))
3642 : ABI_MALLOC(matrx,(2,(3*natom*(3*natom+1))/2))
3643 :
3644 : qphnrm = one
3645 : !in this part use the inverse Fourier transform to get 1 (arbitrary) qpt at a
3646 : !time
3647 : ii = 0
3648 : qtor = 0
3649 : unit_gkkp = 150
3650 : open (unit=unit_gkkp,file='gkkp_file_ascii',form='formatted',status='unknown',iostat=iost)
3651 : if (iost /= 0) then
3652 : ABI_ERROR("error opening gkkpfile as new")
3653 : end if
3654 :
3655 : !loop over all FS pairs.
3656 : !do ikpt1=1,elph_ds%k_phon%nkptirr
3657 : !do iFSqpt=1,elph_ds%k_phon%nkpt
3658 :
3659 : !
3660 : !this should run through the sparse mesh of 2x2x2 kpoints
3661 : !
3662 : do iFSqpt=1,elph_ds%k_phon%nkpt
3663 : res = 2.0_dp*(kpt_phon(1,iFSqpt)+one)
3664 : if (abs(res-int(res)) > tol10) cycle
3665 : res = 2.0_dp*(kpt_phon(2,iFSqpt)+one)
3666 : if (abs(res-int(res)) > tol10) cycle
3667 : res = 2.0_dp*(kpt_phon(3,iFSqpt)+one)
3668 : if (abs(res-int(res)) > tol10) cycle
3669 :
3670 : ! do ikpt1=1,1
3671 : !
3672 : ! NOTE: should be very easy to parallelize!
3673 : !
3674 : ! write(std_out,*) ' interpolate_gkk : ikpt1 = ',ikpt1, ' / ', elph_ds%k_phon%nkptirr
3675 : write(std_out,*) ' interpolate_gkk : ikpt1 = ',iFSqpt, ' / ', elph_ds%k_phon%nkpt
3676 :
3677 : ! DEBUG
3678 : ! write(std_out,*) ' interpolate_gkk : Warning debug version'
3679 : ! cycle
3680 : ! ENDDEBUG
3681 :
3682 : gkk2_tmp(:,:,:,:,:,:,:) = zero
3683 :
3684 : ! qphon = 1 - 2 ie. 1 = 2+qphon
3685 : qphon(:) = kpt_phon(:,iFSqpt)
3686 :
3687 : ! shouldnt be necessary here, but oh well
3688 : call wrap2_pmhalf(qphon(1),redkpt(1),res)
3689 : call wrap2_pmhalf(qphon(2),redkpt(2),res)
3690 : call wrap2_pmhalf(qphon(3),redkpt(3),res)
3691 :
3692 : qphon(:) = redkpt(:)
3693 : redkpt(1) = qphon(1)*gprim(1,1)+qphon(2)*gprim(1,2)+qphon(3)*gprim(1,3)
3694 : redkpt(2) = qphon(1)*gprim(2,1)+qphon(2)*gprim(2,2)+qphon(3)*gprim(2,3)
3695 : redkpt(3) = qphon(1)*gprim(3,1)+qphon(2)*gprim(3,2)+qphon(3)*gprim(3,3)
3696 : write (unit_gkkp,*) 'qp= ', redkpt
3697 :
3698 : call ifc%fourq(crystal,qphon,phfrq_tmp,displ,out_eigvec=pheigvec)
3699 : write (unit_gkkp,*) phfrq_tmp(:)*Ha_cmm1
3700 :
3701 : ii = ii+1
3702 : ! if(ii > 0 .and. ii < 1000) write(std_out,'(a,i5,3E16.6,2x)') &
3703 : ! & ' wrote phfrq_tmp for time ', ii, phfrq_tmp
3704 : ! end if
3705 :
3706 : ! phonon eigenvectors are in eigvec
3707 : ! real and imaginary parts
3708 : ! phonon displacements = eigvec/sqrt(M_i) are in displ
3709 : ! real and imaginary parts
3710 :
3711 : ! DEBUG
3712 : ! test: uniform phonon frequency
3713 : ! phfrq_tmp(:) = 0.0001_dp
3714 : ! ENDDEBUG
3715 :
3716 : ! FT gamma matrices for all kpt_phon points, and
3717 : ! for qpoint = qphon(:) = kpt_phon(ikpt_phon)
3718 :
3719 : call ftgkk(ifc%wghatm,gkk2_tmp,elph_ds%gkk_rpt,elph_ds%gkqwrite,&
3720 : & elph_ds%gkk_rptwrite,gprim,1,&
3721 : & natom,elph_ds%k_phon%nkpt,elph_ds%ngkkband,elph_ds%k_phon%nkpt,1,ifc%nrpt,elph_ds%nsppol,&
3722 : & qtor,ifc%rpt,qphon,elph_ds%unit_gkk_rpt,elph_ds%unitgkq)
3723 :
3724 : ! NOTE: Normally the eigenvectors of the gkk2_tmp should be the same as eigvec
3725 :
3726 : ! Diagonalize gamma matrices at qpoint (complex matrix) for all kpt_phon.
3727 : ! Copied from dfpt_phfrq
3728 : do ikpt_phon2=1,elph_ds%k_phon%nkpt
3729 : res = 8.0_dp*(kpt_phon(1,ikpt_phon2)+one)
3730 : if (abs(res-int(res)) > tol10) cycle
3731 : res = 8.0_dp*(kpt_phon(2,ikpt_phon2)+one)
3732 : if (abs(res-int(res)) > tol10) cycle
3733 : res = 8.0_dp*(kpt_phon(3,ikpt_phon2)+one)
3734 : if (abs(res-int(res)) > tol10) cycle
3735 :
3736 : write (unit_gkkp,*) 'kp= ', kpt_phon(:,ikpt_phon2)
3737 :
3738 : do ib1=1,elph_ds%ngkkband
3739 : do ib2=1,elph_ds%ngkkband
3740 : ier=0
3741 : ii=1
3742 : do i2=1,3*natom
3743 : do i1=1,i2
3744 : matrx(1,ii)=gkk2_tmp(1,ib1,ib2,i1,i2,ikpt_phon2,1)
3745 : matrx(2,ii)=gkk2_tmp(2,ib1,ib2,i1,i2,ikpt_phon2,1)
3746 : ii=ii+1
3747 : end do
3748 : end do
3749 : call ZHPEV ('N','U',3*natom,matrx,eigval,eigvec,3*natom,zhpev1,&
3750 : & zhpev2,ier)
3751 :
3752 : gkk2_diag_tmp(ib2,ib1,:,ikpt_phon2) = eigval(:)
3753 : do i1=1,3*natom
3754 : write (unit_gkkp,*) elph_ds%minFSband-1+ib1,elph_ds%minFSband-1+ib2,i1,&
3755 : & eigval(i1)
3756 : end do
3757 : end do
3758 : end do
3759 : end do
3760 :
3761 : if (elph_ds%gkk2write == 1) then
3762 : write(std_out,*) 'WARNING COMMENTED WRITE TO BINARY FILE!!!'
3763 : ! write (elph_ds%unit_gkk2,REC=iFSqpt) gkk2_diag_tmp(:,:,:,:)
3764 : write(std_out,'(a,i4,4(2E16.6,2x))') ' gkk2 loop ', &
3765 : & iFSqpt,gkk2_diag_tmp(1,1,:,1:2),gkk2_diag_tmp(1,1,:,elph_ds%k_phon%nkpt-1:elph_ds%k_phon%nkpt)
3766 : ! & ikpt1,gkk2_tmp(:,1,1,1,1,1:2),gkk2_tmp(:,1,1,elph_ds%k_phon%nkpt-1:elph_ds%k_phon%nkpt)
3767 : else if (elph_ds%gkk2write == 0) then
3768 : elph_ds%gkk2(:,:,:,:,iFSqpt,isppol) = gkk2_diag_tmp(:,:,:,:)
3769 : ! elph_ds%gkk2(:,:,:,:,ikpt1) = gkk2_tmp
3770 : write(std_out,*) ' interpolate_gkk : gkk2(b=1,b=1,:,kpt=1,iFSqpt) = '
3771 : write(std_out,*) gkk2_diag_tmp(1,1,:,1)
3772 : end if
3773 :
3774 : end do
3775 : !end do on iFSqpt
3776 :
3777 : ABI_FREE(matrx)
3778 : ABI_FREE(zhpev1)
3779 : ABI_FREE(zhpev2)
3780 :
3781 : end subroutine interpolate_gkk
3782 : !!***
3783 :
3784 : !!****f* ABINIT/get_all_gkq
3785 : !!
3786 : !! NAME
3787 : !! get_all_gkq
3788 : !!
3789 : !! FUNCTION
3790 : !! This routine determines what to do with the initial qspace
3791 : !! matrix elements of the electron phonon coupling (to disk or in memory),
3792 : !! then reads those given in the gkk file and completes them
3793 : !! (for kpts, then perturbations)
3794 : !! 01/2010: removed completion on qpoints here (MJV)
3795 : !!
3796 : !! INPUTS
3797 : !! elph_ds = elphon datastructure with data and dimensions
3798 : !! Cryst<crystal_t>=Info on the unit cell and on its symmetries.
3799 : !! Ifc<ifc_type>=Object containing the interatomic force constants.
3800 : !! Bst<ebands_t>=GS energies, occupancies and Fermi level.
3801 : !! FSfullpqtofull = mapping of k+q to another k
3802 : !! kphon_full2full = mapping of FS kpoints under symops
3803 : !! kpt_phon = fermi surface kpoints
3804 : !! %k_phon%wtk = integration weights for bands and kpoints near the FS
3805 : !! gkk_flag = flag to
3806 : !! nband = number of bands
3807 : !! n1wf = number of file headers from perturbation calculations
3808 : !! which are present in the initial gkk input file.
3809 : !! onegkksize = size of one record of the new gkk output file, in bytes
3810 : !! qpttoqpt = mapping of qpoints onto each other under symmetries
3811 : !! unitgkk = fortran unit for initial gkk input file
3812 : !! xred = reduced coordinates of atoms
3813 : !!
3814 : !! OUTPUT
3815 : !! elph_ds%gkq = recip space elphon matrix elements.
3816 : !!
3817 : !! SOURCE
3818 :
3819 15 : subroutine get_all_gkq (elph_ds,Cryst,ifc,Bst,FSfullpqtofull,nband,n1wf,onegkksize,&
3820 15 : & qpttoqpt,ep_prt_yambo,unitgkk,ifltransport)
3821 :
3822 : !Arguments ------------------------------------
3823 : !scalars
3824 : integer,intent(in) :: n1wf,nband,onegkksize,unitgkk,ep_prt_yambo,ifltransport
3825 : type(crystal_t),intent(in) :: Cryst
3826 : type(ifc_type),intent(in) :: ifc
3827 : type(ebands_t),intent(in) :: Bst
3828 : type(elph_type),intent(inout) :: elph_ds
3829 : !arrays
3830 : integer,intent(in) :: FSfullpqtofull(elph_ds%k_phon%nkpt,elph_ds%nqpt_full)
3831 : integer,intent(in) :: qpttoqpt(2,Cryst%nsym,elph_ds%nqpt_full)
3832 :
3833 : !Local variables-------------------------------
3834 : !scalars
3835 : integer :: iost,ierr,me,sz2,sz3,sz4,sz5,sz6
3836 : character(len=10) :: procnum
3837 : character(len=500) :: message
3838 : character(len=fnlen) :: fname
3839 : !arrays
3840 15 : integer,allocatable :: gkk_flag(:,:,:,:,:)
3841 : ! *************************************************************************
3842 :
3843 : !attribute file unit number
3844 15 : elph_ds%unitgkq = get_unit()
3845 :
3846 : !============================================
3847 : !save gkk for all qpts in memory or to disk
3848 : !============================================
3849 :
3850 : !DEBUG
3851 : !write(std_out,*) ' 4 bytes / ??'
3852 : !write(std_out,*) ' kind(real) = ', kind(one)
3853 : !write(std_out,*) ' elph_ds%ngkkband = ', elph_ds%ngkkband, '^2'
3854 : !write(std_out,*) ' elph_ds%nbranch = ', elph_ds%nbranch, '^2'
3855 : !write(std_out,*) ' elph_ds%k_phon%nkpt = ', elph_ds%k_phon%nkpt
3856 : !write(std_out,*) ' elph_ds%nsppol = ', elph_ds%nsppol
3857 : !write(std_out,*) ' elph_ds%nqptirred ', elph_ds%nqptirred
3858 : !ENDDEBUG
3859 :
3860 : write(message,'(a,f14.4,a)')&
3861 15 : & ' get_all_gkq : gkq file/array size = ',&
3862 30 : 4.0*dble(onegkksize)*dble(elph_ds%k_phon%my_nkpt)*dble(elph_ds%nqptirred)/1024.0_dp/1024.0_dp/1024.0_dp,' Gb'
3863 15 : call wrtout(std_out,message,'COLL')
3864 :
3865 15 : if (elph_ds%gkqwrite == 0) then !calculate gkk(q) keeping all in memory
3866 :
3867 14 : call wrtout(std_out,' get_all_gkq : keep gkk(q) in memory ','COLL')
3868 :
3869 14 : sz2=elph_ds%ngkkband*elph_ds%ngkkband
3870 14 : sz3=elph_ds%nbranch*elph_ds%nbranch
3871 14 : sz4=elph_ds%k_phon%my_nkpt
3872 14 : sz5=elph_ds%nsppol
3873 14 : if (ifltransport == 3) then
3874 0 : sz6=elph_ds%nqpt_full
3875 : else
3876 14 : sz6=elph_ds%nqptirred
3877 : end if
3878 98 : ABI_MALLOC_OR_DIE(elph_ds%gkk_qpt,(2,sz2,sz3,sz4,sz5,sz6), ierr)
3879 :
3880 4588187 : elph_ds%gkk_qpt = zero
3881 :
3882 1 : else if (elph_ds%gkqwrite == 1) then !calculate gkk(q) and write to file
3883 1 : me = xmpi_comm_rank(xmpi_world)
3884 1 : call int2char4(me,procnum)
3885 1 : ABI_CHECK((procnum(1:1)/='#'),'Bug: string length too short!')
3886 1 : fname=trim(elph_ds%elph_base_name) // "_P" // trim(procnum) // '_GKKQ'
3887 :
3888 : iost=open_file(file=fname,iomsg=message,newunit=elph_ds%unitgkq,access='direct',&
3889 1 : & recl=onegkksize,form='unformatted')
3890 1 : if (iost /= 0) then
3891 0 : write (message,'(2a)')' get_all_gkq : ERROR- opening file ',trim(fname)
3892 0 : ABI_ERROR(message)
3893 : end if
3894 :
3895 : write (message,'(5a)')&
3896 1 : & ' get_all_gkq : gkq matrix elements will be written to file : ',trim(fname),ch10,&
3897 2 : & ' Nothing is in files yet',ch10
3898 1 : call wrtout(std_out,message,'COLL')
3899 :
3900 : else
3901 0 : write(message,'(a,i0)')' gkqwrite must be 0 or 1 while it is : ',elph_ds%gkqwrite
3902 0 : ABI_BUG(message)
3903 : end if !if gkqwrite
3904 :
3905 : !=====================================================
3906 : !read in g_kk matrix elements for all bands, kpoints,
3907 : !and calculated qpoints
3908 : !=====================================================
3909 15 : call wrtout(std_out,' get_all_gkq : calling read_gkk to read in the g_kk matrix elements',"COLL")
3910 :
3911 15 : sz2=elph_ds%nbranch;sz3=elph_ds%k_phon%my_nkpt
3912 15 : sz4=elph_ds%nsppol;sz5=elph_ds%nqpt_full
3913 105 : ABI_MALLOC_OR_DIE(gkk_flag,(sz2,sz2,sz3,sz4,sz5), ierr)
3914 :
3915 15 : call read_gkk(elph_ds,Cryst,ifc,Bst,FSfullpqtofull,gkk_flag,n1wf,nband,ep_prt_yambo,unitgkk)
3916 :
3917 : !if (elph_ds%symgkq ==1) then
3918 : !MJV 01/2010 removed the completion on qpt here: it should be done after FS integration
3919 : !so that everything is lighter in memory etc... (only irred qpt)
3920 : ! if (0==1) then
3921 15 : if (ifltransport == 3) then ! bxu, complete gkk is necessary
3922 :
3923 : ! ==============================================================
3924 : ! complete gkk matrices for other qpoints on the full grid qpt_full
3925 : ! inspired and cannibalized from symdm9.f
3926 : ! FIXME: should add the possibility to copy over to other qpoints,
3927 : ! without full symmetrization, for testing purposes.
3928 : ! ==============================================================
3929 :
3930 0 : write(message,'(4a)')ch10,&
3931 0 : & ' get_all_gkq : calling complete_gkk to complete ',ch10,&
3932 0 : & ' gkk matrices for other qpoints on the full grid'
3933 0 : call wrtout(std_out,message,'COLL')
3934 :
3935 : call complete_gkk(elph_ds,gkk_flag,Cryst%gprimd,Cryst%indsym,&
3936 0 : & Cryst%natom,Cryst%nsym,qpttoqpt,Cryst%rprimd,Cryst%symrec,Cryst%symrel)
3937 :
3938 0 : call wrtout(std_out,' get_all_gkq : out of complete_gkk','COLL')
3939 :
3940 : end if !symgkq
3941 :
3942 : !TODO Do we need gkk_flag in elphon?
3943 15 : ABI_FREE(gkk_flag)
3944 :
3945 15 : end subroutine get_all_gkq
3946 : !!***
3947 :
3948 : !!****f* ABINIT/get_all_gkr
3949 : !! NAME
3950 : !! get_all_gkr
3951 : !!
3952 : !! FUNCTION
3953 : !! This routine determines what to do with the rspace
3954 : !! matrix elements of the el phon coupling (to disk or in memory),
3955 : !! then reads those given in the gkq file and Fourier Transforms them
3956 : !!
3957 : !! INPUTS
3958 : !! elph_ds = elphon datastructure with data and dimensions
3959 : !! gprim = reciprocal space lattice vectors
3960 : !! natom = number of atoms
3961 : !! nrpt = number of real-space points used for FT
3962 : !! onegkksize = size of one record of the new gkk output file, in bytes
3963 : !! rpt = positions of real-space points for FT
3964 : !! qpt_full = qpoint coordinates
3965 : !! wghatm = weights for real-space rpt in FT
3966 : !!
3967 : !! OUTPUT
3968 : !! elph_ds%gkr = real space elphon matrix elements.
3969 : !!
3970 : !! SOURCE
3971 :
3972 : subroutine get_all_gkr (elph_ds,gprim,natom,nrpt,onegkksize,rpt,qpt_full,wghatm)
3973 :
3974 : !Arguments ------------------------------------
3975 : !scalars
3976 : integer,intent(in) :: natom,nrpt,onegkksize
3977 : type(elph_type),intent(inout) :: elph_ds
3978 : !arrays
3979 : real(dp),intent(in) :: gprim(3,3),rpt(3,nrpt),qpt_full(3,elph_ds%nqpt_full)
3980 : real(dp),intent(in) :: wghatm(natom,natom,nrpt)
3981 :
3982 : !Local variables-------------------------------
3983 : !scalars
3984 : integer :: ikpt_phon0,iost,qtor,sz2,sz3,sz4,sz5
3985 : ! *************************************************************************
3986 :
3987 : !
3988 : !WARNING : disk file used for large arrays gkk_rpt and
3989 : !(eventually) gkk2
3990 : !
3991 : !allocate (gkk_rpt(2,elph_ds%nbranch,elph_ds%nFSband,elph_ds%nFSband,&
3992 : !& elph_ds%k_phon%nkpt,nrpt))
3993 : elph_ds%unit_gkk_rpt = 36
3994 : !see if the gkk_rpt should be written to a file (only available option now)
3995 : if (elph_ds%gkk_rptwrite == 1) then
3996 : ! file is not present : we need to do the FT
3997 : open (unit=elph_ds%unit_gkk_rpt,file='gkk_rpt_file',access='direct',&
3998 : & recl=onegkksize,form='unformatted',&
3999 : & status='new',iostat=iost)
4000 : if (iost /= 0) then
4001 : ABI_ERROR('get_all_gkr : error opening gkk_rpt_file as new')
4002 : end if
4003 : write(std_out,*) ' get_all_gkr : will write real space gkk to a disk file.'
4004 : write(std_out,*) ' size = ', 4.0*dble(onegkksize)*dble(nrpt)/&
4005 : & 1024.0_dp/1024.0_dp, ' Mb'
4006 :
4007 : ! else if (elph_ds%gkk_rptwrite == 0) then
4008 : else
4009 : write(std_out,*) ' get_all_gkr : will keep real space gkk in memory.'
4010 : write(std_out,*) ' size = ', 4.0*dble(onegkksize)*dble(nrpt)/&
4011 : & 1024.0_dp/1024.0_dp, ' Mb'
4012 : sz2=elph_ds%ngkkband*elph_ds%ngkkband
4013 : sz3=elph_ds%nbranch*elph_ds%nbranch
4014 : sz4=elph_ds%k_phon%nkpt
4015 : sz5=elph_ds%nsppol
4016 : ABI_MALLOC(elph_ds%gkk_rpt,(2,sz2,sz3,sz4,sz5,nrpt))
4017 : ! write(std_out,*) ' get_all_gkr: invalid value for gkk_rptwrite'
4018 : ! stop
4019 : end if
4020 : write(std_out,*) ' about to FT the recip space gkk to real space '
4021 : qtor = 1
4022 :
4023 : !
4024 : !NOTE: should be very easy to parallelize!
4025 : !
4026 : ikpt_phon0 = 1
4027 : call ftgkk (wghatm,elph_ds%gkk_qpt,elph_ds%gkk_rpt,&
4028 : & elph_ds%gkqwrite,elph_ds%gkk_rptwrite,gprim,1,natom,&
4029 : & elph_ds%k_phon%nkpt,elph_ds%ngkkband,elph_ds%k_phon%nkpt,elph_ds%nqpt_full,&
4030 : & nrpt,elph_ds%nsppol,qtor,rpt,qpt_full,elph_ds%unit_gkk_rpt,elph_ds%unitgkq)
4031 :
4032 : !call ftgkk (elph_ds,gprim,ikpt_phon0,natom,nrpt,qtor,rpt,qpt_full,wghatm)
4033 : write(std_out,*) ' get_all_gkr : done with FT of gkk to real space'
4034 :
4035 : !No longer need the gkk_qpt?
4036 : !if (elph_ds%gkqwrite == 0) deallocate (elph_ds%gkk_qpt)
4037 :
4038 : !!DEBUG
4039 : !Test the FT of the gkk elements.
4040 : !call test_ftgkk(elph_ds,gprim,natom,nrpt,rpt,qpt_full,wghatm)
4041 : !!ENDDEBUG
4042 :
4043 : !DEBUG
4044 : !do irpt=1,nrpt
4045 : !do ipert1=1,elph_ds%nbranch
4046 : !write(std_out,'(6(F16.5,1x))') elph_ds%gkk_rpt(:,ipert1,1,1,1,irpt)
4047 : !end do
4048 : !end do
4049 : !ENDDEBUG
4050 :
4051 : end subroutine get_all_gkr
4052 : !!***
4053 :
4054 : !!****f* ABINIT/complete_gkk
4055 : !!
4056 : !! NAME
4057 : !! complete_gkk
4058 : !!
4059 : !! FUNCTION
4060 : !! Use the set of special q points calculated by the Monkhorst &
4061 : !! Pack Technique.
4062 : !! Check if all the information for the q points are present in
4063 : !! the DDB to determine the elphon interaction matrices
4064 : !! Generate the gkk matrices of the set of q points which
4065 : !! samples homogeneously the entire Brillouin zone.
4066 : !!
4067 : !! INPUTS
4068 : !! elph_ds = datastructure for elphon information (mainly
4069 : !! matrix elements and dimensions)
4070 : !! elph_ds%k_phon%full2full = kpt_phon index mapping under symops
4071 : !! gkk_flag = flag for existence of matrix element
4072 : !! gprimd(3,3)=dimensionful primitive translations in reciprocal space
4073 : !! indsym = map of atoms by inverses of symrels
4074 : !! natom=number of atoms in unit cell
4075 : !! nsym=number of space group symmetries
4076 : !! qpttoqpt = qpoint index mapping under symops
4077 : !! rprimd(3,3)=dimensionful primitive translations in real space
4078 : !! symrec(3,3,nsym)=3x3 matrices of the group symmetries (recip space)
4079 : !! symrel(3,3,nsym)=3x3 matrices of the group symmetries (real space)
4080 : !! tnons(3,nsym)=nonsymmorphic translations associated to symrel
4081 : !!
4082 : !! OUTPUT
4083 : !! elph_ds%gkk_qpt = gkk matrices for all qpts on a full mesh
4084 : !!
4085 : !! SOURCE
4086 :
4087 0 : subroutine complete_gkk(elph_ds,gkk_flag,gprimd,indsym,natom,nsym,qpttoqpt,rprimd,symrec,symrel)
4088 :
4089 : !Arguments ------------------------------------
4090 : !scalars
4091 : integer,intent(in) :: natom,nsym
4092 : type(elph_type),intent(inout) :: elph_ds
4093 : !arrays
4094 : integer,intent(in) :: indsym(4,nsym,natom)
4095 : integer,intent(in) :: qpttoqpt(2,nsym,elph_ds%nqpt_full),symrec(3,3,nsym)
4096 : integer,intent(in) :: symrel(3,3,nsym)
4097 : integer,intent(inout) :: gkk_flag(elph_ds%nbranch,elph_ds%nbranch,elph_ds%k_phon%my_nkpt,elph_ds%nsppol,elph_ds%nqpt_full)
4098 : real(dp),intent(in) :: gprimd(3,3)
4099 : real(dp),intent(in) :: rprimd(3,3)
4100 :
4101 : !Local variables-------------------------------
4102 : !scalars
4103 : integer :: ikpt_phon,ib1,ibranch,ieqqpt,ii, ierr,comm
4104 : integer :: iqpt,isppol,isym
4105 : integer :: itim,jbranch,jj,kk,ll
4106 : integer :: neqqpt,symikpt_phon
4107 : integer :: iatom,ancestor_iatom
4108 : integer :: ik_this_proc, me,sz1,sz2
4109 :
4110 : real(dp),parameter :: tol=2.d-8
4111 : !arrays
4112 0 : integer :: symmetrized_qpt(elph_ds%nqpt_full)
4113 : real(dp) :: ss(3,3)
4114 0 : real(dp) :: tmp_mat(2,elph_ds%nbranch,elph_ds%nbranch)
4115 0 : real(dp) :: tmp_mat2(2,elph_ds%nbranch,elph_ds%nbranch)
4116 0 : real(dp),allocatable :: gkk_qpt_new(:,:,:,:,:),gkk_qpt_tmp(:,:,:,:,:)
4117 :
4118 0 : real(dp) :: ss_allatoms(2,elph_ds%nbranch,elph_ds%nbranch)
4119 : complex(dp) :: c_one, c_zero
4120 : ! *********************************************************************
4121 :
4122 0 : c_one = dcmplx(one,zero)
4123 0 : c_zero = dcmplx(zero,zero)
4124 :
4125 : !Generation of the gkk matrices relative to the q points
4126 : !of the set which samples the entire Brillouin zone
4127 :
4128 0 : comm = xmpi_world
4129 0 : me = xmpi_comm_rank(comm)
4130 :
4131 0 : symmetrized_qpt(:) = -1
4132 :
4133 : !FIXME bxu, why set it to 1?
4134 : !isppol=1
4135 :
4136 0 : sz1=elph_ds%ngkkband*elph_ds%ngkkband
4137 0 : sz2=elph_ds%nbranch*elph_ds%nbranch
4138 :
4139 : !these arrays are not parallelized, to enable symmetrization: syms swap k-points.
4140 0 : ABI_MALLOC(gkk_qpt_new,(2,sz1,sz2,elph_ds%k_phon%nkpt,elph_ds%nsppol))
4141 0 : ABI_MALLOC(gkk_qpt_tmp,(2,sz1,sz2,elph_ds%k_phon%nkpt,elph_ds%nsppol))
4142 :
4143 0 : do iqpt=1,elph_ds%nqpt_full
4144 :
4145 : ! Already symmetrized?
4146 0 : if (symmetrized_qpt(iqpt) == 1) cycle
4147 :
4148 0 : gkk_qpt_new(:,:,:,:,:) = zero
4149 : ! gkk_qpt_tmp(:,:,:,:,:) = zero
4150 :
4151 : ! loop over qpoints equivalent to iqpt
4152 0 : neqqpt=0
4153 : ! do not use time reversal symmetry to complete the qpoints:
4154 : ! do not know what happens to the gamma matrices
4155 : ! itim=1
4156 :
4157 0 : do itim=1,2
4158 0 : do isym=1,nsym
4159 : ! ieqqpt is sent onto iqpt by itim/isym
4160 0 : ieqqpt = qpttoqpt(itim,isym,iqpt)
4161 0 : gkk_qpt_tmp(:,:,:,:,:) = zero
4162 :
4163 :
4164 0 : if (gkk_flag(1,1,1,1,ieqqpt) == -1) cycle
4165 : ! if we have information on this qpt
4166 : ! iqpt is equivalent to ieqqpt: get it from file or memory
4167 0 : do ik_this_proc =1,elph_ds%k_phon%my_nkpt
4168 0 : ikpt_phon = elph_ds%k_phon%my_ikpt(ik_this_proc)
4169 :
4170 0 : if (elph_ds%gkqwrite == 0) then
4171 0 : gkk_qpt_tmp(:,:,:,ikpt_phon,:) = elph_ds%gkk_qpt(:,:,:,ik_this_proc,:,ieqqpt)
4172 0 : else if (elph_ds%gkqwrite == 1) then
4173 0 : read(elph_ds%unitgkq,REC=((ieqqpt-1)*elph_ds%k_phon%my_nkpt+ik_this_proc)) gkk_qpt_tmp(:,:,:,ikpt_phon,:)
4174 : end if
4175 : end do
4176 :
4177 : ! condense everything
4178 0 : call xmpi_sum (gkk_qpt_tmp, comm, ierr)
4179 :
4180 0 : neqqpt=neqqpt+1
4181 :
4182 0 : if (elph_ds%ep_scalprod==1) then
4183 0 : do ii=1,3
4184 0 : do jj=1,3
4185 0 : ss(ii,jj)=0.0_dp
4186 0 : do kk=1,3
4187 0 : do ll=1,3
4188 0 : ss(ii,jj)=ss(ii,jj)+rprimd(ii,kk)*symrel(kk,ll,isym)*gprimd(ll,jj)
4189 : end do
4190 : end do
4191 : end do
4192 : end do
4193 : else
4194 0 : do ii=1,3
4195 0 : do jj=1,3
4196 0 : ss(ii,jj) = symrec(jj,ii,isym)
4197 : end do
4198 : end do
4199 : end if
4200 :
4201 0 : ss_allatoms(:,:,:) = zero
4202 0 : do iatom=1,natom
4203 0 : ancestor_iatom = indsym(4,isym,iatom)
4204 : ! do jatom=1,natom
4205 : ! ancestor_jatom = indsym(4,isym,jatom)
4206 : ss_allatoms(1,(ancestor_iatom-1)*3+1:(ancestor_iatom-1)*3+3,&
4207 0 : & (iatom-1)*3+1: (iatom-1)*3+3) = ss(1:3,1:3)
4208 : ! end do
4209 : end do
4210 :
4211 :
4212 : ! NOTE ssinv(ii,jj)=ssinv(ii,jj)+gprimd(ii,kk)*rprimd(jj,ll)*symrec(ll,kk,isym)
4213 :
4214 0 : do isppol=1,elph_ds%nsppol
4215 0 : do ikpt_phon=1,elph_ds%k_phon%nkpt
4216 : ! symikpt_phon is sent onto ikpt_phon by itim/isym
4217 0 : symikpt_phon=elph_ds%k_phon%full2full(itim,isym,ikpt_phon)
4218 :
4219 : ! Do each element band1, band2 separately...
4220 0 : do ib1=1,elph_ds%ngkkband*elph_ds%ngkkband
4221 :
4222 : ! multiply by the ss matrices
4223 0 : tmp_mat2(:,:,:) = zero
4224 : tmp_mat(:,:,:) = reshape(gkk_qpt_tmp(:,ib1,:,ikpt_phon,isppol),&
4225 0 : & (/2,elph_ds%nbranch,elph_ds%nbranch/))
4226 : call ZGEMM ('N','N',elph_ds%nbranch,elph_ds%nbranch,elph_ds%nbranch,&
4227 : & c_one,ss_allatoms,elph_ds%nbranch,tmp_mat,elph_ds%nbranch,c_zero,&
4228 0 : & tmp_mat2,elph_ds%nbranch)
4229 : call ZGEMM ('N','T',elph_ds%nbranch,elph_ds%nbranch,elph_ds%nbranch,&
4230 : & c_one,tmp_mat2,elph_ds%nbranch,ss_allatoms,elph_ds%nbranch,c_zero,&
4231 0 : & tmp_mat,elph_ds%nbranch)
4232 :
4233 : ! add to gkk_qpt_new
4234 0 : do ibranch =1,elph_ds%nbranch
4235 0 : do jbranch =1,elph_ds%nbranch
4236 : gkk_qpt_new(:,ib1,(jbranch-1)*elph_ds%nbranch+ibranch,symikpt_phon,isppol) = &
4237 : & gkk_qpt_new(:,ib1,(jbranch-1)*elph_ds%nbranch+ibranch,symikpt_phon,isppol) + &
4238 0 : & tmp_mat(:,jbranch,ibranch)
4239 : end do
4240 : end do
4241 :
4242 : end do ! end ib1 do
4243 : end do ! end ikpt_phon do
4244 : end do ! end isppol do
4245 :
4246 : end do ! end isym do
4247 : end do ! itim
4248 :
4249 0 : if (neqqpt > 1) then
4250 0 : write(std_out,*) ' found several equiv qpts and am symmetrizing them ', neqqpt
4251 : end if
4252 :
4253 : ! divide by number of equivalent qpts found
4254 0 : gkk_qpt_new(:,:,:,:,:) = gkk_qpt_new(:,:,:,:,:)/neqqpt
4255 :
4256 : ! copy the symmetrized version into all the equivalent qpoints, appropriately transformed
4257 : ! See above
4258 : ! itim=1
4259 0 : do itim=1,2
4260 0 : do isym=1,nsym
4261 : ! ieqqpt is sent onto iqpt by itim/isym
4262 0 : ieqqpt = qpttoqpt(itim,isym,iqpt)
4263 :
4264 0 : if (symmetrized_qpt(ieqqpt) /= -1) cycle
4265 0 : gkk_qpt_tmp(:,:,:,:,:) = zero
4266 :
4267 : ! use symrec matrices to get inverse transform from isym^{-1}
4268 0 : if (elph_ds%ep_scalprod==1) then
4269 0 : do ii=1,3
4270 0 : do jj=1,3
4271 0 : ss(ii,jj)=0.0_dp
4272 0 : do kk=1,3
4273 0 : do ll=1,3
4274 : ! Use inverse of symop matrix here to get back to ieqqpt (inv+transpose is in symrec and in gprimd)
4275 0 : ss(ii,jj)=ss(ii,jj)+rprimd(ii,kk)*symrec(ll,kk,isym)*gprimd(ll,jj)
4276 : end do
4277 : end do
4278 : end do
4279 : end do
4280 : else
4281 0 : do ii=1,3
4282 0 : do jj=1,3
4283 0 : ss(ii,jj) = symrel(ii,jj,isym)
4284 : end do
4285 : end do
4286 : end if
4287 :
4288 0 : ss_allatoms(:,:,:) = zero
4289 0 : do iatom=1,natom
4290 0 : ancestor_iatom = indsym(4,isym,iatom)
4291 : ! do jatom=1,natom
4292 : ! ancestor_jatom = indsym(4,isym,jatom)
4293 : ss_allatoms(1,(ancestor_iatom-1)*3+1:(ancestor_iatom-1)*3+3,&
4294 0 : & (iatom-1)*3+1: (iatom-1)*3+3) = ss(1:3,1:3)
4295 : ! end do
4296 : end do
4297 :
4298 : ! ! Use inverse of symop matrix here to get back to ieqqpt
4299 : ! ssinv(ii,jj)=ssinv(ii,jj)+gprimd(ii,kk)*rprimd(jj,ll)*symrel(kk,ll,isym)
4300 :
4301 0 : do isppol=1,elph_ds%nsppol
4302 0 : do ikpt_phon=1,elph_ds%k_phon%nkpt
4303 : ! symikpt_phon is sent onto ikpt_phon by itim/isym
4304 0 : symikpt_phon=elph_ds%k_phon%full2full(itim,isym,ikpt_phon)
4305 :
4306 0 : do ib1=1,elph_ds%ngkkband*elph_ds%ngkkband
4307 :
4308 : ! multiply by the ss^{-1} matrices
4309 0 : tmp_mat2(:,:,:) = zero
4310 : tmp_mat(:,:,:) = reshape(gkk_qpt_new(:,ib1,:,ikpt_phon,isppol),&
4311 0 : & (/2,elph_ds%nbranch,elph_ds%nbranch/))
4312 : call ZGEMM ('N','N',elph_ds%nbranch,elph_ds%nbranch,elph_ds%nbranch,&
4313 : & c_one,ss_allatoms,elph_ds%nbranch,tmp_mat,elph_ds%nbranch,c_zero,&
4314 0 : & tmp_mat2,elph_ds%nbranch)
4315 : call ZGEMM ('N','T',elph_ds%nbranch,elph_ds%nbranch,elph_ds%nbranch,&
4316 : & c_one,tmp_mat2,elph_ds%nbranch,ss_allatoms,elph_ds%nbranch,c_zero,&
4317 0 : & tmp_mat,elph_ds%nbranch)
4318 :
4319 0 : do ibranch =1,elph_ds%nbranch
4320 0 : do jbranch =1,elph_ds%nbranch
4321 : gkk_qpt_tmp(:,ib1,(jbranch-1)*elph_ds%nbranch+ibranch,symikpt_phon,isppol) =&
4322 0 : & tmp_mat(:,jbranch,ibranch)
4323 : end do
4324 : end do
4325 :
4326 0 : do ik_this_proc =1,elph_ds%k_phon%my_nkpt
4327 0 : if (elph_ds%k_phon%my_ikpt(ik_this_proc) == symikpt_phon) then
4328 0 : if (gkk_flag (1,1,ik_this_proc,isppol,ieqqpt) == -1) gkk_flag (:,:,ik_this_proc,isppol,ieqqpt) = 0
4329 : exit
4330 : end if
4331 : end do
4332 : ! if (gkk_flag (1,1,symikpt_phon,isppol,ieqqpt) == -1) then
4333 : ! gkk_flag (:,:,symikpt_phon,isppol,ieqqpt) = 0
4334 : ! end if
4335 :
4336 : end do ! end ib1 do
4337 : end do ! end ikpt_phon do
4338 : end do ! end isppol do
4339 :
4340 :
4341 : ! save symmetrized matrices for qpt ieqqpt
4342 0 : do ik_this_proc =1,elph_ds%k_phon%my_nkpt
4343 0 : ikpt_phon = elph_ds%k_phon%my_ikpt(ik_this_proc)
4344 :
4345 0 : if (elph_ds%gkqwrite == 0) then
4346 0 : elph_ds%gkk_qpt(:,:,:,ik_this_proc,:,ieqqpt) = gkk_qpt_tmp(:,:,:,ikpt_phon,:)
4347 0 : else if (elph_ds%gkqwrite == 1) then
4348 0 : write(elph_ds%unitgkq,REC=((ieqqpt-1)*elph_ds%k_phon%my_nkpt+ik_this_proc)) gkk_qpt_tmp(:,:,:,ikpt_phon,:)
4349 : end if
4350 : end do
4351 :
4352 0 : symmetrized_qpt(ieqqpt) = 1
4353 :
4354 : end do ! end isym do
4355 : end do ! end itim do
4356 :
4357 : end do
4358 : !end iqpt do
4359 :
4360 0 : ABI_FREE(gkk_qpt_new)
4361 0 : ABI_FREE(gkk_qpt_tmp)
4362 :
4363 0 : end subroutine complete_gkk
4364 : !!***
4365 :
4366 : !!****f* ABINIT/get_nv_fs_en
4367 : !! NAME
4368 : !! get_nv_fs_en
4369 : !!
4370 : !! FUNCTION
4371 : !! This routine finds the energy grids for the integration on epsilon
4372 : !! and epsilon prime. It then calculates the DOS and FS averaged velocity_sq at
4373 : !! these energies. Metals and semiconductors are treated differently, to deal
4374 : !! correctly with the gap.
4375 : !!
4376 : !! INPUTS
4377 : !! crystal<crystal_t>=data type gathering info on the crystalline structure.
4378 : !! Ifc<ifc_type>=Object containing the interatomic force constants.
4379 : !! elph_ds
4380 : !! elph_ds%nband = number of bands in ABINIT
4381 : !! elph_ds%k_fine%nkptirr = Number of irreducible points for which there exist at least one band that crosses the Fermi level.
4382 : !! elph_ds%nbranch = number of phonon branches = 3*natom
4383 : !! elph_ds%k_phon%nkpt = number of k points
4384 : !! elph_ds%k_fine%irredtoGS = mapping of elph k-points to ground state grid
4385 : !! elph_ds%minFSband = lowest band included in the FS integration
4386 : !! elph_ds%nFSband = number of bands included in the FS integration
4387 : !! elph_ds%fermie = fermi energy
4388 : !! elph_ds%tempermin = minimum temperature at which resistivity etc are calculated (in K)
4389 : !! elph_ds%temperinc = interval temperature grid on which resistivity etc are calculated (in K)
4390 : !! elph_ds%ep_b_min= first band taken into account in FS integration (if telphint==2)
4391 : !! elph_ds%ep_b_max= last band taken into account in FS integration (if telphint==2)
4392 : !! elph_ds%telphint = flag for integration over the FS with 0=tetrahedra 1=gaussians
4393 : !! elph_ds%elphsmear = smearing width for gaussian integration
4394 : !! or buffer in energy for calculations with tetrahedra (telphint=0)
4395 : !!
4396 : !! elph_tr_ds
4397 : !! elph_tr_ds%el_veloc = electronic velocities from the fine k-grid
4398 : !!
4399 : !! eigenGS = Ground State eigenvalues
4400 : !! kptrlatt_fine = k-point grid vectors (if divided by determinant of present matrix)
4401 : !! max_occ = maximal occupancy for a band
4402 : !!
4403 : !! OUTPUT
4404 : !! elph_ds%nenergy = number of energy points for integration on epsilon
4405 : !! elph_tr_ds%en_all = energy points
4406 : !! elph_tr_ds%de_all = differences between energy points
4407 : !! elph_tr_ds%dos_n = DOS at selected energy points
4408 : !! elph_tr_ds%veloc_sq = FS averaged velocity square at selected energy points
4409 : !! elph_tr_ds%tmp_gkk_intweight = integration weights at coarse k grid
4410 : !! elph_tr_ds%tmp_velocwtk = velocity times integration weights at coarse k grid
4411 : !! elph_tr_ds%tmp_vvelocwtk = velocity square times integration weights at coarse k grid
4412 : !!
4413 : !! SOURCE
4414 :
4415 0 : subroutine get_nv_fs_en(crystal,ifc,elph_ds,eigenGS,max_occ,elph_tr_ds,omega_max)
4416 :
4417 : !Arguments ------------------------------------
4418 : !Scalars
4419 : real(dp), intent(in) :: max_occ
4420 : real(dp), intent(out) :: omega_max
4421 : type(ifc_type),intent(in) :: ifc
4422 : type(crystal_t),intent(in) :: crystal
4423 : type(elph_type),intent(inout) :: elph_ds
4424 : type(elph_tr_type),intent(inout) :: elph_tr_ds
4425 : !Arrays
4426 :
4427 : real(dp), intent(in) :: eigenGS(elph_ds%nband,elph_ds%k_fine%nkptirr,elph_ds%nsppol)
4428 :
4429 : !Local variables-------------------------------
4430 : !scalars
4431 : integer :: iFSqpt,isppol,ie1,ierr
4432 : integer :: i_metal,low_T
4433 : integer :: in_nenergy, out_nenergy
4434 : integer :: n_edge1, n_edge2, edge
4435 : integer :: ie_all, ne_all
4436 : integer :: sz1, sz2, sz3, sz4
4437 : real(dp) :: e_vb_max, e_cb_min,ucvol
4438 : real(dp) :: e1,max_e,fine_range
4439 : real(dp) :: enemin,enemax
4440 : real(dp) :: Temp,e_tiny,de0
4441 : real(dp) :: eff_mass1, eff_mass2, tmp_dos
4442 : character(len=500) :: message
4443 : !arrays
4444 : real(dp) :: gprimd(3,3), kpt_2nd(3), e_cb_2nd(2), en1(2)
4445 0 : real(dp),allocatable :: dos_e1(:,:),tmp_wtk(:,:,:,:), phfrq(:,:), displ(:,:,:,:)
4446 : ! *************************************************************************
4447 :
4448 0 : gprimd = crystal%gprimd
4449 0 : ucvol = crystal%ucvol
4450 :
4451 0 : Temp = elph_ds%tempermin+elph_ds%temperinc
4452 0 : elph_ds%delta_e = kb_HaK*Temp ! about 1000 cm^-1/100, no need to be omega_max
4453 0 : max_e = elph_ds%nenergy*kb_HaK*Temp
4454 0 : e_tiny = kb_HaK*0.00001_dp ! this is the min. delta_e
4455 0 : de0 = kb_HaK*Temp ! Kb*T
4456 :
4457 0 : in_nenergy = elph_ds%nenergy
4458 :
4459 0 : ABI_MALLOC(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol,4))
4460 0 : ABI_MALLOC(dos_e1,(elph_ds%nsppol,3))
4461 :
4462 0 : ABI_MALLOC(phfrq,(elph_ds%nbranch, elph_ds%k_phon%nkpt))
4463 0 : ABI_MALLOC(displ,(2, elph_ds%nbranch, elph_ds%nbranch, elph_ds%k_phon%nkpt))
4464 :
4465 0 : do iFSqpt=1,elph_ds%k_phon%nkpt
4466 0 : call ifc%fourq(crystal,elph_ds%k_phon%kpt(:,iFSqpt),phfrq(:,iFSqpt),displ(:,:,:,iFSqpt))
4467 : end do
4468 :
4469 0 : omega_max = maxval(phfrq)*1.1_dp
4470 0 : ABI_FREE(phfrq)
4471 0 : ABI_FREE(displ)
4472 :
4473 0 : write(message,'(a,E20.12)')' The max phonon energy is ', omega_max
4474 0 : call wrtout(std_out,message,'COLL')
4475 :
4476 0 : enemin = elph_ds%fermie - max_e*2
4477 0 : enemax = elph_ds%fermie + max_e
4478 : call ep_el_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4479 : & enemin, enemax, 4, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4480 : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4481 0 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine, tmp_wtk)
4482 :
4483 0 : do isppol=1,elph_ds%nsppol
4484 0 : dos_e1(isppol,1) = sum(tmp_wtk(:,:,isppol,2))/elph_ds%k_fine%nkpt
4485 0 : dos_e1(isppol,2) = sum(tmp_wtk(:,:,isppol,3))/elph_ds%k_fine%nkpt
4486 0 : dos_e1(isppol,3) = sum(tmp_wtk(:,:,isppol,4))/elph_ds%k_fine%nkpt
4487 :
4488 : ! ! BXU, only treat metallic case at this moment, as variational method may not
4489 : ! ! apply to insulators
4490 : ! i_metal = -1
4491 0 : i_metal = 1
4492 : ! if (dos_e1(isppol,1) .gt. 0.1_dp .and. dos_e1(isppol,2) .gt. 0.1_dp .and. &
4493 : ! & dos_e1(isppol,3) .gt. 0.1_dp) then ! metal
4494 : ! i_metal = 1
4495 0 : if (i_metal == 1) then
4496 0 : write(message,'(a)')' This is a metal.'
4497 0 : call wrtout(std_out,message,'COLL')
4498 :
4499 0 : fine_range = 1.5_dp
4500 0 : e1 = elph_ds%fermie + omega_max*fine_range
4501 0 : out_nenergy = 0
4502 0 : low_T = 1
4503 0 : if (omega_max*fine_range .lt. max_e) then
4504 0 : low_T = 0
4505 0 : de0 = omega_max*fine_range/in_nenergy ! energy spacing within Ef +/- omega_max
4506 0 : do while ((e1-elph_ds%fermie) .lt. max_e)
4507 0 : e1 = e1 + elph_ds%delta_e
4508 0 : out_nenergy = out_nenergy + 1
4509 : end do
4510 : end if
4511 :
4512 : if (low_T == 0) max_e = e1 - elph_ds%fermie
4513 0 : elph_ds%nenergy = in_nenergy*2 + 1 + out_nenergy*2
4514 :
4515 : else ! semiconductor/insulator, need careful consideration later
4516 : i_metal = 0
4517 : ! between CB min and the next k point, use free electron to replace
4518 : ! The weights will be proportional to the DOS, relative to the weights
4519 : ! calculated with ep_fs_weights, tetrahedron method prefered
4520 :
4521 : ! output VB and CB edges for semiconductor/insulator
4522 : e_vb_max = maxval(eigenGS(elph_ds%minFSband+elph_ds%nFSband/2-1,:,isppol))
4523 : e_cb_min = minval(eigenGS(elph_ds%minFSband+elph_ds%nFSband/2,:,isppol))
4524 : e_cb_2nd(1) = eigenGS(elph_ds%minFSband+elph_ds%nFSband/2,2,isppol)
4525 : e_cb_2nd(2) = eigenGS(elph_ds%minFSband+elph_ds%nFSband/2+1,2,isppol)
4526 : write(message,'(a,E20.12,2x,E20.12)')' elphon : top of VB, bottom of CB = ',&
4527 : & e_vb_max, e_cb_min
4528 : call wrtout(std_out,message,'COLL')
4529 : write(message,'(a,E20.12)')' elphon : energy at the neighbor kpt = ',e_cb_2nd(1)
4530 : call wrtout(std_out,message,'COLL')
4531 :
4532 : n_edge1 = 4 ! at the very edge
4533 : n_edge2 = 8 ! sparse to the end of free-electron part
4534 :
4535 : kpt_2nd(:) = gprimd(:,1)*elph_ds%k_fine%kptirr(1,2) + &
4536 : & gprimd(:,2)*elph_ds%k_fine%kptirr(2,2) + &
4537 : & gprimd(:,3)*elph_ds%k_fine%kptirr(3,2)
4538 : write(message,'(a,3E20.12)')' The neighbor k point is: ', elph_ds%k_fine%kptirr(:,2)
4539 : call wrtout(std_out,message,'COLL')
4540 :
4541 : if (dabs(elph_ds%fermie-e_cb_min) .lt. dabs(elph_ds%fermie-e_vb_max)) then
4542 : e1 = e_cb_2nd(1)
4543 : else
4544 : e1 = e_vb_max
4545 : end if
4546 : call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4547 : & e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4548 : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4549 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4550 :
4551 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4552 :
4553 : eff_mass1 = (kpt_2nd(1)*kpt_2nd(1) + kpt_2nd(2)*kpt_2nd(2) + kpt_2nd(3)*kpt_2nd(3)) / &
4554 : & (2.0_dp*(e_cb_2nd(1)-e_cb_min))
4555 : write(message,'(a,E20.12)')' The eff. mass from band1 is: ', eff_mass1
4556 : call wrtout(std_out,message,'COLL')
4557 : eff_mass2 = (kpt_2nd(1)*kpt_2nd(1) + kpt_2nd(2)*kpt_2nd(2) + kpt_2nd(3)*kpt_2nd(3)) / &
4558 : & (2.0_dp*(e_cb_2nd(2)-e_cb_min))
4559 : write(message,'(a,E20.12)')' The eff. mass from band2 is: ', eff_mass2
4560 : call wrtout(std_out,message,'COLL')
4561 :
4562 : ! bxu, but the eff. mass estimated in this way is too small
4563 : ! The following is obtained by roughly fitting to the DOS of 48x48x48
4564 : eff_mass1 = 0.91036
4565 : write(message,'(a,E20.12)')' The eff. mass we are using is: ', eff_mass1
4566 : call wrtout(std_out,message,'COLL')
4567 :
4568 : tmp_dos = (ucvol/2.0_dp/pi**2.0_dp)*(2.0_dp*eff_mass1)**1.5_dp*(e1-e_cb_min)**0.5_dp + &
4569 : & 2.0_dp*(ucvol/2.0_dp/pi**2.0_dp)*(2.0_dp*eff_mass2)**1.5_dp*(e1-e_cb_min)**0.5_dp
4570 : write(message,'(a,E20.12)')' The fake DOS at kpt1 = ', tmp_dos
4571 : call wrtout(std_out,message,'COLL')
4572 : write(message,'(a,E20.12)')' The calculated DOS at kpt1 = ', elph_ds%n0(isppol)
4573 : call wrtout(std_out,message,'COLL')
4574 :
4575 :
4576 : e1 = elph_ds%fermie - max_e
4577 : ie_all = 1
4578 : ne_all = 0
4579 : edge = 0
4580 :
4581 : call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4582 : & e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4583 : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4584 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4585 :
4586 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4587 : do while ((e1-elph_ds%fermie) .lt. max_e)
4588 : if (e1 .lt. e_cb_min .and. elph_ds%n0(isppol) .lt. tol9) then
4589 : e1 = e_cb_2nd(1)
4590 : edge = 1
4591 : e1 = e1 + de0
4592 : end if
4593 :
4594 : if (e1 .lt. e_cb_2nd(1)) then
4595 : e1 = e_cb_2nd(1)
4596 : edge = 1
4597 : e1 = e1 + de0
4598 : end if
4599 :
4600 : if (e1 .gt. e_cb_2nd(1)) then
4601 : call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4602 : & e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4603 : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4604 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4605 :
4606 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4607 :
4608 : e1 = e1 + de0
4609 : ie_all = ie_all + 1
4610 : end if
4611 : end do ! e_all
4612 : ne_all = ie_all - 1 + (n_edge1 + n_edge2 - 1)*edge ! energy levels in the free-electron range
4613 : write(message,'(a,i3,a,i3,a)')' For spin', isppol, ' there are ', &
4614 : & ne_all, ' energy levels considered '
4615 : call wrtout(std_out,message,'COLL')
4616 :
4617 : elph_ds%nenergy = ne_all
4618 : end if ! metal or insulator
4619 : end do ! isppol
4620 :
4621 0 : ABI_FREE(tmp_wtk)
4622 :
4623 0 : if (elph_ds%nenergy .lt. 2) then
4624 0 : ABI_ERROR('There are too few energy levels for non-LOVA')
4625 : end if
4626 :
4627 0 : sz1=elph_ds%ngkkband;sz2=elph_ds%k_phon%nkpt
4628 0 : sz3=elph_ds%nsppol;sz4=elph_ds%nenergy+1
4629 0 : ABI_MALLOC(elph_tr_ds%dos_n,(sz4,sz3))
4630 0 : ABI_MALLOC(elph_tr_ds%veloc_sq,(3,sz3,sz4))
4631 0 : ABI_MALLOC(elph_tr_ds%en_all,(sz3,sz4))
4632 0 : ABI_MALLOC(elph_tr_ds%de_all,(sz3,sz4+1))
4633 0 : ABI_MALLOC(elph_tr_ds%tmp_gkk_intweight,(sz1,sz2,sz3,sz4))
4634 0 : ABI_MALLOC(elph_tr_ds%tmp_velocwtk,(sz1,sz2,3,sz3,sz4))
4635 0 : ABI_MALLOC(elph_tr_ds%tmp_vvelocwtk,(sz1,sz2,3,3,sz3,sz4))
4636 :
4637 0 : elph_tr_ds%dos_n = zero
4638 0 : elph_tr_ds%veloc_sq = zero
4639 0 : elph_tr_ds%tmp_gkk_intweight = zero
4640 0 : elph_tr_ds%tmp_velocwtk = zero
4641 0 : elph_tr_ds%tmp_vvelocwtk = zero
4642 :
4643 0 : ABI_MALLOC_OR_DIE(elph_ds%k_phon%velocwtk,(elph_ds%nFSband,elph_ds%k_phon%nkpt,3,elph_ds%nsppol), ierr)
4644 :
4645 0 : ABI_MALLOC_OR_DIE(elph_ds%k_phon%vvelocwtk,(elph_ds%nFSband,elph_ds%k_phon%nkpt,3,3,elph_ds%nsppol), ierr)
4646 :
4647 0 : elph_ds%k_phon%velocwtk = zero
4648 0 : elph_ds%k_phon%vvelocwtk = zero
4649 :
4650 : !metal
4651 : if (i_metal .eq. 1) then
4652 0 : e1 = elph_ds%fermie - max_e
4653 0 : en1(:) = elph_ds%fermie - max_e
4654 0 : if (low_T .eq. 1) then
4655 0 : enemin = elph_ds%fermie - max_e - elph_ds%delta_e
4656 0 : enemax = elph_ds%fermie + max_e
4657 :
4658 0 : ABI_MALLOC(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol,elph_ds%nenergy+1))
4659 : call ep_el_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4660 : & enemin, enemax, elph_ds%nenergy+1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4661 : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4662 0 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine, tmp_wtk)
4663 :
4664 0 : do isppol=1,elph_ds%nsppol
4665 0 : do ie1 = 1, elph_ds%nenergy
4666 0 : elph_tr_ds%en_all(isppol,ie1) = en1(isppol)
4667 0 : elph_tr_ds%de_all(isppol,ie1) = elph_ds%delta_e
4668 :
4669 0 : elph_ds%k_fine%wtk(:,:,isppol) = tmp_wtk(:,:,isppol,ie1+1)
4670 0 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4671 0 : elph_tr_ds%dos_n(ie1,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4672 :
4673 0 : call get_veloc_tr(elph_ds,elph_tr_ds)
4674 0 : elph_tr_ds%veloc_sq(:,isppol,ie1)=elph_tr_ds%FSelecveloc_sq(:,isppol)
4675 :
4676 0 : call d2c_weights(elph_ds,elph_tr_ds)
4677 :
4678 0 : elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie1) = elph_ds%k_phon%wtk(:,:,isppol)
4679 0 : elph_tr_ds%tmp_velocwtk(:,:,:,isppol,ie1) = elph_ds%k_phon%velocwtk(:,:,:,isppol)
4680 0 : elph_tr_ds%tmp_vvelocwtk(:,:,:,:,isppol,ie1) = elph_ds%k_phon%vvelocwtk(:,:,:,:,isppol)
4681 0 : en1(isppol) = en1(isppol) + elph_ds%delta_e
4682 : end do
4683 : end do
4684 0 : ABI_FREE(tmp_wtk)
4685 :
4686 : else ! low_T = 0
4687 0 : enemin = e1 - elph_ds%delta_e
4688 0 : enemax = e1 + (out_nenergy-1)*elph_ds%delta_e
4689 :
4690 0 : ABI_MALLOC(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol,out_nenergy+1))
4691 : call ep_el_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4692 : & enemin, enemax, out_nenergy+1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4693 : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4694 0 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine, tmp_wtk)
4695 0 : do isppol=1,elph_ds%nsppol
4696 0 : do ie1 = 1, out_nenergy
4697 0 : elph_tr_ds%en_all(isppol,ie1) = en1(isppol)
4698 0 : elph_tr_ds%de_all(isppol,ie1) = elph_ds%delta_e
4699 :
4700 0 : elph_ds%k_fine%wtk(:,:,isppol) = tmp_wtk(:,:,isppol,ie1+1)
4701 0 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4702 0 : elph_tr_ds%dos_n(ie1,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4703 :
4704 0 : call get_veloc_tr(elph_ds,elph_tr_ds)
4705 0 : elph_tr_ds%veloc_sq(:,isppol,ie1)=elph_tr_ds%FSelecveloc_sq(:,isppol)
4706 :
4707 0 : call d2c_weights(elph_ds,elph_tr_ds)
4708 :
4709 0 : elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie1) = elph_ds%k_phon%wtk(:,:,isppol)
4710 0 : elph_tr_ds%tmp_velocwtk(:,:,:,isppol,ie1) = elph_ds%k_phon%velocwtk(:,:,:,isppol)
4711 0 : elph_tr_ds%tmp_vvelocwtk(:,:,:,:,isppol,ie1) = elph_ds%k_phon%vvelocwtk(:,:,:,:,isppol)
4712 :
4713 0 : en1(isppol) = en1(isppol) + elph_ds%delta_e
4714 : end do
4715 : end do
4716 0 : ABI_FREE(tmp_wtk)
4717 :
4718 0 : e1 = en1(1)
4719 0 : enemin = e1 - de0
4720 0 : enemax = e1 + in_nenergy*2*de0
4721 :
4722 0 : ABI_MALLOC(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol,in_nenergy*2+2))
4723 : call ep_el_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4724 : & enemin, enemax, in_nenergy*2+2, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4725 : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4726 0 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine, tmp_wtk)
4727 :
4728 0 : do isppol=1,elph_ds%nsppol
4729 0 : do ie1 = out_nenergy+1, out_nenergy+in_nenergy*2+1
4730 0 : elph_tr_ds%en_all(isppol,ie1) = en1(isppol)
4731 0 : elph_tr_ds%de_all(isppol,ie1) = de0
4732 :
4733 0 : elph_ds%k_fine%wtk(:,:,isppol) = tmp_wtk(:,:,isppol,ie1-out_nenergy+1)
4734 0 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4735 0 : elph_tr_ds%dos_n(ie1,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4736 :
4737 0 : call get_veloc_tr(elph_ds,elph_tr_ds)
4738 0 : elph_tr_ds%veloc_sq(:,isppol,ie1)=elph_tr_ds%FSelecveloc_sq(:,isppol)
4739 :
4740 0 : call d2c_weights(elph_ds,elph_tr_ds)
4741 :
4742 0 : elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie1) = elph_ds%k_phon%wtk(:,:,isppol)
4743 0 : elph_tr_ds%tmp_velocwtk(:,:,:,isppol,ie1) = elph_ds%k_phon%velocwtk(:,:,:,isppol)
4744 0 : elph_tr_ds%tmp_vvelocwtk(:,:,:,:,isppol,ie1) = elph_ds%k_phon%vvelocwtk(:,:,:,:,isppol)
4745 :
4746 0 : en1(isppol) = en1(isppol) + de0
4747 : end do
4748 : end do
4749 0 : ABI_FREE(tmp_wtk)
4750 :
4751 0 : e1 = en1(1)
4752 0 : enemin = e1 - elph_ds%delta_e
4753 0 : enemax = e1 + (out_nenergy-1)*elph_ds%delta_e
4754 :
4755 0 : ABI_MALLOC(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol,out_nenergy+1))
4756 : call ep_el_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4757 : & enemin, enemax, out_nenergy+1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4758 : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4759 0 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine, tmp_wtk)
4760 :
4761 0 : en1(:) = en1(:) - de0 + elph_ds%delta_e ! adjust to make the points symmetric around Ef
4762 0 : do isppol=1,elph_ds%nsppol
4763 0 : do ie1 = out_nenergy+in_nenergy*2+2, in_nenergy*2+1+out_nenergy*2
4764 0 : elph_tr_ds%en_all(isppol,ie1) = en1(isppol)
4765 0 : elph_tr_ds%de_all(isppol,ie1) = elph_ds%delta_e
4766 :
4767 0 : elph_ds%k_fine%wtk(:,:,isppol) = tmp_wtk(:,:,isppol,ie1-out_nenergy-in_nenergy*2)
4768 0 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4769 0 : elph_tr_ds%dos_n(ie1,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4770 :
4771 0 : call get_veloc_tr(elph_ds,elph_tr_ds)
4772 0 : elph_tr_ds%veloc_sq(:,isppol,ie1)=elph_tr_ds%FSelecveloc_sq(:,isppol)
4773 :
4774 0 : call d2c_weights(elph_ds,elph_tr_ds)
4775 :
4776 0 : elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie1) = elph_ds%k_phon%wtk(:,:,isppol)
4777 0 : elph_tr_ds%tmp_velocwtk(:,:,:,isppol,ie1) = elph_ds%k_phon%velocwtk(:,:,:,isppol)
4778 0 : elph_tr_ds%tmp_vvelocwtk(:,:,:,:,isppol,ie1) = elph_ds%k_phon%vvelocwtk(:,:,:,:,isppol)
4779 :
4780 0 : en1(isppol) = en1(isppol) + elph_ds%delta_e
4781 : end do
4782 : end do
4783 0 : ABI_FREE(tmp_wtk)
4784 : end if
4785 :
4786 : !semiconductor
4787 : else if (i_metal .eq. 0) then
4788 : e1 = elph_ds%fermie - max_e
4789 : ie_all = 1
4790 :
4791 : call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4792 : & e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4793 : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4794 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4795 :
4796 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4797 : do while ((e1-elph_ds%fermie) .lt. max_e)
4798 : if (e1 .lt. e_cb_min .and. elph_ds%n0(isppol) .lt. tol9) then
4799 : e1 = e_cb_min
4800 : end if
4801 :
4802 : if (ie_all .ge. n_edge1+n_edge2) then
4803 : if (ie_all .eq. n_edge1+n_edge2) e1 = e1 + de0
4804 : call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4805 : & e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4806 : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4807 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4808 :
4809 : elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie_all) = elph_ds%k_fine%wtk(:,:,isppol)
4810 : elph_tr_ds%dos_n(ie_all,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4811 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4812 :
4813 : elph_tr_ds%en_all(isppol,ie_all) = e1
4814 : call get_veloc_tr(elph_ds,elph_tr_ds)
4815 : elph_tr_ds%veloc_sq(:,isppol,ie_all)=elph_tr_ds%FSelecveloc_sq(:,isppol)
4816 : ! bxu
4817 : ! veloc_sq(1,isppol,ie_all) is "1" good and general??
4818 :
4819 : elph_tr_ds%de_all(isppol,ie_all) = de0
4820 : e1 = e1 + elph_tr_ds%de_all(isppol,ie_all)
4821 : ie_all = ie_all + 1
4822 : else ! divided according to the 1/DOS (evenly)
4823 : if (ie_all .lt. n_edge1) then
4824 : elph_tr_ds%en_all(isppol,ie_all) = e_cb_min + &
4825 : & (e_tiny**(-0.5_dp) - ie_all*(e_tiny**(-0.5_dp)-(e_cb_2nd(1)-e_cb_min)**(-0.5_dp))/ &
4826 : & dble(n_edge1))**(-2.0_dp)
4827 : if (ie_all .gt. 1) then
4828 : elph_tr_ds%de_all(isppol,ie_all) = elph_tr_ds%en_all(isppol,ie_all) - elph_tr_ds%en_all(isppol,ie_all-1)
4829 : else
4830 : elph_tr_ds%de_all(isppol,ie_all) = elph_tr_ds%en_all(isppol,ie_all) - e_cb_min - e_tiny
4831 : end if
4832 : e1 = elph_tr_ds%en_all(isppol,ie_all)
4833 : else
4834 : elph_tr_ds%en_all(isppol,ie_all) = e_cb_min + &
4835 : & ((ie_all-n_edge1+1)/dble(n_edge2))**2.0_dp*(e_cb_2nd(1)-e_cb_min)
4836 : if (ie_all .gt. 1) then
4837 : elph_tr_ds%de_all(isppol,ie_all) = elph_tr_ds%en_all(isppol,ie_all) - elph_tr_ds%en_all(isppol,ie_all-1)
4838 : else
4839 : elph_tr_ds%de_all(isppol,ie_all) = (e_cb_2nd(1)-e_cb_min)/(dble(n_edge2)**2.0_dp)
4840 : end if
4841 : e1 = elph_tr_ds%en_all(isppol,ie_all)
4842 : end if
4843 :
4844 : call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4845 : & e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4846 : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4847 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4848 :
4849 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4850 :
4851 : tmp_dos = (ucvol/2.0_dp/pi**2.0_dp)*(2.0_dp*eff_mass1)**1.5_dp*(e1-e_cb_min)**0.5_dp + &
4852 : & 2.0_dp*(ucvol/2.0_dp/pi**2.0_dp)*(2.0_dp*eff_mass2)**1.5_dp*(e1-e_cb_min)**0.5_dp
4853 : elph_tr_ds%dos_n(ie_all,isppol) = tmp_dos
4854 : elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie_all) = elph_ds%k_fine%wtk(:,:,isppol)*tmp_dos/elph_ds%n0(isppol)
4855 :
4856 : call get_veloc_tr(elph_ds,elph_tr_ds)
4857 : elph_tr_ds%veloc_sq(:,isppol,ie_all)=elph_tr_ds%FSelecveloc_sq(:,isppol)
4858 :
4859 : if (ie_all .eq. (n_edge1+n_edge2)) e1 = e_cb_2nd(1) + de0
4860 : ie_all = ie_all + 1
4861 : end if
4862 : end do ! ie_all
4863 : else
4864 : ABI_BUG('check i_metal!')
4865 : end if ! metal or insulator
4866 :
4867 0 : ABI_FREE(dos_e1)
4868 :
4869 0 : end subroutine get_nv_fs_en
4870 : !!***
4871 :
4872 : !!****f* ABINIT/get_nv_fs_temp
4873 : !! NAME
4874 : !! get_nv_fs_temp
4875 : !!
4876 : !! FUNCTION
4877 : !! This routine calculates the fermi energy, FD smeared DOS(Ef) and
4878 : !! Veloc_sq(Ef) at looped temperatures.
4879 : !!
4880 : !! INPUTS
4881 : !! elph_ds
4882 : !! elph_ds%nband = number of bands in ABINIT
4883 : !! elph_ds%k_fine%nkptirr = Number of irreducible points for which there exist at least one band that crosses the Fermi level.
4884 : !! elph_ds%nFSband = number of bands included in the FS integration
4885 : !! elph_ds%k_fine%nkpt = number of k points for fine k-grid
4886 : !! elph_ds%k_phon%nkpt = number of k points for coarse k-grid
4887 : !! elph_ds%tempermin = minimum temperature at which resistivity etc are calculated (in K)
4888 : !! elph_ds%temperinc = interval temperature grid on which resistivity etc are calculated (in K)
4889 : !! elph_ds%ep_b_min= first band taken into account in FS integration (if telphint==2)
4890 : !! elph_ds%ep_b_max= last band taken into account in FS integration (if telphint==2)
4891 : !! elph_ds%telphint = flag for integration over the FS with 0=tetrahedra 1=gaussians
4892 : !! elph_ds%elphsmear = smearing width for gaussian integration
4893 : !! or buffer in energy for calculations with tetrahedra (telphint=0)
4894 : !!
4895 : !! eigenGS = Ground State eigenvalues
4896 : !! gprimd = reciprocal lattice vectors (dimensionful)
4897 : !! kptrlatt_fine = k-point grid vectors (if divided by determinant of present matrix)
4898 : !! max_occ = maximal occupancy for a band
4899 : !!
4900 : !! OUTPUT
4901 : !! elph_ds%fermie=Fermi level at input temperature
4902 : !! elph_tr_ds%dos_n0=DOS(Ef) at looped temperatures
4903 : !! elph_tr_ds%veloc_sq0=FS averaged velocity at Ef at looped temperatures
4904 : !!
4905 : !! SOURCE
4906 :
4907 0 : subroutine get_nv_fs_temp(elph_ds,BSt,eigenGS,gprimd,max_occ,elph_tr_ds)
4908 :
4909 : !Arguments ------------------------------------
4910 : type(elph_type),intent(inout) :: elph_ds
4911 : type(ebands_t),intent(inout) :: BSt
4912 : type(elph_tr_type),intent(inout) :: elph_tr_ds
4913 :
4914 : !Scalars
4915 : real(dp), intent(in) :: max_occ
4916 :
4917 : ! arrays
4918 : real(dp), intent(in) :: gprimd(3,3)
4919 : real(dp), intent(in) :: eigenGS(elph_ds%nband,elph_ds%k_fine%nkptirr,elph_ds%nsppol)
4920 :
4921 : !Local variables-------------------------------
4922 :
4923 : integer :: isppol!, ie1
4924 : integer :: itemp, tmp_nenergy
4925 :
4926 : character(len=500) :: message
4927 :
4928 : real(dp) :: Temp, tmp_elphsmear, tmp_delta_e
4929 : ! real(dp) :: xtr, e1
4930 : ! real(dp),allocatable :: tmp_wtk(:,:)
4931 : ! *************************************************************************
4932 :
4933 0 : ABI_MALLOC(elph_tr_ds%dos_n0,(elph_ds%ntemper,elph_ds%nsppol))
4934 0 : ABI_MALLOC(elph_tr_ds%veloc_sq0,(elph_ds%ntemper,3,elph_ds%nsppol))
4935 : !if (elph_ds%use_k_fine == 1) then
4936 : !ABI_MALLOC(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt))
4937 : !else
4938 : !ABI_MALLOC(tmp_wtk,(elph_ds%nFSband,elph_ds%k_phon%nkpt))
4939 : !end if
4940 :
4941 0 : elph_tr_ds%dos_n0 = zero
4942 0 : elph_tr_ds%veloc_sq0 = zero
4943 :
4944 : tmp_nenergy = 8
4945 0 : do itemp=1,elph_ds%ntemper ! runs over temperature in K
4946 0 : Temp=elph_ds%tempermin + elph_ds%temperinc*dble(itemp)
4947 0 : tmp_delta_e = kb_HaK*Temp
4948 0 : Bst%occopt = 3
4949 0 : Bst%tsmear = Temp*kb_HaK
4950 0 : tmp_elphsmear = Temp*kb_HaK
4951 0 : call Bst%update_occ(-99.99_dp)
4952 0 : write(message,'(a,f12.6,a,E20.12)')'At T=',Temp,' Fermi level is:',Bst%fermie
4953 0 : call wrtout(std_out,message,'COLL')
4954 0 : if (abs(elph_ds%fermie) < tol10) then
4955 0 : elph_ds%fermie = BSt%fermie
4956 : end if
4957 :
4958 : ! FD smeared DOS and veloc
4959 :
4960 : call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, tmp_elphsmear, &
4961 : & elph_ds%fermie, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine,&
4962 : & max_occ, elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4963 0 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4964 :
4965 0 : do isppol=1,elph_ds%nsppol
4966 0 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4967 0 : write(message,'(a,f12.6,a,f12.6)')'At T=',Temp,' The DOS at Ef is:', elph_ds%n0(isppol)
4968 0 : call wrtout(std_out,message,'COLL')
4969 :
4970 : ! For the non-LOVA case, N(Ef) is not that important (canceled out eventually).
4971 : ! Should not be important for metal, comment out for now
4972 : ! tmp_wtk = zero
4973 : ! do ie1=-tmp_nenergy,tmp_nenergy ! use ie1 here, hope there is no confusion
4974 : ! e1=Bst%fermie+ie1*tmp_delta_e
4975 : ! xtr=(e1-Bst%fermie)/(2.0_dp*kb_HaK*Temp)
4976 : !
4977 : ! call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4978 : ! & e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, &
4979 : ! & max_occ, elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4980 : ! & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4981 : !
4982 : ! tmp_wtk(:,:) = tmp_wtk(:,:) + elph_ds%k_fine%wtk(:,:,isppol)* &
4983 : ! & tmp_delta_e/(4.0d0*kb_HaK*Temp)/(COSH(xtr)**2.0d0)
4984 : ! end do ! ie1
4985 :
4986 : ! elph_ds%k_fine%wtk(:,:,isppol) = tmp_wtk(:,:)
4987 0 : elph_tr_ds%dos_n0(itemp,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4988 : ! elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4989 : ! write(message,'(a,f12.6,a,f12.6)')'At T=',Temp,' The eff. DOS at Ef is:', elph_tr_ds%dos_n0(itemp,isppol)
4990 : ! call wrtout(std_out,message,'COLL')
4991 : end do ! isppol
4992 0 : call get_veloc_tr(elph_ds,elph_tr_ds)
4993 0 : elph_tr_ds%veloc_sq0(itemp,:,:) = elph_tr_ds%FSelecveloc_sq(:,:)
4994 :
4995 : end do ! temperature
4996 :
4997 0 : end subroutine get_nv_fs_temp
4998 : !!***
4999 :
5000 : !!****f* ABINIT/get_veloc_tr
5001 : !!
5002 : !! NAME
5003 : !! get_veloc_tr
5004 : !!
5005 : !! FUNCTION
5006 : !! calculate the (in) and (out) velocity factors for transport
5007 : !!
5008 : !! INPUTS
5009 : !! elph_ds
5010 : !! elph_ds%nFSband = number of bands included in the FS integration
5011 : !! elph_ds%k_fine%nkpt = number of kpts included in the FS integration
5012 : !! elph_ds%nFSband = number of bands included in the FS integration
5013 : !! elph_ds%minFSband = index of the lowest FS band
5014 : !! elph_ds%nqpt_full = number of Q pts
5015 : !! elph_ds%nqptirred = number of irreducible Q pts
5016 : !! to index the GS electronic states :
5017 : !! kphon_full2irr = mapping of full FS kpts to irreducible ones
5018 : !! FSfullpqtofull = mapping of k + q to k
5019 : !! FSirredtoGS = mapping of irreducible kpoints to GS set
5020 : !!
5021 : !! OUTPUT
5022 : !! elph_tr_ds%FSelecveloc_sq = avergae FS electronic velocity
5023 : !!
5024 : !! SOURCE
5025 :
5026 5 : subroutine get_veloc_tr(elph_ds,elph_tr_ds)
5027 :
5028 : !Arguments ------------------------------------
5029 : !arrays
5030 : type(elph_type),intent(in) :: elph_ds
5031 : type(elph_tr_type),intent(inout) :: elph_tr_ds
5032 :
5033 : !Local variables-------------------------------
5034 : !scalars
5035 : integer :: ikpt_fine
5036 : integer :: ib1,fib1,isppol, ii
5037 : real(dp) :: eta2
5038 : !arrays
5039 : real(dp) :: elvelock(3)
5040 :
5041 : ! *********************************************************************
5042 :
5043 5 : ABI_CHECK(allocated(elph_tr_ds%FSelecveloc_sq),"FSele not associated")
5044 :
5045 :
5046 : !precalculate the Fermi speed modulus squared
5047 25 : elph_tr_ds%FSelecveloc_sq = zero
5048 10 : do isppol=1,elph_ds%nsppol
5049 429 : do ikpt_fine=1,elph_ds%k_fine%nkpt
5050 3197 : do ib1=1,elph_ds%nFSband
5051 2768 : fib1=ib1+elph_ds%minFSband-1
5052 11072 : elvelock(:)=elph_tr_ds%el_veloc(ikpt_fine,fib1,:,isppol)
5053 11496 : do ii=1, 3
5054 8304 : eta2=elvelock(ii)*elvelock(ii)
5055 : elph_tr_ds%FSelecveloc_sq(ii, isppol)=elph_tr_ds%FSelecveloc_sq(ii, isppol)&
5056 11072 : & +eta2*elph_ds%k_fine%wtk(ib1,ikpt_fine,isppol)
5057 : end do
5058 : end do
5059 : end do
5060 25 : elph_tr_ds%FSelecveloc_sq(:,isppol) = elph_tr_ds%FSelecveloc_sq(:,isppol)/elph_ds%k_fine%nkpt/elph_ds%n0(isppol)
5061 : ! for factor 1/elph_ds%n0(isppol) see eq 12 of Allen prb 17 3725 [[cite:Allen1978]] : sum of v**2 over all k gives n0 times FSelecveloc_sq
5062 : end do ! end isppol
5063 5 : write (std_out,*) ' get_veloc_tr: FSelecveloc_sq ', elph_tr_ds%FSelecveloc_sq
5064 :
5065 5 : write (std_out,*) 'out of get_veloc_tr'
5066 :
5067 5 : end subroutine get_veloc_tr
5068 : !!***
5069 :
5070 : !!****f* ABINIT/integrate_gamma
5071 : !!
5072 : !! NAME
5073 : !! integrate_gamma
5074 : !!
5075 : !! FUNCTION
5076 : !! This routine integrates the electron phonon coupling matrix
5077 : !! over the kpoints on the fermi surface. A dependency on qpoint
5078 : !! remains for gamma_qpt
5079 : !!
5080 : !! INPUTS
5081 : !! elph_ds = elphon datastructure with data and dimensions
5082 : !! elph_ds%qpt_full = qpoint coordinates
5083 : !! elph_ds%nqptirred = number of irred qpoints
5084 : !! elph_ds%qirredtofull = indexing of the GKK qpoints found
5085 : !! FSfullpqtofull = mapping of k+q to k
5086 : !!
5087 : !! OUTPUT
5088 : !! elph_ds = modified elph_ds%gamma_qpt and created elph_ds%gamma_rpt
5089 : !!
5090 : !! SOURCE
5091 :
5092 15 : subroutine integrate_gamma(elph_ds,FSfullpqtofull)
5093 :
5094 : !Arguments ------------------------------------
5095 : !scalars
5096 : type(elph_type),intent(inout) :: elph_ds
5097 : !arrays
5098 : integer,intent(in) :: FSfullpqtofull(elph_ds%k_phon%nkpt,elph_ds%nqpt_full)
5099 :
5100 : !Local variables-------------------------------
5101 : !scalars
5102 : integer :: comm,ikpt_phon,ikpt_phonq,ib1,ib2,ibeff,iqpt,iqpt_fullbz,isppol,ierr
5103 : integer :: irec, symrankkpt_phon,nbranch,nsppol,ngkkband, ik_this_proc
5104 : character(len=500) :: message
5105 : character(len=fnlen) :: fname
5106 : !arrays
5107 15 : real(dp),allocatable :: tmp_gkk(:,:,:,:)
5108 : ! *************************************************************************
5109 :
5110 15 : comm = xmpi_world
5111 :
5112 15 : write (message,'(3a)')ch10,' entering integrate_gamma ',ch10
5113 15 : call wrtout(std_out,message,'COLL')
5114 :
5115 15 : nsppol = elph_ds%nsppol
5116 15 : nbranch = elph_ds%nbranch
5117 15 : ngkkband = elph_ds%ngkkband
5118 :
5119 75 : ABI_MALLOC(elph_ds%gamma_qpt,(2,nbranch**2,nsppol,elph_ds%nqpt_full))
5120 5663 : elph_ds%gamma_qpt = zero
5121 :
5122 75 : ABI_MALLOC(tmp_gkk ,(2,ngkkband**2,nbranch**2,nsppol))
5123 :
5124 15 : if (elph_ds%gkqwrite == 0) then
5125 14 : call wrtout(std_out,' integrate_gamma : keeping gamma matrices in memory','COLL')
5126 1 : else if (elph_ds%gkqwrite == 1) then
5127 1 : fname=trim(elph_ds%elph_base_name) // '_GKKQ'
5128 1 : write (message,'(2a)')' integrate_gamma : reading gamma matrices from file ',trim(fname)
5129 1 : call wrtout(std_out,message,'COLL')
5130 : else
5131 0 : write (message,'(a,i0)')' Wrong value for gkqwrite = ',elph_ds%gkqwrite
5132 0 : ABI_BUG(message)
5133 : end if
5134 :
5135 :
5136 :
5137 63 : do iqpt=1,elph_ds%nqptirred
5138 48 : iqpt_fullbz = elph_ds%qirredtofull(iqpt)
5139 48 : symrankkpt_phon = elph_ds%k_phon%krank%get_rank (elph_ds%k_phon%kpt(:,iqpt_fullbz))
5140 48 : write (std_out,*) ' iqpt_fullbz in qpt grid only, rank ', iqpt_fullbz, symrankkpt_phon
5141 :
5142 4143 : do ik_this_proc =1,elph_ds%k_phon%my_nkpt
5143 4080 : ikpt_phon = elph_ds%k_phon%my_ikpt(ik_this_proc)
5144 :
5145 4080 : if (elph_ds%gkqwrite == 0) then
5146 4595856 : tmp_gkk = elph_ds%gkk_qpt(:,:,:,ik_this_proc,:,iqpt)
5147 192 : else if (elph_ds%gkqwrite == 1) then
5148 192 : irec = (iqpt-1)*elph_ds%k_phon%my_nkpt+ik_this_proc
5149 192 : if (ikpt_phon == 1) then
5150 3 : write (std_out,*) ' integrate_gamma read record ', irec
5151 : end if
5152 192 : read (elph_ds%unitgkq,REC=irec) tmp_gkk(:,:,:,:)
5153 : end if
5154 :
5155 8232 : do isppol=1,nsppol
5156 4104 : ikpt_phonq = FSfullpqtofull(ikpt_phon,iqpt_fullbz)
5157 : !
5158 20264 : do ib1=1,ngkkband
5159 82904 : do ib2=1,ngkkband
5160 66720 : ibeff = ib2+(ib1-1)*ngkkband
5161 : elph_ds%gamma_qpt(:,:,isppol,iqpt_fullbz) = elph_ds%gamma_qpt(:,:,isppol,iqpt_fullbz) + &
5162 : & tmp_gkk(:,ibeff,:,isppol)&
5163 4617392 : & *elph_ds%gkk_intweight(ib1,ikpt_phon,isppol)*elph_ds%gkk_intweight(ib2,ikpt_phonq,isppol)
5164 : ! NOTE: if ngkkband==1 we are using trivial weights since average
5165 : ! over bands was done in normsq_gkk (nmsq_gam_sumFS or nmsq_pure_gkk)
5166 : end do ! ib2
5167 : end do ! ib1
5168 : end do ! isppol
5169 : end do ! ikpt_phon
5170 : end do ! iqpt
5171 :
5172 15 : call xmpi_sum (elph_ds%gamma_qpt, comm, ierr)
5173 :
5174 15 : ABI_FREE(tmp_gkk)
5175 :
5176 : !need prefactor of 1/nkpt for each integration over 1 kpoint index. NOT INCLUDED IN elph_ds%gkk_intweight
5177 63 : do iqpt=1,elph_ds%nqptirred
5178 48 : iqpt_fullbz = elph_ds%qirredtofull(iqpt)
5179 : ! elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) = elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) / elph_ds%k_phon%nkpt / n0(1) / n0(1)
5180 : ! elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) = elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) / elph_ds%k_phon%nkpt / elph_ds%k_phon%nkpt
5181 2463 : elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) = elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) * elph_ds%occ_factor / elph_ds%k_phon%nkpt
5182 : end do
5183 :
5184 15 : call wrtout(std_out,' integrate_gamma: gamma matrices have been calculated for recip space and irred qpoints ',"COLL")
5185 :
5186 30 : end subroutine integrate_gamma
5187 : !!***
5188 :
5189 : !!****f* ABINIT/integrate_gamma_tr
5190 : !!
5191 : !! NAME
5192 : !! integrate_gamma_tr
5193 : !!
5194 : !! FUNCTION
5195 : !! This routine integrates the TRANSPORT electron phonon coupling matrices
5196 : !! over the kpoints on the fermi surface. A dependency on qpoint
5197 : !! remains for gamma_qpt_in/out
5198 : !! Copied from integrate_gamma
5199 : !!
5200 : !! INPUTS
5201 : !! elph_ds = elphon datastructure with data and dimensions
5202 : !! elph_ds%qpt_full = qpoint coordinates
5203 : !! FSfullpqtofull = mapping of k+q to k
5204 : !! veloc_sq1 = mean square electronic velocity on constant energy surface
5205 : !! veloc_sq2 = mean square electronic velocity on constant energy surface
5206 : !!
5207 : !! OUTPUT
5208 : !! elph_tr_ds%gamma_qpt_tr and created elph_tr_ds%gamma_rpt_tr
5209 : !!
5210 : !! SOURCE
5211 :
5212 0 : subroutine integrate_gamma_tr(elph_ds,FSfullpqtofull,s1,s2, veloc_sq1,veloc_sq2,elph_tr_ds)
5213 :
5214 : !Arguments ------------------------------------
5215 : !scalars
5216 : integer,intent(in) :: s1,s2
5217 : type(elph_tr_type), intent(inout) :: elph_tr_ds
5218 : type(elph_type),intent(in) :: elph_ds
5219 : !arrays
5220 : integer,intent(in) :: FSfullpqtofull(elph_ds%k_phon%nkpt,elph_ds%nqpt_full)
5221 : real(dp),intent(in) :: veloc_sq1(3,elph_ds%nsppol), veloc_sq2(3,elph_ds%nsppol)
5222 :
5223 : !Local variables-------------------------------
5224 : !scalars
5225 : integer :: ikpt_phon,ikpt_phonq,ib1,ib2,ibeff,ierr,iqpt,iqpt_fullbz,isppol
5226 : integer :: itensor, icomp, jcomp,comm
5227 : integer :: fib1, fib2
5228 : integer :: ik_this_proc
5229 : ! integer :: ikpttemp
5230 : character(len=500) :: message
5231 : real(dp) :: wtk, wtkpq, interm
5232 : real(dp) :: veloc1_i, veloc1_j, veloc2_i, veloc2_j
5233 : !arrays
5234 : real(dp) :: elvelock(3), elvelockpq(3), velocwtk(3), velocwtkpq(3), vvelocwtk(3,3), vvelocwtkpq(3,3)
5235 0 : real(dp),allocatable :: tmp_gkk(:,:,:,:)
5236 : ! *************************************************************************
5237 :
5238 0 : comm = xmpi_world
5239 :
5240 : !information
5241 0 : if (elph_ds%gkqwrite == 0) then
5242 0 : write (message,'(a)')' integrate_gamma_tr : keeping gamma matrices in memory'
5243 0 : call wrtout(std_out,message,'COLL')
5244 0 : else if (elph_ds%gkqwrite == 1) then
5245 0 : write (message,'(a)')' integrate_gamma_tr : reading gamma matrices from disk'
5246 0 : call wrtout(std_out,message,'COLL')
5247 : else
5248 0 : write (message,'(3a,i3)')' integrate_gamma_tr : BUG-',ch10,&
5249 0 : & ' Wrong value for gkqwrite = ',elph_ds%gkqwrite
5250 0 : ABI_BUG(message)
5251 : end if
5252 :
5253 : !allocate temp variables
5254 0 : ABI_MALLOC_OR_DIE(tmp_gkk,(2,elph_ds%ngkkband**2,elph_ds%nbranch**2,elph_ds%nsppol), ierr)
5255 :
5256 0 : do iqpt=1,elph_ds%nqptirred
5257 0 : iqpt_fullbz = elph_ds%qirredtofull(iqpt)
5258 : ! write(std_out,*)'iqpt, iqptfullbz ',iqpt, iqpt_fullbz
5259 :
5260 0 : do ik_this_proc =1,elph_ds%k_phon%my_nkpt
5261 0 : ikpt_phon = elph_ds%k_phon%my_ikpt(ik_this_proc)
5262 :
5263 0 : if (elph_ds%gkqwrite == 0) then
5264 0 : tmp_gkk = elph_ds%gkk_qpt(:,:,:,ik_this_proc,:,iqpt)
5265 0 : else if (elph_ds%gkqwrite == 1) then
5266 0 : read(elph_ds%unitgkq,REC=((iqpt-1)*elph_ds%k_phon%my_nkpt+ik_this_proc)) tmp_gkk
5267 : end if
5268 :
5269 0 : ikpt_phonq = FSfullpqtofull(ikpt_phon,iqpt_fullbz)
5270 :
5271 0 : do isppol=1,elph_ds%nsppol
5272 0 : do ib1=1,elph_ds%ngkkband !FS bands
5273 0 : fib1=ib1+elph_ds%minFSband-1 ! full bands
5274 0 : elvelock(:)=elph_tr_ds%el_veloc(ikpt_phon,fib1,:,isppol)
5275 0 : wtk=elph_tr_ds%tmp_gkk_intweight1(ib1,ikpt_phon,isppol)
5276 0 : velocwtk(:)=elph_tr_ds%tmp_velocwtk1(ib1,ikpt_phon,:,isppol)
5277 0 : vvelocwtk(:,:)=elph_tr_ds%tmp_vvelocwtk1(ib1,ikpt_phon,:,:,isppol)
5278 :
5279 0 : do ib2=1,elph_ds%ngkkband ! FS bands
5280 0 : ibeff=ib2+(ib1-1)*elph_ds%ngkkband ! full bands
5281 0 : fib2=ib2+elph_ds%minFSband-1
5282 0 : elvelockpq(:)= elph_tr_ds%el_veloc(ikpt_phonq,fib2,:,isppol)
5283 0 : wtkpq=elph_tr_ds%tmp_gkk_intweight2(ib2,ikpt_phonq,isppol)
5284 0 : velocwtkpq(:)=elph_tr_ds%tmp_velocwtk2(ib2,ikpt_phonq,:,isppol)
5285 0 : vvelocwtkpq(:,:)=elph_tr_ds%tmp_vvelocwtk2(ib2,ikpt_phonq,:,:,isppol)
5286 :
5287 : ! MJV 31/03/2009: Note that the following is valid for any geometry, not just cubic!
5288 : ! see eq 5 and 6 of prb 36 4103 (Al-Lehaibi et al 1987) [[cite:Al-Lehaibi1987]],
5289 : ! see also Allen PRB 17 3725 [[cite:Allen1978]]
5290 : ! generalization to tensorial quantities is simple, by keeping the directional
5291 : ! references of velock and velockpq as indices.
5292 0 : do icomp = 1, 3
5293 0 : do jcomp = 1, 3
5294 0 : itensor = (icomp-1)*3+jcomp
5295 : ! FIXME: could use symmetry i <-> j
5296 :
5297 0 : veloc1_i = sqrt(veloc_sq1(icomp,isppol))
5298 0 : veloc1_j = sqrt(veloc_sq1(jcomp,isppol))
5299 0 : veloc2_i = sqrt(veloc_sq2(icomp,isppol))
5300 0 : veloc2_j = sqrt(veloc_sq2(jcomp,isppol))
5301 0 : if (elph_ds%use_k_fine == 1) then
5302 : interm = vvelocwtk(icomp,jcomp)*wtkpq/veloc1_i/veloc1_j + &
5303 : & s1*s2*vvelocwtkpq(icomp,jcomp)*wtk/veloc2_i/veloc2_j - &
5304 : & s1*velocwtk(jcomp)*velocwtkpq(icomp)/veloc1_j/veloc2_i - &
5305 0 : & s2*velocwtk(icomp)*velocwtkpq(jcomp)/veloc1_i/veloc2_j
5306 :
5307 : elph_tr_ds%gamma_qpt_tr(:,itensor,:,isppol,iqpt_fullbz) = &
5308 : & elph_tr_ds%gamma_qpt_tr(:,itensor,:,isppol,iqpt_fullbz) + &
5309 0 : & tmp_gkk(:,ibeff,:,isppol)*interm
5310 : else
5311 : elph_tr_ds%gamma_qpt_tr(:,itensor,:,isppol,iqpt_fullbz) = &
5312 : & elph_tr_ds%gamma_qpt_tr(:,itensor,:,isppol,iqpt_fullbz) + &
5313 : & tmp_gkk(:,ibeff,:,isppol) &
5314 : & *(elvelock(icomp)/veloc1_i - s1*elvelockpq(icomp)/veloc2_i) &
5315 : & *(elvelock(jcomp)/veloc1_j - s2*elvelockpq(jcomp)/veloc2_j) &
5316 0 : & *wtk*wtkpq
5317 : end if
5318 : end do
5319 : end do
5320 :
5321 : end do
5322 : end do
5323 : end do ! isppol
5324 :
5325 : end do ! ik
5326 : end do ! iq
5327 :
5328 0 : call xmpi_sum (elph_tr_ds%gamma_qpt_tr, comm, ierr)
5329 :
5330 0 : ABI_FREE(tmp_gkk)
5331 :
5332 :
5333 : !need prefactor of 1/nkpt for each integration over 1 kpoint index.
5334 : !NOT INCLUDED IN elph_ds%gkk_intweight
5335 : !Add a factor of 1/2 for the cross terms of (v-v')(v-v')
5336 0 : elph_tr_ds%gamma_qpt_tr = elph_tr_ds%gamma_qpt_tr* elph_ds%occ_factor*0.5_dp / elph_ds%k_phon%nkpt
5337 :
5338 0 : write (message,'(2a)')' integrate_gamma_tr : transport gamma matrices are calculated ',&
5339 0 : & ' in recip space and for irred qpoints'
5340 : !call wrtout(std_out,message,'COLL')
5341 :
5342 0 : end subroutine integrate_gamma_tr
5343 : !!***
5344 :
5345 : !!****f* ABINIT/integrate_gamma_tr_lova
5346 : !!
5347 : !! NAME
5348 : !! integrate_gamma_tr_lova
5349 : !!
5350 : !! FUNCTION
5351 : !! This routine integrates the TRANSPORT electron phonon coupling matrices
5352 : !! over the kpoints on the fermi surface. A dependency on qpoint
5353 : !! remains for gamma_qpt_in/out
5354 : !! Copied from integrate_gamma
5355 : !!
5356 : !! INPUTS
5357 : !! elph_ds = elphon datastructure with data and dimensions
5358 : !! elph_ds%qpt_full = qpoint coordinates
5359 : !! FSfullpqtofull = mapping of k+q to k
5360 : !!
5361 : !! OUTPUT
5362 : !! elph_tr_ds%gamma_qpt_trout
5363 : !! elph_tr_ds%gamma_qpt_trin
5364 : !!
5365 : !! SOURCE
5366 :
5367 5 : subroutine integrate_gamma_tr_lova(elph_ds,FSfullpqtofull,elph_tr_ds)
5368 :
5369 : !Arguments ------------------------------------
5370 : !scalars
5371 : type(elph_tr_type), intent(inout) :: elph_tr_ds
5372 : type(elph_type),intent(in) :: elph_ds
5373 : !arrays
5374 : integer,intent(in) :: FSfullpqtofull(elph_ds%k_phon%nkpt,elph_ds%nqpt_full)
5375 :
5376 : !Local variables-------------------------------
5377 : !scalars
5378 : integer :: ikpt_phon,ikpt_phonq,ib1,ib2,ibeff,ierr,iqpt,iqpt_fullbz,isppol
5379 : integer :: itensor, icomp, jcomp,comm
5380 : integer :: fib1, fib2
5381 : integer :: ik_this_proc
5382 : real(dp) :: etain, etaout
5383 : character(len=500) :: message
5384 : !arrays
5385 : real(dp) :: elvelock(3), elvelockpq(3)
5386 5 : real(dp),allocatable :: tmp_gkk(:,:,:,:)
5387 : ! *************************************************************************
5388 :
5389 5 : comm = xmpi_world
5390 :
5391 5 : ib1=elph_ds%nbranch*elph_ds%nbranch ; ib2=elph_ds%nqpt_full
5392 25 : ABI_MALLOC_OR_DIE(elph_tr_ds%gamma_qpt_trin,(2,9,ib1,elph_ds%nsppol,ib2), ierr)
5393 28309 : elph_tr_ds%gamma_qpt_trin = zero
5394 :
5395 25 : ABI_MALLOC_OR_DIE(elph_tr_ds%gamma_qpt_trout,(2,9,ib1,elph_ds%nsppol,ib2), ierr)
5396 28309 : elph_tr_ds%gamma_qpt_trout = zero
5397 :
5398 : !information
5399 5 : if (elph_ds%gkqwrite == 0) then
5400 5 : write (message,'(a)')' integrate_gamma_tr : keeping gamma matrices in memory'
5401 5 : call wrtout(std_out,message,'COLL')
5402 0 : else if (elph_ds%gkqwrite == 1) then
5403 0 : write (message,'(a)')' integrate_gamma_tr : reading gamma matrices from disk'
5404 0 : call wrtout(std_out,message,'COLL')
5405 : else
5406 0 : write (message,'(3a,i3)')' integrate_gamma_tr : BUG-',ch10,&
5407 0 : & ' Wrong value for gkqwrite = ',elph_ds%gkqwrite
5408 0 : ABI_ERROR(message)
5409 : end if
5410 :
5411 : !allocate temp variables
5412 25 : ABI_MALLOC_OR_DIE(tmp_gkk,(2,elph_ds%ngkkband**2,elph_ds%nbranch**2,elph_ds%nsppol), ierr)
5413 :
5414 23 : do iqpt=1,elph_ds%nqptirred
5415 18 : iqpt_fullbz = elph_ds%qirredtofull(iqpt)
5416 18 : write(std_out,*)'iqpt, iqptfullbz ',iqpt, iqpt_fullbz
5417 :
5418 1439 : do ik_this_proc =1,elph_ds%k_phon%my_nkpt
5419 1416 : ikpt_phon = elph_ds%k_phon%my_ikpt(ik_this_proc)
5420 :
5421 1416 : if (elph_ds%gkqwrite == 0) then
5422 4498560 : tmp_gkk = elph_ds%gkk_qpt(:,:,:,ik_this_proc,:,iqpt)
5423 0 : else if (elph_ds%gkqwrite == 1) then
5424 0 : read(elph_ds%unitgkq,REC=((iqpt-1)*elph_ds%k_phon%my_nkpt+ik_this_proc)) tmp_gkk
5425 : end if
5426 :
5427 1416 : ikpt_phonq = FSfullpqtofull(ikpt_phon,iqpt_fullbz)
5428 :
5429 2850 : do isppol=1,elph_ds%nsppol
5430 12224 : do ib1=1,elph_ds%ngkkband
5431 9392 : fib1=ib1+elph_ds%minFSband-1
5432 37568 : elvelock(:)=elph_tr_ds%el_veloc(ikpt_phon,fib1,:,isppol)
5433 :
5434 74840 : do ib2=1,elph_ds%ngkkband
5435 64032 : ibeff=ib2+(ib1-1)*elph_ds%ngkkband
5436 64032 : fib2=ib2+elph_ds%minFSband-1
5437 256128 : elvelockpq(:)= elph_tr_ds%el_veloc(ikpt_phonq,fib2,:,isppol)
5438 :
5439 :
5440 : ! MJV 31/03/2009: Note that the following is valid for any geometry, not just cubic!
5441 : ! see eq 5 and 6 of prb 36 4103 (Al-Lehaibi et al 1987) [[cite:Al-Lehaibi1987]]
5442 : ! see also Allen PRB 17 3725 [[cite:Allen1978]]
5443 : ! generalization to tensorial quantities is simple, by keeping the directional
5444 : ! references of velock and velockpq as indices.
5445 265520 : do icomp = 1, 3
5446 832416 : do jcomp = 1, 3
5447 576288 : itensor = (icomp-1)*3+jcomp
5448 : ! FIXME: could use symmetry i <-> j
5449 :
5450 576288 : etain = elvelock(icomp)*elvelockpq(jcomp)
5451 576288 : etaout = elvelock(icomp)*elvelock(jcomp)
5452 :
5453 :
5454 : elph_tr_ds%gamma_qpt_trin(:,itensor,:,isppol,iqpt_fullbz) = &
5455 : & elph_tr_ds%gamma_qpt_trin(:,itensor,:,isppol,iqpt_fullbz) + &
5456 : & tmp_gkk(:,ibeff,:,isppol) &
5457 : & *etain &
5458 40770432 : & *elph_ds%gkk_intweight(ib1,ikpt_phon,isppol)*elph_ds%gkk_intweight(ib2,ikpt_phonq,isppol)
5459 :
5460 : elph_tr_ds%gamma_qpt_trout(:,itensor,:,isppol,iqpt_fullbz) = &
5461 : & elph_tr_ds%gamma_qpt_trout(:,itensor,:,isppol,iqpt_fullbz) + &
5462 : & tmp_gkk(:,ibeff,:,isppol) &
5463 : & *etaout &
5464 40962528 : & *elph_ds%gkk_intweight(ib1,ikpt_phon,isppol)*elph_ds%gkk_intweight(ib2,ikpt_phonq,isppol)
5465 :
5466 : end do
5467 : end do
5468 : end do
5469 : end do
5470 :
5471 : end do ! isppol
5472 : end do ! ik
5473 :
5474 : end do ! iq
5475 :
5476 5 : ABI_FREE(tmp_gkk)
5477 :
5478 5 : call xmpi_sum (elph_tr_ds%gamma_qpt_trout, comm, ierr)
5479 5 : call xmpi_sum (elph_tr_ds%gamma_qpt_trin, comm, ierr)
5480 :
5481 :
5482 : !
5483 : !normalize tensor with 1/sqrt(v_x**2 * v_y**2)
5484 : !
5485 : !move the veloc into mka2f_tr_lova, where T dependence is dealt with
5486 : !This will cause some slight difference to the results
5487 : if (.true.) then
5488 10 : do isppol=1, elph_ds%nsppol
5489 25 : do icomp = 1, 3
5490 65 : do jcomp = 1, 3
5491 45 : itensor = (icomp-1)*3+jcomp
5492 60 : if(abs(elph_tr_ds%FSelecveloc_sq(icomp,isppol))>tol14**2 .and. abs(elph_tr_ds%FSelecveloc_sq(jcomp,isppol))>tol14**2)then
5493 : elph_tr_ds%gamma_qpt_trin(:,itensor,:,isppol,:) = elph_tr_ds%gamma_qpt_trin(:,itensor,:,isppol,:) / &
5494 20637 : & sqrt(elph_tr_ds%FSelecveloc_sq(icomp,isppol)*elph_tr_ds%FSelecveloc_sq(jcomp,isppol))
5495 : elph_tr_ds%gamma_qpt_trout(:,itensor,:,isppol,:) = elph_tr_ds%gamma_qpt_trout(:,itensor,:,isppol,:) / &
5496 20637 : & sqrt(elph_tr_ds%FSelecveloc_sq(icomp,isppol)*elph_tr_ds%FSelecveloc_sq(jcomp,isppol))
5497 : else
5498 : ! XG120528 Fixed problem with zero velocity
5499 6984 : elph_tr_ds%gamma_qpt_trin(:,itensor,:,isppol,:)=zero
5500 6984 : elph_tr_ds%gamma_qpt_trout(:,itensor,:,isppol,:)=zero
5501 : end if
5502 : end do
5503 : end do
5504 : end do ! isppol
5505 : end if
5506 :
5507 : !need prefactor of 1/nkpt for each integration over 1 kpoint index.
5508 : !NOT INCLUDED IN elph_ds%gkk_intweight
5509 28309 : elph_tr_ds%gamma_qpt_trout = elph_tr_ds%gamma_qpt_trout* elph_ds%occ_factor / elph_ds%k_phon%nkpt
5510 28309 : elph_tr_ds%gamma_qpt_trin = elph_tr_ds%gamma_qpt_trin * elph_ds%occ_factor / elph_ds%k_phon%nkpt
5511 :
5512 5 : write (message,'(2a)')' integrate_gamma_tr : transport gamma matrices are calculated ',&
5513 10 : & ' in recip space and for irred qpoints'
5514 5 : call wrtout(std_out,message,'COLL')
5515 :
5516 : !DEBUG
5517 : !write(std_out,*)' integrate_gamma_tr_lova: end elph_tr_ds%gamma_qpt_trin(1,9,1,1,1)=',elph_tr_ds%gamma_qpt_trin(1,9,1,1,1)
5518 : !ENDDEBUG
5519 :
5520 5 : end subroutine integrate_gamma_tr_lova
5521 : !!***
5522 :
5523 : !!****f* ABINIT/ftgkk
5524 : !!
5525 : !! NAME
5526 : !! ftgkk
5527 : !!
5528 : !! FUNCTION
5529 : !! If qtor=1 (q->r):
5530 : !! Generates the Fourier transform of the recip space gkk matrices
5531 : !! to obtain the real space ones.
5532 : !! If qtor=0 (r->q):
5533 : !! Generates the Fourier transform of the real space gkk matrices
5534 : !! to obtain the reciprocal space ones.
5535 : !!
5536 : !! INPUTS
5537 : !! gkqwrite = flag to write recip space matrix elements to disk
5538 : !! gkrwrite = flag to write real space matrix elements to disk
5539 : !! gprim(3,3)= Normalized coordinates in reciprocal space
5540 : !! ikpt_phon0 = starting kpt number for forward FT.
5541 : !! natom= Number of atoms in the unit cell
5542 : !! nkpt_phon= Number of kpoints used for the FS
5543 : !! ngkkband = number of bands kept in gkq and gkr matrix elements (=1 or nband)
5544 : !! nkpt_used= number of FS kpoints used, starting at ikpt_phon0
5545 : !! nqpt= Number of q points in the Brillouin zone
5546 : !! if qtor=0 this number is read in the input file
5547 : !! nrpt= Number of R points in the Big Box
5548 : !! qtor= ( q to r : see above )
5549 : !! rpt(3,nprt)= Canonical coordinates of the R points in the unit cell
5550 : !! These coordinates are normalized (=> * acell(3)!!)
5551 : !! qpt_full(3,nqpt)= Reduced coordinates of the q vectors in reciprocal space
5552 : !! if qtor=0 these vectors are read in the input file
5553 : !! unit_gkk_rpt = fortran unit for writing real-space matrix elements
5554 : !! unitgkq = fortran unit for writing reciprocal-space matrix elements
5555 : !! wghatm(natom,natom,nrpt)
5556 : !! = Weights associated to a pair of atoms and to a R vector
5557 : !!
5558 : !! OUTPUT
5559 : !! (see side effects)
5560 : !!
5561 : !! SIDE EFFECTS
5562 : !! Input/output
5563 : !! gkk_qpt(2,3*natom,nFSband,nFSband,nkpt_used,nqpt)
5564 : !! = gkk matrices in recip space coming from the Derivative Data Base
5565 : !! gkk_rpt(2,3*natom,nFSband,nFSband,nkpt_phon,nqpt)
5566 : !! = gkk matrices in real space stored in file unit_gkk_rpt
5567 : !!
5568 : !! NOTES
5569 : !! copied from ftiaf9.f
5570 : !! recip to real space: real space is forced to disk file unit_gkk_rpt
5571 : !! recip space depends on gkqwrite and unitgkq
5572 : !! real to recip space: real space is forced to disk file unit_gkk_rpt
5573 : !! recip space is necessarily in memory in gkk_qpt
5574 : !!
5575 : !! real space elements are complex, but could be reduced, as (-r) = (+r)*
5576 : !!
5577 : !! SOURCE
5578 :
5579 : subroutine ftgkk (wghatm,gkk_qpt,gkk_rpt,gkqwrite,gkrwrite,gprim,ikpt_phon0,&
5580 : & natom,nkpt_phon,ngkkband,nkpt_used,nqpt,nrpt,nsppol,&
5581 : & qtor,rpt,qpt_full,unit_gkk_rpt,unitgkq)
5582 :
5583 : !Arguments -------------------------------
5584 : !scalars
5585 : integer,intent(in) :: gkqwrite,gkrwrite,ikpt_phon0,nkpt_phon,natom,ngkkband
5586 : integer,intent(in) :: nkpt_used,nqpt,nrpt,nsppol,qtor,unit_gkk_rpt,unitgkq
5587 : !arrays
5588 : real(dp),intent(in) :: gprim(3,3),rpt(3,nrpt),qpt_full(3,nqpt)
5589 : real(dp),intent(in) :: wghatm(natom,natom,nrpt)
5590 : real(dp),intent(inout) :: gkk_qpt(2,ngkkband*ngkkband,3*natom*3*natom,nkpt_used,nsppol,nqpt)
5591 : real(dp),intent(inout) :: gkk_rpt(2,ngkkband*ngkkband,3*natom*3*natom,nkpt_used,nsppol,nrpt)
5592 :
5593 : !Local variables -------------------------
5594 : !scalars
5595 : integer :: ikpt_phon,iatom,ib1,ieffkpt_phon,ip,iqpt,irpt,isppol
5596 : integer :: jatom
5597 : real(dp) :: im,kr,re
5598 : character(len=500) :: message
5599 : !arrays
5600 : real(dp) :: coskr(nqpt,nrpt),ftwght(2,3*natom*3*natom)
5601 : real(dp) :: gkk_qpt_tmp(2,ngkkband*ngkkband,3*natom*3*natom,nkpt_used,nsppol)
5602 : real(dp) :: gkk_rpt_tmp(2,ngkkband*ngkkband,3*natom*3*natom,nkpt_phon,nsppol)
5603 : real(dp) :: kk(3),sinkr(nqpt,nrpt)
5604 :
5605 : ! *********************************************************************
5606 :
5607 : !rewind (unit_gkk_rpt)
5608 :
5609 : !prepare the phase factors
5610 : do iqpt=1,nqpt
5611 : ! Calculation of the k coordinates in Normalized Reciprocal
5612 : ! coordinates
5613 : kk(1)= qpt_full(1,iqpt)*gprim(1,1)+&
5614 : & qpt_full(2,iqpt)*gprim(1,2)+&
5615 : & qpt_full(3,iqpt)*gprim(1,3)
5616 : kk(2)= qpt_full(1,iqpt)*gprim(2,1)+&
5617 : & qpt_full(2,iqpt)*gprim(2,2)+&
5618 : & qpt_full(3,iqpt)*gprim(2,3)
5619 : kk(3)= qpt_full(1,iqpt)*gprim(3,1)+&
5620 : & qpt_full(2,iqpt)*gprim(3,2)+&
5621 : & qpt_full(3,iqpt)*gprim(3,3)
5622 : do irpt=1,nrpt
5623 : ! Product of k and r
5624 : kr = kk(1)*rpt(1,irpt)+&
5625 : & kk(2)*rpt(2,irpt)+&
5626 : & kk(3)*rpt(3,irpt)
5627 : coskr(iqpt,irpt)=cos(two_pi*kr)
5628 : sinkr(iqpt,irpt)=sin(two_pi*kr)
5629 : ! DEBUG
5630 : ! if (iqpt < 1000 .and. (irpt == 101 .or. irpt == 901)) then
5631 : ! write(std_out,*) iqpt,irpt,kk,rpt(:,irpt),coskr(iqpt,irpt), sinkr(iqpt,irpt)
5632 : ! end if
5633 : ! ENDDEBUG
5634 : end do
5635 : end do
5636 :
5637 :
5638 :
5639 : !Recip to real space
5640 : if (qtor==1) then
5641 : !
5642 : if (nkpt_used /= nkpt_phon) write(std_out,*) 'ftgkk: strange usage of nkpt_used for back FT!'
5643 : do irpt=1,nrpt
5644 : ! DEBUG
5645 : ! write(std_out,*) ' ftgkk : G->R irpt = ',irpt,' / ',nrpt
5646 : ! ENDDEBUG
5647 : gkk_rpt_tmp(:,:,:,:,:) = zero
5648 :
5649 : do iqpt=1,nqpt
5650 :
5651 : ! write(std_out,*) iqpt
5652 :
5653 : if (gkqwrite == 0) then
5654 : gkk_qpt_tmp(:,:,:,:,:) = gkk_qpt(:,:,:,:,:,iqpt)
5655 : else
5656 : do ikpt_phon=1, nkpt_phon
5657 : read(unitgkq,REC=((iqpt-1)*nkpt_phon+ikpt_phon)) gkk_qpt_tmp(:,:,:,ikpt_phon,:)
5658 : end do
5659 : end if
5660 : ! Get the phase factor with normalization!
5661 : re=coskr(iqpt,irpt)/nqpt
5662 : im=sinkr(iqpt,irpt)/nqpt
5663 : do isppol=1,nsppol
5664 : do ikpt_phon=1,nkpt_used
5665 : ! DEBUG
5666 : ! write(std_out,*) ' ftgkk : G->R ikpt_phon = ',ikpt_phon,' / ',nkpt_used
5667 : ! ENDDEBUG
5668 : do ip=1,3*natom*3*natom
5669 : ! Real and imaginary part of the real-space gkk matrices -> exp(-i k.r)
5670 : do ib1=1,ngkkband*ngkkband
5671 : gkk_rpt_tmp(1,ib1,ip,ikpt_phon,isppol) = gkk_rpt_tmp(1,ib1,ip,ikpt_phon,isppol)&
5672 : & +re*gkk_qpt_tmp(1,ib1,ip,ikpt_phon,isppol) &
5673 : & +im*gkk_qpt_tmp(2,ib1,ip,ikpt_phon,isppol)
5674 : gkk_rpt_tmp(2,ib1,ip,ikpt_phon,isppol) = gkk_rpt_tmp(2,ib1,ip,ikpt_phon,isppol)&
5675 : & +re*gkk_qpt_tmp(2,ib1,ip,ikpt_phon,isppol) &
5676 : & -im*gkk_qpt_tmp(1,ib1,ip,ikpt_phon,isppol)
5677 : end do
5678 : end do
5679 : end do
5680 : end do
5681 : end do
5682 : if (gkrwrite == 0) then
5683 : gkk_rpt(:,:,:,:,:,irpt) = gkk_rpt_tmp(:,:,:,:,:)
5684 : else
5685 : write (unit_gkk_rpt,REC=irpt) gkk_rpt_tmp
5686 : end if
5687 : end do
5688 :
5689 : ! Real space to recip space
5690 : else if (qtor==0) then
5691 :
5692 : ! write(std_out,*) 'ftgkk : shape(gkk_qpt) = ', shape(gkk_qpt)
5693 : gkk_qpt(:,:,:,:,:,:)=zero
5694 :
5695 : ! rewind (unit_gkk_rpt)
5696 : do irpt=1,nrpt
5697 : if (gkrwrite == 0) then
5698 : gkk_rpt_tmp(:,:,:,:,:) = gkk_rpt(:,:,:,:,:,irpt)
5699 : else
5700 : read(unit_gkk_rpt,REC=irpt) gkk_rpt_tmp
5701 : end if
5702 :
5703 :
5704 : do iqpt=1,nqpt
5705 :
5706 : ! Avoid recalculating weights nkpt_used*9 times
5707 : do iatom=1,natom
5708 : do jatom=1,natom
5709 : ip = 3*((iatom-1)*natom+jatom-1)
5710 : ! copy same weight for all 3 directions
5711 : ftwght(1,ip+1:ip+3)=coskr(iqpt,irpt)*wghatm(iatom,jatom,irpt)
5712 : ftwght(2,ip+1:ip+3)=sinkr(iqpt,irpt)*wghatm(iatom,jatom,irpt)
5713 : end do
5714 : end do
5715 :
5716 :
5717 :
5718 : do ip=1,3*natom*3*natom
5719 : ! Get phase factor
5720 : re = ftwght(1,ip)
5721 : im = ftwght(2,ip)
5722 :
5723 : do isppol=1,nsppol
5724 : do ikpt_phon=1,nkpt_used
5725 :
5726 :
5727 : ! DEBUG
5728 : ! write(std_out,*) ' ftgkk : R->G ikpt_phon = ',ikpt_phon,' / ',nkpt_used
5729 : ! ENDDEBUG
5730 : ! effective FS kpt in real space array is ikpt_phon+ikpt_phon0-1 to allow for offset
5731 : ieffkpt_phon = ikpt_phon+ikpt_phon0-1
5732 : ! write(std_out,*) 'ftgkk :ikpt_phon,iqpt,ieffkpt_phon ', ikpt_phon,iqpt,ieffkpt_phon
5733 :
5734 : do ib1=1,ngkkband*ngkkband
5735 : ! Real and imaginary part of the gamma matrices
5736 : gkk_qpt(1,ib1,ip,ikpt_phon,isppol,iqpt)=&
5737 : & gkk_qpt(1,ib1,ip,ikpt_phon,isppol,iqpt)&
5738 : & +re*gkk_rpt_tmp(1,ib1,ip,ieffkpt_phon,isppol)&
5739 : & -im*gkk_rpt_tmp(2,ib1,ip,ieffkpt_phon,isppol)
5740 : ! !DEBUG
5741 : gkk_qpt(2,ib1,ip,ikpt_phon,isppol,iqpt)=&
5742 : & gkk_qpt(2,ib1,ip,ikpt_phon,isppol,iqpt)&
5743 : & +im*gkk_rpt_tmp(1,ib1,ip,ieffkpt_phon,isppol)&
5744 : & +re*gkk_rpt_tmp(2,ib1,ip,ieffkpt_phon,isppol)
5745 : ! !ENDDEBUG
5746 :
5747 : ! if (iqpt < 100 .and. irpt < 100 .and. &
5748 : ! & tmpgkkrim(irpt)**2+tmpgkkrre(irpt)**2 > tol6) then
5749 : ! write(std_out,'(2I4,2E16.8,x,2E16.8)') &
5750 : ! & iqpt,irpt,re,im,tmpgkkrre(irpt),tmpgkkrim(irpt)
5751 : ! end if
5752 :
5753 : end do
5754 : end do
5755 : ! end ikpt_phon
5756 : end do
5757 : ! end isppol
5758 : ! write(std_out,'(a)') ' ftgkk :gkk_qpt :'
5759 : ! write(std_out,'(4E16.5)') gkk_qpt(:,1,1,,ikpt_phon,1:nqpt)
5760 : end do
5761 : ! end ip
5762 : end do
5763 : ! end iqpt
5764 : end do
5765 : ! end irpt
5766 :
5767 :
5768 : ! There is no other space to Fourier transform from ??
5769 : else
5770 : write(message,'(a,a,a,i0,a)' )&
5771 : & 'The only allowed values for qtor are 0 or 1, while',ch10,&
5772 : & 'qtor=',qtor,' has been required.'
5773 : ABI_BUG(message)
5774 : end if
5775 :
5776 : end subroutine ftgkk
5777 : !!***
5778 :
5779 : end module m_elphon
5780 : !!***
|
