TABLE OF CONTENTS


ABINIT/complete_gkk [ Functions ]

[ Top ] [ 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

PARENTS

      get_all_gkq

CHILDREN

      xmpi_sum,zgemm

SOURCE

4318 subroutine complete_gkk(elph_ds,gkk_flag,gprimd,indsym,natom,nsym,qpttoqpt,rprimd,symrec,symrel)
4319 
4320 
4321 !This section has been created automatically by the script Abilint (TD).
4322 !Do not modify the following lines by hand.
4323 #undef ABI_FUNC
4324 #define ABI_FUNC 'complete_gkk'
4325 !End of the abilint section
4326 
4327  implicit none
4328 
4329 !Arguments ------------------------------------
4330 !scalars
4331  integer,intent(in) :: natom,nsym
4332  type(elph_type),intent(inout) :: elph_ds
4333 !arrays
4334  integer,intent(in) :: indsym(4,nsym,natom)
4335  integer,intent(in) :: qpttoqpt(2,nsym,elph_ds%nqpt_full),symrec(3,3,nsym)
4336  integer,intent(in) :: symrel(3,3,nsym)
4337  integer,intent(inout) :: gkk_flag(elph_ds%nbranch,elph_ds%nbranch,elph_ds%k_phon%my_nkpt,elph_ds%nsppol,elph_ds%nqpt_full)
4338  real(dp),intent(in) :: gprimd(3,3)
4339  real(dp),intent(in) :: rprimd(3,3)
4340 
4341 !Local variables-------------------------------
4342 !scalars
4343  integer :: ikpt_phon,ib1,ibranch,ieqqpt,ii, ierr,comm
4344  integer :: iqpt,isppol,isym
4345  integer :: itim,jbranch,jj,kk,ll
4346  integer :: neqqpt,symikpt_phon
4347  integer :: iatom,ancestor_iatom
4348  integer :: ik_this_proc, me,sz1,sz2
4349 
4350  real(dp),parameter :: tol=2.d-8
4351 !arrays
4352  integer :: symmetrized_qpt(elph_ds%nqpt_full)
4353  real(dp) :: ss(3,3)
4354  real(dp) :: tmp_mat(2,elph_ds%nbranch,elph_ds%nbranch)
4355  real(dp) :: tmp_mat2(2,elph_ds%nbranch,elph_ds%nbranch)
4356  real(dp),allocatable :: gkk_qpt_new(:,:,:,:,:),gkk_qpt_tmp(:,:,:,:,:)
4357 
4358  real(dp) :: ss_allatoms(2,elph_ds%nbranch,elph_ds%nbranch)
4359  real(dp) :: c_one(2), c_zero(2)
4360 
4361 
4362 ! *********************************************************************
4363 
4364  c_one = (/one,zero/)
4365  c_zero = (/zero,zero/)
4366 
4367 !Generation of the gkk matrices relative to the q points
4368 !of the set which samples the entire Brillouin zone
4369 
4370  comm = xmpi_world
4371  me = xmpi_comm_rank(comm)
4372 
4373  symmetrized_qpt(:) = -1
4374 
4375 !FIXME bxu, why set it to 1?
4376 !isppol=1
4377 
4378  sz1=elph_ds%ngkkband*elph_ds%ngkkband
4379  sz2=elph_ds%nbranch*elph_ds%nbranch
4380 
4381 !these arrays are not parallelized, to enable symmetrization: syms swap k-points.
4382  ABI_ALLOCATE(gkk_qpt_new,(2,sz1,sz2,elph_ds%k_phon%nkpt,elph_ds%nsppol))
4383  ABI_ALLOCATE(gkk_qpt_tmp,(2,sz1,sz2,elph_ds%k_phon%nkpt,elph_ds%nsppol))
4384 
4385  do iqpt=1,elph_ds%nqpt_full
4386 
4387 !  Already symmetrized?
4388    if (symmetrized_qpt(iqpt) == 1) cycle
4389 
4390    gkk_qpt_new(:,:,:,:,:) = zero
4391 !   gkk_qpt_tmp(:,:,:,:,:) = zero
4392 
4393 !  loop over qpoints equivalent to iqpt
4394    neqqpt=0
4395 !  do not use time reversal symmetry to complete the qpoints:
4396 !  do not know what happens to the gamma matrices
4397 !  itim=1
4398 
4399    do itim=1,2
4400      do isym=1,nsym
4401 !      ieqqpt is sent onto iqpt by itim/isym
4402        ieqqpt = qpttoqpt(itim,isym,iqpt)
4403        gkk_qpt_tmp(:,:,:,:,:) = zero
4404 
4405 
4406        if (gkk_flag(1,1,1,1,ieqqpt) == -1) cycle
4407 !      if we have information on this qpt
4408 !      iqpt is equivalent to ieqqpt: get it from file or memory
4409        do ik_this_proc =1,elph_ds%k_phon%my_nkpt
4410          ikpt_phon = elph_ds%k_phon%my_ikpt(ik_this_proc)
4411 
4412          if (elph_ds%gkqwrite == 0) then
4413            gkk_qpt_tmp(:,:,:,ikpt_phon,:) = elph_ds%gkk_qpt(:,:,:,ik_this_proc,:,ieqqpt)
4414          else if (elph_ds%gkqwrite == 1) then
4415            read(elph_ds%unitgkq,REC=((ieqqpt-1)*elph_ds%k_phon%my_nkpt+ik_this_proc)) gkk_qpt_tmp(:,:,:,ikpt_phon,:)
4416          end if
4417        end do
4418 
4419 !      condense everything
4420        call xmpi_sum (gkk_qpt_tmp, comm, ierr)
4421 
4422        neqqpt=neqqpt+1
4423 
4424        if (elph_ds%ep_scalprod==1) then
4425          do ii=1,3
4426            do jj=1,3
4427              ss(ii,jj)=0.0_dp
4428              do kk=1,3
4429                do ll=1,3
4430                  ss(ii,jj)=ss(ii,jj)+rprimd(ii,kk)*symrel(kk,ll,isym)*gprimd(ll,jj)
4431                end do
4432              end do
4433            end do
4434          end do
4435        else
4436          do ii=1,3
4437            do jj=1,3
4438              ss(ii,jj) = symrec(jj,ii,isym)
4439            end do
4440          end do
4441        end if
4442 
4443        ss_allatoms(:,:,:) = zero
4444        do iatom=1,natom
4445          ancestor_iatom = indsym(4,isym,iatom)
4446 !        do jatom=1,natom
4447 !        ancestor_jatom = indsym(4,isym,jatom)
4448          ss_allatoms(1,(ancestor_iatom-1)*3+1:(ancestor_iatom-1)*3+3,&
4449 &         (iatom-1)*3+1:         (iatom-1)*3+3) = ss(1:3,1:3)
4450 !        end do
4451        end do
4452 
4453 
4454 !      NOTE   ssinv(ii,jj)=ssinv(ii,jj)+gprimd(ii,kk)*rprimd(jj,ll)*symrec(ll,kk,isym)
4455 
4456        do isppol=1,elph_ds%nsppol
4457          do ikpt_phon=1,elph_ds%k_phon%nkpt
4458 !          symikpt_phon is sent onto ikpt_phon by itim/isym
4459            symikpt_phon=elph_ds%k_phon%full2full(itim,isym,ikpt_phon)
4460 
4461 !          Do each element band1, band2 separately...
4462            do ib1=1,elph_ds%ngkkband*elph_ds%ngkkband
4463 
4464 !            multiply by the ss matrices
4465              tmp_mat2(:,:,:) = zero
4466              tmp_mat(:,:,:) = reshape(gkk_qpt_tmp(:,ib1,:,ikpt_phon,isppol),&
4467 &             (/2,elph_ds%nbranch,elph_ds%nbranch/))
4468              call ZGEMM ('N','N',elph_ds%nbranch,elph_ds%nbranch,elph_ds%nbranch,&
4469 &             c_one,ss_allatoms,elph_ds%nbranch,tmp_mat,elph_ds%nbranch,c_zero,&
4470 &             tmp_mat2,elph_ds%nbranch)
4471              call ZGEMM ('N','T',elph_ds%nbranch,elph_ds%nbranch,elph_ds%nbranch,&
4472 &             c_one,tmp_mat2,elph_ds%nbranch,ss_allatoms,elph_ds%nbranch,c_zero,&
4473 &             tmp_mat,elph_ds%nbranch)
4474 
4475 !            add to gkk_qpt_new
4476              do ibranch =1,elph_ds%nbranch
4477                do jbranch =1,elph_ds%nbranch
4478                  gkk_qpt_new(:,ib1,(jbranch-1)*elph_ds%nbranch+ibranch,symikpt_phon,isppol) = &
4479 &                 gkk_qpt_new(:,ib1,(jbranch-1)*elph_ds%nbranch+ibranch,symikpt_phon,isppol) + &
4480 &                 tmp_mat(:,jbranch,ibranch)
4481                end do
4482              end do
4483 
4484            end do ! end ib1 do
4485          end do ! end ikpt_phon do
4486        end do ! end isppol do
4487 
4488      end do ! end isym do
4489    end do ! itim
4490 
4491    if (neqqpt > 1) then
4492      write(std_out,*) ' found several equiv qpts and am symmetrizing them ', neqqpt
4493    end if
4494 
4495 !  divide by number of equivalent qpts found
4496    gkk_qpt_new(:,:,:,:,:) = gkk_qpt_new(:,:,:,:,:)/neqqpt
4497 
4498 !  copy the symmetrized version into all the equivalent qpoints, appropriately transformed
4499 !  See above
4500 !  itim=1
4501    do itim=1,2
4502      do isym=1,nsym
4503 !      ieqqpt is sent onto iqpt by itim/isym
4504        ieqqpt = qpttoqpt(itim,isym,iqpt)
4505 
4506        if (symmetrized_qpt(ieqqpt) /= -1) cycle
4507        gkk_qpt_tmp(:,:,:,:,:) = zero
4508 
4509 !      use symrec matrices to get inverse transform from isym^{-1}
4510        if (elph_ds%ep_scalprod==1) then
4511          do ii=1,3
4512            do jj=1,3
4513              ss(ii,jj)=0.0_dp
4514              do kk=1,3
4515                do ll=1,3
4516 !                Use inverse of symop matrix here to get back to ieqqpt (inv+transpose is in symrec and in gprimd)
4517                  ss(ii,jj)=ss(ii,jj)+rprimd(ii,kk)*symrec(ll,kk,isym)*gprimd(ll,jj)
4518                end do
4519              end do
4520            end do
4521          end do
4522        else
4523          do ii=1,3
4524            do jj=1,3
4525              ss(ii,jj) = symrel(ii,jj,isym)
4526            end do
4527          end do
4528        end if
4529 
4530        ss_allatoms(:,:,:) = zero
4531        do iatom=1,natom
4532          ancestor_iatom = indsym(4,isym,iatom)
4533 !        do jatom=1,natom
4534 !        ancestor_jatom = indsym(4,isym,jatom)
4535          ss_allatoms(1,(ancestor_iatom-1)*3+1:(ancestor_iatom-1)*3+3,&
4536 &         (iatom-1)*3+1:          (iatom-1)*3+3) = ss(1:3,1:3)
4537 !        end do
4538        end do
4539 
4540 !      ! Use inverse of symop matrix here to get back to ieqqpt
4541 !      ssinv(ii,jj)=ssinv(ii,jj)+gprimd(ii,kk)*rprimd(jj,ll)*symrel(kk,ll,isym)
4542 
4543        do isppol=1,elph_ds%nsppol
4544          do ikpt_phon=1,elph_ds%k_phon%nkpt
4545 !          symikpt_phon is sent onto ikpt_phon by itim/isym
4546            symikpt_phon=elph_ds%k_phon%full2full(itim,isym,ikpt_phon)
4547 
4548            do ib1=1,elph_ds%ngkkband*elph_ds%ngkkband
4549 
4550 !            multiply by the ss^{-1} matrices
4551              tmp_mat2(:,:,:) = zero
4552              tmp_mat(:,:,:) = reshape(gkk_qpt_new(:,ib1,:,ikpt_phon,isppol),&
4553 &             (/2,elph_ds%nbranch,elph_ds%nbranch/))
4554              call ZGEMM ('N','N',elph_ds%nbranch,elph_ds%nbranch,elph_ds%nbranch,&
4555 &             c_one,ss_allatoms,elph_ds%nbranch,tmp_mat,elph_ds%nbranch,c_zero,&
4556 &             tmp_mat2,elph_ds%nbranch)
4557              call ZGEMM ('N','T',elph_ds%nbranch,elph_ds%nbranch,elph_ds%nbranch,&
4558 &             c_one,tmp_mat2,elph_ds%nbranch,ss_allatoms,elph_ds%nbranch,c_zero,&
4559 &             tmp_mat,elph_ds%nbranch)
4560 
4561              do ibranch =1,elph_ds%nbranch
4562                do jbranch =1,elph_ds%nbranch
4563                  gkk_qpt_tmp(:,ib1,(jbranch-1)*elph_ds%nbranch+ibranch,symikpt_phon,isppol) =&
4564 &                 tmp_mat(:,jbranch,ibranch)
4565                end do
4566              end do
4567 
4568              do ik_this_proc =1,elph_ds%k_phon%my_nkpt
4569                if (elph_ds%k_phon%my_ikpt(ik_this_proc) == symikpt_phon) then
4570                  if (gkk_flag (1,1,ik_this_proc,isppol,ieqqpt) == -1) gkk_flag (:,:,ik_this_proc,isppol,ieqqpt) = 0
4571                  exit
4572                end if
4573              end do
4574 !             if (gkk_flag (1,1,symikpt_phon,isppol,ieqqpt) == -1) then
4575 !               gkk_flag (:,:,symikpt_phon,isppol,ieqqpt) = 0
4576 !             end if
4577 
4578            end do ! end ib1 do
4579          end do ! end ikpt_phon do
4580        end do ! end isppol do
4581 
4582 
4583 !      save symmetrized matrices for qpt ieqqpt
4584        do ik_this_proc =1,elph_ds%k_phon%my_nkpt
4585          ikpt_phon = elph_ds%k_phon%my_ikpt(ik_this_proc)
4586 
4587          if (elph_ds%gkqwrite == 0) then
4588            elph_ds%gkk_qpt(:,:,:,ik_this_proc,:,ieqqpt) = gkk_qpt_tmp(:,:,:,ikpt_phon,:)
4589          else if (elph_ds%gkqwrite == 1) then
4590            write(elph_ds%unitgkq,REC=((ieqqpt-1)*elph_ds%k_phon%my_nkpt+ik_this_proc)) gkk_qpt_tmp(:,:,:,ikpt_phon,:)
4591          end if
4592        end do
4593 
4594        symmetrized_qpt(ieqqpt) = 1
4595 
4596      end do ! end isym do
4597    end do ! end itim do
4598 
4599  end do
4600 !end iqpt do
4601 
4602  ABI_DEALLOCATE(gkk_qpt_new)
4603  ABI_DEALLOCATE(gkk_qpt_tmp)
4604 
4605 end subroutine complete_gkk

ABINIT/ftgkk [ Functions ]

[ Top ] [ 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

PARENTS

      get_all_gkr,interpolate_gkk,test_ftgkk

CHILDREN

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

5933 subroutine ftgkk (wghatm,gkk_qpt,gkk_rpt,gkqwrite,gkrwrite,gprim,ikpt_phon0,&
5934 &                  natom,nkpt_phon,ngkkband,nkpt_used,nqpt,nrpt,nsppol,&
5935 &                  qtor,rpt,qpt_full,unit_gkk_rpt,unitgkq)
5936 
5937 
5938 !This section has been created automatically by the script Abilint (TD).
5939 !Do not modify the following lines by hand.
5940 #undef ABI_FUNC
5941 #define ABI_FUNC 'ftgkk'
5942 !End of the abilint section
5943 
5944  implicit none
5945 
5946 !Arguments -------------------------------
5947 !scalars
5948  integer,intent(in) :: gkqwrite,gkrwrite,ikpt_phon0,nkpt_phon,natom,ngkkband
5949  integer,intent(in) :: nkpt_used,nqpt,nrpt,nsppol,qtor,unit_gkk_rpt,unitgkq
5950 !arrays
5951  real(dp),intent(in) :: gprim(3,3),rpt(3,nrpt),qpt_full(3,nqpt)
5952  real(dp),intent(in) :: wghatm(natom,natom,nrpt)
5953  real(dp),intent(inout) :: gkk_qpt(2,ngkkband*ngkkband,3*natom*3*natom,nkpt_used,nsppol,nqpt)
5954  real(dp),intent(inout) :: gkk_rpt(2,ngkkband*ngkkband,3*natom*3*natom,nkpt_used,nsppol,nrpt)
5955 
5956 !Local variables -------------------------
5957 !scalars
5958  integer :: ikpt_phon,iatom,ib1,ieffkpt_phon,ip,iqpt,irpt,isppol
5959  integer :: jatom
5960  real(dp) :: im,kr,re
5961  character(len=500) :: message
5962 !arrays
5963  real(dp) :: coskr(nqpt,nrpt),ftwght(2,3*natom*3*natom)
5964  real(dp) :: gkk_qpt_tmp(2,ngkkband*ngkkband,3*natom*3*natom,nkpt_used,nsppol)
5965  real(dp) :: gkk_rpt_tmp(2,ngkkband*ngkkband,3*natom*3*natom,nkpt_phon,nsppol)
5966  real(dp) :: kk(3),sinkr(nqpt,nrpt)
5967 
5968 ! *********************************************************************
5969 
5970 !rewind (unit_gkk_rpt)
5971 
5972 !prepare the phase factors
5973  do iqpt=1,nqpt
5974 !  Calculation of the k coordinates in Normalized Reciprocal
5975 !  coordinates
5976    kk(1)=   qpt_full(1,iqpt)*gprim(1,1)+&
5977 &   qpt_full(2,iqpt)*gprim(1,2)+&
5978 &   qpt_full(3,iqpt)*gprim(1,3)
5979    kk(2)=   qpt_full(1,iqpt)*gprim(2,1)+&
5980 &   qpt_full(2,iqpt)*gprim(2,2)+&
5981 &   qpt_full(3,iqpt)*gprim(2,3)
5982    kk(3)=   qpt_full(1,iqpt)*gprim(3,1)+&
5983 &   qpt_full(2,iqpt)*gprim(3,2)+&
5984 &   qpt_full(3,iqpt)*gprim(3,3)
5985    do irpt=1,nrpt
5986 !    Product of k and r
5987      kr =        kk(1)*rpt(1,irpt)+&
5988 &     kk(2)*rpt(2,irpt)+&
5989 &     kk(3)*rpt(3,irpt)
5990      coskr(iqpt,irpt)=cos(two_pi*kr)
5991      sinkr(iqpt,irpt)=sin(two_pi*kr)
5992 !    DEBUG
5993 !    if (iqpt < 1000 .and. (irpt == 101 .or. irpt == 901)) then
5994 !    write(std_out,*) iqpt,irpt,kk,rpt(:,irpt),coskr(iqpt,irpt), sinkr(iqpt,irpt)
5995 !    end if
5996 !    ENDDEBUG
5997    end do
5998  end do
5999 
6000 
6001 
6002 !Recip to real space
6003  if (qtor==1) then
6004 !
6005    if (nkpt_used /= nkpt_phon) write(std_out,*) 'ftgkk: strange usage of nkpt_used for back FT!'
6006    do irpt=1,nrpt
6007 !    DEBUG
6008 !    write(std_out,*) ' ftgkk : G->R irpt = ',irpt,' / ',nrpt
6009 !    ENDDEBUG
6010      gkk_rpt_tmp(:,:,:,:,:) = zero
6011 
6012      do iqpt=1,nqpt
6013 
6014 !      write(std_out,*) iqpt
6015 
6016        if (gkqwrite == 0) then
6017          gkk_qpt_tmp(:,:,:,:,:) = gkk_qpt(:,:,:,:,:,iqpt)
6018        else
6019          do ikpt_phon=1, nkpt_phon
6020            read(unitgkq,REC=((iqpt-1)*nkpt_phon+ikpt_phon)) gkk_qpt_tmp(:,:,:,ikpt_phon,:)
6021          end do
6022        end if
6023 !      Get the phase factor with normalization!
6024        re=coskr(iqpt,irpt)/nqpt
6025        im=sinkr(iqpt,irpt)/nqpt
6026        do isppol=1,nsppol
6027          do ikpt_phon=1,nkpt_used
6028 !          DEBUG
6029 !          write(std_out,*) ' ftgkk : G->R ikpt_phon = ',ikpt_phon,' / ',nkpt_used
6030 !          ENDDEBUG
6031            do ip=1,3*natom*3*natom
6032 !            Real and imaginary part of the real-space gkk matrices -> exp(-i k.r)
6033              do ib1=1,ngkkband*ngkkband
6034                gkk_rpt_tmp(1,ib1,ip,ikpt_phon,isppol) = gkk_rpt_tmp(1,ib1,ip,ikpt_phon,isppol)&
6035 &               +re*gkk_qpt_tmp(1,ib1,ip,ikpt_phon,isppol) &
6036 &               +im*gkk_qpt_tmp(2,ib1,ip,ikpt_phon,isppol)
6037                gkk_rpt_tmp(2,ib1,ip,ikpt_phon,isppol) = gkk_rpt_tmp(2,ib1,ip,ikpt_phon,isppol)&
6038 &               +re*gkk_qpt_tmp(2,ib1,ip,ikpt_phon,isppol) &
6039 &               -im*gkk_qpt_tmp(1,ib1,ip,ikpt_phon,isppol)
6040              end do
6041            end do
6042          end do
6043        end do
6044      end do
6045      if (gkrwrite == 0) then
6046        gkk_rpt(:,:,:,:,:,irpt) = gkk_rpt_tmp(:,:,:,:,:)
6047      else
6048        write (unit_gkk_rpt,REC=irpt) gkk_rpt_tmp
6049      end if
6050    end do
6051 
6052 !  Real space to recip space
6053  else if (qtor==0) then
6054 
6055 !  write(std_out,*) 'ftgkk : shape(gkk_qpt) = ', shape(gkk_qpt)
6056    gkk_qpt(:,:,:,:,:,:)=zero
6057 
6058 !  rewind (unit_gkk_rpt)
6059    do irpt=1,nrpt
6060      if (gkrwrite == 0) then
6061        gkk_rpt_tmp(:,:,:,:,:) = gkk_rpt(:,:,:,:,:,irpt)
6062      else
6063        read(unit_gkk_rpt,REC=irpt) gkk_rpt_tmp
6064      end if
6065 
6066 
6067      do iqpt=1,nqpt
6068 
6069 !      Avoid recalculating weights nkpt_used*9 times
6070        do iatom=1,natom
6071          do jatom=1,natom
6072            ip = 3*((iatom-1)*natom+jatom-1)
6073 !          copy same weight for all 3 directions
6074            ftwght(1,ip+1:ip+3)=coskr(iqpt,irpt)*wghatm(iatom,jatom,irpt)
6075            ftwght(2,ip+1:ip+3)=sinkr(iqpt,irpt)*wghatm(iatom,jatom,irpt)
6076          end do
6077        end do
6078 
6079 
6080 
6081        do ip=1,3*natom*3*natom
6082 !        Get phase factor
6083          re = ftwght(1,ip)
6084          im = ftwght(2,ip)
6085 
6086          do isppol=1,nsppol
6087            do ikpt_phon=1,nkpt_used
6088 
6089 
6090 !            DEBUG
6091 !            write(std_out,*) ' ftgkk : R->G ikpt_phon = ',ikpt_phon,' / ',nkpt_used
6092 !            ENDDEBUG
6093 !            effective FS kpt in real space array is ikpt_phon+ikpt_phon0-1 to allow for offset
6094              ieffkpt_phon = ikpt_phon+ikpt_phon0-1
6095 !            write(std_out,*) 'ftgkk :ikpt_phon,iqpt,ieffkpt_phon ', ikpt_phon,iqpt,ieffkpt_phon
6096 
6097              do ib1=1,ngkkband*ngkkband
6098 !              Real and imaginary part of the gamma matrices
6099                gkk_qpt(1,ib1,ip,ikpt_phon,isppol,iqpt)=&
6100 &               gkk_qpt(1,ib1,ip,ikpt_phon,isppol,iqpt)&
6101 &               +re*gkk_rpt_tmp(1,ib1,ip,ieffkpt_phon,isppol)&
6102 &               -im*gkk_rpt_tmp(2,ib1,ip,ieffkpt_phon,isppol)
6103 !              !DEBUG
6104                gkk_qpt(2,ib1,ip,ikpt_phon,isppol,iqpt)=&
6105 &               gkk_qpt(2,ib1,ip,ikpt_phon,isppol,iqpt)&
6106 &               +im*gkk_rpt_tmp(1,ib1,ip,ieffkpt_phon,isppol)&
6107 &               +re*gkk_rpt_tmp(2,ib1,ip,ieffkpt_phon,isppol)
6108 !              !ENDDEBUG
6109 
6110 !              if (iqpt < 100 .and. irpt < 100 .and. &
6111 !              &   tmpgkkrim(irpt)**2+tmpgkkrre(irpt)**2 > tol6) then
6112 !              write(std_out,'(2I4,2E16.8,x,2E16.8)') &
6113 !              &   iqpt,irpt,re,im,tmpgkkrre(irpt),tmpgkkrim(irpt)
6114 !              end if
6115 
6116              end do
6117            end do
6118 !          end ikpt_phon
6119          end do
6120 !        end isppol
6121 !        write(std_out,'(a)') ' ftgkk :gkk_qpt :'
6122 !        write(std_out,'(4E16.5)') gkk_qpt(:,1,1,,ikpt_phon,1:nqpt)
6123        end do
6124 !      end ip
6125      end do
6126 !    end iqpt
6127    end do
6128 !  end irpt
6129 
6130 
6131 !  There is no other space to Fourier transform from ??
6132  else
6133    write(message,'(a,a,a,i0,a)' )&
6134 &   'The only allowed values for qtor are 0 or 1, while',ch10,&
6135 &   'qtor=',qtor,' has been required.'
6136    MSG_BUG(message)
6137  end if
6138 
6139 end subroutine ftgkk

ABINIT/get_all_gkk2 [ Functions ]

[ Top ] [ 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

PARENTS

      elphon

CHILDREN

      interpolate_gkk

SOURCE

3650 subroutine get_all_gkk2(crystal,ifc,elph_ds,kptirr_phon,kpt_phon)
3651 
3652 
3653 !This section has been created automatically by the script Abilint (TD).
3654 !Do not modify the following lines by hand.
3655 #undef ABI_FUNC
3656 #define ABI_FUNC 'get_all_gkk2'
3657 !End of the abilint section
3658 
3659  implicit none
3660 
3661 !Arguments ------------------------------------
3662 !scalars
3663  type(crystal_t),intent(in) :: crystal
3664  type(ifc_type),intent(in) :: ifc
3665  type(elph_type),intent(inout) :: elph_ds
3666 !arrays
3667  real(dp),intent(in) :: kpt_phon(3,elph_ds%k_phon%nkpt)
3668  real(dp),intent(in) :: kptirr_phon(3,elph_ds%k_phon%nkptirr)
3669 
3670 !Local variables-------------------------------
3671 !scalars
3672  integer :: iost,onediaggkksize,sz1,sz2,sz3,sz4
3673  real(dp) :: realdp_ex
3674  !character(len=500) :: msg
3675 
3676 ! *************************************************************************
3677 
3678  if (elph_ds%nsppol /= 1) then
3679    MSG_ERROR('get_all_gkk2: nsppol>1 not coded yet!')
3680  end if
3681 
3682  onediaggkksize = elph_ds%nbranch*elph_ds%k_phon%nkpt*kind(realdp_ex)
3683 
3684  elph_ds%unit_gkk2 = 37
3685  if (elph_ds%gkk2write == 0) then
3686    write(std_out,*) 'get_all_gkk2 : keep gkk2 in memory. Size = ',&
3687 &   4.0*dble(elph_ds%k_phon%nkpt)*dble(onediaggkksize)/&
3688 &   1024.0_dp/1024.0_dp, " Mb"
3689    sz1=elph_ds%nbranch
3690    sz2=elph_ds%ngkkband
3691    sz3=elph_ds%ngkkband
3692    sz4=elph_ds%k_phon%nkpt
3693    ABI_ALLOCATE(elph_ds%gkk2,(sz1,sz2,sz3,sz4,elph_ds%k_phon%nkpt,1))
3694    elph_ds%gkk2(:,:,:,:,:,:) = zero
3695 
3696  else if (elph_ds%gkk2write == 1) then
3697    write(std_out,*) 'get_all_gkk2 : About to open gkk2 file : '
3698    write(std_out,*) elph_ds%unit_gkk2,onediaggkksize
3699    open (unit=elph_ds%unit_gkk2,file='gkk2file',access='direct',&
3700 &   recl=onediaggkksize,form='unformatted',status='new',iostat=iost)
3701    if (iost /= 0) then
3702      MSG_ERROR('error opening gkk2file as new')
3703    end if
3704 !  rewind (elph_ds%unit_gkk2)
3705    write(std_out,*) 'get_all_gkk2 : disk file with gkk^2 created'
3706    write(std_out,*) '  calculate from real space gkk and phonon modes'
3707    write(std_out,*) '  gkk2write = 1 is forced: can take a lot of time! '
3708    write(std_out,*) ' size = ', 4.0*dble(onediaggkksize)*dble(elph_ds%k_phon%nkpt)/&
3709 &   1024.0_dp/1024.0_dp, ' Mb'
3710  else
3711    MSG_ERROR('bad value of gkk2write')
3712  end if
3713 
3714 !here do the actual calculation of |g_kk|^2
3715  MSG_ERROR("MGNOTE: interpolate_gkk is broken")
3716  ABI_UNUSED(kptirr_phon(1,1))
3717  call interpolate_gkk (crystal,ifc,elph_ds,kpt_phon)
3718 
3719  !MG: This was the old coding in version 7.6.2:
3720 
3721 ! call interpolate_gkk (elph_ds,kptirr_phon,kpt_phon,natom,nrpt,phon_ds,rcan,wghatm)
3722 !
3723 ! and interpolate_gkk had the prototype:
3724 !
3725 !subroutine interpolate_gkk(elph_ds,kpt_phon,gprim,natom,nrpt,phon_ds,rpt,wghatm)
3726 
3727 ! hence we were associating kpt_phon to gprim!
3728 
3729 end subroutine get_all_gkk2

ABINIT/get_all_gkq [ Functions ]

[ Top ] [ 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.

PARENTS

      elphon

CHILDREN

      complete_gkk,int2char4,read_gkk,wrtout

SOURCE

4016 subroutine get_all_gkq (elph_ds,Cryst,ifc,Bst,FSfullpqtofull,nband,n1wf,onegkksize,&
4017 &    qpttoqpt,ep_prt_yambo,unitgkk,ifltransport)
4018 
4019 
4020 !This section has been created automatically by the script Abilint (TD).
4021 !Do not modify the following lines by hand.
4022 #undef ABI_FUNC
4023 #define ABI_FUNC 'get_all_gkq'
4024 !End of the abilint section
4025 
4026  implicit none
4027 
4028 !Arguments ------------------------------------
4029 !scalars
4030  integer,intent(in) :: n1wf,nband,onegkksize,unitgkk,ep_prt_yambo,ifltransport
4031  type(crystal_t),intent(in) :: Cryst
4032  type(ifc_type),intent(in) :: ifc
4033  type(ebands_t),intent(in) :: Bst
4034  type(elph_type),intent(inout) :: elph_ds
4035 !arrays
4036  integer,intent(in) :: FSfullpqtofull(elph_ds%k_phon%nkpt,elph_ds%nqpt_full)
4037  integer,intent(in) :: qpttoqpt(2,Cryst%nsym,elph_ds%nqpt_full)
4038 
4039 !Local variables-------------------------------
4040 !scalars
4041  integer :: iost,ierr,me,sz2,sz3,sz4,sz5,sz6
4042  character(len=10) :: procnum
4043  character(len=500) :: message
4044  character(len=fnlen) :: fname
4045 !arrays
4046  integer,allocatable :: gkk_flag(:,:,:,:,:)
4047 
4048 ! *************************************************************************
4049 
4050 !attribute file unit number
4051  elph_ds%unitgkq = get_unit()
4052 
4053 !============================================
4054 !save gkk for all qpts in memory or to disk
4055 !============================================
4056 
4057 !DEBUG
4058 !write(std_out,*) ' 4 bytes / ??'
4059 !write(std_out,*) ' kind(real) = ', kind(one)
4060 !write(std_out,*) ' elph_ds%ngkkband = ', elph_ds%ngkkband, '^2'
4061 !write(std_out,*) ' elph_ds%nbranch = ', elph_ds%nbranch, '^2'
4062 !write(std_out,*) ' elph_ds%k_phon%nkpt = ', elph_ds%k_phon%nkpt
4063 !write(std_out,*) ' elph_ds%nsppol = ', elph_ds%nsppol
4064 !write(std_out,*) ' elph_ds%nqptirred ', elph_ds%nqptirred
4065 !ENDDEBUG
4066 
4067  write(message,'(a,f14.4,a)')&
4068 & ' get_all_gkq : gkq file/array size = ',&
4069  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'
4070  call wrtout(std_out,message,'COLL')
4071 
4072  if (elph_ds%gkqwrite == 0) then !calculate gkk(q) keeping all in memory
4073 
4074    call wrtout(std_out,' get_all_gkq : keep gkk(q) in memory ','COLL')
4075 
4076    sz2=elph_ds%ngkkband*elph_ds%ngkkband
4077    sz3=elph_ds%nbranch*elph_ds%nbranch
4078    sz4=elph_ds%k_phon%my_nkpt
4079    sz5=elph_ds%nsppol
4080    if (ifltransport == 3) then
4081      sz6=elph_ds%nqpt_full
4082    else
4083      sz6=elph_ds%nqptirred
4084    end if
4085    ABI_STAT_ALLOCATE(elph_ds%gkk_qpt,(2,sz2,sz3,sz4,sz5,sz6), ierr)
4086    ABI_CHECK(ierr==0, 'Trying to allocate array elph_ds%gkk_qpt')
4087 
4088    elph_ds%gkk_qpt = zero
4089 
4090  else if (elph_ds%gkqwrite == 1) then !calculate gkk(q) and write to file
4091    me = xmpi_comm_rank(xmpi_world)
4092    call int2char4(me,procnum)
4093    ABI_CHECK((procnum(1:1)/='#'),'Bug: string length too short!')
4094    fname=trim(elph_ds%elph_base_name) // "_P" // trim(procnum) // '_GKKQ'
4095 
4096    iost=open_file(file=fname,iomsg=message,newunit=elph_ds%unitgkq,access='direct',&
4097 &   recl=onegkksize,form='unformatted')
4098    if (iost /= 0) then
4099      write (message,'(2a)')' get_all_gkq : ERROR- opening file ',trim(fname)
4100      MSG_ERROR(message)
4101    end if
4102 
4103    write (message,'(5a)')&
4104 &   ' get_all_gkq : gkq matrix elements  will be written to file : ',trim(fname),ch10,&
4105 &   ' Nothing is in files yet',ch10
4106    call wrtout(std_out,message,'COLL')
4107 
4108  else
4109    write(message,'(a,i0)')' gkqwrite must be 0 or 1 while it is : ',elph_ds%gkqwrite
4110    MSG_BUG(message)
4111  end if !if gkqwrite
4112 
4113 !=====================================================
4114 !read in g_kk matrix elements for all bands, kpoints,
4115 !and calculated qpoints
4116 !=====================================================
4117  call wrtout(std_out,' get_all_gkq : calling read_gkk to read in the g_kk matrix elements',"COLL")
4118 
4119  sz2=elph_ds%nbranch;sz3=elph_ds%k_phon%my_nkpt
4120  sz4=elph_ds%nsppol;sz5=elph_ds%nqpt_full
4121  ABI_STAT_ALLOCATE(gkk_flag,(sz2,sz2,sz3,sz4,sz5), ierr)
4122  ABI_CHECK(ierr==0, "allocating gkk_flag")
4123 
4124  call read_gkk(elph_ds,Cryst,ifc,Bst,FSfullpqtofull,gkk_flag,n1wf,nband,ep_prt_yambo,unitgkk)
4125 
4126 !if (elph_ds%symgkq ==1) then
4127 !MJV 01/2010 removed the completion on qpt here: it should be done after FS integration
4128 !so that everything is lighter in memory etc... (only irred qpt)
4129 ! if (0==1) then
4130  if (ifltransport == 3) then !  bxu, complete gkk is necessary
4131 
4132 !  ==============================================================
4133 !  complete gkk matrices for other qpoints on the full grid qpt_full
4134 !  inspired and cannibalized from symdm9.f
4135 !  FIXME: should add the possibility to copy over to other qpoints,
4136 !  without full symmetrization, for testing purposes.
4137 !  ==============================================================
4138 
4139    write(message,'(4a)')ch10,&
4140 &   ' get_all_gkq : calling complete_gkk to complete ',ch10,&
4141 &   ' gkk matrices for other qpoints on the full grid'
4142    call wrtout(std_out,message,'COLL')
4143 
4144    call complete_gkk(elph_ds,gkk_flag,Cryst%gprimd,Cryst%indsym,&
4145 &   Cryst%natom,Cryst%nsym,qpttoqpt,Cryst%rprimd,Cryst%symrec,Cryst%symrel)
4146 
4147    call wrtout(std_out,' get_all_gkq : out of complete_gkk','COLL')
4148 
4149  end if !symgkq
4150 
4151 !TODO Do we need gkk_flag in elphon?
4152  ABI_DEALLOCATE(gkk_flag)
4153 
4154 end subroutine get_all_gkq

ABINIT/get_all_gkr [ Functions ]

[ Top ] [ 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.

PARENTS

      elphon

CHILDREN

      ftgkk

SOURCE

4187 subroutine get_all_gkr (elph_ds,gprim,natom,nrpt,onegkksize,rpt,qpt_full,wghatm)
4188 
4189 
4190 !This section has been created automatically by the script Abilint (TD).
4191 !Do not modify the following lines by hand.
4192 #undef ABI_FUNC
4193 #define ABI_FUNC 'get_all_gkr'
4194 !End of the abilint section
4195 
4196  implicit none
4197 
4198 !Arguments ------------------------------------
4199 !scalars
4200  integer,intent(in) :: natom,nrpt,onegkksize
4201  type(elph_type),intent(inout) :: elph_ds
4202 !arrays
4203  real(dp),intent(in) :: gprim(3,3),rpt(3,nrpt),qpt_full(3,elph_ds%nqpt_full)
4204  real(dp),intent(in) :: wghatm(natom,natom,nrpt)
4205 
4206 !Local variables-------------------------------
4207 !scalars
4208  integer :: ikpt_phon0,iost,qtor,sz2,sz3,sz4,sz5
4209 
4210 ! *************************************************************************
4211 
4212 !
4213 !WARNING : disk file used for large arrays gkk_rpt and
4214 !(eventually) gkk2
4215 !
4216 !allocate (gkk_rpt(2,elph_ds%nbranch,elph_ds%nFSband,elph_ds%nFSband,&
4217 !&  elph_ds%k_phon%nkpt,nrpt))
4218  elph_ds%unit_gkk_rpt = 36
4219 !see if the gkk_rpt should be written to a file (only available option now)
4220  if (elph_ds%gkk_rptwrite == 1) then
4221 !  file is not present : we need to do the FT
4222    open (unit=elph_ds%unit_gkk_rpt,file='gkk_rpt_file',access='direct',&
4223 &   recl=onegkksize,form='unformatted',&
4224 &   status='new',iostat=iost)
4225    if (iost /= 0) then
4226      MSG_ERROR('get_all_gkr : error opening gkk_rpt_file as new')
4227    end if
4228    write(std_out,*) ' get_all_gkr : will write real space gkk to a disk file.'
4229    write(std_out,*) ' size = ', 4.0*dble(onegkksize)*dble(nrpt)/&
4230 &   1024.0_dp/1024.0_dp, ' Mb'
4231 
4232 !  else if (elph_ds%gkk_rptwrite  == 0) then
4233  else
4234    write(std_out,*) ' get_all_gkr : will keep real space gkk in memory.'
4235    write(std_out,*) ' size = ', 4.0*dble(onegkksize)*dble(nrpt)/&
4236 &   1024.0_dp/1024.0_dp, ' Mb'
4237    sz2=elph_ds%ngkkband*elph_ds%ngkkband
4238    sz3=elph_ds%nbranch*elph_ds%nbranch
4239    sz4=elph_ds%k_phon%nkpt
4240    sz5=elph_ds%nsppol
4241    ABI_ALLOCATE(elph_ds%gkk_rpt,(2,sz2,sz3,sz4,sz5,nrpt))
4242 !  write(std_out,*) ' get_all_gkr: invalid value for gkk_rptwrite'
4243 !  stop
4244  end if
4245  write(std_out,*) '    about to FT the recip space gkk to real space '
4246  qtor = 1
4247 
4248 !
4249 !NOTE: should be very easy to parallelize!
4250 !
4251  ikpt_phon0 = 1
4252  call ftgkk (wghatm,elph_ds%gkk_qpt,elph_ds%gkk_rpt,&
4253 & elph_ds%gkqwrite,elph_ds%gkk_rptwrite,gprim,1,natom,&
4254 & elph_ds%k_phon%nkpt,elph_ds%ngkkband,elph_ds%k_phon%nkpt,elph_ds%nqpt_full,&
4255 & nrpt,elph_ds%nsppol,qtor,rpt,qpt_full,elph_ds%unit_gkk_rpt,elph_ds%unitgkq)
4256 
4257 !call ftgkk (elph_ds,gprim,ikpt_phon0,natom,nrpt,qtor,rpt,qpt_full,wghatm)
4258  write(std_out,*) ' get_all_gkr : done with FT of gkk to real space'
4259 
4260 !No longer need the gkk_qpt?
4261 !if (elph_ds%gkqwrite == 0) deallocate (elph_ds%gkk_qpt)
4262 
4263 !!DEBUG
4264 !Test the FT of the gkk elements.
4265 !call test_ftgkk(elph_ds,gprim,natom,nrpt,rpt,qpt_full,wghatm)
4266 !!ENDDEBUG
4267 
4268 !DEBUG
4269 !do irpt=1,nrpt
4270 !do ipert1=1,elph_ds%nbranch
4271 !write(std_out,'(6(F16.5,1x))') elph_ds%gkk_rpt(:,ipert1,1,1,1,irpt)
4272 !end do
4273 !end do
4274 !ENDDEBUG
4275 
4276 end subroutine get_all_gkr

ABINIT/get_fs_bands [ Functions ]

[ Top ] [ 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!

PARENTS

      elphon

CHILDREN

      wrtout

SOURCE

3502 subroutine get_fs_bands(eigenGS,hdr,fermie,ep_b_min,ep_b_max,minFSband,maxFSband,nkptirr)
3503 
3504 
3505 !This section has been created automatically by the script Abilint (TD).
3506 !Do not modify the following lines by hand.
3507 #undef ABI_FUNC
3508 #define ABI_FUNC 'get_fs_bands'
3509 !End of the abilint section
3510 
3511  implicit none
3512 
3513 !Arguments ------------------------------------
3514 !scalars
3515  integer, intent(in) :: ep_b_min, ep_b_max
3516  integer,intent(out) :: minFSband,maxFSband,nkptirr
3517  real(dp),intent(in) :: fermie
3518  type(hdr_type),intent(in) :: hdr
3519 !arrays
3520  real(dp),intent(in) :: eigenGS(hdr%nband(1),hdr%nkpt,hdr%nsppol)
3521 
3522 !Local variables-------------------------------
3523 !scalars
3524  integer :: iband,ikpt,isppol,nband
3525  real(dp) :: epsFS,gausstol,gaussig
3526  character(len=500) :: message
3527  integer :: kpt_phonflag(hdr%nkpt)
3528 
3529 ! *************************************************************************
3530 
3531 !supposes nband is equal for all kpts
3532  nband = hdr%nband(1)
3533 
3534 !gausstol = minimum weight value for integration weights on FS
3535 !should be set to reproduce DOS at Ef (Ref. PRB 34, 5065 [[cite:Lam1986]] p. 5067)
3536  gausstol = 1.0d-10
3537 
3538 !use same band indices in both spin channels
3539  maxFSband=1
3540  minFSband=nband
3541 
3542 !window of states around fermi Energy is contained in +/- epsFS
3543 !should be adjusted to take into account a minimal but sufficient
3544 !fraction of the kpoints: see the loop below.
3545 !The 1000 is purely empirical!!!
3546 !Should also take into account the density of kpoints.
3547 !gaussig = width of gaussian energy window around fermi energy
3548 !needed to get a good fraction of kpoints contributing to the FS
3549 
3550  gaussig = (maxval(eigenGS)-minval(eigenGS))/1000.0_dp
3551 
3552  write (message,'(a,f11.8,2a)')' get_fs_bands : initial energy window = ',gaussig,ch10,&
3553 & ' The window energy will be increased until the full k-grid is inside the range'
3554  call wrtout(std_out,message,'COLL')
3555 
3556 !NOTE: could loop back to here and change gaussig until we have
3557 !a certain fraction of the kpoints in the FS region...
3558  nkptirr = 0
3559 
3560 !Do not use restricted fermi surface: include all kpts -> one
3561  do while (nkptirr < hdr%nkpt)
3562    gaussig = gaussig*1.05_dp
3563 
3564 !  we must take into account kpoints with states within epsFS:
3565    epsFS = gaussig*sqrt(log(one/(gaussig*sqrt(pi)*gausstol)))
3566 
3567 !  check if there are eigenvalues close to the Fermi surface
3568 !  (less than epsFS from it)
3569    kpt_phonflag(:) = 0
3570 
3571 !  do for each sppol channel
3572    do isppol=1,hdr%nsppol
3573      do ikpt=1,hdr%nkpt
3574        do iband=1,nband
3575          if (abs(eigenGS(iband,ikpt,isppol) - fermie) < epsFS) then
3576            kpt_phonflag(ikpt) = 1
3577            if (iband > maxFSband) maxFSband = iband
3578            if (iband < minFSband) minFSband = iband
3579          end if
3580        end do
3581      end do
3582    end do ! isppol
3583 
3584 !  if user imposed certain bands for e-p, make sure they are kept
3585    if (ep_b_min /= 0 .and. ep_b_min < minFSband) then
3586      minFSband = ep_b_min
3587    end if
3588    if (ep_b_max /= 0 .and. ep_b_max > maxFSband) then
3589      maxFSband = ep_b_max
3590    end if
3591 
3592 !  number of irreducible kpoints (by all sym) contributing to the Fermi surface (to be completed by symops).
3593    nkptirr = sum(kpt_phonflag(:))
3594  end do
3595 
3596  write(std_out,*) ' Energy window around Fermi level= ',epsFS,' nkptirr= ',nkptirr
3597 
3598 end subroutine get_fs_bands

ABINIT/get_nv_fs_en [ Functions ]

[ Top ] [ 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

PARENTS

      elphon

CHILDREN

      d2c_weights,ep_el_weights,ep_fs_weights,get_veloc_tr,ifc_fourq,wrtout

SOURCE

4663 subroutine get_nv_fs_en(crystal,ifc,elph_ds,eigenGS,max_occ,elph_tr_ds,omega_max)
4664 
4665 
4666 !This section has been created automatically by the script Abilint (TD).
4667 !Do not modify the following lines by hand.
4668 #undef ABI_FUNC
4669 #define ABI_FUNC 'get_nv_fs_en'
4670 !End of the abilint section
4671 
4672  implicit none
4673 
4674 !Arguments ------------------------------------
4675 !Scalars
4676  real(dp), intent(in)  :: max_occ
4677  real(dp), intent(out) :: omega_max
4678  type(ifc_type),intent(in) :: ifc
4679  type(crystal_t),intent(in) :: crystal
4680  type(elph_type),intent(inout) :: elph_ds
4681  type(elph_tr_type),intent(inout) :: elph_tr_ds
4682 !Arrays
4683 
4684  real(dp), intent(in)  :: eigenGS(elph_ds%nband,elph_ds%k_fine%nkptirr,elph_ds%nsppol)
4685 
4686 !Local variables-------------------------------
4687 !scalars
4688  integer ::  iFSqpt,isppol,ie1,ierr
4689  integer ::  i_metal,low_T
4690  integer ::  in_nenergy, out_nenergy
4691  integer ::  n_edge1, n_edge2, edge
4692  integer ::  ie_all, ne_all
4693  integer ::  sz1, sz2, sz3, sz4
4694   real(dp) :: e_vb_max, e_cb_min,ucvol
4695  real(dp) :: e1,max_e,fine_range
4696  real(dp) :: enemin,enemax
4697  real(dp) :: Temp,e_tiny,de0
4698  real(dp) :: eff_mass1, eff_mass2, tmp_dos
4699  character(len=500) :: message
4700 !arrays
4701  real(dp) :: gprimd(3,3)
4702  real(dp) :: kpt_2nd(3), e_cb_2nd(2), en1(2)
4703  real(dp),allocatable :: dos_e1(:,:),tmp_wtk(:,:,:,:)
4704  real(dp),allocatable :: phfrq(:,:)
4705  real(dp),allocatable :: displ(:,:,:,:)
4706 
4707 ! *************************************************************************
4708 
4709  gprimd = crystal%gprimd
4710  ucvol = crystal%ucvol
4711 
4712  Temp             = elph_ds%tempermin+elph_ds%temperinc
4713  elph_ds%delta_e  = kb_HaK*Temp ! about 1000 cm^-1/100, no need to be omega_max
4714  max_e            = elph_ds%nenergy*kb_HaK*Temp
4715  e_tiny           = kb_HaK*0.00001_dp ! this is the min. delta_e
4716  de0              = kb_HaK*Temp ! Kb*T
4717 
4718  in_nenergy = elph_ds%nenergy
4719 
4720  ABI_ALLOCATE(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol,4))
4721  ABI_ALLOCATE(dos_e1,(elph_ds%nsppol,3))
4722 
4723  ABI_ALLOCATE(phfrq,(elph_ds%nbranch, elph_ds%k_phon%nkpt))
4724  ABI_ALLOCATE(displ,(2, elph_ds%nbranch, elph_ds%nbranch, elph_ds%k_phon%nkpt))
4725 
4726  do iFSqpt=1,elph_ds%k_phon%nkpt
4727    call ifc_fourq(ifc,crystal,elph_ds%k_phon%kpt(:,iFSqpt),phfrq(:,iFSqpt),displ(:,:,:,iFSqpt))
4728  end do
4729 
4730  omega_max = maxval(phfrq)*1.1_dp
4731  ABI_DEALLOCATE(phfrq)
4732  ABI_DEALLOCATE(displ)
4733 
4734  write(message,'(a,E20.12)')' The max phonon energy is  ', omega_max
4735  call wrtout(std_out,message,'COLL')
4736 
4737  enemin = elph_ds%fermie - max_e*2
4738  enemax = elph_ds%fermie + max_e
4739  call ep_el_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4740 & enemin, enemax, 4, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4741 & elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4742 & elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine, tmp_wtk)
4743 
4744  do isppol=1,elph_ds%nsppol
4745    dos_e1(isppol,1) = sum(tmp_wtk(:,:,isppol,2))/elph_ds%k_fine%nkpt
4746    dos_e1(isppol,2) = sum(tmp_wtk(:,:,isppol,3))/elph_ds%k_fine%nkpt
4747    dos_e1(isppol,3) = sum(tmp_wtk(:,:,isppol,4))/elph_ds%k_fine%nkpt
4748 
4749 !  ! BXU, only treat metallic case at this moment, as variational method may not
4750 !  ! apply to insulators
4751 !  i_metal = -1
4752    i_metal = 1
4753 !  if (dos_e1(isppol,1) .gt. 0.1_dp .and. dos_e1(isppol,2) .gt. 0.1_dp .and. &
4754 !  &   dos_e1(isppol,3) .gt. 0.1_dp) then ! metal
4755 !  i_metal = 1
4756    if (i_metal == 1) then
4757      write(message,'(a)')' This is a metal.'
4758      call wrtout(std_out,message,'COLL')
4759 
4760      fine_range = 1.5_dp
4761      e1 = elph_ds%fermie + omega_max*fine_range
4762      out_nenergy = 0
4763      low_T = 1
4764      if (omega_max*fine_range .lt. max_e) then
4765        low_T = 0
4766        de0 = omega_max*fine_range/in_nenergy ! energy spacing within Ef +/- omega_max
4767        do while ((e1-elph_ds%fermie) .lt. max_e)
4768          e1 = e1 + elph_ds%delta_e
4769          out_nenergy = out_nenergy + 1
4770        end do
4771      end if
4772 
4773      if (low_T == 0) max_e = e1 - elph_ds%fermie
4774      elph_ds%nenergy = in_nenergy*2 + 1 + out_nenergy*2
4775 
4776    else ! semiconductor/insulator, need careful consideration later
4777      i_metal = 0
4778 !    between CB min and the next k point, use free electron to replace
4779 !    The weights will be proportional to the DOS, relative to the weights
4780 !    calculated with ep_fs_weights, tetrahedron method prefered
4781 
4782 !    output VB and CB edges for semiconductor/insulator
4783      e_vb_max = maxval(eigenGS(elph_ds%minFSband+elph_ds%nFSband/2-1,:,isppol))
4784      e_cb_min = minval(eigenGS(elph_ds%minFSband+elph_ds%nFSband/2,:,isppol))
4785      e_cb_2nd(1) = eigenGS(elph_ds%minFSband+elph_ds%nFSband/2,2,isppol)
4786      e_cb_2nd(2) = eigenGS(elph_ds%minFSband+elph_ds%nFSband/2+1,2,isppol)
4787      write(message,'(a,E20.12,2x,E20.12)')' elphon : top of VB, bottom of CB = ',&
4788 &     e_vb_max, e_cb_min
4789      call wrtout(std_out,message,'COLL')
4790      write(message,'(a,E20.12)')' elphon : energy at the neighbor kpt = ',e_cb_2nd(1)
4791      call wrtout(std_out,message,'COLL')
4792 
4793      n_edge1 = 4 ! at the very edge
4794      n_edge2 = 8  ! sparse to the end of free-electron part
4795 
4796      kpt_2nd(:) = gprimd(:,1)*elph_ds%k_fine%kptirr(1,2) + &
4797 &     gprimd(:,2)*elph_ds%k_fine%kptirr(2,2) + &
4798 &     gprimd(:,3)*elph_ds%k_fine%kptirr(3,2)
4799      write(message,'(a,3E20.12)')' The neighbor k point is:  ', elph_ds%k_fine%kptirr(:,2)
4800      call wrtout(std_out,message,'COLL')
4801 
4802      if (dabs(elph_ds%fermie-e_cb_min) .lt. dabs(elph_ds%fermie-e_vb_max)) then
4803        e1 = e_cb_2nd(1)
4804      else
4805        e1 = e_vb_max
4806      end if
4807      call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4808 &     e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4809 &     elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4810 &     elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4811 
4812      elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4813 
4814      eff_mass1 = (kpt_2nd(1)*kpt_2nd(1) + kpt_2nd(2)*kpt_2nd(2) + kpt_2nd(3)*kpt_2nd(3)) / &
4815 &     (2.0_dp*(e_cb_2nd(1)-e_cb_min))
4816      write(message,'(a,E20.12)')' The eff. mass from band1 is: ', eff_mass1
4817      call wrtout(std_out,message,'COLL')
4818      eff_mass2 = (kpt_2nd(1)*kpt_2nd(1) + kpt_2nd(2)*kpt_2nd(2) + kpt_2nd(3)*kpt_2nd(3)) / &
4819 &     (2.0_dp*(e_cb_2nd(2)-e_cb_min))
4820      write(message,'(a,E20.12)')' The eff. mass from band2 is: ', eff_mass2
4821      call wrtout(std_out,message,'COLL')
4822 
4823 !    bxu, but the eff. mass estimated in this way is too small
4824 !    The following is obtained by roughly fitting to the DOS of 48x48x48
4825      eff_mass1 = 0.91036
4826      write(message,'(a,E20.12)')' The eff. mass we are using is: ', eff_mass1
4827      call wrtout(std_out,message,'COLL')
4828 
4829      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 + &
4830 &     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
4831      write(message,'(a,E20.12)')' The fake DOS at kpt1 =   ', tmp_dos
4832      call wrtout(std_out,message,'COLL')
4833      write(message,'(a,E20.12)')' The calculated DOS at kpt1 =   ', elph_ds%n0(isppol)
4834      call wrtout(std_out,message,'COLL')
4835 
4836 
4837      e1 = elph_ds%fermie - max_e
4838      ie_all = 1
4839      ne_all = 0
4840      edge = 0
4841 
4842      call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4843 &     e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4844 &     elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4845 &     elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4846 
4847      elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4848      do while ((e1-elph_ds%fermie) .lt. max_e)
4849        if (e1 .lt. e_cb_min .and. elph_ds%n0(isppol) .lt. tol9) then
4850          e1 = e_cb_2nd(1)
4851          edge = 1
4852          e1 = e1 + de0
4853        end if
4854 
4855        if (e1 .lt. e_cb_2nd(1)) then
4856          e1 = e_cb_2nd(1)
4857          edge = 1
4858          e1 = e1 + de0
4859        end if
4860 
4861        if (e1 .gt. e_cb_2nd(1)) then
4862          call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4863 &         e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4864 &         elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4865 &         elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
4866 
4867          elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4868 
4869          e1 = e1 + de0
4870          ie_all = ie_all + 1
4871        end if
4872      end do ! e_all
4873      ne_all = ie_all - 1 + (n_edge1 + n_edge2 - 1)*edge ! energy levels in the free-electron range
4874      write(message,'(a,i3,a,i3,a)')' For spin', isppol, '  there are ', &
4875 &     ne_all, '  energy levels considered '
4876      call wrtout(std_out,message,'COLL')
4877 
4878      elph_ds%nenergy = ne_all
4879    end if ! metal or insulator
4880  end do ! isppol
4881 
4882  ABI_DEALLOCATE(tmp_wtk)
4883 
4884  if (elph_ds%nenergy .lt. 2) then
4885    MSG_ERROR('There are too few energy levels for non-LOVA')
4886  end if
4887 
4888  sz1=elph_ds%ngkkband;sz2=elph_ds%k_phon%nkpt
4889  sz3=elph_ds%nsppol;sz4=elph_ds%nenergy+1
4890  ABI_ALLOCATE(elph_tr_ds%dos_n,(sz4,sz3))
4891  ABI_ALLOCATE(elph_tr_ds%veloc_sq,(3,sz3,sz4))
4892  ABI_ALLOCATE(elph_tr_ds%en_all,(sz3,sz4))
4893  ABI_ALLOCATE(elph_tr_ds%de_all,(sz3,sz4+1))
4894  ABI_ALLOCATE(elph_tr_ds%tmp_gkk_intweight,(sz1,sz2,sz3,sz4))
4895  ABI_ALLOCATE(elph_tr_ds%tmp_velocwtk,(sz1,sz2,3,sz3,sz4))
4896  ABI_ALLOCATE(elph_tr_ds%tmp_vvelocwtk,(sz1,sz2,3,3,sz3,sz4))
4897 
4898  elph_tr_ds%dos_n = zero
4899  elph_tr_ds%veloc_sq = zero
4900  elph_tr_ds%tmp_gkk_intweight = zero
4901  elph_tr_ds%tmp_velocwtk = zero
4902  elph_tr_ds%tmp_vvelocwtk = zero
4903 
4904  ABI_STAT_ALLOCATE(elph_ds%k_phon%velocwtk,(elph_ds%nFSband,elph_ds%k_phon%nkpt,3,elph_ds%nsppol), ierr)
4905  ABI_CHECK(ierr==0, 'allocating elph_ds%k_phon%velocwtk')
4906 
4907  ABI_STAT_ALLOCATE(elph_ds%k_phon%vvelocwtk,(elph_ds%nFSband,elph_ds%k_phon%nkpt,3,3,elph_ds%nsppol), ierr)
4908  ABI_CHECK(ierr==0, 'allocating elph_ds%k_phon%vvelocwtk')
4909 
4910  elph_ds%k_phon%velocwtk = zero
4911  elph_ds%k_phon%vvelocwtk = zero
4912 
4913 !metal
4914  if (i_metal .eq. 1) then
4915    e1 = elph_ds%fermie - max_e
4916    en1(:) = elph_ds%fermie - max_e
4917    if (low_T .eq. 1) then
4918      enemin = elph_ds%fermie - max_e - elph_ds%delta_e
4919      enemax = elph_ds%fermie + max_e
4920 
4921      ABI_ALLOCATE(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol,elph_ds%nenergy+1))
4922      call ep_el_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4923 &     enemin, enemax, elph_ds%nenergy+1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4924 &     elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4925 &     elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine, tmp_wtk)
4926 
4927      do isppol=1,elph_ds%nsppol
4928        do ie1 = 1, elph_ds%nenergy
4929          elph_tr_ds%en_all(isppol,ie1) = en1(isppol)
4930          elph_tr_ds%de_all(isppol,ie1) = elph_ds%delta_e
4931 
4932          elph_ds%k_fine%wtk(:,:,isppol) = tmp_wtk(:,:,isppol,ie1+1)
4933          elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4934          elph_tr_ds%dos_n(ie1,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4935 
4936          call get_veloc_tr(elph_ds,elph_tr_ds)
4937          elph_tr_ds%veloc_sq(:,isppol,ie1)=elph_tr_ds%FSelecveloc_sq(:,isppol)
4938 
4939          call d2c_weights(elph_ds,elph_tr_ds)
4940 
4941          elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie1) = elph_ds%k_phon%wtk(:,:,isppol)
4942          elph_tr_ds%tmp_velocwtk(:,:,:,isppol,ie1) = elph_ds%k_phon%velocwtk(:,:,:,isppol)
4943          elph_tr_ds%tmp_vvelocwtk(:,:,:,:,isppol,ie1) = elph_ds%k_phon%vvelocwtk(:,:,:,:,isppol)
4944          en1(isppol) = en1(isppol) + elph_ds%delta_e
4945        end do
4946      end do
4947      ABI_DEALLOCATE(tmp_wtk)
4948 
4949    else ! low_T = 0
4950      enemin = e1 - elph_ds%delta_e
4951      enemax = e1 + (out_nenergy-1)*elph_ds%delta_e
4952 
4953      ABI_ALLOCATE(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol,out_nenergy+1))
4954      call ep_el_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4955 &     enemin, enemax, out_nenergy+1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4956 &     elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4957 &     elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine, tmp_wtk)
4958      do isppol=1,elph_ds%nsppol
4959        do ie1 = 1, out_nenergy
4960          elph_tr_ds%en_all(isppol,ie1) = en1(isppol)
4961          elph_tr_ds%de_all(isppol,ie1) = elph_ds%delta_e
4962 
4963          elph_ds%k_fine%wtk(:,:,isppol) = tmp_wtk(:,:,isppol,ie1+1)
4964          elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4965          elph_tr_ds%dos_n(ie1,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4966 
4967          call get_veloc_tr(elph_ds,elph_tr_ds)
4968          elph_tr_ds%veloc_sq(:,isppol,ie1)=elph_tr_ds%FSelecveloc_sq(:,isppol)
4969 
4970          call d2c_weights(elph_ds,elph_tr_ds)
4971 
4972          elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie1) = elph_ds%k_phon%wtk(:,:,isppol)
4973          elph_tr_ds%tmp_velocwtk(:,:,:,isppol,ie1) = elph_ds%k_phon%velocwtk(:,:,:,isppol)
4974          elph_tr_ds%tmp_vvelocwtk(:,:,:,:,isppol,ie1) = elph_ds%k_phon%vvelocwtk(:,:,:,:,isppol)
4975 
4976          en1(isppol) = en1(isppol) + elph_ds%delta_e
4977        end do
4978      end do
4979      ABI_DEALLOCATE(tmp_wtk)
4980 
4981      e1 = en1(1)
4982      enemin = e1 - de0
4983      enemax = e1 + in_nenergy*2*de0
4984 
4985      ABI_ALLOCATE(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol,in_nenergy*2+2))
4986      call ep_el_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
4987 &     enemin, enemax, in_nenergy*2+2, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
4988 &     elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
4989 &     elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine, tmp_wtk)
4990 
4991      do isppol=1,elph_ds%nsppol
4992        do ie1 = out_nenergy+1, out_nenergy+in_nenergy*2+1
4993          elph_tr_ds%en_all(isppol,ie1) = en1(isppol)
4994          elph_tr_ds%de_all(isppol,ie1) = de0
4995 
4996          elph_ds%k_fine%wtk(:,:,isppol) = tmp_wtk(:,:,isppol,ie1-out_nenergy+1)
4997          elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
4998          elph_tr_ds%dos_n(ie1,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
4999 
5000          call get_veloc_tr(elph_ds,elph_tr_ds)
5001          elph_tr_ds%veloc_sq(:,isppol,ie1)=elph_tr_ds%FSelecveloc_sq(:,isppol)
5002 
5003          call d2c_weights(elph_ds,elph_tr_ds)
5004 
5005          elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie1) = elph_ds%k_phon%wtk(:,:,isppol)
5006          elph_tr_ds%tmp_velocwtk(:,:,:,isppol,ie1) = elph_ds%k_phon%velocwtk(:,:,:,isppol)
5007          elph_tr_ds%tmp_vvelocwtk(:,:,:,:,isppol,ie1) = elph_ds%k_phon%vvelocwtk(:,:,:,:,isppol)
5008 
5009          en1(isppol) = en1(isppol) + de0
5010        end do
5011      end do
5012      ABI_DEALLOCATE(tmp_wtk)
5013 
5014      e1 = en1(1)
5015      enemin = e1 - elph_ds%delta_e
5016      enemax = e1 + (out_nenergy-1)*elph_ds%delta_e
5017 
5018      ABI_ALLOCATE(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol,out_nenergy+1))
5019      call ep_el_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
5020 &     enemin, enemax, out_nenergy+1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
5021 &     elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
5022 &     elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine, tmp_wtk)
5023 
5024      en1(:) = en1(:) - de0 + elph_ds%delta_e ! adjust to make the points symmetric around Ef
5025      do isppol=1,elph_ds%nsppol
5026        do ie1 = out_nenergy+in_nenergy*2+2, in_nenergy*2+1+out_nenergy*2
5027          elph_tr_ds%en_all(isppol,ie1) = en1(isppol)
5028          elph_tr_ds%de_all(isppol,ie1) = elph_ds%delta_e
5029 
5030          elph_ds%k_fine%wtk(:,:,isppol) = tmp_wtk(:,:,isppol,ie1-out_nenergy-in_nenergy*2)
5031          elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
5032          elph_tr_ds%dos_n(ie1,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
5033 
5034          call get_veloc_tr(elph_ds,elph_tr_ds)
5035          elph_tr_ds%veloc_sq(:,isppol,ie1)=elph_tr_ds%FSelecveloc_sq(:,isppol)
5036 
5037          call d2c_weights(elph_ds,elph_tr_ds)
5038 
5039          elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie1) = elph_ds%k_phon%wtk(:,:,isppol)
5040          elph_tr_ds%tmp_velocwtk(:,:,:,isppol,ie1) = elph_ds%k_phon%velocwtk(:,:,:,isppol)
5041          elph_tr_ds%tmp_vvelocwtk(:,:,:,:,isppol,ie1) = elph_ds%k_phon%vvelocwtk(:,:,:,:,isppol)
5042 
5043          en1(isppol) = en1(isppol) + elph_ds%delta_e
5044        end do
5045      end do
5046      ABI_DEALLOCATE(tmp_wtk)
5047    end if
5048 
5049 !semiconductor
5050  else if (i_metal .eq. 0) then
5051    e1 = elph_ds%fermie - max_e
5052    ie_all = 1
5053 
5054    call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
5055 &   e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
5056 &   elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
5057 &   elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
5058 
5059    elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
5060    do while ((e1-elph_ds%fermie) .lt. max_e)
5061      if (e1 .lt. e_cb_min .and. elph_ds%n0(isppol) .lt. tol9) then
5062        e1 = e_cb_min
5063      end if
5064 
5065      if (ie_all .ge. n_edge1+n_edge2) then
5066        if (ie_all .eq. n_edge1+n_edge2) e1 = e1 + de0
5067        call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
5068 &       e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
5069 &       elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
5070 &       elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
5071 
5072        elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie_all) = elph_ds%k_fine%wtk(:,:,isppol)
5073        elph_tr_ds%dos_n(ie_all,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
5074        elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
5075 
5076        elph_tr_ds%en_all(isppol,ie_all) = e1
5077        call get_veloc_tr(elph_ds,elph_tr_ds)
5078        elph_tr_ds%veloc_sq(:,isppol,ie_all)=elph_tr_ds%FSelecveloc_sq(:,isppol)
5079 !      bxu
5080 !      veloc_sq(1,isppol,ie_all) is "1" good and general??
5081 
5082        elph_tr_ds%de_all(isppol,ie_all) = de0
5083        e1 = e1 + elph_tr_ds%de_all(isppol,ie_all)
5084        ie_all = ie_all + 1
5085      else ! divided according to the 1/DOS (evenly)
5086        if (ie_all .lt. n_edge1) then
5087          elph_tr_ds%en_all(isppol,ie_all) = e_cb_min + &
5088 &         (e_tiny**(-0.5_dp) - ie_all*(e_tiny**(-0.5_dp)-(e_cb_2nd(1)-e_cb_min)**(-0.5_dp))/ &
5089 &         dble(n_edge1))**(-2.0_dp)
5090          if (ie_all .gt. 1) then
5091            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)
5092          else
5093            elph_tr_ds%de_all(isppol,ie_all) = elph_tr_ds%en_all(isppol,ie_all) - e_cb_min - e_tiny
5094          end if
5095          e1 = elph_tr_ds%en_all(isppol,ie_all)
5096        else
5097          elph_tr_ds%en_all(isppol,ie_all) = e_cb_min + &
5098 &         ((ie_all-n_edge1+1)/dble(n_edge2))**2.0_dp*(e_cb_2nd(1)-e_cb_min)
5099          if (ie_all .gt. 1) then
5100            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)
5101          else
5102            elph_tr_ds%de_all(isppol,ie_all) = (e_cb_2nd(1)-e_cb_min)/(dble(n_edge2)**2.0_dp)
5103          end if
5104          e1 = elph_tr_ds%en_all(isppol,ie_all)
5105        end if
5106 
5107        call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
5108 &       e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, max_occ, &
5109 &       elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
5110 &       elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
5111 
5112        elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
5113 
5114        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 + &
5115 &       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
5116        elph_tr_ds%dos_n(ie_all,isppol) = tmp_dos
5117        elph_tr_ds%tmp_gkk_intweight(:,:,isppol,ie_all) = elph_ds%k_fine%wtk(:,:,isppol)*tmp_dos/elph_ds%n0(isppol)
5118 
5119        call get_veloc_tr(elph_ds,elph_tr_ds)
5120        elph_tr_ds%veloc_sq(:,isppol,ie_all)=elph_tr_ds%FSelecveloc_sq(:,isppol)
5121 
5122        if (ie_all .eq. (n_edge1+n_edge2)) e1 = e_cb_2nd(1) + de0
5123        ie_all = ie_all + 1
5124      end if
5125    end do ! ie_all
5126  else
5127    MSG_BUG('check i_metal!')
5128  end if ! metal or insulator
5129 
5130  ABI_DEALLOCATE(dos_e1)
5131 
5132 end subroutine get_nv_fs_en

