diff --git a/wannier/CMakeLists.txt b/wannier/CMakeLists.txt index 02095db40bfc23a0e51b09121311876ba3032293..fe07892c95ee1d95e165a4139d146d8d2b7776f0 100644 --- a/wannier/CMakeLists.txt +++ b/wannier/CMakeLists.txt @@ -4,9 +4,7 @@ wannier/eulerrot.f #wannier/w90kpunktgen.f wannier/wann_1dvacabcof.F wannier/wann_2dvacabcof.F -wannier/wann_abinv.f wannier/wann_amn.f -wannier/wann_anglmom.f wannier/wann_dipole2.f wannier/wann_dipole3.f wannier/wann_dipole_electronic.f @@ -27,7 +25,6 @@ wannier/wann_gwf_commat.f wannier/wann_gwf_tools.f wannier/wann_gwf_write_mmnk.F wannier/wann_hopping.F -wannier/wannier.F wannier/wannier_to_lapw.F wannier/wann_ioncharge_gen.f wannier/wann_kpointgen.f @@ -52,7 +49,6 @@ wannier/wann_mmnk_symm.f wannier/wann_nabla_pauli_rs.f wannier/wann_nabla_rs.f wannier/wann_nocoplot.F -wannier/wann_orbcomp.f #wannier/wann_orbmag.F wannier/wann_pauli_rs.F wannier/wann_perpmag_rs.f @@ -62,7 +58,6 @@ wannier/wann_plot_symm.f wannier/wann_plot_um_dat.F wannier/wann_plot_vac.F #wannier/wann_plotw90.F -wannier/wann_postproc.F wannier/wann_postproc_setup4.F wannier/wann_postproc_setup5.F wannier/wann_postproc_setup.F @@ -99,6 +94,11 @@ set(fleur_F90 ${fleur_F90} wannier/init_wannier_defaults.f90 wannier/wann_read_inp.f90 wannier/wann_optional.f90 +wannier/wann_abinv.f90 +wannier/wann_anglmom.f90 +wannier/wannier.F90 +wannier/wann_orbcomp.f90 +wannier/wann_postproc.F90 ) if(FLEUR_USE_WANN) set(fleur_F90 ${fleur_F90} diff --git a/wannier/uhu/wann_uHu.F b/wannier/uhu/wann_uHu.F index c546e2001621de4c5dcf14c7dc2ff361888991bb..d25d567270655fea1d7db83edbcea1cc093e9efb 100644 --- a/wannier/uhu/wann_uHu.F +++ b/wannier/uhu/wann_uHu.F @@ -1100,9 +1100,7 @@ c*********************************************************** DEALLOCATE(lapw_b%k1,lapw_b%k2,lapw_b%k3) - call wann_abinv( - > ntypd,natd,noccbd_b,lmaxd,lmd,llod,nlod,ntype,neq, - > noccbd_b,lmax,nlo,llo,invsat,invsatnr,bkpt_b,taual, + call wann_abinv(atoms, X acof_b,bcof_b,ccof_b) call cpu_time(t1) t_abcof = t_abcof + t1 - t0 @@ -1222,9 +1220,7 @@ c*********************************************************** DEALLOCATE(lapw_b2%k1,lapw_b2%k2,lapw_b2%k3) - call wann_abinv( - > ntypd,natd,noccbd_b2,lmaxd,lmd,llod,nlod,ntype,neq, - > noccbd_b2,lmax,nlo,llo,invsat,invsatnr,bkpt_b2,taual, + call wann_abinv(atoms, X acof_b2,bcof_b2,ccof_b2) call cpu_time(t1) t_abcof = t_abcof + t1 - t0 diff --git a/wannier/uhu/wann_uHu_dmi.F b/wannier/uhu/wann_uHu_dmi.F index 3aa4f088f9275618d1466e7c527900b73188cc41..9a28d375ceee7e85772492e3575f5a1f5ff29e1b 100644 --- a/wannier/uhu/wann_uHu_dmi.F +++ b/wannier/uhu/wann_uHu_dmi.F @@ -1073,9 +1073,7 @@ c*********************************************************** DEALLOCATE(lapw_b%k1,lapw_b%k2,lapw_b%k3) - call wann_abinv( - > ntypd,natd,noccbd_b,lmaxd,lmd,llod,nlod,ntype,neq, - > noccbd_b,lmax,nlo,llo,invsat,invsatnr,bkpt_b,taual, + call wann_abinv(atoms, X acof_b,bcof_b,ccof_b) call cpu_time(t1) t_abcof = t_abcof + t1 - t0 @@ -1205,9 +1203,7 @@ c*********************************************************** DEALLOCATE(lapw_b2%k1,lapw_b2%k2,lapw_b2%k3) - call wann_abinv( - > ntypd,natd,noccbd_b2,lmaxd,lmd,llod,nlod,ntype,neq, - > noccbd_b2,lmax,nlo,llo,invsat,invsatnr,bkpt_b2,taual, + call wann_abinv(atoms, X acof_b2,bcof_b2,ccof_b2) call cpu_time(t1) t_abcof = t_abcof + t1 - t0 diff --git a/wannier/wann_abinv.f b/wannier/wann_abinv.f deleted file mode 100644 index 8cdf57e3694faaafdbb2d100b051e9345f89b4fc..0000000000000000000000000000000000000000 --- a/wannier/wann_abinv.f +++ /dev/null @@ -1,114 +0,0 @@ -!-------------------------------------------------------------------------------- -! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany -! This file is part of FLEUR and available as free software under the conditions -! of the MIT license as expressed in the LICENSE file in more detail. -!-------------------------------------------------------------------------------- - - module m_wann_abinv - contains - SUBROUTINE wann_abinv( - > ntypd,natd,neigd,lmaxd,lmd,llod,nlod,ntype,neq, - > neig,lmax,nlo,llo,invsat,invsatnr,bkpt,taual, - X acof,bcof,ccof) -C *************************************************************** -C Transform acof,bcof,ccof in case of atoms related by inversion -c symmetry to obtain the coefficients in the global frame. -c Based on abcrot. -c Frank Freimuth -C *************************************************************** - use m_constants, only:pimach - IMPLICIT NONE -C .. -C .. Scalar Arguments .. - INTEGER, INTENT (IN) :: ntypd,natd,neigd,lmd,llod,nlod,ntype - INTEGER, INTENT (IN) :: lmaxd,neig -C .. -C .. Array Arguments .. - INTEGER, INTENT (IN) :: neq(ntypd),lmax(ntypd),nlo(ntypd) - INTEGER, INTENT (IN) :: llo(nlod,ntypd) - INTEGER, INTENT (IN) :: invsat(natd),invsatnr(natd) - real,intent(in) :: bkpt(3) - REAL, INTENT (IN) :: taual(3,natd) - - COMPLEX, INTENT (INOUT) :: acof(neigd,0:lmd,natd) - COMPLEX, INTENT (INOUT) :: bcof(neigd,0:lmd,natd) - COMPLEX, INTENT (INOUT) :: ccof(-llod:llod,neigd,nlod,natd) - -C .. Local Scalars .. - INTEGER :: itype,ineq,iatom,iop,ilo,i,l,m,lm,lmp,ifac - integer :: n,nn,jatom,ie,ll1 - real :: tpi,arg - complex :: fac -C .. - - tpi=2.0*pimach() - - iatom=0 - DO itype=1,ntype - DO ineq=1,neq(itype) - iatom=iatom+1 - IF(invsat(iatom).ne.2) cycle - DO l=1,lmax(itype),2 - DO i=1,neig - acof(i,l**2:l*(l+2),iatom) = (-1)**l * - & acof(i,l**2:l*(l+2),iatom) - bcof(i,l**2:l*(l+2),iatom) = (-1)**l * - & bcof(i,l**2:l*(l+2),iatom) - ENDDO - ENDDO - DO ilo=1,nlo(itype) - l=llo(ilo,itype) - IF(l.gt.0) THEN - if(mod(l,2).eq.0)cycle - DO i=1,neig - ccof(-l:l,i,ilo,iatom) = (-1)**l * - & ccof(-l:l,i,ilo,iatom) - ENDDO - ENDIF - ENDDO - ENDDO - ENDDO - -c$$$ iatom = 0 -c$$$ DO n = 1,ntype -c$$$ DO nn = 1,neq(n) -c$$$ iatom = iatom + 1 -c$$$ IF (invsat(iatom).EQ.1) THEN -c$$$ jatom = invsatnr(iatom) -c$$$ arg= (taual(1,jatom)+taual(1,iatom))*bkpt(1) -c$$$ arg=arg+(taual(2,jatom)+taual(2,iatom))*bkpt(2) -c$$$ arg=arg+(taual(3,jatom)+taual(3,iatom))*bkpt(3) -c$$$ arg=arg*tpi -c$$$ fac=cmplx(cos(arg),sin(arg)) -c$$$ DO ilo = 1,nlo(n) -c$$$ l = llo(ilo,n) -c$$$ DO m = -l,l -c$$$ DO ie = 1,neig -c$$$ ccof(m,ie,ilo,jatom) = fac * -c$$$ + ccof(m,ie,ilo,jatom) -c$$$ ENDDO -c$$$ ENDDO -c$$$ ENDDO -c$$$ DO l = 0,lmax(n) -c$$$ ll1 = l* (l+1) -c$$$ DO m =-l,l -c$$$ lm = ll1 + m -c$$$ DO ie = 1,neig -c$$$ acof(ie,lm,jatom) = fac * -c$$$ * acof(ie,lm,jatom) -c$$$ ENDDO -c$$$ DO ie = 1,neig -c$$$ bcof(ie,lm,jatom) = fac * -c$$$ * bcof(ie,lm,jatom) -c$$$ ENDDO -c$$$ ENDDO -c$$$ ENDDO -c$$$ ENDIF -c$$$ ENDDO -c$$$ ENDDO - - END subroutine - end module - - - diff --git a/wannier/wann_abinv.f90 b/wannier/wann_abinv.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f01ecdc51658bd15febddd01f575f0a348ab66db --- /dev/null +++ b/wannier/wann_abinv.f90 @@ -0,0 +1,55 @@ +!-------------------------------------------------------------------------------- +! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany +! This file is part of FLEUR and available as free software under the conditions +! of the MIT license as expressed in the LICENSE file in more detail. +!-------------------------------------------------------------------------------- + +MODULE m_wann_abinv +CONTAINS + SUBROUTINE wann_abinv(atoms,acof,bcof,ccof) + ! *************************************************************** + ! Transform acof,bcof,ccof in case of atoms related by inversion + ! symmetry to obtain the coefficients in the global frame. + ! Based on abcrot. + ! Frank Freimuth + ! *************************************************************** + USE m_types + IMPLICIT NONE + ! .. + ! .. Scalar Arguments .. + TYPE(t_atoms),INTENT(IN) :: atoms + + COMPLEX, INTENT (INOUT) :: acof(:,0:,:) + COMPLEX, INTENT (INOUT) :: bcof(:,0:,:) + COMPLEX, INTENT (INOUT) :: ccof(-atoms%llod:,:,:,:)!(-llod:llod,neigd,nlod,natd) + + ! .. Local Scalars .. + INTEGER :: itype,ineq,iatom,ilo,l + + iatom=0 + DO itype=1,atoms%ntype + DO ineq=1,atoms%neq(itype) + iatom=iatom+1 + IF(atoms%invsat(iatom).NE.2) CYCLE + DO l=1,atoms%lmax(itype),2 + acof(:,l**2:l*(l+2),iatom) = (-1)**l *& + acof(:,l**2:l*(l+2),iatom) + bcof(:,l**2:l*(l+2),iatom) = (-1)**l * & + bcof(:,l**2:l*(l+2),iatom) + ENDDO + DO ilo=1,atoms%nlo(itype) + l=atoms%llo(ilo,itype) + IF(l.GT.0) THEN + IF(MOD(l,2).EQ.0)CYCLE + ccof(-l:l,:,ilo,iatom) = (-1)**l * & + ccof(-l:l,:,ilo,iatom) + ENDIF + ENDDO + ENDDO + ENDDO + + END SUBROUTINE wann_abinv +END MODULE m_wann_abinv + + + diff --git a/wannier/wann_anglmom.f b/wannier/wann_anglmom.f deleted file mode 100755 index 05da14269bffc34025276c3cb810dec8308cbaff..0000000000000000000000000000000000000000 --- a/wannier/wann_anglmom.f +++ /dev/null @@ -1,260 +0,0 @@ -!-------------------------------------------------------------------------------- -! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany -! This file is part of FLEUR and available as free software under the conditions -! of the MIT license as expressed in the LICENSE file in more detail. -!-------------------------------------------------------------------------------- - - MODULE m_wann_anglmom -c*********************************************************************** -c Compute matrix elements of angular momentum operator -c in the muffin-tin spheres. -c -c Frank Freimuth -c*********************************************************************** - CONTAINS - SUBROUTINE wann_anglmom( - > llod,noccbd,nlod,natd,ntypd,lmax,lmd, - > ntype,neq,nlo,llo,acof,bcof,ccof, - > ddn,uulon,dulon,uloulopn, - = mmn) - implicit none -c .. scalar arguments .. - integer, intent (in) :: llod,nlod,natd,ntypd,lmd - integer, intent (in) :: ntype,noccbd -c .. array arguments .. - integer, intent (in) :: neq(:)!neq(ntypd) - integer, intent (in) :: nlo(:)!nlo(ntypd) - integer, intent (in) :: lmax(:)!lmax(ntypd) - integer, intent (in) :: llo(:,:)!llo(nlod,ntypd) - real, intent (in) :: ddn(0:,:)!ddn(0:lmaxd,ntypd) - real, intent (in) :: uloulopn(:,:,:)!uloulopn(nlod,nlod,ntypd) - real, intent (in) :: uulon(:,:)!uulon(nlod,ntypd) - real, intent (in) :: dulon(:,:)!dulon(nlod,ntypd) - complex, intent (in) :: ccof(-llod:,:,:,:) !ccof(-llod:llod,noccbd,nlod,natd) - complex, intent (in) :: acof(:,0:,:)!acof(noccbd,0:lmd,natd) - complex, intent (in) :: bcof(:,0:,:)!bcof(noccbd,0:lmd,natd) - complex, intent (inout) :: mmn(:,:,:)!mmn(3,noccbd,noccbd) -c .. local scalars .. - logical :: l_select - integer :: i,j,l,lo,lop,m,natom,nn,ntyp - integer :: nt1,nt2,lm,n,ll1,indat - complex :: suma_z,sumb_z - complex :: suma_p,sumb_p - complex :: suma_m,sumb_m - complex :: suma_x,sumb_x - complex :: suma_y,sumb_y - real :: lplus,lminus -C .. -C .. local arrays .. - complex, allocatable :: qlo_z(:,:,:,:,:) - complex, allocatable :: qlo_p(:,:,:,:,:) - complex, allocatable :: qlo_m(:,:,:,:,:) - - complex, allocatable :: qaclo_z(:,:,:,:),qbclo_z(:,:,:,:) - complex, allocatable :: qaclo_p(:,:,:,:),qbclo_p(:,:,:,:) - complex, allocatable :: qaclo_m(:,:,:,:),qbclo_m(:,:,:,:) -C .. -C .. intrinsic functions .. - intrinsic conjg - allocate (qlo_z(noccbd,noccbd,nlod,nlod,ntypd), - + qaclo_z(noccbd,noccbd,nlod,ntypd), - + qbclo_z(noccbd,noccbd,nlod,ntypd) ) - - allocate (qlo_p(noccbd,noccbd,nlod,nlod,ntypd), - + qaclo_p(noccbd,noccbd,nlod,ntypd), - + qbclo_p(noccbd,noccbd,nlod,ntypd) ) - - allocate (qlo_m(noccbd,noccbd,nlod,nlod,ntypd), - + qaclo_m(noccbd,noccbd,nlod,ntypd), - + qbclo_m(noccbd,noccbd,nlod,ntypd) ) - - inquire(file='select_anglmom',exist=l_select) - write(*,*)'select_anglmom: ',l_select - if(l_select) then - open(866,file='select_anglmom') - read(866,*)indat - close(866) - write(*,*)'anglmom for atom=',indat - write(*,*)ntype - write(*,*)neq(indat) - endif - -c-----> lapw-lapw-Terms - do i = 1,noccbd - do j = 1,noccbd - nt1 = 1 - do n = 1,ntype - nt2 = nt1 + neq(n) - 1 - do l = 0,lmax(n) - suma_z = cmplx(0.,0.); sumb_z = cmplx(0.,0.) - suma_m = cmplx(0.,0.); sumb_m = cmplx(0.,0.) - suma_p = cmplx(0.,0.); sumb_p = cmplx(0.,0.) - if(l_select .and. (n.ne.indat)) cycle - ll1 = l* (l+1) - do m = -l,l - lm = ll1 + m - lplus=sqrt(real( (l-m)*(l+m+1) ) ) - lminus=sqrt(real( (l+m)*(l-m+1) ) ) - do natom = nt1,nt2 - suma_z = suma_z + acof(i,lm,natom)* - + conjg(acof(j,lm,natom))*real(m) - sumb_z = sumb_z + bcof(i,lm,natom)* - + conjg(bcof(j,lm,natom))*real(m) - if(m+1.le.l)then - suma_p = suma_p + acof(i,lm,natom)* - + conjg(acof(j,lm+1,natom))*lplus - sumb_p = sumb_p + bcof(i,lm,natom)* - + conjg(bcof(j,lm+1,natom))*lplus - endif - if(m-1.ge.-l)then - suma_m = suma_m + acof(i,lm,natom)* - + conjg(acof(j,lm-1,natom))*lminus - sumb_m = sumb_m + bcof(i,lm,natom)* - + conjg(bcof(j,lm-1,natom))*lminus - endif - enddo - enddo - mmn(3,j,i) = mmn(3,j,i) + (suma_z+sumb_z*ddn(l,n)) - - suma_x=0.5*(suma_p+suma_m) - sumb_x=0.5*(sumb_p+sumb_m) - mmn(1,j,i) = mmn(1,j,i) + (suma_x+sumb_x*ddn(l,n)) - - suma_y=cmplx(0.0,-0.5)*(suma_p-suma_m) - sumb_y=cmplx(0.0,-0.5)*(sumb_p-sumb_m) - mmn(2,j,i) = mmn(2,j,i) + (suma_y+sumb_y*ddn(l,n)) - enddo ! l - nt1 = nt1 + neq(n) - enddo ! n - enddo ! j - enddo ! i - - -c---> Terms involving local orbitals. - qlo_z = 0.0; qlo_p = 0.0; qlo_m = 0.0 - qaclo_z = 0.0; qaclo_p = 0.0; qaclo_m = 0.0 - qbclo_z = 0.0; qbclo_p = 0.0; qbclo_m = 0.0 - - natom = 0 - do ntyp = 1,ntype - do nn = 1,neq(ntyp) - natom = natom + 1 - if(l_select .and. (ntyp.ne.indat)) cycle - do lo = 1,nlo(ntyp) - l = llo(lo,ntyp) - ll1 = l* (l+1) - do m = -l,l - lm = ll1 + m - lplus=sqrt(real( (l-m)*(l+m+1) ) ) - lminus=sqrt(real( (l+m)*(l-m+1) ) ) - do i = 1,noccbd - do j = 1,noccbd - qbclo_z(j,i,lo,ntyp) = qbclo_z(j,i,lo,ntyp) + ( - + bcof(i,lm,natom) * conjg(ccof(m,j,lo,natom)) + - + ccof(m,i,lo,natom)*conjg(bcof(j,lm,natom)) )*real(m) - - qaclo_z(j,i,lo,ntyp) = qaclo_z(j,i,lo,ntyp) + ( - + acof(i,lm,natom) * conjg(ccof(m,j,lo,natom)) + - + ccof(m,i,lo,natom)*conjg(acof(j,lm,natom)) )*real(m) - if(m+1.le.l)then - qbclo_p(j,i,lo,ntyp) = qbclo_p(j,i,lo,ntyp) + ( - + bcof(i,lm,natom) * conjg(ccof(m+1,j,lo,natom)) + - + ccof(m,i,lo,natom)*conjg(bcof(j,lm+1,natom)) )*lplus - - qaclo_p(j,i,lo,ntyp) = qaclo_p(j,i,lo,ntyp) + ( - + acof(i,lm,natom) * conjg(ccof(m+1,j,lo,natom)) + - + ccof(m,i,lo,natom)*conjg(acof(j,lm+1,natom)) )*lplus - endif - if(m-1.ge.-l)then - qbclo_m(j,i,lo,ntyp) = qbclo_m(j,i,lo,ntyp) + ( - + bcof(i,lm,natom) * conjg(ccof(m-1,j,lo,natom)) + - + ccof(m,i,lo,natom)*conjg(bcof(j,lm-1,natom)) )*lminus - - qaclo_m(j,i,lo,ntyp) = qaclo_m(j,i,lo,ntyp) + ( - + acof(i,lm,natom) * conjg(ccof(m-1,j,lo,natom)) + - + ccof(m,i,lo,natom)*conjg(acof(j,lm-1,natom)) )*lminus - endif - - enddo !j - enddo !i - enddo !m - do lop = 1,nlo(ntyp) - if (llo(lop,ntyp).eq.l) then - do m = -l,l - lplus=sqrt(real( (l-m)*(l+m+1) ) ) - lminus=sqrt(real( (l+m)*(l-m+1) ) ) - do i = 1,noccbd - do j = 1,noccbd - qlo_z(j,i,lop,lo,ntyp) = qlo_z(j,i,lop,lo,ntyp) + - + conjg(ccof(m,j,lop,natom)) - * *ccof(m,i,lo,natom)*real(m) - if(m+1.le.l)then - qlo_p(j,i,lop,lo,ntyp) = - + qlo_p(j,i,lop,lo,ntyp) + - + conjg(ccof(m+1,j,lop,natom)) - * *ccof(m,i,lo,natom)*lplus - - endif - if(m-1.ge.-l)then - qlo_m(j,i,lop,lo,ntyp) = - + qlo_m(j,i,lop,lo,ntyp) + - + conjg(ccof(m-1,j,lop,natom)) - * *ccof(m,i,lo,natom)*lminus - endif - enddo ! j - enddo ! i - enddo ! m - endif - enddo ! lop - enddo ! lo - enddo ! nn - enddo ! ntyp -c---> perform summation of the coefficients with the integrals -c---> of the radial basis functions - do ntyp = 1,ntype - if(l_select .and. (ntyp.ne.indat) ) cycle - do lo = 1,nlo(ntyp) - l = llo(lo,ntyp) - do j = 1,noccbd - do i = 1,noccbd - mmn(3,i,j)= mmn(3,i,j) + - + qaclo_z(i,j,lo,ntyp)*uulon(lo,ntyp) + - + qbclo_z(i,j,lo,ntyp)*dulon(lo,ntyp) - - suma_p=qaclo_p(i,j,lo,ntyp)*uulon(lo,ntyp) + - + qbclo_p(i,j,lo,ntyp)*dulon(lo,ntyp) - - suma_m=qaclo_m(i,j,lo,ntyp)*uulon(lo,ntyp) + - + qbclo_m(i,j,lo,ntyp)*dulon(lo,ntyp) - - suma_x= 0.5*(suma_p+suma_m) - suma_y=cmplx(0.0,-0.5)*(suma_p-suma_m) - - mmn(1,i,j)= mmn(1,i,j) + suma_x - mmn(2,i,j)= mmn(2,i,j) + suma_y - - enddo !i - enddo !j - do lop = 1,nlo(ntyp) - if (llo(lop,ntyp).eq.l) then - do j = 1,noccbd - do i = 1,noccbd - mmn(3,i,j) = mmn(3,i,j) + - + qlo_z(i,j,lop,lo,ntyp)*uloulopn(lop,lo,ntyp) - suma_p=qlo_p(i,j,lop,lo,ntyp)*uloulopn(lop,lo,ntyp) - suma_m=qlo_m(i,j,lop,lo,ntyp)*uloulopn(lop,lo,ntyp) - mmn(1,i,j) = mmn(1,i,j) + 0.5*(suma_p+suma_m) - mmn(2,i,j) = mmn(2,i,j) + - + cmplx(0.0,-0.5)*(suma_p-suma_m) - enddo ! i - enddo ! j - endif - enddo !lop - enddo !lo - enddo !ntyp - deallocate ( qlo_z,qaclo_z,qbclo_z ) - deallocate ( qlo_m,qaclo_m,qbclo_m ) - deallocate ( qlo_p,qaclo_p,qbclo_p ) - - END SUBROUTINE wann_anglmom - END MODULE m_wann_anglmom diff --git a/wannier/wann_anglmom.f90 b/wannier/wann_anglmom.f90 new file mode 100644 index 0000000000000000000000000000000000000000..eabd5d9628ffe68964d715d36e588e54d409b2e3 --- /dev/null +++ b/wannier/wann_anglmom.f90 @@ -0,0 +1,251 @@ +!-------------------------------------------------------------------------------- +! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany +! This file is part of FLEUR and available as free software under the conditions +! of the MIT license as expressed in the LICENSE file in more detail. +!-------------------------------------------------------------------------------- + +MODULE m_wann_anglmom + !*********************************************************************** + ! Compute matrix elements of angular momentum operator + ! in the muffin-tin spheres. + ! + ! Frank Freimuth + !*********************************************************************** +CONTAINS + SUBROUTINE wann_anglmom(atoms,usdus,jspin,acof,bcof,ccof, mmn) + USE m_types + IMPLICIT NONE + ! .. scalar arguments .. + TYPE(t_atoms),INTENT(in)::atoms + TYPE(t_usdus),INTENT(in)::usdus + INTEGER,INTENT(IN) ::jspin + ! .. array arguments .. + COMPLEX, INTENT (in) :: ccof(-atoms%llod:,:,:,:) !ccof(-llod:llod,noccbd,atoms%nlod,natd) + COMPLEX, INTENT (in) :: acof(:,0:,:)!acof(noccbd,0:lmd,natd) + COMPLEX, INTENT (in) :: bcof(:,0:,:)!bcof(noccbd,0:lmd,natd) + COMPLEX, INTENT (inout) :: mmn(:,:,:)!mmn(3,noccbd,noccbd) + ! .. local scalars .. + LOGICAL :: l_select + INTEGER :: i,j,l,lo,lop,m,natom,nn,ntyp + INTEGER :: nt1,nt2,lm,n,ll1,indat + COMPLEX :: suma_z,sumb_z + COMPLEX :: suma_p,sumb_p + COMPLEX :: suma_m,sumb_m + COMPLEX :: suma_x,sumb_x + COMPLEX :: suma_y,sumb_y + REAL :: lplus,lminus + ! .. + ! .. local arrays .. + COMPLEX, ALLOCATABLE :: qlo_z(:,:,:,:,:) + COMPLEX, ALLOCATABLE :: qlo_p(:,:,:,:,:) + COMPLEX, ALLOCATABLE :: qlo_m(:,:,:,:,:) + + COMPLEX, ALLOCATABLE :: qaclo_z(:,:,:,:),qbclo_z(:,:,:,:) + COMPLEX, ALLOCATABLE :: qaclo_p(:,:,:,:),qbclo_p(:,:,:,:) + COMPLEX, ALLOCATABLE :: qaclo_m(:,:,:,:),qbclo_m(:,:,:,:) + ! .. + ! .. intrinsic functions .. + INTRINSIC conjg + + ALLOCATE (qlo_z(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%nlod,atoms%ntype) & + ,qaclo_z(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype),& + qbclo_z(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype) ) + + ALLOCATE (qlo_p(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%nlod,atoms%ntype) & + ,qaclo_p(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype),& + qbclo_p(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype) ) + + ALLOCATE (qlo_m(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%nlod,atoms%ntype)& + ,qaclo_m(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype),& + qbclo_m(SIZE(acof,1),SIZE(acof,1),atoms%nlod,atoms%ntype) ) + + INQUIRE(file='select_anglmom',exist=l_select) + WRITE(*,*)'select_anglmom: ',l_select + IF(l_select) THEN + OPEN(866,file='select_anglmom') + READ(866,*)indat + CLOSE(866) + WRITE(*,*)'anglmom for atom=',indat + WRITE(*,*)atoms%ntype + WRITE(*,*)atoms%neq(indat) + ENDIF + + !-----> lapw-lapw-Terms + DO i = 1,SIZE(acof,1) + DO j = 1,SIZE(acof,1) + nt1 = 1 + DO n = 1,atoms%ntype + nt2 = nt1 + atoms%neq(n) - 1 + DO l = 0,atoms%lmax(n) + suma_z = CMPLX(0.,0.); sumb_z = CMPLX(0.,0.) + suma_m = CMPLX(0.,0.); sumb_m = CMPLX(0.,0.) + suma_p = CMPLX(0.,0.); sumb_p = CMPLX(0.,0.) + IF(l_select .AND. (n.NE.indat)) CYCLE + ll1 = l* (l+1) + DO m = -l,l + lm = ll1 + m + lplus=SQRT(REAL( (l-m)*(l+m+1) ) ) + lminus=SQRT(REAL( (l+m)*(l-m+1) ) ) + DO natom = nt1,nt2 + suma_z = suma_z + acof(i,lm,natom)*& + CONJG(acof(j,lm,natom))*REAL(m) + sumb_z = sumb_z + bcof(i,lm,natom)*& + CONJG(bcof(j,lm,natom))*REAL(m) + IF(m+1.LE.l)THEN + suma_p = suma_p + acof(i,lm,natom)*& + CONJG(acof(j,lm+1,natom))*lplus + sumb_p = sumb_p + bcof(i,lm,natom)*& + CONJG(bcof(j,lm+1,natom))*lplus + ENDIF + IF(m-1.GE.-l)THEN + suma_m = suma_m + acof(i,lm,natom)*& + CONJG(acof(j,lm-1,natom))*lminus + sumb_m = sumb_m + bcof(i,lm,natom)*& + CONJG(bcof(j,lm-1,natom))*lminus + ENDIF + ENDDO + ENDDO + mmn(3,j,i) = mmn(3,j,i) + (suma_z+sumb_z*usdus%ddn(l,n,jspin)) + + suma_x=0.5*(suma_p+suma_m) + sumb_x=0.5*(sumb_p+sumb_m) + mmn(1,j,i) = mmn(1,j,i) + (suma_x+sumb_x*usdus%ddn(l,n,jspin)) + + suma_y=CMPLX(0.0,-0.5)*(suma_p-suma_m) + sumb_y=CMPLX(0.0,-0.5)*(sumb_p-sumb_m) + mmn(2,j,i) = mmn(2,j,i) + (suma_y+sumb_y*usdus%ddn(l,n,jspin)) + ENDDO ! l + nt1 = nt1 + atoms%neq(n) + ENDDO ! n + ENDDO ! j + ENDDO ! i + + + !---> Terms involving local orbitals. + qlo_z = 0.0; qlo_p = 0.0; qlo_m = 0.0 + qaclo_z = 0.0; qaclo_p = 0.0; qaclo_m = 0.0 + qbclo_z = 0.0; qbclo_p = 0.0; qbclo_m = 0.0 + + natom = 0 + DO ntyp = 1,atoms%ntype + DO nn = 1,atoms%neq(ntyp) + natom = natom + 1 + IF(l_select .AND. (ntyp.NE.indat)) CYCLE + DO lo = 1,atoms%nlo(ntyp) + l = atoms%llo(lo,ntyp) + ll1 = l* (l+1) + DO m = -l,l + lm = ll1 + m + lplus=SQRT(REAL( (l-m)*(l+m+1) ) ) + lminus=SQRT(REAL( (l+m)*(l-m+1) ) ) + DO i = 1,SIZE(acof,1) + DO j = 1,SIZE(acof,1) + qbclo_z(j,i,lo,ntyp) = qbclo_z(j,i,lo,ntyp) + (& + bcof(i,lm,natom) * CONJG(ccof(m,j,lo,natom)) +& + ccof(m,i,lo,natom)*CONJG(bcof(j,lm,natom)) )*REAL(m) + + qaclo_z(j,i,lo,ntyp) = qaclo_z(j,i,lo,ntyp) + (& + acof(i,lm,natom) * CONJG(ccof(m,j,lo,natom)) +& + ccof(m,i,lo,natom)*CONJG(acof(j,lm,natom)) )*REAL(m) + IF(m+1.LE.l)THEN + qbclo_p(j,i,lo,ntyp) = qbclo_p(j,i,lo,ntyp) + (& + bcof(i,lm,natom) * CONJG(ccof(m+1,j,lo,natom)) +& + ccof(m,i,lo,natom)*CONJG(bcof(j,lm+1,natom)) )*lplus + + qaclo_p(j,i,lo,ntyp) = qaclo_p(j,i,lo,ntyp) + (& + acof(i,lm,natom) * CONJG(ccof(m+1,j,lo,natom)) +& + ccof(m,i,lo,natom)*CONJG(acof(j,lm+1,natom)) )*lplus + ENDIF + IF(m-1.GE.-l)THEN + qbclo_m(j,i,lo,ntyp) = qbclo_m(j,i,lo,ntyp) + (& + bcof(i,lm,natom) * CONJG(ccof(m-1,j,lo,natom)) +& + ccof(m,i,lo,natom)*CONJG(bcof(j,lm-1,natom)) )*lminus + + qaclo_m(j,i,lo,ntyp) = qaclo_m(j,i,lo,ntyp) + (& + acof(i,lm,natom) * CONJG(ccof(m-1,j,lo,natom)) +& + ccof(m,i,lo,natom)*CONJG(acof(j,lm-1,natom)) )*lminus + ENDIF + + ENDDO !j + ENDDO !i + ENDDO !m + DO lop = 1,atoms%nlo(ntyp) + IF (atoms%llo(lop,ntyp).EQ.l) THEN + DO m = -l,l + lplus=SQRT(REAL( (l-m)*(l+m+1) ) ) + lminus=SQRT(REAL( (l+m)*(l-m+1) ) ) + DO i = 1,SIZE(acof,1) + DO j = 1,SIZE(acof,1) + qlo_z(j,i,lop,lo,ntyp) = qlo_z(j,i,lop,lo,ntyp) + & + CONJG(ccof(m,j,lop,natom))& + *ccof(m,i,lo,natom)*REAL(m) + IF(m+1.LE.l)THEN + qlo_p(j,i,lop,lo,ntyp) = & + qlo_p(j,i,lop,lo,ntyp) + & + CONJG(ccof(m+1,j,lop,natom))& + *ccof(m,i,lo,natom)*lplus + + ENDIF + IF(m-1.GE.-l)THEN + qlo_m(j,i,lop,lo,ntyp) = & + qlo_m(j,i,lop,lo,ntyp) + & + CONJG(ccof(m-1,j,lop,natom))& + *ccof(m,i,lo,natom)*lminus + ENDIF + ENDDO ! j + ENDDO ! i + ENDDO ! m + ENDIF + ENDDO ! lop + ENDDO ! lo + ENDDO ! nn + ENDDO ! ntyp + !---> perform summation of the coefficients with the integrals + !---> of the radial basis functions + DO ntyp = 1,atoms%ntype + IF(l_select .AND. (ntyp.NE.indat) ) CYCLE + DO lo = 1,atoms%nlo(ntyp) + l = atoms%llo(lo,ntyp) + DO j = 1,SIZE(acof,1) + DO i = 1,SIZE(acof,1) + mmn(3,i,j)= mmn(3,i,j) + & + qaclo_z(i,j,lo,ntyp)*usdus%uulon(lo,ntyp,jspin) +& + qbclo_z(i,j,lo,ntyp)*usdus%dulon(lo,ntyp,jspin) + + suma_p=qaclo_p(i,j,lo,ntyp)*usdus%uulon(lo,ntyp,jspin) +& + qbclo_p(i,j,lo,ntyp)*usdus%dulon(lo,ntyp,jspin) + + suma_m=qaclo_m(i,j,lo,ntyp)*usdus%uulon(lo,ntyp,jspin) +& + qbclo_m(i,j,lo,ntyp)*usdus%dulon(lo,ntyp,jspin) + + suma_x= 0.5*(suma_p+suma_m) + suma_y=CMPLX(0.0,-0.5)*(suma_p-suma_m) + + mmn(1,i,j)= mmn(1,i,j) + suma_x + mmn(2,i,j)= mmn(2,i,j) + suma_y + + ENDDO !i + ENDDO !j + DO lop = 1,atoms%nlo(ntyp) + IF (atoms%llo(lop,ntyp).EQ.l) THEN + DO j = 1,SIZE(acof,1) + DO i = 1,SIZE(acof,1) + mmn(3,i,j) = mmn(3,i,j) + & + qlo_z(i,j,lop,lo,ntyp)*usdus%uloulopn(lop,lo,ntyp,jspin) + suma_p=qlo_p(i,j,lop,lo,ntyp)*usdus%uloulopn(lop,lo,ntyp,jspin) + suma_m=qlo_m(i,j,lop,lo,ntyp)*usdus%uloulopn(lop,lo,ntyp,jspin) + mmn(1,i,j) = mmn(1,i,j) + 0.5*(suma_p+suma_m) + mmn(2,i,j) = mmn(2,i,j) + & + CMPLX(0.0,-0.5)*(suma_p-suma_m) + ENDDO ! i + ENDDO ! j + ENDIF + ENDDO !lop + ENDDO !lo + ENDDO !ntyp + DEALLOCATE ( qlo_z,qaclo_z,qbclo_z ) + DEALLOCATE ( qlo_m,qaclo_m,qbclo_m ) + DEALLOCATE ( qlo_p,qaclo_p,qbclo_p ) + + END SUBROUTINE wann_anglmom +END MODULE m_wann_anglmom diff --git a/wannier/wann_orbcomp.f b/wannier/wann_orbcomp.f deleted file mode 100755 index b0108b23ad6832e33d6a3bb842defca17a7dc996..0000000000000000000000000000000000000000 --- a/wannier/wann_orbcomp.f +++ /dev/null @@ -1,431 +0,0 @@ -!-------------------------------------------------------------------------------- -! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany -! This file is part of FLEUR and available as free software under the conditions -! of the MIT license as expressed in the LICENSE file in more detail. -!-------------------------------------------------------------------------------- - - MODULE m_wann_orbcomp -c************************************************************************* -c Compute matrix elements of the first 16 angular momentum projectors -c within the MT-spheres. This is done separately for each atom type. -c -c These are: -c 1: |s> llod,noccbd,nlod,natd,ntypd,lmaxd,lmd, - > ntype,neq,nlo,llo,acof,bcof,ccof, - > ddn,uulon,dulon,uloulopn, - > num_orbs, - > orbs, - > l_oc_f, - = mmn) - implicit none -c .. scalar arguments .. - integer, intent (in) :: llod,nlod,natd,ntypd,lmaxd,lmd - integer, intent (in) :: ntype,noccbd -c .. array arguments .. - integer, intent (in) :: neq(:)!neq(ntypd) - integer, intent (in) :: nlo(:)!nlo(ntypd) - integer, intent (in) :: llo(:,:)!llo(nlod,ntypd) - real, intent (in) :: ddn(0:,:)!ddn(0:lmaxd,ntypd) - real, intent (in) :: uloulopn(:,:,:)!uloulopn(nlod,nlod,ntypd) - real, intent (in) :: uulon(:,:)!uulon(nlod,ntypd) - real, intent (in) :: dulon(:,:)!dulon(nlod,ntypd) - complex, intent (in) :: ccof(-llod:,:,:,:) !ccof(-llod:llod,noccbd,nlod,natd) - complex, intent (in) :: acof(:,0:,:)!acof(noccbd,0:lmd,natd) - complex, intent (in) :: bcof(:,0:,:)!bcof(noccbd,0:lmd,natd) - complex, intent (inout) :: mmn(:,:,:,:)!mmn(16,noccbd,noccbd,ntype) - - integer, intent (in) :: num_orbs - integer, intent (in) :: orbs(:) - logical, intent (in) :: l_oc_f - -c ..Local Scalars - - COMPLEX ca00(noccbd) - complex ca01(noccbd) - complex ca02(noccbd) - complex ca03(noccbd) - complex ca04(noccbd) - complex ca05(noccbd) - complex ca06(noccbd) - complex ca07(noccbd) - complex ca08(noccbd) - complex ca09(noccbd) - complex ca10(noccbd) - complex ca11(noccbd) - complex ca12(noccbd) - complex ca13(noccbd) - complex ca14(noccbd) - complex ca15(noccbd) - - COMPLEX cb00(noccbd) - complex cb01(noccbd) - complex cb02(noccbd) - complex cb03(noccbd) - complex cb04(noccbd) - complex cb05(noccbd) - complex cb06(noccbd) - complex cb07(noccbd) - complex cb08(noccbd) - complex cb09(noccbd) - complex cb10(noccbd) - complex cb11(noccbd) - complex cb12(noccbd) - complex cb13(noccbd) - complex cb14(noccbd) - complex cb15(noccbd) - - COMPLEX cc00(noccbd) - complex cc01(noccbd) - complex cc02(noccbd) - complex cc03(noccbd) - complex cc04(noccbd) - complex cc05(noccbd) - complex cc06(noccbd) - complex cc07(noccbd) - complex cc08(noccbd) - complex cc09(noccbd) - complex cc10(noccbd) - complex cc11(noccbd) - complex cc12(noccbd) - complex cc13(noccbd) - complex cc14(noccbd) - complex cc15(noccbd) - - - INTEGER :: lo,orbi,rep - REAL :: ddn0,ddn1,ddn2,ddn3 - integer :: mt,ityp,n,m,mt1,l - real :: h,g,c3,c5 - logical :: l_doit -c .. -c .. -c Intrinsic Function - Intrinsic sqrt,conjg -c - DATA h/0.50/ g/0.0625/ -c**************************************************** - c5 = sqrt(5.0) - c3 = sqrt(3.0) -c - mt=0 - DO 10 ityp = 1,ntypd - do rep=1,neq(ityp) - mt=mt+1 - - l_doit=.false. - do l=1,num_orbs - if(orbs(l)==mt)then - l_doit=.true. - orbi=l - endif - enddo - if(.not.l_doit)cycle - - ddn0 = ddn(0,ityp) - ddn1 = ddn(1,ityp) - ddn2 = ddn(2,ityp) - ddn3 = ddn(3,ityp) - DO n=1,noccbd -c -c acof -c s-states - ca00(n)=acof(n,0,mt) -c p-states - ca01(n) = acof(n,1,mt) - acof(n,3,mt) - ca02(n) = acof(n,1,mt) + acof(n,3,mt) - ca03(n) = acof(n,2,mt) -c d-states - ca04(n) = acof(n,4,mt) - acof(n,8,mt) - ca05(n) = acof(n,5,mt) + acof(n,7,mt) - ca06(n) = acof(n,5,mt) - acof(n,7,mt) - ca07(n) = acof(n,4,mt) + acof(n,8,mt) - ca08(n) = acof(n,6,mt) -c -c f-states: a cubic set (cub) -c - ca09(n) = ( acof(n,9,mt) - acof(n,15,mt) )*c5 - - - ( acof(n,11,mt) - acof(n,13,mt) )*c3 - ca10(n) = ( acof(n,9,mt) + acof(n,15,mt) )*c5 + - + ( acof(n,11,mt) + acof(n,13,mt) )*c3 - ca11(n) = acof(n,12,mt) - ca12(n) = ( acof(n,9,mt) + acof(n,15,mt) )*c3 - - - ( acof(n,11,mt) + acof(n,13,mt) )*c5 - ca13(n) = acof(n,10,mt) + acof(n,14,mt) - ca14(n) = ( acof(n,9,mt) - acof(n,15,mt) )*c3 + - + ( acof(n,11,mt) - acof(n,13,mt) )*c5 - ca15(n) = acof(n,10,mt) - acof(n,14,mt) - -c -c bcof -c s-states - cb00(n) = bcof(n,0,mt) -c p-states - cb01(n) = bcof(n,1,mt) - bcof(n,3,mt) - cb02(n) = bcof(n,1,mt) + bcof(n,3,mt) - cb03(n) = bcof(n,2,mt) -c d-states - cb04(n) = bcof(n,4,mt) - bcof(n,8,mt) - cb05(n) = bcof(n,5,mt) + bcof(n,7,mt) - cb06(n) = bcof(n,5,mt) - bcof(n,7,mt) - cb07(n) = bcof(n,4,mt) + bcof(n,8,mt) - cb08(n) = bcof(n,6,mt) -c -c f-states: a cubic set (cub) -c - cb09(n) = ( bcof(n,9,mt) - bcof(n,15,mt) )*c5 - - - ( bcof(n,11,mt) - bcof(n,13,mt) )*c3 - cb10(n) = ( bcof(n,9,mt) + bcof(n,15,mt) )*c5 + - + ( bcof(n,11,mt) + bcof(n,13,mt) )*c3 - cb11(n) = bcof(n,12,mt) - cb12(n) = ( bcof(n,9,mt) + bcof(n,15,mt) )*c3 - - - ( bcof(n,11,mt) + bcof(n,13,mt) )*c5 - cb13(n) = bcof(n,10,mt) + bcof(n,14,mt) - cb14(n) = ( bcof(n,9,mt) - bcof(n,15,mt) )*c3 + - + ( bcof(n,11,mt) - bcof(n,13,mt) )*c5 - cb15(n) = bcof(n,10,mt) - bcof(n,14,mt) - enddo !n - - do n=1,noccbd - do m=1,noccbd -c s - mmn(1,orbi,m,n) = ca00(n)*conjg(ca00(m)) - + + cb00(n)*conjg(cb00(m))*ddn0 -c p - mmn(2,orbi,m,n) = ( ca01(n)*conjg(ca01(m)) - + + cb01(n)*conjg(cb01(m))*ddn1 )*h - mmn(3,orbi,m,n) = ( ca02(n)*conjg(ca02(m)) - + + cb02(n)*conjg(cb02(m))*ddn1 )*h - mmn(4,orbi,m,n) = ca03(n)*conjg(ca03(m)) - + + cb03(n)*conjg(cb03(m))*ddn1 -c d - mmn(5,orbi,m,n) = ( ca04(n)*conjg(ca04(m)) - + + cb04(n)*conjg(cb04(m))*ddn2 )*h - mmn(6,orbi,m,n) = ( ca05(n)*conjg(ca05(m)) - + + cb05(n)*conjg(cb05(m))*ddn2 )*h - mmn(7,orbi,m,n) = ( ca06(n)*conjg(ca06(m)) - + + cb06(n)*conjg(cb06(m))*ddn2 )*h - mmn(8,orbi,m,n) = ( ca07(n)*conjg(ca07(m)) - + + cb07(n)*conjg(cb07(m))*ddn2 )*h - mmn(9,orbi,m,n) = ca08(n)*conjg(ca08(m)) - + + cb08(n)*conjg(cb08(m))*ddn2 -c f: a cubic set - if(l_oc_f)then - mmn(10,orbi,m,n) = ( ca09(n)*conjg(ca09(m)) - + + cb09(n)*conjg(cb09(m))*ddn3 )*g - mmn(11,orbi,m,n) = ( ca10(n)*conjg(ca10(m)) - + + cb10(n)*conjg(cb10(m))*ddn3 )*g - mmn(12,orbi,m,n) = ca11(n)*conjg(ca11(m)) - + + cb11(n)*conjg(cb11(m))*ddn3 - mmn(13,orbi,m,n) = ( ca12(n)*conjg(ca12(m)) - + + cb12(n)*conjg(cb12(m))*ddn3 )*g - mmn(14,orbi,m,n) = ( ca13(n)*conjg(ca13(m)) - + + cb13(n)*conjg(cb13(m))*ddn3 )*h - mmn(15,orbi,m,n) = ( ca14(n)*conjg(ca14(m)) - + + cb14(n)*conjg(cb14(m))*ddn3 )*g - mmn(16,orbi,m,n) = ( ca15(n)*conjg(ca15(m)) - + + cb15(n)*conjg(cb15(m))*ddn3 )*h - endif !l_oc_f - enddo !m - enddo !n - -c-------------------------------------------------------------------- -c ccof ( contributions from local orbitals ) -c - DO 60 lo = 1,nlo(ityp) - l = llo(lo,ityp) -c lo-s - IF ( l.EQ.0 ) THEN - do n=1,noccbd - cc00(n) = ccof(0,n,lo,mt) - enddo -c - do n=1,noccbd - do m=1,noccbd - mmn(1,orbi,m,n)=mmn(1,orbi,m,n)+ - + ( ca00(n)*conjg(cc00(m)) + - + cc00(n)*conjg(ca00(m)) )*uulon(lo,ityp) + - + ( cb00(n)*conjg(cc00(m)) + - + cc00(n)*conjg(cb00(m)) )*dulon(lo,ityp) + - + cc00(n)*conjg(cc00(m))*uloulopn(lo,lo,ityp) - enddo !m - enddo !n - GOTO 60 - ENDIF -c lo-p - IF ( l.EQ.1 ) THEN - do n=1,noccbd - cc01(n) = ccof(-1,n,lo,mt) - ccof(1,n,lo,mt) - cc02(n) = ccof(-1,n,lo,mt) + ccof(1,n,lo,mt) - cc03(n) = ccof( 0,n,lo,mt) - enddo - do n=1,noccbd - do m=1,noccbd - mmn(2,orbi,m,n) = mmn(2,orbi,m,n) + - + ( ( ca01(n)*conjg(cc01(m)) + - + cc01(n)*conjg(ca01(m)) )*uulon(lo,ityp) + - + ( cb01(n)*conjg(cc01(m)) + - + cc01(n)*conjg(cb01(m)) )*dulon(lo,ityp) + - + cc01(n)*conjg(cc01(m))*uloulopn(lo,lo,ityp) )*h - - mmn(3,orbi,m,n) = mmn(3,orbi,m,n) + - + ( ( ca02(n)*conjg(cc02(m)) + - + cc02(n)*conjg(ca02(m)) )*uulon(lo,ityp) + - + ( cb02(n)*conjg(cc02(m)) + - + cc02(n)*conjg(cb02(m)) )*dulon(lo,ityp) + - + cc02(n)*conjg(cc02(m))*uloulopn(lo,lo,ityp) )*h - - mmn(4,orbi,m,n) = mmn(4,orbi,m,n) + - + ( ca03(n)*conjg(cc03(m)) + - + cc03(n)*conjg(ca03(m)) )*uulon(lo,ityp) + - + ( cb03(n)*conjg(cc03(m)) + - + cc03(n)*conjg(cb03(m)) )*dulon(lo,ityp) + - + cc03(n)*conjg(cc03(m))*uloulopn(lo,lo,ityp) - - - enddo !m - enddo !n - GOTO 60 - ENDIF -c lo-d - IF ( l.EQ.2 ) THEN - do n=1,noccbd - cc04(n) = ccof(-2,n,lo,mt) - ccof(2,n,lo,mt) - cc05(n) = ccof(-1,n,lo,mt) + ccof(1,n,lo,mt) - cc06(n) = ccof(-1,n,lo,mt) - ccof(1,n,lo,mt) - cc07(n) = ccof(-2,n,lo,mt) + ccof(2,n,lo,mt) - cc08(n) = ccof( 0,n,lo,mt) - enddo !n -c - do n=1,noccbd - do m=1,noccbd - mmn(5,orbi,m,n) = mmn(5,orbi,m,n) + - + (( ca04(n)*conjg(cc04(m)) + - + cc04(n)*conjg(ca04(m)) )*uulon(lo,ityp) + - + ( cb04(n)*conjg(cc04(m)) + - + cc04(n)*conjg(cb04(m)) )*dulon(lo,ityp) + - + cc04(n)*conjg(cc04(m))*uloulopn(lo,lo,ityp) )*h - mmn(6,orbi,m,n) = mmn(6,orbi,m,n) + - + (( ca05(n)*conjg(cc05(m)) + - + cc05(n)*conjg(ca05(m)) )*uulon(lo,ityp) + - + ( cb05(n)*conjg(cc05(m)) + - + cc05(n)*conjg(cb05(m)) )*dulon(lo,ityp) + - + cc05(n)*conjg(cc05(m))*uloulopn(lo,lo,ityp) )*h - mmn(7,orbi,m,n) = mmn(7,orbi,m,n) + - + (( ca06(n)*conjg(cc06(m)) + - + cc06(n)*conjg(ca06(m)) )*uulon(lo,ityp) + - + ( cb06(n)*conjg(cc06(m)) + - + cc06(n)*conjg(cb06(m)) )*dulon(lo,ityp) + - + cc06(n)*conjg(cc06(m))*uloulopn(lo,lo,ityp) )*h - mmn(8,orbi,m,n) = mmn(8,orbi,m,n) + - + (( ca07(n)*conjg(cc07(m)) + - + cc07(n)*conjg(ca07(m)) )*uulon(lo,ityp) + - + ( cb07(n)*conjg(cc07(m)) + - + cc07(n)*conjg(cb07(m)) )*dulon(lo,ityp) + - + cc07(n)*conjg(cc07(m))*uloulopn(lo,lo,ityp) )*h - mmn(9,orbi,m,n) = mmn(9,orbi,m,n) + - + ( ca08(n)*conjg(cc08(m)) + - + cc08(n)*conjg(ca08(m)) )*uulon(lo,ityp) + - + ( cb08(n)*conjg(cc08(m)) + - + cc08(n)*conjg(cb08(m)) )*dulon(lo,ityp) + - + cc08(n)*conjg(cc08(m))*uloulopn(lo,lo,ityp) - enddo !m - enddo !n - GOTO 60 - ENDIF -c lo-f - IF ( l.EQ.3 .and. l_oc_f) THEN -c -c a cubic set (cub) -c - do n=1,noccbd - cc09(n) = ( ccof(-3,n,lo,mt) - ccof(3,n,lo,mt) )*c5 - - - ( ccof(-1,n,lo,mt) - ccof(1,n,lo,mt) )*c3 - cc10(n) = ( ccof(-3,n,lo,mt) + ccof(3,n,lo,mt) )*c5 + - + ( ccof(-1,n,lo,mt) + ccof(1,n,lo,mt) )*c3 - cc11(n) = ccof( 0,n,lo,mt) - cc12(n) = ( ccof(-3,n,lo,mt) + ccof(3,n,lo,mt) )*c3 - - - ( ccof(-1,n,lo,mt) + ccof(1,n,lo,mt) )*c5 - cc13(n) = ccof(-2,n,lo,mt) + ccof(2,n,lo,mt) - cc14(n) = ( ccof(-3,n,lo,mt) - ccof(3,n,lo,mt) )*c3 + - + ( ccof(-1,n,lo,mt) - ccof(1,n,lo,mt) )*c5 - cc15(n) = ccof(-2,n,lo,mt) - ccof(2,n,lo,mt) - enddo !n - do n=1,noccbd - do m=1,noccbd - mmn(10,orbi,m,n) = mmn(10,orbi,m,n) + - + (( ca09(n)*conjg(cc09(m)) + - + cc09(n)*conjg(ca09(m)) )*uulon(lo,ityp) + - + ( cb09(n)*conjg(cc09(m)) + - + cc09(n)*conjg(cb09(m)) )*dulon(lo,ityp) + - + cc09(n)*conjg(cc09(m))*uloulopn(lo,lo,ityp) )*g - mmn(11,orbi,m,n) = mmn(11,orbi,m,n) + - + (( ca10(n)*conjg(cc10(m)) + - + cc10(n)*conjg(ca10(m)) )*uulon(lo,ityp) + - + ( cb10(n)*conjg(cc10(m)) + - + cc10(n)*conjg(cb10(m)) )*dulon(lo,ityp) + - + cc10(n)*conjg(cc10(m))*uloulopn(lo,lo,ityp) )*g - mmn(12,orbi,m,n) = mmn(12,orbi,m,n) + - + ( ca11(n)*conjg(cc11(m)) + - + cc11(n)*conjg(ca11(m)) )*uulon(lo,ityp) + - + ( cb11(n)*conjg(cc11(m)) + - + cc11(n)*conjg(cb11(m)) )*dulon(lo,ityp) + - + cc11(n)*conjg(cc11(m))*uloulopn(lo,lo,ityp) - mmn(13,orbi,m,n) = mmn(13,orbi,m,n) + - + (( ca12(n)*conjg(cc12(m)) + - + cc12(n)*conjg(ca12(m)) )*uulon(lo,ityp) + - + ( cb12(n)*conjg(cc12(m)) + - + cc12(n)*conjg(cb12(m)) )*dulon(lo,ityp) + - + cc12(n)*conjg(cc12(m))*uloulopn(lo,lo,ityp) )*g - mmn(14,orbi,m,n) = mmn(14,orbi,m,n) + - + (( ca13(n)*conjg(cc13(m)) + - + cc13(n)*conjg(ca13(m)) )*uulon(lo,ityp) + - + ( cb13(n)*conjg(cc13(m)) + - + cc13(n)*conjg(cb13(m)) )*dulon(lo,ityp) + - + cc13(n)*conjg(cc13(m))*uloulopn(lo,lo,ityp) )*h - mmn(15,orbi,m,n) = mmn(15,orbi,m,n) + - + (( ca14(n)*conjg(cc14(m)) + - + cc14(n)*conjg(ca14(m)) )*uulon(lo,ityp) + - + ( cb14(n)*conjg(cc14(m)) + - + cc14(n)*conjg(cb14(m)) )*dulon(lo,ityp) + - + cc14(n)*conjg(cc14(m))*uloulopn(lo,lo,ityp) )*g - mmn(16,orbi,m,n) = mmn(16,orbi,m,n) + - + (( ca15(n)*conjg(cc15(m)) + - + cc15(n)*conjg(ca15(m)) )*uulon(lo,ityp) + - + ( cb15(n)*conjg(cc15(m)) + - + cc15(n)*conjg(cb15(m)) )*dulon(lo,ityp) + - + cc15(n)*conjg(cc15(m))*uloulopn(lo,lo,ityp) )*h - enddo !m - enddo !n - ENDIF - 60 CONTINUE - - - enddo !rep - - 10 CONTINUE ! types (ityp) - - END SUBROUTINE wann_orbcomp - END MODULE m_wann_orbcomp diff --git a/wannier/wann_orbcomp.f90 b/wannier/wann_orbcomp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e920c903ba586d0f939f37cb3d74206ca2b629c1 --- /dev/null +++ b/wannier/wann_orbcomp.f90 @@ -0,0 +1,424 @@ +!-------------------------------------------------------------------------------- +! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany +! This file is part of FLEUR and available as free software under the conditions +! of the MIT license as expressed in the LICENSE file in more detail. +!-------------------------------------------------------------------------------- + +MODULE m_wann_orbcomp + !************************************************************************* + ! Compute matrix elements of the first 16 angular momentum projectors + ! within the MT-spheres. This is done separately for each atom type. + ! + ! These are: + ! 1: |s> noco,jspin,oneD,acof,bcof,ccof,zMat) - call wann_abinv( - > ntypd,natd,noccbd,lmaxd,lmd,llod,nlod,ntype,neq, - > noccbd,lmax,nlo,llo,invsat,invsatnr,bkpt,taual, + call wann_abinv(atoms, X acof,bcof,ccof) diff --git a/wannier/wann_postproc.F b/wannier/wann_postproc.F deleted file mode 100644 index ea4802655ead03c18e10a41305e95509de0d3203..0000000000000000000000000000000000000000 --- a/wannier/wann_postproc.F +++ /dev/null @@ -1,563 +0,0 @@ -!-------------------------------------------------------------------------------- -! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany -! This file is part of FLEUR and available as free software under the conditions -! of the MIT license as expressed in the LICENSE file in more detail. -!-------------------------------------------------------------------------------- - - module m_wann_postproc - contains - subroutine wann_postproc( - > DIMENSION,stars,vacuum,atoms,sphhar,input,kpts,sym,mpi, - > lapw,oneD,noco,cell,vTot,enpara,eig_id,l_real, - > mpi_comm,wann,l_p0,film,jspins,n2d, - > natd,pos,amat,bmat,ntype,neq,zatom, - > omtil,l_soc,l_noco,neigd,fullnkpts, - > odi,l_proj, - > l_dulo,l_ss,lmaxd,ntypd,nop,nvd,jspd,nbasfcn, - > llod,nlod,nlo,llo,lapw_l,invtab,mrot,ngopr, - > lmax,invsat,invsatnr,nkpt,taual,rmt,bbmat,alph, - > beta,qss,sk2,phi2,ods, - > irank,isize,n3d,nmzxyd,nmzd,jmtd,nlhd,nq3,nvac, - > invs,invs2,nlh,jri,ntypsy,ntypsd,nkptd, - > dx,rmsh, - > e1s,e2s,ulo_der,ustep,k1d,k2d,k3d,nop2, - > ig,rgphs,slice,kk,nnne,nv2d,nmzxy,nmz,nq2, - > delz,area,z1,volint,ig2,tau,symor,ef,l_sgwf,fullnqpts) -c < fermi_weights) - -c*********************************************** -c Collection of those subroutines which may -c be called after the Wannier functions have -c been computed. -c Frank Freimuth -c*********************************************** - use m_types - use m_wann_dipole - use m_wann_dipole2 - use m_wann_wannierize - use m_wann_hopping - use m_wann_plot_um_dat - use m_wannier_to_lapw - use m_wann_plot_from_lapw - use m_wann_nabla_rs - use m_wann_pauli_rs - use m_wann_nabla_pauli_rs - use m_wann_socmat_rs - use m_wann_perpmag_rs - use m_types - use m_wann_wigner_seitz - use m_wann_get_mp - use m_wann_get_kpts - use m_wann_fft4 - use m_wann_fft5 - use m_wann_rmat - use m_wann_nocoplot -#ifdef CPP_TOPO - use m_wann_torque_rs - use m_wann_offdiposop_rs - use m_wann_fft6 - use m_wann_fft3 - use m_wann_nedrho -#endif - -#ifdef DCPP_WANN_EXT - use m_wannier_to_lapw_kpts - use m_wannier_lapw_gfleur -#endif - implicit none - - TYPE(t_dimension),INTENT(IN) :: DIMENSION - TYPE(t_stars),INTENT(IN) :: stars - TYPE(t_vacuum),INTENT(IN) :: vacuum - TYPE(t_atoms),INTENT(IN) :: atoms - TYPE(t_sphhar),INTENT(IN) :: sphhar - TYPE(t_input),INTENT(IN) :: input - TYPE(t_kpts),INTENT(IN) :: kpts - TYPE(t_sym),INTENT(IN) :: sym - TYPE(t_mpi),INTENT(IN) :: mpi - TYPE(t_lapw),INTENT(IN) :: lapw - TYPE(t_oneD),INTENT(IN) :: oneD - TYPE(t_noco),INTENT(IN) :: noco - TYPE(t_cell),INTENT(IN) :: cell - TYPE(t_potden),INTENT(IN) :: vTot - TYPE(t_enpara),INTENT(IN) :: enpara - - type(t_wann), intent(in) :: wann - logical, intent(in) :: l_p0 - logical, intent(in) :: film, l_real - integer, intent(in) :: jspins,n2d,mpi_comm, eig_id - integer, intent(in) :: natd - real, intent(in) :: pos(3,natd) - real, intent(in) :: amat(3,3),bmat(3,3) - integer, intent(in) :: ntype - integer, intent(in) :: neq(ntype) - real, intent(in) :: zatom(ntype) - real, intent(in) :: omtil - logical, intent(in) :: l_soc,l_noco - integer, intent(in) :: neigd - integer, intent(in) :: fullnkpts,fullnqpts - type(od_inp), intent(in) :: odi - logical, intent(in) :: l_proj - integer, intent (in) :: lmaxd,ntypd,nop,nvd,jspd - integer, intent (in) :: nbasfcn,llod,nlod - integer, intent (in) :: nlo(ntypd),llo(nlod,ntypd) - integer, intent (in) :: lapw_l(ntypd) - logical, intent (in) :: l_dulo(nlod,ntypd),l_ss - integer, intent (in) :: invtab(nop),mrot(3,3,nop),ngopr(natd) - integer, intent (in) :: lmax(ntypd) - integer, intent (in) :: invsat(natd),invsatnr(natd),nkpt - real, intent (in) :: taual(3,natd),rmt(ntypd) - real, intent (in) :: bbmat(3,3) - real, intent (in) :: alph(ntypd),beta(ntypd) - real, intent (in) :: qss(3,fullnqpts) - real, intent (in) :: sk2(n2d),phi2(n2d) - type (od_sym),intent(in) :: ods - integer, intent (in) :: irank,isize,n3d - integer, intent (in) :: nmzxyd,nmzd,jmtd,nlhd,nq3,nvac - logical, intent (in) :: invs,invs2 - integer, intent (in) :: ntypsd,nkptd - integer, intent (in) :: nlh(ntypsd),jri(ntypd),ntypsy(natd) - real, intent (in) :: dx(ntypd) - real, intent (in) :: rmsh(jmtd,ntypd) - real, intent (in) :: e1s,e2s - integer, intent (in) :: ulo_der(nlod,ntypd) - complex, intent (in) :: ustep(n3d) - integer, intent (in) :: k1d,k2d,k3d,nop2 - integer, intent (in) :: ig(-k1d:k1d,-k2d:k2d,-k3d:k3d) - complex, intent (in) :: rgphs(-k1d:k1d,-k2d:k2d,-k3d:k3d) - logical, intent (in) :: slice - integer, intent (in) :: kk,nnne - integer, intent (in) :: nv2d,nmzxy,nmz,nq2 - real, intent (in) :: delz,area,z1,volint - integer, intent (in) :: ig2(n3d) - real, intent (in) :: tau(3,nop) - logical, intent (in) :: symor - real, intent (in) :: ef - logical, intent (in) :: l_sgwf -c real,intent(inout) :: fermi_weights(:,:,:) !(neigd,nkptd,jspd) - - character(len=12) :: fending - integer :: i,nkpts,ikpt,nkqpts,iqpt - real :: delta3,time_lapw_expand,delta2,time_lapw_plot - logical :: l_need_fft,l_file - integer :: hopmin_z,hopmax_z - integer :: hopmin_y,hopmax_y - integer :: hopmin_x,hopmax_x - integer :: ii - integer :: rvecnum,rvecind,num(3),int_dummy - integer,allocatable :: rvec(:,:),ndegen(:) - real :: scale - real,allocatable :: kpoints(:,:)!(3,fullnkpts) - integer :: r1,r2,r3,spinspin,num_angl - logical :: l_nocosoc - - ALLOCATE(kpoints(3,fullnkpts)) - l_nocosoc=.false. - if(l_soc)l_nocosoc=.true. - if(l_noco)l_nocosoc=.true. - -c*************************************************** -c Read in the kpoints from w90kpts or kpts. -c*************************************************** - call wann_get_kpts(input,kpts, - > wann%l_bzsym,film,odi%d1,.false., - < nkpts,kpoints) - if (nkpts /= fullnkpts) - + CALL juDFT_error ('mismatch in number of kpoints', - + calledby="wann_postproc") - - call wann_get_kpts(input,kpts, - > wann%l_bzsym,film,odi%d1,.true., - < nkpts,kpoints) -c********************************************************* -c Find out the structure of k-point set. -c********************************************************* - call wann_get_mp( - > fullnkpts,kpoints, - < num) - - if(wann%l_wannierize.and.l_p0)then -#ifndef CPP_WANN - WRITE(*,*) 'At this point a wannierization has to be performed' - WRITE(*,*) 'but the Wannier90 library is not linked!' - CALL juDFT_error ('Wannierization without Wannier90 library', - + calledby="wann_postproc") -#else - call wann_wannierize( - > film,wann%l_bzsym,jspins, - > natd,pos,amat,bmat,ntype,neq,zatom) -#endif - endif - - if(wann%l_dipole2.and.l_p0)then - call wann_dipole2( - > jspins,pos,omtil,natd, - > (l_soc.or.l_noco)) - endif - - if(wann%l_dipole.and.l_p0)then - call wann_dipole( - > jspins,omtil,natd,pos,amat, - > ntype,neq,zatom) - endif - -#ifdef CPP_TOPO - if(wann%l_nedrho.and.l_p0)then - call wann_nedrho( - > fullnkpts,area,ef, - < fermi_weights) - endif -#endif - - if(wann%l_byenergy) i=3 - if(wann%l_bynumber) i=2 - if(wann%l_byindex) i=1 - - if(wann%l_plotw90)then - CALL juDFT_error("not in this version", - + calledby ="wann_postproc") - -c call wann_plotw90(i,wann%band_min,wann%band_max,numbands,nwfs, -c > l_dulo,l_noco,l_ss,lmaxd,ntypd, -c > neigd,natd,nop,nvd,jspd,nbasfcn,llod,nlod,ntype, -c > nwdd,omtil,nlo,llo,lapw_l,invtab,mrot,ngopr,neq,lmax, -c > invsat,invsatnr,nkpt,taual,rmt,amat,bmat,bbmat,alph, -c > beta,qss,sk2,phi2,odi,ods,irank,isize,n3d,nmzxyd,nmzd, -c > jmtd,nlhd,nq3,nvac,invs,invs2,film,nlh,jri,ntypsd, -c > ntypsy,jspins,nkptd,dx,n2d,rmsh,e1s,e2s,ulo_der, -c > ustep,ig,k1d,k2d,k3d,rgphs,slice,kk,nnne, -c > z1,nv2d,nmzxy,nmz,delz,ig2,area,tau,zatom,nq2,nop2, -c > volint,symor,pos,ef,wann%l_bzsym,irecl) - - endif - - l_need_fft=.false. - if(wann%l_hopping.or.wann%l_nablars.or. - & wann%l_nablapaulirs.or.wann%l_pauli.or. - & wann%l_perpmagrs.or.wann%l_socmatrs.or. - & wann%l_torquers.or.wann%l_offdiposoprs.or. - & wann%l_socspicomrs.or.wann%l_spindisprs.or. - & wann%l_anglmomrs .or.wann%l_perturbrs.or. - & wann%l_orbcomprs.or.wann%l_rmat)l_need_fft=.true. - - if(l_need_fft.and.l_p0)then - - if(.false.)then !specify r-mesh by its boundaries - hopmin_z=-5;hopmax_z=5 - hopmin_x=0;hopmax_x=0 - hopmin_y=0;hopmax_y=0 - rvecnum=(hopmax_z-hopmin_z+1) - if(.not.odi%d1.and.film)then - hopmin_x=-5;hopmax_x=5 - hopmin_y=-5;hopmax_y=5 - hopmin_z=0; hopmax_z=0 - else - hopmin_x=-5;hopmax_x=5 - hopmin_y=-5;hopmax_y=5 - endif - rvecnum= (hopmax_z-hopmin_z+1) - rvecnum=rvecnum*(hopmax_y-hopmin_y+1) - rvecnum=rvecnum*(hopmax_x-hopmin_x+1) - - allocate(rvec(3,rvecnum)) - rvecind=0 - do r3=hopmin_z,hopmax_z - do r2=hopmin_y,hopmax_y - do r1=hopmin_x,hopmax_x - rvecind=rvecind+1 - if (rvecind > rvecnum) - + CALL juDFT_error ('mismatch in number of kpoints', - + calledby="wann_postproc") - - rvec(1,rvecind)=r1 - rvec(2,rvecind)=r2 - rvec(3,rvecind)=r3 - enddo !r1 - enddo !r2 - enddo !r3 - else !determine optimal r-mesh - call wann_wigner_seitz( - > .true.,num,amat,0, - < rvecnum,rvec,ndegen) - allocate(rvec(3,rvecnum)) - allocate(ndegen(rvecnum)) - call wann_wigner_seitz( - > .false.,num,amat,rvecnum, - < int_dummy,rvec,ndegen) - - open(333,file='wig_vectors',recl=1000) - do ii=1,rvecnum - write(333,*)ii,rvec(1,ii),rvec(2,ii),rvec(3,ii), - & ndegen(ii) - enddo - close(333) - - endif - - endif - - if(wann%l_hopping.and.l_p0) then - call wann_hopping( - > rvecnum,rvec,kpoints, - > jspins,fullnkpts,wann%l_bzsym,film,odi%d1, - > l_nocosoc,wann%band_min,wann%band_max, - > neigd,wann%l_socmmn0,wann%l_ndegen,ndegen, - > wann%wan90version,wann%l_unformatted) - endif - - if(wann%l_nablars.and.l_p0) then - call wann_nabla_rs( - > rvecnum,rvec,kpoints, - > jspins,fullnkpts,wann%l_bzsym,film,odi%d1, - > l_soc,wann%band_min,wann%band_max, - > neigd,.false., - > wann%wan90version) - endif - - if(wann%l_orbcomprs.and.l_p0)then - num_angl=9 - if(wann%l_oc_f)num_angl=16 - call wann_fft5( - > .false., - > num_angl,wann%oc_num_orbs, - > 'WF1.orbcomp','orbcomp.1', - > rvecnum,rvec,kpoints, - > 1,fullnkpts,film, - > l_soc,wann%band_min,wann%band_max,neigd, - > wann%wan90version) - if( jspins.eq.2 )then - spinspin=2 - if(l_soc.or.l_noco)spinspin=1 - call wann_fft5( - > .false., - > num_angl,wann%oc_num_orbs, - > 'WF2.orbcomp','orbcomp.2', - > rvecnum,rvec,kpoints, - > spinspin,fullnkpts,film, - > l_soc,wann%band_min,wann%band_max,neigd, - > wann%wan90version) - endif - endif - - if(wann%l_rmat)then - call wann_rmat( - > bmat,amat, - > rvecnum,rvec,kpoints, - > jspins,fullnkpts,wann%l_bzsym,film,odi%d1, - > l_nocosoc,wann%band_min,wann%band_max, - > neigd,.false.,wann%wan90version) - endif - - - if(wann%l_anglmomrs.and.l_p0)then - call wann_fft4( - > 'WF1.anglmom', - > 'anglmomrs.1',.false., - > rvecnum,rvec,kpoints, - > jspins,fullnkpts,wann%l_bzsym,film,odi%d1, - > l_soc,wann%band_min,wann%band_max,neigd, - > .false.,wann%wan90version) - endif - -#ifdef CPP_TOPO - if(wann%l_offdiposoprs.and.l_p0)then - call wann_offdiposop_rs( - > rvecnum,rvec,kpoints, - > jspins,fullnkpts,wann%l_bzsym,film,odi%d1, - > l_soc,wann%band_min,wann%band_max,neigd, - > .false.) - endif - - if(wann%l_spindisprs.and.l_p0)then - call wann_fft5( - > rvecnum,rvec,kpoints, - > jspins,fullnkpts,wann%l_bzsym,film,odi%d1, - > l_soc,wann%band_min,wann%band_max,neigd, - > .false.) - endif - - if(wann%l_perturbrs.and.l_p0)then - call wann_fft3( - > 'WF1.perturb' ,'perturbrs.1' ,.false., - > rvecnum,rvec,kpoints, - > jspins,fullnkpts,wann%l_bzsym,film,odi%d1, - > l_soc,wann%band_min,wann%band_max,neigd, - > .false.) - endif - - if(wann%l_socspicomrs.and.l_p0)then - if(l_soc)then - call wann_fft4( - > 'WF1.socspicom','socspicomrs.1',.true., - > rvecnum,rvec,kpoints, - > jspins,fullnkpts,wann%l_bzsym,film,odi%d1, - > l_soc,wann%band_min,wann%band_max,neigd, - > .false.) - else - call wann_fft6( - > rvecnum,rvec,kpoints, - > jspins,fullnkpts,wann%l_bzsym,film,odi%d1, - > l_soc,wann%band_min,wann%band_max,neigd, - > .false.) - endif - endif - - - - if(wann%l_torquers.and.l_p0) then - call wann_torque_rs( - > ntype,neq,rvecnum,rvec,kpoints, - > jspins,fullnkpts,wann%l_bzsym,film,odi%d1, - > l_soc,wann%band_min,wann%band_max, - > neigd,.false.) - endif -#endif - if (wann%l_nablapaulirs.and.l_p0)then - call wann_nabla_pauli_rs( - > rvecnum,rvec,kpoints, - > jspins,fullnkpts,wann%l_bzsym,film,odi%d1, - > l_soc,wann%band_min,wann%band_max, - > neigd,.false.,wann%wan90version) - endif - - if (wann%l_pauli.and.l_p0)then - call wann_pauli_rs( - > rvecnum,rvec,kpoints, - > jspins,fullnkpts,wann%l_bzsym,film,odi%d1, - > l_nocosoc,wann%band_min,wann%band_max, - > neigd,.false.,wann%l_ndegen,ndegen, - > wann%wan90version,wann%l_unformatted) - endif - - if (wann%l_perpmagrs.and.l_p0)then - call wann_perpmag_rs( - > rvecnum,rvec,kpoints, - > jspins,fullnkpts,wann%l_bzsym,film,odi%d1, - > l_soc,wann%band_min,wann%band_max, - > neigd,.false.,wann%l_ndegen,ndegen,wann%wan90version, - > wann%l_unformatted) - endif - - if (wann%l_socmatrs.and.l_p0)then - call wann_socmat_rs( - > rvecnum,rvec,kpoints, - > jspins,fullnkpts,wann%l_bzsym,film,odi%d1, - > l_soc,wann%band_min,wann%band_max, - > neigd,.false.,wann%wan90version) - endif - - if(wann%l_plot_umdat)then - call wann_plot_um_dat( - > DIMENSION,stars,vacuum,atoms,sphhar,input,sym,mpi, - > lapw,oneD,noco,cell,vTot,enpara,eig_id,l_real, - > mpi_comm,i,wann%band_min,wann%band_max,l_soc, - > l_dulo,l_noco,l_ss,lmaxd,ntypd, - > neigd,natd,nop,nvd,jspd,nbasfcn,llod,nlod,ntype, - > omtil,nlo,llo,lapw_l,invtab,mrot,ngopr,neq,lmax, - > invsat,invsatnr,nkpt,taual,rmt,amat,bmat,bbmat,alph, - > beta,qss(:,1),sk2,phi2,odi,ods,irank,isize,n3d,nmzxyd,nmzd, - > jmtd,nlhd,nq3,nvac,invs,invs2,film,nlh,jri,ntypsd, - > ntypsy,jspins,nkptd,dx,n2d,rmsh,e1s,e2s,ulo_der, - > ustep,ig,k1d,k2d,k3d,rgphs,slice,kk,nnne, - > z1,nv2d,nmzxy,nmz,delz,ig2,area,tau,zatom,nq2,nop2, - > volint,symor,pos,ef,wann%l_bzsym,wann%l_proj_plot, - > wann%wan90version) - endif - - - call cpu_time(delta2) - if(wann%l_lapw.and.l_p0)then - call wannier_to_lapw( - > mpi_comm,eig_id,l_real, - > input,lapw,oneD,noco,sym,cell,atoms,stars,vacuum,sphhar, - > vTot, - > l_soc,wann%unigrid,i,wann%band_min,wann%band_max, - > l_dulo,l_noco,l_ss,lmaxd,ntypd, - > neigd,natd,nop,nvd,jspd,nbasfcn,llod,nlod,ntype, - > omtil,nlo,llo,lapw_l,invtab,mrot,ngopr,neq,lmax, - > invsat,invsatnr,nkpt,taual,rmt,amat,bmat,bbmat,alph, - > beta,qss(:,1),sk2,phi2,odi,ods,irank,isize,n3d,nmzxyd,nmzd, - > jmtd,nlhd,nq3,nvac,invs,invs2,film,nlh,jri,ntypsd, - > ntypsy,jspins,nkptd,dx,n2d,rmsh,e1s,e2s,ulo_der, - > ustep,ig,k1d,k2d,k3d,rgphs,slice,kk,nnne, - > z1,nv2d,nmzxy,nmz,delz,ig2,area,tau,zatom,nq2,nop2, - > volint,symor,pos,ef,wann%l_bzsym,wann%l_proj_plot, - > wann%wan90version) - endif - - if(wann%l_lapw_kpts)then -#ifdef DCPP_WANN_EXT - call wannier_to_lapw_kpts( - > unigrid,i,wann%band_min,wann%band_max, - > l_dulo,l_noco,l_ss,lmaxd,ntypd, - > neigd,natd,nop,nvd,jspd,nbasfcn,llod,nlod,ntype, - > nwdd,omtil,nlo,llo,lapw_l,invtab,mrot,ngopr,neq,lmax, - > invsat,invsatnr,nkpt,taual,rmt,amat,bmat,bbmat,alph, - > beta,qss(:,1),sk2,phi2,odi,ods,irank,isize,n3d,nmzxyd,nmzd, - > jmtd,nlhd,nq3,nvac,invs,invs2,film,nlh,jri,ntypsd, - > ntypsy,jspins,nkptd,dx,n2d,rmsh,e1s,e2s,ulo_der, - > ustep,ig,k1d,k2d,k3d,rgphs,slice,kk,nnne, - > z1,nv2d,nmzxy,nmz,delz,ig2,area,tau,zatom,nq2,nop2, - > volint,symor,pos,ef,wann%l_bzsym,wann%l_proj_plot,irecl) -#else - CALL juDFT_error("not yet tested in this release",calledby - + ="wann_postproc") -#endif - endif - if(wann%l_lapw_gfleur)then -#ifdef DCPP_WANN_EXT - call wannier_lapw_gfleur( - > gfthick,gfcut,i,wann%band_min,wann%band_max, - > l_dulo,l_noco,l_ss,lmaxd,ntypd, - > neigd,natd,nop,nvd,jspd,nbasfcn,llod,nlod,ntype, - > nwdd,omtil,nlo,llo,lapw_l,invtab,mrot,ngopr,neq,lmax, - > invsat,invsatnr,nkpt,taual,rmt,amat,bmat,bbmat,alph, - > beta,qss(:,1),sk2,phi2,odi,ods,irank,isize,n3d,nmzxyd,nmzd, - > jmtd,nlhd,nq3,nvac,invs,invs2,film,nlh,jri,ntypsd, - > ntypsy,jspins,nkptd,dx,n2d,rmsh,e1s,e2s,ulo_der, - > ustep,ig,k1d,k2d,k3d,rgphs,slice,kk,nnne, - > z1,nv2d,nmzxy,nmz,delz,ig2,area,tau,zatom,nq2,nop2, - > volint,symor,pos,ef,wann%l_bzsym,wann%l_proj_plot,irecl) -#else - CALL juDFT_error("not yet tested in this release",calledby - + ="wann_postproc") -#endif - endif - - call cpu_time(delta3) - time_lapw_expand=delta3-delta2 - - call cpu_time(delta2) - if(wann%l_plot_lapw.and.l_p0)then - CALL juDFT_error("not yet tested in this release",calledby - + ="wann_postproc") -c call wann_plot_from_lapw( -c > nv2d,jspins,odi,ods,n3d,nmzxyd,n2d, -c > ntypsd, -c > ntype,lmaxd,jmtd,natd,nmzd,neq,nq3,nvac, -c > nmz,nmzxy,nq2,nop,nop2,volint,film,slice,symor, -c > invs,invs2,z1,delz,ngopr,ntypsy,jri,pos,zatom, -c > lmax,mrot,tau,rmsh,invtab,amat,bmat,bbmat,nnne,kk, -c > nlod,llod,lmd,omtil,nlo,llo) - endif - call cpu_time(delta3) - time_lapw_plot=delta3-delta2 - - write(6,*)"time_lapw_expand=",time_lapw_expand - write(6,*)"time_lapw_plot=",time_lapw_plot - - if(wann%l_finishnocoplot.and.l_p0) then -c write(*,*)'doing the UNK mixing' -c write(*,*)'alph',alph -c write(*,*)'beta',beta -c nkqpts=fullnkpts -c if(l_sgwf) nkqpts=fullnkpts*fullnqpts - call wann_nocoplot(atoms,slice,nnne,!nslibd - > amat,bmat,fullnkpts,odi,film, - > natd,ntypd,jmtd,ntype,neq,pos, - > jri,rmsh,alph,beta,fullnqpts,qss, - > z1,zatom) - endif - - end subroutine wann_postproc - end module m_wann_postproc diff --git a/wannier/wann_postproc.F90 b/wannier/wann_postproc.F90 new file mode 100644 index 0000000000000000000000000000000000000000..d158707b0cf4fde1479d9f480fd1d685d0ed2d5f --- /dev/null +++ b/wannier/wann_postproc.F90 @@ -0,0 +1,506 @@ +!-------------------------------------------------------------------------------- +! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany +! This file is part of FLEUR and available as free software under the conditions +! of the MIT license as expressed in the LICENSE file in more detail. +!-------------------------------------------------------------------------------- + +MODULE m_wann_postproc +CONTAINS + SUBROUTINE wann_postproc(& + DIMENSION,stars,vacuum,atoms,sphhar,input,kpts,sym,mpi,& + lapw,oneD,noco,cell,vTot,enpara,sliceplot,eig_id,l_real,& + wann, fullnkpts, l_proj,ef,l_sgwf,fullnqpts) + ! < fermi_weights) + + !*********************************************** + ! Collection of those subroutines which may + ! be called after the Wannier functions have + ! been computed. + ! Frank Freimuth + !*********************************************** + USE m_types + USE m_wann_dipole + USE m_wann_dipole2 + USE m_wann_wannierize + USE m_wann_hopping + USE m_wann_plot_um_dat + USE m_wannier_to_lapw + USE m_wann_plot_from_lapw + USE m_wann_nabla_rs + USE m_wann_pauli_rs + USE m_wann_nabla_pauli_rs + USE m_wann_socmat_rs + USE m_wann_perpmag_rs + USE m_types + USE m_wann_wigner_seitz + USE m_wann_get_mp + USE m_wann_get_kpts + USE m_wann_fft4 + USE m_wann_fft5 + USE m_wann_rmat + USE m_wann_nocoplot +#ifdef CPP_TOPO + USE m_wann_torque_rs + USE m_wann_offdiposop_rs + USE m_wann_fft6 + USE m_wann_fft3 + USE m_wann_nedrho +#endif + +#ifdef DCPP_WANN_EXT + USE m_wannier_to_lapw_kpts + USE m_wannier_lapw_gfleur +#endif + IMPLICIT NONE + + TYPE(t_dimension),INTENT(IN) :: DIMENSION + TYPE(t_stars),INTENT(IN) :: stars + TYPE(t_vacuum),INTENT(IN) :: vacuum + TYPE(t_atoms),INTENT(IN) :: atoms + TYPE(t_sphhar),INTENT(IN) :: sphhar + TYPE(t_input),INTENT(IN) :: input + TYPE(t_kpts),INTENT(IN) :: kpts + TYPE(t_sym),INTENT(IN) :: sym + TYPE(t_mpi),INTENT(IN) :: mpi + TYPE(t_lapw),INTENT(IN) :: lapw + TYPE(t_oneD),INTENT(IN) :: oneD + TYPE(t_noco),INTENT(IN) :: noco + TYPE(t_cell),INTENT(IN) :: cell + TYPE(t_potden),INTENT(IN) :: vTot + TYPE(t_enpara),INTENT(IN) :: enpara + type(t_sliceplot),INTENT(IN) :: sliceplot + + TYPE(t_wann), INTENT(in) :: wann + LOGICAL, INTENT(in) :: l_real + INTEGER, INTENT(in) :: eig_id + INTEGER, INTENT(in) :: fullnkpts,fullnqpts + LOGICAL, INTENT(in) :: l_proj + REAL, INTENT (in) :: ef + LOGICAL, INTENT (in) :: l_sgwf + ! real,intent(inout) :: fermi_weights(:,:,:) !(dimension%neigd,nkptd,jspd) + + CHARACTER(len=12) :: fending + INTEGER :: i,nkpts,ikpt,nkqpts,iqpt + REAL :: delta3,time_lapw_expand,delta2,time_lapw_plot + LOGICAL :: l_need_fft,l_file + INTEGER :: hopmin_z,hopmax_z + INTEGER :: hopmin_y,hopmax_y + INTEGER :: hopmin_x,hopmax_x + INTEGER :: ii + INTEGER :: rvecnum,rvecind,num(3),int_dummy + INTEGER,ALLOCATABLE :: rvec(:,:),ndegen(:) + REAL :: scale + REAL,ALLOCATABLE :: kpoints(:,:)!(3,fullnkpts) + INTEGER :: r1,r2,r3,spinspin,num_angl + LOGICAL :: l_nocosoc + + ALLOCATE(kpoints(3,fullnkpts)) + l_nocosoc=.FALSE. + IF(noco%l_soc)l_nocosoc=.TRUE. + IF(noco%l_noco)l_nocosoc=.TRUE. + + !*************************************************** + ! Read in the kpoints from w90kpts or kpts. + !*************************************************** + CALL wann_get_kpts(input,kpts,& + wann%l_bzsym,input%film,oneD%odi%d1,.FALSE.,& + nkpts,kpoints) + IF (nkpts /= fullnkpts)& + CALL juDFT_error ('mismatch in number of kpoints',& + calledby="wann_postproc") + + CALL wann_get_kpts(input,kpts,& + wann%l_bzsym,input%film,oneD%odi%d1,.TRUE.,& + nkpts,kpoints) + !********************************************************* + ! Find out the structure of k-point set. + !********************************************************* + CALL wann_get_mp(& + fullnkpts,kpoints,& + num) + + IF(wann%l_wannierize.AND.mpi%irank==0)THEN +#ifndef CPP_WANN + WRITE(*,*) 'At this point a wannierization has to be performed' + WRITE(*,*) 'but the Wannier90 library is not linked!' + CALL juDFT_error ('Wannierization without Wannier90 library',& + calledby="wann_postproc") +#else + CALL wann_wannierize(& + input%film,wann%l_bzsym,input%jspins,& + atoms%nat,atoms%pos,cell%amat,cell%bmat,atoms%ntype,atoms%neq,atoms%zatom) +#endif + ENDIF + + IF(wann%l_dipole2.AND.mpi%irank==0)THEN + CALL wann_dipole2(& + input%jspins,atoms%pos,cell%omtil,atoms%nat,& + (noco%l_soc.OR.noco%l_noco)) + ENDIF + + IF(wann%l_dipole.AND.mpi%irank==0)THEN + CALL wann_dipole(& + input%jspins,cell%omtil,atoms%nat,atoms%pos,cell%amat,& + atoms%ntype,atoms%neq,atoms%zatom) + ENDIF + +#ifdef CPP_TOPO + IF(wann%l_nedrho.AND.mpi%irank==0)THEN + CALL wann_nedrho(& + fullnkpts,cell%area,ef,& + fermi_weights) + ENDIF +#endif + + IF(wann%l_byenergy) i=3 + IF(wann%l_bynumber) i=2 + IF(wann%l_byindex) i=1 + + IF(wann%l_plotw90)THEN + CALL juDFT_error("not in this version",& + calledby ="wann_postproc") + + ! call wann_plotw90(i,wann%band_min,wann%band_max,numbands,nwfs, + ! > atoms%l_dulo,noco%l_noco,noco%l_ss,atoms%lmaxd,atoms%ntype, + ! > dimension%neigd,atoms%nat,sym%nop,dimension%nvd,jspd,dimension%nbasfcn,atoms%llod,atoms%nlod,atoms%ntype, + ! > nwdd,cell%omtil,atoms%nlo,atoms%llo,atoms%lapw_l,sym%invtab,sym%mrot,atoms%ngopr,atoms%neq,atoms%lmax, + ! > atoms%invsat,atoms%invsatnr,kpts%nkpt,atoms%taual,atoms%rmt,cell%amat,cell%bmat,cell%bbmat,noco%alph, + ! > noco%beta,noco%qss,stars%sk2,stars%phi2,oneD%odi,oneD%ods,mpi%irank,mpi%isize,stars%ng3,vacuum%nmzxyd,vacuum%nmzd, + ! > size(atoms%rmsh,1),sphhar%nlhd,stars%ng3,vacuum%nvac,sym%invs,sym%invs2,input%film,sphhar%nlh,atoms%jri,sphhar%ntypsd, + ! > atoms%ntypsy,input%jspins,kpts%nkpt,atoms%dx,stars%ng2,atoms%rmsh,sliceplot%e1s,sliceplot%e2s,atoms%ulo_der, + ! > stars%ustep,stars%ig,stars%mx1,stars%mx2,stars%mx3,stars%rgphs,sliceplot%slice,sliceplot%kk,sliceplot%nnne, + ! > cell%z1,dimension%nv2d,vacuum%nmzxy,vacuum%nmz,vacuum%delz,stars%ig2,cell%area,sym%tau,atoms%zatom,stars%ng2,sym%nop2, + ! > cell%volint,sym%symor,atoms%pos,ef,wann%l_bzsym,irecl) + + ENDIF + + l_need_fft=.FALSE. + IF(wann%l_hopping.OR.wann%l_nablars.OR.& + wann%l_nablapaulirs.OR.wann%l_pauli.OR.& + wann%l_perpmagrs.OR.wann%l_socmatrs.OR.& + wann%l_torquers.OR.wann%l_offdiposoprs.OR.& + wann%l_socspicomrs.OR.wann%l_spindisprs.OR.& + wann%l_anglmomrs .OR.wann%l_perturbrs.OR.& + wann%l_orbcomprs.OR.wann%l_rmat)l_need_fft=.TRUE. + + IF(l_need_fft.AND.mpi%irank==0)THEN + + IF(.FALSE.)THEN !specify r-mesh by its boundaries + hopmin_z=-5;hopmax_z=5 + hopmin_x=0;hopmax_x=0 + hopmin_y=0;hopmax_y=0 + rvecnum=(hopmax_z-hopmin_z+1) + IF(.NOT.oneD%odi%d1.AND.input%film)THEN + hopmin_x=-5;hopmax_x=5 + hopmin_y=-5;hopmax_y=5 + hopmin_z=0; hopmax_z=0 + ELSE + hopmin_x=-5;hopmax_x=5 + hopmin_y=-5;hopmax_y=5 + ENDIF + rvecnum= (hopmax_z-hopmin_z+1) + rvecnum=rvecnum*(hopmax_y-hopmin_y+1) + rvecnum=rvecnum*(hopmax_x-hopmin_x+1) + + ALLOCATE(rvec(3,rvecnum)) + rvecind=0 + DO r3=hopmin_z,hopmax_z + DO r2=hopmin_y,hopmax_y + DO r1=hopmin_x,hopmax_x + rvecind=rvecind+1 + IF (rvecind > rvecnum)& + CALL juDFT_error ('mismatch in number of kpoints',& + calledby="wann_postproc") + + rvec(1,rvecind)=r1 + rvec(2,rvecind)=r2 + rvec(3,rvecind)=r3 + ENDDO !r1 + ENDDO !r2 + ENDDO !r3 + ELSE !determine optimal r-mesh + CALL wann_wigner_seitz(& + .TRUE.,num,cell%amat,0,& + rvecnum,rvec,ndegen) + ALLOCATE(rvec(3,rvecnum)) + ALLOCATE(ndegen(rvecnum)) + CALL wann_wigner_seitz(& + .FALSE.,num,cell%amat,rvecnum,& + int_dummy,rvec,ndegen) + + OPEN(333,file='wig_vectors',recl=1000) + DO ii=1,rvecnum + WRITE(333,*)ii,rvec(1,ii),rvec(2,ii),rvec(3,ii),& + ndegen(ii) + ENDDO + CLOSE(333) + + ENDIF + + ENDIF + + IF(wann%l_hopping.AND.mpi%irank==0) THEN + CALL wann_hopping(& + rvecnum,rvec,kpoints,& + input%jspins,fullnkpts,wann%l_bzsym,input%film,oneD%odi%d1,& + l_nocosoc,wann%band_min,wann%band_max,& + DIMENSION%neigd,wann%l_socmmn0,wann%l_ndegen,ndegen,& + wann%wan90version,wann%l_unformatted) + ENDIF + + IF(wann%l_nablars.AND.mpi%irank==0) THEN + CALL wann_nabla_rs(& + rvecnum,rvec,kpoints,& + input%jspins,fullnkpts,wann%l_bzsym,input%film,oneD%odi%d1,& + noco%l_soc,wann%band_min,wann%band_max,& + DIMENSION%neigd,.FALSE.,& + wann%wan90version) + ENDIF + + IF(wann%l_orbcomprs.AND.mpi%irank==0)THEN + num_angl=9 + IF(wann%l_oc_f)num_angl=16 + CALL wann_fft5(& + .FALSE.,& + num_angl,wann%oc_num_orbs,& + 'WF1.orbcomp','orbcomp.1',& + rvecnum,rvec,kpoints,& + 1,fullnkpts,input%film,& + noco%l_soc,wann%band_min,wann%band_max,DIMENSION%neigd,& + wann%wan90version) + IF( input%jspins.EQ.2 )THEN + spinspin=2 + IF(noco%l_soc.OR.noco%l_noco)spinspin=1 + CALL wann_fft5(& + .FALSE.,& + num_angl,wann%oc_num_orbs,& + 'WF2.orbcomp','orbcomp.2',& + rvecnum,rvec,kpoints,& + spinspin,fullnkpts,input%film,& + noco%l_soc,wann%band_min,wann%band_max,DIMENSION%neigd,& + wann%wan90version) + ENDIF + ENDIF + + IF(wann%l_rmat)THEN + CALL wann_rmat(& + cell%bmat,cell%amat,& + rvecnum,rvec,kpoints,& + input%jspins,fullnkpts,wann%l_bzsym,input%film,oneD%odi%d1,& + l_nocosoc,wann%band_min,wann%band_max,& + DIMENSION%neigd,.FALSE.,wann%wan90version) + ENDIF + + + IF(wann%l_anglmomrs.AND.mpi%irank==0)THEN + CALL wann_fft4(& + 'WF1.anglmom',& + 'anglmomrs.1',.FALSE.,& + rvecnum,rvec,kpoints,& + input%jspins,fullnkpts,wann%l_bzsym,input%film,oneD%odi%d1,& + noco%l_soc,wann%band_min,wann%band_max,DIMENSION%neigd,& + .FALSE.,wann%wan90version) + ENDIF + +#ifdef CPP_TOPO + IF(wann%l_offdiposoprs.AND.mpi%irank==0)THEN + CALL wann_offdiposop_rs(& + rvecnum,rvec,kpoints,& + input%jspins,fullnkpts,wann%l_bzsym,input%film,oneD%odi%d1,& + noco%l_soc,wann%band_min,wann%band_max,DIMENSION%neigd,& + .FALSE.) + ENDIF + + IF(wann%l_spindisprs.AND.mpi%irank==0)THEN + CALL wann_fft5(& + rvecnum,rvec,kpoints,& + input%jspins,fullnkpts,wann%l_bzsym,input%film,oneD%odi%d1,& + noco%l_soc,wann%band_min,wann%band_max,DIMENSION%neigd,& + .FALSE.) + ENDIF + + IF(wann%l_perturbrs.AND.mpi%irank==0)THEN + CALL wann_fft3(& + 'WF1.perturb' ,'perturbrs.1' ,.FALSE.,& + rvecnum,rvec,kpoints,& + input%jspins,fullnkpts,wann%l_bzsym,input%film,oneD%odi%d1,& + noco%l_soc,wann%band_min,wann%band_max,DIMENSION%neigd,& + .FALSE.) + ENDIF + + IF(wann%l_socspicomrs.AND.mpi%irank==0)THEN + IF(noco%l_soc)THEN + CALL wann_fft4(& + 'WF1.socspicom','socspicomrs.1',.TRUE.,& + rvecnum,rvec,kpoints,& + input%jspins,fullnkpts,wann%l_bzsym,input%film,oneD%odi%d1,& + noco%l_soc,wann%band_min,wann%band_max,DIMENSION%neigd,& + .FALSE.) + ELSE + CALL wann_fft6(& + rvecnum,rvec,kpoints,& + input%jspins,fullnkpts,wann%l_bzsym,input%film,oneD%odi%d1,& + noco%l_soc,wann%band_min,wann%band_max,DIMENSION%neigd,& + .FALSE.) + ENDIF + ENDIF + + + + IF(wann%l_torquers.AND.mpi%irank==0) THEN + CALL wann_torque_rs(& + atoms%ntype,atoms%neq,rvecnum,rvec,kpoints,& + input%jspins,fullnkpts,wann%l_bzsym,input%film,oneD%odi%d1,& + noco%l_soc,wann%band_min,wann%band_max,& + DIMENSION%neigd,.FALSE.) + ENDIF +#endif + IF (wann%l_nablapaulirs.AND.mpi%irank==0)THEN + CALL wann_nabla_pauli_rs(& + rvecnum,rvec,kpoints,& + input%jspins,fullnkpts,wann%l_bzsym,input%film,oneD%odi%d1,& + noco%l_soc,wann%band_min,wann%band_max,& + DIMENSION%neigd,.FALSE.,wann%wan90version) + ENDIF + + IF (wann%l_pauli.AND.mpi%irank==0)THEN + CALL wann_pauli_rs(& + rvecnum,rvec,kpoints,& + input%jspins,fullnkpts,wann%l_bzsym,input%film,oneD%odi%d1,& + l_nocosoc,wann%band_min,wann%band_max,& + DIMENSION%neigd,.FALSE.,wann%l_ndegen,ndegen,& + wann%wan90version,wann%l_unformatted) + ENDIF + + IF (wann%l_perpmagrs.AND.mpi%irank==0)THEN + CALL wann_perpmag_rs(& + rvecnum,rvec,kpoints,& + input%jspins,fullnkpts,wann%l_bzsym,input%film,oneD%odi%d1,& + noco%l_soc,wann%band_min,wann%band_max,& + DIMENSION%neigd,.FALSE.,wann%l_ndegen,ndegen,wann%wan90version,& + wann%l_unformatted) + ENDIF + + IF (wann%l_socmatrs.AND.mpi%irank==0)THEN + CALL wann_socmat_rs(& + rvecnum,rvec,kpoints,& + input%jspins,fullnkpts,wann%l_bzsym,input%film,oneD%odi%d1,& + noco%l_soc,wann%band_min,wann%band_max,& + DIMENSION%neigd,.FALSE.,wann%wan90version) + ENDIF + + IF(wann%l_plot_umdat)THEN + CALL wann_plot_um_dat(& + DIMENSION,stars,vacuum,atoms,sphhar,input,sym,mpi,& + lapw,oneD,noco,cell,vTot,enpara,eig_id,l_real,& + mpi%mpi_comm,i,wann%band_min,wann%band_max,noco%l_soc,& + atoms%l_dulo,noco%l_noco,noco%l_ss,atoms%lmaxd,atoms%ntype,& + DIMENSION%neigd,atoms%nat,sym%nop,DIMENSION%nvd,input%jspins,DIMENSION%nbasfcn,atoms%llod,atoms%nlod,atoms%ntype,& + cell%omtil,atoms%nlo,atoms%llo,atoms%lapw_l,sym%invtab,sym%mrot,atoms%ngopr,atoms%neq,atoms%lmax,& + atoms%invsat,sym%invsatnr,kpts%nkpt,atoms%taual,atoms%rmt,cell%amat,cell%bmat,cell%bbmat,noco%alph,& + noco%beta,noco%qss,stars%sk2,stars%phi2,oneD%odi,oneD%ods,mpi%irank,mpi%isize,stars%ng3,vacuum%nmzxyd,vacuum%nmzd,& + SIZE(atoms%rmsh,1),sphhar%nlhd,stars%ng3,vacuum%nvac,sym%invs,sym%invs2,input%film,sphhar%nlh,atoms%jri,sphhar%ntypsd,& + atoms%ntypsy,input%jspins,kpts%nkpt,atoms%dx,stars%ng2,atoms%rmsh,sliceplot%e1s,sliceplot%e2s,atoms%ulo_der,& + stars%ustep,stars%ig,stars%mx1,stars%mx2,stars%mx3,stars%rgphs,sliceplot%slice,sliceplot%kk,sliceplot%nnne,& + cell%z1,DIMENSION%nv2d,vacuum%nmzxy,vacuum%nmz,vacuum%delz,stars%ig2,cell%area,sym%tau,atoms%zatom,stars%ng2,sym%nop2,& + cell%volint,sym%symor,atoms%pos,ef,wann%l_bzsym,wann%l_proj_plot,& + wann%wan90version) + ENDIF + + + CALL CPU_TIME(delta2) + IF(wann%l_lapw.AND.mpi%irank==0)THEN + CALL wannier_to_lapw(& + mpi%mpi_comm,eig_id,l_real,& + input,lapw,oneD,noco,sym,cell,atoms,stars,vacuum,sphhar,& + vTot,& + noco%l_soc,wann%unigrid,i,wann%band_min,wann%band_max,& + atoms%l_dulo,noco%l_noco,noco%l_ss,atoms%lmaxd,atoms%ntype,& + DIMENSION%neigd,atoms%nat,sym%nop,DIMENSION%nvd,input%jspins,DIMENSION%nbasfcn,atoms%llod,atoms%nlod,atoms%ntype,& + cell%omtil,atoms%nlo,atoms%llo,atoms%lapw_l,sym%invtab,sym%mrot,atoms%ngopr,atoms%neq,atoms%lmax,& + atoms%invsat,sym%invsatnr,kpts%nkpt,atoms%taual,atoms%rmt,cell%amat,cell%bmat,cell%bbmat,noco%alph,& + noco%beta,noco%qss,stars%sk2,stars%phi2,oneD%odi,oneD%ods,mpi%irank,mpi%isize,stars%ng3,vacuum%nmzxyd,vacuum%nmzd,& + SIZE(atoms%rmsh,1),sphhar%nlhd,stars%ng3,vacuum%nvac,sym%invs,sym%invs2,input%film,sphhar%nlh,atoms%jri,sphhar%ntypsd,& + atoms%ntypsy,input%jspins,kpts%nkpt,atoms%dx,stars%ng2,atoms%rmsh,sliceplot%e1s,sliceplot%e2s,atoms%ulo_der,& + stars%ustep,stars%ig,stars%mx1,stars%mx2,stars%mx3,stars%rgphs,sliceplot%slice,sliceplot%kk,sliceplot%nnne,& + cell%z1,DIMENSION%nv2d,vacuum%nmzxy,vacuum%nmz,vacuum%delz,stars%ig2,cell%area,sym%tau,atoms%zatom,stars%ng2,sym%nop2,& + cell%volint,sym%symor,atoms%pos,ef,wann%l_bzsym,wann%l_proj_plot,& + wann%wan90version) + ENDIF + + IF(wann%l_lapw_kpts)THEN +#ifdef DCPP_WANN_EXT + CALL wannier_to_lapw_kpts(& + unigrid,i,wann%band_min,wann%band_max,& + atoms%l_dulo,noco%l_noco,noco%l_ss,atoms%lmaxd,atoms%ntype,& + DIMENSION%neigd,atoms%nat,sym%nop,DIMENSION%nvd,input%jspins,DIMENSION%nbasfcn,atoms%llod,atoms%nlod,atoms%ntype,& + nwdd,cell%omtil,atoms%nlo,atoms%llo,atoms%lapw_l,sym%invtab,sym%mrot,atoms%ngopr,atoms%neq,atoms%lmax,& + atoms%invsat,sym%invsatnr,kpts%nkpt,atoms%taual,atoms%rmt,cell%amat,cell%bmat,cell%bbmat,noco%alph,& + noco%beta,noco%qss,stars%sk2,stars%phi2,oneD%odi,oneD%ods,mpi%irank,mpi%isize,stars%ng3,vacuum%nmzxyd,vacuum%nmzd,& + SIZE(atoms%rmsh,1),sphhar%nlhd,stars%ng3,vacuum%nvac,sym%invs,sym%invs2,input%film,sphhar%nlh,atoms%jri,sphhar%ntypsd,& + atoms%ntypsy,input%jspins,kpts%nkpt,atoms%dx,stars%ng2,atoms%rmsh,sliceplot%e1s,sliceplot%e2s,atoms%ulo_der,& + stars%ustep,stars%ig,stars%mx1,stars%mx2,stars%mx3,stars%rgphs,sliceplot%slice,sliceplot%kk,sliceplot%nnne,& + cell%z1,DIMENSION%nv2d,vacuum%nmzxy,vacuum%nmz,vacuum%delz,stars%ig2,cell%area,sym%tau,atoms%zatom,stars%ng2,sym%nop2,& + cell%volint,sym%symor,atoms%pos,ef,wann%l_bzsym,wann%l_proj_plot,irecl) +#else + CALL juDFT_error("not yet tested in this release",calledby& + ="wann_postproc") +#endif + ENDIF + IF(wann%l_lapw_gfleur)THEN +#ifdef DCPP_WANN_EXT + CALL wannier_lapw_gfleur(& + gfthick,gfcut,i,wann%band_min,wann%band_max,& + atoms%l_dulo,noco%l_noco,noco%l_ss,atoms%lmaxd,atoms%ntype,& + DIMENSION%neigd,atoms%nat,sym%nop,DIMENSION%nvd,input%jspins,DIMENSION%nbasfcn,atoms%llod,atoms%nlod,atoms%ntype,& + nwdd,cell%omtil,atoms%nlo,atoms%llo,atoms%lapw_l,sym%invtab,sym%mrot,atoms%ngopr,atoms%neq,atoms%lmax,& + atoms%invsat,sym%invsatnr,kpts%nkpt,atoms%taual,atoms%rmt,cell%amat,cell%bmat,cell%bbmat,noco%alph,& + noco%beta,noco%qss,stars%sk2,stars%phi2,oneD%odi,oneD%ods,mpi%irank,mpi%isize,stars%ng3,vacuum%nmzxyd,vacuum%nmzd,& + SIZE(atoms%rmsh,1),sphhar%nlhd,stars%ng3,vacuum%nvac,sym%invs,sym%invs2,input%film,sphhar%nlh,atoms%jri,sphhar%ntypsd,& + atoms%ntypsy,input%jspins,kpts%nkpt,atoms%dx,stars%ng2,atoms%rmsh,sliceplot%e1s,sliceplot%e2s,atoms%ulo_der,& + stars%ustep,stars%ig,stars%mx1,stars%mx2,stars%mx3,stars%rgphs,sliceplot%slice,sliceplot%kk,sliceplot%nnne,& + cell%z1,DIMENSION%nv2d,vacuum%nmzxy,vacuum%nmz,vacuum%delz,stars%ig2,cell%area,sym%tau,atoms%zatom,stars%ng2,sym%nop2,& + cell%volint,sym%symor,atoms%pos,ef,wann%l_bzsym,wann%l_proj_plot,irecl) +#else + CALL juDFT_error("not yet tested in this release",calledby& + ="wann_postproc") +#endif + ENDIF + + CALL CPU_TIME(delta3) + time_lapw_expand=delta3-delta2 + + CALL CPU_TIME(delta2) + IF(wann%l_plot_lapw.AND.mpi%irank==0)THEN + CALL juDFT_error("not yet tested in this release",calledby& + ="wann_postproc") + ! call wann_plot_from_lapw( + ! > dimension%nv2d,input%jspins,oneD%odi,oneD%ods,stars%ng3,vacuum%nmzxyd,stars%ng2, + ! > sphhar%ntypsd, + ! > atoms%ntype,atoms%lmaxd,size(atoms%rmsh,1),atoms%nat,vacuum%nmzd,atoms%neq,stars%ng3,vacuum%nvac, + ! > vacuum%nmz,vacuum%nmzxy,stars%ng2,sym%nop,sym%nop2,cell%volint,input%film,sliceplot%slice,sym%symor, + ! > sym%invs,sym%invs2,cell%z1,vacuum%delz,atoms%ngopr,atoms%ntypsy,atoms%jri,atoms%pos,atoms%zatom, + ! > atoms%lmax,sym%mrot,sym%tau,atoms%rmsh,sym%invtab,cell%amat,cell%bmat,cell%bbmat,sliceplot%nnne,sliceplot%kk, + ! > atoms%nlod,atoms%llod,lmd,cell%omtil,atoms%nlo,atoms%llo) + ENDIF + CALL CPU_TIME(delta3) + time_lapw_plot=delta3-delta2 + + WRITE(6,*)"time_lapw_expand=",time_lapw_expand + WRITE(6,*)"time_lapw_plot=",time_lapw_plot + + IF(wann%l_finishnocoplot.AND.mpi%irank==0) THEN + ! write(*,*)'doing the UNK mixing' + ! write(*,*)'noco%alph',noco%alph + ! write(*,*)'noco%beta',noco%beta + ! nkqpts=fullnkpts + ! if(l_sgwf) nkqpts=fullnkpts*fullnqpts + CALL wann_nocoplot(atoms,sliceplot%slice,sliceplot%nnne,&!nslibd& + cell%amat,cell%bmat,fullnkpts,oneD%odi,input%film,& + atoms%nat,atoms%ntype,SIZE(atoms%rmsh,1),atoms%ntype,atoms%neq,atoms%pos,& + atoms%jri,atoms%rmsh,noco%alph,noco%beta,fullnqpts,noco%qss,& + cell%z1,atoms%zatom) + ENDIF + + END SUBROUTINE wann_postproc +END MODULE m_wann_postproc diff --git a/wannier/wann_updown.F b/wannier/wann_updown.F index e23544abecae11b4289b187500c2ffd622573204..ae54cab918cdc64675458662ed462b0cfe216e7d 100644 --- a/wannier/wann_updown.F +++ b/wannier/wann_updown.F @@ -847,11 +847,9 @@ c...for the lapws and local orbitals, summed by the basis functions + bcof(1:,0:,1:,jspin),ccof(-llod:,1:,1:,1:,jspin), + zMat(jspin)) - call wann_abinv( - > ntypd,natd,noccbd,lmaxd,lmd,llod,nlod,ntype,neq, - > noccbd,lmax,nlo,llo,invsat,invsatnr,bkpt,taual, - X acof(1,0,1,jspin),bcof(1,0,1,jspin), - < ccof(-llod,1,1,1,jspin)) + call wann_abinv(atoms, + X acof(:,0:,:,jspin),bcof(:,0:,:,jspin), + < ccof(-llod:,:,:,:,jspin)) enddo !jspin DEALLOCATE(lapw%k1,lapw%k2,lapw%k3) diff --git a/wannier/wannier.F b/wannier/wannier.F deleted file mode 100644 index 7f0d1eb17439343a91a455cae7e7fcedf27a6579..0000000000000000000000000000000000000000 --- a/wannier/wannier.F +++ /dev/null @@ -1,2870 +0,0 @@ -!-------------------------------------------------------------------------------- -! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany -! This file is part of FLEUR and available as free software under the conditions -! of the MIT license as expressed in the LICENSE file in more detail. -!-------------------------------------------------------------------------------- - - MODULE m_wannier - use m_juDFT - CONTAINS - SUBROUTINE wannier( - > DIMENSION,mpi,input,kpts,sym,atoms,stars,vacuum,sphhar,oneD, - > wann,noco,cell,enpara,banddos,sliceplot,vTot,results, - > eig_idList,l_real,nkpt) -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c Makes necessary for the construction of the wannier functions -c (W90: Yates, Mostofi, Marzari, Souza, Vanderbilt '06 f90 code) -c ab initio preliminaries: constructs the overlaps of the periodic -c parts of the wavefunctions and the projections of the -c wavefunctions -c onto a set of starting wfs, i.e. atomic-like orbitals. -c YM 06 -c Mmn(k,b) = , u being a periodic part -c of the wavefunction psi_nk -c A_mn^k = , where g_n is a trial orbital -c which are written into the files 'WF1.mmn' and 'WF1.amn' -c Marzari Vanderbilt PRB 56,12847(1997) -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c Parallelization, Optionals, Symmetry, Noco&Soc: -c Frank Freimuth -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c The routine reads the bkpts file, which contains the following -c information: -c 1st line: nntot (INT) - number of the nearest neighbors for -c each k-point in the MP mesh -c 2-nkpts*nntot lines containing 5 integers i1,i2,i3,i4,i5: -c i1 - the number of the k-point in the kpts file -c i2 - number of the k-point, which is a periodic image of -c k+b in the 1st BZ -c i3-i5 - coordinates of the G-vector, connecting k-point -c i2 with the actual k+b k-point -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c In general, the number of bands for each k-poin t is -c different: N(k), and also differs from the number of bands -c we are interested in: N (for instance 5 d-bands of Cu among -c the 6 s- and d-bands). While matrices Mmn(k) are square -c for each k-point, matrices Mmn(k,b) can be made so after -c defining the maximum number of bands max(N(k)). -c The matrix Amn is non-diagonal by default (N(k)*N). -cccccc ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c Total number of wannier functions: nwfs -c -c sliceplot%e1s,sliceplot%e2s: lower and upper boundaries of the energy window: -c Needed for sorting by number and sorting by energy. -c Not needed for sorting by index. -ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c Extension to case of higher-dimensional Wannier functions -c according to the formalism in PRB 91, 184413 (2015) -c Jan-Philipp Hanke -ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - use m_types - use m_wann_mmnk_symm - use m_wann_rw_eig - use m_abcof - use m_radfun - use m_radflo - use m_cdnread - use m_constants - use m_wann_mmk0_od_vac - use m_wann_mmkb_od_vac - use m_wann_mmk0_vac - use m_wann_mmkb_vac - use m_wann_updown - use m_wann_mmk0_sph - use m_wann_ujugaunt - use m_wann_mmkb_sph - use m_wann_projmethod - use m_wann_amn - use m_wann_abinv - use m_wann_kptsrotate - use m_wann_plot - use m_wann_read_inp - use m_wann_plot_symm - use m_wann_mmkb_int - use m_wann_postproc - use m_matmul,only : matmul3,matmul3r - use m_wann_write_mmnk - use m_wann_write_amn - use m_wann_write_nabla - use m_vsoc - use m_wann_write_matrix4 - use m_wann_write_matrix5 - use m_wann_orbcomp - use m_wann_anglmom -#ifdef CPP_TOPO - use m_wann_surfcurr - use m_wann_surfcurr_int2 - use m_wann_nabla - use m_wann_nabla_vac - use m_wann_soc_to_mom -#endif - use m_wann_gwf_tools, only : get_index_kq, gwf_plottemplate - use m_wann_gwf_commat - use m_wann_gwf_anglmom - use m_wann_write_mmnk2 - use m_wann_uHu - use m_wann_uHu_dmi - USE m_eig66_io - - IMPLICIT NONE -#include "cpp_double.h" -#ifdef CPP_MPI - include 'mpif.h' - integer ierr(3) - integer cpu_index - integer stt(MPI_STATUS_SIZE) -#endif - - TYPE(t_dimension), INTENT(IN) :: DIMENSION - TYPE(t_mpi), INTENT(IN) :: mpi - TYPE(t_input), INTENT(IN) :: input - TYPE(t_kpts), INTENT(IN) :: kpts - TYPE(t_sym), INTENT(IN) :: sym - TYPE(t_atoms), INTENT(IN) :: atoms - TYPE(t_stars), INTENT(IN) :: stars - TYPE(t_vacuum), INTENT(IN) :: vacuum - TYPE(t_sphhar), INTENT(IN) :: sphhar - TYPE(t_oneD), INTENT(IN) :: oneD - TYPE(t_noco), INTENT(IN) :: noco - TYPE(t_cell), INTENT(IN) :: cell - TYPE(t_enpara), INTENT(IN) :: enpara - TYPE(t_banddos), INTENT(IN) :: banddos - TYPE(t_sliceplot), INTENT(IN) :: sliceplot - TYPE(t_potden), INTENT(IN) :: vTot - TYPE(t_results), INTENT(IN) :: results - TYPE(t_wann), INTENT(INOUT) :: wann - - logical, intent (in) :: l_real - integer, intent (in) :: nkpt - INTEGER, INTENT (IN) :: eig_idList(wann%nparampts) - -cccccccccccccccccc local variables cccccccccccccccccccc - integer :: lmd,nlotot,n,nmat,iter,ikpt,ikpt_b,nmat_b, pc - integer :: addnoco,funbas,loplod,addnoco2,igvm2,eig_id - integer :: noccbd,noccbd_b,nn,nkpts,i,jspin,j,l,i_rec,m,nwf,nwfp - integer :: jsp_start,jsp_end,nrec,nrec1,nrec_b,nbands,nbands_b - integer :: nodeu,noded,n_size,na,n_rank,nbnd,numbands - integer :: i1,i2,i3,in,lda - integer :: n_bands(0:DIMENSION%neigd),nslibd,nslibd_b - character(len=8) :: dop,iop,name(10) - real :: bkpt(3),bkpt_b(3),sfp,tpi,wronk,phase - complex :: c_phase - real :: eig(DIMENSION%neigd),eig_b(DIMENSION%neigd),cp_time(9) - real :: efermi - logical :: l_p0,l_bkpts,l_proj,l_amn,l_mmn -!!! energy window boundaries - integer, allocatable :: kveclo(:),nv(:) - integer, allocatable :: kveclo_b(:),nv_b(:) - integer, allocatable :: k1(:,:),k2(:,:),k3(:,:) - integer, allocatable :: k1_b(:,:),k2_b(:,:),k3_b(:,:) - INTEGER, ALLOCATABLE :: innerEig_idList(:) - real, allocatable :: we(:),we_b(:) - - real, allocatable :: eigg(:) - real kpoints(nkpt) -!!! a and b coeff. constructed for each k-point - complex, allocatable :: acof(:,:,:),acof_b(:,:,:) - complex, allocatable :: bcof(:,:,:),bcof_b(:,:,:) - complex, allocatable :: ccof(:,:,:,:),ccof_b(:,:,:,:) -!!! the parameters for the number of wfs - integer :: nwfs -!!! the potential in the spheres and the vacuum - real, allocatable :: vr(:,:,:),vz(:,:,:) -!!! auxiliary potentials - complex, allocatable :: vpw(:,:) -!!! bkpts data - integer nntot,ikpt_help - integer, allocatable :: gb(:,:,:),bpt(:,:) -!!! radial wavefunctions in the muffin-tins and more ... - real, allocatable :: flo(:,:,:,:,:),vso(:,:,:) - real, allocatable :: ff(:,:,:,:,:),gg(:,:,:,:,:) - - real :: uuilon(atoms%nlod,atoms%ntype) - real :: duilon(atoms%nlod,atoms%ntype) - real :: ulouilopn(atoms%nlod,atoms%nlod,atoms%ntype) - !!! the Mmn matrices - complex, allocatable :: mmnk(:,:,:,:),mmn(:,:,:) - complex, allocatable :: amn(:,:,:),nablamat(:,:,:,:) - complex, allocatable :: soctomom(:,:,:,:) - complex, allocatable :: surfcurr(:,:,:,:) - complex, allocatable :: socmmn(:,:,:) - complex, allocatable :: a(:) - complex, allocatable :: psiw(:,:,:) - complex, allocatable :: anglmom(:,:,:,:) - complex, allocatable :: orbcomp(:,:,:,:,:) -c..wf-hamiltonian in real space (hopping in the same unit cell) - complex, allocatable :: hwfr(:,:),hwfr2(:,:) -c real, allocatable :: ei(:) - complex, allocatable :: work(:) - real,allocatable::centers(:,:,:) - logical :: l_file - logical :: l_amn2, l_conjugate - character(len=3) :: spin12(2) - data spin12/'WF1' , 'WF2'/ - character(len=30) :: task - integer,allocatable::irreduc(:) - integer,allocatable::mapkoper(:) - integer :: fullnkpts,kpt,kptibz,kptibz_b,j1,j2,j3,oper,oper_b,k - real :: bkrot(3),dirfacs(3) - integer :: ios,kplot,kplotoper,plotoper,gfcut - complex :: phasust - integer,allocatable::pair_to_do(:,:) - integer :: ngopr1(atoms%nat) - integer,allocatable::maptopair(:,:,:) - integer :: wannierspin,jspin2,jspin7,jspin2_b - real, allocatable :: rwork(:) - real,allocatable::kdiff(:,:) - integer,allocatable :: shiftkpt(:,:) - integer :: unigrid(6),gfthick - complex,allocatable::ujug(:,:,:,:),ujdg(:,:,:,:) - complex,allocatable::djug(:,:,:,:),djdg(:,:,:,:) - complex,allocatable::ujulog(:,:,:,:,:) - complex,allocatable::djulog(:,:,:,:,:) - complex,allocatable::ulojug(:,:,:,:,:) - complex,allocatable::ulojdg(:,:,:,:,:) - complex,allocatable::ulojulog(:,:,:,:,:,:) - real delta,delta1,time_interstitial,time_mmn - real time_total,delta2,delta3 - real time_lapw_expand,time_rw,time_symm,time_film - real time_lapw_plot,time_ujugaunt,time_abcof - integer :: n_start,n_end,mlotot,mlolotot,err - integer :: mlot_d,mlolot_d,ilo,dir,length - character(len=2) :: spin012(0:2) - data spin012/' ', '.1', '.2'/ - character(len=6) :: filename - real :: arg,hescale - complex :: nsfactor,nsfactor_b,value - real :: b1(3),b2(3) - real,parameter :: bohrtocm=0.529177e-8 - real,parameter :: condquant=7.7480917e-5 - integer :: npotmatfile,ig3,maxvac,irec,imz,ivac,ipot - logical :: l_orbcompinp - integer :: num_angl - complex,allocatable :: vxy(:,:,:) - - -c---->gwf - - ! FURTHER VARIABLES - real :: qpt_i(3),qptb_i(3) - real :: alph_i(atoms%ntype),alphb_i(atoms%ntype) - real :: beta_i(atoms%ntype),betab_i(atoms%ntype) - real :: theta_i, thetab_i, phi_i, phib_i - real :: dalph,db1,db2,coph,siph - real :: zero_taual(3,atoms%nat),bqpt(3) - real :: tt1,tt2,tt3,tt4,tt5,tt6,t_it,t_kov,t_qov - real :: eig_qb(DIMENSION%neigd) - - real,allocatable :: qdiff(:,:), we_qb(:) - real,allocatable :: energies(:,:,:) - real,allocatable :: zero_qdiff(:,:) - - - integer,allocatable :: irreduc_q(:),mapqoper(:) - integer,allocatable :: shiftqpt(:,:),pair_to_do_q(:,:) - integer,allocatable :: maptopair_q(:,:,:) - integer,allocatable :: gb_q(:,:,:),bpt_q(:,:) - integer,allocatable :: k1_qb(:,:),k2_qb(:,:),k3_qb(:,:) - integer,allocatable :: kveclo_qb(:),nv_qb(:) - - integer :: nntot_q = 1 - integer :: fullnqpts = 1 - integer :: funit_start = 5000 - integer :: qptibz, qptibz_b, oper_q, oper_qb - integer :: qpt,iqpt_help, iqpt, iqpt_b - integer :: nbands_qb, nmat_qb, nslibd_qb, noccbd_qb - integer :: sign_q = 1,band_help - integer :: doublespin,jspin_b,jspin3,jspin4,jspin5 - integer :: doublespin_max,nrec5 - integer :: count_i,count_j - integer :: aoff,d1,d10,d100 - integer :: n1,n2,ii,jj - - complex :: interchi,vacchi,amnchi - complex :: phasfac,phasfac2,cmplx_1 - - complex,allocatable :: chi(:) - complex,allocatable :: acof_qb(:,:,:) - complex,allocatable :: bcof_qb(:,:,:) - complex,allocatable :: ccof_qb(:,:,:,:) - complex,allocatable :: mmnk_q(:,:,:,:) - complex,allocatable :: m_int(:,:,:,:) - complex,allocatable :: m_sph(:,:,:,:) - complex,allocatable :: m_vac(:,:,:,:) - complex,allocatable :: ujug_q(:,:,:,:),ujdg_q(:,:,:,:) - complex,allocatable :: djug_q(:,:,:,:),djdg_q(:,:,:,:) - complex,allocatable :: ujulog_q(:,:,:,:,:) - complex,allocatable :: djulog_q(:,:,:,:,:) - complex,allocatable :: ulojug_q(:,:,:,:,:) - complex,allocatable :: ulojdg_q(:,:,:,:,:) - complex,allocatable :: ulojulog_q(:,:,:,:,:,:) - - character(len=12) tmp_filename,fending - character(len=30) fname,fstart,eigfile - - logical :: l_bqpts,l_gwf,l_nochi - - TYPE(t_usdus) :: usdus - TYPE(t_mat) :: zMat, zzMat, zMat_b, zMat_qb - TYPE(t_lapw) :: lapw, lapw_b, lapw_qb - TYPE(t_wann) :: wannTemp - - eig_id = eig_idList(1) - -c---- mpi,input,sym,atoms,stars,vacuum,sphhar,oneD,noco,cell,vTot, - > enpara,eig_idList(1),l_real, - > mpi%mpi_comm,atoms%l_dulo,noco%l_noco,noco%l_ss, - > atoms%lmaxd,atoms%ntype,DIMENSION%neigd,atoms%nat,sym%nop, - > DIMENSION%nvd,input%jspins,DIMENSION%nbasfcn,atoms%llod, - > atoms%nlod,atoms%ntype,cell%omtil,atoms%nlo,atoms%llo, - > atoms%lapw_l,sym%invtab,sym%mrot,atoms%ngopr,atoms%neq, - > atoms%lmax,atoms%invsat,sym%invsatnr,nkpt,atoms%taual, - > atoms%rmt,cell%amat,cell%bmat,cell%bbmat,noco%alph, - > noco%beta,noco%qss, ! TODO: adapt if needed - > stars%sk2,stars%phi2,oneD%odi,oneD%ods,mpi%irank,mpi%isize, - > stars%ng3, - > vacuum%nmzxyd,vacuum%nmzd,atoms%jmtd,sphhar%nlhd,stars%ng3, - > vacuum%nvac,sym%invs,sym%invs2,input%film,sphhar%nlh, - > atoms%jri,sphhar%ntypsd,atoms%ntypsy,input%jspins,nkpt, - > atoms%dx,stars%ng2,atoms%rmsh,sliceplot%e1s,sliceplot%e2s, - > atoms%ulo_der,stars%ustep,stars%ig,stars%mx1, - > stars%mx2,stars%mx3,stars%rgphs, - > sliceplot%slice,sliceplot%kk,sliceplot%nnne,cell%z1, - > DIMENSION%nv2d,vacuum%nmzxy,vacuum%nmz,vacuum%delz, - > stars%ig2,cell%area,sym%tau,atoms%zatom,stars%ng2,sym%nop2, - > cell%volint,sym%symor,atoms%pos,results%ef,noco%l_soc, - > sphhar%memd,atoms%lnonsph,sphhar%clnu,DIMENSION%lmplmd, - > sphhar%mlh,sphhar%nmem,sphhar%llh,atoms%lo1l, - > noco%theta,noco%phi) - - DO pc = 1, wann%nparampts - CALL close_eig(eig_idList(pc)) - END DO - - CALL juDFT_end("updown done",mpi%irank) - endif - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c modern theory of orbital magnetization from Wannier functions -c Jan-Philipp Hanke -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - if(wann%l_matrixuHu)then - wannTemp = wann - call wann_uHu( - > DIMENSION,stars,vacuum,atoms,sphhar,input,kpts,sym,mpi, - > banddos,oneD,noco,cell,vTot,wannTemp,eig_idList, - > l_real,atoms%l_dulo,noco%l_noco,noco%l_ss,atoms%lmaxd, - > atoms%ntype,DIMENSION%neigd,atoms%nat,sym%nop,DIMENSION%nvd, - > input%jspins,DIMENSION%nbasfcn,atoms%llod,atoms%nlod, - > atoms%ntype,cell%omtil,atoms%nlo,atoms%llo, - > atoms%lapw_l,sym%invtab,sym%mrot,atoms%ngopr,atoms%neq, - > atoms%lmax,atoms%invsat,sym%invsatnr,nkpt,atoms%taual, - > atoms%rmt,cell%amat,cell%bmat,cell%bbmat,noco%alph, - > noco%beta,noco%qss,stars%sk2,stars%phi2,oneD%odi,oneD%ods, - > mpi%irank, - > mpi%isize,stars%ng3,vacuum%nmzxyd,vacuum%nmzd,atoms%jmtd, - > sphhar%nlhd,stars%ng3,vacuum%nvac,sym%invs,sym%invs2, - > input%film,sphhar%nlh,atoms%jri,sphhar%ntypsd,atoms%ntypsy, - > input%jspins,nkpt,atoms%dx,stars%ng2,atoms%rmsh, - > sliceplot%e1s,sliceplot%e2s,atoms%ulo_der,stars%ustep, - > stars%ig,stars%mx1,stars%mx2,stars%mx3, - > stars%rgphs,sliceplot%slice, - > sliceplot%kk,sliceplot%nnne,cell%z1,DIMENSION%nv2d, - > vacuum%nmzxy,vacuum%nmz,vacuum%delz,sym%zrfs,stars%ig2, - > cell%area,sym%tau,atoms%zatom,stars%ng2,stars%kv2,sym%nop2, - > cell%volint,sym%symor,atoms%pos,results%ef,noco%l_soc, - > sphhar%memd,atoms%lnonsph,sphhar%clnu,DIMENSION%lmplmd, - > sphhar%mlh,sphhar%nmem,sphhar%llh,atoms%lo1l, - > noco%theta,noco%phi, - > wann%l_ms,wann%l_sgwf,wann%l_socgwf,wann%aux_latt_const, - > wann%param_file,wann%param_vec,wann%nparampts, - > wann%param_alpha,wann%l_dim) - - DO pc = 1, wann%nparampts - CALL close_eig(eig_idList(pc)) - END DO - - CALL juDFT_end("wann_uHu done",mpi%irank) - endif - -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -c modern theory of DMI from higher-dimensional Wannier functions -c Jan-Philipp Hanke -cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - if(wann%l_matrixuHu_dmi)then - wannTemp = wann - call wann_uHu_dmi( - > DIMENSION,stars,vacuum,atoms,sphhar,input,kpts,sym,mpi, - > banddos,oneD,noco,cell,vTot,wannTemp,eig_idList, - > l_real,atoms%l_dulo,noco%l_noco,noco%l_ss,atoms%lmaxd, - > atoms%ntype,DIMENSION%neigd,atoms%nat,sym%nop,DIMENSION%nvd, - > input%jspins,DIMENSION%nbasfcn,atoms%llod,atoms%nlod, - > atoms%ntype,cell%omtil,atoms%nlo,atoms%llo, - > atoms%lapw_l,sym%invtab,sym%mrot,atoms%ngopr,atoms%neq, - > atoms%lmax,atoms%invsat,sym%invsatnr,nkpt,atoms%taual, - > atoms%rmt,cell%amat,cell%bmat,cell%bbmat,noco%alph, - > noco%beta,noco%qss,stars%sk2,stars%phi2,oneD%odi,oneD%ods, - > mpi%irank, - > mpi%isize,stars%ng3,vacuum%nmzxyd,vacuum%nmzd,atoms%jmtd, - > sphhar%nlhd,stars%ng3,vacuum%nvac,sym%invs,sym%invs2, - > input%film,sphhar%nlh,atoms%jri,sphhar%ntypsd,atoms%ntypsy, - > input%jspins,nkpt,atoms%dx,stars%ng2,atoms%rmsh, - > sliceplot%e1s,sliceplot%e2s,atoms%ulo_der,stars%ustep, - > stars%ig,stars%mx1,stars%mx2,stars%mx3, - > stars%rgphs,sliceplot%slice, - > sliceplot%kk,sliceplot%nnne,cell%z1,DIMENSION%nv2d, - > vacuum%nmzxy,vacuum%nmz,vacuum%delz,sym%zrfs,stars%ig2, - > cell%area,sym%tau,atoms%zatom,stars%ng2,stars%kv2,sym%nop2, - > cell%volint,sym%symor,atoms%pos,results%ef,noco%l_soc, - > sphhar%memd,atoms%lnonsph,sphhar%clnu,DIMENSION%lmplmd, - > sphhar%mlh,sphhar%nmem,sphhar%llh,atoms%lo1l, - > noco%theta,noco%phi, - > wann%l_ms,wann%l_sgwf,wann%l_socgwf,wann%aux_latt_const, - > wann%param_file,wann%param_vec,wann%nparampts, - > wann%param_alpha,wann%l_dim,l_nochi) - - DO pc = 1, wann%nparampts - CALL close_eig(eig_idList(pc)) - END DO - - CALL juDFT_end("wann_uHu dmi done",mpi%irank) - endif - - if(wann%l_byenergy.and.wann%l_byindex) CALL juDFT_error - + ("byenergy.and.byindex",calledby ="wannier") - if(wann%l_byenergy.and.wann%l_bynumber) CALL juDFT_error - + ("byenergy.and.bynumber",calledby ="wannier") - if(wann%l_bynumber.and.wann%l_byindex) CALL juDFT_error - + ("bynumber.and.byindex",calledby ="wannier") - if(.not.(wann%l_bynumber.or.wann%l_byindex.or.wann%l_byenergy)) - & CALL juDFT_error("no rule to sort bands",calledby ="wannier") - - - efermi=results%ef - if(.not.wann%l_fermi)efermi=0.0 - -#ifdef CPP_MPI - call MPI_BARRIER(mpi%mpi_comm,ierr) -#endif - -c************************************************************** -c for bzsym=.true.: determine mapping between kpts and w90kpts -c************************************************************** - if (wann%l_bzsym) then - l_file=.false. - inquire(file='w90kpts',exist=l_file) - if(.not.l_file) CALL juDFT_error - + ("w90kpts not found, needed if bzsym",calledby ="wannier") - open(412,file='w90kpts',form='formatted') - read(412,*)fullnkpts - close(412) - if(l_p0)print*,"fullnkpts=",fullnkpts - if(fullnkptsfullnkpts) CALL juDFT_error("bpt.gt.fullnkpts" - + ,calledby ="wannier") - enddo - enddo - close (202) - allocate(kdiff(3,nntot)) - endif - -c********************************************************** -ccccccccccccccc read in the bqpts file ccccccccccccccccc -c********************************************************** - if ((wann%l_matrixmmn).AND.(l_gwf.or.wann%l_ms)) then - l_bqpts = .false. - inquire (file='bqpts',exist=l_bqpts) - if (.not.l_bqpts) CALL juDFT_error("need bqpts for matrixmmn" - + ,calledby ="wannier") - open (202,file='bqpts',form='formatted',status='old') - rewind (202) - read (202,'(i4)') nntot_q - if(l_p0)then - write (*,*) 'nntot_q=',nntot_q - write(*,*) 'fullnqpts=',fullnqpts - endif - allocate ( gb_q(1:3,1:nntot_q,1:fullnqpts), - & bpt_q(1:nntot_q,1:fullnqpts)) - do iqpt=1,fullnqpts - do nn=1,nntot_q - read (202,'(2i6,3x,3i4)') - & iqpt_help,bpt_q(nn,iqpt),(gb_q(i,nn,iqpt),i=1,3) - if (iqpt/=iqpt_help) CALL juDFT_error("iqpt.ne.iqpt_help" - + ,calledby ="wannier") - if (bpt_q(nn,iqpt)>fullnqpts) - & CALL juDFT_error("bpt_q.gt.fullnqpts",calledby ="wannier") - enddo - enddo - close (202) - allocate(qdiff(3,nntot_q)) - allocate(zero_qdiff(3,nntot_q)) - zero_qdiff=0.0 - endif - - -! when treating gen. WF for spin spirals, the Brillouin zone -! of q-points is twice as large compared to k-BZ. Thus, -! the G-vectors connecting neighbors across the boundary -! need to be doubled - if(wann%l_sgwf) gb_q = 2*gb_q - if(wann%l_socgwf) gb_q = 2*gb_q - - if(wann%l_finishgwf) goto 9110 -c******************************************************** -c find symmetry-related elements in mmkb -c******************************************************** - if(wann%l_matrixmmn)then - call cpu_time(delta) - allocate(maptopair(3,fullnkpts,nntot)) - allocate(pair_to_do(fullnkpts,nntot)) - call wann_mmnk_symm(input,kpts, - > fullnkpts,nntot,bpt,gb,wann%l_bzsym, - > irreduc,mapkoper,l_p0,input%film,sym%nop,sym%invtab,sym%mrot, - > oneD%odi%d1,sym%tau, - < pair_to_do,maptopair,kdiff,.false.,wann%param_file) - call cpu_time(delta1) - time_symm=delta1-delta - endif - - ! do the same for q-points to construct GWFs - if(wann%l_matrixmmn.AND.l_gwf)then - allocate(maptopair_q(3,fullnqpts,nntot_q)) - allocate(pair_to_do_q(fullnqpts,nntot_q)) - call wann_mmnk_symm(input,kpts, - > fullnqpts,nntot_q,bpt_q,gb_q,wann%l_bzsym, - > irreduc_q,mapqoper,l_p0,.false.,1,sym%invtab(1), - > sym%mrot(:,:,1),.false.,sym%tau, - < pair_to_do_q,maptopair_q,qdiff,.true.,wann%param_file) - endif - - -c********************************************************* -cccccccccccccccc initialize the potential cccccccccccc -c********************************************************* - - allocate ( vz(vacuum%nmzd,2,4) ) - allocate ( vr(atoms%jmtd,atoms%ntype,input%jspins) ) - allocate ( vso(atoms%jmtd,atoms%nat,2) ) - - vz = 0.0 - vz(:,:,:SIZE(vTot%vacz,3)) = vTot%vacz(:,:,:) - - do jspin = 1,input%jspins - do n = 1, atoms%ntype - do j = 1,atoms%jri(n) - vr(j,n,jspin) = vTot%mt(j,0,n,jspin) - enddo - enddo - enddo - - if(wann%l_soctomom)then - CALL vsoc(input,atoms,vr,enpara%el0,.TRUE., vso) - endif - - if(noco%l_noco.and.input%film)then - npotmatfile=25 - allocate(vpw(stars%ng3,1)) - if(.not.oneD%odi%d1) - & allocate( vxy(vacuum%nmzxyd,stars%ng2-1,2) ) - - OPEN (npotmatfile,FILE='potmat',FORM='unformatted', - + STATUS='old') - READ (npotmatfile) (vpw(ig3,1),ig3=1,stars%ng3) - READ (npotmatfile) (vpw(ig3,1),ig3=1,stars%ng3) - READ (npotmatfile) (vpw(ig3,1),ig3=1,stars%ng3) - maxvac=2 - if(oneD%odi%d1)maxvac=1 - DO ivac = 1,maxvac -c---> if the two vacuua are equivalent, the potential file has to -c---> be backspaced, because the potential is the same at both -c---> surfaces of the film - IF ((ivac.EQ.2) .AND. (vacuum%nvac.EQ.1)) THEN - DO irec = 1,4 - BACKSPACE (npotmatfile) - ENDDO - ENDIF -c---> load the non-warping part of the potential - READ (npotmatfile) - + ((vz(imz,ivac,ipot),imz=1,vacuum%nmzd),ipot=1,4) - - if(.not.oneD%odi%d1)then - DO ipot = 1,3 - READ (npotmatfile)((vxy(imz,igvm2,ivac), - + imz=1,vacuum%nmzxy),igvm2=1,stars%ng2-1) - enddo - endif - enddo - CLOSE (npotmatfile) - deallocate(vpw) - if(.not.oneD%odi%d1)then - deallocate(vxy) - endif - endif - -cccccccccccccccc end of the potential part ccccccccccc - wannierspin=input%jspins - if(noco%l_soc) wannierspin=2 - - allocate ( kveclo(nlotot),nv(wannierspin) ) - allocate ( kveclo_b(nlotot),nv_b(wannierspin) ) - IF(l_gwf) allocate ( kveclo_qb(nlotot),nv_qb(wannierspin) ) - allocate ( k1(DIMENSION%nvd,wannierspin) ) - allocate ( k2(DIMENSION%nvd,wannierspin) ) - allocate ( k3(DIMENSION%nvd,wannierspin) ) - allocate ( k1_b(DIMENSION%nvd,wannierspin) ) - allocate ( k2_b(DIMENSION%nvd,wannierspin) ) - allocate ( k3_b(DIMENSION%nvd,wannierspin) ) - IF(l_gwf) THEN - allocate ( k1_qb(DIMENSION%nvd,wannierspin) ) - allocate ( k2_qb(DIMENSION%nvd,wannierspin) ) - allocate ( k3_qb(DIMENSION%nvd,wannierspin) ) - END IF - - allocate ( ff(atoms%ntype,atoms%jmtd,2,0:atoms%lmaxd,2) ) - allocate ( gg(atoms%ntype,atoms%jmtd,2,0:atoms%lmaxd,2) ) - allocate ( usdus%us(0:atoms%lmaxd,atoms%ntype,2) ) - allocate ( usdus%uds(0:atoms%lmaxd,atoms%ntype,2) ) - allocate ( usdus%dus(0:atoms%lmaxd,atoms%ntype,2) ) - allocate ( usdus%duds(0:atoms%lmaxd,atoms%ntype,2) ) - allocate ( usdus%ddn(0:atoms%lmaxd,atoms%ntype,2) ) - allocate ( usdus%ulos(atoms%nlod,atoms%ntype,2) ) - allocate ( usdus%dulos(atoms%nlod,atoms%ntype,2) ) - allocate ( usdus%uulon(atoms%nlod,atoms%ntype,2) ) - allocate ( usdus%dulon(atoms%nlod,atoms%ntype,2) ) - allocate ( usdus%uloulopn(atoms%nlod,atoms%nlod,atoms%ntype,2) ) - - if(l_gwf.and..not.(wann%l_wann_plot)) then - doublespin_max=4!2 - else - doublespin_max=wannierspin - endif - - t_it=0.0 -! t_kov=0.0 - t_qov=0.0 -c*****************************************************************c -c START Q LOOP c -c standard functionality of code for fullnqpts = nntot_q = 1 c -c and wann%l_ms = wann%l_sgwf = wann%l_socgwf = F c -c*****************************************************************c - do 314 iqpt = 1,fullnqpts ! loop by q-points starts - - ALLOCATE(innerEig_idList(nntot_q)) - - call cpu_time(tt1) -! t_kov=0.0 - t_qov=0.0 - - qptibz=iqpt - if(wann%l_bzsym .AND. l_gwf) qptibz=irreduc_q(iqpt) - if(wann%l_bzsym .AND. l_gwf) oper_q=mapqoper(iqpt) - - qpt_i = noco%qss - alph_i = noco%alph - beta_i = noco%beta - theta_i = noco%theta - phi_i = noco%phi - if(wann%l_sgwf.or.wann%l_ms) then - qpt_i(:) = wann%param_vec(:,qptibz) - alph_i(:) = wann%param_alpha(:,qptibz) - elseif(wann%l_socgwf) then - if(wann%l_dim(2)) phi_i = tpi*wann%param_vec(2,qptibz) - if(wann%l_dim(3)) theta_i = tpi*wann%param_vec(3,qptibz) - endif - - IF (l_gwf) THEN - IF(wann%l_matrixmmn)THEN - do iqpt_b=1,nntot_q - - innerEig_idList(iqpt_b) = eig_idList(bpt_q(iqpt_b,iqpt)) - -! WRITE(fending,'("_",i4.4)')bpt_q(iqpt_b,iqpt) -! innerEig_idList(iqpt_b)=open_eig(mpi%mpi_comm, -! + DIMENSION%nbasfcn,DIMENSION%neigd, -! + nkpts,wannierspin,atoms%lmaxd, -! + atoms%nlod,atoms%ntype,atoms%nlotot, -! + noco%l_noco,.FALSE.,l_real,noco%l_soc,.FALSE., -! + mpi%n_size,filename=trim(fstart)//fending, -! + layers=vacuum%layers,nstars=vacuum%nstars, -! + ncored=DIMENSION%nstd,nsld=atoms%nat, -! + nat=atoms%nat,l_dos=banddos%dos.OR.input%cdinf, -! + l_mcd=banddos%l_mcd,l_orb=banddos%l_orb) - - enddo - ENDIF - - eig_id = eig_idList(qptibz) - -! WRITE(fending,'("_",i4.4)')qptibz -! eig_id=open_eig(mpi%mpi_comm,DIMENSION%nbasfcn,DIMENSION%neigd, -! + nkpts,wannierspin,atoms%lmaxd, -! + atoms%nlod,atoms%ntype,atoms%nlotot, -! + noco%l_noco,.FALSE.,l_real,noco%l_soc,.FALSE., -! + mpi%n_size,filename=trim(fstart)//fending, -! + layers=vacuum%layers,nstars=vacuum%nstars, -! + ncored=DIMENSION%nstd,nsld=atoms%nat, -! + nat=atoms%nat,l_dos=banddos%dos.OR.input%cdinf, -! + l_mcd=banddos%l_mcd,l_orb=banddos%l_orb) - - ELSEIF(wann%l_ms) THEN - - eig_id = eig_idList(qptibz) - -! WRITE(fending,'("_",i4.4)')qptibz -! eig_id=open_eig(mpi%mpi_comm,DIMENSION%nbasfcn,DIMENSION%neigd, -! + nkpts,wannierspin,atoms%lmaxd, -! + atoms%nlod,atoms%ntype,atoms%nlotot, -! + noco%l_noco,.FALSE.,l_real,noco%l_soc,.FALSE., -! + mpi%n_size,filename=trim(fstart)//fending, -! + layers=vacuum%layers,nstars=vacuum%nstars, -! + ncored=DIMENSION%nstd,nsld=atoms%nat, -! + nat=atoms%nat,l_dos=banddos%dos.OR.input%cdinf, -! + l_mcd=banddos%l_mcd,l_orb=banddos%l_orb) - - ELSE - fending='' - ENDIF ! l_gwf.or.wann%l_ms - nrec=0 - nrec_b=0 - - -c**************************************************** -c cycle by spins starts! -c**************************************************** - do 110 doublespin=1,doublespin_max ! cycle by spins - - jspin=mod(doublespin+1,2)+1 - jspin_b=jspin - if(doublespin.eq.3) jspin_b=2 - if(doublespin.eq.4) jspin_b=1 - - nrec_b = nrec - - if(.not.noco%l_noco) then - nrec = (jspin-1)*nkpts - nrec_b = (jspin_b-1)*nkpts - endif - - ! spin-dependent sign of the q-dependent phase - ! in the generalized Bloch theorem - ! -1: spin up, +1: spin down - sign_q = -sign_q - -c...read number of bands and wannier functions from file proj - -c..reading the proj.1 / proj.2 / proj file - l_proj=.false. - do j=jspin,0,-1 - inquire(file=trim('proj'//spin012(j)),exist=l_proj) - if(l_proj)then - filename='proj'//spin012(j) - exit - endif - enddo - - if(l_proj)then - open (203,file=trim(filename),status='old') - rewind (203) - read (203,*) nwfs,numbands - rewind (203) - close (203) - elseif(wann%l_projmethod.or.wann%l_bestproj - & .or.wann%l_matrixamn)then - CALL juDFT_error("no proj/proj.1/proj.2" - & ,calledby ="wannier") - endif - - - jspin2=jspin - if(noco%l_soc .and. input%jspins.eq.1)jspin2=1 - jspin2_b=jspin_b - if(noco%l_soc .and. input%jspins.eq.1)jspin2_b=1 - - jsp_start = jspin ; jsp_end = jspin - - call cpu_time(tt2) -cccccccccccc read in the eigenvalues and vectors cccccc - write(*,*)'wannierspin',wannierspin - do jspin5=1,wannierspin!1!2 -! jspin5=jspin - jsp_start=jspin5; jsp_end=jspin5 - nrec5=0 - if(.not.noco%l_noco) nrec5 = (jspin5-1)*nkpts - - call cdn_read0(eig_id,mpi%irank,mpi%isize,jspin5,input%jspins, !wannierspin instead of DIMENSION%jspd? - > noco%l_noco, - < n_bands,n_size) - - enddo -! call cpu_time(tt3) - !if(l_p0) write(*,*)'cdn_read0=',tt3-tt2 - -c.. now we want to define the maximum number of the bands by all kpts - nbnd = 0 - - i_rec = 0 ; n_rank = 0 -c************************************************************* -c..writing down the eig.1 and/or eig.2 files - -c..write individual files if multi-spiral mode wann%l_ms=T -c************************************************************* - if(l_p0)then - call wann_write_eig( - > eig_id,l_real, - > atoms%lmaxd,atoms%ntype,atoms%nlod,DIMENSION%neigd, - > DIMENSION%nvd,wannierspin, - > mpi%isize,jspin,DIMENSION%nbasfcn,nlotot, - > noco%l_ss,noco%l_noco,nrec,fullnkpts, - > wann%l_bzsym,wann%l_byindex,wann%l_bynumber, - > wann%l_byenergy, - > irreduc,oneD%odi,wann%band_min(jspin), - > wann%band_max(jspin), - > numbands, - > sliceplot%e1s,sliceplot%e2s,efermi,.false.,nkpts, - < nbnd,kpoints,l_gwf,iqpt) - - if(oneD%odi%d1)then - kpoints(:)=kpoints(:)*cell%bmat(3,3) - endif - endif!l_p0 -! call cpu_time(tt2) - !if(l_p0)write(*,*)'write_eig=',tt2-tt3 - - -! nbnd is calculated for process zero and is sent here to the others -#ifdef CPP_MPI - if(l_p0)then - do cpu_index=1,mpi%isize-1 - call MPI_SEND(nbnd,1,MPI_INTEGER,cpu_index,1,mpi%mpi_comm,ierr) - enddo - else - call MPI_RECV(nbnd,1,MPI_INTEGER,0,1,mpi%mpi_comm,stt,ierr) - endif -#endif - - print*,"process: ",mpi%irank," nbnd= ",nbnd -! call cpu_time(tt3) -c################################################################## - if(wann%l_mmn0)then - allocate ( mmn(nbnd,nbnd,fullnkpts) ) - mmn(:,:,:) = cmplx(0.,0.) - if((noco%l_soc.or.noco%l_noco) .and. (doublespin.eq.1)) - & allocate(socmmn(nbnd,nbnd,fullnkpts) ) - endif - if(wann%l_nabla)then - allocate ( nablamat(3,nbnd,nbnd,fullnkpts) ) - nablamat = cmplx(0.,0.) - endif - - if(wann%l_soctomom)then - allocate ( soctomom(3,nbnd,nbnd,fullnkpts) ) - soctomom = cmplx(0.,0.) - endif - - if(wann%l_surfcurr)then - allocate ( surfcurr(3,nbnd,nbnd,fullnkpts) ) - surfcurr = cmplx(0.,0.) - endif - - if(wann%l_anglmom)then - if(.not.allocated(anglmom))then - allocate ( anglmom(3,nbnd,nbnd,fullnkpts) ) - anglmom=cmplx(0.,0.) - endif - endif - - if(wann%l_orbcomp)then - if(allocated(orbcomp))deallocate(orbcomp) - if(wann%l_oc_f)then - allocate(orbcomp(16,wann%oc_num_orbs,nbnd,nbnd,fullnkpts)) - else - allocate(orbcomp(9,wann%oc_num_orbs,nbnd,nbnd,fullnkpts)) - endif - orbcomp=cmplx(0.,0.) - endif - - !write (*,*) 'nwfs=',nwfs - if(wann%l_projmethod.or.wann%l_bestproj.or.wann%l_matrixamn)then - if(.not.allocated(amn))then - allocate ( amn(nbnd,nwfs,fullnkpts) ) - amn(:,:,:) = cmplx(0.,0.) - endif - endif - - if (wann%l_projmethod.or.wann%l_bestproj) then - allocate ( psiw(nbnd,nwfs,fullnkpts) ) - psiw(:,:,:) = cmplx(0.,0.) - if(.not.allocated(hwfr))then - allocate ( hwfr(nwfs,nwfs) ) - hwfr(:,:) = cmplx(0.,0.) - endif - endif - - - if (wann%l_matrixmmn) then - if(.not.allocated(mmnk))then - allocate ( mmnk(nbnd,nbnd,nntot,fullnkpts) ) - mmnk = (0.,0.) - endif - endif - - if(wann%l_matrixmmn)then - if(.not.allocated(mmnk_q).AND.l_gwf)then - allocate ( mmnk_q (nbnd,nbnd,nntot_q,fullnkpts) ) - mmnk_q = (0.,0.) - -! allocate ( m_int(nbnd,nbnd,nntot_q,fullnkpts) ) -! allocate ( m_sph(nbnd,nbnd,nntot_q,fullnkpts) ) -! allocate ( m_vac(nbnd,nbnd,nntot_q,fullnkpts) ) -! m_int = cmplx(0.,0.) -! m_sph = cmplx(0.,0.) -! m_vac = cmplx(0.,0.) - endif - endif - - - allocate ( flo(atoms%ntype,atoms%jmtd,2,atoms%nlod,2) ) -! call cpu_time(tt2) - !if(l_p0) write(*,*)'allocate',tt2-tt3 - - do jspin4=1,wannierspin!2 - jspin3=jspin4 - if(input%jspins.eq.1) jspin3=1 - na = 1 - do 40 n = 1,atoms%ntype - do 30 l = 0,atoms%lmax(n) -c...compute the l-dependent, k-independent radial MT- basis functions - - call radfun( - > l,n,jspin4,enpara%el0(l,n,jspin3),vr(1,n,jspin3),atoms, - < ff(n,:,:,l,jspin4),gg(n,:,:,l,jspin4),usdus, - < nodeu,noded,wronk) - - 30 continue -c...and the local orbital radial functions - do ilo = 1, atoms%nlo(n) - - call radflo( - > atoms,n,jspin4,enpara%ello0(:,:,jspin3),vr(1,n,jspin3), - > ff(n,1:,1:,0:,jspin4),gg(n,1:,1:,0:,jspin4),mpi, - < usdus,uuilon,duilon,ulouilopn,flo(n,:,:,:,jspin4)) - - enddo -c na = na + atoms%neq(n) - 40 continue - enddo!jspin3 -! call cpu_time(tt3) - !if(l_p0) write(*,*)'radfun=',tt3-tt2 - -c**************************************************************** -c calculate the k-independent uju*gaunt-matrix needed for -c mmnmatrix -c**************************************************************** -! TODO: make this more efficient (i.e., compute ujugaunt only once -! and not for all q-points). - if(wann%l_matrixmmn)then - call cpu_time(delta) - allocate(ujug(0:lmd,0:lmd, - & 1:atoms%ntype,1:nntot)) - allocate(ujdg(0:lmd,0:lmd, - & 1:atoms%ntype,1:nntot)) - allocate(djug(0:lmd,0:lmd, - & 1:atoms%ntype,1:nntot)) - allocate(djdg(0:lmd,0:lmd, - & 1:atoms%ntype,1:nntot)) - allocate(ujulog(0:lmd,1:atoms%nlod,-atoms%llod:atoms%llod, - & 1:atoms%ntype,1:nntot)) - allocate(djulog(0:lmd,1:atoms%nlod,-atoms%llod:atoms%llod, - & 1:atoms%ntype,1:nntot)) - allocate(ulojug(0:lmd,1:atoms%nlod,-atoms%llod:atoms%llod, - & 1:atoms%ntype,1:nntot)) - allocate(ulojdg(0:lmd,1:atoms%nlod,-atoms%llod:atoms%llod, - & 1:atoms%ntype,1:nntot)) - allocate(ulojulog(1:atoms%nlod,-atoms%llod:atoms%llod, - & 1:atoms%nlod,-atoms%llod:atoms%llod, - & 1:atoms%ntype,1:nntot)) - - call wann_ujugaunt( - > atoms%llod,nntot,kdiff,atoms%lmax,atoms%ntype, - > atoms%ntype,cell%bbmat,cell%bmat,atoms%nlod,atoms%nlo, - > atoms%llo,flo(:,:,:,:,jspin), - > flo(:,:,:,:,jspin), - > ff(:,:,:,:,jspin), - > ff(:,:,:,:,jspin), - > gg(:,:,:,:,jspin), - > gg(:,:,:,:,jspin),atoms%jri,atoms%rmsh,atoms%dx, - > atoms%jmtd,atoms%lmaxd,lmd, - < ujug,ujdg,djug,djdg, - < ujulog,djulog,ulojug,ulojdg,ulojulog,.false.,1) - -! compute integrals of radial solution, according energy derivatives, -! the spherical Bessel function and the Gaunt coefficients in order -! to account for the overlap of the lattice periodic parts at -! neighboring q-points - IF(l_gwf)THEN - allocate(ujug_q(0:lmd,0:lmd, - & 1:atoms%ntype,1:nntot_q)) - allocate(ujdg_q(0:lmd,0:lmd, - & 1:atoms%ntype,1:nntot_q)) - allocate(djug_q(0:lmd,0:lmd, - & 1:atoms%ntype,1:nntot_q)) - allocate(djdg_q(0:lmd,0:lmd, - & 1:atoms%ntype,1:nntot_q)) - allocate(ujulog_q(0:lmd,1:atoms%nlod,-atoms%llod:atoms%llod, - & 1:atoms%ntype,1:nntot_q)) - allocate(djulog_q(0:lmd,1:atoms%nlod,-atoms%llod:atoms%llod, - & 1:atoms%ntype,1:nntot_q)) - allocate(ulojug_q(0:lmd,1:atoms%nlod,-atoms%llod:atoms%llod, - & 1:atoms%ntype,1:nntot_q)) - allocate(ulojdg_q(0:lmd,1:atoms%nlod,-atoms%llod:atoms%llod, - & 1:atoms%ntype,1:nntot_q)) - allocate(ulojulog_q(1:atoms%nlod,-atoms%llod:atoms%llod, - & 1:atoms%nlod,-atoms%llod:atoms%llod, - & 1:atoms%ntype,1:nntot_q)) - - ! we need G(q+b)/2 as argument for the sph. Bessel func. - ! and additionally a spin-dependent sign (-/+ 1)^{lpp} - if(wann%l_sgwf) call wann_ujugaunt( - > atoms%llod,nntot_q,qdiff/2.0,atoms%lmax,atoms%ntype, - > atoms%ntype,cell%bbmat,cell%bmat,atoms%nlod,atoms%nlo, - > atoms%llo,flo(:,:,:,:,jspin), - > flo(:,:,:,:,jspin_b), - > ff(:,:,:,:,jspin), - > ff(:,:,:,:,jspin_b), - > gg(:,:,:,:,jspin), - > gg(:,:,:,:,jspin_b),atoms%jri,atoms%rmsh,atoms%dx, - > atoms%jmtd,atoms%lmaxd,lmd, - < ujug_q,ujdg_q,djug_q,djdg_q, - < ujulog_q,djulog_q,ulojug_q,ulojdg_q,ulojulog_q,.true., - > sign_q) - - if(wann%l_socgwf) call wann_ujugaunt( - > atoms%llod,nntot_q,zero_qdiff,atoms%lmax,atoms%ntype, - > atoms%ntype,cell%bbmat,cell%bmat,atoms%nlod,atoms%nlo, - > atoms%llo,flo(:,:,:,:,jspin), - > flo(:,:,:,:,jspin_b), - > ff(:,:,:,:,jspin), - > ff(:,:,:,:,jspin_b), - > gg(:,:,:,:,jspin), - > gg(:,:,:,:,jspin_b),atoms%jri,atoms%rmsh,atoms%dx, - > atoms%jmtd, - > atoms%lmaxd,lmd,ujug_q,ujdg_q,djug_q,djdg_q, - < ujulog_q,djulog_q,ulojug_q,ulojdg_q,ulojulog_q, - > .false.,1) - - ENDIF ! l_gwf - - call cpu_time(delta1) - time_ujugaunt=delta1-delta - endif !l_matrixmmn -! call cpu_time(tt2) - !if(l_p0) write(*,*)'ujugaunt=',tt2-tt3 - - zzMat%l_real = l_real - zzMat%matsize1 = DIMENSION%nbasfcn - zzMat%matsize2 = DIMENSION%neigd - IF(l_real) THEN - IF(.not.ALLOCATED(zzMat%data_r)) - > ALLOCATE (zzMat%data_r(zzMat%matsize1,zzMat%matsize2)) - ELSE - IF(.not.ALLOCATED(zzMat%data_c)) - > ALLOCATE (zzMat%data_c(zzMat%matsize1,zzMat%matsize2)) - END IF - - zMat%l_real = zzMat%l_real - zMat%matsize1 = zzMat%matsize1 - zMat%matsize2 = zzMat%matsize2 - IF (zzMat%l_real) THEN - IF(.not.ALLOCATED(zMat%data_r)) - > ALLOCATE (zMat%data_r(zMat%matsize1,zMat%matsize2)) - zMat%data_r = 0.0 - ELSE - IF(.not.ALLOCATED(zMat%data_c)) - > ALLOCATE (zMat%data_c(zMat%matsize1,zMat%matsize2)) - zMat%data_c = CMPLX(0.0,0.0) - END IF - - zMat_b%l_real = zzMat%l_real - zMat_b%matsize1 = zzMat%matsize1 - zMat_b%matsize2 = zzMat%matsize2 - IF (zzMat%l_real) THEN - IF(.not.ALLOCATED(zMat_b%data_r)) - > ALLOCATE (zMat_b%data_r(zMat_b%matsize1,zMat_b%matsize2)) - zMat_b%data_r = 0.0 - ELSE - IF(.not.ALLOCATED(zMat_b%data_c)) - > ALLOCATE (zMat_b%data_c(zMat_b%matsize1,zMat_b%matsize2)) - zMat_b%data_c = CMPLX(0.0,0.0) - END IF - - i_rec = 0 ; n_rank = 0 - -c**************************************************************** -c.. loop by kpoints starts! each may be a separate task -c**************************************************************** - do 10 ikpt = wann%ikptstart,fullnkpts ! loop by k-points starts -! call cpu_time(tt2) -! call cpu_time(tt3) - kptibz=ikpt - if(wann%l_bzsym) kptibz=irreduc(ikpt) - if(wann%l_bzsym) oper=mapkoper(ikpt) - - i_rec = i_rec + 1 - if (mod(i_rec-1,mpi%isize).eq.mpi%irank) then - - allocate ( we(DIMENSION%neigd),eigg(DIMENSION%neigd) ) - - call cpu_time(delta) - n_start=1 - n_end=DIMENSION%neigd - - -! read information of diagonalization for fixed q-point iqpt -! stored in the eig file on unit 66. the lattice respectively -! plane-wave vectors G(k,q) are saved in (k1,k2,k3). - - CALL cdn_read( - > eig_id, - > DIMENSION%nvd,input%jspins,mpi%irank,mpi%isize, !wannierspin instead of DIMENSION%jspd? - > kptibz,jspin,DIMENSION%nbasfcn, - > noco%l_ss,noco%l_noco,DIMENSION%neigd,n_start,n_end, - < nbands,eigg,zzMat) - -! call cpu_time(tt4) - !if(l_p0) write(*,*)'cdn_read=',tt4-tt3 - - call cpu_time(delta1) - time_rw=time_rw+delta1-delta - nslibd = 0 - -c...we work only within the energy window - - eig(:) = 0. - -! print*,"bands used:" - - do i = 1,nbands - if ((eigg(i).ge.sliceplot%e1s.and.nslibd.lt.numbands.and. - & wann%l_bynumber).or. - & (eigg(i).ge.sliceplot%e1s.and.eigg(i).le.sliceplot%e2s.and. - & wann%l_byenergy).or.(i.ge.wann%band_min(jspin).and. - & (i.le.wann%band_max(jspin)).and.wann%l_byindex))then - -! print*,i - nslibd = nslibd + 1 - eig(nslibd) = eigg(i) - we(nslibd) = we(i) - if(noco%l_noco)then - funbas= nv(1)+nlotot - funbas=funbas+nv(2)+nlotot - else - funbas=nv(jspin)+nlotot - endif - IF(zzMat%l_real) THEN - do j = 1, funbas - zMat%data_r(j,nslibd) = zzMat%data_r(j,i) - end do - ELSE - do j = 1, funbas - zMat%data_c(j,nslibd) = zzMat%data_c(j,i) - end do - END IF - endif - enddo - -c*********************************************************** -c rotate the wavefunction -c*********************************************************** - if (wann%l_bzsym.and.oper.ne.1) then !rotate bkpt -! call wann_kptsrotate( -! > atoms%nat,atoms%nlod,atoms%llod, -! > atoms%ntype,atoms%nlo,atoms%llo,atoms%invsat, -! > noco%l_noco,noco%l_soc, -! > atoms%ntype,atoms%neq,nlotot, -! > kveclo,jspin, -! > oper,sym%nop,sym%mrot,DIMENSION%nvd,nv, -! > shiftkpt(:,ikpt), -! > sym%tau, -! x bkpt,k1(:,:),k2(:,:),k3(:,:), -! x zMat,nsfactor) - else - nsfactor=cmplx(1.0,0.0) - endif -c print*,"bkpt1=",bkpt -! call cpu_time(tt3) - !if(l_p0) write(*,*)'nbnd=',tt3-tt4 - -c****************************************************************** - -c...the overlap matrix Mmn which is computed for each k- and b-point - - noccbd = nslibd - - allocate(acof(noccbd,0:lmd,atoms%nat), - & bcof(noccbd,0:lmd,atoms%nat), - & ccof(-atoms%llod:atoms%llod,noccbd,atoms%nlod,atoms%nat)) - - acof(:,:,:) = cmplx(0.,0.) ; bcof(:,:,:) = cmplx(0.,0.) - ccof(:,:,:,:) = cmplx(0.,0.) - -c...generation the A,B,C coefficients in the spheres -c...for the lapws and local orbitals, summed by the basis functions - - call cpu_time(delta) - - ALLOCATE(lapw%k1(SIZE(k1,1),SIZE(k1,2))) - ALLOCATE(lapw%k2(SIZE(k1,1),SIZE(k1,2))) - ALLOCATE(lapw%k3(SIZE(k1,1),SIZE(k1,2))) - lapw%k1 = k1 - lapw%k2 = k2 - lapw%k3 = k3 - lapw%nmat = nmat - lapw%nv = nv - ! I think the other variables of lapw are not needed here. - -! CALL abcof(input,atoms,noccbd,sym,cell,bkpt,lapw,noccbd,usdus, -! > noco,jspin,kveclo,oneD,acof,bcof,ccof,zMat) - - DEALLOCATE(lapw%k1,lapw%k2,lapw%k3) - - call cpu_time(delta1) - time_abcof=time_abcof+delta1-delta - - call wann_abinv( - > atoms%ntype,atoms%nat,noccbd,atoms%lmaxd,lmd,atoms%llod, - > atoms%nlod,atoms%ntype,atoms%neq,noccbd,atoms%lmax, - > atoms%nlo,atoms%llo,atoms%invsat,sym%invsatnr,bkpt, - > atoms%taual, - X acof,bcof,ccof) -! call cpu_time(tt4) - !if(l_p0) write(*,*)'abcof=',tt4-tt3 - - - if((doublespin.eq.3).or.(doublespin.eq.4)) goto 9900 - - - if(wann%l_orbcomp)then - call wann_orbcomp( - > atoms%llod,noccbd,atoms%nlod,atoms%nat,atoms%ntype, - > atoms%lmaxd,lmd,atoms%ntype,atoms%neq,atoms%nlo, - > atoms%llo,acof,bcof,ccof, - > usdus%ddn(:,:,jspin),usdus%uulon(:,:,jspin), - > usdus%dulon(:,:,jspin),usdus%uloulopn(:,:,:,jspin), - > wann%oc_num_orbs, - > wann%oc_orbs, - > wann%l_oc_f, - = orbcomp(:,:,:,:,ikpt)) - endif - - if(wann%l_anglmom)then - call wann_anglmom( - > atoms%llod,noccbd,atoms%nlod,atoms%nat, - > atoms%ntype,atoms%lmax,lmd,!atoms%lmaxd,lmd, - > atoms%ntype,atoms%neq,atoms%nlo,atoms%llo, - > acof,bcof,ccof, - > usdus%ddn(:,:,jspin),usdus%uulon(:,:,jspin), - > usdus%dulon(:,:,jspin), - > usdus%uloulopn(:,:,:,jspin), - = anglmom(:,:,:,ikpt)) - endif - -#ifdef CPP_TOPO - if(wann%l_surfcurr)then -c call wann_surfcurr_int( -c > DIMENSION%nv2d,jspin,oneD%odi,oneD%ods,stars%ng3,vacuum%nmzxyd,stars%ng2,sphhar%ntypsd, -c > atoms%ntype,atoms%lmaxd,atoms%jmtd,atoms%ntype,atoms%nat,vacuum%nmzd,atoms%neq,stars%ng3,vacuum%nvac, -c > vacuum%nmz,vacuum%nmzxy,stars%ng2,sym%nop,sym%nop2,cell%volint,input%film,sliceplot%slice,sym%symor, -c > sym%invs,sym%invs2,cell%z1,vacuum%delz,atoms%ngopr,atoms%ntypsy,atoms%jri,atoms%pos,atoms%zatom, -c > atoms%lmax,sym%mrot,sym%tau,atoms%rmsh,sym%invtab,cell%amat,cell%bmat,cell%bbmat,ikpt,sliceplot%nnne,sliceplot%kk, -c > DIMENSION%nvd,atoms%nlod,atoms%llod,nv(jspin),lmd,bkpt,cell%omtil,atoms%nlo,atoms%llo, -c > k1(:,jspin),k2(:,jspin),k3(:,jspin),evac(:,jspin), -c > vz(:,:,jspin2), -c > nslibd,DIMENSION%nbasfcn,DIMENSION%neigd,ff,gg,flo,acof,bcof,ccof,z, -c > surfcurr(:,:,:,ikpt)) - - call wann_surfcurr_int2( - > DIMENSION%nv2d,jspin,oneD%odi,oneD%ods,stars%ng3, - > vacuum%nmzxyd, - > stars%ng2,sphhar%ntypsd,atoms%ntype,atoms%lmaxd, - > atoms%jmtd,atoms%ntype,atoms%nat,vacuum%nmzd, - > atoms%neq,stars%ng3,vacuum%nvac,vacuum%nmz, - > vacuum%nmzxy,stars%ng2,sym%nop,sym%nop2,cell%volint, - > input%film,sliceplot%slice,sym%symor, - > sym%invs,sym%invs2,cell%z1,vacuum%delz,atoms%ngopr, - > atoms%ntypsy,atoms%jri,atoms%pos,atoms%taual, - > atoms%zatom,atoms%rmt,atoms%lmax,sym%mrot,sym%tau, - > atoms%rmsh,sym%invtab,cell%amat,cell%bmat,cell%bbmat, - > ikpt,DIMENSION%nvd,nv(jspin),bkpt,cell%omtil, - > k1(:,jspin),k2(:,jspin),k3(:,jspin), - > nslibd,DIMENSION%nbasfcn,DIMENSION%neigd,z, - < dirfacs, - > surfcurr(:,:,:,ikpt)) - - call wann_surfcurr( - > dirfacs,cell%amat, - > jspin,atoms%ntype,atoms%lmaxd,atoms%lmax,atoms%nat, - > atoms%neq,noccbd,lmd,atoms%nat,atoms%llod,atoms%nlod, - > atoms%nlo,atoms%llo, - > acof,bcof,ccof, - > us(:,:,jspin),dus(:,:,jspin),duds(:,:,jspin), - > uds(:,:,jspin), - > ulos(:,:,jspin),dulos(:,:,jspin), - > atoms%rmt,atoms%pos, - & surfcurr(:,:,:,ikpt)) - write(6,*)"dirfacs=",dirfacs - endif - - if(wann%l_soctomom)then - call wann_soc_to_mom( - > jspin,atoms%ntype,atoms%lmaxd,atoms%lmax,atoms%nat, - > atoms%jmtd,atoms%jri,atoms%rmsh,atoms%dx,atoms%neq, - > noccbd,lmd,atoms%nat,atoms%llod,atoms%nlod, - > vso(:,:,1), - > ff(:,:,:,:,jspin),gg(:,:,:,:,jspin), - > acof,bcof,ccof, - & soctomom(:,:,:,ikpt)) - endif - - if(wann%l_nabla)then - call wann_nabla( - > atoms%nlo,atoms%llo, - > jspin,atoms%ntype,atoms%lmaxd,atoms%lmax,atoms%nat, - > atoms%jmtd,atoms%jri,atoms%rmsh,atoms%dx,atoms%neq, - > noccbd,lmd,atoms%nat,atoms%llod,atoms%nlod, - > ff(:,:,:,:,jspin),gg(:,:,:,:,jspin),flo(:,:,:,:,jspin), - > acof,bcof,ccof, - & nablamat(:,:,:,ikpt)) - if(input%film.and..not.oneD%odi%d1)then - call wann_nabla_vac( - > cell%z1,vacuum%nmzd,DIMENSION%nv2d, - > stars%mx1,stars%mx2,stars%mx3, - > stars%ng3,vacuum%nvac,stars%ig,vacuum%nmz,vacuum%delz, - > stars%ig2,cell%area,cell%bmat,cell%bbmat,enpara%evac0(:,jspin), - > bkpt,vz(:,:,jspin2),nslibd,jspin,k1,k2,k3,wannierspin, - > DIMENSION%nvd,DIMENSION%nbasfcn,DIMENSION%neigd,z,nv, - > cell%omtil, - < nablamat(:,:,:,ikpt)) - endif - addnoco=0 - do 41 i = n_rank+1,nv(jspin),n_size - b1(1)=bkpt(1)+k1(i,jspin) - b1(2)=bkpt(2)+k2(i,jspin) - b1(3)=bkpt(3)+k3(i,jspin) - b2(1)=b1(1)*cell%bmat(1,1)+b1(2)*cell%bmat(2,1)+ - + b1(3)*cell%bmat(3,1) - b2(2)=b1(1)*cell%bmat(1,2)+b1(2)*cell%bmat(2,2)+ - + b1(3)*cell%bmat(3,2) - b2(3)=b1(1)*cell%bmat(1,3)+b1(2)*cell%bmat(2,3)+ - + b1(3)*cell%bmat(3,3) - do 42 j = n_rank+1,nv(jspin),n_size -c--> determine index and phase factor - i1 = k1(j,jspin) - k1(i,jspin) - i2 = k2(j,jspin) - k2(i,jspin) - i3 = k3(j,jspin) - k3(i,jspin) - in = stars%ig(i1,i2,i3) - if (in.eq.0) goto 42 - phase = stars%rgphs(i1,i2,i3) - phasust = cmplx(phase,0.0)*stars%ustep(in) - - do m = 1,nslibd - do n = 1,nslibd - do dir=1,3 - -#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) - value=phasust*z(i+addnoco,m)*conjg(z(j+addnoco,n)) - nablamat(dir,m,n,ikpt) = - = nablamat(dir,m,n,ikpt) - - + value*b2(dir) -#else - value=phasust*cmplx(z(i+addnoco,m)*z(j+addnoco,n),0.0) - nablamat(dir,m,n,ikpt) = - = nablamat(dir,m,n,ikpt) - - + value*b2(dir) -#endif - enddo - enddo - enddo - - 42 continue - 41 continue - - endif -#endif -c goto jump no longer needed? -c if ((.not.wann%l_matrixmmn).and.(.not.wann%l_matrixamn).and. -c & (.not.wann%l_bestproj).and.(.not.wann%l_projmethod).and. -c & (.not.wann%l_mmn0)) goto 3 - - -c------mmn0-matrix - if(wann%l_mmn0)then - addnoco=0 - if(noco%l_noco.and.(jspin.eq.2))then - addnoco=nv(1)+nlotot - endif - -c$$$ do 21 i = n_rank+1,nv(jspin),n_size -c$$$ do 22 j = n_rank+1,nv(jspin),n_size -c$$$ -c$$$c--> determine index and phase factor -c$$$ i1 = k1(j,jspin) - k1(i,jspin) -c$$$ i2 = k2(j,jspin) - k2(i,jspin) -c$$$ i3 = k3(j,jspin) - k3(i,jspin) -c$$$c if(abs(i1).gt.stars%mx1.or.abs(i2).gt.stars%mx2 -c$$$c & .or. abs(i3).gt.stars%mx3)print*,"interstitial warning" -c$$$ in = stars%ig(i1,i2,i3) -c$$$ if (in.eq.0) goto 22 -c$$$ phase = stars%rgphs(i1,i2,i3) -c$$$ phasust = cmplx(phase,0.0)*stars%ustep(in) -c$$$ do m = 1,nslibd -c$$$ do n = 1,nslibd -c$$$#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) -c$$$ mmn(m,n,ikpt) = -c$$$ = mmn(m,n,ikpt) + -c$$$ + phasust*z(i+addnoco,m)*conjg(z(j+addnoco,n)) -c$$$#else -c$$$ mmn(m,n,ikpt) = -c$$$ = mmn(m,n,ikpt) + -c$$$ + phasust*cmplx(z(i+addnoco,m)*z(j+addnoco,n),0.0) -c$$$#endif -c$$$ enddo -c$$$ enddo -c$$$ -c$$$ 22 continue -c$$$ 21 continue - -c-----> interstitial contribution to mmn0-matrix - - call wann_mmkb_int( - > cmplx_1,addnoco,addnoco, - > DIMENSION%nvd,stars%mx1,stars%mx2,stars%mx3, - > stars%ng3,k1(:,jspin),k2(:,jspin),k3(:,jspin), - > nv(jspin),DIMENSION%neigd,DIMENSION%nbasfcn,zMat,nslibd, - > k1(:,jspin),k2(:,jspin),k3(:,jspin), - > nv(jspin),zMat,nslibd, - > nbnd, - > stars%rgphs,stars%ustep,stars%ig,(/ 0,0,0 /), - < mmn(:,:,ikpt)) - -c---> spherical contribution to mmn0-matrix - - call wann_mmk0_sph( - > atoms%llod,noccbd,atoms%nlod,atoms%nat,atoms%ntype, - > atoms%lmaxd,atoms%lmax,lmd,atoms%ntype,atoms%neq, - > atoms%nlo,atoms%llo,acof(1:noccbd,:,:), - > bcof(1:noccbd,:,:),ccof(:,1:noccbd,:,:), - > usdus%ddn(:,:,jspin),usdus%uulon(:,:,jspin), - > usdus%dulon(:,:,jspin),usdus%uloulopn, - = mmn(:,:,ikpt)) -c---> vacuum contribution to mmn0-matrix - - if (input%film .and. .not.oneD%odi%d1) then - - call wann_mmk0_vac( - > noco%l_noco,nlotot,qpt_i, - > cell%z1,vacuum%nmzd,DIMENSION%nv2d, - > stars%mx1,stars%mx2,stars%mx3, - > stars%ng3,vacuum%nvac,stars%ig,vacuum%nmz,vacuum%delz, - > stars%ig2,cell%area,cell%bmat, - > cell%bbmat,enpara%evac0(:,jspin),bkpt,vz(:,:,jspin2), - > nslibd,jspin,k1,k2,k3,wannierspin,DIMENSION%nvd, - > DIMENSION%nbasfcn,DIMENSION%neigd,zMat,nv,cell%omtil, - < mmn(:,:,ikpt)) - elseif (oneD%odi%d1) then - - call wann_mmk0_od_vac( - > DIMENSION, oneD, vacuum, stars, cell, - > noco%l_noco,nlotot, - > cell%z1,vacuum%nmzxyd,vacuum%nmzd,DIMENSION%nv2d, - > stars%mx1,stars%mx2,stars%mx3,stars%ng2,stars%ng3, - > stars%ig,vacuum%nmzxy,vacuum%nmz,vacuum%delz,stars%ig2, - > oneD%odi%n2d,cell%bbmat,enpara%evac0(1,jspin),bkpt,oneD%odi%M, - > oneD%odi%mb,vz(:,1,jspin2),oneD%odi, - > nslibd,jspin,k1,k2,k3,wannierspin,DIMENSION%nvd, - > cell%area,DIMENSION%nbasfcn,DIMENSION%neigd,zMat,nv, - > stars%sk2,stars%phi2,cell%omtil,qpt_i, - < mmn(:,:,ikpt)) - - endif - endif !l_mmn0 - -! call cpu_time(tt3) - -c---> overlaps with the trial orbitals - if (wann%l_projmethod.or.wann%l_bestproj.or.wann%l_matrixamn) then - l_amn2=.false. - amnchi = cmplx_1!cmplx(1.,0.) - - call wann_amn ( - > amnchi,nslibd,nwfs,atoms%ntype,atoms%nlod,atoms%llod, - > atoms%llo,atoms%nlo,atoms%lmaxd,atoms%jmtd,lmd, - > atoms%neq,atoms%nat,ikpt,nbnd, - > atoms%rmsh,atoms%rmt,atoms%jri,atoms%dx,atoms%lmax, - > usdus%us(:,:,jspin),usdus%dus(:,:,jspin), - > usdus%uds(:,:,jspin), - > usdus%duds(:,:,jspin),flo(:,:,:,:,jspin), - > ff(:,:,:,:,jspin),gg(:,:,:,:,jspin),acof,bcof,ccof, - > (noco%l_soc.or.noco%l_noco),jspin, - & l_amn2,amn(:,:,ikpt)) - if(l_amn2)then - call wann_amn ( - > amnchi,nslibd,nwfs,atoms%ntype,atoms%nlod,atoms%llod, - > atoms%llo,atoms%nlo,atoms%lmaxd,atoms%jmtd,lmd, - > atoms%neq,atoms%nat,ikpt,nbnd, - > atoms%rmsh,atoms%rmt,atoms%jri,atoms%dx,atoms%lmax, - > usdus%us(:,:,jspin),usdus%dus(:,:,jspin), - > usdus%uds(:,:,jspin), - > usdus%duds(:,:,jspin),flo(:,:,:,:,jspin), - > ff(:,:,:,:,jspin),gg(:,:,:,:,jspin),acof,bcof,ccof, - > (noco%l_soc.or.noco%l_noco),jspin, - & l_amn2,amn(:,:,ikpt),bkpt) - endif -c amn(ikpt,:,:)=amn(ikpt,:,:)*conjg(nsfactor) - endif - -! call cpu_time(tt4) - !if(l_p0) write(*,*)'amn',tt4-tt3 - - -c**************************************************************** -c... vanderbilt mmn matrix -c*************************************************************** - if (wann%l_matrixmmn .and. - > (.not.wann%l_skipkov)) then ! vanderbilt procedure Mmn matrix - allocate ( we_b(DIMENSION%neigd) ) - - !!! the cycle by the nearest neighbors (nntot) for each kpoint - - do 15 ikpt_b = 1,nntot -! call cpu_time(tt3) - - if(pair_to_do(ikpt,ikpt_b).eq.0)cycle !save time by symmetry - kptibz_b=bpt(ikpt_b,ikpt) - if(wann%l_bzsym) oper_b=mapkoper(kptibz_b) - if (wann%l_bzsym) kptibz_b=irreduc(kptibz_b) - - - -! now we need the wavefunctions for k_b kpoint - -c print*,"something to do" - - - call cpu_time(delta) - n_start=1 - n_end=DIMENSION%neigd - - CALL cdn_read( - > eig_id, - > DIMENSION%nvd,input%jspins,mpi%irank,mpi%isize, !wannierspin instead of DIMENSION%jspd? - > kptibz_b,jspin,DIMENSION%nbasfcn, - > noco%l_ss,noco%l_noco,DIMENSION%neigd,n_start,n_end, - < nbands_b,eigg,zzMat) - -! call cpu_time(tt4) - !if(l_p0) write(*,*)'read_eig=',tt4-tt3 - - call cpu_time(delta1) - time_rw=time_rw+delta1-delta - nslibd_b = 0 - - eig_b(:) = 0. - - do i = 1,nbands_b - if((eigg(i).ge.sliceplot%e1s.and.nslibd_b.lt.numbands - & .and.wann%l_bynumber).or. - & (eigg(i).ge.sliceplot%e1s.and.eigg(i).le.sliceplot%e2s.and. - & wann%l_byenergy).or.(i.ge.wann%band_min(jspin).and. - & (i.le.wann%band_max(jspin)).and. - & wann%l_byindex))then - nslibd_b = nslibd_b + 1 - eig_b(nslibd_b) = eigg(i) - we_b(nslibd_b) = we_b(i) - if(noco%l_noco)then - funbas = nv_b(1) + nlotot - funbas = funbas+nv_b(2) + nlotot - else - funbas = nv_b(jspin) + nlotot - endif - IF (zzMat%l_real) THEN - do j = 1,funbas - zMat_b%data_r(j,nslibd_b) = zzMat%data_r(j,i) - enddo - ELSE - do j = 1,funbas - zMat_b%data_c(j,nslibd_b) = zzMat%data_c(j,i) - enddo - END IF - endif - enddo - -c*********************************************************** -c Rotate the wavefunction of next neighbor. -c*********************************************************** - if (wann%l_bzsym .and. (oper_b.ne.1) ) then -! call wann_kptsrotate( -! > atoms%nat,atoms%nlod,atoms%llod, -! > atoms%ntype,atoms%nlo,atoms%llo,atoms%invsat, -! > noco%l_noco,noco%l_soc, -! > atoms%ntype,atoms%neq,nlotot, -! > kveclo_b,jspin, -! > oper_b,sym%nop,sym%mrot,DIMENSION%nvd, -! > nv_b, -! > shiftkpt(:,bpt(ikpt_b,ikpt)), -! > sym%tau, -! x bkpt_b,k1_b(:,:), -! x k2_b(:,:),k3_b(:,:), -! x zMat_b,nsfactor_b) - else - nsfactor_b=cmplx(1.0,0.0) - endif -c print*,"kpt2=",bkpt_b -! call cpu_time(tt5) - !if(l_p0) write(*,*)'nbnd_b=',tt5-tt4 - - noccbd_b = nslibd_b - -ccccc we start with the Mmn matrix ccccccccccccc - -!!! matrix elements of the interstitial overlap -!!! matrix with the weights given by products of -!!! the c-coeff. for different G-vectors, bands and k-points -!!! Mmn(k,b)(IR) = \sum(G,G')C_G^(k,n)*C_G'^(k+b,m)\theta_(G-G') - -cccccccccccc Spherical Contributions ccccccccccccc - - allocate (acof_b(noccbd_b,0:lmd,atoms%nat), - & bcof_b(noccbd_b,0:lmd,atoms%nat), - & ccof_b(-atoms%llod:atoms%llod,noccbd_b,atoms%nlod, - & atoms%nat)) - -!!! get the band-dependent k-dependent ab coeff. - call cpu_time(delta) - - ALLOCATE(lapw_b%k1(SIZE(k1_b,1),SIZE(k1_b,2))) - ALLOCATE(lapw_b%k2(SIZE(k1_b,1),SIZE(k1_b,2))) - ALLOCATE(lapw_b%k3(SIZE(k1_b,1),SIZE(k1_b,2))) - lapw_b%k1 = k1_b - lapw_b%k2 = k2_b - lapw_b%k3 = k3_b - lapw_b%nmat = nmat_b - lapw_b%nv = nv_b - ! I think the other variables of lapw are not needed here. - -! CALL abcof(input,atoms,noccbd_b,sym,cell,bkpt_b,lapw_b, -! + noccbd_b,usdus,noco,jspin,kveclo_b,oneD, -! + acof_b,bcof_b,ccof_b,zMat_b) - - DEALLOCATE(lapw_b%k1,lapw_b%k2,lapw_b%k3) - - call cpu_time(delta1) - time_abcof=time_abcof+delta1-delta - - call wann_abinv( - > atoms%ntype,atoms%nat,noccbd_b,atoms%lmaxd,lmd, - > atoms%llod,atoms%nlod,atoms%ntype,atoms%neq, - > noccbd_b,atoms%lmax,atoms%nlo,atoms%llo,atoms%invsat, - > sym%invsatnr,bkpt_b,atoms%taual, - X acof_b,bcof_b,ccof_b) -! call cpu_time(tt4) - !if(l_p0) write(*,*)'abcof_b=',tt4-tt5 - -ccccccccc Interstitial ccccccccccccccccccccccccc -!!! matrix elements of the interstitial overlap -!!! matrix with the weights given by products of -!!! the c-coeff. for different G-vectors, bands and k-points -!!! Mmn(k,b)(IR) = \sum(G,G')C_G^(k,n)*C_G'^(k+b,m)\theta_(G-G') -c... these overlaps are the same as in the mmk0 case, only differ -c... by the b-dependence of the C-coefficients -ccccccccccccccccccccccccccccccccccccccccccccccccccccc - - call cpu_time(delta) - - addnoco=0 - addnoco2=0 - if(noco%l_noco.and.(jspin.eq.2))then - addnoco = nv(1) + nlotot - addnoco2 = nv_b(1) + nlotot - endif - - call wann_mmkb_int( - > cmplx_1,addnoco,addnoco2, - > DIMENSION%nvd,stars%mx1,stars%mx2,stars%mx3, - > stars%ng3,k1(:,jspin),k2(:,jspin),k3(:,jspin), - > nv(jspin),DIMENSION%neigd,DIMENSION%nbasfcn,zMat,nslibd, - > k1_b(:,jspin),k2_b(:,jspin),k3_b(:,jspin), - > nv_b(jspin),zMat_b,nslibd_b, - > nbnd, - > stars%rgphs,stars%ustep,stars%ig,gb(:,ikpt_b,ikpt), - < mmnk(:,:,ikpt_b,ikpt)) - -! call cpu_time(tt5) - !if(l_p0) write(*,*)'int=',tt5-tt4 - - call cpu_time(delta1) - time_interstitial=time_interstitial+delta1-delta - -cccccccccccc Spherical Contributions ccccccccccccc - call cpu_time(delta) - - chi = cmplx_1 - call wann_mmkb_sph( - > nbnd,atoms%llod,nslibd,nslibd_b,atoms%nlod,atoms%nat, - > atoms%ntype,lmd,atoms%jmtd,atoms%taual,sym%nop,atoms%lmax, - > atoms%ntype,atoms%neq,atoms%nlo,atoms%llo,acof,bcof,ccof, - > bkpt_b,acof_b,bcof_b,ccof_b,gb(:,ikpt_b,ikpt),bkpt, - > ujug,ujdg, - > djug,djdg,ujulog,djulog,ulojug,ulojdg,ulojulog,kdiff, - > nntot,chi, - = mmnk(:,:,ikpt_b,ikpt)) - - -! call cpu_time(tt4) - !if(l_p0) write(*,*)'sph=',tt4-tt5 - - call cpu_time(delta1) - time_mmn=time_mmn+delta1-delta - -c...vacuum contributions - call cpu_time(delta) - if (input%film .and. .not.oneD%odi%d1) then - - call wann_mmkb_vac( - > cmplx_1,noco%l_noco,nlotot,qpt_i, - > nbnd,cell%z1,vacuum%nmzd,DIMENSION%nv2d, - > stars%mx1,stars%mx2,stars%mx3, - > stars%ng3,vacuum%nvac,stars%ig,vacuum%nmz, - > vacuum%delz,stars%ig2,cell%area,cell%bmat, - > cell%bbmat,enpara%evac0(:,jspin), - > enpara%evac0(:,jspin_b), - > bkpt,bkpt_b,vz(:,:,jspin2),vz(:,:,jspin2_b), - > nslibd,nslibd_b,jspin,jspin_b, - > k1,k2,k3,k1_b,k2_b,k3_b, - > wannierspin,DIMENSION%nvd, - > DIMENSION%nbasfcn,DIMENSION%neigd,zMat,zMat_b, - > nv,nv_b,cell%omtil, - > gb(:,ikpt_b,ikpt), - < mmnk(:,:,ikpt_b,ikpt)) - elseif (oneD%odi%d1) then - - call wann_mmkb_od_vac( - > DIMENSION,oneD,vacuum,stars,cell, - > cmplx_1,noco%l_noco,nlotot, - > nbnd,cell%z1,vacuum%nmzxyd,vacuum%nmzd,DIMENSION%nv2d, - > stars%mx1,stars%mx2,stars%mx3,stars%ng2,stars%ng3, - > stars%ig,vacuum%nmzxy, - > vacuum%nmz,vacuum%delz,stars%ig2,oneD%odi%n2d, - > cell%bbmat,enpara%evac0(1,jspin),enpara%evac0(1,jspin_b), - > bkpt,bkpt_b,oneD%odi%M,oneD%odi%mb, - > vz(:,1,jspin2),vz(:,1,jspin2_b),oneD%odi, - > nslibd,nslibd_b,jspin,jspin_b,k1,k2,k3,k1_b,k2_b,k3_b, - > wannierspin,DIMENSION%nvd,cell%area,DIMENSION%nbasfcn, - > DIMENSION%neigd, - > zMat,zMat_b,nv,nv_b,stars%sk2,stars%phi2,cell%omtil, - > gb(:,ikpt_b,ikpt),qpt_i, - > .false.,1, - < mmnk(:,:,ikpt_b,ikpt)) - endif - -c mmnk(:,:,ikpt_b,ikpt)= -c & mmnk(:,:,ikpt_b,ikpt)*nsfactor*conjg(nsfactor_b) -! call cpu_time(tt5) - !if(l_p0) write(*,*)'film=',tt5-tt4 - - call cpu_time(delta1) - time_film=time_film+delta1-delta - - deallocate ( acof_b,bcof_b,ccof_b ) - -! call cpu_time(tt4) - !if(l_p0) write(*,*)'k-neig',ikpt_b,' total=',tt4-tt3 -! t_kov=t_kov+tt4-tt3 - -15 continue ! end of loop by the nearest k-neighbors - - deallocate ( we_b ) - - endif!l_matrixmmn=.true. - - 9900 continue ! jump for doublespin loop - - if (wann%l_matrixmmn) then ! vanderbilt procedure Mmn matrix - -c*******************************************c -c START Q-NEIGHBOR LOOP c -c*******************************************c - allocate ( we_qb(DIMENSION%neigd) ) - - DO iqpt_b=1,nntot_q -! call cpu_time(tt3) - IF(.NOT.l_gwf) EXIT ! old functionality - - qptibz_b = bpt_q(iqpt_b,iqpt) - IF(qptibz_b.EQ.qptibz) CYCLE ! no need to compute overlaps - ! with periodic images for now - - qptb_i = noco%qss - alphb_i = noco%alph - betab_i = noco%beta - thetab_i = noco%theta - phib_i = noco%phi - if(wann%l_sgwf) then - qptb_i(:) = wann%param_vec(:,qptibz_b) - alphb_i(:) = wann%param_alpha(:,qptibz_b) - elseif(wann%l_socgwf) then - if(wann%l_dim(2)) phib_i = tpi*wann%param_vec(2,qptibz_b) - if(wann%l_dim(3)) thetab_i = tpi*wann%param_vec(3,qptibz_b) - endif - - !if(pair_to_do_q(iqpt,iqpt_b).eq.0)cycle ! TODO: use symmetry - if(wann%l_bzsym) oper_qb=mapqoper(qptibz_b) - if (wann%l_bzsym) qptibz_b=irreduc_q(qptibz_b) - - n_start=1 - n_end=DIMENSION%neigd - -! read in diagonalization information from corresponding -! eig file to q-point iqpt_b at a given k-point ikpt. -! as a check verify that bkpt.eq.bqpt (same k). -! moreover, the plane-wave vectors G(k,q+b) are stored -! in (k1_qb,k2_qb,k3_qb) for later use. - - CALL cdn_read( - > innerEig_idList(iqpt_b), - > DIMENSION%nvd,input%jspins,mpi%irank,mpi%isize, !wannierspin instead of DIMENSION%jspd? !kptibz_b2? - > kptibz,jspin_b,DIMENSION%nbasfcn, - > noco%l_ss,noco%l_noco,DIMENSION%neigd,n_start, - > n_end, - < nbands_qb,eigg, - < zzMat) - -! call cpu_time(tt4) - !if(l_p0) write(*,*)'read_eig=',tt4-tt3 - - ! are we dealing with the same k-point at which - ! we want to construct A,B,C coefficients etc. ? - IF(ANY(bqpt.NE.bkpt)) CALL juDFT_error("bqpt.ne.bkpt", - > calledby="wannier") - - zMat_qb%l_real = zzMat%l_real - zMat_qb%matsize1 = zzMat%matsize1 - zMat_qb%matsize2 = zzMat%matsize2 - IF (zzMat%l_real) THEN - ALLOCATE (zMat_qb%data_r(zMat%matsize1,zMat%matsize2)) - zMat_qb%data_r = 0.0 - ELSE - ALLOCATE (zMat_qb%data_c(zMat%matsize1,zMat%matsize2)) - zMat_qb%data_c = CMPLX(0.0,0.0) - END IF - - eig_qb(:) = 0. - - nslibd_qb = 0 - do i = 1,nbands_qb - if((eigg(i).ge.sliceplot%e1s.and.nslibd_qb.lt.numbands - & .and.wann%l_bynumber).or. - & (eigg(i).ge.sliceplot%e1s.and.eigg(i).le.sliceplot%e2s.and. - & wann%l_byenergy).or.(i.ge.wann%band_min(jspin).and. - & (i.le.wann%band_max(jspin)).and.wann%l_byindex)) then - nslibd_qb = nslibd_qb + 1 - eig_qb(nslibd_qb) = eigg(i) - we_qb(nslibd_qb) = we_qb(i) - if(noco%l_noco)then - funbas = nv_qb(1) + nlotot - funbas = funbas+nv_qb(2) + nlotot - else - funbas = nv_qb(jspin_b) + nlotot - endif - IF (zzMat%l_real) THEN - do j = 1,funbas - zMat_qb%data_r(j,nslibd_qb) = zzMat%data_r(j,i) - enddo - ELSE - do j = 1,funbas - zMat_qb%data_c(j,nslibd_qb) = zzMat%data_c(j,i) - enddo - END IF - endif - enddo - -! check that eigenvectors and -values are identical if q=q+b - if(iqpt.eq.qptibz_b .and. jspin.eq.jspin_b) then - IF(zMat%l_real) THEN - if(any(zMat%data_r.ne.zMat_qb%data_r)) - + write(*,*)'z.ne.z_qb',iqpt,ikpt - ELSE - if(any(zMat%data_c.ne.zMat_qb%data_c)) - + write(*,*)'z.ne.z_qb',iqpt,ikpt - END IF - if(any(eig.ne.eig_qb)) write(*,*)'eig.ne.eiq_qb',iqpt,ikpt - if(nv(jspin).ne.nv_qb(jspin)) write(*,*)'nv!=nv_qb',iqpt,ikpt - endif - -! check that number of bands are the same at (k,q) and (k,q+b) - if(nslibd.ne.nslibd_qb) - > write(*,*)'nslibd.ne.nslibd_qb',ikpt,iqpt,iqpt_b - - - noccbd_qb = nslibd_qb - nsfactor_b=cmplx(1.0,0.0) - -! call cpu_time(tt5) - !if(l_p0) write(*,*)'nbnd_qb=',tt5-tt4 - - allocate (acof_qb(noccbd_qb,0:lmd,atoms%nat), - & bcof_qb(noccbd_qb,0:lmd,atoms%nat), - & ccof_qb(-atoms%llod:atoms%llod,noccbd_qb,atoms%nlod, - & atoms%nat)) - - acof_qb(:,:,:) = cmplx(0.,0.) ; bcof_qb(:,:,:) = cmplx(0.,0.) - ccof_qb(:,:,:,:) = cmplx(0.,0.) - -! construct the A,B,C coefficients of the wave function -! at the point (k,q+b) using previously read information - - ALLOCATE(lapw_qb%k1(SIZE(k1_qb,1),SIZE(k1_qb,2))) - ALLOCATE(lapw_qb%k2(SIZE(k1_qb,1),SIZE(k1_qb,2))) - ALLOCATE(lapw_qb%k3(SIZE(k1_qb,1),SIZE(k1_qb,2))) - lapw_qb%k1 = k1_qb - lapw_qb%k2 = k2_qb - lapw_qb%k3 = k3_qb - lapw_qb%nmat = nmat_qb - lapw_qb%nv = nv_qb - ! I think the other variables of lapw are not needed here. - -! CALL abcof(input,atoms,noccbd_qb,sym,cell,bkpt,lapw_qb, -! + noccbd_qb,usdus,noco,jspin_b,kveclo_qb,oneD, -! + acof_qb,bcof_qb,ccof_qb,zMat_qb) - - DEALLOCATE(lapw_qb%k1,lapw_qb%k2,lapw_qb%k3) - - call wann_abinv( - > atoms%ntype,atoms%nat,noccbd_qb,atoms%lmaxd,lmd, - > atoms%llod,atoms%nlod,atoms%ntype,atoms%neq, - > noccbd_qb,atoms%lmax,atoms%nlo,atoms%llo,atoms%invsat, - > sym%invsatnr, - > bqpt, ! does not enter - > atoms%taual, ! does not enter - X acof_qb,bcof_qb,ccof_qb) - -! check that A,B,C coefficients are the same if q+b = q - if(l_gwf.and.(iqpt.eq.qptibz_b).and.(jspin.eq.jspin_b)) then - if(any(acof_qb.ne.acof)) write(*,*)'acof',iqpt,ikpt - if(any(bcof_qb.ne.bcof)) write(*,*)'bcof',iqpt,ikpt - if(any(ccof_qb.ne.ccof)) write(*,*)'ccof',iqpt,ikpt - endif - -! call cpu_time(tt4) - !if(l_p0) write(*,*)'abcof_qb=',tt4-tt5 - - addnoco=0 - addnoco2=0 - if(noco%l_noco.and.(jspin.eq.2))then - addnoco = nv(1) + nlotot - endif - if(noco%l_noco.and.(jspin_b.eq.2))then - addnoco2 = nv_qb(1) + nlotot - endif - - -! set up local->global transformation for overlaps - do n=1,atoms%ntype - if(wann%l_sgwf) then - dalph = alph_i(n)-alphb_i(n) - db1 = beta_i(n)/2. - db2 = betab_i(n)/2. - elseif(wann%l_socgwf) then - dalph = phi_i-phib_i - db1 = theta_i/2. - db2 = thetab_i/2. - endif - coph = cos(dalph) - siph = sin(dalph) - phasfac = cmplx(coph,siph) - phasfac2= cmplx(coph,-siph) - - if(l_p0 .and. dalph.ne.0.0) then - write(*,*)'WARNING: include dalph in chi trafo!' - endif - - if( (jspin.eq.1) .and. (jspin_b.eq.1) ) then ! uu -! chi(n) = cos(db1)*cos(db2)*phasfac -! > + sin(db1)*sin(db2)*phasfac2 - chi(n) = cos(db2-db1) - elseif( (jspin.eq.2) .and. (jspin_b.eq.2) ) then !dd -! chi(n) = cos(db1)*cos(db2)*phasfac2 -! > + sin(db1)*sin(db2)*phasfac - chi(n) = cos(db2-db1) - elseif( (jspin.eq.1) .and. (jspin_b.eq.2) ) then ! ud -! chi(n) = sin(db1)*cos(db2)*phasfac2 -! > - cos(db1)*sin(db2)*phasfac - chi(n) = -sin(db2-db1) - elseif( (jspin.eq.2) .and. (jspin_b.eq.1) ) then ! du -! chi(n) = cos(db1)*sin(db2)*phasfac2 -! > - sin(db1)*cos(db2)*phasfac - chi(n) = sin(db2-db1) - else - stop 'problem setting up chi: jspin,jspin_b' - endif - enddo - chi = conjg(chi) - !chi = cmplx_1 - - ! optional: disable chi transformation - ! instead of computing overlap w.r.t. global frame - ! only consider wave function overlaps in local frames - if(l_nochi) then - if(doublespin.lt.3) then - chi = cmplx(1.0,0.0) - else - chi = cmplx(0.0,0.0) - endif - endif - - if((iqpt.eq.1).and.(ikpt.eq.1).and.(iqpt_b.eq.1)) then - write(*,*)'dbs',doublespin,'chi',chi(1) - endif - -! muffin tin contribution to overlap is computed taking into account -! the spin-dependent phase exp(+/- tau*b/2) and the ujugaunt integrals -! calculated especially for the q-points before. then, q and q+b -! take the role of k and k+b and the same for G(q+b) and G(k+b) - if(wann%l_sgwf) call wann_mmkb_sph( - > nbnd,atoms%llod,nslibd,nslibd_qb,atoms%nlod,atoms%nat, - > atoms%ntype,lmd,atoms%jmtd,sign_q*atoms%taual/2.0,sym%nop, - > atoms%lmax,atoms%ntype,atoms%neq,atoms%nlo,atoms%llo, - > acof,bcof,ccof,qptb_i, - > acof_qb,bcof_qb,ccof_qb,gb_q(:,iqpt_b,iqpt),qpt_i, - > ujug_q,ujdg_q, - > djug_q,djdg_q,ujulog_q,djulog_q,ulojug_q,ulojdg_q, - > ulojulog_q,qdiff, - > nntot_q,chi, - = mmnk_q(:,:,iqpt_b,ikpt)) - if(wann%l_socgwf) call wann_mmkb_sph( - > nbnd,atoms%llod,nslibd,nslibd_qb,atoms%nlod,atoms%nat, - > atoms%ntype,lmd,atoms%jmtd, - > zero_taual,sym%nop,atoms%lmax, - > atoms%ntype,atoms%neq,atoms%nlo,atoms%llo,acof,bcof,ccof, - > (/ 0.0, phib_i/tpi, thetab_i/tpi /), - > acof_qb,bcof_qb,ccof_qb,gb_q(:,iqpt_b,iqpt), - > (/ 0.0, phi_i/tpi, theta_i/tpi /), - > ujug_q,ujdg_q, - > djug_q,djdg_q,ujulog_q,djulog_q,ulojug_q,ulojdg_q, - > ulojulog_q,qdiff, - > nntot_q,chi, - = mmnk_q(:,:,iqpt_b,ikpt)) - -! call cpu_time(tt5) - !if(l_p0) write(*,*)'sph=',tt5-tt4 - - - if(((doublespin.ne.3).and.(doublespin.ne.4)) - > .or.(.not.noco%l_noco)) then - - if(.not.noco%l_noco)then - interchi=chi(1) - vacchi=chi(1) - else - interchi=cmplx_1 - vacchi=cmplx_1 - endif - -! call cpu_time(tt4) -! interstitial contribution to overlap is computed using -! (-/+ 1)*G(q+b)/2 as G-vector connecting neighbors -! and lattice vectors G(k,q) (k1...) and G(k,q+b) (k1_qb...) - if(wann%l_sgwf) call wann_mmkb_int( - > interchi,addnoco,addnoco2, - > DIMENSION%nvd,stars%mx1,stars%mx2,stars%mx3, - > stars%ng3,k1(:,jspin),k2(:,jspin),k3(:,jspin), - > nv(jspin),DIMENSION%neigd,DIMENSION%nbasfcn,zMat,nslibd, - > k1_qb(:,jspin_b),k2_qb(:,jspin_b),k3_qb(:,jspin_b), - > nv_qb(jspin_b),zMat_qb,nslibd_qb, - > nbnd, - > stars%rgphs,stars%ustep,stars%ig, - > sign_q*gb_q(:,iqpt_b,iqpt)/2, - = mmnk_q(:,:,iqpt_b,ikpt)) - if(wann%l_socgwf) call wann_mmkb_int( - > interchi,addnoco,addnoco2, - > DIMENSION%nvd,stars%mx1,stars%mx2,stars%mx3, - > stars%ng3,k1(:,jspin),k2(:,jspin),k3(:,jspin), - > nv(jspin),DIMENSION%neigd,DIMENSION%nbasfcn,zMat,nslibd, - > k1_qb(:,jspin_b),k2_qb(:,jspin_b),k3_qb(:,jspin_b), - > nv_qb(jspin_b),zMat_qb,nslibd_qb, - > nbnd, - > stars%rgphs,stars%ustep,stars%ig,(/ 0, 0, 0 /), - = mmnk_q(:,:,iqpt_b,ikpt))!m_int(:,:,iqpt_b,ikpt)) - -! call cpu_time(tt5) - !if(l_p0) write(*,*)'int=',tt5-tt4 - -! vacuum contribution in film calculation - if (input%film .and. .not.oneD%odi%d1) then - if(wann%l_sgwf) call wann_mmkb_vac( - > vacchi,noco%l_noco,nlotot,sign_q*2.*bkpt, - > nbnd,cell%z1,vacuum%nmzd,DIMENSION%nv2d, - > stars%mx1,stars%mx2,stars%mx3, - > stars%ng3,vacuum%nvac,stars%ig,vacuum%nmz, - > vacuum%delz,stars%ig2,cell%area,cell%bmat, - > cell%bbmat,enpara%evac0(:,jspin),enpara%evac0(:,jspin_b), - > sign_q*qpt_i/2., - > sign_q*qptb_i/2., - > vz(:,:,jspin2),vz(:,:,jspin2_b), - > nslibd,nslibd_qb,jspin,jspin_b, - > k1,k2,k3,k1_qb,k2_qb,k3_qb, - > wannierspin,DIMENSION%nvd, - > DIMENSION%nbasfcn,DIMENSION%neigd,zMat,zMat_qb,nv, - > nv_qb,cell%omtil, - > sign_q*gb_q(:,iqpt_b,iqpt)/2, - = mmnk_q(:,:,iqpt_b,ikpt)) - if(wann%l_socgwf) call wann_mmkb_vac( - > vacchi,noco%l_noco,nlotot,qpt_i, - > nbnd,cell%z1,vacuum%nmzd,DIMENSION%nv2d, - > stars%mx1,stars%mx2,stars%mx3, - > stars%ng3,vacuum%nvac,stars%ig,vacuum%nmz, - > vacuum%delz,stars%ig2,cell%area,cell%bmat, - > cell%bbmat,enpara%evac0(:,jspin),enpara%evac0(:,jspin_b), - > bqpt,bqpt, - > vz(:,:,jspin2),vz(:,:,jspin2_b), - > nslibd,nslibd_qb,jspin,jspin_b, - > k1,k2,k3,k1_qb,k2_qb,k3_qb, - > wannierspin,DIMENSION%nvd, - > DIMENSION%nbasfcn,DIMENSION%neigd,zMat,zMat_qb,nv, - > nv_qb,cell%omtil, - > (/ 0, 0, 0 /), - = mmnk_q(:,:,iqpt_b,ikpt)) - -! vacuum contribution in one-dimensional chain calculation where -! q-point plays role of k-point with proper prefactor of (-/+ 1/2). -! moreover, the k-point ikpt is treated like qss in the subroutine -! such that a correction for sign and factor has to appear as well. -! lattice vectors G(k,q) (k1...) and G(k,q+b) (k1_qb...) need to -! be provided. - elseif (oneD%odi%d1) then - if(wann%l_sgwf) call wann_mmkb_od_vac( - > DIMENSION,oneD,vacuum,stars,cell, - > vacchi,noco%l_noco,nlotot, - > nbnd,cell%z1,vacuum%nmzxyd,vacuum%nmzd,DIMENSION%nv2d, - > stars%mx1,stars%mx2,stars%mx3,stars%ng2,stars%ng3, - > stars%ig,vacuum%nmzxy, - > vacuum%nmz,vacuum%delz,stars%ig2,oneD%odi%n2d, - > cell%bbmat,enpara%evac0(1,jspin),enpara%evac0(1,jspin_b), - > sign_q*qpt_i/2.,sign_q*qptb_i/2., - > oneD%odi%M,oneD%odi%mb, - > vz(:,1,jspin2),vz(:,1,jspin2_b),oneD%odi, - > nslibd,nslibd_qb,jspin,jspin_b, - > k1,k2,k3,k1_qb,k2_qb,k3_qb, - > wannierspin,DIMENSION%nvd,cell%area,DIMENSION%nbasfcn, - > DIMENSION%neigd,zMat,zMat_qb,nv,nv_qb,stars%sk2, - > stars%phi2,cell%omtil, - > sign_q*gb_q(:,iqpt_b,iqpt)/2,sign_q*2.*bkpt, - > .true.,sign_q, - = mmnk_q(:,:,iqpt_b,ikpt)) - if(wann%l_socgwf) call wann_mmkb_od_vac( - > DIMENSION,oneD,vacuum,stars,cell, - > vacchi,noco%l_noco,nlotot, - > nbnd,cell%z1,vacuum%nmzxyd,vacuum%nmzd,DIMENSION%nv2d, - > stars%mx1,stars%mx2,stars%mx3,stars%ng2,stars%ng3, - > stars%ig,vacuum%nmzxy, - > vacuum%nmz,vacuum%delz,stars%ig2,oneD%odi%n2d, - > cell%bbmat,enpara%evac0(1,jspin),enpara%evac0(1,jspin_b), - > bqpt,bqpt, - > oneD%odi%M,oneD%odi%mb, - > vz(:,1,jspin2),vz(:,1,jspin2_b),oneD%odi, - > nslibd,nslibd_qb,jspin,jspin_b, - > k1,k2,k3,k1_qb,k2_qb,k3_qb, - > wannierspin,DIMENSION%nvd,cell%area,DIMENSION%nbasfcn, - > DIMENSION%neigd,zMat,zMat_qb,nv,nv_qb,stars%sk2, - > stars%phi2,cell%omtil, - > (/ 0, 0, 0 /),qpt_i, - > .false.,1, - = mmnk_q(:,:,iqpt_b,ikpt)) - endif!film resp. odi - -! call cpu_time(tt4) - !if(l_p0) write(*,*)'film=',tt4-tt5 - - endif!doublespin - - deallocate ( acof_qb,bcof_qb,ccof_qb ) - -! call cpu_time(tt4) - !if(l_p0) write(*,*)'q-neig',iqpt_b,' total=',tt4-tt3 - t_qov=t_qov+tt4-tt3 - - ENDDO !iqpt_b, q-neighbors -c**************************************************c -c END Q-NEIGHBOR LOOP c -c**************************************************c - - deallocate ( we_qb ) - - endif ! if wann%l_matrixmmn = true - -c$$$ 3 continue !goto jump no longer needed? - - if(.not.wann%l_bzsym)oper=0 - if(.not.wann%l_plot_symm.or.oper.eq.1)then - if (wann%l_wann_plot .and. - > (doublespin.eq.1 .or. doublespin.eq.2)) then - - addnoco=0 - if(noco%l_noco.and.(jspin.eq.2))then - addnoco=nv(1)+nlotot - endif - - if (sliceplot%slice) then - if (ikpt.eq.sliceplot%kk) then - - write (6,*) 'nnne=',sliceplot%nnne - write (6,*) 'eig(nnne)=',eig(sliceplot%nnne) - write (6,*) 'we(nnne)=',we(sliceplot%nnne) - - call wann_plot( - > DIMENSION,oneD,vacuum,stars,cell,atoms, - > DIMENSION%nv2d,jspin,oneD%odi,oneD%ods,stars%ng3, - > vacuum%nmzxyd, - > stars%ng2,sphhar%ntypsd,atoms%ntype,atoms%lmaxd, - > atoms%jmtd,atoms%ntype,atoms%nat,vacuum%nmzd,atoms%neq, - > stars%ng3,vacuum%nvac,vacuum%nmz,vacuum%nmzxy,stars%ng2, - > sym%nop,sym%nop2,cell%volint,input%film,sliceplot%slice, - > sym%symor,sym%invs,sym%invs2,cell%z1,vacuum%delz, - > atoms%ngopr,atoms%ntypsy,atoms%jri,atoms%pos,atoms%zatom, - > atoms%lmax,sym%mrot,sym%tau,atoms%rmsh,sym%invtab, - > cell%amat,cell%bmat,cell%bbmat,ikpt,sliceplot%nnne, - > sliceplot%kk,DIMENSION%nvd,atoms%nlod,atoms%llod, - > nv(jspin),lmd,bkpt,cell%omtil,atoms%nlo,atoms%llo, - > k1(:,jspin),k2(:,jspin),k3(:,jspin),enpara%evac0(:,jspin), - > vz(:,:,jspin2), - > nslibd,DIMENSION%nbasfcn,DIMENSION%neigd, - > ff(:,:,:,:,jspin), - > gg(:,:,:,:,jspin),flo,acof,bcof,ccof,zMat, - > stars%mx1,stars%mx2,stars%mx3,stars%ig,stars%ig2, - > stars%sk2,stars%phi2, - > noco%l_noco,noco%l_ss,qpt_i, - > addnoco,get_index_kq(ikpt,iqpt,fullnkpts),wann%l_sgwf) - - endif - else ! not sliceplot%slice - - call wann_plot( - > DIMENSION,oneD,vacuum,stars,cell,atoms, - > DIMENSION%nv2d,jspin,oneD%odi,oneD%ods,stars%ng3, - > vacuum%nmzxyd, - > stars%ng2,sphhar%ntypsd,atoms%ntype,atoms%lmaxd, - > atoms%jmtd,atoms%ntype,atoms%nat,vacuum%nmzd,atoms%neq, - > stars%ng3,vacuum%nvac,vacuum%nmz,vacuum%nmzxy,stars%ng2, - > sym%nop,sym%nop2,cell%volint,input%film,sliceplot%slice, - > sym%symor,sym%invs,sym%invs2,cell%z1,vacuum%delz, - > atoms%ngopr,atoms%ntypsy,atoms%jri,atoms%pos,atoms%zatom, - > atoms%lmax,sym%mrot,sym%tau,atoms%rmsh,sym%invtab, - > cell%amat,cell%bmat,cell%bbmat,ikpt,sliceplot%nnne, - > sliceplot%kk,DIMENSION%nvd,atoms%nlod,atoms%llod, - > nv(jspin),lmd,bkpt,cell%omtil,atoms%nlo,atoms%llo, - > k1(:,jspin),k2(:,jspin),k3(:,jspin),enpara%evac0(:,jspin), - > vz(:,:,jspin2), - > nslibd,DIMENSION%nbasfcn,DIMENSION%neigd, - > ff(:,:,:,:,jspin), - > gg(:,:,:,:,jspin),flo,acof,bcof,ccof,zMat, - > stars%mx1,stars%mx2,stars%mx3,stars%ig,stars%ig2, - > stars%sk2,stars%phi2, - > noco%l_noco,noco%l_ss,qpt_i, - > addnoco,get_index_kq(ikpt,iqpt,fullnkpts),wann%l_sgwf) - - if(wann%l_plot_symm.and.wann%l_bzsym)then - do kplot=1,fullnkpts - if(irreduc(kplot).eq.kptibz)then - plotoper=mapkoper(kplot) - if(plotoper.lt.0)then - plotoper=-plotoper - l_conjugate=.true. - else - l_conjugate=.false. - endif - kplotoper=sym%invtab(plotoper) - call wann_plot_symm(jspin,sym%mrot(:,:,kplotoper),ikpt, - & kplot,l_conjugate) - endif - enddo - endif - - endif - endif - endif !wann%l_plot_symm - deallocate ( acof,bcof,ccof,we,eigg ) - - if(wann%l_projmethod.or.wann%l_bestproj)then - call wann_projmethod( - > fullnkpts, - > wann%l_projmethod,wann%l_bestproj, - > ikpt,nwfs,nslibd,amn,eig, - < psiw,hwfr) - endif ! projmethod - - endif ! loop by processors - -! call cpu_time(tt3) - !if(l_p0) write(*,*)'k-loop',ikpt,' total=',tt3-tt2 -10 continue ! end of cycle by the k-points - - - if(wann%l_matrixmmn) - & deallocate(ujug,ujdg,djug,djdg, - & ujulog,djulog,ulojulog,ulojug,ulojdg) - if(wann%l_matrixmmn.AND.l_gwf) - & deallocate(ujug_q,ujdg_q,djug_q, - & djdg_q,ujulog_q,djulog_q,ulojulog_q,ulojug_q, - & ulojdg_q) - -#ifdef CPP_MPI - call MPI_BARRIER(mpi%mpi_comm,ierr) -#endif - - -c****************************************************** -c Write down the projections. -c****************************************************** - 5 continue - - if(doublespin.eq.3 .or. doublespin.eq.4) goto 912 - - if(wann%l_nabla)then - hescale=tpi*condquant/bohrtocm/cell%omtil - hescale=sqrt(hescale) - nablamat=nablamat*hescale - call wann_write_nabla( - > mpi%mpi_comm,l_p0,spin12(jspin)//'.nabl', - > 'Matrix elements of nabla operator', - > nbnd,fullnkpts,nbnd, - > mpi%irank,mpi%isize, - < nablamat) - endif - - if(wann%l_soctomom)then - hescale=tpi*condquant/bohrtocm/cell%omtil - hescale=sqrt(hescale) - soctomom=soctomom*hescale - call wann_write_nabla( - > mpi%mpi_comm,l_p0,spin12(jspin)//'.stm', - > 'Matrix elements of stm operator', - > nbnd,fullnkpts,nbnd, - > mpi%irank,mpi%isize, - < soctomom) - endif - - if(wann%l_surfcurr)then - surfcurr = conjg( surfcurr/cmplx(0.0,2.0) ) - hescale=tpi*condquant/bohrtocm/cell%omtil - hescale=sqrt(hescale) - surfcurr=surfcurr*hescale - call wann_write_nabla( - > mpi%mpi_comm,l_p0,spin12(jspin)//'.surfcurr', - > 'Surface currents', - > nbnd,fullnkpts,nbnd, - > mpi%irank,mpi%isize, - < surfcurr) - endif - - if((noco%l_soc.or.noco%l_noco).and.wann%l_mmn0)then - call wann_write_amn( - > mpi%mpi_comm, - > l_p0,spin12(jspin)//trim(fending)//'.socmmn0', - > 'Overlaps of the wavefunct. at the same kpoint', - > nbnd,fullnkpts,nbnd, - > mpi%irank,mpi%isize,.false., - < mmn,.false.) - endif !noco%l_soc and l_mmn0 - - if(wann%l_orbcomp)then - num_angl=9 - if(wann%l_oc_f)num_angl=16 - call wann_write_matrix5( - > mpi%mpi_comm,l_p0,spin12(jspin)//'.orbcomp', - > 'angular components', - > nbnd,nbnd, - > num_angl,wann%oc_num_orbs,fullnkpts, - > mpi%irank,mpi%isize, - < orbcomp) - endif - - if((noco%l_soc.or.noco%l_noco) .and. (doublespin.eq.1)) then - if(wann%l_mmn0) socmmn(:,:,:)=mmn(:,:,:) - goto 912 - endif - - if(noco%l_soc.or.noco%l_noco) then - jspin2=1 - if(wann%l_mmn0) mmn(:,:,:)=socmmn(:,:,:)+mmn(:,:,:) - if(wann%l_mmn0) deallocate(socmmn) - endif - -! call cpu_time(tt3) - if (wann%l_matrixamn)then - call wann_write_amn( - > mpi%mpi_comm, - > l_p0,spin12(jspin2)//trim(fending)//'.amn', - > 'Overlaps of the wavefunct. with the trial orbitals', - > nbnd,fullnkpts,nwfs, - > mpi%irank,mpi%isize,.false., - < amn(:,:,:),wann%l_unformatted) - endif !wann%l_matrixamn -! call cpu_time(tt4) - !if(l_p0) write(*,*)'write amn=',tt4-tt3 - - if(wann%l_anglmom)then - call wann_write_matrix4( - > mpi%mpi_comm, - > l_p0,spin12(jspin2)//trim(fending)//'.anglmom', - > 'Matrix elements of angular momentum', - > nbnd,nbnd,3,fullnkpts, - > mpi%irank,mpi%isize, - < anglmom) - endif - - if (l_proj) then -c************************************************************** -c for projmethod: write down WF1.umn -c************************************************************* - if((wann%l_projmethod.or.wann%l_bestproj))then - call wann_write_amn( - > mpi%mpi_comm,l_p0,spin12(jspin2)//'.umn', - > 'transformation to first guess Wannier functions', - > nbnd,fullnkpts,nwfs, - > mpi%irank,mpi%isize,.false., - < psiw,.false.) -#ifdef CPP_MPI - allocate( hwfr2(size(hwfr,1),size(hwfr,2)) ) - length=nwfs*nwfs - CALL MPI_REDUCE( - + hwfr,hwfr2,length, - + CPP_MPI_COMPLEX,MPI_SUM,0, - + mpi%mpi_comm,ierr) - hwfr=hwfr2 - deallocate(hwfr2) -#endif -c******************************************************** -c projmethod: hamiltonian matrix in real space -c******************************************************** - if(l_p0)then - write (6,*) 'the hamiltonian matrix in real space:' - do i = 1,nwfs - do j = 1,nwfs - write (6,*) ' WFs:',i,'and',j - write (6,*) ' matrix element:',hwfr(i,j) - enddo - enddo - endif !l_p0 - deallocate(hwfr) - endif !wann%l_projmethod or wann%l_bestproj - endif !l_proj - -c********************************************************* -c.....write down the mmn0 matrix -c********************************************************* - - if(wann%l_mmn0)then - call wann_write_amn( - > mpi%mpi_comm, - > l_p0,spin12(jspin2)//trim(fending)//'.mmn0', - > 'Overlaps of the wavefunct. at the same kpoint', - > nbnd,fullnkpts,nbnd, - > mpi%irank,mpi%isize,.false., - < mmn,.false.) - endif !wann%l_mmn0 - - -c***************************************************** -c.....write down the matrix M^{k,b}_{mn} -c***************************************************** - -! 912 continue -! call cpu_time(tt3) - if(wann%l_matrixmmn.and.(.not.wann%l_skipkov))then - call wann_write_mmnk( - > mpi%mpi_comm,jspin2,l_p0,fullnkpts,nntot,wann, - > maptopair,pair_to_do,nbnd,bpt,gb, - > mpi%isize,mpi%irank,fending, - < mmnk,wann%l_unformatted) - endif !wann%l_matrixmmn -! call cpu_time(tt4) - !if(l_p0) write(*,*)'write mmnk=',tt4-tt3 - - 912 continue - - - call cpu_time(tt3) - if(l_gwf .and. wann%l_matrixmmn) then -! mmnk_q = mmnk_q + m_sph+m_int+m_vac - if(doublespin.eq.doublespin_max) then - write(fname,'("param_",i4.4,".mmn")')iqpt - call wann_write_mmnk2(l_p0,fullnkpts,nntot_q,wann, - > nbnd,bpt_q(:,iqpt),gb_q(:,:,iqpt)/2, - > mpi%isize,mpi%irank,fname,mmnk_q, - > wann%l_unformatted) - endif - - if(.false.) then - write(fname,'("param_",i4.4,"_",i1,".mmn")')iqpt,doublespin - call wann_write_mmnk2(l_p0,fullnkpts,nntot_q,wann, - > nbnd,bpt_q(:,iqpt),gb_q(:,:,iqpt)/2, - > mpi%isize,mpi%irank,fname, - > m_sph+m_int+m_vac,wann%l_unformatted) - - write(fname,'("param_",i4.4,"_",i1,"_int.mmn")')iqpt,doublespin - call wann_write_mmnk2(l_p0,fullnkpts,nntot_q,wann, - > nbnd,bpt_q(:,iqpt),gb_q(:,:,iqpt)/2, - > mpi%isize,mpi%irank,fname,m_int, - > wann%l_unformatted) - write(fname,'("param_",i4.4,"_",i1,"_sph.mmn")')iqpt,doublespin - call wann_write_mmnk2(l_p0,fullnkpts,nntot_q,wann, - > nbnd,bpt_q(:,iqpt),gb_q(:,:,iqpt)/2, - > mpi%isize,mpi%irank,fname,m_sph, - > wann%l_unformatted) - write(fname,'("param_",i4.4,"_",i1,"_vac.mmn")')iqpt,doublespin - call wann_write_mmnk2(l_p0,fullnkpts,nntot_q,wann, - > nbnd,bpt_q(:,iqpt),gb_q(:,:,iqpt)/2, - > mpi%isize,mpi%irank,fname,m_vac, - > wann%l_unformatted) - endif -! m_int = cmplx(0.,0.) -! m_sph = cmplx(0.,0.) -! m_vac = cmplx(0.,0.) - - endif - -! call cpu_time(tt4) - !if(l_p0) write(*,*)'write mmnq=',tt4-tt3 - - if( allocated (nablamat) ) deallocate( nablamat ) - if( allocated (soctomom) ) deallocate( soctomom ) - - if( allocated (surfcurr) ) deallocate( surfcurr ) - if( allocated( mmn ) ) deallocate(mmn) - if( allocated( amn ) ) then - if(.not.(noco%l_soc.or.noco%l_noco))deallocate(amn) - endif - if ( allocated (psiw) ) deallocate ( psiw ) - if (wann%l_matrixmmn) then - if(.not.(noco%l_soc.or.noco%l_noco))deallocate (mmnk) - endif - if (wann%l_anglmom .and. allocated(anglmom))then - if(.not.(noco%l_soc.or.noco%l_noco))deallocate (anglmom) - endif - deallocate(flo) - - if(.not.noco%l_noco)nrec=nrec+nkpts - -c#ifdef CPP_MPI -c call MPI_BARRIER(mpi%mpi_comm,ierr) -c#endif - -110 continue ! end of cycle by spins - - -#ifdef CPP_MPI - call MPI_BARRIER(mpi%mpi_comm,ierr) -#endif - - ! close eig files - IF (l_gwf) THEN -! CALL close_eig(eig_id) - IF(wann%l_matrixmmn)THEN - DO iqpt_b=1,nntot_q -! CALL close_eig(innerEig_idList(iqpt_b)) - ENDDO - ENDIF - ENDIF - - if (wann%l_matrixmmn.AND.allocated(mmnk))then - deallocate ( mmnk ) - endif - - if(allocated(mmnk_q)) deallocate(mmnk_q) - if(allocated(m_int)) deallocate(m_int) - if(allocated(m_sph)) deallocate(m_sph) - if(allocated(m_vac)) deallocate(m_vac) - - if ((wann%l_projmethod.or.wann%l_bestproj.or.wann%l_matrixamn) - > .AND.allocated(amn))then - deallocate ( amn ) - endif - - if(wann%l_anglmom.AND.allocated(anglmom))then - deallocate ( anglmom ) - endif - - if ((wann%l_projmethod.or.wann%l_bestproj) - > .AND.allocated(hwfr)) then - deallocate ( hwfr ) - endif - -! call cpu_time(tt2) - !if(l_p0) write(*,*)'q-loop',iqpt,' total=',tt2-tt1 - t_it = tt2-tt1 - if(l_p0) then -! write(*,*)t_kov,t_qov,t_it - endif - - DEALLOCATE(innerEig_idList) - -314 continue ! iqpt, q-points -c************************************************c -c END Q LOOP c -c************************************************c - - if(allocated(pair_to_do))deallocate(pair_to_do,maptopair) - - deallocate ( vr,vz,kveclo,nv,k1,k2,k3 ) - deallocate ( ff,gg ) - if (wann%l_matrixmmn) deallocate ( kveclo_b,nv_b,k1_b,k2_b,k3_b ) - if (wann%l_matrixmmn.AND.l_gwf) - > deallocate ( kveclo_qb,nv_qb,k1_qb,k2_qb,k3_qb ) - if (wann%l_bzsym) deallocate(irreduc,mapkoper) - if (wann%l_bzsym.AND.l_gwf) deallocate(irreduc_q,mapqoper) - if(allocated(pair_to_do_q)) - > deallocate(pair_to_do_q,maptopair_q) - - if (allocated(kdiff)) deallocate ( kdiff ) - if (allocated(qdiff)) deallocate(qdiff,zero_qdiff) - - -9110 continue ! jump for l_finishgwf=T - -! correct for previously introduced factor of 2 in the -! G-vectors connecting neighbors across the BZ boundary - if(wann%l_sgwf) gb_q = gb_q/2 - if(wann%l_socgwf) gb_q = gb_q/2 - -! set up input files for wannier90 --> HDWFs - if(l_p0.and.l_gwf.and.(wann%l_matrixmmn.or.wann%l_matrixamn) - > .and.(.not.wann%l_skipkov)) then - call wann_gwf_commat(fullnkpts,nntot,bpt,fullnqpts, - > nntot_q,bpt_q,gb,gb_q,wann%aux_latt_const, - > wann%l_unformatted,wann%l_matrixamn, - > wann%l_matrixmmn,wann%l_dim, - > wann%nparampts,wann%param_vec/2.0) - endif - - if(l_p0.and.l_gwf.and.wann%l_anglmom) then - call wann_gwf_anglmom(fullnkpts,fullnqpts,wann%l_unformatted) - endif - - if (wann%l_matrixmmn) THEN - deallocate (gb,bpt) - IF(l_gwf) deallocate (gb_q,bpt_q) - endif - - - 1911 continue - - if(allocated(chi)) deallocate(chi) - - call cpu_time(delta) - time_total=delta-time_total - write(6,*)"time_total=",time_total - write(6,*)"time_mmn=",time_mmn - write(6,*)"time_interstitial=",time_interstitial - write(6,*)"time_ujugaunt=",time_ujugaunt - write(6,*)"time_abcof=",time_abcof - write(6,*)"time_symm=",time_symm - write(6,*)"time_rw=",time_rw - write(6,*)"time_film=",time_film - - write(*,*)'time_total wannier=',time_total - - call wann_postproc( - > DIMENSION,stars,vacuum,atoms,sphhar,input,kpts,sym,mpi, - > lapw,oneD,noco,cell,vTot,enpara,eig_id,l_real, !eig_id is used here after closing the files?! - > mpi%mpi_comm,wann,l_p0,input%film,input%jspins,stars%ng2, - > atoms%nat,atoms%pos,cell%amat,cell%bmat,atoms%ntype, - > atoms%neq,atoms%zatom,cell%omtil,noco%l_soc,noco%l_noco, - > DIMENSION%neigd,fullnkpts,oneD%odi,l_proj,atoms%l_dulo, - > noco%l_ss,atoms%lmaxd,atoms%ntype,sym%nop,DIMENSION%nvd, - > input%jspins,DIMENSION%nbasfcn,atoms%llod,atoms%nlod, - > atoms%nlo,atoms%llo,atoms%lapw_l,sym%invtab, - > sym%mrot,atoms%ngopr,atoms%lmax,atoms%invsat, - > sym%invsatnr,nkpt,atoms%taual,atoms%rmt,cell%bbmat, - > noco%alph,noco%beta,noco%qss,stars%sk2,stars%phi2, - > oneD%ods, - > mpi%irank,mpi%isize,stars%ng3,vacuum%nmzxyd,vacuum%nmzd, - > atoms%jmtd,sphhar%nlhd,stars%ng3,vacuum%nvac,sym%invs, - > sym%invs2,sphhar%nlh,atoms%jri,atoms%ntypsy, - > sphhar%ntypsd,nkpt,atoms%dx,atoms%rmsh, - > sliceplot%e1s,sliceplot%e2s,atoms%ulo_der,stars%ustep, - > stars%mx1,stars%mx2,stars%mx3,sym%nop2, - > stars%ig,stars%rgphs, - > sliceplot%slice,sliceplot%kk,sliceplot%nnne, - > DIMENSION%nv2d,vacuum%nmzxy,vacuum%nmz,stars%ng2, - > vacuum%delz,cell%area,cell%z1,cell%volint,stars%ig2, - > sym%tau,sym%symor,results%ef,wann%l_sgwf,fullnqpts) - -#ifdef CPP_MPI - call MPI_BARRIER(mpi%mpi_comm,ierr) -#endif - - IF(.not.wann%l_ldauwan) THEN - DO pc = 1, wann%nparampts - CALL close_eig(eig_idList(pc)) - END DO - - CALL juDFT_end("wannier good",mpi%irank) - END IF - - END SUBROUTINE wannier - - - END MODULE m_wannier diff --git a/wannier/wannier.F90 b/wannier/wannier.F90 new file mode 100644 index 0000000000000000000000000000000000000000..e0b59a71ba66e64e189d241c25dbf8814dc77ef3 --- /dev/null +++ b/wannier/wannier.F90 @@ -0,0 +1,2521 @@ +!-------------------------------------------------------------------------------- +! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany +! This file is part of FLEUR and available as free software under the conditions +! of the MIT license as expressed in the LICENSE file in more detail. +!-------------------------------------------------------------------------------- + +MODULE m_wannier + USE m_juDFT +CONTAINS + SUBROUTINE wannier(& + DIMENSION,mpi,input,kpts,sym,atoms,stars,vacuum,sphhar,oneD,& + wann,noco,cell,enpara,banddos,sliceplot,vTot,results,& + eig_idList,l_real,nkpt) + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! Makes necessary for the construction of the wannier functions + ! (W90: Yates, Mostofi, Marzari, Souza, Vanderbilt '06 f90 code) + ! ab initio preliminaries: constructs the overlaps of the periodic + ! parts of the wavefunctions and the projections of the + ! wavefunctions + ! onto a set of starting wfs, i.e. atomic-like orbitals. + ! YM 06 + ! Mmn(k,b) = , u being a periodic part + ! of the wavefunction psi_nk + ! A_mn^k = , where g_n is a trial orbital + ! which are written into the files 'WF1.mmn' and 'WF1.amn' + ! Marzari Vanderbilt PRB 56,12847(1997) + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! Parallelization, Optionals, Symmetry, Noco&Soc: + ! Frank Freimuth + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! The routine reads the bkpts file, which contains the following + ! information: + ! 1st line: nntot (INT) - number of the nearest neighbors for + ! each k-point in the MP mesh + ! 2-nkpts*nntot lines containing 5 integers i1,i2,i3,i4,i5: + ! i1 - the number of the k-point in the kpts file + ! i2 - number of the k-point, which is a periodic image of + ! k+b in the 1st BZ + ! i3-i5 - coordinates of the G-vector, connecting k-point + ! i2 with the actual k+b k-point + !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! In general, the number of bands for each k-poin t is + ! different: N(k), and also differs from the number of bands + ! we are interested in: N (for instance 5 d-bands of Cu among + ! the 6 s- and d-bands). While matrices Mmn(k) are square + ! for each k-point, matrices Mmn(k,b) can be made so after + ! defining the maximum number of bands max(N(k)). + ! The matrix Amn is non-diagonal by default (N(k)*N). + !ccccc ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! Total number of wannier functions: nwfs + ! sliceplot%e1s,sliceplot%e2s: lower and upper boundaries of the energy window: + ! Needed for sorting by number and sorting by energy. + ! Not needed for sorting by index. + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! Extension to case of higher-dimensional Wannier functions + ! according to the formalism in PRB 91, 184413 (2015) + ! Jan-Philipp Hanke + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + USE m_types + USE m_wann_mmnk_symm + USE m_wann_rw_eig + USE m_abcof + USE m_radfun + USE m_radflo + USE m_cdnread + USE m_constants + USE m_wann_mmk0_od_vac + USE m_wann_mmkb_od_vac + USE m_wann_mmk0_vac + USE m_wann_mmkb_vac + USE m_wann_updown + USE m_wann_mmk0_sph + USE m_wann_ujugaunt + USE m_wann_mmkb_sph + USE m_wann_projmethod + USE m_wann_amn + USE m_wann_abinv + USE m_wann_kptsrotate + USE m_wann_plot + USE m_wann_read_inp + USE m_wann_plot_symm + USE m_wann_mmkb_int + USE m_wann_postproc + USE m_matmul,ONLY : matmul3,matmul3r + USE m_wann_write_mmnk + USE m_wann_write_amn + USE m_wann_write_nabla + USE m_vsoc + USE m_wann_write_matrix4 + USE m_wann_write_matrix5 + USE m_wann_orbcomp + USE m_wann_anglmom +#ifdef CPP_TOPO + USE m_wann_surfcurr + USE m_wann_surfcurr_int2 + USE m_wann_nabla + USE m_wann_nabla_vac + USE m_wann_soc_to_mom +#endif + USE m_wann_gwf_tools, ONLY : get_index_kq, gwf_plottemplate + USE m_wann_gwf_commat + USE m_wann_gwf_anglmom + USE m_wann_write_mmnk2 + USE m_wann_uHu + USE m_wann_uHu_dmi + USE m_eig66_io + + IMPLICIT NONE +#include "cpp_double.h" +#ifdef CPP_MPI + INCLUDE 'mpif.h' + INTEGER ierr(3) + INTEGER cpu_index + INTEGER stt(MPI_STATUS_SIZE) +#endif + + TYPE(t_dimension), INTENT(IN) :: DIMENSION + TYPE(t_mpi), INTENT(IN) :: mpi + TYPE(t_input), INTENT(IN) :: input + TYPE(t_kpts), INTENT(IN) :: kpts + TYPE(t_sym), INTENT(IN) :: sym + TYPE(t_atoms), INTENT(IN) :: atoms + TYPE(t_stars), INTENT(IN) :: stars + TYPE(t_vacuum), INTENT(IN) :: vacuum + TYPE(t_sphhar), INTENT(IN) :: sphhar + TYPE(t_oneD), INTENT(IN) :: oneD + TYPE(t_noco), INTENT(IN) :: noco + TYPE(t_cell), INTENT(IN) :: cell + TYPE(t_enpara), INTENT(IN) :: enpara + TYPE(t_banddos), INTENT(IN) :: banddos + TYPE(t_sliceplot), INTENT(IN) :: sliceplot + TYPE(t_potden), INTENT(IN) :: vTot + TYPE(t_results), INTENT(IN) :: results + TYPE(t_wann), INTENT(INOUT) :: wann + + LOGICAL, INTENT (in) :: l_real + INTEGER, INTENT (in) :: nkpt + INTEGER, INTENT (IN) :: eig_idList(wann%nparampts) + + !ccccccccccccccccc local variables cccccccccccccccccccc + INTEGER :: lmd,n,nmat,iter,ikpt,ikpt_b, pc + INTEGER :: addnoco,loplod,addnoco2,igvm2,eig_id + INTEGER :: noccbd,noccbd_b,nn,nkpts,i,jspin,j,l,i_rec,m,nwf,nwfp + INTEGER :: jsp_start,jsp_end,nrec,nrec1,nrec_b,nbands,nbands_b + INTEGER :: nodeu,noded,n_size,na,n_rank,nbnd,numbands + INTEGER :: i1,i2,i3,in,lda + INTEGER :: n_bands(0:DIMENSION%neigd),nslibd,nslibd_b + CHARACTER(len=8) :: dop,iop,name(10) + REAL :: wronk,phase + COMPLEX :: c_phase + REAL :: eig(DIMENSION%neigd),eig_b(DIMENSION%neigd) + REAL :: efermi + LOGICAL :: l_p0,l_bkpts,l_proj,l_amn,l_mmn +!!! energy window boundaries + INTEGER, ALLOCATABLE :: innerEig_idList(:) + REAL, ALLOCATABLE :: we(:),we_b(:) + + REAL, ALLOCATABLE :: eigg(:) + REAL kpoints(nkpt) +!!! a and b coeff. constructed for each k-point + COMPLEX, ALLOCATABLE :: acof(:,:,:),acof_b(:,:,:) + COMPLEX, ALLOCATABLE :: bcof(:,:,:),bcof_b(:,:,:) + COMPLEX, ALLOCATABLE :: ccof(:,:,:,:),ccof_b(:,:,:,:) +!!! the parameters for the number of wfs + INTEGER :: nwfs +!!! the potential in the spheres and the vacuum + REAL, ALLOCATABLE :: vr(:,:,:),vz(:,:,:) +!!! auxiliary potentials + COMPLEX, ALLOCATABLE :: vpw(:,:) +!!! bkpts data + INTEGER nntot,ikpt_help + INTEGER, ALLOCATABLE :: gb(:,:,:),bpt(:,:) +!!! radial wavefunctions in the muffin-tins and more ... + REAL, ALLOCATABLE :: flo(:,:,:,:,:),vso(:,:,:) + REAL, ALLOCATABLE :: ff(:,:,:,:,:),gg(:,:,:,:,:) + + REAL :: uuilon(atoms%nlod,atoms%ntype) + REAL :: duilon(atoms%nlod,atoms%ntype) + REAL :: ulouilopn(atoms%nlod,atoms%nlod,atoms%ntype) +!!! the Mmn matrices + COMPLEX, ALLOCATABLE :: mmnk(:,:,:,:),mmn(:,:,:) + COMPLEX, ALLOCATABLE :: amn(:,:,:),nablamat(:,:,:,:) + COMPLEX, ALLOCATABLE :: soctomom(:,:,:,:) + COMPLEX, ALLOCATABLE :: surfcurr(:,:,:,:) + COMPLEX, ALLOCATABLE :: socmmn(:,:,:) + COMPLEX, ALLOCATABLE :: a(:) + COMPLEX, ALLOCATABLE :: psiw(:,:,:) + COMPLEX, ALLOCATABLE :: anglmom(:,:,:,:) + COMPLEX, ALLOCATABLE :: orbcomp(:,:,:,:,:) + !..wf-hamiltonian in real space (hopping in the same unit cell) + COMPLEX, ALLOCATABLE :: hwfr(:,:),hwfr2(:,:) + ! real, allocatable :: ei(:) + COMPLEX, ALLOCATABLE :: work(:) + REAL,ALLOCATABLE::centers(:,:,:) + LOGICAL :: l_file + LOGICAL :: l_amn2, l_conjugate + CHARACTER(len=3) :: spin12(2) + DATA spin12/'WF1' , 'WF2'/ + CHARACTER(len=30) :: task + INTEGER,ALLOCATABLE::irreduc(:) + INTEGER,ALLOCATABLE::mapkoper(:) + INTEGER :: fullnkpts,kpt,kptibz,kptibz_b,j1,j2,j3,oper,oper_b,k + REAL :: bkrot(3),dirfacs(3) + INTEGER :: ios,kplot,kplotoper,plotoper,gfcut + COMPLEX :: phasust + INTEGER,ALLOCATABLE::pair_to_do(:,:) + INTEGER :: ngopr1(atoms%nat) + INTEGER,ALLOCATABLE::maptopair(:,:,:) + INTEGER :: wannierspin,jspin2,jspin7,jspin2_b + REAL, ALLOCATABLE :: rwork(:) + REAL,ALLOCATABLE::kdiff(:,:) + INTEGER,ALLOCATABLE :: shiftkpt(:,:) + INTEGER :: unigrid(6),gfthick + COMPLEX,ALLOCATABLE::ujug(:,:,:,:),ujdg(:,:,:,:) + COMPLEX,ALLOCATABLE::djug(:,:,:,:),djdg(:,:,:,:) + COMPLEX,ALLOCATABLE::ujulog(:,:,:,:,:) + COMPLEX,ALLOCATABLE::djulog(:,:,:,:,:) + COMPLEX,ALLOCATABLE::ulojug(:,:,:,:,:) + COMPLEX,ALLOCATABLE::ulojdg(:,:,:,:,:) + COMPLEX,ALLOCATABLE::ulojulog(:,:,:,:,:,:) + INTEGER :: n_start,n_end,mlotot,mlolotot,err + INTEGER :: mlot_d,mlolot_d,ilo,dir,length + CHARACTER(len=2) :: spin012(0:2) + DATA spin012/' ', '.1', '.2'/ + CHARACTER(len=6) :: filename + REAL :: arg,hescale + COMPLEX :: nsfactor,nsfactor_b,VALUE + REAL :: b1(3),b2(3) + REAL,PARAMETER :: bohrtocm=0.529177e-8 + REAL,PARAMETER :: condquant=7.7480917e-5 + INTEGER :: npotmatfile,ig3,maxvac,irec,imz,ivac,ipot + LOGICAL :: l_orbcompinp + INTEGER :: num_angl + COMPLEX,ALLOCATABLE :: vxy(:,:,:) + + + !---->gwf + + ! FURTHER VARIABLES + REAL :: qpt_i(3),qptb_i(3) + REAL :: alph_i(atoms%ntype),alphb_i(atoms%ntype) + REAL :: beta_i(atoms%ntype),betab_i(atoms%ntype) + REAL :: theta_i, thetab_i, phi_i, phib_i + REAL :: dalph,db1,db2,coph,siph + REAL :: zero_taual(3,atoms%nat),bqpt(3) + REAL :: eig_qb(DIMENSION%neigd) + + REAL,ALLOCATABLE :: qdiff(:,:), we_qb(:) + REAL,ALLOCATABLE :: energies(:,:,:) + REAL,ALLOCATABLE :: zero_qdiff(:,:) + + + INTEGER,ALLOCATABLE :: irreduc_q(:),mapqoper(:) + INTEGER,ALLOCATABLE :: shiftqpt(:,:),pair_to_do_q(:,:) + INTEGER,ALLOCATABLE :: maptopair_q(:,:,:) + INTEGER,ALLOCATABLE :: gb_q(:,:,:),bpt_q(:,:) + + INTEGER :: nntot_q = 1 + INTEGER :: fullnqpts = 1 + INTEGER :: funit_start = 5000 + INTEGER :: qptibz, qptibz_b, oper_q, oper_qb + INTEGER :: qpt,iqpt_help, iqpt, iqpt_b + INTEGER :: nbands_qb, nmat_qb, nslibd_qb, noccbd_qb + INTEGER :: sign_q = 1,band_help + INTEGER :: doublespin,jspin_b,jspin3,jspin4,jspin5 + INTEGER :: doublespin_max,nrec5 + INTEGER :: count_i,count_j + INTEGER :: n1,n2,ii,jj + + COMPLEX :: interchi,vacchi,amnchi + COMPLEX :: phasfac,phasfac2,cmplx_1 + + COMPLEX,ALLOCATABLE :: chi(:) + COMPLEX,ALLOCATABLE :: acof_qb(:,:,:) + COMPLEX,ALLOCATABLE :: bcof_qb(:,:,:) + COMPLEX,ALLOCATABLE :: ccof_qb(:,:,:,:) + COMPLEX,ALLOCATABLE :: mmnk_q(:,:,:,:) + COMPLEX,ALLOCATABLE :: m_int(:,:,:,:) + COMPLEX,ALLOCATABLE :: m_sph(:,:,:,:) + COMPLEX,ALLOCATABLE :: m_vac(:,:,:,:) + COMPLEX,ALLOCATABLE :: ujug_q(:,:,:,:),ujdg_q(:,:,:,:) + COMPLEX,ALLOCATABLE :: djug_q(:,:,:,:),djdg_q(:,:,:,:) + COMPLEX,ALLOCATABLE :: ujulog_q(:,:,:,:,:) + COMPLEX,ALLOCATABLE :: djulog_q(:,:,:,:,:) + COMPLEX,ALLOCATABLE :: ulojug_q(:,:,:,:,:) + COMPLEX,ALLOCATABLE :: ulojdg_q(:,:,:,:,:) + COMPLEX,ALLOCATABLE :: ulojulog_q(:,:,:,:,:,:) + + CHARACTER(len=30) fname + + LOGICAL :: l_bqpts,l_gwf,l_nochi + + TYPE(t_usdus) :: usdus + TYPE(t_mat) :: zMat, zzMat, zMat_b, zMat_qb + TYPE(t_lapw) :: lapw, lapw_b, lapw_qb + TYPE(t_wann) :: wannTemp + + eig_id = eig_idList(1) + + !----fullnkpts) CALL juDFT_error("bpt.gt.fullnkpts"& + ,calledby ="wannier") + ENDDO + ENDDO + CLOSE (202) + ALLOCATE(kdiff(3,nntot)) + ENDIF + + !********************************************************** + !cccccccccccccc read in the bqpts file ccccccccccccccccc + !********************************************************** + IF ((wann%l_matrixmmn).AND.(l_gwf.OR.wann%l_ms)) THEN + l_bqpts = .FALSE. + INQUIRE (file='bqpts',exist=l_bqpts) + IF (.NOT.l_bqpts) CALL juDFT_error("need bqpts for matrixmmn"& + ,calledby ="wannier") + OPEN (202,file='bqpts',form='formatted',status='old') + REWIND (202) + READ (202,'(i4)') nntot_q + IF(l_p0)THEN + WRITE (*,*) 'nntot_q=',nntot_q + WRITE(*,*) 'fullnqpts=',fullnqpts + ENDIF + ALLOCATE ( gb_q(1:3,1:nntot_q,1:fullnqpts),& + bpt_q(1:nntot_q,1:fullnqpts)) + DO iqpt=1,fullnqpts + DO nn=1,nntot_q + READ (202,'(2i6,3x,3i4)')& + iqpt_help,bpt_q(nn,iqpt),(gb_q(i,nn,iqpt),i=1,3) + IF (iqpt/=iqpt_help) CALL juDFT_error("iqpt.ne.iqpt_help"& + ,calledby ="wannier") + IF (bpt_q(nn,iqpt)>fullnqpts)& + CALL juDFT_error("bpt_q.gt.fullnqpts",calledby ="wannier") + ENDDO + ENDDO + CLOSE (202) + ALLOCATE(qdiff(3,nntot_q)) + ALLOCATE(zero_qdiff(3,nntot_q)) + zero_qdiff=0.0 + ENDIF + + + ! when treating gen. WF for spin spirals, the Brillouin zone + ! of q-points is twice as large compared to k-BZ. Thus, + ! the G-vectors connecting neighbors across the boundary + ! need to be doubled + IF(wann%l_sgwf) gb_q = 2*gb_q + IF(wann%l_socgwf) gb_q = 2*gb_q + + IF(wann%l_finishgwf) GOTO 9110 + !******************************************************** + ! find symmetry-related elements in mmkb + !******************************************************** + IF(wann%l_matrixmmn)THEN + ALLOCATE(maptopair(3,fullnkpts,nntot)) + ALLOCATE(pair_to_do(fullnkpts,nntot)) + CALL wann_mmnk_symm(input,kpts,& + fullnkpts,nntot,bpt,gb,wann%l_bzsym,& + irreduc,mapkoper,l_p0,input%film,sym%nop,sym%invtab,sym%mrot,& + oneD%odi%d1,sym%tau,& + pair_to_do,maptopair,kdiff,.FALSE.,wann%param_file) + ENDIF + + ! do the same for q-points to construct GWFs + IF(wann%l_matrixmmn.AND.l_gwf)THEN + ALLOCATE(maptopair_q(3,fullnqpts,nntot_q)) + ALLOCATE(pair_to_do_q(fullnqpts,nntot_q)) + CALL wann_mmnk_symm(input,kpts,& + fullnqpts,nntot_q,bpt_q,gb_q,wann%l_bzsym,& + irreduc_q,mapqoper,l_p0,.FALSE.,1,sym%invtab(1),& + sym%mrot(:,:,1),.FALSE.,sym%tau,& + pair_to_do_q,maptopair_q,qdiff,.TRUE.,wann%param_file) + ENDIF + + + !********************************************************* + !ccccccccccccccc initialize the potential cccccccccccc + !********************************************************* + + ALLOCATE ( vz(vacuum%nmzd,2,4) ) + ALLOCATE ( vr(atoms%jmtd,atoms%ntype,input%jspins) ) + ALLOCATE ( vso(atoms%jmtd,atoms%nat,2) ) + + vz = 0.0 + vz(:,:,:SIZE(vTot%vacz,3)) = vTot%vacz(:,:,:) + + DO jspin = 1,input%jspins + DO n = 1, atoms%ntype + DO j = 1,atoms%jri(n) + vr(j,n,jspin) = vTot%mt(j,0,n,jspin) + ENDDO + ENDDO + ENDDO + + IF(wann%l_soctomom)THEN + CALL vsoc(input,atoms,vr,enpara%el0,.TRUE., vso) + ENDIF + + IF(noco%l_noco.AND.input%film)THEN + npotmatfile=25 + ALLOCATE(vpw(stars%ng3,1)) + IF(.NOT.oneD%odi%d1)& + ALLOCATE( vxy(vacuum%nmzxyd,stars%ng2-1,2) ) + + OPEN (npotmatfile,FILE='potmat',FORM='unformatted',& + STATUS='old') + READ (npotmatfile) (vpw(ig3,1),ig3=1,stars%ng3) + READ (npotmatfile) (vpw(ig3,1),ig3=1,stars%ng3) + READ (npotmatfile) (vpw(ig3,1),ig3=1,stars%ng3) + maxvac=2 + IF(oneD%odi%d1)maxvac=1 + DO ivac = 1,maxvac + !---> if the two vacuua are equivalent, the potential file has to + !---> be backspaced, because the potential is the same at both + !---> surfaces of the film + IF ((ivac.EQ.2) .AND. (vacuum%nvac.EQ.1)) THEN + DO irec = 1,4 + BACKSPACE (npotmatfile) + ENDDO + ENDIF + !---> load the non-warping part of the potential + READ (npotmatfile)& + ((vz(imz,ivac,ipot),imz=1,vacuum%nmzd),ipot=1,4) + + IF(.NOT.oneD%odi%d1)THEN + DO ipot = 1,3 + READ (npotmatfile)((vxy(imz,igvm2,ivac),& + imz=1,vacuum%nmzxy),igvm2=1,stars%ng2-1) + ENDDO + ENDIF + ENDDO + CLOSE (npotmatfile) + ENDIF + + !ccccccccccccccc end of the potential part ccccccccccc + wannierspin=input%jspins + IF(noco%l_soc) wannierspin=2 + + + ALLOCATE ( ff(atoms%ntype,atoms%jmtd,2,0:atoms%lmaxd,2) ) + ALLOCATE ( gg(atoms%ntype,atoms%jmtd,2,0:atoms%lmaxd,2) ) + ALLOCATE ( usdus%us(0:atoms%lmaxd,atoms%ntype,2) ) + ALLOCATE ( usdus%uds(0:atoms%lmaxd,atoms%ntype,2) ) + ALLOCATE ( usdus%dus(0:atoms%lmaxd,atoms%ntype,2) ) + ALLOCATE ( usdus%duds(0:atoms%lmaxd,atoms%ntype,2) ) + ALLOCATE ( usdus%ddn(0:atoms%lmaxd,atoms%ntype,2) ) + ALLOCATE ( usdus%ulos(atoms%nlod,atoms%ntype,2) ) + ALLOCATE ( usdus%dulos(atoms%nlod,atoms%ntype,2) ) + ALLOCATE ( usdus%uulon(atoms%nlod,atoms%ntype,2) ) + ALLOCATE ( usdus%dulon(atoms%nlod,atoms%ntype,2) ) + ALLOCATE ( usdus%uloulopn(atoms%nlod,atoms%nlod,atoms%ntype,2) ) + + IF(l_gwf.AND..NOT.(wann%l_wann_plot)) THEN + doublespin_max=4!2 + ELSE + doublespin_max=wannierspin + ENDIF + + !*****************************************************************c + ! START Q LOOP c + ! standard functionality of code for fullnqpts = nntot_q = 1 c + ! and wann%l_ms = wann%l_sgwf = wann%l_socgwf = F c + !*****************************************************************c + DO iqpt = 1,fullnqpts ! loop by q-points starts + + ALLOCATE(innerEig_idList(nntot_q)) + + qptibz=iqpt + IF(wann%l_bzsym .AND. l_gwf) qptibz=irreduc_q(iqpt) + IF(wann%l_bzsym .AND. l_gwf) oper_q=mapqoper(iqpt) + + qpt_i = noco%qss + alph_i = noco%alph + beta_i = noco%beta + theta_i = noco%theta + phi_i = noco%phi + IF(wann%l_sgwf.OR.wann%l_ms) THEN + qpt_i(:) = wann%param_vec(:,qptibz) + alph_i(:) = wann%param_alpha(:,qptibz) + ELSEIF(wann%l_socgwf) THEN + IF(wann%l_dim(2)) phi_i = tpi_const*wann%param_vec(2,qptibz) + IF(wann%l_dim(3)) theta_i = tpi_const*wann%param_vec(3,qptibz) + ENDIF + + IF (l_gwf) THEN + IF(wann%l_matrixmmn)THEN + DO iqpt_b=1,nntot_q + + innerEig_idList(iqpt_b) = eig_idList(bpt_q(iqpt_b,iqpt)) + + ! WRITE(fending,'("_",i4.4)')bpt_q(iqpt_b,iqpt) + ! innerEig_idList(iqpt_b)=open_eig(mpi%mpi_comm, + ! + DIMENSION%nbasfcn,DIMENSION%neigd, + ! + nkpts,wannierspin,atoms%lmaxd, + ! + atoms%nlod,atoms%ntype,atoms%nlotot, + ! + noco%l_noco,.FALSE.,l_real,noco%l_soc,.FALSE., + ! + mpi%n_size,filename=trim(fstart)//fending, + ! + layers=vacuum%layers,nstars=vacuum%nstars, + ! + ncored=DIMENSION%nstd,nsld=atoms%nat, + ! + nat=atoms%nat,l_dos=banddos%dos.OR.input%cdinf, + ! + l_mcd=banddos%l_mcd,l_orb=banddos%l_orb) + + ENDDO + ENDIF + + eig_id = eig_idList(qptibz) + + ! WRITE(fending,'("_",i4.4)')qptibz + ! eig_id=open_eig(mpi%mpi_comm,DIMENSION%nbasfcn,DIMENSION%neigd, + ! + nkpts,wannierspin,atoms%lmaxd, + ! + atoms%nlod,atoms%ntype,atoms%nlotot, + ! + noco%l_noco,.FALSE.,l_real,noco%l_soc,.FALSE., + ! + mpi%n_size,filename=trim(fstart)//fending, + ! + layers=vacuum%layers,nstars=vacuum%nstars, + ! + ncored=DIMENSION%nstd,nsld=atoms%nat, + ! + nat=atoms%nat,l_dos=banddos%dos.OR.input%cdinf, + ! + l_mcd=banddos%l_mcd,l_orb=banddos%l_orb) + + ELSEIF(wann%l_ms) THEN + + eig_id = eig_idList(qptibz) + + ! WRITE(fending,'("_",i4.4)')qptibz + ! eig_id=open_eig(mpi%mpi_comm,DIMENSION%nbasfcn,DIMENSION%neigd, + ! + nkpts,wannierspin,atoms%lmaxd, + ! + atoms%nlod,atoms%ntype,atoms%nlotot, + ! + noco%l_noco,.FALSE.,l_real,noco%l_soc,.FALSE., + ! + mpi%n_size,filename=trim(fstart)//fending, + ! + layers=vacuum%layers,nstars=vacuum%nstars, + ! + ncored=DIMENSION%nstd,nsld=atoms%nat, + ! + nat=atoms%nat,l_dos=banddos%dos.OR.input%cdinf, + ! + l_mcd=banddos%l_mcd,l_orb=banddos%l_orb) + + ENDIF ! l_gwf.or.wann%l_ms + nrec=0 + nrec_b=0 + + + !**************************************************** + ! cycle by spins starts! + !**************************************************** + DO doublespin=1,doublespin_max ! cycle by spins + + jspin=MOD(doublespin+1,2)+1 + jspin_b=jspin + IF(doublespin.EQ.3) jspin_b=2 + IF(doublespin.EQ.4) jspin_b=1 + + nrec_b = nrec + + IF(.NOT.noco%l_noco) THEN + nrec = (jspin-1)*nkpts + nrec_b = (jspin_b-1)*nkpts + ENDIF + + ! spin-dependent sign of the q-dependent phase + ! in the generalized Bloch theorem + ! -1: spin up, +1: spin down + sign_q = -sign_q + + !...read number of bands and wannier functions from file proj + + !..reading the proj.1 / proj.2 / proj file + l_proj=.FALSE. + DO j=jspin,0,-1 + INQUIRE(file=TRIM('proj'//spin012(j)),exist=l_proj) + IF(l_proj)THEN + filename='proj'//spin012(j) + EXIT + ENDIF + ENDDO + + IF(l_proj)THEN + OPEN (203,file=TRIM(filename),status='old') + REWIND (203) + READ (203,*) nwfs,numbands + REWIND (203) + CLOSE (203) + ELSEIF(wann%l_projmethod.OR.wann%l_bestproj& + .OR.wann%l_matrixamn)THEN + CALL juDFT_error("no proj/proj.1/proj.2"& + ,calledby ="wannier") + ENDIF + + + jspin2=jspin + IF(noco%l_soc .AND. input%jspins.EQ.1)jspin2=1 + jspin2_b=jspin_b + IF(noco%l_soc .AND. input%jspins.EQ.1)jspin2_b=1 + + jsp_start = jspin ; jsp_end = jspin + + !ccccccccccc read in the eigenvalues and vectors cccccc + WRITE(*,*)'wannierspin',wannierspin + DO jspin5=1,wannierspin!1!2 + ! jspin5=jspin + jsp_start=jspin5; jsp_end=jspin5 + nrec5=0 + IF(.NOT.noco%l_noco) nrec5 = (jspin5-1)*nkpts + + CALL cdn_read0(eig_id,mpi%irank,mpi%isize,jspin5,input%jspins, &!wannierspin instead of DIMENSION%jspd?& + noco%l_noco, n_bands,n_size) + + ENDDO + !.. now we want to define the maximum number of the bands by all kpts + nbnd = 0 + + i_rec = 0 ; n_rank = 0 + !************************************************************* + !..writing down the eig.1 and/or eig.2 files + + !..write individual files if multi-spiral mode wann%l_ms=T + !************************************************************* + IF(l_p0)THEN + CALL wann_write_eig(& + eig_id,l_real,& + atoms%lmaxd,atoms%ntype,atoms%nlod,DIMENSION%neigd,& + DIMENSION%nvd,wannierspin,& + mpi%isize,jspin,DIMENSION%nbasfcn,atoms%nlotot,& + noco%l_ss,noco%l_noco,nrec,fullnkpts,& + wann%l_bzsym,wann%l_byindex,wann%l_bynumber,& + wann%l_byenergy,& + irreduc,oneD%odi,wann%band_min(jspin),& + wann%band_max(jspin),& + numbands,& + sliceplot%e1s,sliceplot%e2s,efermi,.FALSE.,nkpts,& + nbnd,kpoints,l_gwf,iqpt) + + IF(oneD%odi%d1)THEN + kpoints(:)=kpoints(:)*cell%bmat(3,3) + ENDIF + ENDIF!l_p0 + + ! nbnd is calculated for process zero and is sent here to the others +#ifdef CPP_MPI + IF(l_p0)THEN + DO cpu_index=1,mpi%isize-1 + CALL MPI_SEND(nbnd,1,MPI_INTEGER,cpu_index,1,mpi%mpi_comm,ierr) + ENDDO + ELSE + CALL MPI_RECV(nbnd,1,MPI_INTEGER,0,1,mpi%mpi_comm,stt,ierr) + ENDIF +#endif + + PRINT*,"process: ",mpi%irank," nbnd= ",nbnd + !################################################################## + IF(wann%l_mmn0)THEN + ALLOCATE ( mmn(nbnd,nbnd,fullnkpts) ) + mmn(:,:,:) = CMPLX(0.,0.) + IF((noco%l_soc.OR.noco%l_noco) .AND. (doublespin.EQ.1))& + ALLOCATE(socmmn(nbnd,nbnd,fullnkpts) ) + ENDIF + IF(wann%l_nabla)THEN + ALLOCATE ( nablamat(3,nbnd,nbnd,fullnkpts) ) + nablamat = CMPLX(0.,0.) + ENDIF + + IF(wann%l_soctomom)THEN + ALLOCATE ( soctomom(3,nbnd,nbnd,fullnkpts) ) + soctomom = CMPLX(0.,0.) + ENDIF + + IF(wann%l_surfcurr)THEN + ALLOCATE ( surfcurr(3,nbnd,nbnd,fullnkpts) ) + surfcurr = CMPLX(0.,0.) + ENDIF + + IF(wann%l_anglmom)THEN + IF(.NOT.ALLOCATED(anglmom))THEN + ALLOCATE ( anglmom(3,nbnd,nbnd,fullnkpts) ) + anglmom=CMPLX(0.,0.) + ENDIF + ENDIF + + IF(wann%l_orbcomp)THEN + IF(ALLOCATED(orbcomp))DEALLOCATE(orbcomp) + IF(wann%l_oc_f)THEN + ALLOCATE(orbcomp(16,wann%oc_num_orbs,nbnd,nbnd,fullnkpts)) + ELSE + ALLOCATE(orbcomp(9,wann%oc_num_orbs,nbnd,nbnd,fullnkpts)) + ENDIF + orbcomp=CMPLX(0.,0.) + ENDIF + + !write (*,*) 'nwfs=',nwfs + IF(wann%l_projmethod.OR.wann%l_bestproj.OR.wann%l_matrixamn)THEN + IF(.NOT.ALLOCATED(amn))THEN + ALLOCATE ( amn(nbnd,nwfs,fullnkpts) ) + amn(:,:,:) = CMPLX(0.,0.) + ENDIF + ENDIF + + IF (wann%l_projmethod.OR.wann%l_bestproj) THEN + ALLOCATE ( psiw(nbnd,nwfs,fullnkpts) ) + psiw(:,:,:) = CMPLX(0.,0.) + IF(.NOT.ALLOCATED(hwfr))THEN + ALLOCATE ( hwfr(nwfs,nwfs) ) + hwfr(:,:) = CMPLX(0.,0.) + ENDIF + ENDIF + + + IF (wann%l_matrixmmn) THEN + IF(.NOT.ALLOCATED(mmnk))THEN + ALLOCATE ( mmnk(nbnd,nbnd,nntot,fullnkpts) ) + mmnk = (0.,0.) + ENDIF + ENDIF + + IF(wann%l_matrixmmn)THEN + IF(.NOT.ALLOCATED(mmnk_q).AND.l_gwf)THEN + ALLOCATE ( mmnk_q (nbnd,nbnd,nntot_q,fullnkpts) ) + mmnk_q = (0.,0.) + + ! allocate ( m_int(nbnd,nbnd,nntot_q,fullnkpts) ) + ! allocate ( m_sph(nbnd,nbnd,nntot_q,fullnkpts) ) + ! allocate ( m_vac(nbnd,nbnd,nntot_q,fullnkpts) ) + ! m_int = cmplx(0.,0.) + ! m_sph = cmplx(0.,0.) + ! m_vac = cmplx(0.,0.) + ENDIF + ENDIF + + + ALLOCATE ( flo(atoms%ntype,atoms%jmtd,2,atoms%nlod,2) ) + + DO jspin4=1,wannierspin!2 + jspin3=jspin4 + IF(input%jspins.EQ.1) jspin3=1 + na = 1 + DO n = 1,atoms%ntype + DO l = 0,atoms%lmax(n) + !...compute the l-dependent, k-independent radial MT- basis functions + + CALL radfun(& + l,n,jspin4,enpara%el0(l,n,jspin3),vr(1,n,jspin3),atoms,& + ff(n,:,:,l,jspin4),gg(n,:,:,l,jspin4),usdus,& + nodeu,noded,wronk) + + ENDDO + !...and the local orbital radial functions + DO ilo = 1, atoms%nlo(n) + + CALL radflo(& + atoms,n,jspin4,enpara%ello0(:,:,jspin3),vr(1,n,jspin3),& + ff(n,1:,1:,0:,jspin4),gg(n,1:,1:,0:,jspin4),mpi,& + usdus,uuilon,duilon,ulouilopn,flo(n,:,:,:,jspin4)) + + ENDDO + ! na = na + atoms%neq(n) + ENDDO + ENDDO!jspin3 + !**************************************************************** + ! calculate the k-independent uju*gaunt-matrix needed for + ! mmnmatrix + !**************************************************************** + ! TODO: make this more efficient (i.e., compute ujugaunt only once + ! and not for all q-points). + IF(wann%l_matrixmmn)THEN + ALLOCATE(ujug(0:lmd,0:lmd,& + 1:atoms%ntype,1:nntot)) + ALLOCATE(ujdg(0:lmd,0:lmd,& + 1:atoms%ntype,1:nntot)) + ALLOCATE(djug(0:lmd,0:lmd,& + 1:atoms%ntype,1:nntot)) + ALLOCATE(djdg(0:lmd,0:lmd,& + 1:atoms%ntype,1:nntot)) + ALLOCATE(ujulog(0:lmd,1:atoms%nlod,-atoms%llod:atoms%llod,& + 1:atoms%ntype,1:nntot)) + ALLOCATE(djulog(0:lmd,1:atoms%nlod,-atoms%llod:atoms%llod,& + 1:atoms%ntype,1:nntot)) + ALLOCATE(ulojug(0:lmd,1:atoms%nlod,-atoms%llod:atoms%llod,& + 1:atoms%ntype,1:nntot)) + ALLOCATE(ulojdg(0:lmd,1:atoms%nlod,-atoms%llod:atoms%llod,& + 1:atoms%ntype,1:nntot)) + ALLOCATE(ulojulog(1:atoms%nlod,-atoms%llod:atoms%llod,& + 1:atoms%nlod,-atoms%llod:atoms%llod,& + 1:atoms%ntype,1:nntot)) + + CALL wann_ujugaunt(& + atoms%llod,nntot,kdiff,atoms%lmax,atoms%ntype,& + atoms%ntype,cell%bbmat,cell%bmat,atoms%nlod,atoms%nlo,& + atoms%llo,flo(:,:,:,:,jspin),& + flo(:,:,:,:,jspin),& + ff(:,:,:,:,jspin),& + ff(:,:,:,:,jspin),& + gg(:,:,:,:,jspin),& + gg(:,:,:,:,jspin),atoms%jri,atoms%rmsh,atoms%dx,& + atoms%jmtd,atoms%lmaxd,lmd,& + ujug,ujdg,djug,djdg,& + ujulog,djulog,ulojug,ulojdg,ulojulog,.FALSE.,1) + + ! compute integrals of radial solution, according energy derivatives, + ! the spherical Bessel function and the Gaunt coefficients in order + ! to account for the overlap of the lattice periodic parts at + ! neighboring q-points + IF(l_gwf)THEN + ALLOCATE(ujug_q(0:lmd,0:lmd,& + 1:atoms%ntype,1:nntot_q)) + ALLOCATE(ujdg_q(0:lmd,0:lmd,& + 1:atoms%ntype,1:nntot_q)) + ALLOCATE(djug_q(0:lmd,0:lmd,& + 1:atoms%ntype,1:nntot_q)) + ALLOCATE(djdg_q(0:lmd,0:lmd,& + 1:atoms%ntype,1:nntot_q)) + ALLOCATE(ujulog_q(0:lmd,1:atoms%nlod,-atoms%llod:atoms%llod,& + 1:atoms%ntype,1:nntot_q)) + ALLOCATE(djulog_q(0:lmd,1:atoms%nlod,-atoms%llod:atoms%llod,& + 1:atoms%ntype,1:nntot_q)) + ALLOCATE(ulojug_q(0:lmd,1:atoms%nlod,-atoms%llod:atoms%llod,& + 1:atoms%ntype,1:nntot_q)) + ALLOCATE(ulojdg_q(0:lmd,1:atoms%nlod,-atoms%llod:atoms%llod,& + 1:atoms%ntype,1:nntot_q)) + ALLOCATE(ulojulog_q(1:atoms%nlod,-atoms%llod:atoms%llod,& + 1:atoms%nlod,-atoms%llod:atoms%llod,& + 1:atoms%ntype,1:nntot_q)) + + ! we need G(q+b)/2 as argument for the sph. Bessel func. + ! and additionally a spin-dependent sign (-/+ 1)^{lpp} + IF(wann%l_sgwf) CALL wann_ujugaunt(& + atoms%llod,nntot_q,qdiff/2.0,atoms%lmax,atoms%ntype,& + atoms%ntype,cell%bbmat,cell%bmat,atoms%nlod,atoms%nlo,& + atoms%llo,flo(:,:,:,:,jspin),& + flo(:,:,:,:,jspin_b),& + ff(:,:,:,:,jspin),& + ff(:,:,:,:,jspin_b),& + gg(:,:,:,:,jspin),& + gg(:,:,:,:,jspin_b),atoms%jri,atoms%rmsh,atoms%dx,& + atoms%jmtd,atoms%lmaxd,lmd,& + ujug_q,ujdg_q,djug_q,djdg_q,& + ujulog_q,djulog_q,ulojug_q,ulojdg_q,ulojulog_q,.TRUE.,& + sign_q) + + IF(wann%l_socgwf) CALL wann_ujugaunt(& + atoms%llod,nntot_q,zero_qdiff,atoms%lmax,atoms%ntype,& + atoms%ntype,cell%bbmat,cell%bmat,atoms%nlod,atoms%nlo,& + atoms%llo,flo(:,:,:,:,jspin),& + flo(:,:,:,:,jspin_b),& + ff(:,:,:,:,jspin),& + ff(:,:,:,:,jspin_b),& + gg(:,:,:,:,jspin),& + gg(:,:,:,:,jspin_b),atoms%jri,atoms%rmsh,atoms%dx,& + atoms%jmtd,& + atoms%lmaxd,lmd,ujug_q,ujdg_q,djug_q,djdg_q,& + ujulog_q,djulog_q,ulojug_q,ulojdg_q,ulojulog_q,& + .FALSE.,1) + + ENDIF ! l_gwf + + ENDIF !l_matrixmmn + zzMat%l_real = l_real + zzMat%matsize1 = DIMENSION%nbasfcn + zzMat%matsize2 = DIMENSION%neigd + IF(l_real) THEN + IF(.NOT.ALLOCATED(zzMat%data_r))& + ALLOCATE (zzMat%data_r(zzMat%matsize1,zzMat%matsize2)) + ELSE + IF(.NOT.ALLOCATED(zzMat%data_c))& + ALLOCATE (zzMat%data_c(zzMat%matsize1,zzMat%matsize2)) + END IF + + zMat%l_real = zzMat%l_real + zMat%matsize1 = zzMat%matsize1 + zMat%matsize2 = zzMat%matsize2 + IF (zzMat%l_real) THEN + IF(.NOT.ALLOCATED(zMat%data_r))& + ALLOCATE (zMat%data_r(zMat%matsize1,zMat%matsize2)) + zMat%data_r = 0.0 + ELSE + IF(.NOT.ALLOCATED(zMat%data_c))& + ALLOCATE (zMat%data_c(zMat%matsize1,zMat%matsize2)) + zMat%data_c = CMPLX(0.0,0.0) + END IF + + zMat_b%l_real = zzMat%l_real + zMat_b%matsize1 = zzMat%matsize1 + zMat_b%matsize2 = zzMat%matsize2 + IF (zzMat%l_real) THEN + IF(.NOT.ALLOCATED(zMat_b%data_r))& + ALLOCATE (zMat_b%data_r(zMat_b%matsize1,zMat_b%matsize2)) + zMat_b%data_r = 0.0 + ELSE + IF(.NOT.ALLOCATED(zMat_b%data_c))& + ALLOCATE (zMat_b%data_c(zMat_b%matsize1,zMat_b%matsize2)) + zMat_b%data_c = CMPLX(0.0,0.0) + END IF + + i_rec = 0 ; n_rank = 0 + + !**************************************************************** + !.. loop by kpoints starts! each may be a separate task + !**************************************************************** + DO ikpt = wann%ikptstart,fullnkpts ! loop by k-points starts + kptibz=ikpt + IF(wann%l_bzsym) kptibz=irreduc(ikpt) + IF(wann%l_bzsym) oper=mapkoper(ikpt) + + i_rec = i_rec + 1 + IF (MOD(i_rec-1,mpi%isize).EQ.mpi%irank) THEN + + ALLOCATE ( we(DIMENSION%neigd),eigg(DIMENSION%neigd) ) + + n_start=1 + n_end=DIMENSION%neigd + + + ! read information of diagonalization for fixed q-point iqpt + ! stored in the eig file on unit 66. the lattice respectively + ! plane-wave vectors G(k,q) are saved in (k1,k2,k3). + + CALL lapw%init(input,noco,kpts,atoms,sym,kptibz,cell,(sym%zrfs.AND.(SUM(ABS(kpts%bk(3,:kpts%nkpt))).LT.1e-9).AND..NOT.noco%l_noco.and.mpi%n_size==1),mpi) + + CALL cdn_read(& + eig_id,& + DIMENSION%nvd,input%jspins,mpi%irank,mpi%isize, &!wannierspin instead of DIMENSION%jspd?& + kptibz,jspin,DIMENSION%nbasfcn,& + noco%l_ss,noco%l_noco,DIMENSION%neigd,n_start,n_end,& + nbands,eigg,zzMat) + + + nslibd = 0 + + !...we work only within the energy window + + eig(:) = 0. + + ! print*,"bands used:" + + DO i = 1,nbands + IF ((eigg(i).GE.sliceplot%e1s.AND.nslibd.LT.numbands.AND.& + wann%l_bynumber).OR.& + (eigg(i).GE.sliceplot%e1s.AND.eigg(i).LE.sliceplot%e2s.AND.& + wann%l_byenergy).OR.(i.GE.wann%band_min(jspin).AND.& + (i.LE.wann%band_max(jspin)).AND.wann%l_byindex))THEN + + ! print*,i + nslibd = nslibd + 1 + eig(nslibd) = eigg(i) + we(nslibd) = we(i) + IF(zzMat%l_real) THEN + zMat%data_r(:,nslibd) = zzMat%data_r(:,i) + ELSE + zMat%data_c(:,nslibd) = zzMat%data_c(:,i) + END IF + ENDIF + ENDDO + + !*********************************************************** + ! rotate the wavefunction + !*********************************************************** + IF (wann%l_bzsym.AND.oper.NE.1) THEN !rotate bkpt + ! call wann_kptsrotate( + ! > atoms%nat,atoms%nlod,atoms%llod, + ! > atoms%ntype,atoms%nlo,atoms%llo,atoms%invsat, + ! > noco%l_noco,noco%l_soc, + ! > atoms%ntype,atoms%neq,atoms%nlotot, + ! > kveclo,jspin, + ! > oper,sym%nop,sym%mrot,DIMENSION%nvd,nv, + ! > shiftkpt(:,ikpt), + ! > sym%tau, + ! x lapw%bkpt,k1(:,:),k2(:,:),k3(:,:), + ! x zMat,nsfactor) + ELSE + nsfactor=CMPLX(1.0,0.0) + ENDIF + + !****************************************************************** + + !...the overlap matrix Mmn which is computed for each k- and b-point + + noccbd = nslibd + + ALLOCATE(acof(noccbd,0:lmd,atoms%nat),& + bcof(noccbd,0:lmd,atoms%nat),& + ccof(-atoms%llod:atoms%llod,noccbd,atoms%nlod,atoms%nat)) + + acof(:,:,:) = CMPLX(0.,0.) ; bcof(:,:,:) = CMPLX(0.,0.) + ccof(:,:,:,:) = CMPLX(0.,0.) + + !...generation the A,B,C coefficients in the spheres + !...for the lapws and local orbitals, summed by the basis functions + + + CALL abcof(input,atoms,sym,cell,lapw,noccbd,usdus,& + noco,jspin,oneD,acof,bcof,ccof,zMat) + + + CALL wann_abinv(atoms, acof,bcof,ccof) + + + IF((doublespin.EQ.3).OR.(doublespin.EQ.4)) GOTO 9900 + + + IF(wann%l_orbcomp)THEN + CALL wann_orbcomp(atoms,usdus,jspin,acof,bcof,ccof,& + wann%oc_num_orbs,wann%oc_orbs,wann%l_oc_f,orbcomp(:,:,:,:,ikpt)) + ENDIF + + IF(wann%l_anglmom)THEN + CALL wann_anglmom(atoms,usdus,jspin, acof,bcof,ccof,anglmom(:,:,:,ikpt)) + ENDIF + +#ifdef CPP_TOPO + IF(wann%l_surfcurr)THEN + ! call wann_surfcurr_int( + ! > DIMENSION%nv2d,jspin,oneD%odi,oneD%ods,stars%ng3,vacuum%nmzxyd,stars%ng2,sphhar%ntypsd, + ! > atoms%ntype,atoms%lmaxd,atoms%jmtd,atoms%ntype,atoms%nat,vacuum%nmzd,atoms%neq,stars%ng3,vacuum%nvac, + ! > vacuum%nmz,vacuum%nmzxy,stars%ng2,sym%nop,sym%nop2,cell%volint,input%film,sliceplot%slice,sym%symor, + ! > sym%invs,sym%invs2,cell%z1,vacuum%delz,atoms%ngopr,atoms%ntypsy,atoms%jri,atoms%pos,atoms%zatom, + ! > atoms%lmax,sym%mrot,sym%tau,atoms%rmsh,sym%invtab,cell%amat,cell%bmat,cell%bbmat,ikpt,sliceplot%nnne,sliceplot%kk, + ! > DIMENSION%nvd,atoms%nlod,atoms%llod,nv(jspin),lmd,lapw%bkpt,cell%omtil,atoms%nlo,atoms%llo, + ! > k1(:,jspin),k2(:,jspin),k3(:,jspin),evac(:,jspin), + ! > vz(:,:,jspin2), + ! > nslibd,DIMENSION%nbasfcn,DIMENSION%neigd,ff,gg,flo,acof,bcof,ccof,z, + ! > surfcurr(:,:,:,ikpt)) + + CALL wann_surfcurr_int2(& + DIMENSION%nv2d,jspin,oneD%odi,oneD%ods,stars%ng3,& + vacuum%nmzxyd,& + stars%ng2,sphhar%ntypsd,atoms%ntype,atoms%lmaxd,& + atoms%jmtd,atoms%ntype,atoms%nat,vacuum%nmzd,& + atoms%neq,stars%ng3,vacuum%nvac,vacuum%nmz,& + vacuum%nmzxy,stars%ng2,sym%nop,sym%nop2,cell%volint,& + input%film,sliceplot%slice,sym%symor,& + sym%invs,sym%invs2,cell%z1,vacuum%delz,atoms%ngopr,& + atoms%ntypsy,atoms%jri,atoms%pos,atoms%taual,& + atoms%zatom,atoms%rmt,atoms%lmax,sym%mrot,sym%tau,& + atoms%rmsh,sym%invtab,cell%amat,cell%bmat,cell%bbmat,& + ikpt,DIMENSION%nvd,lapw%nv(jspin),lapw%bkpt,cell%omtil,& + lapw%k1(:,jspin),lapw%k2(:,jspin),lapw%k3(:,jspin),& + nslibd,DIMENSION%nbasfcn,DIMENSION%neigd,z,& + dirfacs,& + surfcurr(:,:,:,ikpt)) + + CALL wann_surfcurr(& + dirfacs,cell%amat,& + jspin,atoms%ntype,atoms%lmaxd,atoms%lmax,atoms%nat,& + atoms%neq,noccbd,lmd,atoms%nat,atoms%llod,atoms%nlod,& + atoms%nlo,atoms%llo, & + acof,bcof,ccof,& + us(:,:,jspin),dus(:,:,jspin),duds(:,:,jspin),& + uds(:,:,jspin),& + ulos(:,:,jspin),dulos(:,:,jspin),& + atoms%rmt,atoms%pos, & + surfcurr(:,:,:,ikpt)) + WRITE(6,*)"dirfacs=",dirfacs + ENDIF + + IF(wann%l_soctomom)THEN + CALL wann_soc_to_mom(& + jspin,atoms%ntype,atoms%lmaxd,atoms%lmax,atoms%nat,& + atoms%jmtd,atoms%jri,atoms%rmsh,atoms%dx,atoms%neq,& + noccbd,lmd,atoms%nat,atoms%llod,atoms%nlod,& + vso(:,:,1), & + ff(:,:,:,:,jspin),gg(:,:,:,:,jspin),& + acof,bcof,ccof,& + soctomom(:,:,:,ikpt)) + ENDIF + + IF(wann%l_nabla)THEN + CALL wann_nabla(& + atoms%nlo,atoms%llo,& + jspin,atoms%ntype,atoms%lmaxd,atoms%lmax,atoms%nat,& + atoms%jmtd,atoms%jri,atoms%rmsh,atoms%dx,atoms%neq,& + noccbd,lmd,atoms%nat,atoms%llod,atoms%nlod, & + ff(:,:,:,:,jspin),gg(:,:,:,:,jspin),flo(:,:,:,:,jspin),& + acof,bcof,ccof,& + nablamat(:,:,:,ikpt)) + IF(input%film.AND..NOT.oneD%odi%d1)THEN + CALL wann_nabla_vac(& + cell%z1,vacuum%nmzd,DIMENSION%nv2d,& + stars%mx1,stars%mx2,stars%mx3,& + stars%ng3,vacuum%nvac,stars%ig,vacuum%nmz,vacuum%delz,& + stars%ig2,cell%area,cell%bmat,cell%bbmat,enpara%evac0(:,jspin),& + lapw%bkpt,vz(:,:,jspin2),nslibd,jspin,lapw%k1,lapw%k2,lapw%k3,& + wannierspin,DIMENSION%nvd,DIMENSION%nbasfcn,DIMENSION%neigd,z,nv,& + cell%omtil,& + nablamat(:,:,:,ikpt)) + ENDIF + addnoco=0 + DO i = n_rank+1,lapw%nv(jspin),n_size + b1 = lapw%bkpt+lapw%gvec(:,i,jspin) + b2(1)=b1(1)*cell%bmat(1,1)+b1(2)*cell%bmat(2,1)+& + b1(3)*cell%bmat(3,1) + b2(2)=b1(1)*cell%bmat(1,2)+b1(2)*cell%bmat(2,2)+& + b1(3)*cell%bmat(3,2) + b2(3)=b1(1)*cell%bmat(1,3)+b1(2)*cell%bmat(2,3)+& + b1(3)*cell%bmat(3,3) + DO j = n_rank+1,lapw%nv(jspin),n_size + !--> determine index and phase factor + i1 = lapw%k1(j,jspin) - lapw%k1(i,jspin) + i2 = lapw%k2(j,jspin) - lapw%k2(i,jspin) + i3 = lapw%k3(j,jspin) - lapw%k3(i,jspin) + in = stars%ig(i1,i2,i3) + IF (in.EQ.0) CYCLE + phase = stars%rgphs(i1,i2,i3) + phasust = CMPLX(phase,0.0)*stars%ustep(in) + + DO m = 1,nslibd + DO n = 1,nslibd + DO dir=1,3 + +#if ( !defined(CPP_INVERSION) || defined(CPP_SOC) ) + VALUE=phasust*z(i+addnoco,m)*CONJG(z(j+addnoco,n)) + nablamat(dir,m,n,ikpt) =& + nablamat(dir,m,n,ikpt) -& + VALUE*b2(dir) +#else + VALUE=phasust*CMPLX(z(i+addnoco,m)*z(j+addnoco,n),0.0) + nablamat(dir,m,n,ikpt) =& + nablamat(dir,m,n,ikpt) - & + VALUE*b2(dir) +#endif + ENDDO + ENDDO + ENDDO + + ENDDO + ENDDO + + ENDIF +#endif + ! goto jump no longer needed? + ! if ((.not.wann%l_matrixmmn).and.(.not.wann%l_matrixamn).and. + ! (.not.wann%l_bestproj).and.(.not.wann%l_projmethod).and. + ! (.not.wann%l_mmn0)) goto 3 + + + !------mmn0-matrix + IF(wann%l_mmn0)THEN + addnoco=0 + IF(noco%l_noco.AND.(jspin.EQ.2))THEN + addnoco=lapw%nv(1)+atoms%nlotot + ENDIF + + !-----> interstitial contribution to mmn0-matrix + + CALL wann_mmkb_int(& + cmplx_1,addnoco,addnoco,& + DIMENSION%nvd,stars%mx1,stars%mx2,stars%mx3,& + stars%ng3,lapw%k1(:,jspin),lapw%k2(:,jspin),lapw%k3(:,jspin),& + lapw%nv(jspin),DIMENSION%neigd,DIMENSION%nbasfcn,zMat,nslibd,& + lapw%k1(:,jspin),lapw%k2(:,jspin),lapw%k3(:,jspin),& + lapw%nv(jspin),zMat,nslibd,& + nbnd,& + stars%rgphs,stars%ustep,stars%ig,(/ 0,0,0 /),& + mmn(:,:,ikpt)) + + !---> spherical contribution to mmn0-matrix + + CALL wann_mmk0_sph(& + atoms%llod,noccbd,atoms%nlod,atoms%nat,atoms%ntype,& + atoms%lmaxd,atoms%lmax,lmd,atoms%ntype,atoms%neq,& + atoms%nlo,atoms%llo,acof(1:noccbd,:,:),& + bcof(1:noccbd,:,:),ccof(:,1:noccbd,:,:),& + usdus%ddn(:,:,jspin),usdus%uulon(:,:,jspin),& + usdus%dulon(:,:,jspin),usdus%uloulopn,& + mmn(:,:,ikpt)) + !---> vacuum contribution to mmn0-matrix + + IF (input%film .AND. .NOT.oneD%odi%d1) THEN + + CALL wann_mmk0_vac(& + noco%l_noco,atoms%nlotot,qpt_i,& + cell%z1,vacuum%nmzd,DIMENSION%nv2d,& + stars%mx1,stars%mx2,stars%mx3,& + stars%ng3,vacuum%nvac,stars%ig,vacuum%nmz,vacuum%delz,& + stars%ig2,cell%area,cell%bmat,& + cell%bbmat,enpara%evac0(:,jspin),lapw%bkpt,vz(:,:,jspin2),& + nslibd,jspin,lapw%k1,lapw%k2,lapw%k3,wannierspin,DIMENSION%nvd,& + DIMENSION%nbasfcn,DIMENSION%neigd,zMat,lapw%nv,cell%omtil,& + mmn(:,:,ikpt)) + ELSEIF (oneD%odi%d1) THEN + + CALL wann_mmk0_od_vac(& + DIMENSION, oneD, vacuum, stars, cell,& + noco%l_noco,atoms%nlotot,& + cell%z1,vacuum%nmzxyd,vacuum%nmzd,DIMENSION%nv2d,& + stars%mx1,stars%mx2,stars%mx3,stars%ng2,stars%ng3,& + stars%ig,vacuum%nmzxy,vacuum%nmz,vacuum%delz,stars%ig2,& + oneD%odi%n2d,cell%bbmat,enpara%evac0(1,jspin),lapw%bkpt,oneD%odi%M,& + oneD%odi%mb,vz(:,1,jspin2),oneD%odi,& + nslibd,jspin,lapw%k1,lapw%k2,lapw%k3,wannierspin,DIMENSION%nvd,& + cell%area,DIMENSION%nbasfcn,DIMENSION%neigd,zMat,lapw%nv,& + stars%sk2,stars%phi2,cell%omtil,qpt_i,& + mmn(:,:,ikpt)) + + ENDIF + ENDIF !l_mmn0 + + + !---> overlaps with the trial orbitals + IF (wann%l_projmethod.OR.wann%l_bestproj.OR.wann%l_matrixamn) THEN + l_amn2=.FALSE. + amnchi = cmplx_1!cmplx(1.,0.) + + CALL wann_amn (& + amnchi,nslibd,nwfs,atoms%ntype,atoms%nlod,atoms%llod,& + atoms%llo,atoms%nlo,atoms%lmaxd,atoms%jmtd,lmd,& + atoms%neq,atoms%nat,ikpt,nbnd,& + atoms%rmsh,atoms%rmt,atoms%jri,atoms%dx,atoms%lmax,& + usdus%us(:,:,jspin),usdus%dus(:,:,jspin),& + usdus%uds(:,:,jspin),& + usdus%duds(:,:,jspin),flo(:,:,:,:,jspin),& + ff(:,:,:,:,jspin),gg(:,:,:,:,jspin),acof,bcof,ccof,& + (noco%l_soc.OR.noco%l_noco),jspin,& + l_amn2,amn(:,:,ikpt)) + IF(l_amn2)THEN + CALL wann_amn (& + amnchi,nslibd,nwfs,atoms%ntype,atoms%nlod,atoms%llod,& + atoms%llo,atoms%nlo,atoms%lmaxd,atoms%jmtd,lmd,& + atoms%neq,atoms%nat,ikpt,nbnd,& + atoms%rmsh,atoms%rmt,atoms%jri,atoms%dx,atoms%lmax,& + usdus%us(:,:,jspin),usdus%dus(:,:,jspin),& + usdus%uds(:,:,jspin),& + usdus%duds(:,:,jspin),flo(:,:,:,:,jspin),& + ff(:,:,:,:,jspin),gg(:,:,:,:,jspin),acof,bcof,ccof,& + (noco%l_soc.OR.noco%l_noco),jspin,& + l_amn2,amn(:,:,ikpt),lapw%bkpt) + ENDIF + ! amn(ikpt,:,:)=amn(ikpt,:,:)*conjg(nsfactor) + ENDIF + + + + !**************************************************************** + !... vanderbilt mmn matrix + !*************************************************************** + IF (wann%l_matrixmmn .AND.& + (.NOT.wann%l_skipkov)) THEN ! vanderbilt procedure Mmn matrix + ALLOCATE ( we_b(DIMENSION%neigd) ) + +!!! the cycle by the nearest neighbors (nntot) for each kpoint + + DO ikpt_b = 1,nntot + + IF(pair_to_do(ikpt,ikpt_b).EQ.0)CYCLE !save time by symmetry + kptibz_b=bpt(ikpt_b,ikpt) + IF(wann%l_bzsym) oper_b=mapkoper(kptibz_b) + IF (wann%l_bzsym) kptibz_b=irreduc(kptibz_b) + + + + ! now we need the wavefunctions for k_b kpoint + + ! print*,"something to do" + + + n_start=1 + n_end=DIMENSION%neigd + call lapw_b%init(input,noco,kpts,atoms,sym,kptibz_b,cell,(sym%zrfs.AND.(SUM(ABS(kpts%bk(3,:kpts%nkpt))).LT.1e-9).AND..NOT.noco%l_noco.and.mpi%n_size==1),mpi) + CALL cdn_read(& + eig_id,& + DIMENSION%nvd,input%jspins,mpi%irank,mpi%isize, &!wannierspin instead of DIMENSION%jspd?& + kptibz_b,jspin,DIMENSION%nbasfcn,& + noco%l_ss,noco%l_noco,DIMENSION%neigd,n_start,n_end,& + nbands_b,eigg,zzMat) + + + nslibd_b = 0 + + eig_b(:) = 0. + + DO i = 1,nbands_b + IF((eigg(i).GE.sliceplot%e1s.AND.nslibd_b.LT.numbands& + .AND.wann%l_bynumber).OR.& + (eigg(i).GE.sliceplot%e1s.AND.eigg(i).LE.sliceplot%e2s.AND.& + wann%l_byenergy).OR.(i.GE.wann%band_min(jspin).AND.& + (i.LE.wann%band_max(jspin)).AND.& + wann%l_byindex))THEN + nslibd_b = nslibd_b + 1 + eig_b(nslibd_b) = eigg(i) + we_b(nslibd_b) = we_b(i) + IF (zzMat%l_real) THEN + zMat_b%data_r(:,nslibd_b) = zzMat%data_r(:,i) + ELSE + zMat_b%data_c(:,nslibd_b) = zzMat%data_c(:,i) + END IF + ENDIF + ENDDO + + !*********************************************************** + ! Rotate the wavefunction of next neighbor. + !*********************************************************** + IF (wann%l_bzsym .AND. (oper_b.NE.1) ) THEN + ! call wann_kptsrotate( + ! > atoms%nat,atoms%nlod,atoms%llod, + ! > atoms%ntype,atoms%nlo,atoms%llo,atoms%invsat, + ! > noco%l_noco,noco%l_soc, + ! > atoms%ntype,atoms%neq,atoms%nlotot, + ! > kveclo_b,jspin, + ! > oper_b,sym%nop,sym%mrot,DIMENSION%nvd, + ! > nv_b, + ! > shiftkpt(:,bpt(ikpt_b,ikpt)), + ! > sym%tau, + ! x bkpt_b,k1_b(:,:), + ! x k2_b(:,:),k3_b(:,:), + ! x zMat_b,nsfactor_b) + ELSE + nsfactor_b=CMPLX(1.0,0.0) + ENDIF + ! print*,"kpt2=",bkpt_b + + noccbd_b = nslibd_b + + !cccc we start with the Mmn matrix ccccccccccccc + +!!! matrix elements of the interstitial overlap +!!! matrix with the weights given by products of +!!! the c-coeff. for different G-vectors, bands and k-points +!!! Mmn(k,b)(IR) = \sum(G,G')C_G^(k,n)*C_G'^(k+b,m)\theta_(G-G') + + !ccccccccccc Spherical Contributions ccccccccccccc + + ALLOCATE (acof_b(noccbd_b,0:lmd,atoms%nat),& + bcof_b(noccbd_b,0:lmd,atoms%nat),& + ccof_b(-atoms%llod:atoms%llod,noccbd_b,atoms%nlod,& + atoms%nat)) + +!!! get the band-dependent k-dependent ab coeff. + + CALL abcof(input,atoms,sym,cell,lapw_b,& + noccbd_b,usdus,noco,jspin,oneD,& + acof_b,bcof_b,ccof_b,zMat_b) + + + CALL wann_abinv(atoms,& + acof_b,bcof_b,ccof_b) + + !cccccccc Interstitial ccccccccccccccccccccccccc +!!! matrix elements of the interstitial overlap +!!! matrix with the weights given by products of +!!! the c-coeff. for different G-vectors, bands and k-points +!!! Mmn(k,b)(IR) = \sum(G,G')C_G^(k,n)*C_G'^(k+b,m)\theta_(G-G') + !... these overlaps are the same as in the mmk0 case, only differ + !... by the b-dependence of the C-coefficients + !cccccccccccccccccccccccccccccccccccccccccccccccccccc + + addnoco=0 + addnoco2=0 + IF(noco%l_noco.AND.(jspin.EQ.2))THEN + addnoco = lapw%nv(1) + atoms%nlotot + addnoco2 = lapw_b%nv(1) + atoms%nlotot + ENDIF + + CALL wann_mmkb_int(& + cmplx_1,addnoco,addnoco2,& + DIMENSION%nvd,stars%mx1,stars%mx2,stars%mx3,& + stars%ng3,lapw%k1(:,jspin),lapw%k2(:,jspin),lapw%k3(:,jspin),& + lapw%nv(jspin),DIMENSION%neigd,DIMENSION%nbasfcn,zMat,nslibd,& + lapw_b%k1(:,jspin),lapw_b%k2(:,jspin),lapw_b%k3(:,jspin),& + lapw_b%nv(jspin),zMat_b,nslibd_b,& + nbnd,& + stars%rgphs,stars%ustep,stars%ig,gb(:,ikpt_b,ikpt),& + mmnk(:,:,ikpt_b,ikpt)) + + + + !ccccccccccc Spherical Contributions ccccccccccccc + + chi = cmplx_1 + CALL wann_mmkb_sph(& + nbnd,atoms%llod,nslibd,nslibd_b,atoms%nlod,atoms%nat,& + atoms%ntype,lmd,atoms%jmtd,atoms%taual,sym%nop,atoms%lmax,& + atoms%ntype,atoms%neq,atoms%nlo,atoms%llo,acof,bcof,ccof,& + lapw_b%bkpt,acof_b,bcof_b,ccof_b,gb(:,ikpt_b,ikpt),lapw%bkpt,& + ujug,ujdg,& + djug,djdg,ujulog,djulog,ulojug,ulojdg,ulojulog,kdiff,& + nntot,chi,& + mmnk(:,:,ikpt_b,ikpt)) + + + + + !...vacuum contributions + IF (input%film .AND. .NOT.oneD%odi%d1) THEN + + CALL wann_mmkb_vac(& + cmplx_1,noco%l_noco,atoms%nlotot,qpt_i,& + nbnd,cell%z1,vacuum%nmzd,DIMENSION%nv2d,& + stars%mx1,stars%mx2,stars%mx3,& + stars%ng3,vacuum%nvac,stars%ig,vacuum%nmz,& + vacuum%delz,stars%ig2,cell%area,cell%bmat,& + cell%bbmat,enpara%evac0(:,jspin),& + enpara%evac0(:,jspin_b),& + lapw%bkpt,lapw_b%bkpt,vz(:,:,jspin2),vz(:,:,jspin2_b),& + nslibd,nslibd_b,jspin,jspin_b,& + lapw%k1,lapw%k2,lapw%k3,lapw_b%k1,lapw_b%k2,lapw_b%k3,& + wannierspin,DIMENSION%nvd,& + DIMENSION%nbasfcn,DIMENSION%neigd,zMat,zMat_b,& + lapw%nv,lapw_b%nv,cell%omtil,& + gb(:,ikpt_b,ikpt),& + mmnk(:,:,ikpt_b,ikpt)) + ELSEIF (oneD%odi%d1) THEN + + CALL wann_mmkb_od_vac(& + DIMENSION,oneD,vacuum,stars,cell,& + cmplx_1,noco%l_noco,atoms%nlotot,& + nbnd,cell%z1,vacuum%nmzxyd,vacuum%nmzd,DIMENSION%nv2d,& + stars%mx1,stars%mx2,stars%mx3,stars%ng2,stars%ng3,& + stars%ig,vacuum%nmzxy,& + vacuum%nmz,vacuum%delz,stars%ig2,oneD%odi%n2d,& + cell%bbmat,enpara%evac0(1,jspin),enpara%evac0(1,jspin_b),& + lapw%bkpt,lapw_b%bkpt,oneD%odi%M,oneD%odi%mb,& + vz(:,1,jspin2),vz(:,1,jspin2_b),oneD%odi,& + nslibd,nslibd_b,jspin,jspin_b,lapw%k1,lapw%k2,lapw%k3,lapw_b%k1,lapw_b%k2,lapw_b%k3,& + wannierspin,DIMENSION%nvd,cell%area,DIMENSION%nbasfcn,& + DIMENSION%neigd,& + zMat,zMat_b,lapw%nv,lapw_b%nv,stars%sk2,stars%phi2,cell%omtil,& + gb(:,ikpt_b,ikpt),qpt_i,& + .FALSE.,1,& + mmnk(:,:,ikpt_b,ikpt)) + ENDIF + + ! mmnk(:,:,ikpt_b,ikpt)= + ! mmnk(:,:,ikpt_b,ikpt)*nsfactor*conjg(nsfactor_b) + + + DEALLOCATE ( acof_b,bcof_b,ccof_b ) + + + enddo ! end of loop by the nearest k-neighbors + + DEALLOCATE ( we_b ) + + ENDIF!l_matrixmmn=.true. + +9900 CONTINUE ! jump for doublespin loop + + IF (wann%l_matrixmmn) THEN ! vanderbilt procedure Mmn matrix + + !*******************************************c + ! START Q-NEIGHBOR LOOP c + !*******************************************c + ALLOCATE ( we_qb(DIMENSION%neigd) ) + + DO iqpt_b=1,nntot_q + IF(.NOT.l_gwf) EXIT ! old functionality + + qptibz_b = bpt_q(iqpt_b,iqpt) + IF(qptibz_b.EQ.qptibz) CYCLE ! no need to compute overlaps + ! with periodic images for now + + qptb_i = noco%qss + alphb_i = noco%alph + betab_i = noco%beta + thetab_i = noco%theta + phib_i = noco%phi + IF(wann%l_sgwf) THEN + qptb_i(:) = wann%param_vec(:,qptibz_b) + alphb_i(:) = wann%param_alpha(:,qptibz_b) + ELSEIF(wann%l_socgwf) THEN + IF(wann%l_dim(2)) phib_i = tpi_const*wann%param_vec(2,qptibz_b) + IF(wann%l_dim(3)) thetab_i = tpi_const*wann%param_vec(3,qptibz_b) + ENDIF + + !if(pair_to_do_q(iqpt,iqpt_b).eq.0)cycle ! TODO: use symmetry + IF(wann%l_bzsym) oper_qb=mapqoper(qptibz_b) + IF (wann%l_bzsym) qptibz_b=irreduc_q(qptibz_b) + + n_start=1 + n_end=DIMENSION%neigd + + ! read in diagonalization information from corresponding + ! eig file to q-point iqpt_b at a given k-point ikpt. + ! as a check verify that bkpt.eq.bqpt (same k). + ! moreover, the plane-wave vectors G(k,q+b) are stored + ! in (k1_qb,k2_qb,k3_qb) for later use. + + CALL lapw_qb%init(input,noco,kpts,atoms,sym,kptibz,cell,(sym%zrfs.AND.(SUM(ABS(kpts%bk(3,:kpts%nkpt))).LT.1e-9).AND..NOT.noco%l_noco.and.mpi%n_size==1),mpi) + CALL cdn_read(& + innerEig_idList(iqpt_b),& + DIMENSION%nvd,input%jspins,mpi%irank,mpi%isize, &!wannierspin instead of DIMENSION%jspd? !kptibz_b2?& + kptibz,jspin_b,DIMENSION%nbasfcn,& + noco%l_ss,noco%l_noco,DIMENSION%neigd,n_start,& + n_end,& + nbands_qb,eigg, & + zzMat) + + + ! are we dealing with the same k-point at which + ! we want to construct A,B,C coefficients etc. ? + IF(ANY(bqpt.NE.lapw%bkpt)) CALL juDFT_error("bqpt.ne.bkpt",& + calledby="wannier") + + zMat_qb%l_real = zzMat%l_real + zMat_qb%matsize1 = zzMat%matsize1 + zMat_qb%matsize2 = zzMat%matsize2 + IF (zzMat%l_real) THEN + ALLOCATE (zMat_qb%data_r(zMat%matsize1,zMat%matsize2)) + zMat_qb%data_r = 0.0 + ELSE + ALLOCATE (zMat_qb%data_c(zMat%matsize1,zMat%matsize2)) + zMat_qb%data_c = CMPLX(0.0,0.0) + END IF + + eig_qb(:) = 0. + + nslibd_qb = 0 + DO i = 1,nbands_qb + IF((eigg(i).GE.sliceplot%e1s.AND.nslibd_qb.LT.numbands& + .AND.wann%l_bynumber).OR.& + (eigg(i).GE.sliceplot%e1s.AND.eigg(i).LE.sliceplot%e2s.AND.& + wann%l_byenergy).OR.(i.GE.wann%band_min(jspin).AND.& + (i.LE.wann%band_max(jspin)).AND.wann%l_byindex)) THEN + nslibd_qb = nslibd_qb + 1 + eig_qb(nslibd_qb) = eigg(i) + we_qb(nslibd_qb) = we_qb(i) + IF (zzMat%l_real) THEN + zMat_qb%data_r(:,nslibd_qb) = zzMat%data_r(:,i) + ELSE + zMat_qb%data_c(:,nslibd_qb) = zzMat%data_c(:,i) + END IF + ENDIF + ENDDO + + ! check that eigenvectors and -values are identical if q=q+b + IF(iqpt.EQ.qptibz_b .AND. jspin.EQ.jspin_b) THEN + IF(zMat%l_real) THEN + IF(ANY(zMat%data_r.NE.zMat_qb%data_r)) & + WRITE(*,*)'z.ne.z_qb',iqpt,ikpt + ELSE + IF(ANY(zMat%data_c.NE.zMat_qb%data_c)) & + WRITE(*,*)'z.ne.z_qb',iqpt,ikpt + END IF + IF(ANY(eig.NE.eig_qb)) WRITE(*,*)'eig.ne.eiq_qb',iqpt,ikpt + IF(lapw%nv(jspin).NE.lapw_qb%nv(jspin)) WRITE(*,*)'nv!=nv_qb',iqpt,ikpt + ENDIF + + ! check that number of bands are the same at (k,q) and (k,q+b) + IF(nslibd.NE.nslibd_qb)& + WRITE(*,*)'nslibd.ne.nslibd_qb',ikpt,iqpt,iqpt_b + + + noccbd_qb = nslibd_qb + nsfactor_b=CMPLX(1.0,0.0) + + + ALLOCATE (acof_qb(noccbd_qb,0:lmd,atoms%nat),& + bcof_qb(noccbd_qb,0:lmd,atoms%nat),& + ccof_qb(-atoms%llod:atoms%llod,noccbd_qb,atoms%nlod,& + atoms%nat)) + + acof_qb(:,:,:) = CMPLX(0.,0.) ; bcof_qb(:,:,:) = CMPLX(0.,0.) + ccof_qb(:,:,:,:) = CMPLX(0.,0.) + + ! construct the A,B,C coefficients of the wave function + ! at the point (k,q+b) using previously read information + + CALL abcof(input,atoms,sym,cell,lapw_qb,& + noccbd_qb,usdus,noco,jspin_b,oneD,& + acof_qb,bcof_qb,ccof_qb,zMat_qb) + + CALL wann_abinv(atoms,& + acof_qb,bcof_qb,ccof_qb) + + ! check that A,B,C coefficients are the same if q+b = q + IF(l_gwf.AND.(iqpt.EQ.qptibz_b).AND.(jspin.EQ.jspin_b)) THEN + IF(ANY(acof_qb.NE.acof)) WRITE(*,*)'acof',iqpt,ikpt + IF(ANY(bcof_qb.NE.bcof)) WRITE(*,*)'bcof',iqpt,ikpt + IF(ANY(ccof_qb.NE.ccof)) WRITE(*,*)'ccof',iqpt,ikpt + ENDIF + + addnoco=0 + addnoco2=0 + IF(noco%l_noco.AND.(jspin.EQ.2))THEN + addnoco = lapw%nv(1) + atoms%nlotot + ENDIF + IF(noco%l_noco.AND.(jspin_b.EQ.2))THEN + addnoco2 = lapw_qb%nv(1) + atoms%nlotot + ENDIF + + + ! set up local->global transformation for overlaps + DO n=1,atoms%ntype + IF(wann%l_sgwf) THEN + dalph = alph_i(n)-alphb_i(n) + db1 = beta_i(n)/2. + db2 = betab_i(n)/2. + ELSEIF(wann%l_socgwf) THEN + dalph = phi_i-phib_i + db1 = theta_i/2. + db2 = thetab_i/2. + ENDIF + coph = COS(dalph) + siph = SIN(dalph) + phasfac = CMPLX(coph,siph) + phasfac2= CMPLX(coph,-siph) + + IF(l_p0 .AND. dalph.NE.0.0) THEN + WRITE(*,*)'WARNING: include dalph in chi trafo!' + ENDIF + + IF( (jspin.EQ.1) .AND. (jspin_b.EQ.1) ) THEN ! uu + ! chi(n) = cos(db1)*cos(db2)*phasfac + ! > + sin(db1)*sin(db2)*phasfac2 + chi(n) = COS(db2-db1) + ELSEIF( (jspin.EQ.2) .AND. (jspin_b.EQ.2) ) THEN !dd + ! chi(n) = cos(db1)*cos(db2)*phasfac2 + ! > + sin(db1)*sin(db2)*phasfac + chi(n) = COS(db2-db1) + ELSEIF( (jspin.EQ.1) .AND. (jspin_b.EQ.2) ) THEN ! ud + ! chi(n) = sin(db1)*cos(db2)*phasfac2 + ! > - cos(db1)*sin(db2)*phasfac + chi(n) = -SIN(db2-db1) + ELSEIF( (jspin.EQ.2) .AND. (jspin_b.EQ.1) ) THEN ! du + ! chi(n) = cos(db1)*sin(db2)*phasfac2 + ! > - sin(db1)*cos(db2)*phasfac + chi(n) = SIN(db2-db1) + ELSE + STOP 'problem setting up chi: jspin,jspin_b' + ENDIF + ENDDO + chi = CONJG(chi) + !chi = cmplx_1 + + ! optional: disable chi transformation + ! instead of computing overlap w.r.t. global frame + ! only consider wave function overlaps in local frames + IF(l_nochi) THEN + IF(doublespin.LT.3) THEN + chi = CMPLX(1.0,0.0) + ELSE + chi = CMPLX(0.0,0.0) + ENDIF + ENDIF + + IF((iqpt.EQ.1).AND.(ikpt.EQ.1).AND.(iqpt_b.EQ.1)) THEN + WRITE(*,*)'dbs',doublespin,'chi',chi(1) + ENDIF + + ! muffin tin contribution to overlap is computed taking into account + ! the spin-dependent phase exp(+/- tau*b/2) and the ujugaunt integrals + ! calculated especially for the q-points before. then, q and q+b + ! take the role of k and k+b and the same for G(q+b) and G(k+b) + IF(wann%l_sgwf) CALL wann_mmkb_sph( & + nbnd,atoms%llod,nslibd,nslibd_qb,atoms%nlod,atoms%nat,& + atoms%ntype,lmd,atoms%jmtd,sign_q*atoms%taual/2.0,sym%nop,& + atoms%lmax,atoms%ntype,atoms%neq,atoms%nlo,atoms%llo,& + acof,bcof,ccof,qptb_i,& + acof_qb,bcof_qb,ccof_qb,gb_q(:,iqpt_b,iqpt),qpt_i,& + ujug_q,ujdg_q,& + djug_q,djdg_q,ujulog_q,djulog_q,ulojug_q,ulojdg_q,& + ulojulog_q,qdiff, & + nntot_q,chi,& + mmnk_q(:,:,iqpt_b,ikpt)) + IF(wann%l_socgwf) CALL wann_mmkb_sph( & + nbnd,atoms%llod,nslibd,nslibd_qb,atoms%nlod,atoms%nat,& + atoms%ntype,lmd,atoms%jmtd,& + zero_taual,sym%nop,atoms%lmax, & + atoms%ntype,atoms%neq,atoms%nlo,atoms%llo,acof,bcof,ccof,& + (/ 0.0, phib_i/tpi_const, thetab_i/tpi_const /),& + acof_qb,bcof_qb,ccof_qb,gb_q(:,iqpt_b,iqpt),& + (/ 0.0, phi_i/tpi_const, theta_i/tpi_const /),& + ujug_q,ujdg_q,& + djug_q,djdg_q,ujulog_q,djulog_q,ulojug_q,ulojdg_q,& + ulojulog_q,qdiff, & + nntot_q,chi,& + mmnk_q(:,:,iqpt_b,ikpt)) + + + IF(((doublespin.NE.3).AND.(doublespin.NE.4))& + .OR.(.NOT.noco%l_noco)) THEN + + IF(.NOT.noco%l_noco)THEN + interchi=chi(1) + vacchi=chi(1) + ELSE + interchi=cmplx_1 + vacchi=cmplx_1 + ENDIF + + ! interstitial contribution to overlap is computed using + ! (-/+ 1)*G(q+b)/2 as G-vector connecting neighbors + ! and lattice vectors G(k,q) (k1...) and G(k,q+b) (k1_qb...) + IF(wann%l_sgwf) CALL wann_mmkb_int(& + interchi,addnoco,addnoco2,& + DIMENSION%nvd,stars%mx1,stars%mx2,stars%mx3,& + stars%ng3,lapw%k1(:,jspin),lapw%k2(:,jspin),lapw%k3(:,jspin),& + lapw%nv(jspin),DIMENSION%neigd,DIMENSION%nbasfcn,zMat,nslibd,& + lapw_qb%k1(:,jspin_b),lapw_qb%k2(:,jspin_b),lapw_qb%k3(:,jspin_b),& + lapw_qb%nv(jspin_b),zMat_qb,nslibd_qb,& + nbnd,& + stars%rgphs,stars%ustep,stars%ig,& + sign_q*gb_q(:,iqpt_b,iqpt)/2, & + mmnk_q(:,:,iqpt_b,ikpt)) + IF(wann%l_socgwf) CALL wann_mmkb_int(& + interchi,addnoco,addnoco2,& + DIMENSION%nvd,stars%mx1,stars%mx2,stars%mx3,& + stars%ng3,lapw%k1(:,jspin),lapw%k2(:,jspin),lapw%k3(:,jspin),& + lapw%nv(jspin),DIMENSION%neigd,DIMENSION%nbasfcn,zMat,nslibd,& + lapw_qb%k1(:,jspin_b),lapw_qb%k2(:,jspin_b),lapw_qb%k3(:,jspin_b),& + lapw_qb%nv(jspin_b),zMat_qb,nslibd_qb,& + nbnd,& + stars%rgphs,stars%ustep,stars%ig,(/ 0, 0, 0 /), & + mmnk_q(:,:,iqpt_b,ikpt))!m_int(:,:,iqpt_b,ikpt)) + + + ! vacuum contribution in film calculation + IF (input%film .AND. .NOT.oneD%odi%d1) THEN + IF(wann%l_sgwf) CALL wann_mmkb_vac(& + vacchi,noco%l_noco,atoms%nlotot,sign_q*2.*lapw%bkpt,& + nbnd,cell%z1,vacuum%nmzd,DIMENSION%nv2d,& + stars%mx1,stars%mx2,stars%mx3,& + stars%ng3,vacuum%nvac,stars%ig,vacuum%nmz,& + vacuum%delz,stars%ig2,cell%area,cell%bmat,& + cell%bbmat,enpara%evac0(:,jspin),enpara%evac0(:,jspin_b),& + sign_q*qpt_i/2.,& + sign_q*qptb_i/2.,& + vz(:,:,jspin2),vz(:,:,jspin2_b),& + nslibd,nslibd_qb,jspin,jspin_b,& + lapw%k1,lapw%k2,lapw%k3,lapw_qb%k1,lapw_qb%k2,lapw_qb%k3,& + wannierspin,DIMENSION%nvd,& + DIMENSION%nbasfcn,DIMENSION%neigd,zMat,zMat_qb,lapw%nv,& + lapw_qb%nv,cell%omtil,& + sign_q*gb_q(:,iqpt_b,iqpt)/2,& + mmnk_q(:,:,iqpt_b,ikpt)) + IF(wann%l_socgwf) CALL wann_mmkb_vac(& + vacchi,noco%l_noco,atoms%nlotot,qpt_i,& + nbnd,cell%z1,vacuum%nmzd,DIMENSION%nv2d,& + stars%mx1,stars%mx2,stars%mx3,& + stars%ng3,vacuum%nvac,stars%ig,vacuum%nmz,& + vacuum%delz,stars%ig2,cell%area,cell%bmat,& + cell%bbmat,enpara%evac0(:,jspin),enpara%evac0(:,jspin_b),& + bqpt,bqpt,& + vz(:,:,jspin2),vz(:,:,jspin2_b),& + nslibd,nslibd_qb,jspin,jspin_b,& + lapw%k1,lapw%k2,lapw%k3,lapw_qb%k1,lapw_qb%k2,lapw_qb%k3,& + wannierspin,DIMENSION%nvd,& + DIMENSION%nbasfcn,DIMENSION%neigd,zMat,zMat_qb,lapw%nv,& + lapw_qb%nv,cell%omtil,& + (/ 0, 0, 0 /),& + mmnk_q(:,:,iqpt_b,ikpt)) + + ! vacuum contribution in one-dimensional chain calculation where + ! q-point plays role of k-point with proper prefactor of (-/+ 1/2). + ! moreover, the k-point ikpt is treated like qss in the subroutine + ! such that a correction for sign and factor has to appear as well. + ! lattice vectors G(k,q) (k1...) and G(k,q+b) (k1_qb...) need to + ! be provided. + ELSEIF (oneD%odi%d1) THEN + IF(wann%l_sgwf) CALL wann_mmkb_od_vac(& + DIMENSION,oneD,vacuum,stars,cell,& + vacchi,noco%l_noco,atoms%nlotot, & + nbnd,cell%z1,vacuum%nmzxyd,vacuum%nmzd,DIMENSION%nv2d,& + stars%mx1,stars%mx2,stars%mx3,stars%ng2,stars%ng3,& + stars%ig,vacuum%nmzxy,& + vacuum%nmz,vacuum%delz,stars%ig2,oneD%odi%n2d,& + cell%bbmat,enpara%evac0(1,jspin),enpara%evac0(1,jspin_b),& + sign_q*qpt_i/2.,sign_q*qptb_i/2.,& + oneD%odi%M,oneD%odi%mb,& + vz(:,1,jspin2),vz(:,1,jspin2_b),oneD%odi,& + nslibd,nslibd_qb,jspin,jspin_b,& + lapw%k1,lapw%k2,lapw%k3,lapw_qb%k1,lapw_qb%k2,lapw_qb%k3,& + wannierspin,DIMENSION%nvd,cell%area,DIMENSION%nbasfcn,& + DIMENSION%neigd,zMat,zMat_qb,lapw%nv,lapw_qb%nv,stars%sk2,& + stars%phi2,cell%omtil,& + sign_q*gb_q(:,iqpt_b,iqpt)/2,sign_q*2.*lapw%bkpt, & + .TRUE.,sign_q,& + mmnk_q(:,:,iqpt_b,ikpt)) + IF(wann%l_socgwf) CALL wann_mmkb_od_vac( & + DIMENSION,oneD,vacuum,stars,cell,& + vacchi,noco%l_noco,atoms%nlotot,& + nbnd,cell%z1,vacuum%nmzxyd,vacuum%nmzd,DIMENSION%nv2d,& + stars%mx1,stars%mx2,stars%mx3,stars%ng2,stars%ng3,& + stars%ig,vacuum%nmzxy,& + vacuum%nmz,vacuum%delz,stars%ig2,oneD%odi%n2d,& + cell%bbmat,enpara%evac0(1,jspin),enpara%evac0(1,jspin_b),& + bqpt,bqpt,& + oneD%odi%M,oneD%odi%mb,& + vz(:,1,jspin2),vz(:,1,jspin2_b),oneD%odi,& + nslibd,nslibd_qb,jspin,jspin_b,& + lapw%k1,lapw%k2,lapw%k3,lapw_qb%k1,lapw_qb%k2,lapw_qb%k3,& + wannierspin,DIMENSION%nvd,cell%area,DIMENSION%nbasfcn,& + DIMENSION%neigd,zMat,zMat_qb,lapw%nv,lapw_qb%nv,stars%sk2,& + stars%phi2,cell%omtil,& + (/ 0, 0, 0 /),qpt_i, & + .FALSE.,1,& + mmnk_q(:,:,iqpt_b,ikpt)) + ENDIF!film resp. odi + + + ENDIF!doublespin + + DEALLOCATE ( acof_qb,bcof_qb,ccof_qb ) + + + ENDDO !iqpt_b, q-neighbors + !**************************************************c + ! END Q-NEIGHBOR LOOP c + !**************************************************c + + DEALLOCATE ( we_qb ) + + ENDIF ! if wann%l_matrixmmn = true + + IF(.NOT.wann%l_bzsym)oper=0 + IF(.NOT.wann%l_plot_symm.OR.oper.EQ.1)THEN + IF (wann%l_wann_plot .AND. & + (doublespin.EQ.1 .OR. doublespin.EQ.2)) THEN + + addnoco=0 + IF(noco%l_noco.AND.(jspin.EQ.2))THEN + addnoco=lapw%nv(1)+atoms%nlotot + ENDIF + + IF (sliceplot%slice) THEN + IF (ikpt.EQ.sliceplot%kk) THEN + + WRITE (6,*) 'nnne=',sliceplot%nnne + WRITE (6,*) 'eig(nnne)=',eig(sliceplot%nnne) + WRITE (6,*) 'we(nnne)=',we(sliceplot%nnne) + + CALL wann_plot(& + DIMENSION,oneD,vacuum,stars,cell,atoms,& + DIMENSION%nv2d,jspin,oneD%odi,oneD%ods,stars%ng3,& + vacuum%nmzxyd,& + stars%ng2,sphhar%ntypsd,atoms%ntype,atoms%lmaxd,& + atoms%jmtd,atoms%ntype,atoms%nat,vacuum%nmzd,atoms%neq,& + stars%ng3,vacuum%nvac,vacuum%nmz,vacuum%nmzxy,stars%ng2,& + sym%nop,sym%nop2,cell%volint,input%film,sliceplot%slice,& + sym%symor,sym%invs,sym%invs2,cell%z1,vacuum%delz,& + atoms%ngopr,atoms%ntypsy,atoms%jri,atoms%pos,atoms%zatom,& + atoms%lmax,sym%mrot,sym%tau,atoms%rmsh,sym%invtab,& + cell%amat,cell%bmat,cell%bbmat,ikpt,sliceplot%nnne,& + sliceplot%kk,DIMENSION%nvd,atoms%nlod,atoms%llod,& + lapw%nv(jspin),lmd,lapw%bkpt,cell%omtil,atoms%nlo,atoms%llo,& + lapw%k1(:,jspin),lapw%k2(:,jspin),lapw%k3(:,jspin),enpara%evac0(:,jspin),& + vz(:,:,jspin2),& + nslibd,DIMENSION%nbasfcn,DIMENSION%neigd,& + ff(:,:,:,:,jspin),& + gg(:,:,:,:,jspin),flo,acof,bcof,ccof,zMat,& + stars%mx1,stars%mx2,stars%mx3,stars%ig,stars%ig2,& + stars%sk2,stars%phi2,& + noco%l_noco,noco%l_ss,qpt_i,& + addnoco,get_index_kq(ikpt,iqpt,fullnkpts),wann%l_sgwf) + + ENDIF + ELSE ! not sliceplot%slice + + CALL wann_plot(& + DIMENSION,oneD,vacuum,stars,cell,atoms,& + DIMENSION%nv2d,jspin,oneD%odi,oneD%ods,stars%ng3,& + vacuum%nmzxyd,& + stars%ng2,sphhar%ntypsd,atoms%ntype,atoms%lmaxd,& + atoms%jmtd,atoms%ntype,atoms%nat,vacuum%nmzd,atoms%neq,& + stars%ng3,vacuum%nvac,vacuum%nmz,vacuum%nmzxy,stars%ng2,& + sym%nop,sym%nop2,cell%volint,input%film,sliceplot%slice,& + sym%symor,sym%invs,sym%invs2,cell%z1,vacuum%delz,& + atoms%ngopr,atoms%ntypsy,atoms%jri,atoms%pos,atoms%zatom,& + atoms%lmax,sym%mrot,sym%tau,atoms%rmsh,sym%invtab,& + cell%amat,cell%bmat,cell%bbmat,ikpt,sliceplot%nnne,& + sliceplot%kk,DIMENSION%nvd,atoms%nlod,atoms%llod,& + lapw%nv(jspin),lmd,lapw%bkpt,cell%omtil,atoms%nlo,atoms%llo,& + lapw%k1(:,jspin),lapw%k2(:,jspin),lapw%k3(:,jspin),enpara%evac0(:,jspin),& + vz(:,:,jspin2),& + nslibd,DIMENSION%nbasfcn,DIMENSION%neigd,& + ff(:,:,:,:,jspin),& + gg(:,:,:,:,jspin),flo,acof,bcof,ccof,zMat,& + stars%mx1,stars%mx2,stars%mx3,stars%ig,stars%ig2,& + stars%sk2,stars%phi2,& + noco%l_noco,noco%l_ss,qpt_i,& + addnoco,get_index_kq(ikpt,iqpt,fullnkpts),wann%l_sgwf) + + IF(wann%l_plot_symm.AND.wann%l_bzsym)THEN + DO kplot=1,fullnkpts + IF(irreduc(kplot).EQ.kptibz)THEN + plotoper=mapkoper(kplot) + IF(plotoper.LT.0)THEN + plotoper=-plotoper + l_conjugate=.TRUE. + ELSE + l_conjugate=.FALSE. + ENDIF + kplotoper=sym%invtab(plotoper) + CALL wann_plot_symm(jspin,sym%mrot(:,:,kplotoper),ikpt,& + kplot,l_conjugate) + ENDIF + ENDDO + ENDIF + + ENDIF + ENDIF + ENDIF !wann%l_plot_symm + DEALLOCATE ( acof,bcof,ccof,we,eigg ) + + IF(wann%l_projmethod.OR.wann%l_bestproj)THEN + CALL wann_projmethod(& + fullnkpts,& + wann%l_projmethod,wann%l_bestproj,& + ikpt,nwfs,nslibd,amn,eig,& + psiw,hwfr) + ENDIF ! projmethod + + ENDIF ! loop by processors + + ENDDO ! end of cycle by the k-points + + + IF(wann%l_matrixmmn)& + DEALLOCATE(ujug,ujdg,djug,djdg,& + ujulog,djulog,ulojulog,ulojug,ulojdg) + IF(wann%l_matrixmmn.AND.l_gwf)& + DEALLOCATE(ujug_q,ujdg_q,djug_q,& + djdg_q,ujulog_q,djulog_q,ulojulog_q,ulojug_q,& + ulojdg_q) + +#ifdef CPP_MPI + CALL MPI_BARRIER(mpi%mpi_comm,ierr) +#endif + + + !****************************************************** + ! Write down the projections. + !****************************************************** +5 CONTINUE + + IF(doublespin.EQ.3 .OR. doublespin.EQ.4) GOTO 912 + + IF(wann%l_nabla)THEN + + nablamat=nablamat*hescale + CALL wann_write_nabla(& + mpi%mpi_comm,l_p0,spin12(jspin)//'.nabl',& + 'Matrix elements of nabla operator',& + nbnd,fullnkpts,nbnd,& + mpi%irank,mpi%isize,& + nablamat) + ENDIF + + IF(wann%l_soctomom)THEN + soctomom=soctomom*hescale + CALL wann_write_nabla(& + mpi%mpi_comm,l_p0,spin12(jspin)//'.stm',& + 'Matrix elements of stm operator',& + nbnd,fullnkpts,nbnd,& + mpi%irank,mpi%isize,& + soctomom) + ENDIF + + IF(wann%l_surfcurr)THEN + surfcurr=surfcurr*hescale + CALL wann_write_nabla(& + mpi%mpi_comm,l_p0,spin12(jspin)//'.surfcurr',& + 'Surface currents',& + nbnd,fullnkpts,nbnd,& + mpi%irank,mpi%isize,& + surfcurr) + ENDIF + + IF((noco%l_soc.OR.noco%l_noco).AND.wann%l_mmn0)THEN + CALL wann_write_amn(& + mpi%mpi_comm,& + l_p0,spin12(jspin)//'.socmmn0',& + 'Overlaps of the wavefunct. at the same kpoint',& + nbnd,fullnkpts,nbnd,& + mpi%irank,mpi%isize,.FALSE.,& + mmn,.FALSE.) + ENDIF !noco%l_soc and l_mmn0 + + IF(wann%l_orbcomp)THEN + num_angl=9 + IF(wann%l_oc_f)num_angl=16 + CALL wann_write_matrix5(& + mpi%mpi_comm,l_p0,spin12(jspin)//'.orbcomp',& + 'angular components',& + nbnd,nbnd,& + num_angl,wann%oc_num_orbs,fullnkpts,& + mpi%irank,mpi%isize,& + orbcomp) + ENDIF + + IF((noco%l_soc.OR.noco%l_noco) .AND. (doublespin.EQ.1)) THEN + IF(wann%l_mmn0) socmmn(:,:,:)=mmn(:,:,:) + GOTO 912 + ENDIF + + IF(noco%l_soc.OR.noco%l_noco) THEN + jspin2=1 + IF(wann%l_mmn0) mmn(:,:,:)=socmmn(:,:,:)+mmn(:,:,:) + IF(wann%l_mmn0) DEALLOCATE(socmmn) + ENDIF + + IF (wann%l_matrixamn)THEN + CALL wann_write_amn(& + mpi%mpi_comm,& + l_p0,spin12(jspin2)//'.amn',& + 'Overlaps of the wavefunct. with the trial orbitals',& + nbnd,fullnkpts,nwfs,& + mpi%irank,mpi%isize,.FALSE.,& + amn(:,:,:),wann%l_unformatted) + ENDIF !wann%l_matrixamn + + IF(wann%l_anglmom)THEN + CALL wann_write_matrix4(& + mpi%mpi_comm,& + l_p0,spin12(jspin2)//'.anglmom',& + 'Matrix elements of angular momentum',& + nbnd,nbnd,3,fullnkpts,& + mpi%irank,mpi%isize,& + anglmom) + ENDIF + + IF (l_proj) THEN + !************************************************************** + ! for projmethod: write down WF1.umn + !************************************************************* + IF((wann%l_projmethod.OR.wann%l_bestproj))THEN + CALL wann_write_amn(& + mpi%mpi_comm,l_p0,spin12(jspin2)//'.umn',& + 'transformation to first guess Wannier functions',& + nbnd,fullnkpts,nwfs,& + mpi%irank,mpi%isize,.FALSE.,& + psiw,.FALSE.) +#ifdef CPP_MPI + ALLOCATE( hwfr2(SIZE(hwfr,1),SIZE(hwfr,2)) ) + length=nwfs*nwfs + CALL MPI_REDUCE(& + hwfr,hwfr2,length,& + CPP_MPI_COMPLEX,MPI_SUM,0,& + mpi%mpi_comm,ierr) + hwfr=hwfr2 + DEALLOCATE(hwfr2) +#endif + !******************************************************** + ! projmethod: hamiltonian matrix in real space + !******************************************************** + IF(l_p0)THEN + WRITE (6,*) 'the hamiltonian matrix in real space:' + DO i = 1,nwfs + DO j = 1,nwfs + WRITE (6,*) ' WFs:',i,'and',j + WRITE (6,*) ' matrix element:',hwfr(i,j) + ENDDO + ENDDO + ENDIF !l_p0 + DEALLOCATE(hwfr) + ENDIF !wann%l_projmethod or wann%l_bestproj + ENDIF !l_proj + + !********************************************************* + !.....write down the mmn0 matrix + !********************************************************* + + IF(wann%l_mmn0)THEN + CALL wann_write_amn(& + mpi%mpi_comm,& + l_p0,spin12(jspin2)//'.mmn0',& + 'Overlaps of the wavefunct. at the same kpoint',& + nbnd,fullnkpts,nbnd,& + mpi%irank,mpi%isize,.FALSE.,& + mmn,.FALSE.) + ENDIF !wann%l_mmn0 + + + !***************************************************** + !.....write down the matrix M^{k,b}_{mn} + !***************************************************** + + ! 912 continue + IF(wann%l_matrixmmn.AND.(.NOT.wann%l_skipkov))THEN + CALL wann_write_mmnk(& + mpi%mpi_comm,jspin2,l_p0,fullnkpts,nntot,wann,& + maptopair,pair_to_do,nbnd,bpt,gb,& + mpi%isize,mpi%irank," ",& + mmnk,wann%l_unformatted) + ENDIF !wann%l_matrixmmn + +912 CONTINUE + + IF(l_gwf .AND. wann%l_matrixmmn) THEN + ! mmnk_q = mmnk_q + m_sph+m_int+m_vac + IF(doublespin.EQ.doublespin_max) THEN + WRITE(fname,'("param_",i4.4,".mmn")')iqpt + CALL wann_write_mmnk2(l_p0,fullnkpts,nntot_q,wann,& + nbnd,bpt_q(:,iqpt),gb_q(:,:,iqpt)/2,& + mpi%isize,mpi%irank,fname,mmnk_q,& + wann%l_unformatted) + ENDIF + + IF(.FALSE.) THEN + WRITE(fname,'("param_",i4.4,"_",i1,".mmn")')iqpt,doublespin + CALL wann_write_mmnk2(l_p0,fullnkpts,nntot_q,wann,& + nbnd,bpt_q(:,iqpt),gb_q(:,:,iqpt)/2,& + mpi%isize,mpi%irank,fname,& + m_sph+m_int+m_vac,wann%l_unformatted) + + WRITE(fname,'("param_",i4.4,"_",i1,"_int.mmn")')iqpt,doublespin + CALL wann_write_mmnk2(l_p0,fullnkpts,nntot_q,wann,& + nbnd,bpt_q(:,iqpt),gb_q(:,:,iqpt)/2,& + mpi%isize,mpi%irank,fname,m_int,& + wann%l_unformatted) + WRITE(fname,'("param_",i4.4,"_",i1,"_sph.mmn")')iqpt,doublespin + CALL wann_write_mmnk2(l_p0,fullnkpts,nntot_q,wann,& + nbnd,bpt_q(:,iqpt),gb_q(:,:,iqpt)/2,& + mpi%isize,mpi%irank,fname,m_sph,& + wann%l_unformatted) + WRITE(fname,'("param_",i4.4,"_",i1,"_vac.mmn")')iqpt,doublespin + CALL wann_write_mmnk2(l_p0,fullnkpts,nntot_q,wann,& + nbnd,bpt_q(:,iqpt),gb_q(:,:,iqpt)/2,& + mpi%isize,mpi%irank,fname,m_vac,& + wann%l_unformatted) + ENDIF + ! m_int = cmplx(0.,0.) + ! m_sph = cmplx(0.,0.) + ! m_vac = cmplx(0.,0.) + + ENDIF + + + IF( ALLOCATED (nablamat) ) DEALLOCATE( nablamat ) + IF( ALLOCATED (soctomom) ) DEALLOCATE( soctomom ) + + IF( ALLOCATED (surfcurr) ) DEALLOCATE( surfcurr ) + IF( ALLOCATED( mmn ) ) DEALLOCATE(mmn) + IF( ALLOCATED( amn ) ) THEN + IF(.NOT.(noco%l_soc.OR.noco%l_noco))DEALLOCATE(amn) + ENDIF + IF ( ALLOCATED (psiw) ) DEALLOCATE ( psiw ) + IF (wann%l_matrixmmn) THEN + IF(.NOT.(noco%l_soc.OR.noco%l_noco))DEALLOCATE (mmnk) + ENDIF + IF (wann%l_anglmom .AND. ALLOCATED(anglmom))THEN + IF(.NOT.(noco%l_soc.OR.noco%l_noco))DEALLOCATE (anglmom) + ENDIF + DEALLOCATE(flo) + + IF(.NOT.noco%l_noco)nrec=nrec+nkpts + + !#ifdef CPP_MPI + ! call MPI_BARRIER(mpi%mpi_comm,ierr) + !#endif + + ENDDO ! end of cycle by spins + + +#ifdef CPP_MPI + CALL MPI_BARRIER(mpi%mpi_comm,ierr) +#endif + + ! close eig files + IF (l_gwf) THEN + ! CALL close_eig(eig_id) + IF(wann%l_matrixmmn)THEN + DO iqpt_b=1,nntot_q + ! CALL close_eig(innerEig_idList(iqpt_b)) + ENDDO + ENDIF + ENDIF + + IF (wann%l_matrixmmn.AND.ALLOCATED(mmnk))THEN + DEALLOCATE ( mmnk ) + ENDIF + + IF(ALLOCATED(mmnk_q)) DEALLOCATE(mmnk_q) + IF(ALLOCATED(m_int)) DEALLOCATE(m_int) + IF(ALLOCATED(m_sph)) DEALLOCATE(m_sph) + IF(ALLOCATED(m_vac)) DEALLOCATE(m_vac) + + IF ((wann%l_projmethod.OR.wann%l_bestproj.OR.wann%l_matrixamn)& + .AND.ALLOCATED(amn))THEN + DEALLOCATE ( amn ) + ENDIF + + IF(wann%l_anglmom.AND.ALLOCATED(anglmom))THEN + DEALLOCATE ( anglmom ) + ENDIF + + IF ((wann%l_projmethod.OR.wann%l_bestproj)& + .AND.ALLOCATED(hwfr)) THEN + DEALLOCATE ( hwfr ) + ENDIF + + DEALLOCATE(innerEig_idList) + + ENDDO ! iqpt, q-points + !************************************************c + ! END Q LOOP c + !************************************************c + + IF(ALLOCATED(pair_to_do))DEALLOCATE(pair_to_do,maptopair) + + DEALLOCATE ( vr,vz) + DEALLOCATE ( ff,gg ) + IF (wann%l_bzsym) DEALLOCATE(irreduc,mapkoper) + IF (wann%l_bzsym.AND.l_gwf) DEALLOCATE(irreduc_q,mapqoper) + IF(ALLOCATED(pair_to_do_q))& + DEALLOCATE(pair_to_do_q,maptopair_q) + + IF (ALLOCATED(kdiff)) DEALLOCATE ( kdiff ) + IF (ALLOCATED(qdiff)) DEALLOCATE(qdiff,zero_qdiff) + + +9110 CONTINUE ! jump for l_finishgwf=T + + ! correct for previously introduced factor of 2 in the + ! G-vectors connecting neighbors across the BZ boundary + IF(wann%l_sgwf) gb_q = gb_q/2 + IF(wann%l_socgwf) gb_q = gb_q/2 + + ! set up input files for wannier90 --> HDWFs + IF(l_p0.AND.l_gwf.AND.(wann%l_matrixmmn.OR.wann%l_matrixamn)& + .AND.(.NOT.wann%l_skipkov)) THEN + CALL wann_gwf_commat(fullnkpts,nntot,bpt,fullnqpts,& + nntot_q,bpt_q,gb,gb_q,wann%aux_latt_const,& + wann%l_unformatted,wann%l_matrixamn,& + wann%l_matrixmmn,wann%l_dim,& + wann%nparampts,wann%param_vec/2.0) + ENDIF + + IF(l_p0.AND.l_gwf.AND.wann%l_anglmom) THEN + CALL wann_gwf_anglmom(fullnkpts,fullnqpts,wann%l_unformatted) + ENDIF + + IF (wann%l_matrixmmn) THEN + DEALLOCATE (gb,bpt) + IF(l_gwf) DEALLOCATE (gb_q,bpt_q) + ENDIF + + +1911 CONTINUE + + IF(ALLOCATED(chi)) DEALLOCATE(chi) + + CALL timeStop("Wannier total") + CALL wann_postproc(& + DIMENSION,stars,vacuum,atoms,sphhar,input,kpts,sym,mpi,& + lapw,oneD,noco,cell,vTot,enpara,sliceplot,eig_id,l_real,& !eig_id is used here after closing the files?!& + wann,fullnkpts,l_proj,results%ef,wann%l_sgwf,fullnqpts) + +#ifdef CPP_MPI + CALL MPI_BARRIER(mpi%mpi_comm,ierr) +#endif + + IF(.NOT.wann%l_ldauwan) THEN + DO pc = 1, wann%nparampts + CALL close_eig(eig_idList(pc)) + END DO + + CALL juDFT_end("wannier good",mpi%irank) + END IF + + END SUBROUTINE wannier + + + END MODULE m_wannier