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 @@
module m_wann_mmkb_int
contains
subroutine wann_mmkb_int(
> addnoco,addnoco2,nvd,k1d,k2d,k3d,
> interchi,addnoco,addnoco2,nvd,k1d,k2d,k3d,
> n3d,k1,k2,k3,
> nv,neigd,nbasfcn,z,nslibd,
> k1_b,k2_b,k3_b,
......@@ -23,7 +23,7 @@
integer, intent(in) :: nbnd
integer, intent(in) :: k1d,k2d,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) :: gb(3)
#if (!defined(CPP_INVERSION)||defined(CPP_SOC))
......@@ -81,8 +81,8 @@ c--> determine index and phase factor
c & stepf,nv_b,z_b,
& nbasfcn,cmplx(0.0),
& phasusbmat,nv)
phasusbmat=conjg(phasusbmat)
call CPP_BLAS_cgemm('T','N',nslibd,nslibd_b,nv,cmplx(1.0),
phasusbmat=conjg(phasusbmat)
call CPP_BLAS_cgemm('T','N',nslibd,nslibd_b,nv,interchi,
& z(1+addnoco,1),nbasfcn,phasusbmat,nv,cmplx(1.0),
c & z,nbasfcn,phasusbmat,nv,cmplx(1.0),
& mmnk,nbnd)
......@@ -96,7 +96,7 @@ c & stepf,nv_b,z_b,nbasfcn,real(0.0),
c & z,nbasfcn,phasusbmat,nv,real(0.0),
& mmnk_tmp,nbnd)
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
......
This diff is collapsed.
......@@ -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 once per calculation
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***********************************************************************
> nbnd,llod,nslibd,nslibd_b,nlod,natd,ntypd,lmd,jmtd,
> taual,nop,lmax,
> ntype,neq,nlo,llo,acof,bcof,ccof,bbpt,
> 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)
#include "cpp_double.h"
use m_juDFT
use m_constants, only : pimach
use m_matmul , only : matmul3,matmul3r
......@@ -53,6 +56,7 @@ c .. array arguments ..
integer, intent (in) :: lmax(:) !(ntypd)
integer, intent (in) :: nlo(:) !(ntypd)
integer, intent (in) :: llo(:,:) !(nlod,ntypd)
complex, intent (in) :: chi(ntypd)
real, intent (in) :: bbpt(:) !(3)
real, intent (in) :: taual(:,:) !(3,natd)
real, intent (in) :: bkpt(:) !(3)
......@@ -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)
real, intent (in) :: kdiff(:,:) !(3,nntot)
complex,intent(inout) :: mmn(:,:) !(nbnd,nbnd)
complex,intent(inout) :: mmn(:,:)!nbnd,nbnd) !(nbnd,nbnd)
c .. local scalars ..
integer i,lm,nn,n,na,j,lmp,l,lp,m,mp,lwn,lo,lop
integer ll,llp
real rph,cph,tpi,th,t1nn,t2nn,t3nn
real rph,cph,tpi,th,t1nn,t2nn,t3nn,dummy
complex ic
integer nene
integer nene,lmd2
complex :: fac1,fac2,fac3,fac4
complex :: fac5,fac6,fac7,fac8
complex :: mat(0:lmd,nslibd_b)
C ..
C .. local arrays ..
real bpt(3)
......@@ -96,18 +101,18 @@ C .. intrinsic functions ..
ic = cmplx(0.,1.)
tpi = 2* pimach()
lmd2 = lmd+1
na = 0
bpt(:) = bbpt(:) + gb(:) - bkpt(:)
do nene=1,nntot
if(all(abs(bpt(:)-kdiff(:,nene)).lt.1e-4)) exit
enddo
enddo
IF(nene==nntot+1) CALL juDFT_error
+ ("cannot find matching nearest neighbor k",calledby
+ ="wann_mmkb_sph")
do n=1,ntype
lwn = lmax(n)
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} )
cph = 2*tpi*sin(th)
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
......@@ -181,11 +179,15 @@ c...contributions from the local orbitals with apws
do mp = -lp,lp
lmp = llp + mp
fac1=cmplx(rph,cph)*ujulog(lmp,lo,m,n,nene)
fac2=cmplx(rph,cph)*djulog(lmp,lo,m,n,nene)
fac3=cmplx(rph,cph)*ulojdg(lmp,lo,m,n,nene)
fac4=cmplx(rph,cph)*ulojug(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)*chi(n)
fac3=cmplx(rph,cph)*ulojdg(lmp,lo,m,n,nene)*chi(n)
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 i = 1,nslibd
......@@ -221,13 +223,16 @@ c...contributions from lo*lo
do mp = -lp,lp
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 i = 1,nslibd
mmn(i,j) = mmn(i,j) +
+ ccof(m,i,lo,na)*conjg(ccof_b(mp,j,lop,na))*
* fac1
* fac1
enddo
enddo
......
......@@ -15,11 +15,11 @@ c Y. Mokrousov, F. Freimuth
c***************************************************************
CONTAINS
SUBROUTINE wann_mmkb_vac(
> l_noco,nlotot,qss,
> vacchi,l_noco,nlotot,qss,
> nbnd,z1,nmzd,nv2d,k1d,k2d,k3d,n3d,nvac,
> ig,nmz,delz,ig2,area,bmat,
> bbmat,evac,bkpt,bkpt_b,vz,
> nslibd,nslibd_b,jspin,
> bbmat,evac,evac_b,bkpt,bkpt_b,vz,vz_b,
> nslibd,nslibd_b,jspin,jspin_b,
> k1,k2,k3,k1_b,k2_b,k3_b,jspd,nvd,
> nbasfcn,neigd,z,z_b,nv,nv_b,omtil,gb,
< mmn)
......@@ -29,7 +29,7 @@ c***************************************************************
implicit none
c .. scalar Arguments..
logical, intent (in) :: l_noco
integer, intent (in) :: nlotot
integer, intent (in) :: nlotot,jspin_b
real, intent (in) :: qss(3)
integer, intent (in) :: nmzd,nv2d,k1d,k2d,k3d,n3d,nbnd
integer, intent (in) :: nmz,nslibd,nslibd_b,nvac
......@@ -37,12 +37,14 @@ c .. scalar Arguments..
integer, intent (in) :: nbasfcn,neigd
integer, intent (in) :: gb(3)
real, intent (in) :: delz,z1,omtil,area
complex, intent (in) :: vacchi
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) :: 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_b(nvd,jspd),k2_b(nvd,jspd),k3_b(nvd,jspd)
complex, intent (inout) :: mmn(nbnd,nbnd)
......@@ -64,7 +66,7 @@ c ..basis wavefunctions in the vacuum
c ..local scalars..
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 :: uuimag,udimag,duimag,ddimag,qss1,qss2
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
do ivac = 1,2
vz0(ivac) = vz(nmz,ivac)
vz0_b(ivac) = vz_b(nmz,ivac)
enddo
n2 = 0 ; n2_b = 0
......@@ -111,6 +114,8 @@ c.. for the k-point
addnoco2=0
if(l_noco.and.jspin.eq.2)then
addnoco=nv(1)+nlotot
endif
if(l_noco.and.jspin_b.eq.2)then
addnoco2=nv_b(1)+nlotot
endif
......@@ -123,7 +128,11 @@ c.. for the k-point
endif
30 continue
n2 = n2 + 1
IF(n2>nv2d) then
write(*,*)n2,nv2d,'jspin',jspin
endif
IF (n2>nv2d) CALL juDFT_error("wannier Mmn vac",calledby
+ ="wann_mmkb_vac")
......@@ -131,26 +140,32 @@ c.. for the k-point
kvac2(n2) = k2(k,jspin)
map2(k) = n2
40 continue
!write(*,*)'ok',n2,nv2d,'jspin',jspin
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
if ( k1_b(k,jspin).eq.kvac1_b(j) .and.
+ k2_b(k,jspin).eq.kvac2_b(j) ) then
if ( k1_b(k,jspin_b).eq.kvac1_b(j) .and.
+ k2_b(k,jspin_b).eq.kvac2_b(j) ) then
map2_b(k) = j
goto 41
endif
31 continue
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
+ ="wann_mmkb_vac")
kvac1_b(n2_b) = k1_b(k,jspin)
kvac2_b(n2_b) = k2_b(k,jspin)
kvac1_b(n2_b) = k1_b(k,jspin_b)
kvac2_b(n2_b) = k2_b(k,jspin_b)
map2_b(k) = n2_b
41 continue
!write(*,*)'ok',n2_b,nv2d,'jspin_b',jspin_b
c...cycle by the vacua
do 140 ivac = 1,nvac
......@@ -225,14 +240,15 @@ c-----> loop over basis functions
c...now for the k+b point
evacp = evac_b(ivac)
do ik = 1,nv2_b
v(1) = bkpt_b(1) + kvac1_b(ik) + qss1
v(2) = bkpt_b(2) + kvac2_b(ik) + qss2
v(3) = 0.
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),
+ u_b(1,ik))
call vacudz(ev,vz(1,ivac),vz0(ivac),nmz,delz,te_b(ik),
call vacuz(ev,vz_b(1,ivac),vz0_b(ivac),nmz,delz,t_b(ik),
+ dt_b(ik),u_b(1,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),
+ u_b(1,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
enddo
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)
zks = k3_b(k,jspin)*bmat(3,3)*sign
zks = k3_b(k,jspin_b)*bmat(3,3)*sign
arg = zks*z1
c_1 = cmplx(cos(arg),sin(arg)) * const
av = -c_1 * cmplx( dte_b(l),zks*te_b(l) )
......@@ -307,7 +323,7 @@ c-----> loop over basis functions
* ac(l,i)*conjg(ac_b(lprime,j))*cmplx(uu,uuimag) +
+ 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(bc_b(lprime,j))*cmplx(dd,ddimag) )
+ bc(l,i)*conjg(bc_b(lprime,j))*cmplx(dd,ddimag) )*vacchi
enddo
enddo
......
......@@ -19,7 +19,7 @@ c******************************************************************
> fullnkpts,nntot,bpt,gb,l_bzsym,
> irreduc,mapkoper,l_p0,film,nop,
> invtab,mrot,l_onedimens,tau,
< pair_to_do,maptopair,kdiff)
< pair_to_do,maptopair,kdiff,l_q,param_file)
implicit none
integer,intent(in) :: nop
......@@ -39,6 +39,9 @@ c******************************************************************
integer,intent(out):: maptopair(3,fullnkpts,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 :: num_pair,kptibz_b
integer :: index(fullnkpts,nntot)
......@@ -204,7 +207,11 @@ c endif !gb=0
write(6,*)"maps by conjugation: ",num_conj
write(6,*)"maps by rotation:", 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
c*****************************************************************
......@@ -212,11 +219,19 @@ c determine difference vectors that occur on the k-mesh
c*****************************************************************
if (l_bzsym) then
l_file=.false.
inquire(file='w90kpts',exist=l_file)
IF(.NOT.l_file) CALL juDFT_error
IF(.NOT.l_q)THEN
inquire(file='w90kpts',exist=l_file)
IF(.NOT.l_file) CALL juDFT_error
+ ("w90kpts not found, needed if bzsym",calledby
+ ="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
do k=1,fullnkpts
read(412,*)kpoints(:,k)
......@@ -224,8 +239,13 @@ c*****************************************************************
kpoints=kpoints/scale
close(412)
else
open(412,file='kpts',form='formatted')
read(412,*)fullnkpts_tmp,scale
IF(.not.l_q)THEN
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
read(412,*)kpoints(:,k)
enddo
......@@ -233,8 +253,13 @@ c*****************************************************************
if (film.and..not.l_onedimens) kpoints(3,:)=0.0
close(412)
endif
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
ky=1
do k=1,fullnkpts
......
......@@ -12,7 +12,8 @@
> nop,mrot,bmat,amat,tau,
> taual,film,
> 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 Make preparations for the calculation of
c Wannier functions.
......@@ -44,13 +45,17 @@ c**************************************************
logical,intent(in) :: l_onedimens
logical,intent(in) :: l_soc
logical,intent(in) :: l_noco
real,intent(in) :: omtil
real,intent(in) :: omtil,aux_latt_const
real,intent(in) :: pos(3,natd)
character(len=20),intent(in) :: param_file
type(t_wann) :: wann
integer :: num_wann(2)
logical :: l_nocosoc
logical, intent(in) :: l_ms,l_sgwf,l_socgwf
logical,intent(in) :: l_dim(3)
l_nocosoc=l_noco.or.l_soc
c-----read the input file to determine what to do
......@@ -96,7 +101,9 @@ c-----generate WF1.win and bkpts
call wann_wan90prep(
> jspins,amat,bmat,
> natd,taual,zatom,ntype,
> ntype,neq,wann%l_bzsym,film,l_onedimens)
> ntype,neq,wann%l_bzsym,film,l_onedimens,
> l_ms,l_sgwf,l_socgwf,aux_latt_const,
> param_file,l_dim)
endif
c-----calculate polarization, if not wannierize
......
......@@ -6,7 +6,6 @@
MODULE m_wann_plot
use m_juDFT
c last update: 27.10.06 by FF
! +++++++++++++++++++++++++++++++++++++++++++++++++
! plots the periodic part of the wavefunction at the given k-point
! and specified bands. Needed for real-space
......@@ -44,7 +43,9 @@ c last update: 27.10.06 by FF
> invs,invs2,z1,delz,ngopr,ntypsy,jri,pos,zatom,
> lmax,mrot,tau,rmsh,invtab,amat,bmat,bbmat,ikpt,nnne,kk,
> nvd,nlod,llod,nv,lmd,bkpt,omtil,nlo,llo,k1,k2,k3,evac,vz,
> nslibd,nbasfcn,neigd,ff,gg,flo,acof,bcof,ccof,z)
> nslibd,nbasfcn,neigd,ff,gg,flo,acof,bcof,ccof,z,
> k1d,k2d,k3d,ig,ig2,sk2,phi2,l_noco,l_ss,qss,addnoco,
> index_kq,l_sgwf)
! *****************************************************
USE m_constants, ONLY : pimach
USE m_od_types, ONLY : od_inp, od_sym
......@@ -53,6 +54,8 @@ c last update: 27.10.06 by FF
USE m_dotir
USE m_wann_plot_vac
USE m_wann_2dvacabcof
USE m_wann_plot_od_vac
USE m_wann_1dvacabcof
IMPLICIT NONE
! ..
......@@ -62,9 +65,11 @@ c last update: 27.10.06 by FF
INTEGER, INTENT (IN) :: nq3,nvac,nmz,nmzxy,nq2,nop,nop2,ntype
INTEGER, INTENT (IN) :: nvd,nv,lmd,llod,nlod
INTEGER, INTENT (IN) :: nslibd,nbasfcn,neigd
INTEGER, INTENT (IN) :: nnne,kk
INTEGER, INTENT (IN) :: nnne,kk,addnoco,index_kq
LOGICAL, INTENT (IN) :: symor,invs,slice,invs2,film
LOGICAL, INTENT (IN) :: l_noco,l_ss,l_sgwf
REAL, INTENT (IN) :: z1,delz,volint,omtil
REAL, INTENT (IN) :: qss(3)
real, intent (in) :: vz(nmzd,2)
! ..
! .. Array Arguments ..
......@@ -80,6 +85,9 @@ c last update: 27.10.06 by FF
COMPLEX, INTENT (IN) :: ccof(-llod:llod,nslibd,nlod,natd)
COMPLEX, INTENT (IN) :: acof(nslibd,0:lmd,natd)
COMPLEX, INTENT (IN) :: bcof(nslibd,0:lmd,natd)
integer, intent (in) :: k1d,k2d,k3d,ig2(n3d)
integer, intent (in) :: ig(-k1d:k1d,-k2d:k2d,-k3d:k3d)
real, intent (in) :: sk2(n2d),phi2(n2d)
TYPE (od_inp), INTENT (IN) :: odi
TYPE (od_sym), INTENT (IN) :: ods
#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) )
......@@ -110,8 +118,10 @@ c last update: 27.10.06 by FF
CHARACTER*8 :: name(10)
c ..basis wavefunctions in the vacuum
complex, allocatable :: ac(:,:,:),bc(:,:,:)
complex, allocatable :: ac_1(:,:,:),bc_1(:,:,:)
real, allocatable :: u(:,:,:),ue(:,:,:)
real, allocatable :: u_1(:,:,:),ue_1(:,:,:)
integer ik,nv2,ivac,jvac
complex factor
real fas
......@@ -130,6 +140,12 @@ c real dotirp !module now
nbmax = nslibd
ENDIF
!write(*,*)'in wann_plot'
!write(*,*)'jspin:',jspin
!write(*,*)'addnoco:',addnoco
!write(*,*)'l_noco,l_ss: ',l_noco,l_ss
!write(*,*)'qss:',qss
INQUIRE(file ="plot_inp",exist= twodim)
IF (.NOT.twodim) THEN !no input file exists, create a template and
!exit
......@@ -143,7 +159,7 @@ c WRITE(20,*) " filename='plot1' /"
WRITE(20,*) " vec2(1)=0.0 vec2(2)=1.0 vec2(3)=0.0 "
WRITE(20,*) " vec3(1)=0.0 vec3(2)=0.0 vec3(3)=1.0 "
WRITE(20,*) " grid(1)=30 grid(2)=30 grid(3)=30 "
c WRITE(20,*) " zero(1)=0.0 zero(2)=0.0 zero(3)=0.5 "
WRITE(20,*) " zero(1)=0.0 zero(2)=0.0 zero(3)=0.0 "
WRITE(20,*) " filename ='plot2' /"
CLOSE(20)
WRITE(*,*) "No plot_inp file found. Created a template"
......@@ -153,16 +169,30 @@ c WRITE(20,*) " zero(1)=0.0 zero(2)=0.0 zero(3)=0.5 "
c make preparations for plotting in vacuum
if(film)then
if(film.and..not.odi%d1)then
allocate ( ac(nv2d,nslibd,2),bc(nv2d,nslibd,2),
+ u(nmzd,nv2d,nvac),ue(nmzd,nv2d,nvac))
call wann_2dvacabcof(
> nv2d,nslibd,nvac,nmzd,nmz,omtil,vz,nv,bkpt,z1,
> nvd,k1,k2,k3,evac,bbmat,delz,bmat,nbasfcn,neigd,z,
< ac,bc,u,ue)
< ac,bc,u,ue,addnoco,l_ss,qss,jspin)
endif
if (odi%d1)then
allocate ( ac_1(nv2d,-odi%mb:odi%mb,nslibd),
& bc_1(nv2d,-odi%mb:odi%mb,nslibd),
& u_1(nmzd,nv2d,-odi%mb:odi%mb),
& ue_1(nmzd,nv2d,-odi%mb:odi%mb) )
call wann_1dvacabcof(
> nv2d,nslibd,nmzd,nmz,omtil,vz(:,:),
> nv,bkpt,z1,odi,ods,
> nvd,k1,k2,k3,evac,
> bbmat,delz,bmat,nbasfcn,neigd,z,
> n2d,n3d,ig,nmzxy,nmzxyd,ig2,sk2,phi2,k1d,k2d,k3d,
< ac_1,bc_1,u_1,ue_1,addnoco,l_ss,qss,jspin)
endif !preparations for vacuum
!<-- Open the plot_inp file for input
OPEN (18,file='plot_inp')
......@@ -229,12 +259,27 @@ c..loop by the bands
ELSE
IF (nbn.EQ.nbmin) THEN
WRITE (vandername,201) ikpt,jspin
201 FORMAT ('UNK',i5.5,'.',i1)
IF(l_noco) WRITE(vandername,202)ikpt,jspin
IF(l_sgwf) WRITE(vandername,202)index_kq,jspin
201 FORMAT ('UNK',i5.5,'.',i1)
202 FORMAT ('RNK',i5.5,'.',i1)
OPEN(55,file=vandername)
WRITE (55,7) grid(1),grid(2),grid(3),ikpt,nslibd
IF(.NOT.l_sgwf) THEN
WRITE(55,7) grid(1),grid(2),grid(3),ikpt,nslibd
ELSE
WRITE(55,7) grid(1),grid(2),grid(3),index_kq,nslibd
ENDIF
7 FORMAT (5i4)
ENDIF
ENDIF
if(film.and..not.odi%d1)then
fas=-bkpt(3)*bmat(3,3)*z1
factor=cmplx(cos(fas),sin(fas))
else
factor=cmplx(1.0,0.0)
endif
DO iz = 0,grid(3)-1
DO iy = 0,grid(2)-1
xloop:DO ix = 0,grid(1)-1
......@@ -242,12 +287,7 @@ c..loop by the bands
$ /grid(2)
IF (.NOT.twodim) point = point+vec3*REAL(iz)/grid(3)
!Check if the point is in MT-sphere
if(film)then
fas=-bkpt(3)*bmat(3,3)*z1
factor=cmplx(cos(fas),sin(fas))
else
factor=cmplx(1.0,0.0)
endif
ii1 = 3
ii2 = 3
ii3 = 3
......@@ -274,7 +314,7 @@ c..loop by the bands
> omtil,amat,bmat,odi,ods,nlod,llod,nlo,llo,
> ff,gg,flo,acof(nbn,:,:),bcof(nbn,:,:),
> ccof(:,nbn,:,:),z(:,nbn),
> nv,k1,k2,k3,lmd,nbasfcn,
> nv,k1,k2,k3,lmd,nbasfcn,l_ss,qss,jspin,addnoco,
< xdnout)
xdnout=xdnout*factor
IF (xsf) THEN
......@@ -331,17 +371,10 @@ c < xdnout)
IF (odi%d1) THEN
IF (SQRT((pt(1))**2 + (pt(2))**2)>=z1) THEN
CALL wann_real(
> pt,0,0,1,0,bkpt,
> n3d,nmzxyd,n2d,ntypsd,lmaxd,jmtd,
> natd,ntypd,nmzd,nop,nop2,mrot,tau,invtab,
> nq3,nvac,invs,z1,delz,nmz,nmzxy,nq2,
> lmax,rmsh,jri,pos,ngopr,ntypsy,nvd,
> omtil,amat,bmat,odi,ods,nlod,llod,nlo,llo,