ABINIT/get_nv_fs_temp [ Functions ]

[ Top ] [ 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

PARENTS

      elphon

CHILDREN

      ebands_update_occ,ep_fs_weights,get_veloc_tr,wrtout

SOURCE

5176 subroutine get_nv_fs_temp(elph_ds,BSt,eigenGS,gprimd,max_occ,elph_tr_ds)
5177 
5178 
5179 !This section has been created automatically by the script Abilint (TD).
5180 !Do not modify the following lines by hand.
5181 #undef ABI_FUNC
5182 #define ABI_FUNC 'get_nv_fs_temp'
5183 !End of the abilint section
5184 
5185  implicit none
5186 
5187 !Arguments ------------------------------------
5188 
5189 !data_type
5190  type(elph_type),intent(inout) :: elph_ds
5191  type(ebands_t),intent(inout)   :: BSt
5192  type(elph_tr_type),intent(inout) :: elph_tr_ds
5193 
5194 !Scalars
5195  real(dp), intent(in) :: max_occ
5196 
5197 ! arrays
5198  real(dp), intent(in) :: gprimd(3,3)
5199  real(dp), intent(in) :: eigenGS(elph_ds%nband,elph_ds%k_fine%nkptirr,elph_ds%nsppol)
5200 
5201 !Local variables-------------------------------
5202 
5203  integer :: isppol!, ie1
5204  integer :: itemp, tmp_nenergy
5205 
5206  character(len=500) :: message
5207 
5208  real(dp) :: Temp, tmp_elphsmear, tmp_delta_e
5209 ! real(dp) :: xtr, e1
5210 ! real(dp),allocatable :: tmp_wtk(:,:)
5211 
5212 ! *************************************************************************
5213 
5214  ABI_ALLOCATE(elph_tr_ds%dos_n0,(elph_ds%ntemper,elph_ds%nsppol))
5215  ABI_ALLOCATE(elph_tr_ds%veloc_sq0,(elph_ds%ntemper,3,elph_ds%nsppol))
5216 !if (elph_ds%use_k_fine == 1) then
5217 !ABI_ALLOCATE(tmp_wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt))
5218 !else
5219 !ABI_ALLOCATE(tmp_wtk,(elph_ds%nFSband,elph_ds%k_phon%nkpt))
5220 !end if
5221 
5222  elph_tr_ds%dos_n0 = zero
5223  elph_tr_ds%veloc_sq0 = zero
5224 
5225  tmp_nenergy = 8
5226  do itemp=1,elph_ds%ntemper  ! runs over temperature in K
5227    Temp=elph_ds%tempermin + elph_ds%temperinc*dble(itemp)
5228    tmp_delta_e = kb_HaK*Temp
5229    Bst%occopt = 3
5230    Bst%tsmear = Temp*kb_HaK
5231    tmp_elphsmear = Temp*kb_HaK
5232    call ebands_update_occ(Bst,-99.99_dp)
5233    write(message,'(a,f12.6,a,E20.12)')'At T=',Temp,' Fermi level is:',Bst%fermie
5234    call wrtout(std_out,message,'COLL')
5235    if (abs(elph_ds%fermie) < tol10) then
5236      elph_ds%fermie = BSt%fermie
5237    end if
5238 
5239 !  FD smeared DOS and veloc
5240 
5241    call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, tmp_elphsmear, &
5242 &   elph_ds%fermie, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine,&
5243 &   max_occ, elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
5244 &   elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
5245 
5246    do isppol=1,elph_ds%nsppol
5247      elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
5248      write(message,'(a,f12.6,a,f12.6)')'At T=',Temp,' The DOS at Ef is:', elph_ds%n0(isppol)
5249      call wrtout(std_out,message,'COLL')
5250 
5251 !    For the non-LOVA case, N(Ef) is not that important (canceled out eventually).
5252 !    Should not be important for metal, comment out for now
5253 !    tmp_wtk = zero
5254 !    do ie1=-tmp_nenergy,tmp_nenergy ! use ie1 here, hope there is no confusion
5255 !    e1=Bst%fermie+ie1*tmp_delta_e
5256 !    xtr=(e1-Bst%fermie)/(2.0_dp*kb_HaK*Temp)
5257 !
5258 !    call ep_fs_weights(elph_ds%ep_b_min, elph_ds%ep_b_max, eigenGS, elph_ds%elphsmear, &
5259 !    &       e1, gprimd, elph_ds%k_fine%irredtoGS, elph_ds%kptrlatt_fine, &
5260 !    &       max_occ, elph_ds%minFSband, elph_ds%nband, elph_ds%nFSband, &
5261 !    &       elph_ds%nsppol, elph_ds%telphint, elph_ds%k_fine)
5262 !
5263 !    tmp_wtk(:,:) = tmp_wtk(:,:) + elph_ds%k_fine%wtk(:,:,isppol)* &
5264 !    &       tmp_delta_e/(4.0d0*kb_HaK*Temp)/(COSH(xtr)**2.0d0)
5265 !    end do ! ie1
5266 
5267 !    elph_ds%k_fine%wtk(:,:,isppol) = tmp_wtk(:,:)
5268      elph_tr_ds%dos_n0(itemp,isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
5269 !    elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt ! for get_veloc_tr
5270 !    write(message,'(a,f12.6,a,f12.6)')'At T=',Temp,' The eff. DOS at Ef is:', elph_tr_ds%dos_n0(itemp,isppol)
5271 !    call wrtout(std_out,message,'COLL')
5272    end do ! isppol
5273    call get_veloc_tr(elph_ds,elph_tr_ds)
5274    elph_tr_ds%veloc_sq0(itemp,:,:) = elph_tr_ds%FSelecveloc_sq(:,:)
5275 
5276  end do ! temperature
5277 
5278 end subroutine get_nv_fs_temp

ABINIT/get_veloc_tr [ Functions ]

[ Top ] [ 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

PARENTS

      elphon,get_nv_fs_en,get_nv_fs_temp

CHILDREN

SOURCE

5312 subroutine get_veloc_tr(elph_ds,elph_tr_ds)
5313 
5314 
5315 !This section has been created automatically by the script Abilint (TD).
5316 !Do not modify the following lines by hand.
5317 #undef ABI_FUNC
5318 #define ABI_FUNC 'get_veloc_tr'
5319 !End of the abilint section
5320 
5321   implicit none
5322 
5323 !Arguments ------------------------------------
5324 !arrays
5325   type(elph_type),intent(in) :: elph_ds
5326   type(elph_tr_type),intent(inout) :: elph_tr_ds
5327 
5328 !Local variables-------------------------------
5329   !scalars
5330   integer :: ikpt_fine
5331   integer :: ib1,fib1,isppol, ii
5332   real(dp) :: eta2
5333   !arrays
5334   real(dp) :: elvelock(3)
5335 
5336 ! *********************************************************************
5337 
5338  ABI_CHECK(allocated(elph_tr_ds%FSelecveloc_sq),"FSele not associated")
5339 
5340 
5341 !precalculate the Fermi speed modulus squared
5342  elph_tr_ds%FSelecveloc_sq = zero
5343  do isppol=1,elph_ds%nsppol
5344    do ikpt_fine=1,elph_ds%k_fine%nkpt
5345      do ib1=1,elph_ds%nFSband
5346        fib1=ib1+elph_ds%minFSband-1
5347        elvelock(:)=elph_tr_ds%el_veloc(ikpt_fine,fib1,:,isppol)
5348        do ii=1, 3
5349          eta2=elvelock(ii)*elvelock(ii)
5350          elph_tr_ds%FSelecveloc_sq(ii, isppol)=elph_tr_ds%FSelecveloc_sq(ii, isppol)&
5351 &         +eta2*elph_ds%k_fine%wtk(ib1,ikpt_fine,isppol)
5352        end do
5353      end do
5354    end do
5355    elph_tr_ds%FSelecveloc_sq(:,isppol) = elph_tr_ds%FSelecveloc_sq(:,isppol)/elph_ds%k_fine%nkpt/elph_ds%n0(isppol)
5356 !  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
5357  end do ! end isppol
5358  write (std_out,*) '  get_veloc_tr: FSelecveloc_sq ', elph_tr_ds%FSelecveloc_sq
5359 
5360  write (std_out,*) 'out of get_veloc_tr'
5361 
5362 end subroutine get_veloc_tr

ABINIT/integrate_gamma [ Functions ]

[ Top ] [ 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

PARENTS

      elphon

CHILDREN

      get_rank_1kpt,wrtout,xmpi_sum

SOURCE

5393 subroutine integrate_gamma(elph_ds,FSfullpqtofull)
5394 
5395 
5396 !This section has been created automatically by the script Abilint (TD).
5397 !Do not modify the following lines by hand.
5398 #undef ABI_FUNC
5399 #define ABI_FUNC 'integrate_gamma'
5400 !End of the abilint section
5401 
5402  implicit none
5403 
5404 !Arguments ------------------------------------
5405 !scalars
5406  type(elph_type),intent(inout) :: elph_ds
5407 !arrays
5408  integer,intent(in) :: FSfullpqtofull(elph_ds%k_phon%nkpt,elph_ds%nqpt_full)
5409 
5410 !Local variables-------------------------------
5411 !scalars
5412  integer :: comm,ikpt_phon,ikpt_phonq,ib1,ib2,ibeff,iqpt,iqpt_fullbz,isppol,ierr
5413  integer :: irec, symrankkpt_phon,nbranch,nsppol,ngkkband, ik_this_proc
5414  character(len=500) :: message
5415  character(len=fnlen) :: fname
5416 !arrays
5417  real(dp),allocatable :: tmp_gkk(:,:,:,:)
5418 
5419 ! *************************************************************************
5420 
5421  comm = xmpi_world
5422 
5423  write (message,'(3a)')ch10,' entering integrate_gamma ',ch10
5424  call wrtout(std_out,message,'COLL')
5425 
5426  nsppol   = elph_ds%nsppol
5427  nbranch  = elph_ds%nbranch
5428  ngkkband = elph_ds%ngkkband
5429 
5430  ABI_ALLOCATE(elph_ds%gamma_qpt,(2,nbranch**2,nsppol,elph_ds%nqpt_full))
5431  elph_ds%gamma_qpt = zero
5432 
5433  ABI_ALLOCATE(tmp_gkk ,(2,ngkkband**2,nbranch**2,nsppol))
5434 
5435  if (elph_ds%gkqwrite == 0) then
5436    call wrtout(std_out,' integrate_gamma : keeping gamma matrices in memory','COLL')
5437  else if (elph_ds%gkqwrite == 1) then
5438    fname=trim(elph_ds%elph_base_name) // '_GKKQ'
5439    write (message,'(2a)')' integrate_gamma : reading gamma matrices from file ',trim(fname)
5440    call wrtout(std_out,message,'COLL')
5441  else
5442    write (message,'(a,i0)')' Wrong value for gkqwrite = ',elph_ds%gkqwrite
5443    MSG_BUG(message)
5444  end if
5445 
5446 
5447 
5448  do iqpt=1,elph_ds%nqptirred
5449    iqpt_fullbz = elph_ds%qirredtofull(iqpt)
5450    call get_rank_1kpt (elph_ds%k_phon%kpt(:,iqpt_fullbz),symrankkpt_phon, elph_ds%k_phon%kptrank_t)
5451    write (std_out,*) ' iqpt_fullbz in qpt grid only,  rank ', iqpt_fullbz, symrankkpt_phon
5452 
5453    do ik_this_proc =1,elph_ds%k_phon%my_nkpt
5454      ikpt_phon = elph_ds%k_phon%my_ikpt(ik_this_proc)
5455 
5456      if (elph_ds%gkqwrite == 0) then
5457        tmp_gkk = elph_ds%gkk_qpt(:,:,:,ik_this_proc,:,iqpt)
5458      else if (elph_ds%gkqwrite == 1) then
5459        irec = (iqpt-1)*elph_ds%k_phon%my_nkpt+ik_this_proc
5460        if (ikpt_phon == 1) then
5461          write (std_out,*) ' integrate_gamma  read record ', irec
5462        end if
5463        read (elph_ds%unitgkq,REC=irec) tmp_gkk(:,:,:,:)
5464      end if
5465 
5466      do isppol=1,nsppol
5467        ikpt_phonq = FSfullpqtofull(ikpt_phon,iqpt_fullbz)
5468 !
5469        do ib1=1,ngkkband
5470          do ib2=1,ngkkband
5471            ibeff = ib2+(ib1-1)*ngkkband
5472            elph_ds%gamma_qpt(:,:,isppol,iqpt_fullbz) = elph_ds%gamma_qpt(:,:,isppol,iqpt_fullbz) + &
5473 &           tmp_gkk(:,ibeff,:,isppol)&
5474 &           *elph_ds%gkk_intweight(ib1,ikpt_phon,isppol)*elph_ds%gkk_intweight(ib2,ikpt_phonq,isppol)
5475 !          NOTE: if ngkkband==1 we are using trivial weights since average
5476 !          over bands was done in normsq_gkk (nmsq_gam_sumFS or nmsq_pure_gkk)
5477          end do ! ib2
5478        end do ! ib1
5479      end do ! isppol
5480    end do ! ikpt_phon
5481  end do ! iqpt
5482 
5483  call xmpi_sum (elph_ds%gamma_qpt, comm, ierr)
5484 
5485  ABI_DEALLOCATE(tmp_gkk)
5486 
5487 !need prefactor of 1/nkpt for each integration over 1 kpoint index. NOT INCLUDED IN elph_ds%gkk_intweight
5488  do iqpt=1,elph_ds%nqptirred
5489    iqpt_fullbz = elph_ds%qirredtofull(iqpt)
5490 !  elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) = elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) / elph_ds%k_phon%nkpt / n0(1) / n0(1)
5491 !  elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) = elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) / elph_ds%k_phon%nkpt / elph_ds%k_phon%nkpt
5492    elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) = elph_ds%gamma_qpt(:,:,:,iqpt_fullbz) * elph_ds%occ_factor / elph_ds%k_phon%nkpt
5493  end do
5494 
5495  call wrtout(std_out,' integrate_gamma: gamma matrices have been calculated for recip space and irred qpoints ',"COLL")
5496 
5497 end subroutine integrate_gamma

