Commit eebc7985 authored by Daniel Wortmann's avatar Daniel Wortmann

Added new wannier routines from JPH

parent d6750fc9
This diff is collapsed.
MODULE m_d2fdz2
CONTAINS
SUBROUTINE d2fdz2(jmtd,jri,rmsh,dx,f,fac,d2f)
IMPLICIT NONE
REAL difcub
EXTERNAL difcub
REAL, INTENT(INOUT) :: d2f(jmtd)
REAL, INTENT(IN) :: fac(jmtd)
REAL, INTENT(IN) :: f(jmtd)
REAL, INTENT(IN) :: rmsh(jmtd)
REAL, INTENT(IN) :: dx
INTEGER, INTENT(IN) :: jri
INTEGER, INTENT(IN) :: jmtd
REAL, ALLOCATABLE :: fr(:),dfr(:)
INTEGER :: i
allocate( dfr(jri),fr(jri) )
DO i=1,jri
fr(i) = f(i)*fac(i)
ENDDO
dfr(1) = difcub( rmsh(1),fr(1),rmsh(1) )
DO i = 2, jri-2
dfr(i) = difcub( rmsh(i-1),fr(i-1),rmsh(i) )
ENDDO
dfr(jri-1) = difcub( rmsh(jri-3),fr(jri-3),rmsh(jri-1) )
dfr(jri) = difcub( rmsh(jri-3),fr(jri-3),rmsh(jri) )
d2f(1) = difcub( rmsh(1),dfr(1),rmsh(1) )
DO i = 2, jri-2
d2f(i) = difcub( rmsh(i-1),dfr(i-1),rmsh(i) )
ENDDO
d2f(jri-1) = difcub( rmsh(jri-3),dfr(jri-3),rmsh(jri-1) )
d2f(jri) = difcub( rmsh(jri-3),dfr(jri-3),rmsh(jri) )
deallocate( dfr,fr )
END SUBROUTINE d2fdz2
END MODULE m_d2fdz2
MODULE m_d2fdz2cmplx
CONTAINS
SUBROUTINE d2fdz2cmplx(jmtd,jri,rmsh,dx,f,fac,d2f)
IMPLICIT NONE
REAL difcub
EXTERNAL difcub
COMPLEX, INTENT(INOUT) :: d2f(jmtd)
COMPLEX, INTENT(IN) :: fac(jmtd)
REAL, INTENT(IN) :: f(jmtd)
REAL, INTENT(IN) :: rmsh(jmtd)
REAL, INTENT(IN) :: dx
INTEGER, INTENT(IN) :: jri
INTEGER, INTENT(IN) :: jmtd
REAL, ALLOCATABLE :: fr(:),fi(:),dfr(:),dfi(:)
INTEGER :: i
allocate( dfr(jri),dfi(jri),fr(jri),fi(jri) )
DO i=1,jri
fr(i) = f(i)*real(fac(i))
fi(i) = f(i)*aimag(fac(i))
ENDDO
dfr(1) = difcub( rmsh(1),fr(1),rmsh(1) )
dfi(1) = difcub( rmsh(1),fi(1),rmsh(1) )
DO i = 2, jri-2
dfr(i) = difcub( rmsh(i-1),fr(i-1),rmsh(i) )
dfi(i) = difcub( rmsh(i-1),fi(i-1),rmsh(i) )
ENDDO
dfr(jri-1) = difcub( rmsh(jri-3),fr(jri-3),rmsh(jri-1) )
dfi(jri-1) = difcub( rmsh(jri-3),fi(jri-3),rmsh(jri-1) )
dfr(jri) = difcub( rmsh(jri-3),fr(jri-3),rmsh(jri) )
dfi(jri) = difcub( rmsh(jri-3),fi(jri-3),rmsh(jri) )
d2f(1) = cmplx( difcub( rmsh(1),dfr(1),rmsh(1) ),
> difcub( rmsh(1),dfi(1),rmsh(1) ) )
DO i = 2, jri-2
d2f(i) = cmplx( difcub( rmsh(i-1),dfr(i-1),rmsh(i) ),
> difcub( rmsh(i-1),dfi(i-1),rmsh(i) ) )
ENDDO
d2f(jri-1) = cmplx( difcub( rmsh(jri-3),dfr(jri-3),rmsh(jri-1) ),
> difcub( rmsh(jri-3),dfi(jri-3),rmsh(jri-1) ) )
d2f(jri) = cmplx( difcub( rmsh(jri-3),dfr(jri-3),rmsh(jri) ),
> difcub( rmsh(jri-3),dfi(jri-3),rmsh(jri) ) )
deallocate( dfr,dfi,fr,fi )
c d2f = cmplx(0.,0.)
c d2f(1) = (f(3)-2*f(2)+f(1))/dx/dx
c do i=2,jri-1
c d2f(i) = (f(i+1)-2*f(i)+f(i-1))/dx/dx
c enddo
c d2f(jri) = (f(jri-2)-2*f(jri-1)+f(jri))/dx/dx
END SUBROUTINE d2fdz2cmplx
END MODULE m_d2fdz2cmplx
MODULE m_dujdr
CONTAINS
SUBROUTINE dujdr(jmtd,jri,rmsh,dx,ub,j2,b,l,lmaxd,dub)
USE m_constants
IMPLICIT NONE
REAL difcub
EXTERNAL difcub
REAL, INTENT(IN) :: rmsh(jmtd),dx
REAL, INTENT(IN) :: ub(jmtd,2) ! u(b2)
REAL, INTENT(IN) :: j2(0:lmaxd,jmtd) ! j_l(b2*r)
REAL, INTENT(IN) :: b ! b2
INTEGER, INTENT(IN) :: jri,jmtd,lmaxd
INTEGER, INTENT(IN) :: l ! l of sph. Bessel j2
REAL, INTENT(OUT) :: dub(jmtd,2)
REAL :: xi,t(jri,2)
INTEGER :: i,j
! derivatives d/dr for large and small component of q
DO i=1,jri
t(i,:) = ub(i,:) / rmsh(i) * j2(l,i)
ENDDO
DO j = 1, 2
! derivative at 1st point
dub(1,j) = difcub( rmsh(1),t(1,j),rmsh(1) )
! derivative at 2nd...(jri-2)th point
DO i = 2, jri-2
dub(i,j) = difcub( rmsh(i-1),t(i-1,j),rmsh(i) )
ENDDO
! derivative at last two points
dub(jri-1,j) = difcub( rmsh(jri-3),t(jri-3,j),rmsh(jri-1) )
dub(jri,j) = difcub( rmsh(jri-3),t(jri-3,j),rmsh(jri) )
ENDDO
DO i=1,jri
dub(i,:) = dub(i,:)*rmsh(i)
ENDDO
! complete d/dr (ub*j2) = ub'j2 + ub j2' with sph. Bessel func. j
! rule: j'_{l}(ar) = a*j_{l-1}(ar) - (l+1)/r*j_{l}(ar)
c IF(l.ne.0) THEN
c DO i=1,jri
c xi = rmsh(i)
c dub(i,:) = dub(i,:) * j2(l,i) * xi
c > + ub(i,:) *( j2(l-1,i)*b - (l+1)/xi*j2(l,i) )
c ENDDO
c ELSE
c DO i=1,jri
c xi = rmsh(i)
c dub(i,:) = dub(i,:) * j2(l,i) * xi
c > - ub(i,:) * j2(1,i) * b
c ENDDO
c ENDIF
END SUBROUTINE dujdr
END MODULE m_dujdr
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
c*****************************************c
c Interstitial contribution to uHu c
c < u_{k+b1} | H_{k}^{int} | u_{k+b2} > c
c*****************************************c
c k1_b, k2_b, k3_b : G-vectors at k+b1 c
c k1_b2, k2_b2, k3_b2: G-vectors at k+b2 c
c c
c gb : reciprocal latt. vector taking c
c k+b1 back to first Brillouin zone c
c gb2: reciprocal latt. vector taking c
c k+b2 back to first Brillouin zone c
c c
c z_b : eigenvectors at k+b1 c
c z_b2: eigenvectors at k+b2 c
c*****************************************c
c J.-P. Hanke, Dec. 2015 c
c*****************************************c
module m_wann_uHu_int
contains
subroutine wann_uHu_int(
> chi,nvd,k1d,k2d,k3d,
> n3d,nv_b,nv_b2,nbnd,neigd,
> nslibd_b,nslibd_b2,nbasfcn,
> addnoco,addnoco2,
> k1_b ,k2_b ,k3_b, gb,
> k1_b2,k2_b2,k3_b2,gb2,
> bkpt,bbmat,vpw,z_b,z_b2,
> rgphs,ustep,ig,l_kin,sign,uHu)
#include "cpp_double.h"
use m_dotir, ONLY : dotirp
implicit none
c ..arguments..
logical, intent(in) :: l_kin
integer, intent(in) :: gb(3),gb2(3)
integer, intent(in) :: k1d,k2d,k3d
integer, intent(in) :: nvd,n3d,nv_b,nv_b2,nbnd,neigd
integer, intent(in) :: nslibd_b,nslibd_b2,nbasfcn
integer, intent(in) :: addnoco,addnoco2,sign
integer, intent(in) :: k1_b(nvd) ,k2_b(nvd) ,k3_b(nvd)
integer, intent(in) :: k1_b2(nvd),k2_b2(nvd),k3_b2(nvd)
integer, intent(in) :: ig(-k1d:k1d,-k2d:k2d,-k3d:k3d)
real, intent(in) :: rgphs(-k1d:k1d,-k2d:k2d,-k3d:k3d)
real, intent(in) :: bkpt(3),bbmat(3,3)
complex, intent(in) :: ustep(n3d),vpw(n3d)
complex, intent(in) :: chi
#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) )
complex, intent(in) :: z_b(nbasfcn,neigd),z_b2(nbasfcn,neigd)
#else
real, intent(in) :: z_b(nbasfcn,neigd),z_b2(nbasfcn,neigd)
#endif
complex, intent(inout) :: uHu(nbnd,nbnd)
c ..local variables..
#if (!defined(CPP_INVERSION)||defined(CPP_SOC))
complex,allocatable :: vstep(:,:)
complex,allocatable :: mat(:,:)
complex :: th
#else
real,allocatable :: vstep(:,:)
real,allocatable :: mat(:,:)
real,allocatable :: uHu_tmp(:,:)
real :: th
#endif
real,allocatable :: rk_b(:),rk_b2(:)
real :: phase,phase2,ekk,s(3)
integer :: i,j,j1,j2,j3,i1,i2,i3,in,ind
allocate( vstep(nv_b2,nv_b) )
allocate( mat(nv_b,nslibd_b2) )
allocate( rk_b (nv_b) )
allocate( rk_b2(nv_b2) )
#if (!defined(CPP_INVERSION)||defined(CPP_SOC))
#else
allocate( uHu_tmp(nslibd_b,nslibd_b2) )
#endif
! set up |k+G-G(k+b1)|^2
do i=1,nv_b
s(1) = bkpt(1) + k1_b(i) - gb(1)
s(2) = bkpt(2) + k2_b(i) - gb(2)
s(3) = bkpt(3) + k3_b(i) - gb(3)
rk_b(i) = dotirp(s,s,bbmat)
enddo
! set up |k+G'-G(k+b2)|^2
do i=1,nv_b2
s(1) = bkpt(1) + k1_b2(i) - gb2(1)
s(2) = bkpt(2) + k2_b2(i) - gb2(2)
s(3) = bkpt(3) + k3_b2(i) - gb2(3)
rk_b2(i) = dotirp(s,s,bbmat)
enddo
! construct vstep(g,g') ~ V(g-g')
! + Theta(g-g')*[rk_b+rk_b2]
vstep(:,:) = 0.0
do i=1,nv_b
j1 = -k1_b(i) + gb(1) - gb2(1)
j2 = -k2_b(i) + gb(2) - gb2(2)
j3 = -k3_b(i) + gb(3) - gb2(3)
do j=1,nv_b2
i1 = j1 + k1_b2(j)
i2 = j2 + k2_b2(j)
i3 = j3 + k3_b2(j)
in = ig(sign*i1,sign*i2,sign*i3)
if(in.eq.0) cycle
phase = rgphs(i1,i2,i3) ! TODO: sign also here?
phase2= rgphs(sign*i1,sign*i2,sign*i3)
if(phase.ne.phase2) then
stop 'rgphs in wann_uHu_int'
endif
ekk = rk_b(i) + rk_b2(j)
#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) )
th = phase*conjg(vpw(in))
if(l_kin) th = th + phase*0.25*ekk*conjg(ustep(in))
#else
th = phase*real(vpw(in))
if(l_kin) th = th + phase*0.25*ekk*real(ustep(in))
#endif
vstep(j,i) = th
enddo
enddo
! complex conjugate of (z(k+b1,g))^* vstep(g,g') z(k+b2,g')
#if (!defined(CPP_INVERSION) || defined(CPP_SOC))
call CPP_BLAS_cgemm('T','N',nv_b,nslibd_b2,nv_b2,cmplx(1.0),
> vstep,nv_b2,z_b2(1+addnoco2,1),nbasfcn,
> cmplx(0.0),mat,nv_b)
mat = conjg(mat)
call CPP_BLAS_cgemm('T','N',nslibd_b,nslibd_b2,nv_b,
> chi,z_b(1+addnoco,1),nbasfcn,
> mat,nv_b,cmplx(1.0),uHu,nbnd)
#else
call CPP_BLAS_sgemm('T','N',nv_b,nslibd_b2,nv_b2,real(1.0),
> vstep,nv_b2,z_b2(1+addnoco2,1),nbasfcn,
> real(0.0),mat,nv_b)
call CPP_BLAS_sgemm('T','N',nslibd_b,nslibd_b2,nv_b,
> real(1.0),z_b(1+addnoco,1),nbasfcn,
> mat,nv_b,real(0.0),uHu_tmp,nslibd_b)
uHu(1:nslibd_b,1:nslibd_b2) = uHu(1:nslibd_b,1:nslibd_b2)
> + uHu_tmp(1:nslibd_b,1:nslibd_b2)*chi
#endif
deallocate( vstep, mat )
deallocate( rk_b, rk_b2 )
#if (!defined(CPP_INVERSION) || defined(CPP_SOC))
#else
deallocate( uHu_tmp )
#endif
end subroutine
end module m_wann_uHu_int
module m_wann_uHu_int2
contains
subroutine wann_uHu_int2(
> nvd,k1d,k2d,k3d,
> n3d,k1,k2,k3,
> nv,
> k1_b,k2_b,k3_b,
> nv_b,
> rgphs,ustep,ig,gb,uHu)
#include "cpp_double.h"
implicit none
integer, intent(in) :: nvd,n3d,k1(nvd),k2(nvd),k3(nvd)
integer, intent(in) :: nv
integer, intent(in) :: nv_b,k1_b(nvd),k2_b(nvd),k3_b(nvd)
integer, intent(in) :: k1d,k2d,k3d
real, intent(in) :: rgphs(-k1d:k1d,-k2d:k2d,-k3d:k3d)
complex, intent(in) :: ustep(n3d)
integer, intent(in) :: ig(-k1d:k1d,-k2d:k2d,-k3d:k3d)
integer, intent(in) :: gb(3)
complex, intent(inout) :: uHu(nvd,nvd)!(nv,nv_b)
#if (!defined(CPP_INVERSION)||defined(CPP_SOC))
complex :: stepf(nv_b,nv)
complex phasust
#else
real :: stepf(nv_b,nv)
real phasust
#endif
integer i,j1,j2,j3,i1,i2,i3,j,in,m,n
real phase
stepf(:,:)=0.0
do i =1,nv
do j = 1,nv_b
c--> determine index and phase factor
i1 = k1_b(j) - k1(i) - gb(1)
i2 = k2_b(j) - k2(i) - gb(2)
i3 = k3_b(j) - k3(i) - gb(3)
in = ig(i1,i2,i3)
if (in.eq.0) cycle
phase = rgphs(i1,i2,i3)
#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) )
phasust=conjg(phase*ustep(in))
#else
phasust=phase*real(ustep(in))
#endif
stepf(j,i)=phasust
enddo
enddo
uHu(1:nv,1:nv_b) = uHu(1:nv,1:nv_b) + conjg(transpose(stepf))
end subroutine
end module m_wann_uHu_int2
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
c*****************************c
c routine to define Bravais c
c in the auxiliary space c
c*****************************c
module m_wann_gwf_auxbrav
implicit none
contains
subroutine wann_gwf_auxbrav(a,l_sgwf,l_socgwf,amat,bmat,l_dim)
use m_inv3
use m_constants, only : pimach
implicit none
real, intent(in) :: a
logical, intent(in) :: l_sgwf,l_socgwf,l_dim(3)
real, intent(out) :: amat(3,3),bmat(3,3)
real :: tpi, omtil,kmesh_tol
write(*,*)'auxiliary lattice constant a=',a
tpi = 2.0*pimach()
kmesh_tol = 0.001
amat = 0.0
bmat = 0.0
amat(1,1)=1.1*a; amat(2,2)=1.1*a; amat(3,3)=1.1*a
if(l_dim(1))amat(1,1)=a
if(l_dim(2))amat(2,2)=a
if(l_dim(3))amat(3,3)=a
if(l_sgwf.or.l_socgwf) then
amat = amat/2.0
c amat(1,1)=amat(1,1)-kmesh_tol
c amat(2,2)=amat(2,2)-kmesh_tol
c amat(3,3)=amat(3,3)-kmesh_tol
endif
call inv3(amat,bmat,omtil)
bmat = tpi*bmat
!write(*,*)'aux. amat',amat
!write(*,*)'aux. bmat',bmat
end subroutine wann_gwf_auxbrav
end module m_wann_gwf_auxbrav
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment