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, qmesh_from_brav_ngqpt, kptrlatt_ncells
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%gprimd, elph_ds%nqpt_full,Ifc%nrpt, elph_ds%qpt_full, Ifc%rpt, coskr, sinkr)
1001 : :
1002 : 15 : call timein(tcpu,twall)
1003 : : write(message, '(a,f11.3,a,f11.3,a)' )&
1004 : 15 : & '-elphon begin integration of gkq after tcpu',tcpu-tcpui,' and twall',twall-twalli,' sec'
1005 : 15 : call wrtout(std_out,message,'COLL')
1006 : 15 : tcpui = tcpu
1007 : 15 : twalli = twall
1008 : :
1009 : 15 : call integrate_gamma(elph_ds,FSfullpqtofull)
1010 : :
1011 [ + + ]: 15 : if (elph_ds%symgkq ==1) then
1012 : : ! complete the gamma_qpt here instead of the gkk previously
1013 : : call complete_gamma(Cryst,elph_ds%nbranch,elph_ds%nsppol,elph_ds%nqptirred,elph_ds%nqpt_full,&
1014 : 14 : & elph_ds%ep_scalprod,elph_ds%qirredtofull,qpttoqpt,elph_ds%gamma_qpt)
1015 : : end if
1016 : :
1017 : : !Now FT to real space too
1018 : : !NOTE: gprim (not gprimd) is used for all FT interpolations,
1019 : : !to be consistent with the dimensions of the rpt, which come from anaddb.
1020 [ - + + - : 75 : ABI_MALLOC(elph_ds%gamma_rpt, (2,elph_ds%nbranch**2,elph_ds%nsppol,Ifc%nrpt))
- + + - -
+ + - + -
+ - - + -
+ - + ]
1021 [ + + + + : 15409 : elph_ds%gamma_rpt = zero
+ + + + ]
1022 : :
1023 : 15 : qtor = 1 ! q --> r
1024 [ + + ]: 31 : do isppol=1,elph_ds%nsppol
1025 : : call ftgam(Ifc%wghatm,elph_ds%gamma_qpt(:,:,isppol,:),elph_ds%gamma_rpt(:,:,isppol,:),natom,&
1026 [ + + + - : 3055 : & elph_ds%nqpt_full,Ifc%nrpt,qtor, coskr, sinkr)
+ + + + +
+ + + + -
+ + + + +
+ + + + +
+ + + + +
+ + + + +
+ + ]
1027 : : end do
1028 : :
1029 : 15 : call timein(tcpu,twall)
1030 : : write(message, '(a,f11.3,a,f11.3,a)' )&
1031 : 15 : & '-elphon end integration and completion of gkq after tcpu',tcpu-tcpui,' and twall',twall-twalli,' sec'
1032 : 15 : call wrtout(std_out,message,'COLL')
1033 : 15 : tcpui = tcpu
1034 : 15 : twalli = twall
1035 : :
1036 : :
1037 : : !==========================================================
1038 : : !calculate transport matrix elements, integrated over FS
1039 : : !==========================================================
1040 : :
1041 [ + + ]: 15 : if (elph_tr_ds%ifltransport == 1)then ! LOVA
1042 : :
1043 : 5 : call integrate_gamma_tr_lova(elph_ds,FSfullpqtofull,elph_tr_ds)
1044 : :
1045 : : call complete_gamma_tr(cryst,elph_ds%ep_scalprod,elph_ds%nbranch,elph_ds%nqptirred,&
1046 : 5 : & elph_ds%nqpt_full,elph_ds%nsppol,elph_tr_ds%gamma_qpt_trout,elph_ds%qirredtofull,qpttoqpt)
1047 : :
1048 : : call complete_gamma_tr(cryst,elph_ds%ep_scalprod,elph_ds%nbranch,elph_ds%nqptirred,&
1049 : 5 : & elph_ds%nqpt_full,elph_ds%nsppol,elph_tr_ds%gamma_qpt_trin,elph_ds%qirredtofull,qpttoqpt)
1050 : :
1051 [ - + + - : 25 : ABI_MALLOC(elph_tr_ds%gamma_rpt_trout,(2,9,elph_ds%nbranch**2,elph_ds%nsppol,Ifc%nrpt))
- + + - -
+ + - + -
+ - - + -
+ - + ]
1052 [ + + + + : 85407 : elph_tr_ds%gamma_rpt_trout = zero
+ + + + +
+ ]
1053 : :
1054 [ - + + - : 20 : ABI_MALLOC(elph_tr_ds%gamma_rpt_trin,(2,9,elph_ds%nbranch**2,elph_ds%nsppol,Ifc%nrpt))
- + + - -
+ + - - +
- + - + ]
1055 [ + + + + : 85407 : elph_tr_ds%gamma_rpt_trin = zero
+ + + + +
+ ]
1056 : :
1057 : : ! Now FT to real space too
1058 : 5 : qtor = 1 ! q --> r
1059 [ + + ]: 10 : do isppol=1,elph_ds%nsppol
1060 [ + + ]: 55 : do idir=1,9
1061 : : call ftgam(Ifc%wghatm,elph_tr_ds%gamma_qpt_trout(:,idir,:,isppol,:),&
1062 : : & elph_tr_ds%gamma_rpt_trout(:,idir,:,isppol,:),natom,&
1063 [ + - + - : 221499 : & elph_ds%nqpt_full,Ifc%nrpt,qtor, coskr, sinkr)
+ + + + +
+ + - + -
+ + + + +
+ + - + +
+ + + + +
- + + + +
+ + ]
1064 : :
1065 : : call ftgam(Ifc%wghatm,elph_tr_ds%gamma_qpt_trin(:,idir,:,isppol,:),&
1066 : : & elph_tr_ds%gamma_rpt_trin(:,idir,:,isppol,:),natom,&
1067 [ + - + - : 221504 : & elph_ds%nqpt_full,Ifc%nrpt,qtor, coskr, sinkr)
+ + + + +
+ + - + -
+ + + + +
+ + - + +
+ + + + +
- + + + +
+ + ]
1068 : : end do
1069 : : end do
1070 : :
1071 [ + - ]: 10 : else if (elph_tr_ds%ifltransport==2) then ! non-LOVA case
1072 : :
1073 : : ! Get Ef, DOS(Ef), veloc(Ef) for looped temperatures
1074 : 0 : call get_nv_fs_temp(elph_ds,BSt,eigenGS_fine,cryst%gprimd,max_occ,elph_tr_ds)
1075 : :
1076 : : ! Get DOS(E), veloc(E) for looped energy levels
1077 : 0 : call get_nv_fs_en(cryst,ifc,elph_ds,eigenGS_fine,max_occ,elph_tr_ds,omega_max)
1078 : :
1079 : : ! Save the E, N(E), v^2(E), dE
1080 [ # # ]: 0 : if (master == me) then
1081 [ # # ]: 0 : fname = trim(elph_ds%elph_base_name) // '_EPTS'
1082 [ # # ]: 0 : if (open_file(fname,message,newunit=unit_epts,status="unknown") /=0) then
1083 : 0 : ABI_ERROR(message)
1084 : : end if
1085 [ # # ]: 0 : do isppol = 1, elph_ds%nsppol
1086 : 0 : write(unit_epts,"(a,i6)") '# E, N(E), v^2(E), dE for spin channel ', isppol
1087 [ # # ]: 0 : do ie1 = 1, elph_ds%nenergy
1088 : 0 : write(unit_epts,"(4E20.12)") elph_tr_ds%en_all(isppol,ie1), elph_tr_ds%dos_n(ie1,isppol),&
1089 : 0 : & elph_tr_ds%veloc_sq(1,isppol,ie1), elph_tr_ds%de_all(isppol,ie1)
1090 : : end do
1091 : : end do
1092 : 0 : close(unit=unit_epts)
1093 : : end if
1094 : :
1095 [ # # # # : 0 : ABI_MALLOC(tmp_veloc_sq1,(3,elph_ds%nsppol))
# # # # #
# # # ]
1096 [ # # # # : 0 : ABI_MALLOC(tmp_veloc_sq2,(3,elph_ds%nsppol))
# # # # ]
1097 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%tmp_gkk_intweight1,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,elph_ds%nsppol))
# # # # #
# # # # #
# # # # #
# # # ]
1098 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%tmp_gkk_intweight2,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,elph_ds%nsppol))
# # # # #
# # # # #
# # # # ]
1099 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%tmp_velocwtk1,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,3,elph_ds%nsppol))
# # # # #
# # # # #
# # # # #
# # # #
# ]
1100 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%tmp_velocwtk2,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,3,elph_ds%nsppol))
# # # # #
# # # # #
# # # # ]
1101 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%tmp_vvelocwtk1,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,3,3,elph_ds%nsppol))
# # # # #
# # # # #
# # # # #
# # # #
# ]
1102 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%tmp_vvelocwtk2,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,3,3,elph_ds%nsppol))
# # # # #
# # # # #
# # # # ]
1103 : :
1104 [ # # # # ]: 0 : tmp_veloc_sq1 = zero
1105 [ # # # # ]: 0 : tmp_veloc_sq2 = zero
1106 [ # # # # : 0 : elph_tr_ds%tmp_gkk_intweight1 = zero
# # ]
1107 [ # # # # : 0 : elph_tr_ds%tmp_gkk_intweight2 = zero
# # ]
1108 [ # # # # : 0 : elph_tr_ds%tmp_velocwtk1 = zero
# # # # ]
1109 [ # # # # : 0 : elph_tr_ds%tmp_velocwtk2 = zero
# # # # ]
1110 [ # # # # : 0 : elph_tr_ds%tmp_vvelocwtk1 = zero
# # # # #
# ]
1111 [ # # # # : 0 : elph_tr_ds%tmp_vvelocwtk2 = zero
# # # # #
# ]
1112 : :
1113 [ # # ]: 0 : if (elph_ds%ep_lova .eq. 1) then
1114 : : tmp_nenergy = 1
1115 [ # # ]: 0 : else if (elph_ds%ep_lova .eq. 0) then
1116 : 0 : tmp_nenergy = elph_ds%nenergy
1117 : : else
1118 : 0 : write(message,'(a,i0)')' ep_lova must be 0 or 1 while it is : ', elph_ds%ep_lova
1119 : 0 : ABI_ERROR(message)
1120 : : end if
1121 : :
1122 : : ! This only works for ONE temperature!! for test only
1123 [ # # ]: 0 : elph_ds%n0(:) = elph_tr_ds%dos_n0(1,:)
1124 : :
1125 : : ! bxu, no need for complete sets of ie1 and ie2
1126 : : ! Only save those within the range of omega_max from Ef
1127 [ # # # # : 0 : ABI_MALLOC(pair2red,(tmp_nenergy,tmp_nenergy))
# # # # #
# # # # #
# # ]
1128 [ # # # # ]: 0 : pair2red = 0
1129 : :
1130 : 0 : elph_ds%n_pair = 0
1131 [ # # ]: 0 : do ie1=1,tmp_nenergy
1132 : 0 : e1 = elph_tr_ds%en_all(1,ie1)
1133 : 0 : e2 = e1 - omega_max
1134 [ # # ]: 0 : if (e2 .lt. elph_tr_ds%en_all(1,1)) then
1135 : : i_start = 1
1136 : : else
1137 : 0 : i_start = 1
1138 : 0 : diff = dabs(e2-elph_tr_ds%en_all(1,1))
1139 [ # # ]: 0 : do ie2 = 2, tmp_nenergy
1140 [ # # ]: 0 : if (dabs(e2-elph_tr_ds%en_all(1,ie2)) .lt. diff) then
1141 : 0 : diff = dabs(e2-elph_tr_ds%en_all(1,ie2))
1142 : 0 : i_start = ie2
1143 : : end if
1144 : : end do
1145 : : end if
1146 : 0 : e2 = e1 + omega_max
1147 [ # # ]: 0 : if (e2 .gt. elph_tr_ds%en_all(1,tmp_nenergy)) then
1148 : : i_end = tmp_nenergy
1149 : : else
1150 : 0 : i_end = 1
1151 : 0 : diff = dabs(e2-elph_tr_ds%en_all(1,1))
1152 [ # # ]: 0 : do ie2 = 2, tmp_nenergy
1153 [ # # ]: 0 : if (dabs(e2-elph_tr_ds%en_all(1,ie2)) .lt. diff) then
1154 : 0 : diff = dabs(e2-elph_tr_ds%en_all(1,ie2))
1155 : 0 : i_end = ie2
1156 : : end if
1157 : : end do
1158 : : end if
1159 [ # # ]: 0 : do ie2 = i_start, i_end
1160 : 0 : elph_ds%n_pair = elph_ds%n_pair + 1
1161 : 0 : pair2red(ie1,ie2) = elph_ds%n_pair
1162 : : end do
1163 : : end do
1164 : :
1165 : : ! symmetrize paire2red
1166 : 0 : elph_ds%n_pair = 0
1167 [ # # ]: 0 : do ie1 = 1, tmp_nenergy
1168 [ # # ]: 0 : do ie2 = 1, tmp_nenergy
1169 [ # # # # ]: 0 : if (pair2red(ie1,ie2) .ne. 0 .or. pair2red(ie2,ie1) .ne. 0) then
1170 : 0 : elph_ds%n_pair = elph_ds%n_pair + 1
1171 : 0 : pair2red(ie1,ie2) = elph_ds%n_pair
1172 : : end if
1173 : : end do
1174 : : end do
1175 : :
1176 : 0 : write(message,'(a,i3,a)')' There are ', elph_ds%n_pair, ' energy pairs. '
1177 : 0 : call wrtout(std_out,message,'COLL')
1178 : :
1179 [ # # # # : 0 : ABI_MALLOC(red2pair,(2,elph_ds%n_pair))
# # # # #
# # # ]
1180 [ # # # # ]: 0 : red2pair = 0
1181 : 0 : elph_ds%n_pair = 0
1182 [ # # ]: 0 : do ie1 = 1, tmp_nenergy
1183 [ # # ]: 0 : do ie2 = 1, tmp_nenergy
1184 [ # # # # ]: 0 : if (pair2red(ie1,ie2) .ne. 0 .or. pair2red(ie2,ie1) .ne. 0) then
1185 : 0 : elph_ds%n_pair = elph_ds%n_pair + 1
1186 : 0 : red2pair(1,elph_ds%n_pair) = ie1
1187 : 0 : red2pair(2,elph_ds%n_pair) = ie2
1188 : : end if
1189 : : end do
1190 : : end do
1191 : :
1192 : : ! moved from integrate_gamma_tr to here
1193 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%gamma_qpt_tr,(2,9,elph_ds%nbranch**2,elph_ds%nsppol,elph_ds%nqpt_full))
# # # # #
# # # # #
# # # # #
# # # ]
1194 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%gamma_rpt_tr,(2,9,elph_ds%nbranch**2,elph_ds%nsppol,Ifc%nrpt,4,elph_ds%n_pair))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
1195 [ # # # # : 0 : elph_tr_ds%gamma_rpt_tr = zero
# # # # #
# # # #
# ]
1196 : :
1197 : 0 : s1ofssp = (/1,1,-1,-1/)
1198 : 0 : s2ofssp = (/1,-1,1,-1/)
1199 : :
1200 : : ! Get gamma
1201 [ # # # # : 0 : ABI_MALLOC(gam_qpt,(2,3*natom*3*natom,elph_ds%nqpt_full))
# # # # #
# # # # #
# # # # ]
1202 [ # # # # : 0 : ABI_MALLOC(gam_rpt,(2,3*natom*3*natom,Ifc%nrpt))
# # # # #
# # # # #
# # ]
1203 [ # # ]: 0 : do ie=1,elph_ds%n_pair
1204 : 0 : ie1 = red2pair(1,ie)
1205 : 0 : ie2 = red2pair(2,ie)
1206 : :
1207 [ # # # # ]: 0 : tmp_veloc_sq1(:,:)=elph_tr_ds%veloc_sq(:,:,ie1)
1208 [ # # # # : 0 : elph_tr_ds%tmp_gkk_intweight1(:,:,:) = elph_tr_ds%tmp_gkk_intweight(:,:,:,ie1)
# # ]
1209 [ # # # # : 0 : elph_tr_ds%tmp_velocwtk1(:,:,:,:) = elph_tr_ds%tmp_velocwtk(:,:,:,:,ie1)
# # # # ]
1210 [ # # # # : 0 : elph_tr_ds%tmp_vvelocwtk1(:,:,:,:,:) = elph_tr_ds%tmp_vvelocwtk(:,:,:,:,:,ie1)
# # # # #
# ]
1211 : :
1212 [ # # # # ]: 0 : tmp_veloc_sq2(:,:)=elph_tr_ds%veloc_sq(:,:,ie2)
1213 [ # # # # : 0 : elph_tr_ds%tmp_gkk_intweight2(:,:,:) = elph_tr_ds%tmp_gkk_intweight(:,:,:,ie2)
# # ]
1214 [ # # # # : 0 : elph_tr_ds%tmp_velocwtk2(:,:,:,:) = elph_tr_ds%tmp_velocwtk(:,:,:,:,ie2)
# # # # ]
1215 [ # # # # : 0 : elph_tr_ds%tmp_vvelocwtk2(:,:,:,:,:) = elph_tr_ds%tmp_vvelocwtk(:,:,:,:,:,ie2)
# # # # #
# ]
1216 : :
1217 [ # # ]: 0 : do ssp=1,4 ! (s,s'=+/-1, condense the indices)
1218 : 0 : s1=s1ofssp(ssp)
1219 : 0 : s2=s2ofssp(ssp)
1220 [ # # # # : 0 : elph_tr_ds%gamma_qpt_tr = zero
# # # # #
# ]
1221 : :
1222 : : call integrate_gamma_tr(elph_ds,FSfullpqtofull,s1,s2, &
1223 : 0 : & tmp_veloc_sq1,tmp_veloc_sq2,elph_tr_ds)
1224 : :
1225 : : call complete_gamma_tr(cryst,elph_ds%ep_scalprod,elph_ds%nbranch,elph_ds%nqptirred,&
1226 : 0 : & elph_ds%nqpt_full,elph_ds%nsppol,elph_tr_ds%gamma_qpt_tr,elph_ds%qirredtofull,qpttoqpt)
1227 : :
1228 : : ! Now FT to real space too
1229 : 0 : qtor = 1 ! q --> r
1230 [ # # ]: 0 : do isppol=1,elph_ds%nsppol
1231 [ # # ]: 0 : do idir=1,9
1232 [ # # # # : 0 : gam_qpt(:,:,:)=elph_tr_ds%gamma_qpt_tr(:,idir,:,isppol,:)
# # ]
1233 : : call ftgam(Ifc%wghatm,elph_tr_ds%gamma_qpt_tr(:,idir,:,isppol,:),&
1234 : : & elph_tr_ds%gamma_rpt_tr(:,idir,:,isppol,:,ssp,ie),natom,&
1235 [ # # # # : 0 : & elph_ds%nqpt_full,Ifc%nrpt,qtor,coskr, sinkr)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
1236 [ # # # # : 0 : elph_tr_ds%gamma_rpt_tr(:,idir,:,isppol,:,ssp,ie)=gam_rpt(:,:,:)
# # ]
1237 : : end do
1238 : : end do
1239 : :
1240 : : end do !ss
1241 : : end do !ie
1242 : :
1243 [ # # ]: 0 : ABI_FREE(gam_qpt)
1244 [ # # ]: 0 : ABI_FREE(gam_rpt)
1245 [ # # ]: 0 : ABI_FREE(tmp_veloc_sq1)
1246 [ # # ]: 0 : ABI_FREE(tmp_veloc_sq2)
1247 : : end if ! ifltransport
1248 : :
1249 [ - + ]: 15 : ABI_FREE(qpttoqpt)
1250 [ - + ]: 15 : ABI_FREE(FSfullpqtofull)
1251 : :
1252 : :
1253 : : !==============================================================
1254 : : !Calculate phonon linewidths, interpolating on chosen qpoints
1255 : : !==============================================================
1256 : :
1257 : 15 : call mkph_linwid(Cryst,ifc,elph_ds,anaddb_dtset%nqpath,anaddb_dtset%qpath)
1258 : :
1259 : : !==============================================================
1260 : : !the nesting factor calculation
1261 : : !FIXME: this could go higher up, before the call to get_all_gkq
1262 : : !you only need the kpt and weight info
1263 : : !==============================================================
1264 [ + + ]: 15 : if (any(anaddb_dtset%prtnest==[1,2])) then
1265 : :
1266 [ + - ]: 3 : nestname = trim(elph_ds%elph_base_name) // "_NEST"
1267 : : call mknesting(elph_ds%k_phon%nkpt,elph_ds%k_phon%kpt,elph_ds%kptrlatt,elph_ds%nFSband,&
1268 : : & elph_ds%k_phon%wtk,anaddb_dtset%nqpath,anaddb_dtset%qpath,elph_ds%nqpt_full, &
1269 : 3 : & elph_ds%qpt_full,nestname,cryst%gprimd,cryst%gmet,anaddb_dtset%prtnest,qptrlatt)
1270 : : end if
1271 : :
1272 : : !======================================================
1273 : : !Calculate alpha^2 F integrating over fine kpt_phon grid
1274 : : !======================================================
1275 : :
1276 [ - + + - : 45 : ABI_MALLOC(a2f_1d,(elph_ds%na2f))
+ - + - -
+ - + ]
1277 [ - + + - : 30 : ABI_MALLOC(dos_phon,(elph_ds%na2f))
- + - + ]
1278 : :
1279 : 15 : call mka2f(Cryst,Ifc,a2f_1d,dos_phon,elph_ds,elph_ds%kptrlatt_fine,elph_ds%mustar)
1280 : :
1281 : : !calculate transport spectral function and coefficients
1282 [ + + ]: 15 : if (elph_tr_ds%ifltransport==1 )then ! LOVA
1283 : :
1284 : 5 : call mka2f_tr_lova(cryst,ifc,elph_ds,elph_ds%ntemper,elph_ds%tempermin,elph_ds%temperinc,elph_tr_ds)
1285 : :
1286 [ - + ]: 10 : else if (elph_tr_ds%ifltransport==2 )then ! non LOVA
1287 : :
1288 : 0 : call mka2f_tr(cryst,ifc,elph_ds,elph_ds%ntemper,elph_ds%tempermin,elph_ds%temperinc,pair2red,elph_tr_ds)
1289 : :
1290 [ # # ]: 0 : ABI_FREE(pair2red)
1291 [ # # ]: 0 : ABI_FREE(red2pair)
1292 : :
1293 [ + - ]: 10 : else if (elph_tr_ds%ifltransport==3 )then ! get k-dependent tau
1294 : :
1295 : 0 : call get_tau_k(Cryst,ifc,Bst,elph_ds,elph_tr_ds,eigenGS,max_occ)
1296 : : !call trans_rta(elph_ds,elph_tr_ds,cryst%gprimd,eigenGS,max_occ,cryst%ucvol)
1297 : : end if ! ifltransport
1298 : :
1299 [ - + ]: 15 : ABI_FREE(eigenGS)
1300 [ - + ]: 15 : ABI_FREE(eigenGS_fine)
1301 : :
1302 : :
1303 : : !evaluate a2F only using the input Q-grid (without using interpolated matrices)
1304 : : !SCOPE: test the validity of the Fourier interpolation
1305 : 15 : call wrtout(std_out,' elphon : calling mka2fQgrid',"COLL")
1306 : :
1307 [ + - ]: 15 : fname=trim(elph_ds%elph_base_name) // '_A2F_QGRID'
1308 : 15 : call mka2fQgrid(elph_ds,fname)
1309 : :
1310 : : !=============================================
1311 : : !Eliashberg equation in 1-D (isotropic case)
1312 : : !=============================================
1313 : :
1314 : 15 : call eliashberg_1d(a2f_1d,elph_ds,anaddb_dtset%mustar)
1315 : :
1316 [ - + ]: 15 : ABI_FREE(a2f_1d)
1317 [ - + ]: 15 : ABI_FREE(dos_phon)
1318 : :
1319 : : !MJV: 20070805 should exit here. None of the rest is tested or used yet to my knowledge
1320 : :
1321 : : !========================================================================
1322 : : !Now gkk contains the matrix elements of dH(1)/dxi i=1,2,3
1323 : : !for kpoints on the FS but qpoints only in the given grid {Q}.
1324 : : !
1325 : : !1.) Need to complete the gkk elements for q and k\prime=k+q not
1326 : : !in the set of {k+Q} by Fourier interpolation on the Q.
1327 : : !
1328 : : !2.) Need to complete the dynamical matrices and phonon freqs for
1329 : : !all q between points on the FS.
1330 : : !
1331 : : !3.) With the eigenvectors e_ph of the dyn mats, do the scalar product
1332 : : !e_ph . gkk, which implies the gkk are turned to the eigenbasis of
1333 : : !the phonons. Before the (non eigen-) modes are ordered
1334 : : !atom1 xred1 atom1 xred2 atom1 xred3
1335 : : !atom2 xred1 atom2 xred2 atom2 xred3 ...
1336 : : !=======================================================================
1337 : :
1338 : 15 : make_gkk2=.false.
1339 : :
1340 : : if (.not. make_gkk2) then
1341 : 15 : call wrtout(std_out,' elphon : skipping full g(k,k") interpolation ',"COLL")
1342 : : else
1343 : :
1344 : : ! ==========================================================
1345 : : ! FT of recip space gkk matrices to real space (gkk_rpt)
1346 : : ! NOTE: could be made into FFT, couldnt it? If shifts are
1347 : : ! used with a homogeneous grid
1348 : : ! ==========================================================
1349 : : write (message,'(2a,i0)')ch10,&
1350 : : & ' elphon : Fourier transform (q --> r) of the gkk matrices using nrpt = ',Ifc%nrpt
1351 : : call wrtout(std_out,message,'COLL')
1352 : :
1353 : : call get_all_gkr(elph_ds,ifc%gprimd,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%gprimd, 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, nqshft_use
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 : : real(dp) :: q1shft_use(3,4)
2853 : :
2854 : : ! *********************************************************************
2855 : :
2856 : : !default is to expect a uniform grid
2857 : 15 : elph_ds%tuniformgrid = 1
2858 : :
2859 : : !if we use the normal grid way of generating the qpoints:
2860 [ + - ]: 15 : if (anaddb_dtset%qgrid_type==1) then
2861 : : ! qpoint lattice vectors (inverse, like kptrlatt), from the (brav, ngqpt, q1shft) input.
2862 : : call qmesh_from_brav_ngqpt(anaddb_dtset%brav, anaddb_dtset%ngqpt, anaddb_dtset%nqshft, anaddb_dtset%q1shft, &
2863 : 15 : & qptrlatt, nqshft_use, q1shft_use)
2864 : :
2865 [ - + ]: 15 : if (anaddb_dtset%nqshft /= 1) then
2866 : : ! try to reduce the qpoint grid to a single qshift, otherwise stop
2867 : : ! dummy args for call to getkgrid
2868 : 0 : vacuum(:) = 0
2869 : 0 : iscf = 3
2870 : :
2871 : 0 : mqpt = anaddb_dtset%ngqpt(1)*anaddb_dtset%ngqpt(2)*anaddb_dtset%ngqpt(3)*anaddb_dtset%nqshft
2872 [ # # # # : 0 : ABI_MALLOC(qpt_full,(3,mqpt))
# # # # #
# # # ]
2873 [ # # # # : 0 : ABI_MALLOC(wtq,(mqpt))
# # # # #
# # # ]
2874 [ # # ]: 0 : ABI_MALLOC(tmpshifts,(3,MAX_NSHIFTK))
2875 : :
2876 [ # # ]: 0 : wtq(:) = one
2877 : :
2878 [ # # # # ]: 0 : tmpshifts(:,:) = zero
2879 [ # # # # ]: 0 : tmpshifts(:,1:4) = anaddb_dtset%q1shft(:,:)
2880 : :
2881 : : iout=6
2882 : :
2883 : 0 : berryopt = 1
2884 : :
2885 : : ! just call with identity, to get full set of kpts in qpt_full, but
2886 : : ! reduce qshfts
2887 : :
2888 : 0 : nqshft=anaddb_dtset%nqshft
2889 : : call getkgrid(0,0,iscf,qpt_full,3,qptrlatt,qptrlen, &
2890 : : & 1,mqpt,nqpt_computed,nqshft,1,crystal%rprimd,tmpshifts,crystal%symafm, &
2891 : 0 : & crystal%symrel,vacuum,wtq)
2892 [ # # ]: 0 : ABI_FREE(qpt_full)
2893 [ # # ]: 0 : ABI_FREE(wtq)
2894 [ # # ]: 0 : ABI_FREE(tmpshifts)
2895 : :
2896 : : if (anaddb_dtset%nqshft /= 1) then
2897 : : write (message,'(a,i0)')&
2898 : 0 : & ' multiple qpt shifts not treated yet (should be possible), nqshft= ', anaddb_dtset%nqshft
2899 : 0 : ABI_ERROR(message)
2900 : : end if
2901 : : end if ! end multiple shifted qgrid
2902 : :
2903 : :
2904 : 15 : write(message,'(a,9(i0,1x))')' elphon : enter smpbz with qptrlatt = ',qptrlatt
2905 : 15 : call wrtout(std_out,message,'COLL')
2906 : :
2907 : 15 : option=1
2908 : 15 : mqpt = kptrlatt_ncells(qptrlatt, nqshft_use)
2909 [ - + + - : 45 : ABI_MALLOC(qpt_full,(3,mqpt))
+ - + - -
+ - + ]
2910 : 15 : iout = 6
2911 : 15 : call smpbz(iout,qptrlatt,mqpt,elph_ds%nqpt_full,nqshft_use,option,q1shft_use,qpt_full)
2912 : :
2913 : :
2914 : : ! save the q-grid for future reference
2915 [ - + + - : 45 : ABI_MALLOC(elph_ds%qpt_full,(3,elph_ds%nqpt_full))
+ - + - -
+ - + -
+ ]
2916 : :
2917 : : ! reduce qpt_full to correct zone
2918 [ + + ]: 135 : do iqpt=1,elph_ds%nqpt_full
2919 : 120 : call wrap2_pmhalf(qpt_full(1,iqpt),kpt(1),res)
2920 : 120 : call wrap2_pmhalf(qpt_full(2,iqpt),kpt(2),res)
2921 : 120 : call wrap2_pmhalf(qpt_full(3,iqpt),kpt(3),res)
2922 [ + + ]: 480 : qpt_full(:,iqpt) = kpt
2923 [ + + ]: 495 : elph_ds%qpt_full(:,iqpt)=kpt
2924 : : end do
2925 [ - + ]: 15 : ABI_FREE(qpt_full)
2926 : :
2927 [ # # ]: 0 : else if (anaddb_dtset%qgrid_type==2) then ! use explicit list of qpoints from anaddb input
2928 : 0 : qptrlatt(:,:)=0
2929 : 0 : qptrlatt(1,1)=1
2930 : 0 : qptrlatt(2,2)=1
2931 : 0 : qptrlatt(3,3)=1
2932 : :
2933 : 0 : elph_ds%nqpt_full=anaddb_dtset%ep_nqpt
2934 [ # # # # : 0 : ABI_MALLOC(elph_ds%qpt_full,(3,elph_ds%nqpt_full))
# # # # #
# # # #
# ]
2935 : :
2936 [ # # # # : 0 : elph_ds%qpt_full = anaddb_dtset%ep_qptlist
# # # # #
# # # # #
# # ]
2937 : :
2938 : 0 : elph_ds%tuniformgrid = 0
2939 : : end if ! type of qgrid for elphon
2940 : :
2941 : : !=================================================================
2942 : : !Calculate weights, needed to estimate lambda using the weighted
2943 : : !sum of the uninterpolated e-ph matrix elements
2944 : : !=================================================================
2945 : 15 : call wrtout(std_out,' setqgrid : calling symkpt to find irred q points',"COLL")
2946 : :
2947 [ - + + - : 45 : ABI_MALLOC(indqpt1,(elph_ds%nqpt_full))
+ - + - -
+ - + ]
2948 [ - + + - : 45 : ABI_MALLOC(wtq_folded,(elph_ds%nqpt_full))
+ - + - -
+ - + ]
2949 [ - + + - : 30 : ABI_MALLOC(wtq,(elph_ds%nqpt_full))
- + - + ]
2950 [ - + + - : 45 : ABI_MALLOC(bz2ibz_smap, (6, elph_ds%nqpt_full))
+ - + - -
+ - + ]
2951 : :
2952 [ + + ]: 135 : wtq(:) = one/dble(elph_ds%nqpt_full) !weights normalized to unity
2953 : :
2954 : : !
2955 : : !NOTE: this reduction of irred qpt may not be identical to that in GKK file
2956 : : !which would be more practical to use.
2957 : : !
2958 : 15 : iout=0 !do not write to ab_out
2959 : : !should we save indqpt1 for use inside elph_ds?
2960 : : call symkpt(0,crystal%gmet,indqpt1,iout,elph_ds%qpt_full,elph_ds%nqpt_full,nqpt1,crystal%nsym,crystal%symrec,&
2961 : 15 : & timrev,wtq,wtq_folded, bz2ibz_smap, xmpi_comm_self)
2962 : :
2963 [ - + ]: 15 : ABI_FREE(bz2ibz_smap)
2964 : :
2965 : 15 : write (message,'(2a,i0)')ch10,' Number of irreducible q-points = ',nqpt1
2966 : 15 : call wrtout(std_out,message,'COLL')
2967 : 15 : elph_ds%nqptirred=nqpt1
2968 : :
2969 : 15 : call wrtout(std_out,' === Irreducible q points with weights ==== ','COLL')
2970 : :
2971 [ + + ]: 135 : do iqpt=1,elph_ds%nqpt_full
2972 [ + + ]: 135 : if (wtq_folded(iqpt) /= zero) then
2973 : 48 : write (message,'(1x,i4,a2,4es16.8)')iqpt,') ',elph_ds%qpt_full(:,iqpt),wtq_folded(iqpt)
2974 : 48 : call wrtout(std_out,message,'COLL')
2975 : : end if
2976 : : end do
2977 : :
2978 : 15 : call wrtout(std_out,ch10,'COLL')
2979 : :
2980 [ - + + - : 45 : ABI_MALLOC(elph_ds%wtq,(elph_ds%nqpt_full))
+ - + - -
+ - + -
+ ]
2981 : :
2982 [ + + ]: 135 : elph_ds%wtq(:)=wtq_folded(:)
2983 : : !MEMO indqpt could be useful to test the qgrid read by abinit
2984 [ - + ]: 15 : ABI_FREE(indqpt1)
2985 [ - + ]: 15 : ABI_FREE(wtq_folded)
2986 [ - + ]: 15 : ABI_FREE(wtq)
2987 : :
2988 : 15 : end subroutine ep_setupqpt
2989 : : !!***
2990 : :
2991 : : !!****f* ABINIT/mkph_linwid
2992 : : !!
2993 : : !! NAME
2994 : : !! mkph_linwid
2995 : : !!
2996 : : !! FUNCTION
2997 : : !! Calculate the phonon linewidths on a trajectory in q space
2998 : : !!
2999 : : !! INPUTS
3000 : : !! Cryst<crystal_t>=Info on the unit cell and symmetries.
3001 : : !! Ifc<ifc_type>=Object containing the interatomic force constants.
3002 : : !! elph_ds = datastructure with phonon matrix elements
3003 : : !! nqpath = dimension of qpath_vertices
3004 : : !! qpath_vertices = vertices of reciprocal space trajectory
3005 : : !!
3006 : : !! OUTPUT
3007 : : !!
3008 : : !! SIDE EFFECTS
3009 : : !!
3010 : : !! SOURCE
3011 : :
3012 : 15 : subroutine mkph_linwid(Cryst,ifc,elph_ds,nqpath,qpath_vertices)
3013 : :
3014 : : !Arguments ------------------------------------
3015 : : !scalars
3016 : : integer,intent(in) :: nqpath
3017 : : type(crystal_t),intent(in) :: Cryst
3018 : : type(ifc_type),intent(in) :: ifc
3019 : : type(elph_type),intent(inout) :: elph_ds
3020 : : !arrays
3021 : : real(dp),intent(in) :: qpath_vertices(3,nqpath)
3022 : :
3023 : : !Local variables-------------------------------
3024 : : !scalars
3025 : : integer :: ibranch,natom,ii,indx,ipoint,nbranch,nqbz,nsppol,nrpt
3026 : : integer :: isppol,jbranch,qtor,unit_bs,unit_lambda,unit_lwd,npt_tot
3027 : : real(dp) :: diagerr,res
3028 : : character(len=500) :: msg
3029 : : character(len=fnlen) :: fname,base_name
3030 : : !arrays
3031 : 30 : integer :: ndiv(nqpath-1)
3032 : 15 : integer, allocatable :: indxprtqpt(:)
3033 : : complex(dp),parameter :: c0=dcmplx(0._dp,0._dp),c1=dcmplx(1._dp,0._dp)
3034 : 30 : real(dp) :: displ_cart(2,3*Cryst%natom,3*Cryst%natom)
3035 : 30 : real(dp) :: displ_red(2,3*Cryst%natom,3*Cryst%natom)
3036 : 30 : real(dp) :: eigval(3*Cryst%natom)
3037 : 30 : real(dp) :: gam_now(2,(3*Cryst%natom)**2)
3038 : 30 : real(dp) :: imeigval(3*Cryst%natom)
3039 : 30 : real(dp) :: lambda(3*Cryst%natom)
3040 : 30 : real(dp) :: pheigvec(2*3*Cryst%natom*3*Cryst%natom),phfrq_tmp(3*Cryst%natom)
3041 : : real(dp) :: qpt(3),redkpt(3)
3042 : 30 : real(dp) :: tmpgam1(2,3*Cryst%natom,3*Cryst%natom)
3043 : 30 : real(dp) :: tmpgam2(2,3*Cryst%natom,3*Cryst%natom)
3044 : 15 : real(dp), allocatable :: coskr(:,:), sinkr(:,:),finepath(:,:)
3045 : :
3046 : : ! *********************************************************************
3047 : :
3048 : : DBG_ENTER("COLL")
3049 : :
3050 : 15 : natom = Cryst%natom
3051 : 15 : nbranch = elph_ds%nbranch
3052 : 15 : nsppol = elph_ds%nsppol
3053 : 15 : base_name = elph_ds%elph_base_name
3054 : 15 : nrpt = ifc%nrpt
3055 : :
3056 : : !===================================================================
3057 : : !Definition of the q path along which ph linwid will be interpolated
3058 : : !===================================================================
3059 : 15 : call make_path(nqpath,qpath_vertices,Cryst%gmet,'G',20,ndiv,npt_tot,finepath)
3060 [ - + + - : 45 : ABI_MALLOC(indxprtqpt,(npt_tot))
+ - + - -
+ - + ]
3061 [ + + ]: 3564 : indxprtqpt = 0
3062 : :
3063 : : !==========================================================
3064 : : !Open _LWD file and write header
3065 : : !==========================================================
3066 [ + - ]: 15 : fname=trim(base_name) // '_LWD'
3067 [ - + ]: 15 : if (open_file(fname,msg,newunit=unit_lwd,status="unknown") /= 0) then
3068 : 0 : ABI_ERROR(msg)
3069 : : end if
3070 : :
3071 : 15 : write (unit_lwd,'(a)') '#'
3072 : 15 : write (unit_lwd,'(a)') '# ABINIT package : Phonon linewidth file'
3073 : 15 : write (unit_lwd,'(a)') '#'
3074 : 15 : write (unit_lwd,'(a,i10,a)') '# Phonon linewidths calculated on ',npt_tot,' points along the qpath'
3075 : 15 : write (unit_lwd,'(a)') '# Description of the Q-path :'
3076 : 15 : write (unit_lwd, '(a,i10)') '# Number of line segments = ',nqpath-1
3077 : 15 : write (unit_lwd,'(a)') '# Vertices of the Q-path and corresponding index = '
3078 : :
3079 : 15 : indx=1
3080 : 15 : indxprtqpt(1) = 1
3081 : 15 : indxprtqpt(npt_tot) = 1
3082 : :
3083 [ + + ]: 135 : do ii=1,nqpath
3084 : 120 : write (unit_lwd,'(a,3(e16.6,1x),i8)')'# ',qpath_vertices(:,ii),indx
3085 [ + + ]: 135 : if (ii<nqpath) then
3086 : 105 : indx=indx+ndiv(ii)
3087 : 105 : indxprtqpt(indx) = 1
3088 : : end if
3089 : : end do
3090 : :
3091 : 15 : write (unit_lwd,'(a)')'#'
3092 : :
3093 : : !==========================================================
3094 : : !Open _BST file and write header
3095 : : !==========================================================
3096 [ + - ]: 15 : fname=trim(base_name) // '_BST'
3097 [ - + ]: 15 : if (open_file(fname,msg,newunit=unit_bs,status="unknown") /= 0) then
3098 : 0 : ABI_ERROR(msg)
3099 : : end if
3100 : :
3101 : 15 : write (unit_bs, '(a)') '#'
3102 : 15 : write (unit_bs, '(a)') '# ABINIT package : Phonon band structure file'
3103 : 15 : write (unit_bs, '(a)') '#'
3104 : 15 : write (unit_bs, '(a,i10,a)')'# Phonon BS calculated on ', npt_tot,' points along the qpath'
3105 : 15 : write (unit_bs, '(a,i10)') '# Number of line segments = ', nqpath-1
3106 : 15 : indx=1
3107 [ + + ]: 135 : do ii=1,nqpath
3108 : 120 : write (unit_bs,'(a,3(E16.6,1x),i8)')'# ',qpath_vertices(:,ii),indx
3109 [ + + ]: 135 : if (ii<nqpath) indx=indx+ndiv(ii)
3110 : : end do
3111 : 15 : write (unit_bs,'(a)')'#'
3112 : :
3113 : : !MG20060606
3114 : : !==========================================================
3115 : : !open _LAMBDA file and write header
3116 : : !contains \omega(q,n) and \lambda(q,n) and can be plotted using xmgrace
3117 : : !==========================================================
3118 [ + - ]: 15 : fname=trim(base_name) // '_LAMBDA'
3119 [ - + ]: 15 : if (open_file(fname,msg,newunit=unit_lambda,status="unknown") /= 0) then
3120 : 0 : ABI_ERROR(msg)
3121 : : end if
3122 : :
3123 : 15 : write (unit_lambda,'(a)') '#'
3124 : 15 : write (unit_lambda,'(a)') '# ABINIT package : Lambda file'
3125 : 15 : write (unit_lambda,'(a)') '#'
3126 : 15 : write (unit_lambda,'(a,i10,a)')'# Lambda(q,nu) calculated on ',npt_tot,' Q-points'
3127 : 15 : write (unit_lambda,'(a)') '# Description of the Q-path :'
3128 : 15 : write (unit_lambda,'(a,i10)') '# Number of line segments = ',nqpath-1
3129 : 15 : write (unit_lambda,'(a)') '# Vertices of the Q-path and corresponding index = '
3130 : :
3131 : 15 : indx=1
3132 [ + + ]: 135 : do ii=1,nqpath
3133 : 120 : write (unit_lambda,'(a,3(E16.6,1x),i8)')'# ',qpath_vertices(:,ii),indx
3134 [ + + ]: 135 : if (ii<nqpath) indx=indx+ndiv(ii)
3135 : : end do
3136 : 15 : write (unit_lambda,'(a)')'#'
3137 : 15 : write (unit_lambda,'(a)')'# index frequency lambda(q,n) frequency lambda(q,n) .... lambda_tot'
3138 : 15 : write (unit_lambda,'(a)')'#'
3139 : :
3140 : : !real space to q space
3141 : 15 : qtor=0
3142 : :
3143 : : !initialize the maximum phonon frequency
3144 : 15 : elph_ds%omega_min = zero
3145 : 15 : elph_ds%omega_max = zero
3146 : :
3147 [ - + + - : 60 : ABI_MALLOC(coskr, (npt_tot,nrpt))
- + + - +
- + - - +
- + ]
3148 [ - + + - : 45 : ABI_MALLOC(sinkr, (npt_tot,nrpt))
- + + - -
+ - + ]
3149 : 15 : call ftgam_init(ifc%gprimd, npt_tot, nrpt, finepath, ifc%rpt, coskr, sinkr)
3150 : :
3151 [ + + ]: 75 : write (std_out,*) ' mkph_linwid : shape(elph_ds%gamma_qpt) = ',shape(elph_ds%gamma_qpt)
3152 : 15 : nqbz = SIZE(elph_ds%gamma_qpt,DIM=4)
3153 : 15 : write(std_out,*) " nqbz = SIZE(elph_ds%gamma_qpt,DIM=4) = ",nqbz
3154 : : !
3155 : : !Big do loop over spin polarizations
3156 : : !could put in locally, so phonon stuff is not done twice...
3157 : : !
3158 [ + + ]: 31 : do isppol=1,nsppol
3159 : 16 : indx=1
3160 : :
3161 : : ! Output to the main output file
3162 : 16 : write(msg,'(a,a)')ch10,&
3163 : 32 : & ' Output of the linewidths for the first point of each segment. Linewidths are given in Hartree.'
3164 : 16 : call wrtout(std_out,msg,'COLL')
3165 : 16 : call wrtout(ab_out,msg,'COLL')
3166 : :
3167 : 16 : write (std_out,*) ' mkph_linwid : elph_ds%ep_scalprod = ', elph_ds%ep_scalprod
3168 : :
3169 : : qtor = 0
3170 : :
3171 : : ! Interpolation along specified path in q space
3172 [ + + ]: 3781 : do ipoint=1,npt_tot
3173 : :
3174 : : ! Get qpoint along the path from qpath_vertices
3175 [ + + ]: 15060 : qpt(:) = finepath(:,ipoint)
3176 : :
3177 : 3765 : call wrap2_pmhalf(qpt(1),redkpt(1),res)
3178 : 3765 : call wrap2_pmhalf(qpt(2),redkpt(2),res)
3179 : 3765 : call wrap2_pmhalf(qpt(3),redkpt(3),res)
3180 : 3765 : qpt(:) = redkpt(:)
3181 : : !
3182 : : ! This reduced version of ftgkk supposes the kpoints have been integrated
3183 : : ! in integrate_gamma. Do FT from real-space gamma grid to 1 qpt.
3184 : : call ftgam(ifc%wghatm,gam_now,elph_ds%gamma_rpt(:,:,isppol,:),natom,1,ifc%nrpt,qtor, &
3185 [ + + + - : 617967 : & coskr(ipoint,:), sinkr(ipoint,:))
+ + + + +
+ + - + -
+ + + - +
- + + + +
+ + + + +
+ + - +
- ]
3186 : : !
3187 : : ! get phonon freqs and eigenvectors anyway
3188 : : !
3189 : 3765 : call ifc%fourq(cryst,qpt,phfrq_tmp,displ_cart,out_eigvec=pheigvec)
3190 : : !
3191 : : ! additional frequency factor for some cases
3192 : : !
3193 : : ! If the matrices do not contain the scalar product with the displ_cart vectors yet do it now
3194 [ + + ]: 3765 : if (elph_ds%ep_scalprod == 0) then
3195 : :
3196 : 2592 : call phdispl_cart2red(natom,Cryst%gprimd,displ_cart,displ_red)
3197 : :
3198 [ + + ]: 10368 : tmpgam2 = reshape (gam_now, (/2,nbranch,nbranch/))
3199 : 2592 : call gam_mult_displ(nbranch, displ_red, tmpgam2, tmpgam1)
3200 : :
3201 [ + + ]: 10368 : do jbranch=1,nbranch
3202 : 7776 : eigval(jbranch) = tmpgam1(1, jbranch, jbranch)
3203 : 7776 : imeigval(jbranch) = tmpgam1(2, jbranch, jbranch)
3204 : :
3205 [ - + ]: 10368 : if (abs(imeigval(jbranch)) > tol8) then
3206 : 0 : write (msg,'(a,i0,a,es16.8)')' imaginary values for branch = ',jbranch,' imeigval = ',imeigval(jbranch)
3207 : 0 : ABI_WARNING(msg)
3208 : : end if
3209 : : end do
3210 : :
3211 [ + - ]: 1173 : else if (elph_ds%ep_scalprod == 1) then
3212 : : !
3213 : : ! Diagonalize gamma matrix at qpoint (complex matrix).
3214 : : ! MJV NOTE: gam_now is recast implicitly here to matrix
3215 : : call ZGEMM ( 'N', 'N', 3*natom, 3*natom, 3*natom, c1, gam_now, 3*natom,&
3216 : 1173 : & pheigvec, 3*natom, c0, tmpgam1, 3*natom)
3217 : :
3218 : : call ZGEMM ( 'C', 'N', 3*natom, 3*natom, 3*natom, c1, pheigvec, 3*natom,&
3219 : 1173 : & tmpgam1, 3*natom, c0, tmpgam2, 3*natom)
3220 : :
3221 : 1173 : diagerr = zero
3222 [ + + ]: 7563 : do ibranch=1,nbranch
3223 : :
3224 : 6390 : eigval(ibranch) = tmpgam2(1,ibranch,ibranch)
3225 : :
3226 [ + + ]: 21393 : do jbranch=1,ibranch-1
3227 : 21393 : diagerr = diagerr + abs(tmpgam2(1,jbranch,ibranch))+abs(tmpgam2(2,jbranch,ibranch))
3228 : : end do
3229 [ + + ]: 21393 : do jbranch=ibranch+1,nbranch
3230 : 21393 : diagerr = diagerr + abs(tmpgam2(1,jbranch,ibranch))+abs(tmpgam2(2,jbranch,ibranch))
3231 : : end do
3232 : 7563 : diagerr = diagerr + abs(tmpgam2(2,ibranch,ibranch))
3233 : : end do
3234 : :
3235 [ + + ]: 1173 : if (diagerr > tol12) then
3236 : 1018 : write (msg,'(a,es14.6)')' Numerical error in diagonalization of gamma with phon eigenvectors: ', diagerr
3237 : 1018 : ABI_WARNING(msg)
3238 : : end if
3239 : :
3240 : : else
3241 : 0 : write (msg,'(a,i0)')' Wrong value for elph_ds%ep_scalprod = ',elph_ds%ep_scalprod
3242 : 0 : ABI_BUG(msg)
3243 : : end if ! end elph_ds%ep_scalprod if
3244 : : !
3245 : : ! ==========================================================
3246 : : ! write data to files for each q point
3247 : : ! ==========================================================
3248 : 3765 : write (unit_lwd,'(i5)', advance='no') indx
3249 [ + + ]: 17931 : do ii=1, nbranch
3250 : 17931 : write (unit_lwd,'(E16.5)',advance='no') eigval(ii)
3251 : : end do
3252 : 3765 : write (unit_lwd,*)
3253 : :
3254 : : ! only print phonon BS for isppol 1: independent of electron spins
3255 [ + + ]: 3765 : if (isppol==1) then
3256 : 3549 : write (unit_bs,'(i5)', advance='no') indx
3257 [ + + ]: 17067 : do ii=1, nbranch
3258 : 17067 : write (unit_bs,'(E16.5)',advance='no') phfrq_tmp(ii)
3259 : : end do
3260 : 3549 : write (unit_bs,*)
3261 : : end if
3262 : :
3263 : 3765 : write (unit_lambda,'(i5)', advance='no') indx
3264 [ + + ]: 17931 : do ii=1,nbranch
3265 : 14166 : lambda(ii)=zero
3266 [ + + ]: 14166 : if (abs(phfrq_tmp(ii)) > tol10) lambda(ii)=eigval(ii)/(pi*elph_ds%n0(isppol)*phfrq_tmp(ii)**2)
3267 : 17931 : write (unit_lambda,'(es16.8)',advance='no')phfrq_tmp(ii),lambda(ii)
3268 : : end do
3269 [ + + ]: 17931 : write (unit_lambda,'(es16.8)',advance='no') sum(lambda)
3270 : 3765 : write (unit_lambda,*)
3271 : :
3272 : : ! MG NOTE: I wrote a piece of code to output all these quantities using units
3273 : : ! chosen by the user, maybe in version 5.2?
3274 : : ! In this version the output of lambda(q,\nu) has been added
3275 : :
3276 : : ! Output to the main output file, for first point in segment
3277 [ + + ]: 3765 : if(indxprtqpt(ipoint)==1)then
3278 : 127 : write(msg,'(a,a,3es16.6,a,i4,a,a)')ch10,&
3279 : 127 : & ' Q point =',qpt(:),' isppol = ',isppol,ch10,&
3280 : 254 : & ' Mode number Frequency (Ha) Linewidth (Ha) Lambda(q,n)'
3281 : 127 : call wrtout(std_out,msg,'COLL')
3282 : 127 : call wrtout(ab_out,msg,'COLL')
3283 [ + + ]: 616 : do ii=1,nbranch
3284 : 489 : write(msg,'(i8,es20.6,2es16.6)' )ii,phfrq_tmp(ii),eigval(ii),lambda(ii)
3285 : 489 : call wrtout(std_out,msg,'COLL')
3286 : 616 : call wrtout(ab_out,msg,'COLL')
3287 : : end do
3288 : : end if
3289 : :
3290 : : ! find max/min phonon frequency along path chosen
3291 : : ! presumed to be representative of full BZ to within 10 percent
3292 : 3765 : elph_ds%omega_min = min(elph_ds%omega_min,1.1_dp*phfrq_tmp(1))
3293 : 3765 : elph_ds%omega_max = max(elph_ds%omega_max,1.1_dp*phfrq_tmp(nbranch))
3294 : :
3295 : 3781 : indx = indx+1
3296 : : end do ! end ipoint do
3297 : :
3298 : : ! add blank lines to output files between sppol
3299 : 16 : write(msg,'(a)' ) ''
3300 : 16 : call wrtout(unit_lwd,msg,'COLL')
3301 : 16 : call wrtout(unit_lambda,msg,'COLL')
3302 : 16 : call wrtout(std_out,msg,'COLL')
3303 : 31 : call wrtout(ab_out,msg,'COLL')
3304 : : end do ! isppol
3305 : :
3306 [ - + ]: 15 : ABI_FREE(coskr)
3307 [ - + ]: 15 : ABI_FREE(sinkr)
3308 : :
3309 : 15 : close(unit=unit_lwd)
3310 : 15 : close(unit=unit_bs)
3311 : 15 : close(unit=unit_lambda)
3312 : :
3313 [ - + ]: 15 : ABI_FREE(finepath)
3314 : 15 : ABI_FREE(indxprtqpt)
3315 : :
3316 : 15 : write(std_out,*) ' elph_linwid : omega_min, omega_max = ',elph_ds%omega_min, elph_ds%omega_max
3317 : :
3318 : : DBG_EXIT("COLL")
3319 : :
3320 : 15 : end subroutine mkph_linwid
3321 : : !!***
3322 : :
3323 : : !!****f* ABINIT/get_fs_bands
3324 : : !!
3325 : : !! NAME
3326 : : !! get_fs_bands
3327 : : !!
3328 : : !! FUNCTION
3329 : : !! This routine determines the bands which contribute to the Fermi surface
3330 : : !!
3331 : : !! INPUTS
3332 : : !! eigenGS = ground state eigenvalues
3333 : : !! hdr = header from input GS file
3334 : : !! ep_b_min, ep_b_max=A non-zero value is used to impose certain bands.
3335 : : !! fermie=Fermi level.
3336 : : !! eigenGS(hdr%nband(1),hdr%nkpt,hdr%nsppol)=Energies.
3337 : : !!
3338 : : !! OUTPUT
3339 : : !! minFSband,maxFSband=Minimun and maximum index for the bands that cross the Fermi level
3340 : : !! nkptirr=Number of irreducible points for which there exist at least one band that crosses the Fermi level.
3341 : : !!
3342 : : !! TODO
3343 : : !! 1) Indeces and dimensions should should be spin dependent.
3344 : : !! 2) In the present status of the code, all the k-points in the IBZ are used!
3345 : : !!
3346 : : !! SOURCE
3347 : :
3348 : 15 : subroutine get_fs_bands(eigenGS,hdr,fermie,ep_b_min,ep_b_max,minFSband,maxFSband,nkptirr)
3349 : :
3350 : : !Arguments ------------------------------------
3351 : : !scalars
3352 : : integer, intent(in) :: ep_b_min, ep_b_max
3353 : : integer,intent(out) :: minFSband,maxFSband,nkptirr
3354 : : real(dp),intent(in) :: fermie
3355 : : type(hdr_type),intent(in) :: hdr
3356 : : !arrays
3357 : : real(dp),intent(in) :: eigenGS(hdr%nband(1),hdr%nkpt,hdr%nsppol)
3358 : :
3359 : : !Local variables-------------------------------
3360 : : !scalars
3361 : : integer :: iband,ikpt,isppol,nband
3362 : : real(dp) :: epsFS,gausstol,gaussig
3363 : : character(len=500) :: message
3364 : 30 : integer :: kpt_phonflag(hdr%nkpt)
3365 : : ! *************************************************************************
3366 : :
3367 : : !supposes nband is equal for all kpts
3368 : 15 : nband = hdr%nband(1)
3369 : :
3370 : : !gausstol = minimum weight value for integration weights on FS
3371 : : !should be set to reproduce DOS at Ef (Ref. PRB 34, 5065 [[cite:Lam1986]] p. 5067)
3372 : 15 : gausstol = 1.0d-10
3373 : :
3374 : : !use same band indices in both spin channels
3375 : 15 : maxFSband=1
3376 : 15 : minFSband=nband
3377 : :
3378 : : !window of states around fermi Energy is contained in +/- epsFS
3379 : : !should be adjusted to take into account a minimal but sufficient
3380 : : !fraction of the kpoints: see the loop below.
3381 : : !The 1000 is purely empirical!!!
3382 : : !Should also take into account the density of kpoints.
3383 : : !gaussig = width of gaussian energy window around fermi energy
3384 : : !needed to get a good fraction of kpoints contributing to the FS
3385 : :
3386 [ + + + + : 29166 : gaussig = (maxval(eigenGS)-minval(eigenGS))/1000.0_dp
+ + + + +
- - + - -
+ + + + +
+ + + + -
- + - - ]
3387 : :
3388 : 15 : write (message,'(a,f11.8,2a)')' get_fs_bands : initial energy window = ',gaussig,ch10,&
3389 : 30 : & ' The window energy will be increased until the full k-grid is inside the range'
3390 : 15 : call wrtout(std_out,message,'COLL')
3391 : :
3392 : : !NOTE: could loop back to here and change gaussig until we have
3393 : : !a certain fraction of the kpoints in the FS region...
3394 : 15 : nkptirr = 0
3395 : :
3396 : : !Do not use restricted fermi surface: include all kpts -> one
3397 [ + + ]: 1155 : do while (nkptirr < hdr%nkpt)
3398 : 1140 : gaussig = gaussig*1.05_dp
3399 : :
3400 : : ! we must take into account kpoints with states within epsFS:
3401 : 1140 : epsFS = gaussig*sqrt(log(one/(gaussig*sqrt(pi)*gausstol)))
3402 : :
3403 : : ! check if there are eigenvalues close to the Fermi surface
3404 : : ! (less than epsFS from it)
3405 [ + + ]: 106564 : kpt_phonflag(:) = 0
3406 : :
3407 : : ! do for each sppol channel
3408 [ + + ]: 2308 : do isppol=1,hdr%nsppol
3409 [ + + ]: 107956 : do ikpt=1,hdr%nkpt
3410 [ + + ]: 1162848 : do iband=1,nband
3411 [ + + ]: 1161680 : if (abs(eigenGS(iband,ikpt,isppol) - fermie) < epsFS) then
3412 : 135941 : kpt_phonflag(ikpt) = 1
3413 [ + + ]: 135941 : if (iband > maxFSband) maxFSband = iband
3414 [ + + ]: 135941 : if (iband < minFSband) minFSband = iband
3415 : : end if
3416 : : end do
3417 : : end do
3418 : : end do ! isppol
3419 : :
3420 : : ! if user imposed certain bands for e-p, make sure they are kept
3421 [ + + - + ]: 1140 : if (ep_b_min /= 0 .and. ep_b_min < minFSband) then
3422 : 0 : minFSband = ep_b_min
3423 : : end if
3424 [ + + + + ]: 1140 : if (ep_b_max /= 0 .and. ep_b_max > maxFSband) then
3425 : 1 : maxFSband = ep_b_max
3426 : : end if
3427 : :
3428 : : ! number of irreducible kpoints (by all sym) contributing to the Fermi surface (to be completed by symops).
3429 [ + + ]: 106579 : nkptirr = sum(kpt_phonflag(:))
3430 : : end do
3431 : :
3432 : 15 : write(std_out,*) ' Energy window around Fermi level= ',epsFS,' nkptirr= ',nkptirr
3433 : :
3434 : 15 : end subroutine get_fs_bands
3435 : : !!***
3436 : :
3437 : : !!****f* ABINIT/get_all_gkk2
3438 : : !! NAME
3439 : : !! get_all_gkk2
3440 : : !!
3441 : : !! FUNCTION
3442 : : !! This routine determines where to store gkk2 matrix elements (disk or RAM)
3443 : : !! and calls interpolate_gkk to calculate them.
3444 : : !! This is the most time consuming step.
3445 : : !!
3446 : : !! INPUTS
3447 : : !! acell = lengths of unit cell vectors
3448 : : !! amu = masses of atoms
3449 : : !! atmfrc = atomic force constants
3450 : : !! dielt = dielectric tensor
3451 : : !! dipdip = dipole-dipole contribution flag
3452 : : !! dyewq0 =
3453 : : !! elph_ds = datastructure for elphon data and dimensions
3454 : : !! kptirr_phon = irreducible set of fermi-surface kpoints
3455 : : !! kpt_phon = full set of fermi-surface kpoints
3456 : : !! ftwghtgkk = weights for FT of matrix elements
3457 : : !! gmet = metric in reciprocal space
3458 : : !! indsym = indirect mapping of atoms under symops
3459 : : !! mpert = maximum number of perturbations
3460 : : !! msym = maximum number of symmetries (usually nsym)
3461 : : !! nsym = number of symmetries
3462 : : !! ntypat = number of types of atoms
3463 : : !! onegkksize = size of one gkk record, in bytes
3464 : : !! rmet = real-space metric
3465 : : !! rprim = unit cell lattice vectors (dimensionless)
3466 : : !! rprimd = real-space unit-cell lattice vectors
3467 : : !! rpt = points in real space for FT, in canonical coordinates
3468 : : !! symrel = symmetry operations in reduced real space
3469 : : !! trans = Atomic translations : xred = rcan + trans
3470 : : !! typat = array of types of atoms
3471 : : !! ucvol = unit cell volume
3472 : : !! xred = reduced coordinates of atoms
3473 : : !! zeff = Born effective charges
3474 : : !!
3475 : : !! OUTPUT
3476 : : !! elph_ds = calculated |gkk|^2 are in elph_ds%gkk2
3477 : : !!
3478 : : !! SOURCE
3479 : :
3480 : : subroutine get_all_gkk2(crystal,ifc,elph_ds,kptirr_phon,kpt_phon)
3481 : :
3482 : : !Arguments ------------------------------------
3483 : : !scalars
3484 : : type(crystal_t),intent(in) :: crystal
3485 : : type(ifc_type),intent(in) :: ifc
3486 : : type(elph_type),intent(inout) :: elph_ds
3487 : : !arrays
3488 : : real(dp),intent(in) :: kpt_phon(3,elph_ds%k_phon%nkpt)
3489 : : real(dp),intent(in) :: kptirr_phon(3,elph_ds%k_phon%nkptirr)
3490 : :
3491 : : !Local variables-------------------------------
3492 : : !scalars
3493 : : integer :: iost,onediaggkksize,sz1,sz2,sz3,sz4
3494 : : real(dp) :: realdp_ex
3495 : : !character(len=500) :: msg
3496 : : ! *************************************************************************
3497 : :
3498 : : if (elph_ds%nsppol /= 1) then
3499 : : ABI_ERROR('get_all_gkk2: nsppol>1 not coded yet!')
3500 : : end if
3501 : :
3502 : : onediaggkksize = elph_ds%nbranch*elph_ds%k_phon%nkpt*kind(realdp_ex)
3503 : :
3504 : : elph_ds%unit_gkk2 = 37
3505 : : if (elph_ds%gkk2write == 0) then
3506 : : write(std_out,*) 'get_all_gkk2 : keep gkk2 in memory. Size = ',&
3507 : : & 4.0*dble(elph_ds%k_phon%nkpt)*dble(onediaggkksize)/&
3508 : : & 1024.0_dp/1024.0_dp, " Mb"
3509 : : sz1=elph_ds%nbranch
3510 : : sz2=elph_ds%ngkkband
3511 : : sz3=elph_ds%ngkkband
3512 : : sz4=elph_ds%k_phon%nkpt
3513 : : ABI_MALLOC(elph_ds%gkk2,(sz1,sz2,sz3,sz4,elph_ds%k_phon%nkpt,1))
3514 : : elph_ds%gkk2(:,:,:,:,:,:) = zero
3515 : :
3516 : : else if (elph_ds%gkk2write == 1) then
3517 : : write(std_out,*) 'get_all_gkk2 : About to open gkk2 file : '
3518 : : write(std_out,*) elph_ds%unit_gkk2,onediaggkksize
3519 : : open (unit=elph_ds%unit_gkk2,file='gkk2file',access='direct',&
3520 : : & recl=onediaggkksize,form='unformatted',status='new',iostat=iost)
3521 : : if (iost /= 0) then
3522 : : ABI_ERROR('error opening gkk2file as new')
3523 : : end if
3524 : : ! rewind (elph_ds%unit_gkk2)
3525 : : write(std_out,*) 'get_all_gkk2 : disk file with gkk^2 created'
3526 : : write(std_out,*) ' calculate from real space gkk and phonon modes'
3527 : : write(std_out,*) ' gkk2write = 1 is forced: can take a lot of time! '
3528 : : write(std_out,*) ' size = ', 4.0*dble(onediaggkksize)*dble(elph_ds%k_phon%nkpt)/&
3529 : : & 1024.0_dp/1024.0_dp, ' Mb'
3530 : : else
3531 : : ABI_ERROR('bad value of gkk2write')
3532 : : end if
3533 : :
3534 : : !here do the actual calculation of |g_kk|^2
3535 : : ABI_ERROR("MGNOTE: interpolate_gkk is broken")
3536 : : ABI_UNUSED(kptirr_phon(1,1))
3537 : : call interpolate_gkk (crystal,ifc,elph_ds,kpt_phon)
3538 : :
3539 : : !MG: This was the old coding in version 7.6.2:
3540 : :
3541 : : ! call interpolate_gkk (elph_ds,kptirr_phon,kpt_phon,natom,nrpt,phon_ds,rcan,wghatm)
3542 : : !
3543 : : ! and interpolate_gkk had the prototype:
3544 : : !
3545 : : !subroutine interpolate_gkk(elph_ds,kpt_phon,gprim,natom,nrpt,phon_ds,rpt,wghatm)
3546 : :
3547 : : ! hence we were associating kpt_phon to gprim!
3548 : :
3549 : : end subroutine get_all_gkk2
3550 : : !!***
3551 : :
3552 : : !!****f* ABINIT/interpolate_gkk
3553 : : !! NAME
3554 : : !! interpolate_gkk
3555 : : !!
3556 : : !! FUNCTION
3557 : : !! This routine interpolates the gkk matrices for all q vectors
3558 : : !! between points on the full kpt_phon grid.
3559 : : !!
3560 : : !! INPUTS
3561 : : !! elph_ds = elphon datastructure with data and dimensions
3562 : : !! kpt_phon = coordinates of all kpoints close to the FS
3563 : : !!
3564 : : !! OUTPUT
3565 : : !! elph_ds = modified gkq
3566 : : !!
3567 : : !! NOTES
3568 : : !! inspired to some extent by epcouple.f from the DecAFT package by J. Kay Dewhurst
3569 : : !! most inputs taken from mkifc.f
3570 : : !! in anaddb set ifcflag 1 such that the IFC are calculated in atmfrc prior to calling elphon
3571 : : !!
3572 : : !! SOURCE
3573 : :
3574 : : subroutine interpolate_gkk(crystal,ifc,elph_ds,kpt_phon)
3575 : :
3576 : : !Arguments ------------------------------------
3577 : : !scalars
3578 : : type(crystal_t),intent(in) :: crystal
3579 : : type(ifc_type),intent(in) :: ifc
3580 : : type(elph_type),intent(inout) :: elph_ds
3581 : : !arrays
3582 : : real(dp),intent(in) :: kpt_phon(3,elph_ds%k_phon%nkpt)
3583 : :
3584 : : !Local variables-------------------------------
3585 : : ! output variables for dfpt_phfrq
3586 : : ! variables for zhpev
3587 : : ! variables for phonon interpolation
3588 : : !scalars
3589 : : integer :: i1,i2,ikpt_phon2,iFSqpt,ib1,ib2,ier,ii
3590 : : integer :: iost,isppol,qtor,natom
3591 : : integer :: sz1,sz2,sz3,sz4,unit_gkkp
3592 : : real(dp) :: qphnrm,res
3593 : : !character(len=500) :: msg
3594 : : !arrays
3595 : : real(dp) :: gprim(3,3)
3596 : : real(dp) :: displ(2,elph_ds%nbranch,elph_ds%nbranch),eigval(3*crystal%natom)
3597 : : real(dp) :: eigvec(3*3*crystal%natom*3*crystal%natom)
3598 : : real(dp) :: pheigvec(2*elph_ds%nbranch*elph_ds%nbranch)
3599 : : real(dp) :: phfrq_tmp(elph_ds%nbranch),qphon(3),redkpt(3)
3600 : : real(dp),allocatable :: gkk2_diag_tmp(:,:,:,:),gkk2_tmp(:,:,:,:,:,:,:), matrx(:,:),zhpev1(:,:), zhpev2(:)
3601 : : ! *************************************************************************
3602 : :
3603 : : !NOTE: mjv 18/5/2008 reverted to old style of ftgkk with all kpt done together.
3604 : : !may want to modify this later to use the new cleaner format with 1 FT at a
3605 : : !time.
3606 : : !
3607 : : write(std_out,*) 'interpolate_gkk : enter'
3608 : :
3609 : : natom = crystal%natom
3610 : : gprim = ifc%gprimd
3611 : :
3612 : : if (elph_ds%nsppol /= 1) then
3613 : : ABI_ERROR("interpolate_gkk not coded with nsppol>1 yet")
3614 : : end if
3615 : : isppol = 1
3616 : :
3617 : :
3618 : : !------------------------------------------------------
3619 : : !complete dynamical matrices for all qpts between points
3620 : : !on full kpt grid (interpolation from IFC)
3621 : : !------------------------------------------------------
3622 : :
3623 : : sz1=elph_ds%ngkkband;sz2=elph_ds%nbranch
3624 : : sz3=elph_ds%k_phon%nkpt;sz4=elph_ds%nFSband
3625 : : !allocate (gkk_tmp(2,sz1,sz1,sz2,sz2,1,1))
3626 : : !DEBUG
3627 : : !allocate (gkk_tmp_full(2,sz1,sz1,sz2,elph_ds%nFSband,sz3))
3628 : : !allocate (gkk_tmp_full(2,s2,sz4,sz4,sz3))
3629 : : !ENDDEBUG
3630 : : ABI_MALLOC(gkk2_tmp,(2,sz1,sz1,sz2,sz2,sz3,1))
3631 : : ABI_MALLOC(gkk2_diag_tmp,(sz1,sz1,sz2,sz3))
3632 : : ABI_MALLOC(zhpev1,(2,2*3*natom-1))
3633 : : ABI_MALLOC(zhpev2,(3*3*natom-2))
3634 : : ABI_MALLOC(matrx,(2,(3*natom*(3*natom+1))/2))
3635 : :
3636 : : qphnrm = one
3637 : : !in this part use the inverse Fourier transform to get 1 (arbitrary) qpt at a
3638 : : !time
3639 : : ii = 0
3640 : : qtor = 0
3641 : : unit_gkkp = 150
3642 : : open (unit=unit_gkkp,file='gkkp_file_ascii',form='formatted',status='unknown',iostat=iost)
3643 : : if (iost /= 0) then
3644 : : ABI_ERROR("error opening gkkpfile as new")
3645 : : end if
3646 : :
3647 : : !loop over all FS pairs.
3648 : : !do ikpt1=1,elph_ds%k_phon%nkptirr
3649 : : !do iFSqpt=1,elph_ds%k_phon%nkpt
3650 : :
3651 : : !
3652 : : !this should run through the sparse mesh of 2x2x2 kpoints
3653 : : !
3654 : : do iFSqpt=1,elph_ds%k_phon%nkpt
3655 : : res = 2.0_dp*(kpt_phon(1,iFSqpt)+one)
3656 : : if (abs(res-int(res)) > tol10) cycle
3657 : : res = 2.0_dp*(kpt_phon(2,iFSqpt)+one)
3658 : : if (abs(res-int(res)) > tol10) cycle
3659 : : res = 2.0_dp*(kpt_phon(3,iFSqpt)+one)
3660 : : if (abs(res-int(res)) > tol10) cycle
3661 : :
3662 : : ! do ikpt1=1,1
3663 : : !
3664 : : ! NOTE: should be very easy to parallelize!
3665 : : !
3666 : : ! write(std_out,*) ' interpolate_gkk : ikpt1 = ',ikpt1, ' / ', elph_ds%k_phon%nkptirr
3667 : : write(std_out,*) ' interpolate_gkk : ikpt1 = ',iFSqpt, ' / ', elph_ds%k_phon%nkpt
3668 : :
3669 : : ! DEBUG
3670 : : ! write(std_out,*) ' interpolate_gkk : Warning debug version'
3671 : : ! cycle
3672 : : ! ENDDEBUG
3673 : :
3674 : : gkk2_tmp(:,:,:,:,:,:,:) = zero
3675 : :
3676 : : ! qphon = 1 - 2 ie. 1 = 2+qphon
3677 : : qphon(:) = kpt_phon(:,iFSqpt)
3678 : :
3679 : : ! shouldnt be necessary here, but oh well
3680 : : call wrap2_pmhalf(qphon(1),redkpt(1),res)
3681 : : call wrap2_pmhalf(qphon(2),redkpt(2),res)
3682 : : call wrap2_pmhalf(qphon(3),redkpt(3),res)
3683 : :
3684 : : qphon(:) = redkpt(:)
3685 : : redkpt(1) = qphon(1)*gprim(1,1)+qphon(2)*gprim(1,2)+qphon(3)*gprim(1,3)
3686 : : redkpt(2) = qphon(1)*gprim(2,1)+qphon(2)*gprim(2,2)+qphon(3)*gprim(2,3)
3687 : : redkpt(3) = qphon(1)*gprim(3,1)+qphon(2)*gprim(3,2)+qphon(3)*gprim(3,3)
3688 : : write (unit_gkkp,*) 'qp= ', redkpt
3689 : :
3690 : : call ifc%fourq(crystal,qphon,phfrq_tmp,displ,out_eigvec=pheigvec)
3691 : : write (unit_gkkp,*) phfrq_tmp(:)*Ha_cmm1
3692 : :
3693 : : ii = ii+1
3694 : : ! if(ii > 0 .and. ii < 1000) write(std_out,'(a,i5,3E16.6,2x)') &
3695 : : ! & ' wrote phfrq_tmp for time ', ii, phfrq_tmp
3696 : : ! end if
3697 : :
3698 : : ! phonon eigenvectors are in eigvec
3699 : : ! real and imaginary parts
3700 : : ! phonon displacements = eigvec/sqrt(M_i) are in displ
3701 : : ! real and imaginary parts
3702 : :
3703 : : ! DEBUG
3704 : : ! test: uniform phonon frequency
3705 : : ! phfrq_tmp(:) = 0.0001_dp
3706 : : ! ENDDEBUG
3707 : :
3708 : : ! FT gamma matrices for all kpt_phon points, and
3709 : : ! for qpoint = qphon(:) = kpt_phon(ikpt_phon)
3710 : :
3711 : : call ftgkk(ifc%wghatm,gkk2_tmp,elph_ds%gkk_rpt,elph_ds%gkqwrite,&
3712 : : & elph_ds%gkk_rptwrite,gprim,1,&
3713 : : & natom,elph_ds%k_phon%nkpt,elph_ds%ngkkband,elph_ds%k_phon%nkpt,1,ifc%nrpt,elph_ds%nsppol,&
3714 : : & qtor,ifc%rpt,qphon,elph_ds%unit_gkk_rpt,elph_ds%unitgkq)
3715 : :
3716 : : ! NOTE: Normally the eigenvectors of the gkk2_tmp should be the same as eigvec
3717 : :
3718 : : ! Diagonalize gamma matrices at qpoint (complex matrix) for all kpt_phon.
3719 : : ! Copied from dfpt_phfrq
3720 : : do ikpt_phon2=1,elph_ds%k_phon%nkpt
3721 : : res = 8.0_dp*(kpt_phon(1,ikpt_phon2)+one)
3722 : : if (abs(res-int(res)) > tol10) cycle
3723 : : res = 8.0_dp*(kpt_phon(2,ikpt_phon2)+one)
3724 : : if (abs(res-int(res)) > tol10) cycle
3725 : : res = 8.0_dp*(kpt_phon(3,ikpt_phon2)+one)
3726 : : if (abs(res-int(res)) > tol10) cycle
3727 : :
3728 : : write (unit_gkkp,*) 'kp= ', kpt_phon(:,ikpt_phon2)
3729 : :
3730 : : do ib1=1,elph_ds%ngkkband
3731 : : do ib2=1,elph_ds%ngkkband
3732 : : ier=0
3733 : : ii=1
3734 : : do i2=1,3*natom
3735 : : do i1=1,i2
3736 : : matrx(1,ii)=gkk2_tmp(1,ib1,ib2,i1,i2,ikpt_phon2,1)
3737 : : matrx(2,ii)=gkk2_tmp(2,ib1,ib2,i1,i2,ikpt_phon2,1)
3738 : : ii=ii+1
3739 : : end do
3740 : : end do
3741 : : call ZHPEV ('N','U',3*natom,matrx,eigval,eigvec,3*natom,zhpev1,&
3742 : : & zhpev2,ier)
3743 : :
3744 : : gkk2_diag_tmp(ib2,ib1,:,ikpt_phon2) = eigval(:)
3745 : : do i1=1,3*natom
3746 : : write (unit_gkkp,*) elph_ds%minFSband-1+ib1,elph_ds%minFSband-1+ib2,i1,&
3747 : : & eigval(i1)
3748 : : end do
3749 : : end do
3750 : : end do
3751 : : end do
3752 : :
3753 : : if (elph_ds%gkk2write == 1) then
3754 : : write(std_out,*) 'WARNING COMMENTED WRITE TO BINARY FILE!!!'
3755 : : ! write (elph_ds%unit_gkk2,REC=iFSqpt) gkk2_diag_tmp(:,:,:,:)
3756 : : write(std_out,'(a,i4,4(2E16.6,2x))') ' gkk2 loop ', &
3757 : : & iFSqpt,gkk2_diag_tmp(1,1,:,1:2),gkk2_diag_tmp(1,1,:,elph_ds%k_phon%nkpt-1:elph_ds%k_phon%nkpt)
3758 : : ! & ikpt1,gkk2_tmp(:,1,1,1,1,1:2),gkk2_tmp(:,1,1,elph_ds%k_phon%nkpt-1:elph_ds%k_phon%nkpt)
3759 : : else if (elph_ds%gkk2write == 0) then
3760 : : elph_ds%gkk2(:,:,:,:,iFSqpt,isppol) = gkk2_diag_tmp(:,:,:,:)
3761 : : ! elph_ds%gkk2(:,:,:,:,ikpt1) = gkk2_tmp
3762 : : write(std_out,*) ' interpolate_gkk : gkk2(b=1,b=1,:,kpt=1,iFSqpt) = '
3763 : : write(std_out,*) gkk2_diag_tmp(1,1,:,1)
3764 : : end if
3765 : :
3766 : : end do
3767 : : !end do on iFSqpt
3768 : :
3769 : : ABI_FREE(matrx)
3770 : : ABI_FREE(zhpev1)
3771 : : ABI_FREE(zhpev2)
3772 : :
3773 : : end subroutine interpolate_gkk
3774 : : !!***
3775 : :
3776 : : !!****f* ABINIT/get_all_gkq
3777 : : !!
3778 : : !! NAME
3779 : : !! get_all_gkq
3780 : : !!
3781 : : !! FUNCTION
3782 : : !! This routine determines what to do with the initial qspace
3783 : : !! matrix elements of the electron phonon coupling (to disk or in memory),
3784 : : !! then reads those given in the gkk file and completes them
3785 : : !! (for kpts, then perturbations)
3786 : : !! 01/2010: removed completion on qpoints here (MJV)
3787 : : !!
3788 : : !! INPUTS
3789 : : !! elph_ds = elphon datastructure with data and dimensions
3790 : : !! Cryst<crystal_t>=Info on the unit cell and on its symmetries.
3791 : : !! Ifc<ifc_type>=Object containing the interatomic force constants.
3792 : : !! Bst<ebands_t>=GS energies, occupancies and Fermi level.
3793 : : !! FSfullpqtofull = mapping of k+q to another k
3794 : : !! kphon_full2full = mapping of FS kpoints under symops
3795 : : !! kpt_phon = fermi surface kpoints
3796 : : !! %k_phon%wtk = integration weights for bands and kpoints near the FS
3797 : : !! gkk_flag = flag to
3798 : : !! nband = number of bands
3799 : : !! n1wf = number of file headers from perturbation calculations
3800 : : !! which are present in the initial gkk input file.
3801 : : !! onegkksize = size of one record of the new gkk output file, in bytes
3802 : : !! qpttoqpt = mapping of qpoints onto each other under symmetries
3803 : : !! unitgkk = fortran unit for initial gkk input file
3804 : : !! xred = reduced coordinates of atoms
3805 : : !!
3806 : : !! OUTPUT
3807 : : !! elph_ds%gkq = recip space elphon matrix elements.
3808 : : !!
3809 : : !! SOURCE
3810 : :
3811 : 15 : subroutine get_all_gkq (elph_ds,Cryst,ifc,Bst,FSfullpqtofull,nband,n1wf,onegkksize,&
3812 : 15 : & qpttoqpt,ep_prt_yambo,unitgkk,ifltransport)
3813 : :
3814 : : !Arguments ------------------------------------
3815 : : !scalars
3816 : : integer,intent(in) :: n1wf,nband,onegkksize,unitgkk,ep_prt_yambo,ifltransport
3817 : : type(crystal_t),intent(in) :: Cryst
3818 : : type(ifc_type),intent(in) :: ifc
3819 : : type(ebands_t),intent(in) :: Bst
3820 : : type(elph_type),intent(inout) :: elph_ds
3821 : : !arrays
3822 : : integer,intent(in) :: FSfullpqtofull(elph_ds%k_phon%nkpt,elph_ds%nqpt_full)
3823 : : integer,intent(in) :: qpttoqpt(2,Cryst%nsym,elph_ds%nqpt_full)
3824 : :
3825 : : !Local variables-------------------------------
3826 : : !scalars
3827 : : integer :: iost,ierr,me,sz2,sz3,sz4,sz5,sz6
3828 : : character(len=10) :: procnum
3829 : : character(len=500) :: message
3830 : : character(len=fnlen) :: fname
3831 : : !arrays
3832 : 15 : integer,allocatable :: gkk_flag(:,:,:,:,:)
3833 : : ! *************************************************************************
3834 : :
3835 : : !attribute file unit number
3836 : 15 : elph_ds%unitgkq = get_unit()
3837 : :
3838 : : !============================================
3839 : : !save gkk for all qpts in memory or to disk
3840 : : !============================================
3841 : :
3842 : : !DEBUG
3843 : : !write(std_out,*) ' 4 bytes / ??'
3844 : : !write(std_out,*) ' kind(real) = ', kind(one)
3845 : : !write(std_out,*) ' elph_ds%ngkkband = ', elph_ds%ngkkband, '^2'
3846 : : !write(std_out,*) ' elph_ds%nbranch = ', elph_ds%nbranch, '^2'
3847 : : !write(std_out,*) ' elph_ds%k_phon%nkpt = ', elph_ds%k_phon%nkpt
3848 : : !write(std_out,*) ' elph_ds%nsppol = ', elph_ds%nsppol
3849 : : !write(std_out,*) ' elph_ds%nqptirred ', elph_ds%nqptirred
3850 : : !ENDDEBUG
3851 : :
3852 : : write(message,'(a,f14.4,a)')&
3853 : 15 : & ' get_all_gkq : gkq file/array size = ',&
3854 : 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'
3855 : 15 : call wrtout(std_out,message,'COLL')
3856 : :
3857 [ + + ]: 15 : if (elph_ds%gkqwrite == 0) then !calculate gkk(q) keeping all in memory
3858 : :
3859 : 14 : call wrtout(std_out,' get_all_gkq : keep gkk(q) in memory ','COLL')
3860 : :
3861 : 14 : sz2=elph_ds%ngkkband*elph_ds%ngkkband
3862 : 14 : sz3=elph_ds%nbranch*elph_ds%nbranch
3863 : 14 : sz4=elph_ds%k_phon%my_nkpt
3864 : 14 : sz5=elph_ds%nsppol
3865 [ - + ]: 14 : if (ifltransport == 3) then
3866 : 0 : sz6=elph_ds%nqpt_full
3867 : : else
3868 : 14 : sz6=elph_ds%nqptirred
3869 : : end if
3870 [ - + + - : 98 : ABI_MALLOC_OR_DIE(elph_ds%gkk_qpt,(2,sz2,sz3,sz4,sz5,sz6), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - + - -
+ + - -
+ ]
3871 : :
3872 [ + + + + : 4588187 : elph_ds%gkk_qpt = zero
+ + + + +
+ + + ]
3873 : :
3874 [ + - ]: 1 : else if (elph_ds%gkqwrite == 1) then !calculate gkk(q) and write to file
3875 : 1 : me = xmpi_comm_rank(xmpi_world)
3876 : 1 : call int2char4(me,procnum)
3877 [ - + ]: 1 : ABI_CHECK((procnum(1:1)/='#'),'Bug: string length too short!')
3878 [ + - ]: 1 : fname=trim(elph_ds%elph_base_name) // "_P" // trim(procnum) // '_GKKQ'
3879 : :
3880 : : iost=open_file(file=fname,iomsg=message,newunit=elph_ds%unitgkq,access='direct',&
3881 : 1 : & recl=onegkksize,form='unformatted')
3882 [ - + ]: 1 : if (iost /= 0) then
3883 : 0 : write (message,'(2a)')' get_all_gkq : ERROR- opening file ',trim(fname)
3884 : 0 : ABI_ERROR(message)
3885 : : end if
3886 : :
3887 : : write (message,'(5a)')&
3888 : 1 : & ' get_all_gkq : gkq matrix elements will be written to file : ',trim(fname),ch10,&
3889 : 2 : & ' Nothing is in files yet',ch10
3890 : 1 : call wrtout(std_out,message,'COLL')
3891 : :
3892 : : else
3893 : 0 : write(message,'(a,i0)')' gkqwrite must be 0 or 1 while it is : ',elph_ds%gkqwrite
3894 : 0 : ABI_BUG(message)
3895 : : end if !if gkqwrite
3896 : :
3897 : : !=====================================================
3898 : : !read in g_kk matrix elements for all bands, kpoints,
3899 : : !and calculated qpoints
3900 : : !=====================================================
3901 : 15 : call wrtout(std_out,' get_all_gkq : calling read_gkk to read in the g_kk matrix elements',"COLL")
3902 : :
3903 : 15 : sz2=elph_ds%nbranch;sz3=elph_ds%k_phon%my_nkpt
3904 : 15 : sz4=elph_ds%nsppol;sz5=elph_ds%nqpt_full
3905 [ - + + - : 105 : ABI_MALLOC_OR_DIE(gkk_flag,(sz2,sz2,sz3,sz4,sz5), ierr)
- + + - -
+ + - - +
+ - - + +
- + - + -
+ - - + -
+ ]
3906 : :
3907 : 15 : call read_gkk(elph_ds,Cryst,ifc,Bst,FSfullpqtofull,gkk_flag,n1wf,nband,ep_prt_yambo,unitgkk)
3908 : :
3909 : : !if (elph_ds%symgkq ==1) then
3910 : : !MJV 01/2010 removed the completion on qpt here: it should be done after FS integration
3911 : : !so that everything is lighter in memory etc... (only irred qpt)
3912 : : ! if (0==1) then
3913 [ - + ]: 15 : if (ifltransport == 3) then ! bxu, complete gkk is necessary
3914 : :
3915 : : ! ==============================================================
3916 : : ! complete gkk matrices for other qpoints on the full grid qpt_full
3917 : : ! inspired and cannibalized from symdm9.f
3918 : : ! FIXME: should add the possibility to copy over to other qpoints,
3919 : : ! without full symmetrization, for testing purposes.
3920 : : ! ==============================================================
3921 : :
3922 : 0 : write(message,'(4a)')ch10,&
3923 : 0 : & ' get_all_gkq : calling complete_gkk to complete ',ch10,&
3924 : 0 : & ' gkk matrices for other qpoints on the full grid'
3925 : 0 : call wrtout(std_out,message,'COLL')
3926 : :
3927 : : call complete_gkk(elph_ds,gkk_flag,Cryst%gprimd,Cryst%indsym,&
3928 : 0 : & Cryst%natom,Cryst%nsym,qpttoqpt,Cryst%rprimd,Cryst%symrec,Cryst%symrel)
3929 : :
3930 : 0 : call wrtout(std_out,' get_all_gkq : out of complete_gkk','COLL')
3931 : :
3932 : : end if !symgkq
3933 : :
3934 : : !TODO Do we need gkk_flag in elphon?
3935 [ - + ]: 15 : ABI_FREE(gkk_flag)
3936 : :
3937 : 15 : end subroutine get_all_gkq
3938 : : !!***
3939 : :
3940 : : !!****f* ABINIT/get_all_gkr
3941 : : !! NAME
3942 : : !! get_all_gkr
3943 : : !!
3944 : : !! FUNCTION
3945 : : !! This routine determines what to do with the rspace
3946 : : !! matrix elements of the el phon coupling (to disk or in memory),
3947 : : !! then reads those given in the gkq file and Fourier Transforms them
3948 : : !!
3949 : : !! INPUTS
3950 : : !! elph_ds = elphon datastructure with data and dimensions
3951 : : !! gprim = reciprocal space lattice vectors
3952 : : !! natom = number of atoms
3953 : : !! nrpt = number of real-space points used for FT
3954 : : !! onegkksize = size of one record of the new gkk output file, in bytes
3955 : : !! rpt = positions of real-space points for FT
3956 : : !! qpt_full = qpoint coordinates
3957 : : !! wghatm = weights for real-space rpt in FT
3958 : : !!
3959 : : !! OUTPUT
3960 : : !! elph_ds%gkr = real space elphon matrix elements.
3961 : : !!
3962 : : !! SOURCE
3963 : :
3964 : : subroutine get_all_gkr (elph_ds,gprim,natom,nrpt,onegkksize,rpt,qpt_full,wghatm)
3965 : :
3966 : : !Arguments ------------------------------------
3967 : : !scalars
3968 : : integer,intent(in) :: natom,nrpt,onegkksize
3969 : : type(elph_type),intent(inout) :: elph_ds
3970 : : !arrays
3971 : : real(dp),intent(in) :: gprim(3,3),rpt(3,nrpt),qpt_full(3,elph_ds%nqpt_full)
3972 : : real(dp),intent(in) :: wghatm(natom,natom,nrpt)
3973 : :
3974 : : !Local variables-------------------------------
3975 : : !scalars
3976 : : integer :: ikpt_phon0,iost,qtor,sz2,sz3,sz4,sz5
3977 : : ! *************************************************************************
3978 : :
3979 : : !
3980 : : !WARNING : disk file used for large arrays gkk_rpt and
3981 : : !(eventually) gkk2
3982 : : !
3983 : : !allocate (gkk_rpt(2,elph_ds%nbranch,elph_ds%nFSband,elph_ds%nFSband,&
3984 : : !& elph_ds%k_phon%nkpt,nrpt))
3985 : : elph_ds%unit_gkk_rpt = 36
3986 : : !see if the gkk_rpt should be written to a file (only available option now)
3987 : : if (elph_ds%gkk_rptwrite == 1) then
3988 : : ! file is not present : we need to do the FT
3989 : : open (unit=elph_ds%unit_gkk_rpt,file='gkk_rpt_file',access='direct',&
3990 : : & recl=onegkksize,form='unformatted',&
3991 : : & status='new',iostat=iost)
3992 : : if (iost /= 0) then
3993 : : ABI_ERROR('get_all_gkr : error opening gkk_rpt_file as new')
3994 : : end if
3995 : : write(std_out,*) ' get_all_gkr : will write real space gkk to a disk file.'
3996 : : write(std_out,*) ' size = ', 4.0*dble(onegkksize)*dble(nrpt)/&
3997 : : & 1024.0_dp/1024.0_dp, ' Mb'
3998 : :
3999 : : ! else if (elph_ds%gkk_rptwrite == 0) then
4000 : : else
4001 : : write(std_out,*) ' get_all_gkr : will keep real space gkk in memory.'
4002 : : write(std_out,*) ' size = ', 4.0*dble(onegkksize)*dble(nrpt)/&
4003 : : & 1024.0_dp/1024.0_dp, ' Mb'
4004 : : sz2=elph_ds%ngkkband*elph_ds%ngkkband
4005 : : sz3=elph_ds%nbranch*elph_ds%nbranch
4006 : : sz4=elph_ds%k_phon%nkpt
4007 : : sz5=elph_ds%nsppol
4008 : : ABI_MALLOC(elph_ds%gkk_rpt,(2,sz2,sz3,sz4,sz5,nrpt))
4009 : : ! write(std_out,*) ' get_all_gkr: invalid value for gkk_rptwrite'
4010 : : ! stop
4011 : : end if
4012 : : write(std_out,*) ' about to FT the recip space gkk to real space '
4013 : : qtor = 1
4014 : :
4015 : : !
4016 : : !NOTE: should be very easy to parallelize!
4017 : : !
4018 : : ikpt_phon0 = 1
4019 : : call ftgkk (wghatm,elph_ds%gkk_qpt,elph_ds%gkk_rpt,&
4020 : : & elph_ds%gkqwrite,elph_ds%gkk_rptwrite,gprim,1,natom,&
4021 : : & elph_ds%k_phon%nkpt,elph_ds%ngkkband,elph_ds%k_phon%nkpt,elph_ds%nqpt_full,&
4022 : : & nrpt,elph_ds%nsppol,qtor,rpt,qpt_full,elph_ds%unit_gkk_rpt,elph_ds%unitgkq)
4023 : :
4024 : : !call ftgkk (elph_ds,gprim,ikpt_phon0,natom,nrpt,qtor,rpt,qpt_full,wghatm)
4025 : : write(std_out,*) ' get_all_gkr : done with FT of gkk to real space'
4026 : :
4027 : : !No longer need the gkk_qpt?
4028 : : !if (elph_ds%gkqwrite == 0) deallocate (elph_ds%gkk_qpt)
4029 : :
4030 : : !!DEBUG
4031 : : !Test the FT of the gkk elements.
4032 : : !call test_ftgkk(elph_ds,gprim,natom,nrpt,rpt,qpt_full,wghatm)
4033 : : !!ENDDEBUG
4034 : :
4035 : : !DEBUG
4036 : : !do irpt=1,nrpt
4037 : : !do ipert1=1,elph_ds%nbranch
4038 : : !write(std_out,'(6(F16.5,1x))') elph_ds%gkk_rpt(:,ipert1,1,1,1,irpt)
4039 : : !end do
4040 : : !end do
4041 : : !ENDDEBUG
4042 : :
4043 : : end subroutine get_all_gkr
4044 : : !!***
4045 : :
4046 : : !!****f* ABINIT/complete_gkk
4047 : : !!
4048 : : !! NAME
4049 : : !! complete_gkk
4050 : : !!
4051 : : !! FUNCTION
4052 : : !! Use the set of special q points calculated by the Monkhorst &
4053 : : !! Pack Technique.
4054 : : !! Check if all the information for the q points are present in
4055 : : !! the DDB to determine the elphon interaction matrices
4056 : : !! Generate the gkk matrices of the set of q points which
4057 : : !! samples homogeneously the entire Brillouin zone.
4058 : : !!
4059 : : !! INPUTS
4060 : : !! elph_ds = datastructure for elphon information (mainly
4061 : : !! matrix elements and dimensions)
4062 : : !! elph_ds%k_phon%full2full = kpt_phon index mapping under symops
4063 : : !! gkk_flag = flag for existence of matrix element
4064 : : !! gprimd(3,3)=dimensionful primitive translations in reciprocal space
4065 : : !! indsym = map of atoms by inverses of symrels
4066 : : !! natom=number of atoms in unit cell
4067 : : !! nsym=number of space group symmetries
4068 : : !! qpttoqpt = qpoint index mapping under symops
4069 : : !! rprimd(3,3)=dimensionful primitive translations in real space
4070 : : !! symrec(3,3,nsym)=3x3 matrices of the group symmetries (recip space)
4071 : : !! symrel(3,3,nsym)=3x3 matrices of the group symmetries (real space)
4072 : : !! tnons(3,nsym)=nonsymmorphic translations associated to symrel
4073 : : !!
4074 : : !! OUTPUT
4075 : : !! elph_ds%gkk_qpt = gkk matrices for all qpts on a full mesh
4076 : : !!
4077 : : !! SOURCE
4078 : :
4079 : 0 : subroutine complete_gkk(elph_ds,gkk_flag,gprimd,indsym,natom,nsym,qpttoqpt,rprimd,symrec,symrel)
4080 : :
4081 : : !Arguments ------------------------------------
4082 : : !scalars
4083 : : integer,intent(in) :: natom,nsym
4084 : : type(elph_type),intent(inout) :: elph_ds
4085 : : !arrays
4086 : : integer,intent(in) :: indsym(4,nsym,natom)
4087 : : integer,intent(in) :: qpttoqpt(2,nsym,elph_ds%nqpt_full),symrec(3,3,nsym)
4088 : : integer,intent(in) :: symrel(3,3,nsym)
4089 : : integer,intent(inout) :: gkk_flag(elph_ds%nbranch,elph_ds%nbranch,elph_ds%k_phon%my_nkpt,elph_ds%nsppol,elph_ds%nqpt_full)
4090 : : real(dp),intent(in) :: gprimd(3,3)
4091 : : real(dp),intent(in) :: rprimd(3,3)
4092 : :
4093 : : !Local variables-------------------------------
4094 : : !scalars
4095 : : integer :: ikpt_phon,ib1,ibranch,ieqqpt,ii, ierr,comm
4096 : : integer :: iqpt,isppol,isym
4097 : : integer :: itim,jbranch,jj,kk,ll
4098 : : integer :: neqqpt,symikpt_phon
4099 : : integer :: iatom,ancestor_iatom
4100 : : integer :: ik_this_proc, me,sz1,sz2
4101 : :
4102 : : real(dp),parameter :: tol=2.d-8
4103 : : !arrays
4104 : 0 : integer :: symmetrized_qpt(elph_ds%nqpt_full)
4105 : : real(dp) :: ss(3,3)
4106 : 0 : real(dp) :: tmp_mat(2,elph_ds%nbranch,elph_ds%nbranch)
4107 : 0 : real(dp) :: tmp_mat2(2,elph_ds%nbranch,elph_ds%nbranch)
4108 : 0 : real(dp),allocatable :: gkk_qpt_new(:,:,:,:,:),gkk_qpt_tmp(:,:,:,:,:)
4109 : :
4110 : 0 : real(dp) :: ss_allatoms(2,elph_ds%nbranch,elph_ds%nbranch)
4111 : : complex(dp) :: c_one, c_zero
4112 : : ! *********************************************************************
4113 : :
4114 : 0 : c_one = dcmplx(one,zero)
4115 : 0 : c_zero = dcmplx(zero,zero)
4116 : :
4117 : : !Generation of the gkk matrices relative to the q points
4118 : : !of the set which samples the entire Brillouin zone
4119 : :
4120 : 0 : comm = xmpi_world
4121 : 0 : me = xmpi_comm_rank(comm)
4122 : :
4123 [ # # ]: 0 : symmetrized_qpt(:) = -1
4124 : :
4125 : : !FIXME bxu, why set it to 1?
4126 : : !isppol=1
4127 : :
4128 : 0 : sz1=elph_ds%ngkkband*elph_ds%ngkkband
4129 : 0 : sz2=elph_ds%nbranch*elph_ds%nbranch
4130 : :
4131 : : !these arrays are not parallelized, to enable symmetrization: syms swap k-points.
4132 [ # # # # : 0 : ABI_MALLOC(gkk_qpt_new,(2,sz1,sz2,elph_ds%k_phon%nkpt,elph_ds%nsppol))
# # # # #
# # # # #
# # # # #
# # # #
# ]
4133 [ # # # # : 0 : ABI_MALLOC(gkk_qpt_tmp,(2,sz1,sz2,elph_ds%k_phon%nkpt,elph_ds%nsppol))
# # # # #
# # # # #
# # # # #
# ]
4134 : :
4135 [ # # ]: 0 : do iqpt=1,elph_ds%nqpt_full
4136 : :
4137 : : ! Already symmetrized?
4138 [ # # ]: 0 : if (symmetrized_qpt(iqpt) == 1) cycle
4139 : :
4140 [ # # # # : 0 : gkk_qpt_new(:,:,:,:,:) = zero
# # # # #
# ]
4141 : : ! gkk_qpt_tmp(:,:,:,:,:) = zero
4142 : :
4143 : : ! loop over qpoints equivalent to iqpt
4144 : 0 : neqqpt=0
4145 : : ! do not use time reversal symmetry to complete the qpoints:
4146 : : ! do not know what happens to the gamma matrices
4147 : : ! itim=1
4148 : :
4149 [ # # ]: 0 : do itim=1,2
4150 [ # # ]: 0 : do isym=1,nsym
4151 : : ! ieqqpt is sent onto iqpt by itim/isym
4152 : 0 : ieqqpt = qpttoqpt(itim,isym,iqpt)
4153 [ # # # # : 0 : gkk_qpt_tmp(:,:,:,:,:) = zero
# # # # #
# ]
4154 : :
4155 : :
4156 [ # # ]: 0 : if (gkk_flag(1,1,1,1,ieqqpt) == -1) cycle
4157 : : ! if we have information on this qpt
4158 : : ! iqpt is equivalent to ieqqpt: get it from file or memory
4159 [ # # ]: 0 : do ik_this_proc =1,elph_ds%k_phon%my_nkpt
4160 : 0 : ikpt_phon = elph_ds%k_phon%my_ikpt(ik_this_proc)
4161 : :
4162 [ # # ]: 0 : if (elph_ds%gkqwrite == 0) then
4163 [ # # # # : 0 : gkk_qpt_tmp(:,:,:,ikpt_phon,:) = elph_ds%gkk_qpt(:,:,:,ik_this_proc,:,ieqqpt)
# # # # ]
4164 [ # # ]: 0 : else if (elph_ds%gkqwrite == 1) then
4165 : 0 : read(elph_ds%unitgkq,REC=((ieqqpt-1)*elph_ds%k_phon%my_nkpt+ik_this_proc)) gkk_qpt_tmp(:,:,:,ikpt_phon,:)
4166 : : end if
4167 : : end do
4168 : :
4169 : : ! condense everything
4170 : 0 : call xmpi_sum (gkk_qpt_tmp, comm, ierr)
4171 : :
4172 : 0 : neqqpt=neqqpt+1
4173 : :
4174 [ # # ]: 0 : if (elph_ds%ep_scalprod==1) then
4175 [ # # ]: 0 : do ii=1,3
4176 [ # # ]: 0 : do jj=1,3
4177 : 0 : ss(ii,jj)=0.0_dp
4178 [ # # ]: 0 : do kk=1,3
4179 [ # # ]: 0 : do ll=1,3
4180 : 0 : ss(ii,jj)=ss(ii,jj)+rprimd(ii,kk)*symrel(kk,ll,isym)*gprimd(ll,jj)
4181 : : end do
4182 : : end do
4183 : : end do
4184 : : end do
4185 : : else
4186 [ # # ]: 0 : do ii=1,3
4187 [ # # ]: 0 : do jj=1,3
4188 : 0 : ss(ii,jj) = symrec(jj,ii,isym)
4189 : : end do
4190 : : end do
4191 : : end if
4192 : :
4193 [ # # # # : 0 : ss_allatoms(:,:,:) = zero
# # ]
4194 [ # # ]: 0 : do iatom=1,natom
4195 : 0 : ancestor_iatom = indsym(4,isym,iatom)
4196 : : ! do jatom=1,natom
4197 : : ! ancestor_jatom = indsym(4,isym,jatom)
4198 : : ss_allatoms(1,(ancestor_iatom-1)*3+1:(ancestor_iatom-1)*3+3,&
4199 [ # # # # ]: 0 : & (iatom-1)*3+1: (iatom-1)*3+3) = ss(1:3,1:3)
4200 : : ! end do
4201 : : end do
4202 : :
4203 : :
4204 : : ! NOTE ssinv(ii,jj)=ssinv(ii,jj)+gprimd(ii,kk)*rprimd(jj,ll)*symrec(ll,kk,isym)
4205 : :
4206 [ # # ]: 0 : do isppol=1,elph_ds%nsppol
4207 [ # # ]: 0 : do ikpt_phon=1,elph_ds%k_phon%nkpt
4208 : : ! symikpt_phon is sent onto ikpt_phon by itim/isym
4209 : 0 : symikpt_phon=elph_ds%k_phon%full2full(itim,isym,ikpt_phon)
4210 : :
4211 : : ! Do each element band1, band2 separately...
4212 [ # # ]: 0 : do ib1=1,elph_ds%ngkkband*elph_ds%ngkkband
4213 : :
4214 : : ! multiply by the ss matrices
4215 [ # # # # : 0 : tmp_mat2(:,:,:) = zero
# # ]
4216 : : tmp_mat(:,:,:) = reshape(gkk_qpt_tmp(:,ib1,:,ikpt_phon,isppol),&
4217 [ # # ]: 0 : & (/2,elph_ds%nbranch,elph_ds%nbranch/))
4218 : : call ZGEMM ('N','N',elph_ds%nbranch,elph_ds%nbranch,elph_ds%nbranch,&
4219 : : & c_one,ss_allatoms,elph_ds%nbranch,tmp_mat,elph_ds%nbranch,c_zero,&
4220 : 0 : & tmp_mat2,elph_ds%nbranch)
4221 : : call ZGEMM ('N','T',elph_ds%nbranch,elph_ds%nbranch,elph_ds%nbranch,&
4222 : : & c_one,tmp_mat2,elph_ds%nbranch,ss_allatoms,elph_ds%nbranch,c_zero,&
4223 : 0 : & tmp_mat,elph_ds%nbranch)
4224 : :
4225 : : ! add to gkk_qpt_new
4226 [ # # ]: 0 : do ibranch =1,elph_ds%nbranch
4227 [ # # ]: 0 : do jbranch =1,elph_ds%nbranch
4228 : : gkk_qpt_new(:,ib1,(jbranch-1)*elph_ds%nbranch+ibranch,symikpt_phon,isppol) = &
4229 : : & gkk_qpt_new(:,ib1,(jbranch-1)*elph_ds%nbranch+ibranch,symikpt_phon,isppol) + &
4230 [ # # ]: 0 : & tmp_mat(:,jbranch,ibranch)
4231 : : end do
4232 : : end do
4233 : :
4234 : : end do ! end ib1 do
4235 : : end do ! end ikpt_phon do
4236 : : end do ! end isppol do
4237 : :
4238 : : end do ! end isym do
4239 : : end do ! itim
4240 : :
4241 [ # # ]: 0 : if (neqqpt > 1) then
4242 : 0 : write(std_out,*) ' found several equiv qpts and am symmetrizing them ', neqqpt
4243 : : end if
4244 : :
4245 : : ! divide by number of equivalent qpts found
4246 [ # # # # : 0 : gkk_qpt_new(:,:,:,:,:) = gkk_qpt_new(:,:,:,:,:)/neqqpt
# # # # #
# ]
4247 : :
4248 : : ! copy the symmetrized version into all the equivalent qpoints, appropriately transformed
4249 : : ! See above
4250 : : ! itim=1
4251 [ # # ]: 0 : do itim=1,2
4252 [ # # ]: 0 : do isym=1,nsym
4253 : : ! ieqqpt is sent onto iqpt by itim/isym
4254 : 0 : ieqqpt = qpttoqpt(itim,isym,iqpt)
4255 : :
4256 [ # # ]: 0 : if (symmetrized_qpt(ieqqpt) /= -1) cycle
4257 [ # # # # : 0 : gkk_qpt_tmp(:,:,:,:,:) = zero
# # # # #
# ]
4258 : :
4259 : : ! use symrec matrices to get inverse transform from isym^{-1}
4260 [ # # ]: 0 : if (elph_ds%ep_scalprod==1) then
4261 [ # # ]: 0 : do ii=1,3
4262 [ # # ]: 0 : do jj=1,3
4263 : 0 : ss(ii,jj)=0.0_dp
4264 [ # # ]: 0 : do kk=1,3
4265 [ # # ]: 0 : do ll=1,3
4266 : : ! Use inverse of symop matrix here to get back to ieqqpt (inv+transpose is in symrec and in gprimd)
4267 : 0 : ss(ii,jj)=ss(ii,jj)+rprimd(ii,kk)*symrec(ll,kk,isym)*gprimd(ll,jj)
4268 : : end do
4269 : : end do
4270 : : end do
4271 : : end do
4272 : : else
4273 [ # # ]: 0 : do ii=1,3
4274 [ # # ]: 0 : do jj=1,3
4275 : 0 : ss(ii,jj) = symrel(ii,jj,isym)
4276 : : end do
4277 : : end do
4278 : : end if
4279 : :
4280 [ # # # # : 0 : ss_allatoms(:,:,:) = zero
# # ]
4281 [ # # ]: 0 : do iatom=1,natom
4282 : 0 : ancestor_iatom = indsym(4,isym,iatom)
4283 : : ! do jatom=1,natom
4284 : : ! ancestor_jatom = indsym(4,isym,jatom)
4285 : : ss_allatoms(1,(ancestor_iatom-1)*3+1:(ancestor_iatom-1)*3+3,&
4286 [ # # # # ]: 0 : & (iatom-1)*3+1: (iatom-1)*3+3) = ss(1:3,1:3)
4287 : : ! end do
4288 : : end do
4289 : :
4290 : : ! ! Use inverse of symop matrix here to get back to ieqqpt
4291 : : ! ssinv(ii,jj)=ssinv(ii,jj)+gprimd(ii,kk)*rprimd(jj,ll)*symrel(kk,ll,isym)
4292 : :
4293 [ # # ]: 0 : do isppol=1,elph_ds%nsppol
4294 [ # # ]: 0 : do ikpt_phon=1,elph_ds%k_phon%nkpt
4295 : : ! symikpt_phon is sent onto ikpt_phon by itim/isym
4296 : 0 : symikpt_phon=elph_ds%k_phon%full2full(itim,isym,ikpt_phon)
4297 : :
4298 [ # # ]: 0 : do ib1=1,elph_ds%ngkkband*elph_ds%ngkkband
4299 : :
4300 : : ! multiply by the ss^{-1} matrices
4301 [ # # # # : 0 : tmp_mat2(:,:,:) = zero
# # ]
4302 : : tmp_mat(:,:,:) = reshape(gkk_qpt_new(:,ib1,:,ikpt_phon,isppol),&
4303 [ # # ]: 0 : & (/2,elph_ds%nbranch,elph_ds%nbranch/))
4304 : : call ZGEMM ('N','N',elph_ds%nbranch,elph_ds%nbranch,elph_ds%nbranch,&
4305 : : & c_one,ss_allatoms,elph_ds%nbranch,tmp_mat,elph_ds%nbranch,c_zero,&
4306 : 0 : & tmp_mat2,elph_ds%nbranch)
4307 : : call ZGEMM ('N','T',elph_ds%nbranch,elph_ds%nbranch,elph_ds%nbranch,&
4308 : : & c_one,tmp_mat2,elph_ds%nbranch,ss_allatoms,elph_ds%nbranch,c_zero,&
4309 : 0 : & tmp_mat,elph_ds%nbranch)
4310 : :
4311 [ # # ]: 0 : do ibranch =1,elph_ds%nbranch
4312 [ # # ]: 0 : do jbranch =1,elph_ds%nbranch
4313 : : gkk_qpt_tmp(:,ib1,(jbranch-1)*elph_ds%nbranch+ibranch,symikpt_phon,isppol) =&
4314 [ # # ]: 0 : & tmp_mat(:,jbranch,ibranch)
4315 : : end do
4316 : : end do
4317 : :
4318 [ # # ]: 0 : do ik_this_proc =1,elph_ds%k_phon%my_nkpt
4319 [ # # ]: 0 : if (elph_ds%k_phon%my_ikpt(ik_this_proc) == symikpt_phon) then
4320 [ # # # # : 0 : if (gkk_flag (1,1,ik_this_proc,isppol,ieqqpt) == -1) gkk_flag (:,:,ik_this_proc,isppol,ieqqpt) = 0
# # ]
4321 : : exit
4322 : : end if
4323 : : end do
4324 : : ! if (gkk_flag (1,1,symikpt_phon,isppol,ieqqpt) == -1) then
4325 : : ! gkk_flag (:,:,symikpt_phon,isppol,ieqqpt) = 0
4326 : : ! end if
4327 : :
4328 : : end do ! end ib1 do
4329 : : end do ! end ikpt_phon do
4330 : : end do ! end isppol do
4331 : :
4332 : :
4333 : : ! save symmetrized matrices for qpt ieqqpt
4334 [ # # ]: 0 : do ik_this_proc =1,elph_ds%k_phon%my_nkpt
4335 : 0 : ikpt_phon = elph_ds%k_phon%my_ikpt(ik_this_proc)
4336 : :
4337 [ # # ]: 0 : if (elph_ds%gkqwrite == 0) then
4338 [ # # # # : 0 : elph_ds%gkk_qpt(:,:,:,ik_this_proc,:,ieqqpt) = gkk_qpt_tmp(:,:,:,ikpt_phon,:)
# # # # ]
4339 [ # # ]: 0 : else if (elph_ds%gkqwrite == 1) then
4340 : 0 : write(elph_ds%unitgkq,REC=((ieqqpt-1)*elph_ds%k_phon%my_nkpt+ik_this_proc)) gkk_qpt_tmp(:,:,:,ikpt_phon,:)
4341 : : end if
4342 : : end do
4343 : :
4344 : 0 : symmetrized_qpt(ieqqpt) = 1
4345 : :
4346 : : end do ! end isym do
4347 : : end do ! end itim do
4348 : :
4349 : : end do
4350 : : !end iqpt do
4351 : :
4352 [ # # ]: 0 : ABI_FREE(gkk_qpt_new)
4353 [ # # ]: 0 : ABI_FREE(gkk_qpt_tmp)
4354 : :
4355 : 0 : end subroutine complete_gkk
4356 : : !!***
4357 : :
4358 : : !!****f* ABINIT/get_nv_fs_en
4359 : : !! NAME
4360 : : !! get_nv_fs_en
4361 : : !!
4362 : : !! FUNCTION
4363 : : !! This routine finds the energy grids for the integration on epsilon
4364 : : !! and epsilon prime. It then calculates the DOS and FS averaged velocity_sq at
4365 : : !! these energies. Metals and semiconductors are treated differently, to deal
4366 : : !! correctly with the gap.
4367 : : !!
4368 : : !! INPUTS
4369 : : !! crystal<crystal_t>=data type gathering info on the crystalline structure.
4370 : : !! Ifc<ifc_type>=Object containing the interatomic force constants.
4371 : : !! elph_ds
4372 : : !! elph_ds%nband = number of bands in ABINIT
4373 : : !! elph_ds%k_fine%nkptirr = Number of irreducible points for which there exist at least one band that crosses the Fermi level.
4374 : : !! elph_ds%nbranch = number of phonon branches = 3*natom
4375 : : !! elph_ds%k_phon%nkpt = number of k points
4376 : : !! elph_ds%k_fine%irredtoGS = mapping of elph k-points to ground state grid
4377 : : !! elph_ds%minFSband = lowest band included in the FS integration
4378 : : !! elph_ds%nFSband = number of bands included in the FS integration
4379 : : !! elph_ds%fermie = fermi energy
4380 : : !! elph_ds%tempermin = minimum temperature at which resistivity etc are calculated (in K)
4381 : : !! elph_ds%temperinc = interval temperature grid on which resistivity etc are calculated (in K)
4382 : : !! elph_ds%ep_b_min= first band taken into account in FS integration (if telphint==2)
4383 : : !! elph_ds%ep_b_max= last band taken into account in FS integration (if telphint==2)
4384 : : !! elph_ds%telphint = flag for integration over the FS with 0=tetrahedra 1=gaussians
4385 : : !! elph_ds%elphsmear = smearing width for gaussian integration
4386 : : !! or buffer in energy for calculations with tetrahedra (telphint=0)
4387 : : !!
4388 : : !! elph_tr_ds
4389 : : !! elph_tr_ds%el_veloc = electronic velocities from the fine k-grid
4390 : : !!
4391 : : !! eigenGS = Ground State eigenvalues
4392 : : !! kptrlatt_fine = k-point grid vectors (if divided by determinant of present matrix)
4393 : : !! max_occ = maximal occupancy for a band
4394 : : !!
4395 : : !! OUTPUT
4396 : : !! elph_ds%nenergy = number of energy points for integration on epsilon
4397 : : !! elph_tr_ds%en_all = energy points
4398 : : !! elph_tr_ds%de_all = differences between energy points
4399 : : !! elph_tr_ds%dos_n = DOS at selected energy points
4400 : : !! elph_tr_ds%veloc_sq = FS averaged velocity square at selected energy points
4401 : : !! elph_tr_ds%tmp_gkk_intweight = integration weights at coarse k grid
4402 : : !! elph_tr_ds%tmp_velocwtk = velocity times integration weights at coarse k grid
4403 : : !! elph_tr_ds%tmp_vvelocwtk = velocity square times integration weights at coarse k grid
4404 : : !!
4405 : : !! SOURCE
4406 : :
4407 : 0 : subroutine get_nv_fs_en(crystal,ifc,elph_ds,eigenGS,max_occ,elph_tr_ds,omega_max)
4408 : :
4409 : : !Arguments ------------------------------------
4410 : : !Scalars
4411 : : real(dp), intent(in) :: max_occ
4412 : : real(dp), intent(out) :: omega_max
4413 : : type(ifc_type),intent(in) :: ifc
4414 : : type(crystal_t),intent(in) :: crystal
4415 : : type(elph_type),intent(inout) :: elph_ds
4416 : : type(elph_tr_type),intent(inout) :: elph_tr_ds
4417 : : !Arrays
4418 : :
4419 : : real(dp), intent(in) :: eigenGS(elph_ds%nband,elph_ds%k_fine%nkptirr,elph_ds%nsppol)
4420 : :
4421 : : !Local variables-------------------------------
4422 : : !scalars
4423 : : integer :: iFSqpt,isppol,ie1,ierr
4424 : : integer :: i_metal,low_T
4425 : : integer :: in_nenergy, out_nenergy
4426 : : integer :: n_edge1, n_edge2, edge
4427 : : integer :: ie_all, ne_all
4428 : : integer :: sz1, sz2, sz3, sz4
4429 : : real(dp) :: e_vb_max, e_cb_min,ucvol
4430 : : real(dp) :: e1,max_e,fine_range
4431 : : real(dp) :: enemin,enemax
4432 : : real(dp) :: Temp,e_tiny,de0
4433 : : real(dp) :: eff_mass1, eff_mass2, tmp_dos
4434 : : character(len=500) :: message
4435 : : !arrays
4436 : : real(dp) :: gprimd(3,3), kpt_2nd(3), e_cb_2nd(2), en1(2)
4437 : 0 : real(dp),allocatable :: dos_e1(:,:),tmp_wtk(:,:,:,:), phfrq(:,:), displ(:,:,:,:)
4438 : : ! *************************************************************************
4439 : :
4440 [ # # # # ]: 0 : gprimd = crystal%gprimd
4441 : 0 : ucvol = crystal%ucvol
4442 : :
4443 : 0 : Temp = elph_ds%tempermin+elph_ds%temperinc
4444 : 0 : elph_ds%delta_e = kb_HaK*Temp ! about 1000 cm^-1/100, no need to be omega_max
4445 : 0 : max_e = elph_ds%nenergy*kb_HaK*Temp
4446 : 0 : e_tiny = kb_HaK*0.00001_dp ! this is the min. delta_e
4447 : 0 : de0 = kb_HaK*Temp ! Kb*T
4448 : :
4449 : 0 : in_nenergy = elph_ds%nenergy
4450 : :
4451 [ # # # # : 0 : ABI_MALLOC(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol,4))
# # # # #
# # # # #
# # # # #
# # # ]
4452 [ # # # # : 0 : ABI_MALLOC(dos_e1,(elph_ds%nsppol,3))
# # # # #
# # # ]
4453 : :
4454 [ # # # # : 0 : ABI_MALLOC(phfrq,(elph_ds%nbranch, elph_ds%k_phon%nkpt))
# # # # #
# # # # #
# # ]
4455 [ # # # # : 0 : ABI_MALLOC(displ,(2, elph_ds%nbranch, elph_ds%nbranch, elph_ds%k_phon%nkpt))
# # # # #
# # # # #
# # # # #
# ]
4456 : :
4457 [ # # ]: 0 : do iFSqpt=1,elph_ds%k_phon%nkpt
4458 : 0 : call ifc%fourq(crystal,elph_ds%k_phon%kpt(:,iFSqpt),phfrq(:,iFSqpt),displ(:,:,:,iFSqpt))
4459 : : end do
4460 : :
4461 [ # # # # : 0 : omega_max = maxval(phfrq)*1.1_dp
# # # # #
# # # ]
4462 [ # # ]: 0 : ABI_FREE(phfrq)
4463 [ # # ]: 0 : ABI_FREE(displ)
4464 : :
4465 : 0 : write(message,'(a,E20.12)')' The max phonon energy is ', omega_max
4466 : 0 : call wrtout(std_out,message,'COLL')
4467 : :
4468 : 0 : enemin = elph_ds%fermie - max_e*2
4469 : 0 : enemax = elph_ds%fermie + max_e
4470 : : call ep_el_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4471 : : & enemin, enemax, 4, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4472 : : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4473 : 0 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine, tmp_wtk)
4474 : :
4475 [ # # ]: 0 : do isppol=1,elph_ds%nsppol
4476 [ # # # # ]: 0 : dos_e1(isppol,1) = sum(tmp_wtk(:,:,isppol,2))/elph_ds%k_fine%nkpt
4477 [ # # # # ]: 0 : dos_e1(isppol,2) = sum(tmp_wtk(:,:,isppol,3))/elph_ds%k_fine%nkpt
4478 [ # # # # ]: 0 : dos_e1(isppol,3) = sum(tmp_wtk(:,:,isppol,4))/elph_ds%k_fine%nkpt
4479 : :
4480 : : ! ! BXU, only treat metallic case at this moment, as variational method may not
4481 : : ! ! apply to insulators
4482 : : ! i_metal = -1
4483 : 0 : i_metal = 1
4484 : : ! if (dos_e1(isppol,1) .gt. 0.1_dp .and. dos_e1(isppol,2) .gt. 0.1_dp .and. &
4485 : : ! & dos_e1(isppol,3) .gt. 0.1_dp) then ! metal
4486 : : ! i_metal = 1
4487 : 0 : if (i_metal == 1) then
4488 : 0 : write(message,'(a)')' This is a metal.'
4489 : 0 : call wrtout(std_out,message,'COLL')
4490 : :
4491 : 0 : fine_range = 1.5_dp
4492 : 0 : e1 = elph_ds%fermie + omega_max*fine_range
4493 : 0 : out_nenergy = 0
4494 : 0 : low_T = 1
4495 [ # # ]: 0 : if (omega_max*fine_range .lt. max_e) then
4496 : 0 : low_T = 0
4497 : 0 : de0 = omega_max*fine_range/in_nenergy ! energy spacing within Ef +/- omega_max
4498 [ # # ]: 0 : do while ((e1-elph_ds%fermie) .lt. max_e)
4499 : 0 : e1 = e1 + elph_ds%delta_e
4500 : 0 : out_nenergy = out_nenergy + 1
4501 : : end do
4502 : : end if
4503 : :
4504 : : if (low_T == 0) max_e = e1 - elph_ds%fermie
4505 : 0 : elph_ds%nenergy = in_nenergy*2 + 1 + out_nenergy*2
4506 : :
4507 : : else ! semiconductor/insulator, need careful consideration later
4508 : : i_metal = 0
4509 : : ! between CB min and the next k point, use free electron to replace
4510 : : ! The weights will be proportional to the DOS, relative to the weights
4511 : : ! calculated with ep_fs_weights, tetrahedron method prefered
4512 : :
4513 : : ! output VB and CB edges for semiconductor/insulator
4514 : : e_vb_max = maxval(eigenGS(elph_ds%minFSband+elph_ds%nFSband/2-1,:,isppol))
4515 : : e_cb_min = minval(eigenGS(elph_ds%minFSband+elph_ds%nFSband/2,:,isppol))
4516 : : e_cb_2nd(1) = eigenGS(elph_ds%minFSband+elph_ds%nFSband/2,2,isppol)
4517 : : e_cb_2nd(2) = eigenGS(elph_ds%minFSband+elph_ds%nFSband/2+1,2,isppol)
4518 : : write(message,'(a,E20.12,2x,E20.12)')' elphon : top of VB, bottom of CB = ',&
4519 : : & e_vb_max, e_cb_min
4520 : : call wrtout(std_out,message,'COLL')
4521 : : write(message,'(a,E20.12)')' elphon : energy at the neighbor kpt = ',e_cb_2nd(1)
4522 : : call wrtout(std_out,message,'COLL')
4523 : :
4524 : : n_edge1 = 4 ! at the very edge
4525 : : n_edge2 = 8 ! sparse to the end of free-electron part
4526 : :
4527 : : kpt_2nd(:) = gprimd(:,1)*elph_ds%k_fine%kptirr(1,2) + &
4528 : : & gprimd(:,2)*elph_ds%k_fine%kptirr(2,2) + &
4529 : : & gprimd(:,3)*elph_ds%k_fine%kptirr(3,2)
4530 : : write(message,'(a,3E20.12)')' The neighbor k point is: ', elph_ds%k_fine%kptirr(:,2)
4531 : : call wrtout(std_out,message,'COLL')
4532 : :
4533 : : if (dabs(elph_ds%fermie-e_cb_min) .lt. dabs(elph_ds%fermie-e_vb_max)) then
4534 : : e1 = e_cb_2nd(1)
4535 : : else
4536 : : e1 = e_vb_max
4537 : : end if
4538 : : call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4539 : : & e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4540 : : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4541 : : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4542 : :
4543 : : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4544 : :
4545 : : eff_mass1 = (kpt_2nd(1)*kpt_2nd(1) + kpt_2nd(2)*kpt_2nd(2) + kpt_2nd(3)*kpt_2nd(3)) / &
4546 : : & (2.0_dp*(e_cb_2nd(1)-e_cb_min))
4547 : : write(message,'(a,E20.12)')' The eff. mass from band1 is: ', eff_mass1
4548 : : call wrtout(std_out,message,'COLL')
4549 : : eff_mass2 = (kpt_2nd(1)*kpt_2nd(1) + kpt_2nd(2)*kpt_2nd(2) + kpt_2nd(3)*kpt_2nd(3)) / &
4550 : : & (2.0_dp*(e_cb_2nd(2)-e_cb_min))
4551 : : write(message,'(a,E20.12)')' The eff. mass from band2 is: ', eff_mass2
4552 : : call wrtout(std_out,message,'COLL')
4553 : :
4554 : : ! bxu, but the eff. mass estimated in this way is too small
4555 : : ! The following is obtained by roughly fitting to the DOS of 48x48x48
4556 : : eff_mass1 = 0.91036
4557 : : write(message,'(a,E20.12)')' The eff. mass we are using is: ', eff_mass1
4558 : : call wrtout(std_out,message,'COLL')
4559 : :
4560 : : 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 + &
4561 : : & 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
4562 : : write(message,'(a,E20.12)')' The fake DOS at kpt1 = ', tmp_dos
4563 : : call wrtout(std_out,message,'COLL')
4564 : : write(message,'(a,E20.12)')' The calculated DOS at kpt1 = ', elph_ds%n0(isppol)
4565 : : call wrtout(std_out,message,'COLL')
4566 : :
4567 : :
4568 : : e1 = elph_ds%fermie - max_e
4569 : : ie_all = 1
4570 : : ne_all = 0
4571 : : edge = 0
4572 : :
4573 : : call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4574 : : & e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4575 : : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4576 : : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4577 : :
4578 : : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4579 : : do while ((e1-elph_ds%fermie) .lt. max_e)
4580 : : if (e1 .lt. e_cb_min .and. elph_ds%n0(isppol) .lt. tol9) then
4581 : : e1 = e_cb_2nd(1)
4582 : : edge = 1
4583 : : e1 = e1 + de0
4584 : : end if
4585 : :
4586 : : if (e1 .lt. e_cb_2nd(1)) then
4587 : : e1 = e_cb_2nd(1)
4588 : : edge = 1
4589 : : e1 = e1 + de0
4590 : : end if
4591 : :
4592 : : if (e1 .gt. e_cb_2nd(1)) then
4593 : : call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4594 : : & e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4595 : : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4596 : : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4597 : :
4598 : : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4599 : :
4600 : : e1 = e1 + de0
4601 : : ie_all = ie_all + 1
4602 : : end if
4603 : : end do ! e_all
4604 : : ne_all = ie_all - 1 + (n_edge1 + n_edge2 - 1)*edge ! energy levels in the free-electron range
4605 : : write(message,'(a,i3,a,i3,a)')' For spin', isppol, ' there are ', &
4606 : : & ne_all, ' energy levels considered '
4607 : : call wrtout(std_out,message,'COLL')
4608 : :
4609 : : elph_ds%nenergy = ne_all
4610 : : end if ! metal or insulator
4611 : : end do ! isppol
4612 : :
4613 [ # # ]: 0 : ABI_FREE(tmp_wtk)
4614 : :
4615 [ # # ]: 0 : if (elph_ds%nenergy .lt. 2) then
4616 : 0 : ABI_ERROR('There are too few energy levels for non-LOVA')
4617 : : end if
4618 : :
4619 : 0 : sz1=elph_ds%ngkkband;sz2=elph_ds%k_phon%nkpt
4620 : 0 : sz3=elph_ds%nsppol;sz4=elph_ds%nenergy+1
4621 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%dos_n,(sz4,sz3))
# # # # #
# # # # #
# # # # ]
4622 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%veloc_sq,(3,sz3,sz4))
# # # # #
# # # # #
# # # # ]
4623 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%en_all,(sz3,sz4))
# # # # #
# # # #
# ]
4624 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%de_all,(sz3,sz4+1))
# # # # #
# # # # #
# # # # #
# ]
4625 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%tmp_gkk_intweight,(sz1,sz2,sz3,sz4))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
4626 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%tmp_velocwtk,(sz1,sz2,3,sz3,sz4))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
4627 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%tmp_vvelocwtk,(sz1,sz2,3,3,sz3,sz4))
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
4628 : :
4629 [ # # # # ]: 0 : elph_tr_ds%dos_n = zero
4630 [ # # # # : 0 : elph_tr_ds%veloc_sq = zero
# # ]
4631 [ # # # # : 0 : elph_tr_ds%tmp_gkk_intweight = zero
# # # # ]
4632 [ # # # # : 0 : elph_tr_ds%tmp_velocwtk = zero
# # # # #
# ]
4633 [ # # # # : 0 : elph_tr_ds%tmp_vvelocwtk = zero
# # # # #
# # # ]
4634 : :
4635 [ # # # # : 0 : ABI_MALLOC_OR_DIE(elph_ds%k_phon%velocwtk,(elph_ds%nFSband,elph_ds%k_phon%nkpt,3,elph_ds%nsppol), ierr)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # ]
4636 : :
4637 [ # # # # : 0 : ABI_MALLOC_OR_DIE(elph_ds%k_phon%vvelocwtk,(elph_ds%nFSband,elph_ds%k_phon%nkpt,3,3,elph_ds%nsppol), ierr)
# # # # #
# # # # #
# # # # #
# # # # #
# # # # #
# ]
4638 : :
4639 [ # # # # : 0 : elph_ds%k_phon%velocwtk = zero
# # # # ]
4640 [ # # # # : 0 : elph_ds%k_phon%vvelocwtk = zero
# # # # #
# ]
4641 : :
4642 : : !metal
4643 : : if (i_metal .eq. 1) then
4644 : 0 : e1 = elph_ds%fermie - max_e
4645 [ # # ]: 0 : en1(:) = elph_ds%fermie - max_e
4646 [ # # ]: 0 : if (low_T .eq. 1) then
4647 : 0 : enemin = elph_ds%fermie - max_e - elph_ds%delta_e
4648 : 0 : enemax = elph_ds%fermie + max_e
4649 : :
4650 [ # # # # : 0 : ABI_MALLOC(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol,elph_ds%nenergy+1))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
4651 : : call ep_el_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4652 : : & enemin, enemax, elph_ds%nenergy+1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4653 : : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4654 : 0 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine, tmp_wtk)
4655 : :
4656 [ # # ]: 0 : do isppol=1,elph_ds%nsppol
4657 [ # # ]: 0 : do ie1 = 1, elph_ds%nenergy
4658 : 0 : elph_tr_ds%en_all(isppol,ie1) = en1(isppol)
4659 : 0 : elph_tr_ds%de_all(isppol,ie1) = elph_ds%delta_e
4660 : :
4661 [ # # # # ]: 0 : elph_ds%k_fine%wtk(:,:,isppol) = tmp_wtk(:,:,isppol,ie1+1)
4662 [ # # # # ]: 0 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4663 [ # # # # ]: 0 : elph_tr_ds%dos_n(ie1,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4664 : :
4665 : 0 : call get_veloc_tr(elph_ds,elph_tr_ds)
4666 [ # # ]: 0 : elph_tr_ds%veloc_sq(:,isppol,ie1)=elph_tr_ds%FSelecveloc_sq(:,isppol)
4667 : :
4668 : 0 : call d2c_weights(elph_ds,elph_tr_ds)
4669 : :
4670 [ # # # # ]: 0 : elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie1) = elph_ds%k_phon%wtk(:,:,isppol)
4671 [ # # # # : 0 : elph_tr_ds%tmp_velocwtk(:,:,:,isppol,ie1) = elph_ds%k_phon%velocwtk(:,:,:,isppol)
# # ]
4672 [ # # # # : 0 : elph_tr_ds%tmp_vvelocwtk(:,:,:,:,isppol,ie1) = elph_ds%k_phon%vvelocwtk(:,:,:,:,isppol)
# # # # ]
4673 : 0 : en1(isppol) = en1(isppol) + elph_ds%delta_e
4674 : : end do
4675 : : end do
4676 [ # # ]: 0 : ABI_FREE(tmp_wtk)
4677 : :
4678 : : else ! low_T = 0
4679 : 0 : enemin = e1 - elph_ds%delta_e
4680 : 0 : enemax = e1 + (out_nenergy-1)*elph_ds%delta_e
4681 : :
4682 [ # # # # : 0 : ABI_MALLOC(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol,out_nenergy+1))
# # # # #
# # # # #
# # # # #
# # # #
# ]
4683 : : call ep_el_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4684 : : & enemin, enemax, out_nenergy+1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4685 : : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4686 : 0 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine, tmp_wtk)
4687 [ # # ]: 0 : do isppol=1,elph_ds%nsppol
4688 [ # # ]: 0 : do ie1 = 1, out_nenergy
4689 : 0 : elph_tr_ds%en_all(isppol,ie1) = en1(isppol)
4690 : 0 : elph_tr_ds%de_all(isppol,ie1) = elph_ds%delta_e
4691 : :
4692 [ # # # # ]: 0 : elph_ds%k_fine%wtk(:,:,isppol) = tmp_wtk(:,:,isppol,ie1+1)
4693 [ # # # # ]: 0 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4694 [ # # # # ]: 0 : elph_tr_ds%dos_n(ie1,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4695 : :
4696 : 0 : call get_veloc_tr(elph_ds,elph_tr_ds)
4697 [ # # ]: 0 : elph_tr_ds%veloc_sq(:,isppol,ie1)=elph_tr_ds%FSelecveloc_sq(:,isppol)
4698 : :
4699 : 0 : call d2c_weights(elph_ds,elph_tr_ds)
4700 : :
4701 [ # # # # ]: 0 : elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie1) = elph_ds%k_phon%wtk(:,:,isppol)
4702 [ # # # # : 0 : elph_tr_ds%tmp_velocwtk(:,:,:,isppol,ie1) = elph_ds%k_phon%velocwtk(:,:,:,isppol)
# # ]
4703 [ # # # # : 0 : elph_tr_ds%tmp_vvelocwtk(:,:,:,:,isppol,ie1) = elph_ds%k_phon%vvelocwtk(:,:,:,:,isppol)
# # # # ]
4704 : :
4705 : 0 : en1(isppol) = en1(isppol) + elph_ds%delta_e
4706 : : end do
4707 : : end do
4708 [ # # ]: 0 : ABI_FREE(tmp_wtk)
4709 : :
4710 : 0 : e1 = en1(1)
4711 : 0 : enemin = e1 - de0
4712 : 0 : enemax = e1 + in_nenergy*2*de0
4713 : :
4714 [ # # # # : 0 : ABI_MALLOC(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol,in_nenergy*2+2))
# # # # #
# # # # #
# # # # #
# # # # #
# # ]
4715 : : call ep_el_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4716 : : & enemin, enemax, in_nenergy*2+2, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4717 : : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4718 : 0 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine, tmp_wtk)
4719 : :
4720 [ # # ]: 0 : do isppol=1,elph_ds%nsppol
4721 [ # # ]: 0 : do ie1 = out_nenergy+1, out_nenergy+in_nenergy*2+1
4722 : 0 : elph_tr_ds%en_all(isppol,ie1) = en1(isppol)
4723 : 0 : elph_tr_ds%de_all(isppol,ie1) = de0
4724 : :
4725 [ # # # # ]: 0 : elph_ds%k_fine%wtk(:,:,isppol) = tmp_wtk(:,:,isppol,ie1-out_nenergy+1)
4726 [ # # # # ]: 0 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4727 [ # # # # ]: 0 : elph_tr_ds%dos_n(ie1,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4728 : :
4729 : 0 : call get_veloc_tr(elph_ds,elph_tr_ds)
4730 [ # # ]: 0 : elph_tr_ds%veloc_sq(:,isppol,ie1)=elph_tr_ds%FSelecveloc_sq(:,isppol)
4731 : :
4732 : 0 : call d2c_weights(elph_ds,elph_tr_ds)
4733 : :
4734 [ # # # # ]: 0 : elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie1) = elph_ds%k_phon%wtk(:,:,isppol)
4735 [ # # # # : 0 : elph_tr_ds%tmp_velocwtk(:,:,:,isppol,ie1) = elph_ds%k_phon%velocwtk(:,:,:,isppol)
# # ]
4736 [ # # # # : 0 : elph_tr_ds%tmp_vvelocwtk(:,:,:,:,isppol,ie1) = elph_ds%k_phon%vvelocwtk(:,:,:,:,isppol)
# # # # ]
4737 : :
4738 : 0 : en1(isppol) = en1(isppol) + de0
4739 : : end do
4740 : : end do
4741 [ # # ]: 0 : ABI_FREE(tmp_wtk)
4742 : :
4743 : 0 : e1 = en1(1)
4744 : 0 : enemin = e1 - elph_ds%delta_e
4745 : 0 : enemax = e1 + (out_nenergy-1)*elph_ds%delta_e
4746 : :
4747 [ # # # # : 0 : ABI_MALLOC(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol,out_nenergy+1))
# # # # #
# # # # #
# # # # #
# # # #
# ]
4748 : : call ep_el_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4749 : : & enemin, enemax, out_nenergy+1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4750 : : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4751 : 0 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine, tmp_wtk)
4752 : :
4753 [ # # ]: 0 : en1(:) = en1(:) - de0 + elph_ds%delta_e ! adjust to make the points symmetric around Ef
4754 [ # # ]: 0 : do isppol=1,elph_ds%nsppol
4755 [ # # ]: 0 : do ie1 = out_nenergy+in_nenergy*2+2, in_nenergy*2+1+out_nenergy*2
4756 : 0 : elph_tr_ds%en_all(isppol,ie1) = en1(isppol)
4757 : 0 : elph_tr_ds%de_all(isppol,ie1) = elph_ds%delta_e
4758 : :
4759 [ # # # # ]: 0 : elph_ds%k_fine%wtk(:,:,isppol) = tmp_wtk(:,:,isppol,ie1-out_nenergy-in_nenergy*2)
4760 [ # # # # ]: 0 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4761 [ # # # # ]: 0 : elph_tr_ds%dos_n(ie1,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4762 : :
4763 : 0 : call get_veloc_tr(elph_ds,elph_tr_ds)
4764 [ # # ]: 0 : elph_tr_ds%veloc_sq(:,isppol,ie1)=elph_tr_ds%FSelecveloc_sq(:,isppol)
4765 : :
4766 : 0 : call d2c_weights(elph_ds,elph_tr_ds)
4767 : :
4768 [ # # # # ]: 0 : elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie1) = elph_ds%k_phon%wtk(:,:,isppol)
4769 [ # # # # : 0 : elph_tr_ds%tmp_velocwtk(:,:,:,isppol,ie1) = elph_ds%k_phon%velocwtk(:,:,:,isppol)
# # ]
4770 [ # # # # : 0 : elph_tr_ds%tmp_vvelocwtk(:,:,:,:,isppol,ie1) = elph_ds%k_phon%vvelocwtk(:,:,:,:,isppol)
# # # # ]
4771 : :
4772 : 0 : en1(isppol) = en1(isppol) + elph_ds%delta_e
4773 : : end do
4774 : : end do
4775 [ # # ]: 0 : ABI_FREE(tmp_wtk)
4776 : : end if
4777 : :
4778 : : !semiconductor
4779 : : else if (i_metal .eq. 0) then
4780 : : e1 = elph_ds%fermie - max_e
4781 : : ie_all = 1
4782 : :
4783 : : call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4784 : : & e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4785 : : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4786 : : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4787 : :
4788 : : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4789 : : do while ((e1-elph_ds%fermie) .lt. max_e)
4790 : : if (e1 .lt. e_cb_min .and. elph_ds%n0(isppol) .lt. tol9) then
4791 : : e1 = e_cb_min
4792 : : end if
4793 : :
4794 : : if (ie_all .ge. n_edge1+n_edge2) then
4795 : : if (ie_all .eq. n_edge1+n_edge2) e1 = e1 + de0
4796 : : call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4797 : : & e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4798 : : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4799 : : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4800 : :
4801 : : elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie_all) = elph_ds%k_fine%wtk(:,:,isppol)
4802 : : elph_tr_ds%dos_n(ie_all,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4803 : : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4804 : :
4805 : : elph_tr_ds%en_all(isppol,ie_all) = e1
4806 : : call get_veloc_tr(elph_ds,elph_tr_ds)
4807 : : elph_tr_ds%veloc_sq(:,isppol,ie_all)=elph_tr_ds%FSelecveloc_sq(:,isppol)
4808 : : ! bxu
4809 : : ! veloc_sq(1,isppol,ie_all) is "1" good and general??
4810 : :
4811 : : elph_tr_ds%de_all(isppol,ie_all) = de0
4812 : : e1 = e1 + elph_tr_ds%de_all(isppol,ie_all)
4813 : : ie_all = ie_all + 1
4814 : : else ! divided according to the 1/DOS (evenly)
4815 : : if (ie_all .lt. n_edge1) then
4816 : : elph_tr_ds%en_all(isppol,ie_all) = e_cb_min + &
4817 : : & (e_tiny**(-0.5_dp) - ie_all*(e_tiny**(-0.5_dp)-(e_cb_2nd(1)-e_cb_min)**(-0.5_dp))/ &
4818 : : & dble(n_edge1))**(-2.0_dp)
4819 : : if (ie_all .gt. 1) then
4820 : : 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)
4821 : : else
4822 : : elph_tr_ds%de_all(isppol,ie_all) = elph_tr_ds%en_all(isppol,ie_all) - e_cb_min - e_tiny
4823 : : end if
4824 : : e1 = elph_tr_ds%en_all(isppol,ie_all)
4825 : : else
4826 : : elph_tr_ds%en_all(isppol,ie_all) = e_cb_min + &
4827 : : & ((ie_all-n_edge1+1)/dble(n_edge2))**2.0_dp*(e_cb_2nd(1)-e_cb_min)
4828 : : if (ie_all .gt. 1) then
4829 : : 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)
4830 : : else
4831 : : elph_tr_ds%de_all(isppol,ie_all) = (e_cb_2nd(1)-e_cb_min)/(dble(n_edge2)**2.0_dp)
4832 : : end if
4833 : : e1 = elph_tr_ds%en_all(isppol,ie_all)
4834 : : end if
4835 : :
4836 : : call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4837 : : & e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4838 : : & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4839 : : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4840 : :
4841 : : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4842 : :
4843 : : 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 + &
4844 : : & 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
4845 : : elph_tr_ds%dos_n(ie_all,isppol) = tmp_dos
4846 : : elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie_all) = elph_ds%k_fine%wtk(:,:,isppol)*tmp_dos/elph_ds%n0(isppol)
4847 : :
4848 : : call get_veloc_tr(elph_ds,elph_tr_ds)
4849 : : elph_tr_ds%veloc_sq(:,isppol,ie_all)=elph_tr_ds%FSelecveloc_sq(:,isppol)
4850 : :
4851 : : if (ie_all .eq. (n_edge1+n_edge2)) e1 = e_cb_2nd(1) + de0
4852 : : ie_all = ie_all + 1
4853 : : end if
4854 : : end do ! ie_all
4855 : : else
4856 : : ABI_BUG('check i_metal!')
4857 : : end if ! metal or insulator
4858 : :
4859 [ # # ]: 0 : ABI_FREE(dos_e1)
4860 : :
4861 : 0 : end subroutine get_nv_fs_en
4862 : : !!***
4863 : :
4864 : : !!****f* ABINIT/get_nv_fs_temp
4865 : : !! NAME
4866 : : !! get_nv_fs_temp
4867 : : !!
4868 : : !! FUNCTION
4869 : : !! This routine calculates the fermi energy, FD smeared DOS(Ef) and
4870 : : !! Veloc_sq(Ef) at looped temperatures.
4871 : : !!
4872 : : !! INPUTS
4873 : : !! elph_ds
4874 : : !! elph_ds%nband = number of bands in ABINIT
4875 : : !! elph_ds%k_fine%nkptirr = Number of irreducible points for which there exist at least one band that crosses the Fermi level.
4876 : : !! elph_ds%nFSband = number of bands included in the FS integration
4877 : : !! elph_ds%k_fine%nkpt = number of k points for fine k-grid
4878 : : !! elph_ds%k_phon%nkpt = number of k points for coarse k-grid
4879 : : !! elph_ds%tempermin = minimum temperature at which resistivity etc are calculated (in K)
4880 : : !! elph_ds%temperinc = interval temperature grid on which resistivity etc are calculated (in K)
4881 : : !! elph_ds%ep_b_min= first band taken into account in FS integration (if telphint==2)
4882 : : !! elph_ds%ep_b_max= last band taken into account in FS integration (if telphint==2)
4883 : : !! elph_ds%telphint = flag for integration over the FS with 0=tetrahedra 1=gaussians
4884 : : !! elph_ds%elphsmear = smearing width for gaussian integration
4885 : : !! or buffer in energy for calculations with tetrahedra (telphint=0)
4886 : : !!
4887 : : !! eigenGS = Ground State eigenvalues
4888 : : !! gprimd = reciprocal lattice vectors (dimensionful)
4889 : : !! kptrlatt_fine = k-point grid vectors (if divided by determinant of present matrix)
4890 : : !! max_occ = maximal occupancy for a band
4891 : : !!
4892 : : !! OUTPUT
4893 : : !! elph_ds%fermie=Fermi level at input temperature
4894 : : !! elph_tr_ds%dos_n0=DOS(Ef) at looped temperatures
4895 : : !! elph_tr_ds%veloc_sq0=FS averaged velocity at Ef at looped temperatures
4896 : : !!
4897 : : !! SOURCE
4898 : :
4899 : 0 : subroutine get_nv_fs_temp(elph_ds,BSt,eigenGS,gprimd,max_occ,elph_tr_ds)
4900 : :
4901 : : !Arguments ------------------------------------
4902 : : type(elph_type),intent(inout) :: elph_ds
4903 : : type(ebands_t),intent(inout) :: BSt
4904 : : type(elph_tr_type),intent(inout) :: elph_tr_ds
4905 : :
4906 : : !Scalars
4907 : : real(dp), intent(in) :: max_occ
4908 : :
4909 : : ! arrays
4910 : : real(dp), intent(in) :: gprimd(3,3)
4911 : : real(dp), intent(in) :: eigenGS(elph_ds%nband,elph_ds%k_fine%nkptirr,elph_ds%nsppol)
4912 : :
4913 : : !Local variables-------------------------------
4914 : :
4915 : : integer :: isppol!, ie1
4916 : : integer :: itemp, tmp_nenergy
4917 : :
4918 : : character(len=500) :: message
4919 : :
4920 : : real(dp) :: Temp, tmp_elphsmear, tmp_delta_e
4921 : : ! real(dp) :: xtr, e1
4922 : : ! real(dp),allocatable :: tmp_wtk(:,:)
4923 : : ! *************************************************************************
4924 : :
4925 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%dos_n0,(elph_ds%ntemper,elph_ds%nsppol))
# # # # #
# # # # #
# # # # ]
4926 [ # # # # : 0 : ABI_MALLOC(elph_tr_ds%veloc_sq0,(elph_ds%ntemper,3,elph_ds%nsppol))
# # # # #
# # # # #
# # # # ]
4927 : : !if (elph_ds%use_k_fine == 1) then
4928 : : !ABI_MALLOC(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt))
4929 : : !else
4930 : : !ABI_MALLOC(tmp_wtk,(elph_ds%nFSband,elph_ds%k_phon%nkpt))
4931 : : !end if
4932 : :
4933 [ # # # # ]: 0 : elph_tr_ds%dos_n0 = zero
4934 [ # # # # : 0 : elph_tr_ds%veloc_sq0 = zero
# # ]
4935 : :
4936 : : tmp_nenergy = 8
4937 [ # # ]: 0 : do itemp=1,elph_ds%ntemper ! runs over temperature in K
4938 : 0 : Temp=elph_ds%tempermin + elph_ds%temperinc*dble(itemp)
4939 : 0 : tmp_delta_e = kb_HaK*Temp
4940 : 0 : Bst%occopt = 3
4941 : 0 : Bst%tsmear = Temp*kb_HaK
4942 : 0 : tmp_elphsmear = Temp*kb_HaK
4943 : 0 : call Bst%update_occ(-99.99_dp)
4944 : 0 : write(message,'(a,f12.6,a,E20.12)')'At T=',Temp,' Fermi level is:',Bst%fermie
4945 : 0 : call wrtout(std_out,message,'COLL')
4946 [ # # ]: 0 : if (abs(elph_ds%fermie) < tol10) then
4947 : 0 : elph_ds%fermie = BSt%fermie
4948 : : end if
4949 : :
4950 : : ! FD smeared DOS and veloc
4951 : :
4952 : : call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, tmp_elphsmear, &
4953 : : & elph_ds%fermie, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine,&
4954 : : & max_occ, elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4955 : 0 : & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4956 : :
4957 [ # # ]: 0 : do isppol=1,elph_ds%nsppol
4958 [ # # # # ]: 0 : elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4959 : 0 : write(message,'(a,f12.6,a,f12.6)')'At T=',Temp,' The DOS at Ef is:', elph_ds%n0(isppol)
4960 : 0 : call wrtout(std_out,message,'COLL')
4961 : :
4962 : : ! For the non-LOVA case, N(Ef) is not that important (canceled out eventually).
4963 : : ! Should not be important for metal, comment out for now
4964 : : ! tmp_wtk = zero
4965 : : ! do ie1=-tmp_nenergy,tmp_nenergy ! use ie1 here, hope there is no confusion
4966 : : ! e1=Bst%fermie+ie1*tmp_delta_e
4967 : : ! xtr=(e1-Bst%fermie)/(2.0_dp*kb_HaK*Temp)
4968 : : !
4969 : : ! call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4970 : : ! & e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, &
4971 : : ! & max_occ, elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4972 : : ! & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4973 : : !
4974 : : ! tmp_wtk(:,:) = tmp_wtk(:,:) + elph_ds%k_fine%wtk(:,:,isppol)* &
4975 : : ! & tmp_delta_e/(4.0d0*kb_HaK*Temp)/(COSH(xtr)**2.0d0)
4976 : : ! end do ! ie1
4977 : :
4978 : : ! elph_ds%k_fine%wtk(:,:,isppol) = tmp_wtk(:,:)
4979 [ # # # # ]: 0 : elph_tr_ds%dos_n0(itemp,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4980 : : ! elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4981 : : ! write(message,'(a,f12.6,a,f12.6)')'At T=',Temp,' The eff. DOS at Ef is:', elph_tr_ds%dos_n0(itemp,isppol)
4982 : : ! call wrtout(std_out,message,'COLL')
4983 : : end do ! isppol
4984 : 0 : call get_veloc_tr(elph_ds,elph_tr_ds)
4985 [ # # # # : 0 : elph_tr_ds%veloc_sq0(itemp,:,:) = elph_tr_ds%FSelecveloc_sq(:,:)
# # # # #
# ]
4986 : :
4987 : : end do ! temperature
4988 : :
4989 : 0 : end subroutine get_nv_fs_temp
4990 : : !!***
4991 : :
4992 : : !!****f* ABINIT/get_veloc_tr
4993 : : !!
4994 : : !! NAME
4995 : : !! get_veloc_tr
4996 : : !!
4997 : : !! FUNCTION
4998 : : !! calculate the (in) and (out) velocity factors for transport
4999 : : !!
5000 : : !! INPUTS
5001 : : !! elph_ds
5002 : : !! elph_ds%nFSband = number of bands included in the FS integration
5003 : : !! elph_ds%k_fine%nkpt = number of kpts included in the FS integration
5004 : : !! elph_ds%nFSband = number of bands included in the FS integration
5005 : : !! elph_ds%minFSband = index of the lowest FS band
5006 : : !! elph_ds%nqpt_full = number of Q pts
5007 : : !! elph_ds%nqptirred = number of irreducible Q pts
5008 : : !! to index the GS electronic states :
5009 : : !! kphon_full2irr = mapping of full FS kpts to irreducible ones
5010 : : !! FSfullpqtofull = mapping of k + q to k
5011 : : !! FSirredtoGS = mapping of irreducible kpoints to GS set
5012 : : !!
5013 : : !! OUTPUT
5014 : : !! elph_tr_ds%FSelecveloc_sq = avergae FS electronic velocity
5015 : : !!
5016 : : !! SOURCE
5017 : :
5018 : 5 : subroutine get_veloc_tr(elph_ds,elph_tr_ds)
5019 : :
5020 : : !Arguments ------------------------------------
5021 : : !arrays
5022 : : type(elph_type),intent(in) :: elph_ds
5023 : : type(elph_tr_type),intent(inout) :: elph_tr_ds
5024 : :
5025 : : !Local variables-------------------------------
5026 : : !scalars
5027 : : integer :: ikpt_fine
5028 : : integer :: ib1,fib1,isppol, ii
5029 : : real(dp) :: eta2
5030 : : !arrays
5031 : : real(dp) :: elvelock(3)
5032 : :
5033 : : ! *********************************************************************
5034 : :
5035 [ - + ]: 5 : ABI_CHECK(allocated(elph_tr_ds%FSelecveloc_sq),"FSele not associated")
5036 : :
5037 : :
5038 : : !precalculate the Fermi speed modulus squared
5039 [ + + + + ]: 25 : elph_tr_ds%FSelecveloc_sq = zero
5040 [ + + ]: 10 : do isppol=1,elph_ds%nsppol
5041 [ + + ]: 429 : do ikpt_fine=1,elph_ds%k_fine%nkpt
5042 [ + + ]: 3197 : do ib1=1,elph_ds%nFSband
5043 : 2768 : fib1=ib1+elph_ds%minFSband-1
5044 [ + + ]: 11072 : elvelock(:)=elph_tr_ds%el_veloc(ikpt_fine,fib1,:,isppol)
5045 [ + + ]: 11496 : do ii=1, 3
5046 : 8304 : eta2=elvelock(ii)*elvelock(ii)
5047 : : elph_tr_ds%FSelecveloc_sq(ii, isppol)=elph_tr_ds%FSelecveloc_sq(ii, isppol)&
5048 : 11072 : & +eta2*elph_ds%k_fine%wtk(ib1,ikpt_fine,isppol)
5049 : : end do
5050 : : end do
5051 : : end do
5052 [ + + ]: 25 : elph_tr_ds%FSelecveloc_sq(:,isppol) = elph_tr_ds%FSelecveloc_sq(:,isppol)/elph_ds%k_fine%nkpt/elph_ds%n0(isppol)
5053 : : ! 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
5054 : : end do ! end isppol
5055 : 5 : write (std_out,*) ' get_veloc_tr: FSelecveloc_sq ', elph_tr_ds%FSelecveloc_sq
5056 : :
5057 : 5 : write (std_out,*) 'out of get_veloc_tr'
5058 : :
5059 : 5 : end subroutine get_veloc_tr
5060 : : !!***
5061 : :
5062 : : !!****f* ABINIT/integrate_gamma
5063 : : !!
5064 : : !! NAME
5065 : : !! integrate_gamma
5066 : : !!
5067 : : !! FUNCTION
5068 : : !! This routine integrates the electron phonon coupling matrix
5069 : : !! over the kpoints on the fermi surface. A dependency on qpoint
5070 : : !! remains for gamma_qpt
5071 : : !!
5072 : : !! INPUTS
5073 : : !! elph_ds = elphon datastructure with data and dimensions
5074 : : !! elph_ds%qpt_full = qpoint coordinates
5075 : : !! elph_ds%nqptirred = number of irred qpoints
5076 : : !! elph_ds%qirredtofull = indexing of the GKK qpoints found
5077 : : !! FSfullpqtofull = mapping of k+q to k
5078 : : !!
5079 : : !! OUTPUT
5080 : : !! elph_ds = modified elph_ds%gamma_qpt and created elph_ds%gamma_rpt
5081 : : !!
5082 : : !! SOURCE
5083 : :
5084 : 15 : subroutine integrate_gamma(elph_ds,FSfullpqtofull)
5085 : :
5086 : : !Arguments ------------------------------------
5087 : : !scalars
5088 : : type(elph_type),intent(inout) :: elph_ds
5089 : : !arrays
5090 : : integer,intent(in) :: FSfullpqtofull(elph_ds%k_phon%nkpt,elph_ds%nqpt_full)
5091 : :
5092 : : !Local variables-------------------------------
5093 : : !scalars
5094 : : integer :: comm,ikpt_phon,ikpt_phonq,ib1,ib2,ibeff,iqpt,iqpt_fullbz,isppol,ierr
5095 : : integer :: irec, symrankkpt_phon,nbranch,nsppol,ngkkband, ik_this_proc
5096 : : character(len=500) :: message
5097 : : character(len=fnlen) :: fname
5098 : : !arrays
5099 : 15 : real(dp),allocatable :: tmp_gkk(:,:,:,:)
5100 : : ! *************************************************************************
5101 : :
5102 : 15 : comm = xmpi_world
5103 : :
5104 : 15 : write (message,'(3a)')ch10,' entering integrate_gamma ',ch10
5105 : 15 : call wrtout(std_out,message,'COLL')
5106 : :
5107 : 15 : nsppol = elph_ds%nsppol
5108 : 15 : nbranch = elph_ds%nbranch
5109 : 15 : ngkkband = elph_ds%ngkkband
5110 : :
5111 [ - + + - : 75 : ABI_MALLOC(elph_ds%gamma_qpt,(2,nbranch**2,nsppol,elph_ds%nqpt_full))
- + + - -
+ + - + -
+ - - + -
+ - + ]
5112 [ + + + + : 5663 : elph_ds%gamma_qpt = zero
+ + + + ]
5113 : :
5114 [ - + + - : 75 : ABI_MALLOC(tmp_gkk ,(2,ngkkband**2,nbranch**2,nsppol))
- + + - -
+ + - + -
+ - - + -
+ - + ]
5115 : :
5116 [ + + ]: 15 : if (elph_ds%gkqwrite == 0) then
5117 : 14 : call wrtout(std_out,' integrate_gamma : keeping gamma matrices in memory','COLL')
5118 [ + - ]: 1 : else if (elph_ds%gkqwrite == 1) then
5119 [ + - ]: 1 : fname=trim(elph_ds%elph_base_name) // '_GKKQ'
5120 : 1 : write (message,'(2a)')' integrate_gamma : reading gamma matrices from file ',trim(fname)
5121 : 1 : call wrtout(std_out,message,'COLL')
5122 : : else
5123 : 0 : write (message,'(a,i0)')' Wrong value for gkqwrite = ',elph_ds%gkqwrite
5124 : 0 : ABI_BUG(message)
5125 : : end if
5126 : :
5127 : :
5128 : :
5129 [ + + ]: 63 : do iqpt=1,elph_ds%nqptirred
5130 : 48 : iqpt_fullbz = elph_ds%qirredtofull(iqpt)
5131 : 48 : symrankkpt_phon = elph_ds%k_phon%krank%get_rank (elph_ds%k_phon%kpt(:,iqpt_fullbz))
5132 : 48 : write (std_out,*) ' iqpt_fullbz in qpt grid only, rank ', iqpt_fullbz, symrankkpt_phon
5133 : :
5134 [ + + ]: 4143 : do ik_this_proc =1,elph_ds%k_phon%my_nkpt
5135 : 4080 : ikpt_phon = elph_ds%k_phon%my_ikpt(ik_this_proc)
5136 : :
5137 [ + + ]: 4080 : if (elph_ds%gkqwrite == 0) then
5138 [ + - + - : 4595856 : tmp_gkk = elph_ds%gkk_qpt(:,:,:,ik_this_proc,:,iqpt)
+ - + - -
+ - - + +
+ + + + +
+ ]
5139 [ + - ]: 192 : else if (elph_ds%gkqwrite == 1) then
5140 : 192 : irec = (iqpt-1)*elph_ds%k_phon%my_nkpt+ik_this_proc
5141 [ + + ]: 192 : if (ikpt_phon == 1) then
5142 : 3 : write (std_out,*) ' integrate_gamma read record ', irec
5143 : : end if
5144 : 192 : read (elph_ds%unitgkq,REC=irec) tmp_gkk(:,:,:,:)
5145 : : end if
5146 : :
5147 [ + + ]: 8232 : do isppol=1,nsppol
5148 : 4104 : ikpt_phonq = FSfullpqtofull(ikpt_phon,iqpt_fullbz)
5149 : : !
5150 [ + + ]: 20264 : do ib1=1,ngkkband
5151 [ + + ]: 82904 : do ib2=1,ngkkband
5152 : 66720 : ibeff = ib2+(ib1-1)*ngkkband
5153 : : elph_ds%gamma_qpt(:,:,isppol,iqpt_fullbz) = elph_ds%gamma_qpt(:,:,isppol,iqpt_fullbz) + &
5154 : : & tmp_gkk(:,ibeff,:,isppol)&
5155 [ + + + + ]: 4617392 : & *elph_ds%gkk_intweight(ib1,ikpt_phon,isppol)*elph_ds%gkk_intweight(ib2,ikpt_phonq,isppol)
5156 : : ! NOTE: if ngkkband==1 we are using trivial weights since average
5157 : : ! over bands was done in normsq_gkk (nmsq_gam_sumFS or nmsq_pure_gkk)
5158 : : end do ! ib2
5159 : : end do ! ib1
5160 : : end do ! isppol
5161 : : end do ! ikpt_phon
5162 : : end do ! iqpt
5163 : :
5164 : 15 : call xmpi_sum (elph_ds%gamma_qpt, comm, ierr)
5165 : :
5166 [ - + ]: 15 : ABI_FREE(tmp_gkk)
5167 : :
5168 : : !need prefactor of 1/nkpt for each integration over 1 kpoint index. NOT INCLUDED IN elph_ds%gkk_intweight
5169 [ + + ]: 63 : do iqpt=1,elph_ds%nqptirred
5170 : 48 : iqpt_fullbz = elph_ds%qirredtofull(iqpt)
5171 : : ! elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) = elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) / elph_ds%k_phon%nkpt / n0(1) / n0(1)
5172 : : ! elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) = elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) / elph_ds%k_phon%nkpt / elph_ds%k_phon%nkpt
5173 [ + + + + : 2463 : elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) = elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) * elph_ds%occ_factor / elph_ds%k_phon%nkpt
+ + ]
5174 : : end do
5175 : :
5176 : 15 : call wrtout(std_out,' integrate_gamma: gamma matrices have been calculated for recip space and irred qpoints ',"COLL")
5177 : :
5178 [ - + ]: 30 : end subroutine integrate_gamma
5179 : : !!***
5180 : :
5181 : : !!****f* ABINIT/integrate_gamma_tr
5182 : : !!
5183 : : !! NAME
5184 : : !! integrate_gamma_tr
5185 : : !!
5186 : : !! FUNCTION
5187 : : !! This routine integrates the TRANSPORT electron phonon coupling matrices
5188 : : !! over the kpoints on the fermi surface. A dependency on qpoint
5189 : : !! remains for gamma_qpt_in/out
5190 : : !! Copied from integrate_gamma
5191 : : !!
5192 : : !! INPUTS
5193 : : !! elph_ds = elphon datastructure with data and dimensions
5194 : : !! elph_ds%qpt_full = qpoint coordinates
5195 : : !! FSfullpqtofull = mapping of k+q to k
5196 : : !! veloc_sq1 = mean square electronic velocity on constant energy surface
5197 : : !! veloc_sq2 = mean square electronic velocity on constant energy surface
5198 : : !!
5199 : : !! OUTPUT
5200 : : !! elph_tr_ds%gamma_qpt_tr and created elph_tr_ds%gamma_rpt_tr
5201 : : !!
5202 : : !! SOURCE
5203 : :
5204 : 0 : subroutine integrate_gamma_tr(elph_ds,FSfullpqtofull,s1,s2, veloc_sq1,veloc_sq2,elph_tr_ds)
5205 : :
5206 : : !Arguments ------------------------------------
5207 : : !scalars
5208 : : integer,intent(in) :: s1,s2
5209 : : type(elph_tr_type), intent(inout) :: elph_tr_ds
5210 : : type(elph_type),intent(in) :: elph_ds
5211 : : !arrays
5212 : : integer,intent(in) :: FSfullpqtofull(elph_ds%k_phon%nkpt,elph_ds%nqpt_full)
5213 : : real(dp),intent(in) :: veloc_sq1(3,elph_ds%nsppol), veloc_sq2(3,elph_ds%nsppol)
5214 : :
5215 : : !Local variables-------------------------------
5216 : : !scalars
5217 : : integer :: ikpt_phon,ikpt_phonq,ib1,ib2,ibeff,ierr,iqpt,iqpt_fullbz,isppol
5218 : : integer :: itensor, icomp, jcomp,comm
5219 : : integer :: fib1, fib2
5220 : : integer :: ik_this_proc
5221 : : ! integer :: ikpttemp
5222 : : character(len=500) :: message
5223 : : real(dp) :: wtk, wtkpq, interm
5224 : : real(dp) :: veloc1_i, veloc1_j, veloc2_i, veloc2_j
5225 : : !arrays
5226 : : real(dp) :: elvelock(3), elvelockpq(3), velocwtk(3), velocwtkpq(3), vvelocwtk(3,3), vvelocwtkpq(3,3)
5227 : 0 : real(dp),allocatable :: tmp_gkk(:,:,:,:)
5228 : : ! *************************************************************************
5229 : :
5230 : 0 : comm = xmpi_world
5231 : :
5232 : : !information
5233 [ # # ]: 0 : if (elph_ds%gkqwrite == 0) then
5234 : 0 : write (message,'(a)')' integrate_gamma_tr : keeping gamma matrices in memory'
5235 : 0 : call wrtout(std_out,message,'COLL')
5236 [ # # ]: 0 : else if (elph_ds%gkqwrite == 1) then
5237 : 0 : write (message,'(a)')' integrate_gamma_tr : reading gamma matrices from disk'
5238 : 0 : call wrtout(std_out,message,'COLL')
5239 : : else
5240 : 0 : write (message,'(3a,i3)')' integrate_gamma_tr : BUG-',ch10,&
5241 : 0 : & ' Wrong value for gkqwrite = ',elph_ds%gkqwrite
5242 : 0 : ABI_BUG(message)
5243 : : end if
5244 : :
5245 : : !allocate temp variables
5246 [ # # # # : 0 : ABI_MALLOC_OR_DIE(tmp_gkk,(2,elph_ds%ngkkband**2,elph_ds%nbranch**2,elph_ds%nsppol), ierr)
# # # # #
# # # # #
# # # # #
# # # ]
5247 : :
5248 [ # # ]: 0 : do iqpt=1,elph_ds%nqptirred
5249 : 0 : iqpt_fullbz = elph_ds%qirredtofull(iqpt)
5250 : : ! write(std_out,*)'iqpt, iqptfullbz ',iqpt, iqpt_fullbz
5251 : :
5252 [ # # ]: 0 : do ik_this_proc =1,elph_ds%k_phon%my_nkpt
5253 : 0 : ikpt_phon = elph_ds%k_phon%my_ikpt(ik_this_proc)
5254 : :
5255 [ # # ]: 0 : if (elph_ds%gkqwrite == 0) then
5256 [ # # # # : 0 : tmp_gkk = elph_ds%gkk_qpt(:,:,:,ik_this_proc,:,iqpt)
# # # # #
# # # # #
# # # # #
# ]
5257 [ # # ]: 0 : else if (elph_ds%gkqwrite == 1) then
5258 : 0 : read(elph_ds%unitgkq,REC=((iqpt-1)*elph_ds%k_phon%my_nkpt+ik_this_proc)) tmp_gkk
5259 : : end if
5260 : :
5261 : 0 : ikpt_phonq = FSfullpqtofull(ikpt_phon,iqpt_fullbz)
5262 : :
5263 [ # # ]: 0 : do isppol=1,elph_ds%nsppol
5264 [ # # ]: 0 : do ib1=1,elph_ds%ngkkband !FS bands
5265 : 0 : fib1=ib1+elph_ds%minFSband-1 ! full bands
5266 [ # # ]: 0 : elvelock(:)=elph_tr_ds%el_veloc(ikpt_phon,fib1,:,isppol)
5267 : 0 : wtk=elph_tr_ds%tmp_gkk_intweight1(ib1,ikpt_phon,isppol)
5268 [ # # ]: 0 : velocwtk(:)=elph_tr_ds%tmp_velocwtk1(ib1,ikpt_phon,:,isppol)
5269 [ # # # # ]: 0 : vvelocwtk(:,:)=elph_tr_ds%tmp_vvelocwtk1(ib1,ikpt_phon,:,:,isppol)
5270 : :
5271 [ # # ]: 0 : do ib2=1,elph_ds%ngkkband ! FS bands
5272 : 0 : ibeff=ib2+(ib1-1)*elph_ds%ngkkband ! full bands
5273 : 0 : fib2=ib2+elph_ds%minFSband-1
5274 [ # # ]: 0 : elvelockpq(:)= elph_tr_ds%el_veloc(ikpt_phonq,fib2,:,isppol)
5275 : 0 : wtkpq=elph_tr_ds%tmp_gkk_intweight2(ib2,ikpt_phonq,isppol)
5276 [ # # ]: 0 : velocwtkpq(:)=elph_tr_ds%tmp_velocwtk2(ib2,ikpt_phonq,:,isppol)
5277 [ # # # # ]: 0 : vvelocwtkpq(:,:)=elph_tr_ds%tmp_vvelocwtk2(ib2,ikpt_phonq,:,:,isppol)
5278 : :
5279 : : ! MJV 31/03/2009: Note that the following is valid for any geometry, not just cubic!
5280 : : ! see eq 5 and 6 of prb 36 4103 (Al-Lehaibi et al 1987) [[cite:Al-Lehaibi1987]],
5281 : : ! see also Allen PRB 17 3725 [[cite:Allen1978]]
5282 : : ! generalization to tensorial quantities is simple, by keeping the directional
5283 : : ! references of velock and velockpq as indices.
5284 [ # # ]: 0 : do icomp = 1, 3
5285 [ # # ]: 0 : do jcomp = 1, 3
5286 : 0 : itensor = (icomp-1)*3+jcomp
5287 : : ! FIXME: could use symmetry i <-> j
5288 : :
5289 : 0 : veloc1_i = sqrt(veloc_sq1(icomp,isppol))
5290 : 0 : veloc1_j = sqrt(veloc_sq1(jcomp,isppol))
5291 : 0 : veloc2_i = sqrt(veloc_sq2(icomp,isppol))
5292 : 0 : veloc2_j = sqrt(veloc_sq2(jcomp,isppol))
5293 [ # # ]: 0 : if (elph_ds%use_k_fine == 1) then
5294 : : interm = vvelocwtk(icomp,jcomp)*wtkpq/veloc1_i/veloc1_j + &
5295 : : & s1*s2*vvelocwtkpq(icomp,jcomp)*wtk/veloc2_i/veloc2_j - &
5296 : : & s1*velocwtk(jcomp)*velocwtkpq(icomp)/veloc1_j/veloc2_i - &
5297 : 0 : & s2*velocwtk(icomp)*velocwtkpq(jcomp)/veloc1_i/veloc2_j
5298 : :
5299 : : elph_tr_ds%gamma_qpt_tr(:,itensor,:,isppol,iqpt_fullbz) = &
5300 : : & elph_tr_ds%gamma_qpt_tr(:,itensor,:,isppol,iqpt_fullbz) + &
5301 [ # # # # ]: 0 : & tmp_gkk(:,ibeff,:,isppol)*interm
5302 : : else
5303 : : elph_tr_ds%gamma_qpt_tr(:,itensor,:,isppol,iqpt_fullbz) = &
5304 : : & elph_tr_ds%gamma_qpt_tr(:,itensor,:,isppol,iqpt_fullbz) + &
5305 : : & tmp_gkk(:,ibeff,:,isppol) &
5306 : : & *(elvelock(icomp)/veloc1_i - s1*elvelockpq(icomp)/veloc2_i) &
5307 : : & *(elvelock(jcomp)/veloc1_j - s2*elvelockpq(jcomp)/veloc2_j) &
5308 [ # # # # ]: 0 : & *wtk*wtkpq
5309 : : end if
5310 : : end do
5311 : : end do
5312 : :
5313 : : end do
5314 : : end do
5315 : : end do ! isppol
5316 : :
5317 : : end do ! ik
5318 : : end do ! iq
5319 : :
5320 : 0 : call xmpi_sum (elph_tr_ds%gamma_qpt_tr, comm, ierr)
5321 : :
5322 [ # # ]: 0 : ABI_FREE(tmp_gkk)
5323 : :
5324 : :
5325 : : !need prefactor of 1/nkpt for each integration over 1 kpoint index.
5326 : : !NOT INCLUDED IN elph_ds%gkk_intweight
5327 : : !Add a factor of 1/2 for the cross terms of (v-v')(v-v')
5328 [ # # # # : 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
# # # # #
# ]
5329 : :
5330 : 0 : write (message,'(2a)')' integrate_gamma_tr : transport gamma matrices are calculated ',&
5331 : 0 : & ' in recip space and for irred qpoints'
5332 : : !call wrtout(std_out,message,'COLL')
5333 : :
5334 : 0 : end subroutine integrate_gamma_tr
5335 : : !!***
5336 : :
5337 : : !!****f* ABINIT/integrate_gamma_tr_lova
5338 : : !!
5339 : : !! NAME
5340 : : !! integrate_gamma_tr_lova
5341 : : !!
5342 : : !! FUNCTION
5343 : : !! This routine integrates the TRANSPORT electron phonon coupling matrices
5344 : : !! over the kpoints on the fermi surface. A dependency on qpoint
5345 : : !! remains for gamma_qpt_in/out
5346 : : !! Copied from integrate_gamma
5347 : : !!
5348 : : !! INPUTS
5349 : : !! elph_ds = elphon datastructure with data and dimensions
5350 : : !! elph_ds%qpt_full = qpoint coordinates
5351 : : !! FSfullpqtofull = mapping of k+q to k
5352 : : !!
5353 : : !! OUTPUT
5354 : : !! elph_tr_ds%gamma_qpt_trout
5355 : : !! elph_tr_ds%gamma_qpt_trin
5356 : : !!
5357 : : !! SOURCE
5358 : :
5359 : 5 : subroutine integrate_gamma_tr_lova(elph_ds,FSfullpqtofull,elph_tr_ds)
5360 : :
5361 : : !Arguments ------------------------------------
5362 : : !scalars
5363 : : type(elph_tr_type), intent(inout) :: elph_tr_ds
5364 : : type(elph_type),intent(in) :: elph_ds
5365 : : !arrays
5366 : : integer,intent(in) :: FSfullpqtofull(elph_ds%k_phon%nkpt,elph_ds%nqpt_full)
5367 : :
5368 : : !Local variables-------------------------------
5369 : : !scalars
5370 : : integer :: ikpt_phon,ikpt_phonq,ib1,ib2,ibeff,ierr,iqpt,iqpt_fullbz,isppol
5371 : : integer :: itensor, icomp, jcomp,comm
5372 : : integer :: fib1, fib2
5373 : : integer :: ik_this_proc
5374 : : real(dp) :: etain, etaout
5375 : : character(len=500) :: message
5376 : : !arrays
5377 : : real(dp) :: elvelock(3), elvelockpq(3)
5378 : 5 : real(dp),allocatable :: tmp_gkk(:,:,:,:)
5379 : : ! *************************************************************************
5380 : :
5381 : 5 : comm = xmpi_world
5382 : :
5383 : 5 : ib1=elph_ds%nbranch*elph_ds%nbranch ; ib2=elph_ds%nqpt_full
5384 [ - + + - : 25 : ABI_MALLOC_OR_DIE(elph_tr_ds%gamma_qpt_trin,(2,9,ib1,elph_ds%nsppol,ib2), ierr)
- + + - -
+ + - + -
+ - + - +
- - + + -
- + ]
5385 [ + + + + : 28309 : elph_tr_ds%gamma_qpt_trin = zero
+ + + + +
+ ]
5386 : :
5387 [ - + + - : 25 : ABI_MALLOC_OR_DIE(elph_tr_ds%gamma_qpt_trout,(2,9,ib1,elph_ds%nsppol,ib2), ierr)
- + + - -
+ + - + -
+ - + - +
- - + + -
- + ]
5388 [ + + + + : 28309 : elph_tr_ds%gamma_qpt_trout = zero
+ + + + +
+ ]
5389 : :
5390 : : !information
5391 [ + - ]: 5 : if (elph_ds%gkqwrite == 0) then
5392 : 5 : write (message,'(a)')' integrate_gamma_tr : keeping gamma matrices in memory'
5393 : 5 : call wrtout(std_out,message,'COLL')
5394 [ # # ]: 0 : else if (elph_ds%gkqwrite == 1) then
5395 : 0 : write (message,'(a)')' integrate_gamma_tr : reading gamma matrices from disk'
5396 : 0 : call wrtout(std_out,message,'COLL')
5397 : : else
5398 : 0 : write (message,'(3a,i3)')' integrate_gamma_tr : BUG-',ch10,&
5399 : 0 : & ' Wrong value for gkqwrite = ',elph_ds%gkqwrite
5400 : 0 : ABI_ERROR(message)
5401 : : end if
5402 : :
5403 : : !allocate temp variables
5404 [ - + + - : 25 : ABI_MALLOC_OR_DIE(tmp_gkk,(2,elph_ds%ngkkband**2,elph_ds%nbranch**2,elph_ds%nsppol), ierr)
- + + - -
+ + - + -
+ - + - -
+ - + ]
5405 : :
5406 [ + + ]: 23 : do iqpt=1,elph_ds%nqptirred
5407 : 18 : iqpt_fullbz = elph_ds%qirredtofull(iqpt)
5408 : 18 : write(std_out,*)'iqpt, iqptfullbz ',iqpt, iqpt_fullbz
5409 : :
5410 [ + + ]: 1439 : do ik_this_proc =1,elph_ds%k_phon%my_nkpt
5411 : 1416 : ikpt_phon = elph_ds%k_phon%my_ikpt(ik_this_proc)
5412 : :
5413 [ + - ]: 1416 : if (elph_ds%gkqwrite == 0) then
5414 [ + - + - : 4498560 : tmp_gkk = elph_ds%gkk_qpt(:,:,:,ik_this_proc,:,iqpt)
+ - + - -
+ - - + +
+ + + + +
+ ]
5415 [ # # ]: 0 : else if (elph_ds%gkqwrite == 1) then
5416 : 0 : read(elph_ds%unitgkq,REC=((iqpt-1)*elph_ds%k_phon%my_nkpt+ik_this_proc)) tmp_gkk
5417 : : end if
5418 : :
5419 : 1416 : ikpt_phonq = FSfullpqtofull(ikpt_phon,iqpt_fullbz)
5420 : :
5421 [ + + ]: 2850 : do isppol=1,elph_ds%nsppol
5422 [ + + ]: 12224 : do ib1=1,elph_ds%ngkkband
5423 : 9392 : fib1=ib1+elph_ds%minFSband-1
5424 [ + + ]: 37568 : elvelock(:)=elph_tr_ds%el_veloc(ikpt_phon,fib1,:,isppol)
5425 : :
5426 [ + + ]: 74840 : do ib2=1,elph_ds%ngkkband
5427 : 64032 : ibeff=ib2+(ib1-1)*elph_ds%ngkkband
5428 : 64032 : fib2=ib2+elph_ds%minFSband-1
5429 [ + + ]: 256128 : elvelockpq(:)= elph_tr_ds%el_veloc(ikpt_phonq,fib2,:,isppol)
5430 : :
5431 : :
5432 : : ! MJV 31/03/2009: Note that the following is valid for any geometry, not just cubic!
5433 : : ! see eq 5 and 6 of prb 36 4103 (Al-Lehaibi et al 1987) [[cite:Al-Lehaibi1987]]
5434 : : ! see also Allen PRB 17 3725 [[cite:Allen1978]]
5435 : : ! generalization to tensorial quantities is simple, by keeping the directional
5436 : : ! references of velock and velockpq as indices.
5437 [ + + ]: 265520 : do icomp = 1, 3
5438 [ + + ]: 832416 : do jcomp = 1, 3
5439 : 576288 : itensor = (icomp-1)*3+jcomp
5440 : : ! FIXME: could use symmetry i <-> j
5441 : :
5442 : 576288 : etain = elvelock(icomp)*elvelockpq(jcomp)
5443 : 576288 : etaout = elvelock(icomp)*elvelock(jcomp)
5444 : :
5445 : :
5446 : : elph_tr_ds%gamma_qpt_trin(:,itensor,:,isppol,iqpt_fullbz) = &
5447 : : & elph_tr_ds%gamma_qpt_trin(:,itensor,:,isppol,iqpt_fullbz) + &
5448 : : & tmp_gkk(:,ibeff,:,isppol) &
5449 : : & *etain &
5450 [ + + + + ]: 40770432 : & *elph_ds%gkk_intweight(ib1,ikpt_phon,isppol)*elph_ds%gkk_intweight(ib2,ikpt_phonq,isppol)
5451 : :
5452 : : elph_tr_ds%gamma_qpt_trout(:,itensor,:,isppol,iqpt_fullbz) = &
5453 : : & elph_tr_ds%gamma_qpt_trout(:,itensor,:,isppol,iqpt_fullbz) + &
5454 : : & tmp_gkk(:,ibeff,:,isppol) &
5455 : : & *etaout &
5456 [ + + + + ]: 40962528 : & *elph_ds%gkk_intweight(ib1,ikpt_phon,isppol)*elph_ds%gkk_intweight(ib2,ikpt_phonq,isppol)
5457 : :
5458 : : end do
5459 : : end do
5460 : : end do
5461 : : end do
5462 : :
5463 : : end do ! isppol
5464 : : end do ! ik
5465 : :
5466 : : end do ! iq
5467 : :
5468 [ - + ]: 5 : ABI_FREE(tmp_gkk)
5469 : :
5470 : 5 : call xmpi_sum (elph_tr_ds%gamma_qpt_trout, comm, ierr)
5471 : 5 : call xmpi_sum (elph_tr_ds%gamma_qpt_trin, comm, ierr)
5472 : :
5473 : :
5474 : : !
5475 : : !normalize tensor with 1/sqrt(v_x**2 * v_y**2)
5476 : : !
5477 : : !move the veloc into mka2f_tr_lova, where T dependence is dealt with
5478 : : !This will cause some slight difference to the results
5479 : : if (.true.) then
5480 [ + + ]: 10 : do isppol=1, elph_ds%nsppol
5481 [ + + ]: 25 : do icomp = 1, 3
5482 [ + + ]: 65 : do jcomp = 1, 3
5483 : 45 : itensor = (icomp-1)*3+jcomp
5484 [ + + + + ]: 60 : if(abs(elph_tr_ds%FSelecveloc_sq(icomp,isppol))>tol14**2 .and. abs(elph_tr_ds%FSelecveloc_sq(jcomp,isppol))>tol14**2)then
5485 : : elph_tr_ds%gamma_qpt_trin(:,itensor,:,isppol,:) = elph_tr_ds%gamma_qpt_trin(:,itensor,:,isppol,:) / &
5486 [ + + + + : 20637 : & sqrt(elph_tr_ds%FSelecveloc_sq(icomp,isppol)*elph_tr_ds%FSelecveloc_sq(jcomp,isppol))
+ + ]
5487 : : elph_tr_ds%gamma_qpt_trout(:,itensor,:,isppol,:) = elph_tr_ds%gamma_qpt_trout(:,itensor,:,isppol,:) / &
5488 [ + + + + : 20637 : & sqrt(elph_tr_ds%FSelecveloc_sq(icomp,isppol)*elph_tr_ds%FSelecveloc_sq(jcomp,isppol))
+ + ]
5489 : : else
5490 : : ! XG120528 Fixed problem with zero velocity
5491 [ + + + + : 6984 : elph_tr_ds%gamma_qpt_trin(:,itensor,:,isppol,:)=zero
+ + ]
5492 [ + + + + : 6984 : elph_tr_ds%gamma_qpt_trout(:,itensor,:,isppol,:)=zero
+ + ]
5493 : : end if
5494 : : end do
5495 : : end do
5496 : : end do ! isppol
5497 : : end if
5498 : :
5499 : : !need prefactor of 1/nkpt for each integration over 1 kpoint index.
5500 : : !NOT INCLUDED IN elph_ds%gkk_intweight
5501 [ + + + + : 28309 : elph_tr_ds%gamma_qpt_trout = elph_tr_ds%gamma_qpt_trout* elph_ds%occ_factor / elph_ds%k_phon%nkpt
+ + + + +
+ ]
5502 [ + + + + : 28309 : elph_tr_ds%gamma_qpt_trin = elph_tr_ds%gamma_qpt_trin * elph_ds%occ_factor / elph_ds%k_phon%nkpt
+ + + + +
+ ]
5503 : :
5504 : 5 : write (message,'(2a)')' integrate_gamma_tr : transport gamma matrices are calculated ',&
5505 : 10 : & ' in recip space and for irred qpoints'
5506 : 5 : call wrtout(std_out,message,'COLL')
5507 : :
5508 : : !DEBUG
5509 : : !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)
5510 : : !ENDDEBUG
5511 : :
5512 : 5 : end subroutine integrate_gamma_tr_lova
5513 : : !!***
5514 : :
5515 : : !!****f* ABINIT/ftgkk
5516 : : !!
5517 : : !! NAME
5518 : : !! ftgkk
5519 : : !!
5520 : : !! FUNCTION
5521 : : !! If qtor=1 (q->r):
5522 : : !! Generates the Fourier transform of the recip space gkk matrices
5523 : : !! to obtain the real space ones.
5524 : : !! If qtor=0 (r->q):
5525 : : !! Generates the Fourier transform of the real space gkk matrices
5526 : : !! to obtain the reciprocal space ones.
5527 : : !!
5528 : : !! INPUTS
5529 : : !! gkqwrite = flag to write recip space matrix elements to disk
5530 : : !! gkrwrite = flag to write real space matrix elements to disk
5531 : : !! gprim(3,3)= Normalized coordinates in reciprocal space
5532 : : !! ikpt_phon0 = starting kpt number for forward FT.
5533 : : !! natom= Number of atoms in the unit cell
5534 : : !! nkpt_phon= Number of kpoints used for the FS
5535 : : !! ngkkband = number of bands kept in gkq and gkr matrix elements (=1 or nband)
5536 : : !! nkpt_used= number of FS kpoints used, starting at ikpt_phon0
5537 : : !! nqpt= Number of q points in the Brillouin zone
5538 : : !! if qtor=0 this number is read in the input file
5539 : : !! nrpt= Number of R points in the Big Box
5540 : : !! qtor= ( q to r : see above )
5541 : : !! rpt(3,nprt)= Canonical coordinates of the R points in the unit cell
5542 : : !! These coordinates are normalized (=> * acell(3)!!)
5543 : : !! qpt_full(3,nqpt)= Reduced coordinates of the q vectors in reciprocal space
5544 : : !! if qtor=0 these vectors are read in the input file
5545 : : !! unit_gkk_rpt = fortran unit for writing real-space matrix elements
5546 : : !! unitgkq = fortran unit for writing reciprocal-space matrix elements
5547 : : !! wghatm(natom,natom,nrpt)
5548 : : !! = Weights associated to a pair of atoms and to a R vector
5549 : : !!
5550 : : !! OUTPUT
5551 : : !! (see side effects)
5552 : : !!
5553 : : !! SIDE EFFECTS
5554 : : !! Input/output
5555 : : !! gkk_qpt(2,3*natom,nFSband,nFSband,nkpt_used,nqpt)
5556 : : !! = gkk matrices in recip space coming from the Derivative Data Base
5557 : : !! gkk_rpt(2,3*natom,nFSband,nFSband,nkpt_phon,nqpt)
5558 : : !! = gkk matrices in real space stored in file unit_gkk_rpt
5559 : : !!
5560 : : !! NOTES
5561 : : !! copied from ftiaf9.f
5562 : : !! recip to real space: real space is forced to disk file unit_gkk_rpt
5563 : : !! recip space depends on gkqwrite and unitgkq
5564 : : !! real to recip space: real space is forced to disk file unit_gkk_rpt
5565 : : !! recip space is necessarily in memory in gkk_qpt
5566 : : !!
5567 : : !! real space elements are complex, but could be reduced, as (-r) = (+r)*
5568 : : !!
5569 : : !! SOURCE
5570 : :
5571 : : subroutine ftgkk (wghatm,gkk_qpt,gkk_rpt,gkqwrite,gkrwrite,gprim,ikpt_phon0,&
5572 : : & natom,nkpt_phon,ngkkband,nkpt_used,nqpt,nrpt,nsppol,&
5573 : : & qtor,rpt,qpt_full,unit_gkk_rpt,unitgkq)
5574 : :
5575 : : !Arguments -------------------------------
5576 : : !scalars
5577 : : integer,intent(in) :: gkqwrite,gkrwrite,ikpt_phon0,nkpt_phon,natom,ngkkband
5578 : : integer,intent(in) :: nkpt_used,nqpt,nrpt,nsppol,qtor,unit_gkk_rpt,unitgkq
5579 : : !arrays
5580 : : real(dp),intent(in) :: gprim(3,3),rpt(3,nrpt),qpt_full(3,nqpt)
5581 : : real(dp),intent(in) :: wghatm(natom,natom,nrpt)
5582 : : real(dp),intent(inout) :: gkk_qpt(2,ngkkband*ngkkband,3*natom*3*natom,nkpt_used,nsppol,nqpt)
5583 : : real(dp),intent(inout) :: gkk_rpt(2,ngkkband*ngkkband,3*natom*3*natom,nkpt_used,nsppol,nrpt)
5584 : :
5585 : : !Local variables -------------------------
5586 : : !scalars
5587 : : integer :: ikpt_phon,iatom,ib1,ieffkpt_phon,ip,iqpt,irpt,isppol
5588 : : integer :: jatom
5589 : : real(dp) :: im,kr,re
5590 : : character(len=500) :: message
5591 : : !arrays
5592 : : real(dp) :: coskr(nqpt,nrpt),ftwght(2,3*natom*3*natom)
5593 : : real(dp) :: gkk_qpt_tmp(2,ngkkband*ngkkband,3*natom*3*natom,nkpt_used,nsppol)
5594 : : real(dp) :: gkk_rpt_tmp(2,ngkkband*ngkkband,3*natom*3*natom,nkpt_phon,nsppol)
5595 : : real(dp) :: kk(3),sinkr(nqpt,nrpt)
5596 : :
5597 : : ! *********************************************************************
5598 : :
5599 : : !rewind (unit_gkk_rpt)
5600 : :
5601 : : !prepare the phase factors
5602 : : do iqpt=1,nqpt
5603 : : ! Calculation of the k coordinates in Normalized Reciprocal
5604 : : ! coordinates
5605 : : kk(1)= qpt_full(1,iqpt)*gprim(1,1)+&
5606 : : & qpt_full(2,iqpt)*gprim(1,2)+&
5607 : : & qpt_full(3,iqpt)*gprim(1,3)
5608 : : kk(2)= qpt_full(1,iqpt)*gprim(2,1)+&
5609 : : & qpt_full(2,iqpt)*gprim(2,2)+&
5610 : : & qpt_full(3,iqpt)*gprim(2,3)
5611 : : kk(3)= qpt_full(1,iqpt)*gprim(3,1)+&
5612 : : & qpt_full(2,iqpt)*gprim(3,2)+&
5613 : : & qpt_full(3,iqpt)*gprim(3,3)
5614 : : do irpt=1,nrpt
5615 : : ! Product of k and r
5616 : : kr = kk(1)*rpt(1,irpt)+&
5617 : : & kk(2)*rpt(2,irpt)+&
5618 : : & kk(3)*rpt(3,irpt)
5619 : : coskr(iqpt,irpt)=cos(two_pi*kr)
5620 : : sinkr(iqpt,irpt)=sin(two_pi*kr)
5621 : : ! DEBUG
5622 : : ! if (iqpt < 1000 .and. (irpt == 101 .or. irpt == 901)) then
5623 : : ! write(std_out,*) iqpt,irpt,kk,rpt(:,irpt),coskr(iqpt,irpt), sinkr(iqpt,irpt)
5624 : : ! end if
5625 : : ! ENDDEBUG
5626 : : end do
5627 : : end do
5628 : :
5629 : :
5630 : :
5631 : : !Recip to real space
5632 : : if (qtor==1) then
5633 : : !
5634 : : if (nkpt_used /= nkpt_phon) write(std_out,*) 'ftgkk: strange usage of nkpt_used for back FT!'
5635 : : do irpt=1,nrpt
5636 : : ! DEBUG
5637 : : ! write(std_out,*) ' ftgkk : G->R irpt = ',irpt,' / ',nrpt
5638 : : ! ENDDEBUG
5639 : : gkk_rpt_tmp(:,:,:,:,:) = zero
5640 : :
5641 : : do iqpt=1,nqpt
5642 : :
5643 : : ! write(std_out,*) iqpt
5644 : :
5645 : : if (gkqwrite == 0) then
5646 : : gkk_qpt_tmp(:,:,:,:,:) = gkk_qpt(:,:,:,:,:,iqpt)
5647 : : else
5648 : : do ikpt_phon=1, nkpt_phon
5649 : : read(unitgkq,REC=((iqpt-1)*nkpt_phon+ikpt_phon)) gkk_qpt_tmp(:,:,:,ikpt_phon,:)
5650 : : end do
5651 : : end if
5652 : : ! Get the phase factor with normalization!
5653 : : re=coskr(iqpt,irpt)/nqpt
5654 : : im=sinkr(iqpt,irpt)/nqpt
5655 : : do isppol=1,nsppol
5656 : : do ikpt_phon=1,nkpt_used
5657 : : ! DEBUG
5658 : : ! write(std_out,*) ' ftgkk : G->R ikpt_phon = ',ikpt_phon,' / ',nkpt_used
5659 : : ! ENDDEBUG
5660 : : do ip=1,3*natom*3*natom
5661 : : ! Real and imaginary part of the real-space gkk matrices -> exp(-i k.r)
5662 : : do ib1=1,ngkkband*ngkkband
5663 : : gkk_rpt_tmp(1,ib1,ip,ikpt_phon,isppol) = gkk_rpt_tmp(1,ib1,ip,ikpt_phon,isppol)&
5664 : : & +re*gkk_qpt_tmp(1,ib1,ip,ikpt_phon,isppol) &
5665 : : & +im*gkk_qpt_tmp(2,ib1,ip,ikpt_phon,isppol)
5666 : : gkk_rpt_tmp(2,ib1,ip,ikpt_phon,isppol) = gkk_rpt_tmp(2,ib1,ip,ikpt_phon,isppol)&
5667 : : & +re*gkk_qpt_tmp(2,ib1,ip,ikpt_phon,isppol) &
5668 : : & -im*gkk_qpt_tmp(1,ib1,ip,ikpt_phon,isppol)
5669 : : end do
5670 : : end do
5671 : : end do
5672 : : end do
5673 : : end do
5674 : : if (gkrwrite == 0) then
5675 : : gkk_rpt(:,:,:,:,:,irpt) = gkk_rpt_tmp(:,:,:,:,:)
5676 : : else
5677 : : write (unit_gkk_rpt,REC=irpt) gkk_rpt_tmp
5678 : : end if
5679 : : end do
5680 : :
5681 : : ! Real space to recip space
5682 : : else if (qtor==0) then
5683 : :
5684 : : ! write(std_out,*) 'ftgkk : shape(gkk_qpt) = ', shape(gkk_qpt)
5685 : : gkk_qpt(:,:,:,:,:,:)=zero
5686 : :
5687 : : ! rewind (unit_gkk_rpt)
5688 : : do irpt=1,nrpt
5689 : : if (gkrwrite == 0) then
5690 : : gkk_rpt_tmp(:,:,:,:,:) = gkk_rpt(:,:,:,:,:,irpt)
5691 : : else
5692 : : read(unit_gkk_rpt,REC=irpt) gkk_rpt_tmp
5693 : : end if
5694 : :
5695 : :
5696 : : do iqpt=1,nqpt
5697 : :
5698 : : ! Avoid recalculating weights nkpt_used*9 times
5699 : : do iatom=1,natom
5700 : : do jatom=1,natom
5701 : : ip = 3*((iatom-1)*natom+jatom-1)
5702 : : ! copy same weight for all 3 directions
5703 : : ftwght(1,ip+1:ip+3)=coskr(iqpt,irpt)*wghatm(iatom,jatom,irpt)
5704 : : ftwght(2,ip+1:ip+3)=sinkr(iqpt,irpt)*wghatm(iatom,jatom,irpt)
5705 : : end do
5706 : : end do
5707 : :
5708 : :
5709 : :
5710 : : do ip=1,3*natom*3*natom
5711 : : ! Get phase factor
5712 : : re = ftwght(1,ip)
5713 : : im = ftwght(2,ip)
5714 : :
5715 : : do isppol=1,nsppol
5716 : : do ikpt_phon=1,nkpt_used
5717 : :
5718 : :
5719 : : ! DEBUG
5720 : : ! write(std_out,*) ' ftgkk : R->G ikpt_phon = ',ikpt_phon,' / ',nkpt_used
5721 : : ! ENDDEBUG
5722 : : ! effective FS kpt in real space array is ikpt_phon+ikpt_phon0-1 to allow for offset
5723 : : ieffkpt_phon = ikpt_phon+ikpt_phon0-1
5724 : : ! write(std_out,*) 'ftgkk :ikpt_phon,iqpt,ieffkpt_phon ', ikpt_phon,iqpt,ieffkpt_phon
5725 : :
5726 : : do ib1=1,ngkkband*ngkkband
5727 : : ! Real and imaginary part of the gamma matrices
5728 : : gkk_qpt(1,ib1,ip,ikpt_phon,isppol,iqpt)=&
5729 : : & gkk_qpt(1,ib1,ip,ikpt_phon,isppol,iqpt)&
5730 : : & +re*gkk_rpt_tmp(1,ib1,ip,ieffkpt_phon,isppol)&
5731 : : & -im*gkk_rpt_tmp(2,ib1,ip,ieffkpt_phon,isppol)
5732 : : ! !DEBUG
5733 : : gkk_qpt(2,ib1,ip,ikpt_phon,isppol,iqpt)=&
5734 : : & gkk_qpt(2,ib1,ip,ikpt_phon,isppol,iqpt)&
5735 : : & +im*gkk_rpt_tmp(1,ib1,ip,ieffkpt_phon,isppol)&
5736 : : & +re*gkk_rpt_tmp(2,ib1,ip,ieffkpt_phon,isppol)
5737 : : ! !ENDDEBUG
5738 : :
5739 : : ! if (iqpt < 100 .and. irpt < 100 .and. &
5740 : : ! & tmpgkkrim(irpt)**2+tmpgkkrre(irpt)**2 > tol6) then
5741 : : ! write(std_out,'(2I4,2E16.8,x,2E16.8)') &
5742 : : ! & iqpt,irpt,re,im,tmpgkkrre(irpt),tmpgkkrim(irpt)
5743 : : ! end if
5744 : :
5745 : : end do
5746 : : end do
5747 : : ! end ikpt_phon
5748 : : end do
5749 : : ! end isppol
5750 : : ! write(std_out,'(a)') ' ftgkk :gkk_qpt :'
5751 : : ! write(std_out,'(4E16.5)') gkk_qpt(:,1,1,,ikpt_phon,1:nqpt)
5752 : : end do
5753 : : ! end ip
5754 : : end do
5755 : : ! end iqpt
5756 : : end do
5757 : : ! end irpt
5758 : :
5759 : :
5760 : : ! There is no other space to Fourier transform from ??
5761 : : else
5762 : : write(message,'(a,a,a,i0,a)' )&
5763 : : & 'The only allowed values for qtor are 0 or 1, while',ch10,&
5764 : : & 'qtor=',qtor,' has been required.'
5765 : : ABI_BUG(message)
5766 : : end if
5767 : :
5768 : : end subroutine ftgkk
5769 : : !!***
5770 : :
5771 : : end module m_elphon
5772 : : !!***
|