ABINIT/integrate_gamma_tr [ Functions ]

[ Top ] [ 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

PARENTS

      elphon

CHILDREN

      wrtout,xmpi_sum

SOURCE

5529 subroutine integrate_gamma_tr(elph_ds,FSfullpqtofull,s1,s2, veloc_sq1,veloc_sq2,elph_tr_ds)
5530 
5531 
5532 !This section has been created automatically by the script Abilint (TD).
5533 !Do not modify the following lines by hand.
5534 #undef ABI_FUNC
5535 #define ABI_FUNC 'integrate_gamma_tr'
5536 !End of the abilint section
5537 
5538  implicit none
5539 
5540 !Arguments ------------------------------------
5541 !scalars
5542  integer,intent(in) :: s1,s2
5543  type(elph_tr_type), intent(inout) :: elph_tr_ds
5544  type(elph_type),intent(in) :: elph_ds
5545 !arrays
5546  integer,intent(in) :: FSfullpqtofull(elph_ds%k_phon%nkpt,elph_ds%nqpt_full)
5547  real(dp),intent(in) :: veloc_sq1(3,elph_ds%nsppol), veloc_sq2(3,elph_ds%nsppol)
5548 
5549 !Local variables-------------------------------
5550 !scalars
5551  integer :: ikpt_phon,ikpt_phonq,ib1,ib2,ibeff,ierr,iqpt,iqpt_fullbz,isppol
5552  integer :: itensor, icomp, jcomp,comm
5553  integer :: fib1, fib2
5554  integer :: ik_this_proc
5555 ! integer :: ikpttemp
5556  character(len=500) :: message
5557  real(dp) :: wtk, wtkpq, interm
5558  real(dp) :: veloc1_i, veloc1_j, veloc2_i, veloc2_j
5559 !arrays
5560  real(dp) :: elvelock(3), elvelockpq(3)
5561  real(dp) :: velocwtk(3), velocwtkpq(3)
5562  real(dp) :: vvelocwtk(3,3), vvelocwtkpq(3,3)
5563  real(dp),allocatable :: tmp_gkk(:,:,:,:)
5564 
5565 ! *************************************************************************
5566 
5567  comm = xmpi_world
5568 
5569 !information
5570  if (elph_ds%gkqwrite == 0) then
5571    write (message,'(a)')' integrate_gamma_tr : keeping gamma matrices in memory'
5572    call wrtout(std_out,message,'COLL')
5573  else if (elph_ds%gkqwrite == 1) then
5574    write (message,'(a)')' integrate_gamma_tr : reading gamma matrices from disk'
5575    call wrtout(std_out,message,'COLL')
5576  else
5577    write (message,'(3a,i3)')' integrate_gamma_tr : BUG-',ch10,&
5578 &   ' Wrong value for gkqwrite = ',elph_ds%gkqwrite
5579    MSG_BUG(message)
5580  end if
5581 
5582 !allocate temp variables
5583  ABI_STAT_ALLOCATE(tmp_gkk,(2,elph_ds%ngkkband**2,elph_ds%nbranch**2,elph_ds%nsppol), ierr)
5584  ABI_CHECK(ierr==0, 'trying to allocate array tmp_gkkout')
5585 
5586  do iqpt=1,elph_ds%nqptirred
5587    iqpt_fullbz = elph_ds%qirredtofull(iqpt)
5588 !  write(std_out,*)'iqpt, iqptfullbz  ',iqpt, iqpt_fullbz
5589 
5590    do ik_this_proc =1,elph_ds%k_phon%my_nkpt
5591      ikpt_phon = elph_ds%k_phon%my_ikpt(ik_this_proc)
5592 
5593      if (elph_ds%gkqwrite == 0) then
5594        tmp_gkk = elph_ds%gkk_qpt(:,:,:,ik_this_proc,:,iqpt)
5595      else if (elph_ds%gkqwrite == 1) then
5596        read(elph_ds%unitgkq,REC=((iqpt-1)*elph_ds%k_phon%my_nkpt+ik_this_proc)) tmp_gkk
5597      end if
5598 
5599      ikpt_phonq = FSfullpqtofull(ikpt_phon,iqpt_fullbz)
5600 
5601      do isppol=1,elph_ds%nsppol
5602        do ib1=1,elph_ds%ngkkband !FS bands
5603          fib1=ib1+elph_ds%minFSband-1 ! full bands
5604          elvelock(:)=elph_tr_ds%el_veloc(ikpt_phon,fib1,:,isppol)
5605          wtk=elph_tr_ds%tmp_gkk_intweight1(ib1,ikpt_phon,isppol)
5606          velocwtk(:)=elph_tr_ds%tmp_velocwtk1(ib1,ikpt_phon,:,isppol)
5607          vvelocwtk(:,:)=elph_tr_ds%tmp_vvelocwtk1(ib1,ikpt_phon,:,:,isppol)
5608 
5609          do ib2=1,elph_ds%ngkkband ! FS bands
5610            ibeff=ib2+(ib1-1)*elph_ds%ngkkband ! full bands
5611            fib2=ib2+elph_ds%minFSband-1
5612            elvelockpq(:)= elph_tr_ds%el_veloc(ikpt_phonq,fib2,:,isppol)
5613            wtkpq=elph_tr_ds%tmp_gkk_intweight2(ib2,ikpt_phonq,isppol)
5614            velocwtkpq(:)=elph_tr_ds%tmp_velocwtk2(ib2,ikpt_phonq,:,isppol)
5615            vvelocwtkpq(:,:)=elph_tr_ds%tmp_vvelocwtk2(ib2,ikpt_phonq,:,:,isppol)
5616 
5617 !          MJV 31/03/2009: Note that the following is valid for any geometry, not just cubic!
5618 !          see eq 5 and 6 of prb 36 4103 (Al-Lehaibi et al 1987) [[cite:Al-Lehaibi1987]],
5619 !          see also Allen PRB 17 3725 [[cite:Allen1978]]
5620 !          generalization to tensorial quantities is simple, by keeping the directional
5621 !          references of velock and velockpq as indices.
5622            do icomp = 1, 3
5623              do jcomp = 1, 3
5624                itensor = (icomp-1)*3+jcomp
5625 !              FIXME: could use symmetry i <-> j
5626 
5627                veloc1_i = sqrt(veloc_sq1(icomp,isppol))
5628                veloc1_j = sqrt(veloc_sq1(jcomp,isppol))
5629                veloc2_i = sqrt(veloc_sq2(icomp,isppol))
5630                veloc2_j = sqrt(veloc_sq2(jcomp,isppol))
5631                if (elph_ds%use_k_fine == 1) then
5632                  interm = vvelocwtk(icomp,jcomp)*wtkpq/veloc1_i/veloc1_j + &
5633 &                 s1*s2*vvelocwtkpq(icomp,jcomp)*wtk/veloc2_i/veloc2_j - &
5634 &                 s1*velocwtk(jcomp)*velocwtkpq(icomp)/veloc1_j/veloc2_i - &
5635 &                 s2*velocwtk(icomp)*velocwtkpq(jcomp)/veloc1_i/veloc2_j
5636 
5637                  elph_tr_ds%gamma_qpt_tr(:,itensor,:,isppol,iqpt_fullbz) = &
5638 &                 elph_tr_ds%gamma_qpt_tr(:,itensor,:,isppol,iqpt_fullbz) + &
5639 &                 tmp_gkk(:,ibeff,:,isppol)*interm
5640                else
5641                  elph_tr_ds%gamma_qpt_tr(:,itensor,:,isppol,iqpt_fullbz) = &
5642 &                 elph_tr_ds%gamma_qpt_tr(:,itensor,:,isppol,iqpt_fullbz) + &
5643 &                 tmp_gkk(:,ibeff,:,isppol) &
5644 &                 *(elvelock(icomp)/veloc1_i - s1*elvelockpq(icomp)/veloc2_i) &
5645 &                 *(elvelock(jcomp)/veloc1_j - s2*elvelockpq(jcomp)/veloc2_j) &
5646 &                 *wtk*wtkpq
5647                end if
5648              end do
5649            end do
5650 
5651          end do
5652        end do
5653      end do ! isppol
5654 
5655    end do ! ik
5656  end do ! iq
5657 
5658  call xmpi_sum (elph_tr_ds%gamma_qpt_tr, comm, ierr)
5659 
5660  ABI_DEALLOCATE(tmp_gkk)
5661 
5662 
5663 !need prefactor of 1/nkpt for each integration over 1 kpoint index.
5664 !NOT INCLUDED IN elph_ds%gkk_intweight
5665 !Add a factor of 1/2 for the cross terms of (v-v')(v-v')
5666  elph_tr_ds%gamma_qpt_tr = elph_tr_ds%gamma_qpt_tr* elph_ds%occ_factor*0.5_dp / elph_ds%k_phon%nkpt
5667 
5668  write (message,'(2a)')' integrate_gamma_tr : transport gamma matrices are calculated ',&
5669 & ' in recip space and for irred qpoints'
5670 !call wrtout(std_out,message,'COLL')
5671 
5672 end subroutine integrate_gamma_tr

ABINIT/integrate_gamma_tr_lova [ Functions ]

[ Top ] [ 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

PARENTS

      elphon

CHILDREN

      wrtout,xmpi_sum

SOURCE

5703 subroutine integrate_gamma_tr_lova(elph_ds,FSfullpqtofull,elph_tr_ds)
5704 
5705 
5706 !This section has been created automatically by the script Abilint (TD).
5707 !Do not modify the following lines by hand.
5708 #undef ABI_FUNC
5709 #define ABI_FUNC 'integrate_gamma_tr_lova'
5710 !End of the abilint section
5711 
5712  implicit none
5713 
5714 !Arguments ------------------------------------
5715 !scalars
5716  type(elph_tr_type), intent(inout) :: elph_tr_ds
5717  type(elph_type),intent(in) :: elph_ds
5718 !arrays
5719  integer,intent(in) :: FSfullpqtofull(elph_ds%k_phon%nkpt,elph_ds%nqpt_full)
5720 
5721 !Local variables-------------------------------
5722 !scalars
5723  integer :: ikpt_phon,ikpt_phonq,ib1,ib2,ibeff,ierr,iqpt,iqpt_fullbz,isppol
5724  integer :: itensor, icomp, jcomp,comm
5725  integer :: fib1, fib2
5726  integer :: ik_this_proc
5727  real(dp) :: etain, etaout
5728  character(len=500) :: message
5729 !arrays
5730  real(dp) :: elvelock(3), elvelockpq(3)
5731  real(dp),allocatable :: tmp_gkk(:,:,:,:)
5732 
5733 ! *************************************************************************
5734 
5735  comm = xmpi_world
5736 
5737  ib1=elph_ds%nbranch*elph_ds%nbranch ; ib2=elph_ds%nqpt_full
5738  ABI_STAT_ALLOCATE(elph_tr_ds%gamma_qpt_trin,(2,9,ib1,elph_ds%nsppol,ib2), ierr)
5739  ABI_CHECK(ierr==0, 'trying to allocate array elph_tr_ds%gamma_qpt_trin')
5740  elph_tr_ds%gamma_qpt_trin = zero
5741 
5742  ABI_STAT_ALLOCATE(elph_tr_ds%gamma_qpt_trout,(2,9,ib1,elph_ds%nsppol,ib2), ierr)
5743  ABI_CHECK(ierr==0, 'trying to allocate array elph_tr_ds%gamma_qpt_trout')
5744  elph_tr_ds%gamma_qpt_trout = zero
5745 
5746 !information
5747  if (elph_ds%gkqwrite == 0) then
5748    write (message,'(a)')' integrate_gamma_tr : keeping gamma matrices in memory'
5749    call wrtout(std_out,message,'COLL')
5750  else if (elph_ds%gkqwrite == 1) then
5751    write (message,'(a)')' integrate_gamma_tr : reading gamma matrices from disk'
5752    call wrtout(std_out,message,'COLL')
5753  else
5754    write (message,'(3a,i3)')' integrate_gamma_tr : BUG-',ch10,&
5755 &   ' Wrong value for gkqwrite = ',elph_ds%gkqwrite
5756    MSG_ERROR(message)
5757  end if
5758 
5759 !allocate temp variables
5760  ABI_STAT_ALLOCATE(tmp_gkk,(2,elph_ds%ngkkband**2,elph_ds%nbranch**2,elph_ds%nsppol), ierr)
5761  ABI_CHECK(ierr==0, 'trying to allocate array tmp_gkkout')
5762 
5763  do iqpt=1,elph_ds%nqptirred
5764    iqpt_fullbz = elph_ds%qirredtofull(iqpt)
5765    write(std_out,*)'iqpt, iqptfullbz  ',iqpt, iqpt_fullbz
5766 
5767    do ik_this_proc =1,elph_ds%k_phon%my_nkpt
5768      ikpt_phon = elph_ds%k_phon%my_ikpt(ik_this_proc)
5769 
5770      if (elph_ds%gkqwrite == 0) then
5771        tmp_gkk = elph_ds%gkk_qpt(:,:,:,ik_this_proc,:,iqpt)
5772      else if (elph_ds%gkqwrite == 1) then
5773        read(elph_ds%unitgkq,REC=((iqpt-1)*elph_ds%k_phon%my_nkpt+ik_this_proc)) tmp_gkk
5774      end if
5775 
5776      ikpt_phonq = FSfullpqtofull(ikpt_phon,iqpt_fullbz)
5777 
5778      do isppol=1,elph_ds%nsppol
5779        do ib1=1,elph_ds%ngkkband
5780          fib1=ib1+elph_ds%minFSband-1
5781          elvelock(:)=elph_tr_ds%el_veloc(ikpt_phon,fib1,:,isppol)
5782 
5783          do ib2=1,elph_ds%ngkkband
5784            ibeff=ib2+(ib1-1)*elph_ds%ngkkband
5785            fib2=ib2+elph_ds%minFSband-1
5786            elvelockpq(:)= elph_tr_ds%el_veloc(ikpt_phonq,fib2,:,isppol)
5787 
5788 
5789 !          MJV 31/03/2009: Note that the following is valid for any geometry, not just cubic!
5790 !          see eq 5 and 6 of prb 36 4103 (Al-Lehaibi et al 1987) [[cite:Al-Lehaibi1987]]
5791 !          see also Allen PRB 17 3725 [[cite:Allen1978]]
5792 !          generalization to tensorial quantities is simple, by keeping the directional
5793 !          references of velock and velockpq as indices.
5794            do icomp = 1, 3
5795              do jcomp = 1, 3
5796                itensor = (icomp-1)*3+jcomp
5797 !              FIXME: could use symmetry i <-> j
5798 
5799                etain  = elvelock(icomp)*elvelockpq(jcomp)
5800                etaout = elvelock(icomp)*elvelock(jcomp)
5801 
5802 
5803                elph_tr_ds%gamma_qpt_trin(:,itensor,:,isppol,iqpt_fullbz) = &
5804 &               elph_tr_ds%gamma_qpt_trin(:,itensor,:,isppol,iqpt_fullbz) + &
5805 &               tmp_gkk(:,ibeff,:,isppol) &
5806 &               *etain &
5807 &               *elph_ds%gkk_intweight(ib1,ikpt_phon,isppol)*elph_ds%gkk_intweight(ib2,ikpt_phonq,isppol)
5808 
5809                elph_tr_ds%gamma_qpt_trout(:,itensor,:,isppol,iqpt_fullbz) = &
5810 &               elph_tr_ds%gamma_qpt_trout(:,itensor,:,isppol,iqpt_fullbz) + &
5811 &               tmp_gkk(:,ibeff,:,isppol) &
5812 &               *etaout &
5813 &               *elph_ds%gkk_intweight(ib1,ikpt_phon,isppol)*elph_ds%gkk_intweight(ib2,ikpt_phonq,isppol)
5814 
5815              end do
5816            end do
5817          end do
5818        end do
5819 
5820      end do ! isppol
5821    end do ! ik
5822 
5823  end do ! iq
5824 
5825  ABI_DEALLOCATE(tmp_gkk)
5826 
5827  call xmpi_sum (elph_tr_ds%gamma_qpt_trout, comm, ierr)
5828  call xmpi_sum (elph_tr_ds%gamma_qpt_trin, comm, ierr)
5829 
5830 
5831 !
5832 !normalize tensor with 1/sqrt(v_x**2 * v_y**2)
5833 !
5834 !move the veloc into mka2f_tr_lova, where T dependence is dealt with
5835 !This will cause some slight difference to the results
5836  if (.true.) then
5837    do isppol=1, elph_ds%nsppol
5838      do icomp = 1, 3
5839        do jcomp = 1, 3
5840          itensor = (icomp-1)*3+jcomp
5841          if(abs(elph_tr_ds%FSelecveloc_sq(icomp,isppol))>tol14**2 .and. abs(elph_tr_ds%FSelecveloc_sq(jcomp,isppol))>tol14**2)then
5842            elph_tr_ds%gamma_qpt_trin(:,itensor,:,isppol,:) = elph_tr_ds%gamma_qpt_trin(:,itensor,:,isppol,:) / &
5843 &           sqrt(elph_tr_ds%FSelecveloc_sq(icomp,isppol)*elph_tr_ds%FSelecveloc_sq(jcomp,isppol))
5844            elph_tr_ds%gamma_qpt_trout(:,itensor,:,isppol,:) = elph_tr_ds%gamma_qpt_trout(:,itensor,:,isppol,:) / &
5845 &           sqrt(elph_tr_ds%FSelecveloc_sq(icomp,isppol)*elph_tr_ds%FSelecveloc_sq(jcomp,isppol))
5846          else
5847 !          XG120528 Fixed problem with zero velocity
5848            elph_tr_ds%gamma_qpt_trin(:,itensor,:,isppol,:)=zero
5849            elph_tr_ds%gamma_qpt_trout(:,itensor,:,isppol,:)=zero
5850          end if
5851        end do
5852      end do
5853    end do ! isppol
5854  end if
5855 
5856 !need prefactor of 1/nkpt for each integration over 1 kpoint index.
5857 !NOT INCLUDED IN elph_ds%gkk_intweight
5858  elph_tr_ds%gamma_qpt_trout = elph_tr_ds%gamma_qpt_trout* elph_ds%occ_factor / elph_ds%k_phon%nkpt
5859  elph_tr_ds%gamma_qpt_trin  = elph_tr_ds%gamma_qpt_trin * elph_ds%occ_factor / elph_ds%k_phon%nkpt
5860 
5861  write (message,'(2a)')' integrate_gamma_tr : transport gamma matrices are calculated ',&
5862 & ' in recip space and for irred qpoints'
5863  call wrtout(std_out,message,'COLL')
5864 
5865 !DEBUG
5866 !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)
5867 !ENDDEBUG
5868 
5869 end subroutine integrate_gamma_tr_lova

ABINIT/interpolate_gkk [ Functions ]

[ Top ] [ 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

PARENTS

      get_all_gkk2

CHILDREN

      ftgkk,ifc_fourq,wrap2_pmhalf,zhpev

SOURCE

3760 subroutine interpolate_gkk(crystal,ifc,elph_ds,kpt_phon)
3761 
3762 
3763 !This section has been created automatically by the script Abilint (TD).
3764 !Do not modify the following lines by hand.
3765 #undef ABI_FUNC
3766 #define ABI_FUNC 'interpolate_gkk'
3767 !End of the abilint section
3768 
3769  implicit none
3770 
3771 !Arguments ------------------------------------
3772 !scalars
3773  type(crystal_t),intent(in) :: crystal
3774  type(ifc_type),intent(in) :: ifc
3775  type(elph_type),intent(inout) :: elph_ds
3776 !arrays
3777  real(dp),intent(in) :: kpt_phon(3,elph_ds%k_phon%nkpt)
3778 
3779 !Local variables-------------------------------
3780   ! output variables for dfpt_phfrq
3781 ! variables for zhpev
3782 ! variables for phonon interpolation
3783 !scalars
3784  integer :: i1,i2,ikpt_phon2,iFSqpt,ib1,ib2,ier,ii
3785  integer :: iost,isppol,qtor,natom
3786  integer :: sz1,sz2,sz3,sz4,unit_gkkp
3787  real(dp) :: qphnrm,res
3788  !character(len=500) :: msg
3789 !arrays
3790  real(dp) :: gprim(3,3)
3791  real(dp) :: displ(2,elph_ds%nbranch,elph_ds%nbranch),eigval(3*crystal%natom)
3792  real(dp) :: eigvec(3*3*crystal%natom*3*crystal%natom)
3793  real(dp) :: pheigvec(2*elph_ds%nbranch*elph_ds%nbranch)
3794  real(dp) :: phfrq_tmp(elph_ds%nbranch),qphon(3),redkpt(3)
3795  real(dp),allocatable :: gkk2_diag_tmp(:,:,:,:),gkk2_tmp(:,:,:,:,:,:,:)
3796  real(dp),allocatable :: matrx(:,:),zhpev1(:,:)
3797  real(dp),allocatable :: zhpev2(:)
3798 
3799 ! *************************************************************************
3800 
3801 !
3802 !NOTE: mjv 18/5/2008 reverted to old style of ftgkk with all kpt done together.
3803 !may want to modify this later to use the new cleaner format with 1 FT at a
3804 !time.
3805 !
3806  write(std_out,*) 'interpolate_gkk : enter'
3807 
3808  natom = crystal%natom
3809  gprim = ifc%gprim
3810 
3811  if (elph_ds%nsppol /= 1) then
3812    MSG_ERROR("interpolate_gkk not coded with nsppol>1 yet")
3813  end if
3814  isppol = 1
3815 
3816 
3817 !------------------------------------------------------
3818 !complete dynamical matrices for all qpts between points
3819 !on full kpt grid (interpolation from IFC)
3820 !------------------------------------------------------
3821 
3822  sz1=elph_ds%ngkkband;sz2=elph_ds%nbranch
3823  sz3=elph_ds%k_phon%nkpt;sz4=elph_ds%nFSband
3824 !allocate (gkk_tmp(2,sz1,sz1,sz2,sz2,1,1))
3825 !DEBUG
3826 !allocate (gkk_tmp_full(2,sz1,sz1,sz2,elph_ds%nFSband,sz3))
3827 !allocate (gkk_tmp_full(2,s2,sz4,sz4,sz3))
3828 !ENDDEBUG
3829  ABI_ALLOCATE(gkk2_tmp,(2,sz1,sz1,sz2,sz2,sz3,1))
3830  ABI_ALLOCATE(gkk2_diag_tmp,(sz1,sz1,sz2,sz3))
3831  ABI_ALLOCATE(zhpev1,(2,2*3*natom-1))
3832  ABI_ALLOCATE(zhpev2,(3*3*natom-2))
3833  ABI_ALLOCATE(matrx,(2,(3*natom*(3*natom+1))/2))
3834 
3835  qphnrm = one
3836 !in this part use the inverse Fourier transform to get 1 (arbitrary) qpt at a
3837 !time
3838  ii = 0
3839  qtor = 0
3840  unit_gkkp = 150
3841  open (unit=unit_gkkp,file='gkkp_file_ascii',form='formatted',status='unknown',iostat=iost)
3842  if (iost /= 0) then
3843    MSG_ERROR("error opening gkkpfile as new")
3844  end if
3845 
3846 !loop over all FS pairs.
3847 !do ikpt1=1,elph_ds%k_phon%nkptirr
3848 !do iFSqpt=1,elph_ds%k_phon%nkpt
3849 
3850 !
3851 !this should run through the sparse mesh of 2x2x2 kpoints
3852 !
3853  do iFSqpt=1,elph_ds%k_phon%nkpt
3854    res = 2.0_dp*(kpt_phon(1,iFSqpt)+one)
3855    if (abs(res-int(res)) > tol10) cycle
3856    res = 2.0_dp*(kpt_phon(2,iFSqpt)+one)
3857    if (abs(res-int(res)) > tol10) cycle
3858    res = 2.0_dp*(kpt_phon(3,iFSqpt)+one)
3859    if (abs(res-int(res)) > tol10) cycle
3860 
3861 !  do ikpt1=1,1
3862 !
3863 !  NOTE: should be very easy to parallelize!
3864 !
3865 !  write(std_out,*) ' interpolate_gkk : ikpt1 = ',ikpt1, ' / ', elph_ds%k_phon%nkptirr
3866    write(std_out,*) ' interpolate_gkk : ikpt1 = ',iFSqpt, ' / ', elph_ds%k_phon%nkpt
3867 
3868 !  DEBUG
3869 !  write(std_out,*) ' interpolate_gkk : Warning debug version'
3870 !  cycle
3871 !  ENDDEBUG
3872 
3873    gkk2_tmp(:,:,:,:,:,:,:) = zero
3874 
3875 !  qphon = 1 - 2    ie.  1 = 2+qphon
3876    qphon(:) = kpt_phon(:,iFSqpt)
3877 
3878 !  shouldnt be necessary here, but oh well
3879    call wrap2_pmhalf(qphon(1),redkpt(1),res)
3880    call wrap2_pmhalf(qphon(2),redkpt(2),res)
3881    call wrap2_pmhalf(qphon(3),redkpt(3),res)
3882 
3883    qphon(:) = redkpt(:)
3884    redkpt(1) = qphon(1)*gprim(1,1)+qphon(2)*gprim(1,2)+qphon(3)*gprim(1,3)
3885    redkpt(2) = qphon(1)*gprim(2,1)+qphon(2)*gprim(2,2)+qphon(3)*gprim(2,3)
3886    redkpt(3) = qphon(1)*gprim(3,1)+qphon(2)*gprim(3,2)+qphon(3)*gprim(3,3)
3887    write (unit_gkkp,*) 'qp= ', redkpt
3888 
3889    call ifc_fourq(ifc,crystal,qphon,phfrq_tmp,displ,out_eigvec=pheigvec)
3890    write (unit_gkkp,*) phfrq_tmp(:)*Ha_cmm1
3891 
3892    ii = ii+1
3893 !  if(ii > 0 .and. ii < 1000) write(std_out,'(a,i5,3E16.6,2x)') &
3894 !  &   ' wrote phfrq_tmp for time ', ii, phfrq_tmp
3895 !  end if
3896 
3897 !  phonon eigenvectors are in eigvec
3898 !  real and imaginary parts
3899 !  phonon displacements = eigvec/sqrt(M_i) are in displ
3900 !  real and imaginary parts
3901 
3902 !  DEBUG
3903 !  test: uniform phonon frequency
3904 !  phfrq_tmp(:) = 0.0001_dp
3905 !  ENDDEBUG
3906 
3907 !  FT gamma matrices for all kpt_phon points, and
3908 !  for qpoint = qphon(:) = kpt_phon(ikpt_phon)
3909 
3910    call ftgkk(ifc%wghatm,gkk2_tmp,elph_ds%gkk_rpt,elph_ds%gkqwrite,&
3911 &   elph_ds%gkk_rptwrite,gprim,1,&
3912 &   natom,elph_ds%k_phon%nkpt,elph_ds%ngkkband,elph_ds%k_phon%nkpt,1,ifc%nrpt,elph_ds%nsppol,&
3913 &   qtor,ifc%rpt,qphon,elph_ds%unit_gkk_rpt,elph_ds%unitgkq)
3914 
3915 !  NOTE: Normally the eigenvectors of the gkk2_tmp should be the same as eigvec
3916 
3917 !  Diagonalize gamma matrices at qpoint (complex matrix) for all kpt_phon.
3918 !  Copied from dfpt_phfrq
3919    do ikpt_phon2=1,elph_ds%k_phon%nkpt
3920      res = 8.0_dp*(kpt_phon(1,ikpt_phon2)+one)
3921      if (abs(res-int(res)) > tol10) cycle
3922      res = 8.0_dp*(kpt_phon(2,ikpt_phon2)+one)
3923      if (abs(res-int(res)) > tol10) cycle
3924      res = 8.0_dp*(kpt_phon(3,ikpt_phon2)+one)
3925      if (abs(res-int(res)) > tol10) cycle
3926 
3927      write (unit_gkkp,*) 'kp= ', kpt_phon(:,ikpt_phon2)
3928 
3929      do ib1=1,elph_ds%ngkkband
3930        do ib2=1,elph_ds%ngkkband
3931          ier=0
3932          ii=1
3933          do i2=1,3*natom
3934            do i1=1,i2
3935              matrx(1,ii)=gkk2_tmp(1,ib1,ib2,i1,i2,ikpt_phon2,1)
3936              matrx(2,ii)=gkk2_tmp(2,ib1,ib2,i1,i2,ikpt_phon2,1)
3937              ii=ii+1
3938            end do
3939          end do
3940          call ZHPEV ('N','U',3*natom,matrx,eigval,eigvec,3*natom,zhpev1,&
3941 &         zhpev2,ier)
3942 
3943          gkk2_diag_tmp(ib2,ib1,:,ikpt_phon2) = eigval(:)
3944          do i1=1,3*natom
3945            write (unit_gkkp,*) elph_ds%minFSband-1+ib1,elph_ds%minFSband-1+ib2,i1,&
3946 &           eigval(i1)
3947          end do
3948        end do
3949      end do
3950    end do
3951 
3952    if (elph_ds%gkk2write == 1) then
3953      write(std_out,*) 'WARNING COMMENTED WRITE TO BINARY FILE!!!'
3954 !    write (elph_ds%unit_gkk2,REC=iFSqpt) gkk2_diag_tmp(:,:,:,:)
3955      write(std_out,'(a,i4,4(2E16.6,2x))') ' gkk2 loop ', &
3956 &     iFSqpt,gkk2_diag_tmp(1,1,:,1:2),gkk2_diag_tmp(1,1,:,elph_ds%k_phon%nkpt-1:elph_ds%k_phon%nkpt)
3957 !    &    ikpt1,gkk2_tmp(:,1,1,1,1,1:2),gkk2_tmp(:,1,1,elph_ds%k_phon%nkpt-1:elph_ds%k_phon%nkpt)
3958    else if (elph_ds%gkk2write == 0) then
3959      elph_ds%gkk2(:,:,:,:,iFSqpt,isppol) = gkk2_diag_tmp(:,:,:,:)
3960 !    elph_ds%gkk2(:,:,:,:,ikpt1) = gkk2_tmp
3961      write(std_out,*) ' interpolate_gkk : gkk2(b=1,b=1,:,kpt=1,iFSqpt) = '
3962      write(std_out,*) gkk2_diag_tmp(1,1,:,1)
3963    end if
3964 
3965  end do
3966 !end do on iFSqpt
3967 
3968  ABI_DEALLOCATE(matrx)
3969  ABI_DEALLOCATE(zhpev1)
3970  ABI_DEALLOCATE(zhpev2)
3971 
3972 end subroutine interpolate_gkk

ABINIT/m_elphon [ Modules ]

[ Top ] [ 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-2018 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 .

PARENTS

CHILDREN

SOURCE

23 #if defined HAVE_CONFIG_H
24 #include "config.h"
25 #endif
26 
27 #include "abi_common.h"
28 
29 module m_elphon
30 
31  use defs_basis
32  use defs_datatypes
33  use defs_abitypes
34  use defs_elphon
35  use m_abicore
36  use m_kptrank
37  use m_errors
38  use m_xmpi
39  use m_hdr
40  use m_ebands
41 
42  use m_fstrings,        only : int2char4
43  use m_io_tools,        only : open_file, is_open, get_unit
44  use m_time,            only : timein
45  use m_numeric_tools,   only : wrap2_pmhalf, simpson, simpson_int
46  use m_pptools,         only : printvtk
47  use m_dynmat,          only : ftgam_init, ftgam
48  use m_geometry,        only : phdispl_cart2red
49  use m_kpts,            only : getkgrid, smpbz
50  use m_crystal,         only : crystal_t
51  use m_ifc,             only : ifc_type, ifc_fourq
52  use m_nesting,         only : mknesting, bfactor
53  use m_anaddb_dataset,  only : anaddb_dataset_type
54  use m_eliashberg_1d,   only : eliashberg_1d
55  use m_iogkk,           only : read_el_veloc,  read_gkk
56  use m_bz_mesh,         only : make_path
57  use m_fstab,           only : mkqptequiv
58  use m_epweights,       only : d2c_weights, ep_el_weights, ep_fs_weights
59  use m_a2ftr,           only : mka2f_tr, mka2f_tr_lova, get_tau_k
60  use m_symkpt,     only : symkpt
61 
62  implicit none
63 
64  private

ABINIT/mkph_linwid [ Functions ]

[ Top ] [ 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

PARENTS

      elphon

CHILDREN

      ftgam,ftgam_init,gam_mult_displ,ifc_fourq,make_path,phdispl_cart2red
      wrap2_pmhalf,wrtout,zgemm

SOURCE

3151 subroutine mkph_linwid(Cryst,ifc,elph_ds,nqpath,qpath_vertices)
3152 
3153 
3154 !This section has been created automatically by the script Abilint (TD).
3155 !Do not modify the following lines by hand.
3156 #undef ABI_FUNC
3157 #define ABI_FUNC 'mkph_linwid'
3158 !End of the abilint section
3159 
3160  implicit none
3161 
3162 !Arguments ------------------------------------
3163 !scalars
3164  integer,intent(in) :: nqpath
3165  type(crystal_t),intent(in) :: Cryst
3166  type(ifc_type),intent(in) :: ifc
3167  type(elph_type),intent(inout) :: elph_ds
3168 !arrays
3169  real(dp),intent(in) :: qpath_vertices(3,nqpath)
3170 
3171 !Local variables-------------------------------
3172 !scalars
3173  integer :: ibranch,natom,ii,indx,ipoint,nbranch,nqbz,nsppol,nrpt
3174  integer :: isppol,jbranch,qtor,unit_bs,unit_lambda,unit_lwd,npt_tot
3175  real(dp) :: diagerr,res
3176  character(len=500) :: msg
3177  character(len=fnlen) :: fname,base_name
3178 !arrays
3179  integer :: ndiv(nqpath-1)
3180  integer, allocatable :: indxprtqpt(:)
3181  real(dp),parameter :: c0(2)=(/0._dp,0._dp/),c1(2)=(/1._dp,0._dp/)
3182  real(dp) :: displ_cart(2,3*Cryst%natom,3*Cryst%natom)
3183  real(dp) :: displ_red(2,3*Cryst%natom,3*Cryst%natom)
3184  real(dp) :: eigval(3*Cryst%natom)
3185  real(dp) :: gam_now(2,(3*Cryst%natom)**2)
3186  real(dp) :: imeigval(3*Cryst%natom)
3187  real(dp) :: lambda(3*Cryst%natom)
3188  real(dp) :: pheigvec(2*3*Cryst%natom*3*Cryst%natom),phfrq_tmp(3*Cryst%natom)
3189  real(dp) :: qpt(3),redkpt(3)
3190  real(dp) :: tmpgam1(2,3*Cryst%natom,3*Cryst%natom)
3191  real(dp) :: tmpgam2(2,3*Cryst%natom,3*Cryst%natom)
3192  real(dp), allocatable :: coskr(:,:), sinkr(:,:),finepath(:,:)
3193 
3194 ! *********************************************************************
3195 
3196  DBG_ENTER("COLL")
3197 
3198  natom     = Cryst%natom
3199  nbranch   = elph_ds%nbranch
3200  nsppol    = elph_ds%nsppol
3201  base_name = elph_ds%elph_base_name
3202  nrpt = ifc%nrpt
3203 
3204 !===================================================================
3205 !Definition of the q path along which ph linwid will be interpolated
3206 !===================================================================
3207  call make_path(nqpath,qpath_vertices,Cryst%gmet,'G',20,ndiv,npt_tot,finepath)
3208  ABI_ALLOCATE(indxprtqpt,(npt_tot))
3209  indxprtqpt = 0
3210 
3211 !==========================================================
3212 !Open _LWD file and write header
3213 !==========================================================
3214  fname=trim(base_name) // '_LWD'
3215  if (open_file(fname,msg,newunit=unit_lwd,status="unknown") /= 0) then
3216    MSG_ERROR(msg)
3217  end if
3218 
3219  write (unit_lwd,'(a)')       '#'
3220  write (unit_lwd,'(a)')       '# ABINIT package : Phonon linewidth file'
3221  write (unit_lwd,'(a)')       '#'
3222  write (unit_lwd,'(a,i10,a)') '#  Phonon linewidths calculated on ',npt_tot,' points along the qpath'
3223  write (unit_lwd,'(a)')       '#  Description of the Q-path :'
3224  write (unit_lwd, '(a,i10)')  '#  Number of line segments = ',nqpath-1
3225  write (unit_lwd,'(a)')       '#  Vertices of the Q-path and corresponding index = '
3226 
3227  indx=1
3228  indxprtqpt(1) = 1
3229  indxprtqpt(npt_tot) = 1
3230 
3231  do ii=1,nqpath
3232    write (unit_lwd,'(a,3(e16.6,1x),i8)')'#  ',qpath_vertices(:,ii),indx
3233    if (ii<nqpath) then
3234      indx=indx+ndiv(ii)
3235      indxprtqpt(indx) = 1
3236    end if
3237  end do
3238 
3239  write (unit_lwd,'(a)')'#'
3240 
3241 !==========================================================
3242 !Open _BST file and write header
3243 !==========================================================
3244  fname=trim(base_name) // '_BST'
3245  if (open_file(fname,msg,newunit=unit_bs,status="unknown") /= 0) then
3246    MSG_ERROR(msg)
3247  end if
3248 
3249  write (unit_bs, '(a)')      '#'
3250  write (unit_bs, '(a)')      '# ABINIT package : Phonon band structure file'
3251  write (unit_bs, '(a)')      '#'
3252  write (unit_bs, '(a,i10,a)')'# Phonon BS calculated on ', npt_tot,' points along the qpath'
3253  write (unit_bs, '(a,i10)')  '# Number of line segments = ', nqpath-1
3254  indx=1
3255  do ii=1,nqpath
3256    write (unit_bs,'(a,3(E16.6,1x),i8)')'#  ',qpath_vertices(:,ii),indx
3257    if (ii<nqpath) indx=indx+ndiv(ii)
3258  end do
3259  write (unit_bs,'(a)')'#'
3260 
3261 !MG20060606
3262 !==========================================================
3263 !open _LAMBDA file and write header
3264 !contains \omega(q,n) and \lambda(q,n) and can be plotted using xmgrace
3265 !==========================================================
3266  fname=trim(base_name) // '_LAMBDA'
3267  if (open_file(fname,msg,newunit=unit_lambda,status="unknown") /= 0) then
3268    MSG_ERROR(msg)
3269  end if
3270 
3271  write (unit_lambda,'(a)')      '#'
3272  write (unit_lambda,'(a)')      '# ABINIT package : Lambda file'
3273  write (unit_lambda,'(a)')      '#'
3274  write (unit_lambda,'(a,i10,a)')'#  Lambda(q,nu) calculated on ',npt_tot,' Q-points'
3275  write (unit_lambda,'(a)')      '# Description of the Q-path :'
3276  write (unit_lambda,'(a,i10)')  '# Number of line segments = ',nqpath-1
3277  write (unit_lambda,'(a)')      '# Vertices of the Q-path and corresponding index = '
3278 
3279  indx=1
3280  do ii=1,nqpath
3281    write (unit_lambda,'(a,3(E16.6,1x),i8)')'#  ',qpath_vertices(:,ii),indx
3282    if (ii<nqpath) indx=indx+ndiv(ii)
3283  end do
3284  write (unit_lambda,'(a)')'#'
3285  write (unit_lambda,'(a)')'# index frequency lambda(q,n) frequency lambda(q,n) .... lambda_tot'
3286  write (unit_lambda,'(a)')'#'
3287 
3288 !real space to q space
3289  qtor=0
3290 
3291 !initialize the maximum phonon frequency
3292  elph_ds%omega_min = zero
3293  elph_ds%omega_max = zero
3294 
3295  ABI_ALLOCATE(coskr, (npt_tot,nrpt))
3296  ABI_ALLOCATE(sinkr, (npt_tot,nrpt))
3297  call ftgam_init(ifc%gprim, npt_tot, nrpt, finepath, ifc%rpt, coskr, sinkr)
3298 
3299  write (std_out,*) ' mkph_linwid : shape(elph_ds%gamma_qpt) = ',shape(elph_ds%gamma_qpt)
3300  nqbz =  SIZE(elph_ds%gamma_qpt,DIM=4)
3301  write(std_out,*) " nqbz =  SIZE(elph_ds%gamma_qpt,DIM=4) = ",nqbz
3302 !
3303 !Big do loop over spin polarizations
3304 !could put in locally, so phonon stuff is not done twice...
3305 !
3306  do isppol=1,nsppol
3307    indx=1
3308 
3309 !  Output to the main output file
3310    write(msg,'(a,a)')ch10,&
3311 &   ' Output of the linewidths for the first point of each segment. Linewidths are given in Hartree.'
3312    call wrtout(std_out,msg,'COLL')
3313    call wrtout(ab_out,msg,'COLL')
3314 
3315    write (std_out,*) ' mkph_linwid : elph_ds%ep_scalprod = ', elph_ds%ep_scalprod
3316 
3317    qtor = 0
3318 
3319 !  Interpolation along specified path in q space
3320    do ipoint=1,npt_tot
3321 
3322 !    Get qpoint along the path from qpath_vertices
3323      qpt(:) = finepath(:,ipoint)
3324 
3325      call wrap2_pmhalf(qpt(1),redkpt(1),res)
3326      call wrap2_pmhalf(qpt(2),redkpt(2),res)
3327      call wrap2_pmhalf(qpt(3),redkpt(3),res)
3328      qpt(:) = redkpt(:)
3329 !
3330 !    This reduced version of ftgkk supposes the kpoints have been integrated
3331 !    in integrate_gamma. Do FT from real-space gamma grid to 1 qpt.
3332      call ftgam(ifc%wghatm,gam_now,elph_ds%gamma_rpt(:,:,isppol,:),natom,1,ifc%nrpt,qtor, &
3333 &     coskr(ipoint,:), sinkr(ipoint,:))
3334 !
3335 !    get phonon freqs and eigenvectors anyway
3336 !
3337      call ifc_fourq(ifc,cryst,qpt,phfrq_tmp,displ_cart,out_eigvec=pheigvec)
3338 !
3339 !    additional frequency factor for some cases
3340 !
3341 !    If the matrices do not contain the scalar product with the displ_cart vectors yet do it now
3342      if (elph_ds%ep_scalprod == 0) then
3343 
3344        call phdispl_cart2red(natom,Cryst%gprimd,displ_cart,displ_red)
3345 
3346        tmpgam2 = reshape (gam_now, (/2,nbranch,nbranch/))
3347        call gam_mult_displ(nbranch, displ_red, tmpgam2, tmpgam1)
3348 
3349        do jbranch=1,nbranch
3350          eigval(jbranch) = tmpgam1(1, jbranch, jbranch)
3351          imeigval(jbranch) = tmpgam1(2, jbranch, jbranch)
3352 
3353          if (abs(imeigval(jbranch)) > tol8) then
3354            write (msg,'(a,i0,a,es16.8)')' imaginary values for branch = ',jbranch,' imeigval = ',imeigval(jbranch)
3355            MSG_WARNING(msg)
3356          end if
3357        end do
3358 
3359      else if (elph_ds%ep_scalprod == 1) then
3360 !
3361 !      Diagonalize gamma matrix at qpoint (complex matrix).
3362 !      MJV NOTE: gam_now is recast implicitly here to matrix
3363        call ZGEMM ( 'N', 'N', 3*natom, 3*natom, 3*natom, c1, gam_now, 3*natom,&
3364 &       pheigvec, 3*natom, c0, tmpgam1, 3*natom)
3365 
3366        call ZGEMM ( 'C', 'N', 3*natom, 3*natom, 3*natom, c1, pheigvec, 3*natom,&
3367 &       tmpgam1, 3*natom, c0, tmpgam2, 3*natom)
3368 
3369        diagerr = zero
3370        do ibranch=1,nbranch
3371 
3372          eigval(ibranch) = tmpgam2(1,ibranch,ibranch)
3373 
3374          do jbranch=1,ibranch-1
3375            diagerr = diagerr + abs(tmpgam2(1,jbranch,ibranch))+abs(tmpgam2(2,jbranch,ibranch))
3376          end do
3377          do jbranch=ibranch+1,nbranch
3378            diagerr = diagerr + abs(tmpgam2(1,jbranch,ibranch))+abs(tmpgam2(2,jbranch,ibranch))
3379          end do
3380          diagerr = diagerr + abs(tmpgam2(2,ibranch,ibranch))
3381        end do
3382 
3383        if (diagerr > tol12) then
3384          write (msg,'(a,es14.6)')' Numerical error in diagonalization of gamma with phon eigenvectors: ', diagerr
3385          MSG_WARNING(msg)
3386        end if
3387 
3388      else
3389        write (msg,'(a,i0)')' Wrong value for elph_ds%ep_scalprod = ',elph_ds%ep_scalprod
3390        MSG_BUG(msg)
3391      end if ! end elph_ds%ep_scalprod if
3392 !
3393 !    ==========================================================
3394 !    write data to files for each q point
3395 !    ==========================================================
3396      write (unit_lwd,'(i5)', advance='no') indx
3397      do ii=1, nbranch
3398        write (unit_lwd,'(E16.5)',advance='no') eigval(ii)
3399      end do
3400      write (unit_lwd,*)
3401 
3402 !    only print phonon BS for isppol 1: independent of electron spins
3403      if (isppol==1) then
3404        write (unit_bs,'(i5)', advance='no') indx
3405        do ii=1, nbranch
3406          write (unit_bs,'(E16.5)',advance='no') phfrq_tmp(ii)
3407        end do
3408        write (unit_bs,*)
3409      end if
3410 
3411      write (unit_lambda,'(i5)', advance='no') indx
3412      do ii=1,nbranch
3413        lambda(ii)=zero
3414        if (abs(phfrq_tmp(ii)) > tol10) lambda(ii)=eigval(ii)/(pi*elph_ds%n0(isppol)*phfrq_tmp(ii)**2)
3415        write (unit_lambda,'(es16.8)',advance='no')phfrq_tmp(ii),lambda(ii)
3416      end do
3417      write (unit_lambda,'(es16.8)',advance='no') sum(lambda)
3418      write (unit_lambda,*)
3419 
3420 !    MG NOTE: I wrote a piece of code to output all these quantities using units
3421 !    chosen by the user, maybe in version 5.2?
3422 !    In this version the output of lambda(q,\nu) has been added
3423 
3424 !    Output to the main output file, for first point in segment
3425      if(indxprtqpt(ipoint)==1)then
3426        write(msg,'(a,a,3es16.6,a,i4,a,a)')ch10,&
3427 &       ' Q point =',qpt(:),'   isppol = ',isppol,ch10,&
3428 &       ' Mode number    Frequency (Ha)  Linewidth (Ha)  Lambda(q,n)'
3429        call wrtout(std_out,msg,'COLL')
3430        call wrtout(ab_out,msg,'COLL')
3431        do ii=1,nbranch
3432          write(msg,'(i8,es20.6,2es16.6)' )ii,phfrq_tmp(ii),eigval(ii),lambda(ii)
3433          call wrtout(std_out,msg,'COLL')
3434          call wrtout(ab_out,msg,'COLL')
3435        end do
3436      end if
3437 
3438 !    find max/min phonon frequency along path chosen
3439 !    presumed to be representative of full BZ to within 10 percent
3440      elph_ds%omega_min = min(elph_ds%omega_min,1.1_dp*phfrq_tmp(1))
3441      elph_ds%omega_max = max(elph_ds%omega_max,1.1_dp*phfrq_tmp(nbranch))
3442 
3443      indx = indx+1
3444    end do !  end ipoint do
3445 
3446 !  add blank lines to output files between sppol
3447    write(msg,'(a)' ) ''
3448    call wrtout(unit_lwd,msg,'COLL')
3449    call wrtout(unit_lambda,msg,'COLL')
3450    call wrtout(std_out,msg,'COLL')
3451    call wrtout(ab_out,msg,'COLL')
3452  end do ! isppol
3453 
3454  ABI_DEALLOCATE(coskr)
3455  ABI_DEALLOCATE(sinkr)
3456 
3457  close(unit=unit_lwd)
3458  close(unit=unit_bs)
3459  close(unit=unit_lambda)
3460 
3461  ABI_DEALLOCATE(finepath)
3462  ABI_DEALLOCATE(indxprtqpt)
3463 
3464  write(std_out,*) ' elph_linwid : omega_min, omega_max = ',elph_ds%omega_min, elph_ds%omega_max
3465 
3466  DBG_EXIT("COLL")
3467 
3468 end subroutine mkph_linwid

ABINIT/test_ftgkk [ Functions ]

[ Top ] [ Functions ]

NAME

 test_ftgkk

FUNCTION

  Test the fourier transform routine ftgkk for the el-phon matrix elements

INPUTS

   elph_ds = elphon datastructure with matrix elements
   gprim = reciprocal lattice vectors
   natom = number of atoms
   nrpt = number of real space points for FT interpolation
   rpt = coordinates of real space points for FT interpolation
   qpt_full = qpoint coordinates
   wghatm = weights for pairs of atoms in FT interpolation

OUTPUT

SIDE EFFECTS

NOTES

  MJV 18/5/2008 reverted to old syntax/use for ftgkk, with all ft being done
   in a batch. Might come back to 5.5 version with atomic FT in ftgkk, but later.

PARENTS

CHILDREN

      ftgkk

SOURCE

6174 subroutine test_ftgkk(elph_ds,gprim,natom,nrpt,rpt,qpt_full,wghatm)
6175 
6176 
6177 !This section has been created automatically by the script Abilint (TD).
6178 !Do not modify the following lines by hand.
6179 #undef ABI_FUNC
6180 #define ABI_FUNC 'test_ftgkk'
6181 !End of the abilint section
6182 
6183  implicit none
6184 
6185 !Arguments ------------------------------------
6186 !scalars
6187  integer,intent(in) :: natom,nrpt
6188  type(elph_type),intent(inout) :: elph_ds
6189 !arrays
6190  real(dp),intent(in) :: gprim(3,3),rpt(3,nrpt),qpt_full(3,elph_ds%nqpt_full)
6191  real(dp),intent(in) :: wghatm(natom,natom,nrpt)
6192 
6193 !Local variables-------------------------------
6194 !scalars
6195  integer :: ikpt_phon,iqpt,isppol,qtor,sz1,sz2
6196 !arrays
6197  real(dp),allocatable :: gkq_disk(:,:,:,:,:),tmp_gkq(:,:,:,:,:)
6198 
6199 ! *************************************************************************
6200 
6201 !for each qpt do FT to recuperate original values
6202 
6203  isppol = 1
6204  qtor = 0
6205  sz1=elph_ds%ngkkband*elph_ds%ngkkband
6206  sz2=elph_ds%nbranch*elph_ds%nbranch
6207  ABI_ALLOCATE(gkq_disk,(2,sz1,sz2,elph_ds%k_phon%nkpt,elph_ds%nsppol))
6208  ABI_ALLOCATE(tmp_gkq,(2,sz1,sz2,elph_ds%k_phon%nkpt,elph_ds%nsppol))
6209 
6210  do iqpt=1,elph_ds%nqpt_full
6211    tmp_gkq(:,:,:,:,:) = zero
6212 
6213    call ftgkk (wghatm,tmp_gkq,elph_ds%gkk_rpt,elph_ds%gkqwrite,&
6214 &   elph_ds%gkk_rptwrite,gprim,1,natom,&
6215 &   elph_ds%k_phon%nkpt,elph_ds%ngkkband,elph_ds%k_phon%nkpt,1,&
6216 &   nrpt,elph_ds%nsppol,qtor,rpt,qpt_full,elph_ds%unit_gkk_rpt,elph_ds%unitgkq)
6217 
6218    if (elph_ds%gkqwrite == 0) then
6219      do ikpt_phon=1,10
6220        write (93,*) tmp_gkq(:,:,:,ikpt_phon,isppol)-elph_ds%gkk_qpt(:,:,:,ikpt_phon,isppol,iqpt)
6221      end do
6222    else
6223      do ikpt_phon=1, elph_ds%k_phon%nkpt
6224        read (elph_ds%unitgkq,REC=((iqpt-1)*elph_ds%k_phon%nkpt+ikpt_phon)) gkq_disk(:,:,:,ikpt_phon,:)
6225      end do
6226      do ikpt_phon=1,10
6227        write (93,*) tmp_gkq(:,:,:,ikpt_phon,isppol)-gkq_disk(:,:,:,ikpt_phon,isppol)
6228      end do
6229    end if
6230  end do
6231 
6232 end subroutine test_ftgkk

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(7)=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

PARENTS

      anaddb

CHILDREN

      complete_gamma,complete_gamma_tr,copy_kptrank,d2c_weights,ebands_free
      ebands_update_occ,eliashberg_1d,elph_ds_clean,elph_k_procs
      elph_tr_ds_clean,ep_fs_weights,ep_setupqpt,ftgam,ftgam_init
      get_all_gkk2,get_all_gkq,get_all_gkr,get_fs_bands,get_nv_fs_en
      get_nv_fs_temp,get_rank_1kpt,get_tau_k,get_veloc_tr,hdr_bcast
      hdr_fort_read,hdr_free,integrate_gamma,integrate_gamma_tr
      integrate_gamma_tr_lova,mka2f,mka2f_tr,mka2f_tr_lova,mka2fqgrid
      mkfskgrid,mknesting,mkph_linwid,mkqptequiv,order_fs_kpts,outelph
      printvtk,rchkgsheader,read_el_veloc,symkpt,timein,wrap2_pmhalf,wrtout
      xmpi_bcast

SOURCE

 153 subroutine elphon(anaddb_dtset,Cryst,Ifc,filnam,comm)
 154 
 155 
 156 !This section has been created automatically by the script Abilint (TD).
 157 !Do not modify the following lines by hand.
 158 #undef ABI_FUNC
 159 #define ABI_FUNC 'elphon'
 160 !End of the abilint section
 161 
 162  implicit none
 163 
 164 !Arguments ------------------------------------
 165 !scalars
 166  type(anaddb_dataset_type),intent(inout) :: anaddb_dtset
 167  type(crystal_t),intent(in) :: Cryst
 168  type(ifc_type),intent(inout) :: Ifc
 169  integer,intent(in) :: comm
 170 !arrays
 171  character(len=fnlen),intent(in) :: filnam(7)
 172 
 173 !Local variables-------------------------------
 174 !scalars
 175  integer,parameter :: timrev2=2,space_group0=0,master=0
 176  integer :: ikpt_fine,ierr,unitgkk, unit_epts,iband,ibandp,ii
 177  integer :: ikpt,jkpt,kkpt, ik1,ik2,ik3,nk1, nk2, nk3
 178  integer :: iqpt,isppol,n1wf,nband,natom,onegkksize
 179  integer :: timrev,unitfskgrid,qtor,idir,iFSkpq,symrankkpt,ikpt_irr
 180  integer :: ep_prt_wtk ! eventually to be made into an input variable
 181  integer :: fform,ie,ie1,ie2,i_start,i_end
 182  integer :: ssp,s1,s2,tmp_nenergy, top_vb,nproc,me
 183  integer :: nkpt_tmp
 184  real(dp) :: max_occ,realdp_ex,res !,ss
 185  real(dp) :: tcpu, twall, tcpui, twalli
 186  real(dp) :: e1, e2, btocm3,diff, omega_max
 187  real(dp) :: e_vb_max, e_cb_min, etemp_vb
 188  logical :: make_gkk2,use_afm,use_tr
 189  character(len=500) :: message
 190  character(len=fnlen) :: fname,elph_base_name,ddkfilename,gkk_fname
 191  character(len=fnlen) :: nestname
 192  type(elph_tr_type) :: elph_tr_ds
 193  type(elph_type) :: elph_ds
 194  type(hdr_type) :: hdr,hdr1
 195  type(ebands_t) :: Bst
 196 !arrays
 197  integer :: s1ofssp(4), s2ofssp(4)
 198  integer :: qptrlatt(3,3),kptrlatt_fine(3,3)
 199  integer,allocatable :: indkpt1(:)
 200  integer,allocatable :: FSfullpqtofull(:,:)
 201  integer,allocatable :: qpttoqpt(:,:,:)
 202  integer,allocatable :: pair2red(:,:), red2pair(:,:)
 203  !real(dp) :: acell_in(3),rprim_in(3,3),rprim(3,3),acell(3),
 204  real(dp) :: kpt(3),shiftk(3)
 205  real(dp),allocatable :: wtk_fullbz(:),wtk_folded(:)
 206  real(dp),allocatable :: a2f_1d(:),dos_phon(:)
 207  real(dp),allocatable :: eigenGS(:,:,:),eigenGS_fine(:,:,:)
 208  real(dp),allocatable :: v_surf(:,:,:,:,:,:)
 209  real(dp),allocatable :: tmp_veloc_sq1(:,:), tmp_veloc_sq2(:,:)
 210  real(dp),allocatable :: coskr(:,:), sinkr(:,:)
 211 
 212 ! *************************************************************************
 213 
 214  write(message, '(a,a,(80a),a,a,a,a)' ) ch10,('=',ii=1,80),ch10,ch10,&
 215 & ' Properties based on electron-phonon coupling ',ch10
 216  call wrtout(std_out,message,'COLL')
 217  call wrtout(ab_out,message,'COLL')
 218 
 219  call timein(tcpui,twalli)
 220  write(message, '(a,f11.3,a,f11.3,a)' )&
 221 & '-begin elphon at tcpu',tcpui,'  and twall',twalli,' sec'
 222  call wrtout(std_out,message,'COLL')
 223 
 224  nproc = xmpi_comm_size(comm); me = xmpi_comm_rank(comm)
 225 
 226  write(message, '(a,i0,a,i0)' )'- running on ', nproc,'  cpus me = ', me
 227  call wrtout(std_out,message,'PERS')
 228  write(std_out,*) message
 229 
 230 !==================================
 231 !Initialization of some variables
 232 !==================================
 233 
 234  if (master == me) then
 235    gkk_fname = filnam(5)
 236    if (open_file(gkk_fname,message,newunit=unitgkk,form="unformatted",status="old",action="read") /=0) then
 237      MSG_ERROR(message)
 238    end if
 239  end if
 240 
 241  elph_base_name=trim(filnam(2))//"_ep"
 242  ddkfilename=trim(filnam(7))
 243 
 244 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 245 
 246  natom = Cryst%natom
 247  elph_ds%mustar       = anaddb_dtset%mustar        ! input mustar
 248  elph_ds%nbranch      = 3*natom                    ! number of phonon modes = 3 * natom
 249  elph_ds%natom        = natom                      !
 250  elph_ds%ep_keepbands = anaddb_dtset%ep_keepbands  ! flag to sum over bands
 251  elph_ds%a2fsmear     = anaddb_dtset%a2fsmear      ! smearing for Eliashberg functions
 252  elph_ds%elphsmear    = anaddb_dtset%elphsmear     ! smearing for Eliashberg functions
 253  elph_ds%ep_b_min     = anaddb_dtset%ep_b_min
 254  elph_ds%ep_b_max     = anaddb_dtset%ep_b_max
 255  elph_ds%telphint     = anaddb_dtset%telphint
 256  elph_ds%kptrlatt     = anaddb_dtset%kptrlatt
 257  elph_ds%kptrlatt_fine= anaddb_dtset%kptrlatt_fine
 258  elph_ds%tempermin    = anaddb_dtset%tempermin
 259  elph_ds%temperinc    = anaddb_dtset%temperinc
 260  elph_ds%ntemper      = anaddb_dtset%ntemper
 261  elph_ds%use_k_fine   = anaddb_dtset%use_k_fine
 262  elph_ds%ep_int_gkk   = anaddb_dtset%ep_int_gkk
 263  elph_ds%ep_nspline   = anaddb_dtset%ep_nspline
 264  elph_ds%ep_scalprod  = anaddb_dtset%ep_scalprod
 265  elph_ds%prtbltztrp   = anaddb_dtset%prtbltztrp
 266 
 267  elph_ds%tuniformgrid = 1
 268  elph_ds%na2f         = 400                        ! maximum number of Matsubara frequencies.
 269  elph_ds%ep_lova      = 0                          ! 1 for lova and 0 for general
 270  elph_ds%nenergy      = 8
 271  btocm3 = 1.4818474347690475d-25
 272 
 273 !The nenergy needs to be 1) large enough to converge the integral, 2) greater
 274 !than the max phonon energy.
 275 !elph_ds%nenergy      = INT(8*(anaddb_dtset%tempermin+anaddb_dtset%ntemper*anaddb_dtset%temperinc)/ &
 276 !&                              (anaddb_dtset%tempermin+anaddb_dtset%temperinc))  ! number of energy levels
 277 
 278  write(message,'(a,i6)')' The initial number of energy levels above/below Ef is set to be :',elph_ds%nenergy
 279  call wrtout(std_out,message,'COLL')
 280 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 281 
 282 !The precise number used depends on the value of Tc:
 283 !they span $w_n = (2n+1) \pi T_c$  where $abs(w_n) < w_{cutoff}$
 284 !ie $|n| < n_{cutoff} = ( \frac{w_{cutoff}}{\pi T_c} ) / 2$
 285 
 286 !save gkk data for full kpoints to file on disk
 287 
 288  elph_ds%gkqwrite     = anaddb_dtset%gkqwrite
 289  elph_ds%gkk_rptwrite = anaddb_dtset%gkk_rptwrite
 290  elph_ds%gkk2write    = anaddb_dtset%gkk2write
 291 
 292 !This should never be turned off: symmetrization of elphon matrix elements in complete_gkk. See get_all_gkq
 293  elph_ds%symgkq=anaddb_dtset%symgkq
 294 
 295  elph_ds%elph_base_name = trim(elph_base_name)
 296 
 297  !MG: @Matthieu: Why this? Now we should always use the value of rprim and acell reported in IFC
 298  !rprim_in  = Ifc%rprim
 299  !acell_in = Ifc%acell
 300 
 301 !normalize input rprim and acell.
 302  !do ii=1,3
 303  !  ss = sqrt(rprim_in(1,ii)**2+rprim_in(2,ii)**2+rprim_in(3,ii)**2)
 304  !  rprim(:,ii) = rprim_in(:,ii)/ss
 305  !  acell(ii) = acell_in(ii) * ss
 306  !end do
 307 
 308 !make dimension-ful rprimd and gprimd for transformation of derivatives to cartesian coordinates.
 309  !call mkrdim(acell,rprim,rprimd)
 310  !call matr3inv(rprimd,gprimd)
 311 
 312  !rprimd = cryst%rprimd
 313  !gprimd = cryst%gprimd
 314 
 315 !===================
 316 !Check some inputs
 317 !===================
 318  if (Cryst%nsym==1) then
 319    write (message,'(7a)')ch10,&
 320 &   ' elphon: COMMENT- ',ch10,&
 321 &   ' Symmetries are not used! ',ch10,&
 322 &   ' Full matrix elements must be supplied for all perturbations and qpoints!',ch10
 323    call wrtout(std_out,message,'COLL')
 324    call wrtout(ab_out,message,'COLL')
 325    if ( ANY( ABS(Cryst%tnons(:,1)) > tol10) ) then
 326      MSG_ERROR('nsym==1 but the symmetry is not the identity')
 327    end if
 328  end if
 329 
 330  if (anaddb_dtset%ifcflag/=1) then
 331    write(message,'(a,i0)')&
 332 &   ' ifcflag should be set to 1 since the IFC matrices are supposed to exist but ifcflag= ',anaddb_dtset%ifcflag
 333    MSG_ERROR(message)
 334  end if
 335 
 336  call timein(tcpu,twall)
 337  write(message, '(a,f11.3,a,f11.3,a)' )&
 338 & '-elphon begin setup after tcpu',tcpu-tcpui,'  and twall',twall-twalli,' sec'
 339  call wrtout(std_out,message,'COLL')
 340  tcpui = tcpu
 341  twalli = twall
 342 
 343 !=================================
 344 !Set up the full grid of qpoints
 345 !=================================
 346 !use time reversal symmetry always when possible for kpoint reduction,
 347 !and suppose it has been used in WF generation
 348 !not used for the moment: values are always taken from input files.
 349  timrev = 1
 350  call ep_setupqpt(elph_ds,cryst,anaddb_dtset,qptrlatt,timrev)
 351 
 352 !====================================
 353 !Read the GS header of the GKK file
 354 !this will give the phon grid of k
 355 !and the Fermi surface integration weights
 356 !====================================
 357  call wrtout (std_out,' elphon: reading and checking the GS header of the GKK file','COLL')
 358 
 359  if (master == me) then
 360    call rchkGSheader(hdr,natom,nband,unitgkk)
 361  end if
 362 
 363 !the following is for the non master nodes
 364  call hdr_bcast(hdr,master,me,comm)
 365  call xmpi_bcast(nband, master,comm,ierr)
 366  elph_ds%nband = nband
 367 
 368  elph_ds%nsppol =hdr%nsppol
 369  elph_ds%nspinor=hdr%nspinor
 370 
 371 !in spinor or spin polarized case, orbitals have occupation <= 1 instead of 2
 372  max_occ = one
 373  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
 374  if (elph_ds%nsppol > 1) max_occ = one
 375  write (std_out,*) ' max_occ factor  ', max_occ
 376 
 377  elph_ds%occ_factor = one
 378  if (hdr%nspinor == 1 .and. hdr%nsppol == 1) then
 379    elph_ds%occ_factor = one
 380  else if (hdr%nspinor == 2) then
 381    elph_ds%occ_factor = two
 382  else if (hdr%nsppol == 2) then
 383    elph_ds%occ_factor = one
 384  end if
 385 
 386 !==================================================
 387 !Read GS eigenvalues for each irreducible kpt and
 388 !number of 1WF files contributing to the GKK file
 389 !==================================================
 390 
 391  ABI_ALLOCATE(eigenGS,(nband,hdr%nkpt,elph_ds%nsppol))
 392 
 393  if (master == me) then
 394    do isppol=1,elph_ds%nsppol
 395      do ikpt=1,hdr%nkpt
 396        read(unitgkk) eigenGS(:,ikpt,isppol)
 397      end do
 398    end do
 399 
 400 !  read number of 1WF files contributing to the GKK file
 401    read(unitgkk) n1wf
 402    write(message,'(a,i0)')' elphon : number of perturbations in the gkk file = ',n1wf
 403    call wrtout(std_out,message,'COLL')
 404  end if
 405  call xmpi_bcast(n1wf, master, comm, ierr)
 406  call xmpi_bcast(eigenGS, master, comm, ierr)
 407 
 408 !==================================================
 409 !Set elph_ds%fermie: either comes from anaddb input file or from wfk file
 410 !==================================================
 411  elph_ds%fermie = hdr%fermie
 412  !elph_ds%nelect = hdr_get_nelect_byocc(Hdr)
 413  elph_ds%nelect = Hdr%nelect
 414  if (abs(anaddb_dtset%elph_fermie) > tol10) then
 415    elph_ds%fermie = anaddb_dtset%elph_fermie
 416    write(message,'(a,E20.12)')' Fermi level set by the user at :',elph_ds%fermie
 417    call wrtout(std_out,message,'COLL')
 418    Bst = ebands_from_hdr(Hdr,nband,eigenGS)
 419  else if (abs(anaddb_dtset%ep_extrael) > tol10) then
 420    if (abs(anaddb_dtset%ep_extrael) > 1.0d2) then
 421      write(message,'(a,E20.12)')' Doping set by the user is (negative for el doping) :',&
 422 &     anaddb_dtset%ep_extrael
 423      call wrtout(std_out,message,'COLL')
 424      anaddb_dtset%ep_extrael = anaddb_dtset%ep_extrael*cryst%ucvol*btocm3*(-1.0d0)
 425    end if
 426    write(message,'(a,E20.12)')' Additional electrons per unit cell set by the user at :',&
 427 &   anaddb_dtset%ep_extrael
 428    call wrtout(std_out,message,'COLL')
 429    elph_ds%nelect = elph_ds%nelect + anaddb_dtset%ep_extrael
 430    bst = ebands_from_hdr(Hdr,nband,eigenGS,nelect=elph_ds%nelect)
 431 
 432 !  set Bst to use FD occupations:
 433    Bst%occopt = 3
 434 !   Bst%tsmear = 0.00001_dp ! is this small etol9 Bst%tsmeatol90001_dp ! last used
 435    Bst%tsmear = tol9 ! is this small etol9 Bst%tsmeatol90001_dp ! last used
 436 !  Calculate occupation numbers.
 437    call ebands_update_occ(Bst,-99.99_dp)
 438    write(message,'(a,E20.12)')' Fermi level is now calculated to be :',Bst%fermie
 439    call wrtout(std_out,message,'COLL')
 440    elph_ds%fermie = BSt%fermie
 441  else
 442    bst = ebands_from_hdr(Hdr,nband,eigenGS)
 443  end if
 444  call wrtout(std_out,message,'COLL')
 445 
 446 !====================================================================
 447 !Setup of the phon k-grid :
 448 !1) get bands near Ef
 449 !====================================================================
 450  call get_fs_bands(eigenGS,hdr,elph_ds%fermie,anaddb_dtset%ep_b_min, anaddb_dtset%ep_b_max,&
 451 & elph_ds%minFSband,elph_ds%maxFSband,elph_ds%k_phon%nkptirr)
 452 
 453  elph_ds%nFSband = elph_ds%maxFSband - elph_ds%minFSband + 1
 454 
 455 !Modify the band gap by sissor shift of the CB
 456  if (abs(anaddb_dtset%band_gap) < 10.0d0) then
 457    anaddb_dtset%band_gap = anaddb_dtset%band_gap*0.036749309 ! eV2Ha
 458    do isppol=1,elph_ds%nsppol
 459 
 460 !First find where the gap is
 461      etemp_vb = 999.0d0
 462      top_vb = elph_ds%minFSband
 463      do iband = elph_ds%minFSband, elph_ds%maxFSband
 464        e_vb_max = maxval(eigenGS(iband,:,isppol))
 465        if (dabs(e_vb_max-elph_ds%fermie) < etemp_vb) then
 466          etemp_vb = dabs(e_vb_max-elph_ds%fermie)
 467          top_vb = iband
 468        end if
 469      end do
 470      do iband = top_vb, elph_ds%maxFSband
 471        e_vb_max = maxval(eigenGS(iband,:,isppol))
 472        if (dabs(e_vb_max-maxval(eigenGS(top_vb,:,isppol))) < tol6) then
 473          etemp_vb = dabs(e_vb_max-elph_ds%fermie)
 474          top_vb = iband
 475        end if
 476      end do
 477      e_vb_max = maxval(eigenGS(top_vb,:,isppol))
 478      e_cb_min = minval(eigenGS(top_vb+1,:,isppol))
 479      write(message,'(a,E20.12,2x,E20.12)')' elphon : original fermi energy = ', elph_ds%fermie
 480      call wrtout(std_out,message,'COLL')
 481      write(message,'(a,E20.12,2x,E20.12)')' elphon : top of VB, bottom of CB = ',e_vb_max, e_cb_min
 482      call wrtout(std_out,message,'COLL')
 483 
 484      do iband = top_vb+1, elph_ds%maxFSband
 485        eigenGS(iband,:,isppol) = eigenGS(iband,:,isppol) + (anaddb_dtset%band_gap-(e_cb_min-e_vb_max))
 486      end do
 487    end do !nsppol
 488 
 489 !! recalculate Fermi level
 490    !elph_ds%nelect = hdr_get_nelect_byocc(Hdr)
 491    elph_ds%nelect = Hdr%nelect
 492    if (abs(anaddb_dtset%elph_fermie) > tol10) then
 493      elph_ds%fermie = anaddb_dtset%elph_fermie
 494      write(message,'(a,E20.12)')' Fermi level set by the user at :',elph_ds%fermie
 495      call wrtout(std_out,message,'COLL')
 496      bst = ebands_from_hdr(Hdr,nband,eigenGS)
 497    else if (abs(anaddb_dtset%ep_extrael) > tol10) then
 498      write(message,'(a,E20.12)')' Additional electrons per unit cell set by the user at :',anaddb_dtset%ep_extrael
 499      call wrtout(std_out,message,'COLL')
 500      elph_ds%nelect = elph_ds%nelect + anaddb_dtset%ep_extrael
 501      bst = ebands_from_hdr(Hdr,nband,eigenGS,nelect=elph_ds%nelect)
 502 
 503 !    set Bst to use FD occupations:
 504      Bst%occopt = 3
 505 !     Bst%tsmear = 0.00001_dp ! is this small etol9 Bst%tsmeatol90001_dp ! last used
 506      Bst%tsmear = tol9 ! is this small etol9 Bst%tsmeatol90001_dp ! last used
 507 !    Calculate occupation numbers.
 508      call ebands_update_occ(Bst,-99.99_dp)
 509      write(message,'(a,E20.12)')' Fermi level is now calculated to be :',Bst%fermie
 510      call wrtout(std_out,message,'COLL')
 511      elph_ds%fermie = BSt%fermie
 512    else
 513      bst = ebands_from_hdr(Hdr,nband,eigenGS)
 514    end if
 515    call wrtout(std_out,message,'COLL')
 516  end if !modify band_gap
 517 
 518  if (elph_ds%ep_keepbands == 0) then !we are summing over bands
 519    elph_ds%ngkkband = 1
 520  else if (elph_ds%ep_keepbands == 1) then
 521 !  keep the band dependency btw elph_ds%minFSband and elph_ds%maxFSband
 522    elph_ds%ngkkband = elph_ds%nFSband
 523  else
 524    write(message,'(a,i0)')' ep_keepbands must be 0 or 1 while it is: ',elph_ds%ep_keepbands
 525    MSG_BUG(message)
 526  end if
 527 
 528  write(message,'(a,i0,2x,i0)')' elphon : minFSband, maxFSband = ',elph_ds%minFSband,elph_ds%maxFSband
 529  call wrtout(std_out,message,'COLL')
 530 
 531 
 532  ABI_ALLOCATE(elph_ds%k_phon%kptirr,(3,elph_ds%k_phon%nkptirr))
 533  ABI_ALLOCATE(elph_ds%k_phon%irredtoGS,(elph_ds%k_phon%nkptirr))
 534 
 535 !====================================================================
 536 !2) order irred k-points
 537 !====================================================================
 538  if (master == me) then
 539    call order_fs_kpts(hdr%kptns, hdr%nkpt, elph_ds%k_phon%kptirr,elph_ds%k_phon%nkptirr,elph_ds%k_phon%irredtoGS)
 540  end if
 541  call xmpi_bcast(elph_ds%k_phon%nkptirr, master, comm, ierr)
 542  call xmpi_bcast(elph_ds%k_phon%kptirr, master, comm, ierr)
 543  call xmpi_bcast(elph_ds%k_phon%irredtoGS, master, comm, ierr)
 544 
 545 !==========================================
 546 !3) reconstruct full kgrid from irred kpoints,
 547 !==========================================
 548  call mkFSkgrid (elph_ds%k_phon, Cryst%nsym, Cryst%symrec, timrev)
 549 
 550 ! check that kptrlatt is coherent with kpt found here
 551  nkpt_tmp = elph_ds%kptrlatt(1,1)*elph_ds%kptrlatt(2,2)*elph_ds%kptrlatt(3,3)
 552  if (sum(abs(elph_ds%kptrlatt(:,:))) /= nkpt_tmp) then
 553    MSG_WARNING(' the input kptrlatt is not diagonal... ')
 554  end if
 555  if (anaddb_dtset%ifltransport > 1 .and. nkpt_tmp /= elph_ds%k_phon%nkpt) then
 556    write(message,'(a,i0,a,i0)')&
 557 &   ' the input kptrlatt is inconsistent  ', nkpt_tmp, " /= ", elph_ds%k_phon%nkpt
 558    MSG_ERROR(message)
 559  end if
 560 
 561  if (anaddb_dtset%ifltransport==3 ) then
 562 !====================================================================
 563 ! The real irred kpt, now only used by get_tau_k
 564 !====================================================================
 565 
 566    ABI_ALLOCATE(indkpt1,(elph_ds%k_phon%nkpt))
 567    ABI_ALLOCATE(wtk_fullbz,(elph_ds%k_phon%nkpt))
 568    ABI_ALLOCATE(wtk_folded,(elph_ds%k_phon%nkpt))
 569 
 570    wtk_fullbz(:) = one/dble(elph_ds%k_phon%nkpt) !weights normalized to unity
 571    call symkpt(0,cryst%gmet,indkpt1,0,elph_ds%k_phon%kpt,elph_ds%k_phon%nkpt,elph_ds%k_phon%new_nkptirr,&
 572 &   Cryst%nsym,Cryst%symrec,timrev,wtk_fullbz,wtk_folded)
 573 
 574    write (message,'(2a,i0)')ch10,' Number of irreducible k-points = ',elph_ds%k_phon%new_nkptirr
 575    call wrtout(std_out,message,'COLL')
 576 
 577    ABI_ALLOCATE(elph_ds%k_phon%new_kptirr,(3,elph_ds%k_phon%new_nkptirr))
 578    ABI_ALLOCATE(elph_ds%k_phon%new_wtkirr,(elph_ds%k_phon%new_nkptirr))
 579    ABI_ALLOCATE(elph_ds%k_phon%new_irredtoGS,(elph_ds%k_phon%new_nkptirr))
 580 
 581    ikpt_irr = 0
 582    do ikpt=1,elph_ds%k_phon%nkpt
 583      if (wtk_folded(ikpt) /= zero) then
 584        ikpt_irr = ikpt_irr + 1
 585        elph_ds%k_phon%new_kptirr(:,ikpt_irr) = elph_ds%k_phon%kpt(:,ikpt)
 586        elph_ds%k_phon%new_wtkirr(ikpt_irr) = wtk_folded(ikpt)
 587        elph_ds%k_phon%new_irredtoGS(ikpt_irr) = ikpt
 588      end if
 589    end do
 590    if (ikpt_irr .ne. elph_ds%k_phon%new_nkptirr) then
 591      write (message,'(a)')' The number of irred nkpt does not match! '
 592      MSG_ERROR(message)
 593    end if
 594 
 595    ABI_DEALLOCATE(indkpt1)
 596    ABI_DEALLOCATE(wtk_fullbz)
 597    ABI_DEALLOCATE(wtk_folded)
 598  end if
 599 
 600 !====================================================================
 601 !4) setup weights for integration (gaussian or tetrahedron method)
 602 !====================================================================
 603  elph_ds%k_phon%nband = elph_ds%nFSband
 604  elph_ds%k_phon%nsppol = elph_ds%nsppol
 605  elph_ds%k_phon%nsym = Cryst%nsym
 606  ABI_ALLOCATE(elph_ds%k_phon%wtk,(elph_ds%nFSband,elph_ds%k_phon%nkpt,elph_ds%k_phon%nsppol))
 607 
 608  call ep_fs_weights(anaddb_dtset%ep_b_min, anaddb_dtset%ep_b_max, eigenGS, anaddb_dtset%elphsmear, &
 609 & elph_ds%fermie, cryst%gprimd, elph_ds%k_phon%irredtoGS, elph_ds%kptrlatt, max_occ, elph_ds%minFSband, nband, elph_ds%nFSband, &
 610 & elph_ds%nsppol, anaddb_dtset%telphint, elph_ds%k_phon)
 611 
 612 !distribute k-points among processors, if any
 613  call elph_k_procs(nproc, elph_ds%k_phon)
 614 
 615 !=====================================================
 616 !get kpt info from the fine grid part
 617 !=====================================================
 618  if (anaddb_dtset%use_k_fine == 1) then
 619 
 620    if (abs(anaddb_dtset%band_gap) < 10.0d0) then
 621      write (message,'(a)')' Not coded yet when use_k_fine and band_gap are both used'
 622      MSG_ERROR(message)
 623    end if
 624 
 625    if (master == me) then
 626      if (open_file("densergrid_GKK",message,newunit=unitfskgrid,form="unformatted",status="old") /=0) then
 627        MSG_ERROR(message)
 628      end if
 629      !read the header of file
 630      call hdr_fort_read(hdr1, unitfskgrid, fform)
 631      ABI_CHECK(fform/=0,'denser grid GKK header was mis-read. fform == 0')
 632    end if
 633    call hdr_bcast(hdr1,master,me,comm)
 634 
 635    ABI_ALLOCATE(eigenGS_fine,(nband,hdr1%nkpt,elph_ds%nsppol))
 636 
 637    if (master == me) then
 638      do isppol=1,elph_ds%nsppol
 639        do ikpt=1,hdr1%nkpt
 640          read(unitfskgrid) eigenGS_fine(:,ikpt,isppol)
 641        end do
 642      end do
 643      close(unitfskgrid)
 644    end if
 645    call xmpi_bcast(eigenGS_fine, master, comm, ierr)
 646 
 647 !  Reinit the structure storing the eigevalues.
 648 !  Be careful. This part has not been tested.
 649    call ebands_free(Bst)
 650    bst = ebands_from_hdr(hdr1,nband,eigenGS_fine)
 651 
 652    elph_ds%k_fine%nkptirr = hdr1%nkpt
 653    ABI_ALLOCATE(elph_ds%k_fine%kptirr,(3,elph_ds%k_fine%nkptirr))
 654    ABI_ALLOCATE(elph_ds%k_fine%irredtoGS,(elph_ds%k_fine%nkptirr))
 655 
 656    call order_fs_kpts(hdr1%kptns, hdr1%nkpt, elph_ds%k_fine%kptirr,&
 657 &   elph_ds%k_fine%nkptirr,elph_ds%k_fine%irredtoGS)
 658 
 659    call hdr_free(hdr1)
 660 
 661    call mkFSkgrid (elph_ds%k_fine, Cryst%nsym, Cryst%symrec, timrev)
 662 
 663    elph_ds%k_fine%nband = elph_ds%nFSband
 664    elph_ds%k_fine%nsppol = elph_ds%nsppol
 665    elph_ds%k_fine%nsym = Cryst%nsym
 666 
 667    ABI_ALLOCATE(elph_ds%k_fine%wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%nsppol))
 668 
 669    kptrlatt_fine = elph_ds%kptrlatt_fine
 670 
 671    call ep_fs_weights(anaddb_dtset%ep_b_min, anaddb_dtset%ep_b_max, &
 672 &   eigenGS_fine, anaddb_dtset%elphsmear, &
 673 &   elph_ds%fermie, cryst%gprimd, elph_ds%k_fine%irredtoGS, kptrlatt_fine, &
 674 &   max_occ, elph_ds%minFSband, nband, elph_ds%nFSband, &
 675 &   elph_ds%nsppol, anaddb_dtset%telphint, elph_ds%k_fine)
 676 
 677  else ! not using k_fine
 678    elph_ds%k_fine%nband = elph_ds%k_phon%nband
 679    elph_ds%k_fine%nsppol = elph_ds%k_phon%nsppol
 680    elph_ds%k_fine%nsym = elph_ds%k_phon%nsym
 681 
 682    elph_ds%k_fine%nkpt = elph_ds%k_phon%nkpt
 683    elph_ds%k_fine%nkptirr = elph_ds%k_phon%nkptirr
 684 
 685    elph_ds%k_fine%my_nkpt = elph_ds%k_phon%my_nkpt
 686 
 687    ABI_ALLOCATE(elph_ds%k_fine%my_kpt,(elph_ds%k_fine%nkpt))
 688    elph_ds%k_fine%my_kpt = elph_ds%k_phon%my_kpt
 689 
 690    ABI_ALLOCATE(elph_ds%k_fine%my_ikpt,(elph_ds%k_fine%my_nkpt))
 691    elph_ds%k_fine%my_ikpt = elph_ds%k_phon%my_ikpt
 692 
 693    ABI_ALLOCATE(elph_ds%k_fine%kptirr,(3,elph_ds%k_fine%nkptirr))
 694    elph_ds%k_fine%kptirr = elph_ds%k_phon%kptirr
 695    ABI_ALLOCATE(elph_ds%k_fine%wtkirr,(elph_ds%k_fine%nkptirr))
 696    elph_ds%k_fine%wtkirr = elph_ds%k_phon%wtkirr
 697 
 698    ABI_ALLOCATE(elph_ds%k_fine%wtk,(elph_ds%nFSband,elph_ds%k_fine%nkpt,elph_ds%k_fine%nsppol))
 699    elph_ds%k_fine%wtk = elph_ds%k_phon%wtk
 700    ABI_ALLOCATE(elph_ds%k_fine%kpt,(3,elph_ds%k_fine%nkpt))
 701    elph_ds%k_fine%kpt = elph_ds%k_phon%kpt
 702 
 703    call copy_kptrank(elph_ds%k_phon%kptrank_t, elph_ds%k_fine%kptrank_t)
 704 
 705    ABI_ALLOCATE(elph_ds%k_fine%irr2full,(elph_ds%k_fine%nkptirr))
 706    elph_ds%k_fine%irr2full = elph_ds%k_phon%irr2full
 707    ABI_ALLOCATE(elph_ds%k_fine%full2irr,(3,elph_ds%k_fine%nkpt))
 708    elph_ds%k_fine%full2irr = elph_ds%k_phon%full2irr
 709    ABI_ALLOCATE(elph_ds%k_fine%full2full,(2,elph_ds%k_fine%nsym,elph_ds%k_fine%nkpt))
 710    elph_ds%k_fine%full2full = elph_ds%k_phon%full2full
 711 
 712    ABI_ALLOCATE(elph_ds%k_fine%irredtoGS,(elph_ds%k_fine%nkptirr))
 713    elph_ds%k_fine%irredtoGS = elph_ds%k_phon%irredtoGS
 714 
 715 !  call elph_k_copy(elph_ds%k_phon, elph_ds%k_fine)
 716 
 717    kptrlatt_fine = elph_ds%kptrlatt
 718 
 719    ABI_ALLOCATE(eigenGS_fine,(nband,elph_ds%k_fine%nkptirr,elph_ds%nsppol))
 720 
 721    eigenGS_fine = eigenGS
 722  end if ! k_fine or not
 723 
 724  if (elph_ds%kptrlatt_fine(1,1) == 0) then ! when there is not input for kptrlatt_fine
 725    elph_ds%kptrlatt_fine = kptrlatt_fine
 726  end if
 727 
 728  call timein(tcpu,twall)
 729  write(message, '(a,f11.3,a,f11.3,a)' )&
 730 & '-elphon k and q grids have been setup after tcpu',tcpu-tcpui,'  and twall',twall-twalli,' sec'
 731  call wrtout(std_out,message,'COLL')
 732  tcpui = tcpu
 733  twalli = twall
 734 
 735 !====================================================================
 736 !5) calculate DOS at Ef
 737 !====================================================================
 738  ABI_ALLOCATE(elph_ds%n0,(elph_ds%nsppol))
 739 
 740 !SPPOL sum over spin channels to get total DOS
 741 !channels decoupled => use separate values for DOS_up(Ef) resp down
 742  do isppol=1,elph_ds%nsppol
 743    elph_ds%n0(isppol) = sum(elph_ds%k_fine%wtk(:,:,isppol))/elph_ds%k_fine%nkpt
 744  end do
 745 
 746  if (elph_ds%nsppol == 1) then
 747    write (std_out,*) ' elphon : the estimated DOS(E_Fermi) = ', elph_ds%n0(1), ' states/Ha/spin '
 748    write (std_out,*) ' elphon : the total FS weight and # of kpoints = ',sum(elph_ds%k_fine%wtk),elph_ds%k_fine%nkpt
 749  else if (elph_ds%nsppol == 2) then
 750    write (std_out,*) ' elphon : the spin up   DOS(E_Fermi) = ', elph_ds%n0(1), ' states/Ha/spin '
 751    write (std_out,*) ' elphon : the spin down DOS(E_Fermi) = ', elph_ds%n0(2), ' states/Ha/spin '
 752    write (std_out,*) ' elphon : total DOS(E_Fermi) = ', elph_ds%n0(1)+elph_ds%n0(2), ' states/Ha '
 753    write (std_out,*) ' elphon : the spin up   FS weight and # of kpoints = ',&
 754 &   sum(elph_ds%k_fine%wtk(:,:,1)),elph_ds%k_fine%nkpt
 755    write (std_out,*) ' elphon : the spin down FS weight and # of kpoints = ',&
 756 &   sum(elph_ds%k_fine%wtk(:,:,2)),elph_ds%k_fine%nkpt
 757  else
 758    write (message,'(a,i0)') 'bad value for nsppol ', elph_ds%nsppol
 759    MSG_ERROR(message)
 760  end if
 761 
 762  ABI_ALLOCATE(elph_ds%gkk_intweight,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,elph_ds%nsppol))
 763 
 764  if (elph_ds%ep_keepbands == 0) then
 765 !  use trivial integration weights  for single band,
 766 !  since average over bands is done in normsq_gkk
 767    elph_ds%gkk_intweight(1,:,:) = one
 768 
 769  else if (elph_ds%ep_keepbands == 1) then
 770 !  use elph_ds%k_fine%wtk since average over bands is not done in normsq_gkk
 771    if (elph_ds%use_k_fine == 1) then
 772      call d2c_weights(elph_ds)
 773    end if
 774    elph_ds%gkk_intweight(:,:,:) = elph_ds%k_phon%wtk(:,:,:)
 775  else
 776    write(message,'(a,i0)')' ep_keepbands must be 0 or 1 while it is : ',elph_ds%ep_keepbands
 777    MSG_ERROR(message)
 778  end if
 779 
 780  ep_prt_wtk = 0
 781  if (ep_prt_wtk == 1) then
 782    do iband=1, elph_ds%ngkkband
 783      do ikpt_fine=1, elph_ds%k_fine%nkpt
 784        write (300,*) ikpt_fine, elph_ds%gkk_intweight(iband,ikpt_fine,1)
 785      end do
 786    end do
 787  end if
 788 
 789 
 790  call timein(tcpu,twall)
 791  write(message, '(a,f11.3,a,f11.3,a)' )&
 792 & '-elphon weights and DOS setup after tcpu',tcpu-tcpui,'  and twall',twall-twalli,' sec'
 793  call wrtout(std_out,message,'COLL')
 794  tcpui = tcpu
 795  twalli = twall
 796 
 797 !Output of the Fermi Surface
 798  if (anaddb_dtset%prtfsurf == 1 .and. master == me) then
 799    fname=trim(elph_ds%elph_base_name) // '_BXSF'
 800    if (ebands_write_bxsf(Bst, Cryst, fname) /= 0) then
 801      MSG_WARNING("Cannot produce file for Fermi surface, check log file for more info")
 802    end if
 803  end if
 804 
 805 !=========================================================
 806 !Get equivalence between a kpt_phon pair and a qpt in qpt_full
 807 !only works if the qpt grid is complete (identical to
 808 !the kpt one, with a basic shift of (0,0,0)
 809 !=========================================================
 810 
 811 !mapping of k + q onto k' for k and k' in full BZ
 812  ABI_ALLOCATE(FSfullpqtofull,(elph_ds%k_phon%nkpt,elph_ds%nqpt_full))
 813 
 814 !qpttoqpt(itim,isym,iqpt) = qpoint index which transforms to iqpt under isym and with time reversal itim.
 815  ABI_ALLOCATE(qpttoqpt,(2,Cryst%nsym,elph_ds%nqpt_full))
 816 
 817  call wrtout(std_out,'elphon: calling mkqptequiv to set up the FS qpoint set',"COLL")
 818 
 819  call mkqptequiv (FSfullpqtofull,Cryst,elph_ds%k_phon%kpt,elph_ds%k_phon%nkpt,&
 820 & elph_ds%nqpt_full,qpttoqpt,elph_ds%qpt_full)
 821 
 822 !==========================================
 823 !Set up dataset for phonon interpolations
 824 !==========================================
 825 
 826 !transfer ifltransport flag to structure
 827  elph_tr_ds%ifltransport=anaddb_dtset%ifltransport
 828 !transfer name of files file for ddk
 829  elph_tr_ds%ddkfilename=ddkfilename
 830 
 831 !reduce qpt_full to correct zone
 832  do iqpt=1,elph_ds%nqpt_full
 833    call wrap2_pmhalf(elph_ds%qpt_full(1,iqpt),kpt(1),res)
 834    call wrap2_pmhalf(elph_ds%qpt_full(2,iqpt),kpt(2),res)
 835    call wrap2_pmhalf(elph_ds%qpt_full(3,iqpt),kpt(3),res)
 836    elph_ds%qpt_full(:,iqpt)=kpt
 837  end do
 838 
 839 !test density of k+q grid: the following should be close to n0 squared
 840 !FIXME: generalize for sppol
 841  res = zero
 842  do ikpt_fine = 1, elph_ds%k_phon%nkpt
 843    do iqpt = 1, elph_ds%nqpt_full
 844      kpt = elph_ds%k_phon%kpt(:,ikpt_fine) + elph_ds%qpt_full(:,iqpt)
 845      call get_rank_1kpt (kpt,symrankkpt,elph_ds%k_phon%kptrank_t)
 846      iFSkpq = elph_ds%k_phon%kptrank_t%invrank(symrankkpt)
 847      do iband = 1, elph_ds%ngkkband
 848        do ibandp = 1, elph_ds%ngkkband
 849          res = res + elph_ds%gkk_intweight(iband,ikpt_fine,1)*elph_ds%gkk_intweight(ibandp,iFSkpq,1)
 850        end do
 851      end do
 852    end do
 853  end do
 854  res = res / elph_ds%k_phon%nkpt/elph_ds%k_phon%nkpt
 855  write (std_out,*) 'elphon: integrated value of intweight for given k and q grid : ', res, res / elph_ds%n0(1)**2
 856 
 857  res = zero
 858  do ikpt_fine = 1, elph_ds%k_phon%nkpt
 859    do iqpt = 1, elph_ds%k_phon%nkpt
 860      kpt = elph_ds%k_phon%kpt(:,ikpt_fine) + elph_ds%k_phon%kpt(:,iqpt)
 861      call get_rank_1kpt (kpt,symrankkpt,elph_ds%k_phon%kptrank_t)
 862      iFSkpq = elph_ds%k_phon%kptrank_t%invrank(symrankkpt)
 863      do iband = 1, elph_ds%ngkkband
 864        do ibandp = 1, elph_ds%ngkkband
 865          res = res + elph_ds%gkk_intweight(iband,ikpt_fine,1)*elph_ds%gkk_intweight(ibandp,iFSkpq,1)
 866        end do
 867      end do
 868    end do
 869  end do
 870  res = res / elph_ds%k_phon%nkpt/elph_ds%k_phon%nkpt
 871  write (std_out,*) 'elphon: integrated value of intweight for double k grid : ', res, res / elph_ds%n0(1)**2
 872 
 873 !===================================================
 874 !Allocate all important arrays for FS integrations
 875 !===================================================
 876 
 877 !Record sizes for matrices on disk: complex and real versions (for real and recip space resp!)
 878  onegkksize = 2*elph_ds%nbranch*elph_ds%nbranch*&
 879 & elph_ds%ngkkband*elph_ds%ngkkband*&
 880 & elph_ds%nsppol*kind(realdp_ex)
 881 
 882  elph_tr_ds%onegkksize=onegkksize
 883 
 884  write (message,'(4a)')&
 885 & ' elphon : preliminary setup completed ',ch10,&
 886 & '          calling get_all_gkq to read in all the e-ph matrix elements',ch10
 887  call wrtout(std_out,message,'COLL')
 888 
 889 !flag to do scalar product in gkq before interpolation:
 890 !should also used in interpolate_gkk and mkph_linwid
 891  if (elph_ds%ep_scalprod==0) then
 892    write (std_out,*) ' elphon: will NOT perform scalar product with phonon'
 893    write (std_out,*) '  displacement vectors in read_gkk. ep_scalprod==0'
 894  else if (elph_ds%ep_scalprod==1) then
 895    write (std_out,*) ' elphon: will perform scalar product with phonon'
 896    write (std_out,*) '  displacement vectors in read_gkk. ep_scalprod==1'
 897  else
 898    MSG_ERROR('illegal value for ep_scalprod')
 899  end if
 900 
 901  call timein(tcpu,twall)
 902  write(message, '(a,f11.3,a,f11.3,a)' )&
 903 & '-elphon begin gkq construction after tcpu',tcpu-tcpui,'  and twall',twall-twalli,' sec'
 904  call wrtout(std_out,message,'COLL')
 905  tcpui = tcpu
 906  twalli = twall
 907 
 908  call get_all_gkq (elph_ds,Cryst,ifc,Bst,FSfullpqtofull,nband,n1wf,onegkksize,&
 909 & qpttoqpt,anaddb_dtset%ep_prt_yambo,unitgkk,elph_tr_ds%ifltransport)
 910 
 911  if (master == me) then
 912    close (unitgkk)
 913  end if
 914 
 915  call timein(tcpu,twall)
 916  write(message, '(a,f11.3,a,f11.3,a)' )&
 917 & '-elphon end gkq construction after tcpu',tcpu-tcpui,'  and twall',twall-twalli,' sec'
 918  call wrtout(std_out,message,'COLL')
 919  tcpui = tcpu
 920  twalli = twall
 921 
 922  if (elph_tr_ds%ifltransport==1 .or. elph_tr_ds%ifltransport==2 .or. elph_tr_ds%ifltransport==3)then
 923 
 924 !  check inputs
 925 !  TODO: should be done at earlier stage of initialization and checking
 926    if (elph_ds%ngkkband /= elph_ds%nFSband) then
 927      write (message,'(a)') 'need to keep electron band dependency in memory for transport calculations'
 928      MSG_ERROR(message)
 929    end if
 930 
 931 !  bxu, moved the allocation from get_veloc_tr to elphon
 932    if (anaddb_dtset%use_k_fine == 1) then
 933      ABI_ALLOCATE(elph_tr_ds%el_veloc,(elph_ds%k_fine%nkpt,nband,3,elph_ds%nsppol))
 934    else
 935      ABI_ALLOCATE(elph_tr_ds%el_veloc,(elph_ds%k_phon%nkpt,nband,3,elph_ds%nsppol))
 936    end if
 937    ABI_ALLOCATE(elph_tr_ds%FSelecveloc_sq,(3,elph_ds%nsppol))
 938 
 939 !  this only needs to be read in once - the fermi level average is later done many times with get_veloc_tr
 940    if (me == master) then
 941      if (anaddb_dtset%use_k_fine == 1) then
 942        call read_el_veloc(nband,elph_ds%k_fine%nkpt,elph_ds%k_fine%kpt,elph_ds%nsppol,elph_tr_ds)
 943      else
 944        call read_el_veloc(nband,elph_ds%k_phon%nkpt,elph_ds%k_phon%kpt,elph_ds%nsppol,elph_tr_ds)
 945      end if
 946    end if
 947    call xmpi_bcast (elph_tr_ds%el_veloc, master, comm, ierr)
 948 
 949    call get_veloc_tr(elph_ds,elph_tr_ds)
 950  end if
 951 
 952 !Output of the Fermi velocities
 953 !to be used for Mayavi visualization
 954  if (anaddb_dtset%prtfsurf == 1 .and. master == me) then
 955    fname = trim(elph_ds%elph_base_name) // '_VTK'
 956 
 957 !  FIXME
 958 !  shiftk is defined neither in the anaddb nor in the hdr data type
 959 !  an incorrect FS will be produced in case of a shifted k-grid used during the GS calculation
 960 !  check if we are using a unshifthed kgrid, obviously doesnt work in case
 961 !  of multiple shifts containg a zero translation but in this case prtbxsf should work
 962    shiftk=one
 963    do ii=1,hdr%nkpt
 964      if (all(hdr%kptns(:,ii) == zero)) shiftk=zero
 965    end do
 966 
 967    use_afm=(hdr%nsppol==1.and.hdr%nspden==2)
 968 !  MG FIXME warning time reversal is always assumed to be present.
 969 !  the header should report this information.
 970 
 971    use_tr=(timrev==1)
 972 
 973    nk1 = elph_ds%kptrlatt_fine(1,1)
 974    nk2 = elph_ds%kptrlatt_fine(2,2)
 975    nk3 = elph_ds%kptrlatt_fine(3,3)
 976 
 977    ABI_ALLOCATE(v_surf,(nband,nk1+1,nk2+1,nk3+1,3,elph_ds%nsppol))
 978    v_surf = zero
 979    do isppol=1,elph_ds%nsppol
 980      do iband=1,nband
 981        do ikpt = 1, nk1+1
 982          do jkpt = 1, nk2+1
 983            do kkpt = 1, nk3+1
 984              ik1 = ikpt
 985              ik2 = jkpt
 986              ik3 = kkpt
 987              if (ikpt > nk1) ik1 = ikpt - nk1
 988              if (jkpt > nk2) ik2 = jkpt - nk2
 989              if (kkpt > nk3) ik3 = kkpt - nk3
 990              ikpt_fine = (ik1-1)*nk2*nk3 + (ik2-1)*nk3 + ik3
 991 !            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)
 992              v_surf(iband,ikpt,jkpt,kkpt,:,isppol)=elph_tr_ds%el_veloc(ikpt_fine,iband,:,isppol)
 993            end do
 994          end do
 995        end do
 996      end do
 997    end do
 998 
 999    call printvtk(eigenGS,v_surf,zero,elph_ds%fermie,Cryst%gprimd,&
1000 &   elph_ds%kptrlatt_fine,nband,hdr%nkpt,hdr%kptns,&
1001 &   Cryst%nsym,use_afm,Cryst%symrec,Cryst%symafm,use_tr,elph_ds%nsppol,shiftk,1,fname,ierr)
1002 
1003    ABI_DEALLOCATE(v_surf)
1004 
1005  end if !anaddb_dtset%prtfsurf
1006 
1007 !============================================================================
1008 !Evaluate lambda and omega_log using the weighted sum over the irred q-points
1009 !found in the GKK file. All the data we need are stored in elph_ds%qgrid_data
1010 !============================================================================
1011 
1012  if (master == me) then
1013    fname=trim(elph_ds%elph_base_name) // '_QPTS'
1014    call outelph(elph_ds,anaddb_dtset%enunit,fname)
1015  end if
1016 
1017 !========================================================
1018 !Get FS averaged gamma matrices and Fourier transform to real space
1019 !========================================================
1020 
1021  ABI_ALLOCATE(coskr, (elph_ds%nqpt_full,Ifc%nrpt))
1022  ABI_ALLOCATE(sinkr, (elph_ds%nqpt_full,Ifc%nrpt))
1023  call ftgam_init(ifc%gprim, elph_ds%nqpt_full,Ifc%nrpt, elph_ds%qpt_full, Ifc%rpt, coskr, sinkr)
1024 
1025  call timein(tcpu,twall)
1026  write(message, '(a,f11.3,a,f11.3,a)' )&
1027 & '-elphon begin integration of gkq after tcpu',tcpu-tcpui,'  and twall',twall-twalli,' sec'
1028  call wrtout(std_out,message,'COLL')
1029  tcpui = tcpu
1030  twalli = twall
1031 
1032  call integrate_gamma(elph_ds,FSfullpqtofull)
1033 
1034  if (elph_ds%symgkq ==1) then
1035 !  complete the gamma_qpt here instead of the gkk previously
1036    call complete_gamma(Cryst,elph_ds%nbranch,elph_ds%nsppol,elph_ds%nqptirred,elph_ds%nqpt_full,&
1037 &   elph_ds%ep_scalprod,elph_ds%qirredtofull,qpttoqpt,elph_ds%gamma_qpt)
1038  end if
1039 
1040 !Now FT to real space too
1041 !NOTE: gprim (not gprimd) is used for all FT interpolations,
1042 !to be consistent with the dimensions of the rpt, which come from anaddb.
1043  ABI_ALLOCATE(elph_ds%gamma_rpt, (2,elph_ds%nbranch**2,elph_ds%nsppol,Ifc%nrpt))
1044  elph_ds%gamma_rpt = zero
1045 
1046  qtor = 1 ! q --> r
1047  do isppol=1,elph_ds%nsppol
1048    call ftgam(Ifc%wghatm,elph_ds%gamma_qpt(:,:,isppol,:),elph_ds%gamma_rpt(:,:,isppol,:),natom,&
1049 &   elph_ds%nqpt_full,Ifc%nrpt,qtor, coskr, sinkr)
1050  end do
1051 
1052  call timein(tcpu,twall)
1053  write(message, '(a,f11.3,a,f11.3,a)' )&
1054 & '-elphon end integration and completion of gkq after tcpu',tcpu-tcpui,'  and twall',twall-twalli,' sec'
1055  call wrtout(std_out,message,'COLL')
1056  tcpui = tcpu
1057  twalli = twall
1058 
1059 
1060 !==========================================================
1061 !calculate transport matrix elements, integrated over FS
1062 !==========================================================
1063 
1064  if (elph_tr_ds%ifltransport == 1)then ! LOVA
1065 
1066    call integrate_gamma_tr_lova(elph_ds,FSfullpqtofull,elph_tr_ds)
1067 
1068    call complete_gamma_tr(cryst,elph_ds%ep_scalprod,elph_ds%nbranch,elph_ds%nqptirred,&
1069 &   elph_ds%nqpt_full,elph_ds%nsppol,elph_tr_ds%gamma_qpt_trout,elph_ds%qirredtofull,qpttoqpt)
1070 
1071    call complete_gamma_tr(cryst,elph_ds%ep_scalprod,elph_ds%nbranch,elph_ds%nqptirred,&
1072 &   elph_ds%nqpt_full,elph_ds%nsppol,elph_tr_ds%gamma_qpt_trin,elph_ds%qirredtofull,qpttoqpt)
1073 
1074    ABI_ALLOCATE(elph_tr_ds%gamma_rpt_trout,(2,9,elph_ds%nbranch**2,elph_ds%nsppol,Ifc%nrpt))
1075    elph_tr_ds%gamma_rpt_trout = zero
1076 
1077    ABI_ALLOCATE(elph_tr_ds%gamma_rpt_trin,(2,9,elph_ds%nbranch**2,elph_ds%nsppol,Ifc%nrpt))
1078    elph_tr_ds%gamma_rpt_trin = zero
1079 
1080 !  Now FT to real space too
1081    qtor = 1 ! q --> r
1082    do isppol=1,elph_ds%nsppol
1083      do idir=1,9
1084        call ftgam(Ifc%wghatm,elph_tr_ds%gamma_qpt_trout(:,idir,:,isppol,:),&
1085 &       elph_tr_ds%gamma_rpt_trout(:,idir,:,isppol,:),natom,&
1086 &       elph_ds%nqpt_full,Ifc%nrpt,qtor, coskr, sinkr)
1087 
1088        call ftgam(Ifc%wghatm,elph_tr_ds%gamma_qpt_trin(:,idir,:,isppol,:),&
1089 &       elph_tr_ds%gamma_rpt_trin(:,idir,:,isppol,:),natom,&
1090 &       elph_ds%nqpt_full,Ifc%nrpt,qtor, coskr, sinkr)
1091      end do
1092    end do
1093 
1094  else if (elph_tr_ds%ifltransport==2) then ! non-LOVA case
1095 
1096 !  Get Ef, DOS(Ef), veloc(Ef) for looped temperatures
1097    call get_nv_fs_temp(elph_ds,BSt,eigenGS_fine,cryst%gprimd,max_occ,elph_tr_ds)
1098 
1099 !  Get DOS(E), veloc(E) for looped energy levels
1100    call get_nv_fs_en(cryst,ifc,elph_ds,eigenGS_fine,max_occ,elph_tr_ds,omega_max)
1101 
1102 !  Save the E, N(E), v^2(E), dE
1103    if (master == me) then
1104      fname = trim(elph_ds%elph_base_name) // '_EPTS'
1105      if (open_file(fname,message,newunit=unit_epts,status="unknown") /=0) then
1106        MSG_ERROR(message)
1107      end if
1108      do isppol = 1, elph_ds%nsppol
1109        write(unit_epts,"(a,i6)") '# E, N(E), v^2(E), dE for spin channel ', isppol
1110        do ie1 = 1, elph_ds%nenergy
1111          write(unit_epts,"(4E20.12)") elph_tr_ds%en_all(isppol,ie1), elph_tr_ds%dos_n(ie1,isppol),&
1112 &         elph_tr_ds%veloc_sq(1,isppol,ie1), elph_tr_ds%de_all(isppol,ie1)
1113        end do
1114      end do
1115      close(unit=unit_epts)
1116    end if
1117 
1118    ABI_ALLOCATE(tmp_veloc_sq1,(3,elph_ds%nsppol))
1119    ABI_ALLOCATE(tmp_veloc_sq2,(3,elph_ds%nsppol))
1120    ABI_ALLOCATE(elph_tr_ds%tmp_gkk_intweight1,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,elph_ds%nsppol))
1121    ABI_ALLOCATE(elph_tr_ds%tmp_gkk_intweight2,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,elph_ds%nsppol))
1122    ABI_ALLOCATE(elph_tr_ds%tmp_velocwtk1,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,3,elph_ds%nsppol))
1123    ABI_ALLOCATE(elph_tr_ds%tmp_velocwtk2,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,3,elph_ds%nsppol))
1124    ABI_ALLOCATE(elph_tr_ds%tmp_vvelocwtk1,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,3,3,elph_ds%nsppol))
1125    ABI_ALLOCATE(elph_tr_ds%tmp_vvelocwtk2,(elph_ds%ngkkband,elph_ds%k_phon%nkpt,3,3,elph_ds%nsppol))
1126 
1127    tmp_veloc_sq1 = zero
1128    tmp_veloc_sq2 = zero
1129    elph_tr_ds%tmp_gkk_intweight1 = zero
1130    elph_tr_ds%tmp_gkk_intweight2 = zero
1131    elph_tr_ds%tmp_velocwtk1 = zero
1132    elph_tr_ds%tmp_velocwtk2 = zero
1133    elph_tr_ds%tmp_vvelocwtk1 = zero
1134    elph_tr_ds%tmp_vvelocwtk2 = zero
1135 
1136    if (elph_ds%ep_lova .eq. 1) then
1137      tmp_nenergy = 1
1138    else if (elph_ds%ep_lova .eq. 0) then
1139      tmp_nenergy = elph_ds%nenergy
1140    else
1141      write(message,'(a,i0)')' ep_lova must be 0 or 1 while it is : ', elph_ds%ep_lova
1142      MSG_ERROR(message)
1143    end if
1144 
1145 !  This only works for ONE temperature!! for test only
1146    elph_ds%n0(:) = elph_tr_ds%dos_n0(1,:)
1147 
1148 !  bxu, no need for complete sets of ie1 and ie2
1149 !  Only save those within the range of omega_max from Ef
1150    ABI_ALLOCATE(pair2red,(tmp_nenergy,tmp_nenergy))
1151    pair2red = 0
1152 
1153    elph_ds%n_pair = 0
1154    do ie1=1,tmp_nenergy
1155      e1 = elph_tr_ds%en_all(1,ie1)
1156      e2 = e1 - omega_max
1157      if (e2 .lt. elph_tr_ds%en_all(1,1)) then
1158        i_start = 1
1159      else
1160        i_start = 1
1161        diff = dabs(e2-elph_tr_ds%en_all(1,1))
1162        do ie2 = 2, tmp_nenergy
1163          if (dabs(e2-elph_tr_ds%en_all(1,ie2)) .lt. diff) then
1164            diff = dabs(e2-elph_tr_ds%en_all(1,ie2))
1165            i_start = ie2
1166          end if
1167        end do
1168      end if
1169      e2 = e1 + omega_max
1170      if (e2 .gt. elph_tr_ds%en_all(1,tmp_nenergy)) then
1171        i_end = tmp_nenergy
1172      else
1173        i_end = 1
1174        diff = dabs(e2-elph_tr_ds%en_all(1,1))
1175        do ie2 = 2, tmp_nenergy
1176          if (dabs(e2-elph_tr_ds%en_all(1,ie2)) .lt. diff) then
1177            diff = dabs(e2-elph_tr_ds%en_all(1,ie2))
1178            i_end = ie2
1179          end if
1180        end do
1181      end if
1182      do ie2 = i_start, i_end
1183        elph_ds%n_pair = elph_ds%n_pair + 1
1184        pair2red(ie1,ie2) = elph_ds%n_pair
1185      end do
1186    end do
1187 
1188 !  symmetrize paire2red
1189    elph_ds%n_pair = 0
1190    do ie1 = 1, tmp_nenergy
1191      do ie2 = 1, tmp_nenergy
1192        if (pair2red(ie1,ie2) .ne. 0 .or. pair2red(ie2,ie1) .ne. 0) then
1193          elph_ds%n_pair = elph_ds%n_pair + 1
1194          pair2red(ie1,ie2) = elph_ds%n_pair
1195        end if
1196      end do
1197    end do
1198 
1199    write(message,'(a,i3,a)')' There are  ', elph_ds%n_pair, '  energy pairs. '
1200    call wrtout(std_out,message,'COLL')
1201 
1202    ABI_ALLOCATE(red2pair,(2,elph_ds%n_pair))
1203    red2pair = 0
1204    elph_ds%n_pair = 0
1205    do ie1 = 1, tmp_nenergy
1206      do ie2 = 1, tmp_nenergy
1207        if (pair2red(ie1,ie2) .ne. 0 .or. pair2red(ie2,ie1) .ne. 0) then
1208          elph_ds%n_pair = elph_ds%n_pair + 1
1209          red2pair(1,elph_ds%n_pair) = ie1
1210          red2pair(2,elph_ds%n_pair) = ie2
1211        end if
1212      end do
1213    end do
1214 
1215 !  moved from integrate_gamma_tr to here
1216    ABI_ALLOCATE(elph_tr_ds%gamma_qpt_tr,(2,9,elph_ds%nbranch**2,elph_ds%nsppol,elph_ds%nqpt_full))
1217    ABI_ALLOCATE(elph_tr_ds%gamma_rpt_tr,(2,9,elph_ds%nbranch**2,elph_ds%nsppol,Ifc%nrpt,4,elph_ds%n_pair))
1218    elph_tr_ds%gamma_rpt_tr = zero
1219 
1220    s1ofssp = (/1,1,-1,-1/)
1221    s2ofssp = (/1,-1,1,-1/)
1222 
1223 !  Get gamma
1224    do ie=1,elph_ds%n_pair
1225      ie1 = red2pair(1,ie)
1226      ie2 = red2pair(2,ie)
1227 
1228      tmp_veloc_sq1(:,:)=elph_tr_ds%veloc_sq(:,:,ie1)
1229      elph_tr_ds%tmp_gkk_intweight1(:,:,:) = elph_tr_ds%tmp_gkk_intweight(:,:,:,ie1)
1230      elph_tr_ds%tmp_velocwtk1(:,:,:,:) = elph_tr_ds%tmp_velocwtk(:,:,:,:,ie1)
1231      elph_tr_ds%tmp_vvelocwtk1(:,:,:,:,:) = elph_tr_ds%tmp_vvelocwtk(:,:,:,:,:,ie1)
1232 
1233      tmp_veloc_sq2(:,:)=elph_tr_ds%veloc_sq(:,:,ie2)
1234      elph_tr_ds%tmp_gkk_intweight2(:,:,:) = elph_tr_ds%tmp_gkk_intweight(:,:,:,ie2)
1235      elph_tr_ds%tmp_velocwtk2(:,:,:,:) = elph_tr_ds%tmp_velocwtk(:,:,:,:,ie2)
1236      elph_tr_ds%tmp_vvelocwtk2(:,:,:,:,:) = elph_tr_ds%tmp_vvelocwtk(:,:,:,:,:,ie2)
1237 
1238      do ssp=1,4  ! (s,s'=+/-1, condense the indices)
1239        s1=s1ofssp(ssp)
1240        s2=s2ofssp(ssp)
1241        elph_tr_ds%gamma_qpt_tr = zero
1242 
1243        call integrate_gamma_tr(elph_ds,FSfullpqtofull,s1,s2, &
1244 &       tmp_veloc_sq1,tmp_veloc_sq2,elph_tr_ds)
1245 
1246        call complete_gamma_tr(cryst,elph_ds%ep_scalprod,elph_ds%nbranch,elph_ds%nqptirred,&
1247 &       elph_ds%nqpt_full,elph_ds%nsppol,elph_tr_ds%gamma_qpt_tr,elph_ds%qirredtofull,qpttoqpt)
1248 
1249 !      Now FT to real space too
1250        qtor = 1 ! q --> r
1251        do isppol=1,elph_ds%nsppol
1252          do idir=1,9
1253            call ftgam(Ifc%wghatm,elph_tr_ds%gamma_qpt_tr(:,idir,:,isppol,:),&
1254 &           elph_tr_ds%gamma_rpt_tr(:,idir,:,isppol,:,ssp,ie),natom,&
1255 &           elph_ds%nqpt_full,Ifc%nrpt,qtor,coskr, sinkr)
1256          end do
1257        end do
1258 
1259      end do !ss
1260    end do !ie
1261 
1262    ABI_DEALLOCATE(tmp_veloc_sq1)
1263    ABI_DEALLOCATE(tmp_veloc_sq2)
1264  end if ! ifltransport
1265 
1266  ABI_DEALLOCATE(qpttoqpt)
1267  ABI_DEALLOCATE(FSfullpqtofull)
1268 
1269 
1270 !==============================================================
1271 !Calculate phonon linewidths, interpolating on chosen qpoints
1272 !==============================================================
1273 
1274  call mkph_linwid(Cryst,ifc,elph_ds,anaddb_dtset%nqpath,anaddb_dtset%qpath)
1275 
1276 !==============================================================
1277 !the nesting factor calculation
1278 !FIXME: this could go higher up, before the call to get_all_gkq
1279 !you only need the kpt and weight info
1280 !==============================================================
1281  if (any(anaddb_dtset%prtnest==[1,2])) then
1282 
1283    nestname = trim(elph_ds%elph_base_name) // "_NEST"
1284    call mknesting(elph_ds%k_phon%nkpt,elph_ds%k_phon%kpt,elph_ds%kptrlatt,elph_ds%nFSband,&
1285 &   elph_ds%k_phon%wtk,anaddb_dtset%nqpath,anaddb_dtset%qpath,elph_ds%nqpt_full, &
1286 &   elph_ds%qpt_full,nestname,cryst%gprimd,cryst%gmet,anaddb_dtset%prtnest,qptrlatt)
1287  end if
1288 
1289 !======================================================
1290 !Calculate alpha^2 F integrating over fine kpt_phon grid
1291 !======================================================
1292 
1293  ABI_ALLOCATE(a2f_1d,(elph_ds%na2f))
1294  ABI_ALLOCATE(dos_phon,(elph_ds%na2f))
1295 
1296  call mka2f(Cryst,Ifc,a2f_1d,dos_phon,elph_ds,elph_ds%kptrlatt_fine,elph_ds%mustar)
1297 
1298 !calculate transport spectral function and coefficients
1299  if (elph_tr_ds%ifltransport==1 )then ! LOVA
1300 
1301    call mka2f_tr_lova(cryst,ifc,elph_ds,elph_ds%ntemper,elph_ds%tempermin,elph_ds%temperinc,elph_tr_ds)
1302 
1303  else if (elph_tr_ds%ifltransport==2 )then ! non LOVA
1304 
1305    call mka2f_tr(cryst,ifc,elph_ds,elph_ds%ntemper,elph_ds%tempermin,elph_ds%temperinc,pair2red,elph_tr_ds)
1306 
1307    ABI_DEALLOCATE(pair2red)
1308    ABI_DEALLOCATE(red2pair)
1309 
1310  else if (elph_tr_ds%ifltransport==3 )then ! get k-dependent tau
1311 
1312    call get_tau_k(Cryst,ifc,Bst,elph_ds,elph_tr_ds,eigenGS,max_occ)
1313    !call trans_rta(elph_ds,elph_tr_ds,cryst%gprimd,eigenGS,max_occ,cryst%ucvol)
1314  end if ! ifltransport
1315 
1316  ABI_DEALLOCATE(eigenGS)
1317  ABI_DEALLOCATE(eigenGS_fine)
1318 
1319 
1320 !evaluate a2F only using the input Q-grid (without using interpolated matrices)
1321 !SCOPE: test the validity of the Fourier interpolation
1322  call wrtout(std_out,' elphon : calling mka2fQgrid',"COLL")
1323 
1324  fname=trim(elph_ds%elph_base_name) // '_A2F_QGRID'
1325  call mka2fQgrid(elph_ds,fname)
1326 
1327 !=============================================
1328 !Eliashberg equation in 1-D (isotropic case)
1329 !=============================================
1330 
1331  call eliashberg_1d(a2f_1d,elph_ds,anaddb_dtset%mustar)
1332 
1333  ABI_DEALLOCATE(a2f_1d)
1334  ABI_DEALLOCATE(dos_phon)
1335 
1336 !MJV: 20070805 should exit here. None of the rest is tested or used yet to my knowledge
1337 
1338 !========================================================================
1339 !Now gkk contains the matrix elements of dH(1)/dxi i=1,2,3
1340 !for kpoints on the FS but qpoints only in the given grid {Q}.
1341 !
1342 !1.) Need to complete the gkk elements for q and k\prime=k+q not
1343 !in the set of {k+Q} by Fourier interpolation on the Q.
1344 !
1345 !2.) Need to complete the dynamical matrices and phonon freqs for
1346 !all q between points on the FS.
1347 !
1348 !3.) With the eigenvectors e_ph of the dyn mats, do the scalar product
1349 !e_ph . gkk, which implies the gkk are turned to the eigenbasis of
1350 !the phonons. Before the (non eigen-) modes are ordered
1351 !atom1 xred1 atom1 xred2 atom1 xred3
1352 !atom2 xred1 atom2 xred2 atom2 xred3 ...
1353 !=======================================================================
1354 
1355  make_gkk2=.false.
1356 
1357  if (.not. make_gkk2) then
1358    call wrtout(std_out,' elphon : skipping full g(k,k") interpolation ',"COLL")
1359  else
1360 
1361 !  ==========================================================
1362 !  FT of recip space gkk matrices to real space (gkk_rpt)
1363 !  NOTE: could be made into FFT, couldnt it? If shifts are
1364 !  used with a homogeneous grid
1365 !  ==========================================================
1366    write (message,'(2a,i0)')ch10,&
1367 &   ' elphon : Fourier transform (q --> r) of the gkk matrices using nrpt = ',Ifc%nrpt
1368    call wrtout(std_out,message,'COLL')
1369 
1370    call get_all_gkr(elph_ds,ifc%gprim,natom,Ifc%nrpt,onegkksize,Ifc%rpt,elph_ds%qpt_full,Ifc%wghatm)
1371 
1372 !  =========================================================
1373 !  complete gkk2 for all qpts between points
1374 !  on full kpt grid (interpolation from real space values)
1375 !  =========================================================
1376 
1377    write(message,'(2a)')ch10,&
1378 &   ' elphon : Calling get_all_gkk2 to calculate gkk2 for q points over the full k grid'
1379    call wrtout(std_out,message,'COLL')
1380 
1381    call get_all_gkk2(cryst,ifc,elph_ds,elph_ds%k_phon%kptirr,elph_ds%k_phon%kpt)
1382  end if
1383 
1384 !=====================================================
1385 !Here should be the anisotropic Eliashberg equations.
1386 !=====================================================
1387 
1388 !clean and deallocate junk
1389  call ebands_free(Bst)
1390  call elph_ds_clean(elph_ds)
1391  call elph_tr_ds_clean(elph_tr_ds)
1392  call hdr_free(hdr)
1393 
1394  ABI_DEALLOCATE(coskr)
1395  ABI_DEALLOCATE(sinkr)
1396 
1397  if (is_open(elph_ds%unitgkq)) close(elph_ds%unitgkq)
1398 
1399 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

PARENTS

      elphon

CHILDREN

      getkgrid,smpbz,symkpt,wrap2_pmhalf,wrtout

NOTES

SOURCE

2947 subroutine ep_setupqpt (elph_ds,crystal,anaddb_dtset,qptrlatt,timrev)
2948 
2949 
2950 !This section has been created automatically by the script Abilint (TD).
2951 !Do not modify the following lines by hand.
2952 #undef ABI_FUNC
2953 #define ABI_FUNC 'ep_setupqpt'
2954 !End of the abilint section
2955 
2956  implicit none
2957 
2958 !Arguments -------------------------------
2959 !scalars
2960  integer, intent(in) :: timrev
2961  type(crystal_t),intent(in) :: crystal
2962  type(anaddb_dataset_type), intent(in) :: anaddb_dtset
2963  type(elph_type), intent(inout) :: elph_ds
2964 !arrays
2965  integer, intent(out) :: qptrlatt(3,3)
2966 
2967 !Local variables -------------------------
2968 !scalars
2969  integer :: nqshft,option,iqpt, nqpt1
2970  integer :: iscf,mqpt,iout,berryopt,nqpt_computed
2971  real(dp) :: qptrlen, res
2972  character(len=500) :: message
2973 !arrays
2974  integer :: vacuum(3)
2975  integer,allocatable :: indqpt1(:)
2976  real(dp) :: kpt(3)
2977  real(dp),allocatable :: wtq_folded(:)
2978  real(dp), allocatable :: wtq(:),qpt_full(:,:),tmpshifts(:,:)
2979 
2980 ! *********************************************************************
2981 
2982 !default is to expect a uniform grid
2983  elph_ds%tuniformgrid = 1
2984 
2985 !if we use the normal grid way of generating the qpoints:
2986  if (anaddb_dtset%qgrid_type==1) then
2987 !  qpoint lattice vectors (inverse, like kptrlatt)
2988    qptrlatt(:,:)=0
2989    qptrlatt(1,1)=anaddb_dtset%ngqpt(1)
2990    qptrlatt(2,2)=anaddb_dtset%ngqpt(2)
2991    qptrlatt(3,3)=anaddb_dtset%ngqpt(3)
2992 
2993    if (anaddb_dtset%nqshft /= 1) then
2994 !    try to reduce the qpoint grid to a single qshift, otherwise stop
2995 !    dummy args for call to getkgrid
2996      vacuum(:) = 0
2997      iscf = 3
2998 
2999      mqpt = anaddb_dtset%ngqpt(1)*anaddb_dtset%ngqpt(2)*anaddb_dtset%ngqpt(3)*anaddb_dtset%nqshft
3000      ABI_ALLOCATE(qpt_full,(3,mqpt))
3001      ABI_ALLOCATE(wtq,(mqpt))
3002      ABI_ALLOCATE(tmpshifts,(3,210))
3003 
3004      wtq(:) = one
3005 
3006      tmpshifts(:,:) = zero
3007      tmpshifts(:,1:4) = anaddb_dtset%q1shft(:,:)
3008 
3009      iout=6
3010 
3011      berryopt = 1
3012 
3013 !    just call with identity, to get full set of kpts in qpt_full, but
3014 !    reduce qshfts
3015 
3016      nqshft=anaddb_dtset%nqshft
3017      call getkgrid(0,0,iscf,qpt_full,3,qptrlatt,qptrlen, &
3018 &     1,mqpt,nqpt_computed,nqshft,1,crystal%rprimd,tmpshifts,crystal%symafm, &
3019 &     crystal%symrel,vacuum,wtq)
3020      ABI_DEALLOCATE(qpt_full)
3021      ABI_DEALLOCATE(wtq)
3022      ABI_DEALLOCATE(tmpshifts)
3023 
3024      if (anaddb_dtset%nqshft /= 1) then
3025        write (message,'(a,i0)')&
3026 &       ' multiple qpt shifts not treated yet (should be possible), nqshft= ', anaddb_dtset%nqshft
3027        MSG_ERROR(message)
3028      end if
3029    end if  ! end multiple shifted qgrid
3030 
3031 
3032    write(message,'(a,9(i0,1x))')' elphon : enter smpbz with  qptrlatt = ',qptrlatt
3033    call wrtout(std_out,message,'COLL')
3034 
3035    option=1
3036 !  mqpt=anaddb_dtset%ngqpt(1)*anaddb_dtset%ngqpt(2)*anaddb_dtset%ngqpt(3)*anaddb_dtset%nqshft
3037    mqpt= qptrlatt(1,1)*qptrlatt(2,2)*qptrlatt(3,3) &
3038 &   +qptrlatt(1,2)*qptrlatt(2,3)*qptrlatt(3,1) &
3039 &   +qptrlatt(1,3)*qptrlatt(2,1)*qptrlatt(3,2) &
3040 &   -qptrlatt(1,2)*qptrlatt(2,1)*qptrlatt(3,3) &
3041 &   -qptrlatt(1,3)*qptrlatt(2,2)*qptrlatt(3,1) &
3042 &   -qptrlatt(1,1)*qptrlatt(2,3)*qptrlatt(3,2)
3043 
3044    ABI_ALLOCATE(qpt_full,(3,mqpt))
3045    iout = 6
3046    call smpbz(anaddb_dtset%brav,iout,qptrlatt,mqpt,elph_ds%nqpt_full,anaddb_dtset%nqshft,option,anaddb_dtset%q1shft,qpt_full)
3047 
3048 
3049 !  save the q-grid for future reference
3050    ABI_ALLOCATE(elph_ds%qpt_full,(3,elph_ds%nqpt_full))
3051 
3052 !  reduce qpt_full to correct zone
3053    do iqpt=1,elph_ds%nqpt_full
3054      call wrap2_pmhalf(qpt_full(1,iqpt),kpt(1),res)
3055      call wrap2_pmhalf(qpt_full(2,iqpt),kpt(2),res)
3056      call wrap2_pmhalf(qpt_full(3,iqpt),kpt(3),res)
3057      qpt_full(:,iqpt) = kpt
3058      elph_ds%qpt_full(:,iqpt)=kpt
3059    end do
3060    ABI_DEALLOCATE(qpt_full)
3061 
3062  else if (anaddb_dtset%qgrid_type==2) then ! use explicit list of qpoints from anaddb input
3063    qptrlatt(:,:)=0
3064    qptrlatt(1,1)=1
3065    qptrlatt(2,2)=1
3066    qptrlatt(3,3)=1
3067 
3068    elph_ds%nqpt_full=anaddb_dtset%ep_nqpt
3069    ABI_ALLOCATE(elph_ds%qpt_full,(3,elph_ds%nqpt_full))
3070 
3071    elph_ds%qpt_full = anaddb_dtset%ep_qptlist
3072 
3073    elph_ds%tuniformgrid = 0
3074  end if ! type of qgrid for elphon
3075 
3076 !=================================================================
3077 !Calculate weights, needed to estimate lambda using the weighted
3078 !sum of the uninterpolated e-ph matrix elements
3079 !=================================================================
3080  call wrtout(std_out,' setqgrid : calling symkpt to find irred q points',"COLL")
3081 
3082  ABI_ALLOCATE(indqpt1,(elph_ds%nqpt_full))
3083  ABI_ALLOCATE(wtq_folded,(elph_ds%nqpt_full))
3084  ABI_ALLOCATE(wtq,(elph_ds%nqpt_full))
3085 
3086  wtq(:) = one/dble(elph_ds%nqpt_full) !weights normalized to unity
3087 
3088 !
3089 !NOTE: this reduction of irred qpt may not be identical to that in GKK file
3090 !which would be more practical to use.
3091 !
3092  iout=0 !do not write to ab_out
3093 !should we save indqpt1 for use inside elph_ds?
3094  call symkpt(0,crystal%gmet,indqpt1,iout,elph_ds%qpt_full,elph_ds%nqpt_full,nqpt1,crystal%nsym,crystal%symrec,&
3095 & timrev,wtq,wtq_folded)
3096 
3097  write (message,'(2a,i0)')ch10,' Number of irreducible q-points = ',nqpt1
3098  call wrtout(std_out,message,'COLL')
3099  elph_ds%nqptirred=nqpt1
3100 
3101  call wrtout(std_out,' === Irreducible q points with weights ==== ','COLL')
3102 
3103  do iqpt=1,elph_ds%nqpt_full
3104    if (wtq_folded(iqpt) /= zero) then
3105      write (message,'(1x,i4,a2,4es16.8)')iqpt,') ',elph_ds%qpt_full(:,iqpt),wtq_folded(iqpt)
3106      call wrtout(std_out,message,'COLL')
3107    end if
3108  end do
3109 
3110  call wrtout(std_out,ch10,'COLL')
3111 
3112  ABI_ALLOCATE(elph_ds%wtq,(elph_ds%nqpt_full))
3113 
3114  elph_ds%wtq(:)=wtq_folded(:)
3115 !MEMO indqpt could be useful to test the qgrid read by abinit
3116  ABI_DEALLOCATE(indqpt1)
3117  ABI_DEALLOCATE(wtq_folded)
3118  ABI_DEALLOCATE(wtq)
3119 
3120 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

