Branch data 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,elph_ds%k_phon%nsppol,&
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 : : !!***
|
