Commit faabc5f1 authored by Gregor Michalicek's avatar Gregor Michalicek

Some more adaptions to the Wanier code by JPH

parent c07789ce
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
module m_wann_mmkb_int module m_wann_mmkb_int
contains contains
subroutine wann_mmkb_int( subroutine wann_mmkb_int(
> addnoco,addnoco2,nvd,k1d,k2d,k3d, > interchi,addnoco,addnoco2,nvd,k1d,k2d,k3d,
> n3d,k1,k2,k3, > n3d,k1,k2,k3,
> nv,neigd,nbasfcn,z,nslibd, > nv,neigd,nbasfcn,z,nslibd,
> k1_b,k2_b,k3_b, > k1_b,k2_b,k3_b,
...@@ -23,7 +23,7 @@ ...@@ -23,7 +23,7 @@
integer, intent(in) :: nbnd integer, intent(in) :: nbnd
integer, intent(in) :: k1d,k2d,k3d integer, intent(in) :: k1d,k2d,k3d
real, intent(in) :: rgphs(-k1d:k1d,-k2d:k2d,-k3d:k3d) real, intent(in) :: rgphs(-k1d:k1d,-k2d:k2d,-k3d:k3d)
complex, intent(in) :: ustep(n3d) complex, intent(in) :: ustep(n3d),interchi
integer, intent(in) :: ig(-k1d:k1d,-k2d:k2d,-k3d:k3d) integer, intent(in) :: ig(-k1d:k1d,-k2d:k2d,-k3d:k3d)
integer, intent(in) :: gb(3) integer, intent(in) :: gb(3)
#if (!defined(CPP_INVERSION)||defined(CPP_SOC)) #if (!defined(CPP_INVERSION)||defined(CPP_SOC))
...@@ -81,8 +81,8 @@ c--> determine index and phase factor ...@@ -81,8 +81,8 @@ c--> determine index and phase factor
c & stepf,nv_b,z_b, c & stepf,nv_b,z_b,
& nbasfcn,cmplx(0.0), & nbasfcn,cmplx(0.0),
& phasusbmat,nv) & phasusbmat,nv)
phasusbmat=conjg(phasusbmat) phasusbmat=conjg(phasusbmat)
call CPP_BLAS_cgemm('T','N',nslibd,nslibd_b,nv,cmplx(1.0), call CPP_BLAS_cgemm('T','N',nslibd,nslibd_b,nv,interchi,
& z(1+addnoco,1),nbasfcn,phasusbmat,nv,cmplx(1.0), & z(1+addnoco,1),nbasfcn,phasusbmat,nv,cmplx(1.0),
c & z,nbasfcn,phasusbmat,nv,cmplx(1.0), c & z,nbasfcn,phasusbmat,nv,cmplx(1.0),
& mmnk,nbnd) & mmnk,nbnd)
...@@ -96,7 +96,7 @@ c & stepf,nv_b,z_b,nbasfcn,real(0.0), ...@@ -96,7 +96,7 @@ c & stepf,nv_b,z_b,nbasfcn,real(0.0),
c & z,nbasfcn,phasusbmat,nv,real(0.0), c & z,nbasfcn,phasusbmat,nv,real(0.0),
& mmnk_tmp,nbnd) & mmnk_tmp,nbnd)
mmnk(1:nslibd,1:nslibd_b)=mmnk(1:nslibd,1:nslibd_b)+ mmnk(1:nslibd,1:nslibd_b)=mmnk(1:nslibd,1:nslibd_b)+
& mmnk_tmp(1:nslibd,1:nslibd_b) & mmnk_tmp(1:nslibd,1:nslibd_b)*interchi
#endif #endif
......
This diff is collapsed.
...@@ -25,14 +25,17 @@ c modified for use in conjunction with wann_ujugaunt, which ...@@ -25,14 +25,17 @@ c modified for use in conjunction with wann_ujugaunt, which
c calculates certain matrix elements that have to be treated only c calculates certain matrix elements that have to be treated only
c once per calculation c once per calculation
c Frank Freimuth, October 2006 c Frank Freimuth, October 2006
c***********************************************************************
c use BLAS matrix-matrix multiplication in apw-apw part to be faster
c J.-P. Hanke, Dec. 2015
c*********************************************************************** c***********************************************************************
> nbnd,llod,nslibd,nslibd_b,nlod,natd,ntypd,lmd,jmtd, > nbnd,llod,nslibd,nslibd_b,nlod,natd,ntypd,lmd,jmtd,
> taual,nop,lmax, > taual,nop,lmax,
> ntype,neq,nlo,llo,acof,bcof,ccof,bbpt, > ntype,neq,nlo,llo,acof,bcof,ccof,bbpt,
> acof_b,bcof_b,ccof_b,gb,bkpt,ujug,ujdg,djug,djdg,ujulog, > acof_b,bcof_b,ccof_b,gb,bkpt,ujug,ujdg,djug,djdg,ujulog,
> djulog,ulojug,ulojdg,ulojulog,kdiff,nntot, > djulog,ulojug,ulojdg,ulojulog,kdiff,nntot,chi,
= mmn) = mmn)
#include "cpp_double.h"
use m_juDFT use m_juDFT
use m_constants, only : pimach use m_constants, only : pimach
use m_matmul , only : matmul3,matmul3r use m_matmul , only : matmul3,matmul3r
...@@ -53,6 +56,7 @@ c .. array arguments .. ...@@ -53,6 +56,7 @@ c .. array arguments ..
integer, intent (in) :: lmax(:) !(ntypd) integer, intent (in) :: lmax(:) !(ntypd)
integer, intent (in) :: nlo(:) !(ntypd) integer, intent (in) :: nlo(:) !(ntypd)
integer, intent (in) :: llo(:,:) !(nlod,ntypd) integer, intent (in) :: llo(:,:) !(nlod,ntypd)
complex, intent (in) :: chi(ntypd)
real, intent (in) :: bbpt(:) !(3) real, intent (in) :: bbpt(:) !(3)
real, intent (in) :: taual(:,:) !(3,natd) real, intent (in) :: taual(:,:) !(3,natd)
real, intent (in) :: bkpt(:) !(3) real, intent (in) :: bkpt(:) !(3)
...@@ -75,17 +79,18 @@ c .. array arguments .. ...@@ -75,17 +79,18 @@ c .. array arguments ..
complex, intent (in) :: ulojulog(:,-llod:,:,-llod:,:,:) !(1:nlod,-llod:llod,1:nlod,-llod:llod,1:ntype,1:nntot) complex, intent (in) :: ulojulog(:,-llod:,:,-llod:,:,:) !(1:nlod,-llod:llod,1:nlod,-llod:llod,1:ntype,1:nntot)
real, intent (in) :: kdiff(:,:) !(3,nntot) real, intent (in) :: kdiff(:,:) !(3,nntot)
complex,intent(inout) :: mmn(:,:) !(nbnd,nbnd) complex,intent(inout) :: mmn(:,:)!nbnd,nbnd) !(nbnd,nbnd)
c .. local scalars .. c .. local scalars ..
integer i,lm,nn,n,na,j,lmp,l,lp,m,mp,lwn,lo,lop integer i,lm,nn,n,na,j,lmp,l,lp,m,mp,lwn,lo,lop
integer ll,llp integer ll,llp
real rph,cph,tpi,th,t1nn,t2nn,t3nn real rph,cph,tpi,th,t1nn,t2nn,t3nn,dummy
complex ic complex ic
integer nene integer nene,lmd2
complex :: fac1,fac2,fac3,fac4 complex :: fac1,fac2,fac3,fac4
complex :: fac5,fac6,fac7,fac8 complex :: fac5,fac6,fac7,fac8
complex :: mat(0:lmd,nslibd_b)
C .. C ..
C .. local arrays .. C .. local arrays ..
real bpt(3) real bpt(3)
...@@ -96,18 +101,18 @@ C .. intrinsic functions .. ...@@ -96,18 +101,18 @@ C .. intrinsic functions ..
ic = cmplx(0.,1.) ic = cmplx(0.,1.)
tpi = 2* pimach() tpi = 2* pimach()
lmd2 = lmd+1
na = 0 na = 0
bpt(:) = bbpt(:) + gb(:) - bkpt(:) bpt(:) = bbpt(:) + gb(:) - bkpt(:)
do nene=1,nntot do nene=1,nntot
if(all(abs(bpt(:)-kdiff(:,nene)).lt.1e-4)) exit if(all(abs(bpt(:)-kdiff(:,nene)).lt.1e-4)) exit
enddo enddo
IF(nene==nntot+1) CALL juDFT_error IF(nene==nntot+1) CALL juDFT_error
+ ("cannot find matching nearest neighbor k",calledby + ("cannot find matching nearest neighbor k",calledby
+ ="wann_mmkb_sph") + ="wann_mmkb_sph")
do n=1,ntype do n=1,ntype
lwn = lmax(n) lwn = lmax(n)
do nn = 1,neq(n) ! cycle by the atoms within the atom type do nn = 1,neq(n) ! cycle by the atoms within the atom type
...@@ -123,50 +128,43 @@ c...set up phase factors ( e^{ib\tau} ) ...@@ -123,50 +128,43 @@ c...set up phase factors ( e^{ib\tau} )
cph = 2*tpi*sin(th) cph = 2*tpi*sin(th)
c...contributions from the apws c...contributions from the apws
call CPP_BLAS_cgemm(
> 'T','C',lmd2,nslibd_b,lmd2,cmplx(rph,cph),
> ujug(0,0,n,nene),lmd2,acof_b(1,0,na),nslibd_b,
> cmplx(0.0),mat(0,1),lmd2)
call CPP_BLAS_cgemm(
> 'N','N',nslibd,nslibd_b,lmd2,chi(n),
> acof(1,0,na),nslibd,mat(0,1),lmd2,
> cmplx(1.0),mmn,nbnd)
call CPP_BLAS_cgemm(
> 'T','C',lmd2,nslibd_b,lmd2,cmplx(rph,cph),
> ujdg(0,0,n,nene),lmd2,bcof_b(1,0,na),nslibd_b,
> cmplx(0.0),mat(0,1),lmd2)
call CPP_BLAS_cgemm(
> 'N','N',nslibd,nslibd_b,lmd2,chi(n),
> acof(1,0,na),nslibd,mat(0,1),lmd2,
> cmplx(1.0),mmn,nbnd)
call CPP_BLAS_cgemm(
> 'T','C',lmd2,nslibd_b,lmd2,cmplx(rph,cph),
> djug(0,0,n,nene),lmd2,acof_b(1,0,na),nslibd_b,
> cmplx(0.0),mat(0,1),lmd2)
call CPP_BLAS_cgemm(
> 'N','N',nslibd,nslibd_b,lmd2,chi(n),
> bcof(1,0,na),nslibd,mat(0,1),lmd2,
> cmplx(1.0),mmn,nbnd)
call CPP_BLAS_cgemm(
> 'T','C',lmd2,nslibd_b,lmd2,cmplx(rph,cph),
> djdg(0,0,n,nene),lmd2,bcof_b(1,0,na),nslibd_b,
> cmplx(0.0),mat(0,1),lmd2)
call CPP_BLAS_cgemm(
> 'N','N',nslibd,nslibd_b,lmd2,chi(n),
> bcof(1,0,na),nslibd,mat(0,1),lmd2,
> cmplx(1.0),mmn,nbnd)
do l = 0,lwn
ll = l*(l+1)
do m = -l,l
lm = ll + m
do lp = 0,lwn
llp = lp*(lp+1)
do mp = -lp,lp
lmp = llp + mp
fac1=cmplx(rph,cph)*ujug(lmp,lm,n,nene)
fac2=cmplx(rph,cph)*ujdg(lmp,lm,n,nene)
fac3=cmplx(rph,cph)*djug(lmp,lm,n,nene)
fac4=cmplx(rph,cph)*djdg(lmp,lm,n,nene)
do j = 1,nslibd_b
fac5=conjg(acof_b(j,lmp,na))*fac1
fac6=conjg(bcof_b(j,lmp,na))*fac2
fac7=conjg(acof_b(j,lmp,na))*fac3
fac8=conjg(bcof_b(j,lmp,na))*fac4
do i = 1,nslibd
mmn(i,j) = mmn(i,j) +
+ acof(i,lm,na)*fac5+
+ acof(i,lm,na)*fac6+
+ bcof(i,lm,na)*fac7+
+ bcof(i,lm,na)*fac8
c mmn(i,j) = mmn(i,j) +
c + cmplx(rph,cph)*
c * ( acof(i,lm,na)*conjg(acof_b(j,lmp,na))*ujug(lmp,lm,n,nene)+
c + acof(i,lm,na)*conjg(bcof_b(j,lmp,na))*ujdg(lmp,lm,n,nene)+
c + bcof(i,lm,na)*conjg(acof_b(j,lmp,na))*djug(lmp,lm,n,nene)+
c + bcof(i,lm,na)*conjg(bcof_b(j,lmp,na))*djdg(lmp,lm,n,nene))
enddo
enddo
enddo ! mp
enddo ! lp
enddo ! m
enddo ! l
c...contributions from the local orbitals with apws
if (nlo(n).ge.1) then if (nlo(n).ge.1) then
...@@ -181,11 +179,15 @@ c...contributions from the local orbitals with apws ...@@ -181,11 +179,15 @@ c...contributions from the local orbitals with apws
do mp = -lp,lp do mp = -lp,lp
lmp = llp + mp lmp = llp + mp
fac1=cmplx(rph,cph)*ujulog(lmp,lo,m,n,nene) fac1=cmplx(rph,cph)*ujulog(lmp,lo,m,n,nene)*chi(n)
fac2=cmplx(rph,cph)*djulog(lmp,lo,m,n,nene) fac2=cmplx(rph,cph)*djulog(lmp,lo,m,n,nene)*chi(n)
fac3=cmplx(rph,cph)*ulojdg(lmp,lo,m,n,nene) fac3=cmplx(rph,cph)*ulojdg(lmp,lo,m,n,nene)*chi(n)
fac4=cmplx(rph,cph)*ulojug(lmp,lo,m,n,nene) fac4=cmplx(rph,cph)*ulojug(lmp,lo,m,n,nene)*chi(n)
c if(fac1.ne.0)write(*,*)'fac1',lmp,lm
c if(fac2.ne.0)write(*,*)'fac2',lmp,lm
c if(fac3.ne.0)write(*,*)'fac3',lmp,lm
c if(fac4.ne.0)write(*,*)'fac4',lmp,lm
do j = 1,nslibd_b do j = 1,nslibd_b
do i = 1,nslibd do i = 1,nslibd
...@@ -221,13 +223,16 @@ c...contributions from lo*lo ...@@ -221,13 +223,16 @@ c...contributions from lo*lo
do mp = -lp,lp do mp = -lp,lp
lmp = llp + mp lmp = llp + mp
fac1=cmplx(rph,cph)*ulojulog(lop,mp,lo,m,n,nene) fac1=cmplx(rph,cph)*ulojulog(lop,mp,lo,m,n,nene)*chi(n)
c if(fac1.ne.0)write(*,*)'fac1',lop,lo,mp,m
do j = 1,nslibd_b do j = 1,nslibd_b
do i = 1,nslibd do i = 1,nslibd
mmn(i,j) = mmn(i,j) + mmn(i,j) = mmn(i,j) +
+ ccof(m,i,lo,na)*conjg(ccof_b(mp,j,lop,na))* + ccof(m,i,lo,na)*conjg(ccof_b(mp,j,lop,na))*
* fac1 * fac1
enddo enddo
enddo enddo
......
...@@ -15,11 +15,11 @@ c Y. Mokrousov, F. Freimuth ...@@ -15,11 +15,11 @@ c Y. Mokrousov, F. Freimuth
c*************************************************************** c***************************************************************
CONTAINS CONTAINS
SUBROUTINE wann_mmkb_vac( SUBROUTINE wann_mmkb_vac(
> l_noco,nlotot,qss, > vacchi,l_noco,nlotot,qss,
> nbnd,z1,nmzd,nv2d,k1d,k2d,k3d,n3d,nvac, > nbnd,z1,nmzd,nv2d,k1d,k2d,k3d,n3d,nvac,
> ig,nmz,delz,ig2,area,bmat, > ig,nmz,delz,ig2,area,bmat,
> bbmat,evac,bkpt,bkpt_b,vz, > bbmat,evac,evac_b,bkpt,bkpt_b,vz,vz_b,
> nslibd,nslibd_b,jspin, > nslibd,nslibd_b,jspin,jspin_b,
> k1,k2,k3,k1_b,k2_b,k3_b,jspd,nvd, > k1,k2,k3,k1_b,k2_b,k3_b,jspd,nvd,
> nbasfcn,neigd,z,z_b,nv,nv_b,omtil,gb, > nbasfcn,neigd,z,z_b,nv,nv_b,omtil,gb,
< mmn) < mmn)
...@@ -29,7 +29,7 @@ c*************************************************************** ...@@ -29,7 +29,7 @@ c***************************************************************
implicit none implicit none
c .. scalar Arguments.. c .. scalar Arguments..
logical, intent (in) :: l_noco logical, intent (in) :: l_noco
integer, intent (in) :: nlotot integer, intent (in) :: nlotot,jspin_b
real, intent (in) :: qss(3) real, intent (in) :: qss(3)
integer, intent (in) :: nmzd,nv2d,k1d,k2d,k3d,n3d,nbnd integer, intent (in) :: nmzd,nv2d,k1d,k2d,k3d,n3d,nbnd
integer, intent (in) :: nmz,nslibd,nslibd_b,nvac integer, intent (in) :: nmz,nslibd,nslibd_b,nvac
...@@ -37,12 +37,14 @@ c .. scalar Arguments.. ...@@ -37,12 +37,14 @@ c .. scalar Arguments..
integer, intent (in) :: nbasfcn,neigd integer, intent (in) :: nbasfcn,neigd
integer, intent (in) :: gb(3) integer, intent (in) :: gb(3)
real, intent (in) :: delz,z1,omtil,area real, intent (in) :: delz,z1,omtil,area
complex, intent (in) :: vacchi
c ..array arguments.. c ..array arguments..
real, intent (in) :: bkpt(3),bkpt_b(3),evac(2) real, intent (in) :: bkpt(3),bkpt_b(3),evac(2),evac_b(2)
integer, intent (in) :: ig(-k1d:k1d,-k2d:k2d,-k3d:k3d) integer, intent (in) :: ig(-k1d:k1d,-k2d:k2d,-k3d:k3d)
integer, intent (in) :: ig2(n3d),nv(jspd),nv_b(jspd) integer, intent (in) :: ig2(n3d),nv(jspd),nv_b(jspd)
real, intent (in) :: vz(nmzd,2),bbmat(3,3),bmat(3,3) real, intent (in) :: vz(nmzd,2),vz_b(nmzd,2)
real, intent (in) :: bbmat(3,3),bmat(3,3)
integer, intent (in) :: k1(nvd,jspd),k2(nvd,jspd),k3(nvd,jspd) integer, intent (in) :: k1(nvd,jspd),k2(nvd,jspd),k3(nvd,jspd)
integer,intent(in)::k1_b(nvd,jspd),k2_b(nvd,jspd),k3_b(nvd,jspd) integer,intent(in)::k1_b(nvd,jspd),k2_b(nvd,jspd),k3_b(nvd,jspd)
complex, intent (inout) :: mmn(nbnd,nbnd) complex, intent (inout) :: mmn(nbnd,nbnd)
...@@ -64,7 +66,7 @@ c ..basis wavefunctions in the vacuum ...@@ -64,7 +66,7 @@ c ..basis wavefunctions in the vacuum
c ..local scalars.. c ..local scalars..
logical tail logical tail
real wronk,arg,zks,tpi,vz0(2),scale,evacp,ev,const real wronk,arg,zks,tpi,vz0(2),vz0_b(2),scale,evacp,ev,const
real uu,ud,du,dd,xx(nmz),xximag(nmz) real uu,ud,du,dd,xx(nmz),xximag(nmz)
real :: uuimag,udimag,duimag,ddimag,qss1,qss2 real :: uuimag,udimag,duimag,ddimag,qss1,qss2
integer i,m,l,j,k,n,nv2,nv2_b,ivac,n2,n2_b,sign,ik integer i,m,l,j,k,n,nv2,nv2_b,ivac,n2,n2_b,sign,ik
...@@ -103,6 +105,7 @@ c.. for the k-point ...@@ -103,6 +105,7 @@ c.. for the k-point
do ivac = 1,2 do ivac = 1,2
vz0(ivac) = vz(nmz,ivac) vz0(ivac) = vz(nmz,ivac)
vz0_b(ivac) = vz_b(nmz,ivac)
enddo enddo
n2 = 0 ; n2_b = 0 n2 = 0 ; n2_b = 0
...@@ -111,6 +114,8 @@ c.. for the k-point ...@@ -111,6 +114,8 @@ c.. for the k-point
addnoco2=0 addnoco2=0
if(l_noco.and.jspin.eq.2)then if(l_noco.and.jspin.eq.2)then
addnoco=nv(1)+nlotot addnoco=nv(1)+nlotot
endif
if(l_noco.and.jspin_b.eq.2)then
addnoco2=nv_b(1)+nlotot addnoco2=nv_b(1)+nlotot
endif endif
...@@ -123,7 +128,11 @@ c.. for the k-point ...@@ -123,7 +128,11 @@ c.. for the k-point
endif endif
30 continue 30 continue
n2 = n2 + 1 n2 = n2 + 1
IF(n2>nv2d) then
write(*,*)n2,nv2d,'jspin',jspin
endif
IF (n2>nv2d) CALL juDFT_error("wannier Mmn vac",calledby IF (n2>nv2d) CALL juDFT_error("wannier Mmn vac",calledby
+ ="wann_mmkb_vac") + ="wann_mmkb_vac")
...@@ -131,26 +140,32 @@ c.. for the k-point ...@@ -131,26 +140,32 @@ c.. for the k-point
kvac2(n2) = k2(k,jspin) kvac2(n2) = k2(k,jspin)
map2(k) = n2 map2(k) = n2
40 continue 40 continue
!write(*,*)'ok',n2,nv2d,'jspin',jspin
c.. and for the b-point c.. and for the b-point
do 41 k = 1,nv_b(jspin) do 41 k = 1,nv_b(jspin_b)
do 31 j = 1,n2_b do 31 j = 1,n2_b
if ( k1_b(k,jspin).eq.kvac1_b(j) .and. if ( k1_b(k,jspin_b).eq.kvac1_b(j) .and.
+ k2_b(k,jspin).eq.kvac2_b(j) ) then + k2_b(k,jspin_b).eq.kvac2_b(j) ) then
map2_b(k) = j map2_b(k) = j
goto 41 goto 41
endif endif
31 continue 31 continue
n2_b = n2_b + 1 n2_b = n2_b + 1
IF(n2_b>nv2d) then
write(*,*)n2_b,nv2d,'jspin_b',jspin_b
endif
IF (n2_b>nv2d) CALL juDFT_error("wannier Mmn vac",calledby IF (n2_b>nv2d) CALL juDFT_error("wannier Mmn vac",calledby
+ ="wann_mmkb_vac") + ="wann_mmkb_vac")
kvac1_b(n2_b) = k1_b(k,jspin) kvac1_b(n2_b) = k1_b(k,jspin_b)
kvac2_b(n2_b) = k2_b(k,jspin) kvac2_b(n2_b) = k2_b(k,jspin_b)
map2_b(k) = n2_b map2_b(k) = n2_b
41 continue 41 continue
!write(*,*)'ok',n2_b,nv2d,'jspin_b',jspin_b
c...cycle by the vacua c...cycle by the vacua
do 140 ivac = 1,nvac do 140 ivac = 1,nvac
...@@ -225,14 +240,15 @@ c-----> loop over basis functions ...@@ -225,14 +240,15 @@ c-----> loop over basis functions
c...now for the k+b point c...now for the k+b point
evacp = evac_b(ivac)
do ik = 1,nv2_b do ik = 1,nv2_b
v(1) = bkpt_b(1) + kvac1_b(ik) + qss1 v(1) = bkpt_b(1) + kvac1_b(ik) + qss1
v(2) = bkpt_b(2) + kvac2_b(ik) + qss2 v(2) = bkpt_b(2) + kvac2_b(ik) + qss2
v(3) = 0. v(3) = 0.
ev = evacp - 0.5*dot_product(v,matmul(bbmat,v)) ev = evacp - 0.5*dot_product(v,matmul(bbmat,v))
call vacuz(ev,vz(1,ivac),vz0(ivac),nmz,delz,t_b(ik),dt_b(ik), call vacuz(ev,vz_b(1,ivac),vz0_b(ivac),nmz,delz,t_b(ik),
+ u_b(1,ik)) + dt_b(ik),u_b(1,ik))
call vacudz(ev,vz(1,ivac),vz0(ivac),nmz,delz,te_b(ik), call vacudz(ev,vz_b(1,ivac),vz0_b(ivac),nmz,delz,te_b(ik),
+ dte_b(ik),tei_b(ik),ue_b(1,ik),dt_b(ik), + dte_b(ik),tei_b(ik),ue_b(1,ik),dt_b(ik),
+ u_b(1,ik)) + u_b(1,ik))
scale = wronk/ (te_b(ik)*dt_b(ik)-dte_b(ik)*t_b(ik)) scale = wronk/ (te_b(ik)*dt_b(ik)-dte_b(ik)*t_b(ik))
...@@ -245,9 +261,9 @@ c...now for the k+b point ...@@ -245,9 +261,9 @@ c...now for the k+b point
enddo enddo
c-----> construct a and b coefficients for the k+b point c-----> construct a and b coefficients for the k+b point
do k = 1,nv_b(jspin) do k = 1,nv_b(jspin_b)
l = map2_b(k) l = map2_b(k)
zks = k3_b(k,jspin)*bmat(3,3)*sign zks = k3_b(k,jspin_b)*bmat(3,3)*sign
arg = zks*z1 arg = zks*z1
c_1 = cmplx(cos(arg),sin(arg)) * const c_1 = cmplx(cos(arg),sin(arg)) * const
av = -c_1 * cmplx( dte_b(l),zks*te_b(l) ) av = -c_1 * cmplx( dte_b(l),zks*te_b(l) )
...@@ -307,7 +323,7 @@ c-----> loop over basis functions ...@@ -307,7 +323,7 @@ c-----> loop over basis functions
* ac(l,i)*conjg(ac_b(lprime,j))*cmplx(uu,uuimag) + * ac(l,i)*conjg(ac_b(lprime,j))*cmplx(uu,uuimag) +
+ ac(l,i)*conjg(bc_b(lprime,j))*cmplx(ud,udimag) + + ac(l,i)*conjg(bc_b(lprime,j))*cmplx(ud,udimag) +
* bc(l,i)*conjg(ac_b(lprime,j))*cmplx(du,duimag) + * bc(l,i)*conjg(ac_b(lprime,j))*cmplx(du,duimag) +
+ bc(l,i)*conjg(bc_b(lprime,j))*cmplx(dd,ddimag) ) + bc(l,i)*conjg(bc_b(lprime,j))*cmplx(dd,ddimag) )*vacchi
enddo enddo
enddo enddo
......
...@@ -19,7 +19,7 @@ c****************************************************************** ...@@ -19,7 +19,7 @@ c******************************************************************
> fullnkpts,nntot,bpt,gb,l_bzsym, > fullnkpts,nntot,bpt,gb,l_bzsym,
> irreduc,mapkoper,l_p0,film,nop, > irreduc,mapkoper,l_p0,film,nop,
> invtab,mrot,l_onedimens,tau, > invtab,mrot,l_onedimens,tau,
< pair_to_do,maptopair,kdiff) < pair_to_do,maptopair,kdiff,l_q,param_file)
implicit none implicit none
integer,intent(in) :: nop integer,intent(in) :: nop
...@@ -39,6 +39,9 @@ c****************************************************************** ...@@ -39,6 +39,9 @@ c******************************************************************
integer,intent(out):: maptopair(3,fullnkpts,nntot) integer,intent(out):: maptopair(3,fullnkpts,nntot)
real,intent(out) :: kdiff(3,nntot) real,intent(out) :: kdiff(3,nntot)
logical, intent(in) :: l_q
character(len=20), intent(in) :: param_file
integer :: ikpt,ikpt_k,kptibz,ikpt_b integer :: ikpt,ikpt_k,kptibz,ikpt_b
integer :: num_pair,kptibz_b integer :: num_pair,kptibz_b
integer :: index(fullnkpts,nntot) integer :: index(fullnkpts,nntot)
...@@ -204,7 +207,11 @@ c endif !gb=0 ...@@ -204,7 +207,11 @@ c endif !gb=0
write(6,*)"maps by conjugation: ",num_conj write(6,*)"maps by conjugation: ",num_conj
write(6,*)"maps by rotation:", num_rot write(6,*)"maps by rotation:", num_rot
write(6,*)"num_pair+num_rot+num_conj:",num_pair+num_conj+num_rot write(6,*)"num_pair+num_rot+num_conj:",num_pair+num_conj+num_rot
write(6,*)"fullnkpts*nntot:", fullnkpts*nntot if(.not.l_q) then
write(6,*)"fullnkpts*nntot:", fullnkpts*nntot
else
write(6,*)"fullnqpts*nntot:", fullnkpts*nntot
endif
endif !l_p0 endif !l_p0
c***************************************************************** c*****************************************************************
...@@ -212,11 +219,19 @@ c determine difference vectors that occur on the k-mesh ...@@ -212,11 +219,19 @@ c determine difference vectors that occur on the k-mesh
c***************************************************************** c*****************************************************************
if (l_bzsym) then if (l_bzsym) then
l_file=.false. l_file=.false.
inquire(file='w90kpts',exist=l_file) IF(.NOT.l_q)THEN
IF(.NOT.l_file) CALL juDFT_error inquire(file='w90kpts',exist=l_file)
IF(.NOT.l_file) CALL juDFT_error
+ ("w90kpts not found, needed if bzsym",calledby + ("w90kpts not found, needed if bzsym",calledby
+ ="wann_mmnk_symm") + ="wann_mmnk_symm")
open(412,file='w90kpts',form='formatted') open(412,file='w90kpts',form='formatted')
ELSE
inquire(file='w90qpts',exist=l_file)
IF(.NOT.l_file) CALL juDFT_error
+ ("w90qpts not found, needed if bzsym",calledby
+ ="wann_mmnk_symm")
open(412,file='w90qpts',form='formatted')
ENDIF
read(412,*)fullnkpts_tmp,scale read(412,*)fullnkpts_tmp,scale
do k=1,fullnkpts do k=1,fullnkpts
read(412,*)kpoints(:,k) read(412,*)kpoints(:,k)
...@@ -224,8 +239,13 @@ c***************************************************************** ...@@ -224,8 +239,13 @@ c*****************************************************************
kpoints=kpoints/scale kpoints=kpoints/scale
close(412) close(412)
else else
open(412,file='kpts',form='formatted') IF(.not.l_q)THEN
read(412,*)fullnkpts_tmp,scale open(412,file='kpts',form='formatted')
read(412,*)fullnkpts_tmp,scale
ELSE
open(412,file=param_file,form='formatted')
read(412,*)fullnkpts_tmp,scale
ENDIF
do k=1,fullnkpts do k=1,fullnkpts
read(412,*)kpoints(:,k) read(412,*)kpoints(:,k)
enddo enddo
...@@ -233,8 +253,13 @@ c***************************************************************** ...@@ -233,8 +253,13 @@ c*****************************************************************
if (film.and..not.l_onedimens) kpoints(3,:)=0.0 if (film.and..not.l_onedimens) kpoints(3,:)=0.0
close(412) close(412)
endif endif
if(l_p0)then if(l_p0)then
print*,"vectors combining nearest neighbor k-points:" IF(.not.l_q) THEN
print*,"vectors combining nearest neighbor k-points:"
ELSE
print*,"vectors combining nearest neighbor q-points:"
ENDIF
endif endif
ky=1 ky=1
do k=1,fullnkpts do k=1,fullnkpts
......
...@@ -12,7 +12,8 @@ ...@@ -12,7 +12,8 @@
> nop,mrot,bmat,amat,tau, > nop,mrot,bmat,amat,tau,
> taual,film, > taual,film,
> l_onedimens,l_soc,l_noco, > l_onedimens,l_soc,l_noco,
> omtil,pos) > omtil,pos,l_ms,l_sgwf,l_socgwf,
> aux_latt_const,param_file,l_dim)
c************************************************** c**************************************************