PARENTS

      elphon

CHILDREN

      d2c_wtq,ep_ph_weights,ftgam,ftgam_init,gam_mult_displ,ifc_fourq
      phdispl_cart2red,simpson_int,wrtout,zgemm

NOTES

   copied from ftiaf9.f

SOURCE

2088 subroutine mka2f(Cryst,ifc,a2f_1d,dos_phon,elph_ds,kptrlatt,mustar)
2089 
2090  use m_special_funcs,  only : fermi_dirac, bose_einstein
2091  use m_epweights,      only : d2c_wtq, ep_ph_weights
2092 
2093 !This section has been created automatically by the script Abilint (TD).
2094 !Do not modify the following lines by hand.
2095 #undef ABI_FUNC
2096 #define ABI_FUNC 'mka2f'
2097 !End of the abilint section
2098 
2099  implicit none
2100 
2101 !Arguments ------------------------------------
2102 !scalars
2103  real(dp),intent(in) :: mustar
2104  type(ifc_type),intent(in) :: ifc
2105  type(crystal_t),intent(in) :: Cryst
2106  type(elph_type),target,intent(inout) :: elph_ds
2107 !arrays
2108  integer, intent(in) :: kptrlatt(3,3)
2109  real(dp),intent(out) :: a2f_1d(elph_ds%na2f),dos_phon(elph_ds%na2f)
2110 
2111 !Local variables -------------------------
2112 !scalars
2113  integer :: natom,iFSqpt,ibranch,iomega,nbranch,na2f,nsppol,nkpt,nrpt
2114  integer :: isppol,jbranch,unit_a2f,unit_phdos,ep_scalprod
2115  integer :: itemp, ntemp = 100
2116  real(dp) :: temp
2117  real(dp) :: a2fprefactor,avgelphg,avglambda,avgomlog,diagerr
2118  real(dp) :: lambda_2,lambda_3,lambda_4,lambda_5
2119  real(dp) :: spinfact
2120  real(dp) :: lambda_iso(elph_ds%nsppol)
2121  real(dp) :: lqn,omega
2122  real(dp) :: omegalog(elph_ds%nsppol)
2123  real(dp) :: omlog_qn
2124  real(dp) :: tc_macmill,a2fsmear,domega,omega_min,omega_max
2125  real(dp) :: gaussval, gaussprefactor, gaussfactor, gaussmaxval, xx
2126  character(len=500) :: msg
2127  character(len=fnlen) :: fname,base_name
2128 !arrays
2129  real(dp) :: displ_cart(2,elph_ds%nbranch,elph_ds%nbranch)
2130  real(dp) :: displ_red(2,elph_ds%nbranch,elph_ds%nbranch)
2131  real(dp) :: eigval(elph_ds%nbranch)
2132  real(dp) :: gam_now(2,elph_ds%nbranch*elph_ds%nbranch)
2133  real(dp) :: imeigval(elph_ds%nbranch)
2134 ! real(dp) :: pheigvec(2*elph_ds%nbranch*elph_ds%nbranch),phfrq(elph_ds%nbranch)
2135  real(dp) :: tmp_a2f(elph_ds%na2f)
2136  real(dp) :: tmp_gam1(2,elph_ds%nbranch,elph_ds%nbranch)
2137  real(dp) :: tmp_gam2(2,elph_ds%nbranch,elph_ds%nbranch)
2138  real(dp) :: tmp_phondos(elph_ds%na2f),n0(elph_ds%nsppol)
2139  real(dp),pointer :: kpt(:,:)
2140  real(dp),allocatable :: phfrq(:,:)
2141  real(dp),allocatable :: pheigvec(:,:)
2142  real(dp),allocatable :: tmp_wtq(:,:,:)
2143  real(dp),allocatable :: a2f1mom(:),a2f2mom(:),a2f3mom(:),a2f4mom(:)
2144  real(dp),allocatable :: a2f_1mom(:),a2flogmom(:)
2145  real(dp),allocatable :: a2flogmom_int(:)
2146  real(dp),allocatable :: coskr(:,:)
2147  real(dp),allocatable :: sinkr(:,:)
2148  real(dp),allocatable :: linewidth_of_t(:)
2149  real(dp),allocatable :: linewidth_integrand(:,:)
2150 
2151 ! *********************************************************************
2152 !calculate a2f for frequencies between 0 and elph_ds%omega_max
2153 
2154  DBG_ENTER("COLL")
2155 
2156 !might need kptrlatt for finer interpolation later
2157  ABI_UNUSED(kptrlatt(1,1))
2158 
2159  ! nrpt = number of real-space points for FT interpolation
2160  nrpt = Ifc%nrpt
2161  natom = Cryst%natom
2162 
2163  nbranch   =  elph_ds%nbranch
2164  na2f      =  elph_ds%na2f
2165  nsppol    =  elph_ds%nsppol
2166  base_name =  elph_ds%elph_base_name
2167  a2fsmear  =  elph_ds%a2fsmear
2168  nkpt      =  elph_ds%k_phon%nkpt
2169  kpt       => elph_ds%k_phon%kpt
2170 
2171  ep_scalprod = elph_ds%ep_scalprod
2172  n0        = elph_ds%n0
2173 
2174 !spinfact should be 1 for a normal non sppol calculation without spinorbit
2175 !for spinors it should also be 1 as bands are twice as numerous but n0 has been divided by 2
2176 !for sppol 2 it should be 0.5 as we have 2 spin channels to sum
2177  spinfact = one/elph_ds%nsppol !/elph_ds%nspinor
2178 
2179 !maximum value of frequency (a grid has to be chosen for the representation of alpha^2 F)
2180 !WARNING! supposes this value has been set in mkelph_linwid.
2181  domega = (elph_ds%omega_max-elph_ds%omega_min)/(na2f-one)
2182  elph_ds%domega  = domega  ! MG Why do we need to store domega in elph_ds?
2183  omega_min       = elph_ds%omega_min
2184  omega_max       = elph_ds%omega_max
2185 
2186  gaussprefactor = sqrt(piinv) / a2fsmear
2187  gaussfactor = one / a2fsmear
2188  gaussmaxval = sqrt(-log(1.d-100))
2189 
2190  ! only open the file for the first sppol
2191  fname = trim(base_name) // '_A2F'
2192  if (open_file(fname,msg,newunit=unit_a2f,status="unknown") /= 0) then
2193    MSG_ERROR(msg)
2194  end if
2195 
2196  !write (std_out,*) ' a2f function integrated over the FS'
2197 
2198 !output the a2f_1d header
2199  write (unit_a2f,'(a)')                 '#'
2200  write (unit_a2f,'(a)')                 '# ABINIT package : a2f file'
2201  write (unit_a2f,'(a)')                 '#'
2202  write (unit_a2f,'(a)')                 '# a2f function integrated over the FS. omega in a.u.'
2203  write (unit_a2f,'(a,I10)')             '#  number of kpoints integrated over : ',nkpt
2204  write (unit_a2f,'(a,I10)')             '#  number of energy points : ',na2f
2205  write (unit_a2f,'(a,E16.6,a,E16.6,a)') '#  between omega_min = ',omega_min,' Ha and omega_max = ',omega_max,' Ha'
2206  write (unit_a2f,'(a,E16.6)')           '#  and the smearing width for gaussians is ',a2fsmear
2207 
2208  ! Open file for PH DOS
2209  fname = trim(base_name) // '_PDS'
2210  if (open_file(fname,msg,newunit=unit_phdos,status="replace") /= 0) then
2211    MSG_ERROR(msg)
2212  end if
2213 
2214  ! output the phonon DOS header
2215  write (unit_phdos,'(a)')                '#'
2216  write (unit_phdos,'(a)')                '# ABINIT package : phonon DOS file'
2217  write (unit_phdos,'(a)')                '#'
2218  write (unit_phdos,'(a)')                '# Phonon DOS integrated over the FS. omega in a.u. EXPERIMENTAL!!!'
2219  write (unit_phdos,'(a,I10)')            '# number of kpoints integrated over : ',nkpt
2220  write (unit_phdos,'(a,I10)')            '# number of energy points : ',na2f
2221  write (unit_phdos,'(a,E16.6,a,E16.6,a)')'# between omega_min = ',omega_min,' Ha and omega_max = ',omega_max,' Ha'
2222  write (unit_phdos,'(a,i4,a,E16.6)')     '# The DOS at Fermi level for spin ', 1, ' is ', n0(1)
2223  if (nsppol==2) then
2224    write (unit_phdos,'(a,i4,a,E16.6)')   '# The DOS at Fermi level for spin ', 2, ' is ', n0(2)
2225  end if
2226  write (unit_phdos,'(a,E16.6)')          '# and the smearing width for gaussians is ',a2fsmear
2227  write (unit_phdos,'(a)') '#'
2228 
2229 !Get the integration weights, using tetrahedron method or gaussian
2230  ABI_ALLOCATE(tmp_wtq,(nbranch,elph_ds%k_fine%nkpt,na2f+1))
2231  ABI_ALLOCATE(elph_ds%k_fine%wtq,(nbranch,elph_ds%k_fine%nkpt,na2f))
2232  ABI_ALLOCATE(elph_ds%k_phon%wtq,(nbranch,nkpt,na2f))
2233 
2234  ABI_ALLOCATE(phfrq,(nbranch,elph_ds%k_fine%nkpt))
2235  ABI_ALLOCATE(pheigvec,(2*nbranch*nbranch,elph_ds%k_fine%nkpt))
2236 
2237  do iFSqpt=1,elph_ds%k_fine%nkpt
2238    call ifc_fourq(ifc,cryst,elph_ds%k_fine%kpt(:,iFSqpt),phfrq(:,iFSqpt),displ_cart,out_eigvec=pheigvec(:,iFSqpt))
2239  end do
2240 
2241  omega_min = omega_min - domega
2242 
2243  call ep_ph_weights(phfrq,elph_ds%a2fsmear,omega_min,omega_max,na2f+1,Cryst%gprimd,elph_ds%kptrlatt_fine, &
2244 & elph_ds%nbranch,elph_ds%telphint,elph_ds%k_fine,tmp_wtq)
2245 !call ep_ph_weights(phfrq,elph_ds%a2fsmear,omega_min,omega_max,na2f+1,Cryst%gprimd,elph_ds%kptrlatt_fine, &
2246 !& elph_ds%nbranch,1,elph_ds%k_fine,tmp_wtq)
2247  omega_min = omega_min + domega
2248 
2249  do iomega = 1, na2f
2250    elph_ds%k_fine%wtq(:,:,iomega) = tmp_wtq(:,:,iomega+1)
2251  end do
2252  ABI_DEALLOCATE(tmp_wtq)
2253 
2254  if (elph_ds%use_k_fine == 1) then
2255    call d2c_wtq(elph_ds)
2256  end if
2257 
2258  ABI_ALLOCATE(coskr, (nkpt,nrpt))
2259  ABI_ALLOCATE(sinkr, (nkpt,nrpt))
2260  call ftgam_init(Ifc%gprim, nkpt, nrpt, kpt, Ifc%rpt, coskr, sinkr)
2261 
2262  ABI_DEALLOCATE(phfrq)
2263  ABI_DEALLOCATE(pheigvec)
2264 
2265  do isppol=1,nsppol
2266    write (std_out,*) '##############################################'
2267    write (std_out,*) 'mka2f : Treating spin polarization ', isppol
2268    write (std_out,*) '##############################################'
2269 
2270 !  Average of electron phonon coupling over the whole BZ
2271    avgelphg = zero
2272 !  MG20060607 Do the same for lambda and omega_log
2273    avglambda = zero
2274    avgomlog = zero
2275 
2276    a2f_1d(:) = zero
2277    dos_phon(:) = zero
2278 
2279 !  reduce the dimenstion from fine to phon for phfrq and pheigvec
2280    ABI_ALLOCATE(phfrq,(nbranch,elph_ds%k_phon%nkpt))
2281    ABI_ALLOCATE(pheigvec,(2*nbranch*nbranch,elph_ds%k_phon%nkpt))
2282 
2283 !  loop over qpoint in full kpt grid (presumably dense)
2284 !  MG TODO : This loop can be performed using the IBZ and appropriated weights.
2285    do iFSqpt=1,nkpt
2286 !
2287 !    This reduced version of ftgkk supposes the kpoints have been integrated
2288 !    in integrate_gamma. Do FT from real-space gamma grid to 1 qpt.
2289 
2290      if (elph_ds%ep_int_gkk == 1) then
2291        gam_now(:,:) = elph_ds%gamma_qpt(:,:,isppol,iFSqpt)
2292      else
2293        call ftgam(Ifc%wghatm,gam_now,elph_ds%gamma_rpt(:,:,isppol,:),natom,1,nrpt,0, &
2294 &       coskr(iFSqpt,:), sinkr(iFSqpt,:))
2295      end if
2296 
2297      call ifc_fourq(ifc,cryst,kpt(:,iFSqpt),phfrq(:,iFSqpt),displ_cart,out_eigvec=pheigvec)
2298 
2299 !    Diagonalize gamma matrix at qpoint (complex matrix).
2300 
2301 !    if ep_scalprod==0 we have to dot in the displacement vectors here
2302      if (ep_scalprod==0) then
2303 
2304        call phdispl_cart2red(natom,Cryst%gprimd,displ_cart,displ_red)
2305 
2306        tmp_gam2 = reshape (gam_now, (/2,nbranch,nbranch/))
2307        call gam_mult_displ(nbranch, displ_red, tmp_gam2, tmp_gam1)
2308 
2309        do jbranch=1,nbranch
2310          eigval(jbranch) = tmp_gam1(1, jbranch, jbranch)
2311          imeigval(jbranch) = tmp_gam1(2, jbranch, jbranch)
2312 
2313          if (abs(imeigval(jbranch)) > tol8) then
2314            write (msg,'(a,i0,a,es16.8)')" imaginary values  branch = ",jbranch,' imeigval = ',imeigval(jbranch)
2315            MSG_WARNING(msg)
2316          end if
2317 
2318        end do
2319 
2320 !      if ep_scalprod==1 we have to diagonalize the matrix we interpolated.
2321      else if (ep_scalprod == 1) then
2322 
2323 !      MJV NOTE : gam_now is being recast as a (3*natom)**2 matrix here
2324        call ZGEMM ( 'N', 'N', 3*natom, 3*natom, 3*natom, cone, gam_now, 3*natom,&
2325 &       pheigvec, 3*natom, czero, tmp_gam1, 3*natom)
2326 
2327        call ZGEMM ( 'C', 'N', 3*natom, 3*natom, 3*natom, cone, pheigvec, 3*natom,&
2328 &       tmp_gam1, 3*natom, czero, tmp_gam2, 3*natom)
2329 
2330        diagerr = zero
2331        do ibranch=1,nbranch
2332          eigval(ibranch) = tmp_gam2(1,ibranch,ibranch)
2333          do jbranch=1,ibranch-1
2334            diagerr = diagerr + abs(tmp_gam2(1,jbranch,ibranch))
2335          end do
2336          do jbranch=ibranch+1,nbranch
2337            diagerr = diagerr + abs(tmp_gam2(1,jbranch,ibranch))
2338          end do
2339        end do
2340 
2341        if (diagerr > tol12) then
2342          write(msg,'(a,es15.8)') 'mka2f: residual in diagonalization of gamma with phon eigenvectors: ', diagerr
2343          MSG_WARNING(msg)
2344        end if
2345 
2346      else
2347        write (msg,'(a,i0)')' Wrong value for ep_scalprod = ',ep_scalprod
2348        MSG_BUG(msg)
2349      end if
2350 
2351 !    MG20060603MG
2352 !    there was a bug in the calculation of the phonon DOS
2353 !    since frequencies with small e-ph interaction were skipped inside the loop
2354 !    In this new version all the frequencies (both positive and negative) are taken into account.
2355 !    IDEA: it could be useful to calculate the PH-dos and the a2f
2356 !    using several smearing values to perform a convergence study
2357 !    Now the case ep_scalprod=1 is treated in the right way although it is not default anymore
2358 !    FIXME to be checked
2359 !    ENDMG
2360 
2361 !    Add all contributions from the phonon modes at this qpoint to a2f and the phonon dos.
2362      do ibranch=1,nbranch
2363 
2364 !      if (abs(phfrq(ibranch,iFSqpt)) < tol10) then
2365        if (abs(phfrq(ibranch,iFSqpt)) < tol7) then
2366          a2fprefactor= zero
2367          lqn         = zero
2368          omlog_qn    = zero
2369        else
2370          a2fprefactor = eigval(ibranch)/(two_pi*abs(phfrq(ibranch,iFSqpt))*n0(isppol))
2371          lqn          = eigval(ibranch)/(pi*phfrq(ibranch,iFSqpt)**2*n0(isppol))
2372          omlog_qn     = lqn*log(abs(phfrq(ibranch,iFSqpt)))
2373        end if
2374 
2375 !      Add contribution to average elphon coupling
2376 !      MANY ISSUES WITH FINITE T SUMS. THIS IS DEFINITELY
2377 !      NOT A CORRECT FORMULATION YET.
2378 
2379 !      Added avglambda and avgomglog to calculate lamda and omega_log using the sum over the kpt-grid.
2380 !      If the k-grid is dense enough, these values should be better than the corresponding quantities
2381 !      evaluated through the integration over omega that depends on the a2fsmear
2382 
2383        avgelphg = avgelphg + eigval(ibranch)
2384        avglambda = avglambda + lqn
2385        avgomlog= avgomlog + omlog_qn
2386 !      ENDMG
2387 
2388        omega = omega_min
2389        tmp_a2f(:) = zero
2390        tmp_phondos(:) = zero
2391        do iomega=1,na2f
2392          xx = (omega-phfrq(ibranch,iFSqpt))*gaussfactor
2393          omega = omega + domega
2394          if (abs(xx) > gaussmaxval) cycle
2395 
2396          gaussval = gaussprefactor*exp(-xx*xx)
2397          tmp_a2f(iomega) = tmp_a2f(iomega) + gaussval*a2fprefactor
2398          tmp_phondos(iomega) = tmp_phondos(iomega) + gaussval
2399        end do
2400 
2401 !      tmp_a2f(:) = zero
2402 !      tmp_phondos(:) = zero
2403 !      do iomega=1,na2f
2404 !      tmp_a2f(iomega) = tmp_a2f(iomega) + a2fprefactor*elph_ds%k_phon%wtq(ibranch,iFSqpt,iomega)
2405 !      tmp_phondos(iomega) = tmp_phondos(iomega) + elph_ds%k_phon%wtq(ibranch,iFSqpt,iomega)
2406 !      end do
2407 
2408        a2f_1d(:) = a2f_1d(:) + tmp_a2f(:)
2409        dos_phon(:) = dos_phon(:) + tmp_phondos(:)
2410 
2411      end do ! ibranch
2412    end do  ! iFSqpt do
2413 
2414 
2415 !  second 1 / nkpt factor for the integration weights
2416    a2f_1d(:) = a2f_1d(:) / nkpt
2417    dos_phon(:) = dos_phon(:) / nkpt
2418 
2419 !  MG
2420    avglambda = avglambda/nkpt
2421    avgomlog= avgomlog/nkpt
2422    avgomlog = exp (avgomlog/avglambda)
2423    write(std_out,*) ' from mka2f: for spin ', isppol
2424    write(std_out,*) ' w/o interpolation lambda = ',avglambda,' omega_log= ',avgomlog
2425 !  ENDMG
2426 
2427    write (std_out,'(a,I4,a,E16.6)') '# The DOS at Fermi level for spin ',isppol,' is ',n0(isppol)
2428 
2429    write (unit_a2f,'(a,I4,a,E16.6)') '# The DOS at Fermi level for spin ',isppol,' is ',n0(isppol)
2430    write (unit_a2f,'(a)') '#'
2431 
2432    omega = omega_min
2433    do iomega=1,na2f
2434      write (unit_a2f,*) omega, a2f_1d(iomega)
2435      omega=omega + domega
2436    end do
2437    write (unit_a2f,*)
2438 !
2439 !  output the phonon DOS, but only for the first sppol case
2440    if (isppol == 1) then
2441      omega = omega_min
2442      do iomega=1,na2f
2443        write (unit_phdos,*) omega, dos_phon(iomega)
2444        omega=omega + domega
2445      end do
2446    end if
2447 !
2448 !  Do isotropic calculation of lambda and output lambda, Tc(MacMillan)
2449 !
2450    ABI_ALLOCATE(a2f_1mom,(na2f))
2451    ABI_ALLOCATE(a2f1mom,(na2f))
2452    ABI_ALLOCATE(a2f2mom,(na2f))
2453    ABI_ALLOCATE(a2f3mom,(na2f))
2454    ABI_ALLOCATE(a2f4mom,(na2f))
2455    ABI_ALLOCATE(linewidth_integrand,(na2f,ntemp))
2456    ABI_ALLOCATE(linewidth_of_t,(ntemp))
2457 
2458    a2f_1mom=zero
2459    a2f1mom=zero;  a2f2mom=zero
2460    a2f3mom=zero;  a2f4mom=zero
2461    linewidth_integrand = zero
2462 
2463    omega = omega_min
2464    do iomega=1,na2f
2465      if (abs(omega) > tol10) then
2466        a2f_1mom(iomega) =    two*spinfact*a2f_1d(iomega)/abs(omega)   ! first inverse moment of alpha2F
2467        a2f1mom(iomega)  =    two*spinfact*a2f_1d(iomega)*abs(omega)   ! first positive moment of alpha2F
2468        a2f2mom(iomega)  =     a2f1mom(iomega)*abs(omega)  ! second positive moment of alpha2F
2469        a2f3mom(iomega)  =     a2f2mom(iomega)*abs(omega)  ! third positive moment of alpha2F
2470        a2f4mom(iomega)  =     a2f3mom(iomega)*abs(omega)  ! fourth positive moment of alpha2F
2471 !
2472 !  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
2473 !  phonon lifetimes eq 19 in Savrasov PhysRevB.54.16487 [[cite:Savrasov1996]] (T=0)
2474 !  a first T dependent expression in Allen PRB 6 2577 [[cite:Allen1972]] eq 10. Not sure about the units though
2475 !
2476        do itemp = 1, ntemp
2477          temp = (itemp-1)*10._dp*kb_HaK
2478          linewidth_integrand(iomega, itemp) = a2f_1d(iomega) * (fermi_dirac(omega,zero,temp) + bose_einstein(omega,temp))
2479        end do
2480      end if
2481      omega=omega + domega
2482    end do
2483 !
2484 !  From Allen PRL 59 1460 [[cite:Allen1987]]
2485 !  \lambda <\omega^n> = 2 \int_0^{\infty} d\omega [\alpha^2F / \omega] \omega^n
2486 !
2487    lambda_iso(isppol) = simpson(domega,a2f_1mom)
2488    lambda_2 = simpson(domega,a2f1mom)
2489    lambda_3 = simpson(domega,a2f2mom)
2490    lambda_4 = simpson(domega,a2f3mom)
2491    lambda_5 = simpson(domega,a2f4mom)
2492    do itemp = 1, ntemp
2493      linewidth_of_t(itemp) = simpson(domega,linewidth_integrand(:,itemp))
2494 ! print out gamma(T) here
2495      temp = (itemp-1)*10._dp*kb_HaK
2496      write (std_out,*) 'mka2f: T, average linewidth', temp, linewidth_of_t(itemp)
2497    end do
2498 
2499 
2500    ABI_DEALLOCATE(phfrq)
2501    ABI_DEALLOCATE(pheigvec)
2502    ABI_DEALLOCATE(a2f_1mom)
2503    ABI_DEALLOCATE(a2f1mom)
2504    ABI_DEALLOCATE(a2f2mom)
2505    ABI_DEALLOCATE(a2f3mom)
2506    ABI_DEALLOCATE(a2f4mom)
2507    ABI_DEALLOCATE(linewidth_integrand)
2508    ABI_DEALLOCATE(linewidth_of_t)
2509 
2510    write (std_out,*) 'mka2f: elphon coupling lambdas for spin = ', isppol
2511    write (std_out,*) 'mka2f: isotropic lambda', lambda_iso(isppol)
2512    write (std_out,*) 'mka2f: positive moments of alpha2F:'
2513    write (std_out,*) 'lambda <omega^2> = ', lambda_2
2514    write (std_out,*) 'lambda <omega^3> = ', lambda_3
2515    write (std_out,*) 'lambda <omega^4> = ', lambda_4
2516    write (std_out,*) 'lambda <omega^5> = ', lambda_5
2517 !
2518 !  Get log moment of alpha^2F
2519    ABI_ALLOCATE(a2flogmom,(na2f))
2520    ABI_ALLOCATE(a2flogmom_int,(na2f))
2521    omega = omega_min
2522    a2flogmom(:) = zero
2523    do iomega=1,na2f
2524      if (abs(omega) > tol10) then
2525        a2flogmom(iomega) = a2f_1d(iomega)*log(abs(omega))/abs(omega)
2526      end if
2527      omega=omega + domega
2528    end do
2529    call simpson_int(na2f,domega,a2flogmom,a2flogmom_int)
2530 
2531 !  NOTE: omegalog actually stores the log moment of a2F, which is the quantity to sum over spins, instead of
2532 !  exp(moment/lambda) which is an actual frequency
2533    omegalog(isppol) = two*spinfact*a2flogmom_int(na2f)
2534 
2535    ABI_DEALLOCATE(a2flogmom)
2536    ABI_DEALLOCATE(a2flogmom_int)
2537 
2538    if (nsppol > 1) then
2539      write (msg, '(3a)' ) ch10,&
2540 &     ' Warning : some of the following quantities should be integrated over spin', ch10
2541      call wrtout(std_out,msg,'COLL')
2542      call wrtout(ab_out,msg,'COLL')
2543    end if
2544 
2545    write (msg, '(3a)' ) ch10,&
2546 &   ' Superconductivity : isotropic evaluation of parameters from electron-phonon coupling.',ch10
2547    call wrtout(std_out,msg,'COLL')
2548    call wrtout(ab_out,msg,'COLL')
2549 
2550    if (elph_ds%nsppol > 1) then
2551      write (msg, '(a,i6,a,es16.6)' )' mka2f: isotropic lambda for spin ', isppol, ' = ', lambda_iso(isppol)
2552      call wrtout(std_out,msg,'COLL')
2553      call wrtout(ab_out,msg,'COLL')
2554    end if
2555 
2556    write (msg, '(a,es16.6)' )' mka2f: lambda <omega^2> = ', lambda_2
2557    call wrtout(std_out,msg,'COLL')
2558    call wrtout(ab_out,msg,'COLL')
2559 
2560    write (msg, '(a,es16.6)' )' mka2f: lambda <omega^3> = ', lambda_3
2561    call wrtout(std_out,msg,'COLL')
2562    call wrtout(ab_out,msg,'COLL')
2563 
2564    write (msg, '(a,es16.6)' )' mka2f: lambda <omega^4> = ', lambda_4
2565    call wrtout(std_out,msg,'COLL')
2566    call wrtout(ab_out,msg,'COLL')
2567 
2568    write (msg, '(a,es16.6)' )' mka2f: lambda <omega^5> = ', lambda_5
2569    call wrtout(std_out,msg,'COLL')
2570    call wrtout(ab_out,msg,'COLL')
2571 
2572    if (elph_ds%nsppol > 1) then
2573      write (msg, '(a,i6,a,es16.6,a,es16.6,a)' )' mka2f: omegalog for spin ', isppol, ' = ',&
2574 &     exp(omegalog(isppol)/lambda_iso(isppol)), ' (Ha) ', exp(omegalog(isppol)/lambda_iso(isppol))/kb_HaK, ' (Kelvin) '
2575      call wrtout(std_out,msg,'COLL')
2576      call wrtout(ab_out,msg,'COLL')
2577    end if
2578 
2579  end do ! isppol
2580 
2581 
2582 
2583 !also print out spin-summed quantities
2584  lambda_2 = sum(lambda_iso(1:elph_ds%nsppol))
2585  write (msg, '(a,es16.6)' )' mka2f: isotropic lambda = ', lambda_2
2586  call wrtout(std_out,msg,'COLL')
2587  call wrtout(ab_out,msg,'COLL')
2588 
2589  omega = exp( sum(omegalog(1:elph_ds%nsppol))/lambda_2 )
2590  write (msg, '(a,es16.6,a,es16.6,a)' )' mka2f: omegalog  = ', omega, ' (Ha) ', omega/kb_HaK, ' (Kelvin) '
2591  call wrtout(std_out,msg,'COLL')
2592  call wrtout(ab_out,msg,'COLL')
2593 
2594  write (msg, '(a,es16.6)' )' mka2f: input mustar = ', mustar
2595  call wrtout(std_out,msg,'COLL')
2596  call wrtout(ab_out,msg,'COLL')
2597 
2598  tc_macmill = omega/1.2_dp * exp((-1.04_dp*(one+lambda_2)) / (lambda_2-mustar*(one+0.62_dp*lambda_2)))
2599  write ( msg, '(a,es16.6,a,es16.6,a)')'-mka2f: MacMillan Tc = ', tc_macmill, ' (Ha) ', tc_macmill/kb_HaK, ' (Kelvin) '
2600  call wrtout(std_out,msg,'COLL')
2601  call wrtout(ab_out,msg,'COLL')
2602 
2603  close(unit=unit_a2f)
2604  close(unit=unit_phdos)
2605 
2606  ABI_DEALLOCATE(elph_ds%k_fine%wtq)
2607  ABI_DEALLOCATE(elph_ds%k_phon%wtq)
2608 
2609  ABI_DEALLOCATE(coskr)
2610  ABI_DEALLOCATE(sinkr)
2611 
2612  DBG_EXIT("COLL")
2613 
2614 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

