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