PARENTS

      elphon

CHILDREN

      simpson_int,wrtout

SOURCE

2643 subroutine mka2fQgrid(elph_ds,fname)
2644 
2645 
2646 !This section has been created automatically by the script Abilint (TD).
2647 !Do not modify the following lines by hand.
2648 #undef ABI_FUNC
2649 #define ABI_FUNC 'mka2fQgrid'
2650 !End of the abilint section
2651 
2652  implicit none
2653 
2654 !Arguments ------------------------------------
2655 !scalars
2656  character(len=fnlen),intent(in) :: fname
2657  type(elph_type),intent(in) :: elph_ds
2658 
2659 !Local variables -------------------------
2660 !scalars
2661  integer :: ibranch,iomega,iost,ismear,isppol,nsmear,nunit,qptirred
2662  real(dp) :: a2f_factor,estep,gaussfactor,gaussprefactor,gaussval,lambda_iso
2663  real(dp) :: omega,omegalog,omegastep,smear,tc_macmill,weight,xx
2664  character(len=500) :: msg
2665 !arrays
2666  real(dp),allocatable :: a2f_1d(:),a2f_1mom(:),a2f_1mom_int(:),a2flogmom(:)
2667  real(dp),allocatable :: a2flogmom_int(:),eli_smear(:,:,:),tmpa2f(:)
2668 
2669 ! *********************************************************************
2670 
2671 !grid for the representation of alpha^2F (same as mka2f)
2672 !WARNING : supposing that the maximum and minimum value of frequency
2673 !have been defined in mkelph_linwid.
2674 
2675  omegastep = (elph_ds%omega_max-elph_ds%omega_min)/(elph_ds%na2f-one)
2676 
2677  nunit = get_unit()
2678  open (unit=nunit,file=fname,form='formatted',status='unknown',iostat=iost)
2679  if (iost /= 0) then
2680    MSG_ERROR("Opening file: " //trim(fname))
2681  end if
2682 
2683  write (msg,'(3a)')&
2684 & '# Eliashberg function evaluated using only the irred q-points ',ch10,'#'
2685  call wrtout(nunit,msg,'COLL')
2686 
2687  write (msg,'(a,i5,2a,es16.8,2a,es16.8,2a,es16.8,2a)')&
2688 & '# number of frequencies = ',elph_ds%na2f,ch10,         &
2689 & '# omega_min = ',elph_ds%omega_min,ch10,                &
2690 & '# omega_max = ',elph_ds%omega_max,ch10,                &
2691 & '# step = ',omegastep,ch10,'#'
2692  call wrtout(nunit,msg,'COLL')
2693 
2694 
2695  nsmear=5
2696  estep=0.00002_dp !0.54422767 meV
2697 
2698  write (msg,'(a,i5,3a,f10.6,3a,f10.6,3a)')                &
2699 & '# Using ',nsmear,' values for the gaussian smearing ',ch10,&
2700 & '# starint from ',elph_ds%a2fsmear,' (Ha)',ch10,            &
2701 & '# energy step of ',estep,' (Ha)',ch10,'#'
2702  call wrtout(nunit,msg,'COLL')
2703 
2704 !e-ph quantities will be calculated for nsmear gaussian smearing values
2705 !starting from elph_ds%a2fsmearwith an energy step of estep Hartree
2706 
2707  write (msg,'(3a)')'#      Smear(Ha) Lambda_Iso  isppol  <ln w> (K)    Tc_McMill (K) ',ch10,'#'
2708  call wrtout(nunit,msg,'COLL')
2709 
2710  ABI_ALLOCATE(a2f_1mom,(elph_ds%na2f))
2711  ABI_ALLOCATE(a2f_1mom_int,(elph_ds%na2f))
2712  ABI_ALLOCATE(a2flogmom,(elph_ds%na2f))
2713  ABI_ALLOCATE(a2flogmom_int,(elph_ds%na2f))
2714  ABI_ALLOCATE(a2f_1d,(elph_ds%na2f))
2715  ABI_ALLOCATE(tmpa2f,(elph_ds%na2f))
2716  ABI_ALLOCATE(eli_smear,(nsmear,elph_ds%nsppol,elph_ds%na2f))
2717  eli_smear(:,:,:)=zero
2718 
2719  do ismear=0,nsmear-1
2720 
2721    smear = elph_ds%a2fsmear+ismear*estep
2722    gaussprefactor = sqrt(piinv) / smear
2723    gaussfactor = one / smear
2724 
2725    do isppol=1,elph_ds%nsppol  ! spin pol channels
2726 
2727      a2f_1d(:) = zero
2728      tmpa2f(:) = zero
2729 
2730      do qptirred=1,elph_ds%nqptirred ! sum over irred qpoints
2731        do ibranch=1,elph_ds%nbranch
2732 
2733          if (abs(elph_ds%qgrid_data(qptirred,ibranch,isppol,1)) < tol10) cycle
2734          omega = elph_ds%omega_min
2735 !        MG the weights in elph_ds%wtq(qptirred) are relative to the full grid qpt_full,
2736 !        we need the mapping qirredtofull
2737          weight=elph_ds%wtq(elph_ds%qirredtofull(qptirred))
2738          a2f_factor=weight*elph_ds%qgrid_data(qptirred,ibranch,isppol,2)/abs(elph_ds%qgrid_data(qptirred,ibranch,isppol,1))
2739 
2740          do iomega=1,elph_ds%na2f
2741            xx = (omega-elph_ds%qgrid_data(qptirred,ibranch,isppol,1))*gaussfactor
2742            gaussval = gaussprefactor*exp(-xx*xx)
2743            tmpa2f(iomega) = tmpa2f(iomega) + gaussval*a2f_factor
2744            omega = omega+omegastep
2745          end do
2746 
2747        end do !end ibranch do
2748      end do !end qptirred
2749 
2750      a2f_1d(:)= tmpa2f(:)/(2*pi*elph_ds%n0(isppol))
2751      eli_smear(ismear+1,isppol,:)=a2f_1d(:) !save values
2752 
2753 !    Do isotropic calculation of lambda and output lambda, Tc(MacMillan)
2754      a2f_1mom(:) = zero
2755      omega = elph_ds%omega_min
2756 
2757      do iomega=1,elph_ds%na2f
2758        if (abs(omega) > tol10) a2f_1mom(iomega) = two*a2f_1d(iomega)/abs(omega)
2759        omega=omega+omegastep
2760      end do
2761 
2762      call simpson_int(elph_ds%na2f,omegastep,a2f_1mom,a2f_1mom_int)
2763      lambda_iso = a2f_1mom_int(elph_ds%na2f)
2764 
2765 !    Get log moment of alpha^2F
2766      a2flogmom(:) = zero
2767      omega = elph_ds%omega_min
2768      do iomega=1,elph_ds%na2f
2769        if (abs(omega) > tol10) then
2770          a2flogmom(iomega) = (two/lambda_iso)*a2f_1d(iomega)*log(abs(omega))/abs(omega)
2771        end if
2772        omega=omega+omegastep
2773      end do
2774 
2775      call simpson_int(elph_ds%na2f,omegastep,a2flogmom,a2flogmom_int)
2776      omegalog = exp(a2flogmom_int(elph_ds%na2f))
2777 
2778      tc_macmill = (omegalog/1.2_dp) * &
2779 &     exp((-1.04_dp*(one+lambda_iso)) / (lambda_iso-elph_ds%mustar*(one+0.62_dp*lambda_iso)))
2780 
2781 !    write data
2782      write(msg,'(a,5x,f10.6,f10.6,i5,2x,f12.7,2x,f12.6,2x,es16.8)')&
2783 &     '# ',smear,lambda_iso,isppol,omegalog/kb_HaK,tc_macmill/kb_HaK
2784      call wrtout(nunit,msg,'COLL')
2785 
2786    end do !end isppol
2787 
2788  end do !ismear
2789 
2790  ABI_DEALLOCATE(a2f_1mom)
2791  ABI_DEALLOCATE(a2f_1mom_int)
2792  ABI_DEALLOCATE(a2flogmom)
2793  ABI_DEALLOCATE(a2flogmom_int)
2794 
2795 !write to file
2796  write(msg,'(4a)')'#',ch10,'# Eliashberg function calculated for different gaussian smearing values',ch10
2797  call wrtout(nunit,msg,'COLL')
2798 
2799  do isppol=1,elph_ds%nsppol
2800    omega = elph_ds%omega_min
2801    write(nunit,'(a,i5)') '# smeared alpha2F for isppol = ',isppol
2802    do iomega=1,elph_ds%na2f
2803      write(nunit,'(6(f17.12,1x))')omega,eli_smear(:,isppol,iomega)
2804      omega=omega+omegastep
2805    end do
2806    write(nunit,*)
2807  end do
2808 
2809  ABI_DEALLOCATE(eli_smear)
2810  ABI_DEALLOCATE(a2f_1d)
2811  ABI_DEALLOCATE(tmpa2f)
2812 
2813  close (nunit)
2814 
2815 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.

PARENTS

      elphon

CHILDREN

      destroy_kptrank,get_rank_1kpt,mkkptrank,sort_int,wrap2_pmhalf,wrtout

SOURCE

1877 subroutine mkFSkgrid (elph_k, nsym, symrec, timrev)
1878 
1879  use m_sort
1880 
1881 !This section has been created automatically by the script Abilint (TD).
1882 !Do not modify the following lines by hand.
1883 #undef ABI_FUNC
1884 #define ABI_FUNC 'mkFSkgrid'
1885 !End of the abilint section
1886 
1887  implicit none
1888 
1889 !Arguments ------------------------------------
1890 !scalars
1891  integer,intent(in) :: nsym,timrev
1892  type(elph_kgrid_type),intent(inout) :: elph_k
1893 !arrays
1894  integer,intent(in) :: symrec(3,3,nsym)
1895 
1896 !Local variables-------------------------------
1897 !scalars
1898  integer :: ikpt1,ikpt2,isym,itim,new,symrankkpt
1899  real(dp) :: timsign, res
1900  character(len=500) :: message
1901 
1902 !arrays
1903  real(dp) :: kpt(3),redkpt(3)
1904  integer, allocatable :: sortindexing(:), rankallk(:)
1905 
1906  integer, allocatable :: tmpkphon_full2irr(:,:)
1907  real(dp), allocatable :: tmpkpt(:,:)
1908 
1909 ! *************************************************************************
1910 
1911  if(timrev /= 1 .and. timrev /= 0)then
1912    write (message,'(a,i0)')' timrev must be 1 or 0 but found timrev= ',timrev
1913    MSG_BUG(message)
1914  end if
1915 
1916  ABI_ALLOCATE(tmpkphon_full2irr,(3,2*elph_k%nkptirr*nsym))
1917  tmpkphon_full2irr = -1
1918 
1919  ABI_ALLOCATE(tmpkpt,(3,2*elph_k%nkptirr*nsym))
1920 
1921  ABI_ALLOCATE(elph_k%wtkirr,(elph_k%nkptirr))
1922  elph_k%wtkirr(:) = zero
1923 
1924 !first allocation for irred kpoints - will be destroyed below
1925  call mkkptrank (elph_k%kptirr,elph_k%nkptirr,elph_k%kptrank_t)
1926  ABI_ALLOCATE(rankallk,(elph_k%kptrank_t%max_rank))
1927 
1928 !elph_k%kptrank_t%invrank is used as a placeholder in the following loop
1929  rankallk = -1
1930  elph_k%kptrank_t%invrank = -1
1931 
1932 !replicate all irred kpts by symmetry to get the full k grid.
1933  elph_k%nkpt=0 !zero k-points found so far
1934  do isym=1,nsym
1935    do itim=0,1
1936      timsign = one-two*itim
1937      do ikpt1=1,elph_k%nkptirr
1938 !      generate symmetrics of kpt ikpt1
1939        kpt(:) = timsign*(symrec(:,1,isym)*elph_k%kptirr(1,ikpt1) + &
1940 &       symrec(:,2,isym)*elph_k%kptirr(2,ikpt1) + &
1941 &       symrec(:,3,isym)*elph_k%kptirr(3,ikpt1))
1942 
1943        call get_rank_1kpt (kpt,symrankkpt,elph_k%kptrank_t)
1944 
1945 !      is the kpt on the full grid (may have lower symmetry than full spgroup)
1946 !      is kpt among the full FS kpts found already?
1947        if (elph_k%kptrank_t%invrank(symrankkpt) == -1) then
1948          elph_k%wtkirr(ikpt1)=elph_k%wtkirr(ikpt1)+1
1949          elph_k%nkpt=elph_k%nkpt+1
1950 
1951          call wrap2_pmhalf(kpt(1),redkpt(1),res)
1952          call wrap2_pmhalf(kpt(2),redkpt(2),res)
1953          call wrap2_pmhalf(kpt(3),redkpt(3),res)
1954          tmpkpt(:,elph_k%nkpt) = redkpt
1955          tmpkphon_full2irr(1,elph_k%nkpt) = ikpt1
1956 !        save sym that sends irred kpt ikpt1 onto full kpt
1957          tmpkphon_full2irr(2,elph_k%nkpt) = isym
1958          tmpkphon_full2irr(3,elph_k%nkpt) = itim
1959 
1960          elph_k%kptrank_t%invrank(symrankkpt) = elph_k%nkpt
1961          rankallk(elph_k%nkpt) = symrankkpt
1962        end if
1963 
1964      end do !end loop over irred k points
1965    end do !end loop over timrev
1966  end do !end loop over symmetry
1967 
1968  write(message,'(a,i0)')'mkfskgrid: after first evaluation, elph_k%nkpt= ', elph_k%nkpt
1969  call wrtout(std_out,message,"COLL")
1970 
1971  elph_k%wtkirr(:) = elph_k%wtkirr(:) / elph_k%nkpt
1972 
1973 !copy the kpoints and full --> irred kpt map
1974 !reorder the kpts to get rank increasing monotonically with a sort
1975 !also reorder tmpkphon_full2irr
1976  ABI_ALLOCATE(elph_k%kpt,(3,elph_k%nkpt))
1977  ABI_ALLOCATE(elph_k%full2irr,(3,elph_k%nkpt))
1978  ABI_ALLOCATE(sortindexing,(elph_k%nkpt))
1979 
1980  do ikpt1=1,elph_k%nkpt
1981    sortindexing(ikpt1)=ikpt1
1982  end do
1983  call sort_int(elph_k%nkpt, rankallk, sortindexing)
1984  do ikpt1=1,elph_k%nkpt
1985    if (sortindexing(ikpt1) < 1 .or. sortindexing(ikpt1) > elph_k%nkpt) then
1986      MSG_BUG('sorted k ranks are out of bounds: 1 to nkpt')
1987    end if
1988    elph_k%kpt(:,ikpt1) = tmpkpt(:,sortindexing(ikpt1))
1989    elph_k%full2irr(:,ikpt1) = tmpkphon_full2irr(:,sortindexing(ikpt1))
1990  end do
1991 
1992  ABI_DEALLOCATE(sortindexing)
1993  ABI_DEALLOCATE(rankallk)
1994  ABI_DEALLOCATE(tmpkphon_full2irr)
1995  ABI_DEALLOCATE(tmpkpt)
1996  call destroy_kptrank (elph_k%kptrank_t)
1997 
1998 
1999 !make proper full rank arrays
2000  call mkkptrank (elph_k%kpt,elph_k%nkpt,elph_k%kptrank_t)
2001 
2002 
2003 !find correspondence table between irred FS kpoints and a full one
2004  ABI_ALLOCATE(elph_k%irr2full,(elph_k%nkptirr))
2005  elph_k%irr2full(:) = 0
2006 
2007  do ikpt1=1,elph_k%nkptirr
2008    call get_rank_1kpt (elph_k%kptirr(:,ikpt1),symrankkpt,elph_k%kptrank_t)
2009    elph_k%irr2full(ikpt1) = elph_k%kptrank_t%invrank(symrankkpt)
2010  end do
2011 
2012 !find correspondence table between FS kpoints under symmetry
2013  ABI_ALLOCATE(elph_k%full2full,(2,nsym,elph_k%nkpt))
2014  elph_k%full2full(:,:,:) = -999
2015 
2016  do ikpt1=1,elph_k%nkpt
2017 !  generate symmetrics of kpt ikpt1
2018    do isym=1,nsym
2019      do itim=0,timrev
2020        timsign = one-two*itim
2021        kpt(:) = timsign*(symrec(:,1,isym)*elph_k%kpt(1,ikpt1) + &
2022 &       symrec(:,2,isym)*elph_k%kpt(2,ikpt1) + &
2023 &       symrec(:,3,isym)*elph_k%kpt(3,ikpt1))
2024 
2025 !      which kpt is it among the full FS kpts
2026        call get_rank_1kpt (kpt,symrankkpt,elph_k%kptrank_t)
2027        ikpt2 = elph_k%kptrank_t%invrank(symrankkpt)
2028        new=1
2029        if (ikpt2 /= -1) then
2030          elph_k%full2full(itim+1,isym,ikpt2) = ikpt1
2031          new = 0
2032        end if
2033 
2034        if (new == 1) then
2035          write(std_out,*) ' mkfskgrid Error: FS kpt ',ikpt1,' has no symmetric under sym', isym,' with itim ',itim
2036          write(std_out,*) ' redkpt = ', redkpt
2037          write(std_out,*) ' symrankkpt,ikpt2 = ', symrankkpt,ikpt2
2038          MSG_ERROR("Fatal error, cannot continue")
2039        end if
2040      end do
2041    end do
2042  end do
2043 
2044 !got nkpt, tmpkpt, kphon_full2irr, kphon_full2full, and wtkirr
2045 
2046 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

PARENTS

      elphon

CHILDREN

      destroy_kptrank,mkkptrank,wrap2_pmhalf

SOURCE

2844 subroutine order_fs_kpts(kptns, nkpt, kptirr,nkptirr,FSirredtoGS)
2845 
2846 
2847 !This section has been created automatically by the script Abilint (TD).
2848 !Do not modify the following lines by hand.
2849 #undef ABI_FUNC
2850 #define ABI_FUNC 'order_fs_kpts'
2851 !End of the abilint section
2852 
2853  implicit none
2854 
2855 !Arguments ------------------------------------
2856 !scalars
2857  integer,intent(in) :: nkptirr
2858  integer,intent(in) :: nkpt
2859 
2860 !arrays
2861  integer,intent(out) :: FSirredtoGS(nkptirr)
2862  real(dp),intent(in) :: kptns(3,nkpt)
2863  real(dp),intent(out) :: kptirr(3,nkptirr)
2864 
2865 !Local variables-------------------------------
2866 !scalars
2867  integer :: ikpt,jkpt,kkpt,new, ik
2868  real(dp) :: res
2869  type(kptrank_type) :: kptrank_t
2870 !arrays
2871  integer :: kptirrank(nkptirr)
2872 
2873 ! *************************************************************************
2874 
2875 !rank is used to order kpoints
2876  call mkkptrank (kptns,nkpt,kptrank_t)
2877 
2878  ik=1
2879  do ikpt=1,nkpt
2880 !  add kpt to FS kpts, in order, increasing z, then y, then x !
2881    new = 1
2882 !  look for position to insert kpt ikpt among irredkpts already found
2883    do jkpt=1,ik-1
2884      if (kptirrank(jkpt) > kptrank_t%rank(ikpt)) then
2885 !      shift all the others up
2886        do kkpt=ik-1,jkpt,-1
2887          kptirr(:,kkpt+1) = kptirr(:,kkpt)
2888          kptirrank(kkpt+1) = kptirrank(kkpt)
2889          FSirredtoGS(kkpt+1) = FSirredtoGS(kkpt)
2890        end do
2891 !      insert kpoint ikpt
2892        call wrap2_pmhalf(kptns(1,ikpt),kptirr(1,jkpt),res)
2893        call wrap2_pmhalf(kptns(2,ikpt),kptirr(2,jkpt),res)
2894        call wrap2_pmhalf(kptns(3,ikpt),kptirr(3,jkpt),res)
2895 
2896        kptirrank(jkpt) = kptrank_t%rank(ikpt)
2897        FSirredtoGS(jkpt) = ikpt
2898        new=0
2899        exit
2900      end if
2901    end do
2902 !  ikpt not counted yet and higher rank than all previous
2903    if (new == 1) then
2904      call wrap2_pmhalf(kptns(1,ikpt),kptirr(1,ikpt),res)
2905      call wrap2_pmhalf(kptns(2,ikpt),kptirr(2,ikpt),res)
2906      call wrap2_pmhalf(kptns(3,ikpt),kptirr(3,ikpt),res)
2907      kptirrank(ik) = kptrank_t%rank(ikpt)
2908      FSirredtoGS(ik) = ikpt
2909    end if
2910    ik=ik+1
2911  end do
2912 
2913  call destroy_kptrank (kptrank_t)
2914 
2915 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

PARENTS

      elphon

CHILDREN

      bfactor,destroy_kptrank,mkkptrank,wrtout

SOURCE

1426 subroutine outelph(elph_ds,enunit,fname)
1427 
1428 
1429 !This section has been created automatically by the script Abilint (TD).
1430 !Do not modify the following lines by hand.
1431 #undef ABI_FUNC
1432 #define ABI_FUNC 'outelph'
1433 !End of the abilint section
1434 
1435  implicit none
1436 
1437 !Arguments ------------------------------------
1438 !scalars
1439  integer,intent(in) :: enunit
1440  character(len=fnlen),intent(in) :: fname
1441  type(elph_type),intent(in) :: elph_ds
1442 
1443 !Local variables-------------------------------
1444 !scalars
1445  integer :: ibranch,ii,iqfull,iqirr,isppol,jj,nfile,qmax,qnest_max,qnest_min
1446  integer :: nbranch,nsppol,nqptirred
1447  real(dp) :: lambda_q_max,lambda_qbranch_max,lambda_tot,nest_max,nest_min
1448  real(dp) :: omegalog_q,omegalog_qgrid,tc_macmill
1449  character(len=500) :: msg
1450  type(kptrank_type) :: kptrank_t
1451 !arrays
1452  integer :: qbranch_max(2)
1453  real(dp),allocatable :: lambda_q(:,:),nestfactor(:),qirred(:,:)
1454 
1455 ! *************************************************************************
1456 
1457  if ( ALL (enunit /= (/0,1,2/)) )  then
1458    write(msg,'(a,i0)')' enunit should be 0 or 1 or 2 while it is ',enunit
1459    MSG_BUG(msg)
1460  end if
1461 
1462  nbranch   = elph_ds%nbranch
1463  nsppol    = elph_ds%nsppol
1464  nqptirred = elph_ds%nqptirred
1465 
1466 !==========================================================
1467 !write header
1468 !==========================================================
1469  if (open_file(fname,msg,newunit=nfile,form="formatted",status="unknown") /= 0) then
1470    MSG_ERROR(msg)
1471  end if
1472 
1473  write(msg,'(2a,80a,4a,80a)')ch10,' ',('=',ii=1,80),ch10,&
1474 & ' Values of the parameters that define the electron-phonon calculation',ch10,&
1475 & ' ',('=',ii=1,80)
1476  call wrtout(nfile,msg,'COLL')
1477 
1478  write(msg,'(a,i10,a,i10,a,i10)')&
1479 & ' nkpt_phon    = ',elph_ds%k_phon%nkpt,   ' nkpt_phonirred = ',elph_ds%k_phon%nkptirr,&
1480 & ' nqpt      = ',elph_ds%nqpt_full
1481  call wrtout(nfile,msg,'COLL')
1482 
1483  if (nsppol==1) then
1484    write(msg,'(2a,f10.7,a,f10.6,a,f10.7)')ch10,&
1485 &   ' Fermi DOS = ',elph_ds%n0(1),       ' Fermi level = ',elph_ds%fermie,&
1486 &   ' mustar    = ',elph_ds%mustar
1487    call wrtout(nfile,msg,'COLL')
1488  else if (nsppol==2) then
1489    write(msg,'(2a,f10.7,f10.7,a,f10.6,a,f10.7)')ch10,&
1490 &   ' Fermi DOS (up/dn) = ',elph_ds%n0(1),elph_ds%n0(2),       ' Fermi level = ',elph_ds%fermie,&
1491 &   ' mustar    = ',elph_ds%mustar
1492    call wrtout(nfile,msg,'COLL')
1493  else
1494    MSG_BUG("bad value for nsppol")
1495  end if
1496 
1497  write(msg,'(2a,i10,a,i10,a,i10)')ch10,&
1498 & ' minFSband = ',elph_ds%minFSband,' maxFSband   = ',elph_ds%maxFSband,&
1499 & ' ngkkband  = ',elph_ds%ngkkband
1500  call wrtout(nfile,msg,'COLL')
1501 
1502  write(msg,'(80a,a)')('=',ii=1,80),ch10
1503  call wrtout(nfile,msg,'COLL')
1504 
1505 !==========================================================
1506 !evaluate lambda and omega_log as a weighted sum over the q grid
1507 !NOTE: in this part of the code atomic units are used
1508 !==========================================================
1509 
1510  ABI_ALLOCATE(lambda_q,(nqptirred,nsppol))
1511  lambda_q=zero
1512  lambda_tot=zero ; lambda_q_max=zero
1513  qmax=0          ; lambda_qbranch_max=zero
1514  qbranch_max(:)=1; omegalog_qgrid=zero
1515 
1516  do iqirr=1,nqptirred
1517    omegalog_q=zero
1518 
1519    do isppol=1,nsppol
1520      do ibranch=1,nbranch
1521 !      find Max lambda(q,n)
1522        if (elph_ds%qgrid_data(iqirr,ibranch,isppol,3) > lambda_qbranch_max) then
1523          lambda_qbranch_max=elph_ds%qgrid_data(iqirr,ibranch,isppol,3)
1524          qbranch_max(1)=iqirr
1525          qbranch_max(2)=ibranch
1526        end if
1527        lambda_q(iqirr,isppol)=lambda_q(iqirr,isppol)+elph_ds%qgrid_data(iqirr,ibranch,isppol,3)
1528        if (abs(elph_ds%qgrid_data(iqirr,ibranch,isppol,1)) <= tol10) cycle
1529        omegalog_q=omegalog_q + elph_ds%qgrid_data(iqirr,ibranch,isppol,3)*log(abs(elph_ds%qgrid_data(iqirr,ibranch,isppol,1)))
1530      end do
1531 
1532      lambda_tot=lambda_tot+elph_ds%wtq(elph_ds%qirredtofull(iqirr))*lambda_q(iqirr,isppol)
1533      omegalog_qgrid=omegalog_qgrid+elph_ds%wtq(elph_ds%qirredtofull(iqirr))*omegalog_q
1534 
1535 
1536 !    find Max lambda(q)
1537      if (lambda_q(iqirr,isppol) > lambda_q_max) then
1538        lambda_q_max=lambda_q(iqirr,isppol)
1539        qmax=iqirr
1540      end if
1541    end do
1542 
1543  end do !iqirr
1544 
1545  omegalog_qgrid=exp(omegalog_qgrid/lambda_tot)
1546 
1547  write (msg,'(3a,2(a,es16.8))')                                                                              &
1548 & ' Values of Lambda, Omega_log and Tc obtained using the weighted sum over the input Q-grid',ch10,ch10,&
1549 & ' Isotropic Lambda = ',lambda_tot,'  Input mustar     = ',elph_ds%mustar
1550  call wrtout(nfile,msg,'COLL')
1551 
1552  if (enunit==0) then !use hartree and cm-1
1553    write (msg,'(2a,es16.8,a,es16.8,a)')ch10,&
1554 &   ' Omega_log        = ',omegalog_qgrid,' (Ha) ',omegalog_qgrid*Ha_cmm1,' (cm-1)'
1555    call wrtout(nfile,msg,'COLL')
1556  else if (enunit==1) then !mev Thz
1557    write (msg,'(2a,es16.8,a,es16.8,a)')ch10,&
1558 &   ' Omega_log        = ',omegalog_qgrid*Ha_eV/1000._dp,' (meV) ',omegalog_qgrid*Ha_THz,' (THz)'
1559    call wrtout(nfile,msg,'COLL')
1560  else !hartree,cm-1,mev,Thz,kelvin
1561    write (msg,'(2a,es16.8,a,es16.8,3a,es16.8,a,es16.8,3a,es16.8,a)')ch10,                              &
1562 &   ' Omega_log        = ',omegalog_qgrid,' (Ha)  ',omegalog_qgrid*Ha_cmm1,' (cm-1)',ch10,             &
1563 &   '                  = ',omegalog_qgrid*Ha_eV/1000._dp,' (meV) ',omegalog_qgrid*Ha_THz,' (THz)',ch10,&
1564 &   '                  = ',omegalog_qgrid*Ha_K,' (K) '
1565    call wrtout(nfile,msg,'COLL')
1566  end if
1567 
1568  tc_macmill = omegalog_qgrid/1.2_dp&
1569 & *exp((-1.04_dp*(one+lambda_tot)) / (lambda_tot-elph_ds%mustar*(one+0.62_dp*lambda_tot)))
1570 
1571  if (enunit==0) then !use hartree and cm-1
1572    write (msg,'(2a,es16.8,a,es16.8,2a)')ch10,&
1573 &   ' MacMillan Tc     = ',tc_macmill,' (Ha) ',tc_macmill*Ha_cmm1,' (cm-1) ',ch10
1574    call wrtout(nfile,msg,'COLL')
1575  else if (enunit==1) then !use mev and Thz
1576    write (msg,'(2a,es16.8,a,es16.8,2a)')ch10,&
1577 &   ' MacMillan Tc     = ',tc_macmill*Ha_eV/1000._dp,' (meV) ',tc_macmill*Ha_THz,' (THz) ',ch10
1578    call wrtout(nfile,msg,'COLL')
1579  else !use hartree,cm-1,mev,Thz,kelvin
1580    write (msg,'(2a,es16.8,a,es16.8,3a,es16.8,a,es16.8,3a,es16.8,2a)')ch10,                 &
1581 &   ' MacMillan Tc     = ',tc_macmill,' (Ha)  ',tc_macmill*Ha_cmm1,' (cm-1) ',ch10,            &
1582 &   '                  = ',tc_macmill*Ha_eV/1000._dp,' (meV) ',tc_macmill*Ha_THz,' (THz) ',ch10,&
1583 &   '                  = ',tc_macmill*Ha_K,' (K) ',ch10
1584    call wrtout(nfile,msg,'COLL')
1585  end if
1586 
1587 !==========================================================
1588 !output lambda(q) values for each q point in the irred grid
1589 !==========================================================
1590 
1591  write(msg,'(2a)')' Irreducible q-points and corresponding Lambda(q)',ch10
1592  call wrtout(nfile,msg,'COLL')
1593 
1594  do isppol=1,nsppol
1595    write(msg,'(a,i3,2a)')'  === isppol ', isppol,' === ',ch10
1596    call wrtout(nfile,msg,'COLL')
1597 !
1598    do iqirr=1,nqptirred
1599      iqfull=elph_ds%qirredtofull(iqirr)
1600      write(msg,'(i5,a,3(es16.8,1x),a,es16.8,a)')&
1601 &     iqfull,') ',elph_ds%qpt_full(:,iqfull),'(',lambda_q(iqirr,isppol),'  )'
1602      call wrtout(nfile,msg,'COLL')
1603    end do
1604 !
1605  end do
1606 
1607 !use same indexing as that used for the full q-grid
1608  qmax=elph_ds%qirredtofull(qmax)
1609  qbranch_max(1)=elph_ds%qirredtofull(qbranch_max(1))
1610 
1611  write (msg,'(2a,es16.8,a,i6,3a,es16.8,a,i6,a,i4)')ch10,            &
1612 & ' Max lambda(q)      = ',lambda_q_max,      ' at qpt ',qmax,')',ch10, &
1613 & ' Max lambda(q,n)    = ',lambda_qbranch_max,' at qpt ',qbranch_max(1),&
1614 & ') and Mode number ',qbranch_max(2)
1615  call wrtout(nfile,msg,'COLL')
1616 
1617 !==========================================================
1618 !evaluation of the nesting-factor over the irreducible q grid.
1619 !==========================================================
1620 
1621 !fill irreducile q-grid
1622  ABI_ALLOCATE(qirred,(3,nqptirred))
1623  qirred(:,:)=zero
1624 
1625  do iqirr=1,nqptirred
1626    qirred(:,iqirr)=elph_ds%qpt_full(:,elph_ds%qirredtofull(iqirr))
1627  end do
1628 
1629  call mkkptrank (elph_ds%k_phon%kpt,elph_ds%k_phon%nkpt,kptrank_t)
1630 
1631  ABI_ALLOCATE(nestfactor,(nqptirred))
1632 
1633 !NOTE: weights are not normalised, the normalisation factor in reintroduced in bfactor
1634  call bfactor(elph_ds%k_phon%nkpt,elph_ds%k_phon%kpt,nqptirred,qirred,kptrank_t,&
1635 & elph_ds%k_phon%nkpt,elph_ds%k_phon%wtk,elph_ds%nFSband,nestfactor)
1636 
1637  ABI_DEALLOCATE(qirred)
1638  call destroy_kptrank (kptrank_t)
1639 
1640 
1641 !find Max and min of the nesting factor
1642 !NOTE maxloc and minloc are arrays so they cannot be used in the formatted output
1643 !anyway the size of nestfactor is not so huge!!!
1644  nest_max=maxval(nestfactor); nest_min=minval(nestfactor)
1645 
1646  qnest_max=0
1647  do iqirr=1,nqptirred
1648    if (nestfactor(iqirr)==nest_max) then
1649      qnest_max=iqirr
1650      exit
1651    end if
1652  end do
1653 
1654  qnest_min=0
1655  do iqirr=1,nqptirred
1656    if (nestfactor(iqirr)==nest_min) then
1657      qnest_min=iqirr
1658      exit
1659    end if
1660  end do
1661 
1662  write (std_out,*) maxloc(nestfactor),minloc(nestfactor)
1663  write(msg,'(a,(a,es16.8,a,i6,a),a,(a,es16.8,a,i6,a))')ch10,  &
1664 & ' Max nesting factor = ',nest_max,' at qpt ',qnest_max,') ',ch10,&
1665 & ' min nesting factor = ',nest_min,' at qpt ',qnest_min,') '
1666  call wrtout(nfile,msg,'COLL')
1667 
1668 !==========================================================
1669 !Write ph-linewidths and lambda(q,n) obtained before the
1670 !Fourier interpolation
1671 !==========================================================
1672 
1673  write (msg,'(2a)')ch10,&
1674 & ' Phonon frequencies, linewidths and e-ph coefficients for each irreducible q point '
1675  call wrtout(nfile,msg,'COLL')
1676 
1677  do isppol=1,nsppol
1678    write (msg,'(a,i3,a)') '========= quantities for isppol = ', isppol, ' ================='
1679    call wrtout(nfile,msg,'COLL')
1680    do iqirr=1,nqptirred
1681 !    same numbering as that used for irred q points
1682      iqfull=elph_ds%qirredtofull(iqirr)
1683 !    write(std_out,*) 'iqfull = ', iqfull
1684      write(msg,'(64a,i6,a,3(es16.8),3a,es16.8,a,es16.8,2a,es16.8,a,f8.3,65a)')ch10,&
1685 &     ' ',('=',jj=1,60),ch10,&
1686 &     ' qpt ',iqfull,') ',elph_ds%qpt_full(:,iqfull),ch10,ch10,&
1687 &     ' Weight    = ',elph_ds%wtq(iqfull),'    Lambda(q,isppol) = ',lambda_q(iqirr,isppol),ch10,&
1688 &     ' Nest fact = ',nestfactor(iqirr),'    (',100*nestfactor(iqirr)/nest_max,' % of max_value )',ch10,&
1689 &     ' ',('=',jj=1,60),ch10,' Mode number    Frequency       Linewidth        Lambda(q,n)'
1690      call wrtout(nfile,msg,'COLL')
1691 
1692 !    use units according to enunit
1693      if (enunit==0 .or. enunit==2) then !hartree and cm-1
1694        write(msg,'(63a)')' ',('-',jj=1,60),ch10,&
1695        '                  (Ha)             (Ha)'
1696        call wrtout(nfile,msg,'COLL')
1697        do ibranch=1,nbranch
1698 !        branch index, frequency, linewidth, lamda(q,n) (hartree units)
1699          write(msg,'(i6,5x,3(es16.8,1x))' )ibranch,(elph_ds%qgrid_data(iqirr,ibranch,isppol,jj),jj=1,3)
1700          call wrtout(nfile,msg,'COLL')
1701        end do
1702        write(msg,'(63a)')' ',('-',jj=1,60),ch10,&
1703 &       '                 (cm-1)           (cm-1)'
1704        call wrtout(nfile,msg,'COLL')
1705        do ibranch=1,nbranch
1706 !        branch index, frequency, linewidth (in cm-1)
1707          write(msg,'(i6,5x,2(es16.8,1x))' )ibranch,(Ha_cmm1*elph_ds%qgrid_data(iqirr,ibranch,isppol,jj),jj=1,2)
1708          call wrtout(nfile,msg,'COLL')
1709        end do
1710      end if !hartree and cm-1
1711 
1712      if (enunit==2 .or. enunit==1) then !write also meV Thz and Kelvin
1713        write(msg,'(63a)')' ',('-',jj=1,60),ch10,&
1714 &       '                 (meV)             (meV)'
1715        call wrtout(nfile,msg,'COLL')
1716        if (enunit == 1 ) then !write also lambda values
1717          do ibranch=1,nbranch
1718 !          branch index, frequency, linewidth, lamda(q,n) (mev units)
1719            write(msg,'(i6,5x,3(es16.8,1x))' )ibranch,((Ha_eV/1000._dp)*elph_ds%qgrid_data(iqirr,ibranch,isppol,jj),jj=1,2),&
1720 &           elph_ds%qgrid_data(iqirr,ibranch,isppol,3)
1721            call wrtout(nfile,msg,'COLL')
1722          end do
1723        else !do not write lambda values
1724          do ibranch=1,nbranch
1725 !          branch index, frequency, linewidth (in meV)
1726            write(msg,'(i6,5x,2(es16.8,1x))' )ibranch,((Ha_eV/1000._dp)*elph_ds%qgrid_data(iqirr,ibranch,isppol,jj),jj=1,2)
1727            call wrtout(nfile,msg,'COLL')
1728          end do
1729        end if
1730 
1731        write(msg,'(63a)')' ',('-',jj=1,60),ch10,&
1732 &       '                 (Thz)             (Thz)'
1733        call wrtout(nfile,msg,'COLL')
1734        do ibranch=1,nbranch
1735 !        branch index, frequency, linewidth (in Thz)
1736          write(msg,'(i6,5x,2(es16.8,1x))' )ibranch,(Ha_THz*elph_ds%qgrid_data(iqirr,ibranch,isppol,jj),jj=1,2)
1737          call wrtout(nfile,msg,'COLL')
1738        end do
1739 
1740        if (enunit == 2 ) then !kelvin
1741          write(msg,'(63a)')' ',('-',jj=1,60),ch10,&
1742 &         '                  (K)               (K)'
1743          call wrtout(nfile,msg,'COLL')
1744          do ibranch=1,nbranch
1745 !          branch index, frequency, linewidth (in Kelvin)
1746            write(msg,'(i6,5x,2(es16.8,1x))' )ibranch,(Ha_K*elph_ds%qgrid_data(iqirr,ibranch,isppol,jj),jj=1,2)
1747            call wrtout(nfile,msg,'COLL')
1748          end do
1749        end if !kelvin
1750 
1751      end if  !end write also meV Thz and Kelvin
1752 
1753      write(msg,'(62a)')' ',('=',jj=1,60),ch10
1754      call wrtout(nfile,msg,'COLL')
1755 
1756    end do !nqptirred
1757  end do !nsppol
1758 
1759  ABI_DEALLOCATE(nestfactor)
1760  ABI_DEALLOCATE(lambda_q)
1761 
1762  close (nfile)
1763 
1764 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

PARENTS

      elphon

CHILDREN

      hdr_echo,hdr_fort_read

SOURCE

1792 subroutine rchkGSheader (hdr,natom,nband,unitgkk)
1793 
1794 
1795 !This section has been created automatically by the script Abilint (TD).
1796 !Do not modify the following lines by hand.
1797 #undef ABI_FUNC
1798 #define ABI_FUNC 'rchkGSheader'
1799 !End of the abilint section
1800 
1801  implicit none
1802 
1803 !Arguments ------------------------------------
1804 !scalars
1805  integer,intent(in) :: natom,unitgkk
1806  integer,intent(out) :: nband
1807  type(hdr_type),intent(inout) :: hdr
1808 
1809 !Local variables-------------------------------
1810 !scalars
1811  integer :: fform
1812  character(len=500) :: message
1813 
1814 ! *************************************************************************
1815 !
1816 !read in general header of _GKK file
1817 !this is where we get nkpt, ngkpt(:,:)... which are also read in
1818 !rdddb9 and inprep8. Probably should do some checking to avoid
1819 !using ddb files from other configurations
1820 !
1821  rewind(unitgkk)
1822  call hdr_fort_read(hdr, unitgkk, fform)
1823  ABI_CHECK(fform/=0," GKK header mis-read. fform == 0")
1824 
1825  if (hdr%natom /= natom) then
1826    MSG_ERROR('natom in gkk file is different from anaddb input')
1827  end if
1828 
1829  if (any(hdr%nband(:) /= hdr%nband(1))) then
1830    write(message,'(3a)')&
1831 &   'Use the same number of bands for all kpts: ',ch10,&
1832 &   'could have spurious effects if efermi is too close to the last band '
1833    MSG_ERROR(message)
1834  end if
1835 
1836  call hdr_echo(hdr, fform, 4, unit=std_out)
1837 
1838  nband=hdr%nband(1)
1839 
1840 end subroutine rchkGSheader